]> git.uio.no Git - u/mrichter/AliRoot.git/blame - TAmpt/AMPT/art1f.f
git://git.uio.no / u / mrichter / AliRoot.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Carlos Perez: Separation of VZERO rings. Adding Pi() to MCTUNED_EP. Bugfix for MinXRo...
[u/mrichter/AliRoot.git] / TAmpt / AMPT / art1f.f
CommitLineData
0119ef9a 1c....................art1f.f
2**************************************
3*
4* PROGRAM ART1.0
5*
6* A relativistic transport (ART) model for heavy-ion collisions
7*
8* sp/01/04/2002
9* calculates K+K- from phi decay, dimuons from phi decay
10* has finite baryon density & possibilites of varying Kaon
11* in-medium mass in phiproduction-annhilation channel only.
12*
13*
14* RELEASING DATE: JAN., 1997
15***************************************
16*
17* Bao-An Li & Che Ming Ko
18* Cyclotron Institute, Texas A&M University.
19* Phone: (409) 845-1411
20* e-mail: Bali@comp.tamu.edu & Ko@comp.tamu.edu
21* http://wwwcyc.tamu.edu/~bali
22***************************************
23* Speical notice on the limitation of the code:
24*
25* (1) ART is a hadronic transport model
26*
27* (2) E_beam/A <= 15 GeV
28*
29* (3) The mass of the colliding system is limited by the dimensions of arrays
30* which can be extended purposely. Presently the dimensions are large enough
31* for running Au+Au at 15 GeV/A.
32*
33* (4) The production and absorption of antiparticles (e.g., ki-, anti-nucleons,
34* etc) are not fully included in this version of the model. They, however,
35* have essentially no effect on the reaction dynamics and observables
36* related to nucleons, pions and kaons (K+) at and below AGS energies.
37*
38* (5) Bose enhancement for mesons and Pauli blocking for fermions are
39* turned off.
40*
41*********************************
42*
43* USEFUL REFERENCES ON PHYSICS AND NUMERICS OF NUCLEAR TRANSPORT MODELS:
44* G.F. BERTSCH AND DAS GUPTA, PHYS. REP. 160 (1988) 189.
45* B.A. LI AND W. BAUER, PHYS. REV. C44 (1991) 450.
46* B.A. LI, W. BAUER AND G.F. BERTSCH, PHYS. REV. C44 (1991) 2095.
47* P. DANIELEWICZ AND G.F. BERTSCH, NUCL. PHYS. A533 (1991) 712.
48*
49* MAIN REFERENCES ON THIS VERSION OF ART MODEL:
50* B.A. LI AND C.M. KO, PHYS. REV. C52 (1995) 2037;
51* NUCL. PHYS. A601 (1996) 457.
52*
53**********************************
54**********************************
55* VARIABLES IN INPUT-SECTION: *
56* *
57* 1) TARGET-RELATED QUANTITIES *
58* MASSTA, ZTA - TARGET MASS IN AMU, TARGET CHARGE (INTEGER) *
59* *
60* 2) PROJECTILE-RELATED QUANTITIES *
61* MASSPR, ZPR - PROJECTILE MASS IN AMU, PROJ. CHARGE(INTEGER) *
62* ELAB - BEAM ENERGY IN [MEV/NUCLEON] (REAL) *
63* ZEROPT - DISPLACEMENT OF THE SYSTEM IN Z-DIREC. [FM](REAL) *
64* B - IMPACT PARAMETER [FM] (REAL) *
65* *
66* 3) PROGRAM-CONTROL PARAMETERS *
67* ISEED - SEED FOR RANDOM NUMBER GENERATOR (INTEGER) *
68* DT - TIME-STEP-SIZE [FM/C] (REAL) *
69* NTMAX - TOTAL NUMBER OF TIMESTEPS (INTEGER) *
70* ICOLL - (= 1 -> MEAN FIELD ONLY, *
71* - =-1 -> CACADE ONLY, ELSE FULL ART) (INTEGER) *
72* NUM - NUMBER OF TESTPARTICLES PER NUCLEON (INTEGER) *
73* INSYS - (=0 -> LAB-SYSTEM, ELSE C.M. SYSTEM) (INTEGER) *
74* IPOT - 1 -> SIGMA=2; 2 -> SIGMA=4/3; 3 -> SIGMA=7/6 *
75* IN MEAN FIELD POTENTIAL (INTEGER) *
76* MODE - (=1 -> interpolation for pauli-blocking, *
77* =2 -> local lookup, other -> unblocked)(integer) *
78* DX,DY,DZ - widths of cell for paulat in coor. sp. [fm](real) *
79* DPX,DPY,DPZ-widths of cell for paulat in mom. sp.[GeV/c](real) *
80* IAVOID - (=1 -> AVOID FIRST COLL. WITHIN SAME NUCL. *
81* =0 -> ALLOW THEM) (INTEGER) *
82* IMOMEN - FLAG FOR CHOICE OF INITIAL MOMENTUM DISTRIBUTION *
83* (=1 -> WOODS-SAXON DENSITY AND LOCAL THOMAS-FERMI *
84* =2 -> NUCLEAR MATTER DEN. AND LOCAL THOMAS-FERMI *
85* =3 -> COHERENT BOOST IN Z-DIRECTION) (INTEGER) *
86* 4) CONTROL-PRINTOUT OPTIONS *
87* NFREQ - NUMBER OF TIMSTEPS AFTER WHICH PRINTOUT *
88* IS REQUIRED OR ON-LINE ANALYSIS IS PERFORMED *
89* ICFLOW =1 PERFORM ON-LINE FLOW ANALYSIS EVERY NFREQ STEPS *
90* ICRHO =1 PRINT OUT THE BARYON,PION AND ENERGY MATRIX IN *
91* THE REACTION PLANE EVERY NFREQ TIME-STEPS *
92* 5)
93* CYCBOX - ne.0 => cyclic boundary conditions;boxsize CYCBOX *
94*
95**********************************
96* Lables of particles used in this code *
97**********************************
98*
99* LB(I) IS USED TO LABEL PARTICLE'S CHARGE STATE
100*
101* LB(I) =
102clin-11/07/00:
103* -30 K*-
104clin-8/29/00
105* -13 anti-N*(+1)(1535),s_11
106* -12 anti-N*0(1535),s_11
107* -11 anti-N*(+1)(1440),p_11
108* -10 anti-N*0(1440), p_11
109* -9 anti-DELTA+2
110* -8 anti-DELTA+1
111* -7 anti-DELTA0
112* -6 anti-DELTA-1
113clin-8/29/00-end
114
115cbali2/7/99
116* -2 antineutron
117* -1 antiproton
118cbali2/7/99 end
119* 0 eta
120* 1 PROTON
121* 2 NUETRON
122* 3 PION-
123* 4 PION0
124* 5 PION+
125* 6 DELTA-1
126* 7 DELTA0
127* 8 DELTA+1
128* 9 DELTA+2
129* 10 N*0(1440), p_11
130* 11 N*(+1)(1440),p_11
131* 12 N*0(1535),s_11
132* 13 N*(+1)(1535),s_11
133* 14 LAMBDA
134* 15 sigma-, since we used isospin averaged xsection for
135* 16 sigma0 sigma associated K+ production, sigma0 and
136* 17 sigma+ sigma+ are counted as sigma-
137* 21 kaon-
138* 23 KAON+
139* 24 kaon0
140* 25 rho-
141* 26 rho0
142* 27 rho+
143* 28 omega meson
144* 29 phi
145clin-11/07/00:
146* 30 K*+
147* sp01/03/01
148* -14 LAMBDA(bar)
149* -15 sigma-(bar)
150* -16 sigma0(bar)
151* -17 sigma+(bar)
152* 31 eta-prime
153* 40 cascade-
154* -40 cascade-(bar)
155* 41 cascade0
156* -41 cascade0(bar)
157* 45 Omega baryon
158* -45 Omega baryon(bar)
159* sp01/03/01 end
160clin-5/2008:
161* 42 Deuteron (same in ampt.dat)
162* -42 anti-Deuteron (same in ampt.dat)
163c
164* ++ ------- SEE BAO-AN LI'S NOTE BOOK
165**********************************
166cbz11/16/98
167c PROGRAM ART
168 SUBROUTINE ARTMN
169cbz11/16/98end
170**********************************
171* PARAMETERS: *
172* MAXPAR - MAXIMUM NUMBER OF PARTICLES PROGRAM CAN HANDLE *
173* MAXP - MAXIMUM NUMBER OF CREATED MESONS PROGRAM CAN HANDLE *
174* MAXR - MAXIMUM NUMBER OF EVENTS AT EACH IMPACT PARAMETER *
175* MAXX - NUMBER OF MESHPOINTS IN X AND Y DIRECTION = 2 MAXX + 1 *
176* MAXZ - NUMBER OF MESHPOINTS IN Z DIRECTION = 2 MAXZ + 1 *
177* AMU - 1 ATOMIC MASS UNIT "GEV/C**2" *
178* MX,MY,MZ - MESH SIZES IN COORDINATE SPACE [FM] FOR PAULI LATTICE *
179* MPX,MPY,MPZ- MESH SIZES IN MOMENTUM SPACE [GEV/C] FOR PAULI LATTICE *
180*---------------------------------------------------------------------- *
181clin PARAMETER (maxpar=200000,MAXR=50,AMU= 0.9383,
182 PARAMETER (MAXSTR=150001,MAXR=1,AMU= 0.9383,
183 1 AKA=0.498,etaM=0.5475)
184 PARAMETER (MAXX = 20, MAXZ = 24)
185 PARAMETER (ISUM = 1001, IGAM = 1100)
186 parameter (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
187clin PARAMETER (MAXP = 14000)
188*----------------------------------------------------------------------*
189 INTEGER OUTPAR, zta,zpr
190 COMMON /AA/ R(3,MAXSTR)
191cc SAVE /AA/
192 COMMON /BB/ P(3,MAXSTR)
193cc SAVE /BB/
194 COMMON /CC/ E(MAXSTR)
195cc SAVE /CC/
196 COMMON /DD/ RHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
197 & RHOP(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
198 & RHON(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
199cc SAVE /DD/
200 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
201cc SAVE /EE/
202 COMMON /HH/ PROPER(MAXSTR)
203cc SAVE /HH/
204 common /ff/f(-mx:mx,-my:my,-mz:mz,-mpx:mpx,-mpy:mpy,-mpz:mpzp)
205cc SAVE /ff/
206 common /gg/ dx,dy,dz,dpx,dpy,dpz
207cc SAVE /gg/
208 COMMON /INPUT/ NSTAR,NDIRCT,DIR
209cc SAVE /INPUT/
210 COMMON /PP/ PRHO(-20:20,-24:24)
211 COMMON /QQ/ PHRHO(-MAXZ:MAXZ,-24:24)
212 COMMON /RR/ MASSR(0:MAXR)
213cc SAVE /RR/
214 common /ss/ inout(20)
215cc SAVE /ss/
216 common /zz/ zta,zpr
217cc SAVE /zz/
218 COMMON /RUN/ NUM
219cc SAVE /RUN/
220clin-4/2008:
221c COMMON /KKK/ TKAON(7),EKAON(7,0:200)
222 COMMON /KKK/ TKAON(7),EKAON(7,0:2000)
223cc SAVE /KKK/
224 COMMON /KAON/ AK(3,50,36),SPECK(50,36,7),MF
225cc SAVE /KAON/
226 COMMON/TABLE/ xarray(0:1000),earray(0:1000)
227cc SAVE /TABLE/
228 common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
229cc SAVE /input1/
230 COMMON /DDpi/ piRHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
231cc SAVE /DDpi/
232 common /tt/ PEL(-maxx:maxx,-maxx:maxx,-maxz:maxz)
233 &,rxy(-maxx:maxx,-maxx:maxx,-maxz:maxz)
234cc SAVE /tt/
235clin-4/2008:
236c DIMENSION TEMP(3,MAXSTR),SKAON(7),SEKAON(7,0:200)
237 DIMENSION TEMP(3,MAXSTR),SKAON(7),SEKAON(7,0:2000)
238cbz12/2/98
239 COMMON /INPUT2/ ILAB, MANYB, NTMAX, ICOLL, INSYS, IPOT, MODE,
240 & IMOMEN, NFREQ, ICFLOW, ICRHO, ICOU, KPOTEN, KMUL
241cc SAVE /INPUT2/
242 COMMON /INPUT3/ PLAB, ELAB, ZEROPT, B0, BI, BM, DENCUT, CYCBOX
243cc SAVE /INPUT3/
244cbz12/2/98end
245cbz11/16/98
246 COMMON /ARPRNT/ ARPAR1(100), IAPAR2(50), ARINT1(100), IAINT2(50)
247cc SAVE /ARPRNT/
248
249c.....note in the below, since a common block in ART is called EE,
250c.....the variable EE in /ARPRC/is changed to PEAR.
251clin-9/29/03 changed name in order to distinguish from /prec2/
252c COMMON /ARPRC/ ITYPAR(MAXSTR),
253c & GXAR(MAXSTR), GYAR(MAXSTR), GZAR(MAXSTR), FTAR(MAXSTR),
254c & PXAR(MAXSTR), PYAR(MAXSTR), PZAR(MAXSTR), PEAR(MAXSTR),
255c & XMAR(MAXSTR)
256cc SAVE /ARPRC/
257clin-9/29/03-end
258 COMMON /ARERCP/PRO1(MAXSTR, MAXR)
259cc SAVE /ARERCP/
260 COMMON /ARERC1/MULTI1(MAXR)
261cc SAVE /ARERC1/
262 COMMON /ARPRC1/ITYP1(MAXSTR, MAXR),
263 & GX1(MAXSTR, MAXR), GY1(MAXSTR, MAXR), GZ1(MAXSTR, MAXR),
264 & FT1(MAXSTR, MAXR),
265 & PX1(MAXSTR, MAXR), PY1(MAXSTR, MAXR), PZ1(MAXSTR, MAXR),
266 & EE1(MAXSTR, MAXR), XM1(MAXSTR, MAXR)
267cc SAVE /ARPRC1/
268c
269 DIMENSION NPI(MAXR)
270 DIMENSION RT(3, MAXSTR, MAXR), PT(3, MAXSTR, MAXR)
271 & , ET(MAXSTR, MAXR), LT(MAXSTR, MAXR), PROT(MAXSTR, MAXR)
272
273 EXTERNAL IARFLV, INVFLV
274cbz11/16/98end
275 common /lastt/itimeh,bimp
276cc SAVE /lastt/
277 common/snn/efrm,npart1,npart2
278cc SAVE /snn/
279 COMMON/hbt/lblast(MAXSTR),xlast(4,MAXSTR),plast(4,MAXSTR),nlast
280cc SAVE /hbt/
281 common/resdcy/NSAV,iksdcy
282cc SAVE /resdcy/
283 COMMON/RNDF77/NSEED
284cc SAVE /RNDF77/
285 COMMON/FTMAX/ftsv(MAXSTR),ftsvt(MAXSTR, MAXR)
286 COMMON /dpert/dpertt(MAXSTR,MAXR),dpertp(MAXSTR),dplast(MAXSTR),
287 1 dpdcy(MAXSTR),dpdpi(MAXSTR,MAXR),dpt(MAXSTR, MAXR),
288 2 dpp1(MAXSTR,MAXR),dppion(MAXSTR,MAXR)
289 COMMON/HPARNT/HIPR1(100),IHPR2(50),HINT1(100),IHNT2(50)
290clin-4/2008 zet() expanded to avoid out-of-bound errors:
291 real zet(-45:45)
292 SAVE
293 data zet /
294 4 1.,0.,0.,0.,0.,
295 3 1.,0.,0.,0.,0.,0.,0.,0.,0.,0.,
296 2 -1.,0.,0.,0.,0.,0.,0.,0.,0.,0.,
297 1 0.,0.,0.,-1.,0.,1.,0.,-1.,0.,-1.,
298 s 0.,-2.,-1.,0.,1.,0.,0.,0.,0.,-1.,
299 e 0.,
300 s 1.,0.,-1.,0.,1.,-1.,0.,1.,2.,0.,
301 1 1.,0.,1.,0.,-1.,0.,1.,0.,0.,0.,
302 2 -1.,0.,1.,0.,-1.,0.,1.,0.,0.,1.,
303 3 0.,0.,0.,0.,0.,0.,0.,0.,0.,-1.,
304 4 0.,0.,0.,0.,-1./
305
306 nlast=0
307 do 1002 i=1,MAXSTR
308 ftsv(i)=0.
309 do 1101 irun=1,maxr
310 ftsvt(i,irun)=0.
311 1101 continue
312 lblast(i)=999
313 do 1001 j=1,4
314clin-4/2008 bugs pointed out by Vander Molen & Westfall:
315c xlast(i,j)=0.
316c plast(i,j)=0.
317 xlast(j,i)=0.
318 plast(j,i)=0.
319 1001 continue
320 1002 continue
321
322*-------------------------------------------------------------------*
323* Input information about the reaction system and contral parameters*
324*-------------------------------------------------------------------*
325* input section starts here *
326*-------------------------------------------------------------------*
327
328cbz12/2/98
329c.....input section is moved to subroutine ARTSET
330cbz12/2/98end
331
332*-----------------------------------------------------------------------*
333* input section ends here *
334*-----------------------------------------------------------------------*
335* read in the table for gengrating the transverse momentum
336* IN THE NN-->DDP PROCESS
337 call tablem
338* several control parameters, keep them fixed in this code.
339 ikaon=1
340 nstar=1
341 ndirct=0
342 dir=0.02
343 asy=0.032
344 ESBIN=0.04
345 MF=36
346*----------------------------------------------------------------------*
347c CALL FRONT(12,MASSTA,MASSPR,ELAB)
348*----------------------------------------------------------------------*
349 RADTA = 1.124 * FLOAT(MASSTA)**(1./3.)
350 RADPR = 1.124 * FLOAT(MASSPR)**(1./3.)
351 ZDIST = RADTA + RADPR
352c if ( cycbox.ne.0 ) zdist=0
353 BMAX = RADTA + RADPR
354 MASS = MASSTA + MASSPR
355 NTOTAL = NUM * MASS
356*
357 IF (NTOTAL .GT. MAXSTR) THEN
358 WRITE(12,'(//10X,''**** FATAL ERROR: TOO MANY TEST PART. ****'//
359 & ' '')')
360 STOP
361 END IF
362*
363*-----------------------------------------------------------------------
364* RELATIVISTIC KINEMATICS
365*
366* 1) LABSYSTEM
367*
368 ETA = FLOAT(MASSTA) * AMU
369 PZTA = 0.0
370 BETATA = 0.0
371 GAMMTA = 1.0
372*
373 EPR = FLOAT(MASSPR) * (AMU + 0.001 * ELAB)
374 PZPR = SQRT( EPR**2 - (AMU * FLOAT(MASSPR))**2 )
375 BETAPR = PZPR / EPR
376 GAMMPR = 1.0 / SQRT( 1.0 - BETAPR**2 )
377*
378* BETAC AND GAMMAC OF THE C.M. OBSERVED IN THE LAB. FRAME
379 BETAC=(PZPR+PZTA)/(EPR+ETA)
380 GAMMC=1.0 / SQRT(1.-BETAC**2)
381*
382c WRITE(12,'(/10x,''**** KINEMATICAL PARAMETERS ****''/)')
383c WRITE(12,'(10x,''1) LAB-FRAME: TARGET PROJECTILE'')')
384c WRITE(12,'(10x,'' ETOTAL "GEV" '',2F11.4)') ETA, EPR
385c WRITE(12,'(10x,'' P "GEV/C" '',2F11.4)') PZTA, PZPR
386c WRITE(12,'(10x,'' BETA '',2F11.4)') BETATA, BETAPR
387c WRITE(12,'(10x,'' GAMMA '',2F11.4)') GAMMTA, GAMMPR
388 IF (INSYS .NE. 0) THEN
389*
390* 2) C.M. SYSTEM
391*
392 S = (EPR+ETA)**2 - PZPR**2
393 xx1=4.*alog(float(massta))
394 xx2=4.*alog(float(masspr))
395 xx1=exp(xx1)
396 xx2=exp(xx2)
397 PSQARE = (S**2 + (xx1+ xx2) * AMU**4
398 & - 2.0 * S * AMU**2 * FLOAT(MASSTA**2 + MASSPR**2)
399 & - 2.0 * FLOAT(MASSTA**2 * MASSPR**2) * AMU**4)
400 & / (4.0 * S)
401*
402 ETA = SQRT ( PSQARE + (FLOAT(MASSTA) * AMU)**2 )
403 PZTA = - SQRT(PSQARE)
404 BETATA = PZTA / ETA
405 GAMMTA = 1.0 / SQRT( 1.0 - BETATA**2 )
406*
407 EPR = SQRT ( PSQARE + (FLOAT(MASSPR) * AMU)**2 )
408 PZPR = SQRT(PSQARE)
409 BETAPR = PZPR/ EPR
410 GAMMPR = 1.0 / SQRT( 1.0 - BETAPR**2 )
411*
412c WRITE(12,'(10x,''2) C.M.-FRAME: '')')
413c WRITE(12,'(10x,'' ETOTAL "GEV" '',2F11.4)') ETA, EPR
414c WRITE(12,'(10x,'' P "GEV/C" '',2F11.4)') PZTA, PZPR
415c WRITE(12,'(10x,'' BETA '',2F11.4)') BETATA, BETAPR
416c WRITE(12,'(10x,'' GAMMA '',2F11.4)') GAMMTA, GAMMPR
417c WRITE(12,'(10x,''S "GEV**2" '',F11.4)') S
418c WRITE(12,'(10x,''PSQARE "GEV/C"2 '',E14.3)') PSQARE
419c WRITE(12,'(/10x,''*** CALCULATION DONE IN CM-FRAME ***''/)')
420 ELSE
421c WRITE(12,'(/10x,''*** CALCULATION DONE IN LAB-FRAME ***''/)')
422 END IF
423* MOMENTUM PER PARTICLE
424 PZTA = PZTA / FLOAT(MASSTA)
425 PZPR = PZPR / FLOAT(MASSPR)
426* total initial energy in the N-N cms frame
427 ECMS0=ETA+EPR
428*-----------------------------------------------------------------------
429*
430* Start loop over many runs of different impact parameters
431* IF MANYB=1, RUN AT A FIXED IMPACT PARAMETER B0, OTHERWISE GENERATE
432* MINIMUM BIAS EVENTS WITHIN THE IMPACT PARAMETER RANGE OF B_MIN AND B_MAX
433 DO 50000 IMANY=1,MANYB
434*------------------------------------------------------------------------
435* Initialize the impact parameter B
436 if (manyb. gt.1) then
437111 BX=1.0-2.0*RANART(NSEED)
438 BY=1.0-2.0*RANART(NSEED)
439 B2=BX*BX+BY*BY
440 IF(B2.GT.1.0) GO TO 111
441 B=SQRT(B2)*(BM-BI)+BI
442 ELSE
443 B=B0
444 ENDIF
445c WRITE(12,'(///10X,''RUN NUMBER:'',I6)') IMANY
446c WRITE(12,'(//10X,''IMPACT PARAMETER B FOR THIS RUN:'',
447c & F9.3,'' FM''/10X,49(''*'')/)') B
448*
449*-----------------------------------------------------------------------
450* INITIALIZATION
451*1 INITIALIZATION IN ISOSPIN SPACE FOR BOTH THE PROJECTILE AND TARGET
452 call coulin(masspr,massta,NUM)
453*2 INITIALIZATION IN PHASE SPACE FOR THE TARGET
454 CALL INIT(1 ,MASSTA ,NUM ,RADTA,
455 & B/2. ,ZEROPT+ZDIST/2. ,PZTA,
456 & GAMMTA ,ISEED ,MASS ,IMOMEN)
457*3.1 INITIALIZATION IN PHASE SPACE FOR THE PROJECTILE
458 CALL INIT(1+MASSTA,MASS ,NUM ,RADPR,
459 & -B/2. ,ZEROPT-ZDIST/2. ,PZPR,
460 & GAMMPR ,ISEED ,MASS ,IMOMEN)
461*3.2 OUTPAR IS THE NO. OF ESCAPED PARTICLES
462 OUTPAR = 0
463*3.3 INITIALIZATION FOR THE NO. OF PARTICLES IN EACH SAMPLE
464* THIS IS NEEDED DUE TO THE FACT THAT PIONS CAN BE PRODUCED OR ABSORBED
465 MASSR(0)=0
466 DO 1003 IR =1,NUM
467 MASSR(IR)=MASS
468 1003 CONTINUE
469*3.4 INITIALIZation FOR THE KAON SPECTRUM
470* CALL KSPEC0(BETAC,GAMMC)
471* calculate the local baryon density matrix
472 CALL DENS(IPOT,MASS,NUM,OUTPAR)
473*
474*-----------------------------------------------------------------------
475* CONTROL PRINTOUT OF INITIAL CONFIGURATION
476*
477* WRITE(12,'(''********** INITIAL CONFIGURATION **********''/)')
478*
479c print out the INITIAL density matrix in the reaction plane
480c do ix=-10,10
481c do iz=-10,10
482c write(1053,992)ix,iz,rho(ix,0,iz)/0.168
483c end do
484c end do
485*-----------------------------------------------------------------------
486* CALCULATE MOMENTA FOR T = 0.5 * DT
487* (TO OBTAIN 2ND DEGREE ACCURACY!)
488* "Reference: J. AICHELIN ET AL., PHYS. REV. C31, 1730 (1985)"
489*
490 IF (ICOLL .NE. -1) THEN
491 DO 700 I = 1,NTOTAL
492 IX = NINT( R(1,I) )
493 IY = NINT( R(2,I) )
494 IZ = NINT( R(3,I) )
495clin-4/2008 check bounds:
496 IF(IX.GE.MAXX.OR.IY.GE.MAXX.OR.IZ.GE.MAXZ
497 1 .OR.IX.LE.-MAXX.OR.IY.LE.-MAXX.OR.IZ.LE.-MAXZ) goto 700
498 CALL GRADU(IPOT,IX,IY,IZ,GRADX,GRADY,GRADZ)
499 P(1,I) = P(1,I) - (0.5 * DT) * GRADX
500 P(2,I) = P(2,I) - (0.5 * DT) * GRADY
501 P(3,I) = P(3,I) - (0.5 * DT) * GRADZ
502 700 CONTINUE
503 END IF
504*-----------------------------------------------------------------------
505*-----------------------------------------------------------------------
506*4 INITIALIZATION OF TIME-LOOP VARIABLES
507*4.1 COLLISION NUMBER COUNTERS
508clin 51 RCNNE = 0
509 RCNNE = 0
510 RDD = 0
511 RPP = 0
512 rppk = 0
513 RPN = 0
514 rpd = 0
515 RKN = 0
516 RNNK = 0
517 RDDK = 0
518 RNDK = 0
519 RCNND = 0
520 RCNDN = 0
521 RCOLL = 0
522 RBLOC = 0
523 RDIRT = 0
524 RDECAY = 0
525 RRES = 0
526*4.11 KAON PRODUCTION PROBABILITY COUNTER FOR PERTURBATIVE CALCULATIONS ONLY
527 DO 1005 KKK=1,5
528 SKAON(KKK) = 0
529 DO 1004 IS=1,2000
530 SEKAON(KKK,IS)=0
531 1004 CONTINUE
532 1005 CONTINUE
533*4.12 anti-proton and anti-kaon counters
534 pr0=0.
535 pr1=0.
536 ska0=0.
537 ska1=0.
538* ============== LOOP OVER ALL TIME STEPS ================ *
539* STARTS HERE *
540* ======================================================== *
541cbz11/16/98
542 IF (IAPAR2(1) .NE. 1) THEN
543 DO 1016 I = 1, MAXSTR
544 DO 1015 J = 1, 3
545 R(J, I) = 0.
546 P(J, I) = 0.
547 1015 CONTINUE
548 E(I) = 0.
549 LB(I) = 0
550cbz3/25/00
551 ID(I)=0
552c sp 12/19/00
553 PROPER(I) = 1.
554 1016 CONTINUE
555 MASS = 0
556cbz12/22/98
557c MASSR(1) = 0
558c NP = 0
559c NPI = 1
560 NP = 0
561 DO 1017 J = 1, NUM
562 MASSR(J) = 0
563 NPI(J) = 1
564 1017 CONTINUE
565 DO 1019 I = 1, MAXR
566 DO 1018 J = 1, MAXSTR
567 RT(1, J, I) = 0.
568 RT(2, J, I) = 0.
569 RT(3, J, I) = 0.
570 PT(1, J, I) = 0.
571 PT(2, J, I) = 0.
572 PT(3, J, I) = 0.
573 ET(J, I) = 0.
574 LT(J, I) = 0
575c sp 12/19/00
576 PROT(J, I) = 1.
577 1018 CONTINUE
578 1019 CONTINUE
579cbz12/22/98end
580 END IF
581cbz11/16/98end
582
583 DO 10000 NT = 1,NTMAX
584
585*TEMPORARY PARTICLE COUNTERS
586*4.2 PION COUNTERS : LP1,LP2 AND LP3 ARE THE NO. OF P+,P0 AND P-
587 LP1=0
588 LP2=0
589 LP3=0
590*4.3 DELTA COUNTERS : LD1,LD2,LD3 AND LD4 ARE THE NO. OF D++,D+,D0 AND D-
591 LD1=0
592 LD2=0
593 LD3=0
594 LD4=0
595*4.4 N*(1440) COUNTERS : LN1 AND LN2 ARE THE NO. OF N*+ AND N*0
596 LN1=0
597 LN2=0
598*4.5 N*(1535) counters
599 LN5=0
600*4.6 ETA COUNTERS
601 LE=0
602*4.7 KAON COUNTERS
603 LKAON=0
604
605clin-11/09/00:
606* KAON* COUNTERS
607 LKAONS=0
608
609*-----------------------------------------------------------------------
610 IF (ICOLL .NE. 1) THEN
611* STUDYING BINARY COLLISIONS AMONG PARTICLES DURING THIS TIME INTERVAL *
612clin-10/25/02 get rid of argument usage mismatch in relcol(.nt.):
613 numnt=nt
614 CALL RELCOL(LCOLL,LBLOC,LCNNE,LDD,LPP,lppk,
615 & LPN,lpd,LRHO,LOMEGA,LKN,LNNK,LDDK,LNDK,LCNND,
616 & LCNDN,LDIRT,LDECAY,LRES,LDOU,LDDRHO,LNNRHO,
617 & LNNOM,numnt,ntmax,sp,akaon,sk)
618c & LNNOM,NT,ntmax,sp,akaon,sk)
619clin-10/25/02-end
620*-----------------------------------------------------------------------
621
622c dilepton production from Dalitz decay
623c of pi0 at final time
624* if(nt .eq. ntmax) call dalitz_pi(nt,ntmax)
625* *
626**********************************
627* Lables of collision channels *
628**********************************
629* LCOLL - NUMBER OF COLLISIONS (INTEGER,OUTPUT) *
630* LBLOC - NUMBER OF PULI-BLOCKED COLLISIONS (INTEGER,OUTPUT) *
631* LCNNE - NUMBER OF ELASTIC COLLISION (INTEGER,OUTPUT) *
632* LCNND - NUMBER OF N+N->N+DELTA REACTION (INTEGER,OUTPUT) *
633* LCNDN - NUMBER OF N+DELTA->N+N REACTION (INTEGER,OUTPUT) *
634* LDD - NUMBER OF RESONANCE+RESONANCE COLLISIONS
635* LPP - NUMBER OF PION+PION elastic COLIISIONS
636* lppk - number of pion(RHO,OMEGA)+pion(RHO,OMEGA)
637* -->K+K- collisions
638* LPN - NUMBER OF PION+N-->KAON+X
639* lpd - number of pion+n-->delta+pion
640* lrho - number of pion+n-->Delta+rho
641* lomega - number of pion+n-->Delta+omega
642* LKN - NUMBER OF KAON RESCATTERINGS
643* LNNK - NUMBER OF bb-->kAON PROCESS
644* LDDK - NUMBER OF DD-->KAON PROCESS
645* LNDK - NUMBER OF ND-->KAON PROCESS
646***********************************
647* TIME-INTEGRATED COLLISIONS NUMBERS OF VARIOUS PROCESSES
648 RCOLL = RCOLL + FLOAT(LCOLL)/num
649 RBLOC = RBLOC + FLOAT(LBLOC)/num
650 RCNNE = RCNNE + FLOAT(LCNNE)/num
651 RDD = RDD + FLOAT(LDD)/num
652 RPP = RPP + FLOAT(LPP)/NUM
653 rppk =rppk + float(lppk)/num
654 RPN = RPN + FLOAT(LPN)/NUM
655 rpd =rpd + float(lpd)/num
656 RKN = RKN + FLOAT(LKN)/NUM
657 RNNK =RNNK + FLOAT(LNNK)/NUM
658 RDDK =RDDK + FLOAT(LDDK)/NUM
659 RNDK =RNDK + FLOAT(LNDK)/NUM
660 RCNND = RCNND + FLOAT(LCNND)/num
661 RCNDN = RCNDN + FLOAT(LCNDN)/num
662 RDIRT = RDIRT + FLOAT(LDIRT)/num
663 RDECAY= RDECAY+ FLOAT(LDECAY)/num
664 RRES = RRES + FLOAT(LRES)/num
665* AVERAGE RATES OF VARIOUS COLLISIONS IN THE CURRENT TIME STEP
666 ADIRT=LDIRT/DT/num
667 ACOLL=(LCOLL-LBLOC)/DT/num
668 ACNND=LCNND/DT/num
669 ACNDN=LCNDN/DT/num
670 ADECAY=LDECAY/DT/num
671 ARES=LRES/DT/num
672 ADOU=LDOU/DT/NUM
673 ADDRHO=LDDRHO/DT/NUM
674 ANNRHO=LNNRHO/DT/NUM
675 ANNOM=LNNOM/DT/NUM
676 ADD=LDD/DT/num
677 APP=LPP/DT/num
678 appk=lppk/dt/num
679 APN=LPN/DT/num
680 apd=lpd/dt/num
681 arh=lrho/dt/num
682 aom=lomega/dt/num
683 AKN=LKN/DT/num
684 ANNK=LNNK/DT/num
685 ADDK=LDDK/DT/num
686 ANDK=LNDK/DT/num
687* PRINT OUT THE VARIOUS COLLISION RATES
688* (1)N-N COLLISIONS
689c WRITE(1010,9991)NT*DT,ACNND,ADOU,ADIRT,ADDRHO,ANNRHO+ANNOM
690c9991 FORMAT(6(E10.3,2X))
691* (2)PION-N COLLISIONS
692c WRITE(1011,'(5(E10.3,2X))')NT*DT,apd,ARH,AOM,APN
693* (3)KAON PRODUCTION CHANNELS
694c WRITE(1012,9993)NT*DT,ANNK,ADDK,ANDK,APN,Appk
695* (4)D(N*)+D(N*) COLLISION
696c WRITE(1013,'(4(E10.3,2X))')NT*DT,ADDK,ADD,ADD+ADDK
697* (5)MESON+MESON
698c WRITE(1014,'(4(E10.3,2X))')NT*DT,APPK,APP,APP+APPK
699* (6)DECAY AND RESONANCE
700c WRITE(1016,'(3(E10.3,2X))')NT*DT,ARES,ADECAY
701* (7)N+D(N*)
702c WRITE(1017,'(4(E10.3,2X))')NT*DT,ACNDN,ANDK,ACNDN+ANDK
703c9992 FORMAT(5(E10.3,2X))
704c9993 FORMAT(6(E10.3,2X))
705* PRINT OUT TIME-INTEGRATED COLLISION INFORMATION
706cbz12/28/98
707c write(1018,'(5(e10.3,2x),/, 4(e10.3,2x))')
708c & RCNNE,RCNND,RCNDN,RDIRT,rpd,
709c & RDECAY,RRES,RDD,RPP
710c write(1018,'(6(e10.3,2x),/, 5(e10.3,2x))')
711c & NT*DT,RCNNE,RCNND,RCNDN,RDIRT,rpd,
712c & NT*DT,RDECAY,RRES,RDD,RPP
713cbz12/18/98end
714* PRINT OUT TIME-INTEGRATED KAON MULTIPLICITIES FROM DIFFERENT CHANNELS
715c WRITE(1019,'(7(E10.3,2X))')NT*DT,RNNK,RDDK,RNDK,RPN,Rppk,
716c & RNNK+RDDK+RNDK+RPN+Rppk
717* *
718
719 END IF
720*
721* UPDATE BARYON DENSITY
722*
723 CALL DENS(IPOT,MASS,NUM,OUTPAR)
724*
725* UPDATE POSITIONS FOR ALL THE PARTICLES PRESENT AT THIS TIME
726*
727 sumene=0
728 ISO=0
729 DO 201 MRUN=1,NUM
730 ISO=ISO+MASSR(MRUN-1)
731 DO 201 I0=1,MASSR(MRUN)
732 I =I0+ISO
733 ETOTAL = SQRT( E(I)**2 + P(1,I)**2 + P(2,I)**2 +P(3,I)**2 )
734 sumene=sumene+etotal
735C for kaons, if there is a potential
736C CALCULATE THE ENERGY OF THE KAON ACCORDING TO THE IMPULSE APPROXIMATION
737C REFERENCE: B.A. LI AND C.M. KO, PHYS. REV. C 54 (1996) 3283.
738 if(kpoten.ne.0.and.lb(i).eq.23)then
739 den=0.
740 IX = NINT( R(1,I) )
741 IY = NINT( R(2,I) )
742 IZ = NINT( R(3,I) )
743clin-4/2008:
744c IF (ABS(IX) .LT. MAXX .AND. ABS(IY) .LT. MAXX .AND.
745c & ABS(IZ) .LT. MAXZ) den=rho(ix,iy,iz)
746 IF(IX.LT.MAXX.AND.IY.LT.MAXX.AND.IZ.LT.MAXZ
747 1 .AND.IX.GT.-MAXX.AND.IY.GT.-MAXX.AND.IZ.GT.-MAXZ)
748 2 den=rho(ix,iy,iz)
749c ecor=0.1973**2*0.255*kmul*4*3.14159*(1.+0.4396/0.938)
750c etotal=sqrt(etotal**2+ecor*den)
751c** G.Q Li potential form with n_s = n_b and pot(n_0)=29 MeV, m^*=m
752c GeV^2 fm^3
753 akg = 0.1727
754c GeV fm^3
755 bkg = 0.333
756 rnsg = den
757 ecor = - akg*rnsg + (bkg*den)**2
758 etotal = sqrt(etotal**2 + ecor)
759 endif
760c
761 if(kpoten.ne.0.and.lb(i).eq.21)then
762 den=0.
763 IX = NINT( R(1,I) )
764 IY = NINT( R(2,I) )
765 IZ = NINT( R(3,I) )
766clin-4/2008:
767c IF (ABS(IX) .LT. MAXX .AND. ABS(IY) .LT. MAXX .AND.
768c & ABS(IZ) .LT. MAXZ) den=rho(ix,iy,iz)
769 IF(IX.LT.MAXX.AND.IY.LT.MAXX.AND.IZ.LT.MAXZ
770 1 .AND.IX.GT.-MAXX.AND.IY.GT.-MAXX.AND.IZ.GT.-MAXZ)
771 2 den=rho(ix,iy,iz)
772c* for song potential no effect on position
773c** G.Q Li potential form with n_s = n_b and pot(n_0)=29 MeV, m^*=m
774c GeV^2 fm^3
775 akg = 0.1727
776c GeV fm^3
777 bkg = 0.333
778 rnsg = den
779 ecor = - akg*rnsg + (bkg*den)**2
780 etotal = sqrt(etotal**2 + ecor)
781 endif
782c
783C UPDATE POSITIONS
784 R(1,I) = R(1,I) + DT*P(1,I)/ETOTAL
785 R(2,I) = R(2,I) + DT*P(2,I)/ETOTAL
786 R(3,I) = R(3,I) + DT*P(3,I)/ETOTAL
787c use cyclic boundary conitions
788 if ( cycbox.ne.0 ) then
789 if ( r(1,i).gt. cycbox/2 ) r(1,i)=r(1,i)-cycbox
790 if ( r(1,i).le.-cycbox/2 ) r(1,i)=r(1,i)+cycbox
791 if ( r(2,i).gt. cycbox/2 ) r(2,i)=r(2,i)-cycbox
792 if ( r(2,i).le.-cycbox/2 ) r(2,i)=r(2,i)+cycbox
793 if ( r(3,i).gt. cycbox/2 ) r(3,i)=r(3,i)-cycbox
794 if ( r(3,i).le.-cycbox/2 ) r(3,i)=r(3,i)+cycbox
795 end if
796* UPDATE THE DELTA, N* AND PION COUNTERS
797 LB1=LB(I)
798* 1. FOR DELTA++
799 IF(LB1.EQ.9)LD1=LD1+1
800* 2. FOR DELTA+
801 IF(LB1.EQ.8)LD2=LD2+1
802* 3. FOR DELTA0
803 IF(LB1.EQ.7)LD3=LD3+1
804* 4. FOR DELTA-
805 IF(LB1.EQ.6)LD4=LD4+1
806* 5. FOR N*+(1440)
807 IF(LB1.EQ.11)LN1=LN1+1
808* 6. FOR N*0(1440)
809 IF(LB1.EQ.10)LN2=LN2+1
810* 6.1 FOR N*(1535)
811 IF((LB1.EQ.13).OR.(LB1.EQ.12))LN5=LN5+1
812* 6.2 FOR ETA
813 IF(LB1.EQ.0)LE=LE+1
814* 6.3 FOR KAONS
815 IF(LB1.EQ.23)LKAON=LKAON+1
816clin-11/09/00: FOR KAON*
817 IF(LB1.EQ.30)LKAONS=LKAONS+1
818
819* UPDATE PION COUNTER
820* 7. FOR PION+
821 IF(LB1.EQ.5)LP1=LP1+1
822* 8. FOR PION0
823 IF(LB1.EQ.4)LP2=LP2+1
824* 9. FOR PION-
825 IF(LB1.EQ.3)LP3=LP3+1
826201 CONTINUE
827 LP=LP1+LP2+LP3
828 LD=LD1+LD2+LD3+LD4
829 LN=LN1+LN2
830 ALP=FLOAT(LP)/FLOAT(NUM)
831 ALD=FLOAT(LD)/FLOAT(NUM)
832 ALN=FLOAT(LN)/FLOAT(NUM)
833 ALN5=FLOAT(LN5)/FLOAT(NUM)
834 ATOTAL=ALP+ALD+ALN+0.5*ALN5
835 ALE=FLOAT(LE)/FLOAT(NUM)
836 ALKAON=FLOAT(LKAON)/FLOAT(NUM)
837* UPDATE MOMENTUM DUE TO COULOMB INTERACTION
838 if (icou .eq. 1) then
839* with Coulomb interaction
840 iso=0
841 do 1026 irun = 1,num
842 iso=iso+massr(irun-1)
843 do 1021 il = 1,massr(irun)
844 temp(1,il) = 0.
845 temp(2,il) = 0.
846 temp(3,il) = 0.
847 1021 continue
848 do 1023 il = 1, massr(irun)
849 i=iso+il
850 if (zet(lb(i)).ne.0) then
851 do 1022 jl = 1,il-1
852 j=iso+jl
853 if (zet(lb(j)).ne.0) then
854 ddx=r(1,i)-r(1,j)
855 ddy=r(2,i)-r(2,j)
856 ddz=r(3,i)-r(3,j)
857 rdiff = sqrt(ddx**2+ddy**2+ddz**2)
858 if (rdiff .le. 1.) rdiff = 1.
859 grp=zet(lb(i))*zet(lb(j))/rdiff**3
860 ddx=ddx*grp
861 ddy=ddy*grp
862 ddz=ddz*grp
863 temp(1,il)=temp(1,il)+ddx
864 temp(2,il)=temp(2,il)+ddy
865 temp(3,il)=temp(3,il)+ddz
866 temp(1,jl)=temp(1,jl)-ddx
867 temp(2,jl)=temp(2,jl)-ddy
868 temp(3,jl)=temp(3,jl)-ddz
869 end if
870 1022 continue
871 end if
872 1023 continue
873 do 1025 il = 1,massr(irun)
874 i= iso+il
875 if (zet(lb(i)).ne.0) then
876 do 1024 idir = 1,3
877 p(idir,i) = p(idir,i) + temp(idir,il)
878 & * dt * 0.00144
879 1024 continue
880 end if
881 1025 continue
882 1026 continue
883 end if
884* In the following, we shall:
885* (1) UPDATE MOMENTA DUE TO THE MEAN FIELD FOR BARYONS AND KAONS,
886* (2) calculate the thermalization, temperature in a sphere of
887* radius 2.0 fm AROUND THE CM
888* (3) AND CALCULATE THE NUMBER OF PARTICLES IN THE HIGH DENSITY REGION
889 spt=0
890 spz=0
891 ncen=0
892 ekin=0
893 NLOST = 0
894 MEAN=0
895 nquark=0
896 nbaryn=0
897csp06/18/01
898 rads = 2.
899 zras = 0.1
900 denst = 0.
901 edenst = 0.
902csp06/18/01 end
903 DO 6000 IRUN = 1,NUM
904 MEAN=MEAN+MASSR(IRUN-1)
905 DO 5800 J = 1,MASSR(irun)
906 I=J+MEAN
907c
908csp06/18/01
909 radut = sqrt(r(1,i)**2+r(2,i)**2)
910 if( radut .le. rads )then
911 if( abs(r(3,i)) .le. zras*nt*dt )then
912c vols = 3.14159*radut**2*abs(r(3,i)) ! cylinder pi*r^2*l
913c cylinder pi*r^2*l
914 vols = 3.14159*rads**2*zras
915 engs=sqrt(p(1,i)**2+p(2,i)**2+p(3,i)**2+e(i)**2)
916 gammas=1.
917 if(e(i).ne.0.)gammas=engs/e(i)
918c rho
919 denst = denst + 1./gammas/vols
920c energy density
921 edenst = edenst + engs/gammas/gammas/vols
922 endif
923 endif
924csp06/18/01 end
925c
926 drr=sqrt(r(1,i)**2+r(2,i)**2+r(3,i)**2)
927 if(drr.le.2.0)then
928 spt=spt+p(1,i)**2+p(2,i)**2
929 spz=spz+p(3,i)**2
930 ncen=ncen+1
931 ekin=ekin+sqrt(p(1,i)**2+p(2,i)**2+p(3,i)**2+e(i)**2)-e(i)
932 endif
933 IX = NINT( R(1,I) )
934 IY = NINT( R(2,I) )
935 IZ = NINT( R(3,I) )
936C calculate the No. of particles in the high density region
937clin-4/2008:
938c IF (ABS(IX) .LT. MAXX .AND. ABS(IY) .LT. MAXX .AND.
939c & ABS(IZ) .LT. MAXZ) THEN
940 IF(IX.LT.MAXX.AND.IY.LT.MAXX.AND.IZ.LT.MAXZ
941 1 .AND.IX.GT.-MAXX.AND.IY.GT.-MAXX.AND.IZ.GT.-MAXZ) THEN
942 if(rho(ix,iy,iz)/0.168.gt.dencut)go to 5800
943 if((rho(ix,iy,iz)/0.168.gt.5.).and.(e(i).gt.0.9))
944 & nbaryn=nbaryn+1
945 if(pel(ix,iy,iz).gt.2.0)nquark=nquark+1
946 endif
947c*
948c If there is a kaon potential, propogating kaons
949 if(kpoten.ne.0.and.lb(i).eq.23)then
950 den=0.
951clin-4/2008:
952c IF (ABS(IX) .LT. MAXX .AND. ABS(IY) .LT. MAXX .AND.
953c & ABS(IZ) .LT. MAXZ)then
954 IF(IX.LT.MAXX.AND.IY.LT.MAXX.AND.IZ.LT.MAXZ
955 1 .AND.IX.GT.-MAXX.AND.IY.GT.-MAXX.AND.IZ.GT.-MAXZ) THEN
956 den=rho(ix,iy,iz)
957c ecor=0.1973**2*0.255*kmul*4*3.14159*(1.+0.4396/0.938)
958c etotal=sqrt(P(1,i)**2+p(2,I)**2+p(3,i)**2+e(i)**2+ecor*den)
959c** for G.Q Li potential form with n_s = n_b and pot(n_0)=29 MeV
960c !! GeV^2 fm^3
961 akg = 0.1727
962c !! GeV fm^3
963 bkg = 0.333
964 rnsg = den
965 ecor = - akg*rnsg + (bkg*den)**2
966 etotal = sqrt(P(1,i)**2+p(2,I)**2+p(3,i)**2+e(i)**2 + ecor)
967 ecor = - akg + 2.*bkg**2*den + 2.*bkg*etotal
968c** G.Q. Li potential (END)
969 CALL GRADUK(IX,IY,IZ,GRADXk,GRADYk,GRADZk)
970 P(1,I) = P(1,I) - DT * GRADXk*ecor/(2.*etotal)
971 P(2,I) = P(2,I) - DT * GRADYk*ecor/(2.*etotal)
972 P(3,I) = P(3,I) - DT * GRADZk*ecor/(2.*etotal)
973 endif
974 endif
975c
976 if(kpoten.ne.0.and.lb(i).eq.21)then
977 den=0.
978clin-4/2008:
979c IF (ABS(IX) .LT. MAXX .AND. ABS(IY) .LT. MAXX .AND.
980c & ABS(IZ) .LT. MAXZ)then
981 IF(IX.LT.MAXX.AND.IY.LT.MAXX.AND.IZ.LT.MAXZ
982 1 .AND.IX.GT.-MAXX.AND.IY.GT.-MAXX.AND.IZ.GT.-MAXZ) THEN
983 den=rho(ix,iy,iz)
984 CALL GRADUK(IX,IY,IZ,GRADXk,GRADYk,GRADZk)
985c P(1,I) = P(1,I) - DT * GRADXk*(-0.12/0.168) !! song potential
986c P(2,I) = P(2,I) - DT * GRADYk*(-0.12/0.168)
987c P(3,I) = P(3,I) - DT * GRADZk*(-0.12/0.168)
988c** for G.Q Li potential form with n_s = n_b and pot(n_0)=29 MeV
989c !! GeV^2 fm^3
990 akg = 0.1727
991c !! GeV fm^3
992 bkg = 0.333
993 rnsg = den
994 ecor = - akg*rnsg + (bkg*den)**2
995 etotal = sqrt(P(1,i)**2+p(2,I)**2+p(3,i)**2+e(i)**2 + ecor)
996 ecor = - akg + 2.*bkg**2*den - 2.*bkg*etotal
997 P(1,I) = P(1,I) - DT * GRADXk*ecor/(2.*etotal)
998 P(2,I) = P(2,I) - DT * GRADYk*ecor/(2.*etotal)
999 P(3,I) = P(3,I) - DT * GRADZk*ecor/(2.*etotal)
1000c** G.Q. Li potential (END)
1001 endif
1002 endif
1003c
1004c for other mesons, there is no potential
1005 if(j.gt.mass)go to 5800
1006c with mean field interaction for baryons (open endif below) !!sp05
1007** if( (iabs(lb(i)).eq.1.or.iabs(lb(i)).eq.2) .or.
1008** & (iabs(lb(i)).ge.6.and.iabs(lb(i)).le.17) .or.
1009** & iabs(lb(i)).eq.40.or.iabs(lb(i)).eq.41 )then
1010 IF (ICOLL .NE. -1) THEN
1011* check if the baryon has run off the lattice
1012* IX0=NINT(R(1,I)/DX)
1013* IY0=NINT(R(2,I)/DY)
1014* IZ0=NINT(R(3,I)/DZ)
1015* IPX0=NINT(P(1,I)/DPX)
1016* IPY0=NINT(P(2,I)/DPY)
1017* IPZ0=NINT(P(3,I)/DPZ)
1018* if ( (abs(ix0).gt.mx) .or. (abs(iy0).gt.my) .or. (abs(iz0).gt.mz)
1019* & .or. (abs(ipx0).gt.mpx) .or. (abs(ipy0)
1020* & .or. (ipz0.lt.-mpz) .or. (ipz0.gt.mpzp)) NLOST=NLOST+1
1021clin-4/2008:
1022c IF (ABS(IX) .LT. MAXX .AND. ABS(IY) .LT. MAXX .AND.
1023c & ABS(IZ) .LT. MAXZ ) THEN
1024 IF(IX.LT.MAXX.AND.IY.LT.MAXX.AND.IZ.LT.MAXZ
1025 1 .AND.IX.GT.-MAXX.AND.IY.GT.-MAXX.AND.IZ.GT.-MAXZ) THEN
1026 CALL GRADU(IPOT,IX,IY,IZ,GRADX,GRADY,GRADZ)
1027 TZ=0.
1028 GRADXN=0
1029 GRADYN=0
1030 GRADZN=0
1031 GRADXP=0
1032 GRADYP=0
1033 GRADZP=0
1034 IF(ICOU.EQ.1)THEN
1035 CALL GRADUP(IX,IY,IZ,GRADXP,GRADYP,GRADZP)
1036 CALL GRADUN(IX,IY,IZ,GRADXN,GRADYN,GRADZN)
1037 IF(ZET(LB(I)).NE.0)TZ=-1
1038 IF(ZET(LB(I)).EQ.0)TZ= 1
1039 END IF
1040 if(iabs(lb(i)).ge.14.and.iabs(lb(i)).le.17)then
1041 facl = 2./3.
1042 elseif(iabs(lb(i)).eq.40.or.iabs(lb(i)).eq.41)then
1043 facl = 1./3.
1044 else
1045 facl = 1.
1046 endif
1047 P(1,I) = P(1,I) - facl*DT * (GRADX+asy*(GRADXN-GRADXP)*TZ)
1048 P(2,I) = P(2,I) - facl*DT * (GRADY+asy*(GRADYN-GRADYP)*TZ)
1049 P(3,I) = P(3,I) - facl*DT * (GRADZ+asy*(GRADZN-GRADZP)*TZ)
1050 end if
1051 ENDIF
1052** endif !!sp05
1053 5800 CONTINUE
1054 6000 CONTINUE
1055c print out the average no. of particles in regions where the local
1056c baryon density is higher than 5*rho0
1057c write(1072,'(e10.3,2x,e10.3)')nt*dt,float(nbaryn)/float(num)
1058C print out the average no. of particles in regions where the local
1059c energy density is higher than 2 GeV/fm^3.
1060c write(1073,'(e10.3,2x,e10.3)')nt*dt,float(nquark)/float(num)
1061c print out the no. of particles that have run off the lattice
1062* IF (NLOST .NE. 0 .AND. (NT/NFREQ)*NFREQ .EQ. NT) THEN
1063* WRITE(12,'(5X,''***'',I7,'' TESTPARTICLES LOST AFTER '',
1064* & ''TIME STEP NUMBER'',I4)') NLOST, NT
1065* END IF
1066*
1067* update phase space density
1068* call platin(mode,mass,num,dx,dy,dz,dpx,dpy,dpz,fnorm)
1069*
1070* CONTROL-PRINTOUT OF CONFIGURATION (IF REQUIRED)
1071*
1072* if (inout(5) .eq. 2) CALL ENERGY(NT,IPOT,NUM,MASS,EMIN,EMAX)
1073*
1074*
1075* print out central baryon density as a function of time
1076 CDEN=RHO(0,0,0)/0.168
1077cc WRITE(1002,990)FLOAT(NT)*DT,CDEN
1078c WRITE(1002,1990)FLOAT(NT)*DT,CDEN,denst/real(num)
1079* print out the central energy density as a function of time
1080cc WRITE(1003,990)FLOAT(NT)*DT,PEL(0,0,0)
1081c WRITE(1003,1990)FLOAT(NT)*DT,PEL(0,0,0),edenst/real(num)
1082* print out the no. of pion-like particles as a function of time
1083c WRITE(1004,9999)FLOAT(NT)*DT,ALD,ALN,ALP,ALN5,
1084c & ALD+ALN+ALP+0.5*ALN5
1085* print out the no. of eta-like particles as a function of time
1086c WRITE(1005,991)FLOAT(NT)*DT,ALN5,ALE,ALE+0.5*ALN5
1087c990 FORMAT(E10.3,2X,E10.3)
1088c1990 FORMAT(E10.3,2X,E10.3,2X,E10.3)
1089c991 FORMAT(E10.3,2X,E10.3,2X,E10.3,2X,E10.3)
1090c9999 FORMAT(e10.3,2X,e10.3,2X,E10.3,2X,E10.3,2X,
1091c 1 E10.3,2X,E10.3)
1092C THE FOLLOWING OUTPUTS CAN BE TURNED ON/OFF by setting icflow and icrho=0
1093c print out the baryon and meson density matrix in the reaction plane
1094 IF ((NT/NFREQ)*NFREQ .EQ. NT ) THEN
1095 if(icflow.eq.1)call flow(nt)
1096cbz11/18/98
1097c if(icrho.ne.1)go to 10000
1098c if (icrho .eq. 1) then
1099cbz11/18/98end
1100c do ix=-10,10
1101c do iz=-10,10
1102c write(1053,992)ix,iz,rho(ix,0,iz)/0.168
1103c write(1054,992)ix,iz,pirho(ix,0,iz)/0.168
1104c write(1055,992)ix,iz,pel(ix,0,iz)
1105c end do
1106c end do
1107cbz11/18/98
1108c end if
1109cbz11/18/98end
1110c992 format(i3,i3,e11.4)
1111 endif
1112c print out the ENERGY density matrix in the reaction plane
1113C CHECK LOCAL MOMENTUM EQUILIBRIUM IN EACH CELL,
1114C AND PERFORM ON-LINE FLOW ANALYSIS AT A FREQUENCY OF NFREQ
1115c IF ((NT/NFREQ)*NFREQ .EQ. NT ) THEN
1116c call flow(nt)
1117c call equ(ipot,mass,num,outpar)
1118c do ix=-10,10
1119c do iz=-10,10
1120c write(1055,992)ix,iz,pel(ix,0,iz)
1121c write(1056,992)ix,iz,rxy(ix,0,iz)
1122c end do
1123c end do
1124c endif
1125C calculate the volume of high BARYON AND ENERGY density
1126C matter as a function of time
1127c vbrho=0.
1128c verho=0.
1129c do ix=-20,20
1130c do iy=-20,20
1131c do iz=-20,20
1132c if(rho(ix,iy,iz)/0.168.gt.5.)vbrho=vbrho+1.
1133c if(pel(ix,iy,iz).gt.2.)verho=verho+1.
1134c end do
1135c end do
1136c end do
1137c write(1081,993)dt*nt,vbrho
1138c write(1082,993)dt*nt,verho
1139c993 format(e11.4,2x,e11.4)
1140*-----------------------------------------------------------------------
1141cbz11/16/98
1142c.....for read-in initial conditions produce particles from read-in
1143c.....common block.
1144c.....note that this part is only for cascade with number of test particles
1145c.....NUM = 1.
1146 IF (IAPAR2(1) .NE. 1) THEN
1147 CT = NT * DT
1148cbz12/22/98
1149c NP = MASSR(1)
1150c DO WHILE (FTAR(NPI) .GT. CT - DT .AND. FTAR(NPI) .LE. CT)
1151c NP = NP + 1
1152c R(1, NP) = GXAR(NPI) + PXAR(NPI) / PEAR(NPI) * (CT - FTAR(NPI))
1153c R(2, NP) = GYAR(NPI) + PYAR(NPI) / PEAR(NPI) * (CT - FTAR(NPI))
1154c R(3, NP) = GZAR(NPI) + PZAR(NPI) / PEAR(NPI) * (CT - FTAR(NPI))
1155c P(1, NP) = PXAR(NPI)
1156c P(2, NP) = PYAR(NPI)
1157c P(3, NP) = PZAR(NPI)
1158c E(NP) = XMAR(NPI)
1159c LB(NP) = IARFLV(ITYPAR(NPI))
1160c NPI = NPI + 1
1161c END DO
1162c MASSR(1) = NP
1163 IA = 0
1164 DO 1028 IRUN = 1, NUM
1165 DO 1027 IC = 1, MASSR(IRUN)
1166 IE = IA + IC
1167 RT(1, IC, IRUN) = R(1, IE)
1168 RT(2, IC, IRUN) = R(2, IE)
1169 RT(3, IC, IRUN) = R(3, IE)
1170 PT(1, IC, IRUN) = P(1, IE)
1171 PT(2, IC, IRUN) = P(2, IE)
1172 PT(3, IC, IRUN) = P(3, IE)
1173 ET(IC, IRUN) = E(IE)
1174 LT(IC, IRUN) = LB(IE)
1175c !! sp 12/19/00
1176 PROT(IC, IRUN) = PROPER(IE)
1177clin-5/2008:
1178 dpertt(IC, IRUN)=dpertp(IE)
1179 1027 CONTINUE
1180 NP = MASSR(IRUN)
1181 NP1 = NPI(IRUN)
1182
1183cbz10/05/99
1184c DO WHILE (FT1(NP1, IRUN) .GT. CT - DT .AND.
1185c & FT1(NP1, IRUN) .LE. CT)
1186cbz10/06/99
1187c DO WHILE (NPI(IRUN).LE.MULTI1(IRUN).AND.
1188cbz10/06/99 end
1189clin-11/13/00 finally read in all unformed particles and do the decays in ART:
1190c DO WHILE (NP1.LE.MULTI1(IRUN).AND.
1191c & FT1(NP1, IRUN) .GT. CT - DT .AND.
1192c & FT1(NP1, IRUN) .LE. CT)
1193c
1194 ctlong = ct
1195 if(nt .eq. (ntmax-1))then
1196 ctlong = 1.E30
1197 elseif(nt .eq. ntmax)then
1198 go to 1111
1199 endif
1200 DO WHILE (NP1.LE.MULTI1(IRUN).AND.
1201 & FT1(NP1, IRUN) .GT. (CT - DT) .AND.
1202 & FT1(NP1, IRUN) .LE. ctlong)
1203 NP = NP + 1
1204 UDT = (CT - FT1(NP1, IRUN)) / EE1(NP1, IRUN)
1205clin-10/28/03 since all unformed hadrons at time ct are read in at nt=ntmax-1,
1206c their positions should not be propagated to time ct:
1207 if(nt.eq.(ntmax-1)) then
1208 ftsvt(NP,IRUN)=FT1(NP1, IRUN)
1209 if(FT1(NP1, IRUN).gt.ct) UDT=0.
1210 endif
1211 RT(1, NP, IRUN) = GX1(NP1, IRUN) +
1212 & PX1(NP1, IRUN) * UDT
1213 RT(2, NP, IRUN) = GY1(NP1, IRUN) +
1214 & PY1(NP1, IRUN) * UDT
1215 RT(3, NP, IRUN) = GZ1(NP1, IRUN) +
1216 & PZ1(NP1, IRUN) * UDT
1217 PT(1, NP, IRUN) = PX1(NP1, IRUN)
1218 PT(2, NP, IRUN) = PY1(NP1, IRUN)
1219 PT(3, NP, IRUN) = PZ1(NP1, IRUN)
1220 ET(NP, IRUN) = XM1(NP1, IRUN)
1221 LT(NP, IRUN) = IARFLV(ITYP1(NP1, IRUN))
1222clin-5/2008:
1223 dpertt(NP,IRUN)=dpp1(NP1,IRUN)
1224clin-4/30/03 ctest off
1225c record initial phi,K*,Lambda(1520) resonances formed during the timestep:
1226c if(LT(NP, IRUN).eq.29.or.iabs(LT(NP, IRUN)).eq.30)
1227c 1 write(17,112) 'formed',LT(NP, IRUN),PX1(NP1, IRUN),
1228c 2 PY1(NP1, IRUN),PZ1(NP1, IRUN),XM1(NP1, IRUN),nt
1229c 112 format(a10,1x,I4,4(1x,f9.3),1x,I4)
1230c
1231 NP1 = NP1 + 1
1232c !! sp 12/19/00
1233 PROT(NP, IRUN) = 1.
1234 END DO
1235*
1236 1111 continue
1237 NPI(IRUN) = NP1
1238 IA = IA + MASSR(IRUN)
1239 MASSR(IRUN) = NP
1240 1028 CONTINUE
1241 IA = 0
1242 DO 1030 IRUN = 1, NUM
1243 IA = IA + MASSR(IRUN - 1)
1244 DO 1029 IC = 1, MASSR(IRUN)
1245 IE = IA + IC
1246 R(1, IE) = RT(1, IC, IRUN)
1247 R(2, IE) = RT(2, IC, IRUN)
1248 R(3, IE) = RT(3, IC, IRUN)
1249 P(1, IE) = PT(1, IC, IRUN)
1250 P(2, IE) = PT(2, IC, IRUN)
1251 P(3, IE) = PT(3, IC, IRUN)
1252 E(IE) = ET(IC, IRUN)
1253 LB(IE) = LT(IC, IRUN)
1254c !! sp 12/19/00
1255 PROPER(IE) = PROT(IC, IRUN)
1256 if(nt.eq.(ntmax-1)) ftsv(IE)=ftsvt(IC,IRUN)
1257clin-5/2008:
1258 dpertp(IE)=dpertt(IC, IRUN)
1259 1029 CONTINUE
1260clin-3/2009 Moved here to better take care of freezeout spacetime:
1261 call hbtout(MASSR(IRUN),nt,ntmax)
1262 1030 CONTINUE
1263cbz12/22/98end
1264 END IF
1265cbz11/16/98end
1266
1267clin-5/2009 ctest off:
1268c call flowh(ct)
1269
127010000 continue
1271
1272* *
1273* ============== END OF TIME STEP LOOP ================ *
1274
1275************************************
1276* WRITE OUT particle's MOMENTA ,and/OR COORDINATES ,
1277* label and/or their local baryon density in the final state
1278 iss=0
1279 do 1032 lrun=1,num
1280 iss=iss+massr(lrun-1)
1281 do 1031 l0=1,massr(lrun)
1282 ipart=iss+l0
1283 1031 continue
1284 1032 continue
1285
1286cbz11/16/98
1287 IF (IAPAR2(1) .NE. 1) THEN
1288cbz12/22/98
1289c NSH = MASSR(1) - NPI + 1
1290c IAINT2(1) = IAINT2(1) + NSH
1291c.....to shift the unformed particles to the end of the common block
1292c IF (NSH .GT. 0) THEN
1293c IB = IAINT2(1)
1294c IE = MASSR(1) + 1
1295c II = -1
1296c ELSE IF (NSH .LT. 0) THEN
1297c IB = MASSR(1) + 1
1298c IE = IAINT2(1)
1299c II = 1
1300c END IF
1301c IF (NSH .NE. 0) THEN
1302c DO I = IB, IE, II
1303c J = I - NSH
1304c ITYPAR(I) = ITYPAR(J)
1305c GXAR(I) = GXAR(J)
1306c GYAR(I) = GYAR(J)
1307c GZAR(I) = GZAR(J)
1308c FTAR(I) = FTAR(J)
1309c PXAR(I) = PXAR(J)
1310c PYAR(I) = PYAR(J)
1311c PZAR(I) = PZAR(J)
1312c PEAR(I) = PEAR(J)
1313c XMAR(I) = XMAR(J)
1314c END DO
1315c END IF
1316
1317c.....to copy ART particle info to COMMON /ARPRC/
1318c DO I = 1, MASSR(1)
1319c ITYPAR(I) = INVFLV(LB(I))
1320c GXAR(I) = R(1, I)
1321c GYAR(I) = R(2, I)
1322c GZAR(I) = R(3, I)
1323c FTAR(I) = CT
1324c PXAR(I) = P(1, I)
1325c PYAR(I) = P(2, I)
1326c PZAR(I) = P(3, I)
1327c XMAR(I) = E(I)
1328c PEAR(I) = SQRT(PXAR(I) ** 2 + PYAR(I) ** 2 + PZAR(I) ** 2
1329c & + XMAR(I) ** 2)
1330c END DO
1331 IA = 0
1332 DO 1035 IRUN = 1, NUM
1333 IA = IA + MASSR(IRUN - 1)
1334 NP1 = NPI(IRUN)
1335 NSH = MASSR(IRUN) - NP1 + 1
1336 MULTI1(IRUN) = MULTI1(IRUN) + NSH
1337c.....to shift the unformed particles to the end of the common block
1338 IF (NSH .GT. 0) THEN
1339 IB = MULTI1(IRUN)
1340 IE = MASSR(IRUN) + 1
1341 II = -1
1342 ELSE IF (NSH .LT. 0) THEN
1343 IB = MASSR(IRUN) + 1
1344 IE = MULTI1(IRUN)
1345 II = 1
1346 END IF
1347 IF (NSH .NE. 0) THEN
1348 DO 1033 I = IB, IE, II
1349 J = I - NSH
1350 ITYP1(I, IRUN) = ITYP1(J, IRUN)
1351 GX1(I, IRUN) = GX1(J, IRUN)
1352 GY1(I, IRUN) = GY1(J, IRUN)
1353 GZ1(I, IRUN) = GZ1(J, IRUN)
1354 FT1(I, IRUN) = FT1(J, IRUN)
1355 PX1(I, IRUN) = PX1(J, IRUN)
1356 PY1(I, IRUN) = PY1(J, IRUN)
1357 PZ1(I, IRUN) = PZ1(J, IRUN)
1358 EE1(I, IRUN) = EE1(J, IRUN)
1359 XM1(I, IRUN) = XM1(J, IRUN)
1360c !! sp 12/19/00
1361 PRO1(I, IRUN) = PRO1(J, IRUN)
1362clin-5/2008:
1363 dpp1(I,IRUN)=dpp1(J,IRUN)
1364 1033 CONTINUE
1365 END IF
1366
1367c.....to copy ART particle info to COMMON /ARPRC1/
1368 DO 1034 I = 1, MASSR(IRUN)
1369 IB = IA + I
1370 ITYP1(I, IRUN) = INVFLV(LB(IB))
1371 GX1(I, IRUN) = R(1, IB)
1372 GY1(I, IRUN) = R(2, IB)
1373 GZ1(I, IRUN) = R(3, IB)
1374clin-10/28/03:
1375c since all unformed hadrons at time ct are read in at nt=ntmax-1,
1376c their formation time ft1 should be kept to determine their freezeout(x,t):
1377c FT1(I, IRUN) = CT
1378 if(FT1(I, IRUN).lt.CT) FT1(I, IRUN) = CT
1379 PX1(I, IRUN) = P(1, IB)
1380 PY1(I, IRUN) = P(2, IB)
1381 PZ1(I, IRUN) = P(3, IB)
1382 XM1(I, IRUN) = E(IB)
1383 EE1(I, IRUN) = SQRT(PX1(I, IRUN) ** 2 +
1384 & PY1(I, IRUN) ** 2 +
1385 & PZ1(I, IRUN) ** 2 +
1386 & XM1(I, IRUN) ** 2)
1387c !! sp 12/19/00
1388 PRO1(I, IRUN) = PROPER(IB)
1389 1034 CONTINUE
1390 1035 CONTINUE
1391cbz12/22/98end
1392 END IF
1393cbz11/16/98end
1394c
1395**********************************
1396* *
1397* ======= END OF MANY LOOPS OVER IMPACT PARAMETERS ========== *
1398* *
1399**********************************
140050000 CONTINUE
1401*
1402*-----------------------------------------------------------------------
1403* ==== ART COMPLETED ====
1404*-----------------------------------------------------------------------
1405cbz11/16/98
1406c STOP
1407 RETURN
1408cbz11/16/98end
1409 END
1410**********************************
1411 subroutine coulin(masspr,massta,NUM)
1412* *
1413* purpose: initialization of array zet() and lb() for all runs *
1414* lb(i) = 1 => proton *
1415* lb(i) = 2 => neutron *
1416**********************************
1417 integer zta,zpr
1418 PARAMETER (MAXSTR=150001)
1419 common /EE/ ID(MAXSTR),LB(MAXSTR)
1420cc SAVE /EE/
1421 COMMON /ZZ/ ZTA,ZPR
1422cc SAVE /zz/
1423 SAVE
1424 MASS=MASSTA+MASSPR
1425 DO 500 IRUN=1,NUM
1426 do 100 i = 1+(IRUN-1)*MASS,zta+(IRUN-1)*MASS
1427 LB(i) = 1
1428 100 continue
1429 do 200 i = zta+1+(IRUN-1)*MASS,massta+(IRUN-1)*MASS
1430 LB(i) = 2
1431 200 continue
1432 do 300 i = massta+1+(IRUN-1)*MASS,massta+zpr+(IRUN-1)*MASS
1433 LB(i) = 1
1434 300 continue
1435 do 400 i = massta+zpr+1+(IRUN-1)*MASS,
1436 1 massta+masspr+(IRUN-1)*MASS
1437 LB(i) = 2
1438 400 continue
1439 500 CONTINUE
1440 return
1441 end
1442**********************************
1443* *
1444 SUBROUTINE RELCOL(LCOLL,LBLOC,LCNNE,LDD,LPP,lppk,
1445 &LPN,lpd,lrho,lomega,LKN,LNNK,LDDK,LNDK,LCNND,LCNDN,
1446 &LDIRT,LDECAY,LRES,LDOU,LDDRHO,LNNRHO,LNNOM,
1447 &NT,ntmax,sp,akaon,sk)
1448* *
1449* PURPOSE: CHECK CONDITIONS AND CALCULATE THE KINEMATICS *
1450* FOR BINARY COLLISIONS AMONG PARTICLES *
1451* - RELATIVISTIC FORMULA USED *
1452* *
1453* REFERENCES: HAGEDORN, RELATIVISTIC KINEMATICS (1963) *
1454* *
1455* VARIABLES: *
1456* MASSPR - NUMBER OF NUCLEONS IN PROJECTILE (INTEGER,INPUT) *
1457* MASSTA - NUMBER OF NUCLEONS IN TARGET (INTEGER,INPUT) *
1458* NUM - NUMBER OF TESTPARTICLES PER NUCLEON(INTEGER,INPUT) *
1459* ISEED - SEED FOR RANDOM NUMBER GENERATOR (INTEGER,INPUT) *
1460* IAVOID - (= 1 => AVOID FIRST CLLISIONS WITHIN THE SAME *
1461* NUCLEUS, ELSE ALL COLLISIONS) (INTEGER,INPUT) *
1462* DELTAR - MAXIMUM SPATIAL DISTANCE FOR WHICH A COLLISION *
1463* STILL CAN OCCUR (REAL,INPUT) *
1464* DT - TIME STEP SIZE (REAL,INPUT) *
1465* LCOLL - NUMBER OF COLLISIONS (INTEGER,OUTPUT) *
1466* LBLOC - NUMBER OF PULI-BLOCKED COLLISIONS (INTEGER,OUTPUT) *
1467* LCNNE - NUMBER OF ELASTIC COLLISION (INTEGER,OUTPUT) *
1468* LCNND - NUMBER OF N+N->N+DELTA REACTION (INTEGER,OUTPUT) *
1469* LCNDN - NUMBER OF N+DELTA->N+N REACTION (INTEGER,OUTPUT) *
1470* LDD - NUMBER OF RESONANCE+RESONANCE COLLISIONS
1471* LPP - NUMBER OF PION+PION elastic COLIISIONS
1472* lppk - number of pion(RHO,OMEGA)+pion(RHO,OMEGA)
1473* -->K+K- collisions
1474* LPN - NUMBER OF PION+N-->KAON+X
1475* lpd - number of pion+n-->delta+pion
1476* lrho - number of pion+n-->Delta+rho
1477* lomega - number of pion+n-->Delta+omega
1478* LKN - NUMBER OF KAON RESCATTERINGS
1479* LNNK - NUMBER OF bb-->kAON PROCESS
1480* LDDK - NUMBER OF DD-->KAON PROCESS
1481* LNDK - NUMBER OF ND-->KAON PROCESS
1482* LB(I) IS USED TO LABEL PARTICLE'S CHARGE STATE
1483* LB(I) =
1484cbali2/7/99
1485* -45 Omega baryon(bar)
1486* -41 cascade0(bar)
1487* -40 cascade-(bar)
1488clin-11/07/00:
1489* -30 K*-
1490* -17 sigma+(bar)
1491* -16 sigma0(bar)
1492* -15 sigma-(bar)
1493* -14 LAMBDA(bar)
1494clin-8/29/00
1495* -13 anti-N*(+1)(1535),s_11
1496* -12 anti-N*0(1535),s_11
1497* -11 anti-N*(+1)(1440),p_11
1498* -10 anti-N*0(1440), p_11
1499* -9 anti-DELTA+2
1500* -8 anti-DELTA+1
1501* -7 anti-DELTA0
1502* -6 anti-DELTA-1
1503*
1504* -2 antineutron
1505* -1 antiproton
1506cbali2/7/99end
1507* 0 eta
1508* 1 PROTON
1509* 2 NUETRON
1510* 3 PION-
1511* 4 PION0
1512* 5 PION+
1513* 6 DELTA-1
1514* 7 DELTA0
1515* 8 DELTA+1
1516* 9 DELTA+2
1517* 10 N*0(1440), p_11
1518* 11 N*(+1)(1440),p_11
1519* 12 N*0(1535),s_11
1520* 13 N*(+1)(1535),s_11
1521* 14 LAMBDA
1522* 15 sigma-
1523* 16 sigma0
1524* 17 sigma+
1525* 21 kaon-
1526clin-2/23/03 22 Kaon0Long (converted at the last timestep)
1527* 23 KAON+
1528* 24 Kaon0short (converted at the last timestep then decay)
1529* 25 rho-
1530* 26 rho0
1531* 27 rho+
1532* 28 omega meson
1533* 29 phi
1534* 30 K*+
1535* sp01/03/01
1536* 31 eta-prime
1537* 40 cascade-
1538* 41 cascade0
1539* 45 Omega baryon
1540* sp01/03/01 end
1541*
1542* ++ ------- SEE NOTE BOOK
1543* NSTAR=1 INCLUDING N* RESORANCE
1544* ELSE DELTA RESORANCE ONLY
1545* NDIRCT=1 INCLUDING DIRECT PROCESS,ELSE NOT
1546* DIR - PERCENTAGE OF DIRECT PION PRODUCTION PROCESS
1547**********************************
1548 PARAMETER (MAXSTR=150001,MAXR=1,PI=3.1415926)
1549 parameter (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
1550 PARAMETER (AKA=0.498,ALA=1.1157,ASA=1.1974,aks=0.895)
1551 PARAMETER (AA1=1.26,APHI=1.02,AP1=0.13496)
1552 parameter (maxx=20,maxz=24)
1553 parameter (rrkk=0.6,prkk=0.3,srhoks=5.,ESBIN=0.04)
1554 DIMENSION MASSRN(0:MAXR),RT(3,MAXSTR),PT(3,MAXSTR),ET(MAXSTR)
1555 DIMENSION LT(MAXSTR), PROT(MAXSTR)
1556 COMMON /AA/ R(3,MAXSTR)
1557cc SAVE /AA/
1558 COMMON /BB/ P(3,MAXSTR)
1559cc SAVE /BB/
1560 COMMON /CC/ E(MAXSTR)
1561cc SAVE /CC/
1562 COMMON /DD/ RHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
1563 & RHOP(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
1564 & RHON(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
1565cc SAVE /DD/
1566 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
1567cc SAVE /EE/
1568 COMMON /HH/ PROPER(MAXSTR)
1569cc SAVE /HH/
1570 common /ff/f(-mx:mx,-my:my,-mz:mz,-mpx:mpx,-mpy:mpy,-mpz:mpzp)
1571cc SAVE /ff/
1572 common /gg/ dx,dy,dz,dpx,dpy,dpz
1573cc SAVE /gg/
1574 COMMON /INPUT/ NSTAR,NDIRCT,DIR
1575cc SAVE /INPUT/
1576 COMMON /NN/NNN
1577cc SAVE /NN/
1578 COMMON /RR/ MASSR(0:MAXR)
1579cc SAVE /RR/
1580 common /ss/ inout(20)
1581cc SAVE /ss/
1582 COMMON /BG/BETAX,BETAY,BETAZ,GAMMA
1583cc SAVE /BG/
1584 COMMON /RUN/NUM
1585cc SAVE /RUN/
1586 COMMON /PA/RPION(3,MAXSTR,MAXR)
1587cc SAVE /PA/
1588 COMMON /PB/PPION(3,MAXSTR,MAXR)
1589cc SAVE /PB/
1590 COMMON /PC/EPION(MAXSTR,MAXR)
1591cc SAVE /PC/
1592 COMMON /PD/LPION(MAXSTR,MAXR)
1593cc SAVE /PD/
1594 COMMON /PE/PROPI(MAXSTR,MAXR)
1595cc SAVE /PE/
1596 COMMON /KKK/TKAON(7),EKAON(7,0:2000)
1597cc SAVE /KKK/
1598 COMMON /KAON/ AK(3,50,36),SPECK(50,36,7),MF
1599cc SAVE /KAON/
1600 COMMON/TABLE/ xarray(0:1000),earray(0:1000)
1601cc SAVE /TABLE/
1602 common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
1603cc SAVE /input1/
1604 common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
1605 1 px1n,py1n,pz1n,dp1n
1606cc SAVE /leadng/
1607 COMMON/tdecay/tfdcy(MAXSTR),tfdpi(MAXSTR,MAXR),tft(MAXSTR)
1608cc SAVE /tdecay/
1609 common /lastt/itimeh,bimp
1610cc SAVE /lastt/
1611c
1612 COMMON/ppbmas/niso(15),nstate,ppbm(15,2),thresh(15),weight(15)
1613cc SAVE /ppbmas/
1614 common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
1615cc SAVE /ppb1/
1616 common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
1617cc SAVE /ppmm/
1618 COMMON/hbt/lblast(MAXSTR),xlast(4,MAXSTR),plast(4,MAXSTR),nlast
1619cc SAVE /hbt/
1620 common/resdcy/NSAV,iksdcy
1621cc SAVE /resdcy/
1622 COMMON/RNDF77/NSEED
1623cc SAVE /RNDF77/
1624 COMMON/FTMAX/ftsv(MAXSTR),ftsvt(MAXSTR, MAXR)
1625 dimension ftpisv(MAXSTR,MAXR),fttemp(MAXSTR)
1626 common /dpi/em2,lb2
1627 common/phidcy/iphidcy,pttrig,ntrig,maxmiss
1628clin-5/2008:
1629 DIMENSION dptemp(MAXSTR)
1630 common /para8/ idpert,npertd,idxsec
1631 COMMON /dpert/dpertt(MAXSTR,MAXR),dpertp(MAXSTR),dplast(MAXSTR),
1632 1 dpdcy(MAXSTR),dpdpi(MAXSTR,MAXR),dpt(MAXSTR, MAXR),
1633 2 dpp1(MAXSTR,MAXR),dppion(MAXSTR,MAXR)
1634c
1635 real zet(-45:45)
1636 SAVE
1637 data zet /
1638 4 1.,0.,0.,0.,0.,
1639 3 1.,0.,0.,0.,0.,0.,0.,0.,0.,0.,
1640 2 -1.,0.,0.,0.,0.,0.,0.,0.,0.,0.,
1641 1 0.,0.,0.,-1.,0.,1.,0.,-1.,0.,-1.,
1642 s 0.,-2.,-1.,0.,1.,0.,0.,0.,0.,-1.,
1643 e 0.,
1644 s 1.,0.,-1.,0.,1.,-1.,0.,1.,2.,0.,
1645 1 1.,0.,1.,0.,-1.,0.,1.,0.,0.,0.,
1646 2 -1.,0.,1.,0.,-1.,0.,1.,0.,0.,1.,
1647 3 0.,0.,0.,0.,0.,0.,0.,0.,0.,-1.,
1648 4 0.,0.,0.,0.,-1./
1649
1650clin-2/19/03 initialize n and nsav for resonance decay at each timestep
1651c in order to prevent integer overflow:
1652 call inidcy
1653
1654c OFF skip ART collisions to reproduce HJ:
1655cc if(nt.ne.ntmax) return
1656
1657clin-11/07/00 rrkk is assumed to be 0.6mb(default) for mm->KKbar
1658c with m=rho or omega, estimated from Ko's paper:
1659c rrkk=0.6
1660c prkk: cross section of pi (rho or omega) -> K* Kbar (AND) K*bar K:
1661c prkk=0.3
1662c cross section in mb for (rho or omega) K* -> pi K:
1663c srhoks=5.
1664clin-11/07/00-end
1665c ESBIN=0.04
1666 RESONA=5.
1667*-----------------------------------------------------------------------
1668* INITIALIZATION OF COUNTING VARIABLES
1669 NODELT=0
1670 SUMSRT =0.
1671 LCOLL = 0
1672 LBLOC = 0
1673 LCNNE = 0
1674 LDD = 0
1675 LPP = 0
1676 lpd = 0
1677 lpdr=0
1678 lrho = 0
1679 lrhor=0
1680 lomega=0
1681 lomgar=0
1682 LPN = 0
1683 LKN = 0
1684 LNNK = 0
1685 LDDK = 0
1686 LNDK = 0
1687 lppk =0
1688 LCNND = 0
1689 LCNDN = 0
1690 LDIRT = 0
1691 LDECAY = 0
1692 LRES = 0
1693 Ldou = 0
1694 LDDRHO = 0
1695 LNNRHO = 0
1696 LNNOM = 0
1697 MSUM = 0
1698 MASSRN(0)=0
1699* COM: MSUM IS USED TO COUNT THE TOTAL NO. OF PARTICLES
1700* IN PREVIOUS IRUN-1 RUNS
1701* KAON COUNTERS
1702 DO 1002 IL=1,5
1703 TKAON(IL)=0
1704 DO 1001 IS=1,2000
1705 EKAON(IL,IS)=0
1706 1001 CONTINUE
1707 1002 CONTINUE
1708c sp 12/19/00
1709 DO 1004 i =1,NUM
1710 DO 1003 j =1,MAXSTR
1711 PROPI(j,i) = 1.
1712 1003 CONTINUE
1713 1004 CONTINUE
1714
1715 do 1102 i=1,maxstr
1716 fttemp(i)=0.
1717 do 1101 irun=1,maxr
1718 ftpisv(i,irun)=0.
1719 1101 continue
1720 1102 continue
1721
1722c sp 12/19/00 end
1723 sp=0
1724* antikaon counters
1725 akaon=0
1726 sk=0
1727*-----------------------------------------------------------------------
1728* LOOP OVER ALL PARALLEL RUNS
1729cbz11/17/98
1730c MASS=MASSPR+MASSTA
1731 MASS = 0
1732cbz11/17/98end
1733 DO 1000 IRUN = 1,NUM
1734 NNN=0
1735 MSUM=MSUM+MASSR(IRUN-1)
1736* LOOP OVER ALL PSEUDOPARTICLES 1 IN THE SAME RUN
1737 J10=2
1738 IF(NT.EQ.NTMAX)J10=1
1739c
1740ctest off skips the check of energy conservation after each timestep:
1741c enetot=0.
1742c do ip=1,MASSR(IRUN)
1743c if(e(ip).ne.0.or.lb(ip).eq.10022) enetot=enetot
1744c 1 +sqrt(p(1,ip)**2+p(2,ip)**2+p(3,ip)**2+e(ip)**2)
1745c enddo
1746c write(91,*) 'A:',nt,enetot,massr(irun),bimp
1747
1748 DO 800 J1 = J10,MASSR(IRUN)
1749 I1 = J1 + MSUM
1750* E(I)=0 are for pions having been absorbed or photons which do not enter here:
1751 IF(E(I1).EQ.0.)GO TO 800
1752
1753c To include anti-(Delta,N*1440 and N*1535):
1754c IF ((LB(I1) .LT. -13 .OR. LB(I1) .GT. 28)
1755c 1 .and.iabs(LB(I1)) .ne. 30 ) GOTO 800
1756 IF (LB(I1) .LT. -45 .OR. LB(I1) .GT. 45) GOTO 800
1757 X1 = R(1,I1)
1758 Y1 = R(2,I1)
1759 Z1 = R(3,I1)
1760 PX1 = P(1,I1)
1761 PY1 = P(2,I1)
1762 PZ1 = P(3,I1)
1763 EM1 = E(I1)
1764 am1= em1
1765 E1 = SQRT( EM1**2 + PX1**2 + PY1**2 + PZ1**2 )
1766 ID1 = ID(I1)
1767 LB1 = LB(I1)
1768
1769c generate k0short and k0long from K+ and K- at the last timestep:
1770 if(nt.eq.ntmax.and.(lb1.eq.21.or.lb1.eq.23)) then
1771 pk0=RANART(NSEED)
1772 if(pk0.lt.0.25) then
1773 LB(I1)=22
1774 elseif(pk0.lt.0.50) then
1775 LB(I1)=24
1776 endif
1777 LB1=LB(I1)
1778 endif
1779
1780clin-8/07/02 these particles don't decay strongly, so skip decay routines:
1781c IF( (lb1.ge.-2.and.lb1.le.5) .OR. lb1.eq.31 .OR.
1782c & (iabs(lb1).ge.14.and.iabs(lb1).le.24) .OR.
1783c & (iabs(lb1).ge.40.and.iabs(lb1).le.45) .or.
1784c & lb1.eq.31)GO TO 1
1785c only decay K0short when iksdcy=1:
1786 if(lb1.eq.0.or.lb1.eq.25.or.lb1.eq.26.or.lb1.eq.27
1787 & .or.lb1.eq.28.or.lb1.eq.29.or.iabs(lb1).eq.30
1788 & .or.(iabs(lb1).ge.6.and.iabs(lb1).le.13)
1789 & .or.(iksdcy.eq.1.and.lb1.eq.24)
1790 & .or.iabs(lb1).eq.16) then
1791 continue
1792 else
1793 goto 1
1794 endif
1795* IF I1 IS A RESONANCE, CHECK WHETHER IT DECAYS DURING THIS TIME STEP
1796 IF(lb1.ge.25.and.lb1.le.27) then
1797 wid=0.151
1798 ELSEIF(lb1.eq.28) then
1799 wid=0.00841
1800 ELSEIF(lb1.eq.29) then
1801 wid=0.00443
1802 ELSEIF(iabs(LB1).eq.30) then
1803 WID=0.051
1804 ELSEIF(lb1.eq.0) then
1805 wid=1.18e-6
1806c to give K0short ct0=2.676cm:
1807 ELSEIF(iksdcy.eq.1.and.lb1.eq.24) then
1808 wid=7.36e-15
1809clin-4/29/03 add Sigma0 decay to Lambda, ct0=2.22E-11m:
1810 ELSEIF(iabs(lb1).eq.16) then
1811 wid=8.87e-6
1812csp-07/25/01 test a1 resonance:
1813cc ELSEIF(LB1.EQ.32) then
1814cc WID=0.40
1815 ELSEIF(LB1.EQ.32) then
1816 call WIDA1(EM1,rhomp,WID,iseed)
1817 ELSEIF(iabs(LB1).ge.6.and.iabs(LB1).le.9) then
1818 WID=WIDTH(EM1)
1819 ELSEIF((iabs(LB1).EQ.10).OR.(iabs(LB1).EQ.11)) then
1820 WID=W1440(EM1)
1821 ELSEIF((iabs(LB1).EQ.12).OR.(iabs(LB1).EQ.13)) then
1822 WID=W1535(EM1)
1823 ENDIF
1824
1825* if it is the last time step, FORCE all resonance to strong-decay
1826* and go out of the loop
1827 if(nt.eq.ntmax)then
1828 pdecay=1.1
1829clin-5b/2008 forbid phi decay at the end of hadronic cascade:
1830 if(iphidcy.eq.0.and.iabs(LB1).eq.29) pdecay=0.
05cdcf94 1831cpchrist forbid K* decay at the end of hadronic cascade:
1832 if(ikstardcy.eq.0.and.iabs(LB1).eq.30) pdecay=0.
0119ef9a 1833 else
1834 T0=0.19733/WID
1835 GFACTR=E1/EM1
1836 T0=T0*GFACTR
1837 IF(T0.GT.0.)THEN
1838 PDECAY=1.-EXP(-DT/T0)
1839 ELSE
1840 PDECAY=0.
1841 ENDIF
1842 endif
1843 XDECAY=RANART(NSEED)
1844
1845cc dilepton production from rho0, omega, phi decay
1846cc if(lb1.eq.26 .or. lb1.eq.28 .or. lb1.eq.29)
1847cc & call dec_ceres(nt,ntmax,irun,i1)
1848cc
1849 IF(XDECAY.LT.PDECAY) THEN
1850clin-10/25/02 get rid of argument usage mismatch in rhocay():
1851 idecay=irun
1852 tfnl=nt*dt
1853clin-10/28/03 keep formation time of hadrons unformed at nt=ntmax-1:
1854 if(nt.eq.ntmax.and.ftsv(i1).gt.((ntmax-1)*dt))
1855 1 tfnl=ftsv(i1)
1856 xfnl=x1
1857 yfnl=y1
1858 zfnl=z1
1859* use PYTHIA to perform decays of eta,rho,omega,phi,K*,(K0s) and Delta:
1860 if(lb1.eq.0.or.lb1.eq.25.or.lb1.eq.26.or.lb1.eq.27
1861 & .or.lb1.eq.28.or.lb1.eq.29.or.iabs(lb1).eq.30
1862 & .or.(iabs(lb1).ge.6.and.iabs(lb1).le.9)
1863 & .or.(iksdcy.eq.1.and.lb1.eq.24)
1864 & .or.iabs(lb1).eq.16) then
1865c previous rho decay performed in rhodecay():
1866c nnn=nnn+1
1867c call rhodecay(idecay,i1,nnn,iseed)
1868c
1869ctest off record decays of phi,K*,Lambda(1520) resonances:
1870c if(lb1.eq.29.or.iabs(lb1).eq.30)
1871c 1 write(18,112) 'decay',lb1,px1,py1,pz1,am1,nt
1872 call resdec(i1,nt,nnn,wid,idecay)
1873 p(1,i1)=px1n
1874 p(2,i1)=py1n
1875 p(3,i1)=pz1n
1876clin-5/2008:
1877 dpertp(i1)=dp1n
1878c add decay time to freezeout positions & time at the last timestep:
1879 if(nt.eq.ntmax) then
1880 R(1,i1)=xfnl
1881 R(2,i1)=yfnl
1882 R(3,i1)=zfnl
1883 tfdcy(i1)=tfnl
1884 endif
1885c
1886* decay number for baryon resonance or L/S decay
1887 if(iabs(lb1).ge.6.and.iabs(lb1).le.9) then
1888 LDECAY=LDECAY+1
1889 endif
1890
1891* for a1 decay
1892c elseif(lb1.eq.32)then
1893c NNN=NNN+1
1894c call a1decay(idecay,i1,nnn,iseed,rhomp)
1895
1896* FOR N*(1440)
1897 elseif(iabs(LB1).EQ.10.OR.iabs(LB1).EQ.11) THEN
1898 NNN=NNN+1
1899 LDECAY=LDECAY+1
1900 PNSTAR=1.
1901 IF(E(I1).GT.1.22)PNSTAR=0.6
1902 IF(RANART(NSEED).LE.PNSTAR)THEN
1903* (1) DECAY TO SINGLE PION+NUCLEON
3006c44b 1904 CALL DECAYA(idecay,I1,NNN,ISEED,wid,nt)
0119ef9a 1905 ELSE
1906* (2) DECAY TO TWO PIONS + NUCLEON
1907 CALL DECAY2(idecay,I1,NNN,ISEED,wid,nt)
1908 NNN=NNN+1
1909 ENDIF
1910c for N*(1535) decay
1911 elseif(iabs(LB1).eq.12.or.iabs(LB1).eq.13) then
1912 NNN=NNN+1
3006c44b 1913 CALL DECAYA(idecay,I1,NNN,ISEED,wid,nt)
0119ef9a 1914 LDECAY=LDECAY+1
1915 endif
1916c
1917*COM: AT HIGH ENERGIES WE USE VERY SHORT TIME STEPS,
1918* IN ORDER TO TAKE INTO ACCOUNT THE FINITE FORMATIOM TIME, WE
1919* DO NOT ALLOW PARTICLES FROM THE DECAY OF RESONANCE TO INTERACT
1920* WITH OTHERS IN THE SAME TIME STEP. CHANGE 9000 TO REVERSE THIS
1921* ASSUMPTION. EFFECTS OF THIS ASSUMPTION CAN BE STUDIED BY CHANGING
1922* THE STATEMENT OF 9000. See notebook for discussions on effects of
1923* changing statement 9000.
1924c
1925c kaons from K* decay are converted to k0short (and k0long),
1926c phi decay may produce rho, K0S or eta, N*(1535) decay may produce eta,
1927c and these decay daughters need to decay again if at the last timestep:
1928c (note: these daughters have been assigned to lb(i1) only, not to lpion)
1929c if(nt.eq.ntmax.and.(lb1.eq.29.or.iabs(lb1).eq.30
1930c 1 .iabs(lb1).eq.12.or.iabs(lb1).eq.13)) then
1931 if(nt.eq.ntmax) then
1932 if(lb(i1).eq.25.or.lb(i1).eq.26.or.lb(i1).eq.27) then
1933 wid=0.151
1934 elseif(lb(i1).eq.0) then
1935 wid=1.18e-6
1936 elseif(lb(i1).eq.24.and.iksdcy.eq.1) then
1937 wid=7.36e-17
1938 else
1939 goto 9000
1940 endif
1941 LB1=LB(I1)
1942 PX1=P(1,I1)
1943 PY1=P(2,I1)
1944 PZ1=P(3,I1)
1945 EM1=E(I1)
1946 E1=SQRT(EM1**2+PX1**2+PY1**2+PZ1**2)
1947 call resdec(i1,nt,nnn,wid,idecay)
1948 p(1,i1)=px1n
1949 p(2,i1)=py1n
1950 p(3,i1)=pz1n
1951 R(1,i1)=xfnl
1952 R(2,i1)=yfnl
1953 R(3,i1)=zfnl
1954 tfdcy(i1)=tfnl
1955clin-5/2008:
1956 dpertp(i1)=dp1n
1957 endif
1958
1959* negelecting the Pauli blocking at high energies
1960 9000 go to 800
1961 ENDIF
1962* LOOP OVER ALL PSEUDOPARTICLES 2 IN THE SAME RUN
1963* SAVE ALL THE COORDINATES FOR POSSIBLE CHANGE IN THE FOLLOWING COLLISION
1964 1 if(nt.eq.ntmax)go to 800
1965 X1 = R(1,I1)
1966 Y1 = R(2,I1)
1967 Z1 = R(3,I1)
1968c
1969 DO 600 J2 = 1,J1-1
1970 I2 = J2 + MSUM
1971* IF I2 IS A MESON BEING ABSORBED, THEN GO OUT OF THE LOOP
1972 IF(E(I2).EQ.0.) GO TO 600
1973clin-5/2008 in case the first particle is already destroyed:
1974 IF(E(I1).EQ.0.) GO TO 800
1975 IF (LB(I2) .LT. -45 .OR. LB(I2) .GT. 45) GOTO 600
1976clin-7/26/03 improve speed
1977 X2=R(1,I2)
1978 Y2=R(2,I2)
1979 Z2=R(3,I2)
1980 dr0max=5.
1981clin-9/2008 deuteron+nucleon elastic cross sections could reach ~2810mb:
1982 ilb1=iabs(LB(I1))
1983 ilb2=iabs(LB(I2))
1984 IF(ilb1.EQ.42.or.ilb2.EQ.42) THEN
1985 if((ILB1.GE.1.AND.ILB1.LE.2)
1986 1 .or.(ILB1.GE.6.AND.ILB1.LE.13)
1987 2 .or.(ILB2.GE.1.AND.ILB2.LE.2)
1988 3 .or.(ILB2.GE.6.AND.ILB2.LE.13)) then
1989 if((lb(i1)*lb(i2)).gt.0) dr0max=10.
1990 endif
1991 ENDIF
1992c
1993 if(((X1-X2)**2+(Y1-Y2)**2+(Z1-Z2)**2).GT.dr0max**2)
1994 1 GO TO 600
1995 IF (ID(I1)*ID(I2).EQ.IAVOID) GOTO 400
1996 ID1=ID(I1)
1997 ID2 = ID(I2)
1998c
1999 ix1= nint(x1/dx)
2000 iy1= nint(y1/dy)
2001 iz1= nint(z1/dz)
2002 PX1=P(1,I1)
2003 PY1=P(2,I1)
2004 PZ1=P(3,I1)
2005 EM1=E(I1)
2006 AM1=EM1
2007 LB1=LB(I1)
2008 E1=SQRT(EM1**2+PX1**2+PY1**2+PZ1**2)
2009 IPX1=NINT(PX1/DPX)
2010 IPY1=NINT(PY1/DPY)
2011 IPZ1=NINT(PZ1/DPZ)
2012 LB2 = LB(I2)
2013 PX2 = P(1,I2)
2014 PY2 = P(2,I2)
2015 PZ2 = P(3,I2)
2016 EM2=E(I2)
2017 AM2=EM2
2018 lb1i=lb(i1)
2019 lb2i=lb(i2)
2020 px1i=P(1,I1)
2021 py1i=P(2,I1)
2022 pz1i=P(3,I1)
2023 em1i=E(I1)
2024 px2i=P(1,I2)
2025 py2i=P(2,I2)
2026 pz2i=P(3,I2)
2027 em2i=E(I2)
2028clin-2/26/03 ctest off check energy conservation after each binary search:
2029 eini=SQRT(E(I1)**2+P(1,I1)**2+P(2,I1)**2+P(3,I1)**2)
2030 1 +SQRT(E(I2)**2+P(1,I2)**2+P(2,I2)**2+P(3,I2)**2)
2031 pxini=P(1,I1)+P(1,I2)
2032 pyini=P(2,I1)+P(2,I2)
2033 pzini=P(3,I1)+P(3,I2)
2034 nnnini=nnn
2035c
2036clin-4/30/03 initialize value:
2037 iblock=0
2038c
2039* TO SAVE COMPUTING TIME we do the following
2040* (1) make a ROUGH estimate to see whether particle i2 will collide with
2041* particle I1, and (2) skip the particle pairs for which collisions are
2042* not modeled in the code.
2043* FOR MESON-BARYON AND MESON-MESON COLLISIONS, we use a maximum
2044* interaction distance DELTR0=2.6
2045* for ppbar production from meson (pi rho omega) interactions:
2046c
2047 DELTR0=3.
2048 if( (iabs(lb1).ge.14.and.iabs(lb1).le.17) .or.
2049 & (iabs(lb1).ge.30.and.iabs(lb1).le.45) ) DELTR0=5.0
2050 if( (iabs(lb2).ge.14.and.iabs(lb2).le.17) .or.
2051 & (iabs(lb2).ge.30.and.iabs(lb2).le.45) ) DELTR0=5.0
2052
2053 if(lb1.eq.28.and.lb2.eq.28) DELTR0=4.84
2054clin-10/08/00 to include pi pi -> rho rho:
2055 if((lb1.ge.3.and.lb1.le.5).and.(lb2.ge.3.and.lb2.le.5)) then
2056 E2=SQRT(EM2**2+PX2**2+PY2**2+PZ2**2)
2057 spipi=(e1+e2)**2-(px1+px2)**2-(py1+py2)**2-(pz1+pz2)**2
2058 if(spipi.ge.(4*0.77**2)) DELTR0=3.5
2059 endif
2060
2061c khyperon
2062 IF (LB1.EQ.23 .AND. (LB2.GE.14.AND.LB2.LE.17)) GOTO 3699
2063 IF (LB2.EQ.23 .AND. (LB1.GE.14.AND.LB1.LE.17)) GOTO 3699
2064
2065* K(K*) + Kbar(K*bar) scattering including
2066* K(K*) + Kbar(K*bar) --> phi + pi(rho,omega) and pi pi(rho,omega)
2067 if(lb1.eq.21.and.lb2.eq.23)go to 3699
2068 if(lb2.eq.21.and.lb1.eq.23)go to 3699
2069 if(lb1.eq.30.and.lb2.eq.21)go to 3699
2070 if(lb2.eq.30.and.lb1.eq.21)go to 3699
2071 if(lb1.eq.-30.and.lb2.eq.23)go to 3699
2072 if(lb2.eq.-30.and.lb1.eq.23)go to 3699
2073 if(lb1.eq.-30.and.lb2.eq.30)go to 3699
2074 if(lb2.eq.-30.and.lb1.eq.30)go to 3699
2075c
2076clin-12/15/00
2077c kaon+rho(omega,eta) collisions:
2078 if(lb1.eq.21.or.lb1.eq.23) then
2079 if(lb2.eq.0.or.(lb2.ge.25.and.lb2.le.28)) then
2080 go to 3699
2081 endif
2082 elseif(lb2.eq.21.or.lb2.eq.23) then
2083 if(lb1.eq.0.or.(lb1.ge.25.and.lb1.le.28)) then
2084 goto 3699
2085 endif
2086 endif
2087
2088clin-8/14/02 K* (pi, rho, omega, eta) collisions:
2089 if(iabs(lb1).eq.30 .and.
2090 1 (lb2.eq.0.or.(lb2.ge.25.and.lb2.le.28)
2091 2 .or.(lb2.ge.3.and.lb2.le.5))) then
2092 go to 3699
2093 elseif(iabs(lb2).eq.30 .and.
2094 1 (lb1.eq.0.or.(lb1.ge.25.and.lb1.le.28)
2095 2 .or.(lb1.ge.3.and.lb1.le.5))) then
2096 goto 3699
2097clin-8/14/02-end
2098c K*/K*-bar + baryon/antibaryon collisions:
2099 elseif( iabs(lb1).eq.30 .and.
2100 1 (iabs(lb2).eq.1.or.iabs(lb2).eq.2.or.
2101 2 (iabs(lb2).ge.6.and.iabs(lb2).le.13)) )then
2102 go to 3699
2103 endif
2104 if( iabs(lb2).eq.30 .and.
2105 1 (iabs(lb1).eq.1.or.iabs(lb1).eq.2.or.
2106 2 (iabs(lb1).ge.6.and.iabs(lb1).le.13)) )then
2107 go to 3699
2108 endif
2109* K^+ baryons and antibaryons:
2110c** K+ + B-bar --> La(Si)-bar + pi
2111* K^- and antibaryons, note K^- and baryons are included in newka():
2112* note that we fail to satisfy charge conjugation for these cross sections:
2113 if((lb1.eq.23.or.lb1.eq.21).and.
2114 1 (iabs(lb2).eq.1.or.iabs(lb2).eq.2.or.
2115 2 (iabs(lb2).ge.6.and.iabs(lb2).le.13))) then
2116 go to 3699
2117 elseif((lb2.eq.23.or.lb2.eq.21).and.
2118 1 (iabs(lb1).eq.1.or.iabs(lb1).eq.2.or.
2119 2 (iabs(lb1).ge.6.and.iabs(lb1).le.13))) then
2120 go to 3699
2121 endif
2122*
2123* For anti-nucleons annihilations:
2124* Assumptions:
2125* (1) for collisions involving a p_bar or n_bar,
2126* we allow only collisions between a p_bar and a baryon or a baryon
2127* resonance (as well as a n_bar and a baryon or a baryon resonance),
2128* we skip all other reactions involving a p_bar or n_bar,
2129* such as collisions between p_bar (n_bar) and mesons,
2130* and collisions between two p_bar's (n_bar's).
2131* (2) we introduce a new parameter rppmax: the maximum interaction
2132* distance to make the quick collision check,rppmax=3.57 fm
2133* corresponding to a cutoff of annihilation xsection= 400mb which is
2134* also used consistently in the actual annihilation xsection to be
2135* used in the following as given in the subroutine xppbar(srt)
2136 rppmax=3.57
2137* anti-baryon on baryons
2138 if((lb1.eq.-1.or.lb1.eq.-2.or.(lb1.ge.-13.and.lb1.le.-6))
2139 1 .and.(lb2.eq.1.or.lb2.eq.2.or.(lb2.ge.6.and.lb2.le.13))) then
2140 DELTR0 = RPPMAX
2141 GOTO 2699
2142 else if((lb2.eq.-1.or.lb2.eq.-2.or.(lb2.ge.-13.and.lb2.le.-6))
2143 1 .and.(lb1.eq.1.or.lb1.eq.2.or.(lb1.ge.6.and.lb1.le.13))) then
2144 DELTR0 = RPPMAX
2145 GOTO 2699
2146 END IF
2147
2148c* ((anti) lambda, cascade, omega should not be rejected)
2149 if( (iabs(lb1).ge.14.and.iabs(lb1).le.17) .or.
2150 & (iabs(lb2).ge.14.and.iabs(lb2).le.17) )go to 3699
2151c
2152clin-9/2008 maximum sigma~2810mb for deuteron+nucleon elastic collisions:
2153 IF (iabs(LB1).EQ.42.or.iabs(LB2).EQ.42) THEN
2154 ilb1=iabs(LB1)
2155 ilb2=iabs(LB2)
2156 if((ILB1.GE.1.AND.ILB1.LE.2)
2157 1 .or.(ILB1.GE.6.AND.ILB1.LE.13)
2158 2 .or.(ILB2.GE.1.AND.ILB2.LE.2)
2159 3 .or.(ILB2.GE.6.AND.ILB2.LE.13)) then
2160 if((lb1*lb2).gt.0) deltr0=9.5
2161 endif
2162 ENDIF
2163c
2164 if( (iabs(lb1).ge.40.and.iabs(lb1).le.45) .or.
2165 & (iabs(lb2).ge.40.and.iabs(lb2).le.45) )go to 3699
2166c
2167c* phi channel --> elastic + inelastic scatt.
2168 IF( (lb1.eq.29 .and.((lb2.ge.1.and.lb2.le.13).or.
2169 & (lb2.ge.21.and.lb2.le.28).or.iabs(lb2).eq.30)) .OR.
2170 & (lb2.eq.29 .and.((lb1.ge.1.and.lb1.le.13).or.
2171 & (lb1.ge.21.and.lb1.le.28).or.iabs(lb1).eq.30)) )THEN
2172 DELTR0=3.0
2173 go to 3699
2174 endif
2175c
2176c La/Si, Cas, Om (bar)-meson elastic colln
2177* pion vs. La & Ca (bar) coll. are treated in resp. subroutines
2178
2179* SKIP all other K* RESCATTERINGS
2180 If(iabs(lb1).eq.30.or.iabs(lb2).eq.30) go to 400
2181* SKIP KAON(+) RESCATTERINGS WITH particles other than pions and baryons
2182 If(lb1.eq.23.and.(lb2.lt.1.or.lb2.gt.17))go to 400
2183 If(lb2.eq.23.and.(lb1.lt.1.or.lb1.gt.17))go to 400
2184c
2185c anti-baryon proccess: B-bar+M, N-bar+R-bar, N-bar+N-bar, R-bar+R-bar
2186c R = (D,N*)
2187 if( ((lb1.le.-1.and.lb1.ge.-13)
2188 & .and.(lb2.eq.0.or.(lb2.ge.3.and.lb2.le.5)
2189 & .or.(lb2.ge.25.and.lb2.le.28)))
2190 & .OR.((lb2.le.-1.and.lb2.ge.-13)
2191 & .and.(lb1.eq.0.or.(lb1.ge.3.and.lb1.le.5)
2192 & .or.(lb1.ge.25.and.lb1.le.28))) ) then
2193 elseIF( ((LB1.eq.-1.or.lb1.eq.-2).
2194 & and.(LB2.LT.-5.and.lb2.ge.-13))
2195 & .OR. ((LB2.eq.-1.or.lb2.eq.-2).
2196 & and.(LB1.LT.-5.and.lb1.ge.-13)) )then
2197 elseIF((LB1.eq.-1.or.lb1.eq.-2)
2198 & .AND.(LB2.eq.-1.or.lb2.eq.-2))then
2199 elseIF((LB1.LT.-5.and.lb1.ge.-13).AND.
2200 & (LB2.LT.-5.and.lb2.ge.-13)) then
2201c elseif((lb1.lt.0).or.(lb2.lt.0)) then
2202c go to 400
2203 endif
2204
2205 2699 CONTINUE
2206* for baryon-baryon collisions
2207 IF (LB1 .EQ. 1 .OR. LB1 .EQ. 2 .OR. (LB1 .GE. 6 .AND.
2208 & LB1 .LE. 17)) THEN
2209 IF (LB2 .EQ. 1 .OR. LB2 .EQ. 2 .OR. (LB2 .GE. 6 .AND.
2210 & LB2 .LE. 17)) THEN
2211 DELTR0 = 2.
2212 END IF
2213 END IF
2214c
2215 3699 RSQARE = (X1-X2)**2 + (Y1-Y2)**2 + (Z1-Z2)**2
2216 IF (RSQARE .GT. DELTR0**2) GO TO 400
2217*NOW PARTICLES ARE CLOSE ENOUGH TO EACH OTHER !
2218* KEEP ALL COORDINATES FOR POSSIBLE PHASE SPACE CHANGE
2219 ix2 = nint(x2/dx)
2220 iy2 = nint(y2/dy)
2221 iz2 = nint(z2/dz)
2222 ipx2 = nint(px2/dpx)
2223 ipy2 = nint(py2/dpy)
2224 ipz2 = nint(pz2/dpz)
2225* FIND MOMENTA OF PARTICLES IN THE CMS OF THE TWO COLLIDING PARTICLES
2226* AND THE CMS ENERGY SRT
2227 CALL CMS(I1,I2,PCX,PCY,PCZ,SRT)
2228clin-7/26/03 improve speed
2229 drmax=dr0max
2230 call distc0(drmax,deltr0,DT,
2231 1 Ifirst,PCX,PCY,PCZ,
2232 2 x1,y1,z1,px1,py1,pz1,em1,x2,y2,z2,px2,py2,pz2,em2)
2233 if(Ifirst.eq.-1) goto 400
2234
2235 ISS=NINT(SRT/ESBIN)
2236clin-4/2008 use last bin if ISS is out of EKAON's upper bound of 2000:
afe6642c 2237 if(ISS.lt.0) GOTO 400
0119ef9a 2238 if(ISS.gt.2000) ISS=2000
2239*Sort collisions
2240c
2241clin-8/2008 Deuteron+Meson->B+B;
2242c meson=(pi,rho,omega,eta), B=(n,p,Delta,N*1440,N*1535):
2243 IF (iabs(LB1).EQ.42.or.iabs(LB2).EQ.42) THEN
2244 ilb1=iabs(LB1)
2245 ilb2=iabs(LB2)
2246 if(LB1.eq.0.or.(LB1.GE.3.AND.LB1.LE.5)
2247 1 .or.(LB1.GE.25.AND.LB1.LE.28)
2248 2 .or.
2249 3 LB2.eq.0.or.(LB2.GE.3.AND.LB2.LE.5)
2250 4 .or.(LB2.GE.25.AND.LB2.LE.28)) then
2251 GOTO 505
2252clin-9/2008 Deuteron+Baryon or antiDeuteron+antiBaryon elastic collisions:
2253 elseif(((ILB1.GE.1.AND.ILB1.LE.2)
2254 1 .or.(ILB1.GE.6.AND.ILB1.LE.13)
2255 2 .or.(ILB2.GE.1.AND.ILB2.LE.2)
2256 3 .or.(ILB2.GE.6.AND.ILB2.LE.13))
2257 4 .and.(lb1*lb2).gt.0) then
2258 GOTO 506
2259 else
2260 GOTO 400
2261 endif
2262 ENDIF
2263c
2264* K+ + (N,N*,D)-bar --> L/S-bar + pi
2265 if( ((lb1.eq.23.or.lb1.eq.30).and.
2266 & (lb2.eq.-1.or.lb2.eq.-2.or.(lb2.ge.-13.and.lb2.le.-6)))
2267 & .OR.((lb2.eq.23.or.lb2.eq.30).and.
2268 & (lb1.eq.-1.or.lb1.eq.-2.or.(lb1.ge.-13.and.lb1.le.-6))) )
2269 & then
2270 bmass=0.938
2271 if(srt.le.(bmass+aka)) then
2272 pkaon=0.
2273 else
2274 pkaon=sqrt(((srt**2-(aka**2+bmass**2))
2275 1 /2./bmass)**2-aka**2)
2276 endif
2277clin-10/31/02 cross sections are isospin-averaged, same as those in newka
2278c for K- + (N,N*,D) --> L/S + pi:
2279 sigela = 0.5 * (AKPEL(PKAON) + AKNEL(PKAON))
2280 SIGSGM = 1.5 * AKPSGM(PKAON) + AKNSGM(PKAON)
2281 SIG = sigela + SIGSGM + AKPLAM(PKAON)
2282 if(sig.gt.1.e-7) then
2283c ! K+ + N-bar reactions
2284 icase=3
2285 brel=sigela/sig
2286 brsgm=sigsgm/sig
2287 brsig = sig
2288 nchrg = 1
2289 go to 3555
2290 endif
2291 go to 400
2292 endif
2293c
2294c
2295c meson + hyperon-bar -> K+ + N-bar
2296 if(((lb1.ge.-17.and.lb1.le.-14).and.(lb2.ge.3.and.lb2.le.5))
2297 & .OR.((lb2.ge.-17.and.lb2.le.-14)
2298 & .and.(lb1.ge.3.and.lb1.le.5)))then
2299 nchrg=-100
2300
2301C* first classify the reactions due to total charge.
2302 if((lb1.eq.-15.and.(lb2.eq.5.or.lb2.eq.27)).OR.
2303 & (lb2.eq.-15.and.(lb1.eq.5.or.lb1.eq.27))) then
2304 nchrg=-2
2305c ! D-(bar)
2306 bmass=1.232
2307 go to 110
2308 endif
2309 if( (lb1.eq.-15.and.(lb2.eq.0.or.lb2.eq.4.or.lb2.eq.26.or.
2310 & lb2.eq.28)).OR.(lb2.eq.-15.and.(lb1.eq.0.or.
2311 & lb1.eq.4.or.lb1.eq.26.or.lb1.eq.28)).OR.
2312 & ((lb1.eq.-14.or.lb1.eq.-16).and.(lb2.eq.5.or.lb2.eq.27)).OR.
2313 & ((lb2.eq.-14.or.lb2.eq.-16).and.(lb1.eq.5.or.lb1.eq.27)) )then
2314 nchrg=-1
2315c ! n-bar
2316 bmass=0.938
2317 go to 110
2318 endif
2319 if( (lb1.eq.-15.and.(lb2.eq.3.or.lb2.eq.25)).OR.
2320 & (lb2.eq.-15.and.(lb1.eq.3.or.lb1.eq.25)).OR.
2321 & (lb1.eq.-17.and.(lb2.eq.5.or.lb2.eq.27)).OR.
2322 & (lb2.eq.-17.and.(lb1.eq.5.or.lb1.eq.27)).OR.
2323 & ((lb1.eq.-14.or.lb1.eq.-16).and.(lb2.eq.0.or.lb2.eq.4
2324 & .or.lb2.eq.26.or.lb2.eq.28)).OR.
2325 & ((lb2.eq.-14.or.lb2.eq.-16).and.(lb1.eq.0.or.lb1.eq.4
2326 & .or.lb1.eq.26.or.lb1.eq.28)) )then
2327 nchrg=0
2328c ! p-bar
2329 bmass=0.938
2330 go to 110
2331 endif
2332 if( (lb1.eq.-17.and.(lb2.eq.0.or.lb2.eq.4.or.lb2.eq.26.or.
2333 & lb2.eq.28)).OR.(lb2.eq.-17.and.(lb1.eq.0.or.
2334 & lb1.eq.4.or.lb1.eq.26.or.lb1.eq.28)).OR.
2335 & ((lb1.eq.-14.or.lb1.eq.-16).and.(lb2.eq.3.or.lb2.eq.25)).OR.
2336 & ((lb2.eq.-14.or.lb2.eq.-16).and.(lb1.eq.3.or.lb1.eq.25)))then
2337 nchrg=1
2338c ! D++(bar)
2339 bmass=1.232
2340 endif
2341c
2342c 110 if(nchrg.ne.-100.and.srt.ge.(aka+bmass))then !! for elastic
2343 110 sig = 0.
2344c !! for elastic
2345 if(nchrg.ne.-100.and.srt.ge.(aka+bmass))then
2346cc110 if(nchrg.eq.-100.or.srt.lt.(aka+bmass)) go to 400
2347c ! PI + La(Si)-bar => K+ + N-bar reactions
2348 icase=4
2349cc pkaon=sqrt(((srt**2-(aka**2+bmass**2))/2./bmass)**2-aka**2)
2350 pkaon=sqrt(((srt**2-(aka**2+0.938**2))/2./0.938)**2-aka**2)
2351c ! lambda-bar + Pi
2352 if(lb1.eq.-14.or.lb2.eq.-14) then
2353 if(nchrg.ge.0) sigma0=akPlam(pkaon)
2354 if(nchrg.lt.0) sigma0=akNlam(pkaon)
2355c ! sigma-bar + pi
2356 else
2357c !K-p or K-D++
2358 if(nchrg.ge.0) sigma0=akPsgm(pkaon)
2359c !K-n or K-D-
2360 if(nchrg.lt.0) sigma0=akNsgm(pkaon)
2361 SIGMA0 = 1.5 * AKPSGM(PKAON) + AKNSGM(PKAON)
2362 endif
2363 sig=(srt**2-(aka+bmass)**2)*(srt**2-(aka-bmass)**2)/
2364 & (srt**2-(em1+em2)**2)/(srt**2-(em1-em2)**2)*sigma0
2365c ! K0barD++, K-D-
2366 if(nchrg.eq.-2.or.nchrg.eq.2) sig=2.*sig
2367C* the factor 2 comes from spin of delta, which is 3/2
2368C* detailed balance. copy from Page 423 of N.P. A614 1997
2369 IF (LB1 .EQ. -14 .OR. LB2 .EQ. -14) THEN
2370 SIG = 4.0 / 3.0 * SIG
2371 ELSE IF (NCHRG .EQ. -2 .OR. NCHRG .EQ. 2) THEN
2372 SIG = 8.0 / 9.0 * SIG
2373 ELSE
2374 SIG = 4.0 / 9.0 * SIG
2375 END IF
2376cc brel=0.
2377cc brsgm=0.
2378cc brsig = sig
2379cc if(sig.lt.1.e-7) go to 400
2380*-
2381 endif
2382c ! PI + La(Si)-bar => elastic included
2383 icase=4
2384 sigela = 10.
2385 sig = sig + sigela
2386 brel= sigela/sig
2387 brsgm=0.
2388 brsig = sig
2389*-
2390 go to 3555
2391 endif
2392
2393** MULTISTRANGE PARTICLE (Cas,Omega -bar) PRODUCTION - (NON)PERTURBATIVE
2394
2395* K-/K*0bar + La/Si --> cascade + pi/eta
2396 if( ((lb1.eq.21.or.lb1.eq.-30).and.(lb2.ge.14.and.lb2.le.17)).OR.
2397 & ((lb2.eq.21.or.lb2.eq.-30).and.(lb1.ge.14.and.lb1.le.17)) )then
2398 kp = 0
2399 go to 3455
2400 endif
2401c K+/K*0 + La/Si(bar) --> cascade-bar + pi/eta
2402 if( ((lb1.eq.23.or.lb1.eq.30).and.(lb2.le.-14.and.lb2.ge.-17)).OR.
2403 & ((lb2.eq.23.or.lb2.eq.30).and.(lb1.le.-14.and.lb1.ge.-17)) )then
2404 kp = 1
2405 go to 3455
2406 endif
2407* K-/K*0bar + cascade --> omega + pi
2408 if( ((lb1.eq.21.or.lb1.eq.-30).and.(lb2.eq.40.or.lb2.eq.41)).OR.
2409 & ((lb2.eq.21.or.lb2.eq.-30).and.(lb1.eq.40.or.lb1.eq.41)) )then
2410 kp = 0
2411 go to 3455
2412 endif
2413* K+/K*0 + cascade-bar --> omega-bar + pi
2414 if( ((lb1.eq.23.or.lb1.eq.30).and.(lb2.eq.-40.or.lb2.eq.-41)).OR.
2415 & ((lb2.eq.23.or.lb2.eq.30).and.(lb1.eq.-40.or.lb1.eq.-41)) )then
2416 kp = 1
2417 go to 3455
2418 endif
2419* Omega + Omega --> Di-Omega + photon(eta)
2420cc if( lb1.eq.45.and.lb2.eq.45 ) go to 3455
2421
2422c annhilation of cascade(bar), omega(bar)
2423 kp = 3
2424* K- + L/S <-- cascade(bar) + pi/eta
2425 if( (((lb1.ge.3.and.lb1.le.5).or.lb1.eq.0)
2426 & .and.(iabs(lb2).eq.40.or.iabs(lb2).eq.41))
2427 & .OR. (((lb2.ge.3.and.lb2.le.5).or.lb2.eq.0)
2428 & .and.(iabs(lb1).eq.40.or.iabs(lb1).eq.41)) )go to 3455
2429* K- + cascade(bar) <-- omega(bar) + pi
2430* if( (lb1.eq.0.and.iabs(lb2).eq.45)
2431* & .OR. (lb2.eq.0.and.iabs(lb1).eq.45) )go to 3455
2432 if( ((lb1.ge.3.and.lb1.le.5).and.iabs(lb2).eq.45)
2433 & .OR.((lb2.ge.3.and.lb2.le.5).and.iabs(lb1).eq.45) )go to 3455
2434c
2435
2436*** MULTISTRANGE PARTICLE PRODUCTION (END)
2437
2438c* K+ + La(Si) --> Meson + B
2439 IF (LB1.EQ.23 .AND. (LB2.GE.14.AND.LB2.LE.17)) GOTO 5699
2440 IF (LB2.EQ.23 .AND. (LB1.GE.14.AND.LB1.LE.17)) GOTO 5699
2441c* K- + La(Si)-bar --> Meson + B-bar
2442 IF (LB1.EQ.21 .AND. (LB2.GE.-17.AND.LB2.LE.-14)) GOTO 5699
2443 IF (LB2.EQ.21 .AND. (LB1.GE.-17.AND.LB1.LE.-14)) GOTO 5699
2444
2445c La/Si-bar + B --> pi + K+
2446 IF( (((LB1.eq.1.or.LB1.eq.2).or.(LB1.ge.6.and.LB1.le.13))
2447 & .AND.(LB2.GE.-17.AND.LB2.LE.-14)) .OR.
2448 & (((LB2.eq.1.or.LB2.eq.2).or.(LB2.ge.6.and.LB2.le.13))
2449 & .AND.(LB1.GE.-17.AND.LB1.LE.-14)) )go to 5999
2450c La/Si + B-bar --> pi + K-
2451 IF( (((LB1.eq.-1.or.LB1.eq.-2).or.(LB1.le.-6.and.LB1.ge.-13))
2452 & .AND.(LB2.GE.14.AND.LB2.LE.17)) .OR.
2453 & (((LB2.eq.-1.or.LB2.eq.-2).or.(LB2.le.-6.and.LB2.ge.-13))
2454 & .AND.(LB1.GE.14.AND.LB1.LE.17)) )go to 5999
2455*
2456*
2457* K(K*) + Kbar(K*bar) --> phi + pi(rho,omega), M + M (M=pi,rho,omega,eta)
2458 if(lb1.eq.21.and.lb2.eq.23) go to 8699
2459 if(lb2.eq.21.and.lb1.eq.23) go to 8699
2460 if(lb1.eq.30.and.lb2.eq.21) go to 8699
2461 if(lb2.eq.30.and.lb1.eq.21) go to 8699
2462 if(lb1.eq.-30.and.lb2.eq.23) go to 8699
2463 if(lb2.eq.-30.and.lb1.eq.23) go to 8699
2464 if(lb1.eq.-30.and.lb2.eq.30) go to 8699
2465 if(lb2.eq.-30.and.lb1.eq.30) go to 8699
2466c* (K,K*)-bar + rho(omega) --> phi +(K,K*)-bar, piK and elastic
2467 IF( ((lb1.eq.23.or.lb1.eq.21.or.iabs(lb1).eq.30) .and.
2468 & (lb2.ge.25.and.lb2.le.28)) .OR.
2469 & ((lb2.eq.23.or.lb2.eq.21.or.iabs(lb2).eq.30) .and.
2470 & (lb1.ge.25.and.lb1.le.28)) ) go to 8799
2471c
2472c* K*(-bar) + pi --> phi + (K,K*)-bar
2473 IF( (iabs(lb1).eq.30.and.(lb2.ge.3.and.lb2.le.5)) .OR.
2474 & (iabs(lb2).eq.30.and.(lb1.ge.3.and.lb1.le.5)) )go to 8799
2475*
2476c
2477c* phi + N --> pi+N(D), rho+N(D), K+ +La
2478c* phi + D --> pi+N(D), rho+N(D)
2479 IF( (lb1.eq.29 .and.(lb2.eq.1.or.lb2.eq.2.or.
2480 & (lb2.ge.6.and.lb2.le.9))) .OR.
2481 & (lb2.eq.29 .and.(lb1.eq.1.or.lb1.eq.2.or.
2482 & (lb1.ge.6.and.lb1.le.9))) )go to 7222
2483c
2484c* phi + (pi,rho,ome,K,K*-bar) --> K+K, K+K*, K*+K*, (pi,rho,omega)+(K,K*-bar)
2485 IF( (lb1.eq.29 .and.((lb2.ge.3.and.lb2.le.5).or.
2486 & (lb2.ge.21.and.lb2.le.28).or.iabs(lb2).eq.30)) .OR.
2487 & (lb2.eq.29 .and.((lb1.ge.3.and.lb1.le.5).or.
2488 & (lb1.ge.21.and.lb1.le.28).or.iabs(lb1).eq.30)) )THEN
2489 go to 7444
2490 endif
2491*
2492c
2493* La/Si, Cas, Om (bar)-(rho,omega,phi) elastic colln
2494* pion vs. La, Ca, Omega-(bar) elastic coll. treated in resp. subroutines
2495 if( ((iabs(lb1).ge.14.and.iabs(lb1).le.17).or.iabs(lb1).ge.40)
2496 & .and.((lb2.ge.25.and.lb2.le.29).or.lb2.eq.0) )go to 888
2497 if( ((iabs(lb2).ge.14.and.iabs(lb2).le.17).or.iabs(lb2).ge.40)
2498 & .and.((lb1.ge.25.and.lb1.le.29).or.lb1.eq.0) )go to 888
2499c
2500c K+/K* (N,R) OR K-/K*- (N,R)-bar elastic scatt
2501 if( ((lb1.eq.23.or.lb1.eq.30).and.(lb2.eq.1.or.lb2.eq.2.or.
2502 & (lb2.ge.6.and.lb2.le.13))) .OR.
2503 & ((lb2.eq.23.or.lb2.eq.30).and.(lb1.eq.1.or.lb1.eq.2.or.
2504 & (lb1.ge.6.and.lb1.le.13))) ) go to 888
2505 if( ((lb1.eq.21.or.lb1.eq.-30).and.(lb2.eq.-1.or.lb2.eq.-2.or.
2506 & (lb2.ge.-13.and.lb2.le.-6))) .OR.
2507 & ((lb2.eq.21.or.lb2.eq.-30).and.(lb1.eq.-1.or.lb1.eq.-2.or.
2508 & (lb1.ge.-13.and.lb1.le.-6))) ) go to 888
2509c
2510* L/S-baryon elastic collision
2511 If( ((lb1.ge.14.and.lb1.le.17).and.(lb2.ge.6.and.lb2.le.13))
2512 & .OR.((lb2.ge.14.and.lb2.le.17).and.(lb1.ge.6.and.lb1.le.13)) )
2513 & go to 7799
2514 If(((lb1.le.-14.and.lb1.ge.-17).and.(lb2.le.-6.and.lb2.ge.-13))
2515 &.OR.((lb2.le.-14.and.lb2.ge.-17).and.(lb1.le.-6.and.lb1.ge.-13)))
2516 & go to 7799
2517c
2518c skip other collns with perturbative particles or hyperon-bar
2519 if( iabs(lb1).ge.40 .or. iabs(lb2).ge.40
2520 & .or. (lb1.le.-14.and.lb1.ge.-17)
2521 & .or. (lb2.le.-14.and.lb2.ge.-17) )go to 400
2522c
2523c
2524* anti-baryon on baryon resonaces
2525 if((lb1.eq.-1.or.lb1.eq.-2.or.(lb1.ge.-13.and.lb1.le.-6))
2526 1 .and.(lb2.eq.1.or.lb2.eq.2.or.(lb2.ge.6.and.lb2.le.13))) then
2527 GOTO 2799
2528 else if((lb2.eq.-1.or.lb2.eq.-2.or.(lb2.ge.-13.and.lb2.le.-6))
2529 1 .and.(lb1.eq.1.or.lb1.eq.2.or.(lb1.ge.6.and.lb1.le.13))) then
2530 GOTO 2799
2531 END IF
2532c
2533clin-10/25/02 get rid of argument usage mismatch in newka():
2534 inewka=irun
2535c call newka(icase,irun,iseed,dt,nt,
2536clin-5/01/03 set iblock value in art1f.f, necessary for resonance studies:
2537c call newka(icase,inewka,iseed,dt,nt,
2538c & ictrl,i1,i2,srt,pcx,pcy,pcz)
2539 call newka(icase,inewka,iseed,dt,nt,
2540 & ictrl,i1,i2,srt,pcx,pcy,pcz,iblock)
2541
2542clin-10/25/02-end
2543 IF (ICTRL .EQ. 1) GOTO 400
2544c
2545* SEPARATE NUCLEON+NUCLEON( BARYON RESONANCE+ BARYON RESONANCE ELASTIC
2546* COLLISION), BARYON RESONANCE+NUCLEON AND BARYON-PION
2547* COLLISIONS INTO THREE PARTS TO CHECK IF THEY ARE GOING TO SCATTER,
2548* WE only allow L/S to COLLIDE elastically with a nucleon and meson
2549 if((iabs(lb1).ge.14.and.iabs(lb1).le.17).
2550 & or.(iabs(lb2).ge.14.and.iabs(lb2).le.17))go to 400
2551* IF PION+PION COLLISIONS GO TO 777
2552* if pion+eta, eta+eta to create kaons go to 777
2553 IF((lb1.ge.3.and.lb1.le.5).and.(lb2.ge.3.and.lb2.le.5))GO TO 777
2554 if(lb1.eq.0.and.(lb2.ge.3.and.lb2.le.5)) go to 777
2555 if(lb2.eq.0.and.(lb1.ge.3.and.lb1.le.5)) go to 777
2556 if(lb1.eq.0.and.lb2.eq.0)go to 777
2557* we assume that rho and omega behave the same way as pions in
2558* kaon production
2559* (1) rho(omega)+rho(omega)
2560 if( (lb1.ge.25.and.lb1.le.28).and.
2561 & (lb2.ge.25.and.lb2.le.28) )goto 777
2562* (2) rho(omega)+pion
2563 If((lb1.ge.25.and.lb1.le.28).and.(lb2.ge.3.and.lb2.le.5))go to 777
2564 If((lb2.ge.25.and.lb2.le.28).and.(lb1.ge.3.and.lb1.le.5))go to 777
2565* (3) rho(omega)+eta
2566 if((lb1.ge.25.and.lb1.le.28).and.lb2.eq.0)go to 777
2567 if((lb2.ge.25.and.lb2.le.28).and.lb1.eq.0)go to 777
2568c
2569* if kaon+pion collisions go to 889
2570 if((lb1.eq.23.or.lb1.eq.21).and.(lb2.ge.3.and.lb2.le.5))go to 889
2571 if((lb2.eq.23.or.lb2.eq.21).and.(lb1.ge.3.and.lb1.le.5))go to 889
2572c
2573clin-2/06/03 skip all other (K K* Kbar K*bar) channels:
2574* SKIP all other K and K* RESCATTERINGS
2575 If(iabs(lb1).eq.30.or.iabs(lb2).eq.30) go to 400
2576 If(lb1.eq.21.or.lb2.eq.21) go to 400
2577 If(lb1.eq.23.or.lb2.eq.23) go to 400
2578c
2579* IF PION+baryon COLLISION GO TO 3
2580 IF( (LB1.ge.3.and.LB1.le.5) .and.
2581 & (iabs(LB2).eq.1.or.iabs(LB2).eq.2.or.
2582 & (iabs(LB2).ge.6.and.iabs(LB2).le.13)) )GO TO 3
2583 IF( (LB2.ge.3.and.LB2.le.5) .and.
2584 & (iabs(LB1).eq.1.or.iabs(LB1).eq.2.or.
2585 & (iabs(LB1).ge.6.and.iabs(LB1).le.13)) )GO TO 3
2586c
2587* IF rho(omega)+NUCLEON (baryon resonance) COLLISION GO TO 33
2588 IF( (LB1.ge.25.and.LB1.le.28) .and.
2589 & (iabs(LB2).eq.1.or.iabs(LB2).eq.2.or.
2590 & (iabs(LB2).ge.6.and.iabs(LB2).le.13)) )GO TO 33
2591 IF( (LB2.ge.25.and.LB2.le.28) .and.
2592 & (iabs(LB1).eq.1.or.iabs(LB1).eq.2.or.
2593 & (iabs(LB1).ge.6.and.iabs(LB1).le.13)) )GO TO 33
2594c
2595* IF ETA+NUCLEON (baryon resonance) COLLISIONS GO TO 547
2596 IF( LB1.eq.0 .and.
2597 & (iabs(LB2).eq.1.or.iabs(LB2).eq.2.or.
2598 & (iabs(LB2).ge.6.and.iabs(LB2).le.13)) )GO TO 547
2599 IF( LB2.eq.0 .and.
2600 & (iabs(LB1).eq.1.or.iabs(LB1).eq.2.or.
2601 & (iabs(LB1).ge.6.and.iabs(LB1).le.13)) )GO TO 547
2602c
2603* IF NUCLEON+BARYON RESONANCE COLLISION GO TO 44
2604 IF((LB1.eq.1.or.lb1.eq.2).
2605 & AND.(LB2.GT.5.and.lb2.le.13))GOTO 44
2606 IF((LB2.eq.1.or.lb2.eq.2).
2607 & AND.(LB1.GT.5.and.lb1.le.13))GOTO 44
2608 IF((LB1.eq.-1.or.lb1.eq.-2).
2609 & AND.(LB2.LT.-5.and.lb2.ge.-13))GOTO 44
2610 IF((LB2.eq.-1.or.lb2.eq.-2).
2611 & AND.(LB1.LT.-5.and.lb1.ge.-13))GOTO 44
2612c
2613* IF NUCLEON+NUCLEON COLLISION GO TO 4
2614 IF((LB1.eq.1.or.lb1.eq.2).AND.(LB2.eq.1.or.lb2.eq.2))GOTO 4
2615 IF((LB1.eq.-1.or.lb1.eq.-2).AND.(LB2.eq.-1.or.lb2.eq.-2))GOTO 4
2616c
2617* IF BARYON RESONANCE+BARYON RESONANCE COLLISION GO TO 444
2618 IF((LB1.GT.5.and.lb1.le.13).AND.
2619 & (LB2.GT.5.and.lb2.le.13)) GOTO 444
2620 IF((LB1.LT.-5.and.lb1.ge.-13).AND.
2621 & (LB2.LT.-5.and.lb2.ge.-13)) GOTO 444
2622c
2623* if L/S+L/S or L/s+nucleon go to 400
2624* otherwise, develop a model for their collisions
2625 if((lb1.lt.3).and.(lb2.ge.14.and.lb2.le.17))goto 400
2626 if((lb2.lt.3).and.(lb1.ge.14.and.lb1.le.17))goto 400
2627 if((lb1.ge.14.and.lb1.le.17).and.
2628 & (lb2.ge.14.and.lb2.le.17))goto 400
2629c
2630* otherwise, go out of the loop
2631 go to 400
2632*
2633*
2634547 IF(LB1*LB2.EQ.0)THEN
2635* (1) FOR ETA+NUCLEON SYSTEM, we allow both elastic collision,
2636* i.e. N*(1535) formation and kaon production
2637* the total kaon production cross section is
2638* ASSUMED to be THE SAME AS PION+NUCLEON COLLISIONS
2639* (2) for eta+baryon resonance we only allow kaon production
2640 ece=(em1+em2+0.02)**2
2641 xkaon0=0.
2642 if(srt.ge.1.63.AND.SRT.LE.1.7)xkaon0=pnlka(srt)
2643 IF(SRT.GT.1.7)XKAON0=PNLKA(SRT)+pnska(srt)
2644cbz3/7/99 neutralk
2645 XKAON0 = 2.0 * XKAON0
2646cbz3/7/99 neutralk end
2647
2648* Here we negelect eta+n inelastic collisions other than the
2649* kaon production, therefore the total inelastic cross section
2650* xkaon equals to the xkaon0 (kaon production cross section)
2651 xkaon=xkaon0
2652* note here the xkaon is in unit of fm**2
2653 XETA=XN1535(I1,I2,0)
2654 If((iabs(LB(I1)).ge.6.and.iabs(LB(I1)).le.13).or.
2655 & (iabs(LB(I2)).ge.6.and.iabs(LB(I2)).le.13)) xeta=0.
2656 IF((XETA+xkaon).LE.1.e-06)GO TO 400
2657 DSE=SQRT((XETA+XKAON)/PI)
2658 DELTRE=DSE+0.1
2659 px1cm=pcx
2660 py1cm=pcy
2661 pz1cm=pcz
2662* CHECK IF N*(1535) resonance CAN BE FORMED
2663 CALL DISTCE(I1,I2,DELTRE,DSE,DT,ECE,SRT,IC,
2664 1 PCX,PCY,PCZ)
2665 IF(IC.EQ.-1) GO TO 400
2666 ekaon(4,iss)=ekaon(4,iss)+1
2667 IF(XKAON0/(XKAON+XETA).GT.RANART(NSEED))then
2668* kaon production, USE CREN TO CALCULATE THE MOMENTUM OF L/S K+
2669 CALL CREN(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK)
2670* kaon production
2671 IF(IBLOCK.EQ.7) then
2672 LPN=LPN+1
2673 elseIF(IBLOCK.EQ.-7) then
2674 endif
2675c
2676 em1=e(i1)
2677 em2=e(i2)
2678 GO TO 440
2679 endif
2680* N*(1535) FORMATION
2681 resona=1.
2682 GO TO 98
2683 ENDIF
2684*IF PION+NUCLEON (baryon resonance) COLLISION THEN
26853 CONTINUE
2686 px1cm=pcx
2687 py1cm=pcy
2688 pz1cm=pcz
2689* the total kaon production cross section for pion+baryon (resonance) is
2690* assumed to be the same as in pion+nucleon
2691 xkaon0=0.
2692 if(srt.ge.1.63.AND.SRT.LE.1.7)xkaon0=pnlka(srt)
2693 IF(SRT.GT.1.7)XKAON0=PNLKA(SRT)+pnska(srt)
2694 XKAON0 = 2.0 * XKAON0
2695c
2696c sp11/21/01 phi production: pi +N(D) -> phi + N(D)
2697 Xphi = 0.
2698 if( ( ((lb1.ge.1.and.lb1.le.2).or.
2699 & (lb1.ge.6.and.lb1.le.9))
2700 & .OR.((lb2.ge.1.and.lb2.le.2).or.
2701 & (lb2.ge.6.and.lb2.le.9)) )
2702 & .AND. srt.gt.1.958)
2703 & call pibphi(srt,lb1,lb2,em1,em2,Xphi,xphin)
2704c !! in fm^2 above
2705
2706* if a pion collide with a baryon resonance,
2707* we only allow kaon production AND the reabsorption
2708* processes: Delta+pion-->N+pion, N*+pion-->N+pion
2709* Later put in pion+baryon resonance elastic
2710* cross through forming higher resonances implicitly.
2711c If(em1.gt.1.or.em2.gt.1.)go to 31
2712 If((iabs(LB(I1)).ge.6.and.iabs(LB(I1)).le.13).or.
2713 & (iabs(LB(I2)).ge.6.and.iabs(LB(I2)).le.13)) go to 31
2714* For pion+nucleon collisions:
2715* using the experimental pion+nucleon inelastic cross section, we assume it
2716* is exhausted by the Delta+pion, Delta+rho and Delta+omega production
2717* and kaon production. In the following we first check whether
2718* inelastic pion+n collision can happen or not, then determine in
2719* crpn whether it is through pion production or through kaon production
2720* note that the xkaon0 is the kaon production cross section
2721* Note in particular that:
2722* xkaon in the following is the total pion+nucleon inelastic cross section
2723* note here the xkaon is in unit of fm**2, xnpi is also in unit of fm**2
2724* FOR PION+NUCLEON SYSTEM, THE MINIMUM S IS 1.2056 the minimum srt for
2725* elastic scattering, and it is 1.60 for pion production, 1.63 for LAMBDA+kaon
2726* production and 1.7 FOR SIGMA+KAON
2727* (EC = PION MASS+NUCLEON MASS+20MEV)**2
2728 EC=(em1+em2+0.02)**2
2729 xkaon=0.
2730 if(srt.gt.1.23)xkaon=(pionpp(srt)+PIPP1(SRT))/2.
2731* pion+nucleon elastic cross section is divided into two parts:
2732* (1) forming D(1232)+N*(1440) +N*(1535)
2733* (2) cross sections forming higher resonances are calculated as
2734* the difference between the total elastic and (1), this part is
2735* treated as direct process since we do not explicitLY include
2736* higher resonances.
2737* the following is the resonance formation cross sections.
2738*1. PION(+)+PROTON-->DELTA++,PION(-)+NEUTRON-->DELTA(-)
2739 IF( (LB1*LB2.EQ.5.OR.((LB1*LB2.EQ.6).AND.
2740 & (LB1.EQ.3.OR.LB2.EQ.3)))
2741 & .OR. (LB1*LB2.EQ.-3.OR.((LB1*LB2.EQ.-10).AND.
2742 & (LB1.EQ.5.OR.LB2.EQ.5))) )then
2743 XMAX=190.
2744 xmaxn=0
2745 xmaxn1=0
2746 xdirct=dirct1(srt)
2747 go to 678
2748 endif
2749*2. PION(-)+PROTON-->DELTA0,PION(+)+NEUTRON-->DELTA+
2750* or N*(+)(1440) or N*(+)(1535)
2751* note the factor 2/3 is from the isospin consideration and
2752* the factor 0.6 or 0.5 is the branching ratio for the resonance to decay
2753* into pion+nucleon
2754 IF( (LB1*LB2.EQ.3.OR.((LB1*LB2.EQ.10).AND.
2755 & (LB1.EQ.5.OR.LB2.EQ.5)))
2756 & .OR. (LB1*LB2.EQ.-5.OR.((LB1*LB2.EQ.-6).AND.
2757 & (LB1.EQ.3.OR.LB2.EQ.3))) )then
2758 XMAX=27.
2759 xmaxn=2./3.*25.*0.6
2760 xmaxn1=2./3.*40.*0.5
2761 xdirct=dirct2(srt)
2762 go to 678
2763 endif
2764*3. PION0+PROTON-->DELTA+,PION0+NEUTRON-->DELTA0, or N*(0)(1440) or N*(0)(1535)
2765 IF((LB1.EQ.4.OR.LB2.EQ.4).AND.
2766 & (iabs(LB1*LB2).EQ.4.OR.iabs(LB1*LB2).EQ.8))then
2767 XMAX=50.
2768 xmaxn=1./3.*25*0.6
2769 xmaxn1=1/3.*40.*0.5
2770 xdirct=dirct3(srt)
2771 go to 678
2772 endif
2773678 xnpin1=0
2774 xnpin=0
2775 XNPID=XNPI(I1,I2,1,XMAX)
2776 if(xmaxn1.ne.0)xnpin1=XNPI(i1,i2,2,XMAXN1)
2777 if(xmaxn.ne.0)XNPIN=XNPI(I1,I2,0,XMAXN)
2778* the following
2779 xres=xnpid+xnpin+xnpin1
2780 xnelas=xres+xdirct
2781 icheck=1
2782 go to 34
2783* For pion + baryon resonance the reabsorption
2784* cross section is calculated from the detailed balance
2785* using reab(i1,i2,srt,ictrl), ictrl=1, 2 and 3
2786* for pion, rho and omega + baryon resonance
278731 ec=(em1+em2+0.02)**2
2788 xreab=reab(i1,i2,srt,1)
2789
2790clin-12/02/00 to satisfy detailed balance, forbid N* absorptions:
2791 if((iabs(lb1).ge.10.and.iabs(lb1).le.13)
2792 1 .or.(iabs(lb2).ge.10.and.iabs(lb2).le.13)) XREAB = 0.
2793
2794 xkaon=xkaon0+xreab
2795* a constant of 10 mb IS USED FOR PION + N* RESONANCE,
2796 IF((iabs(LB1).GT.9.AND.iabs(LB1).LE.13) .OR.
2797 & (iabs(LB2).GT.9.AND.iabs(LB2).LE.13))THEN
2798 Xnelas=1.0
2799 ELSE
2800 XNELAS=DPION(EM1,EM2,LB1,LB2,SRT)
2801 ENDIF
2802 icheck=2
280334 IF((Xnelas+xkaon+Xphi).LE.0.000001)GO TO 400
2804 DS=SQRT((Xnelas+xkaon+Xphi)/PI)
2805csp09/20/01
2806c totcr = xnelas+xkaon
2807c if(srt .gt. 3.5)totcr = max1(totcr,3.)
2808c DS=SQRT(totcr/PI)
2809csp09/20/01 end
2810
2811 deltar=ds+0.1
2812 CALL DISTCE(I1,I2,DELTAR,DS,DT,EC,SRT,IC,
2813 1 PCX,PCY,PCZ)
2814 IF(IC.EQ.-1) GO TO 400
2815 ekaon(4,iss)=ekaon(4,iss)+1
2816c***
2817* check what kind of collision has happened
2818* (1) pion+baryon resonance
2819* if direct elastic process
2820 if(icheck.eq.2)then
2821c !!sp11/21/01
2822 if(xnelas/(xnelas+xkaon+Xphi).ge.RANART(NSEED))then
2823c call Crdir(PX1CM,PY1CM,PZ1CM,SRT,I1,I2)
2824 call Crdir(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK)
2825 go to 440
2826 else
2827* for inelastic process, go to 96 to check
2828* kaon production and pion reabsorption : pion+D(N*)-->pion+N
2829 go to 96
2830 endif
2831 endif
2832*(2) pion+n
2833* CHECK IF inELASTIC COLLISION IS POSSIBLE FOR PION+N COLLISIONS
2834clin-8/17/00 typo corrected, many other occurences:
2835c IF(XKAON/(XKAON+Xnelas).GT.RANART(NSEED))GO TO 95
2836 IF((XKAON+Xphi)/(XKAON+Xphi+Xnelas).GT.RANART(NSEED))GO TO 95
2837
2838* direct process
2839 if(xdirct/xnelas.ge.RANART(NSEED))then
2840c call Crdir(PX1CM,PY1CM,PZ1CM,SRT,I1,I2)
2841 call Crdir(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK)
2842 go to 440
2843 endif
2844* now resonance formation or direct process (higher resonances)
2845 IF( (LB1*LB2.EQ.5.OR.((LB1*LB2.EQ.6).AND.
2846 & (LB1.EQ.3.OR.LB2.EQ.3)))
2847 & .OR. (LB1*LB2.EQ.-3.OR.((LB1*LB2.EQ.-10).AND.
2848 & (LB1.EQ.5.OR.LB2.EQ.5))) )then
2849c
2850* ONLY DELTA RESONANCE IS POSSIBLE, go to 99
2851 GO TO 99
2852 else
2853* NOW BOTH DELTA AND N* RESORANCE ARE POSSIBLE
2854* DETERMINE THE RESORANT STATE BY USING THE MONTRE CARLO METHOD
2855 XX=(XNPIN+xnpin1)/xres
2856 IF(RANART(NSEED).LT.XX)THEN
2857* N* RESONANCE IS SELECTED
2858* decide N*(1440) or N*(1535) formation
2859 xx0=xnpin/(xnpin+xnpin1)
2860 if(RANART(NSEED).lt.xx0)then
2861 RESONA=0.
2862* N*(1440) formation
2863 GO TO 97
2864 else
2865* N*(1535) formation
2866 resona=1.
2867 GO TO 98
2868 endif
2869 ELSE
2870* DELTA RESONANCE IS SELECTED
2871 GO TO 99
2872 ENDIF
2873 ENDIF
287497 CONTINUE
2875 IF(RESONA.EQ.0.)THEN
2876*N*(1440) IS PRODUCED,WE DETERMINE THE CHARGE STATE OF THE PRODUCED N*
2877 I=I1
2878 IF(EM1.LT.0.6)I=I2
2879* (0.1) n+pion(+)-->N*(+)
2880 IF( (LB1*LB2.EQ.10.AND.(LB1.EQ.5.OR.LB2.EQ.5))
2881 & .OR.(LB1*LB2.EQ.-6.AND.(LB1.EQ.3.OR.LB2.EQ.3)) )THEN
2882 LB(I)=11
2883 go to 303
2884 ENDIF
2885* (0.2) p+pion(0)-->N*(+)
2886c IF(LB(I1)*LB(I2).EQ.4.AND.(LB(I1).EQ.1.OR.LB(I2).EQ.1))THEN
2887 IF(iabs(LB(I1)*LB(I2)).EQ.4.AND.
2888 & (LB(I1).EQ.4.OR.LB(I2).EQ.4))THEN
2889 LB(I)=11
2890 go to 303
2891 ENDIF
2892* (0.3) n+pion(0)-->N*(0)
2893c IF(LB(I1)*LB(I2).EQ.8.AND.(LB(I1).EQ.2.OR.LB(I2).EQ.2))THEN
2894 IF(iabs(LB(I1)*LB(I2)).EQ.8.AND.
2895 & (LB(I1).EQ.4.OR.LB(I2).EQ.4))THEN
2896 LB(I)=10
2897 go to 303
2898 ENDIF
2899* (0.4) p+pion(-)-->N*(0)
2900c IF(LB(I1)*LB(I2).EQ.3)THEN
2901 IF( (LB(I1)*LB(I2).EQ.3)
2902 & .OR.(LB(I1)*LB(I2).EQ.-5) )THEN
2903 LB(I)=10
2904 ENDIF
2905303 CALL DRESON(I1,I2)
2906 if(LB1.lt.0.or.LB2.lt.0) LB(I)=-LB(I)
2907 lres=lres+1
2908 GO TO 101
2909*COM: GO TO 101 TO CHANGE THE PHASE SPACE DENSITY OF THE NUCLEON
2910 ENDIF
291198 IF(RESONA.EQ.1.)THEN
2912*N*(1535) IS PRODUCED, WE DETERMINE THE CHARGE STATE OF THE PRODUCED N*
2913 I=I1
2914 IF(EM1.LT.0.6)I=I2
2915* note: this condition applies to both eta and pion
2916* (0.1) n+pion(+)-->N*(+)
2917c IF(LB1*LB2.EQ.10.AND.(LB1.EQ.2.OR.LB2.EQ.2))THEN
2918 IF( (LB1*LB2.EQ.10.AND.(LB1.EQ.5.OR.LB2.EQ.5))
2919 & .OR.(LB1*LB2.EQ.-6.AND.(LB1.EQ.3.OR.LB2.EQ.3)) )THEN
2920 LB(I)=13
2921 go to 304
2922 ENDIF
2923* (0.2) p+pion(0)-->N*(+)
2924c IF(LB(I1)*LB(I2).EQ.4.AND.(LB(I1).EQ.1.OR.LB(I2).EQ.1))THEN
2925 IF(iabs(LB(I1)*LB(I2)).EQ.4.AND.
2926 & (LB(I1).EQ.4.OR.LB(I2).EQ.4))THEN
2927 LB(I)=13
2928 go to 304
2929 ENDIF
2930* (0.3) n+pion(0)-->N*(0)
2931c IF(LB(I1)*LB(I2).EQ.8.AND.(LB(I1).EQ.2.OR.LB(I2).EQ.2))THEN
2932 IF(iabs(LB(I1)*LB(I2)).EQ.8.AND.
2933 & (LB(I1).EQ.4.OR.LB(I2).EQ.4))THEN
2934 LB(I)=12
2935 go to 304
2936 ENDIF
2937* (0.4) p+pion(-)-->N*(0)
2938c IF(LB(I1)*LB(I2).EQ.3)THEN
2939 IF( (LB(I1)*LB(I2).EQ.3)
2940 & .OR.(LB(I1)*LB(I2).EQ.-5) )THEN
2941 LB(I)=12
2942 go to 304
2943 endif
2944* (0.5) p+eta-->N*(+)(1535),n+eta-->N*(0)(1535)
2945 if(lb(i1)*lb(i2).eq.0)then
2946c if((lb(i1).eq.1).or.(lb(i2).eq.1))then
2947 if(iabs(lb(i1)).eq.1.or.iabs(lb(i2)).eq.1)then
2948 LB(I)=13
2949 go to 304
2950 ELSE
2951 LB(I)=12
2952 ENDIF
2953 endif
2954304 CALL DRESON(I1,I2)
2955 if(LB1.lt.0.or.LB2.lt.0) LB(I)=-LB(I)
2956 lres=lres+1
2957 GO TO 101
2958*COM: GO TO 101 TO CHANGE THE PHASE SPACE DENSITY OF THE NUCLEON
2959 ENDIF
2960*DELTA IS PRODUCED,IN THE FOLLOWING WE DETERMINE THE
2961*CHARGE STATE OF THE PRODUCED DELTA
296299 LRES=LRES+1
2963 I=I1
2964 IF(EM1.LE.0.6)I=I2
2965* (1) p+pion(+)-->DELTA(++)
2966c IF(LB(I1)*LB(I2).EQ.5)THEN
2967 IF( (LB(I1)*LB(I2).EQ.5)
2968 & .OR.(LB(I1)*LB(I2).EQ.-3) )THEN
2969 LB(I)=9
2970 go to 305
2971 ENDIF
2972* (2) p+pion(0)-->delta(+)
2973c IF(LB(I1)*LB(I2).EQ.4.AND.(LB(I1).EQ.1.OR.LB(I2).EQ.1))then
2974 IF(iabs(LB(I1)*LB(I2)).EQ.4.AND.(LB(I1).EQ.4.OR.LB(I2).EQ.4))then
2975 LB(I)=8
2976 go to 305
2977 ENDIF
2978* (3) n+pion(+)-->delta(+)
2979c IF(LB(I1)*LB(I2).EQ.10.AND.(LB(I1).EQ.2.OR.LB(I2).EQ.2))THEN
2980 IF( (LB(I1)*LB(I2).EQ.10.AND.(LB(I1).EQ.5.OR.LB(I2).EQ.5))
2981 & .OR.(LB(I1)*LB(I2).EQ.-6.AND.(LB(I1).EQ.3.OR.LB(I2).EQ.3)) )THEN
2982 LB(I)=8
2983 go to 305
2984 ENDIF
2985* (4) n+pion(0)-->delta(0)
2986c IF(LB(I1)*LB(I2).EQ.8.AND.(LB(I1).EQ.2.OR.LB(I2).EQ.2))THEN
2987 IF(iabs(LB(I1)*LB(I2)).EQ.8.AND.(LB(I1).EQ.4.OR.LB(I2).EQ.4))THEN
2988 LB(I)=7
2989 go to 305
2990 ENDIF
2991* (5) p+pion(-)-->delta(0)
2992c IF(LB(I1)*LB(I2).EQ.3)THEN
2993 IF( (LB(I1)*LB(I2).EQ.3)
2994 & .OR.(LB(I1)*LB(I2).EQ.-5) )THEN
2995 LB(I)=7
2996 go to 305
2997 ENDIF
2998* (6) n+pion(-)-->delta(-)
2999c IF(LB(I1)*LB(I2).EQ.6.AND.(LB(I1).EQ.2.OR.LB(I2).EQ.2))THEN
3000 IF( (LB(I1)*LB(I2).EQ.6.AND.(LB(I1).EQ.3.OR.LB(I2).EQ.3))
3001 & .OR.(LB(I1)*LB(I2).EQ.-10.AND.(LB(I1).EQ.5.OR.LB(I2).EQ.5)) )THEN
3002 LB(I)=6
3003 ENDIF
3004305 CALL DRESON(I1,I2)
3005 if(LB1.lt.0.or.LB2.lt.0) LB(I)=-LB(I)
3006 GO TO 101
3007
3008csp-11/08/01 K*
3009* FOR kaON+pion COLLISIONS, form K* (bar) or
3010c La/Si-bar + N <-- pi + K+
3011c La/Si + N-bar <-- pi + K-
3012c phi + K <-- pi + K
3013clin (rho,omega) + K* <-- pi + K
3014889 CONTINUE
3015 PX1CM=PCX
3016 PY1CM=PCY
3017 PZ1CM=PCZ
3018 EC=(em1+em2+0.02)**2
3019* the cross section is from C.M. Ko, PRC 23, 2760 (1981).
3020 spika=60./(1.+4.*(srt-0.895)**2/(0.05)**2)
3021c
3022cc if(lb(i1).eq.23.or.lb(i2).eq.23)then !! block K- + pi->La + B-bar
3023
3024 call Crkpla(PX1CM,PY1CM,PZ1CM,EC,SRT,spika,
3025 & emm1,emm2,lbp1,lbp2,I1,I2,icase,srhoks)
3026cc
3027c* only K* or K*bar formation
3028c else
3029c DSkn=SQRT(spika/PI/10.)
3030c dsknr=dskn+0.1
3031c CALL DISTCE(I1,I2,dsknr,DSkn,DT,EC,SRT,IC,
3032c 1 PX1CM,PY1CM,PZ1CM)
3033c IF(IC.EQ.-1) GO TO 400
3034c icase = 1
3035c endif
3036c
3037 if(icase .eq. 0) then
3038 iblock=0
3039 go to 400
3040 endif
3041
3042 if(icase .eq. 1)then
3043 call KSRESO(I1,I2)
3044clin-4/30/03 give non-zero iblock for resonance selections:
3045 iblock = 171
3046ctest off for resonance (phi, K*) studies:
3047c if(iabs(lb(i1)).eq.30) then
3048c write(17,112) 'ks',lb(i1),p(1,i1),p(2,i1),p(3,i1),e(i1),nt
3049c elseif(iabs(lb(i2)).eq.30) then
3050c write(17,112) 'ks',lb(i2),p(1,i2),p(2,i2),p(3,i2),e(i2),nt
3051c endif
3052c
3053 lres=lres+1
3054 go to 101
3055 elseif(icase .eq. 2)then
3056 iblock = 71
3057c
3058* La/Si (bar) formation
3059
3060 elseif(iabs(icase).eq.5)then
3061 iblock = 88
3062
3063 else
3064*
3065* phi formation
3066 iblock = 222
3067 endif
3068 LB(I1) = lbp1
3069 LB(I2) = lbp2
3070 E(I1) = emm1
3071 E(I2) = emm2
3072 em1=e(i1)
3073 em2=e(i2)
3074 ntag = 0
3075 go to 440
3076c
307733 continue
3078 em1=e(i1)
3079 em2=e(i2)
3080* (1) if rho or omega collide with a nucleon we allow both elastic
3081* scattering and kaon production to happen if collision conditions
3082* are satisfied.
3083* (2) if rho or omega collide with a baryon resonance we allow
3084* kaon production, pion reabsorption: rho(omega)+D(N*)-->pion+N
3085* and NO elastic scattering to happen
3086 xelstc=0
3087 if((lb1.ge.25.and.lb1.le.28).and.
3088 & (iabs(lb2).eq.1.or.iabs(lb2).eq.2))
3089 & xelstc=ERHON(EM1,EM2,LB1,LB2,SRT)
3090 if((lb2.ge.25.and.lb2.le.28).and.
3091 & (iabs(lb1).eq.1.or.iabs(lb1).eq.2))
3092 & xelstc=ERHON(EM1,EM2,LB1,LB2,SRT)
3093 ec=(em1+em2+0.02)**2
3094* the kaon production cross section is
3095 xkaon0=0
3096 if(srt.ge.1.63.AND.SRT.LE.1.7)xkaon0=pnlka(srt)
3097 IF(SRT.GT.1.7)XKAON0=PNLKA(SRT)+pnska(srt)
3098 if(xkaon0.lt.0)xkaon0=0
3099
3100cbz3/7/99 neutralk
3101 XKAON0 = 2.0 * XKAON0
3102cbz3/7/99 neutralk end
3103
3104* the total inelastic cross section for rho(omega)+N is
3105 xkaon=xkaon0
3106 ichann=0
3107* the total inelastic cross section for rho (omega)+D(N*) is
3108* xkaon=xkaon0+reab(**)
3109
3110c sp11/21/01 phi production: rho + N(D) -> phi + N(D)
3111 Xphi = 0.
3112 if( ( (((lb1.ge.1.and.lb1.le.2).or.
3113 & (lb1.ge.6.and.lb1.le.9))
3114 & .and.(lb2.ge.25.and.lb2.le.27))
3115 & .OR.(((lb2.ge.1.and.lb2.le.2).or.
3116 & (lb2.ge.6.and.lb2.le.9))
3117 & .and.(lb1.ge.25.and.lb1.le.27)) ).AND. srt.gt.1.958)
3118 & call pibphi(srt,lb1,lb2,em1,em2,Xphi,xphin)
3119c !! in fm^2 above
3120c
3121 if((iabs(lb1).ge.6.and.lb2.ge.25).or.
3122 & (lb1.ge.25.and.iabs(lb2).ge.6))then
3123 ichann=1
3124 ictrl=2
3125 if(lb1.eq.28.or.lb2.eq.28)ictrl=3
3126 xreab=reab(i1,i2,srt,ictrl)
3127
3128clin-12/02/00 to satisfy detailed balance, forbid N* absorptions:
3129 if((iabs(lb1).ge.10.and.iabs(lb1).le.13)
3130 1 .or.(iabs(lb2).ge.10.and.iabs(lb2).le.13)) XREAB = 0.
3131
3132 if(xreab.lt.0)xreab=1.E-06
3133 xkaon=xkaon0+xreab
3134 XELSTC=1.0
3135 endif
3136 DS=SQRT((XKAON+Xphi+xelstc)/PI)
3137c
3138csp09/20/01
3139c totcr = xelstc+xkaon
3140c if(srt .gt. 3.5)totcr = max1(totcr,3.)
3141c DS=SQRT(totcr/PI)
3142csp09/20/01 end
3143c
3144 DELTAR=DS+0.1
3145 px1cm=pcx
3146 py1cm=pcy
3147 pz1cm=pcz
3148* CHECK IF the collision can happen
3149 CALL DISTCE(I1,I2,DELTAR,DS,DT,EC,SRT,IC,
3150 1 PCX,PCY,PCZ)
3151 IF(IC.EQ.-1) GO TO 400
3152 ekaon(4,iss)=ekaon(4,iss)+1
3153c*
3154* NOW rho(omega)+N or D(N*) COLLISION IS POSSIBLE
3155* (1) check elastic collision
3156 if(xelstc/(xelstc+xkaon+Xphi).gt.RANART(NSEED))then
3157c call crdir(px1CM,py1CM,pz1CM,srt,I1,i2)
3158 call crdir(px1CM,py1CM,pz1CM,srt,I1,i2,IBLOCK)
3159 go to 440
3160 endif
3161* (2) check pion absorption or kaon production
3162 CALL CRRD(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3163 1 IBLOCK,xkaon0,xkaon,Xphi,xphin)
3164
3165* kaon production
3166csp05/16/01
3167 IF(IBLOCK.EQ.7) then
3168 LPN=LPN+1
3169 elseIF(IBLOCK.EQ.-7) then
3170 endif
3171csp05/16/01 end
3172* rho obsorption
3173 if(iblock.eq.81) lrhor=lrhor+1
3174* omega obsorption
3175 if(iblock.eq.82) lomgar=lomgar+1
3176 em1=e(i1)
3177 em2=e(i2)
3178 GO TO 440
3179* for pion+n now using the subroutine crpn to change
3180* the particle label and set the new momentum of L/S+K final state
318195 continue
3182* NOW PION+N INELASTIC COLLISION IS POSSIBLE
3183* check pion production or kaon production
3184 CALL CRPN(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3185 1 IBLOCK,xkaon0,xkaon,Xphi,xphin)
3186
3187* kaon production
3188csp05/16/01
3189 IF(IBLOCK.EQ.7) then
3190 LPN=LPN+1
3191 elseIF(IBLOCK.EQ.-7) then
3192 endif
3193csp05/16/01 end
3194* pion production
3195 if(iblock.eq.77) lpd=lpd+1
3196* rho production
3197 if(iblock.eq.78) lrho=lrho+1
3198* omega production
3199 if(iblock.eq.79) lomega=lomega+1
3200 em1=e(i1)
3201 em2=e(i2)
3202 GO TO 440
3203* for pion+D(N*) now using the subroutine crpd to
3204* (1) check kaon production or pion reabsorption
3205* (2) change the particle label and set the new
3206* momentum of L/S+K final state
320796 continue
3208 CALL CRPD(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3209 1 IBLOCK,xkaon0,xkaon,Xphi,xphin)
3210
3211* kaon production
3212csp05/16/01
3213 IF(IBLOCK.EQ.7) then
3214 LPN=LPN+1
3215 elseIF(IBLOCK.EQ.-7) then
3216 endif
3217csp05/16/01 end
3218* pion obserption
3219 if(iblock.eq.80) lpdr=lpdr+1
3220 em1=e(i1)
3221 em2=e(i2)
3222 GO TO 440
3223* CALCULATE KAON PRODUCTION PROBABILITY FROM PION + N COLLISIONS
3224C IF(SRT.GT.1.615)THEN
3225C CALL PKAON(SRT,XXp,PK)
3226C TKAON(7)=TKAON(7)+PK
3227C EKAON(7,ISS)=EKAON(7,ISS)+1
3228c CALL KSPEC1(SRT,PK)
3229C call LK(3,srt,iseed,pk)
3230C ENDIF
3231* negelecting the pauli blocking at high energies
3232
3233101 continue
3234 IF(E(I2).EQ.0.)GO TO 600
3235 IF(E(I1).EQ.0.)GO TO 800
3236* IF NUCLEON+BARYON RESONANCE COLLISIONS
323744 CONTINUE
3238* CALCULATE THE TOTAL CROSS SECTION OF NUCLEON+ BARYON RESONANCE COLLISION
3239* WE ASSUME THAT THE ELASTIC CROSS SECTION IS THE SAME AS NUCLEON+NUCLEON
3240* COM: WE USE THE PARAMETERISATION BY CUGNON FOR LOW ENERGIES
3241* AND THE PARAMETERIZATIONS FROM CERN DATA BOOK FOR HIGHER
3242* ENERGIES. THE CUTOFF FOR THE TOTAL CROSS SECTION IS 55 MB
3243 cutoff=em1+em2+0.02
3244 IF(SRT.LE.CUTOFF)GO TO 400
3245 IF(SRT.GT.2.245)THEN
3246 SIGNN=PP2(SRT)
3247 ELSE
3248 SIGNN = 35.0 / (1. + (SRT - CUTOFF) * 100.0) + 20.0
3249 ENDIF
3250 call XND(pcx,pcy,pcz,srt,I1,I2,xinel,
3251 & sigk,xsk1,xsk2,xsk3,xsk4,xsk5)
3252 sig=signn+xinel
3253* For nucleon+baryon resonance collision, the minimum cms**2 energy is
3254 EC=(EM1+EM2+0.02)**2
3255* CHECK THE DISTENCE BETWEEN THE TWO PARTICLES
3256 PX1CM=PCX
3257 PY1CM=PCY
3258 PZ1CM=PCZ
3259
3260clin-6/2008 Deuteron production:
3261 ianti=0
3262 if(lb(i1).lt.0 .and. lb(i2).lt.0) ianti=1
3263 call sbbdm(srt,sdprod,ianti,lbm,xmm,pfinal)
3264 sig=sig+sdprod
3265clin-6/2008 perturbative treatment of deuterons:
3266 ipdflag=0
3267 if(idpert.eq.1) then
3268 ipert1=1
3269 sigr0=sig
3270 dspert=sqrt(sigr0/pi/10.)
3271 dsrpert=dspert+0.1
3272 CALL DISTCE(I1,I2,dsrpert,dspert,DT,EC,SRT,IC,
3273 1 PX1CM,PY1CM,PZ1CM)
3274 IF(IC.EQ.-1) GO TO 363
3275 signn0=0.
3276 CALL CRND(IRUN,PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3277 & IBLOCK,SIGNN0,SIGr0,sigk,xsk1,xsk2,xsk3,xsk4,xsk5,NT,ipert1)
3278c & IBLOCK,SIGNN,SIG,sigk,xsk1,xsk2,xsk3,xsk4,xsk5)
3279 ipdflag=1
3280 363 continue
3281 ipert1=0
3282 endif
3283 if(idpert.eq.2) ipert1=1
3284c
3285 DS=SQRT(SIG/(10.*PI))
3286 DELTAR=DS+0.1
3287 CALL DISTCE(I1,I2,DELTAR,DS,DT,EC,SRT,IC,
3288 1 PX1CM,PY1CM,PZ1CM)
3289c IF(IC.EQ.-1)GO TO 400
3290 IF(IC.EQ.-1) then
3291 if(ipdflag.eq.1) iblock=501
3292 GO TO 400
3293 endif
3294
afe6642c 3295c print *,"ISS (3294) is ",iss
0119ef9a 3296 ekaon(3,iss)=ekaon(3,iss)+1
3297* CALCULATE KAON PRODUCTION PROBABILITY FROM NUCLEON + BARYON RESONANCE
3298* COLLISIONS
3299 go to 361
3300
3301* CHECK WHAT KIND OF COLLISION HAS HAPPENED
3302 361 continue
3303 CALL CRND(IRUN,PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3304 & IBLOCK,SIGNN,SIG,sigk,xsk1,xsk2,xsk3,xsk4,xsk5,NT,ipert1)
3305c & IBLOCK,SIGNN,SIG,sigk,xsk1,xsk2,xsk3,xsk4,xsk5)
3306 IF(iblock.eq.0.and.ipdflag.eq.1) iblock=501
3307 IF(IBLOCK.EQ.11)THEN
3308 LNDK=LNDK+1
3309 GO TO 400
3310c elseIF(IBLOCK.EQ.-11) then
3311 elseIF(IBLOCK.EQ.-11.or.iblock.eq.501) then
3312 GO TO 400
3313 ENDIF
3314 if(iblock .eq. 222)then
3315c !! sp12/17/01
3316 GO TO 400
3317 ENDIF
3318 em1=e(i1)
3319 em2=e(i2)
3320 GO TO 440
3321* IF NUCLEON+NUCLEON OR BARYON RESONANCE+BARYON RESONANCE COLLISIONS
33224 CONTINUE
3323* PREPARE THE EALSTIC CROSS SECTION FOR BARYON+BARYON COLLISIONS
3324* COM: WE USE THE PARAMETERISATION BY CUGNON FOR SRT LEQ 2.0 GEV
3325* AND THE PARAMETERIZATIONS FROM CERN DATA BOOK FOR HIGHER
3326* ENERGIES. THE CUTOFF FOR THE TOTAL CROSS SECTION IS 55 MB
3327* WITH LOW-ENERGY-CUTOFF
3328 CUTOFF=em1+em2+0.14
3329* AT HIGH ENERGIES THE ISOSPIN DEPENDENCE IS NEGLIGIBLE
3330* THE TOTAL CROSS SECTION IS TAKEN AS THAT OF THE PP
3331* ABOVE E_KIN=800 MEV, WE USE THE ISOSPIN INDEPENDNET XSECTION
3332 IF(SRT.GT.2.245)THEN
3333 SIG=ppt(srt)
3334 SIGNN=SIG-PP1(SRT)
3335 ELSE
3336* AT LOW ENERGIES THE ISOSPIN DEPENDENCE FOR NN COLLISION IS STRONG
3337 SIG=XPP(SRT)
3338 IF(ZET(LB(I1))*ZET(LB(I2)).LE.0)SIG=XNP(SRT)
3339 IF(ZET(LB(I1))*ZET(LB(I2)).GT.0)SIG=XPP(SRT)
3340 IF(ZET(LB(I1)).EQ.0.
3341 & AND.ZET(LB(I2)).EQ.0)SIG=XPP(SRT)
3342 if((lb(i1).eq.-1.and.lb(i2).eq.-2) .or.
3343 & (lb(i2).eq.-1.and.lb(i1).eq.-2))sig=xnp(srt)
3344* WITH LOW-ENERGY-CUTOFF
3345 IF (SRT .LT. 1.897) THEN
3346 SIGNN = SIG
3347 ELSE
3348 SIGNN = 35.0 / (1. + (SRT - 1.897) * 100.0) + 20.0
3349 ENDIF
3350 ENDIF
3351 PX1CM=PCX
3352 PY1CM=PCY
3353 PZ1CM=PCZ
3354clin-5/2008 Deuteron production cross sections were not included
3355c in the previous parameterized inelastic cross section of NN collisions
3356c (SIGinel=SIG-SIGNN), so they are added here:
3357 ianti=0
3358 if(lb(i1).lt.0 .and. lb(i2).lt.0) ianti=1
3359 call sbbdm(srt,sdprod,ianti,lbm,xmm,pfinal)
3360 sig=sig+sdprod
3361c
3362clin-5/2008 perturbative treatment of deuterons:
3363 ipdflag=0
3364 if(idpert.eq.1) then
3365c For idpert=1: ipert1=1 means we will first treat deuteron perturbatively,
3366c then we set ipert1=0 to treat regular NN or NbarNbar collisions including
3367c the regular deuteron productions.
3368c ipdflag=1 means perturbative deuterons are produced here:
3369 ipert1=1
3370 EC=2.012**2
3371c Use the same cross section for NN/NNBAR collisions
3372c to trigger perturbative production
3373 sigr0=sig
3374c One can also trigger with X*sbbdm() so the weight will not be too small;
3375c but make sure to limit the maximum trigger Xsec:
3376c sigr0=sdprod*25.
3377c if(sigr0.ge.100.) sigr0=100.
3378 dspert=sqrt(sigr0/pi/10.)
3379 dsrpert=dspert+0.1
3380 CALL DISTCE(I1,I2,dsrpert,dspert,DT,EC,SRT,IC,
3381 1 PX1CM,PY1CM,PZ1CM)
3382 IF(IC.EQ.-1) GO TO 365
3383 signn0=0.
3384 CALL CRNN(IRUN,PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK,
3385 1 NTAG,signn0,sigr0,NT,ipert1)
3386 ipdflag=1
3387 365 continue
3388 ipert1=0
3389 endif
3390 if(idpert.eq.2) ipert1=1
3391c
3392clin-5/2008 in case perturbative deuterons are produced for idpert=1:
3393c IF(SIGNN.LE.0)GO TO 400
3394 IF(SIGNN.LE.0) then
3395 if(ipdflag.eq.1) iblock=501
3396 GO TO 400
3397 endif
3398c
3399 EC=3.59709
3400 ds=sqrt(sig/pi/10.)
3401 dsr=ds+0.1
3402 IF((E(I1).GE.1.).AND.(e(I2).GE.1.))EC=4.75
3403 CALL DISTCE(I1,I2,dsr,ds,DT,EC,SRT,IC,
3404 1 PX1CM,PY1CM,PZ1CM)
3405clin-5/2008 in case perturbative deuterons are produced above:
3406c IF(IC.EQ.-1) GO TO 400
3407 IF(IC.EQ.-1) then
3408 if(ipdflag.eq.1) iblock=501
3409 GO TO 400
3410 endif
3411c
3412* CALCULATE KAON PRODUCTION PROBABILITY FROM NUCLEON+NUCLEON OR
3413* RESONANCE+RESONANCE COLLISIONS
3414 go to 362
3415
3416C CHECK WHAT KIND OF COLLISION HAS HAPPENED
3417 362 ekaon(1,iss)=ekaon(1,iss)+1
3418 CALL CRNN(IRUN,PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK,
3419 1 NTAG,SIGNN,SIG,NT,ipert1)
3420clin-5/2008 give iblock # in case pert deuterons are produced for idpert=1:
3421 IF(iblock.eq.0.and.ipdflag.eq.1) iblock=501
3422clin-5/2008 add iblock # for deuteron formation:
3423c IF(IBLOCK.EQ.4.OR.IBLOCK.Eq.9.or.iblock.ge.44.OR.IBLOCK.EQ.-9
3424c & .or.iblock.eq.222)THEN
3425 IF(IBLOCK.EQ.4.OR.IBLOCK.Eq.9.or.iblock.ge.44.OR.IBLOCK.EQ.-9
3426 & .or.iblock.eq.222.or.iblock.eq.501)THEN
3427c
3428c !! sp12/17/01 above
3429* momentum of the three particles in the final state have been calculated
3430* in the crnn, go out of the loop
3431 LCOLL=LCOLL+1
3432 if(iblock.eq.4)then
3433 LDIRT=LDIRT+1
3434 elseif(iblock.eq.44)then
3435 LDdrho=LDdrho+1
3436 elseif(iblock.eq.45)then
3437 Lnnrho=Lnnrho+1
3438 elseif(iblock.eq.46)then
3439 Lnnom=Lnnom+1
3440 elseif(iblock .eq. 222)then
3441 elseIF(IBLOCK.EQ.9) then
3442 LNNK=LNNK+1
3443 elseIF(IBLOCK.EQ.-9) then
3444 endif
3445 GO TO 400
3446 ENDIF
3447
3448 em1=e(i1)
3449 em2=e(i2)
3450 GO TO 440
3451clin-8/2008 B+B->Deuteron+Meson over
3452c
3453clin-8/2008 Deuteron+Meson->B+B collisions:
3454 505 continue
3455 ianti=0
3456 if(lb(i1).lt.0 .or. lb(i2).lt.0) ianti=1
3457 call sdmbb(SRT,sdm,ianti)
3458 PX1CM=PCX
3459 PY1CM=PCY
3460 PZ1CM=PCZ
3461c minimum srt**2, note a 2.012GeV lower cutoff is used in N+N->Deuteron+pi:
3462 EC=2.012**2
3463 ds=sqrt(sdm/31.4)
3464 dsr=ds+0.1
3465 CALL DISTCE(I1,I2,dsr,ds,DT,EC,SRT,IC,PX1CM,PY1CM,PZ1CM)
3466 IF(IC.EQ.-1) GO TO 400
3467 CALL crdmbb(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK,
3468 1 NTAG,sdm,NT,ianti)
3469 LCOLL=LCOLL+1
3470 GO TO 400
3471clin-8/2008 Deuteron+Meson->B+B collisions over
3472c
3473clin-9/2008 Deuteron+Baryon elastic collisions:
3474 506 continue
3475 ianti=0
3476 if(lb(i1).lt.0 .or. lb(i2).lt.0) ianti=1
3477 call sdbelastic(SRT,sdb)
3478 PX1CM=PCX
3479 PY1CM=PCY
3480 PZ1CM=PCZ
3481c minimum srt**2, note a 2.012GeV lower cutoff is used in N+N->Deuteron+pi:
3482 EC=2.012**2
3483 ds=sqrt(sdb/31.4)
3484 dsr=ds+0.1
3485 CALL DISTCE(I1,I2,dsr,ds,DT,EC,SRT,IC,PX1CM,PY1CM,PZ1CM)
3486 IF(IC.EQ.-1) GO TO 400
3487 CALL crdbel(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK,
3488 1 NTAG,sdb,NT,ianti)
3489 LCOLL=LCOLL+1
3490 GO TO 400
3491clin-9/2008 Deuteron+Baryon elastic collisions over
3492c
3493* IF BARYON RESONANCE+BARYON RESONANCE COLLISIONS
3494 444 CONTINUE
3495* PREPARE THE EALSTIC CROSS SECTION FOR BARYON+BARYON COLLISIONS
3496 CUTOFF=em1+em2+0.02
3497* AT HIGH ENERGIES THE ISOSPIN DEPENDENCE IS NEGLIGIBLE
3498* THE TOTAL CROSS SECTION IS TAKEN AS THAT OF THE PP
3499 IF(SRT.LE.CUTOFF)GO TO 400
3500 IF(SRT.GT.2.245)THEN
3501 SIGNN=PP2(SRT)
3502 ELSE
3503 SIGNN = 35.0 / (1. + (SRT - CUTOFF) * 100.0) + 20.0
3504 ENDIF
3505 IF(SIGNN.LE.0)GO TO 400
3506 CALL XDDIN(PCX,PCY,PCZ,SRT,I1,I2,
3507 &XINEL,SIGK,XSK1,XSK2,XSK3,XSK4,XSK5)
3508 SIG=SIGNN+XINEL
3509 EC=(EM1+EM2+0.02)**2
3510 PX1CM=PCX
3511 PY1CM=PCY
3512 PZ1CM=PCZ
3513
3514clin-6/2008 Deuteron production:
3515 ianti=0
3516 if(lb(i1).lt.0 .and. lb(i2).lt.0) ianti=1
3517 call sbbdm(srt,sdprod,ianti,lbm,xmm,pfinal)
3518 sig=sig+sdprod
3519clin-6/2008 perturbative treatment of deuterons:
3520 ipdflag=0
3521 if(idpert.eq.1) then
3522 ipert1=1
3523 sigr0=sig
3524 dspert=sqrt(sigr0/pi/10.)
3525 dsrpert=dspert+0.1
3526 CALL DISTCE(I1,I2,dsrpert,dspert,DT,EC,SRT,IC,
3527 1 PX1CM,PY1CM,PZ1CM)
3528 IF(IC.EQ.-1) GO TO 367
3529 signn0=0.
3530 CALL CRDD(IRUN,PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3531 1 IBLOCK,NTAG,SIGNN0,SIGr0,NT,ipert1)
3532c 1 IBLOCK,NTAG,SIGNN,SIG)
3533 ipdflag=1
3534 367 continue
3535 ipert1=0
3536 endif
3537 if(idpert.eq.2) ipert1=1
3538c
3539 ds=sqrt(sig/31.4)
3540 dsr=ds+0.1
3541 CALL DISTCE(I1,I2,dsr,ds,DT,EC,SRT,IC,
3542 1 PX1CM,PY1CM,PZ1CM)
3543c IF(IC.EQ.-1) GO TO 400
3544 IF(IC.EQ.-1) then
3545 if(ipdflag.eq.1) iblock=501
3546 GO TO 400
3547 endif
3548
3549* CALCULATE KAON PRODUCTION PROBABILITY FROM NUCLEON+NUCLEON OR
3550* RESONANCE+RESONANCE COLLISIONS
3551 go to 364
3552
3553C CHECK WHAT KIND OF COLLISION HAS HAPPENED
3554364 ekaon(2,iss)=ekaon(2,iss)+1
3555* for resonance+resonance
3556clin-6/2008:
3557 CALL CRDD(IRUN,PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3558 1 IBLOCK,NTAG,SIGNN,SIG,NT,ipert1)
3559c 1 IBLOCK,NTAG,SIGNN,SIG)
3560 IF(iblock.eq.0.and.ipdflag.eq.1) iblock=501
3561c
3562 IF(iabs(IBLOCK).EQ.10)THEN
3563* momentum of the three particles in the final state have been calculated
3564* in the crnn, go out of the loop
3565 LCOLL=LCOLL+1
3566 IF(IBLOCK.EQ.10)THEN
3567 LDDK=LDDK+1
3568 elseIF(IBLOCK.EQ.-10) then
3569 endif
3570 GO TO 400
3571 ENDIF
3572clin-6/2008
3573c if(iblock .eq. 222)then
3574 if(iblock .eq. 222.or.iblock.eq.501)then
3575c !! sp12/17/01
3576 GO TO 400
3577 ENDIF
3578 em1=e(i1)
3579 em2=e(i2)
3580 GO TO 440
3581* FOR PION+PION,pion+eta, eta+eta and rho(omega)+pion(rho,omega) or eta
3582777 CONTINUE
3583 PX1CM=PCX
3584 PY1CM=PCY
3585 PZ1CM=PCZ
3586* energy thresh for collisions
3587 ec0=em1+em2+0.02
3588 IF(SRT.LE.ec0)GO TO 400
3589 ec=(em1+em2+0.02)**2
3590* we negelect the elastic collision between mesons except that betwen
3591* two pions because of the lack of information about these collisions
3592* However, we do let them to collide inelastically to produce kaons
3593clin-8/15/02 ppel=1.e-09
3594 ppel=20.
3595 ipp=1
3596 if(lb1.lt.3.or.lb1.gt.5.or.lb2.lt.3.or.lb2.gt.5)go to 778
3597 CALL PPXS(LB1,LB2,SRT,PPSIG,spprho,IPP)
3598 ppel=ppsig
3599778 ppink=pipik(srt)
3600
3601* pi+eta and eta+eta are assumed to be the same as pipik( for pi+pi -> K+K-)
3602* estimated from Ko's paper:
3603 ppink = 2.0 * ppink
3604 if(lb1.ge.25.and.lb2.ge.25) ppink=rrkk
3605
3606clin-2/13/03 include omega the same as rho, eta the same as pi:
3607c if(((lb1.ge.3.and.lb1.le.5).and.(lb2.ge.25.and.lb2.le.27))
3608c 1 .or.((lb2.ge.3.and.lb2.le.5).and.(lb1.ge.25.and.lb1.le.27)))
3609 if( ( (lb1.eq.0.or.(lb1.ge.3.and.lb1.le.5))
3610 1 .and.(lb2.ge.25.and.lb2.le.28))
3611 2 .or. ( (lb2.eq.0.or.(lb2.ge.3.and.lb2.le.5))
3612 3 .and.(lb1.ge.25.and.lb1.le.28))) then
3613 ppink=0.
3614 if(srt.ge.(aka+aks)) ppink = prkk
3615 endif
3616
3617c pi pi <-> rho rho:
3618 call spprr(lb1,lb2,srt)
3619clin-4/03/02 pi pi <-> eta eta:
3620 call sppee(lb1,lb2,srt)
3621clin-4/03/02 pi pi <-> pi eta:
3622 call spppe(lb1,lb2,srt)
3623clin-4/03/02 rho pi <-> rho eta:
3624 call srpre(lb1,lb2,srt)
3625clin-4/03/02 omega pi <-> omega eta:
3626 call sopoe(lb1,lb2,srt)
3627clin-4/03/02 rho rho <-> eta eta:
3628 call srree(lb1,lb2,srt)
3629
3630 ppinnb=0.
3631 if(srt.gt.thresh(1)) then
3632 call getnst(srt)
3633 if(lb1.ge.3.and.lb1.le.5.and.lb2.ge.3.and.lb2.le.5) then
3634 ppinnb=ppbbar(srt)
3635 elseif((lb1.ge.3.and.lb1.le.5.and.lb2.ge.25.and.lb2.le.27)
3636 1 .or.(lb2.ge.3.and.lb2.le.5.and.lb1.ge.25.and.lb1.le.27)) then
3637 ppinnb=prbbar(srt)
3638 elseif(lb1.ge.25.and.lb1.le.27
3639 1 .and.lb2.ge.25.and.lb2.le.27) then
3640 ppinnb=rrbbar(srt)
3641 elseif((lb1.ge.3.and.lb1.le.5.and.lb2.eq.28)
3642 1 .or.(lb2.ge.3.and.lb2.le.5.and.lb1.eq.28)) then
3643 ppinnb=pobbar(srt)
3644 elseif((lb1.ge.25.and.lb1.le.27.and.lb2.eq.28)
3645 1 .or.(lb2.ge.25.and.lb2.le.27.and.lb1.eq.28)) then
3646 ppinnb=robbar(srt)
3647 elseif(lb1.eq.28.and.lb2.eq.28) then
3648 ppinnb=oobbar(srt)
3649 else
3650 if(lb1.ne.0.and.lb2.ne.0)
3651 1 write(6,*) 'missed MM lb1,lb2=',lb1,lb2
3652 endif
3653 endif
3654 ppin=ppink+ppinnb+pprr+ppee+pppe+rpre+xopoe+rree
3655
3656* check if a collision can happen
3657 if((ppel+ppin).le.0.01)go to 400
3658 DSPP=SQRT((ppel+ppin)/31.4)
3659 dsppr=dspp+0.1
3660 CALL DISTCE(I1,I2,dsppr,DSPP,DT,EC,SRT,IC,
3661 1 PX1CM,PY1CM,PZ1CM)
3662 IF(IC.EQ.-1) GO TO 400
3663 if(ppel.eq.0)go to 400
3664* the collision can happen
3665* check what kind collision has happened
afe6642c 3666c print *,"ISS (3665) is ",iss
0119ef9a 3667 ekaon(5,iss)=ekaon(5,iss)+1
3668 CALL CRPP(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3669 1 IBLOCK,ppel,ppin,spprho,ipp)
3670
3671* rho formation, go to 400
3672c if(iblock.eq.666)go to 600
3673 if(iblock.eq.666)go to 555
3674 if(iblock.eq.6)LPP=LPP+1
3675 if(iblock.eq.66)then
3676 LPPk=LPPk+1
3677 elseif(iblock.eq.366)then
3678 LPPk=LPPk+1
3679 elseif(iblock.eq.367)then
3680 LPPk=LPPk+1
3681 endif
3682 em1=e(i1)
3683 em2=e(i2)
3684 go to 440
3685
3686* In this block we treat annihilations of
3687clin-9/28/00* an anti-nucleon and a baryon or baryon resonance
3688* an anti-baryon and a baryon (including resonances)
36892799 CONTINUE
3690 PX1CM=PCX
3691 PY1CM=PCY
3692 PZ1CM=PCZ
3693 EC=(em1+em2+0.02)**2
3694clin assume the same cross section (as a function of sqrt s) as for PPbar:
3695
3696clin-ctest annih maximum
3697c DSppb=SQRT(amin1(xppbar(srt),30.)/PI/10.)
3698 DSppb=SQRT(xppbar(srt)/PI/10.)
3699 dsppbr=dsppb+0.1
3700 CALL DISTCE(I1,I2,dsppbr,DSppb,DT,EC,SRT,IC,
3701 1 PX1CM,PY1CM,PZ1CM)
3702 IF(IC.EQ.-1) GO TO 400
3703 CALL Crppba(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3704 1 IBLOCK)
3705 em1=e(i1)
3706 em2=e(i2)
3707 go to 440
3708c
37093555 PX1CM=PCX
3710 PY1CM=PCY
3711 PZ1CM=PCZ
3712 EC=(em1+em2+0.02)**2
3713 DSkk=SQRT(SIG/PI/10.)
3714 dskk0=dskk+0.1
3715 CALL DISTCE(I1,I2,dskk0,DSkk,DT,EC,SRT,IC,
3716 1 PX1CM,PY1CM,PZ1CM)
3717 IF(IC.EQ.-1) GO TO 400
3718 CALL Crlaba(PX1CM,PY1CM,PZ1CM,SRT,brel,brsgm,
3719 & I1,I2,nt,IBLOCK,nchrg,icase)
3720 em1=e(i1)
3721 em2=e(i2)
3722 go to 440
3723*
3724c perturbative production of cascade and omega
37253455 PX1CM=PCX
3726 PY1CM=PCY
3727 PZ1CM=PCZ
3728 call pertur(PX1CM,PY1CM,PZ1CM,SRT,IRUN,I1,I2,nt,kp,icontp)
3729 if(icontp .eq. 0)then
3730c inelastic collisions:
3731 em1 = e(i1)
3732 em2 = e(i2)
3733 iblock = 727
3734 go to 440
3735 endif
3736c elastic collisions:
3737 if (e(i1) .eq. 0.) go to 800
3738 if (e(i2) .eq. 0.) go to 600
3739 go to 400
3740*
3741c* phi + N --> pi+N(D), N(D,N*)+N(D,N*), K+ +La
3742c* phi + D --> pi+N(D)
37437222 CONTINUE
3744 PX1CM=PCX
3745 PY1CM=PCY
3746 PZ1CM=PCZ
3747 EC=(em1+em2+0.02)**2
3748 CALL XphiB(LB1, LB2, EM1, EM2, SRT,
3749 & XSK1, XSK2, XSK3, XSK4, XSK5, SIGP)
3750 DSkk=SQRT(SIGP/PI/10.)
3751 dskk0=dskk+0.1
3752 CALL DISTCE(I1,I2,dskk0,DSkk,DT,EC,SRT,IC,
3753 1 PX1CM,PY1CM,PZ1CM)
3754 IF(IC.EQ.-1) GO TO 400
3755 CALL CRPHIB(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3756 & XSK1, XSK2, XSK3, XSK4, XSK5, SIGP, IBLOCK)
3757 em1=e(i1)
3758 em2=e(i2)
3759 go to 440
3760*
3761c* phi + M --> K+ + K* .....
37627444 CONTINUE
3763 PX1CM=PCX
3764 PY1CM=PCY
3765 PZ1CM=PCZ
3766 EC=(em1+em2+0.02)**2
3767 CALL PHIMES(I1, I2, SRT, XSK1, XSK2, XSK3, XSK4, XSK5,
3768 1 XSK6, XSK7, SIGPHI)
3769 DSkk=SQRT(SIGPHI/PI/10.)
3770 dskk0=dskk+0.1
3771 CALL DISTCE(I1,I2,dskk0,DSkk,DT,EC,SRT,IC,
3772 1 PX1CM,PY1CM,PZ1CM)
3773 IF(IC.EQ.-1) GO TO 400
3774c*---
3775 PZRT = p(3,i1)+p(3,i2)
3776 ER1 = sqrt( p(1,i1)**2+p(2,i1)**2+p(3,i1)**2+E(i1)**2 )
3777 ER2 = sqrt( p(1,i2)**2+p(2,i2)**2+p(3,i2)**2+E(i2)**2 )
3778 ERT = ER1+ER2
3779 yy = 0.5*log( (ERT+PZRT)/(ERT-PZRT) )
3780c*------
3781 CALL CRPHIM(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3782 & XSK1, XSK2, XSK3, XSK4, XSK5, XSK6, SIGPHI, IKKG, IKKL, IBLOCK)
3783 em1=e(i1)
3784 em2=e(i2)
3785 go to 440
3786c
3787c lambda-N elastic xsection, Li & Ko, PRC 54(1996)1897.
3788 7799 CONTINUE
3789 PX1CM=PCX
3790 PY1CM=PCY
3791 PZ1CM=PCZ
3792 EC=(em1+em2+0.02)**2
3793 call lambar(i1,i2,srt,siglab)
3794 DShn=SQRT(siglab/PI/10.)
3795 dshnr=dshn+0.1
3796 CALL DISTCE(I1,I2,dshnr,DShn,DT,EC,SRT,IC,
3797 1 PX1CM,PY1CM,PZ1CM)
3798 IF(IC.EQ.-1) GO TO 400
3799 CALL Crhb(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK)
3800 em1=e(i1)
3801 em2=e(i2)
3802 go to 440
3803c
3804c* K+ + La(Si) --> Meson + B
3805c* K- + La(Si)-bar --> Meson + B-bar
38065699 CONTINUE
3807 PX1CM=PCX
3808 PY1CM=PCY
3809 PZ1CM=PCZ
3810 EC=(em1+em2+0.02)**2
3811 CALL XKHYPE(I1, I2, SRT, XKY1, XKY2, XKY3, XKY4, XKY5,
3812 & XKY6, XKY7, XKY8, XKY9, XKY10, XKY11, XKY12, XKY13,
3813 & XKY14, XKY15, XKY16, XKY17, SIGK)
3814 DSkk=SQRT(sigk/PI)
3815 dskk0=dskk+0.1
3816 CALL DISTCE(I1,I2,dskk0,DSkk,DT,EC,SRT,IC,
3817 1 PX1CM,PY1CM,PZ1CM)
3818 IF(IC.EQ.-1) GO TO 400
3819c
3820 if(lb(i1).eq.23 .or. lb(i2).eq.23)then
3821 IKMP = 1
3822 else
3823 IKMP = -1
3824 endif
3825 CALL Crkhyp(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3826 & XKY1, XKY2, XKY3, XKY4, XKY5,
3827 & XKY6, XKY7, XKY8, XKY9, XKY10, XKY11, XKY12, XKY13,
3828 & XKY14, XKY15, XKY16, XKY17, SIGK, IKMP,
3829 1 IBLOCK)
3830 em1=e(i1)
3831 em2=e(i2)
3832 go to 440
3833c khyperon end
3834*
3835csp11/03/01 La/Si-bar + N --> pi + K+
3836c La/Si + N-bar --> pi + K-
38375999 CONTINUE
3838 PX1CM=PCX
3839 PY1CM=PCY
3840 PZ1CM=PCZ
3841 EC=(em1+em2+0.02)**2
3842 sigkp = 15.
3843c if((lb1.ge.14.and.lb1.le.17)
3844c & .or.(lb2.ge.14.and.lb2.le.17))sigkp=10.
3845 DSkk=SQRT(SIGKP/PI/10.)
3846 dskk0=dskk+0.1
3847 CALL DISTCE(I1,I2,dskk0,DSkk,DT,EC,SRT,IC,
3848 1 PX1CM,PY1CM,PZ1CM)
3849 IF(IC.EQ.-1) GO TO 400
3850c
3851 CALL CRLAN(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK)
3852 em1=e(i1)
3853 em2=e(i2)
3854 go to 440
3855c
3856c*
3857* K(K*) + K(K*) --> phi + pi(rho,omega)
38588699 CONTINUE
3859 PX1CM=PCX
3860 PY1CM=PCY
3861 PZ1CM=PCZ
3862 EC=(em1+em2+0.02)**2
3863* CALL CROSSKKPHI(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK) used for KK*->phi+rho
3864
3865 CALL Crkphi(PX1CM,PY1CM,PZ1CM,EC,SRT,IBLOCK,
3866 & emm1,emm2,lbp1,lbp2,I1,I2,ikk,icase,rrkk,prkk)
3867 if(icase .eq. 0) then
3868 iblock=0
3869 go to 400
3870 endif
3871
3872c*---
3873 if(lbp1.eq.29.or.lbp2.eq.29) then
3874 PZRT = p(3,i1)+p(3,i2)
3875 ER1 = sqrt( p(1,i1)**2+p(2,i1)**2+p(3,i1)**2+E(i1)**2 )
3876 ER2 = sqrt( p(1,i2)**2+p(2,i2)**2+p(3,i2)**2+E(i2)**2 )
3877 ERT = ER1+ER2
3878 yy = 0.5*log( (ERT+PZRT)/(ERT-PZRT) )
3879c*------
3880 iblock = 222
3881 ntag = 0
3882 endif
3883
3884 LB(I1) = lbp1
3885 LB(I2) = lbp2
3886 E(I1) = emm1
3887 E(I2) = emm2
3888 em1=e(i1)
3889 em2=e(i2)
3890 go to 440
3891c*
3892* rho(omega) + K(K*) --> phi + K(K*)
38938799 CONTINUE
3894 PX1CM=PCX
3895 PY1CM=PCY
3896 PZ1CM=PCZ
3897 EC=(em1+em2+0.02)**2
3898* CALL CROSSKKPHI(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK) used for KK*->phi+rho
3899 CALL Crksph(PX1CM,PY1CM,PZ1CM,EC,SRT,
3900 & emm1,emm2,lbp1,lbp2,I1,I2,ikkg,ikkl,iblock,icase,srhoks)
3901 if(icase .eq. 0) then
3902 iblock=0
3903 go to 400
3904 endif
3905c
3906 if(lbp1.eq.29.or.lbp2.eq.20) then
3907c*---
3908 PZRT = p(3,i1)+p(3,i2)
3909 ER1 = sqrt( p(1,i1)**2+p(2,i1)**2+p(3,i1)**2+E(i1)**2 )
3910 ER2 = sqrt( p(1,i2)**2+p(2,i2)**2+p(3,i2)**2+E(i2)**2 )
3911 ERT = ER1+ER2
3912 yy = 0.5*log( (ERT+PZRT)/(ERT-PZRT) )
3913 endif
3914
3915 LB(I1) = lbp1
3916 LB(I2) = lbp2
3917 E(I1) = emm1
3918 E(I2) = emm2
3919 em1=e(i1)
3920 em2=e(i2)
3921 go to 440
3922
3923* for kaon+baryon scattering, using a constant xsection of 10 mb.
3924888 CONTINUE
3925 PX1CM=PCX
3926 PY1CM=PCY
3927 PZ1CM=PCZ
3928 EC=(em1+em2+0.02)**2
3929 sig = 10.
3930 if(iabs(lb1).eq.14.or.iabs(lb2).eq.14 .or.
3931 & iabs(lb1).eq.30.or.iabs(lb2).eq.30)sig=20.
3932 if(lb1.eq.29.or.lb2.eq.29)sig=5.0
3933
3934 DSkn=SQRT(sig/PI/10.)
3935 dsknr=dskn+0.1
3936 CALL DISTCE(I1,I2,dsknr,DSkn,DT,EC,SRT,IC,
3937 1 PX1CM,PY1CM,PZ1CM)
3938 IF(IC.EQ.-1) GO TO 400
3939 CALL Crkn(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3940 1 IBLOCK)
3941 em1=e(i1)
3942 em2=e(i2)
3943 go to 440
3944***
3945
3946 440 CONTINUE
3947* IBLOCK = 0 ; NOTHING HAS HAPPENED
3948* IBLOCK = 1 ; ELASTIC N-N COLLISION
3949* IBLOCK = 2 ; N + N -> N + DELTA
3950* IBLOCK = 3 ; N + DELTA -> N + N
3951* IBLOCK = 4 ; N + N -> d + d + PION,DIRECT PROCESS
3952* IBLOCK = 5 ; D(N*)+D(N*) COLLISIONS
3953* IBLOCK = 6 ; PION+PION COLLISIONS
3954* iblock = 7 ; pion+nucleon-->l/s+kaon
3955* iblock =77; pion+nucleon-->delta+pion
3956* iblock = 8 ; kaon+baryon rescattering
3957* IBLOCK = 9 ; NN-->KAON+X
3958* IBLOCK = 10; DD-->KAON+X
3959* IBLOCK = 11; ND-->KAON+X
3960cbali2/1/99
3961*
3962* iblock - 1902 annihilation-->pion(+)+pion(-) (2 pion)
3963* iblock - 1903 annihilation-->pion(+)+rho(-) (3 pion)
3964* iblock - 1904 annihilation-->rho(+)+rho(-) (4 pion)
3965* iblock - 1905 annihilation-->rho(0)+omega (5 pion)
3966* iblock - 1906 annihilation-->omega+omega (6 pion)
3967cbali3/5/99
3968* iblock - 1907 K+K- to pi+pi-
3969cbali3/5/99 end
3970cbz3/9/99 khyperon
3971* iblock - 1908 K+Y -> piN
3972cbz3/9/99 khyperon end
3973cbali2/1/99end
3974
3975clin-9/28/00 Processes: m(pi rho omega)+m(pi rho omega)
3976c to anti-(p n D N*1 N*2)+(p n D N*1 N*2):
3977* iblock - 1801 mm -->pbar p
3978* iblock - 18021 mm -->pbar n
3979* iblock - 18022 mm -->nbar p
3980* iblock - 1803 mm -->nbar n
3981* iblock - 18041 mm -->pbar Delta
3982* iblock - 18042 mm -->anti-Delta p
3983* iblock - 18051 mm -->nbar Delta
3984* iblock - 18052 mm -->anti-Delta n
3985* iblock - 18061 mm -->pbar N*(1400)
3986* iblock - 18062 mm -->anti-N*(1400) p
3987* iblock - 18071 mm -->nbar N*(1400)
3988* iblock - 18072 mm -->anti-N*(1400) n
3989* iblock - 1808 mm -->anti-Delta Delta
3990* iblock - 18091 mm -->pbar N*(1535)
3991* iblock - 18092 mm -->anti-N*(1535) p
3992* iblock - 18101 mm -->nbar N*(1535)
3993* iblock - 18102 mm -->anti-N*(1535) n
3994* iblock - 18111 mm -->anti-Delta N*(1440)
3995* iblock - 18112 mm -->anti-N*(1440) Delta
3996* iblock - 18121 mm -->anti-Delta N*(1535)
3997* iblock - 18122 mm -->anti-N*(1535) Delta
3998* iblock - 1813 mm -->anti-N*(1440) N*(1440)
3999* iblock - 18141 mm -->anti-N*(1440) N*(1535)
4000* iblock - 18142 mm -->anti-N*(1535) N*(1440)
4001* iblock - 1815 mm -->anti-N*(1535) N*(1535)
4002clin-9/28/00-end
4003
4004clin-10/08/00 Processes: pi pi <-> rho rho
4005* iblock - 1850 pi pi -> rho rho
4006* iblock - 1851 rho rho -> pi pi
4007clin-10/08/00-end
4008
4009clin-08/14/02 Processes: pi pi <-> eta eta
4010* iblock - 1860 pi pi -> eta eta
4011* iblock - 1861 eta eta -> pi pi
4012* Processes: pi pi <-> pi eta
4013* iblock - 1870 pi pi -> pi eta
4014* iblock - 1871 pi eta -> pi pi
4015* Processes: rho pi <-> rho eta
4016* iblock - 1880 pi pi -> pi eta
4017* iblock - 1881 pi eta -> pi pi
4018* Processes: omega pi <-> omega eta
4019* iblock - 1890 pi pi -> pi eta
4020* iblock - 1891 pi eta -> pi pi
4021* Processes: rho rho <-> eta eta
4022* iblock - 1895 rho rho -> eta eta
4023* iblock - 1896 eta eta -> rho rho
4024clin-08/14/02-end
4025
4026clin-11/07/00 Processes:
4027* iblock - 366 pi rho -> K* Kbar or K*bar K
4028* iblock - 466 pi rho <- K* Kbar or K*bar K
4029
4030clin-9/2008 Deuteron:
4031* iblock - 501 B+B -> Deuteron+Meson
4032* iblock - 502 Deuteron+Meson -> B+B
4033* iblock - 503 Deuteron+Baryon elastic
4034* iblock - 504 Deuteron+Meson elastic
4035c
4036 IF(IBLOCK.EQ.0) GOTO 400
4037*COM: FOR DIRECT PROCESS WE HAVE TREATED THE PAULI BLOCKING AND FIND
4038* THE MOMENTUM OF PARTICLES IN THE ''LAB'' FRAME. SO GO TO 400
4039* A COLLISION HAS TAKEN PLACE !!
4040 LCOLL = LCOLL +1
4041* WAS COLLISION PAULI-FORBIDEN? IF YES, NTAG = -1
4042 NTAG = 0
4043*
4044* LORENTZ-TRANSFORMATION INTO CMS FRAME
4045 E1CM = SQRT (EM1**2 + PX1CM**2 + PY1CM**2 + PZ1CM**2)
4046 P1BETA = PX1CM*BETAX + PY1CM*BETAY + PZ1CM*BETAZ
4047 TRANSF = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) + E1CM )
4048 Pt1I1 = BETAX * TRANSF + PX1CM
4049 Pt2I1 = BETAY * TRANSF + PY1CM
4050 Pt3I1 = BETAZ * TRANSF + PZ1CM
4051* negelect the pauli blocking at high energies
4052 go to 90002
4053
4054clin-10/25/02-comment out following, since there is no path to it:
4055c*CHECK IF PARTICLE #1 IS PAULI BLOCKED
4056c CALL PAULat(I1,occup)
4057c if (RANART(NSEED) .lt. occup) then
4058c ntag = -1
4059c else
4060c ntag = 0
4061c end if
4062clin-10/25/02-end
4063
406490002 continue
4065*IF PARTICLE #1 IS NOT PAULI BLOCKED
4066c IF (NTAG .NE. -1) THEN
4067 E2CM = SQRT (EM2**2 + PX1CM**2 + PY1CM**2 + PZ1CM**2)
4068 TRANSF = GAMMA * (-GAMMA*P1BETA / (GAMMA + 1.) + E2CM)
4069 Pt1I2 = BETAX * TRANSF - PX1CM
4070 Pt2I2 = BETAY * TRANSF - PY1CM
4071 Pt3I2 = BETAZ * TRANSF - PZ1CM
4072 go to 90003
4073
4074clin-10/25/02-comment out following, since there is no path to it:
4075c*CHECK IF PARTICLE #2 IS PAULI BLOCKED
4076c CALL PAULat(I2,occup)
4077c if (RANART(NSEED) .lt. occup) then
4078c ntag = -1
4079c else
4080c ntag = 0
4081c end if
4082cc END IF
4083c* IF COLLISION IS BLOCKED,RESTORE THE MOMENTUM,MASSES
4084c* AND LABELS OF I1 AND I2
4085cc IF (NTAG .EQ. -1) THEN
4086c LBLOC = LBLOC + 1
4087c P(1,I1) = PX1
4088c P(2,I1) = PY1
4089c P(3,I1) = PZ1
4090c P(1,I2) = PX2
4091c P(2,I2) = PY2
4092c P(3,I2) = PZ2
4093c E(I1) = EM1
4094c E(I2) = EM2
4095c LB(I1) = LB1
4096c LB(I2) = LB2
4097cc ELSE
4098clin-10/25/02-end
4099
410090003 IF(IBLOCK.EQ.1) LCNNE=LCNNE+1
4101 IF(IBLOCK.EQ.5) LDD=LDD+1
4102 if(iblock.eq.2) LCNND=LCNND+1
4103 IF(IBLOCK.EQ.8) LKN=LKN+1
4104 if(iblock.eq.43) Ldou=Ldou+1
4105c IF(IBLOCK.EQ.2) THEN
4106* CALCULATE THE AVERAGE SRT FOR N + N---> N + DELTA PROCESS
4107C NODELT=NODELT+1
4108C SUMSRT=SUMSRT+SRT
4109c ENDIF
4110 IF(IBLOCK.EQ.3) LCNDN=LCNDN+1
4111* assign final momenta to particles while keep the leadng particle
4112* behaviour
4113C if((pt1i1*px1+pt2i1*py1+pt3i1*pz1).gt.0)then
4114 p(1,i1)=pt1i1
4115 p(2,i1)=pt2i1
4116 p(3,i1)=pt3i1
4117 p(1,i2)=pt1i2
4118 p(2,i2)=pt2i2
4119 p(3,i2)=pt3i2
4120C else
4121C p(1,i1)=pt1i2
4122C p(2,i1)=pt2i2
4123C p(3,i1)=pt3i2
4124C p(1,i2)=pt1i1
4125C p(2,i2)=pt2i1
4126C p(3,i2)=pt3i1
4127C endif
4128 PX1 = P(1,I1)
4129 PY1 = P(2,I1)
4130 PZ1 = P(3,I1)
4131 EM1 = E(I1)
4132 EM2 = E(I2)
4133 LB1 = LB(I1)
4134 LB2 = LB(I2)
4135 ID(I1) = 2
4136 ID(I2) = 2
4137 E1 = SQRT( EM1**2 + PX1**2 + PY1**2 + PZ1**2 )
4138 ID1 = ID(I1)
4139 go to 90004
4140clin-10/25/02-comment out following, since there is no path to it:
4141c* change phase space density FOR NUCLEONS INVOLVED :
4142c* NOTE THAT f is the phase space distribution function for nucleons only
4143c if ((abs(ix1).le.mx) .and. (abs(iy1).le.my) .and.
4144c & (abs(iz1).le.mz)) then
4145c ipx1p = nint(p(1,i1)/dpx)
4146c ipy1p = nint(p(2,i1)/dpy)
4147c ipz1p = nint(p(3,i1)/dpz)
4148c if ((ipx1p.ne.ipx1) .or. (ipy1p.ne.ipy1) .or.
4149c & (ipz1p.ne.ipz1)) then
4150c if ((abs(ipx1).le.mpx) .and. (abs(ipy1).le.my)
4151c & .and. (ipz1.ge.-mpz) .and. (ipz1.le.mpzp)
4152c & .AND. (AM1.LT.1.))
4153c & f(ix1,iy1,iz1,ipx1,ipy1,ipz1) =
4154c & f(ix1,iy1,iz1,ipx1,ipy1,ipz1) - 1.
4155c if ((abs(ipx1p).le.mpx) .and. (abs(ipy1p).le.my)
4156c & .and. (ipz1p.ge.-mpz).and. (ipz1p.le.mpzp)
4157c & .AND. (EM1.LT.1.))
4158c & f(ix1,iy1,iz1,ipx1p,ipy1p,ipz1p) =
4159c & f(ix1,iy1,iz1,ipx1p,ipy1p,ipz1p) + 1.
4160c end if
4161c end if
4162c if ((abs(ix2).le.mx) .and. (abs(iy2).le.my) .and.
4163c & (abs(iz2).le.mz)) then
4164c ipx2p = nint(p(1,i2)/dpx)
4165c ipy2p = nint(p(2,i2)/dpy)
4166c ipz2p = nint(p(3,i2)/dpz)
4167c if ((ipx2p.ne.ipx2) .or. (ipy2p.ne.ipy2) .or.
4168c & (ipz2p.ne.ipz2)) then
4169c if ((abs(ipx2).le.mpx) .and. (abs(ipy2).le.my)
4170c & .and. (ipz2.ge.-mpz) .and. (ipz2.le.mpzp)
4171c & .AND. (AM2.LT.1.))
4172c & f(ix2,iy2,iz2,ipx2,ipy2,ipz2) =
4173c & f(ix2,iy2,iz2,ipx2,ipy2,ipz2) - 1.
4174c if ((abs(ipx2p).le.mpx) .and. (abs(ipy2p).le.my)
4175c & .and. (ipz2p.ge.-mpz) .and. (ipz2p.le.mpzp)
4176c & .AND. (EM2.LT.1.))
4177c & f(ix2,iy2,iz2,ipx2p,ipy2p,ipz2p) =
4178c & f(ix2,iy2,iz2,ipx2p,ipy2p,ipz2p) + 1.
4179c end if
4180c end if
4181clin-10/25/02-end
4182
418390004 continue
4184 AM1=EM1
4185 AM2=EM2
4186c END IF
4187
4188
4189 400 CONTINUE
4190c
4191clin-6/10/03 skips the info output on resonance creations:
4192c goto 550
4193cclin-4/30/03 study phi,K*,Lambda(1520) resonances at creation:
4194cc note that no decays give these particles, so don't need to consider nnn:
4195c if(iblock.ne.0.and.(lb(i1).eq.29.or.iabs(lb(i1)).eq.30
4196c 1 .or.lb(i2).eq.29.or.iabs(lb(i2)).eq.30
4197c 2 .or.lb1i.eq.29.or.iabs(lb1i).eq.30
4198c 3 .or.lb2i.eq.29.or.iabs(lb2i).eq.30)) then
4199c lb1now=lb(i1)
4200c lb2now=lb(i2)
4201cc
4202c nphi0=0
4203c nksp0=0
4204c nksm0=0
4205cc nlar0=0
4206cc nlarbar0=0
4207c if(lb1i.eq.29) then
4208c nphi0=nphi0+1
4209c elseif(lb1i.eq.30) then
4210c nksp0=nksp0+1
4211c elseif(lb1i.eq.-30) then
4212c nksm0=nksm0+1
4213c endif
4214c if(lb2i.eq.29) then
4215c nphi0=nphi0+1
4216c elseif(lb2i.eq.30) then
4217c nksp0=nksp0+1
4218c elseif(lb2i.eq.-30) then
4219c nksm0=nksm0+1
4220c endif
4221cc
4222c nphi=0
4223c nksp=0
4224c nksm=0
4225c nlar=0
4226c nlarbar=0
4227c if(lb1now.eq.29) then
4228c nphi=nphi+1
4229c elseif(lb1now.eq.30) then
4230c nksp=nksp+1
4231c elseif(lb1now.eq.-30) then
4232c nksm=nksm+1
4233c endif
4234c if(lb2now.eq.29) then
4235c nphi=nphi+1
4236c elseif(lb2now.eq.30) then
4237c nksp=nksp+1
4238c elseif(lb2now.eq.-30) then
4239c nksm=nksm+1
4240c endif
4241cc
4242c if(nphi.eq.2.or.nksp.eq.2.or.nksm.eq.2) then
4243c write(91,*) '2 same resonances in one reaction!'
4244c write(91,*) nphi,nksp,nksm,iblock
4245c endif
4246c
4247cc All reactions create or destroy no more than 1 these resonance,
4248cc otherwise file "fort.91" warns us:
4249c do 222 ires=1,3
4250c if(ires.eq.1.and.nphi.ne.nphi0) then
4251c idr=29
4252c elseif(ires.eq.2.and.nksp.ne.nksp0) then
4253c idr=30
4254c elseif(ires.eq.3.and.nksm.ne.nksm0) then
4255c idr=-30
4256c else
4257c goto 222
4258c endif
4259cctest off for resonance (phi, K*) studies:
4260cc if(lb1now.eq.idr) then
4261cc write(17,112) 'collision',lb1now,P(1,I1),P(2,I1),P(3,I1),e(I1),nt
4262cc elseif(lb2now.eq.idr) then
4263cc write(17,112) 'collision',lb2now,P(1,I2),P(2,I2),P(3,I2),e(I2),nt
4264cc elseif(lb1i.eq.idr) then
4265cc write(18,112) 'collision',lb1i,px1i,py1i,pz1i,em1i,nt
4266cc elseif(lb2i.eq.idr) then
4267cc write(18,112) 'collision',lb2i,px2i,py2i,pz2i,em2i,nt
4268cc endif
4269c 222 continue
4270c
4271c else
4272c endif
4273cc 112 format(a10,I4,4(1x,f9.3),1x,I4)
4274c
4275clin-2/26/03 skips the check of energy conservation after each binary search:
4276c 550 goto 555
4277c pxfin=0
4278c pyfin=0
4279c pzfin=0
4280c efin=0
4281c if(e(i1).ne.0.or.lb(i1).eq.10022) then
4282c efin=efin+SQRT(E(I1)**2+P(1,I1)**2+P(2,I1)**2+P(3,I1)**2)
4283c pxfin=pxfin+P(1,I1)
4284c pyfin=pyfin+P(2,I1)
4285c pzfin=pzfin+P(3,I1)
4286c endif
4287c if(e(i2).ne.0.or.lb(i2).eq.10022) then
4288c efin=efin+SQRT(E(I2)**2+P(1,I2)**2+P(2,I2)**2+P(3,I2)**2)
4289c pxfin=pxfin+P(1,I2)
4290c pyfin=pyfin+P(2,I2)
4291c pzfin=pzfin+P(3,I2)
4292c endif
4293c if((nnn-nnnini).ge.1) then
4294c do imore=nnnini+1,nnn
4295c if(EPION(imore,IRUN).ne.0) then
4296c efin=efin+SQRT(EPION(imore,IRUN)**2
4297c 1 +PPION(1,imore,IRUN)**2+PPION(2,imore,IRUN)**2
4298c 2 +PPION(3,imore,IRUN)**2)
4299c pxfin=pxfin+PPION(1,imore,IRUN)
4300c pyfin=pyfin+PPION(2,imore,IRUN)
4301c pzfin=pzfin+PPION(3,imore,IRUN)
4302c endif
4303c enddo
4304c endif
4305c devio=sqrt((pxfin-pxini)**2+(pyfin-pyini)**2
4306c 1 +(pzfin-pzini)**2+(efin-eini)**2)
4307cc
4308c if(devio.ge.0.1) then
4309c write(92,'a20,5(1x,i6),2(1x,f8.3)') 'iblock,lb,npi=',
4310c 1 iblock,lb1i,lb2i,lb(i1),lb(i2),e(i1),e(i2)
4311c do imore=nnnini+1,nnn
4312c if(EPION(imore,IRUN).ne.0) then
4313c write(92,'a10,2(1x,i6)') 'ipi,lbm=',
4314c 1 imore,LPION(imore,IRUN)
4315c endif
4316c enddo
4317c write(92,'a3,4(1x,f8.3)') 'I:',eini,pxini,pyini,pzini
4318c write(92,'a3,5(1x,f8.3)')
4319c 1 'F:',efin,pxfin,pyfin,pzfin,devio
4320c endif
4321c
4322 555 continue
4323ctest off only one collision for the same 2 particles in the same timestep:
4324c if(iblock.ne.0) then
4325c goto 800
4326c endif
4327ctest off collisions history:
4328c if(iblock.ne.0) then
4329c write(10,*) nt,i1,i2,iblock,x1,z1,x2,z2
4330c endif
4331
4332 600 CONTINUE
4333 800 CONTINUE
4334* RELABLE MESONS LEFT IN THIS RUN EXCLUDING THOSE BEING CREATED DURING
4335* THIS TIME STEP AND COUNT THE TOTAL NO. OF PARTICLES IN THIS RUN
4336* note that the first mass=mta+mpr particles are baryons
4337c write(*,*)'I: NNN,massr ', nnn,massr(irun)
4338 N0=MASS+MSUM
4339 DO 1005 N=N0+1,MASSR(IRUN)+MSUM
4340cbz11/25/98
4341clin-2/19/03 lb>5000: keep particles with no LB codes in ART(photon,lepton,..):
4342c IF(E(N).GT.0.)THEN
4343 IF(E(N) .GT. 0. .OR. LB(N) .GT. 5000)THEN
4344cbz11/25/98end
4345 NNN=NNN+1
4346 RPION(1,NNN,IRUN)=R(1,N)
4347 RPION(2,NNN,IRUN)=R(2,N)
4348 RPION(3,NNN,IRUN)=R(3,N)
4349clin-10/28/03:
4350 if(nt.eq.ntmax) then
4351 ftpisv(NNN,IRUN)=ftsv(N)
4352 tfdpi(NNN,IRUN)=tfdcy(N)
4353 endif
4354c
4355 PPION(1,NNN,IRUN)=P(1,N)
4356 PPION(2,NNN,IRUN)=P(2,N)
4357 PPION(3,NNN,IRUN)=P(3,N)
4358 EPION(NNN,IRUN)=E(N)
4359 LPION(NNN,IRUN)=LB(N)
4360c !! sp 12/19/00
4361 PROPI(NNN,IRUN)=PROPER(N)
4362clin-5/2008:
4363 dppion(NNN,IRUN)=dpertp(N)
4364c if(lb(n) .eq. 45)
4365c & write(*,*)'IN-1 NT,NNN,LB,P ',nt,NNN,lb(n),proper(n)
4366 ENDIF
4367 1005 CONTINUE
4368 MASSRN(IRUN)=NNN+MASS
4369c write(*,*)'F: NNN,massrn ', nnn,massrn(irun)
43701000 CONTINUE
4371* CALCULATE THE AVERAGE SRT FOR N + N--->N +DELTA PROCESSES
4372C IF(NODELT.NE.0)THEN
4373C AVSRT=SUMSRT/FLOAT(NODELT)
4374C ELSE
4375C AVSRT=0.
4376C ENDIF
4377C WRITE(1097,'(F8.2,2X,E10.3)')FLOAT(NT)*DT,AVSRT
4378* RELABLE ALL THE PARTICLES EXISTING AFTER THIS TIME STEP
4379 IA=0
4380 IB=0
4381 DO 10001 IRUN=1,NUM
4382 IA=IA+MASSR(IRUN-1)
4383 IB=IB+MASSRN(IRUN-1)
4384 DO 10001 IC=1,MASSRN(IRUN)
4385 IE=IA+IC
4386 IG=IB+IC
4387 IF(IC.LE.MASS)THEN
4388 RT(1,IG)=R(1,IE)
4389 RT(2,IG)=R(2,IE)
4390 RT(3,IG)=R(3,IE)
4391clin-10/28/03:
4392 if(nt.eq.ntmax) then
4393 fttemp(IG)=ftsv(IE)
4394 tft(IG)=tfdcy(IE)
4395 endif
4396c
4397 PT(1,IG)=P(1,IE)
4398 PT(2,IG)=P(2,IE)
4399 PT(3,IG)=P(3,IE)
4400 ET(IG)=E(IE)
4401 LT(IG)=LB(IE)
4402 PROT(IG)=PROPER(IE)
4403clin-5/2008:
4404 dptemp(IG)=dpertp(IE)
4405 ELSE
4406 I0=IC-MASS
4407 RT(1,IG)=RPION(1,I0,IRUN)
4408 RT(2,IG)=RPION(2,I0,IRUN)
4409 RT(3,IG)=RPION(3,I0,IRUN)
4410clin-10/28/03:
4411 if(nt.eq.ntmax) then
4412 fttemp(IG)=ftpisv(I0,IRUN)
4413 tft(IG)=tfdpi(I0,IRUN)
4414 endif
4415c
4416 PT(1,IG)=PPION(1,I0,IRUN)
4417 PT(2,IG)=PPION(2,I0,IRUN)
4418 PT(3,IG)=PPION(3,I0,IRUN)
4419 ET(IG)=EPION(I0,IRUN)
4420 LT(IG)=LPION(I0,IRUN)
4421 PROT(IG)=PROPI(I0,IRUN)
4422clin-5/2008:
4423 dptemp(IG)=dppion(I0,IRUN)
4424 ENDIF
442510001 CONTINUE
4426c
4427 IL=0
4428clin-10/26/01-hbt:
4429c DO 10002 IRUN=1,NUM
4430 DO 10003 IRUN=1,NUM
4431
4432 MASSR(IRUN)=MASSRN(IRUN)
4433 IL=IL+MASSR(IRUN-1)
4434 DO 10002 IM=1,MASSR(IRUN)
4435 IN=IL+IM
4436 R(1,IN)=RT(1,IN)
4437 R(2,IN)=RT(2,IN)
4438 R(3,IN)=RT(3,IN)
4439clin-10/28/03:
4440 if(nt.eq.ntmax) then
4441 ftsv(IN)=fttemp(IN)
4442 tfdcy(IN)=tft(IN)
4443 endif
4444 P(1,IN)=PT(1,IN)
4445 P(2,IN)=PT(2,IN)
4446 P(3,IN)=PT(3,IN)
4447 E(IN)=ET(IN)
4448 LB(IN)=LT(IN)
4449 PROPER(IN)=PROT(IN)
4450clin-5/2008:
4451 dpertp(IN)=dptemp(IN)
4452 IF(LB(IN).LT.1.OR.LB(IN).GT.2)ID(IN)=0
445310002 CONTINUE
4454clin-ctest off check energy conservation after each timestep
4455c enetot=0.
4456c do ip=1,MASSR(IRUN)
4457c if(e(ip).ne.0.or.lb(ip).eq.10022) enetot=enetot
4458c 1 +sqrt(p(1,ip)**2+p(2,ip)**2+p(3,ip)**2+e(ip)**2)
4459c enddo
4460c write(91,*) 'B:',nt,enetot,massr(irun),bimp
4461clin-3/2009 move to the end of a timestep to take care of freezeout spacetime:
4462c call hbtout(MASSR(IRUN),nt,ntmax)
446310003 CONTINUE
4464c
4465 RETURN
4466 END
4467****************************************
4468 SUBROUTINE CMS(I1,I2,PX1CM,PY1CM,PZ1CM,SRT)
4469* PURPOSE : FIND THE MOMENTA OF PARTICLES IN THE CMS OF THE
4470* TWO COLLIDING PARTICLES
4471* VARIABLES :
4472*****************************************
4473 PARAMETER (MAXSTR=150001)
4474 COMMON /AA/ R(3,MAXSTR)
4475cc SAVE /AA/
4476 COMMON /BB/ P(3,MAXSTR)
4477cc SAVE /BB/
4478 COMMON /CC/ E(MAXSTR)
4479cc SAVE /CC/
4480 COMMON /BG/ BETAX,BETAY,BETAZ,GAMMA
4481cc SAVE /BG/
4482 SAVE
4483 PX1=P(1,I1)
4484 PY1=P(2,I1)
4485 PZ1=P(3,I1)
4486 PX2=P(1,I2)
4487 PY2=P(2,I2)
4488 PZ2=P(3,I2)
4489 EM1=E(I1)
4490 EM2=E(I2)
4491 E1=SQRT(EM1**2+PX1**2+PY1**2+PZ1**2)
4492 E2=SQRT(EM2**2 + PX2**2 + PY2**2 + PZ2**2 )
4493 S=(E1+E2)**2-(PX1+PX2)**2-(PY1+PY2)**2-(PZ1+PZ2)**2
4494 SRT=SQRT(S)
4495*LORENTZ-TRANSFORMATION IN I1-I2-C.M. SYSTEM
4496 ETOTAL = E1 + E2
4497 BETAX = (PX1+PX2) / ETOTAL
4498 BETAY = (PY1+PY2) / ETOTAL
4499 BETAZ = (PZ1+PZ2) / ETOTAL
4500 GAMMA = 1.0 / SQRT(1.0-BETAX**2-BETAY**2-BETAZ**2)
4501*TRANSFORMATION OF MOMENTA (PX1CM = - PX2CM)
4502 P1BETA = PX1*BETAX + PY1*BETAY + PZ1 * BETAZ
4503 TRANSF = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) - E1 )
4504 PX1CM = BETAX * TRANSF + PX1
4505 PY1CM = BETAY * TRANSF + PY1
4506 PZ1CM = BETAZ * TRANSF + PZ1
4507 RETURN
4508 END
4509***************************************
4510 SUBROUTINE DISTCE(I1,I2,DELTAR,DS,DT,EC,SRT
4511 1 ,IC,PX1CM,PY1CM,PZ1CM)
4512* PURPOSE : CHECK IF THE COLLISION BETWEEN TWO PARTICLES CAN HAPPEN
4513* BY CHECKING
4514* (1) IF THE DISTANCE BETWEEN THEM IS SMALLER
4515* THAN THE MAXIMUM DISTANCE DETERMINED FROM THE CROSS SECTION.
4516* (2) IF PARTICLE WILL PASS EACH OTHER WITHIN
4517* TWO HARD CORE RADIUS.
4518* (3) IF PARTICLES WILL GET CLOSER.
4519* VARIABLES :
4520* IC=1 COLLISION HAPPENED
4521* IC=-1 COLLISION CAN NOT HAPPEN
4522*****************************************
4523 PARAMETER (MAXSTR=150001)
4524 COMMON /AA/ R(3,MAXSTR)
4525cc SAVE /AA/
4526 COMMON /BB/ P(3,MAXSTR)
4527cc SAVE /BB/
4528 COMMON /CC/ E(MAXSTR)
4529cc SAVE /CC/
4530 COMMON /BG/ BETAX,BETAY,BETAZ,GAMMA
4531 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
4532cc SAVE /BG/
4533 common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
4534 1 px1n,py1n,pz1n,dp1n
4535 common /dpi/em2,lb2
4536 SAVE
4537 IC=0
4538 X1=R(1,I1)
4539 Y1=R(2,I1)
4540 Z1=R(3,I1)
4541 PX1=P(1,I1)
4542 PY1=P(2,I1)
4543 PZ1=P(3,I1)
4544 X2=R(1,I2)
4545 Y2=R(2,I2)
4546 Z2=R(3,I2)
4547 PX2=P(1,I2)
4548 PY2=P(2,I2)
4549 PZ2=P(3,I2)
4550 EM1=E(I1)
4551 EM2=E(I2)
4552 E1=SQRT(EM1**2+PX1**2+PY1**2+PZ1**2)
4553c IF (ABS(X1-X2) .GT. DELTAR) GO TO 400
4554c IF (ABS(Y1-Y2) .GT. DELTAR) GO TO 400
4555c IF (ABS(Z1-Z2) .GT. DELTAR) GO TO 400
4556 RSQARE = (X1-X2)**2 + (Y1-Y2)**2 + (Z1-Z2)**2
4557 IF (RSQARE .GT. DELTAR**2) GO TO 400
4558*NOW PARTICLES ARE CLOSE ENOUGH TO EACH OTHER !
4559 E2 = SQRT ( EM2**2 + PX2**2 + PY2**2 + PZ2**2 )
4560 S = SRT*SRT
4561 IF (S .LT. EC) GO TO 400
4562*NOW THERE IS ENOUGH ENERGY AVAILABLE !
4563*LORENTZ-TRANSFORMATION IN I1-I2-C.M. SYSTEM
4564* BETAX, BETAY, BETAZ AND GAMMA HAVE BEEN GIVEN IN THE SUBROUTINE CMS
4565*TRANSFORMATION OF MOMENTA (PX1CM = - PX2CM)
4566 P1BETA = PX1*BETAX + PY1*BETAY + PZ1 * BETAZ
4567 TRANSF = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) - E1 )
4568 PRCM = SQRT (PX1CM**2 + PY1CM**2 + PZ1CM**2)
4569 IF (PRCM .LE. 0.00001) GO TO 400
4570*TRANSFORMATION OF SPATIAL DISTANCE
4571 DRBETA = BETAX*(X1-X2) + BETAY*(Y1-Y2) + BETAZ*(Z1-Z2)
4572 TRANSF = GAMMA * GAMMA * DRBETA / (GAMMA + 1)
4573 DXCM = BETAX * TRANSF + X1 - X2
4574 DYCM = BETAY * TRANSF + Y1 - Y2
4575 DZCM = BETAZ * TRANSF + Z1 - Z2
4576*DETERMINING IF THIS IS THE POINT OF CLOSEST APPROACH
4577 DRCM = SQRT (DXCM**2 + DYCM**2 + DZCM**2 )
4578 DZZ = (PX1CM*DXCM + PY1CM*DYCM + PZ1CM*DZCM) / PRCM
4579 if ((drcm**2 - dzz**2) .le. 0.) then
4580 BBB = 0.
4581 else
4582 BBB = SQRT (DRCM**2 - DZZ**2)
4583 end if
4584*WILL PARTICLE PASS EACH OTHER WITHIN 2 * HARD CORE RADIUS ?
4585 IF (BBB .GT. DS) GO TO 400
4586 RELVEL = PRCM * (1.0/E1 + 1.0/E2)
4587 DDD = RELVEL * DT * 0.5
4588*WILL PARTICLES GET CLOSER ?
4589 IF (ABS(DDD) .LT. ABS(DZZ)) GO TO 400
4590 IC=1
4591 GO TO 500
4592400 IC=-1
4593500 CONTINUE
4594 RETURN
4595 END
4596****************************************
4597* *
4598* *
4599 SUBROUTINE CRNN(IRUN,PX,PY,PZ,SRT,I1,I2,IBLOCK,
4600 1NTAG,SIGNN,SIG,NT,ipert1)
4601* PURPOSE: *
4602* DEALING WITH NUCLEON-NUCLEON COLLISIONS *
4603* NOTE : *
4604* QUANTITIES: *
4605* PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
4606* SRT - SQRT OF S *
4607* NSTAR =1 INCLUDING N* RESORANCE,ELSE NOT *
4608* NDIRCT=1 INCLUDING DIRECT PION PRODUCTION PROCESS *
4609* IBLOCK - THE INFORMATION BACK *
4610* 0-> COLLISION CANNOT HAPPEN *
4611* 1-> N-N ELASTIC COLLISION *
4612* 2-> N+N->N+DELTA,OR N+N->N+N* REACTION *
4613* 3-> N+DELTA->N+N OR N+N*->N+N REACTION *
4614* 4-> N+N->D+D+pion reaction
4615* 43->N+N->D(N*)+D(N*) reaction
4616* 44->N+N->D+D+rho reaction
4617* 45->N+N->N+N+rho
4618* 46->N+N->N+N+omega
4619* N12 - IS USED TO SPECIFY BARYON-BARYON REACTION *
4620* CHANNELS. M12 IS THE REVERSAL CHANNEL OF N12 *
4621* N12, *
4622* M12=1 FOR p+n-->delta(+)+ n *
4623* 2 p+n-->delta(0)+ p *
4624* 3 p+p-->delta(++)+n *
4625* 4 p+p-->delta(+)+p *
4626* 5 n+n-->delta(0)+n *
4627* 6 n+n-->delta(-)+p *
4628* 7 n+p-->N*(0)(1440)+p *
4629* 8 n+p-->N*(+)(1440)+n *
4630* 9 p+p-->N*(+)(1535)+p *
4631* 10 n+n-->N*(0)(1535)+n *
4632* 11 n+p-->N*(+)(1535)+n *
4633* 12 n+p-->N*(0)(1535)+p
4634* 13 D(++)+D(-)-->N*(+)(1440)+n
4635* 14 D(++)+D(-)-->N*(0)(1440)+p
4636* 15 D(+)+D(0)--->N*(+)(1440)+n
4637* 16 D(+)+D(0)--->N*(0)(1440)+p
4638* 17 D(++)+D(0)-->N*(+)(1535)+p
4639* 18 D(++)+D(-)-->N*(0)(1535)+p
4640* 19 D(++)+D(-)-->N*(+)(1535)+n
4641* 20 D(+)+D(+)-->N*(+)(1535)+p
4642* 21 D(+)+D(0)-->N*(+)(1535)+n
4643* 22 D(+)+D(0)-->N*(0)(1535)+p
4644* 23 D(+)+D(-)-->N*(0)(1535)+n
4645* 24 D(0)+D(0)-->N*(0)(1535)+n
4646* 25 N*(+)(14)+N*(+)(14)-->N*(+)(15)+p
4647* 26 N*(0)(14)+N*(0)(14)-->N*(0)(15)+n
4648* 27 N*(+)(14)+N*(0)(14)-->N*(+)(15)+n
4649* 28 N*(+)(14)+N*(0)(14)-->N*(0)(15)+p
4650* 29 N*(+)(14)+D+-->N*(+)(15)+p
4651* 30 N*(+)(14)+D0-->N*(+)(15)+n
4652* 31 N*(+)(14)+D(-)-->N*(0)(1535)+n
4653* 32 N*(0)(14)+D++--->N*(+)(15)+p
4654* 33 N*(0)(14)+D+--->N*(+)(15)+n
4655* 34 N*(0)(14)+D+--->N*(0)(15)+p
4656* 35 N*(0)(14)+D0-->N*(0)(15)+n
4657* 36 N*(+)(14)+D0--->N*(0)(15)+p
4658* ++ see the note book for more listing
4659*
4660*
4661* NOTE ABOUT N*(1440) RESORANCE IN Nucleon+NUCLEON COLLISION: *
4662* As it has been discussed in VerWest's paper,I= 1(initial isospin)*
4663* channel can all be attributed to delta resorance while I= 0 *
4664* channel can all be attribured to N* resorance.Only in n+p *
4665* one can have I=0 channel so is the N*(1440) resonance *
4666* *
4667* REFERENCES: *
4668* J. CUGNON ET AL., NUCL. PHYS. A352, 505 (1981) *
4669* Y. KITAZOE ET AL., PHYS. LETT. 166B, 35 (1986) *
4670* B. VerWest el al., PHYS. PRV. C25 (1982)1979 *
4671* Gy. Wolf et al, Nucl Phys A517 (1990) 615; *
4672* Nucl phys A552 (1993) 349. *
4673**********************************
4674 PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
4675 1 AMP=0.93828,AP1=0.13496,aka=0.498,AP2=0.13957,AM0=1.232,
4676 2 PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383,APHI=1.020)
4677 parameter (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
4678 parameter (xmd=1.8756,npdmax=10000)
4679 COMMON /AA/ R(3,MAXSTR)
4680cc SAVE /AA/
4681 COMMON /BB/ P(3,MAXSTR)
4682cc SAVE /BB/
4683 COMMON /CC/ E(MAXSTR)
4684cc SAVE /CC/
4685 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
4686cc SAVE /EE/
4687 common /ff/f(-mx:mx,-my:my,-mz:mz,-mpx:mpx,-mpy:mpy,-mpz:mpzp)
4688cc SAVE /ff/
4689 common /gg/ dx,dy,dz,dpx,dpy,dpz
4690cc SAVE /gg/
4691 COMMON /INPUT/ NSTAR,NDIRCT,DIR
4692cc SAVE /INPUT/
4693 COMMON /NN/NNN
4694cc SAVE /NN/
4695 COMMON /BG/BETAX,BETAY,BETAZ,GAMMA
4696cc SAVE /BG/
4697 COMMON /RUN/NUM
4698cc SAVE /RUN/
4699 COMMON /PA/RPION(3,MAXSTR,MAXR)
4700cc SAVE /PA/
4701 COMMON /PB/PPION(3,MAXSTR,MAXR)
4702cc SAVE /PB/
4703 COMMON /PC/EPION(MAXSTR,MAXR)
4704cc SAVE /PC/
4705 COMMON /PD/LPION(MAXSTR,MAXR)
4706cc SAVE /PD/
4707 COMMON/TABLE/ xarray(0:1000),earray(0:1000)
4708cc SAVE /TABLE/
4709 common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
4710cc SAVE /input1/
4711 common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
4712 1 px1n,py1n,pz1n,dp1n
4713cc SAVE /leadng/
4714 COMMON/RNDF77/NSEED
4715cc SAVE /RNDF77/
4716 common /dpi/em2,lb2
4717 COMMON /dpert/dpertt(MAXSTR,MAXR),dpertp(MAXSTR),dplast(MAXSTR),
4718 1 dpdcy(MAXSTR),dpdpi(MAXSTR,MAXR),dpt(MAXSTR, MAXR),
4719 2 dpp1(MAXSTR,MAXR),dppion(MAXSTR,MAXR)
4720 common /para8/ idpert,npertd,idxsec
4721 dimension ppd(3,npdmax),lbpd(npdmax)
4722 SAVE
4723*-----------------------------------------------------------------------
4724 n12=0
4725 m12=0
4726 IBLOCK=0
4727 NTAG=0
4728 EM1=E(I1)
4729 EM2=E(I2)
4730 PR=SQRT( PX**2 + PY**2 + PZ**2 )
4731 C2=PZ / PR
4732 X1=RANART(NSEED)
4733 ianti=0
4734 if(lb(i1).lt.0 .and. lb(i2).lt.0) ianti=1
4735 call sbbdm(srt,sdprod,ianti,lbm,xmm,pfinal)
4736clin-5/2008 Production of perturbative deuterons for idpert=1:
4737 if(idpert.eq.1.and.ipert1.eq.1) then
4738 IF (SRT .LT. 2.012) RETURN
4739 if((iabs(lb(i1)).eq.1.or.iabs(lb(i1)).eq.2)
4740 1 .and.(iabs(lb(i2)).eq.1.or.iabs(lb(i2)).eq.2)) then
4741 goto 108
4742 else
4743 return
4744 endif
4745 endif
4746c
4747*-----------------------------------------------------------------------
4748*COM: TEST FOR ELASTIC SCATTERING (EITHER N-N OR DELTA-DELTA 0R
4749* N-DELTA OR N*-N* or N*-Delta)
4750c IF (X1 .LE. SIGNN/SIG) THEN
4751 IF (X1.LE.(SIGNN/SIG)) THEN
4752*COM: PARAMETRISATION IS TAKEN FROM THE CUGNON-PAPER
4753 AS = ( 3.65 * (SRT - 1.8766) )**6
4754 A = 6.0 * AS / (1.0 + AS)
4755 TA = -2.0 * PR**2
4756 X = RANART(NSEED)
4757clin-10/24/02 T1 = DLOG( (1-X) * DEXP(dble(A)*dble(TA)) + X ) / A
4758 T1 = sngl(DLOG(dble(1.-X)*DEXP(dble(A)*dble(TA))+dble(X)))/ A
4759 C1 = 1.0 - T1/TA
4760 T1 = 2.0 * PI * RANART(NSEED)
4761 IBLOCK=1
4762 GO TO 107
4763 ELSE
4764*COM: TEST FOR INELASTIC SCATTERING
4765* IF THE AVAILABLE ENERGY IS LESS THAN THE PION-MASS, NOTHING
4766* CAN HAPPEN ANY MORE ==> RETURN (2.012 = 2*AVMASS + PI-MASS)
4767clin-5/2008: Mdeuteron+Mpi=2.0106 to 2.0152 GeV/c2, so we can still use this:
4768 IF (SRT .LT. 2.012) RETURN
4769* calculate the N*(1535) production cross section in N+N collisions
4770* note that the cross sections in this subroutine are in units of mb
4771* as only ratios of the cross sections are used to determine the
4772* reaction channels
4773 call N1535(iabs(lb(i1)),iabs(lb(i2)),srt,x1535)
4774*COM: HERE WE HAVE A PROCESS N+N ==> N+DELTA,OR N+N==>N+N*(144) or N*(1535)
4775* OR
4776* 3 pi channel : N+N==>d1+d2+PION
4777 SIG3=3.*(X3pi(SRT)+x33pi(srt))
4778* 2 pi channel : N+N==>d1+d2+d1*n*+n*n*
4779 SIG4=4.*X2pi(srt)
4780* 4 pi channel : N+N==>d1+d2+rho
4781 s4pi=x4pi(srt)
4782* N+N-->NN+rho channel
4783 srho=xrho(srt)
4784* N+N-->NN+omega
4785 somega=omega(srt)
4786* CROSS SECTION FOR KAON PRODUCTION from the four channels
4787* for NLK channel
4788 akp=0.498
4789 ak0=0.498
4790 ana=0.94
4791 ada=1.232
4792 al=1.1157
4793 as=1.1197
4794 xsk1=0
4795 xsk2=0
4796 xsk3=0
4797 xsk4=0
4798 xsk5=0
4799 t1nlk=ana+al+akp
4800 if(srt.le.t1nlk)go to 222
4801 XSK1=1.5*PPLPK(SRT)
4802* for DLK channel
4803 t1dlk=ada+al+akp
4804 t2dlk=ada+al-akp
4805 if(srt.le.t1dlk)go to 222
4806 es=srt
4807 pmdlk2=(es**2-t1dlk**2)*(es**2-t2dlk**2)/(4.*es**2)
4808 pmdlk=sqrt(pmdlk2)
4809 XSK3=1.5*PPLPK(srt)
4810* for NSK channel
4811 t1nsk=ana+as+akp
4812 t2nsk=ana+as-akp
4813 if(srt.le.t1nsk)go to 222
4814 pmnsk2=(es**2-t1nsk**2)*(es**2-t2nsk**2)/(4.*es**2)
4815 pmnsk=sqrt(pmnsk2)
4816 XSK2=1.5*(PPK1(srt)+PPK0(srt))
4817* for DSK channel
4818 t1DSk=aDa+aS+akp
4819 t2DSk=aDa+aS-akp
4820 if(srt.le.t1dsk)go to 222
4821 pmDSk2=(es**2-t1DSk**2)*(es**2-t2DSk**2)/(4.*es**2)
4822 pmDSk=sqrt(pmDSk2)
4823 XSK4=1.5*(PPK1(srt)+PPK0(srt))
4824csp11/21/01
4825c phi production
4826 if(srt.le.(2.*amn+aphi))go to 222
4827c !! mb put the correct form
4828 xsk5 = 0.0001
4829csp11/21/01 end
4830c
4831* THE TOTAL KAON+ PRODUCTION CROSS SECTION IS THEN
4832 222 SIGK=XSK1+XSK2+XSK3+XSK4
4833
4834cbz3/7/99 neutralk
4835 XSK1 = 2.0 * XSK1
4836 XSK2 = 2.0 * XSK2
4837 XSK3 = 2.0 * XSK3
4838 XSK4 = 2.0 * XSK4
4839 SIGK = 2.0 * SIGK + xsk5
4840cbz3/7/99 neutralk end
4841c
4842** FOR P+P or L/S+L/S COLLISION:
4843c lb1=lb(i1)
4844c lb2=lb(i2)
4845 lb1=iabs(lb(i1))
4846 lb2=iabs(lb(i2))
4847 IF((LB(I1)*LB(I2).EQ.1).or.
4848 & ((lb1.le.17.and.lb1.ge.14).and.(lb2.le.17.and.lb2.ge.14)).
4849 & or.((lb1.le.2).and.(lb2.le.17.and.lb2.ge.14)).
4850 & or.((lb2.le.2).and.(lb1.le.17.and.lb1.ge.14)))THEN
4851clin-8/2008 PP->d+meson here:
4852 IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
4853 SIG1=SIGMA(SRT,1,1,0)+0.5*SIGMA(SRT,1,1,1)
4854 SIG2=1.5*SIGMA(SRT,1,1,1)
4855 SIGND=SIG1+SIG2+SIG3+SIG4+X1535+SIGK+s4pi+srho+somega
4856clin-5/2008:
4857c IF (X1.GT.(SIGNN+SIGND)/SIG)RETURN
4858 IF (X1.GT.(SIGNN+SIGND+sdprod)/SIG)RETURN
4859 DIR=SIG3/SIGND
4860 IF(RANART(NSEED).LE.DIR)GO TO 106
4861 IF(RANART(NSEED).LE.SIGK/(SIGK+X1535+SIG4+SIG2+SIG1
4862 & +s4pi+srho+somega))GO TO 306
4863 if(RANART(NSEED).le.s4pi/(x1535+sig4+sig2+sig1
4864 & +s4pi+srho+somega))go to 307
4865 if(RANART(NSEED).le.srho/(x1535+sig4+sig2+sig1
4866 & +srho+somega))go to 308
4867 if(RANART(NSEED).le.somega/(x1535+sig4+sig2+sig1
4868 & +somega))go to 309
4869 if(RANART(NSEED).le.x1535/(sig1+sig2+sig4+x1535))then
4870* N*(1535) production
4871 N12=9
4872 ELSE
4873 IF(RANART(NSEED).LE.SIG4/(SIG1+sig2+sig4))THEN
4874* DOUBLE DELTA PRODUCTION
4875 N12=66
4876 GO TO 1012
4877 else
4878*DELTA PRODUCTION
4879 N12=3
4880 IF (RANART(NSEED).GT.SIG1/(SIG1+SIG2))N12=4
4881 ENDIF
4882 endif
4883 GO TO 1011
4884 ENDIF
4885** FOR N+N COLLISION:
4886 IF(iabs(LB(I1)).EQ.2.AND.iabs(LB(I2)).EQ.2)THEN
4887clin-8/2008 NN->d+meson here:
4888 IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
4889 SIG1=SIGMA(SRT,1,1,0)+0.5*SIGMA(SRT,1,1,1)
4890 SIG2=1.5*SIGMA(SRT,1,1,1)
4891 SIGND=SIG1+SIG2+X1535+SIG3+SIG4+SIGK+s4pi+srho+somega
4892clin-5/2008:
4893c IF (X1.GT.(SIGNN+SIGND)/SIG)RETURN
4894 IF (X1.GT.(SIGNN+SIGND+sdprod)/SIG)RETURN
4895 dir=sig3/signd
4896 IF(RANART(NSEED).LE.DIR)GO TO 106
4897 IF(RANART(NSEED).LE.SIGK/(SIGK+X1535+SIG4+SIG2+SIG1
4898 & +s4pi+srho+somega))GO TO 306
4899 if(RANART(NSEED).le.s4pi/(x1535+sig4+sig2+sig1
4900 & +s4pi+srho+somega))go to 307
4901 if(RANART(NSEED).le.srho/(x1535+sig4+sig2+sig1
4902 & +srho+somega))go to 308
4903 if(RANART(NSEED).le.somega/(x1535+sig4+sig2+sig1
4904 & +somega))go to 309
4905 IF(RANART(NSEED).LE.X1535/(x1535+sig1+sig2+sig4))THEN
4906* N*(1535) PRODUCTION
4907 N12=10
4908 ELSE
4909 if(RANART(NSEED).le.sig4/(sig1+sig2+sig4))then
4910* double delta production
4911 N12=67
4912 GO TO 1013
4913 else
4914* DELTA PRODUCTION
4915 N12=6
4916 IF (RANART(NSEED).GT.SIG1/(SIG1+SIG2))N12=5
4917 ENDIF
4918 endif
4919 GO TO 1011
4920 ENDIF
4921** FOR N+P COLLISION
4922 IF(LB(I1)*LB(I2).EQ.2)THEN
4923clin-5/2008 NP->d+meson here:
4924 IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
4925 SIG1=0.5*SIGMA(SRT,1,1,1)+0.25*SIGMA(SRT,1,1,0)
4926 IF(NSTAR.EQ.1)THEN
4927 SIG2=(3./4.)*SIGMA(SRT,2,0,1)
4928 ELSE
4929 SIG2=0.
4930 ENDIF
4931 SIGND=2.*(SIG1+SIG2+X1535)+sig3+sig4+SIGK+s4pi+srho+somega
4932clin-5/2008:
4933c IF (X1.GT.(SIGNN+SIGND)/SIG)RETURN
4934 IF (X1.GT.(SIGNN+SIGND+sdprod)/SIG)RETURN
4935 dir=sig3/signd
4936 IF(RANART(NSEED).LE.DIR)GO TO 106
4937 IF(RANART(NSEED).LE.SIGK/(SIGND-SIG3))GO TO 306
4938 if(RANART(NSEED).le.s4pi/(signd-sig3-sigk))go to 307
4939 if(RANART(NSEED).le.srho/(signd-sig3-sigk-s4pi))go to 308
4940 if(RANART(NSEED).le.somega/(signd-sig3-sigk-s4pi-srho))
4941 1 go to 309
4942 IF(RANART(NSEED).LT.X1535/(SIG1+SIG2+X1535+0.5*sig4))THEN
4943* N*(1535) PRODUCTION
4944 N12=11
4945 IF(RANART(NSEED).LE.0.5)N12=12
4946 ELSE
4947 if(RANART(NSEED).le.sig4/(sig4+2.*(sig1+sig2)))then
4948* double resonance production
4949 N12=68
4950 GO TO 1014
4951 else
4952 IF(RANART(NSEED).LE.SIG1/(SIG1+SIG2))THEN
4953* DELTA PRODUCTION
4954 N12=2
4955 IF(RANART(NSEED).GE.0.5)N12=1
4956 ELSE
4957* N*(1440) PRODUCTION
4958 N12=8
4959 IF(RANART(NSEED).GE.0.5)N12=7
4960 ENDIF
4961 ENDIF
4962 ENDIF
4963 endif
4964 1011 iblock=2
4965 CONTINUE
4966*PARAMETRIZATION OF THE SHAPE OF THE DELTA RESONANCE ACCORDING
4967* TO kitazoe's or J.D.JACKSON'S MASS FORMULA AND BREIT WIGNER
4968* FORMULA FOR N* RESORANCE
4969* DETERMINE DELTA MASS VIA REJECTION METHOD.
4970 DMAX = SRT - AVMASS-0.005
4971 DMAX = SRT - AVMASS-0.005
4972 DMIN = 1.078
4973 IF(N12.LT.7)THEN
4974* Delta(1232) production
4975 IF(DMAX.LT.1.232) THEN
4976 FM=FDE(DMAX,SRT,0.)
4977 ELSE
4978
4979clin-10/25/02 get rid of argument usage mismatch in FDE():
4980 xdmass=1.232
4981c FM=FDE(1.232,SRT,1.)
4982 FM=FDE(xdmass,SRT,1.)
4983clin-10/25/02-end
4984
4985 ENDIF
4986 IF(FM.EQ.0.)FM=1.E-09
4987 NTRY1=0
498810 DM = RANART(NSEED) * (DMAX-DMIN) + DMIN
4989 NTRY1=NTRY1+1
4990 IF((RANART(NSEED) .GT. FDE(DM,SRT,1.)/FM).AND.
4991 1 (NTRY1.LE.30)) GOTO 10
4992
4993clin-2/26/03 limit the Delta mass below a certain value
4994c (here taken as its central value + 2* B-W fullwidth):
4995 if(dm.gt.1.47) goto 10
4996
4997 GO TO 13
4998 ENDIF
4999 IF((n12.eq.7).or.(n12.eq.8))THEN
5000* N*(1440) production
5001 IF(DMAX.LT.1.44) THEN
5002 FM=FNS(DMAX,SRT,0.)
5003 ELSE
5004
5005clin-10/25/02 get rid of argument usage mismatch in FNS():
5006 xdmass=1.44
5007c FM=FNS(1.44,SRT,1.)
5008 FM=FNS(xdmass,SRT,1.)
5009clin-10/25/02-end
5010
5011 ENDIF
5012 IF(FM.EQ.0.)FM=1.E-09
5013 NTRY2=0
501411 DM=RANART(NSEED)*(DMAX-DMIN)+DMIN
5015 NTRY2=NTRY2+1
5016 IF((RANART(NSEED).GT.FNS(DM,SRT,1.)/FM).AND.
5017 1 (NTRY2.LE.10)) GO TO 11
5018
5019clin-2/26/03 limit the N* mass below a certain value
5020c (here taken as its central value + 2* B-W fullwidth):
5021 if(dm.gt.2.14) goto 11
5022
5023 GO TO 13
5024 ENDIF
5025 IF(n12.ge.17)then
5026* N*(1535) production
5027 IF(DMAX.LT.1.535) THEN
5028 FM=FD5(DMAX,SRT,0.)
5029 ELSE
5030
5031clin-10/25/02 get rid of argument usage mismatch in FNS():
5032 xdmass=1.535
5033c FM=FD5(1.535,SRT,1.)
5034 FM=FD5(xdmass,SRT,1.)
5035clin-10/25/02-end
5036
5037 ENDIF
5038 IF(FM.EQ.0.)FM=1.E-09
5039 NTRY1=0
504012 DM = RANART(NSEED) * (DMAX-DMIN) + DMIN
5041 NTRY1=NTRY1+1
5042 IF((RANART(NSEED) .GT. FD5(DM,SRT,1.)/FM).AND.
5043 1 (NTRY1.LE.10)) GOTO 12
5044
5045clin-2/26/03 limit the N* mass below a certain value
5046c (here taken as its central value + 2* B-W fullwidth):
5047 if(dm.gt.1.84) goto 12
5048
5049 GO TO 13
5050 ENDIF
5051* CALCULATE THE MASSES OF BARYON RESONANCES IN THE DOUBLE RESONANCE
5052* PRODUCTION PROCESS AND RELABLE THE PARTICLES
50531012 iblock=43
5054 call Rmasdd(srt,1.232,1.232,1.08,
5055 & 1.08,ISEED,1,dm1,dm2)
5056 call Rmasdd(srt,1.232,1.44,1.08,
5057 & 1.08,ISEED,3,dm1n,dm2n)
5058 IF(N12.EQ.66)THEN
5059*(1) PP-->DOUBLE RESONANCES
5060* DETERMINE THE FINAL STATE
5061 XFINAL=RANART(NSEED)
5062 IF(XFINAL.LE.0.25)THEN
5063* (1.1) D+++D0
5064 LB(I1)=9
5065 LB(I2)=7
5066 e(i1)=dm1
5067 e(i2)=dm2
5068 GO TO 200
5069* go to 200 to set the new momentum
5070 ENDIF
5071 IF((XFINAL.gt.0.25).and.(xfinal.le.0.5))THEN
5072* (1.2) D++D+
5073 LB(I1)=8
5074 LB(I2)=8
5075 e(i1)=dm1
5076 e(i2)=dm2
5077 GO TO 200
5078* go to 200 to set the new momentum
5079 ENDIF
5080 IF((XFINAL.gt.0.5).and.(xfinal.le.0.75))THEN
5081* (1.3) D+++N*0
5082 LB(I1)=9
5083 LB(I2)=10
5084 e(i1)=dm1n
5085 e(i2)=dm2n
5086 GO TO 200
5087* go to 200 to set the new momentum
5088 ENDIF
5089 IF(XFINAL.gt.0.75)then
5090* (1.4) D++N*+
5091 LB(I1)=8
5092 LB(I2)=11
5093 e(i1)=dm1n
5094 e(i2)=dm2n
5095 GO TO 200
5096* go to 200 to set the new momentum
5097 ENDIF
5098 ENDIF
50991013 iblock=43
5100 call Rmasdd(srt,1.232,1.232,1.08,
5101 & 1.08,ISEED,1,dm1,dm2)
5102 call Rmasdd(srt,1.232,1.44,1.08,
5103 & 1.08,ISEED,3,dm1n,dm2n)
5104 IF(N12.EQ.67)THEN
5105*(2) NN-->DOUBLE RESONANCES
5106* DETERMINE THE FINAL STATE
5107 XFINAL=RANART(NSEED)
5108 IF(XFINAL.LE.0.25)THEN
5109* (2.1) D0+D0
5110 LB(I1)=7
5111 LB(I2)=7
5112 e(i1)=dm1
5113 e(i2)=dm2
5114 GO TO 200
5115* go to 200 to set the new momentum
5116 ENDIF
5117 IF((XFINAL.gt.0.25).and.(xfinal.le.0.5))THEN
5118* (2.2) D++D+
5119 LB(I1)=6
5120 LB(I2)=8
5121 e(i1)=dm1
5122 e(i2)=dm2
5123 GO TO 200
5124* go to 200 to set the new momentum
5125 ENDIF
5126 IF((XFINAL.gt.0.5).and.(xfinal.le.0.75))THEN
5127* (2.3) D0+N*0
5128 LB(I1)=7
5129 LB(I2)=10
5130 e(i1)=dm1n
5131 e(i2)=dm2n
5132 GO TO 200
5133* go to 200 to set the new momentum
5134 ENDIF
5135 IF(XFINAL.gt.0.75)then
5136* (2.4) D++N*+
5137 LB(I1)=8
5138 LB(I2)=11
5139 e(i1)=dm1n
5140 e(i2)=dm2n
5141 GO TO 200
5142* go to 200 to set the new momentum
5143 ENDIF
5144 ENDIF
51451014 iblock=43
5146 call Rmasdd(srt,1.232,1.232,1.08,
5147 & 1.08,ISEED,1,dm1,dm2)
5148 call Rmasdd(srt,1.232,1.44,1.08,
5149 & 1.08,ISEED,3,dm1n,dm2n)
5150 IF(N12.EQ.68)THEN
5151*(3) NP-->DOUBLE RESONANCES
5152* DETERMINE THE FINAL STATE
5153 XFINAL=RANART(NSEED)
5154 IF(XFINAL.LE.0.25)THEN
5155* (3.1) D0+D+
5156 LB(I1)=7
5157 LB(I2)=8
5158 e(i1)=dm1
5159 e(i2)=dm2
5160 GO TO 200
5161* go to 200 to set the new momentum
5162 ENDIF
5163 IF((XFINAL.gt.0.25).and.(xfinal.le.0.5))THEN
5164* (3.2) D+++D-
5165 LB(I1)=9
5166 LB(I2)=6
5167 e(i1)=dm1
5168 e(i2)=dm2
5169 GO TO 200
5170* go to 200 to set the new momentum
5171 ENDIF
5172 IF((XFINAL.gt.0.5).and.(xfinal.le.0.75))THEN
5173* (3.3) D0+N*+
5174 LB(I1)=7
5175 LB(I2)=11
5176 e(i1)=dm1n
5177 e(i2)=dm2n
5178 GO TO 200
5179* go to 200 to set the new momentum
5180 ENDIF
5181 IF(XFINAL.gt.0.75)then
5182* (3.4) D++N*0
5183 LB(I1)=8
5184 LB(I2)=10
5185 e(i1)=dm1n
5186 e(i2)=dm2n
5187 GO TO 200
5188* go to 200 to set the new momentum
5189 ENDIF
5190 ENDIF
519113 CONTINUE
5192*-------------------------------------------------------
5193* RELABLE BARYON I1 AND I2
5194*1. p+n-->delta(+)+n
5195 IF(N12.EQ.1)THEN
5196 IF(iabs(LB(I1)).EQ.1)THEN
5197 LB(I2)=2
5198 LB(I1)=8
5199 E(I1)=DM
5200 ELSE
5201 LB(I1)=2
5202 LB(I2)=8
5203 E(I2)=DM
5204 ENDIF
5205 GO TO 200
5206 ENDIF
5207*2 p+n-->delta(0)+p
5208 IF(N12.EQ.2)THEN
5209 IF(iabs(LB(I1)).EQ.2)THEN
5210 LB(I2)=1
5211 LB(I1)=7
5212 E(I1)=DM
5213 ELSE
5214 LB(I1)=1
5215 LB(I2)=7
5216 E(I2)=DM
5217 ENDIF
5218 GO TO 200
5219 ENDIF
5220*3 p+p-->delta(++)+n
5221 IF(N12.EQ.3)THEN
5222 LB(I1)=9
5223 E(I1)=DM
5224 LB(I2)=2
5225 E(I2)=AMN
5226 GO TO 200
5227 ENDIF
5228*4 p+p-->delta(+)+p
5229 IF(N12.EQ.4)THEN
5230 LB(I2)=1
5231 LB(I1)=8
5232 E(I1)=DM
5233 GO TO 200
5234 ENDIF
5235*5 n+n--> delta(0)+n
5236 IF(N12.EQ.5)THEN
5237 LB(I2)=2
5238 LB(I1)=7
5239 E(I1)=DM
5240 GO TO 200
5241 ENDIF
5242*6 n+n--> delta(-)+p
5243 IF(N12.EQ.6)THEN
5244 LB(I1)=6
5245 E(I1)=DM
5246 LB(I2)=1
5247 E(I2)=AMP
5248 GO TO 200
5249 ENDIF
5250*7 n+p--> N*(0)+p
5251 IF(N12.EQ.7)THEN
5252 IF(iabs(LB(I1)).EQ.1)THEN
5253 LB(I1)=1
5254 LB(I2)=10
5255 E(I2)=DM
5256 ELSE
5257 LB(I2)=1
5258 LB(I1)=10
5259 E(I1)=DM
5260 ENDIF
5261 GO TO 200
5262 ENDIF
5263*8 n+p--> N*(+)+n
5264 IF(N12.EQ.8)THEN
5265 IF(iabs(LB(I1)).EQ.1)THEN
5266 LB(I2)=2
5267 LB(I1)=11
5268 E(I1)=DM
5269 ELSE
5270 LB(I1)=2
5271 LB(I2)=11
5272 E(I2)=DM
5273 ENDIF
5274 GO TO 200
5275 ENDIF
5276*9 p+p--> N*(+)(1535)+p
5277 IF(N12.EQ.9)THEN
5278 IF(RANART(NSEED).le.0.5)THEN
5279 LB(I2)=1
5280 LB(I1)=13
5281 E(I1)=DM
5282 ELSE
5283 LB(I1)=1
5284 LB(I2)=13
5285 E(I2)=DM
5286 ENDIF
5287 GO TO 200
5288 ENDIF
5289*10 n+n--> N*(0)(1535)+n
5290 IF(N12.EQ.10)THEN
5291 IF(RANART(NSEED).le.0.5)THEN
5292 LB(I2)=2
5293 LB(I1)=12
5294 E(I1)=DM
5295 ELSE
5296 LB(I1)=2
5297 LB(I2)=12
5298 E(I2)=DM
5299 ENDIF
5300 GO TO 200
5301 ENDIF
5302*11 n+p--> N*(+)(1535)+n
5303 IF(N12.EQ.11)THEN
5304 IF(iabs(LB(I1)).EQ.2)THEN
5305 LB(I1)=2
5306 LB(I2)=13
5307 E(I2)=DM
5308 ELSE
5309 LB(I2)=2
5310 LB(I1)=13
5311 E(I1)=DM
5312 ENDIF
5313 GO TO 200
5314 ENDIF
5315*12 n+p--> N*(0)(1535)+p
5316 IF(N12.EQ.12)THEN
5317 IF(iabs(LB(I1)).EQ.1)THEN
5318 LB(I1)=1
5319 LB(I2)=12
5320 E(I2)=DM
5321 ELSE
5322 LB(I2)=1
5323 LB(I1)=12
5324 E(I1)=DM
5325 ENDIF
5326 ENDIF
5327 endif
5328* CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
5329* ENERGY CONSERVATION
5330200 EM1=E(I1)
5331 EM2=E(I2)
5332 PR2 = (SRT**2 - EM1**2 - EM2**2)**2
5333 1 - 4.0 * (EM1*EM2)**2
5334 IF(PR2.LE.0.)PR2=1.e-09
5335 PR=SQRT(PR2)/(2.*SRT)
5336 if(srt.le.2.14)C1= 1.0 - 2.0 * RANART(NSEED)
86c53b9e 5337 if(srt.gt.2.14.and.srt.le.2.4)c1=anga(srt,iseed)
0119ef9a 5338 if(srt.gt.2.4)then
5339
5340clin-10/25/02 get rid of argument usage mismatch in PTR():
5341 xptr=0.33*pr
5342c cc1=ptr(0.33*pr,iseed)
5343 cc1=ptr(xptr,iseed)
5344clin-10/25/02-end
5345
5346 c1=sqrt(pr**2-cc1**2)/pr
5347 endif
5348 T1 = 2.0 * PI * RANART(NSEED)
5349 if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
5350 lb(i1) = -lb(i1)
5351 lb(i2) = -lb(i2)
5352 endif
5353 GO TO 107
5354*FOR THE NN-->D1+D2+PI PROCESS, FIND MOMENTUM OF THE FINAL TWO
5355*DELTAS AND PION IN THE NUCLEUS-NUCLEUS CMS.
5356106 CONTINUE
5357 NTRY1=0
5358123 CALL DDP2(SRT,ISEED,PX3,PY3,PZ3,DM3,PX4,PY4,PZ4,DM4,
5359 & PPX,PPY,PPZ,icou1)
5360 NTRY1=NTRY1+1
5361 if((icou1.lt.0).AND.(NTRY1.LE.40))GO TO 123
5362C if(icou1.lt.0)return
5363* ROTATE THE MOMENTA OF PARTICLES IN THE CMS OF P1+P2
5364 CALL ROTATE(PX,PY,PZ,PX3,PY3,PZ3)
5365 CALL ROTATE(PX,PY,PZ,PX4,PY4,PZ4)
5366 CALL ROTATE(PX,PY,PZ,PPX,PPY,PPZ)
5367 NNN=NNN+1
5368* DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
5369* (1) FOR P+P
5370 XDIR=RANART(NSEED)
5371 IF(LB(I1)*LB(I2).EQ.1)THEN
5372 IF(XDIR.Le.0.2)then
5373* (1.1)P+P-->D+++D0+PION(0)
5374 LPION(NNN,IRUN)=4
5375 EPION(NNN,IRUN)=AP1
5376 LB(I1)=9
5377 LB(I2)=7
5378 GO TO 205
5379 ENDIF
5380* (1.2)P+P -->D++D+PION(0)
5381 IF((XDIR.LE.0.4).AND.(XDIR.GT.0.2))THEN
5382 LPION(NNN,IRUN)=4
5383 EPION(NNN,IRUN)=AP1
5384 LB(I1)=8
5385 LB(I2)=8
5386 GO TO 205
5387 ENDIF
5388* (1.3)P+P-->D+++D+PION(-)
5389 IF((XDIR.LE.0.6).AND.(XDIR.GT.0.4))THEN
5390 LPION(NNN,IRUN)=3
5391 EPION(NNN,IRUN)=AP2
5392 LB(I1)=9
5393 LB(I2)=8
5394 GO TO 205
5395 ENDIF
5396 IF((XDIR.LE.0.8).AND.(XDIR.GT.0.6))THEN
5397 LPION(NNN,IRUN)=5
5398 EPION(NNN,IRUN)=AP2
5399 LB(I1)=9
5400 LB(I2)=6
5401 GO TO 205
5402 ENDIF
5403 IF(XDIR.GT.0.8)THEN
5404 LPION(NNN,IRUN)=5
5405 EPION(NNN,IRUN)=AP2
5406 LB(I1)=7
5407 LB(I2)=8
5408 GO TO 205
5409 ENDIF
5410 ENDIF
5411* (2)FOR N+N
5412 IF(iabs(LB(I1)).EQ.2.AND.iabs(LB(I2)).EQ.2)THEN
5413 IF(XDIR.Le.0.2)then
5414* (2.1)N+N-->D++D-+PION(0)
5415 LPION(NNN,IRUN)=4
5416 EPION(NNN,IRUN)=AP1
5417 LB(I1)=6
5418 LB(I2)=7
5419 GO TO 205
5420 ENDIF
5421* (2.2)N+N -->D+++D-+PION(-)
5422 IF((XDIR.LE.0.4).AND.(XDIR.GT.0.2))THEN
5423 LPION(NNN,IRUN)=3
5424 EPION(NNN,IRUN)=AP2
5425 LB(I1)=6
5426 LB(I2)=9
5427 GO TO 205
5428 ENDIF
5429* (2.3)P+P-->D0+D-+PION(+)
5430 IF((XDIR.GT.0.4).AND.(XDIR.LE.0.6))THEN
5431 LPION(NNN,IRUN)=5
5432 EPION(NNN,IRUN)=AP2
5433 LB(I1)=9
5434 LB(I2)=8
5435 GO TO 205
5436 ENDIF
5437* (2.4)P+P-->D0+D0+PION(0)
5438 IF((XDIR.GT.0.6).AND.(XDIR.LE.0.8))THEN
5439 LPION(NNN,IRUN)=4
5440 EPION(NNN,IRUN)=AP1
5441 LB(I1)=7
5442 LB(I2)=7
5443 GO TO 205
5444 ENDIF
5445* (2.5)P+P-->D0+D++PION(-)
5446 IF(XDIR.GT.0.8)THEN
5447 LPION(NNN,IRUN)=3
5448 EPION(NNN,IRUN)=AP2
5449 LB(I1)=7
5450 LB(I2)=8
5451 GO TO 205
5452 ENDIF
5453 ENDIF
5454* (3)FOR N+P
5455 IF(LB(I1)*LB(I2).EQ.2)THEN
5456 IF(XDIR.Le.0.17)then
5457* (3.1)N+P-->D+++D-+PION(0)
5458 LPION(NNN,IRUN)=4
5459 EPION(NNN,IRUN)=AP1
5460 LB(I1)=6
5461 LB(I2)=9
5462 GO TO 205
5463 ENDIF
5464* (3.2)N+P -->D+++D0+PION(-)
5465 IF((XDIR.LE.0.34).AND.(XDIR.GT.0.17))THEN
5466 LPION(NNN,IRUN)=3
5467 EPION(NNN,IRUN)=AP2
5468 LB(I1)=7
5469 LB(I2)=9
5470 GO TO 205
5471 ENDIF
5472* (3.3)N+P-->D++D-+PION(+)
5473 IF((XDIR.GT.0.34).AND.(XDIR.LE.0.51))THEN
5474 LPION(NNN,IRUN)=5
5475 EPION(NNN,IRUN)=AP2
5476 LB(I1)=7
5477 LB(I2)=8
5478 GO TO 205
5479 ENDIF
5480* (3.4)N+P-->D++D++PION(-)
5481 IF((XDIR.GT.0.51).AND.(XDIR.LE.0.68))THEN
5482 LPION(NNN,IRUN)=3
5483 EPION(NNN,IRUN)=AP2
5484 LB(I1)=8
5485 LB(I2)=8
5486 GO TO 205
5487 ENDIF
5488* (3.5)N+P-->D0+D++PION(0)
5489 IF((XDIR.GT.0.68).AND.(XDIR.LE.0.85))THEN
5490 LPION(NNN,IRUN)=4
5491 EPION(NNN,IRUN)=AP2
5492 LB(I1)=7
5493 LB(I2)=8
5494 GO TO 205
5495 ENDIF
5496* (3.6)N+P-->D0+D0+PION(+)
5497 IF(XDIR.GT.0.85)THEN
5498 LPION(NNN,IRUN)=5
5499 EPION(NNN,IRUN)=AP2
5500 LB(I1)=7
5501 LB(I2)=7
5502 ENDIF
5503 ENDIF
5504* FIND THE MOMENTUM OF PARTICLES IN THE FINAL STATE IN THE NUCLEUS-
5505* NUCLEUS CMS. FRAME
5506* LORENTZ-TRANSFORMATION INTO LAB FRAME FOR DELTA1
5507205 E1CM = SQRT (dm3**2 + PX3**2 + PY3**2 + PZ3**2)
5508 P1BETA = PX3*BETAX + PY3*BETAY + PZ3*BETAZ
5509 TRANSF = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) + E1CM )
5510 Pt1i1 = BETAX * TRANSF + PX3
5511 Pt2i1 = BETAY * TRANSF + PY3
5512 Pt3i1 = BETAZ * TRANSF + PZ3
5513 Eti1 = DM3
5514c
5515 if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
5516 lb(i1) = -lb(i1)
5517 lb(i2) = -lb(i2)
5518 if(LPION(NNN,IRUN) .eq. 3)then
5519 LPION(NNN,IRUN)=5
5520 elseif(LPION(NNN,IRUN) .eq. 5)then
5521 LPION(NNN,IRUN)=3
5522 endif
5523 endif
5524c
5525 lb1=lb(i1)
5526* FOR DELTA2
5527 E2CM = SQRT (dm4**2 + PX4**2 + PY4**2 + PZ4**2)
5528 P2BETA = PX4*BETAX+PY4*BETAY+PZ4*BETAZ
5529 TRANSF = GAMMA * (GAMMA*P2BETA / (GAMMA + 1.) + E2CM)
5530 Pt1I2 = BETAX * TRANSF + PX4
5531 Pt2I2 = BETAY * TRANSF + PY4
5532 Pt3I2 = BETAZ * TRANSF + PZ4
5533 EtI2 = DM4
5534 lb2=lb(i2)
5535* assign delta1 and delta2 to i1 or i2 to keep the leadng particle
5536* behaviour
5537C if((pt1i1*px1+pt2i1*py1+pt3i1*pz1).gt.0)then
5538 p(1,i1)=pt1i1
5539 p(2,i1)=pt2i1
5540 p(3,i1)=pt3i1
5541 e(i1)=eti1
5542 lb(i1)=lb1
5543 p(1,i2)=pt1i2
5544 p(2,i2)=pt2i2
5545 p(3,i2)=pt3i2
5546 e(i2)=eti2
5547 lb(i2)=lb2
5548 PX1 = P(1,I1)
5549 PY1 = P(2,I1)
5550 PZ1 = P(3,I1)
5551 EM1 = E(I1)
5552 ID(I1) = 2
5553 ID(I2) = 2
5554 ID1 = ID(I1)
5555 IBLOCK=4
5556* GET PION'S MOMENTUM AND COORDINATES IN NUCLEUS-NUCLEUS CMS. FRAME
5557 EPCM=SQRT(EPION(NNN,IRUN)**2+PPX**2+PPY**2+PPZ**2)
5558 PPBETA=PPX*BETAX+PPY*BETAY+PPZ*BETAZ
5559 TRANSF=GAMMA*(GAMMA*PPBETA/(GAMMA+1.)+EPCM)
5560 PPION(1,NNN,IRUN)=BETAX*TRANSF+PPX
5561 PPION(2,NNN,IRUN)=BETAY*TRANSF+PPY
5562 PPION(3,NNN,IRUN)=BETAZ*TRANSF+PPZ
5563clin-5/2008:
5564 dppion(nnn,irun)=dpertp(i1)*dpertp(i2)
5565clin-5/2008 do not allow smearing in position of produced particles
5566c to avoid immediate reinteraction with the particle I1, I2 or themselves:
5567c2002 X01 = 1.0 - 2.0 * RANART(NSEED)
5568c Y01 = 1.0 - 2.0 * RANART(NSEED)
5569c Z01 = 1.0 - 2.0 * RANART(NSEED)
5570c IF ((X01*X01+Y01*Y01+Z01*Z01) .GT. 1.0) GOTO 2002
5571c RPION(1,NNN,IRUN)=R(1,I1)+0.5*x01
5572c RPION(2,NNN,IRUN)=R(2,I1)+0.5*y01
5573c RPION(3,NNN,IRUN)=R(3,I1)+0.5*z01
5574 RPION(1,NNN,IRUN)=R(1,I1)
5575 RPION(2,NNN,IRUN)=R(2,I1)
5576 RPION(3,NNN,IRUN)=R(3,I1)
5577c
5578 go to 90005
5579clin-5/2008 N+N->Deuteron+pi:
5580* FIND MOMENTUM OF THE FINAL PARTICLES IN THE NUCLEUS-NUCLEUS CMS.
5581 108 CONTINUE
5582 if(idpert.eq.1.and.ipert1.eq.1.and.npertd.ge.1) then
5583c For idpert=1: we produce npertd pert deuterons:
5584 ndloop=npertd
5585 elseif(idpert.eq.2.and.npertd.ge.1) then
5586c For idpert=2: we first save information for npertd pert deuterons;
5587c at the last ndloop we create the regular deuteron+pi
5588c and those pert deuterons:
5589 ndloop=npertd+1
5590 else
5591c Just create the regular deuteron+pi:
5592 ndloop=1
5593 endif
5594c
5595 dprob1=sdprod/sig/float(npertd)
5596 do idloop=1,ndloop
5597 CALL bbdangle(pxd,pyd,pzd,nt,ipert1,ianti,idloop,pfinal,
5598 1 dprob1,lbm)
5599 CALL ROTATE(PX,PY,PZ,PXd,PYd,PZd)
5600* LORENTZ-TRANSFORMATION OF THE MOMENTUM OF PARTICLES IN THE FINAL STATE
5601* FROM THE NN CMS FRAME INTO THE GLOBAL CMS FRAME:
5602* For the Deuteron:
5603 xmass=xmd
5604 E1dCM=SQRT(xmass**2+PXd**2+PYd**2+PZd**2)
5605 P1dBETA=PXd*BETAX+PYd*BETAY+PZd*BETAZ
5606 TRANSF=GAMMA*(GAMMA*P1dBETA/(GAMMA+1.)+E1dCM)
5607 pxi1=BETAX*TRANSF+PXd
5608 pyi1=BETAY*TRANSF+PYd
5609 pzi1=BETAZ*TRANSF+PZd
5610 if(ianti.eq.0)then
5611 lbd=42
5612 else
5613 lbd=-42
5614 endif
5615 if(idpert.eq.1.and.ipert1.eq.1.and.npertd.ge.1) then
5616cccc Perturbative production for idpert=1:
5617 nnn=nnn+1
5618 PPION(1,NNN,IRUN)=pxi1
5619 PPION(2,NNN,IRUN)=pyi1
5620 PPION(3,NNN,IRUN)=pzi1
5621 EPION(NNN,IRUN)=xmd
5622 LPION(NNN,IRUN)=lbd
5623 RPION(1,NNN,IRUN)=R(1,I1)
5624 RPION(2,NNN,IRUN)=R(2,I1)
5625 RPION(3,NNN,IRUN)=R(3,I1)
5626clin-5/2008 assign the perturbative probability:
5627 dppion(NNN,IRUN)=sdprod/sig/float(npertd)
5628 elseif(idpert.eq.2.and.idloop.le.npertd) then
5629clin-5/2008 For idpert=2, we produce NPERTD perturbative (anti)deuterons
5630c only when a regular (anti)deuteron+pi is produced in NN collisions.
5631c First save the info for the perturbative deuterons:
5632 ppd(1,idloop)=pxi1
5633 ppd(2,idloop)=pyi1
5634 ppd(3,idloop)=pzi1
5635 lbpd(idloop)=lbd
5636 else
5637cccc Regular production:
5638c For the regular pion: do LORENTZ-TRANSFORMATION:
5639 E(i1)=xmm
5640 E2piCM=SQRT(xmm**2+PXd**2+PYd**2+PZd**2)
5641 P2piBETA=-PXd*BETAX-PYd*BETAY-PZd*BETAZ
5642 TRANSF=GAMMA*(GAMMA*P2piBETA/(GAMMA+1.)+E2piCM)
5643 pxi2=BETAX*TRANSF-PXd
5644 pyi2=BETAY*TRANSF-PYd
5645 pzi2=BETAZ*TRANSF-PZd
5646 p(1,i1)=pxi2
5647 p(2,i1)=pyi2
5648 p(3,i1)=pzi2
5649c Remove regular pion to check the equivalence
5650c between the perturbative and regular deuteron results:
5651c E(i1)=0.
5652c
5653 LB(I1)=lbm
5654 PX1=P(1,I1)
5655 PY1=P(2,I1)
5656 PZ1=P(3,I1)
5657 EM1=E(I1)
5658 ID(I1)=2
5659 ID1=ID(I1)
5660 E1=SQRT(EM1**2+PX1**2+PY1**2+PZ1**2)
5661 lb1=lb(i1)
5662c For the regular deuteron:
5663 p(1,i2)=pxi1
5664 p(2,i2)=pyi1
5665 p(3,i2)=pzi1
5666 lb(i2)=lbd
5667 lb2=lb(i2)
5668 E(i2)=xmd
5669 EtI2=E(I2)
5670 ID(I2)=2
5671c For idpert=2: create the perturbative deuterons:
5672 if(idpert.eq.2.and.idloop.eq.ndloop) then
5673 do ipertd=1,npertd
5674 nnn=nnn+1
5675 PPION(1,NNN,IRUN)=ppd(1,ipertd)
5676 PPION(2,NNN,IRUN)=ppd(2,ipertd)
5677 PPION(3,NNN,IRUN)=ppd(3,ipertd)
5678 EPION(NNN,IRUN)=xmd
5679 LPION(NNN,IRUN)=lbpd(ipertd)
5680 RPION(1,NNN,IRUN)=R(1,I1)
5681 RPION(2,NNN,IRUN)=R(2,I1)
5682 RPION(3,NNN,IRUN)=R(3,I1)
5683clin-5/2008 assign the perturbative probability:
5684 dppion(NNN,IRUN)=1./float(npertd)
5685 enddo
5686 endif
5687 endif
5688 enddo
5689 IBLOCK=501
5690 go to 90005
5691clin-5/2008 N+N->Deuteron+pi over
5692* FOR THE NN-->KAON+X PROCESS, FIND MOMENTUM OF THE FINAL PARTICLES IN
5693* THE NUCLEUS-NUCLEUS CMS.
5694306 CONTINUE
5695csp11/21/01 phi production
5696 if(XSK5/sigK.gt.RANART(NSEED))then
5697 pz1=p(3,i1)
5698 pz2=p(3,i2)
5699 LB(I1) = 1 + int(2 * RANART(NSEED))
5700 LB(I2) = 1 + int(2 * RANART(NSEED))
5701 nnn=nnn+1
5702 LPION(NNN,IRUN)=29
5703 EPION(NNN,IRUN)=APHI
5704 iblock = 222
5705 GO TO 208
5706 ENDIF
5707c
5708 IBLOCK=9
5709 if(ianti .eq. 1)iblock=-9
5710c
5711 pz1=p(3,i1)
5712 pz2=p(3,i2)
5713* DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
5714 nnn=nnn+1
5715 LPION(NNN,IRUN)=23
5716 EPION(NNN,IRUN)=Aka
5717 if(srt.le.2.63)then
5718* only lambda production is possible
5719* (1.1)P+P-->p+L+kaon+
5720 ic=1
5721 LB(I1) = 1 + int(2 * RANART(NSEED))
5722 LB(I2)=14
5723 GO TO 208
5724 ENDIF
5725 if(srt.le.2.74.and.srt.gt.2.63)then
5726* both Lambda and sigma production are possible
5727 if(XSK1/(XSK1+XSK2).gt.RANART(NSEED))then
5728* lambda production
5729 ic=1
5730 LB(I1) = 1 + int(2 * RANART(NSEED))
5731 LB(I2)=14
5732 else
5733* sigma production
5734 LB(I1) = 1 + int(2 * RANART(NSEED))
5735 LB(I2) = 15 + int(3 * RANART(NSEED))
5736 ic=2
5737 endif
5738 GO TO 208
5739 endif
5740 if(srt.le.2.77.and.srt.gt.2.74)then
5741* then pp-->Delta lamda kaon can happen
5742 if(xsk1/(xsk1+xsk2+xsk3).
5743 1 gt.RANART(NSEED))then
5744* * (1.1)P+P-->p+L+kaon+
5745 ic=1
5746 LB(I1) = 1 + int(2 * RANART(NSEED))
5747 LB(I2)=14
5748 go to 208
5749 else
5750 if(xsk2/(xsk2+xsk3).gt.RANART(NSEED))then
5751* pp-->psk
5752 ic=2
5753 LB(I1) = 1 + int(2 * RANART(NSEED))
5754 LB(I2) = 15 + int(3 * RANART(NSEED))
5755 else
5756* pp-->D+l+k
5757 ic=3
5758 LB(I1) = 6 + int(4 * RANART(NSEED))
5759 lb(i2)=14
5760 endif
5761 GO TO 208
5762 endif
5763 endif
5764 if(srt.gt.2.77)then
5765* all four channels are possible
5766 if(xsk1/(xsk1+xsk2+xsk3+xsk4).gt.RANART(NSEED))then
5767* p lambda k production
5768 ic=1
5769 LB(I1) = 1 + int(2 * RANART(NSEED))
5770 LB(I2)=14
5771 go to 208
5772 else
5773 if(xsk3/(xsk2+xsk3+xsk4).gt.RANART(NSEED))then
5774* delta l K production
5775 ic=3
5776 LB(I1) = 6 + int(4 * RANART(NSEED))
5777 lb(i2)=14
5778 go to 208
5779 else
5780 if(xsk2/(xsk2+xsk4).gt.RANART(NSEED))then
5781* n sigma k production
5782 LB(I1) = 1 + int(2 * RANART(NSEED))
5783 LB(I2) = 15 + int(3 * RANART(NSEED))
5784 ic=2
5785 else
5786 ic=4
5787 LB(I1) = 6 + int(4 * RANART(NSEED))
5788 LB(I2) = 15 + int(3 * RANART(NSEED))
5789 endif
5790 go to 208
5791 endif
5792 endif
5793 endif
5794208 continue
5795 if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
5796 lb(i1) = - lb(i1)
5797 lb(i2) = - lb(i2)
5798 if(LPION(NNN,IRUN) .eq. 23)LPION(NNN,IRUN)=21
5799 endif
5800* KEEP ALL COORDINATES OF PARTICLE 2 FOR POSSIBLE PHASE SPACE CHANGE
5801 NTRY1=0
5802127 CALL BBKAON(ic,SRT,PX3,PY3,PZ3,DM3,PX4,PY4,PZ4,DM4,
5803 & PPX,PPY,PPZ,icou1)
5804 NTRY1=NTRY1+1
5805 if((icou1.lt.0).AND.(NTRY1.LE.20))GO TO 127
5806c if(icou1.lt.0)return
5807* ROTATE THE MOMENTA OF PARTICLES IN THE CMS OF P1+P2
5808 CALL ROTATE(PX,PY,PZ,PX3,PY3,PZ3)
5809 CALL ROTATE(PX,PY,PZ,PX4,PY4,PZ4)
5810 CALL ROTATE(PX,PY,PZ,PPX,PPY,PPZ)
5811* FIND THE MOMENTUM OF PARTICLES IN THE FINAL STATE IN THE NUCLEUS-
5812* NUCLEUS CMS. FRAME
5813* (1) for the necleon/delta
5814* LORENTZ-TRANSFORMATION INTO LAB FRAME FOR DELTA1
5815 E1CM = SQRT (dm3**2 + PX3**2 + PY3**2 + PZ3**2)
5816 P1BETA = PX3*BETAX + PY3*BETAY + PZ3*BETAZ
5817 TRANSF = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) + E1CM )
5818 Pt1i1 = BETAX * TRANSF + PX3
5819 Pt2i1 = BETAY * TRANSF + PY3
5820 Pt3i1 = BETAZ * TRANSF + PZ3
5821 Eti1 = DM3
5822 lbi1=lb(i1)
5823* (2) for the lambda/sigma
5824 E2CM = SQRT (dm4**2 + PX4**2 + PY4**2 + PZ4**2)
5825 P2BETA = PX4*BETAX+PY4*BETAY+PZ4*BETAZ
5826 TRANSF = GAMMA * (GAMMA*P2BETA / (GAMMA + 1.) + E2CM)
5827 Pt1I2 = BETAX * TRANSF + PX4
5828 Pt2I2 = BETAY * TRANSF + PY4
5829 Pt3I2 = BETAZ * TRANSF + PZ4
5830 EtI2 = DM4
5831 lbi2=lb(i2)
5832* GET the kaon'S MOMENTUM AND COORDINATES IN NUCLEUS-NUCLEUS CMS. FRAME
5833 EPCM=SQRT(aka**2+PPX**2+PPY**2+PPZ**2)
5834 PPBETA=PPX*BETAX+PPY*BETAY+PPZ*BETAZ
5835 TRANSF=GAMMA*(GAMMA*PPBETA/(GAMMA+1.)+EPCM)
5836 PPION(1,NNN,IRUN)=BETAX*TRANSF+PPX
5837 PPION(2,NNN,IRUN)=BETAY*TRANSF+PPY
5838 PPION(3,NNN,IRUN)=BETAZ*TRANSF+PPZ
5839clin-5/2008
5840 dppion(nnn,irun)=dpertp(i1)*dpertp(i2)
5841clin-5/2008
5842c2003 X01 = 1.0 - 2.0 * RANART(NSEED)
5843c Y01 = 1.0 - 2.0 * RANART(NSEED)
5844c Z01 = 1.0 - 2.0 * RANART(NSEED)
5845c IF ((X01*X01+Y01*Y01+Z01*Z01) .GT. 1.0) GOTO 2003
5846c RPION(1,NNN,IRUN)=R(1,I1)+0.5*x01
5847c RPION(2,NNN,IRUN)=R(2,I1)+0.5*y01
5848c RPION(3,NNN,IRUN)=R(3,I1)+0.5*z01
5849 RPION(1,NNN,IRUN)=R(1,I1)
5850 RPION(2,NNN,IRUN)=R(2,I1)
5851 RPION(3,NNN,IRUN)=R(3,I1)
5852c
5853* assign the nucleon/delta and lambda/sigma to i1 or i2 to keep the
5854* leadng particle behaviour
5855C if((pt1i1*px1+pt2i1*py1+pt3i1*pz1).gt.0)then
5856 p(1,i1)=pt1i1
5857 p(2,i1)=pt2i1
5858 p(3,i1)=pt3i1
5859 e(i1)=eti1
5860 lb(i1)=lbi1
5861 p(1,i2)=pt1i2
5862 p(2,i2)=pt2i2
5863 p(3,i2)=pt3i2
5864 e(i2)=eti2
5865 lb(i2)=lbi2
5866 PX1 = P(1,I1)
5867 PY1 = P(2,I1)
5868 PZ1 = P(3,I1)
5869 EM1 = E(I1)
5870 ID(I1) = 2
5871 ID(I2) = 2
5872 ID1 = ID(I1)
5873 go to 90005
5874* FOR THE NN-->Delta+Delta+rho PROCESS, FIND MOMENTUM OF THE FINAL
5875* PARTICLES IN THE NUCLEUS-NUCLEUS CMS.
5876307 CONTINUE
5877 NTRY1=0
5878125 CALL DDrho(SRT,ISEED,PX3,PY3,PZ3,DM3,PX4,PY4,PZ4,DM4,
5879 & PPX,PPY,PPZ,amrho,icou1)
5880 NTRY1=NTRY1+1
5881 if((icou1.lt.0).AND.(NTRY1.LE.20))GO TO 125
5882C if(icou1.lt.0)return
5883* ROTATE THE MOMENTA OF PARTICLES IN THE CMS OF P1+P2
5884 CALL ROTATE(PX,PY,PZ,PX3,PY3,PZ3)
5885 CALL ROTATE(PX,PY,PZ,PX4,PY4,PZ4)
5886 CALL ROTATE(PX,PY,PZ,PPX,PPY,PPZ)
5887 NNN=NNN+1
5888 arho=amrho
5889* DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
5890* (1) FOR P+P
5891 XDIR=RANART(NSEED)
5892 IF(LB(I1)*LB(I2).EQ.1)THEN
5893 IF(XDIR.Le.0.2)then
5894* (1.1)P+P-->D+++D0+rho(0)
5895 LPION(NNN,IRUN)=26
5896 EPION(NNN,IRUN)=Arho
5897 LB(I1)=9
5898 LB(I2)=7
5899 GO TO 2051
5900 ENDIF
5901* (1.2)P+P -->D++D+rho(0)
5902 IF((XDIR.LE.0.4).AND.(XDIR.GT.0.2))THEN
5903 LPION(NNN,IRUN)=26
5904 EPION(NNN,IRUN)=Arho
5905 LB(I1)=8
5906 LB(I2)=8
5907 GO TO 2051
5908 ENDIF
5909* (1.3)P+P-->D+++D+arho(-)
5910 IF((XDIR.LE.0.6).AND.(XDIR.GT.0.4))THEN
5911 LPION(NNN,IRUN)=25
5912 EPION(NNN,IRUN)=Arho
5913 LB(I1)=9
5914 LB(I2)=8
5915 GO TO 2051
5916 ENDIF
5917 IF((XDIR.LE.0.8).AND.(XDIR.GT.0.6))THEN
5918 LPION(NNN,IRUN)=27
5919 EPION(NNN,IRUN)=Arho
5920 LB(I1)=9
5921 LB(I2)=6
5922 GO TO 2051
5923 ENDIF
5924 IF(XDIR.GT.0.8)THEN
5925 LPION(NNN,IRUN)=27
5926 EPION(NNN,IRUN)=Arho
5927 LB(I1)=7
5928 LB(I2)=8
5929 GO TO 2051
5930 ENDIF
5931 ENDIF
5932* (2)FOR N+N
5933 IF(iabs(LB(I1)).EQ.2.AND.iabs(LB(I2)).EQ.2)THEN
5934 IF(XDIR.Le.0.2)then
5935* (2.1)N+N-->D++D-+rho(0)
5936 LPION(NNN,IRUN)=26
5937 EPION(NNN,IRUN)=Arho
5938 LB(I1)=6
5939 LB(I2)=7
5940 GO TO 2051
5941 ENDIF
5942* (2.2)N+N -->D+++D-+rho(-)
5943 IF((XDIR.LE.0.4).AND.(XDIR.GT.0.2))THEN
5944 LPION(NNN,IRUN)=25
5945 EPION(NNN,IRUN)=Arho
5946 LB(I1)=6
5947 LB(I2)=9
5948 GO TO 2051
5949 ENDIF
5950* (2.3)P+P-->D0+D-+rho(+)
5951 IF((XDIR.GT.0.4).AND.(XDIR.LE.0.6))THEN
5952 LPION(NNN,IRUN)=27
5953 EPION(NNN,IRUN)=Arho
5954 LB(I1)=9
5955 LB(I2)=8
5956 GO TO 2051
5957 ENDIF
5958* (2.4)P+P-->D0+D0+rho(0)
5959 IF((XDIR.GT.0.6).AND.(XDIR.LE.0.8))THEN
5960 LPION(NNN,IRUN)=26
5961 EPION(NNN,IRUN)=Arho
5962 LB(I1)=7
5963 LB(I2)=7
5964 GO TO 2051
5965 ENDIF
5966* (2.5)P+P-->D0+D++rho(-)
5967 IF(XDIR.GT.0.8)THEN
5968 LPION(NNN,IRUN)=25
5969 EPION(NNN,IRUN)=Arho
5970 LB(I1)=7
5971 LB(I2)=8
5972 GO TO 2051
5973 ENDIF
5974 ENDIF
5975* (3)FOR N+P
5976 IF(LB(I1)*LB(I2).EQ.2)THEN
5977 IF(XDIR.Le.0.17)then
5978* (3.1)N+P-->D+++D-+rho(0)
5979 LPION(NNN,IRUN)=25
5980 EPION(NNN,IRUN)=Arho
5981 LB(I1)=6
5982 LB(I2)=9
5983 GO TO 2051
5984 ENDIF
5985* (3.2)N+P -->D+++D0+rho(-)
5986 IF((XDIR.LE.0.34).AND.(XDIR.GT.0.17))THEN
5987 LPION(NNN,IRUN)=25
5988 EPION(NNN,IRUN)=Arho
5989 LB(I1)=7
5990 LB(I2)=9
5991 GO TO 2051
5992 ENDIF
5993* (3.3)N+P-->D++D-+rho(+)
5994 IF((XDIR.GT.0.34).AND.(XDIR.LE.0.51))THEN
5995 LPION(NNN,IRUN)=27
5996 EPION(NNN,IRUN)=Arho
5997 LB(I1)=7
5998 LB(I2)=8
5999 GO TO 2051
6000 ENDIF
6001* (3.4)N+P-->D++D++rho(-)
6002 IF((XDIR.GT.0.51).AND.(XDIR.LE.0.68))THEN
6003 LPION(NNN,IRUN)=25
6004 EPION(NNN,IRUN)=Arho
6005 LB(I1)=8
6006 LB(I2)=8
6007 GO TO 2051
6008 ENDIF
6009* (3.5)N+P-->D0+D++rho(0)
6010 IF((XDIR.GT.0.68).AND.(XDIR.LE.0.85))THEN
6011 LPION(NNN,IRUN)=26
6012 EPION(NNN,IRUN)=Arho
6013 LB(I1)=7
6014 LB(I2)=8
6015 GO TO 2051
6016 ENDIF
6017* (3.6)N+P-->D0+D0+rho(+)
6018 IF(XDIR.GT.0.85)THEN
6019 LPION(NNN,IRUN)=27
6020 EPION(NNN,IRUN)=Arho
6021 LB(I1)=7
6022 LB(I2)=7
6023 ENDIF
6024 ENDIF
6025* FIND THE MOMENTUM OF PARTICLES IN THE FINAL STATE IN THE NUCLEUS-
6026* NUCLEUS CMS. FRAME
6027* LORENTZ-TRANSFORMATION INTO LAB FRAME FOR DELTA1
60282051 E1CM = SQRT (dm3**2 + PX3**2 + PY3**2 + PZ3**2)
6029 P1BETA = PX3*BETAX + PY3*BETAY + PZ3*BETAZ
6030 TRANSF = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) + E1CM )
6031 Pt1i1 = BETAX * TRANSF + PX3
6032 Pt2i1 = BETAY * TRANSF + PY3
6033 Pt3i1 = BETAZ * TRANSF + PZ3
6034 Eti1 = DM3
6035c
6036 if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
6037 lb(i1) = -lb(i1)
6038 lb(i2) = -lb(i2)
6039 if(LPION(NNN,IRUN) .eq. 25)then
6040 LPION(NNN,IRUN)=27
6041 elseif(LPION(NNN,IRUN) .eq. 27)then
6042 LPION(NNN,IRUN)=25
6043 endif
6044 endif
6045c
6046 lb1=lb(i1)
6047* FOR DELTA2
6048 E2CM = SQRT (dm4**2 + PX4**2 + PY4**2 + PZ4**2)
6049 P2BETA = PX4*BETAX+PY4*BETAY+PZ4*BETAZ
6050 TRANSF = GAMMA * (GAMMA*P2BETA / (GAMMA + 1.) + E2CM)
6051 Pt1I2 = BETAX * TRANSF + PX4
6052 Pt2I2 = BETAY * TRANSF + PY4
6053 Pt3I2 = BETAZ * TRANSF + PZ4
6054 EtI2 = DM4
6055 lb2=lb(i2)
6056* assign delta1 and delta2 to i1 or i2 to keep the leadng particle
6057* behaviour
6058C if((pt1i1*px1+pt2i1*py1+pt3i1*pz1).gt.0)then
6059 p(1,i1)=pt1i1
6060 p(2,i1)=pt2i1
6061 p(3,i1)=pt3i1
6062 e(i1)=eti1
6063 lb(i1)=lb1
6064 p(1,i2)=pt1i2
6065 p(2,i2)=pt2i2
6066 p(3,i2)=pt3i2
6067 e(i2)=eti2
6068 lb(i2)=lb2
6069 PX1 = P(1,I1)
6070 PY1 = P(2,I1)
6071 PZ1 = P(3,I1)
6072 EM1 = E(I1)
6073 ID(I1) = 2
6074 ID(I2) = 2
6075 ID1 = ID(I1)
6076 IBLOCK=44
6077* GET rho'S MOMENTUM AND COORDINATES IN NUCLEUS-NUCLEUS CMS. FRAME
6078 EPCM=SQRT(EPION(NNN,IRUN)**2+PPX**2+PPY**2+PPZ**2)
6079 PPBETA=PPX*BETAX+PPY*BETAY+PPZ*BETAZ
6080 TRANSF=GAMMA*(GAMMA*PPBETA/(GAMMA+1.)+EPCM)
6081 PPION(1,NNN,IRUN)=BETAX*TRANSF+PPX
6082 PPION(2,NNN,IRUN)=BETAY*TRANSF+PPY
6083 PPION(3,NNN,IRUN)=BETAZ*TRANSF+PPZ
6084clin-5/2008:
6085 dppion(nnn,irun)=dpertp(i1)*dpertp(i2)
6086clin-5/2008:
6087c2004 X01 = 1.0 - 2.0 * RANART(NSEED)
6088c Y01 = 1.0 - 2.0 * RANART(NSEED)
6089c Z01 = 1.0 - 2.0 * RANART(NSEED)
6090c IF ((X01*X01+Y01*Y01+Z01*Z01) .GT. 1.0) GOTO 2004
6091c RPION(1,NNN,IRUN)=R(1,I1)+0.5*x01
6092c RPION(2,NNN,IRUN)=R(2,I1)+0.5*y01
6093c RPION(3,NNN,IRUN)=R(3,I1)+0.5*z01
6094 RPION(1,NNN,IRUN)=R(1,I1)
6095 RPION(2,NNN,IRUN)=R(2,I1)
6096 RPION(3,NNN,IRUN)=R(3,I1)
6097c
6098 go to 90005
6099* FOR THE NN-->N+N+rho PROCESS, FIND MOMENTUM OF THE FINAL
6100* PARTICLES IN THE NUCLEUS-NUCLEUS CMS.
6101308 CONTINUE
6102 NTRY1=0
6103126 CALL pprho(SRT,ISEED,PX3,PY3,PZ3,DM3,PX4,PY4,PZ4,DM4,
6104 & PPX,PPY,PPZ,amrho,icou1)
6105 NTRY1=NTRY1+1
6106 if((icou1.lt.0).AND.(NTRY1.LE.20))GO TO 126
6107C if(icou1.lt.0)return
6108* ROTATE THE MOMENTA OF PARTICLES IN THE CMS OF P1+P2
6109 CALL ROTATE(PX,PY,PZ,PX3,PY3,PZ3)
6110 CALL ROTATE(PX,PY,PZ,PX4,PY4,PZ4)
6111 CALL ROTATE(PX,PY,PZ,PPX,PPY,PPZ)
6112 NNN=NNN+1
6113 arho=amrho
6114* DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
6115* (1) FOR P+P
6116 XDIR=RANART(NSEED)
6117 IF(LB(I1)*LB(I2).EQ.1)THEN
6118 IF(XDIR.Le.0.5)then
6119* (1.1)P+P-->P+P+rho(0)
6120 LPION(NNN,IRUN)=26
6121 EPION(NNN,IRUN)=Arho
6122 LB(I1)=1
6123 LB(I2)=1
6124 GO TO 2052
6125 Else
6126* (1.2)P+P -->p+n+rho(+)
6127 LPION(NNN,IRUN)=27
6128 EPION(NNN,IRUN)=Arho
6129 LB(I1)=1
6130 LB(I2)=2
6131 GO TO 2052
6132 ENDIF
6133 endif
6134* (2)FOR N+N
6135 IF(iabs(LB(I1)).EQ.2.AND.iabs(LB(I2)).EQ.2)THEN
6136 IF(XDIR.Le.0.5)then
6137* (2.1)N+N-->N+N+rho(0)
6138 LPION(NNN,IRUN)=26
6139 EPION(NNN,IRUN)=Arho
6140 LB(I1)=2
6141 LB(I2)=2
6142 GO TO 2052
6143 Else
6144* (2.2)N+N -->N+P+rho(-)
6145 LPION(NNN,IRUN)=25
6146 EPION(NNN,IRUN)=Arho
6147 LB(I1)=1
6148 LB(I2)=2
6149 GO TO 2052
6150 ENDIF
6151 endif
6152* (3)FOR N+P
6153 IF(LB(I1)*LB(I2).EQ.2)THEN
6154 IF(XDIR.Le.0.33)then
6155* (3.1)N+P-->N+P+rho(0)
6156 LPION(NNN,IRUN)=26
6157 EPION(NNN,IRUN)=Arho
6158 LB(I1)=1
6159 LB(I2)=2
6160 GO TO 2052
6161* (3.2)N+P -->P+P+rho(-)
6162 else IF((XDIR.LE.0.67).AND.(XDIR.GT.0.34))THEN
6163 LPION(NNN,IRUN)=25
6164 EPION(NNN,IRUN)=Arho
6165 LB(I1)=1
6166 LB(I2)=1
6167 GO TO 2052
6168 Else
6169* (3.3)N+P-->N+N+rho(+)
6170 LPION(NNN,IRUN)=27
6171 EPION(NNN,IRUN)=Arho
6172 LB(I1)=2
6173 LB(I2)=2
6174 GO TO 2052
6175 ENDIF
6176 endif
6177* FIND THE MOMENTUM OF PARTICLES IN THE FINAL STATE IN THE NUCLEUS-
6178* NUCLEUS CMS. FRAME
6179* LORENTZ-TRANSFORMATION INTO LAB FRAME FOR DELTA1
61802052 E1CM = SQRT (dm3**2 + PX3**2 + PY3**2 + PZ3**2)
6181 P1BETA = PX3*BETAX + PY3*BETAY + PZ3*BETAZ
6182 TRANSF = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) + E1CM )
6183 Pt1i1 = BETAX * TRANSF + PX3
6184 Pt2i1 = BETAY * TRANSF + PY3
6185 Pt3i1 = BETAZ * TRANSF + PZ3
6186 Eti1 = DM3
6187c
6188 if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
6189 lb(i1) = -lb(i1)
6190 lb(i2) = -lb(i2)
6191 if(LPION(NNN,IRUN) .eq. 25)then
6192 LPION(NNN,IRUN)=27
6193 elseif(LPION(NNN,IRUN) .eq. 27)then
6194 LPION(NNN,IRUN)=25
6195 endif
6196 endif
6197c
6198 lb1=lb(i1)
6199* FOR p2
6200 E2CM = SQRT (dm4**2 + PX4**2 + PY4**2 + PZ4**2)
6201 P2BETA = PX4*BETAX+PY4*BETAY+PZ4*BETAZ
6202 TRANSF = GAMMA * (GAMMA*P2BETA / (GAMMA + 1.) + E2CM)
6203 Pt1I2 = BETAX * TRANSF + PX4
6204 Pt2I2 = BETAY * TRANSF + PY4
6205 Pt3I2 = BETAZ * TRANSF + PZ4
6206 EtI2 = DM4
6207 lb2=lb(i2)
6208* assign p1 and p2 to i1 or i2 to keep the leadng particle
6209* behaviour
6210C if((pt1i1*px1+pt2i1*py1+pt3i1*pz1).gt.0)then
6211 p(1,i1)=pt1i1
6212 p(2,i1)=pt2i1
6213 p(3,i1)=pt3i1
6214 e(i1)=eti1
6215 lb(i1)=lb1
6216 p(1,i2)=pt1i2
6217 p(2,i2)=pt2i2
6218 p(3,i2)=pt3i2
6219 e(i2)=eti2
6220 lb(i2)=lb2
6221 PX1 = P(1,I1)
6222 PY1 = P(2,I1)
6223 PZ1 = P(3,I1)
6224 EM1 = E(I1)
6225 ID(I1) = 2
6226 ID(I2) = 2
6227 ID1 = ID(I1)
6228 IBLOCK=45
6229* GET rho'S MOMENTUM AND COORDINATES IN NUCLEUS-NUCLEUS CMS. FRAME
6230 EPCM=SQRT(EPION(NNN,IRUN)**2+PPX**2+PPY**2+PPZ**2)
6231 PPBETA=PPX*BETAX+PPY*BETAY+PPZ*BETAZ
6232 TRANSF=GAMMA*(GAMMA*PPBETA/(GAMMA+1.)+EPCM)
6233 PPION(1,NNN,IRUN)=BETAX*TRANSF+PPX
6234 PPION(2,NNN,IRUN)=BETAY*TRANSF+PPY
6235 PPION(3,NNN,IRUN)=BETAZ*TRANSF+PPZ
6236clin-5/2008:
6237 dppion(nnn,irun)=dpertp(i1)*dpertp(i2)
6238clin-5/2008:
6239c2005 X01 = 1.0 - 2.0 * RANART(NSEED)
6240c Y01 = 1.0 - 2.0 * RANART(NSEED)
6241c Z01 = 1.0 - 2.0 * RANART(NSEED)
6242c IF ((X01*X01+Y01*Y01+Z01*Z01) .GT. 1.0) GOTO 2005
6243c RPION(1,NNN,IRUN)=R(1,I1)+0.5*x01
6244c RPION(2,NNN,IRUN)=R(2,I1)+0.5*y01
6245c RPION(3,NNN,IRUN)=R(3,I1)+0.5*z01
6246 RPION(1,NNN,IRUN)=R(1,I1)
6247 RPION(2,NNN,IRUN)=R(2,I1)
6248 RPION(3,NNN,IRUN)=R(3,I1)
6249c
6250 go to 90005
6251* FOR THE NN-->p+p+omega PROCESS, FIND MOMENTUM OF THE FINAL
6252* PARTICLES IN THE NUCLEUS-NUCLEUS CMS.
6253309 CONTINUE
6254 NTRY1=0
6255138 CALL ppomga(SRT,ISEED,PX3,PY3,PZ3,DM3,PX4,PY4,PZ4,DM4,
6256 & PPX,PPY,PPZ,icou1)
6257 NTRY1=NTRY1+1
6258 if((icou1.lt.0).AND.(NTRY1.LE.20))GO TO 138
6259C if(icou1.lt.0)return
6260* ROTATE THE MOMENTA OF PARTICLES IN THE CMS OF P1+P2
6261 CALL ROTATE(PX,PY,PZ,PX3,PY3,PZ3)
6262 CALL ROTATE(PX,PY,PZ,PX4,PY4,PZ4)
6263 CALL ROTATE(PX,PY,PZ,PPX,PPY,PPZ)
6264 NNN=NNN+1
6265 aomega=0.782
6266* DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
6267* (1) FOR P+P
6268 IF(LB(I1)*LB(I2).EQ.1)THEN
6269* (1.1)P+P-->P+P+omega(0)
6270 LPION(NNN,IRUN)=28
6271 EPION(NNN,IRUN)=Aomega
6272 LB(I1)=1
6273 LB(I2)=1
6274 GO TO 2053
6275 ENDIF
6276* (2)FOR N+N
6277 IF(iabs(LB(I1)).EQ.2.AND.iabs(LB(I2)).EQ.2)THEN
6278* (2.1)N+N-->N+N+omega(0)
6279 LPION(NNN,IRUN)=28
6280 EPION(NNN,IRUN)=Aomega
6281 LB(I1)=2
6282 LB(I2)=2
6283 GO TO 2053
6284 ENDIF
6285* (3)FOR N+P
6286 IF(LB(I1)*LB(I2).EQ.2)THEN
6287* (3.1)N+P-->N+P+omega(0)
6288 LPION(NNN,IRUN)=28
6289 EPION(NNN,IRUN)=Aomega
6290 LB(I1)=1
6291 LB(I2)=2
6292 GO TO 2053
6293 ENDIF
6294* FIND THE MOMENTUM OF PARTICLES IN THE FINAL STATE IN THE NUCLEUS-
6295* NUCLEUS CMS. FRAME
6296* LORENTZ-TRANSFORMATION INTO LAB FRAME FOR DELTA1
62972053 E1CM = SQRT (dm3**2 + PX3**2 + PY3**2 + PZ3**2)
6298 P1BETA = PX3*BETAX + PY3*BETAY + PZ3*BETAZ
6299 TRANSF = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) + E1CM )
6300 Pt1i1 = BETAX * TRANSF + PX3
6301 Pt2i1 = BETAY * TRANSF + PY3
6302 Pt3i1 = BETAZ * TRANSF + PZ3
6303 Eti1 = DM3
6304 if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
6305 lb(i1) = -lb(i1)
6306 lb(i2) = -lb(i2)
6307 endif
6308 lb1=lb(i1)
6309* FOR DELTA2
6310 E2CM = SQRT (dm4**2 + PX4**2 + PY4**2 + PZ4**2)
6311 P2BETA = PX4*BETAX+PY4*BETAY+PZ4*BETAZ
6312 TRANSF = GAMMA * (GAMMA*P2BETA / (GAMMA + 1.) + E2CM)
6313 Pt1I2 = BETAX * TRANSF + PX4
6314 Pt2I2 = BETAY * TRANSF + PY4
6315 Pt3I2 = BETAZ * TRANSF + PZ4
6316 EtI2 = DM4
6317 lb2=lb(i2)
6318* assign delta1 and delta2 to i1 or i2 to keep the leadng particle
6319* behaviour
6320C if((pt1i1*px1+pt2i1*py1+pt3i1*pz1).gt.0)then
6321 p(1,i1)=pt1i1
6322 p(2,i1)=pt2i1
6323 p(3,i1)=pt3i1
6324 e(i1)=eti1
6325 lb(i1)=lb1
6326 p(1,i2)=pt1i2
6327 p(2,i2)=pt2i2
6328 p(3,i2)=pt3i2
6329 e(i2)=eti2
6330 lb(i2)=lb2
6331 PX1 = P(1,I1)
6332 PY1 = P(2,I1)
6333 PZ1 = P(3,I1)
6334 EM1 = E(I1)
6335 ID(I1) = 2
6336 ID(I2) = 2
6337 ID1 = ID(I1)
6338 IBLOCK=46
6339* GET omega'S MOMENTUM AND COORDINATES IN NUCLEUS-NUCLEUS CMS. FRAME
6340 EPCM=SQRT(EPION(NNN,IRUN)**2+PPX**2+PPY**2+PPZ**2)
6341 PPBETA=PPX*BETAX+PPY*BETAY+PPZ*BETAZ
6342 TRANSF=GAMMA*(GAMMA*PPBETA/(GAMMA+1.)+EPCM)
6343 PPION(1,NNN,IRUN)=BETAX*TRANSF+PPX
6344 PPION(2,NNN,IRUN)=BETAY*TRANSF+PPY
6345 PPION(3,NNN,IRUN)=BETAZ*TRANSF+PPZ
6346clin-5/2008:
6347 dppion(nnn,irun)=dpertp(i1)*dpertp(i2)
6348clin-5/2008:
6349c2006 X01 = 1.0 - 2.0 * RANART(NSEED)
6350c Y01 = 1.0 - 2.0 * RANART(NSEED)
6351c Z01 = 1.0 - 2.0 * RANART(NSEED)
6352c IF ((X01*X01+Y01*Y01+Z01*Z01) .GT. 1.0) GOTO 2006
6353c RPION(1,NNN,IRUN)=R(1,I1)+0.5*x01
6354c RPION(2,NNN,IRUN)=R(2,I1)+0.5*y01
6355c RPION(3,NNN,IRUN)=R(3,I1)+0.5*z01
6356 RPION(1,NNN,IRUN)=R(1,I1)
6357 RPION(2,NNN,IRUN)=R(2,I1)
6358 RPION(3,NNN,IRUN)=R(3,I1)
6359c
6360 go to 90005
6361* change phase space density FOR NUCLEONS AFTER THE PROCESS
6362
6363clin-10/25/02-comment out following, since there is no path to it:
6364clin-8/16/02 used before set
6365c IX1,IY1,IZ1,IPX1,IPY1,IPZ1, IX2,IY2,IZ2,IPX2,IPY2,IPZ2:
6366c if ((abs(ix1).le.mx) .and. (abs(iy1).le.my) .and.
6367c & (abs(iz1).le.mz)) then
6368c ipx1p = nint(p(1,i1)/dpx)
6369c ipy1p = nint(p(2,i1)/dpy)
6370c ipz1p = nint(p(3,i1)/dpz)
6371c if ((ipx1p.ne.ipx1) .or. (ipy1p.ne.ipy1) .or.
6372c & (ipz1p.ne.ipz1)) then
6373c if ((abs(ipx1).le.mpx) .and. (abs(ipy1).le.my)
6374c & .and. (ipz1.ge.-mpz) .and. (ipz1.le.mpzp))
6375c & f(ix1,iy1,iz1,ipx1,ipy1,ipz1) =
6376c & f(ix1,iy1,iz1,ipx1,ipy1,ipz1) - 1.
6377c if ((abs(ipx1p).le.mpx) .and. (abs(ipy1p).le.my)
6378c & .and. (ipz1p.ge.-mpz).and. (ipz1p.le.mpzp))
6379c & f(ix1,iy1,iz1,ipx1p,ipy1p,ipz1p) =
6380c & f(ix1,iy1,iz1,ipx1p,ipy1p,ipz1p) + 1.
6381c end if
6382c end if
6383c if ((abs(ix2).le.mx) .and. (abs(iy2).le.my) .and.
6384c & (abs(iz2).le.mz)) then
6385c ipx2p = nint(p(1,i2)/dpx)
6386c ipy2p = nint(p(2,i2)/dpy)
6387c ipz2p = nint(p(3,i2)/dpz)
6388c if ((ipx2p.ne.ipx2) .or. (ipy2p.ne.ipy2) .or.
6389c & (ipz2p.ne.ipz2)) then
6390c if ((abs(ipx2).le.mpx) .and. (abs(ipy2).le.my)
6391c & .and. (ipz2.ge.-mpz) .and. (ipz2.le.mpzp))
6392c & f(ix2,iy2,iz2,ipx2,ipy2,ipz2) =
6393c & f(ix2,iy2,iz2,ipx2,ipy2,ipz2) - 1.
6394c if ((abs(ipx2p).le.mpx) .and. (abs(ipy2p).le.my)
6395c & .and. (ipz2p.ge.-mpz) .and. (ipz2p.le.mpzp))
6396c & f(ix2,iy2,iz2,ipx2p,ipy2p,ipz2p) =
6397c & f(ix2,iy2,iz2,ipx2p,ipy2p,ipz2p) + 1.
6398c end if
6399c end if
6400clin-10/25/02-end
6401
640290005 continue
6403 RETURN
6404*-----------------------------------------------------------------------
6405*COM: SET THE NEW MOMENTUM COORDINATES
6406107 IF(PX .EQ. 0.0 .AND. PY .EQ. 0.0) THEN
6407 T2 = 0.0
6408 ELSE
6409 T2=ATAN2(PY,PX)
6410 END IF
6411 S1 = 1.0 - C1**2
6412 IF(S1.LE.0)S1=0
6413 S1=SQRT(S1)
6414 S2 = SQRT( 1.0 - C2**2 )
6415 CT1 = COS(T1)
6416 ST1 = SIN(T1)
6417 CT2 = COS(T2)
6418 ST2 = SIN(T2)
6419 PZ = PR * ( C1*C2 - S1*S2*CT1 )
6420 SS = C2 * S1 * CT1 + S2 * C1
6421 PX = PR * ( SS*CT2 - S1*ST1*ST2 )
6422 PY = PR * ( SS*ST2 + S1*ST1*CT2 )
6423 RETURN
6424 END
6425clin-5/2008 CRNN over
6426
6427**********************************
6428**********************************
6429* *
6430* *
6431c
6432 SUBROUTINE CRPP(PX,PY,PZ,SRT,I1,I2,IBLOCK,
6433 &ppel,ppin,spprho,ipp)
6434* PURPOSE: *
6435* DEALING WITH PION-PION COLLISIONS *
6436* NOTE : *
6437* VALID ONLY FOR PION-PION-DISTANCES LESS THAN 2.5 FM *
6438* QUANTITIES: *
6439* PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
6440* SRT - SQRT OF S *
6441* IBLOCK - THE INFORMATION BACK *
6442* 6-> Meson+Meson elastic
6443* 66-> Meson+meson-->K+K-
6444**********************************
6445 PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
6446 1 AMP=0.93828,AP1=0.13496,
6447 2 AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
6448 PARAMETER (AKA=0.498,aks=0.895)
6449 parameter (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
6450 COMMON /AA/ R(3,MAXSTR)
6451cc SAVE /AA/
6452 COMMON /BB/ P(3,MAXSTR)
6453cc SAVE /BB/
6454 COMMON /CC/ E(MAXSTR)
6455cc SAVE /CC/
6456 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
6457cc SAVE /EE/
6458 common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
6459cc SAVE /input1/
6460 common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
6461cc SAVE /ppb1/
6462 common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
6463cc SAVE /ppmm/
6464 COMMON/RNDF77/NSEED
6465cc SAVE /RNDF77/
6466 SAVE
6467
6468 lb1i=lb(i1)
6469 lb2i=lb(i2)
6470
6471 PX0=PX
6472 PY0=PY
6473 PZ0=PZ
6474 iblock=1
6475*-----------------------------------------------------------------------
6476* check Meson+Meson inelastic collisions
6477clin-9/28/00
6478c if((srt.gt.1.).and.(ppin/(ppin+ppel).gt.RANART(NSEED)))then
6479c iblock=66
6480c e(i1)=0.498
6481c e(i2)=0.498
6482c lb(i1)=21
6483c lb(i2)=23
6484c go to 10
6485clin-11/07/00
6486c if(srt.gt.1.and.(ppin/(ppin+ppel)).gt.RANART(NSEED)) then
6487clin-4/03/02
6488 if(srt.gt.(2*aka).and.(ppin/(ppin+ppel)).gt.RANART(NSEED)) then
6489c if(ppin/(ppin+ppel).gt.RANART(NSEED)) then
6490clin-10/08/00
6491
6492 ranpi=RANART(NSEED)
6493 if((pprr/ppin).ge.ranpi) then
6494
6495c 1) pi pi <-> rho rho:
6496 call pi2ro2(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
6497
6498clin-4/03/02 eta equilibration:
6499 elseif((pprr+ppee)/ppin.ge.ranpi) then
6500c 4) pi pi <-> eta eta:
6501 call pi2et2(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
6502 elseif(((pprr+ppee+pppe)/ppin).ge.ranpi) then
6503c 5) pi pi <-> pi eta:
6504 call pi3eta(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
6505 elseif(((pprr+ppee+pppe+rpre)/ppin).ge.ranpi) then
6506c 6) rho pi <-> pi eta:
6507 call rpiret(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
6508 elseif(((pprr+ppee+pppe+rpre+xopoe)/ppin).ge.ranpi) then
6509c 7) omega pi <-> omega eta:
6510 call opioet(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
6511 elseif(((pprr+ppee+pppe+rpre+xopoe+rree)
6512 1 /ppin).ge.ranpi) then
6513c 8) rho rho <-> eta eta:
6514 call ro2et2(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
6515clin-4/03/02-end
6516
6517c 2) BBbar production:
6518 elseif(((pprr+ppee+pppe+rpre+xopoe+rree+ppinnb)/ppin)
6519 1 .ge.ranpi) then
6520
6521 call bbarfs(lbb1,lbb2,ei1,ei2,iblock,iseed)
6522c 3) KKbar production:
6523 else
6524 iblock=66
6525 ei1=aka
6526 ei2=aka
6527 lbb1=21
6528 lbb2=23
6529clin-11/07/00 pi rho -> K* Kbar and K*bar K productions:
6530 lb1=lb(i1)
6531 lb2=lb(i2)
6532clin-2/13/03 include omega the same as rho, eta the same as pi:
6533c if(((lb1.ge.3.and.lb1.le.5).and.(lb2.ge.25.and.lb2.le.27))
6534c 1 .or.((lb2.ge.3.and.lb2.le.5).and.(lb1.ge.25.and.lb1.le.27)))
6535 if( ( (lb1.eq.0.or.(lb1.ge.3.and.lb1.le.5))
6536 1 .and.(lb2.ge.25.and.lb2.le.28))
6537 2 .or. ( (lb2.eq.0.or.(lb2.ge.3.and.lb2.le.5))
6538 3 .and.(lb1.ge.25.and.lb1.le.28))) then
6539 ei1=aks
6540 ei2=aka
6541 if(RANART(NSEED).ge.0.5) then
6542 iblock=366
6543 lbb1=30
6544 lbb2=21
6545 else
6546 iblock=367
6547 lbb1=-30
6548 lbb2=23
6549 endif
6550 endif
6551clin-11/07/00-end
6552 endif
6553clin-ppbar-8/25/00
6554 e(i1)=ei1
6555 e(i2)=ei2
6556 lb(i1)=lbb1
6557 lb(i2)=lbb2
6558clin-10/08/00-end
6559
6560 else
6561cbzdbg10/15/99
6562c.....for meson+meson elastic srt.le.2Mk, if not pi+pi collision return
6563 if ((lb(i1).lt.3.or.lb(i1).gt.5).and.
6564 & (lb(i2).lt.3.or.lb(i2).gt.5)) return
6565cbzdbg10/15/99 end
6566
6567* check Meson+Meson elastic collisions
6568 IBLOCK=6
6569* direct process
6570 if(ipp.eq.1.or.ipp.eq.4.or.ipp.eq.6)go to 10
6571 if(spprho/ppel.gt.RANART(NSEED))go to 20
6572 endif
657310 NTAG=0
6574 EM1=E(I1)
6575 EM2=E(I2)
6576
6577*-----------------------------------------------------------------------
6578* CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
6579* ENERGY CONSERVATION
6580 PR2 = (SRT**2 - EM1**2 - EM2**2)**2
6581 1 - 4.0 * (EM1*EM2)**2
6582 IF(PR2.LE.0.)PR2=1.e-09
6583 PR=SQRT(PR2)/(2.*SRT)
6584 C1 = 1.0 - 2.0 * RANART(NSEED)
6585 T1 = 2.0 * PI * RANART(NSEED)
6586 S1 = SQRT( 1.0 - C1**2 )
6587 CT1 = COS(T1)
6588 ST1 = SIN(T1)
6589 PZ = PR * C1
6590 PX = PR * S1*CT1
6591 PY = PR * S1*ST1
6592* for isotropic distribution no need to ROTATE THE MOMENTUM
6593
6594* ROTATE IT
6595 CALL ROTATE(PX0,PY0,PZ0,PX,PY,PZ)
6596
6597 RETURN
659820 continue
6599 iblock=666
6600* treat rho formation in pion+pion collisions
6601* calculate the mass and momentum of rho in the nucleus-nucleus frame
6602 call rhores(i1,i2)
6603 if(ipp.eq.2)lb(i1)=27
6604 if(ipp.eq.3)lb(i1)=26
6605 if(ipp.eq.5)lb(i1)=25
6606 return
6607 END
6608**********************************
6609**********************************
6610* *
6611* *
6612 SUBROUTINE CRND(IRUN,PX,PY,PZ,SRT,I1,I2,IBLOCK,
6613 &SIGNN,SIG,sigk,xsk1,xsk2,xsk3,xsk4,xsk5,NT,ipert1)
6614* PURPOSE: *
6615* DEALING WITH NUCLEON-BARYON RESONANCE COLLISIONS *
6616* NOTE : *
6617* VALID ONLY FOR BARYON-BARYON-DISTANCES LESS THAN 1.32 FM *
6618* (1.32 = 2 * HARD-CORE-RADIUS [HRC] ) *
6619* QUANTITIES: *
6620* PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
6621* SRT - SQRT OF S *
6622* NSTAR =1 INCLUDING N* RESORANCE,ELSE NOT *
6623* NDIRCT=1 INCLUDING DIRECT PION PRODUCTION PROCESS *
6624* IBLOCK - THE INFORMATION BACK *
6625* 0-> COLLISION CANNOT HAPPEN *
6626* 1-> N-N ELASTIC COLLISION *
6627* 2-> N+N->N+DELTA,OR N+N->N+N* REACTION *
6628* 3-> N+DELTA->N+N OR N+N*->N+N REACTION *
6629* 4-> N+N->N+N+PION,DIRTCT PROCESS *
6630* N12 - IS USED TO SPECIFY BARYON-BARYON REACTION *
6631* CHANNELS. M12 IS THE REVERSAL CHANNEL OF N12 *
6632* N12, *
6633* M12=1 FOR p+n-->delta(+)+ n *
6634* 2 p+n-->delta(0)+ p *
6635* 3 p+p-->delta(++)+n *
6636* 4 p+p-->delta(+)+p *
6637* 5 n+n-->delta(0)+n *
6638* 6 n+n-->delta(-)+p *
6639* 7 n+p-->N*(0)(1440)+p *
6640* 8 n+p-->N*(+)(1440)+n *
6641* 9 p+p-->N*(+)(1535)+p *
6642* 10 n+n-->N*(0)(1535)+n *
6643* 11 n+p-->N*(+)(1535)+n *
6644* 12 n+p-->N*(0)(1535)+p
6645* 13 D(++)+D(-)-->N*(+)(1440)+n
6646* 14 D(++)+D(-)-->N*(0)(1440)+p
6647* 15 D(+)+D(0)--->N*(+)(1440)+n
6648* 16 D(+)+D(0)--->N*(0)(1440)+p
6649* 17 D(++)+D(0)-->N*(+)(1535)+p
6650* 18 D(++)+D(-)-->N*(0)(1535)+p
6651* 19 D(++)+D(-)-->N*(+)(1535)+n
6652* 20 D(+)+D(+)-->N*(+)(1535)+p
6653* 21 D(+)+D(0)-->N*(+)(1535)+n
6654* 22 D(+)+D(0)-->N*(0)(1535)+p
6655* 23 D(+)+D(-)-->N*(0)(1535)+n
6656* 24 D(0)+D(0)-->N*(0)(1535)+n
6657* 25 N*(+)(14)+N*(+)(14)-->N*(+)(15)+p
6658* 26 N*(0)(14)+N*(0)(14)-->N*(0)(15)+n
6659* 27 N*(+)(14)+N*(0)(14)-->N*(+)(15)+n
6660* 28 N*(+)(14)+N*(0)(14)-->N*(0)(15)+p
6661* 29 N*(+)(14)+D+-->N*(+)(15)+p
6662* 30 N*(+)(14)+D0-->N*(+)(15)+n
6663* 31 N*(+)(14)+D(-)-->N*(0)(1535)+n
6664* 32 N*(0)(14)+D++--->N*(+)(15)+p
6665* 33 N*(0)(14)+D+--->N*(+)(15)+n
6666* 34 N*(0)(14)+D+--->N*(0)(15)+p
6667* 35 N*(0)(14)+D0-->N*(0)(15)+n
6668* 36 N*(+)(14)+D0--->N*(0)(15)+p
6669* ++ see the note book for more listing
6670**********************************
6671 PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
6672 1 AMP=0.93828,AP1=0.13496,AKA=0.498,APHI=1.020,
6673 2 AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
6674 parameter (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
6675 parameter (xmd=1.8756,npdmax=10000)
6676 COMMON /AA/ R(3,MAXSTR)
6677cc SAVE /AA/
6678 COMMON /BB/ P(3,MAXSTR)
6679cc SAVE /BB/
6680 COMMON /CC/ E(MAXSTR)
6681cc SAVE /CC/
6682 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
6683cc SAVE /EE/
6684 common /ff/f(-mx:mx,-my:my,-mz:mz,-mpx:mpx,-mpy:mpy,-mpz:mpzp)
6685cc SAVE /ff/
6686 common /gg/ dx,dy,dz,dpx,dpy,dpz
6687cc SAVE /gg/
6688 COMMON /INPUT/ NSTAR,NDIRCT,DIR
6689cc SAVE /INPUT/
6690 COMMON /NN/NNN
6691cc SAVE /NN/
6692 COMMON /BG/BETAX,BETAY,BETAZ,GAMMA
6693cc SAVE /BG/
6694 COMMON /RUN/NUM
6695cc SAVE /RUN/
6696 COMMON /PA/RPION(3,MAXSTR,MAXR)
6697cc SAVE /PA/
6698 COMMON /PB/PPION(3,MAXSTR,MAXR)
6699cc SAVE /PB/
6700 COMMON /PC/EPION(MAXSTR,MAXR)
6701cc SAVE /PC/
6702 COMMON /PD/LPION(MAXSTR,MAXR)
6703cc SAVE /PD/
6704 common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
6705cc SAVE /input1/
6706 common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
6707 1 px1n,py1n,pz1n,dp1n
6708cc SAVE /leadng/
6709 COMMON/RNDF77/NSEED
6710cc SAVE /RNDF77/
6711 COMMON /dpert/dpertt(MAXSTR,MAXR),dpertp(MAXSTR),dplast(MAXSTR),
6712 1 dpdcy(MAXSTR),dpdpi(MAXSTR,MAXR),dpt(MAXSTR, MAXR),
6713 2 dpp1(MAXSTR,MAXR),dppion(MAXSTR,MAXR)
6714 common /dpi/em2,lb2
6715 common /para8/ idpert,npertd,idxsec
6716 dimension ppd(3,npdmax),lbpd(npdmax)
6717 SAVE
6718*-----------------------------------------------------------------------
6719 n12=0
6720 m12=0
6721 IBLOCK=0
6722 NTAG=0
6723 EM1=E(I1)
6724 EM2=E(I2)
6725 PR = SQRT( PX**2 + PY**2 + PZ**2 )
6726 C2 = PZ / PR
6727 X1 = RANART(NSEED)
6728 ianti=0
6729 if(lb(i1).lt.0 .and. lb(i2).lt.0)ianti=1
6730
6731clin-6/2008 Production of perturbative deuterons for idpert=1:
6732 call sbbdm(srt,sdprod,ianti,lbm,xmm,pfinal)
6733 if(idpert.eq.1.and.ipert1.eq.1) then
6734 IF (SRT .LT. 2.012) RETURN
6735 if((iabs(lb(i1)).eq.1.or.iabs(lb(i1)).eq.2)
6736 1 .and.(iabs(lb(i2)).ge.6.and.iabs(lb(i2)).le.13)) then
6737 goto 108
6738 elseif((iabs(lb(i2)).eq.1.or.iabs(lb(i2)).eq.2)
6739 1 .and.(iabs(lb(i1)).ge.6.and.iabs(lb(i1)).le.13)) then
6740 goto 108
6741 else
6742 return
6743 endif
6744 endif
6745*-----------------------------------------------------------------------
6746*COM: TEST FOR ELASTIC SCATTERING (EITHER N-N OR DELTA-DELTA 0R
6747* N-DELTA OR N*-N* or N*-Delta)
6748 IF (X1 .LE. SIGNN/SIG) THEN
6749*COM: PARAMETRISATION IS TAKEN FROM THE CUGNON-PAPER
6750 AS = ( 3.65 * (SRT - 1.8766) )**6
6751 A = 6.0 * AS / (1.0 + AS)
6752 TA = -2.0 * PR**2
6753 X = RANART(NSEED)
6754clin-10/24/02 T1 = ALOG( (1-X) * DEXP(dble(A)*dble(TA)) + X ) / A
6755 T1 = sngl(DLOG(dble(1.-X)*DEXP(dble(A)*dble(TA))+dble(X)))/ A
6756 C1 = 1.0 - T1/TA
6757 T1 = 2.0 * PI * RANART(NSEED)
6758 IBLOCK=1
6759 GO TO 107
6760 ELSE
6761*COM: TEST FOR INELASTIC SCATTERING
6762* IF THE AVAILABLE ENERGY IS LESS THAN THE PION-MASS, NOTHING
6763* CAN HAPPEN ANY MORE ==> RETURN (2.04 = 2*AVMASS + PI-MASS+0.02)
6764 IF (SRT .LT. 2.04) RETURN
6765clin-6/2008 add d+meson production for n*N*(0)(1440) and p*N*(+)(1440) channels
6766c (they did not have any inelastic reactions before):
6767 if(((iabs(LB(I1)).EQ.2.or.iabs(LB(I2)).EQ.2).AND.
6768 1 (LB(I1)*LB(I2)).EQ.20).or.(LB(I1)*LB(I2)).EQ.13) then
6769 IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
6770 ENDIF
6771c
6772* Resonance absorption or Delta + N-->N*(1440), N*(1535)
6773* COM: TEST FOR DELTA OR N* ABSORPTION
6774* IN THE PROCESS DELTA+N-->NN, N*+N-->NN
6775 PRF=SQRT(0.25*SRT**2-AVMASS**2)
6776 IF(EM1.GT.1.)THEN
6777 DELTAM=EM1
6778 ELSE
6779 DELTAM=EM2
6780 ENDIF
6781 RENOM=DELTAM*PRF**2/DENOM(SRT,1.)/PR
6782 RENOMN=DELTAM*PRF**2/DENOM(SRT,2.)/PR
6783 RENOM1=DELTAM*PRF**2/DENOM(SRT,-1.)/PR
6784* avoid the inelastic collisions between n+delta- -->N+N
6785* and p+delta++ -->N+N due to charge conservation,
6786* but they can scatter to produce kaons
6787 if((iabs(lb(i1)).eq.2).and.(iabs(lb(i2)).eq.6)) renom=0.
6788 if((iabs(lb(i2)).eq.2).and.(iabs(lb(i1)).eq.6)) renom=0.
6789 if((iabs(lb(i1)).eq.1).and.(iabs(lb(i2)).eq.9)) renom=0.
6790 if((iabs(lb(i2)).eq.1).and.(iabs(lb(i1)).eq.9)) renom=0.
6791 Call M1535(iabs(lb(i1)),iabs(lb(i2)),srt,x1535)
6792 X1440=(3./4.)*SIGMA(SRT,2,0,1)
6793* CROSS SECTION FOR KAON PRODUCTION from the four channels
6794* for NLK channel
6795* avoid the inelastic collisions between n+delta- -->N+N
6796* and p+delta++ -->N+N due to charge conservation,
6797* but they can scatter to produce kaons
6798 if(((iabs(lb(i1)).eq.2).and.(iabs(lb(i2)).eq.6)).OR.
6799 & ((iabs(lb(i2)).eq.2).and.(iabs(lb(i1)).eq.6)).OR.
6800 & ((iabs(lb(i1)).eq.1).and.(iabs(lb(i2)).eq.9)).OR.
6801 & ((iabs(lb(i2)).eq.1).and.(iabs(lb(i1)).eq.9)))THEN
6802clin-6/2008
6803 IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
6804c IF((SIGK+SIGNN)/SIG.GE.X1)GO TO 306
6805 IF((SIGK+SIGNN+sdprod)/SIG.GE.X1)GO TO 306
6806c
6807 ENDIF
6808* WE DETERMINE THE REACTION CHANNELS IN THE FOLLOWING
6809* FOR n+delta(++)-->p+p or n+delta(++)-->n+N*(+)(1440),n+N*(+)(1535)
6810* REABSORPTION OR N*(1535) PRODUCTION LIKE IN P+P OR N*(1440) LIKE PN,
6811 IF(LB(I1)*LB(I2).EQ.18.AND.
6812 & (iabs(LB(I1)).EQ.2.OR.iabs(LB(I2)).EQ.2))then
6813 SIGND=SIGMA(SRT,1,1,0)+0.5*SIGMA(SRT,1,1,1)
6814 SIGDN=0.25*SIGND*RENOM
6815clin-6/2008
6816 IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
6817c IF(X1.GT.(SIGNN+SIGDN+X1440+X1535+SIGK)/SIG)RETURN
6818 IF(X1.GT.(SIGNN+SIGDN+X1440+X1535+SIGK+sdprod)/SIG)RETURN
6819c
6820 IF(SIGK/(SIGK+SIGDN+X1440+X1535).GT.RANART(NSEED))GO TO 306
6821* REABSORPTION:
6822 IF(RANART(NSEED).LT.SIGDN/(SIGDN+X1440+X1535))THEN
6823 M12=3
6824 GO TO 206
6825 ELSE
6826* N* PRODUCTION
6827 IF(RANART(NSEED).LT.X1440/(X1440+X1535))THEN
6828* N*(1440)
6829 M12=37
6830 ELSE
6831* N*(1535) M12=38
6832clin-2/26/03 why is the above commented out? leads to M12=0 but
6833c particle mass is changed after 204 (causes energy violation).
6834c replace by elastic process (return):
6835 return
6836
6837 ENDIF
6838 GO TO 204
6839 ENDIF
6840 ENDIF
6841* FOR p+delta(-)-->n+n or p+delta(-)-->n+N*(0)(1440),n+N*(0)(1535)
6842* REABSORPTION OR N*(1535) PRODUCTION LIKE IN P+P OR N*(1440) LIKE PN,
6843 IF(LB(I1)*LB(I2).EQ.6.AND.
6844 & ((iabs(LB(I1)).EQ.1).OR.(iabs(LB(I2)).EQ.1)))then
6845 SIGND=SIGMA(SRT,1,1,0)+0.5*SIGMA(SRT,1,1,1)
6846 SIGDN=0.25*SIGND*RENOM
6847clin-6/2008
6848 IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
6849c IF (X1.GT.(SIGNN+SIGDN+X1440+X1535+SIGK)/SIG)RETURN
6850 IF (X1.GT.(SIGNN+SIGDN+X1440+X1535+SIGK+sdprod)/SIG)RETURN
6851c
6852 IF(SIGK/(SIGK+SIGDN+X1440+X1535).GT.RANART(NSEED))GO TO 306
6853* REABSORPTION:
6854 IF(RANART(NSEED).LT.SIGDN/(SIGDN+X1440+X1535))THEN
6855 M12=6
6856 GO TO 206
6857 ELSE
6858* N* PRODUCTION
6859 IF(RANART(NSEED).LT.X1440/(X1440+X1535))THEN
6860* N*(1440)
6861 M12=47
6862 ELSE
6863* N*(1535) M12=48
6864clin-2/26/03 causes energy violation, replace by elastic process (return):
6865 return
6866
6867 ENDIF
6868 GO TO 204
6869 ENDIF
6870 ENDIF
6871* FOR p+delta(+)-->p+p, N*(+)(144)+p, N*(+)(1535)+p
6872 IF(LB(I1)*LB(I2).EQ.8.AND.
6873 & (iabs(LB(I1)).EQ.1.OR.iabs(LB(I2)).EQ.1))THEN
6874 SIGND=1.5*SIGMA(SRT,1,1,1)
6875 SIGDN=0.25*SIGND*RENOM
6876clin-6/2008
6877 IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
6878c IF(X1.GT.(SIGNN+SIGDN+x1440+x1535+SIGK)/SIG)RETURN
6879 IF(X1.GT.(SIGNN+SIGDN+x1440+x1535+SIGK+sdprod)/SIG)RETURN
6880c
6881 IF(SIGK/(SIGK+SIGDN+X1440+X1535).GT.RANART(NSEED))GO TO 306
6882 IF(RANART(NSEED).LT.SIGDN/(SIGDN+X1440+X1535))THEN
6883 M12=4
6884 GO TO 206
6885 ELSE
6886 IF(RANART(NSEED).LT.X1440/(X1440+X1535))THEN
6887* N*(144)
6888 M12=39
6889 ELSE
6890 M12=40
6891 ENDIF
6892 GO TO 204
6893 ENDIF
6894 ENDIF
6895* FOR n+delta(0)-->n+n, N*(0)(144)+n, N*(0)(1535)+n
6896 IF(LB(I1)*LB(I2).EQ.14.AND.
6897 & (iabs(LB(I1)).EQ.2.OR.iabs(LB(I2)).EQ.2))THEN
6898 SIGND=1.5*SIGMA(SRT,1,1,1)
6899 SIGDN=0.25*SIGND*RENOM
6900clin-6/2008
6901 IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
6902c IF(X1.GT.(SIGNN+SIGDN+x1440+x1535+SIGK)/SIG)RETURN
6903 IF(X1.GT.(SIGNN+SIGDN+x1440+x1535+SIGK+sdprod)/SIG)RETURN
6904c
6905 IF(SIGK/(SIGK+SIGDN+X1440+X1535).GT.RANART(NSEED))GO TO 306
6906 IF(RANART(NSEED).LT.SIGDN/(SIGDN+X1440+X1535))THEN
6907 M12=5
6908 GO TO 206
6909 ELSE
6910 IF(RANART(NSEED).LT.X1440/(X1440+X1535))THEN
6911* N*(144)
6912 M12=48
6913 ELSE
6914 M12=49
6915 ENDIF
6916 GO TO 204
6917 ENDIF
6918 ENDIF
6919* FOR n+delta(+)-->n+p, N*(+)(1440)+n,N*(0)(1440)+p,
6920* N*(+)(1535)+n,N*(0)(1535)+p
6921 IF(LB(I1)*LB(I2).EQ.16.AND.
6922 & (iabs(LB(I1)).EQ.2.OR.iabs(LB(I2)).EQ.2))THEN
6923 SIGND=0.5*SIGMA(SRT,1,1,1)+0.25*SIGMA(SRT,1,1,0)
6924 SIGDN=0.5*SIGND*RENOM
6925clin-6/2008
6926 IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
6927c IF(X1.GT.(SIGNN+SIGDN+2.*x1440+2.*x1535+SIGK)/SIG)RETURN
6928 IF(X1.GT.(SIGNN+SIGDN+2.*x1440+2.*x1535+SIGK+sdprod)/SIG)RETURN
6929c
6930 IF(SIGK/(SIGK+SIGDN+2*X1440+2*X1535).GT.RANART(NSEED))GO TO 306
6931 IF(RANART(NSEED).LT.SIGDN/(SIGDN+2.*X1440+2.*X1535))THEN
6932 M12=1
6933 GO TO 206
6934 ELSE
6935 IF(RANART(NSEED).LT.X1440/(X1440+X1535))THEN
6936 M12=41
6937 IF(RANART(NSEED).LE.0.5)M12=43
6938 ELSE
6939 M12=42
6940 IF(RANART(NSEED).LE.0.5)M12=44
6941 ENDIF
6942 GO TO 204
6943 ENDIF
6944 ENDIF
6945* FOR p+delta(0)-->n+p, N*(+)(1440)+n,N*(0)(1440)+p,
6946* N*(+)(1535)+n,N*(0)(1535)+p
6947 IF(LB(I1)*LB(I2).EQ.7)THEN
6948 SIGND=0.5*SIGMA(SRT,1,1,1)+0.25*SIGMA(SRT,1,1,0)
6949 SIGDN=0.5*SIGND*RENOM
6950clin-6/2008
6951 IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
6952c IF(X1.GT.(SIGNN+SIGDN+2.*x1440+2.*x1535+SIGK)/SIG)RETURN
6953 IF(X1.GT.(SIGNN+SIGDN+2.*x1440+2.*x1535+SIGK+sdprod)/SIG)RETURN
6954c
6955 IF(SIGK/(SIGK+SIGDN+2*X1440+2*X1535).GT.RANART(NSEED))GO TO 306
6956 IF(RANART(NSEED).LT.SIGDN/(SIGDN+2.*X1440+2.*X1535))THEN
6957 M12=2
6958 GO TO 206
6959 ELSE
6960 IF(RANART(NSEED).LT.X1440/(X1440+X1535))THEN
6961 M12=50
6962 IF(RANART(NSEED).LE.0.5)M12=51
6963 ELSE
6964 M12=52
6965 IF(RANART(NSEED).LE.0.5)M12=53
6966 ENDIF
6967 GO TO 204
6968 ENDIF
6969 ENDIF
6970* FOR p+N*(0)(14)-->p+n, N*(+)(1535)+n,N*(0)(1535)+p
6971* OR P+N*(0)(14)-->D(+)+N, D(0)+P,
6972 IF(LB(I1)*LB(I2).EQ.10.AND.
6973 & (iabs(LB(I1)).EQ.1.OR.iabs(LB(I2)).EQ.1))then
6974 SIGND=(3./4.)*SIGMA(SRT,2,0,1)
6975 SIGDN=SIGND*RENOMN
6976clin-6/2008
6977 IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
6978c IF(X1.GT.(SIGNN+SIGDN+X1535+SIGK)/SIG)RETURN
6979 IF(X1.GT.(SIGNN+SIGDN+X1535+SIGK+sdprod)/SIG)RETURN
6980c
6981 IF(SIGK/(SIGK+SIGDN+X1535).GT.RANART(NSEED))GO TO 306
6982 IF(RANART(NSEED).LT.SIGDN/(SIGDN+X1535))THEN
6983 M12=7
6984 GO TO 206
6985 ELSE
6986 M12=54
6987 IF(RANART(NSEED).LE.0.5)M12=55
6988 ENDIF
6989 GO TO 204
6990 ENDIF
6991* FOR n+N*(+)-->p+n, N*(+)(1535)+n,N*(0)(1535)+p
6992 IF(LB(I1)*LB(I2).EQ.22.AND.
6993 & (iabs(LB(I1)).EQ.2.OR.iabs(LB(I2)).EQ.2))then
6994 SIGND=(3./4.)*SIGMA(SRT,2,0,1)
6995 SIGDN=SIGND*RENOMN
6996clin-6/2008
6997 IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
6998c IF(X1.GT.(SIGNN+SIGDN+X1535+SIGK)/SIG)RETURN
6999 IF(X1.GT.(SIGNN+SIGDN+X1535+SIGK+sdprod)/SIG)RETURN
7000c
7001 IF(SIGK/(SIGK+SIGDN+X1535).GT.RANART(NSEED))GO TO 306
7002 IF(RANART(NSEED).LT.SIGDN/(SIGDN+X1535))THEN
7003 M12=8
7004 GO TO 206
7005 ELSE
7006 M12=56
7007 IF(RANART(NSEED).LE.0.5)M12=57
7008 ENDIF
7009 GO TO 204
7010 ENDIF
7011* FOR N*(1535)+N-->N+N COLLISIONS
7012 IF((iabs(LB(I1)).EQ.12).OR.(iabs(LB(I1)).EQ.13).OR.
7013 1 (iabs(LB(I2)).EQ.12).OR.(iabs(LB(I2)).EQ.13))THEN
7014 SIGND=X1535
7015 SIGDN=SIGND*RENOM1
7016clin-6/2008
7017 IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
7018c IF(X1.GT.(SIGNN+SIGDN+SIGK)/SIG)RETURN
7019 IF(X1.GT.(SIGNN+SIGDN+SIGK+sdprod)/SIG)RETURN
7020c
7021 IF(SIGK/(SIGK+SIGDN).GT.RANART(NSEED))GO TO 306
7022 IF(LB(I1)*LB(I2).EQ.24)M12=10
7023 IF(LB(I1)*LB(I2).EQ.12)M12=12
7024 IF(LB(I1)*LB(I2).EQ.26)M12=11
7025 IF(LB(I1)*LB(I2).EQ.13)M12=9
7026 GO TO 206
7027 ENDIF
7028204 CONTINUE
7029* (1) GENERATE THE MASS FOR THE N*(1440) AND N*(1535)
7030* (2) CALCULATE THE FINAL MOMENTUM OF THE n+N* SYSTEM
7031* (3) RELABLE THE FINAL STATE PARTICLES
7032*PARAMETRIZATION OF THE SHAPE OF THE N* RESONANCE ACCORDING
7033* TO kitazoe's or J.D.JACKSON'S MASS FORMULA AND BREIT WIGNER
7034* FORMULA FOR N* RESORANCE
7035* DETERMINE DELTA MASS VIA REJECTION METHOD.
7036 DMAX = SRT - AVMASS-0.005
7037 DMIN = 1.078
7038 IF((M12.eq.37).or.(M12.eq.39).or.
7039 1 (M12.eQ.41).OR.(M12.eQ.43).OR.(M12.EQ.46).
7040 2 OR.(M12.EQ.48).OR.(M12.EQ.50).OR.(M12.EQ.51))then
7041* N*(1440) production
7042 IF(DMAX.LT.1.44) THEN
7043 FM=FNS(DMAX,SRT,0.)
7044 ELSE
7045
7046clin-10/25/02 get rid of argument usage mismatch in FNS():
7047 xdmass=1.44
7048c FM=FNS(1.44,SRT,1.)
7049 FM=FNS(xdmass,SRT,1.)
7050clin-10/25/02-end
7051
7052 ENDIF
7053 IF(FM.EQ.0.)FM=1.E-09
7054 NTRY2=0
705511 DM=RANART(NSEED)*(DMAX-DMIN)+DMIN
7056 NTRY2=NTRY2+1
7057 IF((RANART(NSEED).GT.FNS(DM,SRT,1.)/FM).AND.
7058 1 (NTRY2.LE.10)) GO TO 11
7059
7060clin-2/26/03 limit the N* mass below a certain value
7061c (here taken as its central value + 2* B-W fullwidth):
7062 if(dm.gt.2.14) goto 11
7063
7064 GO TO 13
7065 ELSE
7066* N*(1535) production
7067 IF(DMAX.LT.1.535) THEN
7068 FM=FD5(DMAX,SRT,0.)
7069 ELSE
7070
7071clin-10/25/02 get rid of argument usage mismatch in FNS():
7072 xdmass=1.535
7073c FM=FD5(1.535,SRT,1.)
7074 FM=FD5(xdmass,SRT,1.)
7075clin-10/25/02-end
7076
7077 ENDIF
7078 IF(FM.EQ.0.)FM=1.E-09
7079 NTRY1=0
708012 DM = RANART(NSEED) * (DMAX-DMIN) + DMIN
7081 NTRY1=NTRY1+1
7082 IF((RANART(NSEED) .GT. FD5(DM,SRT,1.)/FM).AND.
7083 1 (NTRY1.LE.10)) GOTO 12
7084
7085clin-2/26/03 limit the N* mass below a certain value
7086c (here taken as its central value + 2* B-W fullwidth):
7087 if(dm.gt.1.84) goto 12
7088
7089 ENDIF
709013 CONTINUE
7091* (2) DETERMINE THE FINAL MOMENTUM
7092 PRF=0.
7093 PF2=((SRT**2-DM**2+AVMASS**2)/(2.*SRT))**2-AVMASS**2
7094 IF(PF2.GT.0.)PRF=SQRT(PF2)
7095* (3) RELABLE FINAL STATE PARTICLES
7096* 37 D(++)+n-->N*(+)(14)+p
7097 IF(M12.EQ.37)THEN
7098 IF(iabs(LB(I1)).EQ.9)THEN
7099 LB(I1)=1
7100 E(I1)=AMP
7101 LB(I2)=11
7102 E(I2)=DM
7103 ELSE
7104 LB(I2)=1
7105 E(I2)=AMP
7106 LB(I1)=11
7107 E(I1)=DM
7108 ENDIF
7109 GO TO 207
7110 ENDIF
7111* 38 D(++)+n-->N*(+)(15)+p
7112 IF(M12.EQ.38)THEN
7113 IF(iabs(LB(I1)).EQ.9)THEN
7114 LB(I1)=1
7115 E(I1)=AMP
7116 LB(I2)=13
7117 E(I2)=DM
7118 ELSE
7119 LB(I2)=1
7120 E(I2)=AMP
7121 LB(I1)=13
7122 E(I1)=DM
7123 ENDIF
7124 GO TO 207
7125 ENDIF
7126* 39 D(+)+P-->N*(+)(14)+p
7127 IF(M12.EQ.39)THEN
7128 IF(iabs(LB(I1)).EQ.8)THEN
7129 LB(I1)=1
7130 E(I1)=AMP
7131 LB(I2)=11
7132 E(I2)=DM
7133 ELSE
7134 LB(I2)=1
7135 E(I2)=AMP
7136 LB(I1)=11
7137 E(I1)=DM
7138 ENDIF
7139 GO TO 207
7140 ENDIF
7141* 40 D(+)+P-->N*(+)(15)+p
7142 IF(M12.EQ.40)THEN
7143 IF(iabs(LB(I1)).EQ.8)THEN
7144 LB(I1)=1
7145 E(I1)=AMP
7146 LB(I2)=13
7147 E(I2)=DM
7148 ELSE
7149 LB(I2)=1
7150 E(I2)=AMP
7151 LB(I1)=13
7152 E(I1)=DM
7153 ENDIF
7154 GO TO 207
7155 ENDIF
7156* 41 D(+)+N-->N*(+)(14)+N
7157 IF(M12.EQ.41)THEN
7158 IF(iabs(LB(I1)).EQ.8)THEN
7159 LB(I1)=2
7160 E(I1)=AMN
7161 LB(I2)=11
7162 E(I2)=DM
7163 ELSE
7164 LB(I2)=2
7165 E(I2)=AMN
7166 LB(I1)=11
7167 E(I1)=DM
7168 ENDIF
7169 GO TO 207
7170 ENDIF
7171* 42 D(+)+N-->N*(+)(15)+N
7172 IF(M12.EQ.42)THEN
7173 IF(iabs(LB(I1)).EQ.8)THEN
7174 LB(I1)=2
7175 E(I1)=AMN
7176 LB(I2)=13
7177 E(I2)=DM
7178 ELSE
7179 LB(I2)=2
7180 E(I2)=AMN
7181 LB(I1)=13
7182 E(I1)=DM
7183 ENDIF
7184 GO TO 207
7185 ENDIF
7186* 43 D(+)+N-->N*(0)(14)+P
7187 IF(M12.EQ.43)THEN
7188 IF(iabs(LB(I1)).EQ.8)THEN
7189 LB(I1)=1
7190 E(I1)=AMP
7191 LB(I2)=10
7192 E(I2)=DM
7193 ELSE
7194 LB(I2)=1
7195 E(I2)=AMP
7196 LB(I1)=10
7197 E(I1)=DM
7198 ENDIF
7199 GO TO 207
7200 ENDIF
7201* 44 D(+)+N-->N*(0)(15)+P
7202 IF(M12.EQ.44)THEN
7203 IF(iabs(LB(I1)).EQ.8)THEN
7204 LB(I1)=1
7205 E(I1)=AMP
7206 LB(I2)=12
7207 E(I2)=DM
7208 ELSE
7209 LB(I2)=1
7210 E(I2)=AMP
7211 LB(I1)=12
7212 E(I1)=DM
7213 ENDIF
7214 GO TO 207
7215 ENDIF
7216* 46 D(-)+P-->N*(0)(14)+N
7217 IF(M12.EQ.46)THEN
7218 IF(iabs(LB(I1)).EQ.6)THEN
7219 LB(I1)=2
7220 E(I1)=AMN
7221 LB(I2)=10
7222 E(I2)=DM
7223 ELSE
7224 LB(I2)=2
7225 E(I2)=AMN
7226 LB(I1)=10
7227 E(I1)=DM
7228 ENDIF
7229 GO TO 207
7230 ENDIF
7231* 47 D(-)+P-->N*(0)(15)+N
7232 IF(M12.EQ.47)THEN
7233 IF(iabs(LB(I1)).EQ.6)THEN
7234 LB(I1)=2
7235 E(I1)=AMN
7236 LB(I2)=12
7237 E(I2)=DM
7238 ELSE
7239 LB(I2)=2
7240 E(I2)=AMN
7241 LB(I1)=12
7242 E(I1)=DM
7243 ENDIF
7244 GO TO 207
7245 ENDIF
7246* 48 D(0)+N-->N*(0)(14)+N
7247 IF(M12.EQ.48)THEN
7248 IF(iabs(LB(I1)).EQ.7)THEN
7249 LB(I1)=2
7250 E(I1)=AMN
7251 LB(I2)=11
7252 E(I2)=DM
7253 ELSE
7254 LB(I2)=2
7255 E(I2)=AMN
7256 LB(I1)=11
7257 E(I1)=DM
7258 ENDIF
7259 GO TO 207
7260 ENDIF
7261* 49 D(0)+N-->N*(0)(15)+N
7262 IF(M12.EQ.49)THEN
7263 IF(iabs(LB(I1)).EQ.7)THEN
7264 LB(I1)=2
7265 E(I1)=AMN
7266 LB(I2)=12
7267 E(I2)=DM
7268 ELSE
7269 LB(I2)=2
7270 E(I2)=AMN
7271 LB(I1)=12
7272 E(I1)=DM
7273 ENDIF
7274 GO TO 207
7275 ENDIF
7276* 50 D(0)+P-->N*(0)(14)+P
7277 IF(M12.EQ.50)THEN
7278 IF(iabs(LB(I1)).EQ.7)THEN
7279 LB(I1)=1
7280 E(I1)=AMP
7281 LB(I2)=10
7282 E(I2)=DM
7283 ELSE
7284 LB(I2)=1
7285 E(I2)=AMP
7286 LB(I1)=10
7287 E(I1)=DM
7288 ENDIF
7289 GO TO 207
7290 ENDIF
7291* 51 D(0)+P-->N*(+)(14)+N
7292 IF(M12.EQ.51)THEN
7293 IF(iabs(LB(I1)).EQ.7)THEN
7294 LB(I1)=2
7295 E(I1)=AMN
7296 LB(I2)=11
7297 E(I2)=DM
7298 ELSE
7299 LB(I2)=2
7300 E(I2)=AMN
7301 LB(I1)=11
7302 E(I1)=DM
7303 ENDIF
7304 GO TO 207
7305 ENDIF
7306* 52 D(0)+P-->N*(0)(15)+P
7307 IF(M12.EQ.52)THEN
7308 IF(iabs(LB(I1)).EQ.7)THEN
7309 LB(I1)=1
7310 E(I1)=AMP
7311 LB(I2)=12
7312 E(I2)=DM
7313 ELSE
7314 LB(I2)=1
7315 E(I2)=AMP
7316 LB(I1)=12
7317 E(I1)=DM
7318 ENDIF
7319 GO TO 207
7320 ENDIF
7321* 53 D(0)+P-->N*(+)(15)+N
7322 IF(M12.EQ.53)THEN
7323 IF(iabs(LB(I1)).EQ.7)THEN
7324 LB(I1)=2
7325 E(I1)=AMN
7326 LB(I2)=13
7327 E(I2)=DM
7328 ELSE
7329 LB(I2)=2
7330 E(I2)=AMN
7331 LB(I1)=13
7332 E(I1)=DM
7333 ENDIF
7334 GO TO 207
7335 ENDIF
7336* 54 N*(0)(14)+P-->N*(+)(15)+N
7337 IF(M12.EQ.54)THEN
7338 IF(iabs(LB(I1)).EQ.10)THEN
7339 LB(I1)=2
7340 E(I1)=AMN
7341 LB(I2)=13
7342 E(I2)=DM
7343 ELSE
7344 LB(I2)=2
7345 E(I2)=AMN
7346 LB(I1)=13
7347 E(I1)=DM
7348 ENDIF
7349 GO TO 207
7350 ENDIF
7351* 55 N*(0)(14)+P-->N*(0)(15)+P
7352 IF(M12.EQ.55)THEN
7353 IF(iabs(LB(I1)).EQ.10)THEN
7354 LB(I1)=1
7355 E(I1)=AMP
7356 LB(I2)=12
7357 E(I2)=DM
7358 ELSE
7359 LB(I2)=1
7360 E(I2)=AMP
7361 LB(I1)=12
7362 E(I1)=DM
7363 ENDIF
7364 GO TO 207
7365 ENDIF
7366* 56 N*(+)(14)+N-->N*(+)(15)+N
7367 IF(M12.EQ.56)THEN
7368 IF(iabs(LB(I1)).EQ.11)THEN
7369 LB(I1)=2
7370 E(I1)=AMN
7371 LB(I2)=13
7372 E(I2)=DM
7373 ELSE
7374 LB(I2)=2
7375 E(I2)=AMN
7376 LB(I1)=13
7377 E(I1)=DM
7378 ENDIF
7379 GO TO 207
7380 ENDIF
7381* 57 N*(+)(14)+N-->N*(0)(15)+P
7382 IF(M12.EQ.57)THEN
7383 IF(iabs(LB(I1)).EQ.11)THEN
7384 LB(I1)=1
7385 E(I1)=AMP
7386 LB(I2)=12
7387 E(I2)=DM
7388 ELSE
7389 LB(I2)=1
7390 E(I2)=AMP
7391 LB(I1)=12
7392 E(I1)=DM
7393 ENDIF
7394 ENDIF
7395 GO TO 207
7396*------------------------------------------------
7397* RELABLE NUCLEONS AFTER DELTA OR N* BEING ABSORBED
7398*(1) n+delta(+)-->n+p
7399206 IF(M12.EQ.1)THEN
7400 IF(iabs(LB(I1)).EQ.8)THEN
7401 LB(I2)=2
7402 LB(I1)=1
7403 E(I1)=AMP
7404 ELSE
7405 LB(I1)=2
7406 LB(I2)=1
7407 E(I2)=AMP
7408 ENDIF
7409 GO TO 207
7410 ENDIF
7411*(2) p+delta(0)-->p+n
7412 IF(M12.EQ.2)THEN
7413 IF(iabs(LB(I1)).EQ.7)THEN
7414 LB(I2)=1
7415 LB(I1)=2
7416 E(I1)=AMN
7417 ELSE
7418 LB(I1)=1
7419 LB(I2)=2
7420 E(I2)=AMN
7421 ENDIF
7422 GO TO 207
7423 ENDIF
7424*(3) n+delta(++)-->p+p
7425 IF(M12.EQ.3)THEN
7426 LB(I1)=1
7427 LB(I2)=1
7428 E(I1)=AMP
7429 E(I2)=AMP
7430 GO TO 207
7431 ENDIF
7432*(4) p+delta(+)-->p+p
7433 IF(M12.EQ.4)THEN
7434 LB(I1)=1
7435 LB(I2)=1
7436 E(I1)=AMP
7437 E(I2)=AMP
7438 GO TO 207
7439 ENDIF
7440*(5) n+delta(0)-->n+n
7441 IF(M12.EQ.5)THEN
7442 LB(I1)=2
7443 LB(I2)=2
7444 E(I1)=AMN
7445 E(I2)=AMN
7446 GO TO 207
7447 ENDIF
7448*(6) p+delta(-)-->n+n
7449 IF(M12.EQ.6)THEN
7450 LB(I1)=2
7451 LB(I2)=2
7452 E(I1)=AMN
7453 E(I2)=AMN
7454 GO TO 207
7455 ENDIF
7456*(7) p+N*(0)-->n+p
7457 IF(M12.EQ.7)THEN
7458 IF(iabs(LB(I1)).EQ.1)THEN
7459 LB(I1)=1
7460 LB(I2)=2
7461 E(I1)=AMP
7462 E(I2)=AMN
7463 ELSE
7464 LB(I1)=2
7465 LB(I2)=1
7466 E(I1)=AMN
7467 E(I2)=AMP
7468 ENDIF
7469 GO TO 207
7470 ENDIF
7471*(8) n+N*(+)-->n+p
7472 IF(M12.EQ.8)THEN
7473 IF(iabs(LB(I1)).EQ.2)THEN
7474 LB(I1)=2
7475 LB(I2)=1
7476 E(I1)=AMN
7477 E(I2)=AMP
7478 ELSE
7479 LB(I1)=1
7480 LB(I2)=2
7481 E(I1)=AMP
7482 E(I2)=AMN
7483 ENDIF
7484 GO TO 207
7485 ENDIF
7486clin-6/2008
7487c*(9) N*(+)p-->pp
7488*(9) N*(+)(1535) p-->pp
7489 IF(M12.EQ.9)THEN
7490 LB(I1)=1
7491 LB(I2)=1
7492 E(I1)=AMP
7493 E(I2)=AMP
7494 GO TO 207
7495 ENDIF
7496*(12) N*(0)P-->nP
7497 IF(M12.EQ.12)THEN
7498 LB(I1)=2
7499 LB(I2)=1
7500 E(I1)=AMN
7501 E(I2)=AMP
7502 GO TO 207
7503 ENDIF
7504*(11) N*(+)n-->nP
7505 IF(M12.EQ.11)THEN
7506 LB(I1)=2
7507 LB(I2)=1
7508 E(I1)=AMN
7509 E(I2)=AMP
7510 GO TO 207
7511 ENDIF
7512clin-6/2008
7513c*(12) N*(0)p-->Np
7514*(12) N*(0)(1535) p-->Np
7515 IF(M12.EQ.12)THEN
7516 LB(I1)=1
7517 LB(I2)=2
7518 E(I1)=AMP
7519 E(I2)=AMN
7520 ENDIF
7521*----------------------------------------------
7522207 PR = PRF
7523 C1 = 1.0 - 2.0 * RANART(NSEED)
7524 if(srt.le.2.14)C1= 1.0 - 2.0 * RANART(NSEED)
86c53b9e 7525 if(srt.gt.2.14.and.srt.le.2.4)c1=anga(srt,iseed)
0119ef9a 7526 if(srt.gt.2.4)then
7527
7528clin-10/25/02 get rid of argument usage mismatch in PTR():
7529 xptr=0.33*pr
7530c cc1=ptr(0.33*pr,iseed)
7531 cc1=ptr(xptr,iseed)
7532clin-10/25/02-end
7533
7534 c1=sqrt(pr**2-cc1**2)/pr
7535 endif
7536 T1 = 2.0 * PI * RANART(NSEED)
7537 IBLOCK=3
7538 ENDIF
7539 if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
7540 lb(i1) = -lb(i1)
7541 lb(i2) = -lb(i2)
7542 endif
7543
7544*-----------------------------------------------------------------------
7545*COM: SET THE NEW MOMENTUM COORDINATES
7546 107 IF(PX .EQ. 0.0 .AND. PY .EQ. 0.0) THEN
7547 T2 = 0.0
7548 ELSE
7549 T2=ATAN2(PY,PX)
7550 END IF
7551 S1 = SQRT( 1.0 - C1**2 )
7552 S2 = SQRT( 1.0 - C2**2 )
7553 CT1 = COS(T1)
7554 ST1 = SIN(T1)
7555 CT2 = COS(T2)
7556 ST2 = SIN(T2)
7557 PZ = PR * ( C1*C2 - S1*S2*CT1 )
7558 SS = C2 * S1 * CT1 + S2 * C1
7559 PX = PR * ( SS*CT2 - S1*ST1*ST2 )
7560 PY = PR * ( SS*ST2 + S1*ST1*CT2 )
7561 RETURN
7562* FOR THE NN-->KAON+X PROCESS, FIND MOMENTUM OF THE FINAL PARTICLES IN
7563* THE NUCLEUS-NUCLEUS CMS.
7564306 CONTINUE
7565csp11/21/01 phi production
7566 if(XSK5/sigK.gt.RANART(NSEED))then
7567 pz1=p(3,i1)
7568 pz2=p(3,i2)
7569 LB(I1) = 1 + int(2 * RANART(NSEED))
7570 LB(I2) = 1 + int(2 * RANART(NSEED))
7571 nnn=nnn+1
7572 LPION(NNN,IRUN)=29
7573 EPION(NNN,IRUN)=APHI
7574 iblock = 222
7575 GO TO 208
7576 ENDIF
7577csp11/21/01 end
7578 IBLOCK=11
7579 if(ianti .eq. 1)iblock=-11
7580c
7581 pz1=p(3,i1)
7582 pz2=p(3,i2)
7583* DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
7584 nnn=nnn+1
7585 LPION(NNN,IRUN)=23
7586 EPION(NNN,IRUN)=Aka
7587 if(srt.le.2.63)then
7588* only lambda production is possible
7589* (1.1)P+P-->p+L+kaon+
7590 ic=1
7591
7592 LB(I1) = 1 + int(2 * RANART(NSEED))
7593 LB(I2)=14
7594 GO TO 208
7595 ENDIF
7596 if(srt.le.2.74.and.srt.gt.2.63)then
7597* both Lambda and sigma production are possible
7598 if(XSK1/(XSK1+XSK2).gt.RANART(NSEED))then
7599* lambda production
7600 ic=1
7601
7602 LB(I1) = 1 + int(2 * RANART(NSEED))
7603 LB(I2)=14
7604 else
7605* sigma production
7606
7607 LB(I1) = 1 + int(2 * RANART(NSEED))
7608 LB(I2) = 15 + int(3 * RANART(NSEED))
7609 ic=2
7610 endif
7611 GO TO 208
7612 endif
7613 if(srt.le.2.77.and.srt.gt.2.74)then
7614* then pp-->Delta lamda kaon can happen
7615 if(xsk1/(xsk1+xsk2+xsk3).
7616 1 gt.RANART(NSEED))then
7617* * (1.1)P+P-->p+L+kaon+
7618 ic=1
7619
7620 LB(I1) = 1 + int(2 * RANART(NSEED))
7621 LB(I2)=14
7622 go to 208
7623 else
7624 if(xsk2/(xsk2+xsk3).gt.RANART(NSEED))then
7625* pp-->psk
7626 ic=2
7627
7628 LB(I1) = 1 + int(2 * RANART(NSEED))
7629 LB(I2) = 15 + int(3 * RANART(NSEED))
7630
7631 else
7632* pp-->D+l+k
7633 ic=3
7634
7635 LB(I1) = 6 + int(4 * RANART(NSEED))
7636 lb(i2)=14
7637 endif
7638 GO TO 208
7639 endif
7640 endif
7641 if(srt.gt.2.77)then
7642* all four channels are possible
7643 if(xsk1/(xsk1+xsk2+xsk3+xsk4).gt.RANART(NSEED))then
7644* p lambda k production
7645 ic=1
7646
7647 LB(I1) = 1 + int(2 * RANART(NSEED))
7648 LB(I2)=14
7649 go to 208
7650 else
7651 if(xsk3/(xsk2+xsk3+xsk4).gt.RANART(NSEED))then
7652* delta l K production
7653 ic=3
7654
7655 LB(I1) = 6 + int(4 * RANART(NSEED))
7656 lb(i2)=14
7657 go to 208
7658 else
7659 if(xsk2/(xsk2+xsk4).gt.RANART(NSEED))then
7660* n sigma k production
7661
7662 LB(I1) = 1 + int(2 * RANART(NSEED))
7663 LB(I2) = 15 + int(3 * RANART(NSEED))
7664
7665 ic=2
7666 else
7667 ic=4
7668
7669 LB(I1) = 6 + int(4 * RANART(NSEED))
7670 LB(I2) = 15 + int(3 * RANART(NSEED))
7671
7672 endif
7673 go to 208
7674 endif
7675 endif
7676 endif
7677208 continue
7678 if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
7679 lb(i1) = - lb(i1)
7680 lb(i2) = - lb(i2)
7681 if(LPION(NNN,IRUN) .eq. 23)LPION(NNN,IRUN)=21
7682 endif
7683 lbi1=lb(i1)
7684 lbi2=lb(i2)
7685* KEEP ALL COORDINATES OF PARTICLE 2 FOR POSSIBLE PHASE SPACE CHANGE
7686 NTRY1=0
7687128 CALL BBKAON(ic,SRT,PX3,PY3,PZ3,DM3,PX4,PY4,PZ4,DM4,
7688 & PPX,PPY,PPZ,icou1)
7689 NTRY1=NTRY1+1
7690 if((icou1.lt.0).AND.(NTRY1.LE.20))GO TO 128
7691c if(icou1.lt.0)return
7692* ROTATE THE MOMENTA OF PARTICLES IN THE CMS OF P1+P2
7693 CALL ROTATE(PX,PY,PZ,PX3,PY3,PZ3)
7694 CALL ROTATE(PX,PY,PZ,PX4,PY4,PZ4)
7695 CALL ROTATE(PX,PY,PZ,PPX,PPY,PPZ)
7696* FIND THE MOMENTUM OF PARTICLES IN THE FINAL STATE IN THE NUCLEUS-
7697* NUCLEUS CMS. FRAME
7698* (1) for the necleon/delta
7699* LORENTZ-TRANSFORMATION INTO LAB FRAME FOR DELTA1
7700 E1CM = SQRT (dm3**2 + PX3**2 + PY3**2 + PZ3**2)
7701 P1BETA = PX3*BETAX + PY3*BETAY + PZ3*BETAZ
7702 TRANSF = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) + E1CM )
7703 Pt1i1 = BETAX * TRANSF + PX3
7704 Pt2i1 = BETAY * TRANSF + PY3
7705 Pt3i1 = BETAZ * TRANSF + PZ3
7706 Eti1 = DM3
7707* (2) for the lambda/sigma
7708 E2CM = SQRT (dm4**2 + PX4**2 + PY4**2 + PZ4**2)
7709 P2BETA = PX4*BETAX+PY4*BETAY+PZ4*BETAZ
7710 TRANSF = GAMMA * (GAMMA*P2BETA / (GAMMA + 1.) + E2CM)
7711 Pt1I2 = BETAX * TRANSF + PX4
7712 Pt2I2 = BETAY * TRANSF + PY4
7713 Pt3I2 = BETAZ * TRANSF + PZ4
7714 EtI2 = DM4
7715* GET the kaon'S MOMENTUM AND COORDINATES IN NUCLEUS-NUCLEUS CMS. FRAME
7716 EPCM=SQRT(aka**2+PPX**2+PPY**2+PPZ**2)
7717 PPBETA=PPX*BETAX+PPY*BETAY+PPZ*BETAZ
7718 TRANSF=GAMMA*(GAMMA*PPBETA/(GAMMA+1.)+EPCM)
7719 PPION(1,NNN,IRUN)=BETAX*TRANSF+PPX
7720 PPION(2,NNN,IRUN)=BETAY*TRANSF+PPY
7721 PPION(3,NNN,IRUN)=BETAZ*TRANSF+PPZ
7722clin-5/2008:
7723 dppion(nnn,irun)=dpertp(i1)*dpertp(i2)
7724clin-5/2008:
7725c2008 X01 = 1.0 - 2.0 * RANART(NSEED)
7726c Y01 = 1.0 - 2.0 * RANART(NSEED)
7727c Z01 = 1.0 - 2.0 * RANART(NSEED)
7728c IF ((X01*X01+Y01*Y01+Z01*Z01) .GT. 1.0) GOTO 2008
7729c RPION(1,NNN,IRUN)=R(1,I1)+0.5*x01
7730c RPION(2,NNN,IRUN)=R(2,I1)+0.5*y01
7731c RPION(3,NNN,IRUN)=R(3,I1)+0.5*z01
7732 RPION(1,NNN,IRUN)=R(1,I1)
7733 RPION(2,NNN,IRUN)=R(2,I1)
7734 RPION(3,NNN,IRUN)=R(3,I1)
7735c
7736* assign the nucleon/delta and lambda/sigma to i1 or i2 to keep the
7737* leadng particle behaviour
7738C if((pt1i1*px1+pt2i1*py1+pt3i1*pz1).gt.0)then
7739 p(1,i1)=pt1i1
7740 p(2,i1)=pt2i1
7741 p(3,i1)=pt3i1
7742 e(i1)=eti1
7743 lb(i1)=lbi1
7744 p(1,i2)=pt1i2
7745 p(2,i2)=pt2i2
7746 p(3,i2)=pt3i2
7747 e(i2)=eti2
7748 lb(i2)=lbi2
7749 PX1 = P(1,I1)
7750 PY1 = P(2,I1)
7751 PZ1 = P(3,I1)
7752 EM1 = E(I1)
7753 ID(I1) = 2
7754 ID(I2) = 2
7755 ID1 = ID(I1)
7756 if(LPION(NNN,IRUN) .ne. 29) IBLOCK=11
7757 LB1=LB(I1)
7758 LB2=LB(I2)
7759 AM1=EM1
7760 am2=em2
7761 E1= SQRT( EM1**2 + PX1**2 + PY1**2 + PZ1**2 )
7762 RETURN
7763
7764clin-6/2008 N+D->Deuteron+pi:
7765* FIND MOMENTUM OF THE FINAL PARTICLES IN THE NUCLEUS-NUCLEUS CMS.
7766 108 CONTINUE
7767 if(idpert.eq.1.and.ipert1.eq.1.and.npertd.ge.1) then
7768c For idpert=1: we produce npertd pert deuterons:
7769 ndloop=npertd
7770 elseif(idpert.eq.2.and.npertd.ge.1) then
7771c For idpert=2: we first save information for npertd pert deuterons;
7772c at the last ndloop we create the regular deuteron+pi
7773c and those pert deuterons:
7774 ndloop=npertd+1
7775 else
7776c Just create the regular deuteron+pi:
7777 ndloop=1
7778 endif
7779c
7780 dprob1=sdprod/sig/float(npertd)
7781 do idloop=1,ndloop
7782 CALL bbdangle(pxd,pyd,pzd,nt,ipert1,ianti,idloop,pfinal,
7783 1 dprob1,lbm)
7784 CALL ROTATE(PX,PY,PZ,PXd,PYd,PZd)
7785* LORENTZ-TRANSFORMATION OF THE MOMENTUM OF PARTICLES IN THE FINAL STATE
7786* FROM THE NN CMS FRAME INTO THE GLOBAL CMS FRAME:
7787* For the Deuteron:
7788 xmass=xmd
7789 E1dCM=SQRT(xmass**2+PXd**2+PYd**2+PZd**2)
7790 P1dBETA=PXd*BETAX+PYd*BETAY+PZd*BETAZ
7791 TRANSF=GAMMA*(GAMMA*P1dBETA/(GAMMA+1.)+E1dCM)
7792 pxi1=BETAX*TRANSF+PXd
7793 pyi1=BETAY*TRANSF+PYd
7794 pzi1=BETAZ*TRANSF+PZd
7795 if(ianti.eq.0)then
7796 lbd=42
7797 else
7798 lbd=-42
7799 endif
7800 if(idpert.eq.1.and.ipert1.eq.1.and.npertd.ge.1) then
7801cccc Perturbative production for idpert=1:
7802 nnn=nnn+1
7803 PPION(1,NNN,IRUN)=pxi1
7804 PPION(2,NNN,IRUN)=pyi1
7805 PPION(3,NNN,IRUN)=pzi1
7806 EPION(NNN,IRUN)=xmd
7807 LPION(NNN,IRUN)=lbd
7808 RPION(1,NNN,IRUN)=R(1,I1)
7809 RPION(2,NNN,IRUN)=R(2,I1)
7810 RPION(3,NNN,IRUN)=R(3,I1)
7811clin-6/2008 assign the perturbative probability:
7812 dppion(NNN,IRUN)=sdprod/sig/float(npertd)
7813 elseif(idpert.eq.2.and.idloop.le.npertd) then
7814clin-6/2008 For idpert=2, we produce NPERTD perturbative (anti)deuterons
7815c only when a regular (anti)deuteron+pi is produced in NN collisions.
7816c First save the info for the perturbative deuterons:
7817 ppd(1,idloop)=pxi1
7818 ppd(2,idloop)=pyi1
7819 ppd(3,idloop)=pzi1
7820 lbpd(idloop)=lbd
7821 else
7822cccc Regular production:
7823c For the regular pion: do LORENTZ-TRANSFORMATION:
7824 E(i1)=xmm
7825 E2piCM=SQRT(xmm**2+PXd**2+PYd**2+PZd**2)
7826 P2piBETA=-PXd*BETAX-PYd*BETAY-PZd*BETAZ
7827 TRANSF=GAMMA*(GAMMA*P2piBETA/(GAMMA+1.)+E2piCM)
7828 pxi2=BETAX*TRANSF-PXd
7829 pyi2=BETAY*TRANSF-PYd
7830 pzi2=BETAZ*TRANSF-PZd
7831 p(1,i1)=pxi2
7832 p(2,i1)=pyi2
7833 p(3,i1)=pzi2
7834c Remove regular pion to check the equivalence
7835c between the perturbative and regular deuteron results:
7836c E(i1)=0.
7837c
7838 LB(I1)=lbm
7839 PX1=P(1,I1)
7840 PY1=P(2,I1)
7841 PZ1=P(3,I1)
7842 EM1=E(I1)
7843 ID(I1)=2
7844 ID1=ID(I1)
7845 E1=SQRT(EM1**2+PX1**2+PY1**2+PZ1**2)
7846 lb1=lb(i1)
7847c For the regular deuteron:
7848 p(1,i2)=pxi1
7849 p(2,i2)=pyi1
7850 p(3,i2)=pzi1
7851 lb(i2)=lbd
7852 lb2=lb(i2)
7853 E(i2)=xmd
7854 EtI2=E(I2)
7855 ID(I2)=2
7856c For idpert=2: create the perturbative deuterons:
7857 if(idpert.eq.2.and.idloop.eq.ndloop) then
7858 do ipertd=1,npertd
7859 nnn=nnn+1
7860 PPION(1,NNN,IRUN)=ppd(1,ipertd)
7861 PPION(2,NNN,IRUN)=ppd(2,ipertd)
7862 PPION(3,NNN,IRUN)=ppd(3,ipertd)
7863 EPION(NNN,IRUN)=xmd
7864 LPION(NNN,IRUN)=lbpd(ipertd)
7865 RPION(1,NNN,IRUN)=R(1,I1)
7866 RPION(2,NNN,IRUN)=R(2,I1)
7867 RPION(3,NNN,IRUN)=R(3,I1)
7868clin-6/2008 assign the perturbative probability:
7869 dppion(NNN,IRUN)=1./float(npertd)
7870 enddo
7871 endif
7872 endif
7873 enddo
7874 IBLOCK=501
7875 return
7876clin-6/2008 N+D->Deuteron+pi over
7877
7878 END
7879**********************************
7880* *
7881* *
7882 SUBROUTINE CRDD(IRUN,PX,PY,PZ,SRT,I1,I2,IBLOCK,
7883 1NTAG,SIGNN,SIG,NT,ipert1)
7884c 1NTAG,SIGNN,SIG)
7885* PURPOSE: *
7886* DEALING WITH BARYON RESONANCE-BARYON RESONANCE COLLISIONS*
7887* NOTE : *
7888* QUANTITIES: *
7889* PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
7890* SRT - SQRT OF S *
7891* NSTAR =1 INCLUDING N* RESORANCE,ELSE NOT *
7892* NDIRCT=1 INCLUDING DIRECT PION PRODUCTION PROCESS *
7893* IBLOCK - THE INFORMATION BACK *
7894* 0-> COLLISION CANNOT HAPPEN *
7895* 1-> N-N ELASTIC COLLISION *
7896* 2-> N+N->N+DELTA,OR N+N->N+N* REACTION *
7897* 3-> N+DELTA->N+N OR N+N*->N+N REACTION *
7898* 4-> N+N->N+N+PION,DIRTCT PROCESS *
7899* 5-> DELTA(N*)+DELTA(N*) TOTAL COLLISIONS *
7900* N12 - IS USED TO SPECIFY BARYON-BARYON REACTION *
7901* CHANNELS. M12 IS THE REVERSAL CHANNEL OF N12 *
7902* N12, *
7903* M12=1 FOR p+n-->delta(+)+ n *
7904* 2 p+n-->delta(0)+ p *
7905* 3 p+p-->delta(++)+n *
7906* 4 p+p-->delta(+)+p *
7907* 5 n+n-->delta(0)+n *
7908* 6 n+n-->delta(-)+p *
7909* 7 n+p-->N*(0)(1440)+p *
7910* 8 n+p-->N*(+)(1440)+n *
7911* 9 p+p-->N*(+)(1535)+p *
7912* 10 n+n-->N*(0)(1535)+n *
7913* 11 n+p-->N*(+)(1535)+n *
7914* 12 n+p-->N*(0)(1535)+p
7915* 13 D(++)+D(-)-->N*(+)(1440)+n
7916* 14 D(++)+D(-)-->N*(0)(1440)+p
7917* 15 D(+)+D(0)--->N*(+)(1440)+n
7918* 16 D(+)+D(0)--->N*(0)(1440)+p
7919* 17 D(++)+D(0)-->N*(+)(1535)+p
7920* 18 D(++)+D(-)-->N*(0)(1535)+p
7921* 19 D(++)+D(-)-->N*(+)(1535)+n
7922* 20 D(+)+D(+)-->N*(+)(1535)+p
7923* 21 D(+)+D(0)-->N*(+)(1535)+n
7924* 22 D(+)+D(0)-->N*(0)(1535)+p
7925* 23 D(+)+D(-)-->N*(0)(1535)+n
7926* 24 D(0)+D(0)-->N*(0)(1535)+n
7927* 25 N*(+)(14)+N*(+)(14)-->N*(+)(15)+p
7928* 26 N*(0)(14)+N*(0)(14)-->N*(0)(15)+n
7929* 27 N*(+)(14)+N*(0)(14)-->N*(+)(15)+n
7930* 28 N*(+)(14)+N*(0)(14)-->N*(0)(15)+p
7931* 29 N*(+)(14)+D+-->N*(+)(15)+p
7932* 30 N*(+)(14)+D0-->N*(+)(15)+n
7933* 31 N*(+)(14)+D(-)-->N*(0)(1535)+n
7934* 32 N*(0)(14)+D++--->N*(+)(15)+p
7935* 33 N*(0)(14)+D+--->N*(+)(15)+n
7936* 34 N*(0)(14)+D+--->N*(0)(15)+p
7937* 35 N*(0)(14)+D0-->N*(0)(15)+n
7938* 36 N*(+)(14)+D0--->N*(0)(15)+p
7939* +++
7940* AND MORE CHANNELS AS LISTED IN THE NOTE BOOK
7941*
7942* NOTE ABOUT N*(1440) RESORANCE: *
7943* As it has been discussed in VerWest's paper,I= 1 (initial isospin)
7944* channel can all be attributed to delta resorance while I= 0 *
7945* channel can all be attribured to N* resorance.Only in n+p *
7946* one can have I=0 channel so is the N*(1440) resorance *
7947* REFERENCES: J. CUGNON ET AL., NUCL. PHYS. A352, 505 (1981) *
7948* Y. KITAZOE ET AL., PHYS. LETT. 166B, 35 (1986) *
7949* B. VerWest el al., PHYS. PRV. C25 (1982)1979 *
7950* Gy. Wolf et al, Nucl Phys A517 (1990) 615 *
7951* CUTOFF = 2 * AVMASS + 20 MEV *
7952* *
7953* for N*(1535) we use the parameterization by Gy. Wolf et al *
7954* Nucl phys A552 (1993) 349, added May 18, 1994 *
7955**********************************
7956 PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
7957 1 AMP=0.93828,AP1=0.13496,AKA=0.498,APHI=1.020,
7958 2 AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
7959 parameter (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
7960 parameter (xmd=1.8756,npdmax=10000)
7961 COMMON /AA/ R(3,MAXSTR)
7962cc SAVE /AA/
7963 COMMON /BB/ P(3,MAXSTR)
7964cc SAVE /BB/
7965 COMMON /CC/ E(MAXSTR)
7966cc SAVE /CC/
7967 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
7968cc SAVE /EE/
7969 common /ff/f(-mx:mx,-my:my,-mz:mz,-mpx:mpx,-mpy:mpy,-mpz:mpzp)
7970cc SAVE /ff/
7971 common /gg/ dx,dy,dz,dpx,dpy,dpz
7972cc SAVE /gg/
7973 COMMON /INPUT/ NSTAR,NDIRCT,DIR
7974cc SAVE /INPUT/
7975 COMMON /NN/NNN
7976cc SAVE /NN/
7977 COMMON /BG/BETAX,BETAY,BETAZ,GAMMA
7978cc SAVE /BG/
7979 COMMON /RUN/NUM
7980cc SAVE /RUN/
7981 COMMON /PA/RPION(3,MAXSTR,MAXR)
7982cc SAVE /PA/
7983 COMMON /PB/PPION(3,MAXSTR,MAXR)
7984cc SAVE /PB/
7985 COMMON /PC/EPION(MAXSTR,MAXR)
7986cc SAVE /PC/
7987 COMMON /PD/LPION(MAXSTR,MAXR)
7988cc SAVE /PD/
7989 common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
7990cc SAVE /input1/
7991 common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
7992 1 px1n,py1n,pz1n,dp1n
7993cc SAVE /leadng/
7994 COMMON/RNDF77/NSEED
7995cc SAVE /RNDF77/
7996 COMMON /dpert/dpertt(MAXSTR,MAXR),dpertp(MAXSTR),dplast(MAXSTR),
7997 1 dpdcy(MAXSTR),dpdpi(MAXSTR,MAXR),dpt(MAXSTR, MAXR),
7998 2 dpp1(MAXSTR,MAXR),dppion(MAXSTR,MAXR)
7999 common /dpi/em2,lb2
8000 common /para8/ idpert,npertd,idxsec
8001 dimension ppd(3,npdmax),lbpd(npdmax)
8002 SAVE
8003*-----------------------------------------------------------------------
8004 n12=0
8005 m12=0
8006 IBLOCK=0
8007 NTAG=0
8008 EM1=E(I1)
8009 EM2=E(I2)
8010 PR = SQRT( PX**2 + PY**2 + PZ**2 )
8011 C2 = PZ / PR
8012 IF(PX .EQ. 0.0 .AND. PY .EQ. 0.0) THEN
8013 T2 = 0.0
8014 ELSE
8015 T2=ATAN2(PY,PX)
8016 END IF
8017 X1 = RANART(NSEED)
8018 ianti=0
8019 if(lb(i1).lt.0 .and. lb(i2).lt.0)ianti=1
8020
8021clin-6/2008 Production of perturbative deuterons for idpert=1:
8022 call sbbdm(srt,sdprod,ianti,lbm,xmm,pfinal)
8023 if(idpert.eq.1.and.ipert1.eq.1) then
8024 IF (SRT .LT. 2.012) RETURN
8025 if((iabs(lb(i1)).ge.6.and.iabs(lb(i1)).le.13)
8026 1 .and.(iabs(lb(i2)).ge.6.and.iabs(lb(i2)).le.13)) then
8027 goto 108
8028 else
8029 return
8030 endif
8031 endif
8032
8033*-----------------------------------------------------------------------
8034*COM: TEST FOR ELASTIC SCATTERING (EITHER N-N OR DELTA-DELTA 0R
8035* N-DELTA OR N*-N* or N*-Delta)
8036 IF (X1 .LE. SIGNN/SIG) THEN
8037*COM: PARAMETRISATION IS TAKEN FROM THE CUGNON-PAPER
8038 AS = ( 3.65 * (SRT - 1.8766) )**6
8039 A = 6.0 * AS / (1.0 + AS)
8040 TA = -2.0 * PR**2
8041 X = RANART(NSEED)
8042clin-10/24/02 T1 = DLOG( (1-X) * DEXP(dble(A)*dble(TA)) + X ) / A
8043 T1 = sngl(DLOG(dble(1.-X)*DEXP(dble(A)*dble(TA))+dble(X)))/ A
8044 C1 = 1.0 - T1/TA
8045 T1 = 2.0 * PI * RANART(NSEED)
8046 IBLOCK=20
8047 GO TO 107
8048 ELSE
8049*COM: TEST FOR INELASTIC SCATTERING
8050* IF THE AVAILABLE ENERGY IS LESS THAN THE PION-MASS, NOTHING
8051* CAN HAPPEN ANY MORE ==> RETURN (2.15 = 2*AVMASS +2*PI-MASS)
8052 IF (SRT .LT. 2.15) RETURN
8053* IF THERE WERE 2 N*(1535) AND THEY DIDN'T SCATT. ELAST.,
8054* ALLOW THEM TO PRODUCE KAONS. NO OTHER INELASTIC CHANNELS
8055* ARE KNOWN
8056C if((lb(i1).ge.12).and.(lb(i2).ge.12))return
8057* ALL the inelastic collisions between N*(1535) and Delta as well
8058* as N*(1440) TO PRODUCE KAONS, NO OTHER CHANNELS ARE KNOWN
8059C if((lb(i1).ge.12).and.(lb(i2).ge.3))return
8060C if((lb(i2).ge.12).and.(lb(i1).ge.3))return
8061* calculate the N*(1535) production cross section in I1+I2 collisions
8062 call N1535(iabs(lb(i1)),iabs(lb(i2)),srt,X1535)
8063
8064* for Delta+Delta-->N*(1440 OR 1535)+N AND N*(1440)+N*(1440)-->N*(1535)+X
8065* AND DELTA+N*(1440)-->N*(1535)+X
8066* WE ASSUME THEY HAVE THE SAME CROSS SECTIONS as CORRESPONDING N+N COLLISION):
8067* FOR D++D0, D+D+,D+D-,D0D0,N*+N*+,N*0N*0,N*(+)D+,N*(+)D(-),N*(0)D(0)
8068* N*(1535) production, kaon production and reabsorption through
8069* D(N*)+D(N*)-->NN are ALLOWED.
8070* CROSS SECTION FOR KAON PRODUCTION from the four channels are
8071* for NLK channel
8072 akp=0.498
8073 ak0=0.498
8074 ana=0.938
8075 ada=1.232
8076 al=1.1157
8077 as=1.1197
8078 xsk1=0
8079 xsk2=0
8080 xsk3=0
8081 xsk4=0
8082 xsk5=0
8083 t1nlk=ana+al+akp
8084 if(srt.le.t1nlk)go to 222
8085 XSK1=1.5*PPLPK(SRT)
8086* for DLK channel
8087 t1dlk=ada+al+akp
8088 t2dlk=ada+al-akp
8089 if(srt.le.t1dlk)go to 222
8090 es=srt
8091 pmdlk2=(es**2-t1dlk**2)*(es**2-t2dlk**2)/(4.*es**2)
8092 pmdlk=sqrt(pmdlk2)
8093 XSK3=1.5*PPLPK(srt)
8094* for NSK channel
8095 t1nsk=ana+as+akp
8096 t2nsk=ana+as-akp
8097 if(srt.le.t1nsk)go to 222
8098 pmnsk2=(es**2-t1nsk**2)*(es**2-t2nsk**2)/(4.*es**2)
8099 pmnsk=sqrt(pmnsk2)
8100 XSK2=1.5*(PPK1(srt)+PPK0(srt))
8101* for DSK channel
8102 t1DSk=aDa+aS+akp
8103 t2DSk=aDa+aS-akp
8104 if(srt.le.t1dsk)go to 222
8105 pmDSk2=(es**2-t1DSk**2)*(es**2-t2DSk**2)/(4.*es**2)
8106 pmDSk=sqrt(pmDSk2)
8107 XSK4=1.5*(PPK1(srt)+PPK0(srt))
8108csp11/21/01
8109c phi production
8110 if(srt.le.(2.*amn+aphi))go to 222
8111c !! mb put the correct form
8112 xsk5 = 0.0001
8113csp11/21/01 end
8114* THE TOTAL KAON+ PRODUCTION CROSS SECTION IS THEN
8115222 SIGK=XSK1+XSK2+XSK3+XSK4
8116
8117cbz3/7/99 neutralk
8118 XSK1 = 2.0 * XSK1
8119 XSK2 = 2.0 * XSK2
8120 XSK3 = 2.0 * XSK3
8121 XSK4 = 2.0 * XSK4
8122 SIGK = 2.0 * SIGK + xsk5
8123cbz3/7/99 neutralk end
8124
8125* The reabsorption cross section for the process
8126* D(N*)D(N*)-->NN is
8127 s2d=reab2d(i1,i2,srt)
8128
8129cbz3/16/99 pion
8130 S2D = 0.
8131cbz3/16/99 pion end
8132
8133*(1) N*(1535)+D(N*(1440)) reactions
8134* we allow kaon production and reabsorption only
8135 if(((iabs(lb(i1)).ge.12).and.(iabs(lb(i2)).ge.12)).OR.
8136 & ((iabs(lb(i1)).ge.12).and.(iabs(lb(i2)).ge.6)).OR.
8137 & ((iabs(lb(i2)).ge.12).and.(iabs(lb(i1)).ge.6)))THEN
8138 signd=sigk+s2d
8139clin-6/2008
8140 IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
8141c if(x1.gt.(signd+signn)/sig)return
8142 if(x1.gt.(signd+signn+sdprod)/sig)return
8143c
8144* if kaon production
8145clin-6/2008
8146c IF(SIGK/SIG.GE.RANART(NSEED))GO TO 306
8147 IF((SIGK+sdprod)/SIG.GE.RANART(NSEED))GO TO 306
8148c
8149* if reabsorption
8150 go to 1012
8151 ENDIF
8152 IDD=iabs(LB(I1)*LB(I2))
8153* channels have the same charge as pp
8154 IF((IDD.EQ.63).OR.(IDD.EQ.64).OR.(IDD.EQ.48).
8155 1 OR.(IDD.EQ.49).OR.(IDD.EQ.11*11).OR.(IDD.EQ.10*10).
8156 2 OR.(IDD.EQ.88).OR.(IDD.EQ.66).
8157 3 OR.(IDD.EQ.90).OR.(IDD.EQ.70))THEN
8158 SIGND=X1535+SIGK+s2d
8159clin-6/2008
8160 IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
8161c IF (X1.GT.(SIGNN+SIGND)/SIG)RETURN
8162 IF (X1.GT.(SIGNN+SIGND+sdprod)/SIG)RETURN
8163c
8164* if kaon production
8165 IF(SIGK/SIGND.GT.RANART(NSEED))GO TO 306
8166* if reabsorption
8167 if(s2d/(x1535+s2d).gt.RANART(NSEED))go to 1012
8168* if N*(1535) production
8169 IF(IDD.EQ.63)N12=17
8170 IF(IDD.EQ.64)N12=20
8171 IF(IDD.EQ.48)N12=23
8172 IF(IDD.EQ.49)N12=24
8173 IF(IDD.EQ.121)N12=25
8174 IF(IDD.EQ.100)N12=26
8175 IF(IDD.EQ.88)N12=29
8176 IF(IDD.EQ.66)N12=31
8177 IF(IDD.EQ.90)N12=32
8178 IF(IDD.EQ.70)N12=35
8179 GO TO 1011
8180 ENDIF
8181* IN DELTA+N*(1440) and N*(1440)+N*(1440) COLLISIONS,
8182* N*(1535), kaon production and reabsorption are ALLOWED
8183* IN N*(1440)+N*(1440) COLLISIONS, ONLY N*(1535) IS ALLOWED
8184 IF((IDD.EQ.110).OR.(IDD.EQ.77).OR.(IDD.EQ.80))THEN
8185clin-6/2008
8186 IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
8187c IF(X1.GT.(SIGNN+X1535+SIGK+s2d)/SIG)RETURN
8188 IF(X1.GT.(SIGNN+X1535+SIGK+s2d+sdprod)/SIG)RETURN
8189c
8190 IF(SIGK/(X1535+SIGK+s2d).GT.RANART(NSEED))GO TO 306
8191 if(s2d/(x1535+s2d).gt.RANART(NSEED))go to 1012
8192 IF(IDD.EQ.77)N12=30
8193 IF((IDD.EQ.77).AND.(RANART(NSEED).LE.0.5))N12=36
8194 IF(IDD.EQ.80)N12=34
8195 IF((IDD.EQ.80).AND.(RANART(NSEED).LE.0.5))N12=35
8196 IF(IDD.EQ.110)N12=27
8197 IF((IDD.EQ.110).AND.(RANART(NSEED).LE.0.5))N12=28
8198 GO TO 1011
8199 ENDIF
8200 IF((IDD.EQ.54).OR.(IDD.EQ.56))THEN
8201* LIKE FOR N+P COLLISION,
8202* IN DELTA+DELTA COLLISIONS BOTH N*(1440) AND N*(1535) CAN BE PRODUCED
8203 SIG2=(3./4.)*SIGMA(SRT,2,0,1)
8204 SIGND=2.*(SIG2+X1535)+SIGK+s2d
8205clin-6/2008
8206 IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
8207c IF(X1.GT.(SIGNN+SIGND)/SIG)RETURN
8208 IF(X1.GT.(SIGNN+SIGND+sdprod)/SIG)RETURN
8209c
8210 IF(SIGK/SIGND.GT.RANART(NSEED))GO TO 306
8211 if(s2d/(2.*(sig2+x1535)+s2d).gt.RANART(NSEED))go to 1012
8212 IF(RANART(NSEED).LT.X1535/(SIG2+X1535))THEN
8213* N*(1535) PRODUCTION
8214 IF(IDD.EQ.54)N12=18
8215 IF((IDD.EQ.54).AND.(RANART(NSEED).LE.0.5))N12=19
8216 IF(IDD.EQ.56)N12=21
8217 IF((IDD.EQ.56).AND.(RANART(NSEED).LE.0.5))N12=22
8218 ELSE
8219* N*(144) PRODUCTION
8220 IF(IDD.EQ.54)N12=13
8221 IF((IDD.EQ.54).AND.(RANART(NSEED).LE.0.5))N12=14
8222 IF(IDD.EQ.56)N12=15
8223 IF((IDD.EQ.56).AND.(RANART(NSEED).LE.0.5))N12=16
8224 ENDIF
8225 ENDIF
82261011 CONTINUE
8227 iblock=5
8228*PARAMETRIZATION OF THE SHAPE OF THE N*(1440) AND N*(1535)
8229* RESONANCE ACCORDING
8230* TO kitazoe's or J.D.JACKSON'S MASS FORMULA AND BREIT WIGNER
8231* FORMULA FOR N* RESORANCE
8232* DETERMINE DELTA MASS VIA REJECTION METHOD.
8233 DMAX = SRT - AVMASS-0.005
8234 DMIN = 1.078
8235 IF((n12.ge.13).and.(n12.le.16))then
8236* N*(1440) production
8237 IF(DMAX.LT.1.44) THEN
8238 FM=FNS(DMAX,SRT,0.)
8239 ELSE
8240
8241clin-10/25/02 get rid of argument usage mismatch in FNS():
8242 xdmass=1.44
8243c FM=FNS(1.44,SRT,1.)
8244 FM=FNS(xdmass,SRT,1.)
8245clin-10/25/02-end
8246
8247 ENDIF
8248 IF(FM.EQ.0.)FM=1.E-09
8249 NTRY2=0
825011 DM=RANART(NSEED)*(DMAX-DMIN)+DMIN
8251 NTRY2=NTRY2+1
8252 IF((RANART(NSEED).GT.FNS(DM,SRT,1.)/FM).AND.
8253 1 (NTRY2.LE.10)) GO TO 11
8254
8255clin-2/26/03 limit the N* mass below a certain value
8256c (here taken as its central value + 2* B-W fullwidth):
8257 if(dm.gt.2.14) goto 11
8258
8259 GO TO 13
8260 ENDIF
8261 IF((n12.ge.17).AND.(N12.LE.36))then
8262* N*(1535) production
8263 IF(DMAX.LT.1.535) THEN
8264 FM=FD5(DMAX,SRT,0.)
8265 ELSE
8266
8267clin-10/25/02 get rid of argument usage mismatch in FNS():
8268 xdmass=1.535
8269c FM=FD5(1.535,SRT,1.)
8270 FM=FD5(xdmass,SRT,1.)
8271clin-10/25/02-end
8272
8273 ENDIF
8274 IF(FM.EQ.0.)FM=1.E-09
8275 NTRY1=0
827612 DM = RANART(NSEED) * (DMAX-DMIN) + DMIN
8277 NTRY1=NTRY1+1
8278 IF((RANART(NSEED) .GT. FD5(DM,SRT,1.)/FM).AND.
8279 1 (NTRY1.LE.10)) GOTO 12
8280
8281clin-2/26/03 limit the N* mass below a certain value
8282c (here taken as its central value + 2* B-W fullwidth):
8283 if(dm.gt.1.84) goto 12
8284
8285 ENDIF
828613 CONTINUE
8287*-------------------------------------------------------
8288* RELABLE BARYON I1 AND I2
8289*13 D(++)+D(-)--> N*(+)(14)+n
8290 IF(N12.EQ.13)THEN
8291 IF(RANART(NSEED).LE.0.5)THEN
8292 LB(I2)=11
8293 E(I2)=DM
8294 LB(I1)=2
8295 E(I1)=AMN
8296 ELSE
8297 LB(I1)=11
8298 E(I1)=DM
8299 LB(I2)=2
8300 E(I2)=AMN
8301 ENDIF
8302 go to 200
8303 ENDIF
8304*14 D(++)+D(-)--> N*(0)(14)+P
8305 IF(N12.EQ.14)THEN
8306 IF(RANART(NSEED).LE.0.5)THEN
8307 LB(I2)=10
8308 E(I2)=DM
8309 LB(I1)=1
8310 E(I1)=AMP
8311 ELSE
8312 LB(I1)=10
8313 E(I1)=DM
8314 LB(I2)=1
8315 E(I2)=AMP
8316 ENDIF
8317 go to 200
8318 ENDIF
8319*15 D(+)+D(0)--> N*(+)(14)+n
8320 IF(N12.EQ.15)THEN
8321 IF(RANART(NSEED).LE.0.5)THEN
8322 LB(I2)=11
8323 E(I2)=DM
8324 LB(I1)=2
8325 E(I1)=AMN
8326 ELSE
8327 LB(I1)=11
8328 E(I1)=DM
8329 LB(I2)=2
8330 E(I2)=AMN
8331 ENDIF
8332 go to 200
8333 ENDIF
8334*16 D(+)+D(0)--> N*(0)(14)+P
8335 IF(N12.EQ.16)THEN
8336 IF(RANART(NSEED).LE.0.5)THEN
8337 LB(I2)=10
8338 E(I2)=DM
8339 LB(I1)=1
8340 E(I1)=AMP
8341 ELSE
8342 LB(I1)=10
8343 E(I1)=DM
8344 LB(I2)=1
8345 E(I2)=AMP
8346 ENDIF
8347 go to 200
8348 ENDIF
8349*17 D(++)+D(0)--> N*(+)(14)+P
8350 IF(N12.EQ.17)THEN
8351 LB(I2)=13
8352 E(I2)=DM
8353 LB(I1)=1
8354 E(I1)=AMP
8355 go to 200
8356 ENDIF
8357*18 D(++)+D(-)--> N*(0)(15)+P
8358 IF(N12.EQ.18)THEN
8359 IF(RANART(NSEED).LE.0.5)THEN
8360 LB(I2)=12
8361 E(I2)=DM
8362 LB(I1)=1
8363 E(I1)=AMP
8364 ELSE
8365 LB(I1)=12
8366 E(I1)=DM
8367 LB(I2)=1
8368 E(I2)=AMP
8369 ENDIF
8370 go to 200
8371 ENDIF
8372*19 D(++)+D(-)--> N*(+)(15)+N
8373 IF(N12.EQ.19)THEN
8374 IF(RANART(NSEED).LE.0.5)THEN
8375 LB(I2)=13
8376 E(I2)=DM
8377 LB(I1)=2
8378 E(I1)=AMN
8379 ELSE
8380 LB(I1)=13
8381 E(I1)=DM
8382 LB(I2)=2
8383 E(I2)=AMN
8384 ENDIF
8385 go to 200
8386 ENDIF
8387*20 D(+)+D(+)--> N*(+)(15)+P
8388 IF(N12.EQ.20)THEN
8389 IF(RANART(NSEED).LE.0.5)THEN
8390 LB(I2)=13
8391 E(I2)=DM
8392 LB(I1)=1
8393 E(I1)=AMP
8394 ELSE
8395 LB(I1)=13
8396 E(I1)=DM
8397 LB(I2)=1
8398 E(I2)=AMP
8399 ENDIF
8400 go to 200
8401 ENDIF
8402*21 D(+)+D(0)--> N*(+)(15)+N
8403 IF(N12.EQ.21)THEN
8404 IF(RANART(NSEED).LE.0.5)THEN
8405 LB(I2)=13
8406 E(I2)=DM
8407 LB(I1)=2
8408 E(I1)=AMN
8409 ELSE
8410 LB(I1)=13
8411 E(I1)=DM
8412 LB(I2)=2
8413 E(I2)=AMN
8414 ENDIF
8415 go to 200
8416 ENDIF
8417*22 D(+)+D(0)--> N*(0)(15)+P
8418 IF(N12.EQ.22)THEN
8419 IF(RANART(NSEED).LE.0.5)THEN
8420 LB(I2)=12
8421 E(I2)=DM
8422 LB(I1)=1
8423 E(I1)=AMP
8424 ELSE
8425 LB(I1)=12
8426 E(I1)=DM
8427 LB(I2)=1
8428 E(I2)=AMP
8429 ENDIF
8430 go to 200
8431 ENDIF
8432*23 D(+)+D(-)--> N*(0)(15)+N
8433 IF(N12.EQ.23)THEN
8434 IF(RANART(NSEED).LE.0.5)THEN
8435 LB(I2)=12
8436 E(I2)=DM
8437 LB(I1)=2
8438 E(I1)=AMN
8439 ELSE
8440 LB(I1)=12
8441 E(I1)=DM
8442 LB(I2)=2
8443 E(I2)=AMN
8444 ENDIF
8445 go to 200
8446 ENDIF
8447*24 D(0)+D(0)--> N*(0)(15)+N
8448 IF(N12.EQ.24)THEN
8449 LB(I2)=12
8450 E(I2)=DM
8451 LB(I1)=2
8452 E(I1)=AMN
8453 go to 200
8454 ENDIF
8455*25 N*(+)+N*(+)--> N*(0)(15)+P
8456 IF(N12.EQ.25)THEN
8457 LB(I2)=12
8458 E(I2)=DM
8459 LB(I1)=1
8460 E(I1)=AMP
8461 go to 200
8462 ENDIF
8463*26 N*(0)+N*(0)--> N*(0)(15)+N
8464 IF(N12.EQ.26)THEN
8465 LB(I2)=12
8466 E(I2)=DM
8467 LB(I1)=2
8468 E(I1)=AMN
8469 go to 200
8470 ENDIF
8471*27 N*(+)+N*(0)--> N*(+)(15)+N
8472 IF(N12.EQ.27)THEN
8473 IF(RANART(NSEED).LE.0.5)THEN
8474 LB(I2)=13
8475 E(I2)=DM
8476 LB(I1)=2
8477 E(I1)=AMN
8478 ELSE
8479 LB(I1)=13
8480 E(I1)=DM
8481 LB(I2)=2
8482 E(I2)=AMN
8483 ENDIF
8484 go to 200
8485 ENDIF
8486*28 N*(+)+N*(0)--> N*(0)(15)+P
8487 IF(N12.EQ.28)THEN
8488 IF(RANART(NSEED).LE.0.5)THEN
8489 LB(I2)=12
8490 E(I2)=DM
8491 LB(I1)=1
8492 E(I1)=AMP
8493 ELSE
8494 LB(I1)=12
8495 E(I1)=DM
8496 LB(I2)=1
8497 E(I2)=AMP
8498 ENDIF
8499 go to 200
8500 ENDIF
8501*27 N*(+)+N*(0)--> N*(+)(15)+N
8502 IF(N12.EQ.27)THEN
8503 IF(RANART(NSEED).LE.0.5)THEN
8504 LB(I2)=13
8505 E(I2)=DM
8506 LB(I1)=2
8507 E(I1)=AMN
8508 ELSE
8509 LB(I1)=13
8510 E(I1)=DM
8511 LB(I2)=2
8512 E(I2)=AMN
8513 ENDIF
8514 go to 200
8515 ENDIF
8516*29 N*(+)+D(+)--> N*(+)(15)+P
8517 IF(N12.EQ.29)THEN
8518 IF(RANART(NSEED).LE.0.5)THEN
8519 LB(I2)=13
8520 E(I2)=DM
8521 LB(I1)=1
8522 E(I1)=AMP
8523 ELSE
8524 LB(I1)=13
8525 E(I1)=DM
8526 LB(I2)=1
8527 E(I2)=AMP
8528 ENDIF
8529 go to 200
8530 ENDIF
8531*30 N*(+)+D(0)--> N*(+)(15)+N
8532 IF(N12.EQ.30)THEN
8533 IF(RANART(NSEED).LE.0.5)THEN
8534 LB(I2)=13
8535 E(I2)=DM
8536 LB(I1)=2
8537 E(I1)=AMN
8538 ELSE
8539 LB(I1)=13
8540 E(I1)=DM
8541 LB(I2)=2
8542 E(I2)=AMN
8543 ENDIF
8544 go to 200
8545 ENDIF
8546*31 N*(+)+D(-)--> N*(0)(15)+N
8547 IF(N12.EQ.31)THEN
8548 IF(RANART(NSEED).LE.0.5)THEN
8549 LB(I2)=12
8550 E(I2)=DM
8551 LB(I1)=2
8552 E(I1)=AMN
8553 ELSE
8554 LB(I1)=12
8555 E(I1)=DM
8556 LB(I2)=2
8557 E(I2)=AMN
8558 ENDIF
8559 go to 200
8560 ENDIF
8561*32 N*(0)+D(++)--> N*(+)(15)+P
8562 IF(N12.EQ.32)THEN
8563 IF(RANART(NSEED).LE.0.5)THEN
8564 LB(I2)=13
8565 E(I2)=DM
8566 LB(I1)=1
8567 E(I1)=AMP
8568 ELSE
8569 LB(I1)=13
8570 E(I1)=DM
8571 LB(I2)=1
8572 E(I2)=AMP
8573 ENDIF
8574 go to 200
8575 ENDIF
8576*33 N*(0)+D(+)--> N*(+)(15)+N
8577 IF(N12.EQ.33)THEN
8578 IF(RANART(NSEED).LE.0.5)THEN
8579 LB(I2)=13
8580 E(I2)=DM
8581 LB(I1)=2
8582 E(I1)=AMN
8583 ELSE
8584 LB(I1)=13
8585 E(I1)=DM
8586 LB(I2)=2
8587 E(I2)=AMN
8588 ENDIF
8589 go to 200
8590 ENDIF
8591*34 N*(0)+D(+)--> N*(0)(15)+P
8592 IF(N12.EQ.34)THEN
8593 IF(RANART(NSEED).LE.0.5)THEN
8594 LB(I2)=12
8595 E(I2)=DM
8596 LB(I1)=1
8597 E(I1)=AMP
8598 ELSE
8599 LB(I1)=12
8600 E(I1)=DM
8601 LB(I2)=1
8602 E(I2)=AMP
8603 ENDIF
8604 go to 200
8605 ENDIF
8606*35 N*(0)+D(0)--> N*(0)(15)+N
8607 IF(N12.EQ.35)THEN
8608 IF(RANART(NSEED).LE.0.5)THEN
8609 LB(I2)=12
8610 E(I2)=DM
8611 LB(I1)=2
8612 E(I1)=AMN
8613 ELSE
8614 LB(I1)=12
8615 E(I1)=DM
8616 LB(I2)=2
8617 E(I2)=AMN
8618 ENDIF
8619 go to 200
8620 ENDIF
8621*36 N*(+)+D(0)--> N*(0)(15)+P
8622 IF(N12.EQ.36)THEN
8623 IF(RANART(NSEED).LE.0.5)THEN
8624 LB(I2)=12
8625 E(I2)=DM
8626 LB(I1)=1
8627 E(I1)=AMP
8628 ELSE
8629 LB(I1)=12
8630 E(I1)=DM
8631 LB(I2)=1
8632 E(I2)=AMP
8633 ENDIF
8634 go to 200
8635 ENDIF
86361012 continue
8637 iblock=55
8638 lb1=lb(i1)
8639 lb2=lb(i2)
8640 ich=iabs(lb1*lb2)
8641*-------------------------------------------------------
8642* RELABLE BARYON I1 AND I2 in the reabsorption processes
8643*37 D(++)+D(-)--> n+p
8644 IF(ich.EQ.9*6)THEN
8645 IF(RANART(NSEED).LE.0.5)THEN
8646 LB(I2)=1
8647 E(I2)=amp
8648 LB(I1)=2
8649 E(I1)=AMN
8650 ELSE
8651 LB(I1)=1
8652 E(I1)=amp
8653 LB(I2)=2
8654 E(I2)=AMN
8655 ENDIF
8656 go to 200
8657 ENDIF
8658*38 D(+)+D(0)--> n+p
8659 IF(ich.EQ.8*7)THEN
8660 IF(RANART(NSEED).LE.0.5)THEN
8661 LB(I2)=1
8662 E(I2)=amp
8663 LB(I1)=2
8664 E(I1)=AMN
8665 ELSE
8666 LB(I1)=1
8667 E(I1)=amp
8668 LB(I2)=2
8669 E(I2)=AMN
8670 ENDIF
8671 go to 200
8672 ENDIF
8673*39 D(++)+D(0)--> p+p
8674 IF(ich.EQ.9*7)THEN
8675 LB(I2)=1
8676 E(I2)=amp
8677 LB(I1)=1
8678 E(I1)=AMP
8679 go to 200
8680 ENDIF
8681*40 D(+)+D(+)--> p+p
8682 IF(ich.EQ.8*8)THEN
8683 LB(I2)=1
8684 E(I2)=amp
8685 LB(I1)=1
8686 E(I1)=AMP
8687 go to 200
8688 ENDIF
8689*41 D(+)+D(-)--> n+n
8690 IF(ich.EQ.8*6)THEN
8691 LB(I2)=2
8692 E(I2)=amn
8693 LB(I1)=2
8694 E(I1)=AMN
8695 go to 200
8696 ENDIF
8697*42 D(0)+D(0)--> n+n
8698 IF(ich.EQ.6*6)THEN
8699 LB(I2)=2
8700 E(I2)=amn
8701 LB(I1)=2
8702 E(I1)=AMN
8703 go to 200
8704 ENDIF
8705*43 N*(+)+N*(+)--> p+p
8706 IF(ich.EQ.11*11.or.ich.eq.13*13.or.ich.eq.11*13)THEN
8707 LB(I2)=1
8708 E(I2)=amp
8709 LB(I1)=1
8710 E(I1)=AMP
8711 go to 200
8712 ENDIF
8713*44 N*(0)(1440)+N*(0)--> n+n
8714 IF(ich.EQ.10*10.or.ich.eq.12*12.or.ich.eq.10*12)THEN
8715 LB(I2)=2
8716 E(I2)=amn
8717 LB(I1)=2
8718 E(I1)=AMN
8719 go to 200
8720 ENDIF
8721*45 N*(+)+N*(0)--> n+p
8722 IF(ich.EQ.10*11.or.ich.eq.12*13.or.ich.
8723 & eq.10*13.or.ich.eq.11*12)THEN
8724 IF(RANART(NSEED).LE.0.5)THEN
8725 LB(I2)=1
8726 E(I2)=amp
8727 LB(I1)=2
8728 E(I1)=AMN
8729 ELSE
8730 LB(I1)=1
8731 E(I1)=amp
8732 LB(I2)=2
8733 E(I2)=AMN
8734 ENDIF
8735 go to 200
8736 ENDIF
8737*46 N*(+)+D(+)--> p+p
8738 IF(ich.eq.11*8.or.ich.eq.13*8)THEN
8739 LB(I2)=1
8740 E(I2)=amp
8741 LB(I1)=1
8742 E(I1)=AMP
8743 go to 200
8744 ENDIF
8745*47 N*(+)+D(0)--> n+p
8746 IF(ich.EQ.11*7.or.ich.eq.13*7)THEN
8747 IF(RANART(NSEED).LE.0.5)THEN
8748 LB(I2)=1
8749 E(I2)=amp
8750 LB(I1)=2
8751 E(I1)=AMN
8752 ELSE
8753 LB(I1)=1
8754 E(I1)=amp
8755 LB(I2)=2
8756 E(I2)=AMN
8757 ENDIF
8758 go to 200
8759 ENDIF
8760*48 N*(+)+D(-)--> n+n
8761 IF(ich.EQ.11*6.or.ich.eq.13*6)THEN
8762 LB(I2)=2
8763 E(I2)=amn
8764 LB(I1)=2
8765 E(I1)=AMN
8766 go to 200
8767 ENDIF
8768*49 N*(0)+D(++)--> p+p
8769 IF(ich.EQ.10*9.or.ich.eq.12*9)THEN
8770 LB(I2)=1
8771 E(I2)=amp
8772 LB(I1)=1
8773 E(I1)=AMP
8774 go to 200
8775 ENDIF
8776*50 N*(0)+D(0)--> n+n
8777 IF(ich.EQ.10*7.or.ich.eq.12*7)THEN
8778 LB(I2)=2
8779 E(I2)=amn
8780 LB(I1)=2
8781 E(I1)=AMN
8782 go to 200
8783 ENDIF
8784*51 N*(0)+D(+)--> n+p
8785 IF(ich.EQ.10*8.or.ich.eq.12*8)THEN
8786 IF(RANART(NSEED).LE.0.5)THEN
8787 LB(I2)=2
8788 E(I2)=amn
8789 LB(I1)=1
8790 E(I1)=AMP
8791 ELSE
8792 LB(I1)=2
8793 E(I1)=amn
8794 LB(I2)=1
8795 E(I2)=AMP
8796 ENDIF
8797 go to 200
8798 ENDIF
8799 lb(i1)=1
8800 e(i1)=amp
8801 lb(i2)=2
8802 e(i2)=amn
8803* CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
8804* ENERGY CONSERVATION
8805* resonance production or absorption in resonance+resonance collisions is
8806* assumed to have the same pt distribution as pp
8807200 EM1=E(I1)
8808 EM2=E(I2)
8809 PR2 = (SRT**2 - EM1**2 - EM2**2)**2
8810 1 - 4.0 * (EM1*EM2)**2
8811 IF(PR2.LE.0.)PR2=1.e-09
8812 PR=SQRT(PR2)/(2.*SRT)
8813 if(srt.le.2.14)C1= 1.0 - 2.0 * RANART(NSEED)
86c53b9e 8814 if(srt.gt.2.14.and.srt.le.2.4)c1=anga(srt,iseed)
0119ef9a 8815 if(srt.gt.2.4)then
8816
8817clin-10/25/02 get rid of argument usage mismatch in PTR():
8818 xptr=0.33*pr
8819c cc1=ptr(0.33*pr,iseed)
8820 cc1=ptr(xptr,iseed)
8821clin-10/25/02-end
8822
8823 c1=sqrt(pr**2-cc1**2)/pr
8824 endif
8825 T1 = 2.0 * PI * RANART(NSEED)
8826 if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
8827 lb(i1) = -lb(i1)
8828 lb(i2) = -lb(i2)
8829 endif
8830 ENDIF
8831*COM: SET THE NEW MOMENTUM COORDINATES
8832107 S1 = SQRT( 1.0 - C1**2 )
8833 S2 = SQRT( 1.0 - C2**2 )
8834 CT1 = COS(T1)
8835 ST1 = SIN(T1)
8836 CT2 = COS(T2)
8837 ST2 = SIN(T2)
8838 PZ = PR * ( C1*C2 - S1*S2*CT1 )
8839 SS = C2 * S1 * CT1 + S2 * C1
8840 PX = PR * ( SS*CT2 - S1*ST1*ST2 )
8841 PY = PR * ( SS*ST2 + S1*ST1*CT2 )
8842 RETURN
8843* FOR THE DD-->KAON+X PROCESS, FIND MOMENTUM OF THE FINAL PARTICLES IN
8844* THE NUCLEUS-NUCLEUS CMS.
8845306 CONTINUE
8846csp11/21/01 phi production
8847 if(XSK5/sigK.gt.RANART(NSEED))then
8848 pz1=p(3,i1)
8849 pz2=p(3,i2)
8850 LB(I1) = 1 + int(2 * RANART(NSEED))
8851 LB(I2) = 1 + int(2 * RANART(NSEED))
8852 nnn=nnn+1
8853 LPION(NNN,IRUN)=29
8854 EPION(NNN,IRUN)=APHI
8855 iblock = 222
8856 GO TO 208
8857 ENDIF
8858 iblock=10
8859 if(ianti .eq. 1)iblock=-10
8860 pz1=p(3,i1)
8861 pz2=p(3,i2)
8862* DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
8863 nnn=nnn+1
8864 LPION(NNN,IRUN)=23
8865 EPION(NNN,IRUN)=Aka
8866 if(srt.le.2.63)then
8867* only lambda production is possible
8868* (1.1)P+P-->p+L+kaon+
8869 ic=1
8870 LB(I1) = 1 + int(2 * RANART(NSEED))
8871 LB(I2)=14
8872 GO TO 208
8873 ENDIF
8874 if(srt.le.2.74.and.srt.gt.2.63)then
8875* both Lambda and sigma production are possible
8876 if(XSK1/(XSK1+XSK2).gt.RANART(NSEED))then
8877* lambda production
8878 ic=1
8879 LB(I1) = 1 + int(2 * RANART(NSEED))
8880 LB(I2)=14
8881 else
8882* sigma production
8883 LB(I1) = 1 + int(2 * RANART(NSEED))
8884 LB(I2) = 15 + int(3 * RANART(NSEED))
8885 ic=2
8886 endif
8887 GO TO 208
8888 endif
8889 if(srt.le.2.77.and.srt.gt.2.74)then
8890* then pp-->Delta lamda kaon can happen
8891 if(xsk1/(xsk1+xsk2+xsk3).gt.RANART(NSEED))then
8892* * (1.1)P+P-->p+L+kaon+
8893 ic=1
8894 LB(I1) = 1 + int(2 * RANART(NSEED))
8895 LB(I2)=14
8896 go to 208
8897 else
8898 if(xsk2/(xsk2+xsk3).gt.RANART(NSEED))then
8899* pp-->psk
8900 ic=2
8901 LB(I1) = 1 + int(2 * RANART(NSEED))
8902 LB(I2) = 15 + int(3 * RANART(NSEED))
8903 else
8904* pp-->D+l+k
8905 ic=3
8906 LB(I1) = 6 + int(4 * RANART(NSEED))
8907 lb(i2)=14
8908 endif
8909 GO TO 208
8910 endif
8911 endif
8912 if(srt.gt.2.77)then
8913* all four channels are possible
8914 if(xsk1/(xsk1+xsk2+xsk3+xsk4).gt.RANART(NSEED))then
8915* p lambda k production
8916 ic=1
8917 LB(I1) = 1 + int(2 * RANART(NSEED))
8918 LB(I2)=14
8919 go to 208
8920 else
8921 if(xsk3/(xsk2+xsk3+xsk4).gt.RANART(NSEED))then
8922* delta l K production
8923 ic=3
8924 LB(I1) = 6 + int(4 * RANART(NSEED))
8925 lb(i2)=14
8926 go to 208
8927 else
8928 if(xsk2/(xsk2+xsk4).gt.RANART(NSEED))then
8929* n sigma k production
8930 LB(I1) = 1 + int(2 * RANART(NSEED))
8931 LB(I2) = 15 + int(3 * RANART(NSEED))
8932 ic=2
8933 else
8934* D sigma K
8935 ic=4
8936 LB(I1) = 6 + int(4 * RANART(NSEED))
8937 LB(I2) = 15 + int(3 * RANART(NSEED))
8938 endif
8939 go to 208
8940 endif
8941 endif
8942 endif
8943208 continue
8944 if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
8945 lb(i1) = - lb(i1)
8946 lb(i2) = - lb(i2)
8947 if(LPION(NNN,IRUN) .eq. 23)LPION(NNN,IRUN)=21
8948 endif
8949 lbi1=lb(i1)
8950 lbi2=lb(i2)
8951* KEEP ALL COORDINATES OF PARTICLE 2 FOR POSSIBLE PHASE SPACE CHANGE
8952 NTRY1=0
8953129 CALL BBKAON(ic,SRT,PX3,PY3,PZ3,DM3,PX4,PY4,PZ4,DM4,
8954 & PPX,PPY,PPZ,icou1)
8955 NTRY1=NTRY1+1
8956 if((icou1.lt.0).AND.(NTRY1.LE.20))GO TO 129
8957c if(icou1.lt.0)return
8958* ROTATE THE MOMENTA OF PARTICLES IN THE CMS OF P1+P2
8959 CALL ROTATE(PX,PY,PZ,PX3,PY3,PZ3)
8960 CALL ROTATE(PX,PY,PZ,PX4,PY4,PZ4)
8961 CALL ROTATE(PX,PY,PZ,PPX,PPY,PPZ)
8962* FIND THE MOMENTUM OF PARTICLES IN THE FINAL STATE IN THE NUCLEUS-
8963* NUCLEUS CMS. FRAME
8964* (1) for the necleon/delta
8965* LORENTZ-TRANSFORMATION INTO LAB FRAME FOR DELTA1
8966 E1CM = SQRT (dm3**2 + PX3**2 + PY3**2 + PZ3**2)
8967 P1BETA = PX3*BETAX + PY3*BETAY + PZ3*BETAZ
8968 TRANSF = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) + E1CM )
8969 Pt1i1 = BETAX * TRANSF + PX3
8970 Pt2i1 = BETAY * TRANSF + PY3
8971 Pt3i1 = BETAZ * TRANSF + PZ3
8972 Eti1 = DM3
8973* (2) for the lambda/sigma
8974 E2CM = SQRT (dm4**2 + PX4**2 + PY4**2 + PZ4**2)
8975 P2BETA = PX4*BETAX+PY4*BETAY+PZ4*BETAZ
8976 TRANSF = GAMMA * (GAMMA*P2BETA / (GAMMA + 1.) + E2CM)
8977 Pt1I2 = BETAX * TRANSF + PX4
8978 Pt2I2 = BETAY * TRANSF + PY4
8979 Pt3I2 = BETAZ * TRANSF + PZ4
8980 EtI2 = DM4
8981* GET the kaon'S MOMENTUM AND COORDINATES IN NUCLEUS-NUCLEUS CMS. FRAME
8982 EPCM=SQRT(aka**2+PPX**2+PPY**2+PPZ**2)
8983 PPBETA=PPX*BETAX+PPY*BETAY+PPZ*BETAZ
8984 TRANSF=GAMMA*(GAMMA*PPBETA/(GAMMA+1.)+EPCM)
8985 PPION(1,NNN,IRUN)=BETAX*TRANSF+PPX
8986 PPION(2,NNN,IRUN)=BETAY*TRANSF+PPY
8987 PPION(3,NNN,IRUN)=BETAZ*TRANSF+PPZ
8988clin-5/2008:
8989 dppion(nnn,irun)=dpertp(i1)*dpertp(i2)
8990clin-5/2008:
8991c2007 X01 = 1.0 - 2.0 * RANART(NSEED)
8992c Y01 = 1.0 - 2.0 * RANART(NSEED)
8993c Z01 = 1.0 - 2.0 * RANART(NSEED)
8994c IF ((X01*X01+Y01*Y01+Z01*Z01) .GT. 1.0) GOTO 2007
8995c RPION(1,NNN,IRUN)=R(1,I1)+0.5*x01
8996c RPION(2,NNN,IRUN)=R(2,I1)+0.5*y01
8997c RPION(3,NNN,IRUN)=R(3,I1)+0.5*z01
8998 RPION(1,NNN,IRUN)=R(1,I1)
8999 RPION(2,NNN,IRUN)=R(2,I1)
9000 RPION(3,NNN,IRUN)=R(3,I1)
9001c
9002* assign the nucleon/delta and lambda/sigma to i1 or i2 to keep the
9003* leadng particle behaviour
9004C if((pt1i1*px1+pt2i1*py1+pt3i1*pz1).gt.0)then
9005 p(1,i1)=pt1i1
9006 p(2,i1)=pt2i1
9007 p(3,i1)=pt3i1
9008 e(i1)=eti1
9009 lb(i1)=lbi1
9010 p(1,i2)=pt1i2
9011 p(2,i2)=pt2i2
9012 p(3,i2)=pt3i2
9013 e(i2)=eti2
9014 lb(i2)=lbi2
9015 PX1 = P(1,I1)
9016 PY1 = P(2,I1)
9017 PZ1 = P(3,I1)
9018 EM1 = E(I1)
9019 ID(I1) = 2
9020 ID(I2) = 2
9021 ID1 = ID(I1)
9022 LB1=LB(I1)
9023 LB2=LB(I2)
9024 AM1=EM1
9025 am2=em2
9026 E1= SQRT( EM1**2 + PX1**2 + PY1**2 + PZ1**2 )
9027 RETURN
9028
9029clin-6/2008 D+D->Deuteron+pi:
9030* FIND MOMENTUM OF THE FINAL PARTICLES IN THE NUCLEUS-NUCLEUS CMS.
9031 108 CONTINUE
9032 if(idpert.eq.1.and.ipert1.eq.1.and.npertd.ge.1) then
9033c For idpert=1: we produce npertd pert deuterons:
9034 ndloop=npertd
9035 elseif(idpert.eq.2.and.npertd.ge.1) then
9036c For idpert=2: we first save information for npertd pert deuterons;
9037c at the last ndloop we create the regular deuteron+pi
9038c and those pert deuterons:
9039 ndloop=npertd+1
9040 else
9041c Just create the regular deuteron+pi:
9042 ndloop=1
9043 endif
9044c
9045 dprob1=sdprod/sig/float(npertd)
9046 do idloop=1,ndloop
9047 CALL bbdangle(pxd,pyd,pzd,nt,ipert1,ianti,idloop,pfinal,
9048 1 dprob1,lbm)
9049 CALL ROTATE(PX,PY,PZ,PXd,PYd,PZd)
9050* LORENTZ-TRANSFORMATION OF THE MOMENTUM OF PARTICLES IN THE FINAL STATE
9051* FROM THE NN CMS FRAME INTO THE GLOBAL CMS FRAME:
9052* For the Deuteron:
9053 xmass=xmd
9054 E1dCM=SQRT(xmass**2+PXd**2+PYd**2+PZd**2)
9055 P1dBETA=PXd*BETAX+PYd*BETAY+PZd*BETAZ
9056 TRANSF=GAMMA*(GAMMA*P1dBETA/(GAMMA+1.)+E1dCM)
9057 pxi1=BETAX*TRANSF+PXd
9058 pyi1=BETAY*TRANSF+PYd
9059 pzi1=BETAZ*TRANSF+PZd
9060 if(ianti.eq.0)then
9061 lbd=42
9062 else
9063 lbd=-42
9064 endif
9065 if(idpert.eq.1.and.ipert1.eq.1.and.npertd.ge.1) then
9066cccc Perturbative production for idpert=1:
9067 nnn=nnn+1
9068 PPION(1,NNN,IRUN)=pxi1
9069 PPION(2,NNN,IRUN)=pyi1
9070 PPION(3,NNN,IRUN)=pzi1
9071 EPION(NNN,IRUN)=xmd
9072 LPION(NNN,IRUN)=lbd
9073 RPION(1,NNN,IRUN)=R(1,I1)
9074 RPION(2,NNN,IRUN)=R(2,I1)
9075 RPION(3,NNN,IRUN)=R(3,I1)
9076clin-6/2008 assign the perturbative probability:
9077 dppion(NNN,IRUN)=sdprod/sig/float(npertd)
9078 elseif(idpert.eq.2.and.idloop.le.npertd) then
9079clin-6/2008 For idpert=2, we produce NPERTD perturbative (anti)deuterons
9080c only when a regular (anti)deuteron+pi is produced in NN collisions.
9081c First save the info for the perturbative deuterons:
9082 ppd(1,idloop)=pxi1
9083 ppd(2,idloop)=pyi1
9084 ppd(3,idloop)=pzi1
9085 lbpd(idloop)=lbd
9086 else
9087cccc Regular production:
9088c For the regular pion: do LORENTZ-TRANSFORMATION:
9089 E(i1)=xmm
9090 E2piCM=SQRT(xmm**2+PXd**2+PYd**2+PZd**2)
9091 P2piBETA=-PXd*BETAX-PYd*BETAY-PZd*BETAZ
9092 TRANSF=GAMMA*(GAMMA*P2piBETA/(GAMMA+1.)+E2piCM)
9093 pxi2=BETAX*TRANSF-PXd
9094 pyi2=BETAY*TRANSF-PYd
9095 pzi2=BETAZ*TRANSF-PZd
9096 p(1,i1)=pxi2
9097 p(2,i1)=pyi2
9098 p(3,i1)=pzi2
9099c Remove regular pion to check the equivalence
9100c between the perturbative and regular deuteron results:
9101c E(i1)=0.
9102c
9103 LB(I1)=lbm
9104 PX1=P(1,I1)
9105 PY1=P(2,I1)
9106 PZ1=P(3,I1)
9107 EM1=E(I1)
9108 ID(I1)=2
9109 ID1=ID(I1)
9110 E1=SQRT(EM1**2+PX1**2+PY1**2+PZ1**2)
9111 lb1=lb(i1)
9112c For the regular deuteron:
9113 p(1,i2)=pxi1
9114 p(2,i2)=pyi1
9115 p(3,i2)=pzi1
9116 lb(i2)=lbd
9117 lb2=lb(i2)
9118 E(i2)=xmd
9119 EtI2=E(I2)
9120 ID(I2)=2
9121c For idpert=2: create the perturbative deuterons:
9122 if(idpert.eq.2.and.idloop.eq.ndloop) then
9123 do ipertd=1,npertd
9124 nnn=nnn+1
9125 PPION(1,NNN,IRUN)=ppd(1,ipertd)
9126 PPION(2,NNN,IRUN)=ppd(2,ipertd)
9127 PPION(3,NNN,IRUN)=ppd(3,ipertd)
9128 EPION(NNN,IRUN)=xmd
9129 LPION(NNN,IRUN)=lbpd(ipertd)
9130 RPION(1,NNN,IRUN)=R(1,I1)
9131 RPION(2,NNN,IRUN)=R(2,I1)
9132 RPION(3,NNN,IRUN)=R(3,I1)
9133clin-6/2008 assign the perturbative probability:
9134 dppion(NNN,IRUN)=1./float(npertd)
9135 enddo
9136 endif
9137 endif
9138 enddo
9139 IBLOCK=501
9140 return
9141clin-6/2008 D+D->Deuteron+pi over
9142
9143 END
9144**********************************
9145**********************************
9146* *
9147 SUBROUTINE INIT(MINNUM,MAXNUM,NUM,RADIUS,X0,Z0,P0,
9148 & GAMMA,ISEED,MASS,IOPT)
9149* *
9150* PURPOSE: PROVIDING INITIAL CONDITIONS FOR PHASE-SPACE *
9151* DISTRIBUTION OF TESTPARTICLES *
9152* VARIABLES: (ALL INPUT) *
9153* MINNUM - FIRST TESTPARTICLE TREATED IN ONE RUN (INTEGER) *
9154* MAXNUM - LAST TESTPARTICLE TREATED IN ONE RUN (INTEGER) *
9155* NUM - NUMBER OF TESTPARTICLES PER NUCLEON (INTEGER) *
9156* RADIUS - RADIUS OF NUCLEUS "FM" (REAL) *
9157* X0,Z0 - DISPLACEMENT OF CENTER OF NUCLEUS IN X,Z- *
9158* DIRECTION "FM" (REAL) *
9159* P0 - MOMENTUM-BOOST IN C.M. FRAME "GEV/C" (REAL) *
9160* GAMMA - RELATIVISTIC GAMMA-FACTOR (REAL) *
9161* ISEED - SEED FOR RANDOM-NUMBER GENERATOR (INTEGER) *
9162* MASS - TOTAL MASS OF THE SYSTEM (INTEGER) *
9163* IOPT - OPTION FOR DIFFERENT OCCUPATION OF MOMENTUM *
9164* SPACE (INTEGER) *
9165* *
9166**********************************
9167 PARAMETER (MAXSTR=150001, AMU = 0.9383)
9168 PARAMETER (MAXX = 20, MAXZ = 24)
9169 PARAMETER (PI=3.1415926)
9170*
9171 REAL PTOT(3)
9172 COMMON /AA/ R(3,MAXSTR)
9173cc SAVE /AA/
9174 COMMON /BB/ P(3,MAXSTR)
9175cc SAVE /BB/
9176 COMMON /CC/ E(MAXSTR)
9177cc SAVE /CC/
9178 COMMON /DD/ RHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
9179 & RHOP(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
9180 & RHON(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
9181cc SAVE /DD/
9182 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
9183cc SAVE /EE/
9184 common /ss/ inout(20)
9185cc SAVE /ss/
9186 COMMON/RNDF77/NSEED
9187cc SAVE /RNDF77/
9188 SAVE
9189*----------------------------------------------------------------------
9190* PREPARATION FOR LORENTZ-TRANSFORMATIONS
9191*
9192 ISEED=ISEED
9193 IF (P0 .NE. 0.) THEN
9194 SIGN = P0 / ABS(P0)
9195 ELSE
9196 SIGN = 0.
9197 END IF
9198 BETA = SIGN * SQRT(GAMMA**2-1.)/GAMMA
9199*-----------------------------------------------------------------------
9200* TARGET-ID = 1 AND PROJECTILE-ID = -1
9201*
9202 IF (MINNUM .EQ. 1) THEN
9203 IDNUM = 1
9204 ELSE
9205 IDNUM = -1
9206 END IF
9207*-----------------------------------------------------------------------
9208* IDENTIFICATION OF TESTPARTICLES AND ASSIGMENT OF RESTMASS
9209*
9210* LOOP OVER ALL PARALLEL RUNS:
9211 DO 400 IRUN = 1,NUM
9212 DO 100 I = MINNUM+(IRUN-1)*MASS,MAXNUM+(IRUN-1)*MASS
9213 ID(I) = IDNUM
9214 E(I) = AMU
9215 100 CONTINUE
9216*-----------------------------------------------------------------------
9217* OCCUPATION OF COORDINATE-SPACE
9218*
9219 DO 300 I = MINNUM+(IRUN-1)*MASS,MAXNUM+(IRUN-1)*MASS
9220 200 CONTINUE
9221 X = 1.0 - 2.0 * RANART(NSEED)
9222 Y = 1.0 - 2.0 * RANART(NSEED)
9223 Z = 1.0 - 2.0 * RANART(NSEED)
9224 IF ((X*X+Y*Y+Z*Z) .GT. 1.0) GOTO 200
9225 R(1,I) = X * RADIUS
9226 R(2,I) = Y * RADIUS
9227 R(3,I) = Z * RADIUS
9228 300 CONTINUE
9229 400 CONTINUE
9230*=======================================================================
9231 IF (IOPT .NE. 3) THEN
9232*-----
9233* OPTION 1: USE WOODS-SAXON PARAMETRIZATION FOR DENSITY AND
9234*----- CALCULATE LOCAL FERMI-MOMENTUM
9235*
9236 RHOW0 = 0.168
9237 DO 1000 IRUN = 1,NUM
9238 DO 600 I = MINNUM+(IRUN-1)*MASS,MAXNUM+(IRUN-1)*MASS
9239 500 CONTINUE
9240 PX = 1.0 - 2.0 * RANART(NSEED)
9241 PY = 1.0 - 2.0 * RANART(NSEED)
9242 PZ = 1.0 - 2.0 * RANART(NSEED)
9243 IF (PX*PX+PY*PY+PZ*PZ .GT. 1.0) GOTO 500
9244 RDIST = SQRT( R(1,I)**2 + R(2,I)**2 + R(3,I)**2 )
9245 RHOWS = RHOW0 / ( 1.0 + EXP( (RDIST-RADIUS) / 0.55 ) )
9246 PFERMI = 0.197 * (1.5 * PI*PI * RHOWS)**(1./3.)
9247*-----
9248* OPTION 2: NUCLEAR MATTER CASE
9249 IF(IOPT.EQ.2) PFERMI=0.27
9250 if(iopt.eq.4) pfermi=0.
9251*-----
9252 P(1,I) = PFERMI * PX
9253 P(2,I) = PFERMI * PY
9254 P(3,I) = PFERMI * PZ
9255 600 CONTINUE
9256*
9257* SET TOTAL MOMENTUM TO 0 IN REST FRAME AND BOOST
9258*
9259 DO 700 IDIR = 1,3
9260 PTOT(IDIR) = 0.0
9261 700 CONTINUE
9262 NPART = 0
9263 DO 900 I = MINNUM+(IRUN-1)*MASS,MAXNUM+(IRUN-1)*MASS
9264 NPART = NPART + 1
9265 DO 800 IDIR = 1,3
9266 PTOT(IDIR) = PTOT(IDIR) + P(IDIR,I)
9267 800 CONTINUE
9268 900 CONTINUE
9269 DO 950 I = MINNUM+(IRUN-1)*MASS,MAXNUM+(IRUN-1)*MASS
9270 DO 925 IDIR = 1,3
9271 P(IDIR,I) = P(IDIR,I) - PTOT(IDIR) / FLOAT(NPART)
9272 925 CONTINUE
9273* BOOST
9274 IF ((IOPT .EQ. 1).or.(iopt.eq.2)) THEN
9275 EPART = SQRT(P(1,I)**2+P(2,I)**2+P(3,I)**2+AMU**2)
9276 P(3,I) = GAMMA*(P(3,I) + BETA*EPART)
9277 ELSE
9278 P(3,I) = P(3,I) + P0
9279 END IF
9280 950 CONTINUE
9281 1000 CONTINUE
9282*-----
9283 ELSE
9284*-----
9285* OPTION 3: GIVE ALL NUCLEONS JUST A Z-MOMENTUM ACCORDING TO
9286* THE BOOST OF THE NUCLEI
9287*
9288 DO 1200 IRUN = 1,NUM
9289 DO 1100 I = MINNUM+(IRUN-1)*MASS,MAXNUM+(IRUN-1)*MASS
9290 P(1,I) = 0.0
9291 P(2,I) = 0.0
9292 P(3,I) = P0
9293 1100 CONTINUE
9294 1200 CONTINUE
9295*-----
9296 END IF
9297*=======================================================================
9298* PUT PARTICLES IN THEIR POSITION IN COORDINATE-SPACE
9299* (SHIFT AND RELATIVISTIC CONTRACTION)
9300*
9301 DO 1400 IRUN = 1,NUM
9302 DO 1300 I = MINNUM+(IRUN-1)*MASS,MAXNUM+(IRUN-1)*MASS
9303 R(1,I) = R(1,I) + X0
9304* two nuclei in touch after contraction
9305 R(3,I) = (R(3,I)+Z0)/ GAMMA
9306* two nuclei in touch before contraction
9307c R(3,I) = R(3,I) / GAMMA + Z0
9308 1300 CONTINUE
9309 1400 CONTINUE
9310*
9311 RETURN
9312 END
9313**********************************
9314* *
9315 SUBROUTINE DENS(IPOT,MASS,NUM,NESC)
9316* *
9317* PURPOSE: CALCULATION OF LOCAL BARYON, MESON AND ENERGY *
9318* DENSITY FROM SPATIAL DISTRIBUTION OF TESTPARTICLES*
9319* *
9320* VARIABLES (ALL INPUT, ALL INTEGER) *
9321* MASS - MASS NUMBER OF THE SYSTEM *
9322* NUM - NUMBER OF TESTPARTICLES PER NUCLEON *
9323* *
9324* NESC - NUMBER OF ESCAPED PARTICLES (INTEGER,OUTPUT) *
9325* *
9326**********************************
9327 PARAMETER (MAXSTR= 150001,MAXR=1)
9328 PARAMETER (MAXX = 20, MAXZ = 24)
9329*
9330 dimension pxl(-maxx:maxx,-maxx:maxx,-maxz:maxz),
9331 1 pyl(-maxx:maxx,-maxx:maxx,-maxz:maxz),
9332 2 pzl(-maxx:maxx,-maxx:maxx,-maxz:maxz)
9333 COMMON /AA/ R(3,MAXSTR)
9334cc SAVE /AA/
9335 COMMON /BB/ P(3,MAXSTR)
9336cc SAVE /BB/
9337 COMMON /CC/ E(MAXSTR)
9338cc SAVE /CC/
9339 COMMON /DD/ RHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
9340 & RHOP(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
9341 & RHON(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
9342cc SAVE /DD/
9343 COMMON /DDpi/ piRHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
9344cc SAVE /DDpi/
9345 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
9346cc SAVE /EE/
9347 common /ss/ inout(20)
9348cc SAVE /ss/
9349 COMMON /RR/ MASSR(0:MAXR)
9350cc SAVE /RR/
9351 common /tt/ PEL(-maxx:maxx,-maxx:maxx,-maxz:maxz)
9352 &,rxy(-maxx:maxx,-maxx:maxx,-maxz:maxz)
9353cc SAVE /tt/
9354 common /bbb/ bxx(-maxx:maxx,-maxx:maxx,-maxz:maxz),
9355 &byy(-maxx:maxx,-maxx:maxx,-maxz:maxz),
9356 &bzz(-maxx:maxx,-maxx:maxx,-maxz:maxz)
9357*
9358 real zet(-45:45)
9359 SAVE
9360 data zet /
9361 4 1.,0.,0.,0.,0.,
9362 3 1.,0.,0.,0.,0.,0.,0.,0.,0.,0.,
9363 2 -1.,0.,0.,0.,0.,0.,0.,0.,0.,0.,
9364 1 0.,0.,0.,-1.,0.,1.,0.,-1.,0.,-1.,
9365 s 0.,-2.,-1.,0.,1.,0.,0.,0.,0.,-1.,
9366 e 0.,
9367 s 1.,0.,-1.,0.,1.,-1.,0.,1.,2.,0.,
9368 1 1.,0.,1.,0.,-1.,0.,1.,0.,0.,0.,
9369 2 -1.,0.,1.,0.,-1.,0.,1.,0.,0.,1.,
9370 3 0.,0.,0.,0.,0.,0.,0.,0.,0.,-1.,
9371 4 0.,0.,0.,0.,-1./
9372
9373 DO 300 IZ = -MAXZ,MAXZ
9374 DO 200 IY = -MAXX,MAXX
9375 DO 100 IX = -MAXX,MAXX
9376 RHO(IX,IY,IZ) = 0.0
9377 RHOn(IX,IY,IZ) = 0.0
9378 RHOp(IX,IY,IZ) = 0.0
9379 piRHO(IX,IY,IZ) = 0.0
9380 pxl(ix,iy,iz) = 0.0
9381 pyl(ix,iy,iz) = 0.0
9382 pzl(ix,iy,iz) = 0.0
9383 pel(ix,iy,iz) = 0.0
9384 bxx(ix,iy,iz) = 0.0
9385 byy(ix,iy,iz) = 0.0
9386 bzz(ix,iy,iz) = 0.0
9387 100 CONTINUE
9388 200 CONTINUE
9389 300 CONTINUE
9390*
9391 NESC = 0
9392 BIG = 1.0 / ( 3.0 * FLOAT(NUM) )
9393 SMALL = 1.0 / ( 9.0 * FLOAT(NUM) )
9394*
9395 MSUM=0
9396 DO 400 IRUN = 1,NUM
9397 MSUM=MSUM+MASSR(IRUN-1)
9398 DO 400 J=1,MASSr(irun)
9399 I=J+MSUM
9400 IX = NINT( R(1,I) )
9401 IY = NINT( R(2,I) )
9402 IZ = NINT( R(3,I) )
9403 IF( IX .LE. -MAXX .OR. IX .GE. MAXX .OR.
9404 & IY .LE. -MAXX .OR. IY .GE. MAXX .OR.
9405 & IZ .LE. -MAXZ .OR. IZ .GE. MAXZ ) THEN
9406 NESC = NESC + 1
9407 ELSE
9408c
9409csp01/04/02 include baryon density
9410 if(j.gt.mass)go to 30
9411c if( (lb(i).eq.1.or.lb(i).eq.2) .or.
9412c & (lb(i).ge.6.and.lb(i).le.17) )then
9413* (1) baryon density
9414 RHO(IX, IY, IZ ) = RHO(IX, IY, IZ ) + BIG
9415 RHO(IX+1,IY, IZ ) = RHO(IX+1,IY, IZ ) + SMALL
9416 RHO(IX-1,IY, IZ ) = RHO(IX-1,IY, IZ ) + SMALL
9417 RHO(IX, IY+1,IZ ) = RHO(IX, IY+1,IZ ) + SMALL
9418 RHO(IX, IY-1,IZ ) = RHO(IX, IY-1,IZ ) + SMALL
9419 RHO(IX, IY, IZ+1) = RHO(IX, IY, IZ+1) + SMALL
9420 RHO(IX, IY, IZ-1) = RHO(IX, IY, IZ-1) + SMALL
9421* (2) CALCULATE THE PROTON DENSITY
9422 IF(ZET(LB(I)).NE.0)THEN
9423 RHOP(IX, IY, IZ ) = RHOP(IX, IY, IZ ) + BIG
9424 RHOP(IX+1,IY, IZ ) = RHOP(IX+1,IY, IZ ) + SMALL
9425 RHOP(IX-1,IY, IZ ) = RHOP(IX-1,IY, IZ ) + SMALL
9426 RHOP(IX, IY+1,IZ ) = RHOP(IX, IY+1,IZ ) + SMALL
9427 RHOP(IX, IY-1,IZ ) = RHOP(IX, IY-1,IZ ) + SMALL
9428 RHOP(IX, IY, IZ+1) = RHOP(IX, IY, IZ+1) + SMALL
9429 RHOP(IX, IY, IZ-1) = RHOP(IX, IY, IZ-1) + SMALL
9430 go to 40
9431 ENDIF
9432* (3) CALCULATE THE NEUTRON DENSITY
9433 IF(ZET(LB(I)).EQ.0)THEN
9434 RHON(IX, IY, IZ ) = RHON(IX, IY, IZ ) + BIG
9435 RHON(IX+1,IY, IZ ) = RHON(IX+1,IY, IZ ) + SMALL
9436 RHON(IX-1,IY, IZ ) = RHON(IX-1,IY, IZ ) + SMALL
9437 RHON(IX, IY+1,IZ ) = RHON(IX, IY+1,IZ ) + SMALL
9438 RHON(IX, IY-1,IZ ) = RHON(IX, IY-1,IZ ) + SMALL
9439 RHON(IX, IY, IZ+1) = RHON(IX, IY, IZ+1) + SMALL
9440 RHON(IX, IY, IZ-1) = RHON(IX, IY, IZ-1) + SMALL
9441 go to 40
9442 END IF
9443c else !! sp01/04/02
9444* (4) meson density
944530 piRHO(IX, IY, IZ ) = piRHO(IX, IY, IZ ) + BIG
9446 piRHO(IX+1,IY, IZ ) = piRHO(IX+1,IY, IZ ) + SMALL
9447 piRHO(IX-1,IY, IZ ) = piRHO(IX-1,IY, IZ ) + SMALL
9448 piRHO(IX, IY+1,IZ ) = piRHO(IX, IY+1,IZ ) + SMALL
9449 piRHO(IX, IY-1,IZ ) = piRHO(IX, IY-1,IZ ) + SMALL
9450 piRHO(IX, IY, IZ+1) = piRHO(IX, IY, IZ+1) + SMALL
9451 piRHO(IX, IY, IZ-1) = piRHO(IX, IY, IZ-1) + SMALL
9452c endif !! sp01/04/02
9453* to calculate the Gamma factor in each cell
9454*(1) PX
945540 pxl(ix,iy,iz)=pxl(ix,iy,iz)+p(1,I)*BIG
9456 pxl(ix+1,iy,iz)=pxl(ix+1,iy,iz)+p(1,I)*SMALL
9457 pxl(ix-1,iy,iz)=pxl(ix-1,iy,iz)+p(1,I)*SMALL
9458 pxl(ix,iy+1,iz)=pxl(ix,iy+1,iz)+p(1,I)*SMALL
9459 pxl(ix,iy-1,iz)=pxl(ix,iy-1,iz)+p(1,I)*SMALL
9460 pxl(ix,iy,iz+1)=pxl(ix,iy,iz+1)+p(1,I)*SMALL
9461 pxl(ix,iy,iz-1)=pxl(ix,iy,iz-1)+p(1,I)*SMALL
9462*(2) PY
9463 pYl(ix,iy,iz)=pYl(ix,iy,iz)+p(2,I)*BIG
9464 pYl(ix+1,iy,iz)=pYl(ix+1,iy,iz)+p(2,I)*SMALL
9465 pYl(ix-1,iy,iz)=pYl(ix-1,iy,iz)+p(2,I)*SMALL
9466 pYl(ix,iy+1,iz)=pYl(ix,iy+1,iz)+p(2,I)*SMALL
9467 pYl(ix,iy-1,iz)=pYl(ix,iy-1,iz)+p(2,I)*SMALL
9468 pYl(ix,iy,iz+1)=pYl(ix,iy,iz+1)+p(2,I)*SMALL
9469 pYl(ix,iy,iz-1)=pYl(ix,iy,iz-1)+p(2,I)*SMALL
9470* (3) PZ
9471 pZl(ix,iy,iz)=pZl(ix,iy,iz)+p(3,I)*BIG
9472 pZl(ix+1,iy,iz)=pZl(ix+1,iy,iz)+p(3,I)*SMALL
9473 pZl(ix-1,iy,iz)=pZl(ix-1,iy,iz)+p(3,I)*SMALL
9474 pZl(ix,iy+1,iz)=pZl(ix,iy+1,iz)+p(3,I)*SMALL
9475 pZl(ix,iy-1,iz)=pZl(ix,iy-1,iz)+p(3,I)*SMALL
9476 pZl(ix,iy,iz+1)=pZl(ix,iy,iz+1)+p(3,I)*SMALL
9477 pZl(ix,iy,iz-1)=pZl(ix,iy,iz-1)+p(3,I)*SMALL
9478* (4) ENERGY
9479 pel(ix,iy,iz)=pel(ix,iy,iz)
9480 1 +sqrt(e(I)**2+p(1,i)**2+p(2,I)**2+p(3,I)**2)*BIG
9481 pel(ix+1,iy,iz)=pel(ix+1,iy,iz)
9482 1 +sqrt(e(I)**2+p(1,i)**2+p(2,I)**2+p(3,I)**2)*SMALL
9483 pel(ix-1,iy,iz)=pel(ix-1,iy,iz)
9484 1 +sqrt(e(I)**2+p(1,i)**2+p(2,I)**2+p(3,I)**2)*SMALL
9485 pel(ix,iy+1,iz)=pel(ix,iy+1,iz)
9486 1 +sqrt(e(I)**2+p(1,i)**2+p(2,I)**2+p(3,I)**2)*SMALL
9487 pel(ix,iy-1,iz)=pel(ix,iy-1,iz)
9488 1 +sqrt(e(I)**2+p(1,i)**2+p(2,I)**2+p(3,I)**2)*SMALL
9489 pel(ix,iy,iz+1)=pel(ix,iy,iz+1)
9490 1 +sqrt(e(I)**2+p(1,i)**2+p(2,I)**2+p(3,I)**2)*SMALL
9491 pel(ix,iy,iz-1)=pel(ix,iy,iz-1)
9492 1 +sqrt(e(I)**2+p(1,i)**2+p(2,I)**2+p(3,I)**2)*SMALL
9493 END IF
9494 400 CONTINUE
9495*
9496 DO 301 IZ = -MAXZ,MAXZ
9497 DO 201 IY = -MAXX,MAXX
9498 DO 101 IX = -MAXX,MAXX
9499 IF((RHO(IX,IY,IZ).EQ.0).OR.(PEL(IX,IY,IZ).EQ.0))
9500 1GO TO 101
9501 SMASS2=PEL(IX,IY,IZ)**2-PXL(IX,IY,IZ)**2
9502 1-PYL(IX,IY,IZ)**2-PZL(IX,IY,IZ)**2
9503 IF(SMASS2.LE.0)SMASS2=1.E-06
9504 SMASS=SQRT(SMASS2)
9505 IF(SMASS.EQ.0.)SMASS=1.e-06
9506 GAMMA=PEL(IX,IY,IZ)/SMASS
9507 if(gamma.eq.0)go to 101
9508 bxx(ix,iy,iz)=pxl(ix,iy,iz)/pel(ix,iy,iz)
9509 byy(ix,iy,iz)=pyl(ix,iy,iz)/pel(ix,iy,iz)
9510 bzz(ix,iy,iz)=pzl(ix,iy,iz)/pel(ix,iy,iz)
9511 RHO(IX,IY,IZ) = RHO(IX,IY,IZ)/GAMMA
9512 RHOn(IX,IY,IZ) = RHOn(IX,IY,IZ)/GAMMA
9513 RHOp(IX,IY,IZ) = RHOp(IX,IY,IZ)/GAMMA
9514 piRHO(IX,IY,IZ) = piRHO(IX,IY,IZ)/GAMMA
9515 pEL(IX,IY,IZ) = pEL(IX,IY,IZ)/(GAMMA**2)
9516 rho0=0.163
9517 IF(IPOT.EQ.0)THEN
9518 U=0
9519 GO TO 70
9520 ENDIF
9521 IF(IPOT.EQ.1.or.ipot.eq.6)THEN
9522 A=-0.1236
9523 B=0.0704
9524 S=2
9525 GO TO 60
9526 ENDIF
9527 IF(IPOT.EQ.2.or.ipot.eq.7)THEN
9528 A=-0.218
9529 B=0.164
9530 S=4./3.
9531 ENDIF
9532 IF(IPOT.EQ.3)THEN
9533 a=-0.3581
9534 b=0.3048
9535 S=1.167
9536 GO TO 60
9537 ENDIF
9538 IF(IPOT.EQ.4)THEN
9539 denr=rho(ix,iy,iz)/rho0
9540 b=0.3048
9541 S=1.167
9542 if(denr.le.4.or.denr.gt.7)then
9543 a=-0.3581
9544 else
9545 a=-b*denr**(1./6.)-2.*0.036/3.*denr**(-0.333)
9546 endif
9547 GO TO 60
9548 ENDIF
954960 U = 0.5*A*RHO(IX,IY,IZ)**2/RHO0
9550 1 + B/(1+S) * (RHO(IX,IY,IZ)/RHO0)**S*RHO(IX,IY,IZ)
955170 PEL(IX,IY,IZ)=PEL(IX,IY,IZ)+U
9552 101 CONTINUE
9553 201 CONTINUE
9554 301 CONTINUE
9555 RETURN
9556 END
9557
9558**********************************
9559* *
9560 SUBROUTINE GRADU(IOPT,IX,IY,IZ,GRADX,GRADY,GRADZ)
9561* *
9562* PURPOSE: DETERMINE GRAD(U(RHO(X,Y,Z))) *
9563* VARIABLES: *
9564* IOPT - METHOD FOR EVALUATING THE GRADIENT *
9565* (INTEGER,INPUT) *
9566* IX, IY, IZ - COORDINATES OF POINT (INTEGER,INPUT) *
9567* GRADX, GRADY, GRADZ - GRADIENT OF U (REAL,OUTPUT) *
9568* *
9569**********************************
9570 PARAMETER (MAXX = 20, MAXZ = 24)
9571 PARAMETER (RHO0 = 0.167)
9572*
9573 COMMON /DD/ RHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
9574 & RHOP(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
9575 & RHON(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
9576cc SAVE /DD/
9577 common /ss/ inout(20)
9578cc SAVE /ss/
9579 common /tt/ PEL(-maxx:maxx,-maxx:maxx,-maxz:maxz)
9580 &,rxy(-maxx:maxx,-maxx:maxx,-maxz:maxz)
9581cc SAVE /tt/
9582 SAVE
9583*
9584 RXPLUS = RHO(IX+1,IY, IZ ) / RHO0
9585 RXMINS = RHO(IX-1,IY, IZ ) / RHO0
9586 RYPLUS = RHO(IX, IY+1,IZ ) / RHO0
9587 RYMINS = RHO(IX, IY-1,IZ ) / RHO0
9588 RZPLUS = RHO(IX, IY, IZ+1) / RHO0
9589 RZMINS = RHO(IX, IY, IZ-1) / RHO0
9590 den0 = RHO(IX, IY, IZ) / RHO0
9591 ene0 = pel(IX, IY, IZ)
9592*-----------------------------------------------------------------------
9593 GOTO (1,2,3,4,5) IOPT
9594 if(iopt.eq.6)go to 6
9595 if(iopt.eq.7)go to 7
9596*
9597 1 CONTINUE
9598* POTENTIAL USED IN 1) (STIFF):
9599* U = -.124 * RHO/RHO0 + .0705 (RHO/RHO0)**2 GEV
9600*
9601 GRADX = -0.062 * (RXPLUS - RXMINS) + 0.03525 * (RXPLUS**2 -
9602 & RXMINS**2)
9603 GRADY = -0.062 * (RYPLUS - RYMINS) + 0.03525 * (RYPLUS**2 -
9604 & RYMINS**2)
9605 GRADZ = -0.062 * (RZPLUS - RZMINS) + 0.03525 * (RZPLUS**2 -
9606 & RZMINS**2)
9607 RETURN
9608*
9609 2 CONTINUE
9610* POTENTIAL USED IN 2):
9611* U = -.218 * RHO/RHO0 + .164 (RHO/RHO0)**(4/3) GEV
9612*
9613 EXPNT = 1.3333333
9614 GRADX = -0.109 * (RXPLUS - RXMINS)
9615 & + 0.082 * (RXPLUS**EXPNT-RXMINS**EXPNT)
9616 GRADY = -0.109 * (RYPLUS - RYMINS)
9617 & + 0.082 * (RYPLUS**EXPNT-RYMINS**EXPNT)
9618 GRADZ = -0.109 * (RZPLUS - RZMINS)
9619 & + 0.082 * (RZPLUS**EXPNT-RZMINS**EXPNT)
9620 RETURN
9621*
9622 3 CONTINUE
9623* POTENTIAL USED IN 3) (SOFT):
9624* U = -.356 * RHO/RHO0 + .303 * (RHO/RHO0)**(7/6) GEV
9625*
9626 EXPNT = 1.1666667
9627 acoef = 0.178
9628 GRADX = -acoef * (RXPLUS - RXMINS)
9629 & + 0.1515 * (RXPLUS**EXPNT-RXMINS**EXPNT)
9630 GRADY = -acoef * (RYPLUS - RYMINS)
9631 & + 0.1515 * (RYPLUS**EXPNT-RYMINS**EXPNT)
9632 GRADZ = -acoef * (RZPLUS - RZMINS)
9633 & + 0.1515 * (RZPLUS**EXPNT-RZMINS**EXPNT)
9634 RETURN
9635*
9636*
9637 4 CONTINUE
9638* POTENTIAL USED IN 4) (super-soft in the mixed phase of 4 < rho/rho <7):
9639* U1 = -.356 * RHO/RHO0 + .303 * (RHO/RHO0)**(7/6) GEV
9640* normal phase, soft eos of iopt=3
9641* U2 = -.02 * (RHO/RHO0)**(2/3) -0.0253 * (RHO/RHO0)**(7/6) GEV
9642*
9643 eh=4.
9644 eqgp=7.
9645 acoef=0.178
9646 EXPNT = 1.1666667
9647 denr=rho(ix,iy,iz)/rho0
9648 if(denr.le.eh.or.denr.ge.eqgp)then
9649 GRADX = -acoef * (RXPLUS - RXMINS)
9650 & + 0.1515 * (RXPLUS**EXPNT-RXMINS**EXPNT)
9651 GRADY = -acoef * (RYPLUS - RYMINS)
9652 & + 0.1515 * (RYPLUS**EXPNT-RYMINS**EXPNT)
9653 GRADZ = -acoef * (RZPLUS - RZMINS)
9654 & + 0.1515 * (RZPLUS**EXPNT-RZMINS**EXPNT)
9655 else
9656 acoef1=0.178
9657 acoef2=0.0
9658 expnt2=2./3.
9659 GRADX =-acoef1* (RXPLUS**EXPNT-RXMINS**EXPNT)
9660 & -acoef2* (RXPLUS**expnt2 - RXMINS**expnt2)
9661 GRADy =-acoef1* (RyPLUS**EXPNT-RyMINS**EXPNT)
9662 & -acoef2* (RyPLUS**expnt2 - RyMINS**expnt2)
9663 GRADz =-acoef1* (RzPLUS**EXPNT-RzMINS**EXPNT)
9664 & -acoef2* (RzPLUS**expnt2 - RzMINS**expnt2)
9665 endif
9666 return
9667*
9668 5 CONTINUE
9669* POTENTIAL USED IN 5) (SUPER STIFF):
9670* U = -.10322 * RHO/RHO0 + .04956 * (RHO/RHO0)**(2.77) GEV
9671*
9672 EXPNT = 2.77
9673 GRADX = -0.0516 * (RXPLUS - RXMINS)
9674 & + 0.02498 * (RXPLUS**EXPNT-RXMINS**EXPNT)
9675 GRADY = -0.0516 * (RYPLUS - RYMINS)
9676 & + 0.02498 * (RYPLUS**EXPNT-RYMINS**EXPNT)
9677 GRADZ = -0.0516 * (RZPLUS - RZMINS)
9678 & + 0.02498 * (RZPLUS**EXPNT-RZMINS**EXPNT)
9679 RETURN
9680*
9681 6 CONTINUE
9682* POTENTIAL USED IN 6) (STIFF-qgp):
9683* U = -.124 * RHO/RHO0 + .0705 (RHO/RHO0)**2 GEV
9684*
9685 if(ene0.le.0.5)then
9686 GRADX = -0.062 * (RXPLUS - RXMINS) + 0.03525 * (RXPLUS**2 -
9687 & RXMINS**2)
9688 GRADY = -0.062 * (RYPLUS - RYMINS) + 0.03525 * (RYPLUS**2 -
9689 & RYMINS**2)
9690 GRADZ = -0.062 * (RZPLUS - RZMINS) + 0.03525 * (RZPLUS**2 -
9691 & RZMINS**2)
9692 RETURN
9693 endif
9694 if(ene0.gt.0.5.and.ene0.le.1.5)then
9695* U=c1-ef*rho/rho0**2/3
9696 ef=36./1000.
9697 GRADX = -0.5*ef* (RXPLUS**0.67-RXMINS**0.67)
9698 GRADy = -0.5*ef* (RyPLUS**0.67-RyMINS**0.67)
9699 GRADz = -0.5*ef* (RzPLUS**0.67-RzMINS**0.67)
9700 RETURN
9701 endif
9702 if(ene0.gt.1.5)then
9703* U=800*(rho/rho0)**1/3.-Ef*(rho/rho0)**2/3.-c2
9704 ef=36./1000.
9705 cf0=0.8
9706 GRADX =0.5*cf0*(rxplus**0.333-rxmins**0.333)
9707 & -0.5*ef* (RXPLUS**0.67-RXMINS**0.67)
9708 GRADy =0.5*cf0*(ryplus**0.333-rymins**0.333)
9709 & -0.5*ef* (RyPLUS**0.67-RyMINS**0.67)
9710 GRADz =0.5*cf0*(rzplus**0.333-rzmins**0.333)
9711 & -0.5*ef* (RzPLUS**0.67-RzMINS**0.67)
9712 RETURN
9713 endif
9714*
9715 7 CONTINUE
9716* POTENTIAL USED IN 7) (Soft-qgp):
9717 if(den0.le.4.5)then
9718* POTENTIAL USED is the same as IN 3) (SOFT):
9719* U = -.356 * RHO/RHO0 + .303 * (RHO/RHO0)**(7/6) GEV
9720*
9721 EXPNT = 1.1666667
9722 acoef = 0.178
9723 GRADX = -acoef * (RXPLUS - RXMINS)
9724 & + 0.1515 * (RXPLUS**EXPNT-RXMINS**EXPNT)
9725 GRADY = -acoef * (RYPLUS - RYMINS)
9726 & + 0.1515 * (RYPLUS**EXPNT-RYMINS**EXPNT)
9727 GRADZ = -acoef * (RZPLUS - RZMINS)
9728 & + 0.1515 * (RZPLUS**EXPNT-RZMINS**EXPNT)
9729 return
9730 endif
9731 if(den0.gt.4.5.and.den0.le.5.1)then
9732* U=c1-ef*rho/rho0**2/3
9733 ef=36./1000.
9734 GRADX = -0.5*ef* (RXPLUS**0.67-RXMINS**0.67)
9735 GRADy = -0.5*ef* (RyPLUS**0.67-RyMINS**0.67)
9736 GRADz = -0.5*ef* (RzPLUS**0.67-RzMINS**0.67)
9737 RETURN
9738 endif
9739 if(den0.gt.5.1)then
9740* U=800*(rho/rho0)**1/3.-Ef*(rho/rho0)**2/3.-c2
9741 ef=36./1000.
9742 cf0=0.8
9743 GRADX =0.5*cf0*(rxplus**0.333-rxmins**0.333)
9744 & -0.5*ef* (RXPLUS**0.67-RXMINS**0.67)
9745 GRADy =0.5*cf0*(ryplus**0.333-rymins**0.333)
9746 & -0.5*ef* (RyPLUS**0.67-RyMINS**0.67)
9747 GRADz =0.5*cf0*(rzplus**0.333-rzmins**0.333)
9748 & -0.5*ef* (RzPLUS**0.67-RzMINS**0.67)
9749 RETURN
9750 endif
9751 END
9752**********************************
9753* *
9754 SUBROUTINE GRADUK(IX,IY,IZ,GRADXk,GRADYk,GRADZk)
9755* *
9756* PURPOSE: DETERMINE the baryon density gradient for *
9757* proporgating kaons in a mean field caused by *
9758* surrounding baryons *
9759* VARIABLES: *
9760* IX, IY, IZ - COORDINATES OF POINT (INTEGER,INPUT) *
9761* GRADXk, GRADYk, GRADZk (REAL,OUTPUT) *
9762* *
9763**********************************
9764 PARAMETER (MAXX = 20, MAXZ = 24)
9765 PARAMETER (RHO0 = 0.168)
9766*
9767 COMMON /DD/ RHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
9768 & RHOP(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
9769 & RHON(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
9770cc SAVE /DD/
9771 common /ss/ inout(20)
9772cc SAVE /ss/
9773 SAVE
9774*
9775 RXPLUS = RHO(IX+1,IY, IZ )
9776 RXMINS = RHO(IX-1,IY, IZ )
9777 RYPLUS = RHO(IX, IY+1,IZ )
9778 RYMINS = RHO(IX, IY-1,IZ )
9779 RZPLUS = RHO(IX, IY, IZ+1)
9780 RZMINS = RHO(IX, IY, IZ-1)
9781 GRADXk = (RXPLUS - RXMINS)/2.
9782 GRADYk = (RYPLUS - RYMINS)/2.
9783 GRADZk = (RZPLUS - RZMINS)/2.
9784 RETURN
9785 END
9786*-----------------------------------------------------------------------
9787 SUBROUTINE GRADUP(IX,IY,IZ,GRADXP,GRADYP,GRADZP)
9788* *
9789* PURPOSE: DETERMINE THE GRADIENT OF THE PROTON DENSITY *
9790* VARIABLES: *
9791* *
9792* IX, IY, IZ - COORDINATES OF POINT (INTEGER,INPUT) *
9793* GRADXP, GRADYP, GRADZP - GRADIENT OF THE PROTON *
9794* DENSITY(REAL,OUTPUT) *
9795* *
9796**********************************
9797 PARAMETER (MAXX = 20, MAXZ = 24)
9798 PARAMETER (RHO0 = 0.168)
9799*
9800 COMMON /DD/ RHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
9801 & RHOP(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
9802 & RHON(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
9803cc SAVE /DD/
9804 common /ss/ inout(20)
9805cc SAVE /ss/
9806 SAVE
9807*
9808 RXPLUS = RHOP(IX+1,IY, IZ ) / RHO0
9809 RXMINS = RHOP(IX-1,IY, IZ ) / RHO0
9810 RYPLUS = RHOP(IX, IY+1,IZ ) / RHO0
9811 RYMINS = RHOP(IX, IY-1,IZ ) / RHO0
9812 RZPLUS = RHOP(IX, IY, IZ+1) / RHO0
9813 RZMINS = RHOP(IX, IY, IZ-1) / RHO0
9814*-----------------------------------------------------------------------
9815*
9816 GRADXP = (RXPLUS - RXMINS)/2.
9817 GRADYP = (RYPLUS - RYMINS)/2.
9818 GRADZP = (RZPLUS - RZMINS)/2.
9819 RETURN
9820 END
9821*-----------------------------------------------------------------------
9822 SUBROUTINE GRADUN(IX,IY,IZ,GRADXN,GRADYN,GRADZN)
9823* *
9824* PURPOSE: DETERMINE THE GRADIENT OF THE NEUTRON DENSITY *
9825* VARIABLES: *
9826* *
9827* IX, IY, IZ - COORDINATES OF POINT (INTEGER,INPUT) *
9828* GRADXN, GRADYN, GRADZN - GRADIENT OF THE NEUTRON *
9829* DENSITY(REAL,OUTPUT) *
9830* *
9831**********************************
9832 PARAMETER (MAXX = 20, MAXZ = 24)
9833 PARAMETER (RHO0 = 0.168)
9834*
9835 COMMON /DD/ RHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
9836 & RHOP(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
9837 & RHON(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
9838cc SAVE /DD/
9839 common /ss/ inout(20)
9840cc SAVE /ss/
9841 SAVE
9842*
9843 RXPLUS = RHON(IX+1,IY, IZ ) / RHO0
9844 RXMINS = RHON(IX-1,IY, IZ ) / RHO0
9845 RYPLUS = RHON(IX, IY+1,IZ ) / RHO0
9846 RYMINS = RHON(IX, IY-1,IZ ) / RHO0
9847 RZPLUS = RHON(IX, IY, IZ+1) / RHO0
9848 RZMINS = RHON(IX, IY, IZ-1) / RHO0
9849*-----------------------------------------------------------------------
9850*
9851 GRADXN = (RXPLUS - RXMINS)/2.
9852 GRADYN = (RYPLUS - RYMINS)/2.
9853 GRADZN = (RZPLUS - RZMINS)/2.
9854 RETURN
9855 END
9856
9857*-----------------------------------------------------------------------------
9858*FUNCTION FDE(DMASS) GIVES DELTA MASS DISTRIBUTION BY USING OF
9859*KITAZOE'S FORMULA
9860 REAL FUNCTION FDE(DMASS,SRT,CON)
9861 SAVE
9862 AMN=0.938869
9863 AVPI=0.13803333
9864 AM0=1.232
9865 FD=4.*(AM0**2)*WIDTH(DMASS)/((DMASS**2-1.232**2)**2
9866 1 +AM0**2*WIDTH(DMASS)**2)
9867 IF(CON.EQ.1.)THEN
9868 P11=(SRT**2+DMASS**2-AMN**2)**2
9869 1 /(4.*SRT**2)-DMASS**2
9870 if(p11.le.0)p11=1.E-06
9871 p1=sqrt(p11)
9872 ELSE
9873 DMASS=AMN+AVPI
9874 P11=(SRT**2+DMASS**2-AMN**2)**2
9875 1 /(4.*SRT**2)-DMASS**2
9876 if(p11.le.0)p11=1.E-06
9877 p1=sqrt(p11)
9878 ENDIF
9879 FDE=FD*P1*DMASS
9880 RETURN
9881 END
9882*-------------------------------------------------------------
9883*FUNCTION FDE(DMASS) GIVES N*(1535) MASS DISTRIBUTION BY USING OF
9884*KITAZOE'S FORMULA
9885 REAL FUNCTION FD5(DMASS,SRT,CON)
9886 SAVE
9887 AMN=0.938869
9888 AVPI=0.13803333
9889 AM0=1.535
9890 FD=4.*(AM0**2)*W1535(DMASS)/((DMASS**2-1.535**2)**2
9891 1 +AM0**2*W1535(DMASS)**2)
9892 IF(CON.EQ.1.)THEN
9893 P1=SQRT((SRT**2+DMASS**2-AMN**2)**2
9894 1 /(4.*SRT**2)-DMASS**2)
9895 ELSE
9896 DMASS=AMN+AVPI
9897 P1=SQRT((SRT**2+DMASS**2-AMN**2)**2
9898 1 /(4.*SRT**2)-DMASS**2)
9899 ENDIF
9900 FD5=FD*P1*DMASS
9901 RETURN
9902 END
9903*--------------------------------------------------------------------------
9904*FUNCTION FNS(DMASS) GIVES N* MASS DISTRIBUTION
9905c BY USING OF BREIT-WIGNER FORMULA
9906 REAL FUNCTION FNS(DMASS,SRT,CON)
9907 SAVE
9908 WIDTH=0.2
9909 AMN=0.938869
9910 AVPI=0.13803333
9911 AN0=1.43
9912 FN=4.*(AN0**2)*WIDTH/((DMASS**2-1.44**2)**2+AN0**2*WIDTH**2)
9913 IF(CON.EQ.1.)THEN
9914 P1=SQRT((SRT**2+DMASS**2-AMN**2)**2
9915 1 /(4.*SRT**2)-DMASS**2)
9916 ELSE
9917 DMASS=AMN+AVPI
9918 P1=SQRT((SRT**2+DMASS**2-AMN**2)**2
9919 1 /(4.*SRT**2)-DMASS**2)
9920 ENDIF
9921 FNS=FN*P1*DMASS
9922 RETURN
9923 END
9924*-----------------------------------------------------------------------------
9925*-----------------------------------------------------------------------------
9926* PURPOSE:1. SORT N*(1440) and N*(1535) 2-body DECAY PRODUCTS
9927* 2. DETERMINE THE MOMENTUM AND COORDINATES OF NUCLEON AND PION
9928* AFTER THE DELTA OR N* DECAYING
9929* DATE : JAN. 24,1990, MODIFIED ON MAY 17, 1994 TO INCLUDE ETA
3006c44b 9930 SUBROUTINE DECAYA(IRUN,I,NNN,ISEED,wid,nt)
0119ef9a 9931 PARAMETER (MAXSTR=150001,MAXR=1,
9932 1 AMN=0.939457,ETAM=0.5475,AMP=0.93828,AP1=0.13496,
9933 2 AP2=0.13957,AM0=1.232,PI=3.1415926)
9934 COMMON /AA/ R(3,MAXSTR)
9935cc SAVE /AA/
9936 COMMON /BB/ P(3,MAXSTR)
9937cc SAVE /BB/
9938 COMMON /CC/ E(MAXSTR)
9939cc SAVE /CC/
9940 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
9941cc SAVE /EE/
9942 COMMON /RUN/NUM
9943cc SAVE /RUN/
9944 COMMON /PA/RPION(3,MAXSTR,MAXR)
9945cc SAVE /PA/
9946 COMMON /PB/PPION(3,MAXSTR,MAXR)
9947cc SAVE /PB/
9948 COMMON /PC/EPION(MAXSTR,MAXR)
9949cc SAVE /PC/
9950 COMMON /PD/LPION(MAXSTR,MAXR)
9951cc SAVE /PD/
9952 COMMON /INPUT2/ ILAB, MANYB, NTMAX, ICOLL, INSYS, IPOT, MODE,
9953 & IMOMEN, NFREQ, ICFLOW, ICRHO, ICOU, KPOTEN, KMUL
9954cc SAVE /INPUT2/
9955 COMMON/RNDF77/NSEED
9956 COMMON /dpert/dpertt(MAXSTR,MAXR),dpertp(MAXSTR),dplast(MAXSTR),
9957 1 dpdcy(MAXSTR),dpdpi(MAXSTR,MAXR),dpt(MAXSTR, MAXR),
9958 2 dpp1(MAXSTR,MAXR),dppion(MAXSTR,MAXR)
9959cc SAVE /RNDF77/
9960 SAVE
9961 lbanti=LB(I)
9962c
9963 DM=E(I)
9964*1. FOR N*+(1440) DECAY
9965 IF(iabs(LB(I)).EQ.11)THEN
9966 X3=RANART(NSEED)
9967 IF(X3.GT.(1./3.))THEN
9968 LB(I)=2
9969 NLAB=2
9970 LPION(NNN,IRUN)=5
9971 EPION(NNN,IRUN)=AP2
9972 ELSE
9973 LB(I)=1
9974 NLAB=1
9975 LPION(NNN,IRUN)=4
9976 EPION(NNN,IRUN)=AP1
9977 ENDIF
9978*2. FOR N*0(1440) DECAY
9979 ELSEIF(iabs(LB(I)).EQ.10)THEN
9980 X4=RANART(NSEED)
9981 IF(X4.GT.(1./3.))THEN
9982 LB(I)=1
9983 NLAB=1
9984 LPION(NNN,IRUN)=3
9985 EPION(NNN,IRUN)=AP2
9986 ELSE
9987 LB(I)=2
9988 NALB=2
9989 LPION(NNN,IRUN)=4
9990 EPION(NNN,IRUN)=AP1
9991 ENDIF
9992* N*(1535) CAN DECAY TO A PION OR AN ETA IF DM > 1.49 GeV
9993*3 N*(0)(1535) DECAY
9994 ELSEIF(iabs(LB(I)).EQ.12)THEN
9995 CTRL=0.65
9996 IF(DM.lE.1.49)ctrl=-1.
9997 X5=RANART(NSEED)
9998 IF(X5.GE.ctrl)THEN
9999* DECAY TO PION+NUCLEON
10000 X6=RANART(NSEED)
10001 IF(X6.GT.(1./3.))THEN
10002 LB(I)=1
10003 NLAB=1
10004 LPION(NNN,IRUN)=3
10005 EPION(NNN,IRUN)=AP2
10006 ELSE
10007 LB(I)=2
10008 NALB=2
10009 LPION(NNN,IRUN)=4
10010 EPION(NNN,IRUN)=AP1
10011 ENDIF
10012 ELSE
10013* DECAY TO ETA+NEUTRON
10014 LB(I)=2
10015 NLAB=2
10016 LPION(NNN,IRUN)=0
10017 EPION(NNN,IRUN)=ETAM
10018 ENDIF
10019*4. FOR N*+(1535) DECAY
10020 ELSEIF(iabs(LB(I)).EQ.13)THEN
10021 CTRL=0.65
10022 IF(DM.lE.1.49)ctrl=-1.
10023 X5=RANART(NSEED)
10024 IF(X5.GE.ctrl)THEN
10025* DECAY TO PION+NUCLEON
10026 X8=RANART(NSEED)
10027 IF(X8.GT.(1./3.))THEN
10028 LB(I)=2
10029 NLAB=2
10030 LPION(NNN,IRUN)=5
10031 EPION(NNN,IRUN)=AP2
10032 ELSE
10033 LB(I)=1
10034 NLAB=1
10035 LPION(NNN,IRUN)=4
10036 EPION(NNN,IRUN)=AP1
10037 ENDIF
10038 ELSE
10039* DECAY TO ETA+NUCLEON
10040 LB(I)=1
10041 NLAB=1
10042 LPION(NNN,IRUN)=0
10043 EPION(NNN,IRUN)=ETAM
10044 ENDIF
10045 ENDIF
10046c
10047 CALL DKINE(IRUN,I,NNN,NLAB,ISEED,wid,nt)
10048c
10049c anti-particle ID for anti-N* decays:
10050 if(lbanti.lt.0) then
10051 lbi=LB(I)
10052 if(lbi.eq.1.or.lbi.eq.2) then
10053 lbi=-lbi
10054 elseif(lbi.eq.3) then
10055 lbi=5
10056 elseif(lbi.eq.5) then
10057 lbi=3
10058 endif
10059 LB(I)=lbi
10060c
10061 lbi=LPION(NNN,IRUN)
10062 if(lbi.eq.3) then
10063 lbi=5
10064 elseif(lbi.eq.5) then
10065 lbi=3
10066 elseif(lbi.eq.1.or.lbi.eq.2) then
10067 lbi=-lbi
10068 endif
10069 LPION(NNN,IRUN)=lbi
10070 endif
10071c
10072 if(nt.eq.ntmax) then
10073c at the last timestep, assign rho or eta (decay daughter)
10074c to lb(i1) only (not to lpion) in order to decay them again:
10075 lbm=LPION(NNN,IRUN)
10076 if(lbm.eq.0.or.lbm.eq.25
10077 1 .or.lbm.eq.26.or.lbm.eq.27) then
10078c switch rho or eta with baryon, positions are the same (no change needed):
10079 lbsave=lbm
10080 xmsave=EPION(NNN,IRUN)
10081 pxsave=PPION(1,NNN,IRUN)
10082 pysave=PPION(2,NNN,IRUN)
10083 pzsave=PPION(3,NNN,IRUN)
10084clin-5/2008:
10085 dpsave=dppion(NNN,IRUN)
10086 LPION(NNN,IRUN)=LB(I)
10087 EPION(NNN,IRUN)=E(I)
10088 PPION(1,NNN,IRUN)=P(1,I)
10089 PPION(2,NNN,IRUN)=P(2,I)
10090 PPION(3,NNN,IRUN)=P(3,I)
10091clin-5/2008:
10092 dppion(NNN,IRUN)=dpertp(I)
10093 LB(I)=lbsave
10094 E(I)=xmsave
10095 P(1,I)=pxsave
10096 P(2,I)=pysave
10097 P(3,I)=pzsave
10098clin-5/2008:
10099 dpertp(I)=dpsave
10100 endif
10101 endif
10102
10103 RETURN
10104 END
10105
10106*-------------------------------------------------------------------
10107*-------------------------------------------------------------------
10108* PURPOSE:
10109* CALCULATE THE MOMENTUM OF NUCLEON AND PION (OR ETA)
10110* IN THE LAB. FRAME AFTER DELTA OR N* DECAY
10111* DATE : JAN. 24,1990, MODIFIED ON MAY 17, 1994 TO INCLUDE ETA PRODUCTION
10112 SUBROUTINE DKINE(IRUN,I,NNN,NLAB,ISEED,wid,nt)
10113 PARAMETER (hbarc=0.19733)
10114 PARAMETER (MAXSTR=150001,MAXR=1,
10115 1 AMN=0.939457,AMP=0.93828,ETAM=0.5475,
10116 2 AP1=0.13496,AP2=0.13957,AM0=1.232,PI=3.1415926)
10117 COMMON /AA/ R(3,MAXSTR)
10118cc SAVE /AA/
10119 COMMON /BB/ P(3,MAXSTR)
10120cc SAVE /BB/
10121 COMMON /CC/ E(MAXSTR)
10122cc SAVE /CC/
10123 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
10124cc SAVE /EE/
10125 COMMON /RUN/NUM
10126cc SAVE /RUN/
10127 COMMON /PA/RPION(3,MAXSTR,MAXR)
10128cc SAVE /PA/
10129 COMMON /PB/PPION(3,MAXSTR,MAXR)
10130cc SAVE /PB/
10131 COMMON /PC/EPION(MAXSTR,MAXR)
10132cc SAVE /PC/
10133 COMMON /PD/LPION(MAXSTR,MAXR)
10134cc SAVE /PD/
10135 common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
10136 1 px1n,py1n,pz1n,dp1n
10137cc SAVE /leadng/
10138 COMMON/tdecay/tfdcy(MAXSTR),tfdpi(MAXSTR,MAXR),tft(MAXSTR)
10139cc SAVE /tdecay/
10140 COMMON /INPUT2/ ILAB, MANYB, NTMAX, ICOLL, INSYS, IPOT, MODE,
10141 & IMOMEN, NFREQ, ICFLOW, ICRHO, ICOU, KPOTEN, KMUL
10142cc SAVE /INPUT2/
10143 COMMON/RNDF77/NSEED
10144cc SAVE /RNDF77/
10145 COMMON /dpert/dpertt(MAXSTR,MAXR),dpertp(MAXSTR),dplast(MAXSTR),
10146 1 dpdcy(MAXSTR),dpdpi(MAXSTR,MAXR),dpt(MAXSTR, MAXR),
10147 2 dpp1(MAXSTR,MAXR),dppion(MAXSTR,MAXR)
10148 EXTERNAL IARFLV, INVFLV
10149 SAVE
10150 ISEED=ISEED
10151* READ IN THE COORDINATES OF DELTA OR N* UNDERGOING DECAY
10152 PX=P(1,I)
10153 PY=P(2,I)
10154 PZ=P(3,I)
10155 RX=R(1,I)
10156 RY=R(2,I)
10157 RZ=R(3,I)
10158 DM=E(I)
10159 EDELTA=SQRT(DM**2+PX**2+PY**2+PZ**2)
10160 PM=EPION(NNN,IRUN)
10161 AM=AMP
10162 IF(NLAB.EQ.2)AM=AMN
10163* FIND OUT THE MOMENTUM AND ENERGY OF PION AND NUCLEON IN DELTA REST FRAME
10164* THE MAGNITUDE OF MOMENTUM IS DETERMINED BY ENERGY CONSERVATION ,THE FORMULA
10165* CAN BE FOUND ON PAGE 716,W BAUER P.R.C40,1989
10166* THE DIRECTION OF THE MOMENTUM IS ASSUMED ISOTROPIC. NOTE THAT P(PION)=-P(N)
10167 Q2=((DM**2-AM**2+PM**2)/(2.*DM))**2-PM**2
10168 IF(Q2.LE.0.)Q2=1.e-09
10169 Q=SQRT(Q2)
1017011 QX=1.-2.*RANART(NSEED)
10171 QY=1.-2.*RANART(NSEED)
10172 QZ=1.-2.*RANART(NSEED)
10173 QS=QX**2+QY**2+QZ**2
10174 IF(QS.GT.1.) GO TO 11
10175 PXP=Q*QX/SQRT(QS)
10176 PYP=Q*QY/SQRT(QS)
10177 PZP=Q*QZ/SQRT(QS)
10178 EP=SQRT(Q**2+PM**2)
10179 PXN=-PXP
10180 PYN=-PYP
10181 PZN=-PZP
10182 EN=SQRT(Q**2+AM**2)
10183* TRANSFORM INTO THE LAB. FRAME. THE GENERAL LORENTZ TRANSFORMATION CAN
10184* BE FOUND ON PAGE 34 OF R. HAGEDORN " RELATIVISTIC KINEMATICS"
10185 GD=EDELTA/DM
10186 FGD=GD/(1.+GD)
10187 BDX=PX/EDELTA
10188 BDY=PY/EDELTA
10189 BDZ=PZ/EDELTA
10190 BPP=BDX*PXP+BDY*PYP+BDZ*PZP
10191 BPN=BDX*PXN+BDY*PYN+BDZ*PZN
10192 P(1,I)=PXN+BDX*GD*(FGD*BPN+EN)
10193 P(2,I)=PYN+BDY*GD*(FGD*BPN+EN)
10194 P(3,I)=PZN+BDZ*GD*(FGD*BPN+EN)
10195 E(I)=AM
10196* WE ASSUME THAT THE SPACIAL COORDINATE OF THE NUCLEON
10197* IS THAT OF THE DELTA
10198 PPION(1,NNN,IRUN)=PXP+BDX*GD*(FGD*BPP+EP)
10199 PPION(2,NNN,IRUN)=PYP+BDY*GD*(FGD*BPP+EP)
10200 PPION(3,NNN,IRUN)=PZP+BDZ*GD*(FGD*BPP+EP)
10201clin-5/2008:
10202 dppion(NNN,IRUN)=dpertp(I)
10203* WE ASSUME THE PION OR ETA COMING FROM DELTA DECAY IS LOCATED ON THE SPHERE
10204* OF RADIUS 0.5FM AROUND DELTA, THIS POINT NEED TO BE CHECKED
10205* AND OTHER CRIERTION MAY BE TRIED
10206clin-2/20/03 no additional smearing for position of decay daughters:
10207c200 X0 = 1.0 - 2.0 * RANART(NSEED)
10208c Y0 = 1.0 - 2.0 * RANART(NSEED)
10209c Z0 = 1.0 - 2.0 * RANART(NSEED)
10210c IF ((X0*X0+Y0*Y0+Z0*Z0) .GT. 1.0) GOTO 200
10211c RPION(1,NNN,IRUN)=R(1,I)+0.5*x0
10212c RPION(2,NNN,IRUN)=R(2,I)+0.5*y0
10213c RPION(3,NNN,IRUN)=R(3,I)+0.5*z0
10214 RPION(1,NNN,IRUN)=R(1,I)
10215 RPION(2,NNN,IRUN)=R(2,I)
10216 RPION(3,NNN,IRUN)=R(3,I)
10217c
10218 devio=SQRT(EPION(NNN,IRUN)**2+PPION(1,NNN,IRUN)**2
10219 1 +PPION(2,NNN,IRUN)**2+PPION(3,NNN,IRUN)**2)
10220 2 +SQRT(E(I)**2+P(1,I)**2+P(2,I)**2+P(3,I)**2)-e1
10221c if(abs(devio).gt.0.02) write(93,*) 'decay(): nt=',nt,devio,lb1
10222
10223c add decay time to daughter's formation time at the last timestep:
10224 if(nt.eq.ntmax) then
10225 tau0=hbarc/wid
10226 taudcy=tau0*(-1.)*alog(1.-RANART(NSEED))
10227c lorentz boost:
10228 taudcy=taudcy*e1/em1
10229 tfnl=tfnl+taudcy
10230 xfnl=xfnl+px1/e1*taudcy
10231 yfnl=yfnl+py1/e1*taudcy
10232 zfnl=zfnl+pz1/e1*taudcy
10233 R(1,I)=xfnl
10234 R(2,I)=yfnl
10235 R(3,I)=zfnl
10236 tfdcy(I)=tfnl
10237 RPION(1,NNN,IRUN)=xfnl
10238 RPION(2,NNN,IRUN)=yfnl
10239 RPION(3,NNN,IRUN)=zfnl
10240 tfdpi(NNN,IRUN)=tfnl
10241 endif
10242
10243cc 200 format(a30,2(1x,e10.4))
10244cc 210 format(i6,5(1x,f8.3))
10245cc 220 format(a2,i5,5(1x,f8.3))
10246
10247 RETURN
10248 END
10249
10250*-----------------------------------------------------------------------------
10251*-----------------------------------------------------------------------------
10252* PURPOSE:1. N*-->N+PION+PION DECAY PRODUCTS
10253* 2. DETERMINE THE MOMENTUM AND COORDINATES OF NUCLEON AND PION
10254* AFTER THE DELTA OR N* DECAYING
10255* DATE : NOV.7,1994
10256*----------------------------------------------------------------------------
10257 SUBROUTINE DECAY2(IRUN,I,NNN,ISEED,wid,nt)
10258 PARAMETER (MAXSTR=150001,MAXR=1,
10259 1 AMN=0.939457,ETAM=0.5475,AMP=0.93828,AP1=0.13496,
10260 2 AP2=0.13957,AM0=1.232,PI=3.1415926)
10261 COMMON /AA/ R(3,MAXSTR)
10262cc SAVE /AA/
10263 COMMON /BB/ P(3,MAXSTR)
10264cc SAVE /BB/
10265 COMMON /CC/ E(MAXSTR)
10266cc SAVE /CC/
10267 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
10268cc SAVE /EE/
10269 COMMON /RUN/NUM
10270cc SAVE /RUN/
10271 COMMON /PA/RPION(3,MAXSTR,MAXR)
10272cc SAVE /PA/
10273 COMMON /PB/PPION(3,MAXSTR,MAXR)
10274cc SAVE /PB/
10275 COMMON /PC/EPION(MAXSTR,MAXR)
10276cc SAVE /PC/
10277 COMMON /PD/LPION(MAXSTR,MAXR)
10278cc SAVE /PD/
10279 COMMON/RNDF77/NSEED
10280cc SAVE /RNDF77/
10281 SAVE
10282
10283 lbanti=LB(I)
10284c
10285 DM=E(I)
10286* DETERMINE THE DECAY PRODUCTS
10287* FOR N*+(1440) DECAY
10288 IF(iabs(LB(I)).EQ.11)THEN
10289 X3=RANART(NSEED)
10290 IF(X3.LT.(1./3))THEN
10291 LB(I)=2
10292 NLAB=2
10293 LPION(NNN,IRUN)=5
10294 EPION(NNN,IRUN)=AP2
10295 LPION(NNN+1,IRUN)=4
10296 EPION(NNN+1,IRUN)=AP1
10297 ELSEIF(X3.LT.2./3.AND.X3.GT.1./3.)THEN
10298 LB(I)=1
10299 NLAB=1
10300 LPION(NNN,IRUN)=5
10301 EPION(NNN,IRUN)=AP2
10302 LPION(NNN+1,IRUN)=3
10303 EPION(NNN+1,IRUN)=AP2
10304 ELSE
10305 LB(I)=1
10306 NLAB=1
10307 LPION(NNN,IRUN)=4
10308 EPION(NNN,IRUN)=AP1
10309 LPION(NNN+1,IRUN)=4
10310 EPION(NNN+1,IRUN)=AP1
10311 ENDIF
10312* FOR N*0(1440) DECAY
10313 ELSEIF(iabs(LB(I)).EQ.10)THEN
10314 X3=RANART(NSEED)
10315 IF(X3.LT.(1./3))THEN
10316 LB(I)=2
10317 NLAB=2
10318 LPION(NNN,IRUN)=4
10319 EPION(NNN,IRUN)=AP1
10320 LPION(NNN+1,IRUN)=4
10321 EPION(NNN+1,IRUN)=AP1
10322 ELSEIF(X3.LT.2./3.AND.X3.GT.1./3.)THEN
10323 LB(I)=1
10324 NLAB=1
10325 LPION(NNN,IRUN)=3
10326 EPION(NNN,IRUN)=AP2
10327 LPION(NNN+1,IRUN)=4
10328 EPION(NNN+1,IRUN)=AP1
10329 ELSE
10330 LB(I)=2
10331 NLAB=2
10332 LPION(NNN,IRUN)=5
10333 EPION(NNN,IRUN)=AP2
10334 LPION(NNN+1,IRUN)=3
10335 EPION(NNN+1,IRUN)=AP2
10336 ENDIF
10337 ENDIF
10338
10339 CALL DKINE2(IRUN,I,NNN,NLAB,ISEED,wid,nt)
10340c
10341c anti-particle ID for anti-N* decays:
10342 if(lbanti.lt.0) then
10343 lbi=LB(I)
10344 if(lbi.eq.1.or.lbi.eq.2) then
10345 lbi=-lbi
10346 elseif(lbi.eq.3) then
10347 lbi=5
10348 elseif(lbi.eq.5) then
10349 lbi=3
10350 endif
10351 LB(I)=lbi
10352c
10353 lbi=LPION(NNN,IRUN)
10354 if(lbi.eq.3) then
10355 lbi=5
10356 elseif(lbi.eq.5) then
10357 lbi=3
10358 elseif(lbi.eq.1.or.lbi.eq.2) then
10359 lbi=-lbi
10360 endif
10361 LPION(NNN,IRUN)=lbi
10362c
10363 lbi=LPION(NNN+1,IRUN)
10364 if(lbi.eq.3) then
10365 lbi=5
10366 elseif(lbi.eq.5) then
10367 lbi=3
10368 elseif(lbi.eq.1.or.lbi.eq.2) then
10369 lbi=-lbi
10370 endif
10371 LPION(NNN+1,IRUN)=lbi
10372 endif
10373c
10374 RETURN
10375 END
10376*-------------------------------------------------------------------
10377*--------------------------------------------------------------------------
10378* CALCULATE THE MOMENTUM OF NUCLEON AND PION (OR ETA)
10379* IN THE LAB. FRAME AFTER DELTA OR N* DECAY
10380* DATE : JAN. 24,1990, MODIFIED ON MAY 17, 1994 TO INCLUDE ETA PRODUCTION
10381*--------------------------------------------------------------------------
10382 SUBROUTINE DKINE2(IRUN,I,NNN,NLAB,ISEED,wid,nt)
10383 PARAMETER (hbarc=0.19733)
10384 PARAMETER (MAXSTR=150001,MAXR=1,
10385 1 AMN=0.939457,AMP=0.93828,ETAM=0.5475,
10386 2 AP1=0.13496,AP2=0.13957,AM0=1.232,PI=3.1415926)
10387 COMMON /AA/ R(3,MAXSTR)
10388cc SAVE /AA/
10389 COMMON /BB/ P(3,MAXSTR)
10390cc SAVE /BB/
10391 COMMON /CC/ E(MAXSTR)
10392cc SAVE /CC/
10393 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
10394cc SAVE /EE/
10395 COMMON /RUN/NUM
10396cc SAVE /RUN/
10397 COMMON /PA/RPION(3,MAXSTR,MAXR)
10398cc SAVE /PA/
10399 COMMON /PB/PPION(3,MAXSTR,MAXR)
10400cc SAVE /PB/
10401 COMMON /PC/EPION(MAXSTR,MAXR)
10402cc SAVE /PC/
10403 COMMON /PD/LPION(MAXSTR,MAXR)
10404cc SAVE /PD/
10405 common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
10406 1 px1n,py1n,pz1n,dp1n
10407cc SAVE /leadng/
10408 COMMON/tdecay/tfdcy(MAXSTR),tfdpi(MAXSTR,MAXR),tft(MAXSTR)
10409cc SAVE /tdecay/
10410 COMMON /INPUT2/ ILAB, MANYB, NTMAX, ICOLL, INSYS, IPOT, MODE,
10411 & IMOMEN, NFREQ, ICFLOW, ICRHO, ICOU, KPOTEN, KMUL
10412cc SAVE /INPUT2/
10413 EXTERNAL IARFLV, INVFLV
10414 COMMON/RNDF77/NSEED
10415cc SAVE /RNDF77/
10416 COMMON /dpert/dpertt(MAXSTR,MAXR),dpertp(MAXSTR),dplast(MAXSTR),
10417 1 dpdcy(MAXSTR),dpdpi(MAXSTR,MAXR),dpt(MAXSTR, MAXR),
10418 2 dpp1(MAXSTR,MAXR),dppion(MAXSTR,MAXR)
10419 SAVE
10420
10421 ISEED=ISEED
10422* READ IN THE COORDINATES OF THE N*(1440) UNDERGOING DECAY
10423 PX=P(1,I)
10424 PY=P(2,I)
10425 PZ=P(3,I)
10426 RX=R(1,I)
10427 RY=R(2,I)
10428 RZ=R(3,I)
10429 DM=E(I)
10430 EDELTA=SQRT(DM**2+PX**2+PY**2+PZ**2)
10431 PM1=EPION(NNN,IRUN)
10432 PM2=EPION(NNN+1,IRUN)
10433 AM=AMN
10434 IF(NLAB.EQ.1)AM=AMP
10435* THE MAXIMUM MOMENTUM OF THE NUCLEON FROM THE DECAY OF A N*
10436 PMAX2=(DM**2-(AM+PM1+PM2)**2)*(DM**2-(AM-PM1-PM2)**2)/4/DM**2
10437 PMAX=SQRT(PMAX2)
10438* GENERATE THE MOMENTUM OF THE NUCLEON IN THE N* REST FRAME
10439 CSS=1.-2.*RANART(NSEED)
10440 SSS=SQRT(1-CSS**2)
10441 FAI=2*PI*RANART(NSEED)
10442 PX0=PMAX*SSS*COS(FAI)
10443 PY0=PMAX*SSS*SIN(FAI)
10444 PZ0=PMAX*CSS
10445 EP0=SQRT(PX0**2+PY0**2+PZ0**2+AM**2)
10446clin-5/23/01 bug: P0 for pion0 is equal to PMAX, leaving pion+ and pion-
10447c without no relative momentum, thus producing them with equal momenta,
10448* BETA AND GAMMA OF THE CMS OF PION+-PION-
10449 BETAX=-PX0/(DM-EP0)
10450 BETAY=-PY0/(DM-EP0)
10451 BETAZ=-PZ0/(DM-EP0)
10452 GD1=1./SQRT(1-BETAX**2-BETAY**2-BETAZ**2)
10453 FGD1=GD1/(1+GD1)
10454* GENERATE THE MOMENTA OF PIONS IN THE CMS OF PION+PION-
10455 Q2=((DM-EP0)/(2.*GD1))**2-PM1**2
10456 IF(Q2.LE.0.)Q2=1.E-09
10457 Q=SQRT(Q2)
1045811 QX=1.-2.*RANART(NSEED)
10459 QY=1.-2.*RANART(NSEED)
10460 QZ=1.-2.*RANART(NSEED)
10461 QS=QX**2+QY**2+QZ**2
10462 IF(QS.GT.1.) GO TO 11
10463 PXP=Q*QX/SQRT(QS)
10464 PYP=Q*QY/SQRT(QS)
10465 PZP=Q*QZ/SQRT(QS)
10466 EP=SQRT(Q**2+PM1**2)
10467 PXN=-PXP
10468 PYN=-PYP
10469 PZN=-PZP
10470 EN=SQRT(Q**2+PM2**2)
10471* TRANSFORM THE MOMENTA OF PION+PION- INTO THE N* REST FRAME
10472 BPP1=BETAX*PXP+BETAY*PYP+BETAZ*PZP
10473 BPN1=BETAX*PXN+BETAY*PYN+BETAZ*PZN
10474* FOR PION-
10475 P1M=PXN+BETAX*GD1*(FGD1*BPN1+EN)
10476 P2M=PYN+BETAY*GD1*(FGD1*BPN1+EN)
10477 P3M=PZN+BETAZ*GD1*(FGD1*BPN1+EN)
10478 EPN=SQRT(P1M**2+P2M**2+P3M**2+PM2**2)
10479* FOR PION+
10480 P1P=PXP+BETAX*GD1*(FGD1*BPP1+EP)
10481 P2P=PYP+BETAY*GD1*(FGD1*BPP1+EP)
10482 P3P=PZP+BETAZ*GD1*(FGD1*BPP1+EP)
10483 EPP=SQRT(P1P**2+P2P**2+P3P**2+PM1**2)
10484* TRANSFORM MOMENTA OF THE THREE PIONS INTO THE
10485* THE NUCLEUS-NUCLEUS CENTER OF MASS FRAME.
10486* THE GENERAL LORENTZ TRANSFORMATION CAN
10487* BE FOUND ON PAGE 34 OF R. HAGEDORN " RELATIVISTIC KINEMATICS"
10488 GD=EDELTA/DM
10489 FGD=GD/(1.+GD)
10490 BDX=PX/EDELTA
10491 BDY=PY/EDELTA
10492 BDZ=PZ/EDELTA
10493 BP0=BDX*PX0+BDY*PY0+BDZ*PZ0
10494 BPP=BDX*P1P+BDY*P2P+BDZ*P3P
10495 BPN=BDX*P1M+BDY*P2M+BDZ*P3M
10496* FOR THE NUCLEON
10497 P(1,I)=PX0+BDX*GD*(FGD*BP0+EP0)
10498 P(2,I)=PY0+BDY*GD*(FGD*BP0+EP0)
10499 P(3,I)=PZ0+BDZ*GD*(FGD*BP0+EP0)
10500 E(I)=am
10501 ID(I)=0
10502 enucl=sqrt(p(1,i)**2+p(2,i)**2+p(3,i)**2+e(i)**2)
10503* WE ASSUME THAT THE SPACIAL COORDINATE OF THE PION0
10504* IS in a sphere of radius 0.5 fm around N*
10505* FOR PION+
10506 PPION(1,NNN,IRUN)=P1P+BDX*GD*(FGD*BPP+EPP)
10507 PPION(2,NNN,IRUN)=P2P+BDY*GD*(FGD*BPP+EPP)
10508 PPION(3,NNN,IRUN)=P3P+BDZ*GD*(FGD*BPP+EPP)
10509 epion1=sqrt(ppion(1,nnn,irun)**2
10510 & +ppion(2,nnn,irun)**2+ppion(3,nnn,irun)**2
10511 & +epion(nnn,irun)**2)
10512clin-2/20/03 no additional smearing for position of decay daughters:
10513c200 X0 = 1.0 - 2.0 * RANART(NSEED)
10514c Y0 = 1.0 - 2.0 * RANART(NSEED)
10515c Z0 = 1.0 - 2.0 * RANART(NSEED)
10516c IF ((X0*X0+Y0*Y0+Z0*Z0) .GT. 1.0) GOTO 200
10517c RPION(1,NNN,IRUN)=R(1,I)+0.5*x0
10518c RPION(2,NNN,IRUN)=R(2,I)+0.5*y0
10519c RPION(3,NNN,IRUN)=R(3,I)+0.5*z0
10520 RPION(1,NNN,IRUN)=R(1,I)
10521 RPION(2,NNN,IRUN)=R(2,I)
10522 RPION(3,NNN,IRUN)=R(3,I)
10523* FOR PION-
10524 PPION(1,NNN+1,IRUN)=P1M+BDX*GD*(FGD*BPN+EPN)
10525 PPION(2,NNN+1,IRUN)=P2M+BDY*GD*(FGD*BPN+EPN)
10526 PPION(3,NNN+1,IRUN)=P3M+BDZ*GD*(FGD*BPN+EPN)
10527clin-5/2008:
10528 dppion(NNN,IRUN)=dpertp(I)
10529 dppion(NNN+1,IRUN)=dpertp(I)
10530c
10531 epion2=sqrt(ppion(1,nnn+1,irun)**2
10532 & +ppion(2,nnn+1,irun)**2+ppion(3,nnn+1,irun)**2
10533 & +epion(nnn+1,irun)**2)
10534clin-2/20/03 no additional smearing for position of decay daughters:
10535c300 X0 = 1.0 - 2.0 * RANART(NSEED)
10536c Y0 = 1.0 - 2.0 * RANART(NSEED)
10537c Z0 = 1.0 - 2.0 * RANART(NSEED)
10538c IF ((X0*X0+Y0*Y0+Z0*Z0) .GT. 1.0) GOTO 300
10539c RPION(1,NNN+1,IRUN)=R(1,I)+0.5*x0
10540c RPION(2,NNN+1,IRUN)=R(2,I)+0.5*y0
10541c RPION(3,NNN+1,IRUN)=R(3,I)+0.5*z0
10542 RPION(1,NNN+1,IRUN)=R(1,I)
10543 RPION(2,NNN+1,IRUN)=R(2,I)
10544 RPION(3,NNN+1,IRUN)=R(3,I)
10545c
10546* check energy conservation in the decay
10547c efinal=enucl+epion1+epion2
10548c DEEE=(EDELTA-EFINAL)/EDELTA
10549c IF(ABS(DEEE).GE.1.E-03)write(6,*)1,edelta,efinal
10550
10551 devio=SQRT(EPION(NNN,IRUN)**2+PPION(1,NNN,IRUN)**2
10552 1 +PPION(2,NNN,IRUN)**2+PPION(3,NNN,IRUN)**2)
10553 2 +SQRT(E(I)**2+P(1,I)**2+P(2,I)**2+P(3,I)**2)
10554 3 +SQRT(EPION(NNN+1,IRUN)**2+PPION(1,NNN+1,IRUN)**2
10555 4 +PPION(2,NNN+1,IRUN)**2+PPION(3,NNN+1,IRUN)**2)-e1
10556c if(abs(devio).gt.0.02) write(93,*) 'decay2(): nt=',nt,devio,lb1
10557
10558c add decay time to daughter's formation time at the last timestep:
10559 if(nt.eq.ntmax) then
10560 tau0=hbarc/wid
10561 taudcy=tau0*(-1.)*alog(1.-RANART(NSEED))
10562c lorentz boost:
10563 taudcy=taudcy*e1/em1
10564 tfnl=tfnl+taudcy
10565 xfnl=xfnl+px1/e1*taudcy
10566 yfnl=yfnl+py1/e1*taudcy
10567 zfnl=zfnl+pz1/e1*taudcy
10568 R(1,I)=xfnl
10569 R(2,I)=yfnl
10570 R(3,I)=zfnl
10571 tfdcy(I)=tfnl
10572 RPION(1,NNN,IRUN)=xfnl
10573 RPION(2,NNN,IRUN)=yfnl
10574 RPION(3,NNN,IRUN)=zfnl
10575 tfdpi(NNN,IRUN)=tfnl
10576 RPION(1,NNN+1,IRUN)=xfnl
10577 RPION(2,NNN+1,IRUN)=yfnl
10578 RPION(3,NNN+1,IRUN)=zfnl
10579 tfdpi(NNN+1,IRUN)=tfnl
10580 endif
10581
10582cc 200 format(a30,2(1x,e10.4))
10583cc 210 format(i6,5(1x,f8.3))
10584cc 220 format(a2,i5,5(1x,f8.3))
10585
10586 RETURN
10587 END
10588*---------------------------------------------------------------------------
10589*---------------------------------------------------------------------------
10590* PURPOSE : CALCULATE THE MASS AND MOMENTUM OF BARYON RESONANCE
10591* AFTER PION OR ETA BEING ABSORBED BY A NUCLEON
10592* NOTE :
10593*
10594* DATE : JAN.29,1990
10595 SUBROUTINE DRESON(I1,I2)
10596 PARAMETER (MAXSTR=150001,MAXR=1,
10597 1 AMN=0.939457,AMP=0.93828,
10598 2 AP1=0.13496,AP2=0.13957,AM0=1.232,PI=3.1415926)
10599 COMMON /AA/ R(3,MAXSTR)
10600cc SAVE /AA/
10601 COMMON /BB/ P(3,MAXSTR)
10602cc SAVE /BB/
10603 COMMON /CC/ E(MAXSTR)
10604cc SAVE /CC/
10605 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
10606cc SAVE /EE/
10607 COMMON /RUN/NUM
10608cc SAVE /RUN/
10609 COMMON /PA/RPION(3,MAXSTR,MAXR)
10610cc SAVE /PA/
10611 COMMON /PB/PPION(3,MAXSTR,MAXR)
10612cc SAVE /PB/
10613 COMMON /PC/EPION(MAXSTR,MAXR)
10614cc SAVE /PC/
10615 COMMON /PD/LPION(MAXSTR,MAXR)
10616cc SAVE /PD/
10617 SAVE
10618* 1. DETERMINE THE MOMENTUM COMPONENT OF DELTA/N* IN THE LAB. FRAME
10619 E10=SQRT(E(I1)**2+P(1,I1)**2+P(2,I1)**2+P(3,I1)**2)
10620 E20=SQRT(E(I2)**2+P(1,I2)**2+P(2,I2)**2+P(3,I2)**2)
10621 IF(iabs(LB(I2)) .EQ. 1 .OR. iabs(LB(I2)) .EQ. 2 .OR.
10622 & (iabs(LB(I2)) .GE. 6 .AND. iabs(LB(I2)) .LE. 17)) THEN
10623 E(I1)=0.
10624 I=I2
10625 ELSE
10626 E(I2)=0.
10627 I=I1
10628 ENDIF
10629 P(1,I)=P(1,I1)+P(1,I2)
10630 P(2,I)=P(2,I1)+P(2,I2)
10631 P(3,I)=P(3,I1)+P(3,I2)
10632* 2. DETERMINE THE MASS OF DELTA/N* BY USING THE REACTION KINEMATICS
10633 DM=SQRT((E10+E20)**2-P(1,I)**2-P(2,I)**2-P(3,I)**2)
10634 E(I)=DM
10635 RETURN
10636 END
10637*---------------------------------------------------------------------------
10638* PURPOSE : CALCULATE THE MASS AND MOMENTUM OF RHO RESONANCE
10639* AFTER PION + PION COLLISION
10640* DATE : NOV. 30,1994
10641 SUBROUTINE RHORES(I1,I2)
10642 PARAMETER (MAXSTR=150001,MAXR=1,
10643 1 AMN=0.939457,AMP=0.93828,
10644 2 AP1=0.13496,AP2=0.13957,AM0=1.232,PI=3.1415926)
10645 COMMON /AA/ R(3,MAXSTR)
10646cc SAVE /AA/
10647 COMMON /BB/ P(3,MAXSTR)
10648cc SAVE /BB/
10649 COMMON /CC/ E(MAXSTR)
10650cc SAVE /CC/
10651 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
10652cc SAVE /EE/
10653 COMMON /RUN/NUM
10654cc SAVE /RUN/
10655 COMMON /PA/RPION(3,MAXSTR,MAXR)
10656cc SAVE /PA/
10657 COMMON /PB/PPION(3,MAXSTR,MAXR)
10658cc SAVE /PB/
10659 COMMON /PC/EPION(MAXSTR,MAXR)
10660cc SAVE /PC/
10661 COMMON /PD/LPION(MAXSTR,MAXR)
10662cc SAVE /PD/
10663 SAVE
10664* 1. DETERMINE THE MOMENTUM COMPONENT OF THE RHO IN THE CMS OF NN FRAME
10665* WE LET I1 TO BE THE RHO AND ABSORB I2
10666 E10=SQRT(E(I1)**2+P(1,I1)**2+P(2,I1)**2+P(3,I1)**2)
10667 E20=SQRT(E(I2)**2+P(1,I2)**2+P(2,I2)**2+P(3,I2)**2)
10668 P(1,I1)=P(1,I1)+P(1,I2)
10669 P(2,I1)=P(2,I1)+P(2,I2)
10670 P(3,I1)=P(3,I1)+P(3,I2)
10671* 2. DETERMINE THE MASS OF THE RHO BY USING THE REACTION KINEMATICS
10672 DM=SQRT((E10+E20)**2-P(1,I1)**2-P(2,I1)**2-P(3,I1)**2)
10673 E(I1)=DM
10674 E(I2)=0
10675 RETURN
10676 END
10677*---------------------------------------------------------------------------
10678* PURPOSE : CALCULATE THE PION+NUCLEON CROSS SECTION ACCORDING TO THE
10679* BREIT-WIGNER FORMULA/(p*)**2
10680* VARIABLE : LA = 1 FOR DELTA RESONANCE
10681* LA = 0 FOR N*(1440) RESONANCE
10682* LA = 2 FRO N*(1535) RESONANCE
10683* DATE : JAN.29,1990
10684 REAL FUNCTION XNPI(I1,I2,LA,XMAX)
10685 PARAMETER (MAXSTR=150001,MAXR=1,
10686 1 AMN=0.939457,AMP=0.93828,
10687 2 AP1=0.13496,AP2=0.13957,AM0=1.232,PI=3.1415926)
10688 COMMON /AA/ R(3,MAXSTR)
10689cc SAVE /AA/
10690 COMMON /BB/ P(3,MAXSTR)
10691cc SAVE /BB/
10692 COMMON /CC/ E(MAXSTR)
10693cc SAVE /CC/
10694 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
10695cc SAVE /EE/
10696 COMMON /RUN/NUM
10697cc SAVE /RUN/
10698 COMMON /PA/RPION(3,MAXSTR,MAXR)
10699cc SAVE /PA/
10700 COMMON /PB/PPION(3,MAXSTR,MAXR)
10701cc SAVE /PB/
10702 COMMON /PC/EPION(MAXSTR,MAXR)
10703cc SAVE /PC/
10704 COMMON /PD/LPION(MAXSTR,MAXR)
10705cc SAVE /PD/
10706 SAVE
10707 AVMASS=0.5*(AMN+AMP)
10708 AVPI=(2.*AP2+AP1)/3.
10709* 1. DETERMINE THE MOMENTUM COMPONENT OF DELTA IN THE LAB. FRAME
10710 E10=SQRT(E(I1)**2+P(1,I1)**2+P(2,I1)**2+P(3,I1)**2)
10711 E20=SQRT(E(I2)**2+P(1,I2)**2+P(2,I2)**2+P(3,I2)**2)
10712 P1=P(1,I1)+P(1,I2)
10713 P2=P(2,I1)+P(2,I2)
10714 P3=P(3,I1)+P(3,I2)
10715* 2. DETERMINE THE MASS OF DELTA BY USING OF THE REACTION KINEMATICS
10716 DM=SQRT((E10+E20)**2-P1**2-P2**2-P3**2)
10717 IF(DM.LE.1.1) THEN
10718 XNPI=1.e-09
10719 RETURN
10720 ENDIF
10721* 3. DETERMINE THE PION+NUCLEON CROSS SECTION ACCORDING TO THE
10722* BREIT-WIGNER FORMULA IN UNIT OF FM**2
10723 IF(LA.EQ.1)THEN
10724 GAM=WIDTH(DM)
10725 F1=0.25*GAM**2/(0.25*GAM**2+(DM-1.232)**2)
10726 PDELT2=0.051622
10727 GO TO 10
10728 ENDIF
10729 IF(LA.EQ.0)THEN
10730 GAM=W1440(DM)
10731 F1=0.25*GAM**2/(0.25*GAM**2+(DM-1.440)**2)
10732 PDELT2=0.157897
10733 GO TO 10
10734 ENDIF
10735 IF(LA.EQ.2)THEN
10736 GAM=W1535(DM)
10737 F1=0.25*GAM**2/(0.25*GAM**2+(DM-1.535)**2)
10738 PDELT2=0.2181
10739 ENDIF
1074010 PSTAR2=((DM**2-AVMASS**2+AVPI**2)/(2.*DM))**2-AVPI**2
10741 IF(PSTAR2.LE.0.)THEN
10742 XNPI=1.e-09
10743 ELSE
10744* give the cross section in unit of fm**2
10745 XNPI=F1*(PDELT2/PSTAR2)*XMAX/10.
10746 ENDIF
10747 RETURN
10748 END
10749*------------------------------------------------------------------------------
10750*****************************************
10751 REAL FUNCTION SIGMA(SRT,ID,IOI,IOF)
10752*PURPOSE : THIS IS THE PROGRAM TO CALCULATE THE ISOSPIN DECOMPOSED CROSS
10753* SECTION BY USING OF B.J.VerWEST AND R.A.ARNDT'S PARAMETERIZATION
10754*REFERENCE: PHYS. REV. C25(1982)1979
10755*QUANTITIES: IOI -- INITIAL ISOSPIN OF THE TWO NUCLEON SYSTEM
10756* IOF -- FINAL ISOSPIN -------------------------
10757* ID -- =1 FOR DELTA RESORANCE
10758* =2 FOR N* RESORANCE
10759*DATE : MAY 15,1990
10760*****************************************
10761 PARAMETER (AMU=0.9383,AMP=0.1384,PI=3.1415926,HC=0.19733)
10762 SAVE
10763 IF(ID.EQ.1)THEN
10764 AMASS0=1.22
10765 T0 =0.12
10766 ELSE
10767 AMASS0=1.43
10768 T0 =0.2
10769 ENDIF
10770 IF((IOI.EQ.1).AND.(IOF.EQ.1))THEN
10771 ALFA=3.772
10772 BETA=1.262
10773 AM0=1.188
10774 T=0.09902
10775 ENDIF
10776 IF((IOI.EQ.1).AND.(IOF.EQ.0))THEN
10777 ALFA=15.28
10778 BETA=0.
10779 AM0=1.245
10780 T=0.1374
10781 ENDIF
10782 IF((IOI.EQ.0).AND.(IOF.EQ.1))THEN
10783 ALFA=146.3
10784 BETA=0.
10785 AM0=1.472
10786 T=0.02649
10787 ENDIF
10788 ZPLUS=(SRT-AMU-AMASS0)*2./T0
10789 ZMINUS=(AMU+AMP-AMASS0)*2./T0
10790 deln=ATAN(ZPLUS)-ATAN(ZMINUS)
10791 if(deln.eq.0)deln=1.E-06
10792 AMASS=AMASS0+(T0/4.)*ALOG((1.+ZPLUS**2)/(1.+ZMINUS**2))
10793 1 /deln
10794 S=SRT**2
10795 P2=S/4.-AMU**2
10796 S0=(AMU+AM0)**2
10797 P02=S0/4.-AMU**2
10798 P0=SQRT(P02)
10799 PR2=(S-(AMU-AMASS)**2)*(S-(AMU+AMASS)**2)/(4.*S)
10800 IF(PR2.GT.1.E-06)THEN
10801 PR=SQRT(PR2)
10802 ELSE
10803 PR=0.
10804 SIGMA=1.E-06
10805 RETURN
10806 ENDIF
10807 SS=AMASS**2
10808 Q2=(SS-(AMU-AMP)**2)*(SS-(AMU+AMP)**2)/(4.*SS)
10809 IF(Q2.GT.1.E-06)THEN
10810 Q=SQRT(Q2)
10811 ELSE
10812 Q=0.
10813 SIGMA=1.E-06
10814 RETURN
10815 ENDIF
10816 SS0=AM0**2
10817 Q02=(SS0-(AMU-AMP)**2)*(SS0-(AMU+AMP)**2)/(4.*SS0)
10818 Q0=SQRT(Q02)
10819 SIGMA=PI*(HC)**2/(2.*P2)*ALFA*(PR/P0)**BETA*AM0**2*T**2
10820 1 *(Q/Q0)**3/((SS-AM0**2)**2+AM0**2*T**2)
10821 SIGMA=SIGMA*10.
10822 IF(SIGMA.EQ.0)SIGMA=1.E-06
10823 RETURN
10824 END
10825
10826*****************************
10827 REAL FUNCTION DENOM(SRT,CON)
10828* NOTE: CON=1 FOR DELTA RESONANCE, CON=2 FOR N*(1440) RESONANCE
10829* con=-1 for N*(1535)
10830* PURPOSE : CALCULATE THE INTEGRAL IN THE DETAILED BALANCE
10831*
10832* DATE : NOV. 15, 1991
10833*******************************
10834 PARAMETER (AP1=0.13496,
10835 1 AP2=0.13957,PI=3.1415926,AVMASS=0.9383)
10836 SAVE
10837 AVPI=(AP1+2.*AP2)/3.
10838 AM0=1.232
10839 AMN=AVMASS
10840 AMP=AVPI
10841 AMAX=SRT-AVMASS
10842 AMIN=AVMASS+AVPI
10843 NMAX=200
10844 DMASS=(AMAX-AMIN)/FLOAT(NMAX)
10845 SUM=0.
10846 DO 10 I=1,NMAX+1
10847 DM=AMIN+FLOAT(I-1)*DMASS
10848 IF(CON.EQ.1.)THEN
10849 Q2=((DM**2-AMN**2+AMP**2)/(2.*DM))**2-AMP**2
10850 IF(Q2.GT.0.)THEN
10851 Q=SQRT(Q2)
10852 ELSE
10853 Q=1.E-06
10854 ENDIF
10855 TQ=0.47*(Q**3)/(AMP**2*(1.+0.6*(Q/AMP)**2))
10856 ELSE if(con.eq.2)then
10857 TQ=0.2
10858 AM0=1.44
10859 else if(con.eq.-1.)then
10860 tq=0.1
10861 am0=1.535
10862 ENDIF
10863 A1=4.*TQ*AM0**2/(AM0**2*TQ**2+(DM**2-AM0**2)**2)
10864 S=SRT**2
10865 P0=(S+DM**2-AMN**2)**2/(4.*S)-DM**2
10866 IF(P0.LE.0.)THEN
10867 P1=1.E-06
10868 ELSE
10869 P1=SQRT(P0)
10870 ENDIF
10871 F=DM*A1*P1
10872 IF((I.EQ.1).OR.(I.EQ.(NMAX+1)))THEN
10873 SUM=SUM+F*0.5
10874 ELSE
10875 SUM=SUM+F
10876 ENDIF
1087710 CONTINUE
10878 DENOM=SUM*DMASS/(2.*PI)
10879 RETURN
10880 END
10881**********************************
10882* subroutine : ang.FOR
10883* PURPOSE : Calculate the angular distribution of Delta production process
10884* DATE : Nov. 19, 1992
10885* REFERENCE: G. WOLF ET. AL., NUCL. PHYS. A517 (1990) 615
10886* Note: this function applies when srt is larger than 2.14 GeV,
10887* for less energetic reactions, we assume the angular distribution
10888* is isotropic.
10889***********************************
3006c44b 10890 real function anga(srt,iseed)
0119ef9a 10891 COMMON/RNDF77/NSEED
10892cc SAVE /RNDF77/
10893 SAVE
10894 ISEED=ISEED
10895c if(srt.le.2.14)then
10896c b1s=0.5
10897c b2s=0.
10898c endif
10899 if((srt.gt.2.14).and.(srt.le.2.4))then
10900 b1s=29.03-23.75*srt+4.865*srt**2
10901 b2s=-30.33+25.53*srt-5.301*srt**2
10902 endif
10903 if(srt.gt.2.4)then
10904 b1s=0.06
10905 b2s=0.4
10906 endif
10907 x=RANART(NSEED)
10908 p=b1s/b2s
10909 q=(2.*x-1.)*(b1s+b2s)/b2s
10910 IF((-q/2.+sqrt((q/2.)**2+(p/3.)**3)).GE.0.)THEN
10911 ang1=(-q/2.+sqrt((q/2.)**2+(p/3.)**3))**(1./3.)
10912 ELSE
10913 ang1=-(q/2.-sqrt((q/2.)**2+(p/3.)**3))**(1./3.)
10914 ENDIF
10915 IF((-q/2.-sqrt((q/2.)**2+(p/3.)**3).GE.0.))THEN
10916 ang2=(-q/2.-sqrt((q/2.)**2+(p/3.)**3))**(1./3.)
10917 ELSE
10918 ang2=-(q/2.+sqrt((q/2.)**2+(p/3.)**3))**(1./3.)
10919 ENDIF
3006c44b 10920 ANGA=ANG1+ANG2
0119ef9a 10921 return
10922 end
10923*--------------------------------------------------------------------------
10924*****subprogram * kaon production from pi+B collisions *******************
10925 real function PNLKA(srt)
10926 SAVE
10927* units: fm**2
10928***********************************C
10929 ala=1.116
10930 aka=0.498
10931 ana=0.939
10932 t1=ala+aka
10933 if(srt.le.t1) THEN
10934 Pnlka=0
10935 Else
10936 IF(SRT.LT.1.7)sbbk=(0.9/0.091)*(SRT-T1)
10937 IF(SRT.GE.1.7)sbbk=0.09/(SRT-1.6)
10938 Pnlka=0.25*sbbk
10939* give the cross section in units of fm**2
10940 pnlka=pnlka/10.
10941 endif
10942 return
10943 end
10944*-------------------------------------------------------------------------
10945*****subprogram * kaon production from pi+B collisions *******************
10946 real function PNSKA(srt)
10947 SAVE
10948***********************************
10949 if(srt.gt.3.0)then
10950 pnska=0
10951 return
10952 endif
10953 ala=1.116
10954 aka=0.498
10955 ana=0.939
10956 asa=1.197
10957 t1=asa+aka
10958 if(srt.le.t1) THEN
10959 Pnska=0
10960 return
10961 Endif
10962 IF(SRT.LT.1.9)SBB1=(0.7/0.218)*(SRT-T1)
10963 IF(SRT.GE.1.9)SBB1=0.14/(SRT-1.7)
10964 sbb2=0.
10965 if(srt.gT.1.682)sbb2=0.5*(1.-0.75*(srt-1.682))
10966 pnska=0.25*(sbb1+sbb2)
10967* give the cross section in fm**2
10968 pnska=pnska/10.
10969 return
10970 end
10971
10972********************************
10973*
10974* Kaon momentum distribution in baryon-baryon-->N lamda K process
10975*
10976* NOTE: dsima/dp is prototional to (1-p/p_max)(p/p_max)^2
10977* we use rejection method to generate kaon momentum
10978*
10979* Variables: Fkaon = F(p)/F_max
10980* srt = cms energy of the colliding pair,
10981* used to calculate the P_max
10982* Date: Feb. 8, 1994
10983*
10984* Reference: C. M. Ko et al.
10985********************************
10986 Real function fkaon(p,pmax)
10987 SAVE
10988 fmax=0.148
10989 if(pmax.eq.0.)pmax=0.000001
10990 fkaon=(1.-p/pmax)*(p/pmax)**2
10991 if(fkaon.gt.fmax)fkaon=fmax
10992 fkaon=fkaon/fmax
10993 return
10994 end
10995
10996*************************
10997* cross section for N*(1535) production in ND OR NN* collisions
10998* VARIABLES:
10999* LB1,LB2 ARE THE LABLES OF THE TWO COLLIDING PARTICLES
11000* SRT IS THE CMS ENERGY
11001* X1535 IS THE N*(1535) PRODUCTION CROSS SECTION
11002* NOTE THAT THE N*(1535) PRODUCTION CROSS SECTION IS 2 TIMES THE ETA
11003* PRODUCTION CROSS SECTION
11004* DATE: MAY 18, 1994
11005* ***********************
11006 Subroutine M1535(LB1,LB2,SRT,X1535)
11007 SAVE
11008 S0=2.424
11009 x1535=0.
11010 IF(SRT.LE.S0)RETURN
11011 SIGMA=2.*0.102*(SRT-S0)/(0.058+(SRT-S0)**2)
11012* I N*(1535) PRODUCTION IN NUCLEON-DELTA COLLISIONS
11013*(1) nD(++)->pN*(+)(1535), pD(-)->nN*(0)(1535),pD(+)-->N*(+)p
11014cbz11/25/98
11015c IF((LB1*LB2.EQ.18).OR.(LB1*LB2.EQ.6).
11016c 1 or.(lb1*lb2).eq.8)then
11017 IF((LB1*LB2.EQ.18.AND.(LB1.EQ.2.OR.LB2.EQ.2)).OR.
11018 & (LB1*LB2.EQ.6.AND.(LB1.EQ.1.OR.LB2.EQ.1)).or.
11019 & (lb1*lb2.eq.8.AND.(LB1.EQ.1.OR.LB2.EQ.1)))then
11020cbz11/25/98end
11021 X1535=SIGMA
11022 return
11023 ENDIF
11024*(2) pD(0)->pN*(0)(1535),pD(0)->nN*(+)(1535)
11025 IF(LB1*LB2.EQ.7)THEN
11026 X1535=3.*SIGMA
11027 RETURN
11028 ENDIF
11029* II N*(1535) PRODUCTION IN N*(1440)+NUCLEON REACTIONS
11030*(3) N*(+)(1440)p->N*(0+)(1535)p, N*(0)(1440)n->N*(0)(1535)
11031cbz11/25/98
11032c IF((LB1*LB2.EQ.11).OR.(LB1*LB2.EQ.20))THEN
11033 IF((LB1*LB2.EQ.11).OR.
11034 & (LB1*LB2.EQ.20.AND.(LB1.EQ.2.OR.LB2.EQ.2)))THEN
11035cbz11/25/98end
11036 X1535=SIGMA
11037 RETURN
11038 ENDIF
11039*(4) N*(0)(1440)p->N*(0+) or N*(+)(1440)n->N*(0+)(1535)
11040cbz11/25/98
11041c IF((LB1*LB2.EQ.10).OR.(LB1*LB2.EQ.22))X1535=3.*SIGMA
11042 IF((LB1*LB2.EQ.10.AND.(LB1.EQ.1.OR.LB2.EQ.1)).OR.
11043 & (LB1*LB2.EQ.22.AND.(LB1.EQ.2.OR.LB2.EQ.2)))
11044 & X1535=3.*SIGMA
11045cbz11/25/98end
11046 RETURN
11047 END
11048*************************
11049* cross section for N*(1535) production in NN collisions
11050* VARIABLES:
11051* LB1,LB2 ARE THE LABLES OF THE TWO COLLIDING PARTICLES
11052* SRT IS THE CMS ENERGY
11053* X1535 IS THE N*(1535) PRODUCTION CROSS SECTION
11054* NOTE THAT THE N*(1535) PRODUCTION CROSS SECTION IS 2 TIMES THE ETA
11055* PRODUCTION CROSS SECTION
11056* DATE: MAY 18, 1994
11057* ***********************
11058 Subroutine N1535(LB1,LB2,SRT,X1535)
11059 SAVE
11060 S0=2.424
11061 x1535=0.
11062 IF(SRT.LE.S0)RETURN
11063 SIGMA=2.*0.102*(SRT-S0)/(0.058+(SRT-S0)**2)
11064* I N*(1535) PRODUCTION IN NUCLEON-NUCLEON COLLISIONS
11065*(1) pp->pN*(+)(1535), nn->nN*(0)(1535)
11066cbdbg11/25/98
11067c IF((LB1*LB2.EQ.1).OR.(LB1*LB2.EQ.4))then
11068 IF((LB1*LB2.EQ.1).OR.
11069 & (LB1.EQ.2.AND.LB2.EQ.2))then
11070cbz11/25/98end
11071 X1535=SIGMA
11072 return
11073 endif
11074*(2) pn->pN*(0)(1535),pn->nN*(+)(1535)
11075 IF(LB1*LB2.EQ.2)then
11076 X1535=3.*SIGMA
11077 return
11078 endif
11079* III N*(1535) PRODUCTION IN DELTA+DELTA REACTIONS
11080* (5) D(++)+D(0), D(+)+D(+),D(+)+D(-),D(0)+D(0)
11081cbz11/25/98
11082c IF((LB1*LB2.EQ.63).OR.(LB1*LB2.EQ.64).OR.(LB1*LB2.EQ.48).
11083c 1 OR.(LB1*LB2.EQ.49))then
11084 IF((LB1*LB2.EQ.63.AND.(LB1.EQ.7.OR.LB2.EQ.7)).OR.
11085 & (LB1*LB2.EQ.64.AND.(LB1.EQ.8.OR.LB2.EQ.8)).OR.
11086 & (LB1*LB2.EQ.48.AND.(LB1.EQ.6.OR.LB2.EQ.6)).OR.
11087 & (LB1*LB2.EQ.49.AND.(LB1.EQ.7.OR.LB2.EQ.7)))then
11088cbz11/25/98end
11089 X1535=SIGMA
11090 return
11091 endif
11092* (6) D(++)+D(-),D(+)+D(0)
11093cbz11/25/98
11094c IF((LB1*LB2.EQ.54).OR.(LB1*LB2.EQ.56))then
11095 IF((LB1*LB2.EQ.54.AND.(LB1.EQ.6.OR.LB2.EQ.6)).OR.
11096 & (LB1*LB2.EQ.56.AND.(LB1.EQ.7.OR.LB2.EQ.7)))then
11097cbz11/25/98end
11098 X1535=3.*SIGMA
11099 return
11100 endif
11101* IV N*(1535) PRODUCTION IN N*(1440)+N*(1440) REACTIONS
11102cbz11/25/98
11103c IF((LB1*LB2.EQ.100).OR.(LB1*LB2.EQ.11*11))X1535=SIGMA
11104 IF((LB1.EQ.10.AND.LB2.EQ.10).OR.
11105 & (LB1.EQ.11.AND.LB2.EQ.11))X1535=SIGMA
11106c IF(LB1*LB2.EQ.110)X1535=3.*SIGMA
11107 IF(LB1*LB2.EQ.110.AND.(LB1.EQ.10.OR.LB2.EQ.10))X1535=3.*SIGMA
11108cbdbg11/25/98end
11109 RETURN
11110 END
11111************************************
11112* FUNCTION WA1(DMASS) GIVES THE A1 DECAY WIDTH
11113
11114 subroutine WIDA1(DMASS,rhomp,wa1,iseed)
11115 SAVE
11116c
11117 PIMASS=0.137265
11118 coupa = 14.8
11119c
11120 RHOMAX = DMASS-PIMASS-0.02
11121 IF(RHOMAX.LE.0)then
11122 rhomp=0.
11123c !! no decay
11124 wa1=-10.
11125 endif
11126 icount = 0
11127711 rhomp=RHOMAS(RHOMAX,ISEED)
11128 icount=icount+1
11129 if(dmass.le.(pimass+rhomp)) then
11130 if(icount.le.100) then
11131 goto 711
11132 else
11133 rhomp=0.
11134c !! no decay
11135 wa1=-10.
11136 return
11137 endif
11138 endif
11139 qqp2=(dmass**2-(rhomp+pimass)**2)*(dmass**2-(rhomp-pimass)**2)
11140 qqp=sqrt(qqp2)/(2.0*dmass)
11141 epi=sqrt(pimass**2+qqp**2)
11142 erho=sqrt(rhomp**2+qqp**2)
11143 epirho=2.0*(epi*erho+qqp**2)**2+rhomp**2*epi**2
11144 wa1=coupa**2*qqp*epirho/(24.0*3.1416*dmass**2)
11145 return
11146 end
11147************************************
11148* FUNCTION W1535(DMASS) GIVES THE N*(1535) DECAY WIDTH
11149c FOR A GIVEN N*(1535) MASS
11150* HERE THE FORMULA GIVEN BY KITAZOE IS USED
11151 REAL FUNCTION W1535(DMASS)
11152 SAVE
11153 AVMASS=0.938868
11154 PIMASS=0.137265
11155 AUX = 0.25*(DMASS**2-AVMASS**2-PIMASS**2)**2
11156 & -(AVMASS*PIMASS)**2
11157 IF (AUX .GT. 0.) THEN
11158 QAVAIL = SQRT(AUX / DMASS**2)
11159 ELSE
11160 QAVAIL = 1.E-06
11161 END IF
11162 W1535 = 0.15* QAVAIL/0.467
11163c W1535=0.15
11164 RETURN
11165 END
11166************************************
11167* FUNCTION W1440(DMASS) GIVES THE N*(1440) DECAY WIDTH
11168c FOR A GIVEN N*(1535) MASS
11169* HERE THE FORMULA GIVEN BY KITAZOE IS USED
11170 REAL FUNCTION W1440(DMASS)
11171 SAVE
11172 AVMASS=0.938868
11173 PIMASS=0.137265
11174 AUX = 0.25*(DMASS**2-AVMASS**2-PIMASS**2)**2
11175 & -(AVMASS*PIMASS)**2
11176 IF (AUX .GT. 0.) THEN
11177 QAVAIL = SQRT(AUX)/DMASS
11178 ELSE
11179 QAVAIL = 1.E-06
11180 END IF
11181c w1440=0.2
11182 W1440 = 0.2* (QAVAIL/0.397)**3
11183 RETURN
11184 END
11185****************
11186* PURPOSE : CALCULATE THE PION(ETA)+NUCLEON CROSS SECTION
11187* ACCORDING TO THE BREIT-WIGNER FORMULA,
11188* NOTE THAT N*(1535) IS S_11
11189* VARIABLE : LA = 1 FOR PI+N
11190* LA = 0 FOR ETA+N
11191* DATE : MAY 16, 1994
11192****************
11193 REAL FUNCTION XN1535(I1,I2,LA)
11194 PARAMETER (MAXSTR=150001,MAXR=1,
11195 1 AMN=0.939457,AMP=0.93828,ETAM=0.5475,
11196 2 AP1=0.13496,AP2=0.13957,AM0=1.232,PI=3.1415926)
11197 COMMON /AA/ R(3,MAXSTR)
11198cc SAVE /AA/
11199 COMMON /BB/ P(3,MAXSTR)
11200cc SAVE /BB/
11201 COMMON /CC/ E(MAXSTR)
11202cc SAVE /CC/
11203 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
11204cc SAVE /EE/
11205 COMMON /RUN/NUM
11206cc SAVE /RUN/
11207 COMMON /PA/RPION(3,MAXSTR,MAXR)
11208cc SAVE /PA/
11209 COMMON /PB/PPION(3,MAXSTR,MAXR)
11210cc SAVE /PB/
11211 COMMON /PC/EPION(MAXSTR,MAXR)
11212cc SAVE /PC/
11213 COMMON /PD/LPION(MAXSTR,MAXR)
11214cc SAVE /PD/
11215 SAVE
11216 AVMASS=0.5*(AMN+AMP)
11217 AVPI=(2.*AP2+AP1)/3.
11218* 1. DETERMINE THE MOMENTUM COMPONENT OF N*(1535) IN THE LAB. FRAME
11219 E10=SQRT(E(I1)**2+P(1,I1)**2+P(2,I1)**2+P(3,I1)**2)
11220 E20=SQRT(E(I2)**2+P(1,I2)**2+P(2,I2)**2+P(3,I2)**2)
11221 P1=P(1,I1)+P(1,I2)
11222 P2=P(2,I1)+P(2,I2)
11223 P3=P(3,I1)+P(3,I2)
11224* 2. DETERMINE THE MASS OF DELTA BY USING OF THE REACTION KINEMATICS
11225 DM=SQRT((E10+E20)**2-P1**2-P2**2-P3**2)
11226 IF(DM.LE.1.1) THEN
11227 XN1535=1.E-06
11228 RETURN
11229 ENDIF
11230* 3. DETERMINE THE PION(ETA)+NUCLEON->N*(1535) CROSS SECTION ACCORDING TO THE
11231* BREIT-WIGNER FORMULA IN UNIT OF FM**2
11232 GAM=W1535(DM)
11233 GAM0=0.15
11234 F1=0.25*GAM0**2/(0.25*GAM**2+(DM-1.535)**2)
11235 IF(LA.EQ.1)THEN
11236 XMAX=11.3
11237 ELSE
11238 XMAX=74.
11239 ENDIF
11240 XN1535=F1*XMAX/10.
11241 RETURN
11242 END
11243***************************8
11244*FUNCTION FDE(DMASS) GIVES DELTA MASS DISTRIBUTION BY USING OF
11245*KITAZOE'S FORMULA
11246 REAL FUNCTION FDELTA(DMASS)
11247 SAVE
11248 AMN=0.938869
11249 AVPI=0.13803333
11250 AM0=1.232
11251 FD=0.25*WIDTH(DMASS)**2/((DMASS-1.232)**2
11252 1 +0.25*WIDTH(DMASS)**2)
11253 FDELTA=FD
11254 RETURN
11255 END
11256* FUNCTION WIDTH(DMASS) GIVES THE DELTA DECAY WIDTH FOR A GIVEN DELTA MASS
11257* HERE THE FORMULA GIVEN BY KITAZOE IS USED
11258 REAL FUNCTION WIDTH(DMASS)
11259 SAVE
11260 AVMASS=0.938868
11261 PIMASS=0.137265
11262 AUX = 0.25*(DMASS**2-AVMASS**2-PIMASS**2)**2
11263 & -(AVMASS*PIMASS)**2
11264 IF (AUX .GT. 0.) THEN
11265 QAVAIL = SQRT(AUX / DMASS**2)
11266 ELSE
11267 QAVAIL = 1.E-06
11268 END IF
11269 WIDTH = 0.47 * QAVAIL**3 /
11270 & (PIMASS**2 * (1.+0.6*(QAVAIL/PIMASS)**2))
11271c width=0.115
11272 RETURN
11273 END
11274************************************
11275 SUBROUTINE ddp2(SRT,ISEED,PX,PY,PZ,DM1,PNX,
11276 & PNY,PNZ,DM2,PPX,PPY,PPZ,icou1)
11277* PURPOSE : CALCULATE MOMENTUM OF PARTICLES IN THE FINAL SATAT FROM
11278* THE PROCESS N+N--->D1+D2+PION
11279* DATE : July 25, 1994
11280* Generate the masses and momentum for particles in the NN-->DDpi process
11281* for a given center of mass energy srt, the momenta are given in the center
11282* of mass of the NN
11283*****************************************
11284 COMMON/TABLE/ xarray(0:1000),earray(0:1000)
11285cc SAVE /TABLE/
11286 COMMON/RNDF77/NSEED
11287cc SAVE /RNDF77/
11288 SAVE
11289 icou1=0
11290 pi=3.1415926
11291 AMN=938.925/1000.
11292 AMP=137.265/1000.
11293* (1) GENGRATE THE MASS OF DELTA1 AND DELTA2 USING
11294 srt1=srt-amp-0.02
11295 ntrym=0
112968 call Rmasdd(srt1,1.232,1.232,1.08,
11297 & 1.08,ISEED,1,dm1,dm2)
11298 ntrym=ntrym+1
11299* CONSTANTS FOR GENERATING THE LONGITUDINAL MOMENTUM
11300* FOR ONE OF THE RESONANCES
11301 V=0.43
11302 W=-0.84
11303* (2) Generate the transverse momentum
11304* OF DELTA1
11305* (2.1) estimate the maximum transverse momentum
11306 PTMAX2=(SRT**2-(DM1+DM2+AMP)**2)*
11307 1 (SRT**2-(DM1-AMP-DM2)**2)/4./SRT**2
11308 if(ptmax2.le.0)go to 8
11309 PTMAX=SQRT(PTMAX2)*1./3.
113107 PT=PTR(PTMAX,ISEED)
11311* (3.1) THE MAXIMUM LONGITUDINAL MOMENTUM IS
11312 PZMAX2=(SRT**2-(DM1+DM2+AMP)**2)*
11313 1 (SRT**2-(DM1-AMP-DM2)**2)/4./SRT**2-PT**2
11314 IF((PZMAX2.LT.0.).and.ntrym.le.100)then
11315 go to 7
11316 else
11317 pzmax2=1.E-09
11318 endif
11319 PZMAX=SQRT(PZMAX2)
11320 XMAX=2.*PZMAX/SRT
11321* (3.2) THE GENERATED X IS
11322* THE DSTRIBUTION HAS A MAXIMUM AT X0=-V/(2*w), f(X0)=1.056
11323 ntryx=0
11324 fmax00=1.056
11325 x00=0.26
11326 if(abs(xmax).gt.0.26)then
11327 f00=fmax00
11328 else
11329 f00=1.+v*abs(xmax)+w*xmax**2
11330 endif
113319 X=XMAX*(1.-2.*RANART(NSEED))
11332 ntryx=ntryx+1
11333 xratio=(1.+V*ABS(X)+W*X**2)/f00
11334clin-8/17/00 IF(xratio.LT.RANART(NSEED).and.ntryx.le.50)GO TO 9
11335 IF(xratio.LT.RANART(NSEED).and.ntryx.le.50)GO TO 9
11336* (3.5) THE PZ IS
11337 PZ=0.5*SRT*X
11338* The x and y components of the deltA1
11339 fai=2.*pi*RANART(NSEED)
11340 Px=pt*cos(fai)
11341 Py=pt*sin(fai)
11342* find the momentum of delta2 and pion
11343* the energy of the delta1
11344 ek=sqrt(dm1**2+PT**2+Pz**2)
11345* (1) Generate the momentum of the delta2 in the cms of delta2 and pion
11346* the energy of the cms of DP
11347 eln=srt-ek
11348 IF(ELN.lE.0)then
11349 icou1=-1
11350 return
11351 endif
11352* beta and gamma of the cms of delta2+pion
11353 bx=-Px/eln
11354 by=-Py/eln
11355 bz=-Pz/eln
11356 ga=1./sqrt(1.-bx**2-by**2-bz**2)
11357* the momentum of delta2 and pion in their cms frame
11358 elnc=eln/ga
11359 pn2=((elnc**2+dm2**2-amp**2)/(2.*elnc))**2-dm2**2
11360 if(pn2.le.0)then
11361 icou1=-1
11362 return
11363 endif
11364 pn=sqrt(pn2)
11365
11366clin-10/25/02 get rid of argument usage mismatch in PTR():
11367 xptr=0.33*PN
11368c PNT=PTR(0.33*PN,ISEED)
11369 PNT=PTR(xptr,ISEED)
11370clin-10/25/02-end
11371
11372 fain=2.*pi*RANART(NSEED)
11373 pnx=pnT*cos(fain)
11374 pny=pnT*sin(fain)
11375 SIG=1
11376 IF(X.GT.0)SIG=-1
11377 pnz=SIG*SQRT(pn**2-PNT**2)
11378 en=sqrt(dm2**2+pnx**2+pny**2+pnz**2)
11379* (2) the momentum for the pion
11380 ppx=-pnx
11381 ppy=-pny
11382 ppz=-pnz
11383 ep=sqrt(amp**2+ppx**2+ppy**2+ppz**2)
11384* (3) for the delta2, LORENTZ-TRANSFORMATION INTO nn cms FRAME
11385 PBETA = PnX*BX + PnY*By+ PnZ*Bz
11386 TRANS0 = GA * ( GA * PBETA / (GA + 1.) + En )
11387 Pnx = BX * TRANS0 + PnX
11388 Pny = BY * TRANS0 + PnY
11389 Pnz = BZ * TRANS0 + PnZ
11390* (4) for the pion, LORENTZ-TRANSFORMATION INTO nn cms FRAME
11391 if(ep.eq.0.)ep=1.E-09
11392 PBETA = PPX*BX + PPY*By+ PPZ*Bz
11393 TRANS0 = GA * ( GA * PBETA / (GA + 1.) + EP )
11394 PPx = BX * TRANS0 + PPX
11395 PPy = BY * TRANS0 + PPY
11396 PPz = BZ * TRANS0 + PPZ
11397 return
11398 end
11399****************************************
11400 SUBROUTINE ddrho(SRT,ISEED,PX,PY,PZ,DM1,PNX,
11401 & PNY,PNZ,DM2,PPX,PPY,PPZ,amp,icou1)
11402* PURPOSE : CALCULATE MOMENTUM OF PARTICLES IN THE FINAL SATAT FROM
11403* THE PROCESS N+N--->D1+D2+rho
11404* DATE : Nov.5, 1994
11405* Generate the masses and momentum for particles in the NN-->DDrho process
11406* for a given center of mass energy srt, the momenta are given in the center
11407* of mass of the NN
11408*****************************************
11409 COMMON/TABLE/ xarray(0:1000),earray(0:1000)
11410cc SAVE /TABLE/
11411 COMMON/RNDF77/NSEED
11412cc SAVE /RNDF77/
11413 SAVE
11414 icou1=0
11415 pi=3.1415926
11416 AMN=938.925/1000.
11417 AMP=770./1000.
11418* (1) GENGRATE THE MASS OF DELTA1 AND DELTA2 USING
11419 srt1=srt-amp-0.02
11420 ntrym=0
114218 call Rmasdd(srt1,1.232,1.232,1.08,
11422 & 1.08,ISEED,1,dm1,dm2)
11423 ntrym=ntrym+1
11424* GENERATE THE MASS FOR THE RHO
11425 RHOMAX = SRT-DM1-DM2-0.02
11426 IF(RHOMAX.LE.0.and.ntrym.le.20)go to 8
11427 AMP=RHOMAS(RHOMAX,ISEED)
11428* CONSTANTS FOR GENERATING THE LONGITUDINAL MOMENTUM
11429* FOR ONE OF THE RESONANCES
11430 V=0.43
11431 W=-0.84
11432* (2) Generate the transverse momentum
11433* OF DELTA1
11434* (2.1) estimate the maximum transverse momentum
11435 PTMAX2=(SRT**2-(DM1+DM2+AMP)**2)*
11436 1 (SRT**2-(DM1-AMP-DM2)**2)/4./SRT**2
11437 PTMAX=SQRT(PTMAX2)*1./3.
114387 PT=PTR(PTMAX,ISEED)
11439* (3) GENGRATE THE LONGITUDINAL MOMENTUM FOR DM1
11440* USING THE GIVEN DISTRIBUTION
11441* (3.1) THE MAXIMUM LONGITUDINAL MOMENTUM IS
11442 PZMAX2=(SRT**2-(DM1+DM2+AMP)**2)*
11443 1 (SRT**2-(DM1-AMP-DM2)**2)/4./SRT**2-PT**2
11444 IF((PZMAX2.LT.0.).and.ntrym.le.100)then
11445 go to 7
11446 else
11447 pzmax2=1.E-06
11448 endif
11449 PZMAX=SQRT(PZMAX2)
11450 XMAX=2.*PZMAX/SRT
11451* (3.2) THE GENERATED X IS
11452* THE DSTRIBUTION HAS A MAXIMUM AT X0=-V/(2*w), f(X0)=1.056
11453 ntryx=0
11454 fmax00=1.056
11455 x00=0.26
11456 if(abs(xmax).gt.0.26)then
11457 f00=fmax00
11458 else
11459 f00=1.+v*abs(xmax)+w*xmax**2
11460 endif
114619 X=XMAX*(1.-2.*RANART(NSEED))
11462 ntryx=ntryx+1
11463 xratio=(1.+V*ABS(X)+W*X**2)/f00
11464clin-8/17/00 IF(xratio.LT.RANART(NSEED).and.ntryx.le.50)GO TO 9
11465 IF(xratio.LT.RANART(NSEED).and.ntryx.le.50)GO TO 9
11466* (3.5) THE PZ IS
11467 PZ=0.5*SRT*X
11468* The x and y components of the delta1
11469 fai=2.*pi*RANART(NSEED)
11470 Px=pt*cos(fai)
11471 Py=pt*sin(fai)
11472* find the momentum of delta2 and rho
11473* the energy of the delta1
11474 ek=sqrt(dm1**2+PT**2+Pz**2)
11475* (1) Generate the momentum of the delta2 in the cms of delta2 and rho
11476* the energy of the cms of Drho
11477 eln=srt-ek
11478 IF(ELN.lE.0)then
11479 icou1=-1
11480 return
11481 endif
11482* beta and gamma of the cms of delta2 and rho
11483 bx=-Px/eln
11484 by=-Py/eln
11485 bz=-Pz/eln
11486 ga=1./sqrt(1.-bx**2-by**2-bz**2)
11487 elnc=eln/ga
11488 pn2=((elnc**2+dm2**2-amp**2)/(2.*elnc))**2-dm2**2
11489 if(pn2.le.0)then
11490 icou1=-1
11491 return
11492 endif
11493 pn=sqrt(pn2)
11494
11495clin-10/25/02 get rid of argument usage mismatch in PTR():
11496 xptr=0.33*PN
11497c PNT=PTR(0.33*PN,ISEED)
11498 PNT=PTR(xptr,ISEED)
11499clin-10/25/02-end
11500
11501 fain=2.*pi*RANART(NSEED)
11502 pnx=pnT*cos(fain)
11503 pny=pnT*sin(fain)
11504 SIG=1
11505 IF(X.GT.0)SIG=-1
11506 pnz=SIG*SQRT(pn**2-PNT**2)
11507 en=sqrt(dm2**2+pnx**2+pny**2+pnz**2)
11508* (2) the momentum for the rho
11509 ppx=-pnx
11510 ppy=-pny
11511 ppz=-pnz
11512 ep=sqrt(amp**2+ppx**2+ppy**2+ppz**2)
11513* (3) for the delta2, LORENTZ-TRANSFORMATION INTO nn cms FRAME
11514 PBETA = PnX*BX + PnY*By+ PnZ*Bz
11515 TRANS0 = GA * ( GA * PBETA / (GA + 1.) + En )
11516 Pnx = BX * TRANS0 + PnX
11517 Pny = BY * TRANS0 + PnY
11518 Pnz = BZ * TRANS0 + PnZ
11519* (4) for the rho, LORENTZ-TRANSFORMATION INTO nn cms FRAME
11520 if(ep.eq.0.)ep=1.e-09
11521 PBETA = PPX*BX + PPY*By+ PPZ*Bz
11522 TRANS0 = GA * ( GA * PBETA / (GA + 1.) + EP )
11523 PPx = BX * TRANS0 + PPX
11524 PPy = BY * TRANS0 + PPY
11525 PPz = BZ * TRANS0 + PPZ
11526 return
11527 end
11528****************************************
11529 SUBROUTINE pprho(SRT,ISEED,PX,PY,PZ,DM1,PNX,
11530 & PNY,PNZ,DM2,PPX,PPY,PPZ,amp,icou1)
11531* PURPOSE : CALCULATE MOMENTUM OF PARTICLES IN THE FINAL SATAT FROM
11532* THE PROCESS N+N--->N1+N2+rho
11533* DATE : Nov.5, 1994
11534* Generate the masses and momentum for particles in the NN--> process
11535* for a given center of mass energy srt, the momenta are given in the center
11536* of mass of the NN
11537*****************************************
11538 COMMON/TABLE/ xarray(0:1000),earray(0:1000)
11539cc SAVE /TABLE/
11540 COMMON/RNDF77/NSEED
11541cc SAVE /RNDF77/
11542 SAVE
11543 ntrym=0
11544 icou1=0
11545 pi=3.1415926
11546 AMN=938.925/1000.
11547* AMP=770./1000.
11548 DM1=amn
11549 DM2=amn
11550* GENERATE THE MASS FOR THE RHO
11551 RHOMAX=SRT-DM1-DM2-0.02
11552 IF(RHOMAX.LE.0)THEN
11553 ICOU=-1
11554 RETURN
11555 ENDIF
11556 AMP=RHOMAS(RHOMAX,ISEED)
11557* CONSTANTS FOR GENERATING THE LONGITUDINAL MOMENTUM
11558* FOR ONE OF THE nucleons
11559 V=0.43
11560 W=-0.84
11561* (2) Generate the transverse momentum
11562* OF p1
11563* (2.1) estimate the maximum transverse momentum
11564 PTMAX2=(SRT**2-(DM1+DM2+AMP)**2)*
11565 1 (SRT**2-(DM1-AMP-DM2)**2)/4./SRT**2
11566 PTMAX=SQRT(PTMAX2)*1./3.
115677 PT=PTR(PTMAX,ISEED)
11568* (3) GENGRATE THE LONGITUDINAL MOMENTUM FOR DM1
11569* USING THE GIVEN DISTRIBUTION
11570* (3.1) THE MAXIMUM LONGITUDINAL MOMENTUM IS
11571 PZMAX2=(SRT**2-(DM1+DM2+AMP)**2)*
11572 1 (SRT**2-(DM1-AMP-DM2)**2)/4./SRT**2-PT**2
11573 NTRYM=NTRYM+1
11574 IF((PZMAX2.LT.0.).and.ntrym.le.100)then
11575 go to 7
11576 else
11577 pzmax2=1.E-06
11578 endif
11579 PZMAX=SQRT(PZMAX2)
11580 XMAX=2.*PZMAX/SRT
11581* (3.2) THE GENERATED X IS
11582* THE DSTRIBUTION HAS A MAXIMUM AT X0=-V/(2*w), f(X0)=1.056
11583 ntryx=0
11584 fmax00=1.056
11585 x00=0.26
11586 if(abs(xmax).gt.0.26)then
11587 f00=fmax00
11588 else
11589 f00=1.+v*abs(xmax)+w*xmax**2
11590 endif
115919 X=XMAX*(1.-2.*RANART(NSEED))
11592 ntryx=ntryx+1
11593 xratio=(1.+V*ABS(X)+W*X**2)/f00
11594clin-8/17/00 IF(xratio.LT.RANART(NSEED).and.ntryx.le.50)GO TO 9
11595 IF(xratio.LT.RANART(NSEED).and.ntryx.le.50)GO TO 9
11596* (3.5) THE PZ IS
11597 PZ=0.5*SRT*X
11598* The x and y components of the delta1
11599 fai=2.*pi*RANART(NSEED)
11600 Px=pt*cos(fai)
11601 Py=pt*sin(fai)
11602* find the momentum of delta2 and rho
11603* the energy of the delta1
11604 ek=sqrt(dm1**2+PT**2+Pz**2)
11605* (1) Generate the momentum of the delta2 in the cms of delta2 and rho
11606* the energy of the cms of Drho
11607 eln=srt-ek
11608 IF(ELN.lE.0)then
11609 icou1=-1
11610 return
11611 endif
11612* beta and gamma of the cms of the two partciles
11613 bx=-Px/eln
11614 by=-Py/eln
11615 bz=-Pz/eln
11616 ga=1./sqrt(1.-bx**2-by**2-bz**2)
11617 elnc=eln/ga
11618 pn2=((elnc**2+dm2**2-amp**2)/(2.*elnc))**2-dm2**2
11619 if(pn2.le.0)then
11620 icou1=-1
11621 return
11622 endif
11623 pn=sqrt(pn2)
11624
11625clin-10/25/02 get rid of argument usage mismatch in PTR():
11626 xptr=0.33*PN
11627c PNT=PTR(0.33*PN,ISEED)
11628 PNT=PTR(xptr,ISEED)
11629clin-10/25/02-end
11630
11631 fain=2.*pi*RANART(NSEED)
11632 pnx=pnT*cos(fain)
11633 pny=pnT*sin(fain)
11634 SIG=1
11635 IF(X.GT.0)SIG=-1
11636 pnz=SIG*SQRT(pn**2-PNT**2)
11637 en=sqrt(dm2**2+pnx**2+pny**2+pnz**2)
11638* (2) the momentum for the rho
11639 ppx=-pnx
11640 ppy=-pny
11641 ppz=-pnz
11642 ep=sqrt(amp**2+ppx**2+ppy**2+ppz**2)
11643* (3) for the delta2, LORENTZ-TRANSFORMATION INTO nn cms FRAME
11644 PBETA = PnX*BX + PnY*By+ PnZ*Bz
11645 TRANS0 = GA * ( GA * PBETA / (GA + 1.) + En )
11646 Pnx = BX * TRANS0 + PnX
11647 Pny = BY * TRANS0 + PnY
11648 Pnz = BZ * TRANS0 + PnZ
11649* (4) for the rho, LORENTZ-TRANSFORMATION INTO nn cms FRAME
11650 if(ep.eq.0.)ep=1.e-09
11651 PBETA = PPX*BX + PPY*By+ PPZ*Bz
11652 TRANS0 = GA * ( GA * PBETA / (GA + 1.) + EP )
11653 PPx = BX * TRANS0 + PPX
11654 PPy = BY * TRANS0 + PPY
11655 PPz = BZ * TRANS0 + PPZ
11656 return
11657 end
11658***************************8
11659****************************************
11660 SUBROUTINE ppomga(SRT,ISEED,PX,PY,PZ,DM1,PNX,
11661 & PNY,PNZ,DM2,PPX,PPY,PPZ,icou1)
11662* PURPOSE : CALCULATE MOMENTUM OF PARTICLES IN THE FINAL SATAT FROM
11663* THE PROCESS N+N--->N1+N2+OMEGA
11664* DATE : Nov.5, 1994
11665* Generate the masses and momentum for particles in the NN--> process
11666* for a given center of mass energy srt, the momenta are given in the center
11667* of mass of the NN
11668*****************************************
11669 COMMON/TABLE/ xarray(0:1000),earray(0:1000)
11670cc SAVE /TABLE/
11671 COMMON/RNDF77/NSEED
11672cc SAVE /RNDF77/
11673 SAVE
11674 ntrym=0
11675 icou1=0
11676 pi=3.1415926
11677 AMN=938.925/1000.
11678 AMP=782./1000.
11679 DM1=amn
11680 DM2=amn
11681* CONSTANTS FOR GENERATING THE LONGITUDINAL MOMENTUM
11682* FOR ONE OF THE nucleons
11683 V=0.43
11684 W=-0.84
11685* (2) Generate the transverse momentum
11686* OF p1
11687* (2.1) estimate the maximum transverse momentum
11688 PTMAX2=(SRT**2-(DM1+DM2+AMP)**2)*
11689 1 (SRT**2-(DM1-AMP-DM2)**2)/4./SRT**2
11690 PTMAX=SQRT(PTMAX2)*1./3.
116917 PT=PTR(PTMAX,ISEED)
11692* (3) GENGRATE THE LONGITUDINAL MOMENTUM FOR DM1
11693* USING THE GIVEN DISTRIBUTION
11694* (3.1) THE MAXIMUM LONGITUDINAL MOMENTUM IS
11695 PZMAX2=(SRT**2-(DM1+DM2+AMP)**2)*
11696 1 (SRT**2-(DM1-AMP-DM2)**2)/4./SRT**2-PT**2
11697 NTRYM=NTRYM+1
11698 IF((PZMAX2.LT.0.).and.ntrym.le.100)then
11699 go to 7
11700 else
11701 pzmax2=1.E-09
11702 endif
11703 PZMAX=SQRT(PZMAX2)
11704 XMAX=2.*PZMAX/SRT
11705* (3.2) THE GENERATED X IS
11706* THE DSTRIBUTION HAS A MAXIMUM AT X0=-V/(2*w), f(X0)=1.056
11707 ntryx=0
11708 fmax00=1.056
11709 x00=0.26
11710 if(abs(xmax).gt.0.26)then
11711 f00=fmax00
11712 else
11713 f00=1.+v*abs(xmax)+w*xmax**2
11714 endif
117159 X=XMAX*(1.-2.*RANART(NSEED))
11716 ntryx=ntryx+1
11717 xratio=(1.+V*ABS(X)+W*X**2)/f00
11718clin-8/17/00 IF(xratio.LT.RANART(NSEED).and.ntryx.le.50)GO TO 9
11719 IF(xratio.LT.RANART(NSEED).and.ntryx.le.50)GO TO 9
11720* (3.5) THE PZ IS
11721 PZ=0.5*SRT*X
11722* The x and y components of the delta1
11723 fai=2.*pi*RANART(NSEED)
11724 Px=pt*cos(fai)
11725 Py=pt*sin(fai)
11726* find the momentum of delta2 and rho
11727* the energy of the delta1
11728 ek=sqrt(dm1**2+PT**2+Pz**2)
11729* (1) Generate the momentum of the delta2 in the cms of delta2 and rho
11730* the energy of the cms of Drho
11731 eln=srt-ek
11732 IF(ELN.lE.0)then
11733 icou1=-1
11734 return
11735 endif
11736 bx=-Px/eln
11737 by=-Py/eln
11738 bz=-Pz/eln
11739 ga=1./sqrt(1.-bx**2-by**2-bz**2)
11740 elnc=eln/ga
11741 pn2=((elnc**2+dm2**2-amp**2)/(2.*elnc))**2-dm2**2
11742 if(pn2.le.0)then
11743 icou1=-1
11744 return
11745 endif
11746 pn=sqrt(pn2)
11747
11748clin-10/25/02 get rid of argument usage mismatch in PTR():
11749 xptr=0.33*PN
11750c PNT=PTR(0.33*PN,ISEED)
11751 PNT=PTR(xptr,ISEED)
11752clin-10/25/02-end
11753
11754 fain=2.*pi*RANART(NSEED)
11755 pnx=pnT*cos(fain)
11756 pny=pnT*sin(fain)
11757 SIG=1
11758 IF(X.GT.0)SIG=-1
11759 pnz=SIG*SQRT(pn**2-PNT**2)
11760 en=sqrt(dm2**2+pnx**2+pny**2+pnz**2)
11761* (2) the momentum for the rho
11762 ppx=-pnx
11763 ppy=-pny
11764 ppz=-pnz
11765 ep=sqrt(amp**2+ppx**2+ppy**2+ppz**2)
11766* (3) for the delta2, LORENTZ-TRANSFORMATION INTO nn cms FRAME
11767 PBETA = PnX*BX + PnY*By+ PnZ*Bz
11768 TRANS0 = GA * ( GA * PBETA / (GA + 1.) + En )
11769 Pnx = BX * TRANS0 + PnX
11770 Pny = BY * TRANS0 + PnY
11771 Pnz = BZ * TRANS0 + PnZ
11772* (4) for the rho, LORENTZ-TRANSFORMATION INTO nn cms FRAME
11773 if(ep.eq.0.)ep=1.E-09
11774 PBETA = PPX*BX + PPY*By+ PPZ*Bz
11775 TRANS0 = GA * ( GA * PBETA / (GA + 1.) + EP )
11776 PPx = BX * TRANS0 + PPX
11777 PPy = BY * TRANS0 + PPY
11778 PPz = BZ * TRANS0 + PPZ
11779 return
11780 end
11781***************************8
11782***************************8
11783* DELTA MASS GENERATOR
11784 REAL FUNCTION RMASS(DMAX,ISEED)
11785 COMMON/RNDF77/NSEED
11786cc SAVE /RNDF77/
11787 SAVE
11788 ISEED=ISEED
11789* THE MINIMUM MASS FOR DELTA
11790 DMIN = 1.078
11791* Delta(1232) production
11792 IF(DMAX.LT.1.232) THEN
11793 FM=FDELTA(DMAX)
11794 ELSE
11795 FM=1.
11796 ENDIF
11797 IF(FM.EQ.0.)FM=1.E-06
11798 NTRY1=0
1179910 DM = RANART(NSEED) * (DMAX-DMIN) + DMIN
11800 NTRY1=NTRY1+1
11801 IF((RANART(NSEED) .GT. FDELTA(DM)/FM).AND.
11802 1 (NTRY1.LE.10)) GOTO 10
11803clin-2/26/03 sometimes Delta mass can reach very high values (e.g. 15.GeV),
11804c thus violating the thresh of the collision which produces it
11805c and leads to large violation of energy conservation.
11806c To limit the above, limit the Delta mass below a certain value
11807c (here taken as its central value + 2* B-W fullwidth):
11808 if(dm.gt.1.47) goto 10
11809
11810 RMASS=DM
11811 RETURN
11812 END
11813
11814*------------------------------------------------------------------
11815* THE Breit Wigner FORMULA
11816 REAL FUNCTION FRHO(DMASS)
11817 SAVE
11818 AM0=0.77
11819 WID=0.153
11820 FD=0.25*wid**2/((DMASS-AM0)**2+0.25*WID**2)
11821 FRHO=FD
11822 RETURN
11823 END
11824***************************8
11825* RHO MASS GENERATOR
11826 REAL FUNCTION RHOMAS(DMAX,ISEED)
11827 COMMON/RNDF77/NSEED
11828cc SAVE /RNDF77/
11829 SAVE
11830 ISEED=ISEED
11831* THE MINIMUM MASS FOR DELTA
11832 DMIN = 0.28
11833* RHO(770) production
11834 IF(DMAX.LT.0.77) THEN
11835 FM=FRHO(DMAX)
11836 ELSE
11837 FM=1.
11838 ENDIF
11839 IF(FM.EQ.0.)FM=1.E-06
11840 NTRY1=0
1184110 DM = RANART(NSEED) * (DMAX-DMIN) + DMIN
11842 NTRY1=NTRY1+1
11843 IF((RANART(NSEED) .GT. FRHO(DM)/FM).AND.
11844 1 (NTRY1.LE.10)) GOTO 10
11845clin-2/26/03 limit the rho mass below a certain value
11846c (here taken as its central value + 2* B-W fullwidth):
11847 if(dm.gt.1.07) goto 10
11848
11849 RHOMAS=DM
11850 RETURN
11851 END
11852******************************************
11853* for pp-->pp+2pi
11854c real*4 function X2pi(srt)
11855 real function X2pi(srt)
11856* This function contains the experimental
11857c total pp-pp+pi(+)pi(-) Xsections *
11858* srt = DSQRT(s) in GeV *
11859* xsec = production cross section in mb *
11860* earray = EXPerimental table with proton momentum in GeV/c *
11861* xarray = EXPerimental table with cross sections in mb (curve to guide eye)*
11862* *
11863******************************************
11864c real*4 xarray(15), earray(15)
11865 real xarray(15), earray(15)
11866 SAVE
11867 data earray /2.23,2.81,3.67,4.0,4.95,5.52,5.97,6.04,
11868 &6.6,6.9,7.87,8.11,10.01,16.0,19./
11869 data xarray /1.22,2.51,2.67,2.95,2.96,2.84,2.8,3.2,
11870 &2.7,3.0,2.54,2.46,2.4,1.66,1.5/
11871
11872 pmass=0.9383
11873* 1.Calculate p(lab) from srt [GeV]
11874* Formula used: DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
11875c ekin = 2.*pmass*((srt/(2.*pmass))**2 - 1.)
11876 x2pi=0.000001
11877 if(srt.le.2.2)return
11878 plab=sqrt(((srt**2-2.*pmass**2)/(2.*pmass))**2-pmass**2)
11879 if (plab .lt. earray(1)) then
11880 x2pi = xarray(1)
11881 return
11882 end if
11883*
11884* 2.Interpolate double logarithmically to find sigma(srt)
11885*
11886 do 1001 ie = 1,15
11887 if (earray(ie) .eq. plab) then
11888 x2pi= xarray(ie)
11889 return
11890 else if (earray(ie) .gt. plab) then
11891 ymin = alog(xarray(ie-1))
11892 ymax = alog(xarray(ie))
11893 xmin = alog(earray(ie-1))
11894 xmax = alog(earray(ie))
11895 X2pi = exp(ymin + (alog(plab)-xmin)*(ymax-ymin)
11896 & /(xmax-xmin) )
11897 return
11898 end if
11899 1001 continue
11900 return
11901 END
11902******************************************
11903* for pp-->pn+pi(+)pi(+)pi(-)
11904c real*4 function X3pi(srt)
11905 real function X3pi(srt)
11906* This function contains the experimental pp->pp+3pi cross sections *
11907* srt = DSQRT(s) in GeV *
11908* xsec = production cross section in mb *
11909* earray = EXPerimental table with proton energies in MeV *
11910* xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
11911* *
11912******************************************
11913c real*4 xarray(12), earray(12)
11914 real xarray(12), earray(12)
11915 SAVE
11916 data xarray /0.02,0.4,1.15,1.60,2.19,2.85,2.30,
11917 &3.10,2.47,2.60,2.40,1.70/
11918 data earray /2.23,2.81,3.67,4.00,4.95,5.52,5.97,
11919 &6.04,6.60,6.90,10.01,19./
11920
11921 pmass=0.9383
11922* 1.Calculate p(lab) from srt [GeV]
11923* Formula used: DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
11924c ekin = 2.*pmass*((srt/(2.*pmass))**2 - 1.)
11925 x3pi=1.E-06
11926 if(srt.le.2.3)return
11927 plab=sqrt(((srt**2-2.*pmass**2)/(2.*pmass))**2-pmass**2)
11928 if (plab .lt. earray(1)) then
11929 x3pi = xarray(1)
11930 return
11931 end if
11932*
11933* 2.Interpolate double logarithmically to find sigma(srt)
11934*
11935 do 1001 ie = 1,12
11936 if (earray(ie) .eq. plab) then
11937 x3pi= xarray(ie)
11938 return
11939 else if (earray(ie) .gt. plab) then
11940 ymin = alog(xarray(ie-1))
11941 ymax = alog(xarray(ie))
11942 xmin = alog(earray(ie-1))
11943 xmax = alog(earray(ie))
11944 X3pi= exp(ymin + (alog(plab)-xmin)*(ymax-ymin)
11945 & /(xmax-xmin) )
11946 return
11947 end if
11948 1001 continue
11949 return
11950 END
11951******************************************
11952******************************************
11953* for pp-->pp+pi(+)pi(-)pi(0)
11954c real*4 function X33pi(srt)
11955 real function X33pi(srt)
11956* This function contains the experimental pp->pp+3pi cross sections *
11957* srt = DSQRT(s) in GeV *
11958* xsec = production cross section in mb *
11959* earray = EXPerimental table with proton energies in MeV *
11960* xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
11961* *
11962******************************************
11963c real*4 xarray(12), earray(12)
11964 real xarray(12), earray(12)
11965 SAVE
11966 data xarray /0.02,0.22,0.74,1.10,1.76,1.84,2.20,
11967 &2.40,2.15,2.60,2.30,1.70/
11968 data earray /2.23,2.81,3.67,4.00,4.95,5.52,5.97,
11969 &6.04,6.60,6.90,10.01,19./
11970
11971 pmass=0.9383
11972 x33pi=1.E-06
11973 if(srt.le.2.3)return
11974* 1.Calculate p(lab) from srt [GeV]
11975* Formula used: DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
11976c ekin = 2.*pmass*((srt/(2.*pmass))**2 - 1.)
11977 plab=sqrt(((srt**2-2.*pmass**2)/(2.*pmass))**2-pmass**2)
11978 if (plab .lt. earray(1)) then
11979 x33pi = xarray(1)
11980 return
11981 end if
11982*
11983* 2.Interpolate double logarithmically to find sigma(srt)
11984*
11985 do 1001 ie = 1,12
11986 if (earray(ie) .eq. plab) then
11987 x33pi= xarray(ie)
11988 return
11989 else if (earray(ie) .gt. plab) then
11990 ymin = alog(xarray(ie-1))
11991 ymax = alog(xarray(ie))
11992 xmin = alog(earray(ie-1))
11993 xmax = alog(earray(ie))
11994 x33pi= exp(ymin + (alog(plab)-xmin)*(ymax-ymin)
11995 & /(xmax-xmin))
11996 return
11997 end if
11998 1001 continue
11999 return
12000 END
12001******************************************
12002c REAL*4 FUNCTION X4pi(SRT)
12003 REAL FUNCTION X4pi(SRT)
12004 SAVE
12005* CROSS SECTION FOR NN-->DD+rho PROCESS
12006* *****************************
12007 akp=0.498
12008 ak0=0.498
12009 ana=0.94
12010 ada=1.232
12011 al=1.1157
12012 as=1.1197
12013 pmass=0.9383
12014 ES=SRT
12015 IF(ES.LE.4)THEN
12016 X4pi=0.
12017 ELSE
12018* cross section for two resonance pp-->DD+DN*+N*N*
12019 xpp2pi=4.*x2pi(es)
12020* cross section for pp-->pp+spi
12021 xpp3pi=3.*(x3pi(es)+x33pi(es))
12022* cross section for pp-->pD+ and nD++
12023 pps1=sigma(es,1,1,0)+0.5*sigma(es,1,1,1)
12024 pps2=1.5*sigma(es,1,1,1)
12025 ppsngl=pps1+pps2+s1535(es)
12026* CROSS SECTION FOR KAON PRODUCTION from the four channels
12027* for NLK channel
12028 xk1=0
12029 xk2=0
12030 xk3=0
12031 xk4=0
12032 t1nlk=ana+al+akp
12033 t2nlk=ana+al-akp
12034 if(es.le.t1nlk)go to 333
12035 pmnlk2=(es**2-t1nlk**2)*(es**2-t2nlk**2)/(4.*es**2)
12036 pmnlk=sqrt(pmnlk2)
12037 xk1=pplpk(es)
12038* for DLK channel
12039 t1dlk=ada+al+akp
12040 t2dlk=ada+al-akp
12041 if(es.le.t1dlk)go to 333
12042 pmdlk2=(es**2-t1dlk**2)*(es**2-t2dlk**2)/(4.*es**2)
12043 pmdlk=sqrt(pmdlk2)
12044 xk3=pplpk(es)
12045* for NSK channel
12046 t1nsk=ana+as+akp
12047 t2nsk=ana+as-akp
12048 if(es.le.t1nsk)go to 333
12049 pmnsk2=(es**2-t1nsk**2)*(es**2-t2nsk**2)/(4.*es**2)
12050 pmnsk=sqrt(pmnsk2)
12051 xk2=ppk1(es)+ppk0(es)
12052* for DSK channel
12053 t1DSk=aDa+aS+akp
12054 t2DSk=aDa+aS-akp
12055 if(es.le.t1dsk)go to 333
12056 pmDSk2=(es**2-t1DSk**2)*(es**2-t2DSk**2)/(4.*es**2)
12057 pmDSk=sqrt(pmDSk2)
12058 xk4=ppk1(es)+ppk0(es)
12059* THE TOTAL KAON+ AND KAON0 PRODUCTION CROSS SECTION IS THEN
12060333 XKAON=3.*(xk1+xk2+xk3+xk4)
12061* cross section for pp-->DD+rho
12062 x4pi=pp1(es)-ppsngl-xpp2pi-xpp3pi-XKAON
12063 if(x4pi.le.0)x4pi=1.E-06
12064 ENDIF
12065 RETURN
12066 END
12067******************************************
12068* for pp-->inelastic
12069c real*4 function pp1(srt)
12070 real function pp1(srt)
12071 SAVE
12072* srt = DSQRT(s) in GeV *
12073* xsec = production cross section in mb *
12074* earray = EXPerimental table with proton energies in MeV *
12075* xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
12076* *
12077******************************************
12078 pmass=0.9383
12079 PP1=0.
12080* 1.Calculate p(lab) from srt [GeV]
12081* Formula used: DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
12082c ekin = 2.*pmass*((srt/(2.*pmass))**2 - 1.)
12083 plab2=((srt**2-2.*pmass**2)/(2.*pmass))**2-pmass**2
12084 IF(PLAB2.LE.0)RETURN
12085 plab=sqrt(PLAB2)
12086 pmin=0.968
12087 pmax=2080
12088 if ((plab .lt. pmin).or.(plab.gt.pmax)) then
12089 pp1 = 0.
12090 return
12091 end if
12092c* fit parameters
12093 a=30.9
12094 b=-28.9
12095 c=0.192
12096 d=-0.835
12097 an=-2.46
12098 pp1 = a+b*(plab**an)+c*(alog(plab))**2
12099 if(pp1.le.0)pp1=0.0
12100 return
12101 END
12102******************************************
12103* for pp-->elastic
12104c real*4 function pp2(srt)
12105 real function pp2(srt)
12106 SAVE
12107* srt = DSQRT(s) in GeV *
12108* xsec = production cross section in mb *
12109* earray = EXPerimental table with proton energies in MeV *
12110* xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
12111* *
12112******************************************
12113 pmass=0.9383
12114* 1.Calculate p(lab) from srt [GeV]
12115* Formula used: DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
12116c ekin = 2.*pmass*((srt/(2.*pmass))**2 - 1.)
12117 plab=sqrt(((srt**2-2.*pmass**2)/(2.*pmass))**2-pmass**2)
12118 pmin=2.
12119 pmax=2050
12120 if(plab.gt.pmax)then
12121 pp2=8.
12122 return
12123 endif
12124 if(plab .lt. pmin)then
12125 pp2 = 25.
12126 return
12127 end if
12128c* fit parameters
12129 a=11.2
12130 b=25.5
12131 c=0.151
12132 d=-1.62
12133 an=-1.12
12134 pp2 = a+b*(plab**an)+c*(alog(plab))**2+d*alog(plab)
12135 if(pp2.le.0)pp2=0
12136 return
12137 END
12138
12139******************************************
12140* for pp-->total
12141c real*4 function ppt(srt)
12142 real function ppt(srt)
12143 SAVE
12144* srt = DSQRT(s) in GeV *
12145* xsec = production cross section in mb *
12146* earray = EXPerimental table with proton energies in MeV *
12147* xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
12148* *
12149******************************************
12150 pmass=0.9383
12151* 1.Calculate p(lab) from srt [GeV]
12152* Formula used: DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
12153c ekin = 2.*pmass*((srt/(2.*pmass))**2 - 1.)
12154 plab=sqrt(((srt**2-2.*pmass**2)/(2.*pmass))**2-pmass**2)
12155 pmin=3.
12156 pmax=2100
12157 if ((plab .lt. pmin).or.(plab.gt.pmax)) then
12158 ppt = 55.
12159 return
12160 end if
12161c* fit parameters
12162 a=45.6
12163 b=219.0
12164 c=0.410
12165 d=-3.41
12166 an=-4.23
12167 ppt = a+b*(plab**an)+c*(alog(plab))**2+d*alog(plab)
12168 if(ppt.le.0)ppt=0.0
12169 return
12170 END
12171
12172*************************
12173* cross section for N*(1535) production in PP collisions
12174* VARIABLES:
12175* LB1,LB2 ARE THE LABLES OF THE TWO COLLIDING PARTICLES
12176* SRT IS THE CMS ENERGY
12177* X1535 IS THE N*(1535) PRODUCTION CROSS SECTION
12178* NOTE THAT THE N*(1535) PRODUCTION CROSS SECTION IS 2 TIMES THE ETA
12179* PRODUCTION CROSS SECTION
12180* DATE: Aug. 1 , 1994
12181* ********************************
12182 real function s1535(SRT)
12183 SAVE
12184 S0=2.424
12185 s1535=0.
12186 IF(SRT.LE.S0)RETURN
12187 S1535=2.*0.102*(SRT-S0)/(0.058+(SRT-S0)**2)
12188 return
12189 end
12190****************************************
12191* generate a table for pt distribution for
12192 subroutine tablem
12193* THE PROCESS N+N--->N+N+PION
12194* DATE : July 11, 1994
12195*****************************************
12196 COMMON/TABLE/ xarray(0:1000),earray(0:1000)
12197cc SAVE /TABLE/
12198 SAVE
12199 ptmax=2.01
12200 anorm=ptdis(ptmax)
12201 do 10 L=0,200
12202 x=0.01*float(L+1)
12203 rr=ptdis(x)/anorm
12204 earray(l)=rr
12205 xarray(l)=x
1220610 continue
12207 RETURN
12208 end
12209*********************************
12210 real function ptdis(x)
12211 SAVE
12212* NUCLEON TRANSVERSE MOMENTUM DISTRIBUTION AT HIGH ENERGIES
12213* DATE: Aug. 11, 1994
12214*********************************
12215 b=3.78
12216 c=0.47
12217 d=3.60
12218c b=b*3
12219c d=d*3
12220 ptdis=1./(2.*b)*(1.-exp(-b*x**2))-c/d*x*exp(-d*x)
12221 1 -c/D**2*(exp(-d*x)-1.)
12222 return
12223 end
12224*****************************
12225 subroutine ppxS(lb1,lb2,srt,ppsig,spprho,ipp)
12226* purpose: this subroutine gives the cross section for pion+pion
12227* elastic collision
12228* variables:
12229* input: lb1,lb2 and srt are the labels and srt for I1 and I2
12230* output: ppsig: pp xsection
12231* ipp: label for the pion+pion channel
12232* Ipp=0 NOTHING HAPPEND
12233* 1 for Pi(+)+PI(+) DIRECT
12234* 2 PI(+)+PI(0) FORMING RHO(+)
12235* 3 PI(+)+PI(-) FORMING RHO(0)
12236* 4 PI(0)+PI(O) DIRECT
12237* 5 PI(0)+PI(-) FORMING RHO(-)
12238* 6 PI(-)+PI(-) DIRECT
12239* reference: G.F. Bertsch, Phys. Rev. D37 (1988) 1202.
12240* date : Aug 29, 1994
12241*****************************
12242 parameter (amp=0.14,pi=3.1415926)
12243 SAVE
12244 PPSIG=0.0
12245
12246cbzdbg10/15/99
12247 spprho=0.0
12248cbzdbg10/15/99 end
12249
12250 IPP=0
12251 IF(SRT.LE.0.3)RETURN
12252 q=sqrt((srt/2)**2-amp**2)
12253 esigma=5.8*amp
12254 tsigma=2.06*q
12255 erho=0.77
12256 trho=0.095*q*(q/amp/(1.+(q/erho)**2))**2
12257 esi=esigma-srt
12258 if(esi.eq.0)then
12259 d00=pi/2.
12260 go to 10
12261 endif
12262 d00=atan(tsigma/2./esi)
1226310 erh=erho-srt
12264 if(erh.eq.0.)then
12265 d11=pi/2.
12266 go to 20
12267 endif
12268 d11=atan(trho/2./erh)
1226920 d20=-0.12*q/amp
12270 s0=8.*pi*sin(d00)**2/q**2
12271 s1=8*pi*3*sin(d11)**2/q**2
12272 s2=8*pi*5*sin(d20)**2/q**2
12273c !! GeV^-2 to mb
12274 s0=s0*0.197**2*10.
12275 s1=s1*0.197**2*10.
12276 s2=s2*0.197**2*10.
12277C ppXS=s0/9.+s1/3.+s2*0.56
12278C if(ppxs.le.0)ppxs=0.00001
12279 spprho=s1/2.
12280* (1) PI(+)+PI(+)
12281 IF(LB1.EQ.5.AND.LB2.EQ.5)THEN
12282 IPP=1
12283 PPSIG=S2
12284 RETURN
12285 ENDIF
12286* (2) PI(+)+PI(0)
12287 IF((LB1.EQ.5.AND.LB2.EQ.4).OR.(LB1.EQ.4.AND.LB2.EQ.5))THEN
12288 IPP=2
12289 PPSIG=S2/2.+S1/2.
12290 RETURN
12291 ENDIF
12292* (3) PI(+)+PI(-)
12293 IF((LB1.EQ.5.AND.LB2.EQ.3).OR.(LB1.EQ.3.AND.LB2.EQ.5))THEN
12294 IPP=3
12295 PPSIG=S2/6.+S1/2.+S0/3.
12296 RETURN
12297 ENDIF
12298* (4) PI(0)+PI(0)
12299 IF(LB1.EQ.4.AND.LB2.EQ.4)THEN
12300 IPP=4
12301 PPSIG=2*S2/3.+S0/3.
12302 RETURN
12303 ENDIF
12304* (5) PI(0)+PI(-)
12305 IF((LB1.EQ.4.AND.LB2.EQ.3).OR.(LB1.EQ.3.AND.LB2.EQ.4))THEN
12306 IPP=5
12307 PPSIG=S2/2.+S1/2.
12308 RETURN
12309 ENDIF
12310* (6) PI(-)+PI(-)
12311 IF(LB1.EQ.3.AND.LB2.EQ.3)THEN
12312 IPP=6
12313 PPSIG=S2
12314 ENDIF
12315 return
12316 end
12317**********************************
12318* elementary kaon production cross sections
12319* from the CERN data book
12320* date: Sept.2, 1994
12321* for pp-->pLK+
12322c real*4 function pplpk(srt)
12323 real function pplpk(srt)
12324 SAVE
12325* srt = DSQRT(s) in GeV *
12326* xsec = production cross section in mb *
12327* earray = EXPerimental table with proton energies in MeV *
12328* xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
12329* *
12330******************************************
12331 pmass=0.9383
12332* 1.Calculate p(lab) from srt [GeV]
12333* Formula used: DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
12334* find the center of mass energy corresponding to the given pm as
12335* if Lambda+N+K are produced
12336 pplpk=0.
12337 plab=sqrt(((srt**2-2.*pmass**2)/(2.*pmass))**2-pmass**2)
12338 pmin=2.82
12339 pmax=25.0
12340 if(plab.gt.pmax)then
12341 pplpk=0.036
12342 return
12343 endif
12344 if(plab .lt. pmin)then
12345 pplpk = 0.
12346 return
12347 end if
12348c* fit parameters
12349 a=0.0654
12350 b=-3.16
12351 c=-0.0029
12352 an=-4.14
12353 pplpk = a+b*(plab**an)+c*(alog(plab))**2
12354 if(pplpk.le.0)pplpk=0
12355 return
12356 END
12357
12358******************************************
12359* for pp-->pSigma+K0
12360c real*4 function ppk0(srt)
12361 real function ppk0(srt)
12362* srt = DSQRT(s) in GeV *
12363* xsec = production cross section in mb *
12364* *
12365******************************************
12366c real*4 xarray(7), earray(7)
12367 real xarray(7), earray(7)
12368 SAVE
12369 data xarray /0.030,0.025,0.025,0.026,0.02,0.014,0.06/
12370 data earray /3.67,4.95,5.52,6.05,6.92,7.87,10./
12371
12372 pmass=0.9383
12373* 1.Calculate p(lab) from srt [GeV]
12374* Formula used: DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
12375c ekin = 2.*pmass*((srt/(2.*pmass))**2 - 1.)
12376 ppk0=0
12377 if(srt.le.2.63)return
12378 if(srt.gt.4.54)then
12379 ppk0=0.037
12380 return
12381 endif
12382 plab=sqrt(((srt**2-2.*pmass**2)/(2.*pmass))**2-pmass**2)
12383 if (plab .lt. earray(1)) then
12384 ppk0 = xarray(1)
12385 return
12386 end if
12387*
12388* 2.Interpolate double logarithmically to find sigma(srt)
12389*
12390 do 1001 ie = 1,7
12391 if (earray(ie) .eq. plab) then
12392 ppk0 = xarray(ie)
12393 go to 10
12394 else if (earray(ie) .gt. plab) then
12395 ymin = alog(xarray(ie-1))
12396 ymax = alog(xarray(ie))
12397 xmin = alog(earray(ie-1))
12398 xmax = alog(earray(ie))
12399 ppk0 = exp(ymin + (alog(plab)-xmin)*(ymax-ymin)
12400 &/(xmax-xmin) )
12401 go to 10
12402 end if
12403 1001 continue
1240410 continue
12405 return
12406 END
12407******************************************
12408* for pp-->pSigma0K+
12409c real*4 function ppk1(srt)
12410 real function ppk1(srt)
12411* srt = DSQRT(s) in GeV *
12412* xsec = production cross section in mb *
12413* *
12414******************************************
12415c real*4 xarray(7), earray(7)
12416 real xarray(7), earray(7)
12417 SAVE
12418 data xarray /0.013,0.025,0.016,0.012,0.017,0.029,0.025/
12419 data earray /3.67,4.95,5.52,5.97,6.05,6.92,7.87/
12420
12421 pmass=0.9383
12422* 1.Calculate p(lab) from srt [GeV]
12423* Formula used: DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
12424c ekin = 2.*pmass*((srt/(2.*pmass))**2 - 1.)
12425 ppk1=0.
12426 if(srt.le.2.63)return
12427 if(srt.gt.4.08)then
12428 ppk1=0.025
12429 return
12430 endif
12431 plab=sqrt(((srt**2-2.*pmass**2)/(2.*pmass))**2-pmass**2)
12432 if (plab .lt. earray(1)) then
12433 ppk1 =xarray(1)
12434 return
12435 end if
12436*
12437* 2.Interpolate double logarithmically to find sigma(srt)
12438*
12439 do 1001 ie = 1,7
12440 if (earray(ie) .eq. plab) then
12441 ppk1 = xarray(ie)
12442 go to 10
12443 else if (earray(ie) .gt. plab) then
12444 ymin = alog(xarray(ie-1))
12445 ymax = alog(xarray(ie))
12446 xmin = alog(earray(ie-1))
12447 xmax = alog(earray(ie))
12448 ppk1 = exp(ymin + (alog(plab)-xmin)*(ymax-ymin)
12449 &/(xmax-xmin) )
12450 go to 10
12451 end if
12452 1001 continue
1245310 continue
12454 return
12455 END
12456**********************************
12457* *
12458* *
12459 SUBROUTINE CRPN(PX,PY,PZ,SRT,I1,I2,
12460 & IBLOCK,xkaon0,xkaon,Xphi,xphin)
12461* PURPOSE: *
12462* DEALING WITH PION+N-->L/S+KAON PROCESS AND PION PRODUCTION *
12463* NOTE : *
12464*
12465* QUANTITIES: *
12466* PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
12467* SRT - SQRT OF S *
12468* IBLOCK - THE INFORMATION BACK *
12469* 7 PION+N-->L/S+KAON
12470* iblock - 77 pion+N-->Delta+pion
12471* iblock - 78 pion+N-->Delta+RHO
12472* iblock - 79 pion+N-->Delta+OMEGA
12473* iblock - 222 pion+N-->Phi
12474**********************************
12475 PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
12476 1 AMP=0.93828,AP1=0.13496,APHI=1.020,
12477 2 AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
12478 PARAMETER (AKA=0.498,ALA=1.1157,ASA=1.1974)
12479 parameter (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
12480 COMMON /AA/ R(3,MAXSTR)
12481cc SAVE /AA/
12482 COMMON /BB/ P(3,MAXSTR)
12483cc SAVE /BB/
12484 COMMON /CC/ E(MAXSTR)
12485cc SAVE /CC/
12486 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
12487cc SAVE /EE/
12488 common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
12489cc SAVE /input1/
12490 COMMON/RNDF77/NSEED
12491cc SAVE /RNDF77/
12492 SAVE
12493
12494 PX0=PX
12495 PY0=PY
12496 PZ0=PZ
12497 iblock=1
12498 x1=RANART(NSEED)
12499 ianti=0
12500 if(lb(i1).lt.0 .or. lb(i2).lt.0) ianti=1
12501 if(xkaon0/(xkaon+Xphi).ge.x1)then
12502* kaon production
12503*-----------------------------------------------------------------------
12504 IBLOCK=7
12505 if(ianti .eq. 1)iblock=-7
12506 NTAG=0
12507* RELABLE PARTICLES FOR THE PROCESS PION+n-->LAMBDA K OR SIGMA k
12508* DECIDE LAMBDA OR SIGMA PRODUCTION, AND TO CALCULATE THE NEW
12509* MOMENTA FOR PARTICLES IN THE FINAL STATE.
12510 KAONC=0
12511 IF(PNLKA(SRT)/(PNLKA(SRT)
12512 & +PNSKA(SRT)).GT.RANART(NSEED))KAONC=1
12513 IF(E(I1).LE.0.2)THEN
12514 LB(I1)=23
12515 E(I1)=AKA
12516 IF(KAONC.EQ.1)THEN
12517 LB(I2)=14
12518 E(I2)=ALA
12519 ELSE
12520 LB(I2) = 15 + int(3 * RANART(NSEED))
12521 E(I2)=ASA
12522 ENDIF
12523 if(ianti .eq. 1)then
12524 lb(i1) = 21
12525 lb(i2) = -lb(i2)
12526 endif
12527 ELSE
12528 LB(I2)=23
12529 E(I2)=AKA
12530 IF(KAONC.EQ.1)THEN
12531 LB(I1)=14
12532 E(I1)=ALA
12533 ELSE
12534 LB(I1) = 15 + int(3 * RANART(NSEED))
12535 E(I1)=ASA
12536 ENDIF
12537 if(ianti .eq. 1)then
12538 lb(i2) = 21
12539 lb(i1) = -lb(i1)
12540 endif
12541 ENDIF
12542 EM1=E(I1)
12543 EM2=E(I2)
12544 go to 50
12545* to gererate the momentum for the kaon and L/S
12546 elseif(Xphi/(xkaon+Xphi).ge.x1)then
12547 iblock=222
12548 if(xphin/Xphi .ge. RANART(NSEED))then
12549 LB(I1)= 1+int(2*RANART(NSEED))
12550 E(I1)=AMN
12551 else
12552 LB(I1)= 6+int(4*RANART(NSEED))
12553 E(I1)=AM0
12554 endif
12555c !! at present only baryon
12556 if(ianti .eq. 1)lb(i1)=-lb(i1)
12557 LB(I2)= 29
12558 E(I2)=APHI
12559 EM1=E(I1)
12560 EM2=E(I2)
12561 go to 50
12562 else
12563* CHECK WHAT KIND OF PION PRODUCTION PROCESS HAS HAPPENED
12564 IF(RANART(NSEED).LE.TWOPI(SRT)/
12565 & (TWOPI(SRT)+THREPI(SRT)+FOURPI(SRT)))THEN
12566 iblock=77
12567 ELSE
12568 IF(THREPI(SRT)/(THREPI(SRT)+FOURPI(SRT)).
12569 & GT.RANART(NSEED))THEN
12570 IBLOCK=78
12571 ELSE
12572 IBLOCK=79
12573 ENDIF
12574 endif
12575 ntag=0
12576* pion production (Delta+pion/rho/omega in the final state)
12577* generate the mass of the delta resonance
12578 X2=RANART(NSEED)
12579* relable the particles
12580 if(iblock.eq.77)then
12581* GENERATE THE DELTA MASS
12582 dmax=srt-ap1-0.02
12583 dm=rmass(dmax,iseed)
12584* pion+baryon-->pion+delta
12585* Relable particles, I1 is assigned to the Delta and I2 is assigned to the
12586* meson
12587*(1) for pi(+)+p-->D(+)+P(+) OR D(++)+p(0)
12588 if( ((lb(i1).eq.1.and.lb(i2).eq.5).
12589 & or.(lb(i1).eq.5.and.lb(i2).eq.1))
12590 & .OR. ((lb(i1).eq.-1.and.lb(i2).eq.3).
12591 & or.(lb(i1).eq.3.and.lb(i2).eq.-1)) )then
12592 if(iabs(lb(i1)).eq.1)then
12593 ii = i1
12594 IF(X2.LE.0.5)THEN
12595 lb(i1)=8
12596 e(i1)=dm
12597 lb(i2)=5
12598 e(i2)=ap1
12599 go to 40
12600 ELSE
12601 lb(i1)=9
12602 e(i1)=dm
12603 lb(i2)=4
12604 ipi = 4
12605 e(i2)=ap1
12606 go to 40
12607 endif
12608 else
12609 ii = i2
12610 IF(X2.LE.0.5)THEN
12611 lb(i2)=8
12612 e(i2)=dm
12613 lb(i1)=5
12614 e(i1)=ap1
12615 go to 40
12616 ELSE
12617 lb(i2)=9
12618 e(i2)=dm
12619 lb(i1)=4
12620 e(i1)=ap1
12621 go to 40
12622 endif
12623 endif
12624 endif
12625*(2) for pi(-)+p-->D(0)+P(0) OR D(+)+p(-),or D(-)+p(+)
12626 if( ((lb(i1).eq.1.and.lb(i2).eq.3).
12627 & or.(lb(i1).eq.3.and.lb(i2).eq.1))
12628 & .OR. ((lb(i1).eq.-1.and.lb(i2).eq.5).
12629 & or.(lb(i1).eq.5.and.lb(i2).eq.-1)) )then
12630 if(iabs(lb(i1)).eq.1)then
12631 ii = i1
12632 IF(X2.LE.0.33)THEN
12633 lb(i1)=6
12634 e(i1)=dm
12635 lb(i2)=5
12636 e(i2)=ap1
12637 go to 40
12638 ENDIF
12639 if(X2.gt.0.33.and.X2.le.0.67)then
12640 lb(i1)=7
12641 e(i1)=dm
12642 lb(i2)=4
12643 e(i2)=ap1
12644 go to 40
12645 endif
12646 if(X2.gt.0.67)then
12647 lb(i1)=8
12648 e(i1)=dm
12649 lb(i2)=3
12650 e(i2)=ap1
12651 go to 40
12652 endif
12653 else
12654 ii = i2
12655 IF(X2.LE.0.33)THEN
12656 lb(i2)=6
12657 e(i2)=dm
12658 lb(i1)=5
12659 e(i1)=ap1
12660 go to 40
12661 ENDIF
12662 if(X2.gt.0.33.and.X2.le.0.67)then
12663 lb(i2)=7
12664 e(i2)=dm
12665 lb(i1)=4
12666 e(i1)=ap1
12667 go to 40
12668 endif
12669 if(X2.gt.0.67)then
12670 lb(i2)=8
12671 e(i2)=dm
12672 lb(i1)=3
12673 e(i1)=ap1
12674 go to 40
12675 endif
12676 endif
12677 endif
12678*(3) for pi(+)+n-->D(+)+Pi(0) OR D(++)+p(-) or D(0)+pi(+)
12679 if( ((lb(i1).eq.2.and.lb(i2).eq.5).
12680 & or.(lb(i1).eq.5.and.lb(i2).eq.2))
12681 & .OR. ((lb(i1).eq.-2.and.lb(i2).eq.3).
12682 & or.(lb(i1).eq.3.and.lb(i2).eq.-2)) )then
12683 if(iabs(lb(i1)).eq.2)then
12684 ii = i1
12685 IF(X2.LE.0.33)THEN
12686 lb(i1)=8
12687 e(i1)=dm
12688 lb(i2)=4
12689 e(i2)=ap1
12690 go to 40
12691 ENDIF
12692 if(X2.gt.0.33.and.X2.le.0.67)then
12693 lb(i1)=7
12694 e(i1)=dm
12695 lb(i2)=5
12696 e(i2)=ap1
12697 go to 40
12698 endif
12699 if(X2.gt.0.67)then
12700 lb(i1)=9
12701 e(i1)=dm
12702 lb(i2)=3
12703 e(i2)=ap1
12704 go to 40
12705 endif
12706 else
12707 ii = i2
12708 IF(X2.LE.0.33)THEN
12709 lb(i2)=8
12710 e(i2)=dm
12711 lb(i1)=4
12712 e(i1)=ap1
12713 go to 40
12714 ENDIF
12715 if(X2.gt.0.33.and.X2.le.0.67)then
12716 lb(i2)=7
12717 e(i2)=dm
12718 lb(i1)=5
12719 e(i1)=ap1
12720 go to 40
12721 endif
12722 if(X2.gt.0.67)then
12723 lb(i2)=9
12724 e(i2)=dm
12725 lb(i1)=3
12726 e(i1)=ap1
12727 go to 40
12728 endif
12729 endif
12730 endif
12731*(4) for pi(0)+p-->D(+)+Pi(0) OR D(++)+p(-) or D(0)+pi(+)
12732 if((iabs(lb(i1)).eq.1.and.lb(i2).eq.4).
12733 & or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.1))then
12734 if(iabs(lb(i1)).eq.1)then
12735 ii = i1
12736 IF(X2.LE.0.33)THEN
12737 lb(i1)=8
12738 e(i1)=dm
12739 lb(i2)=4
12740 e(i2)=ap1
12741 go to 40
12742 ENDIF
12743 if(X2.gt.0.33.and.X2.le.0.67)then
12744 lb(i1)=7
12745 e(i1)=dm
12746 lb(i2)=5
12747 e(i2)=ap1
12748 go to 40
12749 endif
12750 if(X2.gt.0.67)then
12751 lb(i1)=9
12752 e(i1)=dm
12753 lb(i2)=3
12754 e(i2)=ap1
12755 go to 40
12756 endif
12757 else
12758 ii = i2
12759 IF(X2.LE.0.33)THEN
12760 lb(i2)=8
12761 e(i2)=dm
12762 lb(i1)=4
12763 e(i1)=ap1
12764 go to 40
12765 ENDIF
12766 if(X2.gt.0.33.and.X2.le.0.67)then
12767 lb(i2)=7
12768 e(i2)=dm
12769 lb(i1)=5
12770 e(i1)=ap1
12771 go to 40
12772 endif
12773 if(X2.gt.0.67)then
12774 lb(i2)=9
12775 e(i2)=dm
12776 lb(i1)=3
12777 e(i1)=ap1
12778 go to 40
12779 endif
12780 endif
12781 endif
12782*(5) for pi(-)+n-->D(-)+P(0) OR D(0)+p(-)
12783 if( ((lb(i1).eq.2.and.lb(i2).eq.3).
12784 & or.(lb(i1).eq.3.and.lb(i2).eq.2))
12785 & .OR. ((lb(i1).eq.-2.and.lb(i2).eq.5).
12786 & or.(lb(i1).eq.5.and.lb(i2).eq.-2)) )then
12787 if(iabs(lb(i1)).eq.2)then
12788 ii = i1
12789 IF(X2.LE.0.5)THEN
12790 lb(i1)=6
12791 e(i1)=dm
12792 lb(i2)=4
12793 e(i2)=ap1
12794 go to 40
12795 ELSE
12796 lb(i1)=7
12797 e(i1)=dm
12798 lb(i2)=3
12799 e(i2)=ap1
12800 go to 40
12801 endif
12802 else
12803 ii = i2
12804 IF(X2.LE.0.5)THEN
12805 lb(i2)=6
12806 e(i2)=dm
12807 lb(i1)=4
12808 e(i1)=ap1
12809 go to 40
12810 ELSE
12811 lb(i2)=7
12812 e(i2)=dm
12813 lb(i1)=3
12814 e(i1)=ap1
12815 go to 40
12816 endif
12817 endif
12818 ENDIF
12819*(6) for pi(0)+n-->D(0)+P(0), D(-)+p(+) or D(+)+p(-)
12820 if((iabs(lb(i1)).eq.2.and.lb(i2).eq.4).
12821 & or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.2))then
12822 if(iabs(lb(i1)).eq.2)then
12823 ii = i1
12824 IF(X2.LE.0.33)THEN
12825 lb(i1)=7
12826 e(i1)=dm
12827 lb(i2)=4
12828 e(i2)=ap1
12829 go to 40
12830 Endif
12831 IF(X2.LE.0.67.AND.X2.GT.0.33)THEN
12832 lb(i1)=6
12833 e(i1)=dm
12834 lb(i2)=5
12835 e(i2)=ap1
12836 go to 40
12837 endif
12838 IF(X2.GT.0.67)THEN
12839 LB(I1)=8
12840 E(I1)=DM
12841 LB(I2)=3
12842 E(I2)=AP1
12843 GO TO 40
12844 ENDIF
12845 else
12846 ii = i2
12847 IF(X2.LE.0.33)THEN
12848 lb(i2)=7
12849 e(i2)=dm
12850 lb(i1)=4
12851 e(i1)=ap1
12852 go to 40
12853 ENDIF
12854 IF(X2.LE.0.67.AND.X2.GT.0.33)THEN
12855 lb(i2)=6
12856 e(i2)=dm
12857 lb(i1)=5
12858 e(i1)=ap1
12859 go to 40
12860 endif
12861 IF(X2.GT.0.67)THEN
12862 LB(I2)=8
12863 E(I2)=DM
12864 LB(I1)=3
12865 E(I1)=AP1
12866 GO TO 40
12867 ENDIF
12868 endif
12869 endif
12870 ENDIF
12871 if(iblock.eq.78)then
12872 call Rmasdd(srt,1.232,0.77,1.08,
12873 & 0.28,ISEED,4,dm,ameson)
12874 arho=AMESON
12875* pion+baryon-->Rho+delta
12876*(1) for pi(+)+p-->D(+)+rho(+) OR D(++)+rho(0)
12877 if( ((lb(i1).eq.1.and.lb(i2).eq.5).
12878 & or.(lb(i1).eq.5.and.lb(i2).eq.1))
12879 & .OR. ((lb(i1).eq.-1.and.lb(i2).eq.3).
12880 & or.(lb(i1).eq.3.and.lb(i2).eq.-1)) )then
12881 if(iabs(lb(i1)).eq.1)then
12882 ii = i1
12883 IF(X2.LE.0.5)THEN
12884 lb(i1)=8
12885 e(i1)=dm
12886 lb(i2)=27
12887 e(i2)=arho
12888 go to 40
12889 ELSE
12890 lb(i1)=9
12891 e(i1)=dm
12892 lb(i2)=26
12893 e(i2)=arho
12894 go to 40
12895 endif
12896 else
12897 ii = i2
12898 IF(X2.LE.0.5)THEN
12899 lb(i2)=8
12900 e(i2)=dm
12901 lb(i1)=27
12902 e(i1)=arho
12903 go to 40
12904 ELSE
12905 lb(i2)=9
12906 e(i2)=dm
12907 lb(i1)=26
12908 e(i1)=arho
12909 go to 40
12910 endif
12911 endif
12912 endif
12913*(2) for pi(-)+p-->D(+)+rho(-) OR D(0)+rho(0) or D(-)+rho(+)
12914 if( ((lb(i1).eq.1.and.lb(i2).eq.3).
12915 & or.(lb(i1).eq.3.and.lb(i2).eq.1))
12916 & .OR. ((lb(i1).eq.-1.and.lb(i2).eq.5).
12917 & or.(lb(i1).eq.5.and.lb(i2).eq.-1)) )then
12918 if(iabs(lb(i1)).eq.1)then
12919 ii = i1
12920 IF(X2.LE.0.33)THEN
12921 lb(i1)=6
12922 e(i1)=dm
12923 lb(i2)=27
12924 e(i2)=arho
12925 go to 40
12926 ENDIF
12927 if(X2.gt.0.33.and.X2.le.0.67)then
12928 lb(i1)=7
12929 e(i1)=dm
12930 lb(i2)=26
12931 e(i2)=arho
12932 go to 40
12933 endif
12934 if(X2.gt.0.67)then
12935 lb(i1)=8
12936 e(i1)=dm
12937 lb(i2)=25
12938 e(i2)=arho
12939 go to 40
12940 endif
12941 else
12942 ii = i2
12943 IF(X2.LE.0.33)THEN
12944 lb(i2)=6
12945 e(i2)=dm
12946 lb(i1)=27
12947 e(i1)=arho
12948 go to 40
12949 ENDIF
12950 if(X2.gt.0.33.and.X2.le.0.67)then
12951 lb(i2)=7
12952 e(i2)=dm
12953 lb(i1)=26
12954 e(i1)=arho
12955 go to 40
12956 endif
12957 if(X2.gt.0.67)then
12958 lb(i2)=8
12959 e(i2)=dm
12960 lb(i1)=25
12961 e(i1)=arho
12962 go to 40
12963 endif
12964 endif
12965 endif
12966*(3) for pi(+)+n-->D(+)+rho(0) OR D(++)+rho(-) or D(0)+rho(+)
12967 if( ((lb(i1).eq.2.and.lb(i2).eq.5).
12968 & or.(lb(i1).eq.5.and.lb(i2).eq.2))
12969 & .OR.((lb(i1).eq.-2.and.lb(i2).eq.3).
12970 & or.(lb(i1).eq.3.and.lb(i2).eq.-2)) )then
12971 if(iabs(lb(i1)).eq.2)then
12972 ii = i1
12973 IF(X2.LE.0.33)THEN
12974 lb(i1)=8
12975 e(i1)=dm
12976 lb(i2)=26
12977 e(i2)=arho
12978 go to 40
12979 ENDIF
12980 if(X2.gt.0.33.and.X2.le.0.67)then
12981 lb(i1)=7
12982 e(i1)=dm
12983 lb(i2)=27
12984 e(i2)=arho
12985 go to 40
12986 endif
12987 if(X2.gt.0.67)then
12988 lb(i1)=9
12989 e(i1)=dm
12990 lb(i2)=25
12991 e(i2)=arho
12992 go to 40
12993 endif
12994 else
12995 ii = i2
12996 IF(X2.LE.0.33)THEN
12997 lb(i2)=8
12998 e(i2)=dm
12999 lb(i1)=26
13000 e(i1)=arho
13001 go to 40
13002 ENDIF
13003 if(X2.gt.0.33.and.X2.le.0.67)then
13004 lb(i2)=7
13005 e(i2)=dm
13006 lb(i1)=27
13007 e(i1)=arho
13008 go to 40
13009 endif
13010 if(X2.gt.0.67)then
13011 lb(i2)=9
13012 e(i2)=dm
13013 lb(i1)=25
13014 e(i1)=arho
13015 go to 40
13016 endif
13017 endif
13018 endif
13019*(4) for pi(0)+p-->D(+)+rho(0) OR D(++)+rho(-) or D(0)+rho(+)
13020 if((iabs(lb(i1)).eq.1.and.lb(i2).eq.4).
13021 & or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.1))then
13022 if(iabs(lb(i1)).eq.1)then
13023 ii = i1
13024 IF(X2.LE.0.33)THEN
13025 lb(i1)=7
13026 e(i1)=dm
13027 lb(i2)=27
13028 e(i2)=arho
13029 go to 40
13030 ENDIF
13031 if(X2.gt.0.33.and.X2.le.0.67)then
13032 lb(i1)=8
13033 e(i1)=dm
13034 lb(i2)=26
13035 e(i2)=arho
13036 go to 40
13037 endif
13038 if(X2.gt.0.67)then
13039 lb(i1)=9
13040 e(i1)=dm
13041 lb(i2)=25
13042 e(i2)=arho
13043 go to 40
13044 endif
13045 else
13046 ii = i2
13047 IF(X2.LE.0.33)THEN
13048 lb(i2)=7
13049 e(i2)=dm
13050 lb(i1)=27
13051 e(i1)=arho
13052 go to 40
13053 ENDIF
13054 if(X2.gt.0.33.and.X2.le.0.67)then
13055 lb(i2)=8
13056 e(i2)=dm
13057 lb(i1)=26
13058 e(i1)=arho
13059 go to 40
13060 endif
13061 if(X2.gt.0.67)then
13062 lb(i2)=9
13063 e(i2)=dm
13064 lb(i1)=25
13065 e(i1)=arho
13066 go to 40
13067 endif
13068 endif
13069 endif
13070*(5) for pi(-)+n-->D(-)+rho(0) OR D(0)+rho(-)
13071 if( ((lb(i1).eq.2.and.lb(i2).eq.3).
13072 & or.(lb(i1).eq.3.and.lb(i2).eq.2))
13073 & .OR. ((lb(i1).eq.-2.and.lb(i2).eq.5).
13074 & or.(lb(i1).eq.5.and.lb(i2).eq.-2)) )then
13075 if(iabs(lb(i1)).eq.2)then
13076 ii = i1
13077 IF(X2.LE.0.5)THEN
13078 lb(i1)=6
13079 e(i1)=dm
13080 lb(i2)=26
13081 e(i2)=arho
13082 go to 40
13083 ELSE
13084 lb(i1)=7
13085 e(i1)=dm
13086 lb(i2)=25
13087 e(i2)=arho
13088 go to 40
13089 endif
13090 else
13091 ii = i2
13092 IF(X2.LE.0.5)THEN
13093 lb(i2)=6
13094 e(i2)=dm
13095 lb(i1)=26
13096 e(i1)=arho
13097 go to 40
13098 ELSE
13099 lb(i2)=7
13100 e(i2)=dm
13101 lb(i1)=25
13102 e(i1)=arho
13103 go to 40
13104 endif
13105 endif
13106 ENDIF
13107*(6) for pi(0)+n-->D(0)+rho(0), D(-)+rho(+) and D(+)+rho(-)
13108 if((iabs(lb(i1)).eq.2.and.lb(i2).eq.4).
13109 & or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.2))then
13110 if(iabs(lb(i1)).eq.2)then
13111 ii = i1
13112 IF(X2.LE.0.33)THEN
13113 lb(i1)=7
13114 e(i1)=dm
13115 lb(i2)=26
13116 e(i2)=arho
13117 go to 40
13118 endif
13119 if(x2.gt.0.33.and.x2.le.0.67)then
13120 lb(i1)=6
13121 e(i1)=dm
13122 lb(i2)=27
13123 e(i2)=arho
13124 go to 40
13125 endif
13126 if(x2.gt.0.67)then
13127 lb(i1)=8
13128 e(i1)=dm
13129 lb(i2)=25
13130 e(i2)=arho
13131 endif
13132 else
13133 ii = i2
13134 IF(X2.LE.0.33)THEN
13135 lb(i2)=7
13136 e(i2)=dm
13137 lb(i1)=26
13138 e(i1)=arho
13139 go to 40
13140 endif
13141 if(x2.le.0.67.and.x2.gt.0.33)then
13142 lb(i2)=6
13143 e(i2)=dm
13144 lb(i1)=27
13145 e(i1)=arho
13146 go to 40
13147 endif
13148 if(x2.gt.0.67)then
13149 lb(i2)=8
13150 e(i2)=dm
13151 lb(i1)=25
13152 e(i1)=arho
13153 endif
13154 endif
13155 endif
13156 Endif
13157 if(iblock.eq.79)then
13158 aomega=0.782
13159* GENERATE THE DELTA MASS
13160 dmax=srt-0.782-0.02
13161 dm=rmass(dmax,iseed)
13162* pion+baryon-->omega+delta
13163*(1) for pi(+)+p-->D(++)+omega(0)
13164 if( ((lb(i1).eq.1.and.lb(i2).eq.5).
13165 & or.(lb(i1).eq.5.and.lb(i2).eq.1))
13166 & .OR.((lb(i1).eq.-1.and.lb(i2).eq.3).
13167 & or.(lb(i1).eq.3.and.lb(i2).eq.-1)) )then
13168 if(iabs(lb(i1)).eq.1)then
13169 ii = i1
13170 lb(i1)=9
13171 e(i1)=dm
13172 lb(i2)=28
13173 e(i2)=aomega
13174 go to 40
13175 else
13176 ii = i2
13177 lb(i2)=9
13178 e(i2)=dm
13179 lb(i1)=28
13180 e(i1)=aomega
13181 go to 40
13182 endif
13183 endif
13184*(2) for pi(-)+p-->D(0)+omega(0)
13185 if( ((lb(i1).eq.1.and.lb(i2).eq.3).
13186 & or.(lb(i1).eq.3.and.lb(i2).eq.1))
13187 & .OR. ((lb(i1).eq.-1.and.lb(i2).eq.5).
13188 & or.(lb(i1).eq.5.and.lb(i2).eq.-1)) )then
13189 if(iabs(lb(i1)).eq.1)then
13190 ii = i1
13191 lb(i1)=7
13192 e(i1)=dm
13193 lb(i2)=28
13194 e(i2)=aomega
13195 go to 40
13196 else
13197 ii = i2
13198 lb(i2)=7
13199 e(i2)=dm
13200 lb(i1)=28
13201 e(i1)=aomega
13202 go to 40
13203 endif
13204 endif
13205*(3) for pi(+)+n-->D(+)+omega(0)
13206 if( ((lb(i1).eq.2.and.lb(i2).eq.5).
13207 & or.(lb(i1).eq.5.and.lb(i2).eq.2))
13208 & .OR. ((lb(i1).eq.-2.and.lb(i2).eq.3).
13209 & or.(lb(i1).eq.3.and.lb(i2).eq.-2)) )then
13210 if(iabs(lb(i1)).eq.2)then
13211 ii = i1
13212 lb(i1)=8
13213 e(i1)=dm
13214 lb(i2)=28
13215 e(i2)=aomega
13216 go to 40
13217 else
13218 ii = i2
13219 lb(i2)=8
13220 e(i2)=dm
13221 lb(i1)=28
13222 e(i1)=aomega
13223 go to 40
13224 endif
13225 endif
13226*(4) for pi(0)+p-->D(+)+omega(0)
13227 if((iabs(lb(i1)).eq.1.and.lb(i2).eq.4).
13228 & or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.1))then
13229 if(iabs(lb(i1)).eq.1)then
13230 ii = i1
13231 lb(i1)=8
13232 e(i1)=dm
13233 lb(i2)=28
13234 e(i2)=aomega
13235 go to 40
13236 else
13237 ii = i2
13238 lb(i2)=8
13239 e(i2)=dm
13240 lb(i1)=28
13241 e(i1)=aomega
13242 go to 40
13243 endif
13244 endif
13245*(5) for pi(-)+n-->D(-)+omega(0)
13246 if( ((lb(i1).eq.2.and.lb(i2).eq.3).
13247 & or.(lb(i1).eq.3.and.lb(i2).eq.2))
13248 & .OR. ((lb(i1).eq.-2.and.lb(i2).eq.5).
13249 & or.(lb(i1).eq.5.and.lb(i2).eq.-2)) )then
13250 if(iabs(lb(i1)).eq.2)then
13251 ii = i1
13252 lb(i1)=6
13253 e(i1)=dm
13254 lb(i2)=28
13255 e(i2)=aomega
13256 go to 40
13257 ELSE
13258 ii = i2
13259 lb(i2)=6
13260 e(i2)=dm
13261 lb(i1)=28
13262 e(i1)=aomega
13263 endif
13264 ENDIF
13265*(6) for pi(0)+n-->D(0)+omega(0)
13266 if((iabs(lb(i1)).eq.2.and.lb(i2).eq.4).
13267 & or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.2))then
13268 if(iabs(lb(i1)).eq.2)then
13269 ii = i1
13270 lb(i1)=7
13271 e(i1)=dm
13272 lb(i2)=28
13273 e(i2)=aomega
13274 go to 40
13275 else
13276 ii = i2
13277 lb(i2)=7
13278 e(i2)=dm
13279 lb(i1)=26
13280 e(i1)=arho
13281 go to 40
13282 endif
13283 endif
13284 Endif
1328540 em1=e(i1)
13286 em2=e(i2)
13287 if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
13288 lb(ii) = -lb(ii)
13289 jj = i2
13290 if(ii .eq. i2)jj = i1
13291 if(iblock .eq. 77)then
13292 if(lb(jj).eq.3)then
13293 lb(jj) = 5
13294 elseif(lb(jj).eq.5)then
13295 lb(jj) = 3
13296 endif
13297 elseif(iblock .eq. 78)then
13298 if(lb(jj).eq.25)then
13299 lb(jj) = 27
13300 elseif(lb(jj).eq.27)then
13301 lb(jj) = 25
13302 endif
13303 endif
13304 endif
13305 endif
13306*-----------------------------------------------------------------------
13307* CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
13308* ENERGY CONSERVATION
1330950 PR2 = (SRT**2 - EM1**2 - EM2**2)**2
13310 1 - 4.0 * (EM1*EM2)**2
13311 IF(PR2.LE.0.)PR2=0.00000001
13312 PR=SQRT(PR2)/(2.*SRT)
13313* here we use the same transverse momentum distribution as for
13314* pp collisions, it might be necessary to use a different distribution
13315
13316clin-10/25/02 get rid of argument usage mismatch in PTR():
13317 xptr=0.33*pr
13318c cc1=ptr(0.33*pr,iseed)
13319 cc1=ptr(xptr,iseed)
13320clin-10/25/02-end
13321
13322 c1=sqrt(pr**2-cc1**2)/pr
13323* C1 = 1.0 - 2.0 * RANART(NSEED)
13324 T1 = 2.0 * PI * RANART(NSEED)
13325 S1 = SQRT( 1.0 - C1**2 )
13326 CT1 = COS(T1)
13327 ST1 = SIN(T1)
13328* THE MOMENTUM IN THE CMS IN THE FINAL STATE
13329 PZ = PR * C1
13330 PX = PR * S1*CT1
13331 PY = PR * S1*ST1
13332* ROTATE IT
13333 CALL ROTATE(PX0,PY0,PZ0,PX,PY,PZ)
13334 RETURN
13335 END
13336**********************************
13337* *
13338* *
13339 SUBROUTINE CREN(PX,PY,PZ,SRT,I1,I2,IBLOCK)
13340* PURPOSE: *
13341* DEALING WITH ETA+N-->L/S+KAON PROCESS *
13342* NOTE : *
13343*
13344* QUANTITIES: *
13345* PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
13346* SRT - SQRT OF S *
13347* IBLOCK - THE INFORMATION BACK *
13348* 7 ETA+N-->L/S+KAON
13349**********************************
13350 PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
13351 1 AMP=0.93828,AP1=0.13496,
13352 2 AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
13353 PARAMETER (AKA=0.498,ALA=1.1157,ASA=1.1974)
13354 parameter (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
13355 COMMON /AA/ R(3,MAXSTR)
13356cc SAVE /AA/
13357 COMMON /BB/ P(3,MAXSTR)
13358cc SAVE /BB/
13359 COMMON /CC/ E(MAXSTR)
13360cc SAVE /CC/
13361 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
13362cc SAVE /EE/
13363 common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
13364cc SAVE /input1/
13365 COMMON/RNDF77/NSEED
13366cc SAVE /RNDF77/
13367 SAVE
13368
13369 PX0=PX
13370 PY0=PY
13371 PZ0=PZ
13372 NTAG=0
13373 IBLOCK=7
13374 ianti=0
13375 if(lb(i1).lt.0 .or. lb(i2).lt.0)then
13376 ianti=1
13377 iblock=-7
13378 endif
13379* RELABLE PARTICLES FOR THE PROCESS eta+n-->LAMBDA K OR SIGMA k
13380* DECIDE LAMBDA OR SIGMA PRODUCTION, AND TO CALCULATE THE NEW
13381* MOMENTA FOR PARTICLES IN THE FINAL STATE.
13382 KAONC=0
13383 IF(PNLKA(SRT)/(PNLKA(SRT)
13384 & +PNSKA(SRT)).GT.RANART(NSEED))KAONC=1
13385 IF(E(I1).LE.0.6)THEN
13386 LB(I1)=23
13387 E(I1)=AKA
13388 IF(KAONC.EQ.1)THEN
13389 LB(I2)=14
13390 E(I2)=ALA
13391 ELSE
13392 LB(I2) = 15 + int(3 * RANART(NSEED))
13393 E(I2)=ASA
13394 ENDIF
13395 if(ianti .eq. 1)then
13396 lb(i1)=21
13397 lb(i2)=-lb(i2)
13398 endif
13399 ELSE
13400 LB(I2)=23
13401 E(I2)=AKA
13402 IF(KAONC.EQ.1)THEN
13403 LB(I1)=14
13404 E(I1)=ALA
13405 ELSE
13406 LB(I1) = 15 + int(3 * RANART(NSEED))
13407 E(I1)=ASA
13408 ENDIF
13409 if(ianti .eq. 1)then
13410 lb(i2)=21
13411 lb(i1)=-lb(i1)
13412 endif
13413 ENDIF
13414 EM1=E(I1)
13415 EM2=E(I2)
13416*-----------------------------------------------------------------------
13417* CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
13418* ENERGY CONSERVATION
13419 PR2 = (SRT**2 - EM1**2 - EM2**2)**2
13420 1 - 4.0 * (EM1*EM2)**2
13421 IF(PR2.LE.0.)PR2=1.e-09
13422 PR=SQRT(PR2)/(2.*SRT)
13423 C1 = 1.0 - 2.0 * RANART(NSEED)
13424 T1 = 2.0 * PI * RANART(NSEED)
13425 S1 = SQRT( 1.0 - C1**2 )
13426 CT1 = COS(T1)
13427 ST1 = SIN(T1)
13428* THE MOMENTUM IN THE CMS IN THE FINAL STATE
13429 PZ = PR * C1
13430 PX = PR * S1*CT1
13431 PY = PR * S1*ST1
13432* FOR THE ISOTROPIC DISTRIBUTION THERE IS NO NEED TO ROTATE
13433 RETURN
13434 END
13435**********************************
13436* *
13437* *
13438c SUBROUTINE Crdir(PX,PY,PZ,SRT,I1,I2)
13439 SUBROUTINE Crdir(PX,PY,PZ,SRT,I1,I2,IBLOCK)
13440* PURPOSE: *
13441* DEALING WITH pion+N-->pion+N PROCESS *
13442* NOTE : *
13443*
13444* QUANTITIES: *
13445* PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
13446* SRT - SQRT OF S *
13447* IBLOCK - THE INFORMATION BACK *
13448*
13449**********************************
13450 PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
13451 1 AMP=0.93828,AP1=0.13496,
13452 2 AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
13453 PARAMETER (AKA=0.498,ALA=1.1157,ASA=1.1974)
13454 parameter (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
13455 COMMON /AA/ R(3,MAXSTR)
13456cc SAVE /AA/
13457 COMMON /BB/ P(3,MAXSTR)
13458cc SAVE /BB/
13459 COMMON /CC/ E(MAXSTR)
13460cc SAVE /CC/
13461 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
13462cc SAVE /EE/
13463 common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
13464cc SAVE /input1/
13465 COMMON/RNDF77/NSEED
13466cc SAVE /RNDF77/
13467 SAVE
13468
13469 PX0=PX
13470 PY0=PY
13471 PZ0=PZ
13472 IBLOCK=999
13473 NTAG=0
13474 EM1=E(I1)
13475 EM2=E(I2)
13476*-----------------------------------------------------------------------
13477* CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
13478* ENERGY CONSERVATION
13479 PR2 = (SRT**2 - EM1**2 - EM2**2)**2
13480 1 - 4.0 * (EM1*EM2)**2
13481 IF(PR2.LE.0.)PR2=1.e-09
13482 PR=SQRT(PR2)/(2.*SRT)
13483
13484clin-10/25/02 get rid of argument usage mismatch in PTR():
13485 xptr=0.33*pr
13486c cc1=ptr(0.33*pr,iseed)
13487 cc1=ptr(xptr,iseed)
13488clin-10/25/02-end
13489
13490 c1=sqrt(pr**2-cc1**2)/pr
13491 T1 = 2.0 * PI * RANART(NSEED)
13492 S1 = SQRT( 1.0 - C1**2 )
13493 CT1 = COS(T1)
13494 ST1 = SIN(T1)
13495* THE MOMENTUM IN THE CMS IN THE FINAL STATE
13496 PZ = PR * C1
13497 PX = PR * S1*CT1
13498 PY = PR * S1*ST1
13499* ROTATE the momentum
13500 call rotate(px0,py0,pz0,px,py,pz)
13501 RETURN
13502 END
13503**********************************
13504* *
13505* *
13506 SUBROUTINE CRPD(PX,PY,PZ,SRT,I1,I2,
13507 & IBLOCK,xkaon0,xkaon,Xphi,xphin)
13508* PURPOSE: *
13509* DEALING WITH PION+D(N*)-->PION +N OR
13510* L/S+KAON PROCESS *
13511* NOTE : *
13512*
13513* QUANTITIES: *
13514* PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
13515* SRT - SQRT OF S *
13516* IBLOCK - THE INFORMATION BACK *
13517* 7 PION+D(N*)-->L/S+KAON
13518* iblock - 80 pion+D(N*)-->pion+N
13519* iblock - 81 RHO+D(N*)-->PION+N
13520* iblock - 82 OMEGA+D(N*)-->PION+N
13521* 222 PION+D --> PHI
13522**********************************
13523 PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
13524 1 AMP=0.93828,AP1=0.13496,APHI=1.020,
13525 2 AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
13526 PARAMETER (AKA=0.498,ALA=1.1157,ASA=1.1974)
13527 parameter (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
13528 COMMON /AA/ R(3,MAXSTR)
13529cc SAVE /AA/
13530 COMMON /BB/ P(3,MAXSTR)
13531cc SAVE /BB/
13532 COMMON /CC/ E(MAXSTR)
13533cc SAVE /CC/
13534 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
13535cc SAVE /EE/
13536 common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
13537cc SAVE /input1/
13538 COMMON/RNDF77/NSEED
13539cc SAVE /RNDF77/
13540 SAVE
13541
13542 PX0=PX
13543 PY0=PY
13544 PZ0=PZ
13545 IBLOCK=1
13546 x1=RANART(NSEED)
13547 ianti=0
13548 if(lb(i1).lt.0 .or. lb(i2).lt.0)ianti=1
13549 if(xkaon0/(xkaon+Xphi).ge.x1)then
13550* kaon production
13551*-----------------------------------------------------------------------
13552 IBLOCK=7
13553 if(ianti .eq. 1)iblock=-7
13554 NTAG=0
13555* RELABLE PARTICLES FOR THE PROCESS PION+n-->LAMBDA K OR SIGMA k
13556* DECIDE LAMBDA OR SIGMA PRODUCTION, AND TO CALCULATE THE NEW
13557* MOMENTA FOR PARTICLES IN THE FINAL STATE.
13558 KAONC=0
13559 IF(PNLKA(SRT)/(PNLKA(SRT)
13560 & +PNSKA(SRT)).GT.RANART(NSEED))KAONC=1
13561clin-8/17/00 & +PNSKA(SRT)).GT.RANART(NSEED))KAONC=1
13562 IF(E(I1).LE.0.2)THEN
13563 LB(I1)=23
13564 E(I1)=AKA
13565 IF(KAONC.EQ.1)THEN
13566 LB(I2)=14
13567 E(I2)=ALA
13568 ELSE
13569 LB(I2) = 15 + int(3 * RANART(NSEED))
13570 E(I2)=ASA
13571 ENDIF
13572 if(ianti .eq. 1)then
13573 lb(i1)=21
13574 lb(i2)=-lb(i2)
13575 endif
13576 ELSE
13577 LB(I2)=23
13578 E(I2)=AKA
13579 IF(KAONC.EQ.1)THEN
13580 LB(I1)=14
13581 E(I1)=ALA
13582 ELSE
13583 LB(I1) = 15 + int(3 * RANART(NSEED))
13584 E(I1)=ASA
13585 ENDIF
13586 if(ianti .eq. 1)then
13587 lb(i2)=21
13588 lb(i1)=-lb(i1)
13589 endif
13590 ENDIF
13591 EM1=E(I1)
13592 EM2=E(I2)
13593 go to 50
13594* to gererate the momentum for the kaon and L/S
13595c
13596c* Phi production
13597 elseif(Xphi/(xkaon+Xphi).ge.x1)then
13598 iblock=222
13599 if(xphin/Xphi .ge. RANART(NSEED))then
13600 LB(I1)= 1+int(2*RANART(NSEED))
13601 E(I1)=AMN
13602 else
13603 LB(I1)= 6+int(4*RANART(NSEED))
13604 E(I1)=AM0
13605 endif
13606c !! at present only baryon
13607 if(ianti .eq. 1)lb(i1)=-lb(i1)
13608 LB(I2)= 29
13609 E(I2)=APHI
13610 EM1=E(I1)
13611 EM2=E(I2)
13612 go to 50
13613 else
13614* PION REABSORPTION HAS HAPPENED
13615 X2=RANART(NSEED)
13616 IBLOCK=80
13617 ntag=0
13618* Relable particles, I1 is assigned to the nucleon
13619* and I2 is assigned to the pion
13620* for the reverse of the following process
13621*(1) for D(+)+P(+)-->p+pion(+)
13622 if( ((lb(i1).eq.8.and.lb(i2).eq.5).
13623 & or.(lb(i1).eq.5.and.lb(i2).eq.8))
13624 & .OR.((lb(i1).eq.-8.and.lb(i2).eq.3).
13625 & or.(lb(i1).eq.3.and.lb(i2).eq.-8)) )then
13626 if(iabs(lb(i1)).eq.8)then
13627 ii = i1
13628 lb(i1)=1
13629 e(i1)=amn
13630 lb(i2)=5
13631 e(i2)=ap1
13632 go to 40
13633 else
13634 ii = i2
13635 lb(i2)=1
13636 e(i2)=amn
13637 lb(i1)=5
13638 e(i1)=ap1
13639 go to 40
13640 endif
13641 endif
13642c
13643*(2) for D(0)+P(0)-->n+pi(0) or p+pi(-)
13644 if((iabs(lb(i1)).eq.7.and.lb(i2).eq.4).
13645 & or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.7))then
13646 if(iabs(lb(i1)).eq.7)then
13647 ii = i1
13648 IF(X2.LE.0.5)THEN
13649 lb(i1)=2
13650 e(i1)=amn
13651 lb(i2)=4
13652 e(i2)=ap1
13653 go to 40
13654 Else
13655 lb(i1)=1
13656 e(i1)=amn
13657 lb(i2)=3
13658 e(i2)=ap1
13659 go to 40
13660 endif
13661 else
13662 ii = i2
13663 IF(X2.LE.0.5)THEN
13664 lb(i2)=2
13665 e(i2)=amn
13666 lb(i1)=4
13667 e(i1)=ap1
13668 go to 40
13669 Else
13670 lb(i2)=1
13671 e(i2)=amn
13672 lb(i1)=3
13673 e(i1)=ap1
13674 go to 40
13675 endif
13676 endif
13677 endif
13678*(3) for D(+)+Pi(0)-->pi(+)+n or pi(0)+p
13679 if((iabs(lb(i1)).eq.8.and.lb(i2).eq.4).
13680 & or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.8))then
13681 if(iabs(lb(i1)).eq.8)then
13682 ii = i1
13683 IF(X2.LE.0.5)THEN
13684 lb(i1)=2
13685 e(i1)=amn
13686 lb(i2)=5
13687 e(i2)=ap1
13688 go to 40
13689 Else
13690 lb(i1)=1
13691 e(i1)=amn
13692 lb(i2)=4
13693 e(i2)=ap1
13694 go to 40
13695 endif
13696 else
13697 ii = i2
13698 IF(X2.LE.0.5)THEN
13699 lb(i2)=2
13700 e(i2)=amn
13701 lb(i1)=5
13702 e(i1)=ap1
13703 go to 40
13704 Else
13705 lb(i2)=1
13706 e(i2)=amn
13707 lb(i1)=4
13708 e(i1)=ap1
13709 go to 40
13710 endif
13711 endif
13712 endif
13713*(4) for D(-)+Pi(0)-->n+pi(-)
13714 if((iabs(lb(i1)).eq.6.and.lb(i2).eq.4).
13715 & or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.6))then
13716 if(iabs(lb(i1)).eq.6)then
13717 ii = i1
13718 lb(i1)=2
13719 e(i1)=amn
13720 lb(i2)=3
13721 e(i2)=ap1
13722 go to 40
13723 else
13724 ii = i2
13725 lb(i2)=2
13726 e(i2)=amn
13727 lb(i1)=3
13728 e(i1)=ap1
13729 go to 40
13730 ENDIF
13731 endif
13732*(5) for D(+)+Pi(-)-->pi(0)+n or pi(-)+p
13733 if( ((lb(i1).eq.8.and.lb(i2).eq.3).
13734 & or.(lb(i1).eq.3.and.lb(i2).eq.8))
13735 & .OR.((lb(i1).eq.-8.and.lb(i2).eq.5).
13736 & or.(lb(i1).eq.5.and.lb(i2).eq.-8)) )then
13737 if(iabs(lb(i1)).eq.8)then
13738 ii = i1
13739 IF(X2.LE.0.5)THEN
13740 lb(i1)=2
13741 e(i1)=amn
13742 lb(i2)=4
13743 e(i2)=ap1
13744 go to 40
13745 ELSE
13746 lb(i1)=1
13747 e(i1)=amn
13748 lb(i2)=3
13749 e(i2)=ap1
13750 go to 40
13751 endif
13752 else
13753 ii = i2
13754 IF(X2.LE.0.5)THEN
13755 lb(i2)=2
13756 e(i2)=amn
13757 lb(i1)=4
13758 e(i1)=ap1
13759 go to 40
13760 ELSE
13761 lb(i2)=1
13762 e(i2)=amn
13763 lb(i1)=3
13764 e(i1)=ap1
13765 go to 40
13766 endif
13767 endif
13768 ENDIF
13769*(6) D(0)+P(+)-->n+pi(+) or p+pi(0)
13770 if( ((lb(i1).eq.7.and.lb(i2).eq.5).
13771 & or.(lb(i1).eq.5.and.lb(i2).eq.7))
13772 & .OR.((lb(i1).eq.-7.and.lb(i2).eq.3).
13773 & or.(lb(i1).eq.3.and.lb(i2).eq.-7)) )then
13774 if(iabs(lb(i1)).eq.7)then
13775 ii = i1
13776 IF(X2.LE.0.5)THEN
13777 lb(i1)=2
13778 e(i1)=amn
13779 lb(i2)=5
13780 e(i2)=ap1
13781 go to 40
13782 else
13783 lb(i1)=1
13784 e(i1)=amn
13785 lb(i2)=4
13786 e(i2)=ap1
13787 go to 40
13788 endif
13789 else
13790 ii = i2
13791 IF(X2.LE.0.5)THEN
13792 lb(i2)=2
13793 e(i2)=amn
13794 lb(i1)=5
13795 e(i1)=ap1
13796 go to 40
13797 Else
13798 lb(i2)=1
13799 e(i2)=amn
13800 lb(i1)=4
13801 e(i1)=ap1
13802 go to 40
13803 endif
13804 endif
13805 ENDIF
13806*(7) for D(0)+Pi(-)-->n+pi(-)
13807 if( ((lb(i1).eq.7.and.lb(i2).eq.3).
13808 & or.(lb(i1).eq.3.and.lb(i2).eq.7))
13809 & .OR.((lb(i1).eq.-7.and.lb(i2).eq.5).
13810 & or.(lb(i1).eq.5.and.lb(i2).eq.-7)) )then
13811 if(iabs(lb(i1)).eq.7)then
13812 ii = i1
13813 lb(i1)=2
13814 e(i1)=amn
13815 lb(i2)=3
13816 e(i2)=ap1
13817 go to 40
13818 else
13819 ii = i2
13820 lb(i2)=2
13821 e(i2)=amn
13822 lb(i1)=3
13823 e(i1)=ap1
13824 go to 40
13825 ENDIF
13826 endif
13827*(8) D(-)+P(+)-->n+pi(0) or p+pi(-)
13828 if( ((lb(i1).eq.6.and.lb(i2).eq.5)
13829 & .or.(lb(i1).eq.5.and.lb(i2).eq.6))
13830 & .OR.((lb(i1).eq.-6.and.lb(i2).eq.3).
13831 & or.(lb(i1).eq.3.and.lb(i2).eq.-6)) )then
13832 if(iabs(lb(i1)).eq.6)then
13833 ii = i1
13834 IF(X2.LE.0.5)THEN
13835 lb(i1)=2
13836 e(i1)=amn
13837 lb(i2)=4
13838 e(i2)=ap1
13839 go to 40
13840 else
13841 lb(i1)=1
13842 e(i1)=amn
13843 lb(i2)=3
13844 e(i2)=ap1
13845 go to 40
13846 endif
13847 else
13848 ii = i2
13849 IF(X2.LE.0.5)THEN
13850 lb(i2)=2
13851 e(i2)=amn
13852 lb(i1)=4
13853 e(i1)=ap1
13854 go to 40
13855 Else
13856 lb(i2)=1
13857 e(i2)=amn
13858 lb(i1)=3
13859 e(i1)=ap1
13860 go to 40
13861 endif
13862 endif
13863 ENDIF
13864c
13865*(9) D(++)+P(-)-->n+pi(+) or p+pi(0)
13866 if( ((lb(i1).eq.9.and.lb(i2).eq.3)
13867 & .or.(lb(i1).eq.3.and.lb(i2).eq.9))
13868 & .OR. ((lb(i1).eq.-9.and.lb(i2).eq.5)
13869 & .or.(lb(i1).eq.5.and.lb(i2).eq.-9)) )then
13870 if(iabs(lb(i1)).eq.9)then
13871 ii = i1
13872 IF(X2.LE.0.5)THEN
13873 lb(i1)=2
13874 e(i1)=amn
13875 lb(i2)=5
13876 e(i2)=ap1
13877 go to 40
13878 else
13879 lb(i1)=1
13880 e(i1)=amn
13881 lb(i2)=4
13882 e(i2)=ap1
13883 go to 40
13884 endif
13885 else
13886 ii = i2
13887 IF(X2.LE.0.5)THEN
13888 lb(i2)=2
13889 e(i2)=amn
13890 lb(i1)=5
13891 e(i1)=ap1
13892 go to 40
13893 Else
13894 lb(i2)=1
13895 e(i2)=amn
13896 lb(i1)=4
13897 e(i1)=ap1
13898 go to 40
13899 endif
13900 endif
13901 ENDIF
13902*(10) for D(++)+Pi(0)-->p+pi(+)
13903 if((iabs(lb(i1)).eq.9.and.lb(i2).eq.4)
13904 & .or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.9))then
13905 if(iabs(lb(i1)).eq.9)then
13906 ii = i1
13907 lb(i1)=1
13908 e(i1)=amn
13909 lb(i2)=5
13910 e(i2)=ap1
13911 go to 40
13912 else
13913 ii = i2
13914 lb(i2)=1
13915 e(i2)=amn
13916 lb(i1)=5
13917 e(i1)=ap1
13918 go to 40
13919 ENDIF
13920 endif
13921*(11) for N*(1440)(+)or N*(1535)(+)+P(+)-->p+pion(+)
13922 if( ((lb(i1).eq.11.and.lb(i2).eq.5).
13923 & or.(lb(i1).eq.5.and.lb(i2).eq.11).
13924 & or.(lb(i1).eq.13.and.lb(i2).eq.5).
13925 & or.(lb(i1).eq.5.and.lb(i2).eq.13))
13926 & .OR.((lb(i1).eq.-11.and.lb(i2).eq.3).
13927 & or.(lb(i1).eq.3.and.lb(i2).eq.-11).
13928 & or.(lb(i1).eq.-13.and.lb(i2).eq.3).
13929 & or.(lb(i1).eq.3.and.lb(i2).eq.-13)) )then
13930 if(iabs(lb(i1)).eq.11.or.iabs(lb(i1)).eq.13)then
13931 ii = i1
13932 lb(i1)=1
13933 e(i1)=amn
13934 lb(i2)=5
13935 e(i2)=ap1
13936 go to 40
13937 else
13938 ii = i2
13939 lb(i2)=1
13940 e(i2)=amn
13941 lb(i1)=5
13942 e(i1)=ap1
13943 go to 40
13944 endif
13945 endif
13946*(12) for N*(1440) or N*(1535)(0)+P(0)-->n+pi(0) or p+pi(-)
13947 if((iabs(lb(i1)).eq.10.and.lb(i2).eq.4).
13948 & or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.10).
13949 & or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.12).
13950 & or.(lb(i2).eq.4.and.iabs(lb(i1)).eq.12))then
13951 if(iabs(lb(i1)).eq.10.or.iabs(lb(i1)).eq.12)then
13952 ii = i1
13953 IF(X2.LE.0.5)THEN
13954 lb(i1)=2
13955 e(i1)=amn
13956 lb(i2)=4
13957 e(i2)=ap1
13958 go to 40
13959 Else
13960 lb(i1)=1
13961 e(i1)=amn
13962 lb(i2)=3
13963 e(i2)=ap1
13964 go to 40
13965 endif
13966 else
13967 ii = i2
13968 IF(X2.LE.0.5)THEN
13969 lb(i2)=2
13970 e(i2)=amn
13971 lb(i1)=4
13972 e(i1)=ap1
13973 go to 40
13974 Else
13975 lb(i2)=1
13976 e(i2)=amn
13977 lb(i1)=3
13978 e(i1)=ap1
13979 go to 40
13980 endif
13981 endif
13982 endif
13983*(13) for N*(1440) or N*(1535)(+)+Pi(0)-->pi(+)+n or pi(0)+p
13984 if((iabs(lb(i1)).eq.11.and.lb(i2).eq.4).
13985 & or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.11).
13986 & or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.13).
13987 & or.(lb(i2).eq.4.and.iabs(lb(i1)).eq.13))then
13988 if(iabs(lb(i1)).eq.11.or.iabs(lb(i1)).eq.13)then
13989 ii = i1
13990 IF(X2.LE.0.5)THEN
13991 lb(i1)=2
13992 e(i1)=amn
13993 lb(i2)=5
13994 e(i2)=ap1
13995 go to 40
13996 Else
13997 lb(i1)=1
13998 e(i1)=amn
13999 lb(i2)=4
14000 e(i2)=ap1
14001 go to 40
14002 endif
14003 else
14004 ii = i2
14005 IF(X2.LE.0.5)THEN
14006 lb(i2)=2
14007 e(i2)=amn
14008 lb(i1)=5
14009 e(i1)=ap1
14010 go to 40
14011 Else
14012 lb(i2)=1
14013 e(i2)=amn
14014 lb(i1)=4
14015 e(i1)=ap1
14016 go to 40
14017 endif
14018 endif
14019 endif
14020*(14) for N*(1440) or N*(1535)(+)+Pi(-)-->pi(0)+n or pi(-)+p
14021 if( ((lb(i1).eq.11.and.lb(i2).eq.3).
14022 & or.(lb(i1).eq.3.and.lb(i2).eq.11).
14023 & or.(lb(i1).eq.3.and.lb(i2).eq.13).
14024 & or.(lb(i2).eq.3.and.lb(i1).eq.13))
14025 & .OR.((lb(i1).eq.-11.and.lb(i2).eq.5).
14026 & or.(lb(i1).eq.5.and.lb(i2).eq.-11).
14027 & or.(lb(i1).eq.5.and.lb(i2).eq.-13).
14028 & or.(lb(i2).eq.5.and.lb(i1).eq.-13)) )then
14029 if(iabs(lb(i1)).eq.11.or.iabs(lb(i1)).eq.13)then
14030 ii = i1
14031 IF(X2.LE.0.5)THEN
14032 lb(i1)=2
14033 e(i1)=amn
14034 lb(i2)=4
14035 e(i2)=ap1
14036 go to 40
14037 ELSE
14038 lb(i1)=1
14039 e(i1)=amn
14040 lb(i2)=3
14041 e(i2)=ap1
14042 go to 40
14043 endif
14044 else
14045 ii = i2
14046 IF(X2.LE.0.5)THEN
14047 lb(i2)=2
14048 e(i2)=amn
14049 lb(i1)=4
14050 e(i1)=ap1
14051 go to 40
14052 ELSE
14053 lb(i2)=1
14054 e(i2)=amn
14055 lb(i1)=3
14056 e(i1)=ap1
14057 go to 40
14058 endif
14059 endif
14060 ENDIF
14061*(15) N*(1440) or N*(1535)(0)+P(+)-->n+pi(+) or p+pi(0)
14062 if( ((lb(i1).eq.10.and.lb(i2).eq.5).
14063 & or.(lb(i1).eq.5.and.lb(i2).eq.10).
14064 & or.(lb(i1).eq.12.and.lb(i2).eq.5).
14065 & or.(lb(i1).eq.5.and.lb(i2).eq.12))
14066 & .OR.((lb(i1).eq.-10.and.lb(i2).eq.3).
14067 & or.(lb(i1).eq.3.and.lb(i2).eq.-10).
14068 & or.(lb(i1).eq.-12.and.lb(i2).eq.3).
14069 & or.(lb(i1).eq.3.and.lb(i2).eq.-12)) )then
14070 if(iabs(lb(i1)).eq.10.or.iabs(lb(i1)).eq.12)then
14071 ii = i1
14072 IF(X2.LE.0.5)THEN
14073 lb(i1)=2
14074 e(i1)=amn
14075 lb(i2)=5
14076 e(i2)=ap1
14077 go to 40
14078 else
14079 lb(i1)=1
14080 e(i1)=amn
14081 lb(i2)=4
14082 e(i2)=ap1
14083 go to 40
14084 endif
14085 else
14086 ii = i2
14087 IF(X2.LE.0.5)THEN
14088 lb(i2)=2
14089 e(i2)=amn
14090 lb(i1)=5
14091 e(i1)=ap1
14092 go to 40
14093 Else
14094 lb(i2)=1
14095 e(i2)=amn
14096 lb(i1)=4
14097 e(i1)=ap1
14098 go to 40
14099 endif
14100 endif
14101 ENDIF
14102*(16) for N*(1440) or N*(1535) (0)+Pi(-)-->n+pi(-)
14103 if( ((lb(i1).eq.10.and.lb(i2).eq.3).
14104 & or.(lb(i1).eq.3.and.lb(i2).eq.10).
14105 & or.(lb(i1).eq.3.and.lb(i2).eq.12).
14106 & or.(lb(i1).eq.12.and.lb(i2).eq.3))
14107 & .OR.((lb(i1).eq.-10.and.lb(i2).eq.5).
14108 & or.(lb(i1).eq.5.and.lb(i2).eq.-10).
14109 & or.(lb(i1).eq.5.and.lb(i2).eq.-12).
14110 & or.(lb(i1).eq.-12.and.lb(i2).eq.5)) )then
14111 if(iabs(lb(i1)).eq.10.or.iabs(lb(i1)).eq.12)then
14112 ii = i1
14113 lb(i1)=2
14114 e(i1)=amn
14115 lb(i2)=3
14116 e(i2)=ap1
14117 go to 40
14118 else
14119 ii = i2
14120 lb(i2)=2
14121 e(i2)=amn
14122 lb(i1)=3
14123 e(i1)=ap1
14124 go to 40
14125 ENDIF
14126 endif
1412740 em1=e(i1)
14128 em2=e(i2)
14129 if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
14130 lb(ii) = -lb(ii)
14131 jj = i2
14132 if(ii .eq. i2)jj = i1
14133 if(lb(jj).eq.3)then
14134 lb(jj) = 5
14135 elseif(lb(jj).eq.5)then
14136 lb(jj) = 3
14137 endif
14138 endif
14139 endif
14140*-----------------------------------------------------------------------
14141* CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
14142* ENERGY CONSERVATION
1414350 PR2 = (SRT**2 - EM1**2 - EM2**2)**2
14144 1 - 4.0 * (EM1*EM2)**2
14145 IF(PR2.LE.0.)PR2=1.E-09
14146 PR=SQRT(PR2)/(2.*SRT)
14147
14148clin-10/25/02 get rid of argument usage mismatch in PTR():
14149 xptr=0.33*pr
14150c cc1=ptr(0.33*pr,iseed)
14151 cc1=ptr(xptr,iseed)
14152clin-10/25/02-end
14153
14154 c1=sqrt(pr**2-cc1**2)/pr
14155c C1 = 1.0 - 2.0 * RANART(NSEED)
14156 T1 = 2.0 * PI * RANART(NSEED)
14157 S1 = SQRT( 1.0 - C1**2 )
14158 CT1 = COS(T1)
14159 ST1 = SIN(T1)
14160 PZ = PR * C1
14161 PX = PR * S1*CT1
14162 PY = PR * S1*ST1
14163* rotate the momentum
14164 call rotate(px0,py0,pz0,px,py,pz)
14165 RETURN
14166 END
14167**********************************
14168* *
14169* *
14170 SUBROUTINE CRRD(PX,PY,PZ,SRT,I1,I2,
14171 & IBLOCK,xkaon0,xkaon,Xphi,xphin)
14172* PURPOSE: *
14173* DEALING WITH rho(omega)+N or D(N*)-->PION +N OR
14174* L/S+KAON PROCESS *
14175* NOTE : *
14176*
14177* QUANTITIES: *
14178* PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
14179* SRT - SQRT OF S *
14180* IBLOCK - THE INFORMATION BACK *
14181* 7 rho(omega)+N or D(N*)-->L/S+KAON
14182* iblock - 80 pion+D(N*)-->pion+N
14183* iblock - 81 RHO+D(N*)-->PION+N
14184* iblock - 82 OMEGA+D(N*)-->PION+N
14185* iblock - 222 pion+N-->Phi
14186**********************************
14187 PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
14188 1 AMP=0.93828,AP1=0.13496,
14189 2 AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
14190 PARAMETER (AKA=0.498,ALA=1.1157,ASA=1.1974,APHI=1.02)
14191 parameter (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
14192 COMMON /AA/ R(3,MAXSTR)
14193cc SAVE /AA/
14194 COMMON /BB/ P(3,MAXSTR)
14195cc SAVE /BB/
14196 COMMON /CC/ E(MAXSTR)
14197cc SAVE /CC/
14198 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
14199cc SAVE /EE/
14200 common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
14201cc SAVE /input1/
14202 COMMON/RNDF77/NSEED
14203cc SAVE /RNDF77/
14204 SAVE
14205
14206 PX0=PX
14207 PY0=PY
14208 PZ0=PZ
14209 IBLOCK=1
14210 ianti=0
14211 if(lb(i1).lt.0 .or. lb(i2).lt.0) ianti=1
14212 x1=RANART(NSEED)
14213 if(xkaon0/(xkaon+Xphi).ge.x1)then
14214* kaon production
14215*-----------------------------------------------------------------------
14216 IBLOCK=7
14217 if(ianti .eq. 1)iblock=-7
14218 NTAG=0
14219* RELABLE PARTICLES FOR THE PROCESS PION+n-->LAMBDA K OR SIGMA k
14220* DECIDE LAMBDA OR SIGMA PRODUCTION, AND TO CALCULATE THE NEW
14221* MOMENTA FOR PARTICLES IN THE FINAL STATE.
14222 KAONC=0
14223 IF(PNLKA(SRT)/(PNLKA(SRT)
14224 & +PNSKA(SRT)).GT.RANART(NSEED))KAONC=1
14225clin-8/17/00 & +PNSKA(SRT)).GT.RANART(NSEED))KAONC=1
14226 IF(E(I1).LE.0.92)THEN
14227 LB(I1)=23
14228 E(I1)=AKA
14229 IF(KAONC.EQ.1)THEN
14230 LB(I2)=14
14231 E(I2)=ALA
14232 ELSE
14233 LB(I2) = 15 + int(3 * RANART(NSEED))
14234 E(I2)=ASA
14235 ENDIF
14236 if(ianti .eq. 1)then
14237 lb(i1) = 21
14238 lb(i2) = -lb(i2)
14239 endif
14240 ELSE
14241 LB(I2)=23
14242 E(I2)=AKA
14243 IF(KAONC.EQ.1)THEN
14244 LB(I1)=14
14245 E(I1)=ALA
14246 ELSE
14247 LB(I1) = 15 + int(3 * RANART(NSEED))
14248 E(I1)=ASA
14249 ENDIF
14250 if(ianti .eq. 1)then
14251 lb(i2) = 21
14252 lb(i1) = -lb(i1)
14253 endif
14254 ENDIF
14255 EM1=E(I1)
14256 EM2=E(I2)
14257 go to 50
14258* to gererate the momentum for the kaon and L/S
14259c
14260c* Phi production
14261 elseif(Xphi/(xkaon+Xphi).ge.x1)then
14262 iblock=222
14263 if(xphin/Xphi .ge. RANART(NSEED))then
14264 LB(I1)= 1+int(2*RANART(NSEED))
14265 E(I1)=AMN
14266 else
14267 LB(I1)= 6+int(4*RANART(NSEED))
14268 E(I1)=AM0
14269 endif
14270c !! at present only baryon
14271 if(ianti .eq. 1)lb(i1)=-lb(i1)
14272 LB(I2)= 29
14273 E(I2)=APHI
14274 EM1=E(I1)
14275 EM2=E(I2)
14276 go to 50
14277 else
14278* rho(omega) REABSORPTION HAS HAPPENED
14279 X2=RANART(NSEED)
14280 IBLOCK=81
14281 ntag=0
14282 if(lb(i1).eq.28.or.lb(i2).eq.28)go to 60
14283* we treat Rho reabsorption in the following
14284* Relable particles, I1 is assigned to the Delta
14285* and I2 is assigned to the meson
14286* for the reverse of the following process
14287*(1) for D(+)+rho(+)-->p+pion(+)
14288 if( ((lb(i1).eq.8.and.lb(i2).eq.27).
14289 & or.(lb(i1).eq.27.and.lb(i2).eq.8))
14290 & .OR. ((lb(i1).eq.-8.and.lb(i2).eq.25).
14291 & or.(lb(i1).eq.25.and.lb(i2).eq.-8)) )then
14292 if(iabs(lb(i1)).eq.8)then
14293 ii = i1
14294 lb(i1)=1
14295 e(i1)=amn
14296 lb(i2)=5
14297 e(i2)=ap1
14298 go to 40
14299 else
14300 ii = i2
14301 lb(i2)=1
14302 e(i2)=amn
14303 lb(i1)=5
14304 e(i1)=ap1
14305 go to 40
14306 endif
14307 endif
14308*(2) for D(0)+rho(0)-->n+pi(0) or p+pi(-)
14309 if((iabs(lb(i1)).eq.7.and.lb(i2).eq.26).
14310 & or.(lb(i1).eq.26.and.iabs(lb(i2)).eq.7))then
14311 if(iabs(lb(i1)).eq.7)then
14312 ii = i1
14313 IF(X2.LE.0.5)THEN
14314 lb(i1)=2
14315 e(i1)=amn
14316 lb(i2)=4
14317 e(i2)=ap1
14318 go to 40
14319 Else
14320 lb(i1)=1
14321 e(i1)=amn
14322 lb(i2)=3
14323 e(i2)=ap1
14324 go to 40
14325 endif
14326 else
14327 ii = i2
14328 IF(X2.LE.0.5)THEN
14329 lb(i2)=2
14330 e(i2)=amn
14331 lb(i1)=4
14332 e(i1)=ap1
14333 go to 40
14334 Else
14335 lb(i2)=1
14336 e(i2)=amn
14337 lb(i1)=3
14338 e(i1)=ap1
14339 go to 40
14340 endif
14341 endif
14342 endif
14343*(3) for D(+)+rho(0)-->pi(+)+n or pi(0)+p
14344 if((iabs(lb(i1)).eq.8.and.lb(i2).eq.26).
14345 & or.(lb(i1).eq.26.and.iabs(lb(i2)).eq.8))then
14346 if(iabs(lb(i1)).eq.8)then
14347 ii = i1
14348 IF(X2.LE.0.5)THEN
14349 lb(i1)=2
14350 e(i1)=amn
14351 lb(i2)=5
14352 e(i2)=ap1
14353 go to 40
14354 Else
14355 lb(i1)=1
14356 e(i1)=amn
14357 lb(i2)=4
14358 e(i2)=ap1
14359 go to 40
14360 endif
14361 else
14362 ii = i2
14363 IF(X2.LE.0.5)THEN
14364 lb(i2)=2
14365 e(i2)=amn
14366 lb(i1)=5
14367 e(i1)=ap1
14368 go to 40
14369 Else
14370 lb(i2)=1
14371 e(i2)=amn
14372 lb(i1)=4
14373 e(i1)=ap1
14374 go to 40
14375 endif
14376 endif
14377 endif
14378*(4) for D(-)+rho(0)-->n+pi(-)
14379 if((iabs(lb(i1)).eq.6.and.lb(i2).eq.26).
14380 & or.(lb(i1).eq.26.and.iabs(lb(i2)).eq.6))then
14381 if(iabs(lb(i1)).eq.6)then
14382 ii = i1
14383 lb(i1)=2
14384 e(i1)=amn
14385 lb(i2)=3
14386 e(i2)=ap1
14387 go to 40
14388 else
14389 ii = i2
14390 lb(i2)=2
14391 e(i2)=amn
14392 lb(i1)=3
14393 e(i1)=ap1
14394 go to 40
14395 ENDIF
14396 endif
14397*(5) for D(+)+rho(-)-->pi(0)+n or pi(-)+p
14398 if( ((lb(i1).eq.8.and.lb(i2).eq.25).
14399 & or.(lb(i1).eq.25.and.lb(i2).eq.8))
14400 & .OR. ((lb(i1).eq.-8.and.lb(i2).eq.27).
14401 & or.(lb(i1).eq.27.and.lb(i2).eq.-8)) )then
14402 if(iabs(lb(i1)).eq.8)then
14403 ii = i1
14404 IF(X2.LE.0.5)THEN
14405 lb(i1)=2
14406 e(i1)=amn
14407 lb(i2)=4
14408 e(i2)=ap1
14409 go to 40
14410 ELSE
14411 lb(i1)=1
14412 e(i1)=amn
14413 lb(i2)=3
14414 e(i2)=ap1
14415 go to 40
14416 endif
14417 else
14418 ii = i2
14419 IF(X2.LE.0.5)THEN
14420 lb(i2)=2
14421 e(i2)=amn
14422 lb(i1)=4
14423 e(i1)=ap1
14424 go to 40
14425 ELSE
14426 lb(i2)=1
14427 e(i2)=amn
14428 lb(i1)=3
14429 e(i1)=ap1
14430 go to 40
14431 endif
14432 endif
14433 ENDIF
14434*(6) D(0)+rho(+)-->n+pi(+) or p+pi(0)
14435 if( ((lb(i1).eq.7.and.lb(i2).eq.27).
14436 & or.(lb(i1).eq.27.and.lb(i2).eq.7))
14437 & .OR.((lb(i1).eq.-7.and.lb(i2).eq.25).
14438 & or.(lb(i1).eq.25.and.lb(i2).eq.-7)) )then
14439 if(iabs(lb(i1)).eq.7)then
14440 ii = i1
14441 IF(X2.LE.0.5)THEN
14442 lb(i1)=2
14443 e(i1)=amn
14444 lb(i2)=5
14445 e(i2)=ap1
14446 go to 40
14447 else
14448 lb(i1)=1
14449 e(i1)=amn
14450 lb(i2)=4
14451 e(i2)=ap1
14452 go to 40
14453 endif
14454 else
14455 ii = i2
14456 IF(X2.LE.0.5)THEN
14457 lb(i2)=2
14458 e(i2)=amn
14459 lb(i1)=5
14460 e(i1)=ap1
14461 go to 40
14462 Else
14463 lb(i2)=1
14464 e(i2)=amn
14465 lb(i1)=4
14466 e(i1)=ap1
14467 go to 40
14468 endif
14469 endif
14470 ENDIF
14471*(7) for D(0)+rho(-)-->n+pi(-)
14472 if( ((lb(i1).eq.7.and.lb(i2).eq.25).
14473 & or.(lb(i1).eq.25.and.lb(i2).eq.7))
14474 & .OR.((lb(i1).eq.-7.and.lb(i2).eq.27).
14475 & or.(lb(i1).eq.27.and.lb(i2).eq.-7)) )then
14476 if(iabs(lb(i1)).eq.7)then
14477 ii = i1
14478 lb(i1)=2
14479 e(i1)=amn
14480 lb(i2)=3
14481 e(i2)=ap1
14482 go to 40
14483 else
14484 ii = i2
14485 lb(i2)=2
14486 e(i2)=amn
14487 lb(i1)=3
14488 e(i1)=ap1
14489 go to 40
14490 ENDIF
14491 endif
14492*(8) D(-)+rho(+)-->n+pi(0) or p+pi(-)
14493 if( ((lb(i1).eq.6.and.lb(i2).eq.27).
14494 & or.(lb(i1).eq.27.and.lb(i2).eq.6))
14495 & .OR. ((lb(i1).eq.-6.and.lb(i2).eq.25).
14496 & or.(lb(i1).eq.25.and.lb(i2).eq.-6)) )then
14497 if(iabs(lb(i1)).eq.6)then
14498 ii = i1
14499 IF(X2.LE.0.5)THEN
14500 lb(i1)=2
14501 e(i1)=amn
14502 lb(i2)=4
14503 e(i2)=ap1
14504 go to 40
14505 else
14506 lb(i1)=1
14507 e(i1)=amn
14508 lb(i2)=3
14509 e(i2)=ap1
14510 go to 40
14511 endif
14512 else
14513 ii = i2
14514 IF(X2.LE.0.5)THEN
14515 lb(i2)=2
14516 e(i2)=amn
14517 lb(i1)=4
14518 e(i1)=ap1
14519 go to 40
14520 Else
14521 lb(i2)=1
14522 e(i2)=amn
14523 lb(i1)=3
14524 e(i1)=ap1
14525 go to 40
14526 endif
14527 endif
14528 ENDIF
14529*(9) D(++)+rho(-)-->n+pi(+) or p+pi(0)
14530 if( ((lb(i1).eq.9.and.lb(i2).eq.25).
14531 & or.(lb(i1).eq.25.and.lb(i2).eq.9))
14532 & .OR.((lb(i1).eq.-9.and.lb(i2).eq.27).
14533 & or.(lb(i1).eq.27.and.lb(i2).eq.-9)) )then
14534 if(iabs(lb(i1)).eq.9)then
14535 ii = i1
14536 IF(X2.LE.0.5)THEN
14537 lb(i1)=2
14538 e(i1)=amn
14539 lb(i2)=5
14540 e(i2)=ap1
14541 go to 40
14542 else
14543 lb(i1)=1
14544 e(i1)=amn
14545 lb(i2)=4
14546 e(i2)=ap1
14547 go to 40
14548 endif
14549 else
14550 ii = i2
14551 IF(X2.LE.0.5)THEN
14552 lb(i2)=2
14553 e(i2)=amn
14554 lb(i1)=5
14555 e(i1)=ap1
14556 go to 40
14557 Else
14558 lb(i2)=1
14559 e(i2)=amn
14560 lb(i1)=4
14561 e(i1)=ap1
14562 go to 40
14563 endif
14564 endif
14565 ENDIF
14566*(10) for D(++)+rho(0)-->p+pi(+)
14567 if((iabs(lb(i1)).eq.9.and.lb(i2).eq.26).
14568 & or.(lb(i1).eq.26.and.iabs(lb(i2)).eq.9))then
14569 if(iabs(lb(i1)).eq.9)then
14570 ii = i1
14571 lb(i1)=1
14572 e(i1)=amn
14573 lb(i2)=5
14574 e(i2)=ap1
14575 go to 40
14576 else
14577 ii = i2
14578 lb(i2)=1
14579 e(i2)=amn
14580 lb(i1)=5
14581 e(i1)=ap1
14582 go to 40
14583 ENDIF
14584 endif
14585*(11) for N*(1440)(+)or N*(1535)(+)+rho(+)-->p+pion(+)
14586 if( ((lb(i1).eq.11.and.lb(i2).eq.27).
14587 & or.(lb(i1).eq.27.and.lb(i2).eq.11).
14588 & or.(lb(i1).eq.13.and.lb(i2).eq.27).
14589 & or.(lb(i1).eq.27.and.lb(i2).eq.13))
14590 & .OR. ((lb(i1).eq.-11.and.lb(i2).eq.25).
14591 & or.(lb(i1).eq.25.and.lb(i2).eq.-11).
14592 & or.(lb(i1).eq.-13.and.lb(i2).eq.25).
14593 & or.(lb(i1).eq.25.and.lb(i2).eq.-13)) )then
14594 if(iabs(lb(i1)).eq.11.or.iabs(lb(i1)).eq.13)then
14595 ii = i1
14596 lb(i1)=1
14597 e(i1)=amn
14598 lb(i2)=5
14599 e(i2)=ap1
14600 go to 40
14601 else
14602 ii = i2
14603 lb(i2)=1
14604 e(i2)=amn
14605 lb(i1)=5
14606 e(i1)=ap1
14607 go to 40
14608 endif
14609 endif
14610*(12) for N*(1440) or N*(1535)(0)+rho(0)-->n+pi(0) or p+pi(-)
14611 if((iabs(lb(i1)).eq.10.and.lb(i2).eq.26).
14612 & or.(lb(i1).eq.26.and.iabs(lb(i2)).eq.10).
14613 & or.(lb(i1).eq.26.and.iabs(lb(i2)).eq.12).
14614 & or.(lb(i2).eq.26.and.iabs(lb(i1)).eq.12))then
14615 if(iabs(lb(i1)).eq.10.or.iabs(lb(i1)).eq.12)then
14616 ii = i1
14617 IF(X2.LE.0.5)THEN
14618 lb(i1)=2
14619 e(i1)=amn
14620 lb(i2)=4
14621 e(i2)=ap1
14622 go to 40
14623 Else
14624 lb(i1)=1
14625 e(i1)=amn
14626 lb(i2)=3
14627 e(i2)=ap1
14628 go to 40
14629 endif
14630 else
14631 ii = i2
14632 IF(X2.LE.0.5)THEN
14633 lb(i2)=2
14634 e(i2)=amn
14635 lb(i1)=4
14636 e(i1)=ap1
14637 go to 40
14638 Else
14639 lb(i2)=1
14640 e(i2)=amn
14641 lb(i1)=3
14642 e(i1)=ap1
14643 go to 40
14644 endif
14645 endif
14646 endif
14647*(13) for N*(1440) or N*(1535)(+)+rho(0)-->pi(+)+n or pi(0)+p
14648 if((iabs(lb(i1)).eq.11.and.lb(i2).eq.26).
14649 & or.(lb(i1).eq.26.and.iabs(lb(i2)).eq.11).
14650 & or.(lb(i1).eq.26.and.iabs(lb(i2)).eq.13).
14651 & or.(lb(i2).eq.26.and.iabs(lb(i1)).eq.13))then
14652 if(iabs(lb(i1)).eq.11.or.iabs(lb(i1)).eq.13)then
14653 ii = i1
14654 IF(X2.LE.0.5)THEN
14655 lb(i1)=2
14656 e(i1)=amn
14657 lb(i2)=5
14658 e(i2)=ap1
14659 go to 40
14660 Else
14661 lb(i1)=1
14662 e(i1)=amn
14663 lb(i2)=4
14664 e(i2)=ap1
14665 go to 40
14666 endif
14667 else
14668 ii = i2
14669 IF(X2.LE.0.5)THEN
14670 lb(i2)=2
14671 e(i2)=amn
14672 lb(i1)=5
14673 e(i1)=ap1
14674 go to 40
14675 Else
14676 lb(i2)=1
14677 e(i2)=amn
14678 lb(i1)=4
14679 e(i1)=ap1
14680 go to 40
14681 endif
14682 endif
14683 endif
14684*(14) for N*(1440) or N*(1535)(+)+rho(-)-->pi(0)+n or pi(-)+p
14685 if( ((lb(i1).eq.11.and.lb(i2).eq.25).
14686 & or.(lb(i1).eq.25.and.lb(i2).eq.11).
14687 & or.(lb(i1).eq.25.and.lb(i2).eq.13).
14688 & or.(lb(i2).eq.25.and.lb(i1).eq.13))
14689 & .OR.((lb(i1).eq.-11.and.lb(i2).eq.27).
14690 & or.(lb(i1).eq.27.and.lb(i2).eq.-11).
14691 & or.(lb(i1).eq.27.and.lb(i2).eq.-13).
14692 & or.(lb(i2).eq.27.and.lb(i1).eq.-13)) )then
14693 if(iabs(lb(i1)).eq.11.or.iabs(lb(i1)).eq.13)then
14694 ii = i1
14695 IF(X2.LE.0.5)THEN
14696 lb(i1)=2
14697 e(i1)=amn
14698 lb(i2)=4
14699 e(i2)=ap1
14700 go to 40
14701 ELSE
14702 lb(i1)=1
14703 e(i1)=amn
14704 lb(i2)=3
14705 e(i2)=ap1
14706 go to 40
14707 endif
14708 else
14709 ii = i2
14710 IF(X2.LE.0.5)THEN
14711 lb(i2)=2
14712 e(i2)=amn
14713 lb(i1)=4
14714 e(i1)=ap1
14715 go to 40
14716 ELSE
14717 lb(i2)=1
14718 e(i2)=amn
14719 lb(i1)=3
14720 e(i1)=ap1
14721 go to 40
14722 endif
14723 endif
14724 ENDIF
14725*(15) N*(1440) or N*(1535)(0)+rho(+)-->n+pi(+) or p+pi(0)
14726 if( ((lb(i1).eq.10.and.lb(i2).eq.27).
14727 & or.(lb(i1).eq.27.and.lb(i2).eq.10).
14728 & or.(lb(i1).eq.12.and.lb(i2).eq.27).
14729 & or.(lb(i1).eq.27.and.lb(i2).eq.12))
14730 & .OR.((lb(i1).eq.-10.and.lb(i2).eq.25).
14731 & or.(lb(i1).eq.25.and.lb(i2).eq.-10).
14732 & or.(lb(i1).eq.-12.and.lb(i2).eq.25).
14733 & or.(lb(i1).eq.25.and.lb(i2).eq.-12)) )then
14734 if(iabs(lb(i1)).eq.10.or.iabs(lb(i1)).eq.12)then
14735 ii = i1
14736 IF(X2.LE.0.5)THEN
14737 lb(i1)=2
14738 e(i1)=amn
14739 lb(i2)=5
14740 e(i2)=ap1
14741 go to 40
14742 else
14743 lb(i1)=1
14744 e(i1)=amn
14745 lb(i2)=4
14746 e(i2)=ap1
14747 go to 40
14748 endif
14749 else
14750 ii = i2
14751 IF(X2.LE.0.5)THEN
14752 lb(i2)=2
14753 e(i2)=amn
14754 lb(i1)=5
14755 e(i1)=ap1
14756 go to 40
14757 Else
14758 lb(i2)=1
14759 e(i2)=amn
14760 lb(i1)=4
14761 e(i1)=ap1
14762 go to 40
14763 endif
14764 endif
14765 ENDIF
14766*(16) for N*(1440) or N*(1535) (0)+rho(-)-->n+pi(-)
14767 if( ((lb(i1).eq.10.and.lb(i2).eq.25).
14768 & or.(lb(i1).eq.25.and.lb(i2).eq.10).
14769 & or.(lb(i1).eq.25.and.lb(i2).eq.12).
14770 & or.(lb(i1).eq.12.and.lb(i2).eq.25))
14771 & .OR. ((lb(i1).eq.-10.and.lb(i2).eq.27).
14772 & or.(lb(i1).eq.27.and.lb(i2).eq.-10).
14773 & or.(lb(i1).eq.27.and.lb(i2).eq.-12).
14774 & or.(lb(i1).eq.-12.and.lb(i2).eq.27)) )then
14775 if(iabs(lb(i1)).eq.10.or.iabs(lb(i1)).eq.12)then
14776 ii = i1
14777 lb(i1)=2
14778 e(i1)=amn
14779 lb(i2)=3
14780 e(i2)=ap1
14781 go to 40
14782 else
14783 ii = i2
14784 lb(i2)=2
14785 e(i2)=amn
14786 lb(i1)=3
14787 e(i1)=ap1
14788 go to 40
14789 ENDIF
14790 endif
1479160 IBLOCK=82
14792* FOR OMEGA REABSORPTION
14793* Relable particles, I1 is assigned to the Delta
14794* and I2 is assigned to the meson
14795* for the reverse of the following process
14796*(1) for D(0)+OMEGA(0)-->n+pi(0) or p+pi(-)
14797 if((iabs(lb(i1)).eq.7.and.lb(i2).eq.28).
14798 & or.(lb(i1).eq.28.and.iabs(lb(i2)).eq.7))then
14799 if(iabs(lb(i1)).eq.7)then
14800 ii = i1
14801 IF(X2.LE.0.5)THEN
14802 lb(i1)=2
14803 e(i1)=amn
14804 lb(i2)=4
14805 e(i2)=ap1
14806 go to 40
14807 Else
14808 lb(i1)=1
14809 e(i1)=amn
14810 lb(i2)=3
14811 e(i2)=ap1
14812 go to 40
14813 endif
14814 else
14815 ii = i2
14816 IF(X2.LE.0.5)THEN
14817 lb(i2)=2
14818 e(i2)=amn
14819 lb(i1)=4
14820 e(i1)=ap1
14821 go to 40
14822 Else
14823 lb(i2)=1
14824 e(i2)=amn
14825 lb(i1)=3
14826 e(i1)=ap1
14827 go to 40
14828 endif
14829 endif
14830 endif
14831*(2) for D(+)+OMEGA(0)-->pi(+)+n or pi(0)+p
14832 if((iabs(lb(i1)).eq.8.and.lb(i2).eq.28).
14833 & or.(lb(i1).eq.28.and.iabs(lb(i2)).eq.8))then
14834 if(iabs(lb(i1)).eq.8)then
14835 ii = i1
14836 IF(X2.LE.0.5)THEN
14837 lb(i1)=2
14838 e(i1)=amn
14839 lb(i2)=5
14840 e(i2)=ap1
14841 go to 40
14842 Else
14843 lb(i1)=1
14844 e(i1)=amn
14845 lb(i2)=4
14846 e(i2)=ap1
14847 go to 40
14848 endif
14849 else
14850 ii = i2
14851 IF(X2.LE.0.5)THEN
14852 lb(i2)=2
14853 e(i2)=amn
14854 lb(i1)=5
14855 e(i1)=ap1
14856 go to 40
14857 Else
14858 lb(i2)=1
14859 e(i2)=amn
14860 lb(i1)=4
14861 e(i1)=ap1
14862 go to 40
14863 endif
14864 endif
14865 endif
14866*(3) for D(-)+OMEGA(0)-->n+pi(-)
14867 if((iabs(lb(i1)).eq.6.and.lb(i2).eq.28).
14868 & or.(lb(i1).eq.28.and.iabs(lb(i2)).eq.6))then
14869 if(iabs(lb(i1)).eq.6)then
14870 ii = i1
14871 lb(i1)=2
14872 e(i1)=amn
14873 lb(i2)=3
14874 e(i2)=ap1
14875 go to 40
14876 else
14877 ii = i2
14878 lb(i2)=2
14879 e(i2)=amn
14880 lb(i1)=3
14881 e(i1)=ap1
14882 go to 40
14883 ENDIF
14884 endif
14885*(4) for D(++)+OMEGA(0)-->p+pi(+)
14886 if((iabs(lb(i1)).eq.9.and.lb(i2).eq.28).
14887 & or.(lb(i1).eq.28.and.iabs(lb(i2)).eq.9))then
14888 if(iabs(lb(i1)).eq.9)then
14889 ii = i1
14890 lb(i1)=1
14891 e(i1)=amn
14892 lb(i2)=5
14893 e(i2)=ap1
14894 go to 40
14895 else
14896 ii = i2
14897 lb(i2)=1
14898 e(i2)=amn
14899 lb(i1)=5
14900 e(i1)=ap1
14901 go to 40
14902 ENDIF
14903 endif
14904*(5) for N*(1440) or N*(1535)(0)+omega(0)-->n+pi(0) or p+pi(-)
14905 if((iabs(lb(i1)).eq.10.and.lb(i2).eq.28).
14906 & or.(lb(i1).eq.28.and.iabs(lb(i2)).eq.10).
14907 & or.(lb(i1).eq.28.and.iabs(lb(i2)).eq.12).
14908 & or.(lb(i2).eq.28.and.iabs(lb(i1)).eq.12))then
14909 if(iabs(lb(i1)).eq.10.or.iabs(lb(i1)).eq.12)then
14910 ii = i1
14911 IF(X2.LE.0.5)THEN
14912 lb(i1)=2
14913 e(i1)=amn
14914 lb(i2)=4
14915 e(i2)=ap1
14916 go to 40
14917 Else
14918 lb(i1)=1
14919 e(i1)=amn
14920 lb(i2)=3
14921 e(i2)=ap1
14922 go to 40
14923 endif
14924 else
14925 ii = i2
14926 IF(X2.LE.0.5)THEN
14927 lb(i2)=2
14928 e(i2)=amn
14929 lb(i1)=4
14930 e(i1)=ap1
14931 go to 40
14932 Else
14933 lb(i2)=1
14934 e(i2)=amn
14935 lb(i1)=3
14936 e(i1)=ap1
14937 go to 40
14938 endif
14939 endif
14940 endif
14941*(6) for N*(1440) or N*(1535)(+)+omega(0)-->pi(+)+n or pi(0)+p
14942 if((iabs(lb(i1)).eq.11.and.lb(i2).eq.28).
14943 & or.(lb(i1).eq.28.and.iabs(lb(i2)).eq.11).
14944 & or.(lb(i1).eq.28.and.iabs(lb(i2)).eq.13).
14945 & or.(lb(i2).eq.28.and.iabs(lb(i1)).eq.13))then
14946 if(iabs(lb(i1)).eq.11.or.iabs(lb(i1)).eq.13)then
14947 ii = i1
14948 IF(X2.LE.0.5)THEN
14949 lb(i1)=2
14950 e(i1)=amn
14951 lb(i2)=5
14952 e(i2)=ap1
14953 go to 40
14954 Else
14955 lb(i1)=1
14956 e(i1)=amn
14957 lb(i2)=4
14958 e(i2)=ap1
14959 go to 40
14960 endif
14961 else
14962 ii = i2
14963 IF(X2.LE.0.5)THEN
14964 lb(i2)=2
14965 e(i2)=amn
14966 lb(i1)=5
14967 e(i1)=ap1
14968 go to 40
14969 Else
14970 lb(i2)=1
14971 e(i2)=amn
14972 lb(i1)=4
14973 e(i1)=ap1
14974 go to 40
14975 endif
14976 endif
14977 endif
1497840 em1=e(i1)
14979 em2=e(i2)
14980 if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
14981 lb(ii) = -lb(ii)
14982 jj = i2
14983 if(ii .eq. i2)jj = i1
14984 if(lb(jj).eq.3)then
14985 lb(jj) = 5
14986 elseif(lb(jj).eq.5)then
14987 lb(jj) = 3
14988 endif
14989 endif
14990 endif
14991*-----------------------------------------------------------------------
14992* CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
14993* ENERGY CONSERVATION
1499450 PR2 = (SRT**2 - EM1**2 - EM2**2)**2
14995 1 - 4.0 * (EM1*EM2)**2
14996 IF(PR2.LE.0.)PR2=1.E-09
14997 PR=SQRT(PR2)/(2.*SRT)
14998* C1 = 1.0 - 2.0 * RANART(NSEED)
14999
15000clin-10/25/02 get rid of argument usage mismatch in PTR():
15001 xptr=0.33*pr
15002c cc1=ptr(0.33*pr,iseed)
15003 cc1=ptr(xptr,iseed)
15004clin-10/25/02-end
15005
15006 c1=sqrt(pr**2-cc1**2)/pr
15007 T1 = 2.0 * PI * RANART(NSEED)
15008 S1 = SQRT( 1.0 - C1**2 )
15009 CT1 = COS(T1)
15010 ST1 = SIN(T1)
15011 PZ = PR * C1
15012 PX = PR * S1*CT1
15013 PY = PR * S1*ST1
15014* ROTATE THE MOMENTUM
15015 CALL ROTATE(PX0,PY0,PZ0,PX,PY,PZ)
15016 RETURN
15017 END
15018**********************************
15019* sp 03/19/01 *
15020* *
15021 SUBROUTINE Crlaba(PX,PY,PZ,SRT,brel,brsgm,
15022 & I1,I2,nt,IBLOCK,nchrg,icase)
15023* PURPOSE: *
15024* DEALING WITH K+ + N(D,N*)-bar <--> La(Si)-bar + pi *
15025* NOTE : *
15026* *
15027* QUANTITIES: *
15028* PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
15029* SRT - SQRT OF S *
15030* IBLOCK - THE INFORMATION BACK *
15031* 8-> elastic scatt *
15032* 100-> K+ + N-bar -> Sigma-bar + PI
15033* 102-> PI + Sigma(Lambda)-bar -> K+ + N-bar
15034**********************************
15035 PARAMETER (MAXSTR=150001, MAXR=1, AMN=0.939457,
15036 1 AMP=0.93828,AP1=0.13496,
15037 2 AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
15038 PARAMETER (AKA=0.498,ALA=1.1157,ASA=1.1974)
15039 PARAMETER (ETAM=0.5475, AOMEGA=0.782, ARHO=0.77)
15040 COMMON /AA/ R(3,MAXSTR)
15041cc SAVE /AA/
15042 COMMON /BB/ P(3,MAXSTR)
15043cc SAVE /BB/
15044 COMMON /CC/ E(MAXSTR)
15045cc SAVE /CC/
15046 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
15047cc SAVE /EE/
15048 common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
15049cc SAVE /input1/
15050 COMMON/RNDF77/NSEED
15051cc SAVE /RNDF77/
15052 SAVE
15053 NT=NT
15054c
15055 PX0=PX
15056 PY0=PY
15057 PZ0=PZ
15058c
15059 if(icase .eq. 3)then
15060 rrr=RANART(NSEED)
15061 if(rrr.lt.brel) then
15062c !! elastic scat. (avoid in reverse process)
15063 IBLOCK=8
15064 else
15065 IBLOCK=100
15066 if(rrr.lt.(brel+brsgm)) then
15067c* K+ + N-bar -> Sigma-bar + PI
15068 LB(i1) = -15 - int(3 * RANART(NSEED))
15069
15070 e(i1)=asa
15071 else
15072c* K+ + N-bar -> Lambda-bar + PI
15073 LB(i1)= -14
15074 e(i1)=ala
15075 endif
15076 LB(i2) = 3 + int(3 * RANART(NSEED))
15077 e(i2)=0.138
15078 endif
15079 endif
15080c
15081c
15082 if(icase .eq. 4)then
15083 rrr=RANART(NSEED)
15084 if(rrr.lt.brel) then
15085c !! elastic scat.
15086 IBLOCK=8
15087 else
15088 IBLOCK=102
15089c PI + Sigma(Lambda)-bar -> K+ + N-bar
15090c ! K+
15091 LB(i1) = 23
15092 LB(i2) = -1 - int(2 * RANART(NSEED))
15093 if(nchrg.eq.-2) LB(i2) = -6
15094 if(nchrg.eq. 1) LB(i2) = -9
15095 e(i1) = aka
15096 e(i2) = 0.938
15097 if(nchrg.eq.-2.or.nchrg.eq.1) e(i2)=1.232
15098 endif
15099 endif
15100c
15101 EM1=E(I1)
15102 EM2=E(I2)
15103* CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
15104* ENERGY CONSERVATION
15105 PR2 = (SRT**2 - EM1**2 - EM2**2)**2
15106 1 - 4.0 * (EM1*EM2)**2
15107 IF(PR2.LE.0.)PR2=1.e-09
15108 PR=SQRT(PR2)/(2.*SRT)
15109 C1 = 1.0 - 2.0 * RANART(NSEED)
15110 T1 = 2.0 * PI * RANART(NSEED)
15111 S1 = SQRT( 1.0 - C1**2 )
15112 CT1 = COS(T1)
15113 ST1 = SIN(T1)
15114 PZ = PR * C1
15115 PX = PR * S1*CT1
15116 PY = PR * S1*ST1
15117* ROTATE IT
15118 CALL ROTATE(PX0,PY0,PZ0,PX,PY,PZ)
15119 RETURN
15120 END
15121**********************************
15122* *
15123* *
15124 SUBROUTINE Crkn(PX,PY,PZ,SRT,I1,I2,IBLOCK)
15125* PURPOSE: *
15126* DEALING WITH kaON+N/pi-->KAON +N/pi elastic PROCESS *
15127* NOTE : *
15128*
15129* QUANTITIES: *
15130* PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
15131* SRT - SQRT OF S *
15132* IBLOCK - THE INFORMATION BACK *
15133* 8-> PION+N-->L/S+KAON
15134**********************************
15135 PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
15136 1 AMP=0.93828,AP1=0.13496,
15137 2 AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
15138 PARAMETER (AKA=0.498,ALA=1.1157,ASA=1.1974)
15139 parameter (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
15140 COMMON /AA/ R(3,MAXSTR)
15141cc SAVE /AA/
15142 COMMON /BB/ P(3,MAXSTR)
15143cc SAVE /BB/
15144 COMMON /CC/ E(MAXSTR)
15145cc SAVE /CC/
15146 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
15147cc SAVE /EE/
15148 common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
15149cc SAVE /input1/
15150 COMMON/RNDF77/NSEED
15151cc SAVE /RNDF77/
15152 SAVE
15153
15154 PX0=PX
15155 PY0=PY
15156 PZ0=PZ
15157*-----------------------------------------------------------------------
15158 IBLOCK=8
15159 NTAG=0
15160 EM1=E(I1)
15161 EM2=E(I2)
15162*-----------------------------------------------------------------------
15163* CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
15164* ENERGY CONSERVATION
15165 PR2 = (SRT**2 - EM1**2 - EM2**2)**2
15166 1 - 4.0 * (EM1*EM2)**2
15167 IF(PR2.LE.0.)PR2=1.e-09
15168 PR=SQRT(PR2)/(2.*SRT)
15169 C1 = 1.0 - 2.0 * RANART(NSEED)
15170 T1 = 2.0 * PI * RANART(NSEED)
15171 S1 = SQRT( 1.0 - C1**2 )
15172 CT1 = COS(T1)
15173 ST1 = SIN(T1)
15174 PZ = PR * C1
15175 PX = PR * S1*CT1
15176 PY = PR * S1*ST1
15177 RETURN
15178 END
15179**********************************
15180* *
15181* *
15182 SUBROUTINE Crppba(PX,PY,PZ,SRT,I1,I2,IBLOCK)
15183* PURPOSE: *
15184
15185clin-8/29/00* DEALING WITH anti-nucleon annihilation with
15186* DEALING WITH anti-baryon annihilation with
15187
15188* nucleons or baryon resonances
15189* Determine: *
15190* (1) no. of pions in the final state
15191* (2) relable particles in the final state
15192* (3) new momenta of final state particles *
15193*
15194* QUANTITIES: *
15195* PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
15196* SRT - SQRT OF S *
15197* IBLOCK - INFORMATION about the reaction channel *
15198*
15199* iblock - 1902 annihilation-->pion(+)+pion(-) (2 pion)
15200* iblock - 1903 annihilation-->pion(+)+rho(-) (3 pion)
15201* iblock - 1904 annihilation-->rho(+)+rho(-) (4 pion)
15202* iblock - 1905 annihilation-->rho(0)+omega (5 pion)
15203* iblock - 1906 annihilation-->omega+omega (6 pion)
15204* charge conservation is enforced in relabling particles
15205* in the final state (note: at the momentum we don't check the
15206* initial charges while dealing with annihilation, since some
15207* annihilation channels between antinucleons and nucleons (baryon
15208* resonances) might be forbiden by charge conservation, this effect
15209* should be small, but keep it in mind.
15210**********************************
15211 PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
15212 1 AMP=0.93828,AP1=0.13496,AMRHO=0.769,AMOMGA=0.782,
15213 2 AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
15214 PARAMETER (AKA=0.498,ALA=1.1157,ASA=1.1974)
15215 parameter (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
15216 COMMON /AA/ R(3,MAXSTR)
15217cc SAVE /AA/
15218 COMMON /BB/ P(3,MAXSTR)
15219cc SAVE /BB/
15220 COMMON /CC/ E(MAXSTR)
15221cc SAVE /CC/
15222 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
15223cc SAVE /EE/
15224 common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
15225cc SAVE /input1/
15226 COMMON/RNDF77/NSEED
15227cc SAVE /RNDF77/
15228 SAVE
15229
15230 PX0=PX
15231 PY0=PY
15232 PZ0=PZ
15233* determine the no. of pions in the final state using a
15234* statistical model
15235 call pbarfs(srt,npion,iseed)
15236* find the masses of the final state particles before calculate
15237* their momenta, and relable them. The masses of rho and omega
15238* will be generated according to the Breit Wigner formula (NOTE!!!
15239* NOT DONE YET, AT THE MOMENT LET US USE FIXED RHO AND OMEGA MAEES)
15240cbali2/22/99
15241* Here we generate two stes of integer random numbers (3,4,5)
15242* one or both of them are used directly as the lables of pions
15243* similarly, 22+nchrg1 and 22+nchrg2 are used directly
15244* to label rhos
15245 nchrg1=3+int(3*RANART(NSEED))
15246 nchrg2=3+int(3*RANART(NSEED))
15247* the corresponding masses of pions
15248 pmass1=ap1
15249 pmass2=ap1
15250 if(nchrg1.eq.3.or.nchrg1.eq.5)pmass1=ap2
15251 if(nchrg2.eq.3.or.nchrg2.eq.5)pmass2=ap2
15252* (1) for 2 pion production
15253 IF(NPION.EQ.2)THEN
15254 IBLOCK=1902
15255* randomly generate the charges of final state particles,
15256 LB(I1)=nchrg1
15257 E(I1)=pmass1
15258 LB(I2)=nchrg2
15259 E(I2)=pmass2
15260* TO CALCULATE THE FINAL MOMENTA
15261 GO TO 50
15262 ENDIF
15263* (2) FOR 3 PION PRODUCTION
15264 IF(NPION.EQ.3)THEN
15265 IBLOCK=1903
15266 LB(I1)=nchrg1
15267 E(I1)=pmass1
15268 LB(I2)=22+nchrg2
15269 E(I2)=AMRHO
15270 GO TO 50
15271 ENDIF
15272* (3) FOR 4 PION PRODUCTION
15273* we allow both rho+rho and pi+omega with 50-50% probability
15274 IF(NPION.EQ.4)THEN
15275 IBLOCK=1904
15276* determine rho+rho or pi+omega
15277 if(RANART(NSEED).ge.0.5)then
15278* rho+rho
15279 LB(I1)=22+nchrg1
15280 E(I1)=AMRHO
15281 LB(I2)=22+nchrg2
15282 E(I2)=AMRHO
15283 else
15284* pion+omega
15285 LB(I1)=nchrg1
15286 E(I1)=pmass1
15287 LB(I2)=28
15288 E(I2)=AMOMGA
15289 endif
15290 GO TO 50
15291 ENDIF
15292* (4) FOR 5 PION PRODUCTION
15293 IF(NPION.EQ.5)THEN
15294 IBLOCK=1905
15295* RHO AND OMEGA
15296 LB(I1)=22+nchrg1
15297 E(I1)=AMRHO
15298 LB(I2)=28
15299 E(I2)=AMOMGA
15300 GO TO 50
15301 ENDIF
15302* (5) FOR 6 PION PRODUCTION
15303 IF(NPION.EQ.6)THEN
15304 IBLOCK=1906
15305* OMEGA AND OMEGA
15306 LB(I1)=28
15307 E(I1)=AMOMGA
15308 LB(I2)=28
15309 E(I2)=AMOMGA
15310 ENDIF
15311cbali2/22/99
1531250 EM1=E(I1)
15313 EM2=E(I2)
15314*-----------------------------------------------------------------------
15315* CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
15316* ENERGY CONSERVATION
15317 PR2 = (SRT**2 - EM1**2 - EM2**2)**2
15318 1 - 4.0 * (EM1*EM2)**2
15319 IF(PR2.LE.0.)PR2=1.E-08
15320 PR=SQRT(PR2)/(2.*SRT)
15321* WE ASSUME AN ISOTROPIC ANGULAR DISTRIBUTION IN THE CMS
15322 C1 = 1.0 - 2.0 * RANART(NSEED)
15323 T1 = 2.0 * PI * RANART(NSEED)
15324 S1 = SQRT( 1.0 - C1**2 )
15325 CT1 = COS(T1)
15326 ST1 = SIN(T1)
15327* THE MOMENTUM IN THE CMS IN THE FINAL STATE
15328 PZ = PR * C1
15329 PX = PR * S1*CT1
15330 PY = PR * S1*ST1
15331* ROTATE IT
15332 CALL ROTATE(PX0,PY0,PZ0,PX,PY,PZ)
15333 RETURN
15334 END
15335cbali2/7/99end
15336cbali3/5/99
15337**********************************
15338* PURPOSE: *
15339* assign final states for K+K- --> light mesons
15340*
15341 SUBROUTINE crkkpi(I1,I2,XSK1, XSK2, XSK3, XSK4,
15342 & XSK5, XSK6, XSK7, XSK8, XSK9, XSK10, XSK11, SIGK,
15343 & IBLOCK,lbp1,lbp2,emm1,emm2)
15344*
15345* QUANTITIES: *
15346* IBLOCK - INFORMATION about the reaction channel *
15347*
15348* iblock - 1907
15349**********************************
15350 PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
15351 1 AMP=0.93828,AP1=0.13496,AMRHO=0.769,AMOMGA=0.782,
15352 & AMETA = 0.5473,
15353 2 AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
15354 PARAMETER (AKA=0.498,ALA=1.1157,ASA=1.1974)
15355 parameter (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
15356 COMMON /AA/ R(3,MAXSTR)
15357cc SAVE /AA/
15358 COMMON /BB/ P(3,MAXSTR)
15359cc SAVE /BB/
15360 COMMON /CC/ E(MAXSTR)
15361cc SAVE /CC/
15362 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
15363cc SAVE /EE/
15364 common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
15365cc SAVE /input1/
15366 COMMON/RNDF77/NSEED
15367cc SAVE /RNDF77/
15368 SAVE
15369
15370 XSK11=XSK11
15371 IBLOCK=1907
15372 X1 = RANART(NSEED) * SIGK
15373 XSK2 = XSK1 + XSK2
15374 XSK3 = XSK2 + XSK3
15375 XSK4 = XSK3 + XSK4
15376 XSK5 = XSK4 + XSK5
15377 XSK6 = XSK5 + XSK6
15378 XSK7 = XSK6 + XSK7
15379 XSK8 = XSK7 + XSK8
15380 XSK9 = XSK8 + XSK9
15381 XSK10 = XSK9 + XSK10
15382 IF (X1 .LE. XSK1) THEN
15383 LB(I1) = 3 + int(3 * RANART(NSEED))
15384 LB(I2) = 3 + int(3 * RANART(NSEED))
15385 E(I1) = AP2
15386 E(I2) = AP2
15387 GOTO 100
15388 ELSE IF (X1 .LE. XSK2) THEN
15389 LB(I1) = 3 + int(3 * RANART(NSEED))
15390 LB(I2) = 25 + int(3 * RANART(NSEED))
15391 E(I1) = AP2
15392 E(I2) = AMRHO
15393 GOTO 100
15394 ELSE IF (X1 .LE. XSK3) THEN
15395 LB(I1) = 3 + int(3 * RANART(NSEED))
15396 LB(I2) = 28
15397 E(I1) = AP2
15398 E(I2) = AMOMGA
15399 GOTO 100
15400 ELSE IF (X1 .LE. XSK4) THEN
15401 LB(I1) = 3 + int(3 * RANART(NSEED))
15402 LB(I2) = 0
15403 E(I1) = AP2
15404 E(I2) = AMETA
15405 GOTO 100
15406 ELSE IF (X1 .LE. XSK5) THEN
15407 LB(I1) = 25 + int(3 * RANART(NSEED))
15408 LB(I2) = 25 + int(3 * RANART(NSEED))
15409 E(I1) = AMRHO
15410 E(I2) = AMRHO
15411 GOTO 100
15412 ELSE IF (X1 .LE. XSK6) THEN
15413 LB(I1) = 25 + int(3 * RANART(NSEED))
15414 LB(I2) = 28
15415 E(I1) = AMRHO
15416 E(I2) = AMOMGA
15417 GOTO 100
15418 ELSE IF (X1 .LE. XSK7) THEN
15419 LB(I1) = 25 + int(3 * RANART(NSEED))
15420 LB(I2) = 0
15421 E(I1) = AMRHO
15422 E(I2) = AMETA
15423 GOTO 100
15424 ELSE IF (X1 .LE. XSK8) THEN
15425 LB(I1) = 28
15426 LB(I2) = 28
15427 E(I1) = AMOMGA
15428 E(I2) = AMOMGA
15429 GOTO 100
15430 ELSE IF (X1 .LE. XSK9) THEN
15431 LB(I1) = 28
15432 LB(I2) = 0
15433 E(I1) = AMOMGA
15434 E(I2) = AMETA
15435 GOTO 100
15436 ELSE IF (X1 .LE. XSK10) THEN
15437 LB(I1) = 0
15438 LB(I2) = 0
15439 E(I1) = AMETA
15440 E(I2) = AMETA
15441 ELSE
15442 iblock = 222
15443 call rhores(i1,i2)
15444c !! phi
15445 lb(i1) = 29
15446c return
15447 e(i2)=0.
15448 END IF
15449
15450 100 CONTINUE
15451 lbp1=lb(i1)
15452 lbp2=lb(i2)
15453 emm1=e(i1)
15454 emm2=e(i2)
15455
15456 RETURN
15457 END
15458**********************************
15459* PURPOSE: *
15460* DEALING WITH K+Y -> piN scattering
15461*
15462 SUBROUTINE Crkhyp(PX,PY,PZ,SRT,I1,I2,
15463 & XKY1, XKY2, XKY3, XKY4, XKY5,
15464 & XKY6, XKY7, XKY8, XKY9, XKY10, XKY11, XKY12, XKY13,
15465 & XKY14, XKY15, XKY16, XKY17, SIGK, IKMP,
15466 & IBLOCK)
15467*
15468* Determine: *
15469* (1) relable particles in the final state *
15470* (2) new momenta of final state particles *
15471* *
15472* QUANTITIES: *
15473* PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
15474* SRT - SQRT OF S *
15475* IBLOCK - INFORMATION about the reaction channel *
15476* *
15477* iblock - 1908 *
15478* iblock - 222 !! phi *
15479**********************************
15480 PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
15481 1 AMP=0.93828,AP1=0.13496,AMRHO=0.769,AMOMGA=0.782,APHI=1.02,
15482 2 AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
15483 parameter (pimass=0.140, AMETA = 0.5473, aka=0.498,
15484 & aml=1.116,ams=1.193, AM1440 = 1.44, AM1535 = 1.535)
15485 parameter (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
15486 COMMON /AA/ R(3,MAXSTR)
15487cc SAVE /AA/
15488 COMMON /BB/ P(3,MAXSTR)
15489cc SAVE /BB/
15490 COMMON /CC/ E(MAXSTR)
15491cc SAVE /CC/
15492 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
15493cc SAVE /EE/
15494 common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
15495cc SAVE /input1/
15496 COMMON/RNDF77/NSEED
15497cc SAVE /RNDF77/
15498 SAVE
15499
15500 XKY17=XKY17
15501 PX0=PX
15502 PY0=PY
15503 PZ0=PZ
15504 IBLOCK=1908
15505c
15506 X1 = RANART(NSEED) * SIGK
15507 XKY2 = XKY1 + XKY2
15508 XKY3 = XKY2 + XKY3
15509 XKY4 = XKY3 + XKY4
15510 XKY5 = XKY4 + XKY5
15511 XKY6 = XKY5 + XKY6
15512 XKY7 = XKY6 + XKY7
15513 XKY8 = XKY7 + XKY8
15514 XKY9 = XKY8 + XKY9
15515 XKY10 = XKY9 + XKY10
15516 XKY11 = XKY10 + XKY11
15517 XKY12 = XKY11 + XKY12
15518 XKY13 = XKY12 + XKY13
15519 XKY14 = XKY13 + XKY14
15520 XKY15 = XKY14 + XKY15
15521 XKY16 = XKY15 + XKY16
15522 IF (X1 .LE. XKY1) THEN
15523 LB(I1) = 3 + int(3 * RANART(NSEED))
15524 LB(I2) = 1 + int(2 * RANART(NSEED))
15525 E(I1) = PIMASS
15526 E(I2) = AMP
15527 GOTO 100
15528 ELSE IF (X1 .LE. XKY2) THEN
15529 LB(I1) = 3 + int(3 * RANART(NSEED))
15530 LB(I2) = 6 + int(4 * RANART(NSEED))
15531 E(I1) = PIMASS
15532 E(I2) = AM0
15533 GOTO 100
15534 ELSE IF (X1 .LE. XKY3) THEN
15535 LB(I1) = 3 + int(3 * RANART(NSEED))
15536 LB(I2) = 10 + int(2 * RANART(NSEED))
15537 E(I1) = PIMASS
15538 E(I2) = AM1440
15539 GOTO 100
15540 ELSE IF (X1 .LE. XKY4) THEN
15541 LB(I1) = 3 + int(3 * RANART(NSEED))
15542 LB(I2) = 12 + int(2 * RANART(NSEED))
15543 E(I1) = PIMASS
15544 E(I2) = AM1535
15545 GOTO 100
15546 ELSE IF (X1 .LE. XKY5) THEN
15547 LB(I1) = 25 + int(3 * RANART(NSEED))
15548 LB(I2) = 1 + int(2 * RANART(NSEED))
15549 E(I1) = AMRHO
15550 E(I2) = AMP
15551 GOTO 100
15552 ELSE IF (X1 .LE. XKY6) THEN
15553 LB(I1) = 25 + int(3 * RANART(NSEED))
15554 LB(I2) = 6 + int(4 * RANART(NSEED))
15555 E(I1) = AMRHO
15556 E(I2) = AM0
15557 GOTO 100
15558 ELSE IF (X1 .LE. XKY7) THEN
15559 LB(I1) = 25 + int(3 * RANART(NSEED))
15560 LB(I2) = 10 + int(2 * RANART(NSEED))
15561 E(I1) = AMRHO
15562 E(I2) = AM1440
15563 GOTO 100
15564 ELSE IF (X1 .LE. XKY8) THEN
15565 LB(I1) = 25 + int(3 * RANART(NSEED))
15566 LB(I2) = 12 + int(2 * RANART(NSEED))
15567 E(I1) = AMRHO
15568 E(I2) = AM1535
15569 GOTO 100
15570 ELSE IF (X1 .LE. XKY9) THEN
15571 LB(I1) = 28
15572 LB(I2) = 1 + int(2 * RANART(NSEED))
15573 E(I1) = AMOMGA
15574 E(I2) = AMP
15575 GOTO 100
15576 ELSE IF (X1 .LE. XKY10) THEN
15577 LB(I1) = 28
15578 LB(I2) = 6 + int(4 * RANART(NSEED))
15579 E(I1) = AMOMGA
15580 E(I2) = AM0
15581 GOTO 100
15582 ELSE IF (X1 .LE. XKY11) THEN
15583 LB(I1) = 28
15584 LB(I2) = 10 + int(2 * RANART(NSEED))
15585 E(I1) = AMOMGA
15586 E(I2) = AM1440
15587 GOTO 100
15588 ELSE IF (X1 .LE. XKY12) THEN
15589 LB(I1) = 28
15590 LB(I2) = 12 + int(2 * RANART(NSEED))
15591 E(I1) = AMOMGA
15592 E(I2) = AM1535
15593 GOTO 100
15594 ELSE IF (X1 .LE. XKY13) THEN
15595 LB(I1) = 0
15596 LB(I2) = 1 + int(2 * RANART(NSEED))
15597 E(I1) = AMETA
15598 E(I2) = AMP
15599 GOTO 100
15600 ELSE IF (X1 .LE. XKY14) THEN
15601 LB(I1) = 0
15602 LB(I2) = 6 + int(4 * RANART(NSEED))
15603 E(I1) = AMETA
15604 E(I2) = AM0
15605 GOTO 100
15606 ELSE IF (X1 .LE. XKY15) THEN
15607 LB(I1) = 0
15608 LB(I2) = 10 + int(2 * RANART(NSEED))
15609 E(I1) = AMETA
15610 E(I2) = AM1440
15611 GOTO 100
15612 ELSE IF (X1 .LE. XKY16) THEN
15613 LB(I1) = 0
15614 LB(I2) = 12 + int(2 * RANART(NSEED))
15615 E(I1) = AMETA
15616 E(I2) = AM1535
15617 GOTO 100
15618 ELSE
15619 LB(I1) = 29
15620 LB(I2) = 1 + int(2 * RANART(NSEED))
15621 E(I1) = APHI
15622 E(I2) = AMN
15623 IBLOCK=222
15624 GOTO 100
15625 END IF
15626
15627 100 CONTINUE
15628 if(IKMP .eq. -1) LB(I2) = -LB(I2)
15629
15630 EM1=E(I1)
15631 EM2=E(I2)
15632*-----------------------------------------------------------------------
15633* CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
15634* ENERGY CONSERVATION
15635 PR2 = (SRT**2 - EM1**2 - EM2**2)**2
15636 1 - 4.0 * (EM1*EM2)**2
15637 IF(PR2.LE.0.)PR2=1.E-08
15638 PR=SQRT(PR2)/(2.*SRT)
15639* WE ASSUME AN ISOTROPIC ANGULAR DISTRIBUTION IN THE CMS
15640 C1 = 1.0 - 2.0 * RANART(NSEED)
15641 T1 = 2.0 * PI * RANART(NSEED)
15642 S1 = SQRT( 1.0 - C1**2 )
15643 CT1 = COS(T1)
15644 ST1 = SIN(T1)
15645* THE MOMENTUM IN THE CMS IN THE FINAL STATE
15646 PZ = PR * C1
15647 PX = PR * S1*CT1
15648 PY = PR * S1*ST1
15649* ROTATE IT
15650 CALL ROTATE(PX0,PY0,PZ0,PX,PY,PZ)
15651 RETURN
15652 END
15653**********************************
15654* *
15655* *
15656 SUBROUTINE CRLAN(PX,PY,PZ,SRT,I1,I2,IBLOCK)
15657* PURPOSE: *
15658* DEALING WITH La/Si-bar + N --> K+ + pi PROCESS *
15659* La/Si + N-bar --> K- + pi *
15660* NOTE : *
15661*
15662* QUANTITIES: *
15663* PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
15664* SRT - SQRT OF S *
15665* IBLOCK - THE INFORMATION BACK *
15666* 71
15667**********************************
15668 PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
15669 1 AMP=0.93828,AP1=0.13496,
15670 2 AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
15671 PARAMETER (AKA=0.498,ALA=1.1157,ASA=1.1974)
15672 parameter (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
15673 COMMON /AA/ R(3,MAXSTR)
15674cc SAVE /AA/
15675 COMMON /BB/ P(3,MAXSTR)
15676cc SAVE /BB/
15677 COMMON /CC/ E(MAXSTR)
15678cc SAVE /CC/
15679 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
15680cc SAVE /EE/
15681 common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
15682cc SAVE /input1/
15683 COMMON/RNDF77/NSEED
15684cc SAVE /RNDF77/
15685 SAVE
15686
15687 PX0=PX
15688 PY0=PY
15689 PZ0=PZ
15690 IBLOCK=71
15691 NTAG=0
15692 if( (lb(i1).ge.14.and.lb(i1).le.17) .OR.
15693 & (lb(i2).ge.14.and.lb(i2).le.17) )then
15694 LB(I1)=21
15695 else
15696 LB(I1)=23
15697 endif
15698 LB(I2)= 3 + int(3 * RANART(NSEED))
15699 E(I1)=AKA
15700 E(I2)=0.138
15701 EM1=E(I1)
15702 EM2=E(I2)
15703*-----------------------------------------------------------------------
15704* CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
15705* ENERGY CONSERVATION
15706 PR2 = (SRT**2 - EM1**2 - EM2**2)**2
15707 1 - 4.0 * (EM1*EM2)**2
15708 IF(PR2.LE.0.)PR2=1.e-09
15709 PR=SQRT(PR2)/(2.*SRT)
15710 C1 = 1.0 - 2.0 * RANART(NSEED)
15711 T1 = 2.0 * PI * RANART(NSEED)
15712 S1 = SQRT( 1.0 - C1**2 )
15713 CT1 = COS(T1)
15714 ST1 = SIN(T1)
15715* THE MOMENTUM IN THE CMS IN THE FINAL STATE
15716 PZ = PR * C1
15717 PX = PR * S1*CT1
15718 PY = PR * S1*ST1
15719* FOR THE ISOTROPIC DISTRIBUTION THERE IS NO NEED TO ROTATE
15720 RETURN
15721 END
15722csp11/03/01 end
15723**********************************
15724**********************************
15725* *
15726* *
15727 SUBROUTINE Crkpla(PX,PY,PZ,EC,SRT,spika,
15728 & emm1,emm2,lbp1,lbp2,I1,I2,icase,srhoks)
15729
15730* PURPOSE: *
15731* DEALING WITH K+ + Pi ---> La/Si-bar + B, phi+K, phi+K* OR K* *
15732* K- + Pi ---> La/Si + B-bar OR K*-bar *
15733
15734* NOTE : *
15735*
15736* QUANTITIES: *
15737* PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
15738* SRT - SQRT OF S *
15739* IBLOCK - THE INFORMATION BACK *
15740* 71
15741**********************************
15742 PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
15743 1 AMP=0.93828,AP1=0.13496,AP2=0.13957,AMRHO=0.769,AMOMGA=0.782,
15744 2 AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
15745 PARAMETER (AKA=0.498,AKS=0.895,ALA=1.1157,ASA=1.1974
15746 1 ,APHI=1.02)
15747 PARAMETER (AM1440 = 1.44, AM1535 = 1.535)
15748 parameter (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
15749 COMMON /AA/ R(3,MAXSTR)
15750cc SAVE /AA/
15751 COMMON /BB/ P(3,MAXSTR)
15752cc SAVE /BB/
15753 COMMON /CC/ E(MAXSTR)
15754cc SAVE /CC/
15755 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
15756cc SAVE /EE/
15757 common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
15758cc SAVE /input1/
15759 COMMON/RNDF77/NSEED
15760cc SAVE /RNDF77/
15761 SAVE
15762
15763 emm1=0.
15764 emm2=0.
15765 lbp1=0
15766 lbp2=0
15767 XKP0 = spika
15768 XKP1 = 0.
15769 XKP2 = 0.
15770 XKP3 = 0.
15771 XKP4 = 0.
15772 XKP5 = 0.
15773 XKP6 = 0.
15774 XKP7 = 0.
15775 XKP8 = 0.
15776 XKP9 = 0.
15777 XKP10 = 0.
15778 sigm = 15.
15779c if(lb(i1).eq.21.or.lb(i2).eq.21)sigm=10.
15780 pdd = (srt**2-(aka+ap1)**2)*(srt**2-(aka-ap1)**2)
15781c
15782 if(srt .lt. (ala+amn))go to 70
15783 XKP1 = sigm*(4./3.)*(srt**2-(ala+amn)**2)*
15784 & (srt**2-(ala-amn)**2)/pdd
15785 if(srt .gt. (ala+am0))then
15786 XKP2 = sigm*(16./3.)*(srt**2-(ala+am0)**2)*
15787 & (srt**2-(ala-am0)**2)/pdd
15788 endif
15789 if(srt .gt. (ala+am1440))then
15790 XKP3 = sigm*(4./3.)*(srt**2-(ala+am1440)**2)*
15791 & (srt**2-(ala-am1440)**2)/pdd
15792 endif
15793 if(srt .gt. (ala+am1535))then
15794 XKP4 = sigm*(4./3.)*(srt**2-(ala+am1535)**2)*
15795 & (srt**2-(ala-am1535)**2)/pdd
15796 endif
15797c
15798 if(srt .gt. (asa+amn))then
15799 XKP5 = sigm*4.*(srt**2-(asa+amn)**2)*
15800 & (srt**2-(asa-amn)**2)/pdd
15801 endif
15802 if(srt .gt. (asa+am0))then
15803 XKP6 = sigm*16.*(srt**2-(asa+am0)**2)*
15804 & (srt**2-(asa-am0)**2)/pdd
15805 endif
15806 if(srt .gt. (asa+am1440))then
15807 XKP7 = sigm*4.*(srt**2-(asa+am1440)**2)*
15808 & (srt**2-(asa-am1440)**2)/pdd
15809 endif
15810 if(srt .gt. (asa+am1535))then
15811 XKP8 = sigm*4.*(srt**2-(asa+am1535)**2)*
15812 & (srt**2-(asa-am1535)**2)/pdd
15813 endif
1581470 continue
15815 sig1 = 195.639
15816 sig2 = 372.378
15817 if(srt .gt. aphi+aka)then
15818 pff = sqrt((srt**2-(aphi+aka)**2)*(srt**2-(aphi-aka)**2))
15819 XKP9 = sig1*pff/sqrt(pdd)*1./32./pi/srt**2
15820 if(srt .gt. aphi+aks)then
15821 pff = sqrt((srt**2-(aphi+aks)**2)*(srt**2-(aphi-aks)**2))
15822 XKP10 = sig2*pff/sqrt(pdd)*3./32./pi/srt**2
15823 endif
15824 endif
15825
15826clin-8/15/02 K pi -> K* (rho omega), from detailed balance,
15827c neglect rho and omega mass difference for now:
15828 sigpik=0.
15829 if(srt.gt.(amrho+aks)) then
15830 sigpik=srhoks*9.
15831 1 *(srt**2-(0.77-aks)**2)*(srt**2-(0.77+aks)**2)/4
15832 2 /srt**2/(px**2+py**2+pz**2)
15833 if(srt.gt.(amomga+aks)) sigpik=sigpik*12./9.
15834 endif
15835
15836c
15837 sigkp = XKP0 + XKP1 + XKP2 + XKP3 + XKP4
15838 & + XKP5 + XKP6 + XKP7 + XKP8 + XKP9 + XKP10 +sigpik
15839 icase = 0
15840 DSkn=SQRT(sigkp/PI/10.)
15841 dsknr=dskn+0.1
15842 CALL DISTCE(I1,I2,dsknr,DSkn,DT,EC,SRT,IC,
15843 1 PX,PY,PZ)
15844 IF(IC.EQ.-1)return
15845c
15846 randu = RANART(NSEED)*sigkp
15847 XKP1 = XKP0 + XKP1
15848 XKP2 = XKP1 + XKP2
15849 XKP3 = XKP2 + XKP3
15850 XKP4 = XKP3 + XKP4
15851 XKP5 = XKP4 + XKP5
15852 XKP6 = XKP5 + XKP6
15853 XKP7 = XKP6 + XKP7
15854 XKP8 = XKP7 + XKP8
15855 XKP9 = XKP8 + XKP9
15856
15857 XKP10 = XKP9 + XKP10
15858c
15859c !! K* formation
15860 if(randu .le. XKP0)then
15861 icase = 1
15862 return
15863 else
15864* La/Si-bar + B formation
15865 icase = 2
15866 if( randu .le. XKP1 )then
15867 lbp1 = -14
15868 lbp2 = 1 + int(2*RANART(NSEED))
15869 emm1 = ala
15870 emm2 = amn
15871 go to 60
15872 elseif( randu .le. XKP2 )then
15873 lbp1 = -14
15874 lbp2 = 6 + int(4*RANART(NSEED))
15875 emm1 = ala
15876 emm2 = am0
15877 go to 60
15878 elseif( randu .le. XKP3 )then
15879 lbp1 = -14
15880 lbp2 = 10 + int(2*RANART(NSEED))
15881 emm1 = ala
15882 emm2 = am1440
15883 go to 60
15884 elseif( randu .le. XKP4 )then
15885 lbp1 = -14
15886 lbp2 = 12 + int(2*RANART(NSEED))
15887 emm1 = ala
15888 emm2 = am1535
15889 go to 60
15890 elseif( randu .le. XKP5 )then
15891 lbp1 = -15 - int(3*RANART(NSEED))
15892 lbp2 = 1 + int(2*RANART(NSEED))
15893 emm1 = asa
15894 emm2 = amn
15895 go to 60
15896 elseif( randu .le. XKP6 )then
15897 lbp1 = -15 - int(3*RANART(NSEED))
15898 lbp2 = 6 + int(4*RANART(NSEED))
15899 emm1 = asa
15900 emm2 = am0
15901 go to 60
15902 elseif( randu .lt. XKP7 )then
15903 lbp1 = -15 - int(3*RANART(NSEED))
15904 lbp2 = 10 + int(2*RANART(NSEED))
15905 emm1 = asa
15906 emm2 = am1440
15907 go to 60
15908 elseif( randu .lt. XKP8 )then
15909 lbp1 = -15 - int(3*RANART(NSEED))
15910 lbp2 = 12 + int(2*RANART(NSEED))
15911 emm1 = asa
15912 emm2 = am1535
15913 go to 60
15914 elseif( randu .lt. XKP9 )then
15915c !! phi +K formation (iblock=224)
15916 icase = 3
15917 lbp1 = 29
15918 lbp2 = 23
15919 emm1 = aphi
15920 emm2 = aka
15921 if(lb(i1).eq.21.or.lb(i2).eq.21)then
15922c !! phi +K-bar formation (iblock=124)
15923 lbp2 = 21
15924 icase = -3
15925 endif
15926 go to 60
15927 elseif( randu .lt. XKP10 )then
15928c !! phi +K* formation (iblock=226)
15929 icase = 4
15930 lbp1 = 29
15931 lbp2 = 30
15932 emm1 = aphi
15933 emm2 = aks
15934 if(lb(i1).eq.21.or.lb(i2).eq.21)then
15935 lbp2 = -30
15936 icase = -4
15937 endif
15938 go to 60
15939
15940 else
15941c !! (rho,omega) +K* formation (iblock=88)
15942 icase=5
15943 lbp1=25+int(3*RANART(NSEED))
15944 lbp2=30
15945 emm1=amrho
15946 emm2=aks
15947 if(srt.gt.(amomga+aks).and.RANART(NSEED).lt.0.25) then
15948 lbp1=28
15949 emm1=amomga
15950 endif
15951 if(lb(i1).eq.21.or.lb(i2).eq.21)then
15952 lbp2=-30
15953 icase=-5
15954 endif
15955
15956 endif
15957 endif
15958c
1595960 if( icase.eq.2 .and. (lb(i1).eq.21.or.lb(i2).eq.21) )then
15960 lbp1 = -lbp1
15961 lbp2 = -lbp2
15962 endif
15963 PX0=PX
15964 PY0=PY
15965 PZ0=PZ
15966*-----------------------------------------------------------------------
15967* CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
15968* ENERGY CONSERVATION
15969 PR2 = (SRT**2 - EMM1**2 - EMM2**2)**2
15970 1 - 4.0 * (EMM1*EMM2)**2
15971 IF(PR2.LE.0.)PR2=1.e-09
15972 PR=SQRT(PR2)/(2.*SRT)
15973 C1 = 1.0 - 2.0 * RANART(NSEED)
15974 T1 = 2.0 * PI * RANART(NSEED)
15975 S1 = SQRT( 1.0 - C1**2 )
15976 CT1 = COS(T1)
15977 ST1 = SIN(T1)
15978* THE MOMENTUM IN THE CMS IN THE FINAL STATE
15979 PZ = PR * C1
15980 PX = PR * S1*CT1
15981 PY = PR * S1*ST1
15982* FOR THE ISOTROPIC DISTRIBUTION THERE IS NO NEED TO ROTATE
15983 RETURN
15984 END
15985**********************************
15986* *
15987* *
15988 SUBROUTINE Crkphi(PX,PY,PZ,EC,SRT,IBLOCK,
15989 & emm1,emm2,lbp1,lbp2,I1,I2,ikk,icase,rrkk,prkk)
15990
15991* PURPOSE: *
15992* DEALING WITH KKbar, KK*bar, KbarK*, K*K*bar --> Phi + pi(rho,omega)
15993* and KKbar --> (pi eta) (pi eta), (rho omega) (rho omega)
15994* and KK*bar or Kbar K* --> (pi eta) (rho omega)
15995*
15996* NOTE : *
15997*
15998* QUANTITIES: *
15999* PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
16000* SRT - SQRT OF S *
16001* IBLOCK - THE INFORMATION BACK *
16002* 222
16003**********************************
16004 PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
16005 1 AMP=0.93828,AP1=0.13496,AP2=0.13957,APHI=1.02,
16006 2 AM0=1.232,AMNS=1.52,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
16007 PARAMETER (AKA=0.498,ALA=1.1157,ASA=1.1974,ACAS=1.3213)
16008 PARAMETER (AKS=0.895,AOMEGA=0.7819, ARHO=0.77)
16009 parameter (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
16010 COMMON /AA/ R(3,MAXSTR)
16011cc SAVE /AA/
16012 COMMON /BB/ P(3,MAXSTR)
16013cc SAVE /BB/
16014 COMMON /CC/ E(MAXSTR)
16015cc SAVE /CC/
16016 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
16017cc SAVE /EE/
16018 common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
16019cc SAVE /input1/
16020 COMMON/RNDF77/NSEED
16021cc SAVE /RNDF77/
16022 SAVE
16023
16024 lb1 = lb(i1)
16025 lb2 = lb(i2)
16026 icase = 0
16027
16028c if(srt .lt. aphi+ap1)return
16029cc if(srt .lt. aphi+ap1) then
16030 if(srt .lt. (aphi+ap1)) then
16031 sig1 = 0.
16032 sig2 = 0.
16033 sig3 = 0.
16034 else
16035c
16036 if((lb1.eq.23.and.lb2.eq.21).or.(lb2.eq.23.and.lb1.eq.21))then
16037 dnr = 4.
16038 ikk = 2
16039 elseif((lb1.eq.21.and.lb2.eq.30).or.(lb2.eq.21.and.lb1.eq.30)
16040 & .or.(lb1.eq.23.and.lb2.eq.-30).or.(lb2.eq.23.and.lb1.eq.-30))then
16041 dnr = 12.
16042 ikk = 1
16043 else
16044 dnr = 36.
16045 ikk = 0
16046 endif
16047
16048 sig1 = 0.
16049 sig2 = 0.
16050 sig3 = 0.
16051 srri = E(i1)+E(i2)
16052 srr1 = aphi+ap1
16053 srr2 = aphi+aomega
16054 srr3 = aphi+arho
16055c
16056 pii = (srt**2-(e(i1)+e(i2))**2)*(srt**2-(e(i1)-e(i2))**2)
16057 srrt = srt - amax1(srri,srr1)
16058cc to avoid divergent/negative values at small srrt:
16059c if(srrt .lt. 0.3)then
16060 if(srrt .lt. 0.3 .and. srrt .gt. 0.01)then
16061 sig = 1.69/(srrt**0.141 - 0.407)
16062 else
16063 sig = 3.74 + 0.008*srrt**1.9
16064 endif
16065 sig1=sig*(9./dnr)*(srt**2-(aphi+ap1)**2)*
16066 & (srt**2-(aphi-ap1)**2)/pii
16067 if(srt .gt. aphi+aomega)then
16068 srrt = srt - amax1(srri,srr2)
16069cc if(srrt .lt. 0.3)then
16070 if(srrt .lt. 0.3 .and. srrt .gt. 0.01)then
16071 sig = 1.69/(srrt**0.141 - 0.407)
16072 else
16073 sig = 3.74 + 0.008*srrt**1.9
16074 endif
16075 sig2=sig*(9./dnr)*(srt**2-(aphi+aomega)**2)*
16076 & (srt**2-(aphi-aomega)**2)/pii
16077 endif
16078 if(srt .gt. aphi+arho)then
16079 srrt = srt - amax1(srri,srr3)
16080cc if(srrt .lt. 0.3)then
16081 if(srrt .lt. 0.3 .and. srrt .gt. 0.01)then
16082 sig = 1.69/(srrt**0.141 - 0.407)
16083 else
16084 sig = 3.74 + 0.008*srrt**1.9
16085 endif
16086 sig3=sig*(27./dnr)*(srt**2-(aphi+arho)**2)*
16087 & (srt**2-(aphi-arho)**2)/pii
16088 endif
16089c sig1 = amin1(20.,sig1)
16090c sig2 = amin1(20.,sig2)
16091c sig3 = amin1(20.,sig3)
16092 endif
16093
16094 rrkk0=rrkk
16095 prkk0=prkk
16096 SIGM=0.
16097 if((lb1.eq.23.and.lb2.eq.21).or.(lb2.eq.23.and.lb1.eq.21))then
16098 CALL XKKANN(SRT, XSK1, XSK2, XSK3, XSK4, XSK5,
16099 & XSK6, XSK7, XSK8, XSK9, XSK10, XSK11, SIGM, rrkk0)
16100 elseif((lb1.eq.21.and.lb2.eq.30).or.(lb2.eq.21.and.lb1.eq.30)
16101 & .or.(lb1.eq.23.and.lb2.eq.-30).or.(lb2.eq.23.and.lb1.eq.-30))then
16102 CALL XKKSAN(i1,i2,SRT,SIGKS1,SIGKS2,SIGKS3,SIGKS4,SIGM,prkk0)
16103 else
16104 endif
16105c
16106c sigks = sig1 + sig2 + sig3
16107 sigm0=sigm
16108 sigks = sig1 + sig2 + sig3 + SIGM
16109 DSkn=SQRT(sigks/PI/10.)
16110 dsknr=dskn+0.1
16111 CALL DISTCE(I1,I2,dsknr,DSkn,DT,EC,SRT,IC,
16112 1 PX,PY,PZ)
16113 IF(IC.EQ.-1)return
16114 icase = 1
16115 ranx = RANART(NSEED)
16116
16117 lbp1 = 29
16118 emm1 = aphi
16119 if(ranx .le. sig1/sigks)then
16120 lbp2 = 3 + int(3*RANART(NSEED))
16121 emm2 = ap1
16122 elseif(ranx .le. (sig1+sig2)/sigks)then
16123 lbp2 = 28
16124 emm2 = aomega
16125 elseif(ranx .le. (sig1+sig2+sig3)/sigks)then
16126 lbp2 = 25 + int(3*RANART(NSEED))
16127 emm2 = arho
16128 else
16129 if((lb1.eq.23.and.lb2.eq.21)
16130 & .or.(lb2.eq.23.and.lb1.eq.21))then
16131 CALL crkkpi(I1,I2,XSK1, XSK2, XSK3, XSK4,
16132 & XSK5, XSK6, XSK7, XSK8, XSK9, XSK10, XSK11, SIGM0,
16133 & IBLOCK,lbp1,lbp2,emm1,emm2)
16134 elseif((lb1.eq.21.and.lb2.eq.30)
16135 & .or.(lb2.eq.21.and.lb1.eq.30)
16136 & .or.(lb1.eq.23.and.lb2.eq.-30)
16137 & .or.(lb2.eq.23.and.lb1.eq.-30))then
16138 CALL crkspi(I1,I2,SIGKS1, SIGKS2, SIGKS3, SIGKS4,
16139 & SIGM0,IBLOCK,lbp1,lbp2,emm1,emm2)
16140 else
16141 endif
16142 endif
16143*
16144 PX0=PX
16145 PY0=PY
16146 PZ0=PZ
16147*-----------------------------------------------------------------------
16148* CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
16149* ENERGY CONSERVATION
16150 PR2 = (SRT**2 - EMM1**2 - EMM2**2)**2
16151 1 - 4.0 * (EMM1*EMM2)**2
16152 IF(PR2.LE.0.)PR2=1.e-09
16153 PR=SQRT(PR2)/(2.*SRT)
16154 C1 = 1.0 - 2.0 * RANART(NSEED)
16155 T1 = 2.0 * PI * RANART(NSEED)
16156 S1 = SQRT( 1.0 - C1**2 )
16157 CT1 = COS(T1)
16158 ST1 = SIN(T1)
16159* THE MOMENTUM IN THE CMS IN THE FINAL STATE
16160 PZ = PR * C1
16161 PX = PR * S1*CT1
16162 PY = PR * S1*ST1
16163* FOR THE ISOTROPIC DISTRIBUTION THERE IS NO NEED TO ROTATE
16164 RETURN
16165 END
16166csp11/21/01 end
16167**********************************
16168* *
16169* *
16170 SUBROUTINE Crksph(PX,PY,PZ,EC,SRT,
16171 & emm1,emm2,lbp1,lbp2,I1,I2,ikkg,ikkl,iblock,
16172 & icase,srhoks)
16173
16174* PURPOSE: *
16175* DEALING WITH K + rho(omega) or K* + pi(rho,omega)
16176* --> Phi + K(K*), pi + K* or pi + K, and elastic
16177* NOTE : *
16178*
16179* QUANTITIES: *
16180* PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
16181* SRT - SQRT OF S *
16182* IBLOCK - THE INFORMATION BACK *
16183* 222
16184* 223 --> phi + pi(rho,omega)
16185* 224 --> phi + K <-> K + pi(rho,omega)
16186* 225 --> phi + K <-> K* + pi(rho,omega)
16187* 226 --> phi + K* <-> K + pi(rho,omega)
16188* 227 --> phi + K* <-> K* + pi(rho,omega)
16189**********************************
16190 PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
16191 1 AMP=0.93828,AP1=0.13496,AP2=0.13957,APHI=1.02,
16192 2 AM0=1.232,AMNS=1.52,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
16193 PARAMETER (AKA=0.498,ALA=1.1157,ASA=1.1974,ACAS=1.3213)
16194 PARAMETER (AKS=0.895,AOMEGA=0.7819, ARHO=0.77)
16195 parameter (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
16196 COMMON /AA/ R(3,MAXSTR)
16197cc SAVE /AA/
16198 COMMON /BB/ P(3,MAXSTR)
16199cc SAVE /BB/
16200 COMMON /CC/ E(MAXSTR)
16201cc SAVE /CC/
16202 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
16203cc SAVE /EE/
16204 common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
16205cc SAVE /input1/
16206 COMMON/RNDF77/NSEED
16207cc SAVE /RNDF77/
16208 SAVE
16209
16210 lb1 = lb(i1)
16211 lb2 = lb(i2)
16212 icase = 0
16213 sigela=10.
16214 sigkm=0.
16215c K(K*) + rho(omega) -> pi K*(K)
16216 if((lb1.ge.25.and.lb1.le.28).or.(lb2.ge.25.and.lb2.le.28)) then
16217 if(iabs(lb1).eq.30.or.iabs(lb2).eq.30) then
16218 sigkm=srhoks
16219clin-2/26/03 check whether (rho K) is above the (pi K*) thresh:
16220 elseif((lb1.eq.23.or.lb1.eq.21.or.lb2.eq.23.or.lb2.eq.21)
16221 1 .and.srt.gt.(ap2+aks)) then
16222 sigkm=srhoks
16223 endif
16224 endif
16225
16226c if(srt .lt. aphi+aka)return
16227 if(srt .lt. (aphi+aka)) then
16228 sig11=0.
16229 sig22=0.
16230 else
16231
16232c K*-bar +pi --> phi + (K,K*)-bar
16233 if( (iabs(lb1).eq.30.and.(lb2.ge.3.and.lb2.le.5)) .or.
16234 & (iabs(lb2).eq.30.and.(lb1.ge.3.and.lb1.le.5)) )then
16235 dnr = 18.
16236 ikkl = 0
16237 IBLOCK = 225
16238c sig1 = 15.0
16239c sig2 = 30.0
16240clin-2/06/03 these large values reduces to ~10 mb for sig11 or sig22
16241c due to the factors of ~1/(32*pi*s)~1/200:
16242 sig1 = 2047.042
16243 sig2 = 1496.692
16244c K(-bar)+rho --> phi + (K,K*)-bar
16245 elseif((lb1.eq.23.or.lb1.eq.21.and.(lb2.ge.25.and.lb2.le.27)).or.
16246 & (lb2.eq.23.or.lb2.eq.21.and.(lb1.ge.25.and.lb1.le.27)) )then
16247 dnr = 18.
16248 ikkl = 1
16249 IBLOCK = 224
16250c sig1 = 3.5
16251c sig2 = 9.0
16252 sig1 = 526.702
16253 sig2 = 1313.960
16254c K*(-bar) +rho
16255 elseif( (iabs(lb1).eq.30.and.(lb2.ge.25.and.lb2.le.27)) .or.
16256 & (iabs(lb2).eq.30.and.(lb1.ge.25.and.lb1.le.27)) )then
16257 dnr = 54.
16258 ikkl = 0
16259 IBLOCK = 225
16260c sig1 = 3.5
16261c sig2 = 9.0
16262 sig1 = 1371.257
16263 sig2 = 6999.840
16264c K(-bar) + omega
16265 elseif( ((lb1.eq.23.or.lb1.eq.21) .and. lb2.eq.28).or.
16266 & ((lb2.eq.23.or.lb2.eq.21) .and. lb1.eq.28) )then
16267 dnr = 6.
16268 ikkl = 1
16269 IBLOCK = 224
16270c sig1 = 3.5
16271c sig2 = 6.5
16272 sig1 = 355.429
16273 sig2 = 440.558
16274c K*(-bar) +omega
16275 else
16276 dnr = 18.
16277 ikkl = 0
16278 IBLOCK = 225
16279c sig1 = 3.5
16280c sig2 = 15.0
16281 sig1 = 482.292
16282 sig2 = 1698.903
16283 endif
16284
16285 sig11 = 0.
16286 sig22 = 0.
16287c sig11=sig1*(6./dnr)*(srt**2-(aphi+aka)**2)*
16288c & (srt**2-(aphi-aka)**2)/(srt**2-(e(i1)+e(i2))**2)/
16289c & (srt**2-(e(i1)-e(i2))**2)
16290 pii = sqrt((srt**2-(e(i1)+e(i2))**2)*(srt**2-(e(i1)-e(i2))**2))
16291 pff = sqrt((srt**2-(aphi+aka)**2)*(srt**2-(aphi-aka)**2))
16292 sig11 = sig1*pff/pii*6./dnr/32./pi/srt**2
16293c
16294 if(srt .gt. aphi+aks)then
16295c sig22=sig2*(18./dnr)*(srt**2-(aphi+aks)**2)*
16296c & (srt**2-(aphi-aks)**2)/(srt**2-(e(i1)+e(i2))**2)/
16297c & (srt**2-(e(i1)-e(i2))**2)
16298 pff = sqrt((srt**2-(aphi+aks)**2)*(srt**2-(aphi-aks)**2))
16299 sig22 = sig2*pff/pii*18./dnr/32./pi/srt**2
16300 endif
16301c sig11 = amin1(20.,sig11)
16302c sig22 = amin1(20.,sig22)
16303c
16304 endif
16305
16306c sigks = sig11 + sig22
16307 sigks=sig11+sig22+sigela+sigkm
16308c
16309 DSkn=SQRT(sigks/PI/10.)
16310 dsknr=dskn+0.1
16311 CALL DISTCE(I1,I2,dsknr,DSkn,DT,EC,SRT,IC,
16312 1 PX,PY,PZ)
16313 IF(IC.EQ.-1)return
16314 icase = 1
16315 ranx = RANART(NSEED)
16316
16317 if(ranx .le. (sigela/sigks))then
16318 lbp1=lb1
16319 emm1=e(i1)
16320 lbp2=lb2
16321 emm2=e(i2)
16322 iblock=111
16323 elseif(ranx .le. ((sigela+sigkm)/sigks))then
16324 lbp1=3+int(3*RANART(NSEED))
16325 emm1=0.14
16326 if(lb1.eq.23.or.lb2.eq.23) then
16327 lbp2=30
16328 emm2=aks
16329 elseif(lb1.eq.21.or.lb2.eq.21) then
16330 lbp2=-30
16331 emm2=aks
16332 elseif(lb1.eq.30.or.lb2.eq.30) then
16333 lbp2=23
16334 emm2=aka
16335 else
16336 lbp2=21
16337 emm2=aka
16338 endif
16339 iblock=112
16340 elseif(ranx .le. ((sigela+sigkm+sig11)/sigks))then
16341 lbp2 = 23
16342 emm2 = aka
16343 ikkg = 1
16344 if(lb1.eq.21.or.lb2.eq.21.or.lb1.eq.-30.or.lb2.eq.-30)then
16345 lbp2=21
16346 iblock=iblock-100
16347 endif
16348 lbp1 = 29
16349 emm1 = aphi
16350 else
16351 lbp2 = 30
16352 emm2 = aks
16353 ikkg = 0
16354 IBLOCK=IBLOCK+2
16355 if(lb1.eq.21.or.lb2.eq.21.or.lb1.eq.-30.or.lb2.eq.-30)then
16356 lbp2=-30
16357 iblock=iblock-100
16358 endif
16359 lbp1 = 29
16360 emm1 = aphi
16361 endif
16362*
16363 PX0=PX
16364 PY0=PY
16365 PZ0=PZ
16366*-----------------------------------------------------------------------
16367* CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
16368* ENERGY CONSERVATION
16369 PR2 = (SRT**2 - EMM1**2 - EMM2**2)**2
16370 1 - 4.0 * (EMM1*EMM2)**2
16371 IF(PR2.LE.0.)PR2=1.e-09
16372 PR=SQRT(PR2)/(2.*SRT)
16373 C1 = 1.0 - 2.0 * RANART(NSEED)
16374 T1 = 2.0 * PI * RANART(NSEED)
16375 S1 = SQRT( 1.0 - C1**2 )
16376 CT1 = COS(T1)
16377 ST1 = SIN(T1)
16378* THE MOMENTUM IN THE CMS IN THE FINAL STATE
16379 PZ = PR * C1
16380 PX = PR * S1*CT1
16381 PY = PR * S1*ST1
16382* FOR THE ISOTROPIC DISTRIBUTION THERE IS NO NEED TO ROTATE
16383 RETURN
16384 END
16385csp11/21/01 end
16386**********************************
16387**********************************
16388 SUBROUTINE bbkaon(ic,SRT,PX,PY,PZ,ana,PlX,
16389 & PlY,PlZ,ala,pkX,PkY,PkZ,icou1)
16390* purpose: generate the momenta for kaon,lambda/sigma and nucleon/delta
16391* in the BB-->nlk process
16392* date: Sept. 9, 1994
16393c
16394 common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
16395cc SAVE /input1/
16396 COMMON/RNDF77/NSEED
16397cc SAVE /RNDF77/
16398 SAVE
16399
16400 PI=3.1415962
16401 icou1=0
16402 aka=0.498
16403 ala=1.116
16404 if(ic.eq.2.or.ic.eq.4)ala=1.197
16405 ana=0.939
16406* generate the mass of the delta
16407 if(ic.gt.2)then
16408 dmax=srt-aka-ala-0.02
16409 DM1=RMASS(DMAX,ISEED)
16410 ana=dm1
16411 endif
16412 t1=aka+ana+ala
16413 t2=ana+ala-aka
16414 if(srt.le.t1)then
16415 icou1=-1
16416 return
16417 endif
16418 pmax=sqrt((srt**2-t1**2)*(srt**2-t2**2))/(2.*srt)
16419 if(pmax.eq.0.)pmax=1.e-09
16420* (1) Generate the momentum of the kaon according to the distribution Fkaon
16421* and assume that the angular distribution is isotropic
16422* in the cms of the colliding pair
16423 ntry=0
164241 pk=pmax*RANART(NSEED)
16425 ntry=ntry+1
16426 prob=fkaon(pk,pmax)
16427 if((prob.lt.RANART(NSEED)).and.(ntry.le.40))go to 1
16428 cs=1.-2.*RANART(NSEED)
16429 ss=sqrt(1.-cs**2)
16430 fai=2.*3.14*RANART(NSEED)
16431 pkx=pk*ss*cos(fai)
16432 pky=pk*ss*sin(fai)
16433 pkz=pk*cs
16434* the energy of the kaon
16435 ek=sqrt(aka**2+pk**2)
16436* (2) Generate the momentum of the nucleon/delta in the cms of N/delta
16437* and lamda/sigma
16438* the energy of the cms of NL
16439 eln=srt-ek
16440 if(eln.le.0)then
16441 icou1=-1
16442 return
16443 endif
16444* beta and gamma of the cms of L/S+N
16445 bx=-pkx/eln
16446 by=-pky/eln
16447 bz=-pkz/eln
16448 ga=1./sqrt(1.-bx**2-by**2-bz**2)
16449 elnc=eln/ga
16450 pn2=((elnc**2+ana**2-ala**2)/(2.*elnc))**2-ana**2
16451 if(pn2.le.0.)pn2=1.e-09
16452 pn=sqrt(pn2)
16453 csn=1.-2.*RANART(NSEED)
16454 ssn=sqrt(1.-csn**2)
16455 fain=2.*3.14*RANART(NSEED)
16456 px=pn*ssn*cos(fain)
16457 py=pn*ssn*sin(fain)
16458 pz=pn*csn
16459 en=sqrt(ana**2+pn2)
16460* the momentum of the lambda/sigma in the n-l cms frame is
16461 plx=-px
16462 ply=-py
16463 plz=-pz
16464* (3) LORENTZ-TRANSFORMATION INTO nn cms FRAME for the neutron/delta
16465 PBETA = PX*BX + PY*By+ PZ*Bz
16466 TRANS0 = GA * ( GA * PBETA / (GA + 1.) + En )
16467 Px = BX * TRANS0 + PX
16468 Py = BY * TRANS0 + PY
16469 Pz = BZ * TRANS0 + PZ
16470* (4) Lorentz-transformation for the lambda/sigma
16471 el=sqrt(ala**2+plx**2+ply**2+plz**2)
16472 PBETA = PlX*BX + PlY*By+ PlZ*Bz
16473 TRANS0 = GA * ( GA * PBETA / (GA + 1.) + El )
16474 Plx = BX * TRANS0 + PlX
16475 Ply = BY * TRANS0 + PlY
16476 Plz = BZ * TRANS0 + PlZ
16477 return
16478 end
16479******************************************
16480* for pion+pion-->K+K-
16481c real*4 function pipik(srt)
16482 real function pipik(srt)
16483* srt = DSQRT(s) in GeV *
16484* xsec = production cross section in mb *
16485* NOTE: DEVIDE THE CROSS SECTION TO OBTAIN K+ PRODUCTION *
16486******************************************
16487c real*4 xarray(5), earray(5)
16488 real xarray(5), earray(5)
16489 SAVE
16490 data xarray /0.001, 0.7,1.5,1.7,2.0/
16491 data earray /1.,1.2,1.6,2.0,2.4/
16492
16493 pmass=0.9383
16494* 1.Calculate p(lab) from srt [GeV]
16495* Formula used: DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
16496c ekin = 2.*pmass*((srt/(2.*pmass))**2 - 1.)
16497 pipik=0.
16498 if(srt.le.1.)return
16499 if(srt.gt.2.4)then
16500 pipik=2.0/2.
16501 return
16502 endif
16503 if (srt .lt. earray(1)) then
16504 pipik =xarray(1)/2.
16505 return
16506 end if
16507*
16508* 2.Interpolate double logarithmically to find sigma(srt)
16509*
16510 do 1001 ie = 1,5
16511 if (earray(ie) .eq. srt) then
16512 pipik = xarray(ie)
16513 go to 10
16514 else if (earray(ie) .gt. srt) then
16515 ymin = alog(xarray(ie-1))
16516 ymax = alog(xarray(ie))
16517 xmin = alog(earray(ie-1))
16518 xmax = alog(earray(ie))
16519 pipik = exp(ymin + (alog(srt)-xmin)*(ymax-ymin)
16520 &/(xmax-xmin) )
16521 go to 10
16522 end if
16523 1001 continue
1652410 PIPIK=PIPIK/2.
16525 continue
16526 return
16527 END
16528**********************************
16529* TOTAL PION-P INELASTIC CROSS SECTION
16530* from the CERN data book
16531* date: Sept.2, 1994
16532* for pion++p-->Delta+pion
16533c real*4 function pionpp(srt)
16534 real function pionpp(srt)
16535 SAVE
16536* srt = DSQRT(s) in GeV *
16537* xsec = production cross section in fm**2 *
16538* earray = EXPerimental table with proton energies in MeV *
16539* xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
16540* *
16541******************************************
16542 pmass=0.14
16543 pmass1=0.938
16544 PIONPP=0.00001
16545 IF(SRT.LE.1.22)RETURN
16546* 1.Calculate p(lab) from srt [GeV]
16547* Formula used: DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
16548c ekin = 2.*pmass*((srt/(2.*pmass))**2 - 1.)
16549 plab=sqrt(((srt**2-pmass**2-pmass1**2)/(2.*pmass1))**2-pmass**2)
16550 pmin=0.3
16551 pmax=25.0
16552 if(plab.gt.pmax)then
16553 pionpp=20./10.
16554 return
16555 endif
16556 if(plab .lt. pmin)then
16557 pionpp = 0.
16558 return
16559 end if
16560c* fit parameters
16561 a=24.3
16562 b=-12.3
16563 c=0.324
16564 an=-1.91
16565 d=-2.44
16566 pionpp = a+b*(plab**an)+c*(alog(plab))**2+d*alog(plab)
16567 if(pionpp.le.0)pionpp=0
16568 pionpp=pionpp/10.
16569 return
16570 END
16571**********************************
16572* elementary cross sections
16573* from the CERN data book
16574* date: Sept.2, 1994
16575* for pion-+p-->INELASTIC
16576c real*4 function pipp1(srt)
16577 real function pipp1(srt)
16578 SAVE
16579* srt = DSQRT(s) in GeV *
16580* xsec = production cross section in fm**2 *
16581* earray = EXPerimental table with proton energies in MeV *
16582* xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
16583* UNITS: FM**2
16584******************************************
16585 pmass=0.14
16586 pmass1=0.938
16587 PIPP1=0.0001
16588 IF(SRT.LE.1.22)RETURN
16589* 1.Calculate p(lab) from srt [GeV]
16590* Formula used: DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
16591c ekin = 2.*pmass*((srt/(2.*pmass))**2 - 1.)
16592 plab=sqrt(((srt**2-pmass**2-pmass1**2)/(2.*pmass1))**2-pmass**2)
16593 pmin=0.3
16594 pmax=25.0
16595 if(plab.gt.pmax)then
16596 pipp1=20./10.
16597 return
16598 endif
16599 if(plab .lt. pmin)then
16600 pipp1 = 0.
16601 return
16602 end if
16603c* fit parameters
16604 a=26.6
16605 b=-7.18
16606 c=0.327
16607 an=-1.86
16608 d=-2.81
16609 pipp1 = a+b*(plab**an)+c*(alog(plab))**2+d*alog(plab)
16610 if(pipp1.le.0)pipp1=0
16611 PIPP1=PIPP1/10.
16612 return
16613 END
16614* *****************************
16615c real*4 function xrho(srt)
16616 real function xrho(srt)
16617 SAVE
16618* xsection for pp-->pp+rho
16619* *****************************
16620 pmass=0.9383
16621 rmass=0.77
16622 trho=0.151
16623 xrho=0.000000001
16624 if(srt.le.2.67)return
16625 ESMIN=2.*0.9383+rmass-trho/2.
16626 ES=srt
16627* the cross section for tho0 production is
16628 xrho0=0.24*(es-esmin)/(1.4+(es-esmin)**2)
16629 xrho=3.*Xrho0
16630 return
16631 end
16632* *****************************
16633c real*4 function omega(srt)
16634 real function omega(srt)
16635 SAVE
16636* xsection for pp-->pp+omega
16637* *****************************
16638 pmass=0.9383
16639 omass=0.782
16640 tomega=0.0084
16641 omega=0.00000001
16642 if(srt.le.2.68)return
16643 ESMIN=2.*0.9383+omass-tomega/2.
16644 es=srt
16645 omega=0.36*(es-esmin)/(1.25+(es-esmin)**2)
16646 return
16647 end
16648******************************************
16649* for ppi(+)-->DELTA+pi
16650c real*4 function TWOPI(srt)
16651 real function TWOPI(srt)
16652* This function contains the experimental pi+p-->DELTA+PION cross sections *
16653* srt = DSQRT(s) in GeV *
16654* xsec = production cross section in mb *
16655* earray = EXPerimental table with proton energies in MeV *
16656* xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
16657* *
16658******************************************
16659c real*4 xarray(19), earray(19)
16660 real xarray(19), earray(19)
16661 SAVE
16662 data xarray /0.300E-05,0.187E+01,0.110E+02,0.149E+02,0.935E+01,
16663 &0.765E+01,0.462E+01,0.345E+01,0.241E+01,0.185E+01,0.165E+01,
16664 &0.150E+01,0.132E+01,0.117E+01,0.116E+01,0.100E+01,0.856E+00,
16665 &0.745E+00,0.300E-05/
16666 data earray /0.122E+01, 0.147E+01, 0.172E+01, 0.197E+01,
16667 &0.222E+01, 0.247E+01, 0.272E+01, 0.297E+01, 0.322E+01,
16668 &0.347E+01, 0.372E+01, 0.397E+01, 0.422E+01, 0.447E+01,
16669 &0.472E+01, 0.497E+01, 0.522E+01, 0.547E+01, 0.572E+01/
16670
16671 pmass=0.14
16672 pmass1=0.938
16673 TWOPI=0.000001
16674 if(srt.le.1.22)return
16675* 1.Calculate p(lab) from srt [GeV]
16676* Formula used: DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
16677 plab=SRT
16678 if (plab .lt. earray(1)) then
16679 TWOPI= 0.00001
16680 return
16681 end if
16682*
16683* 2.Interpolate double logarithmically to find sigma(srt)
16684*
16685 do 1001 ie = 1,19
16686 if (earray(ie) .eq. plab) then
16687 TWOPI= xarray(ie)
16688 return
16689 else if (earray(ie) .gt. plab) then
16690 ymin = alog(xarray(ie-1))
16691 ymax = alog(xarray(ie))
16692 xmin = alog(earray(ie-1))
16693 xmax = alog(earray(ie))
16694 TWOPI= exp(ymin + (alog(plab)-xmin)*(ymax-ymin)
16695 & /(xmax-xmin) )
16696 return
16697 end if
16698 1001 continue
16699 return
16700 END
16701******************************************
16702******************************************
16703* for ppi(+)-->DELTA+RHO
16704c real*4 function THREPI(srt)
16705 real function THREPI(srt)
16706* This function contains the experimental pi+p-->DELTA + rho cross sections *
16707* srt = DSQRT(s) in GeV *
16708* xsec = production cross section in mb *
16709* earray = EXPerimental table with proton energies in MeV *
16710* xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
16711* *
16712******************************************
16713c real*4 xarray(15), earray(15)
16714 real xarray(15), earray(15)
16715 SAVE
16716 data xarray /8.0000000E-06,6.1999999E-05,1.881940,5.025690,
16717 &11.80154,13.92114,15.07308,11.79571,11.53772,10.01197,9.792673,
16718 &9.465264,8.970490,7.944254,6.886320/
16719 data earray /0.122E+01, 0.147E+01, 0.172E+01, 0.197E+01,
16720 &0.222E+01, 0.247E+01, 0.272E+01, 0.297E+01, 0.322E+01,
16721 &0.347E+01, 0.372E+01, 0.397E+01, 0.422E+01, 0.447E+01,
16722 &0.472E+01/
16723
16724 pmass=0.14
16725 pmass1=0.938
16726 THREPI=0.000001
16727 if(srt.le.1.36)return
16728* 1.Calculate p(lab) from srt [GeV]
16729* Formula used: DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
16730 plab=SRT
16731 if (plab .lt. earray(1)) then
16732 THREPI = 0.00001
16733 return
16734 end if
16735*
16736* 2.Interpolate double logarithmically to find sigma(srt)
16737*
16738 do 1001 ie = 1,15
16739 if (earray(ie) .eq. plab) then
16740 THREPI= xarray(ie)
16741 return
16742 else if (earray(ie) .gt. plab) then
16743 ymin = alog(xarray(ie-1))
16744 ymax = alog(xarray(ie))
16745 xmin = alog(earray(ie-1))
16746 xmax = alog(earray(ie))
16747 THREPI = exp(ymin + (alog(plab)-xmin)*(ymax-ymin)
16748 & /(xmax-xmin) )
16749 return
16750 end if
16751 1001 continue
16752 return
16753 END
16754******************************************
16755******************************************
16756* for ppi(+)-->DELTA+omega
16757c real*4 function FOURPI(srt)
16758 real function FOURPI(srt)
16759* This function contains the experimental pi+p-->DELTA+PION cross sections *
16760* srt = DSQRT(s) in GeV *
16761* xsec = production cross section in mb *
16762* earray = EXPerimental table with proton energies in MeV *
16763* xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
16764* *
16765******************************************
16766c real*4 xarray(10), earray(10)
16767 real xarray(10), earray(10)
16768 SAVE
16769 data xarray /0.0001,1.986597,6.411932,7.636956,
16770 &9.598362,9.889740,10.24317,10.80138,11.86988,12.83925/
16771 data earray /2.468,2.718,2.968,0.322E+01,
16772 &0.347E+01, 0.372E+01, 0.397E+01, 0.422E+01, 0.447E+01,
16773 &0.472E+01/
16774
16775 pmass=0.14
16776 pmass1=0.938
16777 FOURPI=0.000001
16778 if(srt.le.1.52)return
16779* 1.Calculate p(lab) from srt [GeV]
16780* Formula used: DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
16781 plab=SRT
16782 if (plab .lt. earray(1)) then
16783 FOURPI= 0.00001
16784 return
16785 end if
16786*
16787* 2.Interpolate double logarithmically to find sigma(srt)
16788*
16789 do 1001 ie = 1,10
16790 if (earray(ie) .eq. plab) then
16791 FOURPI= xarray(ie)
16792 return
16793 else if (earray(ie) .gt. plab) then
16794 ymin = alog(xarray(ie-1))
16795 ymax = alog(xarray(ie))
16796 xmin = alog(earray(ie-1))
16797 xmax = alog(earray(ie))
16798 FOURPI= exp(ymin + (alog(plab)-xmin)*(ymax-ymin)
16799 & /(xmax-xmin) )
16800 return
16801 end if
16802 1001 continue
16803 return
16804 END
16805******************************************
16806******************************************
16807* for pion (rho or omega)+baryon resonance collisions
16808c real*4 function reab(i1,i2,srt,ictrl)
16809 real function reab(i1,i2,srt,ictrl)
16810* This function calculates the cross section for
16811* pi+Delta(N*)-->N+PION process *
16812* srt = DSQRT(s) in GeV *
16813* reab = cross section in fm**2 *
16814* ictrl=1,2,3 for pion, rho and omega+D(N*)
16815****************************************
16816 PARAMETER (MAXSTR=150001,MAXR=1,PI=3.1415926)
16817 parameter (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
16818 PARAMETER (AKA=0.498,ALA=1.1157,ASA=1.1974)
16819 parameter (amn=0.938,ap1=0.14,arho=0.77,aomega=0.782)
16820 parameter (maxx=20,maxz=24)
16821 COMMON /AA/ R(3,MAXSTR)
16822cc SAVE /AA/
16823 COMMON /BB/ P(3,MAXSTR)
16824cc SAVE /BB/
16825 COMMON /CC/ E(MAXSTR)
16826cc SAVE /CC/
16827 COMMON /DD/ RHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
16828 & RHOP(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
16829 & RHON(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
16830cc SAVE /DD/
16831 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
16832cc SAVE /EE/
16833 SAVE
16834 LB1=LB(I1)
16835 LB2=LB(I2)
16836 reab=0
16837 if(ictrl.eq.1.and.srt.le.(amn+2.*ap1+0.02))return
16838 if(ictrl.eq.3.and.srt.le.(amn+ap1+aomega+0.02))return
16839 pin2=((srt**2+ap1**2-amn**2)/(2.*srt))**2-ap1**2
16840 if(pin2.le.0)return
16841* for pion+D(N*)-->pion+N
16842 if(ictrl.eq.1)then
16843 if(e(i1).gt.1)then
16844 ed=e(i1)
16845 else
16846 ed=e(i2)
16847 endif
16848 pout2=((srt**2+ap1**2-ed**2)/(2.*srt))**2-ap1**2
16849 if(pout2.le.0)return
16850 xpro=twopi(srt)/10.
16851 factor=1/3.
16852 if( ((lb1.eq.8.and.lb2.eq.5).or.
16853 & (lb1.eq.5.and.lb2.eq.8))
16854 & .OR.((lb1.eq.-8.and.lb2.eq.3).or.
16855 & (lb1.eq.3.and.lb2.eq.-8)) )factor=1/4.
16856 if((iabs(lb1).ge.10.and.iabs(lb1).le.13).
16857 & or.(iabs(lb2).ge.10.and.iabs(lb2).le.13))factor=1.
16858 reab=factor*pin2/pout2*xpro
16859 return
16860 endif
16861* for rho reabsorption
16862 if(ictrl.eq.2)then
16863 if(lb(i2).ge.25)then
16864 ed=e(i1)
16865 arho1=e(i2)
16866 else
16867 ed=e(i2)
16868 arho1=e(i1)
16869 endif
16870 if(srt.le.(amn+ap1+arho1+0.02))return
16871 pout2=((srt**2+arho1**2-ed**2)/(2.*srt))**2-arho1**2
16872 if(pout2.le.0)return
16873 xpro=threpi(srt)/10.
16874 factor=1/3.
16875 if( ((lb1.eq.8.and.lb2.eq.27).or.
16876 & (lb1.eq.27.and.lb2.eq.8))
16877 & .OR. ((lb1.eq.-8.and.lb2.eq.25).or.
16878 & (lb1.eq.25.and.lb2.eq.-8)) )factor=1/4.
16879 if((iabs(lb1).ge.10.and.iabs(lb1).le.13).
16880 & or.(iabs(lb2).ge.10.and.iabs(lb2).le.13))factor=1.
16881 reab=factor*pin2/pout2*xpro
16882 return
16883 endif
16884* for omega reabsorption
16885 if(ictrl.eq.3)then
16886 if(e(i1).gt.1)ed=e(i1)
16887 if(e(i2).gt.1)ed=e(i2)
16888 pout2=((srt**2+aomega**2-ed**2)/(2.*srt))**2-aomega**2
16889 if(pout2.le.0)return
16890 xpro=fourpi(srt)/10.
16891 factor=1/6.
16892 if((iabs(lb1).ge.10.and.iabs(lb1).le.13).
16893 & or.(iabs(lb2).ge.10.and.iabs(lb2).le.13))factor=1./3.
16894 reab=factor*pin2/pout2*xpro
16895 endif
16896 return
16897 END
16898******************************************
16899* for the reabsorption of two resonances
16900* This function calculates the cross section for
16901* DD-->NN, N*N*-->NN and DN*-->NN
16902c real*4 function reab2d(i1,i2,srt)
16903 real function reab2d(i1,i2,srt)
16904* srt = DSQRT(s) in GeV *
16905* reab = cross section in mb
16906****************************************
16907 PARAMETER (MAXSTR=150001,MAXR=1,PI=3.1415926)
16908 parameter (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
16909 PARAMETER (AKA=0.498,ALA=1.1157,ASA=1.1974)
16910 parameter (amn=0.938,ap1=0.14,arho=0.77,aomega=0.782)
16911 parameter (maxx=20,maxz=24)
16912 COMMON /AA/ R(3,MAXSTR)
16913cc SAVE /AA/
16914 COMMON /BB/ P(3,MAXSTR)
16915cc SAVE /BB/
16916 COMMON /CC/ E(MAXSTR)
16917cc SAVE /CC/
16918 COMMON /DD/ RHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
16919 & RHOP(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
16920 & RHON(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
16921cc SAVE /DD/
16922 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
16923cc SAVE /EE/
16924 SAVE
16925 reab2d=0
16926 LB1=iabs(LB(I1))
16927 LB2=iabs(LB(I2))
16928 ed1=e(i1)
16929 ed2=e(i2)
16930 pin2=(srt/2.)**2-amn**2
16931 pout2=((srt**2+ed1**2-ed2**2)/(2.*srt))**2-ed1**2
16932 if(pout2.le.0)return
16933 xpro=x2pi(srt)
16934 factor=1/4.
16935 if((lb1.ge.10.and.lb1.le.13).and.
16936 & (lb2.ge.10.and.lb2.le.13))factor=1.
16937 if((lb1.ge.6.and.lb1.le.9).and.
16938 & (lb2.gt.10.and.lb2.le.13))factor=1/2.
16939 if((lb2.ge.6.and.lb2.le.9).and.
16940 & (lb1.gt.10.and.lb1.le.13))factor=1/2.
16941 reab2d=factor*pin2/pout2*xpro
16942 return
16943 end
16944***************************************
16945 SUBROUTINE rotate(PX0,PY0,PZ0,px,py,pz)
16946 SAVE
16947* purpose: rotate the momentum of a particle in the CMS of p1+p2 such that
16948* the x' y' and z' in the cms of p1+p2 is the same as the fixed x y and z
16949* quantities:
16950* px0,py0 and pz0 are the cms momentum of the incoming colliding
16951* particles
16952* px, py and pz are the cms momentum of any one of the particles
16953* after the collision to be rotated
16954***************************************
16955* the momentum, polar and azimuthal angles of the incoming momentm
16956 PR0 = SQRT( PX0**2 + PY0**2 + PZ0**2 )
16957 IF(PR0.EQ.0)PR0=0.00000001
16958 C2 = PZ0 / PR0
16959 IF(PX0 .EQ. 0.0 .AND. PY0 .EQ. 0.0) THEN
16960 T2 = 0.0
16961 ELSE
16962 T2=ATAN2(PY0,PX0)
16963 END IF
16964 S2 = SQRT( 1.0 - C2**2 )
16965 CT2 = COS(T2)
16966 ST2 = SIN(T2)
16967* the momentum, polar and azimuthal angles of the momentum to be rotated
16968 PR=SQRT(PX**2+PY**2+PZ**2)
16969 IF(PR.EQ.0)PR=0.0000001
16970 C1=PZ/PR
16971 IF(PX.EQ.0.AND.PY.EQ.0)THEN
16972 T1=0.
16973 ELSE
16974 T1=ATAN2(PY,PX)
16975 ENDIF
16976 S1 = SQRT( 1.0 - C1**2 )
16977 CT1 = COS(T1)
16978 ST1 = SIN(T1)
16979 SS = C2 * S1 * CT1 + S2 * C1
16980* THE MOMENTUM AFTER ROTATION
16981 PX = PR * ( SS*CT2 - S1*ST1*ST2 )
16982 PY = PR * ( SS*ST2 + S1*ST1*CT2 )
16983 PZ = PR * ( C1*C2 - S1*S2*CT1 )
16984 RETURN
16985 END
16986******************************************
16987c real*4 function Xpp(srt)
16988 real function Xpp(srt)
16989* This function contains the experimental total n-p cross sections *
16990* srt = DSQRT(s) in GeV *
16991* xsec = production cross section in mb *
16992* earray = EXPerimental table with proton energies in MeV *
16993* xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
16994* WITH A CUTOFF AT 55MB *
16995******************************************
16996c real*4 xarray(14), earray(14)
16997 real xarray(14), earray(14)
16998 SAVE
16999 data earray /20.,30.,40.,60.,80.,100.,
17000 &170.,250.,310.,
17001 &350.,460.,560.,660.,800./
17002 data xarray /150.,90.,80.6,48.0,36.6,
17003 &31.6,25.9,24.0,23.1,
17004 &24.0,28.3,33.6,41.5,47/
17005
17006 xpp=0.
17007 pmass=0.9383
17008* 1.Calculate E_kin(lab) [MeV] from srt [GeV]
17009* Formula used: DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
17010 ekin = 2000.*pmass*((srt/(2.*pmass))**2 - 1.)
17011 if (ekin .lt. earray(1)) then
17012 xpp = xarray(1)
17013 IF(XPP.GT.55)XPP=55
17014 return
17015 end if
17016 IF(EKIN.GT.EARRAY(14))THEN
17017 XPP=XARRAY(14)
17018 RETURN
17019 ENDIF
17020*
17021*
17022* 2.Interpolate double logarithmically to find sigma(srt)
17023*
17024 do 1001 ie = 1,14
17025 if (earray(ie) .eq. ekin) then
17026 xPP= xarray(ie)
17027 if(xpp.gt.55)xpp=55.
17028 return
17029 endif
17030 if (earray(ie) .gt. ekin) then
17031 ymin = alog(xarray(ie-1))
17032 ymax = alog(xarray(ie))
17033 xmin = alog(earray(ie-1))
17034 xmax = alog(earray(ie))
17035 XPP = exp(ymin + (alog(ekin)-xmin)
17036 & *(ymax-ymin)/(xmax-xmin) )
17037 IF(XPP.GT.55)XPP=55.
17038 go to 50
17039 end if
17040 1001 continue
1704150 continue
17042 return
17043 END
17044******************************************
17045 real function Xnp(srt)
17046* This function contains the experimental total n-p cross sections *
17047* srt = DSQRT(s) in GeV *
17048* xsec = production cross section in mb *
17049* earray = EXPerimental table with proton energies in MeV *
17050* xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
17051* WITH A CUTOFF AT 55MB *
17052******************************************
17053c real*4 xarray(11), earray(11)
17054 real xarray(11), earray(11)
17055 SAVE
17056 data earray /20.,30.,40.,60.,90.,135.0,200.,
17057 &300.,400.,600.,800./
17058 data xarray / 410.,270.,214.5,130.,78.,53.5,
17059 &41.6,35.9,34.2,34.3,34.9/
17060
17061 xnp=0.
17062 pmass=0.9383
17063* 1.Calculate E_kin(lab) [MeV] from srt [GeV]
17064* Formula used: DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
17065 ekin = 2000.*pmass*((srt/(2.*pmass))**2 - 1.)
17066 if (ekin .lt. earray(1)) then
17067 xnp = xarray(1)
17068 IF(XNP.GT.55)XNP=55
17069 return
17070 end if
17071 IF(EKIN.GT.EARRAY(11))THEN
17072 XNP=XARRAY(11)
17073 RETURN
17074 ENDIF
17075*
17076*Interpolate double logarithmically to find sigma(srt)
17077*
17078 do 1001 ie = 1,11
17079 if (earray(ie) .eq. ekin) then
17080 xNP = xarray(ie)
17081 if(xnp.gt.55)xnp=55.
17082 return
17083 endif
17084 if (earray(ie) .gt. ekin) then
17085 ymin = alog(xarray(ie-1))
17086 ymax = alog(xarray(ie))
17087 xmin = alog(earray(ie-1))
17088 xmax = alog(earray(ie))
17089 xNP = exp(ymin + (alog(ekin)-xmin)
17090 & *(ymax-ymin)/(xmax-xmin) )
17091 IF(XNP.GT.55)XNP=55
17092 go to 50
17093 end if
17094 1001 continue
1709550 continue
17096 return
17097 END
17098*******************************
17099 function ptr(ptmax,iseed)
17100* (2) Generate the transverse momentum
17101* OF nucleons
17102*******************************
17103 COMMON/TABLE/ xarray(0:1000),earray(0:1000)
17104cc SAVE /TABLE/
17105 COMMON/RNDF77/NSEED
17106cc SAVE /RNDF77/
17107 SAVE
17108 ISEED=ISEED
17109 ptr=0.
17110 if(ptmax.le.1.e-02)then
17111 ptr=ptmax
17112 return
17113 endif
17114 if(ptmax.gt.2.01)ptmax=2.01
17115 tryial=ptdis(ptmax)/ptdis(2.01)
17116 XT=RANART(NSEED)*tryial
17117* look up the table and
17118*Interpolate double logarithmically to find pt
17119 do 50 ie = 1,200
17120 if (earray(ie) .eq. xT) then
17121 ptr = xarray(ie)
17122 return
17123 end if
17124 if(xarray(ie-1).le.0.00001)go to 50
17125 if(xarray(ie).le.0.00001)go to 50
17126 if(earray(ie-1).le.0.00001)go to 50
17127 if(earray(ie).le.0.00001)go to 50
17128 if (earray(ie) .gt. xT) then
17129 ymin = alog(xarray(ie-1))
17130 ymax = alog(xarray(ie))
17131 xmin = alog(earray(ie-1))
17132 xmax = alog(earray(ie))
17133 ptr= exp(ymin + (alog(xT)-xmin)*(ymax-ymin)
17134 & /(xmax-xmin) )
17135 if(ptr.gt.ptmax)ptr=ptmax
17136 return
17137 endif
1713850 continue
17139 return
17140 end
17141
17142**********************************
17143**********************************
17144* *
17145* *
17146 SUBROUTINE XND(px,py,pz,srt,I1,I2,xinel,
17147 & sigk,xsk1,xsk2,xsk3,xsk4,xsk5)
17148* PURPOSE: *
17149* calculate NUCLEON-BARYON RESONANCE inelatic Xsection *
17150* NOTE : *
17151* QUANTITIES: *
17152* CHANNELS. M12 IS THE REVERSAL CHANNEL OF N12 *
17153* N12, *
17154* M12=1 FOR p+n-->delta(+)+ n *
17155* 2 p+n-->delta(0)+ p *
17156* 3 p+p-->delta(++)+n *
17157* 4 p+p-->delta(+)+p *
17158* 5 n+n-->delta(0)+n *
17159* 6 n+n-->delta(-)+p *
17160* 7 n+p-->N*(0)(1440)+p *
17161* 8 n+p-->N*(+)(1440)+n *
17162* 9 p+p-->N*(+)(1535)+p *
17163* 10 n+n-->N*(0)(1535)+n *
17164* 11 n+p-->N*(+)(1535)+n *
17165* 12 n+p-->N*(0)(1535)+p
17166* 13 D(++)+D(-)-->N*(+)(1440)+n
17167* 14 D(++)+D(-)-->N*(0)(1440)+p
17168* 15 D(+)+D(0)--->N*(+)(1440)+n
17169* 16 D(+)+D(0)--->N*(0)(1440)+p
17170* 17 D(++)+D(0)-->N*(+)(1535)+p
17171* 18 D(++)+D(-)-->N*(0)(1535)+p
17172* 19 D(++)+D(-)-->N*(+)(1535)+n
17173* 20 D(+)+D(+)-->N*(+)(1535)+p
17174* 21 D(+)+D(0)-->N*(+)(1535)+n
17175* 22 D(+)+D(0)-->N*(0)(1535)+p
17176* 23 D(+)+D(-)-->N*(0)(1535)+n
17177* 24 D(0)+D(0)-->N*(0)(1535)+n
17178* 25 N*(+)(14)+N*(+)(14)-->N*(+)(15)+p
17179* 26 N*(0)(14)+N*(0)(14)-->N*(0)(15)+n
17180* 27 N*(+)(14)+N*(0)(14)-->N*(+)(15)+n
17181* 28 N*(+)(14)+N*(0)(14)-->N*(0)(15)+p
17182* 29 N*(+)(14)+D+-->N*(+)(15)+p
17183* 30 N*(+)(14)+D0-->N*(+)(15)+n
17184* 31 N*(+)(14)+D(-)-->N*(0)(1535)+n
17185* 32 N*(0)(14)+D++--->N*(+)(15)+p
17186* 33 N*(0)(14)+D+--->N*(+)(15)+n
17187* 34 N*(0)(14)+D+--->N*(0)(15)+p
17188* 35 N*(0)(14)+D0-->N*(0)(15)+n
17189* 36 N*(+)(14)+D0--->N*(0)(15)+p
17190* and more
17191***********************************
17192 PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
17193 1 AMP=0.93828,AP1=0.13496,AKA=0.498,APHI=1.020,
17194 2 AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
17195 parameter (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
17196 COMMON /AA/ R(3,MAXSTR)
17197cc SAVE /AA/
17198 COMMON /BB/ P(3,MAXSTR)
17199cc SAVE /BB/
17200 COMMON /CC/ E(MAXSTR)
17201cc SAVE /CC/
17202 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
17203cc SAVE /EE/
17204 common /ff/f(-mx:mx,-my:my,-mz:mz,-mpx:mpx,-mpy:mpy,-mpz:mpzp)
17205cc SAVE /ff/
17206 common /gg/ dx,dy,dz,dpx,dpy,dpz
17207cc SAVE /gg/
17208 COMMON /INPUT/ NSTAR,NDIRCT,DIR
17209cc SAVE /INPUT/
17210 COMMON /NN/NNN
17211cc SAVE /NN/
17212 COMMON /BG/BETAX,BETAY,BETAZ,GAMMA
17213cc SAVE /BG/
17214 COMMON /RUN/NUM
17215cc SAVE /RUN/
17216 COMMON /PA/RPION(3,MAXSTR,MAXR)
17217cc SAVE /PA/
17218 COMMON /PB/PPION(3,MAXSTR,MAXR)
17219cc SAVE /PB/
17220 COMMON /PC/EPION(MAXSTR,MAXR)
17221cc SAVE /PC/
17222 COMMON /PD/LPION(MAXSTR,MAXR)
17223cc SAVE /PD/
17224 common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
17225cc SAVE /input1/
17226 SAVE
17227
17228*-----------------------------------------------------------------------
17229 xinel=0.
17230 sigk=0
17231 xsk1=0
17232 xsk2=0
17233 xsk3=0
17234 xsk4=0
17235 xsk5=0
17236 EM1=E(I1)
17237 EM2=E(I2)
17238 PR = SQRT( PX**2 + PY**2 + PZ**2 )
17239* CAN HAPPEN ANY MORE ==> RETURN (2.04 = 2*AVMASS + PI-MASS+0.02)
17240 IF (SRT .LT. 2.04) RETURN
17241* Resonance absorption or Delta + N-->N*(1440), N*(1535)
17242* COM: TEST FOR DELTA OR N* ABSORPTION
17243* IN THE PROCESS DELTA+N-->NN, N*+N-->NN
17244 PRF=SQRT(0.25*SRT**2-AVMASS**2)
17245 IF(EM1.GT.1.)THEN
17246 DELTAM=EM1
17247 ELSE
17248 DELTAM=EM2
17249 ENDIF
17250 RENOM=DELTAM*PRF**2/DENOM(SRT,1.)/PR
17251 RENOMN=DELTAM*PRF**2/DENOM(SRT,2.)/PR
17252 RENOM1=DELTAM*PRF**2/DENOM(SRT,-1.)/PR
17253* avoid the inelastic collisions between n+delta- -->N+N
17254* and p+delta++ -->N+N due to charge conservation,
17255* but they can scatter to produce kaons
17256 if((iabs(lb(i1)).eq.2).and.(iabs(lb(i2)).eq.6)) renom=0.
17257 if((iabs(lb(i2)).eq.2).and.(iabs(lb(i1)).eq.6)) renom=0.
17258 if((iabs(lb(i1)).eq.1).and.(iabs(lb(i2)).eq.9)) renom=0.
17259 if((iabs(lb(i2)).eq.1).and.(iabs(lb(i1)).eq.9)) renom=0.
17260 Call M1535(iabs(lb(i1)),iabs(lb(i2)),srt,x1535)
17261 X1440=(3./4.)*SIGMA(SRT,2,0,1)
17262* CROSS SECTION FOR KAON PRODUCTION from the four channels
17263* for NLK channel
17264 akp=0.498
17265 ak0=0.498
17266 ana=0.94
17267 ada=1.232
17268 al=1.1157
17269 as=1.1197
17270 xsk1=0
17271 xsk2=0
17272 xsk3=0
17273 xsk4=0
17274c !! phi production
17275 xsk5=0
17276 t1nlk=ana+al+akp
17277 if(srt.le.t1nlk)go to 222
17278 XSK1=1.5*PPLPK(SRT)
17279* for DLK channel
17280 t1dlk=ada+al+akp
17281 t2dlk=ada+al-akp
17282 if(srt.le.t1dlk)go to 222
17283 es=srt
17284 pmdlk2=(es**2-t1dlk**2)*(es**2-t2dlk**2)/(4.*es**2)
17285 pmdlk=sqrt(pmdlk2)
17286 XSK3=1.5*PPLPK(srt)
17287* for NSK channel
17288 t1nsk=ana+as+akp
17289 t2nsk=ana+as-akp
17290 if(srt.le.t1nsk)go to 222
17291 pmnsk2=(es**2-t1nsk**2)*(es**2-t2nsk**2)/(4.*es**2)
17292 pmnsk=sqrt(pmnsk2)
17293 XSK2=1.5*(PPK1(srt)+PPK0(srt))
17294* for DSK channel
17295 t1DSk=aDa+aS+akp
17296 t2DSk=aDa+aS-akp
17297 if(srt.le.t1dsk)go to 222
17298 pmDSk2=(es**2-t1DSk**2)*(es**2-t2DSk**2)/(4.*es**2)
17299 pmDSk=sqrt(pmDSk2)
17300 XSK4=1.5*(PPK1(srt)+PPK0(srt))
17301csp11/21/01
17302c phi production
17303 if(srt.le.(2.*amn+aphi))go to 222
17304c !! mb put the correct form
17305 xsk5 = 0.0001
17306csp11/21/01 end
17307
17308* THE TOTAL KAON+ PRODUCTION CROSS SECTION IS THEN
17309222 SIGK=XSK1+XSK2+XSK3+XSK4
17310
17311cbz3/7/99 neutralk
17312 XSK1 = 2.0 * XSK1
17313 XSK2 = 2.0 * XSK2
17314 XSK3 = 2.0 * XSK3
17315 XSK4 = 2.0 * XSK4
17316 SIGK = 2.0 * SIGK + xsk5
17317cbz3/7/99 neutralk end
17318
17319* avoid the inelastic collisions between n+delta- -->N+N
17320* and p+delta++ -->N+N due to charge conservation,
17321* but they can scatter to produce kaons
17322 if(((iabs(lb(i1)).eq.2).and.(iabs(lb(i2)).eq.6)).OR.
17323 & ((iabs(lb(i2)).eq.2).and.(iabs(lb(i1)).eq.6)).OR.
17324 & ((iabs(lb(i1)).eq.1).and.(iabs(lb(i2)).eq.9)).OR.
17325 & ((iabs(lb(i2)).eq.1).and.(iabs(lb(i1)).eq.9)))THEN
17326 xinel=sigk
17327 return
17328 ENDIF
17329* WE DETERMINE THE REACTION CHANNELS IN THE FOLLOWING
17330* FOR n+delta(++)-->p+p or n+delta(++)-->n+N*(+)(1440),n+N*(+)(1535)
17331* REABSORPTION OR N*(1535) PRODUCTION LIKE IN P+P OR N*(1440) LIKE PN,
17332 IF(LB(I1)*LB(I2).EQ.18.AND.
17333 & (iabs(LB(I1)).EQ.2.OR.iabs(LB(I2)).EQ.2))then
17334 SIGND=SIGMA(SRT,1,1,0)+0.5*SIGMA(SRT,1,1,1)
17335 SIGDN=0.25*SIGND*RENOM
17336 xinel=SIGDN+X1440+X1535+SIGK
17337 RETURN
17338 endif
17339* FOR p+delta(-)-->n+n or p+delta(-)-->n+N*(0)(1440),n+N*(0)(1535)
17340* REABSORPTION OR N*(1535) PRODUCTION LIKE IN P+P OR N*(1440) LIKE PN,
17341 IF(LB(I1)*LB(I2).EQ.6.AND.
17342 & (iabs(LB(I1)).EQ.1.OR.iabs(LB(I2)).EQ.1))THEN
17343 SIGND=SIGMA(SRT,1,1,0)+0.5*SIGMA(SRT,1,1,1)
17344 SIGDN=0.25*SIGND*RENOM
17345 xinel=SIGDN+X1440+X1535+SIGK
17346 RETURN
17347 endif
17348* FOR p+delta(+)-->p+p, N*(+)(144)+p, N*(+)(1535)+p
17349cbz11/25/98
17350 IF(LB(I1)*LB(I2).EQ.8.AND.
17351 & (iabs(LB(I1)).EQ.1.OR.iabs(LB(I2)).EQ.1))THEN
17352 SIGND=1.5*SIGMA(SRT,1,1,1)
17353 SIGDN=0.25*SIGND*RENOM
17354 xinel=SIGDN+x1440+x1535+SIGK
17355 RETURN
17356 endif
17357* FOR n+delta(0)-->n+n, N*(0)(144)+n, N*(0)(1535)+n
17358 IF(LB(I1)*LB(I2).EQ.14.AND.
17359 & (iabs(LB(I1)).EQ.2.AND.iabs(LB(I2)).EQ.2))THEN
17360 SIGND=1.5*SIGMA(SRT,1,1,1)
17361 SIGDN=0.25*SIGND*RENOM
17362 xinel=SIGDN+x1440+x1535+SIGK
17363 RETURN
17364 endif
17365* FOR n+delta(+)-->n+p, N*(+)(1440)+n,N*(0)(1440)+p,
17366* N*(+)(1535)+n,N*(0)(1535)+p
17367 IF(LB(I1)*LB(I2).EQ.16.AND.
17368 & (iabs(LB(I1)).EQ.2.OR.iabs(LB(I2)).EQ.2))THEN
17369 SIGND=0.5*SIGMA(SRT,1,1,1)+0.25*SIGMA(SRT,1,1,0)
17370 SIGDN=0.5*SIGND*RENOM
17371 xinel=SIGDN+2.*x1440+2.*x1535+SIGK
17372 RETURN
17373 endif
17374* FOR p+delta(0)-->n+p, N*(+)(1440)+n,N*(0)(1440)+p,
17375* N*(+)(1535)+n,N*(0)(1535)+p
17376 IF(LB(I1)*LB(I2).EQ.7)THEN
17377 SIGND=0.5*SIGMA(SRT,1,1,1)+0.25*SIGMA(SRT,1,1,0)
17378 SIGDN=0.5*SIGND*RENOM
17379 xinel=SIGDN+2.*x1440+2.*x1535+SIGK
17380 RETURN
17381 endif
17382* FOR p+N*(0)(14)-->p+n, N*(+)(1535)+n,N*(0)(1535)+p
17383* OR P+N*(0)(14)-->D(+)+N, D(0)+P,
17384 IF(LB(I1)*LB(I2).EQ.10.AND.
17385 & (iabs(LB(I1)).EQ.1.OR.iabs(LB(I2)).EQ.1))then
17386 SIGND=(3./4.)*SIGMA(SRT,2,0,1)
17387 SIGDN=SIGND*RENOMN
17388 xinel=SIGDN+X1535+SIGK
17389 RETURN
17390 endif
17391* FOR n+N*(+)-->p+n, N*(+)(1535)+n,N*(0)(1535)+p
17392 IF(LB(I1)*LB(I2).EQ.22.AND.
17393 & (iabs(LB(I1)).EQ.2.OR.iabs(LB(I2)).EQ.2))then
17394 SIGND=(3./4.)*SIGMA(SRT,2,0,1)
17395 SIGDN=SIGND*RENOMN
17396 xinel=SIGDN+X1535+SIGK
17397 RETURN
17398 endif
17399* FOR N*(1535)+N-->N+N COLLISIONS
17400 IF((iabs(LB(I1)).EQ.12).OR.(iabs(LB(I1)).EQ.13).OR.
17401 1 (iabs(LB(I2)).EQ.12).OR.(iabs(LB(I2)).EQ.13))THEN
17402 SIGND=X1535
17403 SIGDN=SIGND*RENOM1
17404 xinel=SIGDN+SIGK
17405 RETURN
17406 endif
17407 RETURN
17408 end
17409**********************************
17410* *
17411* *
17412 SUBROUTINE XDDIN(PX,PY,PZ,SRT,I1,I2,
17413 &XINEL,SIGK,XSK1,XSK2,XSK3,XSK4,XSK5)
17414* PURPOSE: *
17415* DEALING WITH BARYON RESONANCE-BARYON RESONANCE COLLISIONS*
17416* NOTE : *
17417* VALID ONLY FOR BARYON-BARYON-DISTANCES LESS THAN 1.32 FM *
17418* (1.32 = 2 * HARD-CORE-RADIUS [HRC] ) *
17419* QUANTITIES: *
17420* PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
17421* SRT - SQRT OF S *
17422* NSTAR =1 INCLUDING N* RESORANCE,ELSE NOT *
17423* NDIRCT=1 INCLUDING DIRECT PION PRODUCTION PROCESS *
17424* IBLOCK - THE INFORMATION BACK *
17425* 0-> COLLISION CANNOT HAPPEN *
17426* 1-> N-N ELASTIC COLLISION *
17427* 2-> N+N->N+DELTA,OR N+N->N+N* REACTION *
17428* 3-> N+DELTA->N+N OR N+N*->N+N REACTION *
17429* 4-> N+N->N+N+PION,DIRTCT PROCESS *
17430* 5-> DELTA(N*)+DELTA(N*) TOTAL COLLISIONS *
17431* N12 - IS USED TO SPECIFY BARYON-BARYON REACTION *
17432* CHANNELS. M12 IS THE REVERSAL CHANNEL OF N12 *
17433* N12, *
17434* M12=1 FOR p+n-->delta(+)+ n *
17435* 2 p+n-->delta(0)+ p *
17436* 3 p+p-->delta(++)+n *
17437* 4 p+p-->delta(+)+p *
17438* 5 n+n-->delta(0)+n *
17439* 6 n+n-->delta(-)+p *
17440* 7 n+p-->N*(0)(1440)+p *
17441* 8 n+p-->N*(+)(1440)+n *
17442* 9 p+p-->N*(+)(1535)+p *
17443* 10 n+n-->N*(0)(1535)+n *
17444* 11 n+p-->N*(+)(1535)+n *
17445* 12 n+p-->N*(0)(1535)+p
17446* 13 D(++)+D(-)-->N*(+)(1440)+n
17447* 14 D(++)+D(-)-->N*(0)(1440)+p
17448* 15 D(+)+D(0)--->N*(+)(1440)+n
17449* 16 D(+)+D(0)--->N*(0)(1440)+p
17450* 17 D(++)+D(0)-->N*(+)(1535)+p
17451* 18 D(++)+D(-)-->N*(0)(1535)+p
17452* 19 D(++)+D(-)-->N*(+)(1535)+n
17453* 20 D(+)+D(+)-->N*(+)(1535)+p
17454* 21 D(+)+D(0)-->N*(+)(1535)+n
17455* 22 D(+)+D(0)-->N*(0)(1535)+p
17456* 23 D(+)+D(-)-->N*(0)(1535)+n
17457* 24 D(0)+D(0)-->N*(0)(1535)+n
17458* 25 N*(+)(14)+N*(+)(14)-->N*(+)(15)+p
17459* 26 N*(0)(14)+N*(0)(14)-->N*(0)(15)+n
17460* 27 N*(+)(14)+N*(0)(14)-->N*(+)(15)+n
17461* 28 N*(+)(14)+N*(0)(14)-->N*(0)(15)+p
17462* 29 N*(+)(14)+D+-->N*(+)(15)+p
17463* 30 N*(+)(14)+D0-->N*(+)(15)+n
17464* 31 N*(+)(14)+D(-)-->N*(0)(1535)+n
17465* 32 N*(0)(14)+D++--->N*(+)(15)+p
17466* 33 N*(0)(14)+D+--->N*(+)(15)+n
17467* 34 N*(0)(14)+D+--->N*(0)(15)+p
17468* 35 N*(0)(14)+D0-->N*(0)(15)+n
17469* 36 N*(+)(14)+D0--->N*(0)(15)+p
17470* +++
17471* AND MORE CHANNELS AS LISTED IN THE NOTE BOOK
17472*
17473* NOTE ABOUT N*(1440) RESORANCE: *
17474* As it has been discussed in VerWest's paper,I= 1 (initial isospin)
17475* channel can all be attributed to delta resorance while I= 0 *
17476* channel can all be attribured to N* resorance.Only in n+p *
17477* one can have I=0 channel so is the N*(1440) resorance *
17478* REFERENCES: J. CUGNON ET AL., NUCL. PHYS. A352, 505 (1981) *
17479* Y. KITAZOE ET AL., PHYS. LETT. 166B, 35 (1986) *
17480* B. VerWest el al., PHYS. PRV. C25 (1982)1979 *
17481* Gy. Wolf et al, Nucl Phys A517 (1990) 615 *
17482* CUTOFF = 2 * AVMASS + 20 MEV *
17483* *
17484* for N*(1535) we use the parameterization by Gy. Wolf et al *
17485* Nucl phys A552 (1993) 349, added May 18, 1994 *
17486**********************************
17487 PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
17488 1 AMP=0.93828,AP1=0.13496,AKA=0.498,APHI=1.020,
17489 2 AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
17490 parameter (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
17491 COMMON /AA/ R(3,MAXSTR)
17492cc SAVE /AA/
17493 COMMON /BB/ P(3,MAXSTR)
17494cc SAVE /BB/
17495 COMMON /CC/ E(MAXSTR)
17496cc SAVE /CC/
17497 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
17498cc SAVE /EE/
17499 common /ff/f(-mx:mx,-my:my,-mz:mz,-mpx:mpx,-mpy:mpy,-mpz:mpzp)
17500cc SAVE /ff/
17501 common /gg/ dx,dy,dz,dpx,dpy,dpz
17502cc SAVE /gg/
17503 COMMON /INPUT/ NSTAR,NDIRCT,DIR
17504cc SAVE /INPUT/
17505 COMMON /NN/NNN
17506cc SAVE /NN/
17507 COMMON /BG/BETAX,BETAY,BETAZ,GAMMA
17508cc SAVE /BG/
17509 COMMON /RUN/NUM
17510cc SAVE /RUN/
17511 COMMON /PA/RPION(3,MAXSTR,MAXR)
17512cc SAVE /PA/
17513 COMMON /PB/PPION(3,MAXSTR,MAXR)
17514cc SAVE /PB/
17515 COMMON /PC/EPION(MAXSTR,MAXR)
17516cc SAVE /PC/
17517 COMMON /PD/LPION(MAXSTR,MAXR)
17518cc SAVE /PD/
17519 common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
17520cc SAVE /input1/
17521 SAVE
17522*-----------------------------------------------------------------------
17523 XINEL=0
17524 SIGK=0
17525 XSK1=0
17526 XSK2=0
17527 XSK3=0
17528 XSK4=0
17529 XSK5=0
17530 EM1=E(I1)
17531 EM2=E(I2)
17532 PR = SQRT( PX**2 + PY**2 + PZ**2 )
17533* IF THERE WERE 2 N*(1535) AND THEY DIDN'T SCATT. ELAST.,
17534* ALLOW THEM TO PRODUCE KAONS. NO OTHER INELASTIC CHANNELS
17535* ARE KNOWN
17536C if((lb(i1).ge.12).and.(lb(i2).ge.12))return
17537* ALL the inelastic collisions between N*(1535) and Delta as well
17538* as N*(1440) TO PRODUCE KAONS, NO OTHER CHANNELS ARE KNOWN
17539C if((lb(i1).ge.12).and.(lb(i2).ge.3))return
17540C if((lb(i2).ge.12).and.(lb(i1).ge.3))return
17541* calculate the N*(1535) production cross section in I1+I2 collisions
17542 call N1535(iabs(lb(i1)),iabs(lb(i2)),srt,X1535)
17543c
17544* for Delta+Delta-->N*(1440 OR 1535)+N AND N*(1440)+N*(1440)-->N*(1535)+X
17545* AND DELTA+N*(1440)-->N*(1535)+X
17546* WE ASSUME THEY HAVE THE SAME CROSS SECTIONS as CORRESPONDING N+N COLLISION):
17547* FOR D++D0, D+D+,D+D-,D0D0,N*+N*+,N*0N*0,N*(+)D+,N*(+)D(-),N*(0)D(0)
17548* N*(1535) production, kaon production and reabsorption through
17549* D(N*)+D(N*)-->NN are ALLOWED.
17550* CROSS SECTION FOR KAON PRODUCTION from the four channels are
17551* for NLK channel
17552 akp=0.498
17553 ak0=0.498
17554 ana=0.94
17555 ada=1.232
17556 al=1.1157
17557 as=1.1197
17558 xsk1=0
17559 xsk2=0
17560 xsk3=0
17561 xsk4=0
17562 t1nlk=ana+al+akp
17563 if(srt.le.t1nlk)go to 222
17564 XSK1=1.5*PPLPK(SRT)
17565* for DLK channel
17566 t1dlk=ada+al+akp
17567 t2dlk=ada+al-akp
17568 if(srt.le.t1dlk)go to 222
17569 es=srt
17570 pmdlk2=(es**2-t1dlk**2)*(es**2-t2dlk**2)/(4.*es**2)
17571 pmdlk=sqrt(pmdlk2)
17572 XSK3=1.5*PPLPK(srt)
17573* for NSK channel
17574 t1nsk=ana+as+akp
17575 t2nsk=ana+as-akp
17576 if(srt.le.t1nsk)go to 222
17577 pmnsk2=(es**2-t1nsk**2)*(es**2-t2nsk**2)/(4.*es**2)
17578 pmnsk=sqrt(pmnsk2)
17579 XSK2=1.5*(PPK1(srt)+PPK0(srt))
17580* for DSK channel
17581 t1DSk=aDa+aS+akp
17582 t2DSk=aDa+aS-akp
17583 if(srt.le.t1dsk)go to 222
17584 pmDSk2=(es**2-t1DSk**2)*(es**2-t2DSk**2)/(4.*es**2)
17585 pmDSk=sqrt(pmDSk2)
17586 XSK4=1.5*(PPK1(srt)+PPK0(srt))
17587csp11/21/01
17588c phi production
17589 if(srt.le.(2.*amn+aphi))go to 222
17590c !! mb put the correct form
17591 xsk5 = 0.0001
17592csp11/21/01 end
17593* THE TOTAL KAON+ PRODUCTION CROSS SECTION IS THEN
17594222 SIGK=XSK1+XSK2+XSK3+XSK4
17595
17596cbz3/7/99 neutralk
17597 XSK1 = 2.0 * XSK1
17598 XSK2 = 2.0 * XSK2
17599 XSK3 = 2.0 * XSK3
17600 XSK4 = 2.0 * XSK4
17601 SIGK = 2.0 * SIGK + xsk5
17602cbz3/7/99 neutralk end
17603
17604 IDD=iabs(LB(I1)*LB(I2))
17605* The reabsorption cross section for the process
17606* D(N*)D(N*)-->NN is
17607 s2d=reab2d(i1,i2,srt)
17608
17609cbz3/16/99 pion
17610 S2D = 0.
17611cbz3/16/99 pion end
17612
17613*(1) N*(1535)+D(N*(1440)) reactions
17614* we allow kaon production and reabsorption only
17615 if(((iabs(lb(i1)).ge.12).and.(iabs(lb(i2)).ge.12)).OR.
17616 & ((iabs(lb(i1)).ge.12).and.(iabs(lb(i2)).ge.6)).OR.
17617 & ((iabs(lb(i2)).ge.12).and.(iabs(lb(i1)).ge.6)))THEN
17618 XINEL=sigk+s2d
17619 RETURN
17620 ENDIF
17621* channels have the same charge as pp
17622 IF((IDD.EQ.63).OR.(IDD.EQ.64).OR.(IDD.EQ.48).
17623 1 OR.(IDD.EQ.49).OR.(IDD.EQ.11*11).OR.(IDD.EQ.10*10).
17624 2 OR.(IDD.EQ.88).OR.(IDD.EQ.66).
17625 3 OR.(IDD.EQ.90).OR.(IDD.EQ.70))THEN
17626 XINEL=X1535+SIGK+s2d
17627 RETURN
17628 ENDIF
17629* IN DELTA+N*(1440) and N*(1440)+N*(1440) COLLISIONS,
17630* N*(1535), kaon production and reabsorption are ALLOWED
17631* IN N*(1440)+N*(1440) COLLISIONS, ONLY N*(1535) IS ALLOWED
17632 IF((IDD.EQ.110).OR.(IDD.EQ.77).OR.(IDD.EQ.80))THEN
17633 XINEL=X1535+SIGK+s2d
17634 RETURN
17635 ENDIF
17636 IF((IDD.EQ.54).OR.(IDD.EQ.56))THEN
17637* LIKE FOR N+P COLLISION,
17638* IN DELTA+DELTA COLLISIONS BOTH N*(1440) AND N*(1535) CAN BE PRODUCED
17639 SIG2=(3./4.)*SIGMA(SRT,2,0,1)
17640 XINEL=2.*(SIG2+X1535)+SIGK+s2d
17641 RETURN
17642 ENDIF
17643 RETURN
17644 END
17645******************************************
17646 real function dirct1(srt)
17647* This function contains the experimental, direct pion(+) + p cross sections *
17648* srt = DSQRT(s) in GeV *
17649* dirct1 = cross section in fm**2 *
17650* earray = EXPerimental table with the srt
17651* xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
17652******************************************
17653c real*4 xarray(122), earray(122)
17654 real xarray(122), earray(122)
17655 SAVE
17656 data earray /
17657 &1.568300,1.578300,1.588300,1.598300,1.608300,1.618300,1.628300,
17658 &1.638300,1.648300,1.658300,1.668300,1.678300,1.688300,1.698300,
17659 &1.708300,1.718300,1.728300,1.738300,1.748300,1.758300,1.768300,
17660 &1.778300,1.788300,1.798300,1.808300,1.818300,1.828300,1.838300,
17661 &1.848300,1.858300,1.868300,1.878300,1.888300,1.898300,1.908300,
17662 &1.918300,1.928300,1.938300,1.948300,1.958300,1.968300,1.978300,
17663 &1.988300,1.998300,2.008300,2.018300,2.028300,2.038300,2.048300,
17664 &2.058300,2.068300,2.078300,2.088300,2.098300,2.108300,2.118300,
17665 &2.128300,2.138300,2.148300,2.158300,2.168300,2.178300,2.188300,
17666 &2.198300,2.208300,2.218300,2.228300,2.238300,2.248300,2.258300,
17667 &2.268300,2.278300,2.288300,2.298300,2.308300,2.318300,2.328300,
17668 &2.338300,2.348300,2.358300,2.368300,2.378300,2.388300,2.398300,
17669 &2.408300,2.418300,2.428300,2.438300,2.448300,2.458300,2.468300,
17670 &2.478300,2.488300,2.498300,2.508300,2.518300,2.528300,2.538300,
17671 &2.548300,2.558300,2.568300,2.578300,2.588300,2.598300,2.608300,
17672 &2.618300,2.628300,2.638300,2.648300,2.658300,2.668300,2.678300,
17673 &2.688300,2.698300,2.708300,2.718300,2.728300,2.738300,2.748300,
17674 &2.758300,2.768300,2.778300/
17675 data xarray/
17676 &1.7764091E-02,0.5643668,0.8150568,1.045565,2.133695,3.327922,
17677 &4.206488,3.471242,4.486876,5.542213,6.800052,7.192446,6.829848,
17678 &6.580306,6.868410,8.527946,10.15720,9.716511,9.298335,8.901310,
17679 &10.31213,10.52185,11.17630,11.61639,12.05577,12.71596,13.46036,
17680 &14.22060,14.65449,14.94775,14.93310,15.32907,16.56481,16.29422,
17681 &15.18548,14.12658,13.72544,13.24488,13.31003,14.42680,12.84423,
17682 &12.49025,12.14858,11.81870,11.18993,11.35816,11.09447,10.83873,
17683 &10.61592,10.53754,9.425521,8.195912,9.661075,9.696192,9.200142,
17684 &8.953734,8.715461,8.484999,8.320765,8.255512,8.190969,8.127125,
17685 &8.079508,8.073004,8.010611,7.948909,7.887895,7.761005,7.626290,
17686 &7.494696,7.366132,7.530178,8.392097,9.046881,8.962544,8.879403,
17687 &8.797427,8.716601,8.636904,8.558312,8.404368,8.328978,8.254617,
17688 &8.181265,8.108907,8.037527,7.967100,7.897617,7.829057,7.761405,
17689 &7.694647,7.628764,7.563742,7.499570,7.387562,7.273281,7.161334,
17690 &6.973375,6.529592,6.280323,6.293136,6.305725,6.318097,6.330258,
17691 &6.342214,6.353968,6.365528,6.376895,6.388079,6.399081,6.409906,
17692 &6.420560,6.431045,6.441367,6.451529,6.461533,6.471386,6.481091,
17693 &6.490650,6.476413,6.297259,6.097826/
17694
17695 dirct1=0
17696 if (srt .lt. earray(1)) then
17697 dirct1 = 0.00001
17698 return
17699 end if
17700 if (srt .gt. earray(122)) then
17701 dirct1 = xarray(122)
17702 dirct1=dirct1/10.
17703 return
17704 end if
17705*
17706*Interpolate double logarithmically to find xdirct2(srt)
17707*
17708 do 1001 ie = 1,122
17709 if (earray(ie) .eq. srt) then
17710 dirct1= xarray(ie)
17711 dirct1=dirct1/10.
17712 return
17713 endif
17714 if (earray(ie) .gt. srt) then
17715 ymin = alog(xarray(ie-1))
17716 ymax = alog(xarray(ie))
17717 xmin = alog(earray(ie-1))
17718 xmax = alog(earray(ie))
17719 dirct1= exp(ymin + (alog(srt)-xmin)
17720 & *(ymax-ymin)/(xmax-xmin) )
17721 dirct1=dirct1/10.
17722 go to 50
17723 end if
17724 1001 continue
1772550 continue
17726 return
17727 END
17728*******************************
17729******************************************
17730 real function dirct2(srt)
17731* This function contains the experimental, direct pion(-) + p cross sections *
17732* srt = DSQRT(s) in GeV *
17733* dirct2 = cross section in fm**2
17734* earray = EXPerimental table with the srt
17735* xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
17736******************************************
17737c real*4 xarray(122), earray(122)
17738 real xarray(122), earray(122)
17739 SAVE
17740 data earray /
17741 &1.568300,1.578300,1.588300,1.598300,1.608300,1.618300,1.628300,
17742 &1.638300,1.648300,1.658300,1.668300,1.678300,1.688300,1.698300,
17743 &1.708300,1.718300,1.728300,1.738300,1.748300,1.758300,1.768300,
17744 &1.778300,1.788300,1.798300,1.808300,1.818300,1.828300,1.838300,
17745 &1.848300,1.858300,1.868300,1.878300,1.888300,1.898300,1.908300,
17746 &1.918300,1.928300,1.938300,1.948300,1.958300,1.968300,1.978300,
17747 &1.988300,1.998300,2.008300,2.018300,2.028300,2.038300,2.048300,
17748 &2.058300,2.068300,2.078300,2.088300,2.098300,2.108300,2.118300,
17749 &2.128300,2.138300,2.148300,2.158300,2.168300,2.178300,2.188300,
17750 &2.198300,2.208300,2.218300,2.228300,2.238300,2.248300,2.258300,
17751 &2.268300,2.278300,2.288300,2.298300,2.308300,2.318300,2.328300,
17752 &2.338300,2.348300,2.358300,2.368300,2.378300,2.388300,2.398300,
17753 &2.408300,2.418300,2.428300,2.438300,2.448300,2.458300,2.468300,
17754 &2.478300,2.488300,2.498300,2.508300,2.518300,2.528300,2.538300,
17755 &2.548300,2.558300,2.568300,2.578300,2.588300,2.598300,2.608300,
17756 &2.618300,2.628300,2.638300,2.648300,2.658300,2.668300,2.678300,
17757 &2.688300,2.698300,2.708300,2.718300,2.728300,2.738300,2.748300,
17758 &2.758300,2.768300,2.778300/
17759 data xarray/0.5773182,1.404156,2.578629,3.832013,4.906011,
17760 &9.076963,13.10492,10.65975,15.31156,19.77611,19.92874,18.68979,
17761 &19.80114,18.39536,14.34269,13.35353,13.58822,14.57031,10.24686,
17762 &11.23386,9.764803,10.35652,10.53539,10.07524,9.582198,9.596469,
17763 &9.818489,9.012848,9.378012,9.529244,9.529698,8.835624,6.671396,
17764 &8.797758,8.133437,7.866227,7.823946,7.808504,7.791755,7.502062,
17765 &7.417275,7.592349,7.752028,7.910585,8.068122,8.224736,8.075289,
17766 &7.895902,7.721359,7.551512,7.386224,7.225343,7.068739,6.916284,
17767 &6.767842,6.623294,6.482520,6.345404,6.211833,7.339510,7.531462,
17768 &7.724824,7.919620,7.848021,7.639856,7.571083,7.508881,7.447474,
17769 &7.386855,7.327011,7.164454,7.001266,6.842526,6.688094,6.537823,
17770 &6.391583,6.249249,6.110689,5.975790,5.894200,5.959503,6.024602,
17771 &6.089505,6.154224,6.218760,6.283128,6.347331,6.297411,6.120248,
17772 &5.948606,6.494864,6.357106,6.222824,6.091910,5.964267,5.839795,
17773 &5.718402,5.599994,5.499146,5.451325,5.404156,5.357625,5.311721,
17774 &5.266435,5.301964,5.343963,5.385833,5.427577,5.469200,5.510702,
17775 &5.552088,5.593359,5.634520,5.675570,5.716515,5.757356,5.798093,
17776 &5.838732,5.879272,5.919717,5.960068,5.980941/
17777
17778 dirct2=0.
17779 if (srt .lt. earray(1)) then
17780 dirct2 = 0.00001
17781 return
17782 end if
17783 if (srt .gt. earray(122)) then
17784 dirct2 = xarray(122)
17785 dirct2=dirct2/10.
17786 return
17787 end if
17788*
17789*Interpolate double logarithmically to find xdirct2(srt)
17790*
17791 do 1001 ie = 1,122
17792 if (earray(ie) .eq. srt) then
17793 dirct2= xarray(ie)
17794 dirct2=dirct2/10.
17795 return
17796 endif
17797 if (earray(ie) .gt. srt) then
17798 ymin = alog(xarray(ie-1))
17799 ymax = alog(xarray(ie))
17800 xmin = alog(earray(ie-1))
17801 xmax = alog(earray(ie))
17802 dirct2= exp(ymin + (alog(srt)-xmin)
17803 & *(ymax-ymin)/(xmax-xmin) )
17804 dirct2=dirct2/10.
17805 go to 50
17806 end if
17807 1001 continue
1780850 continue
17809 return
17810 END
17811*******************************
17812******************************
17813* this program calculates the elastic cross section for rho+nucleon
17814* through higher resonances
17815c real*4 function ErhoN(em1,em2,lb1,lb2,srt)
17816 real function ErhoN(em1,em2,lb1,lb2,srt)
17817* date : Dec. 19, 1994
17818* ****************************
17819c implicit real*4 (a-h,o-z)
17820 dimension arrayj(19),arrayl(19),arraym(19),
17821 &arrayw(19),arrayb(19)
17822 SAVE
17823 data arrayj /0.5,1.5,0.5,0.5,2.5,2.5,1.5,0.5,1.5,3.5,
17824 &1.5,0.5,1.5,0.5,2.5,0.5,1.5,2.5,3.5/
17825 data arrayl/1,2,0,0,2,3,2,1,1,3,
17826 &1,0,2,0,3,1,1,2,3/
17827 data arraym /1.44,1.52,1.535,1.65,1.675,1.68,1.70,1.71,
17828 &1.72,1.99,1.60,1.62,1.70,1.90,1.905,1.910,
17829 &1.86,1.93,1.95/
17830 data arrayw/0.2,0.125,0.15,0.15,0.155,0.125,0.1,0.11,
17831 &0.2,0.29,0.25,0.16,0.28,0.15,0.3,0.22,0.25,
17832 &0.25,0.24/
17833 data arrayb/0.15,0.20,0.05,0.175,0.025,0.125,0.1,0.20,
17834 &0.53,0.34,0.05,0.07,0.15,0.45,0.45,0.058,
17835 &0.08,0.12,0.08/
17836
17837* the minimum energy for pion+delta collision
17838 pi=3.1415926
17839 xs=0
17840* include contribution from each resonance
17841 do 1001 ir=1,19
17842cbz11/25/98
17843 IF(IR.LE.8)THEN
17844c if(lb1*lb2.eq.27.OR.LB1*LB2.EQ.25*2)branch=0.
17845c if(lb1*lb2.eq.26.OR.LB1*LB2.EQ.26*2)branch=1./3.
17846c if(lb1*lb2.eq.27*2.OR.LB1*LB2.EQ.25)branch=2./3.
17847c ELSE
17848c if(lb1*lb2.eq.27.OR.LB1*LB2.EQ.25*2)branch=1.
17849c if(lb1*lb2.eq.26.OR.LB1*LB2.EQ.26*2)branch=2./3.
17850c if(lb1*lb2.eq.27*2.OR.LB1*LB2.EQ.25)branch=1./3.
17851c ENDIF
17852 if( ((lb1*lb2.eq.27.AND.(LB1.EQ.1.OR.LB2.EQ.1)).OR.
17853 & (LB1*LB2.EQ.25*2.AND.(LB1.EQ.2.OR.LB2.EQ.2)))
17854 & .OR.((lb1*lb2.eq.-25.AND.(LB1.EQ.-1.OR.LB2.EQ.-1)).OR.
17855 & (LB1*LB2.EQ.-27*2.AND.(LB1.EQ.-2.OR.LB2.EQ.-2))) )
17856 & branch=0.
17857 if((iabs(lb1*lb2).eq.26.AND.(iabs(LB1).EQ.1.OR.iabs(LB2).EQ.1))
17858 & .OR.(iabs(LB1*LB2).EQ.26*2
17859 & .AND.(iabs(LB1).EQ.2.OR.iabs(LB2).EQ.2)))
17860 & branch=1./3.
17861 if( ((lb1*lb2.eq.27*2.AND.(LB1.EQ.2.OR.LB2.EQ.2)).OR.
17862 & (LB1*LB2.EQ.25.AND.(LB1.EQ.1.OR.LB2.EQ.1)))
17863 & .OR.((lb1*lb2.eq.-25*2.AND.(LB1.EQ.-2.OR.LB2.EQ.-2)).OR.
17864 & (LB1*LB2.EQ.-27.AND.(LB1.EQ.-1.OR.LB2.EQ.-1))) )
17865 & branch=2./3.
17866 ELSE
17867 if( ((lb1*lb2.eq.27.AND.(LB1.EQ.1.OR.LB2.EQ.1)).OR.
17868 & (LB1*LB2.EQ.25*2.AND.(LB1.EQ.2.OR.LB2.EQ.2)))
17869 & .OR.((lb1*lb2.eq.-25.AND.(LB1.EQ.-1.OR.LB2.EQ.-1)).OR.
17870 & (LB1*LB2.EQ.-27*2.AND.(LB1.EQ.-2.OR.LB2.EQ.-2))) )
17871 & branch=1.
17872 if((iabs(lb1*lb2).eq.26.AND.(iabs(LB1).EQ.1.OR.iabs(LB2).EQ.1))
17873 & .OR.(iabs(LB1*LB2).EQ.26*2
17874 & .AND.(iabs(LB1).EQ.2.OR.iabs(LB2).EQ.2)))
17875 & branch=2./3.
17876 if( ((lb1*lb2.eq.27*2.AND.(LB1.EQ.2.OR.LB2.EQ.2)).OR.
17877 & (LB1*LB2.EQ.25.AND.(LB1.EQ.1.OR.LB2.EQ.1)))
17878 & .OR.((lb1*lb2.eq.-25*2.AND.(LB1.EQ.-2.OR.LB2.EQ.-2)).OR.
17879 & (LB1*LB2.EQ.-27.AND.(LB1.EQ.-1.OR.LB2.EQ.-1))) )
17880 & branch=1./3.
17881 ENDIF
17882cbz11/25/98end
17883 xs0=fdR(arraym(ir),arrayj(ir),arrayl(ir),
17884 &arrayw(ir),arrayb(ir),srt,EM1,EM2)
17885 xs=xs+1.3*pi*branch*xs0*(0.1973)**2
17886 1001 continue
17887 Erhon=xs
17888 return
17889 end
17890***************************8
17891*FUNCTION FDE(DMASS) GIVES DELTA MASS DISTRIBUTION BY USING OF
17892*KITAZOE'S FORMULA
17893c REAL*4 FUNCTION FDR(DMASS,aj,al,width,widb0,srt,em1,em2)
17894 REAL FUNCTION FDR(DMASS,aj,al,width,widb0,srt,em1,em2)
17895 SAVE
17896 AMd=em1
17897 AmP=em2
17898 Ak02= 0.25*(DMASS**2-amd**2-amp**2)**2
17899 & -(Amp*amd)**2
17900 IF (ak02 .GT. 0.) THEN
17901 Q0 = SQRT(ak02/DMASS)
17902 ELSE
17903 Q0= 0.0
17904 fdR=0
17905 return
17906 END IF
17907 Ak2= 0.25*(srt**2-amd**2-amp**2)**2
17908 & -(Amp*amd)**2
17909 IF (ak2 .GT. 0.) THEN
17910 Q = SQRT(ak2/DMASS)
17911 ELSE
17912 Q= 0.00
17913 fdR=0
17914 return
17915 END IF
17916 b=widb0*1.2*dmass/srt*(q/q0)**(2.*al+1)
17917 & /(1.+0.2*(q/q0)**(2*al))
17918 FDR=(2.*aj+1)*WIDTH**2*b/((srt-dmass)**2
17919 1 +0.25*WIDTH**2)/(6.*q**2)
17920 RETURN
17921 END
17922******************************
17923* this program calculates the elastic cross section for pion+delta
17924* through higher resonances
17925c REAL*4 FUNCTION DIRCT3(SRT)
17926 REAL FUNCTION DIRCT3(SRT)
17927* date : Dec. 19, 1994
17928* ****************************
17929c implicit real*4 (a-h,o-z)
17930 dimension arrayj(17),arrayl(17),arraym(17),
17931 &arrayw(17),arrayb(17)
17932 SAVE
17933 data arrayj /1.5,0.5,2.5,2.5,1.5,0.5,1.5,3.5,
17934 &1.5,0.5,1.5,0.5,2.5,0.5,1.5,2.5,3.5/
17935 data arrayl/2,0,2,3,2,1,1,3,
17936 &1,0,2,0,3,1,1,2,3/
17937 data arraym /1.52,1.65,1.675,1.68,1.70,1.71,
17938 &1.72,1.99,1.60,1.62,1.70,1.90,1.905,1.910,
17939 &1.86,1.93,1.95/
17940 data arrayw/0.125,0.15,0.155,0.125,0.1,0.11,
17941 &0.2,0.29,0.25,0.16,0.28,0.15,0.3,0.22,0.25,
17942 &0.25,0.24/
17943 data arrayb/0.55,0.6,0.375,0.6,0.1,0.15,
17944 &0.15,0.05,0.35,0.3,0.15,0.1,0.1,0.22,
17945 &0.2,0.09,0.4/
17946
17947* the minimum energy for pion+delta collision
17948 pi=3.1415926
17949 amn=0.938
17950 amp=0.138
17951 xs=0
17952* include contribution from each resonance
17953 branch=1./3.
17954 do 1001 ir=1,17
17955 if(ir.gt.8)branch=2./3.
17956 xs0=fd1(arraym(ir),arrayj(ir),arrayl(ir),
17957 &arrayw(ir),arrayb(ir),srt)
17958 xs=xs+1.3*pi*branch*xs0*(0.1973)**2
17959 1001 continue
17960 DIRCT3=XS
17961 RETURN
17962 end
17963***************************8
17964*FUNCTION FDE(DMASS) GIVES DELTA MASS DISTRIBUTION BY USING OF
17965*KITAZOE'S FORMULA
17966c REAL*4 FUNCTION FD1(DMASS,aj,al,width,widb0,srt)
17967 REAL FUNCTION FD1(DMASS,aj,al,width,widb0,srt)
17968 SAVE
17969 AMN=0.938
17970 AmP=0.138
17971 amd=amn
17972 Ak02= 0.25*(DMASS**2-amd**2-amp**2)**2
17973 & -(Amp*amd)**2
17974 IF (ak02 .GT. 0.) THEN
17975 Q0 = SQRT(ak02/DMASS)
17976 ELSE
17977 Q0= 0.0
17978 fd1=0
17979 return
17980 END IF
17981 Ak2= 0.25*(srt**2-amd**2-amp**2)**2
17982 & -(Amp*amd)**2
17983 IF (ak2 .GT. 0.) THEN
17984 Q = SQRT(ak2/DMASS)
17985 ELSE
17986 Q= 0.00
17987 fd1=0
17988 return
17989 END IF
17990 b=widb0*1.2*dmass/srt*(q/q0)**(2.*al+1)
17991 & /(1.+0.2*(q/q0)**(2*al))
17992 FD1=(2.*aj+1)*WIDTH**2*b/((srt-dmass)**2
17993 1 +0.25*WIDTH**2)/(2.*q**2)
17994 RETURN
17995 END
17996******************************
17997* this program calculates the elastic cross section for pion+delta
17998* through higher resonances
17999c REAL*4 FUNCTION DPION(EM1,EM2,LB1,LB2,SRT)
18000 REAL FUNCTION DPION(EM1,EM2,LB1,LB2,SRT)
18001* date : Dec. 19, 1994
18002* ****************************
18003c implicit real*4 (a-h,o-z)
18004 dimension arrayj(19),arrayl(19),arraym(19),
18005 &arrayw(19),arrayb(19)
18006 SAVE
18007 data arrayj /0.5,1.5,0.5,0.5,2.5,2.5,1.5,0.5,1.5,3.5,
18008 &1.5,0.5,1.5,0.5,2.5,0.5,1.5,2.5,3.5/
18009 data arrayl/1,2,0,0,2,3,2,1,1,3,
18010 &1,0,2,0,3,1,1,2,3/
18011 data arraym /1.44,1.52,1.535,1.65,1.675,1.68,1.70,1.71,
18012 &1.72,1.99,1.60,1.62,1.70,1.90,1.905,1.910,
18013 &1.86,1.93,1.95/
18014 data arrayw/0.2,0.125,0.15,0.15,0.155,0.125,0.1,0.11,
18015 &0.2,0.29,0.25,0.16,0.28,0.15,0.3,0.22,0.25,
18016 &0.25,0.24/
18017 data arrayb/0.15,0.25,0.,0.05,0.575,0.125,0.379,0.10,
18018 &0.10,0.062,0.45,0.60,0.6984,0.05,0.25,0.089,
18019 &0.19,0.2,0.13/
18020
18021* the minimum energy for pion+delta collision
18022 pi=3.1415926
18023 amn=0.94
18024 amp=0.14
18025 xs=0
18026* include contribution from each resonance
18027 do 1001 ir=1,19
18028 BRANCH=0.
18029cbz11/25/98
18030 if(ir.LE.8)THEN
18031c IF(LB1*LB2.EQ.5*7.OR.LB1*LB2.EQ.3*8)branch=1./6.
18032c IF(LB1*LB2.EQ.4*7.OR.LB1*LB2.EQ.4*8)branch=1./3.
18033c IF(LB1*LB2.EQ.5*6.OR.LB1*LB2.EQ.3*9)branch=1./2.
18034c ELSE
18035c IF(LB1*LB2.EQ.5*8.OR.LB1*LB2.EQ.5*6)branch=2./5.
18036c IF(LB1*LB2.EQ.3*9.OR.LB1*LB2.EQ.3*7)branch=2./5.
18037c IF(LB1*LB2.EQ.5*7.OR.LB1*LB2.EQ.3*8)branch=8./15.
18038c IF(LB1*LB2.EQ.4*7.OR.LB1*LB2.EQ.4*8)branch=1./15.
18039c IF(LB1*LB2.EQ.4*9.OR.LB1*LB2.EQ.4*6)branch=3./5.
18040c ENDIF
18041 IF( ((LB1*LB2.EQ.5*7.AND.(LB1.EQ.5.OR.LB2.EQ.5)).OR.
18042 & (LB1*LB2.EQ.3*8.AND.(LB1.EQ.3.OR.LB2.EQ.3)))
18043 & .OR.((LB1*LB2.EQ.-3*7.AND.(LB1.EQ.3.OR.LB2.EQ.3)).OR.
18044 & (LB1*LB2.EQ.-5*8.AND.(LB1.EQ.5.OR.LB2.EQ.5))) )
18045 & branch=1./6.
18046 IF((iabs(LB1*LB2).EQ.4*7.AND.(LB1.EQ.4.OR.LB2.EQ.4)).OR.
18047 & (iabs(LB1*LB2).EQ.4*8.AND.(LB1.EQ.4.OR.LB2.EQ.4)))
18048 & branch=1./3.
18049 IF( ((LB1*LB2.EQ.5*6.AND.(LB1.EQ.5.OR.LB2.EQ.5)).OR.
18050 & (LB1*LB2.EQ.3*9.AND.(LB1.EQ.3.OR.LB2.EQ.3)))
18051 & .OR.((LB1*LB2.EQ.-3*6.AND.(LB1.EQ.3.OR.LB2.EQ.3)).OR.
18052 & (LB1*LB2.EQ.-5*9.AND.(LB1.EQ.5.OR.LB2.EQ.5))) )
18053 & branch=1./2.
18054 ELSE
18055 IF( ((LB1*LB2.EQ.5*8.AND.(LB1.EQ.5.OR.LB2.EQ.5)).OR.
18056 & (LB1*LB2.EQ.5*6.AND.(LB1.EQ.5.OR.LB2.EQ.5)))
18057 & .OR.((LB1*LB2.EQ.-3*8.AND.(LB1.EQ.3.OR.LB2.EQ.3)).OR.
18058 & (LB1*LB2.EQ.-3*6.AND.(LB1.EQ.3.OR.LB2.EQ.3))) )
18059 & branch=2./5.
18060 IF( ((LB1*LB2.EQ.3*9.AND.(LB1.EQ.3.OR.LB2.EQ.3)).OR.
18061 & (LB1*LB2.EQ.3*7.AND.(LB1.EQ.3.OR.LB2.EQ.3)))
18062 & .OR. ((LB1*LB2.EQ.-5*9.AND.(LB1.EQ.5.OR.LB2.EQ.5)).OR.
18063 & (LB1*LB2.EQ.-5*7.AND.(LB1.EQ.5.OR.LB2.EQ.5))) )
18064 & branch=2./5.
18065 IF( ((LB1*LB2.EQ.5*7.AND.(LB1.EQ.5.OR.LB2.EQ.5)).OR.
18066 & (LB1*LB2.EQ.3*8.AND.(LB1.EQ.3.OR.LB2.EQ.3)))
18067 & .OR.((LB1*LB2.EQ.-3*7.AND.(LB1.EQ.3.OR.LB2.EQ.3)).OR.
18068 & (LB1*LB2.EQ.-5*8.AND.(LB1.EQ.5.OR.LB2.EQ.5))) )
18069 & branch=8./15.
18070 IF((iabs(LB1*LB2).EQ.4*7.AND.(LB1.EQ.4.OR.LB2.EQ.4)).OR.
18071 & (iabs(LB1*LB2).EQ.4*8.AND.(LB1.EQ.4.OR.LB2.EQ.4)))
18072 & branch=1./15.
18073 IF((iabs(LB1*LB2).EQ.4*9.AND.(LB1.EQ.4.OR.LB2.EQ.4)).OR.
18074 & (iabs(LB1*LB2).EQ.4*6.AND.(LB1.EQ.4.OR.LB2.EQ.4)))
18075 & branch=3./5.
18076 ENDIF
18077cbz11/25/98end
18078 xs0=fd2(arraym(ir),arrayj(ir),arrayl(ir),
18079 &arrayw(ir),arrayb(ir),EM1,EM2,srt)
18080 xs=xs+1.3*pi*branch*xs0*(0.1973)**2
18081 1001 continue
18082 DPION=XS
18083 RETURN
18084 end
18085***************************8
18086*FUNCTION FDE(DMASS) GIVES DELTA MASS DISTRIBUTION BY USING OF
18087*KITAZOE'S FORMULA
18088c REAL*4 FUNCTION FD2(DMASS,aj,al,width,widb0,EM1,EM2,srt)
18089 REAL FUNCTION FD2(DMASS,aj,al,width,widb0,EM1,EM2,srt)
18090 SAVE
18091 AmP=EM1
18092 amd=EM2
18093 Ak02= 0.25*(DMASS**2-amd**2-amp**2)**2
18094 & -(Amp*amd)**2
18095 IF (ak02 .GT. 0.) THEN
18096 Q0 = SQRT(ak02/DMASS)
18097 ELSE
18098 Q0= 0.0
18099 fd2=0
18100 return
18101 END IF
18102 Ak2= 0.25*(srt**2-amd**2-amp**2)**2
18103 & -(Amp*amd)**2
18104 IF (ak2 .GT. 0.) THEN
18105 Q = SQRT(ak2/DMASS)
18106 ELSE
18107 Q= 0.00
18108 fd2=0
18109 return
18110 END IF
18111 b=widb0*1.2*dmass/srt*(q/q0)**(2.*al+1)
18112 & /(1.+0.2*(q/q0)**(2*al))
18113 FD2=(2.*aj+1)*WIDTH**2*b/((srt-dmass)**2
18114 1 +0.25*WIDTH**2)/(4.*q**2)
18115 RETURN
18116 END
18117***************************8
18118* MASS GENERATOR for two resonances simultaneously
18119 subroutine Rmasdd(srt,am10,am20,
18120 &dmin1,dmin2,ISEED,ic,dm1,dm2)
18121 COMMON/RNDF77/NSEED
18122cc SAVE /RNDF77/
18123 SAVE
18124 ISEED=ISEED
18125 amn=0.94
18126 amp=0.14
18127* the maximum mass for resonance 1
18128 dmax1=srt-dmin2
18129* generate the mass for the first resonance
18130 5 NTRY1=0
18131 ntry2=0
18132 ntry=0
18133 ictrl=0
1813410 DM1 = RANART(NSEED) * (DMAX1-DMIN1) + DMIN1
18135 NTRY1=NTRY1+1
18136* the maximum mass for resonance 2
18137 if(ictrl.eq.0)dmax2=srt-dm1
18138* generate the mass for the second resonance
1813920 dm2=RANART(NSEED)*(dmax2-dmin2)+dmin2
18140 NTRY2=NTRY2+1
18141* check the energy-momentum conservation with two masses
18142* q2 in the following is q**2*4*srt**2
18143 q2=((srt**2-dm1**2-dm2**2)**2-4.*dm1**2*dm2**2)
18144 if(q2.le.0)then
18145 dmax2=dm2-0.01
18146c dmax1=dm1-0.01
18147 ictrl=1
18148 go to 20
18149 endif
18150* determine the weight of the mass pair
18151 IF(DMAX1.LT.am10) THEN
18152 if(ic.eq.1)FM1=Fmassd(DMAX1)
18153 if(ic.eq.2)FM1=Fmassn(DMAX1)
18154 if(ic.eq.3)FM1=Fmassd(DMAX1)
18155 if(ic.eq.4)FM1=Fmassd(DMAX1)
18156 ELSE
18157 if(ic.eq.1)FM1=Fmassd(am10)
18158 if(ic.eq.2)FM1=Fmassn(am10)
18159 if(ic.eq.3)FM1=Fmassd(am10)
18160 if(ic.eq.4)FM1=Fmassd(am10)
18161 ENDIF
18162 IF(DMAX2.LT.am20) THEN
18163 if(ic.eq.1)FM2=Fmassd(DMAX2)
18164 if(ic.eq.2)FM2=Fmassn(DMAX2)
18165 if(ic.eq.3)FM2=Fmassn(DMAX2)
18166 if(ic.eq.4)FM2=Fmassr(DMAX2)
18167 ELSE
18168 if(ic.eq.1)FM2=Fmassd(am20)
18169 if(ic.eq.2)FM2=Fmassn(am20)
18170 if(ic.eq.3)FM2=Fmassn(am20)
18171 if(ic.eq.4)FM2=Fmassr(am20)
18172 ENDIF
18173 IF(FM1.EQ.0.)FM1=1.e-04
18174 IF(FM2.EQ.0.)FM2=1.e-04
18175 prob0=fm1*fm2
18176 if(ic.eq.1)prob=Fmassd(dm1)*fmassd(dm2)
18177 if(ic.eq.2)prob=Fmassn(dm1)*fmassn(dm2)
18178 if(ic.eq.3)prob=Fmassd(dm1)*fmassn(dm2)
18179 if(ic.eq.4)prob=Fmassd(dm1)*fmassr(dm2)
18180 if(prob.le.1.e-06)prob=1.e-06
18181 fff=prob/prob0
18182 ntry=ntry+1
18183 IF(RANART(NSEED).GT.fff.AND.
18184 1 NTRY.LE.20) GO TO 10
18185
18186clin-2/26/03 limit the mass of (rho,Delta,N*1440) below a certain value
18187c (here taken as its central value + 2* B-W fullwidth):
18188 if((abs(am10-0.77).le.0.01.and.dm1.gt.1.07)
18189 1 .or.(abs(am10-1.232).le.0.01.and.dm1.gt.1.47)
18190 2 .or.(abs(am10-1.44).le.0.01.and.dm1.gt.2.14)) goto 5
18191 if((abs(am20-0.77).le.0.01.and.dm2.gt.1.07)
18192 1 .or.(abs(am20-1.232).le.0.01.and.dm2.gt.1.47)
18193 2 .or.(abs(am20-1.44).le.0.01.and.dm2.gt.2.14)) goto 5
18194
18195 RETURN
18196 END
18197*FUNCTION Fmassd(DMASS) GIVES the delta MASS DISTRIBUTION
18198 REAL FUNCTION Fmassd(DMASS)
18199 SAVE
18200 AM0=1.232
18201 Fmassd=am0*WIDTH(DMASS)/((DMASS**2-am0**2)**2
18202 1 +am0**2*WIDTH(DMASS)**2)
18203 RETURN
18204 END
18205*FUNCTION Fmassn(DMASS) GIVES the N* MASS DISTRIBUTION
18206 REAL FUNCTION Fmassn(DMASS)
18207 SAVE
18208 AM0=1.44
18209 Fmassn=am0*W1440(DMASS)/((DMASS**2-am0**2)**2
18210 1 +am0**2*W1440(DMASS)**2)
18211 RETURN
18212 END
18213*FUNCTION Fmassr(DMASS) GIVES the rho MASS DISTRIBUTION
18214 REAL FUNCTION Fmassr(DMASS)
18215 SAVE
18216 AM0=0.77
18217 wid=0.153
18218 Fmassr=am0*Wid/((DMASS**2-am0**2)**2
18219 1 +am0**2*Wid**2)
18220 RETURN
18221 END
18222**********************************
18223* PURPOSE : flow analysis
18224* DATE : Feb. 1, 1995
18225***********************************
18226 subroutine flow(nt)
18227c IMPLICIT REAL*4 (A-H,O-Z)
18228 PARAMETER ( PI=3.1415926,APion=0.13957,aka=0.498)
18229 PARAMETER (MAXSTR=150001,MAXR=1,AMU= 0.9383,etaM=0.5475)
18230 DIMENSION ypion(-80:80),ypr(-80:80),ykaon(-80:80)
18231 dimension pxpion(-80:80),pxpro(-80:80),pxkaon(-80:80)
18232*----------------------------------------------------------------------*
18233 COMMON /AA/ R(3,MAXSTR)
18234cc SAVE /AA/
18235 COMMON /BB/ P(3,MAXSTR)
18236cc SAVE /BB/
18237 COMMON /CC/ E(MAXSTR)
18238cc SAVE /CC/
18239 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
18240cc SAVE /EE/
18241 COMMON /RR/ MASSR(0:MAXR)
18242cc SAVE /RR/
18243 COMMON /RUN/ NUM
18244cc SAVE /RUN/
18245 common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
18246cc SAVE /input1/
18247 SAVE
18248*----------------------------------------------------------------------*
18249 NT=NT
18250 ycut1=-2.6
18251 ycut2=2.6
18252 DY=0.2
18253 LY=NINT((YCUT2-YCUT1)/DY)
18254***********************************
18255C initialize the transverse momentum counters
18256 do 11 kk=-80,80
18257 pxpion(kk)=0
18258 pxpro(kk)=0
18259 pxkaon(kk)=0
1826011 continue
18261 DO 701 J=-LY,LY
18262 ypion(j)=0
18263 ykaon(j)=0
18264 ypr(j)=0
18265 701 CONTINUE
18266 nkaon=0
18267 npr=0
18268 npion=0
18269 IS=0
18270 DO 20 NRUN=1,NUM
18271 IS=IS+MASSR(NRUN-1)
18272 DO 20 J=1,MASSR(NRUN)
18273 I=J+IS
18274* for protons go to 200 to calculate its rapidity and transvese momentum
18275* distributions
18276 e00=sqrt(P(1,I)**2+P(2,i)**2+P(3,i)**2+e(I)**2)
18277 y00=0.5*alog((e00+p(3,i))/(e00-p(3,i)))
18278 if(abs(y00).ge.ycut2)go to 20
18279 iy=nint(y00/DY)
18280 if(abs(iy).ge.80)go to 20
18281 if(e(i).eq.0)go to 20
18282 if(lb(i).ge.25)go to 20
18283 if((lb(i).le.5).and.(lb(i).ge.3))go to 50
18284 if(lb(i).eq.1.or.lb(i).eq.2)go to 200
18285cbz3/10/99
18286c if(lb(i).ge.6.and.lb(i).le.15)go to 200
18287 if(lb(i).ge.6.and.lb(i).le.17)go to 200
18288cbz3/10/99 end
18289 if(lb(i).eq.23)go to 400
18290 go to 20
18291* calculate rapidity and transverse momentum distribution for pions
1829250 npion=npion+1
18293* (2) rapidity distribution in the cms frame
18294 ypion(iy)=ypion(iy)+1
18295 pxpion(iy)=pxpion(iy)+p(1,i)/e(I)
18296 go TO 20
18297* calculate rapidity and transverse energy distribution for baryons
18298200 npr=npr+1
18299 pxpro(iy)=pxpro(iy)+p(1,I)/E(I)
18300 ypr(iy)=ypr(iy)+1.
18301 go to 20
18302400 nkaon=nkaon+1
18303 ykaon(iy)=ykaon(iy)+1.
18304 pxkaon(iy)=pxkaon(iy)+p(1,i)/E(i)
1830520 CONTINUE
18306C PRINT OUT NUCLEON'S TRANSVERSE MOMENTUM distribution
18307c write(1041,*)Nt
18308c write(1042,*)Nt
18309c write(1043,*)Nt
18310c write(1090,*)Nt
18311c write(1091,*)Nt
18312c write(1092,*)Nt
18313 do 3 npt=-10,10
18314 IF(ypr(npt).eq.0) go to 101
18315 pxpro(NPT)=-Pxpro(NPT)/ypr(NPT)
18316 DNUC=Pxpro(NPT)/SQRT(ypr(NPT))
18317c WRITE(1041,*)NPT*DY,Pxpro(NPT),DNUC
18318c print pion's transverse momentum distribution
18319101 IF(ypion(npt).eq.0) go to 102
18320 pxpion(NPT)=-pxpion(NPT)/ypion(NPT)
18321 DNUCp=pxpion(NPT)/SQRT(ypion(NPT))
18322c WRITE(1042,*)NPT*DY,Pxpion(NPT),DNUCp
18323c kaons
18324102 IF(ykaon(npt).eq.0) go to 3
18325 pxkaon(NPT)=-pxkaon(NPT)/ykaon(NPT)
18326 DNUCk=pxkaon(NPT)/SQRT(ykaon(NPT))
18327c WRITE(1043,*)NPT*DY,Pxkaon(NPT),DNUCk
183283 CONTINUE
18329********************************
18330* OUTPUT PION AND PROTON RAPIDITY DISTRIBUTIONS
18331 DO 1001 M=-LY,LY
18332* PROTONS
18333 DYPR=0
18334 IF(YPR(M).NE.0)DYPR=SQRT(YPR(M))/FLOAT(NRUN)/DY
18335 YPR(M)=YPR(M)/FLOAT(NRUN)/DY
18336c WRITE(1090,'(E11.3,2X,E11.3,2X,E11.3)')m*DY,YPR(M),DYPR
18337* PIONS
18338 DYPION=0
18339 IF(YPION(M).NE.0)DYPION=SQRT(YPION(M))/FLOAT(NRUN)/DY
18340 YPION(M)=YPION(M)/FLOAT(NRUN)/DY
18341c WRITE(1091,'(E11.3,2X,E11.3,2X,E11.3)')m*DY,YPION(M),DYPION
18342* KAONS
18343 DYKAON=0
18344 IF(YKAON(M).NE.0)DYKAON=SQRT(YKAON(M))/FLOAT(NRUN)/DY
18345 YKAON(M)=YKAON(M)/FLOAT(NRUN)/DY
18346c WRITE(1092,'(E11.3,2X,E11.3,2X,E11.3)')m*DY,YKAON(M),DYKAON
18347 1001 CONTINUE
18348 return
18349 end
18350cbali1/16/99
18351********************************************
18352* Purpose: pp_bar annihilation cross section as a functon of their cms energy
18353c real*4 function xppbar(srt)
18354 real function xppbar(srt)
18355* srt = DSQRT(s) in GeV *
18356* xppbar = pp_bar annihilation cross section in mb *
18357*
18358* Reference: G.J. Wang, R. Bellwied, C. Pruneau and G. Welke
18359* Proc. of the 14th Winter Workshop on Nuclear Dynamics,
18360* Snowbird, Utah 31, Eds. W. Bauer and H.G. Ritter
18361* (Plenum Publishing, 1998) *
18362*
18363******************************************
18364 Parameter (pmass=0.9383,xmax=400.)
18365 SAVE
18366* Note:
18367* (1) we introduce a new parameter xmax=400 mb:
18368* the maximum annihilation xsection
18369* there are shadowing effects in pp_bar annihilation, with this parameter
18370* we can probably look at these effects
18371* (2) Calculate p(lab) from srt [GeV], since the formular in the
18372* reference applies only to the case of a p_bar on a proton at rest
18373* Formula used: srt**2=2.*pmass*(pmass+sqrt(pmass**2+plab**2))
18374 xppbar=1.e-06
18375 plab2=(srt**2/(2.*pmass)-pmass)**2-pmass**2
18376 if(plab2.gt.0)then
18377 plab=sqrt(plab2)
18378 xppbar=67./(plab**0.7)
18379 if(xppbar.gt.xmax)xppbar=xmax
18380 endif
18381 return
18382 END
18383cbali1/16/99 end
18384**********************************
18385cbali2/6/99
18386********************************************
18387* Purpose: To generate randomly the no. of pions in the final
18388* state of pp_bar annihilation according to a statistical
18389* model by using of the rejection method.
18390cbz2/25/99
18391c real*4 function pbarfs(srt,npion,iseed)
18392 subroutine pbarfs(srt,npion,iseed)
18393cbz2/25/99end
18394* Quantities:
18395* srt: DSQRT(s) in GeV *
18396* npion: No. of pions produced in the annihilation of ppbar at srt *
18397* nmax=6, cutoff of the maximum no. of n the code can handle
18398*
18399* Reference: C.M. Ko and R. Yuan, Phys. Lett. B192 (1987) 31 *
18400*
18401******************************************
18402 parameter (pimass=0.140,pi=3.1415926)
18403 Dimension factor(6),pnpi(6)
18404 COMMON/RNDF77/NSEED
18405cc SAVE /RNDF77/
18406 SAVE
18407 ISEED=ISEED
18408C the factorial coefficients in the pion no. distribution
18409* from n=2 to 6 calculated use the formula in the reference
18410 factor(2)=1.
18411 factor(3)=1.17e-01
18412 factor(4)=3.27e-03
18413 factor(5)=3.58e-05
18414 factor(6)=1.93e-07
18415 ene=(srt/pimass)**3/(6.*pi**2)
18416c the relative probability from n=2 to 6
18417 do 1001 n=2,6
18418 pnpi(n)=ene**n*factor(n)
18419 1001 continue
18420c find the maximum of the probabilities, I checked a
18421c Fortan manual: max() returns the maximum value of
18422c the same type as in the argument list
18423 pmax=max(pnpi(2),pnpi(3),pnpi(4),pnpi(5),pnpi(6))
18424c randomly generate n between 2 and 6
18425 ntry=0
18426 10 npion=2+int(5*RANART(NSEED))
18427clin-4/2008 check bounds:
18428 if(npion.gt.6) goto 10
18429 thisp=pnpi(npion)/pmax
18430 ntry=ntry+1
18431c decide whether to take this npion according to the distribution
18432c using rejection method.
18433 if((thisp.lt.RANART(NSEED)).and.(ntry.le.20)) go to 10
18434c now take the last generated npion and return
18435 return
18436 END
18437**********************************
18438cbali2/6/99 end
18439cbz3/9/99 kkbar
18440cbali3/5/99
18441******************************************
18442* purpose: Xsection for K+ K- to pi+ pi-
18443c real*4 function xkkpi(srt)
18444* srt = DSQRT(s) in GeV *
18445* xkkpi = xsection in mb obtained from
18446* the detailed balance *
18447* ******************************************
18448c parameter (pimass=0.140,aka=0.498)
18449c xkkpi=1.e-08
18450c ppi2=(srt/2)**2-pimass**2
18451c pk2=(srt/2)**2-aka**2
18452c if(ppi2.le.0.or.pk2.le.0)return
18453cbz3/9/99 kkbar
18454c xkkpi=ppi2/pk2*pipik(srt)
18455c xkkpi=9.0 / 4.0 * ppi2/pk2*pipik(srt)
18456c xkkpi = 2.0 * xkkpi
18457cbz3/9/99 kkbar end
18458
18459cbz3/9/99 kkbar
18460c end
18461c return
18462c END
18463cbz3/9/99 kkbar end
18464
18465cbali3/5/99 end
18466cbz3/9/99 kkbar end
18467
18468cbz3/9/99 kkbar
18469*****************************
18470* purpose: Xsection for K+ K- to pi+ pi-
18471 SUBROUTINE XKKANN(SRT, XSK1, XSK2, XSK3, XSK4, XSK5,
18472 & XSK6, XSK7, XSK8, XSK9, XSK10, XSK11, SIGK, rrkk)
18473* srt = DSQRT(s) in GeV *
18474* xsk1 = annihilation into pi pi *
18475* xsk2 = annihilation into pi rho (shifted to XKKSAN) *
18476* xsk3 = annihilation into pi omega (shifted to XKKSAN) *
18477* xsk4 = annihilation into pi eta *
18478* xsk5 = annihilation into rho rho *
18479* xsk6 = annihilation into rho omega *
18480* xsk7 = annihilation into rho eta (shifted to XKKSAN) *
18481* xsk8 = annihilation into omega omega *
18482* xsk9 = annihilation into omega eta (shifted to XKKSAN) *
18483* xsk10 = annihilation into eta eta *
18484* sigk = xsection in mb obtained from *
18485* the detailed balance *
18486* ***************************
18487 PARAMETER (MAXSTR=150001, MAXX=20, MAXZ=24)
18488 PARAMETER (AKA=0.498, PIMASS=0.140, RHOM = 0.770,
18489 & OMEGAM = 0.7819, ETAM = 0.5473, APHI=1.02)
18490 COMMON /AA/ R(3,MAXSTR)
18491cc SAVE /AA/
18492 COMMON /BB/ P(3,MAXSTR)
18493cc SAVE /BB/
18494 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
18495cc SAVE /EE/
18496 COMMON /DD/ RHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
18497 & RHOP(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
18498 & RHON(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
18499cc SAVE /DD/
18500 SAVE
18501
18502 S = SRT ** 2
18503 SIGK = 1.E-08
18504 XSK1 = 0.0
18505 XSK2 = 0.0
18506 XSK3 = 0.0
18507 XSK4 = 0.0
18508 XSK5 = 0.0
18509 XSK6 = 0.0
18510 XSK7 = 0.0
18511 XSK8 = 0.0
18512 XSK9 = 0.0
18513 XSK10 = 0.0
18514 XSK11 = 0.0
18515
18516 XPION0 = PIPIK(SRT)
18517c.....take into account both K+ and K0
18518 XPION0 = 2.0 * XPION0
18519 PI2 = S * (S - 4.0 * AKA ** 2)
18520 if(PI2 .le. 0.0)return
18521
18522 XM1 = PIMASS
18523 XM2 = PIMASS
18524 PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
18525 IF (PF2 .GT. 0.0) THEN
18526 XSK1 = 9.0 / 4.0 * PF2 / PI2 * XPION0
18527 END IF
18528
18529clin-8/28/00 (pi eta) eta -> K+K- is assumed the same as pi pi -> K+K-:
18530 XM1 = PIMASS
18531 XM2 = ETAM
18532 PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
18533 IF (PF2 .GT. 0.0) THEN
18534 XSK4 = 3.0 / 4.0 * PF2 / PI2 * XPION0
18535 END IF
18536
18537 XM1 = ETAM
18538 XM2 = ETAM
18539 PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
18540 IF (PF2 .GT. 0.0) THEN
18541 XSK10 = 1.0 / 4.0 * PF2 / PI2 * XPION0
18542 END IF
18543
18544 XPION0 = rrkk
18545
18546clin-11/07/00: (pi eta) (rho omega) -> K* Kbar (or K*bar K) instead to K Kbar:
18547c XM1 = PIMASS
18548c XM2 = RHOM
18549c PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
18550c IF (PF2 .GT. 0.0) THEN
18551c XSK2 = 27.0 / 4.0 * PF2 / PI2 * XPION0
18552c END IF
18553
18554c XM1 = PIMASS
18555c XM2 = OMEGAM
18556c PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
18557c IF (PF2 .GT. 0.0) THEN
18558c XSK3 = 9.0 / 4.0 * PF2 / PI2 * XPION0
18559c END IF
18560
18561 XM1 = RHOM
18562 XM2 = RHOM
18563 PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
18564 IF (PF2 .GT. 0.0) THEN
18565 XSK5 = 81.0 / 4.0 * PF2 / PI2 * XPION0
18566 END IF
18567
18568 XM1 = RHOM
18569 XM2 = OMEGAM
18570 PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
18571 IF (PF2 .GT. 0.0) THEN
18572 XSK6 = 27.0 / 4.0 * PF2 / PI2 * XPION0
18573 END IF
18574
18575c XM1 = RHOM
18576c XM2 = ETAM
18577c PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
18578c IF (PF2 .GT. 0.0) THEN
18579c XSK7 = 9.0 / 4.0 * PF2 / PI2 * XPION0
18580c END IF
18581
18582 XM1 = OMEGAM
18583 XM2 = OMEGAM
18584 PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
18585 IF (PF2 .GT. 0.0) THEN
18586 XSK8 = 9.0 / 4.0 * PF2 / PI2 * XPION0
18587 END IF
18588
18589c XM1 = OMEGAM
18590c XM2 = ETAM
18591c PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
18592c IF (PF2 .GT. 0.0) THEN
18593c XSK9 = 3.0 / 4.0 * PF2 / PI2 * XPION0
18594c END IF
18595
18596c* K+ + K- --> phi
18597 fwdp = 1.68*(aphi**2-4.*aka**2)**1.5/6./aphi/aphi
18598 pkaon=0.5*sqrt(srt**2-4.0*aka**2)
18599 XSK11 = 30.*3.14159*0.1973**2*(aphi*fwdp)**2/
18600 & ((srt**2-aphi**2)**2+(aphi*fwdp)**2)/pkaon**2
18601c
18602 SIGK = XSK1 + XSK2 + XSK3 + XSK4 + XSK5 +
18603 & XSK6 + XSK7 + XSK8 + XSK9 + XSK10 + XSK11
18604
18605 RETURN
18606 END
18607cbz3/9/99 kkbar end
18608
18609*****************************
18610* purpose: Xsection for Phi + B
18611 SUBROUTINE XphiB(LB1, LB2, EM1, EM2, SRT,
18612 & XSK1, XSK2, XSK3, XSK4, XSK5, SIGP)
18613c
18614* ***************************
18615 PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
18616 1 AMP=0.93828,AP1=0.13496,AP2=0.13957,AM0=1.232,PI=3.1415926)
18617 PARAMETER (AKA=0.498, ALA = 1.1157, PIMASS=0.140, APHI=1.02)
18618 parameter (arho=0.77)
18619 SAVE
18620
18621 SIGP = 1.E-08
18622 XSK1 = 0.0
18623 XSK2 = 0.0
18624 XSK3 = 0.0
18625 XSK4 = 0.0
18626 XSK5 = 0.0
18627 XSK6 = 0.0
18628 srrt = srt - (em1+em2)
18629
18630c* phi + N(D) -> elastic scattering
18631c XSK1 = 0.56 !! mb
18632c !! mb (photo-production xsecn used)
18633 XSK1 = 8.00
18634c
18635c* phi + N(D) -> pi + N
18636 IF (srt .GT. (ap1+amn)) THEN
18637 XSK2 = 0.0235*srrt**(-0.519)
18638 END IF
18639c
18640c* phi + N(D) -> pi + D
18641 IF (srt .GT. (ap1+am0)) THEN
18642 if(srrt .lt. 0.7)then
18643 XSK3 = 0.0119*srrt**(-0.534)
18644 else
18645 XSK3 = 0.0130*srrt**(-0.304)
18646 endif
18647 END IF
18648c
18649c* phi + N(D) -> rho + N
18650 IF (srt .GT. (arho+amn)) THEN
18651 if(srrt .lt. 0.7)then
18652 XSK4 = 0.0166*srrt**(-0.786)
18653 else
18654 XSK4 = 0.0189*srrt**(-0.277)
18655 endif
18656 END IF
18657c
18658c* phi + N(D) -> rho + D (same as pi + D)
18659 IF (srt .GT. (arho+am0)) THEN
18660 if(srrt .lt. 0.7)then
18661 XSK5 = 0.0119*srrt**(-0.534)
18662 else
18663 XSK5 = 0.0130*srrt**(-0.304)
18664 endif
18665 END IF
18666c
18667c* phi + N -> K+ + La
18668 IF( (lb1.ge.1.and.lb1.le.2) .or. (lb2.ge.1.and.lb2.le.2) )THEN
18669 IF (srt .GT. (aka+ala)) THEN
18670 XSK6 = 1.715/((srrt+3.508)**2-12.138)
18671 END IF
18672 END IF
18673 SIGP = XSK1 + XSK2 + XSK3 + XSK4 + XSK5 + XSK6
18674 RETURN
18675 END
18676c
18677**********************************
18678*
18679 SUBROUTINE CRPHIB(PX,PY,PZ,SRT,I1,I2,
18680 & XSK1, XSK2, XSK3, XSK4, XSK5, SIGP, IBLOCK)
18681*
18682* PURPOSE: *
18683* DEALING WITH PHI + N(D) --> pi+N(D), rho+N(D), K+ + La
18684* QUANTITIES: *
18685* PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
18686* SRT - SQRT OF S *
18687* IBLOCK - INFORMATION about the reaction channel *
18688*
18689* iblock - 20 elastic
18690* iblock - 221 K+ formation
18691* iblock - 223 others
18692**********************************
18693 PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
18694 1 AMP=0.93828,AP1=0.13496,AMRHO=0.769,AMOMGA=0.782,
18695 2 AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
18696 PARAMETER (AKA=0.498,ALA=1.1157,ASA=1.1974,ARHO=0.77)
18697 parameter (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
18698 COMMON /AA/ R(3,MAXSTR)
18699cc SAVE /AA/
18700 COMMON /BB/ P(3,MAXSTR)
18701cc SAVE /BB/
18702 COMMON /CC/ E(MAXSTR)
18703cc SAVE /CC/
18704 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
18705cc SAVE /EE/
18706 common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
18707cc SAVE /input1/
18708 COMMON/RNDF77/NSEED
18709cc SAVE /RNDF77/
18710 SAVE
18711c
18712 PX0=PX
18713 PY0=PY
18714 PZ0=PZ
18715 IBLOCK=223
18716c
18717 X1 = RANART(NSEED) * SIGP
18718 XSK2 = XSK1 + XSK2
18719 XSK3 = XSK2 + XSK3
18720 XSK4 = XSK3 + XSK4
18721 XSK5 = XSK4 + XSK5
18722c
18723c !! elastic scatt.
18724 IF (X1 .LE. XSK1) THEN
18725 iblock=20
18726 GOTO 100
18727 ELSE IF (X1 .LE. XSK2) THEN
18728 LB(I1) = 3 + int(3 * RANART(NSEED))
18729 LB(I2) = 1 + int(2 * RANART(NSEED))
18730 E(I1) = AP1
18731 E(I2) = AMN
18732 GOTO 100
18733 ELSE IF (X1 .LE. XSK3) THEN
18734 LB(I1) = 3 + int(3 * RANART(NSEED))
18735 LB(I2) = 6 + int(4 * RANART(NSEED))
18736 E(I1) = AP1
18737 E(I2) = AM0
18738 GOTO 100
18739 ELSE IF (X1 .LE. XSK4) THEN
18740 LB(I1) = 25 + int(3 * RANART(NSEED))
18741 LB(I2) = 1 + int(2 * RANART(NSEED))
18742 E(I1) = ARHO
18743 E(I2) = AMN
18744 GOTO 100
18745 ELSE IF (X1 .LE. XSK5) THEN
18746 LB(I1) = 25 + int(3 * RANART(NSEED))
18747 LB(I2) = 6 + int(4 * RANART(NSEED))
18748 E(I1) = ARHO
18749 E(I2) = AM0
18750 GOTO 100
18751 ELSE
18752 LB(I1) = 23
18753 LB(I2) = 14
18754 E(I1) = AKA
18755 E(I2) = ALA
18756 IBLOCK=221
18757 ENDIF
18758 100 CONTINUE
18759 EM1=E(I1)
18760 EM2=E(I2)
18761*-----------------------------------------------------------------------
18762* CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
18763* ENERGY CONSERVATION
18764 PR2 = (SRT**2 - EM1**2 - EM2**2)**2
18765 1 - 4.0 * (EM1*EM2)**2
18766 IF(PR2.LE.0.)PR2=1.E-08
18767 PR=SQRT(PR2)/(2.*SRT)
18768* WE ASSUME AN ISOTROPIC ANGULAR DISTRIBUTION IN THE CMS
18769 C1 = 1.0 - 2.0 * RANART(NSEED)
18770 T1 = 2.0 * PI * RANART(NSEED)
18771 S1 = SQRT( 1.0 - C1**2 )
18772 CT1 = COS(T1)
18773 ST1 = SIN(T1)
18774* THE MOMENTUM IN THE CMS IN THE FINAL STATE
18775 PZ = PR * C1
18776 PX = PR * S1*CT1
18777 PY = PR * S1*ST1
18778* ROTATE IT
18779 CALL ROTATE(PX0,PY0,PZ0,PX,PY,PZ)
18780 RETURN
18781 END
18782c
18783*****************************
18784* purpose: Xsection for Phi + B
18785c!! in fm^2
18786 SUBROUTINE pibphi(srt,lb1,lb2,em1,em2,Xphi,xphin)
18787c
18788* phi + N(D) <- pi + N
18789* phi + N(D) <- pi + D
18790* phi + N(D) <- rho + N
18791* phi + N(D) <- rho + D (same as pi + D)
18792c
18793* ***************************
18794 PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
18795 1 AMP=0.93828,AP1=0.13496,AP2=0.13957,AM0=1.232,PI=3.1415926)
18796 PARAMETER (AKA=0.498, ALA = 1.1157, PIMASS=0.140, APHI=1.02)
18797 parameter (arho=0.77)
18798 SAVE
18799
18800 Xphi = 0.0
18801 xphin = 0.0
18802 xphid = 0.0
18803c
18804 if( (lb1.ge.3.and.lb1.le.5) .or.
18805 & (lb2.ge.3.and.lb2.le.5) )then
18806c
18807 if( (iabs(lb1).ge.1.and.iabs(lb1).le.2) .or.
18808 & (iabs(lb2).ge.1.and.iabs(lb2).le.2) )then
18809c* phi + N <- pi + N
18810 IF (srt .GT. (aphi+amn)) THEN
18811 srrt = srt - (aphi+amn)
18812 sig = 0.0235*srrt**(-0.519)
18813 xphin=sig*1.*(srt**2-(aphi+amn)**2)*
18814 & (srt**2-(aphi-amn)**2)/(srt**2-(em1+em2)**2)/
18815 & (srt**2-(em1-em2)**2)
18816 END IF
18817c* phi + D <- pi + N
18818 IF (srt .GT. (aphi+am0)) THEN
18819 srrt = srt - (aphi+am0)
18820 sig = 0.0235*srrt**(-0.519)
18821 xphid=sig*4.*(srt**2-(aphi+am0)**2)*
18822 & (srt**2-(aphi-am0)**2)/(srt**2-(em1+em2)**2)/
18823 & (srt**2-(em1-em2)**2)
18824 END IF
18825 else
18826c* phi + N <- pi + D
18827 IF (srt .GT. (aphi+amn)) THEN
18828 srrt = srt - (aphi+amn)
18829 if(srrt .lt. 0.7)then
18830 sig = 0.0119*srrt**(-0.534)
18831 else
18832 sig = 0.0130*srrt**(-0.304)
18833 endif
18834 xphin=sig*(1./4.)*(srt**2-(aphi+amn)**2)*
18835 & (srt**2-(aphi-amn)**2)/(srt**2-(em1+em2)**2)/
18836 & (srt**2-(em1-em2)**2)
18837 END IF
18838c* phi + D <- pi + D
18839 IF (srt .GT. (aphi+am0)) THEN
18840 srrt = srt - (aphi+am0)
18841 if(srrt .lt. 0.7)then
18842 sig = 0.0119*srrt**(-0.534)
18843 else
18844 sig = 0.0130*srrt**(-0.304)
18845 endif
18846 xphid=sig*1.*(srt**2-(aphi+am0)**2)*
18847 & (srt**2-(aphi-am0)**2)/(srt**2-(em1+em2)**2)/
18848 & (srt**2-(em1-em2)**2)
18849 END IF
18850 endif
18851c
18852c
18853C** for rho + N(D) colln
18854c
18855 else
18856c
18857 if( (iabs(lb1).ge.1.and.iabs(lb1).le.2) .or.
18858 & (iabs(lb2).ge.1.and.iabs(lb2).le.2) )then
18859c
18860c* phi + N <- rho + N
18861 IF (srt .GT. (aphi+amn)) THEN
18862 srrt = srt - (aphi+amn)
18863 if(srrt .lt. 0.7)then
18864 sig = 0.0166*srrt**(-0.786)
18865 else
18866 sig = 0.0189*srrt**(-0.277)
18867 endif
18868 xphin=sig*(1./3.)*(srt**2-(aphi+amn)**2)*
18869 & (srt**2-(aphi-amn)**2)/(srt**2-(em1+em2)**2)/
18870 & (srt**2-(em1-em2)**2)
18871 END IF
18872c* phi + D <- rho + N
18873 IF (srt .GT. (aphi+am0)) THEN
18874 srrt = srt - (aphi+am0)
18875 if(srrt .lt. 0.7)then
18876 sig = 0.0166*srrt**(-0.786)
18877 else
18878 sig = 0.0189*srrt**(-0.277)
18879 endif
18880 xphid=sig*(4./3.)*(srt**2-(aphi+am0)**2)*
18881 & (srt**2-(aphi-am0)**2)/(srt**2-(em1+em2)**2)/
18882 & (srt**2-(em1-em2)**2)
18883 END IF
18884 else
18885c* phi + N <- rho + D (same as pi+D->phi+N)
18886 IF (srt .GT. (aphi+amn)) THEN
18887 srrt = srt - (aphi+amn)
18888 if(srrt .lt. 0.7)then
18889 sig = 0.0119*srrt**(-0.534)
18890 else
18891 sig = 0.0130*srrt**(-0.304)
18892 endif
18893 xphin=sig*(1./12.)*(srt**2-(aphi+amn)**2)*
18894 & (srt**2-(aphi-amn)**2)/(srt**2-(em1+em2)**2)/
18895 & (srt**2-(em1-em2)**2)
18896 END IF
18897c* phi + D <- rho + D (same as pi+D->phi+D)
18898 IF (srt .GT. (aphi+am0)) THEN
18899 srrt = srt - (aphi+am0)
18900 if(srrt .lt. 0.7)then
18901 sig = 0.0119*srrt**(-0.534)
18902 else
18903 sig = 0.0130*srrt**(-0.304)
18904 endif
18905 xphid=sig*(1./3.)*(srt**2-(aphi+am0)**2)*
18906 & (srt**2-(aphi-am0)**2)/(srt**2-(em1+em2)**2)/
18907 & (srt**2-(em1-em2)**2)
18908 END IF
18909 endif
18910 END IF
18911c !! in fm^2
18912 xphin = xphin/10.
18913c !! in fm^2
18914 xphid = xphid/10.
18915 Xphi = xphin + xphid
18916
18917 RETURN
18918 END
18919c
18920*****************************
18921* purpose: Xsection for phi +M to K+K etc
18922 SUBROUTINE PHIMES(I1, I2, SRT, XSK1, XSK2, XSK3, XSK4, XSK5,
18923 1 XSK6, XSK7, SIGPHI)
18924
18925* QUANTITIES: *
18926* PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
18927* SRT - SQRT OF S *
18928* IBLOCK - THE INFORMATION BACK *
18929* 223 --> phi destruction
18930* 20 --> elastic
18931**********************************
18932 PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
18933 1 AMP=0.93828,AP1=0.13496,
18934 2 AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
18935 PARAMETER (AKA=0.498, AKS=0.895, AOMEGA=0.7819,
18936 3 ARHO=0.77, APHI=1.02)
18937 parameter (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
18938 PARAMETER (MAXX=20, MAXZ=24)
18939 COMMON /AA/ R(3,MAXSTR)
18940cc SAVE /AA/
18941 COMMON /BB/ P(3,MAXSTR)
18942cc SAVE /BB/
18943 COMMON /CC/ E(MAXSTR)
18944cc SAVE /CC/
18945 COMMON /DD/ RHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
18946 & RHOP(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
18947 & RHON(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
18948cc SAVE /DD/
18949 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
18950cc SAVE /EE/
18951 SAVE
18952
18953 S = SRT ** 2
18954 SIGPHI = 1.E-08
18955 XSK1 = 0.0
18956 XSK2 = 0.0
18957 XSK3 = 0.0
18958 XSK4 = 0.0
18959 XSK5 = 0.0
18960 XSK6 = 0.0
18961 XSK7 = 0.0
18962 em1 = E(i1)
18963 em2 = E(i2)
18964 LB1 = LB(i1)
18965 LB2 = LB(i2)
18966 akap = aka
18967c******
18968c
18969c !! mb, elastic
18970 XSK1 = 5.0
18971
18972 pii = sqrt((S-(em1+em2)**2)*(S-(em1-em2)**2))
18973* phi + K(-bar) channel
18974 if( lb1.eq.23.or.lb2.eq.23 .or. lb1.eq.21.or.lb2.eq.21 )then
18975 if(srt .gt. (ap1+akap))then
18976c XSK2 = 2.5
18977 pff = sqrt((S-(ap1+akap)**2)*(S-(ap1-akap)**2))
18978 XSK2 = 195.639*pff/pii/32./pi/S
18979 endif
18980 if(srt .gt. (arho+akap))then
18981c XSK3 = 3.5
18982 pff = sqrt((S-(arho+akap)**2)*(S-(arho-akap)**2))
18983 XSK3 = 526.702*pff/pii/32./pi/S
18984 endif
18985 if(srt .gt. (aomega+akap))then
18986c XSK4 = 3.5
18987 pff = sqrt((S-(aomega+akap)**2)*(S-(aomega-akap)**2))
18988 XSK4 = 355.429*pff/pii/32./pi/S
18989 endif
18990 if(srt .gt. (ap1+aks))then
18991c XSK5 = 15.0
18992 pff = sqrt((S-(ap1+aks)**2)*(S-(ap1-aks)**2))
18993 XSK5 = 2047.042*pff/pii/32./pi/S
18994 endif
18995 if(srt .gt. (arho+aks))then
18996c XSK6 = 3.5
18997 pff = sqrt((S-(arho+aks)**2)*(S-(arho-aks)**2))
18998 XSK6 = 1371.257*pff/pii/32./pi/S
18999 endif
19000 if(srt .gt. (aomega+aks))then
19001c XSK7 = 3.5
19002 pff = sqrt((S-(aomega+aks)**2)*(S-(aomega-aks)**2))
19003 XSK7 = 482.292*pff/pii/32./pi/S
19004 endif
19005c
19006 elseif( iabs(lb1).eq.30.or.iabs(lb2).eq.30 )then
19007* phi + K*(-bar) channel
19008c
19009 if(srt .gt. (ap1+akap))then
19010c XSK2 = 3.5
19011 pff = sqrt((S-(ap1+akap)**2)*(S-(ap1-akap)**2))
19012 XSK2 = 372.378*pff/pii/32./pi/S
19013 endif
19014 if(srt .gt. (arho+akap))then
19015c XSK3 = 9.0
19016 pff = sqrt((S-(arho+akap)**2)*(S-(arho-akap)**2))
19017 XSK3 = 1313.960*pff/pii/32./pi/S
19018 endif
19019 if(srt .gt. (aomega+akap))then
19020c XSK4 = 6.5
19021 pff = sqrt((S-(aomega+akap)**2)*(S-(aomega-akap)**2))
19022 XSK4 = 440.558*pff/pii/32./pi/S
19023 endif
19024 if(srt .gt. (ap1+aks))then
19025c XSK5 = 30.0 !wrong
19026 pff = sqrt((S-(ap1+aks)**2)*(S-(ap1-aks)**2))
19027 XSK5 = 1496.692*pff/pii/32./pi/S
19028 endif
19029 if(srt .gt. (arho+aks))then
19030c XSK6 = 9.0
19031 pff = sqrt((S-(arho+aks)**2)*(S-(arho-aks)**2))
19032 XSK6 = 6999.840*pff/pii/32./pi/S
19033 endif
19034 if(srt .gt. (aomega+aks))then
19035c XSK7 = 15.0
19036 pff = sqrt((S-(aomega+aks)**2)*(S-(aomega-aks)**2))
19037 XSK7 = 1698.903*pff/pii/32./pi/S
19038 endif
19039 else
19040c
19041* phi + rho(pi,omega) channel
19042c
19043 srr1 = em1+em2
19044 if(srt .gt. (akap+akap))then
19045 srrt = srt - srr1
19046cc if(srrt .lt. 0.3)then
19047 if(srrt .lt. 0.3 .and. srrt .gt. 0.01)then
19048 XSK2 = 1.69/(srrt**0.141 - 0.407)
19049 else
19050 XSK2 = 3.74 + 0.008*srrt**1.9
19051 endif
19052 endif
19053 if(srt .gt. (akap+aks))then
19054 srr2 = akap+aks
19055 srr = amax1(srr1,srr2)
19056 srrt = srt - srr
19057cc if(srrt .lt. 0.3)then
19058 if(srrt .lt. 0.3 .and. srrt .gt. 0.01)then
19059 XSK3 = 1.69/(srrt**0.141 - 0.407)
19060 else
19061 XSK3 = 3.74 + 0.008*srrt**1.9
19062 endif
19063 endif
19064 if(srt .gt. (aks+aks))then
19065 srr2 = aks+aks
19066 srr = amax1(srr1,srr2)
19067 srrt = srt - srr
19068cc if(srrt .lt. 0.3)then
19069 if(srrt .lt. 0.3 .and. srrt .gt. 0.01)then
19070 XSK4 = 1.69/(srrt**0.141 - 0.407)
19071 else
19072 XSK4 = 3.74 + 0.008*srrt**1.9
19073 endif
19074 endif
19075c xsk2 = amin1(20.,xsk2)
19076c xsk3 = amin1(20.,xsk3)
19077c xsk4 = amin1(20.,xsk4)
19078 endif
19079
19080 SIGPHI = XSK1 + XSK2 + XSK3 + XSK4 + XSK5 + XSK6 + XSK7
19081
19082 RETURN
19083 END
19084
19085**********************************
19086* PURPOSE: *
19087* DEALING WITH phi+M scatt.
19088*
19089 SUBROUTINE CRPHIM(PX,PY,PZ,SRT,I1,I2,
19090 & XSK1, XSK2, XSK3, XSK4, XSK5, XSK6, SIGPHI, IKKG, IKKL, IBLOCK)
19091*
19092* QUANTITIES: *
19093* PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
19094* SRT - SQRT OF S *
19095* IBLOCK - THE INFORMATION BACK *
19096* 20 --> elastic
19097* 223 --> phi + pi(rho,omega)
19098* 224 --> phi + K -> K + pi(rho,omega)
19099* 225 --> phi + K -> K* + pi(rho,omega)
19100* 226 --> phi + K* -> K + pi(rho,omega)
19101* 227 --> phi + K* -> K* + pi(rho,omega)
19102**********************************
19103 PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
19104 1 AMP=0.93828,AP1=0.13496,ARHO=0.77,AOMEGA=0.7819,
19105 2 AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
19106 PARAMETER (AKA=0.498,AKS=0.895)
19107 parameter (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
19108 COMMON /AA/ R(3,MAXSTR)
19109cc SAVE /AA/
19110 COMMON /BB/ P(3,MAXSTR)
19111cc SAVE /BB/
19112 COMMON /CC/ E(MAXSTR)
19113cc SAVE /CC/
19114 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
19115cc SAVE /EE/
19116 common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
19117cc SAVE /input1/
19118 COMMON/RNDF77/NSEED
19119cc SAVE /RNDF77/
19120 SAVE
19121c
19122 PX0=PX
19123 PY0=PY
19124 PZ0=PZ
19125 LB1 = LB(i1)
19126 LB2 = LB(i2)
19127
19128 X1 = RANART(NSEED) * SIGPHI
19129 XSK2 = XSK1 + XSK2
19130 XSK3 = XSK2 + XSK3
19131 XSK4 = XSK3 + XSK4
19132 XSK5 = XSK4 + XSK5
19133 XSK6 = XSK5 + XSK6
19134 IF (X1 .LE. XSK1) THEN
19135c !! elastic scatt
19136 IBLOCK=20
19137 GOTO 100
19138 ELSE
19139c
19140*phi + (K,K*)-bar
19141 if( lb1.eq.23.or.lb1.eq.21.or.iabs(lb1).eq.30 .OR.
19142 & lb2.eq.23.or.lb2.eq.21.or.iabs(lb2).eq.30 )then
19143c
19144 if(lb1.eq.23.or.lb2.eq.23)then
19145 IKKL=1
19146 IBLOCK=224
19147 iad1 = 23
19148 iad2 = 30
19149 elseif(lb1.eq.30.or.lb2.eq.30)then
19150 IKKL=0
19151 IBLOCK=226
19152 iad1 = 23
19153 iad2 = 30
19154 elseif(lb1.eq.21.or.lb2.eq.21)then
19155 IKKL=1
19156 IBLOCK=124
19157 iad1 = 21
19158 iad2 = -30
19159c !! -30
19160 else
19161 IKKL=0
19162 IBLOCK=126
19163 iad1 = 21
19164 iad2 = -30
19165 endif
19166 IF (X1 .LE. XSK2) THEN
19167 LB(I1) = 3 + int(3 * RANART(NSEED))
19168 LB(I2) = iad1
19169 E(I1) = AP1
19170 E(I2) = AKA
19171 IKKG = 1
19172 GOTO 100
19173 ELSE IF (X1 .LE. XSK3) THEN
19174 LB(I1) = 25 + int(3 * RANART(NSEED))
19175 LB(I2) = iad1
19176 E(I1) = ARHO
19177 E(I2) = AKA
19178 IKKG = 1
19179 GOTO 100
19180 ELSE IF (X1 .LE. XSK4) THEN
19181 LB(I1) = 28
19182 LB(I2) = iad1
19183 E(I1) = AOMEGA
19184 E(I2) = AKA
19185 IKKG = 1
19186 GOTO 100
19187 ELSE IF (X1 .LE. XSK5) THEN
19188 LB(I1) = 3 + int(3 * RANART(NSEED))
19189 LB(I2) = iad2
19190 E(I1) = AP1
19191 E(I2) = AKS
19192 IKKG = 0
19193 IBLOCK=IBLOCK+1
19194 GOTO 100
19195 ELSE IF (X1 .LE. XSK6) THEN
19196 LB(I1) = 25 + int(3 * RANART(NSEED))
19197 LB(I2) = iad2
19198 E(I1) = ARHO
19199 E(I2) = AKS
19200 IKKG = 0
19201 IBLOCK=IBLOCK+1
19202 GOTO 100
19203 ELSE
19204 LB(I1) = 28
19205 LB(I2) = iad2
19206 E(I1) = AOMEGA
19207 E(I2) = AKS
19208 IKKG = 0
19209 IBLOCK=IBLOCK+1
19210 GOTO 100
19211 ENDIF
19212 else
19213c !! phi destruction via (pi,rho,omega)
19214 IBLOCK=223
19215*phi + pi(rho,omega)
19216 IF (X1 .LE. XSK2) THEN
19217 LB(I1) = 23
19218 LB(I2) = 21
19219 E(I1) = AKA
19220 E(I2) = AKA
19221 IKKG = 2
19222 IKKL = 0
19223 GOTO 100
19224 ELSE IF (X1 .LE. XSK3) THEN
19225 LB(I1) = 23
19226c LB(I2) = 30
19227 LB(I2) = -30
19228clin-2/10/03 currently take XSK3 to be the sum of KK*bar & KbarK*:
19229 if(RANART(NSEED).le.0.5) then
19230 LB(I1) = 21
19231 LB(I2) = 30
19232 endif
19233
19234 E(I1) = AKA
19235 E(I2) = AKS
19236 IKKG = 1
19237 IKKL = 0
19238 GOTO 100
19239 ELSE IF (X1 .LE. XSK4) THEN
19240 LB(I1) = 30
19241c LB(I2) = 30
19242 LB(I2) = -30
19243 E(I1) = AKS
19244 E(I2) = AKS
19245 IKKG = 0
19246 IKKL = 0
19247 GOTO 100
19248 ENDIF
19249 endif
19250 ENDIF
19251*
19252100 CONTINUE
19253 EM1=E(I1)
19254 EM2=E(I2)
19255
19256*-----------------------------------------------------------------------
19257* CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
19258* ENERGY CONSERVATION
19259 PR2 = (SRT**2 - EM1**2 - EM2**2)**2
19260 1 - 4.0 * (EM1*EM2)**2
19261 IF(PR2.LE.0.)PR2=1.E-08
19262 PR=SQRT(PR2)/(2.*SRT)
19263* WE ASSUME AN ISOTROPIC ANGULAR DISTRIBUTION IN THE CMS
19264 C1 = 1.0 - 2.0 * RANART(NSEED)
19265 T1 = 2.0 * PI * RANART(NSEED)
19266 S1 = SQRT( 1.0 - C1**2 )
19267 CT1 = COS(T1)
19268 ST1 = SIN(T1)
19269* THE MOMENTUM IN THE CMS IN THE FINAL STATE
19270 PZ = PR * C1
19271 PX = PR * S1*CT1
19272 PY = PR * S1*ST1
19273* ROTATE IT
19274 CALL ROTATE(PX0,PY0,PZ0,PX,PY,PZ)
19275 RETURN
19276 END
19277**********************************
19278**********************************
19279cbz3/9/99 khyperon
19280*************************************
19281* purpose: Xsection for K+Y -> piN *
19282* Xsection for K+Y-bar -> piN-bar !! sp03/29/01 *
19283*
19284 SUBROUTINE XKHYPE(I1, I2, SRT, XKY1, XKY2, XKY3, XKY4, XKY5,
19285 & XKY6, XKY7, XKY8, XKY9, XKY10, XKY11, XKY12, XKY13,
19286 & XKY14, XKY15, XKY16, XKY17, SIGK)
19287c subroutine xkhype(i1, i2, srt, sigk)
19288* srt = DSQRT(s) in GeV *
19289* xkkpi = xsection in mb obtained from *
19290* the detailed balance *
19291* ***********************************
19292 PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
19293 1 AMP=0.93828,AP1=0.13496,AMRHO=0.769,AMOMGA=0.782,APHI=1.02,
19294 2 AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
19295 parameter (pimass=0.140, AMETA = 0.5473, aka=0.498,
19296 & aml=1.116,ams=1.193, AM1440 = 1.44, AM1535 = 1.535)
19297 COMMON /EE/ID(MAXSTR), LB(MAXSTR)
19298cc SAVE /EE/
19299 SAVE
19300
19301 S = SRT ** 2
19302 SIGK=1.E-08
19303 XKY1 = 0.0
19304 XKY2 = 0.0
19305 XKY3 = 0.0
19306 XKY4 = 0.0
19307 XKY5 = 0.0
19308 XKY6 = 0.0
19309 XKY7 = 0.0
19310 XKY8 = 0.0
19311 XKY9 = 0.0
19312 XKY10 = 0.0
19313 XKY11 = 0.0
19314 XKY12 = 0.0
19315 XKY13 = 0.0
19316 XKY14 = 0.0
19317 XKY15 = 0.0
19318 XKY16 = 0.0
19319 XKY17 = 0.0
19320
19321 LB1 = LB(I1)
19322 LB2 = LB(I2)
19323 IF (iabs(LB1) .EQ. 14 .OR. iabs(LB2) .EQ. 14) THEN
19324 XKAON0 = PNLKA(SRT)
19325 XKAON0 = 2.0 * XKAON0
19326 PI2 = (S - (AML + AKA) ** 2) * (S - (AML - AKA) ** 2)
19327 ELSE
19328 XKAON0 = PNSKA(SRT)
19329 XKAON0 = 2.0 * XKAON0
19330 PI2 = (S - (AMS + AKA) ** 2) * (S - (AMS - AKA) ** 2)
19331 END IF
19332 if(PI2 .le. 0.0)return
19333
19334 XM1 = PIMASS
19335 XM2 = AMP
19336 PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19337 IF (PF2 .GT. 0.0) THEN
19338 XKY1 = 3.0 * PF2 / PI2 * XKAON0
19339 END IF
19340
19341 XM1 = PIMASS
19342 XM2 = AM0
19343 PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19344 IF (PF2 .GT. 0.0) THEN
19345 XKY2 = 12.0 * PF2 / PI2 * XKAON0
19346 END IF
19347
19348 XM1 = PIMASS
19349 XM2 = AM1440
19350 PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19351 IF (PF2 .GT. 0.0) THEN
19352 XKY3 = 3.0 * PF2 / PI2 * XKAON0
19353 END IF
19354
19355 XM1 = PIMASS
19356 XM2 = AM1535
19357 PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19358 IF (PF2 .GT. 0.0) THEN
19359 XKY4 = 3.0 * PF2 / PI2 * XKAON0
19360 END IF
19361
19362 XM1 = AMRHO
19363 XM2 = AMP
19364 PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19365 IF (PF2 .GT. 0.0) THEN
19366 XKY5 = 9.0 * PF2 / PI2 * XKAON0
19367 END IF
19368
19369 XM1 = AMRHO
19370 XM2 = AM0
19371 PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19372 IF (PF2 .GT. 0.0) THEN
19373 XKY6 = 36.0 * PF2 / PI2 * XKAON0
19374 END IF
19375
19376 XM1 = AMRHO
19377 XM2 = AM1440
19378 PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19379 IF (PF2 .GT. 0.0) THEN
19380 XKY7 = 9.0 * PF2 / PI2 * XKAON0
19381 END IF
19382
19383 XM1 = AMRHO
19384 XM2 = AM1535
19385 PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19386 IF (PF2 .GT. 0.0) THEN
19387 XKY8 = 9.0 * PF2 / PI2 * XKAON0
19388 END IF
19389
19390 XM1 = AMOMGA
19391 XM2 = AMP
19392 PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19393 IF (PF2 .GT. 0.0) THEN
19394 XKY9 = 3.0 * PF2 / PI2 * XKAON0
19395 END IF
19396
19397 XM1 = AMOMGA
19398 XM2 = AM0
19399 PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19400 IF (PF2 .GT. 0.0) THEN
19401 XKY10 = 12.0 * PF2 / PI2 * XKAON0
19402 END IF
19403
19404 XM1 = AMOMGA
19405 XM2 = AM1440
19406 PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19407 IF (PF2 .GT. 0.0) THEN
19408 XKY11 = 3.0 * PF2 / PI2 * XKAON0
19409 END IF
19410
19411 XM1 = AMOMGA
19412 XM2 = AM1535
19413 PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19414 IF (PF2 .GT. 0.0) THEN
19415 XKY12 = 3.0 * PF2 / PI2 * XKAON0
19416 END IF
19417
19418 XM1 = AMETA
19419 XM2 = AMP
19420 PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19421 IF (PF2 .GT. 0.0) THEN
19422 XKY13 = 1.0 * PF2 / PI2 * XKAON0
19423 END IF
19424
19425 XM1 = AMETA
19426 XM2 = AM0
19427 PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19428 IF (PF2 .GT. 0.0) THEN
19429 XKY14 = 4.0 * PF2 / PI2 * XKAON0
19430 END IF
19431
19432 XM1 = AMETA
19433 XM2 = AM1440
19434 PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19435 IF (PF2 .GT. 0.0) THEN
19436 XKY15 = 1.0 * PF2 / PI2 * XKAON0
19437 END IF
19438
19439 XM1 = AMETA
19440 XM2 = AM1535
19441 PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19442 IF (PF2 .GT. 0.0) THEN
19443 XKY16 = 1.0 * PF2 / PI2 * XKAON0
19444 END IF
19445
19446csp11/21/01 K+ + La --> phi + N
19447 if(lb1.eq.14 .or. lb2.eq.14)then
19448 if(srt .gt. (aphi+amn))then
19449 srrt = srt - (aphi+amn)
19450 sig = 1.715/((srrt+3.508)**2-12.138)
19451 XM1 = AMN
19452 XM2 = APHI
19453 PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19454c ! fm^-1
19455 XKY17 = 3.0 * PF2 / PI2 * SIG/10.
19456 endif
19457 endif
19458csp11/21/01 end
19459c
19460
19461 IF ((iabs(LB1) .GE. 15 .AND. iabs(LB1) .LE. 17) .OR.
19462 & (iabs(LB2) .GE. 15 .AND. iabs(LB2) .LE. 17)) THEN
19463 DDF = 3.0
19464 XKY1 = XKY1 / DDF
19465 XKY2 = XKY2 / DDF
19466 XKY3 = XKY3 / DDF
19467 XKY4 = XKY4 / DDF
19468 XKY5 = XKY5 / DDF
19469 XKY6 = XKY6 / DDF
19470 XKY7 = XKY7 / DDF
19471 XKY8 = XKY8 / DDF
19472 XKY9 = XKY9 / DDF
19473 XKY10 = XKY10/ DDF
19474 XKY11 = XKY11 / DDF
19475 XKY12 = XKY12 / DDF
19476 XKY13 = XKY13 / DDF
19477 XKY14 = XKY14 / DDF
19478 XKY15 = XKY15 / DDF
19479 XKY16 = XKY16 / DDF
19480 END IF
19481
19482 SIGK = XKY1 + XKY2 + XKY3 + XKY4 +
19483 & XKY5 + XKY6 + XKY7 + XKY8 +
19484 & XKY9 + XKY10 + XKY11 + XKY12 +
19485 & XKY13 + XKY14 + XKY15 + XKY16 + XKY17
19486
19487 RETURN
19488 END
19489
19490C*******************************
19491 BLOCK DATA PPBDAT
19492
19493 parameter (AMP=0.93828,AMN=0.939457,
19494 1 AM0=1.232,AM1440 = 1.44, AM1535 = 1.535)
19495
19496c to give default values to parameters for BbarB production from mesons
19497 COMMON/ppbmas/niso(15),nstate,ppbm(15,2),thresh(15),weight(15)
19498cc SAVE /ppbmas/
19499 common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
19500cc SAVE /ppb1/
19501 common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
19502cc SAVE /ppmm/
19503 SAVE
19504c thresh(i) gives the mass thresh for final channel i:
19505 DATA thresh/1.87656,1.877737,1.878914,2.17028,
19506 1 2.171457,2.37828,2.379457,2.464,2.47328,2.474457,
19507 2 2.672,2.767,2.88,2.975,3.07/
19508c ppbm(i,j=1,2) gives masses for the two final baryons of channel i,
19509c with j=1 for the lighter baryon:
19510 DATA (ppbm(i,1),i=1,15)/amp,amp,amn,amp,amn,amp,amn,
19511 1 am0,amp,amn,am0,am0,am1440,am1440,am1535/
19512 DATA (ppbm(i,2),i=1,15)/amp,amn,amn,am0,am0,am1440,am1440,
19513 1 am0,am1535,am1535,am1440,am1535,am1440,am1535,am1535/
19514c factr2(i) gives weights for producing i pions from ppbar annihilation:
19515 DATA factr2/0,1,1.17e-01,3.27e-03,3.58e-05,1.93e-07/
19516c niso(i) gives the degeneracy factor for final channel i:
19517 DATA niso/1,2,1,16,16,4,4,64,4,4,32,32,4,8,4/
19518
19519 END
19520
19521
19522*****************************************
19523* get the number of BbarB states available for mm collisions of energy srt
19524 subroutine getnst(srt)
19525* srt = DSQRT(s) in GeV *
19526*****************************************
19527 parameter (pimass=0.140,pi=3.1415926)
19528 COMMON/ppbmas/niso(15),nstate,ppbm(15,2),thresh(15),weight(15)
19529cc SAVE /ppbmas/
19530 common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
19531cc SAVE /ppb1/
19532 common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
19533cc SAVE /ppmm/
19534 SAVE
19535
19536 s=srt**2
19537 nstate=0
19538 wtot=0.
19539 if(srt.le.thresh(1)) return
19540 do 1001 i=1,15
19541 weight(i)=0.
19542 if(srt.gt.thresh(i)) nstate=i
19543 1001 continue
19544 do 1002 i=1,nstate
19545 pf2=(s-(ppbm(i,1)+ppbm(i,2))**2)
19546 1 *(s-(ppbm(i,1)-ppbm(i,2))**2)/4/s
19547 weight(i)=pf2*niso(i)
19548 wtot=wtot+weight(i)
19549 1002 continue
19550 ene=(srt/pimass)**3/(6.*pi**2)
19551 fsum=factr2(2)+factr2(3)*ene+factr2(4)*ene**2
19552 1 +factr2(5)*ene**3+factr2(6)*ene**4
19553
19554 return
19555 END
19556
19557*****************************************
19558* for pion+pion-->Bbar B *
19559c real*4 function ppbbar(srt)
19560 real function ppbbar(srt)
19561*****************************************
19562 parameter (pimass=0.140,arho=0.77,aomega=0.782)
19563 common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
19564cc SAVE /ppb1/
19565 common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
19566cc SAVE /ppmm/
19567 SAVE
19568
19569 sppb2p=xppbar(srt)*factr2(2)/fsum
19570 pi2=(s-4*pimass**2)/4
19571 ppbbar=4./9.*sppb2p/pi2*wtot
19572
19573 return
19574 END
19575
19576*****************************************
19577* for pion+rho-->Bbar B *
19578c real*4 function prbbar(srt)
19579 real function prbbar(srt)
19580*****************************************
19581 parameter (pimass=0.140,arho=0.77,aomega=0.782)
19582 common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
19583cc SAVE /ppb1/
19584 common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
19585cc SAVE /ppmm/
19586 SAVE
19587
19588 sppb3p=xppbar(srt)*factr2(3)*ene/fsum
19589 pi2=(s-(pimass+arho)**2)*(s-(pimass-arho)**2)/4/s
19590 prbbar=4./27.*sppb3p/pi2*wtot
19591
19592 return
19593 END
19594
19595*****************************************
19596* for rho+rho-->Bbar B *
19597c real*4 function rrbbar(srt)
19598 real function rrbbar(srt)
19599*****************************************
19600 parameter (pimass=0.140,arho=0.77,aomega=0.782)
19601 common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
19602cc SAVE /ppb1/
19603 common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
19604cc SAVE /ppmm/
19605 SAVE
19606
19607 sppb4p=xppbar(srt)*factr2(4)*ene**2/fsum
19608 pi2=(s-4*arho**2)/4
19609 rrbbar=4./81.*(sppb4p/2)/pi2*wtot
19610
19611 return
19612 END
19613
19614*****************************************
19615* for pi+omega-->Bbar B *
19616c real*4 function pobbar(srt)
19617 real function pobbar(srt)
19618*****************************************
19619 parameter (pimass=0.140,arho=0.77,aomega=0.782)
19620 common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
19621cc SAVE /ppb1/
19622 common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
19623cc SAVE /ppmm/
19624 SAVE
19625
19626 sppb4p=xppbar(srt)*factr2(4)*ene**2/fsum
19627 pi2=(s-(pimass+aomega)**2)*(s-(pimass-aomega)**2)/4/s
19628 pobbar=4./9.*(sppb4p/2)/pi2*wtot
19629
19630 return
19631 END
19632
19633*****************************************
19634* for rho+omega-->Bbar B *
19635c real*4 function robbar(srt)
19636 real function robbar(srt)
19637*****************************************
19638 parameter (pimass=0.140,arho=0.77,aomega=0.782)
19639 common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
19640cc SAVE /ppb1/
19641 common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
19642cc SAVE /ppmm/
19643 SAVE
19644
19645 sppb5p=xppbar(srt)*factr2(5)*ene**3/fsum
19646 pi2=(s-(arho+aomega)**2)*(s-(arho-aomega)**2)/4/s
19647 robbar=4./27.*sppb5p/pi2*wtot
19648
19649 return
19650 END
19651
19652*****************************************
19653* for omega+omega-->Bbar B *
19654c real*4 function oobbar(srt)
19655 real function oobbar(srt)
19656*****************************************
19657 parameter (pimass=0.140,arho=0.77,aomega=0.782)
19658 common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
19659cc SAVE /ppb1/
19660 common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
19661cc SAVE /ppmm/
19662 SAVE
19663
19664 sppb6p=xppbar(srt)*factr2(6)*ene**4/fsum
19665 pi2=(s-4*aomega**2)/4
19666 oobbar=4./9.*sppb6p/pi2*wtot
19667
19668 return
19669 END
19670
19671*****************************************
19672* Generate final states for mm-->Bbar B *
19673 SUBROUTINE bbarfs(lbb1,lbb2,ei1,ei2,iblock,iseed)
19674*****************************************
19675 COMMON/ppbmas/niso(15),nstate,ppbm(15,2),thresh(15),weight(15)
19676cc SAVE /ppbmas/
19677 common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
19678cc SAVE /ppb1/
19679 common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
19680cc SAVE /ppmm/
19681 COMMON/RNDF77/NSEED
19682cc SAVE /RNDF77/
19683 SAVE
19684 ISEED=ISEED
19685c determine which final BbarB channel occurs:
19686 rd=RANART(NSEED)
19687 wsum=0.
19688 do 1001 i=1,nstate
19689 wsum=wsum+weight(i)
19690 if(rd.le.(wsum/wtot)) then
19691 ifs=i
19692 ei1=ppbm(i,1)
19693 ei2=ppbm(i,2)
19694 goto 10
19695 endif
19696 1001 continue
19697 10 continue
19698
19699c1 pbar p
19700 if(ifs.eq.1) then
19701 iblock=1801
19702 lbb1=-1
19703 lbb2=1
19704 elseif(ifs.eq.2) then
19705c2 pbar n
19706 if(RANART(NSEED).le.0.5) then
19707 iblock=18021
19708 lbb1=-1
19709 lbb2=2
19710c2 nbar p
19711 else
19712 iblock=18022
19713 lbb1=1
19714 lbb2=-2
19715 endif
19716c3 nbar n
19717 elseif(ifs.eq.3) then
19718 iblock=1803
19719 lbb1=-2
19720 lbb2=2
19721c4&5 (pbar nbar) Delta, (p n) anti-Delta
19722 elseif(ifs.eq.4.or.ifs.eq.5) then
19723 rd=RANART(NSEED)
19724 if(rd.le.0.5) then
19725c (pbar nbar) Delta
19726 if(ifs.eq.4) then
19727 iblock=18041
19728 lbb1=-1
19729 else
19730 iblock=18051
19731 lbb1=-2
19732 endif
19733 rd2=RANART(NSEED)
19734 if(rd2.le.0.25) then
19735 lbb2=6
19736 elseif(rd2.le.0.5) then
19737 lbb2=7
19738 elseif(rd2.le.0.75) then
19739 lbb2=8
19740 else
19741 lbb2=9
19742 endif
19743 else
19744c (p n) anti-Delta
19745 if(ifs.eq.4) then
19746 iblock=18042
19747 lbb1=1
19748 else
19749 iblock=18052
19750 lbb1=2
19751 endif
19752 rd2=RANART(NSEED)
19753 if(rd2.le.0.25) then
19754 lbb2=-6
19755 elseif(rd2.le.0.5) then
19756 lbb2=-7
19757 elseif(rd2.le.0.75) then
19758 lbb2=-8
19759 else
19760 lbb2=-9
19761 endif
19762 endif
19763c6&7 (pbar nbar) N*(1440), (p n) anti-N*(1440)
19764 elseif(ifs.eq.6.or.ifs.eq.7) then
19765 rd=RANART(NSEED)
19766 if(rd.le.0.5) then
19767c (pbar nbar) N*(1440)
19768 if(ifs.eq.6) then
19769 iblock=18061
19770 lbb1=-1
19771 else
19772 iblock=18071
19773 lbb1=-2
19774 endif
19775 rd2=RANART(NSEED)
19776 if(rd2.le.0.5) then
19777 lbb2=10
19778 else
19779 lbb2=11
19780 endif
19781 else
19782c (p n) anti-N*(1440)
19783 if(ifs.eq.6) then
19784 iblock=18062
19785 lbb1=1
19786 else
19787 iblock=18072
19788 lbb1=2
19789 endif
19790 rd2=RANART(NSEED)
19791 if(rd2.le.0.5) then
19792 lbb2=-10
19793 else
19794 lbb2=-11
19795 endif
19796 endif
19797c8 Delta anti-Delta
19798 elseif(ifs.eq.8) then
19799 iblock=1808
19800 rd1=RANART(NSEED)
19801 if(rd1.le.0.25) then
19802 lbb1=6
19803 elseif(rd1.le.0.5) then
19804 lbb1=7
19805 elseif(rd1.le.0.75) then
19806 lbb1=8
19807 else
19808 lbb1=9
19809 endif
19810 rd2=RANART(NSEED)
19811 if(rd2.le.0.25) then
19812 lbb2=-6
19813 elseif(rd2.le.0.5) then
19814 lbb2=-7
19815 elseif(rd2.le.0.75) then
19816 lbb2=-8
19817 else
19818 lbb2=-9
19819 endif
19820c9&10 (pbar nbar) N*(1535), (p n) anti-N*(1535)
19821 elseif(ifs.eq.9.or.ifs.eq.10) then
19822 rd=RANART(NSEED)
19823 if(rd.le.0.5) then
19824c (pbar nbar) N*(1440)
19825 if(ifs.eq.9) then
19826 iblock=18091
19827 lbb1=-1
19828 else
19829 iblock=18101
19830 lbb1=-2
19831 endif
19832 rd2=RANART(NSEED)
19833 if(rd2.le.0.5) then
19834 lbb2=12
19835 else
19836 lbb2=13
19837 endif
19838 else
19839c (p n) anti-N*(1535)
19840 if(ifs.eq.9) then
19841 iblock=18092
19842 lbb1=1
19843 else
19844 iblock=18102
19845 lbb1=2
19846 endif
19847 rd2=RANART(NSEED)
19848 if(rd2.le.0.5) then
19849 lbb2=-12
19850 else
19851 lbb2=-13
19852 endif
19853 endif
19854c11&12 anti-Delta N*, Delta anti-N*
19855 elseif(ifs.eq.11.or.ifs.eq.12) then
19856 rd=RANART(NSEED)
19857 if(rd.le.0.5) then
19858c anti-Delta N*
19859 rd1=RANART(NSEED)
19860 if(rd1.le.0.25) then
19861 lbb1=-6
19862 elseif(rd1.le.0.5) then
19863 lbb1=-7
19864 elseif(rd1.le.0.75) then
19865 lbb1=-8
19866 else
19867 lbb1=-9
19868 endif
19869 if(ifs.eq.11) then
19870 iblock=18111
19871 rd2=RANART(NSEED)
19872 if(rd2.le.0.5) then
19873 lbb2=10
19874 else
19875 lbb2=11
19876 endif
19877 else
19878 iblock=18121
19879 rd2=RANART(NSEED)
19880 if(rd2.le.0.5) then
19881 lbb2=12
19882 else
19883 lbb2=13
19884 endif
19885 endif
19886 else
19887c Delta anti-N*
19888 rd1=RANART(NSEED)
19889 if(rd1.le.0.25) then
19890 lbb1=6
19891 elseif(rd1.le.0.5) then
19892 lbb1=7
19893 elseif(rd1.le.0.75) then
19894 lbb1=8
19895 else
19896 lbb1=9
19897 endif
19898 if(ifs.eq.11) then
19899 iblock=18112
19900 rd2=RANART(NSEED)
19901 if(rd2.le.0.5) then
19902 lbb2=-10
19903 else
19904 lbb2=-11
19905 endif
19906 else
19907 iblock=18122
19908 rd2=RANART(NSEED)
19909 if(rd2.le.0.5) then
19910 lbb2=-12
19911 else
19912 lbb2=-13
19913 endif
19914 endif
19915 endif
19916c13 N*(1440) anti-N*(1440)
19917 elseif(ifs.eq.13) then
19918 iblock=1813
19919 rd1=RANART(NSEED)
19920 if(rd1.le.0.5) then
19921 lbb1=10
19922 else
19923 lbb1=11
19924 endif
19925 rd2=RANART(NSEED)
19926 if(rd2.le.0.5) then
19927 lbb2=-10
19928 else
19929 lbb2=-11
19930 endif
19931c14 anti-N*(1440) N*(1535), N*(1440) anti-N*(1535)
19932 elseif(ifs.eq.14) then
19933 rd=RANART(NSEED)
19934 if(rd.le.0.5) then
19935c anti-N*(1440) N*(1535)
19936 iblock=18141
19937 rd1=RANART(NSEED)
19938 if(rd1.le.0.5) then
19939 lbb1=-10
19940 else
19941 lbb1=-11
19942 endif
19943 rd2=RANART(NSEED)
19944 if(rd2.le.0.5) then
19945 lbb2=12
19946 else
19947 lbb2=13
19948 endif
19949 else
19950c N*(1440) anti-N*(1535)
19951 iblock=18142
19952 rd1=RANART(NSEED)
19953 if(rd1.le.0.5) then
19954 lbb1=10
19955 else
19956 lbb1=11
19957 endif
19958 rd2=RANART(NSEED)
19959 if(rd2.le.0.5) then
19960 lbb2=-12
19961 else
19962 lbb2=-13
19963 endif
19964 endif
19965c15 N*(1535) anti-N*(1535)
19966 elseif(ifs.eq.15) then
19967 iblock=1815
19968 rd1=RANART(NSEED)
19969 if(rd1.le.0.5) then
19970 lbb1=12
19971 else
19972 lbb1=13
19973 endif
19974 rd2=RANART(NSEED)
19975 if(rd2.le.0.5) then
19976 lbb2=-12
19977 else
19978 lbb2=-13
19979 endif
19980 else
19981 endif
19982
19983 RETURN
19984 END
19985
19986*****************************************
19987* for pi pi <-> rho rho cross sections
19988 SUBROUTINE spprr(lb1,lb2,srt)
19989 parameter (arho=0.77)
19990 common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
19991cc SAVE /ppb1/
19992 common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
19993cc SAVE /ppmm/
19994 SAVE
19995
19996 pprr=0.
19997 if((lb1.ge.3.and.lb1.le.5).and.(lb2.ge.3.and.lb2.le.5)) then
19998c for now, rho mass taken to be the central value in these two processes
19999 if(srt.gt.(2*arho)) pprr=ptor(srt)
20000 elseif((lb1.ge.25.and.lb1.le.27).and.(lb2.ge.25.and.lb2.le.27))
20001 1 then
20002 pprr=rtop(srt)
20003 endif
20004c
20005 return
20006 END
20007
20008*****************************************
20009* for pi pi -> rho rho, determined from detailed balance
20010 real function ptor(srt)
20011*****************************************
20012 parameter (pimass=0.140,arho=0.77)
20013 common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20014cc SAVE /ppb1/
20015 common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20016cc SAVE /ppmm/
20017 SAVE
20018
20019 s2=srt**2
20020 ptor=9*(s2-4*arho**2)/(s2-4*pimass**2)*rtop(srt)
20021
20022 return
20023 END
20024
20025*****************************************
20026* for rho rho -> pi pi, assumed a constant cross section (in mb)
20027 real function rtop(srt)
20028*****************************************
20029 srt=srt
20030 rtop=5.
20031 return
20032 END
20033
20034*****************************************
20035* for pi pi <-> rho rho final states
20036 SUBROUTINE pi2ro2(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
20037 PARAMETER (MAXSTR=150001)
20038 PARAMETER (AP1=0.13496,AP2=0.13957)
20039 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
20040cc SAVE /EE/
20041 common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20042cc SAVE /ppb1/
20043 common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20044cc SAVE /ppmm/
20045 COMMON/RNDF77/NSEED
20046cc SAVE /RNDF77/
20047 SAVE
20048 iseed=iseed
20049 if((lb(i1).ge.3.and.lb(i1).le.5)
20050 1 .and.(lb(i2).ge.3.and.lb(i2).le.5)) then
20051 iblock=1850
20052 ei1=0.77
20053 ei2=0.77
20054c for now, we don't check isospin states(allowing pi+pi+ & pi0pi0 -> 2rho)
20055c thus the cross sections used are considered as the isospin-averaged ones.
20056 lbb1=25+int(3*RANART(NSEED))
20057 lbb2=25+int(3*RANART(NSEED))
20058 elseif((lb(i1).ge.25.and.lb(i1).le.27)
20059 1 .and.(lb(i2).ge.25.and.lb(i2).le.27)) then
20060 iblock=1851
20061 lbb1=3+int(3*RANART(NSEED))
20062 lbb2=3+int(3*RANART(NSEED))
20063 ei1=ap2
20064 ei2=ap2
20065 if(lbb1.eq.4) ei1=ap1
20066 if(lbb2.eq.4) ei2=ap1
20067 endif
20068
20069 return
20070 END
20071
20072*****************************************
20073* for pi pi <-> eta eta cross sections
20074 SUBROUTINE sppee(lb1,lb2,srt)
20075 parameter (ETAM=0.5475)
20076 common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20077cc SAVE /ppb1/
20078 common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20079cc SAVE /ppmm/
20080 SAVE
20081
20082 ppee=0.
20083 if((lb1.ge.3.and.lb1.le.5).and.(lb2.ge.3.and.lb2.le.5)) then
20084 if(srt.gt.(2*ETAM)) ppee=ptoe(srt)
20085 elseif(lb1.eq.0.and.lb2.eq.0) then
20086 ppee=etop(srt)
20087 endif
20088
20089 return
20090 END
20091
20092*****************************************
20093* for pi pi -> eta eta, determined from detailed balance, spin-isospin averaged
20094 real function ptoe(srt)
20095*****************************************
20096 parameter (pimass=0.140,ETAM=0.5475)
20097 common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20098cc SAVE /ppb1/
20099 common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20100cc SAVE /ppmm/
20101 SAVE
20102
20103 s2=srt**2
20104 ptoe=1./9.*(s2-4*etam**2)/(s2-4*pimass**2)*etop(srt)
20105
20106 return
20107 END
20108*****************************************
20109* for eta eta -> pi pi, assumed a constant cross section (in mb)
20110 real function etop(srt)
20111*****************************************
20112 srt=srt
20113c eta equilibration:
20114c most important channel is found to be pi pi <-> pi eta, then
20115c rho pi <-> rho eta.
20116 etop=5.
20117 return
20118 END
20119
20120*****************************************
20121* for pi pi <-> eta eta final states
20122 SUBROUTINE pi2et2(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
20123 PARAMETER (MAXSTR=150001)
20124 PARAMETER (AP1=0.13496,AP2=0.13957,ETAM=0.5475)
20125 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
20126cc SAVE /EE/
20127 common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20128cc SAVE /ppb1/
20129 common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20130cc SAVE /ppmm/
20131 COMMON/RNDF77/NSEED
20132cc SAVE /RNDF77/
20133 SAVE
20134
20135 iseed=iseed
20136 if((lb(i1).ge.3.and.lb(i1).le.5)
20137 1 .and.(lb(i2).ge.3.and.lb(i2).le.5)) then
20138 iblock=1860
20139 ei1=etam
20140 ei2=etam
20141c for now, we don't check isospin states(allowing pi+pi+ & pi0pi0 -> 2rho)
20142c thus the cross sections used are considered as the isospin-averaged ones.
20143 lbb1=0
20144 lbb2=0
20145 elseif(lb(i1).eq.0.and.lb(i2).eq.0) then
20146 iblock=1861
20147 lbb1=3+int(3*RANART(NSEED))
20148 lbb2=3+int(3*RANART(NSEED))
20149 ei1=ap2
20150 ei2=ap2
20151 if(lbb1.eq.4) ei1=ap1
20152 if(lbb2.eq.4) ei2=ap1
20153 endif
20154
20155 return
20156 END
20157
20158*****************************************
20159* for pi pi <-> pi eta cross sections
20160 SUBROUTINE spppe(lb1,lb2,srt)
20161 parameter (pimass=0.140,ETAM=0.5475)
20162 common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20163cc SAVE /ppb1/
20164 common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20165cc SAVE /ppmm/
20166 SAVE
20167
20168 pppe=0.
20169 if((lb1.ge.3.and.lb1.le.5).and.(lb2.ge.3.and.lb2.le.5)) then
20170 if(srt.gt.(ETAM+pimass)) pppe=pptope(srt)
20171 elseif((lb1.ge.3.and.lb1.le.5).and.lb2.eq.0) then
20172 pppe=petopp(srt)
20173 elseif((lb2.ge.3.and.lb2.le.5).and.lb1.eq.0) then
20174 pppe=petopp(srt)
20175 endif
20176
20177 return
20178 END
20179
20180*****************************************
20181* for pi pi -> pi eta, determined from detailed balance, spin-isospin averaged
20182 real function pptope(srt)
20183*****************************************
20184 parameter (pimass=0.140,ETAM=0.5475)
20185 common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20186cc SAVE /ppb1/
20187 common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20188cc SAVE /ppmm/
20189 SAVE
20190
20191 s2=srt**2
20192 pf2=(s2-(pimass+ETAM)**2)*(s2-(pimass-ETAM)**2)/2/sqrt(s2)
20193 pi2=(s2-4*pimass**2)*s2/2/sqrt(s2)
20194 pptope=1./3.*pf2/pi2*petopp(srt)
20195
20196 return
20197 END
20198*****************************************
20199* for pi eta -> pi pi, assumed a constant cross section (in mb)
20200 real function petopp(srt)
20201*****************************************
20202 srt=srt
20203c eta equilibration:
20204 petopp=5.
20205 return
20206 END
20207
20208*****************************************
20209* for pi pi <-> pi eta final states
20210 SUBROUTINE pi3eta(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
20211 PARAMETER (MAXSTR=150001)
20212 PARAMETER (AP1=0.13496,AP2=0.13957,ETAM=0.5475)
20213 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
20214cc SAVE /EE/
20215 common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20216cc SAVE /ppb1/
20217 common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20218cc SAVE /ppmm/
20219 COMMON/RNDF77/NSEED
20220cc SAVE /RNDF77/
20221 SAVE
20222
20223 ISEED=ISEED
20224 if((lb(i1).ge.3.and.lb(i1).le.5)
20225 1 .and.(lb(i2).ge.3.and.lb(i2).le.5)) then
20226 iblock=1870
20227 ei1=ap2
20228 ei2=etam
20229c for now, we don't check isospin states(allowing pi+pi+ & pi0pi0 -> 2rho)
20230c thus the cross sections used are considered as the isospin-averaged ones.
20231 lbb1=3+int(3*RANART(NSEED))
20232 if(lbb1.eq.4) ei1=ap1
20233 lbb2=0
20234 elseif((lb(i1).ge.3.and.lb(i1).le.5.and.lb(i2).eq.0).or.
20235 1 (lb(i2).ge.3.and.lb(i2).le.5.and.lb(i1).eq.0)) then
20236 iblock=1871
20237 lbb1=3+int(3*RANART(NSEED))
20238 lbb2=3+int(3*RANART(NSEED))
20239 ei1=ap2
20240 ei2=ap2
20241 if(lbb1.eq.4) ei1=ap1
20242 if(lbb2.eq.4) ei2=ap1
20243 endif
20244
20245 return
20246 END
20247
20248*****************************************
20249* for rho pi <-> rho eta cross sections
20250 SUBROUTINE srpre(lb1,lb2,srt)
20251 parameter (pimass=0.140,ETAM=0.5475,arho=0.77)
20252 common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20253cc SAVE /ppb1/
20254 common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20255cc SAVE /ppmm/
20256 SAVE
20257
20258 rpre=0.
20259 if(lb1.ge.25.and.lb1.le.27.and.lb2.ge.3.and.lb2.le.5) then
20260 if(srt.gt.(ETAM+arho)) rpre=rptore(srt)
20261 elseif(lb2.ge.25.and.lb2.le.27.and.lb1.ge.3.and.lb1.le.5) then
20262 if(srt.gt.(ETAM+arho)) rpre=rptore(srt)
20263 elseif(lb1.ge.25.and.lb1.le.27.and.lb2.eq.0) then
20264 if(srt.gt.(pimass+arho)) rpre=retorp(srt)
20265 elseif(lb2.ge.25.and.lb2.le.27.and.lb1.eq.0) then
20266 if(srt.gt.(pimass+arho)) rpre=retorp(srt)
20267 endif
20268
20269 return
20270 END
20271
20272*****************************************
20273* for rho pi->rho eta, determined from detailed balance, spin-isospin averaged
20274 real function rptore(srt)
20275*****************************************
20276 parameter (pimass=0.140,ETAM=0.5475,arho=0.77)
20277 common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20278cc SAVE /ppb1/
20279 common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20280cc SAVE /ppmm/
20281 SAVE
20282
20283 s2=srt**2
20284 pf2=(s2-(arho+ETAM)**2)*(s2-(arho-ETAM)**2)/2/sqrt(s2)
20285 pi2=(s2-(arho+pimass)**2)*(s2-(arho-pimass)**2)/2/sqrt(s2)
20286 rptore=1./3.*pf2/pi2*retorp(srt)
20287
20288 return
20289 END
20290*****************************************
20291* for rho eta -> rho pi, assumed a constant cross section (in mb)
20292 real function retorp(srt)
20293*****************************************
20294 srt=srt
20295c eta equilibration:
20296 retorp=5.
20297 return
20298 END
20299
20300*****************************************
20301* for rho pi <-> rho eta final states
20302 SUBROUTINE rpiret(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
20303 PARAMETER (MAXSTR=150001)
20304 PARAMETER (AP1=0.13496,AP2=0.13957,ETAM=0.5475,arho=0.77)
20305 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
20306cc SAVE /EE/
20307 common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20308cc SAVE /ppb1/
20309 common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20310cc SAVE /ppmm/
20311 COMMON/RNDF77/NSEED
20312cc SAVE /RNDF77/
20313 SAVE
20314 ISEED=ISEED
20315 if((lb(i1).ge.25.and.lb(i1).le.27
20316 1 .and.lb(i2).ge.3.and.lb(i2).le.5).or.
20317 2 (lb(i1).ge.3.and.lb(i1).le.5
20318 3 .and.lb(i2).ge.25.and.lb(i2).le.27)) then
20319 iblock=1880
20320 ei1=arho
20321 ei2=etam
20322c for now, we don't check isospin states(allowing pi+pi+ & pi0pi0 -> 2rho)
20323c thus the cross sections used are considered as the isospin-averaged ones.
20324 lbb1=25+int(3*RANART(NSEED))
20325 lbb2=0
20326 elseif((lb(i1).ge.25.and.lb(i1).le.27.and.lb(i2).eq.0).or.
20327 1 (lb(i2).ge.25.and.lb(i2).le.27.and.lb(i1).eq.0)) then
20328 iblock=1881
20329 lbb1=25+int(3*RANART(NSEED))
20330 lbb2=3+int(3*RANART(NSEED))
20331 ei1=arho
20332 ei2=ap2
20333 if(lbb2.eq.4) ei2=ap1
20334 endif
20335
20336 return
20337 END
20338
20339*****************************************
20340* for omega pi <-> omega eta cross sections
20341 SUBROUTINE sopoe(lb1,lb2,srt)
20342 parameter (ETAM=0.5475,aomega=0.782)
20343 common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20344cc SAVE /ppb1/
20345 common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20346cc SAVE /ppmm/
20347 SAVE
20348
20349 xopoe=0.
20350 if((lb1.eq.28.and.lb2.ge.3.and.lb2.le.5).or.
20351 1 (lb2.eq.28.and.lb1.ge.3.and.lb1.le.5)) then
20352 if(srt.gt.(aomega+ETAM)) xopoe=xop2oe(srt)
20353 elseif((lb1.eq.28.and.lb2.eq.0).or.
20354 1 (lb1.eq.0.and.lb2.eq.28)) then
20355 if(srt.gt.(aomega+ETAM)) xopoe=xoe2op(srt)
20356 endif
20357
20358 return
20359 END
20360
20361*****************************************
20362* for omega pi -> omega eta,
20363c determined from detailed balance, spin-isospin averaged
20364 real function xop2oe(srt)
20365*****************************************
20366 parameter (pimass=0.140,ETAM=0.5475,aomega=0.782)
20367 common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20368cc SAVE /ppb1/
20369 common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20370cc SAVE /ppmm/
20371 SAVE
20372
20373 s2=srt**2
20374 pf2=(s2-(aomega+ETAM)**2)*(s2-(aomega-ETAM)**2)/2/sqrt(s2)
20375 pi2=(s2-(aomega+pimass)**2)*(s2-(aomega-pimass)**2)/2/sqrt(s2)
20376 xop2oe=1./3.*pf2/pi2*xoe2op(srt)
20377
20378 return
20379 END
20380*****************************************
20381* for omega eta -> omega pi, assumed a constant cross section (in mb)
20382 real function xoe2op(srt)
20383*****************************************
20384 srt=srt
20385c eta equilibration:
20386 xoe2op=5.
20387 return
20388 END
20389
20390*****************************************
20391* for omega pi <-> omega eta final states
20392 SUBROUTINE opioet(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
20393 PARAMETER (MAXSTR=150001)
20394 PARAMETER (AP1=0.13496,AP2=0.13957,ETAM=0.5475,aomega=0.782)
20395 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
20396cc SAVE /EE/
20397 common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20398cc SAVE /ppb1/
20399 common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20400cc SAVE /ppmm/
20401 COMMON/RNDF77/NSEED
20402cc SAVE /RNDF77/
20403 SAVE
20404
20405 iseed=iseed
20406 if((lb(i1).ge.3.and.lb(i1).le.5.and.lb(i2).eq.28).or.
20407 1 (lb(i2).ge.3.and.lb(i2).le.5.and.lb(i1).eq.28)) then
20408 iblock=1890
20409 ei1=aomega
20410 ei2=etam
20411c for now, we don't check isospin states(allowing pi+pi+ & pi0pi0 -> 2rho)
20412c thus the cross sections used are considered as the isospin-averaged ones.
20413 lbb1=28
20414 lbb2=0
20415 elseif((lb(i1).eq.28.and.lb(i2).eq.0).or.
20416 1 (lb(i1).eq.0.and.lb(i2).eq.28)) then
20417 iblock=1891
20418 lbb1=28
20419 lbb2=3+int(3*RANART(NSEED))
20420 ei1=aomega
20421 ei2=ap2
20422 if(lbb2.eq.4) ei2=ap1
20423 endif
20424
20425 return
20426 END
20427
20428*****************************************
20429* for rho rho <-> eta eta cross sections
20430 SUBROUTINE srree(lb1,lb2,srt)
20431 parameter (ETAM=0.5475,arho=0.77)
20432 common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20433cc SAVE /ppb1/
20434 common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20435cc SAVE /ppmm/
20436 SAVE
20437
20438 rree=0.
20439 if(lb1.ge.25.and.lb1.le.27.and.
20440 1 lb2.ge.25.and.lb2.le.27) then
20441 if(srt.gt.(2*ETAM)) rree=rrtoee(srt)
20442 elseif(lb1.eq.0.and.lb2.eq.0) then
20443 if(srt.gt.(2*arho)) rree=eetorr(srt)
20444 endif
20445
20446 return
20447 END
20448
20449*****************************************
20450* for eta eta -> rho rho
20451c determined from detailed balance, spin-isospin averaged
20452 real function eetorr(srt)
20453*****************************************
20454 parameter (ETAM=0.5475,arho=0.77)
20455 common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20456cc SAVE /ppb1/
20457 common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20458cc SAVE /ppmm/
20459 SAVE
20460
20461 s2=srt**2
20462 eetorr=81.*(s2-4*arho**2)/(s2-4*etam**2)*rrtoee(srt)
20463
20464 return
20465 END
20466*****************************************
20467* for rho rho -> eta eta, assumed a constant cross section (in mb)
20468 real function rrtoee(srt)
20469*****************************************
20470 srt=srt
20471c eta equilibration:
20472 rrtoee=5.
20473 return
20474 END
20475
20476*****************************************
20477* for rho rho <-> eta eta final states
20478 SUBROUTINE ro2et2(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
20479 PARAMETER (MAXSTR=150001)
20480 parameter (ETAM=0.5475,arho=0.77)
20481 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
20482cc SAVE /EE/
20483 common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20484cc SAVE /ppb1/
20485 common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20486cc SAVE /ppmm/
20487 COMMON/RNDF77/NSEED
20488cc SAVE /RNDF77/
20489 SAVE
20490
20491 ISEED=ISEED
20492 if(lb(i1).ge.25.and.lb(i1).le.27.and.
20493 1 lb(i2).ge.25.and.lb(i2).le.27) then
20494 iblock=1895
20495 ei1=etam
20496 ei2=etam
20497c for now, we don't check isospin states(allowing pi+pi+ & pi0pi0 -> 2rho)
20498c thus the cross sections used are considered as the isospin-averaged ones.
20499 lbb1=0
20500 lbb2=0
20501 elseif(lb(i1).eq.0.and.lb(i2).eq.0) then
20502 iblock=1896
20503 lbb1=25+int(3*RANART(NSEED))
20504 lbb2=25+int(3*RANART(NSEED))
20505 ei1=arho
20506 ei2=arho
20507 endif
20508
20509 return
20510 END
20511
20512*****************************
20513* purpose: Xsection for K* Kbar or K*bar K to pi(eta) rho(omega)
20514 SUBROUTINE XKKSAN(i1,i2,SRT,SIGKS1,SIGKS2,SIGKS3,SIGKS4,SIGK,prkk)
20515* srt = DSQRT(s) in GeV *
20516* sigk = xsection in mb obtained from *
20517* the detailed balance *
20518* ***************************
20519 PARAMETER (AKA=0.498, PIMASS=0.140, RHOM = 0.770,aks=0.895,
20520 & OMEGAM = 0.7819, ETAM = 0.5473)
20521 PARAMETER (MAXSTR=150001)
20522 COMMON /CC/ E(MAXSTR)
20523cc SAVE /CC/
20524 SAVE
20525
20526 S = SRT ** 2
20527 SIGKS1 = 1.E-08
20528 SIGKS2 = 1.E-08
20529 SIGKS3 = 1.E-08
20530 SIGKS4 = 1.E-08
20531
20532 XPION0 = prkk
20533clin note that prkk is for pi (rho omega) -> K* Kbar (AND!) K*bar K:
20534 XPION0 = XPION0/2
20535
20536cc
20537c PI2 = (S - (aks + AKA) ** 2) * (S - (aks - AKA) ** 2)
20538 PI2 = (S - (e(i1) + e(i2)) ** 2) * (S - (e(i1) - e(i2)) ** 2)
20539 SIGK = 1.E-08
20540 if(PI2 .le. 0.0) return
20541
20542 XM1 = PIMASS
20543 XM2 = RHOM
20544 PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
20545 IF (PI2 .GT. 0.0 .AND. PF2 .GT. 0.0) THEN
20546 SIGKS1 = 27.0 / 4.0 * PF2 / PI2 * XPION0
20547 END IF
20548
20549 XM1 = PIMASS
20550 XM2 = OMEGAM
20551 PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
20552 IF (PI2 .GT. 0.0 .AND. PF2 .GT. 0.0) THEN
20553 SIGKS2 = 9.0 / 4.0 * PF2 / PI2 * XPION0
20554 END IF
20555
20556 XM1 = RHOM
20557 XM2 = ETAM
20558 PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
20559 IF (PF2 .GT. 0.0) THEN
20560 SIGKS3 = 9.0 / 4.0 * PF2 / PI2 * XPION0
20561 END IF
20562
20563 XM1 = OMEGAM
20564 XM2 = ETAM
20565 PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
20566 IF (PF2 .GT. 0.0) THEN
20567 SIGKS4 = 3.0 / 4.0 * PF2 / PI2 * XPION0
20568 END IF
20569
20570 SIGK=SIGKS1+SIGKS2+SIGKS3+SIGKS4
20571
20572 RETURN
20573 END
20574
20575**********************************
20576* PURPOSE: *
20577* assign final states for KK*bar or K*Kbar --> light mesons
20578*
20579c SUBROUTINE Crkspi(PX,PY,PZ,SRT,I1,I2,IBLOCK)
20580 SUBROUTINE crkspi(I1,I2,XSK1, XSK2, XSK3, XSK4, SIGK,
20581 & IBLOCK,lbp1,lbp2,emm1,emm2)
20582* iblock - 466
20583**********************************
20584 PARAMETER (MAXSTR=150001,MAXR=1)
20585 PARAMETER (AP1=0.13496,AP2=0.13957,RHOM = 0.770,PI=3.1415926)
20586 PARAMETER (AETA=0.548,AMOMGA=0.782)
20587 parameter (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
20588 COMMON /AA/ R(3,MAXSTR)
20589cc SAVE /AA/
20590 COMMON /BB/ P(3,MAXSTR)
20591cc SAVE /BB/
20592 COMMON /CC/ E(MAXSTR)
20593cc SAVE /CC/
20594 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
20595cc SAVE /EE/
20596 common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
20597cc SAVE /input1/
20598 COMMON/RNDF77/NSEED
20599cc SAVE /RNDF77/
20600 SAVE
20601
20602 IBLOCK=466
20603* charges of final state mesons:
20604
20605 X1 = RANART(NSEED) * SIGK
20606 XSK2 = XSK1 + XSK2
20607 XSK3 = XSK2 + XSK3
20608 XSK4 = XSK3 + XSK4
20609 IF (X1 .LE. XSK1) THEN
20610 LB(I1) = 3 + int(3 * RANART(NSEED))
20611 LB(I2) = 25 + int(3 * RANART(NSEED))
20612 E(I1) = AP2
20613 E(I2) = rhom
20614 ELSE IF (X1 .LE. XSK2) THEN
20615 LB(I1) = 3 + int(3 * RANART(NSEED))
20616 LB(I2) = 28
20617 E(I1) = AP2
20618 E(I2) = AMOMGA
20619 ELSE IF (X1 .LE. XSK3) THEN
20620 LB(I1) = 0
20621 LB(I2) = 25 + int(3 * RANART(NSEED))
20622 E(I1) = AETA
20623 E(I2) = rhom
20624 ELSE
20625 LB(I1) = 0
20626 LB(I2) = 28
20627 E(I1) = AETA
20628 E(I2) = AMOMGA
20629 ENDIF
20630
20631 if(lb(i1).eq.4) E(I1) = AP1
20632 lbp1=lb(i1)
20633 lbp2=lb(i2)
20634 emm1=e(i1)
20635 emm2=e(i2)
20636
20637 RETURN
20638 END
20639
20640*---------------------------------------------------------------------------
20641* PURPOSE : CALCULATE THE MASS AND MOMENTUM OF K* RESONANCE
20642* AFTER PION + KAON COLLISION
20643*clin only here the K* mass may be different from aks=0.895
20644 SUBROUTINE KSRESO(I1,I2)
20645 PARAMETER (MAXSTR=150001,MAXR=1,
20646 1 AMN=0.939457,AMP=0.93828,
20647 2 AP1=0.13496,AP2=0.13957,AM0=1.232,PI=3.1415926)
20648 COMMON /AA/ R(3,MAXSTR)
20649cc SAVE /AA/
20650 COMMON /BB/ P(3,MAXSTR)
20651cc SAVE /BB/
20652 COMMON /CC/ E(MAXSTR)
20653cc SAVE /CC/
20654 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
20655cc SAVE /EE/
20656 COMMON /RUN/NUM
20657cc SAVE /RUN/
20658 COMMON /PA/RPION(3,MAXSTR,MAXR)
20659cc SAVE /PA/
20660 COMMON /PB/PPION(3,MAXSTR,MAXR)
20661cc SAVE /PB/
20662 COMMON /PC/EPION(MAXSTR,MAXR)
20663cc SAVE /PC/
20664 COMMON /PD/LPION(MAXSTR,MAXR)
20665cc SAVE /PD/
20666 SAVE
20667* 1. DETERMINE THE MOMENTUM COMPONENT OF THE K* IN THE CMS OF PI-K FRAME
20668* WE LET I1 TO BE THE K* AND ABSORB I2
20669 E10=SQRT(E(I1)**2+P(1,I1)**2+P(2,I1)**2+P(3,I1)**2)
20670 E20=SQRT(E(I2)**2+P(1,I2)**2+P(2,I2)**2+P(3,I2)**2)
20671 IF(LB(I2) .EQ. 21 .OR. LB(I2) .EQ. 23) THEN
20672 E(I1)=0.
20673 I=I2
20674 ELSE
20675 E(I2)=0.
20676 I=I1
20677 ENDIF
20678 if(LB(I).eq.23) then
20679 LB(I)=30
20680 else if(LB(I).eq.21) then
20681 LB(I)=-30
20682 endif
20683 P(1,I)=P(1,I1)+P(1,I2)
20684 P(2,I)=P(2,I1)+P(2,I2)
20685 P(3,I)=P(3,I1)+P(3,I2)
20686* 2. DETERMINE THE MASS OF K* BY USING THE REACTION KINEMATICS
20687 DM=SQRT((E10+E20)**2-P(1,I)**2-P(2,I)**2-P(3,I)**2)
20688 E(I)=DM
20689 RETURN
20690 END
20691
20692c--------------------------------------------------------
20693*************************************
20694* *
20695 SUBROUTINE pertur(PX,PY,PZ,SRT,IRUN,I1,I2,nt,kp,icont)
20696* *
20697* PURPOSE: TO PRODUCE CASCADE AND OMEGA PERTURBATIVELY *
20698c sp 01/03/01
20699* 40 cascade-
20700* -40 cascade-(bar)
20701* 41 cascade0
20702* -41 cascade0(bar)
20703* 45 Omega baryon
20704* -45 Omega baryon(bar)
20705* 44 Di-Omega
20706**********************************
20707 PARAMETER (MAXSTR=150001,MAXR=1,PI=3.1415926)
20708 parameter (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
20709 PARAMETER (AMN=0.939457,AMP=0.93828,AP1=0.13496,AP2=0.13957)
20710 PARAMETER (AKA=0.498,ALA=1.1157,ASA=1.1974,aks=0.895)
20711 PARAMETER (ACAS=1.3213,AOME=1.6724,AMRHO=0.769,AMOMGA=0.782)
20712 PARAMETER (AETA=0.548,ADIOMG=3.2288)
20713 parameter (maxx=20,maxz=24)
20714 COMMON /AA/ R(3,MAXSTR)
20715cc SAVE /AA/
20716 COMMON /BB/ P(3,MAXSTR)
20717cc SAVE /BB/
20718 COMMON /CC/ E(MAXSTR)
20719cc SAVE /CC/
20720 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
20721cc SAVE /EE/
20722 COMMON /HH/ PROPER(MAXSTR)
20723cc SAVE /HH/
20724 common /ff/f(-mx:mx,-my:my,-mz:mz,-mpx:mpx,-mpy:mpy,-mpz:mpzp)
20725cc SAVE /ff/
20726 common /gg/ dx,dy,dz,dpx,dpy,dpz
20727cc SAVE /gg/
20728 COMMON /INPUT/ NSTAR,NDIRCT,DIR
20729cc SAVE /INPUT/
20730 COMMON /NN/NNN
20731cc SAVE /NN/
20732 COMMON /PA/RPION(3,MAXSTR,MAXR)
20733cc SAVE /PA/
20734 COMMON /PB/PPION(3,MAXSTR,MAXR)
20735cc SAVE /PB/
20736 COMMON /PC/EPION(MAXSTR,MAXR)
20737cc SAVE /PC/
20738 COMMON /PD/LPION(MAXSTR,MAXR)
20739cc SAVE /PD/
20740 COMMON /PE/PROPI(MAXSTR,MAXR)
20741cc SAVE /PE/
20742 COMMON /RR/ MASSR(0:MAXR)
20743cc SAVE /RR/
20744 COMMON /BG/BETAX,BETAY,BETAZ,GAMMA
20745cc SAVE /BG/
20746 common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
20747cc SAVE /input1/
20748c perturbative method is disabled:
20749c common /imulst/ iperts
20750c
20751 COMMON/RNDF77/NSEED
20752cc SAVE /RNDF77/
20753 COMMON /dpert/dpertt(MAXSTR,MAXR),dpertp(MAXSTR),dplast(MAXSTR),
20754 1 dpdcy(MAXSTR),dpdpi(MAXSTR,MAXR),dpt(MAXSTR, MAXR),
20755 2 dpp1(MAXSTR,MAXR),dppion(MAXSTR,MAXR)
20756 SAVE
20757 kp=kp
20758 nt=nt
20759
20760 px0 = px
20761 py0 = py
20762 pz0 = pz
20763 LB1 = LB(I1)
20764 EM1 = E(I1)
20765 X1 = R(1,I1)
20766 Y1 = R(2,I1)
20767 Z1 = R(3,I1)
20768 prob1 = PROPER(I1)
20769c
20770 LB2 = LB(I2)
20771 EM2 = E(I2)
20772 X2 = R(1,I2)
20773 Y2 = R(2,I2)
20774 Z2 = R(3,I2)
20775 prob2 = PROPER(I2)
20776c
20777c !! flag for real 2-body process (1/0=no/yes)
20778 icont = 1
20779c !! flag for elastic scatt only (-1=no)
20780 icsbel = -1
20781
20782* K-/K*0bar + La/Si --> cascade + pi
20783* K+/K*0 + La/Si (bar) --> cascade-bar + pi
20784 if( (lb1.eq.21.or.lb1.eq.23.or.iabs(lb1).eq.30) .and.
20785 & (iabs(lb2).ge.14.and.iabs(lb2).le.17) )go to 60
20786 if( (lb2.eq.21.or.lb2.eq.23.or.iabs(lb2).eq.30) .and.
20787 & (iabs(lb1).ge.14.and.iabs(lb1).le.17) )go to 60
20788* K-/K*0bar + cascade --> omega + pi
20789* K+/K*0 + cascade-bar --> omega-bar + pi
20790 if( (lb1.eq.21.or.lb1.eq.23.or.iabs(lb1).eq.30) .and.
20791 & (iabs(lb2).eq.40.or.iabs(lb2).eq.41) )go to 70
20792 if( (lb2.eq.21.or.lb2.eq.23.or.iabs(lb2).eq.30) .and.
20793 & (iabs(lb1).eq.40.or.iabs(lb1).eq.41) )go to 70
20794c
20795c annhilation of cascade,cascade-bar, omega,omega-bar
20796c
20797* K- + La/Si <-- cascade + pi(eta,rho,omega)
20798* K+ + La/Si(bar) <-- cascade-bar + pi(eta,rho,omega)
20799 if( (((lb1.ge.3.and.lb1.le.5).or.lb1.eq.0)
20800 & .and.(iabs(lb2).eq.40.or.iabs(lb2).eq.41))
20801 & .OR. (((lb2.ge.3.and.lb2.le.5).or.lb2.eq.0)
20802 & .and.(iabs(lb1).eq.40.or.iabs(lb1).eq.41)) )go to 90
20803* K- + cascade <-- omega + pi
20804* K+ + cascade-bar <-- omega-bar + pi
20805c if( (lb1.eq.0.and.iabs(lb2).eq.45)
20806c & .OR. (lb2.eq.0.and.iabs(lb1).eq.45) ) go to 110
20807 if( ((lb1.ge.3.and.lb1.le.5).and.iabs(lb2).eq.45)
20808 & .OR.((lb2.ge.3.and.lb2.le.5).and.iabs(lb1).eq.45) )go to 110
20809c
20810
20811c----------------------------------------------------
20812* for process: K-bar + L(S) --> Ca + pi
20813*
2081460 if(iabs(lb1).ge.14 .and. iabs(lb1).le.17)then
20815 asap = e(i1)
20816 akap = e(i2)
20817 idp = i1
20818 else
20819 asap = e(i2)
20820 akap = e(i1)
20821 idp = i2
20822 endif
20823 app = 0.138
20824 if(srt .lt. (acas+app))return
20825 srrt = srt - (acas+app) + (amn+akap)
20826 pkaon = sqrt(((srrt**2-(amn**2+akap**2))/2./amn)**2 - akap**2)
20827 sigca = 1.5*( akNPsg(pkaon)+akNPsg(pkaon) )
20828clin pii & pff should be each divided by (4*srt**2),
20829c but these two factors cancel out in the ratio pii/pff:
20830 pii = sqrt((srt**2-(amn+akap)**2)*(srt**2-(amn-akap)**2))
20831 pff = sqrt((srt**2-(asap+app)**2)*(srt**2-(asap-app)**2))
20832 cmat = sigca*pii/pff
20833 sigpi = cmat*
20834 & sqrt((srt**2-(acas+app)**2)*(srt**2-(acas-app)**2))/
20835 & sqrt((srt**2-(asap+akap)**2)*(srt**2-(asap-akap)**2))
20836c
20837 sigeta = 0.
20838 if(srt .gt. (acas+aeta))then
20839 srrt = srt - (acas+aeta) + (amn+akap)
20840 pkaon = sqrt(((srrt**2-(amn**2+akap**2))/2./amn)**2 - akap**2)
20841 sigca = 1.5*( akNPsg(pkaon)+akNPsg(pkaon) )
20842 cmat = sigca*pii/pff
20843 sigeta = cmat*
20844 & sqrt((srt**2-(acas+aeta)**2)*(srt**2-(acas-aeta)**2))/
20845 & sqrt((srt**2-(asap+akap)**2)*(srt**2-(asap-akap)**2))
20846 endif
20847c
20848 sigca = sigpi + sigeta
20849 sigpe = 0.
20850clin-2/25/03 disable the perturb option:
20851c if(iperts .eq. 1) sigpe = 40. !! perturbative xsecn
20852 sig = amax1(sigpe,sigca)
20853 ds = sqrt(sig/31.4)
20854 dsr = ds + 0.1
20855 ec = (em1+em2+0.02)**2
20856 call distce(i1,i2,dsr,ds,dt,ec,srt,ic,px,py,pz)
20857 if(ic .eq. -1)return
20858 brpp = sigca/sig
20859c
20860c else particle production
20861 if( (lb1.ge.14.and.lb1.le.17) .or.
20862 & (lb2.ge.14.and.lb2.le.17) )then
20863c !! cascade- or cascde0
20864 lbpp1 = 40 + int(2*RANART(NSEED))
20865 else
20866* elseif(lb1 .eq. -14 .or. lb2 .eq. -14)
20867c !! cascade-bar- or cascde0 -bar
20868 lbpp1 = -40 - int(2*RANART(NSEED))
20869 endif
20870 empp1 = acas
20871 if(RANART(NSEED) .lt. sigpi/sigca)then
20872c !! pion
20873 lbpp2 = 3 + int(3*RANART(NSEED))
20874 empp2 = 0.138
20875 else
20876c !! eta
20877 lbpp2 = 0
20878 empp2 = aeta
20879 endif
20880c* check real process of cascade(bar) and pion formation
20881 if(RANART(NSEED) .lt. brpp)then
20882c !! real process flag
20883 icont = 0
20884 lb(i1) = lbpp1
20885 e(i1) = empp1
20886c !! cascade formed with prob Gam
20887 proper(i1) = brpp
20888 lb(i2) = lbpp2
20889 e(i2) = empp2
20890c !! pion/eta formed with prob 1.
20891 proper(i2) = 1.
20892 endif
20893c else only cascade(bar) formed perturbatively
20894 go to 700
20895
20896c----------------------------------------------------
20897* for process: Cas(bar) + K_bar(K) --> Om(bar) + pi !! eta
20898*
2089970 if(iabs(lb1).eq.40 .or. iabs(lb1).eq.41)then
20900 acap = e(i1)
20901 akap = e(i2)
20902 idp = i1
20903 else
20904 acap = e(i2)
20905 akap = e(i1)
20906 idp = i2
20907 endif
20908 app = 0.138
20909* ames = aeta
20910c !! only pion
20911 ames = 0.138
20912 if(srt .lt. (aome+ames))return
20913 srrt = srt - (aome+ames) + (amn+akap)
20914 pkaon = sqrt(((srrt**2-(amn**2+akap**2))/2./amn)**2 - akap**2)
20915c use K(bar) + Ca --> Om + eta xsecn same as K(bar) + N --> Si + Pi
20916* as Omega have no resonances
20917c** using same matrix elements as K-bar + N -> Si + pi
20918 sigomm = 1.5*( akNPsg(pkaon)+akNPsg(pkaon) )
20919 cmat = sigomm*
20920 & sqrt((srt**2-(amn+akap)**2)*(srt**2-(amn-akap)**2))/
20921 & sqrt((srt**2-(asa+app)**2)*(srt**2-(asa-app)**2))
20922 sigom = cmat*
20923 & sqrt((srt**2-(aome+ames)**2)*(srt**2-(aome-ames)**2))/
20924 & sqrt((srt**2-(acap+akap)**2)*(srt**2-(acap-akap)**2))
20925 sigpe = 0.
20926clin-2/25/03 disable the perturb option:
20927c if(iperts .eq. 1) sigpe = 40. !! perturbative xsecn
20928 sig = amax1(sigpe,sigom)
20929 ds = sqrt(sig/31.4)
20930 dsr = ds + 0.1
20931 ec = (em1+em2+0.02)**2
20932 call distce(i1,i2,dsr,ds,dt,ec,srt,ic,px,py,pz)
20933 if(ic .eq. -1)return
20934 brpp = sigom/sig
20935c
20936c else particle production
20937 if( (lb1.ge.40.and.lb1.le.41) .or.
20938 & (lb2.ge.40.and.lb2.le.41) )then
20939c !! omega
20940 lbpp1 = 45
20941 else
20942* elseif(lb1 .eq. -40 .or. lb2 .eq. -40)
20943c !! omega-bar
20944 lbpp1 = -45
20945 endif
20946 empp1 = aome
20947* lbpp2 = 0 !! eta
20948c !! pion
20949 lbpp2 = 3 + int(3*RANART(NSEED))
20950 empp2 = ames
20951c
20952c* check real process of omega(bar) and pion formation
20953 xrand=RANART(NSEED)
20954 if(xrand .lt. (proper(idp)*brpp))then
20955c !! real process flag
20956 icont = 0
20957 lb(i1) = lbpp1
20958 e(i1) = empp1
20959c !! P_Om = P_Cas*Gam
20960 proper(i1) = proper(idp)*brpp
20961 lb(i2) = lbpp2
20962 e(i2) = empp2
20963c !! pion formed with prob 1.
20964 proper(i2) = 1.
20965 elseif(xrand.lt.brpp) then
20966c else omega(bar) formed perturbatively and cascade destroyed
20967 e(idp) = 0.
20968 endif
20969 go to 700
20970
20971c-----------------------------------------------------------
20972* for process: Ca + pi/eta --> K-bar + L(S)
20973*
2097490 if(iabs(lb1).eq.40 .or. iabs(lb1).eq.41)then
20975 acap = e(i1)
20976 app = e(i2)
20977 idp = i1
20978 idn = i2
20979 else
20980 acap = e(i2)
20981 app = e(i1)
20982 idp = i2
20983 idn = i1
20984 endif
20985c akal = (aka+aks)/2. !! average of K and K* taken
20986c !! using K only
20987 akal = aka
20988c
20989 alas = ala
20990 if(srt .le. (alas+aka))return
20991 srrt = srt - (acap+app) + (amn+aka)
20992 pkaon = sqrt(((srrt**2-(amn**2+aka**2))/2./amn)**2 - aka**2)
20993c** using same matrix elements as K-bar + N -> La/Si + pi
20994 sigca = 1.5*( akNPsg(pkaon)+akNPsg(pkaon) )
20995 cmat = sigca*
20996 & sqrt((srt**2-(amn+aka)**2)*(srt**2-(amn-aka)**2))/
20997 & sqrt((srt**2-(alas+0.138)**2)*(srt**2-(alas-0.138)**2))
20998 sigca = cmat*
20999 & sqrt((srt**2-(acap+app)**2)*(srt**2-(acap-app)**2))/
21000 & sqrt((srt**2-(alas+aka)**2)*(srt**2-(alas-aka)**2))
21001c !! pi
21002 dfr = 1./3.
21003c !! eta
21004 if(lb(idn).eq.0)dfr = 1.
21005 sigcal = sigca*dfr*(srt**2-(alas+aka)**2)*
21006 & (srt**2-(alas-aka)**2)/(srt**2-(acap+app)**2)/
21007 & (srt**2-(acap-app)**2)
21008c
21009 alas = ASA
21010 if(srt .le. (alas+aka))then
21011 sigcas = 0.
21012 else
21013 srrt = srt - (acap+app) + (amn+aka)
21014 pkaon = sqrt(((srrt**2-(amn**2+aka**2))/2./amn)**2 - aka**2)
21015c use K(bar) + La/Si --> Ca + Pi xsecn same as K(bar) + N --> Si + Pi
21016c** using same matrix elements as K-bar + N -> La/Si + pi
21017 sigca = 1.5*( akNPsg(pkaon)+akNPsg(pkaon) )
21018 cmat = sigca*
21019 & sqrt((srt**2-(amn+aka)**2)*(srt**2-(amn-aka)**2))/
21020 & sqrt((srt**2-(alas+0.138)**2)*(srt**2-(alas-0.138)**2))
21021 sigca = cmat*
21022 & sqrt((srt**2-(acap+app)**2)*(srt**2-(acap-app)**2))/
21023 & sqrt((srt**2-(alas+aka)**2)*(srt**2-(alas-aka)**2))
21024c !! pi
21025 dfr = 1.
21026c !! eta
21027 if(lb(idn).eq.0)dfr = 3.
21028 sigcas = sigca*dfr*(srt**2-(alas+aka)**2)*
21029 & (srt**2-(alas-aka)**2)/(srt**2-(acap+app)**2)/
21030 & (srt**2-(acap-app)**2)
21031 endif
21032c
21033 sig = sigcal + sigcas
21034 brpp = 1.
21035 ds = sqrt(sig/31.4)
21036 dsr = ds + 0.1
21037 ec = (em1+em2+0.02)**2
21038 call distce(i1,i2,dsr,ds,dt,ec,srt,ic,px,py,pz)
21039c
21040clin-2/25/03: checking elastic scatt after failure of inelastic scatt gives
21041c conditional probability (in general incorrect), tell Pal to correct:
21042 if(ic .eq. -1)then
21043c check for elastic scatt, no particle annhilation
21044c !! elastic cross section of 20 mb
21045 ds = sqrt(20.0/31.4)
21046 dsr = ds + 0.1
21047 call distce(i1,i2,dsr,ds,dt,ec,srt,icsbel,px,py,pz)
21048 if(icsbel .eq. -1)return
21049 empp1 = EM1
21050 empp2 = EM2
21051 go to 700
21052 endif
21053c
21054c else pert. produced cascade(bar) is annhilated OR real process
21055c
21056* DECIDE LAMBDA OR SIGMA PRODUCTION
21057c
21058 IF(sigcal/sig .GT. RANART(NSEED))THEN
21059 if(lb1.eq.40.or.lb1.eq.41.or.lb2.eq.40.or.lb2.eq.41)then
21060 lbpp1 = 21
21061 lbpp2 = 14
21062 else
21063 lbpp1 = 23
21064 lbpp2 = -14
21065 endif
21066 alas = ala
21067 ELSE
21068 if(lb1.eq.40.or.lb1.eq.41.or.lb2.eq.40.or.lb2.eq.41)then
21069 lbpp1 = 21
21070 lbpp2 = 15 + int(3 * RANART(NSEED))
21071 else
21072 lbpp1 = 23
21073 lbpp2 = -15 - int(3 * RANART(NSEED))
21074 endif
21075 alas = ASA
21076 ENDIF
21077 empp1 = aka
21078 empp2 = alas
21079c
21080c check for real process for L/S(bar) and K(bar) formation
21081 if(RANART(NSEED) .lt. proper(idp))then
21082* real process
21083c !! real process flag
21084 icont = 0
21085 lb(i1) = lbpp1
21086 e(i1) = empp1
21087c !! K(bar) formed with prob 1.
21088 proper(i1) = 1.
21089 lb(i2) = lbpp2
21090 e(i2) = empp2
21091c !! L/S(bar) formed with prob 1.
21092 proper(i2) = 1.
21093 go to 700
21094 else
21095c else only cascade(bar) annhilation & go out
21096 e(idp) = 0.
21097 endif
21098 return
21099c
21100c----------------------------------------------------
21101* for process: Om(bar) + pi --> Cas(bar) + K_bar(K)
21102*
21103110 if(lb1 .eq. 45 .or. lb1 .eq. -45)then
21104 aomp = e(i1)
21105 app = e(i2)
21106 idp = i1
21107 idn = i2
21108 else
21109 aomp = e(i2)
21110 app = e(i1)
21111 idp = i2
21112 idn = i1
21113 endif
21114c akal = (aka+aks)/2. !! average of K and K* taken
21115c !! using K only
21116 akal = aka
21117 if(srt .le. (acas+aka))return
21118 srrt = srt - (aome+app) + (amn+aka)
21119 pkaon = sqrt(((srrt**2-(amn**2+aka**2))/2./amn)**2 - aka**2)
21120c use K(bar) + Ca --> Om + eta xsecn same as K(bar) + N --> Si + Pi
21121c** using same matrix elements as K-bar + N -> La/Si + pi
21122 sigca = 1.5*( akNPsg(pkaon)+akNPsg(pkaon) )
21123 cmat = sigca*
21124 & sqrt((srt**2-(amn+aka)**2)*(srt**2-(amn-aka)**2))/
21125 & sqrt((srt**2-(asa+0.138)**2)*(srt**2-(asa-0.138)**2))
21126 sigom = cmat*
21127 & sqrt((srt**2-(aomp+app)**2)*(srt**2-(aomp-app)**2))/
21128 & sqrt((srt**2-(acas+aka)**2)*(srt**2-(acas-aka)**2))
21129c dfr = 2. !! eta
21130c !! pion
21131 dfr = 2./3.
21132 sigom = sigom*dfr*(srt**2-(acas+aka)**2)*
21133 & (srt**2-(acas-aka)**2)/(srt**2-(aomp+app)**2)/
21134 & (srt**2-(aomp-app)**2)
21135c
21136 brpp = 1.
21137 ds = sqrt(sigom/31.4)
21138 dsr = ds + 0.1
21139 ec = (em1+em2+0.02)**2
21140 call distce(i1,i2,dsr,ds,dt,ec,srt,ic,px,py,pz)
21141c
21142clin-2/25/03: checking elastic scatt after failure of inelastic scatt gives
21143c conditional probability (in general incorrect), tell Pal to correct:
21144 if(ic .eq. -1)then
21145c check for elastic scatt, no particle annhilation
21146c !! elastic cross section of 20 mb
21147 ds = sqrt(20.0/31.4)
21148 dsr = ds + 0.1
21149 call distce(i1,i2,dsr,ds,dt,ec,srt,icsbel,px,py,pz)
21150 if(icsbel .eq. -1)return
21151 empp1 = EM1
21152 empp2 = EM2
21153 go to 700
21154 endif
21155c
21156c else pert. produced omega(bar) annhilated OR real process
21157c annhilate only pert. omega, rest from hijing go out WITHOUT annhil.
21158 if(lb1.eq.45 .or. lb2.eq.45)then
21159c !! Ca
21160 lbpp1 = 40 + int(2*RANART(NSEED))
21161c !! K-
21162 lbpp2 = 21
21163 else
21164* elseif(lb1 .eq. -45 .or. lb2 .eq. -45)
21165c !! Ca-bar
21166 lbpp1 = -40 - int(2*RANART(NSEED))
21167c !! K+
21168 lbpp2 = 23
21169 endif
21170 empp1 = acas
21171 empp2 = aka
21172c
21173c check for real process for Cas(bar) and K(bar) formation
21174 if(RANART(NSEED) .lt. proper(idp))then
21175c !! real process flag
21176 icont = 0
21177 lb(i1) = lbpp1
21178 e(i1) = empp1
21179c !! P_Cas(bar) = P_Om(bar)
21180 proper(i1) = proper(idp)
21181 lb(i2) = lbpp2
21182 e(i2) = empp2
21183c !! K(bar) formed with prob 1.
21184 proper(i2) = 1.
21185c
21186 else
21187c else Cascade(bar) produced and Omega(bar) annhilated
21188 e(idp) = 0.
21189 endif
21190c !! for produced particles
21191 go to 700
21192c
21193c-----------------------------------------------------------
21194700 continue
21195* CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
21196* ENERGY CONSERVATION
21197 PR2 = (SRT**2 - EMpp1**2 - EMpp2**2)**2
21198 & - 4.0 * (EMpp1*EMpp2)**2
21199 IF(PR2.LE.0.)PR2=0.00000001
21200 PR=SQRT(PR2)/(2.*SRT)
21201* using isotropic
21202 C1 = 1.0 - 2.0 * RANART(NSEED)
21203 T1 = 2.0 * PI * RANART(NSEED)
21204 S1 = SQRT( 1.0 - C1**2 )
21205 CT1 = COS(T1)
21206 ST1 = SIN(T1)
21207* THE MOMENTUM IN THE CMS IN THE FINAL STATE
21208 PZ = PR * C1
21209 PX = PR * S1*CT1
21210 PY = PR * S1*ST1
21211* ROTATE IT
21212 CALL ROTATE(PX0,PY0,PZ0,PX,PY,PZ)
21213 if(icont .eq. 0)return
21214c
21215* LORENTZ-TRANSFORMATION INTO CMS FRAME
21216 E1CM = SQRT (EMpp1**2 + PX**2 + PY**2 + PZ**2)
21217 P1BETA = PX*BETAX + PY*BETAY + PZ*BETAZ
21218 TRANSF = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) + E1CM )
21219 Ppt11 = BETAX * TRANSF + PX
21220 Ppt12 = BETAY * TRANSF + PY
21221 Ppt13 = BETAZ * TRANSF + PZ
21222c
21223cc** for elastic scattering update the momentum of pertb particles
21224 if(icsbel .ne. -1)then
21225c if(EMpp1 .gt. 0.9)then
21226 p(1,i1) = Ppt11
21227 p(2,i1) = Ppt12
21228 p(3,i1) = Ppt13
21229c else
21230 E2CM = SQRT (EMpp2**2 + PX**2 + PY**2 + PZ**2)
21231 TRANSF = GAMMA * ( -GAMMA * P1BETA / (GAMMA + 1) + E2CM )
21232 Ppt21 = BETAX * TRANSF - PX
21233 Ppt22 = BETAY * TRANSF - PY
21234 Ppt23 = BETAZ * TRANSF - PZ
21235 p(1,i2) = Ppt21
21236 p(2,i2) = Ppt22
21237 p(3,i2) = Ppt23
21238c endif
21239 return
21240 endif
21241clin-5/2008:
21242c2008 X01 = 1.0 - 2.0 * RANART(NSEED)
21243c Y01 = 1.0 - 2.0 * RANART(NSEED)
21244c Z01 = 1.0 - 2.0 * RANART(NSEED)
21245c IF ((X01*X01+Y01*Y01+Z01*Z01) .GT. 1.0) GOTO 2008
21246c Xpt=X1+0.5*x01
21247c Ypt=Y1+0.5*y01
21248c Zpt=Z1+0.5*z01
21249 Xpt=X1
21250 Ypt=Y1
21251 Zpt=Z1
21252c
21253c
21254c if(lbpp1 .eq. 45)then
21255c write(*,*)'II lb1,lb2,lbpp1,empp1,proper(idp),brpp'
21256c write(*,*)lb1,lb2,lbpp1,empp1,proper(idp),brpp
21257c endif
21258c
21259 NNN=NNN+1
21260 PROPI(NNN,IRUN)= proper(idp)*brpp
21261 LPION(NNN,IRUN)= lbpp1
21262 EPION(NNN,IRUN)= empp1
21263 RPION(1,NNN,IRUN)=Xpt
21264 RPION(2,NNN,IRUN)=Ypt
21265 RPION(3,NNN,IRUN)=Zpt
21266 PPION(1,NNN,IRUN)=Ppt11
21267 PPION(2,NNN,IRUN)=Ppt12
21268 PPION(3,NNN,IRUN)=Ppt13
21269clin-5/2008:
21270 dppion(nnn,irun)=dpertp(i1)*dpertp(i2)
21271 RETURN
21272 END
21273**********************************
21274* sp 12/08/00 *
21275 SUBROUTINE Crhb(PX,PY,PZ,SRT,I1,I2,IBLOCK)
21276* PURPOSE: *
21277* DEALING WITH hyperon+N(D,N*)->hyp+N(D,N*) elastic PROCESS *
21278* NOTE : *
21279*
21280* QUANTITIES: *
21281* PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
21282* SRT - SQRT OF S *
21283* IBLOCK - THE INFORMATION BACK *
21284* 144-> hyp+N(D,N*)->hyp+N(D,N*)
21285**********************************
21286 PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
21287 1 AMP=0.93828,AP1=0.13496,
21288 2 AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
21289 PARAMETER (AKA=0.498,ALA=1.1157,ASA=1.1974)
21290 parameter (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
21291 COMMON /AA/ R(3,MAXSTR)
21292cc SAVE /AA/
21293 COMMON /BB/ P(3,MAXSTR)
21294cc SAVE /BB/
21295 COMMON /CC/ E(MAXSTR)
21296cc SAVE /CC/
21297 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
21298cc SAVE /EE/
21299 common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
21300cc SAVE /input1/
21301 COMMON/RNDF77/NSEED
21302cc SAVE /RNDF77/
21303 SAVE
21304
21305 PX0=PX
21306 PY0=PY
21307 PZ0=PZ
21308*-----------------------------------------------------------------------
21309 IBLOCK=144
21310 NTAG=0
21311 EM1=E(I1)
21312 EM2=E(I2)
21313*-----------------------------------------------------------------------
21314* CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
21315* ENERGY CONSERVATION
21316 PR2 = (SRT**2 - EM1**2 - EM2**2)**2
21317 1 - 4.0 * (EM1*EM2)**2
21318 IF(PR2.LE.0.)PR2=1.e-09
21319 PR=SQRT(PR2)/(2.*SRT)
21320 C1 = 1.0 - 2.0 * RANART(NSEED)
21321 T1 = 2.0 * PI * RANART(NSEED)
21322 S1 = SQRT( 1.0 - C1**2 )
21323 CT1 = COS(T1)
21324 ST1 = SIN(T1)
21325 PZ = PR * C1
21326 PX = PR * S1*CT1
21327 PY = PR * S1*ST1
21328 RETURN
21329 END
21330****************************************
21331c sp 04/05/01
21332* Purpose: lambda-baryon elastic xsection as a functon of their cms energy
21333 subroutine lambar(i1,i2,srt,siglab)
21334* srt = DSQRT(s) in GeV *
21335* siglab = lambda-nuclar elastic cross section in mb
21336* = 12 + 0.43/p_lab**3.3 (mb)
21337*
21338* (2) Calculate p(lab) from srt [GeV], since the formular in the
21339* reference applies only to the case of a p_bar on a proton at rest
21340* Formula used: srt**2=2.*pmass*(pmass+sqrt(pmass**2+plab**2))
21341*****************************
21342 PARAMETER (MAXSTR=150001)
21343 COMMON /AA/ R(3,MAXSTR)
21344cc SAVE /AA/
21345 COMMON /BB/ P(3,MAXSTR)
21346cc SAVE /BB/
21347 COMMON /CC/ E(MAXSTR)
21348cc SAVE /CC/
21349 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
21350cc SAVE /EE/
21351 SAVE
21352
21353 siglab=1.e-06
21354 if( iabs(lb(i1)).ge.14.and.iabs(lb(i1)).le.17 )then
21355 eml = e(i1)
21356 emb = e(i2)
21357 else
21358 eml = e(i2)
21359 emb = e(i1)
21360 endif
21361 pthr = srt**2-eml**2-emb**2
21362 if(pthr .gt. 0.)then
21363 plab2=(pthr/2./emb)**2-eml**2
21364 if(plab2.gt.0)then
21365 plab=sqrt(plab2)
21366 siglab=12. + 0.43/(plab**3.3)
21367 if(siglab.gt.200.)siglab=200.
21368 endif
21369 endif
21370 return
21371 END
21372C------------------------------------------------------------------
21373clin-7/26/03 improve speed
21374***************************************
21375 SUBROUTINE distc0(drmax,deltr0,DT,
21376 1 Ifirst,PX1CM,PY1CM,PZ1CM,
21377 2 x1,y1,z1,px1,py1,pz1,em1,x2,y2,z2,px2,py2,pz2,em2)
21378* PURPOSE : CHECK IF THE COLLISION BETWEEN TWO PARTICLES CAN HAPPEN
21379* BY CHECKING
21380* (2) IF PARTICLE WILL PASS EACH OTHER WITHIN
21381* TWO HARD CORE RADIUS.
21382* (3) IF PARTICLES WILL GET CLOSER.
21383* VARIABLES :
21384* Ifirst=1 COLLISION may HAPPENED
21385* Ifirst=-1 COLLISION CAN NOT HAPPEN
21386*****************************************
21387 COMMON /BG/ BETAX,BETAY,BETAZ,GAMMA
21388cc SAVE /BG/
21389 SAVE
21390 deltr0=deltr0
21391 Ifirst=-1
21392 E1=SQRT(EM1**2+PX1**2+PY1**2+PZ1**2)
21393*NOW PARTICLES ARE CLOSE ENOUGH TO EACH OTHER !
21394 E2 = SQRT ( EM2**2 + PX2**2 + PY2**2 + PZ2**2 )
21395*NOW THERE IS ENOUGH ENERGY AVAILABLE !
21396*LORENTZ-TRANSFORMATION IN I1-I2-C.M. SYSTEM
21397* BETAX, BETAY, BETAZ AND GAMMA HAVE BEEN GIVEN IN THE SUBROUTINE CMS
21398*TRANSFORMATION OF MOMENTA (PX1CM = - PX2CM)
21399 P1BETA = PX1*BETAX + PY1*BETAY + PZ1 * BETAZ
21400 TRANSF = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) - E1 )
21401 PRCM = SQRT (PX1CM**2 + PY1CM**2 + PZ1CM**2)
21402 IF (PRCM .LE. 0.00001) return
21403*TRANSFORMATION OF SPATIAL DISTANCE
21404 DRBETA = BETAX*(X1-X2) + BETAY*(Y1-Y2) + BETAZ*(Z1-Z2)
21405 TRANSF = GAMMA * GAMMA * DRBETA / (GAMMA + 1)
21406 DXCM = BETAX * TRANSF + X1 - X2
21407 DYCM = BETAY * TRANSF + Y1 - Y2
21408 DZCM = BETAZ * TRANSF + Z1 - Z2
21409*DETERMINING IF THIS IS THE POINT OF CLOSEST APPROACH
21410 DRCM = SQRT (DXCM**2 + DYCM**2 + DZCM**2 )
21411 DZZ = (PX1CM*DXCM + PY1CM*DYCM + PZ1CM*DZCM) / PRCM
21412 if ((drcm**2 - dzz**2) .le. 0.) then
21413 BBB = 0.
21414 else
21415 BBB = SQRT (DRCM**2 - DZZ**2)
21416 end if
21417*WILL PARTICLE PASS EACH OTHER WITHIN 2 * HARD CORE RADIUS ?
21418 IF (BBB .GT. drmax) return
21419 RELVEL = PRCM * (1.0/E1 + 1.0/E2)
21420 DDD = RELVEL * DT * 0.5
21421*WILL PARTICLES GET CLOSER ?
21422 IF (ABS(DDD) .LT. ABS(DZZ)) return
21423 Ifirst=1
21424 RETURN
21425 END
21426*---------------------------------------------------------------------------
21427c
21428clin-8/2008 B+B->Deuteron+Meson cross section in mb:
21429 subroutine sbbdm(srt,sdprod,ianti,lbm,xmm,pfinal)
21430 PARAMETER (xmd=1.8756,AP1=0.13496,AP2=0.13957,
21431 1 xmrho=0.770,xmomega=0.782,xmeta=0.548,srt0=2.012)
21432 common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
21433 1 px1n,py1n,pz1n,dp1n
21434 common /dpi/em2,lb2
21435 common /para8/ idpert,npertd,idxsec
21436 COMMON/RNDF77/NSEED
21437 SAVE
21438c
21439 sdprod=0.
21440 sbbdpi=0.
21441 sbbdrho=0.
21442 sbbdomega=0.
21443 sbbdeta=0.
21444 if(srt.le.(em1+em2)) return
21445c
21446 ilb1=iabs(lb1)
21447 ilb2=iabs(lb2)
21448ctest off check Xsec using fixed mass for resonances:
21449c if(ilb1.ge.6.and.ilb1.le.9) then
21450c em1=1.232
21451c elseif(ilb1.ge.10.and.ilb1.le.11) then
21452c em1=1.44
21453c elseif(ilb1.ge.12.and.ilb1.le.13) then
21454c em1=1.535
21455c endif
21456c if(ilb2.ge.6.and.ilb2.le.9) then
21457c em2=1.232
21458c elseif(ilb2.ge.10.and.ilb2.le.11) then
21459c em2=1.44
21460c elseif(ilb2.ge.12.and.ilb2.le.13) then
21461c em2=1.535
21462c endif
21463c
21464 s=srt**2
21465 pinitial=sqrt((s-(em1+em2)**2)*(s-(em1-em2)**2))/2./srt
21466 fs=fnndpi(s)
21467c Determine isospin and spin factors for the ratio between
21468c BB->Deuteron+Meson and Deuteron+Meson->BB cross sections:
21469 if(idxsec.eq.1.or.idxsec.eq.2) then
21470c Assume B+B -> d+Meson has the same cross sections as N+N -> d+pi:
21471 else
21472c Assume d+Meson -> B+B has the same cross sections as d+pi -> N+N,
21473c then determine B+B -> d+Meson cross sections:
21474 if(ilb1.ge.1.and.ilb1.le.2.and.
21475 1 ilb2.ge.1.and.ilb2.le.2) then
21476 pifactor=9./8.
21477 elseif((ilb1.ge.1.and.ilb1.le.2.and.
21478 1 ilb2.ge.6.and.ilb2.le.9).or.
21479 2 (ilb2.ge.1.and.ilb2.le.2.and.
21480 1 ilb1.ge.6.and.ilb1.le.9)) then
21481 pifactor=9./64.
21482 elseif((ilb1.ge.1.and.ilb1.le.2.and.
21483 1 ilb2.ge.10.and.ilb2.le.13).or.
21484 2 (ilb2.ge.1.and.ilb2.le.2.and.
21485 1 ilb1.ge.10.and.ilb1.le.13)) then
21486 pifactor=9./16.
21487 elseif(ilb1.ge.6.and.ilb1.le.9.and.
21488 1 ilb2.ge.6.and.ilb2.le.9) then
21489 pifactor=9./128.
21490 elseif((ilb1.ge.6.and.ilb1.le.9.and.
21491 1 ilb2.ge.10.and.ilb2.le.13).or.
21492 2 (ilb2.ge.6.and.ilb2.le.9.and.
21493 1 ilb1.ge.10.and.ilb1.le.13)) then
21494 pifactor=9./64.
21495 elseif((ilb1.ge.10.and.ilb1.le.11.and.
21496 1 ilb2.ge.10.and.ilb2.le.11).or.
21497 2 (ilb2.ge.12.and.ilb2.le.13.and.
21498 1 ilb1.ge.12.and.ilb1.le.13)) then
21499 pifactor=9./8.
21500 elseif((ilb1.ge.10.and.ilb1.le.11.and.
21501 1 ilb2.ge.12.and.ilb2.le.13).or.
21502 2 (ilb2.ge.10.and.ilb2.le.11.and.
21503 1 ilb1.ge.12.and.ilb1.le.13)) then
21504 pifactor=9./16.
21505 endif
21506 endif
21507c d pi: DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
21508* (1) FOR P+P->Deuteron+pi+:
21509 IF((ilb1*ilb2).EQ.1)THEN
21510 lbm=5
21511 if(ianti.eq.1) lbm=3
21512 xmm=ap2
21513* (2)FOR N+N->Deuteron+pi-:
21514 ELSEIF(ilb1.EQ.2.AND.ilb2.EQ.2)THEN
21515 lbm=3
21516 if(ianti.eq.1) lbm=5
21517 xmm=ap2
21518* (3)FOR N+P->Deuteron+pi0:
21519 ELSEIF((ilb1*ilb2).EQ.2)THEN
21520 lbm=4
21521 xmm=ap1
21522 ELSE
21523c For baryon resonances, use isospin-averaged cross sections:
21524 lbm=3+int(3 * RANART(NSEED))
21525 if(lbm.eq.4) then
21526 xmm=ap1
21527 else
21528 xmm=ap2
21529 endif
21530 ENDIF
21531c
21532 if(srt.ge.(xmd+xmm)) then
21533 pfinal=sqrt((s-(xmd+xmm)**2)*(s-(xmd-xmm)**2))/2./srt
21534 if((ilb1.eq.1.and.ilb2.eq.1).or.
21535 1 (ilb1.eq.2.and.ilb2.eq.2)) then
21536c for pp or nn initial states:
21537 sbbdpi=fs*pfinal/pinitial/4.
21538 elseif((ilb1.eq.1.and.ilb2.eq.2).or.
21539 1 (ilb1.eq.2.and.ilb2.eq.1)) then
21540c factor of 1/2 for pn or np initial states:
21541 sbbdpi=fs*pfinal/pinitial/4./2.
21542 else
21543c for other BB initial states (spin- and isospin averaged):
21544 if(idxsec.eq.1) then
21545c 1: assume the same |matrix element|**2 (after averaging over initial
21546c spins and isospins) for B+B -> deuteron+meson at the same sqrt(s);
21547 sbbdpi=fs*pfinal/pinitial*3./16.
21548 elseif(idxsec.eq.2.or.idxsec.eq.4) then
21549 threshold=amax1(xmd+xmm,em1+em2)
21550 snew=(srt-threshold+srt0)**2
21551 if(idxsec.eq.2) then
21552c 2: assume the same |matrix element|**2 for B+B -> deuteron+meson
21553c at the same sqrt(s)-threshold:
21554 sbbdpi=fnndpi(snew)*pfinal/pinitial*3./16.
21555 elseif(idxsec.eq.4) then
21556c 4: assume the same |matrix element|**2 for B+B <- deuteron+meson
21557c at the same sqrt(s)-threshold:
21558 sbbdpi=fnndpi(snew)*pfinal/pinitial/6.*pifactor
21559 endif
21560 elseif(idxsec.eq.3) then
21561c 3: assume the same |matrix element|**2 for B+B <- deuteron+meson
21562c at the same sqrt(s):
21563 sbbdpi=fs*pfinal/pinitial/6.*pifactor
21564 endif
21565c
21566 endif
21567 endif
21568c
21569* d rho: DETERMINE THE CROSS SECTION TO THIS FINAL STATE:
21570 if(srt.gt.(xmd+xmrho)) then
21571 pfinal=sqrt((s-(xmd+xmrho)**2)*(s-(xmd-xmrho)**2))/2./srt
21572 if(idxsec.eq.1) then
21573 sbbdrho=fs*pfinal/pinitial*3./16.
21574 elseif(idxsec.eq.2.or.idxsec.eq.4) then
21575 threshold=amax1(xmd+xmrho,em1+em2)
21576 snew=(srt-threshold+srt0)**2
21577 if(idxsec.eq.2) then
21578 sbbdrho=fnndpi(snew)*pfinal/pinitial*3./16.
21579 elseif(idxsec.eq.4) then
21580c The spin- and isospin-averaged factor is 3-times larger for rho:
21581 sbbdrho=fnndpi(snew)*pfinal/pinitial/6.*(pifactor*3.)
21582 endif
21583 elseif(idxsec.eq.3) then
21584 sbbdrho=fs*pfinal/pinitial/6.*(pifactor*3.)
21585 endif
21586 endif
21587c
21588* d omega: DETERMINE THE CROSS SECTION TO THIS FINAL STATE:
21589 if(srt.gt.(xmd+xmomega)) then
21590 pfinal=sqrt((s-(xmd+xmomega)**2)*(s-(xmd-xmomega)**2))/2./srt
21591 if(idxsec.eq.1) then
21592 sbbdomega=fs*pfinal/pinitial*3./16.
21593 elseif(idxsec.eq.2.or.idxsec.eq.4) then
21594 threshold=amax1(xmd+xmomega,em1+em2)
21595 snew=(srt-threshold+srt0)**2
21596 if(idxsec.eq.2) then
21597 sbbdomega=fnndpi(snew)*pfinal/pinitial*3./16.
21598 elseif(idxsec.eq.4) then
21599 sbbdomega=fnndpi(snew)*pfinal/pinitial/6.*pifactor
21600 endif
21601 elseif(idxsec.eq.3) then
21602 sbbdomega=fs*pfinal/pinitial/6.*pifactor
21603 endif
21604 endif
21605c
21606* d eta: DETERMINE THE CROSS SECTION TO THIS FINAL STATE:
21607 if(srt.gt.(xmd+xmeta)) then
21608 pfinal=sqrt((s-(xmd+xmeta)**2)*(s-(xmd-xmeta)**2))/2./srt
21609 if(idxsec.eq.1) then
21610 sbbdeta=fs*pfinal/pinitial*3./16.
21611 elseif(idxsec.eq.2.or.idxsec.eq.4) then
21612 threshold=amax1(xmd+xmeta,em1+em2)
21613 snew=(srt-threshold+srt0)**2
21614 if(idxsec.eq.2) then
21615 sbbdeta=fnndpi(snew)*pfinal/pinitial*3./16.
21616 elseif(idxsec.eq.4) then
21617 sbbdeta=fnndpi(snew)*pfinal/pinitial/6.*(pifactor/3.)
21618 endif
21619 elseif(idxsec.eq.3) then
21620 sbbdeta=fs*pfinal/pinitial/6.*(pifactor/3.)
21621 endif
21622 endif
21623c
21624 sdprod=sbbdpi+sbbdrho+sbbdomega+sbbdeta
21625ctest off
21626c write(99,111) srt,sbbdpi,sbbdrho,sbbdomega,sbbdeta,sdprod
21627c 111 format(6(f8.2,1x))
21628c
21629 if(sdprod.le.0) return
21630c
21631c choose final state and assign masses here:
21632 x1=RANART(NSEED)
21633 if(x1.le.sbbdpi/sdprod) then
21634c use the above-determined lbm and xmm.
21635 elseif(x1.le.(sbbdpi+sbbdrho)/sdprod) then
21636 lbm=25+int(3*RANART(NSEED))
21637 xmm=xmrho
21638 elseif(x1.le.(sbbdpi+sbbdrho+sbbdomega)/sdprod) then
21639 lbm=28
21640 xmm=xmomega
21641 else
21642 lbm=0
21643 xmm=xmeta
21644 endif
21645c
21646 return
21647 end
21648c
21649c Generate angular distribution of Deuteron in the CMS frame:
21650 subroutine bbdangle(pxd,pyd,pzd,nt,ipert1,ianti,idloop,pfinal,
21651 1 dprob1,lbm)
21652 PARAMETER (PI=3.1415926)
21653 common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
21654 1 px1n,py1n,pz1n,dp1n
21655 common /dpi/em2,lb2
21656 COMMON/RNDF77/NSEED
21657 common /para8/ idpert,npertd,idxsec
21658 COMMON /AREVT/ IAEVT, IARUN, MISS
21659 SAVE
21660c take isotropic distribution for now:
21661 C1=1.0-2.0*RANART(NSEED)
21662 T1=2.0*PI*RANART(NSEED)
21663 S1=SQRT(1.0-C1**2)
21664 CT1=COS(T1)
21665 ST1=SIN(T1)
21666* THE MOMENTUM IN THE CMS IN THE FINAL STATE
21667 PZd=pfinal*C1
21668 PXd=pfinal*S1*CT1
21669 PYd=pfinal*S1*ST1
21670clin-5/2008 track the number of produced deuterons:
21671 if(idpert.eq.1.and.npertd.ge.1) then
21672 dprob=dprob1
21673 elseif(idpert.eq.2.and.npertd.ge.1) then
21674 dprob=1./float(npertd)
21675 endif
21676c if(ianti.eq.0) then
21677c if(idpert.eq.0.or.(idpert.eq.1.and.ipert1.eq.0).or.
21678c 1 (idpert.eq.2.and.idloop.eq.(npertd+1))) then
21679c write (91,*) lb1,' *',lb2,' ->d+',lbm,' (regular d prodn)
21680c 1 @evt#',iaevt,' @nt=',nt
21681c elseif((idpert.eq.1.or.idpert.eq.2).and.idloop.eq.npertd) then
21682c write (91,*) lb1,' *',lb2,' ->d+',lbm,' (pert d prodn)
21683c 1 @evt#',iaevt,' @nt=',nt,' @prob=',dprob
21684c endif
21685c else
21686c if(idpert.eq.0.or.(idpert.eq.1.and.ipert1.eq.0).or.
21687c 1 (idpert.eq.2.and.idloop.eq.(npertd+1))) then
21688c write (91,*) lb1,' *',lb2,' ->d+',lbm,' (regular dbar prodn)
21689c 1 @evt#',iaevt,' @nt=',nt
21690c elseif((idpert.eq.1.or.idpert.eq.2).and.idloop.eq.npertd) then
21691c write (91,*) lb1,' *',lb2,' ->d+',lbm,' (pert dbar prodn)
21692c 1 @evt#',iaevt,' @nt=',nt,' @prob=',dprob
21693c endif
21694c endif
21695c
21696 return
21697 end
21698c
21699c Deuteron+Meson->B+B cross section (in mb)
21700 subroutine sdmbb(SRT,sdm,ianti)
21701 PARAMETER (AMN=0.939457,AMP=0.93828,
21702 1 AM0=1.232,AM1440=1.44,AM1535=1.535,srt0=2.012)
21703 common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
21704 1 px1n,py1n,pz1n,dp1n
21705 common /dpi/em2,lb2
21706 common /dpifsl/lbnn1,lbnn2,lbnd1,lbnd2,lbns1,lbns2,lbnp1,lbnp2,
21707 1 lbdd1,lbdd2,lbds1,lbds2,lbdp1,lbdp2,lbss1,lbss2,
21708 2 lbsp1,lbsp2,lbpp1,lbpp2
21709 common /dpifsm/xmnn1,xmnn2,xmnd1,xmnd2,xmns1,xmns2,xmnp1,xmnp2,
21710 1 xmdd1,xmdd2,xmds1,xmds2,xmdp1,xmdp2,xmss1,xmss2,
21711 2 xmsp1,xmsp2,xmpp1,xmpp2
21712 common /dpisig/sdmel,sdmnn,sdmnd,sdmns,sdmnp,sdmdd,sdmds,sdmdp,
21713 1 sdmss,sdmsp,sdmpp
21714 common /para8/ idpert,npertd,idxsec
21715 COMMON/RNDF77/NSEED
21716 SAVE
21717c
21718 sdm=0.
21719 sdmel=0.
21720 sdmnn=0.
21721 sdmnd=0.
21722 sdmns=0.
21723 sdmnp=0.
21724 sdmdd=0.
21725 sdmds=0.
21726 sdmdp=0.
21727 sdmss=0.
21728 sdmsp=0.
21729 sdmpp=0.
21730ctest off check Xsec using fixed mass for resonances:
21731c if(lb1.ge.25.and.lb1.le.27) then
21732c em1=0.776
21733c elseif(lb1.eq.28) then
21734c em1=0.783
21735c elseif(lb1.eq.0) then
21736c em1=0.548
21737c endif
21738c if(lb2.ge.25.and.lb2.le.27) then
21739c em2=0.776
21740c elseif(lb2.eq.28) then
21741c em2=0.783
21742c elseif(lb2.eq.0) then
21743c em2=0.548
21744c endif
21745c
21746 if(srt.le.(em1+em2)) return
21747 s=srt**2
21748 pinitial=sqrt((s-(em1+em2)**2)*(s-(em1-em2)**2))/2./srt
21749 fs=fnndpi(s)
21750c Determine isospin and spin factors for the ratio between
21751c Deuteron+Meson->BB and BB->Deuteron+Meson cross sections:
21752 if(idxsec.eq.1.or.idxsec.eq.2) then
21753c Assume B+B -> d+Meson has the same cross sections as N+N -> d+pi,
21754c then determine d+Meson -> B+B cross sections:
21755 if((lb1.ge.3.and.lb1.le.5).or.
21756 1 (lb2.ge.3.and.lb2.le.5)) then
21757 xnnfactor=8./9.
21758 elseif((lb1.ge.25.and.lb1.le.27).or.
21759 1 (lb2.ge.25.and.lb2.le.27)) then
21760 xnnfactor=8./27.
21761 elseif(lb1.eq.28.or.lb2.eq.28) then
21762 xnnfactor=8./9.
21763 elseif(lb1.eq.0.or.lb2.eq.0) then
21764 xnnfactor=8./3.
21765 endif
21766 else
21767c Assume d+Meson -> B+B has the same cross sections as d+pi -> N+N:
21768 endif
21769clin-9/2008 For elastic collisions:
21770 if(idxsec.eq.1.or.idxsec.eq.3) then
21771c 1/3: assume the same |matrix element|**2 (after averaging over initial
21772c spins and isospins) for d+Meson elastic at the same sqrt(s);
21773 sdmel=fdpiel(s)
21774 elseif(idxsec.eq.2.or.idxsec.eq.4) then
21775c 2/4: assume the same |matrix element|**2 (after averaging over initial
21776c spins and isospins) for d+Meson elastic at the same sqrt(s)-threshold:
21777 threshold=em1+em2
21778 snew=(srt-threshold+srt0)**2
21779 sdmel=fdpiel(snew)
21780 endif
21781c
21782* NN: DETERMINE THE CHARGE STATES OF PARTICLESIN THE FINAL STATE
21783 IF(((lb1.eq.5.or.lb2.eq.5.or.lb1.eq.27.or.lb2.eq.27)
21784 1 .and.ianti.eq.0).or.
21785 2 ((lb1.eq.3.or.lb2.eq.3.or.lb1.eq.25.or.lb2.eq.25)
21786 3 .and.ianti.eq.1))THEN
21787* (1) FOR Deuteron+(pi+,rho+) -> P+P or DeuteronBar+(pi-,rho-)-> PBar+PBar:
21788 lbnn1=1
21789 lbnn2=1
21790 xmnn1=amp
21791 xmnn2=amp
21792 ELSEIF(lb1.eq.3.or.lb2.eq.3.or.lb1.eq.26.or.lb2.eq.26
21793 1 .or.lb1.eq.28.or.lb2.eq.28.or.lb1.eq.0.or.lb2.eq.0)THEN
21794* (2) FOR Deuteron+(pi0,rho0,omega,eta) -> N+P
21795* or DeuteronBar+(pi0,rho0,omega,eta) ->NBar+PBar:
21796 lbnn1=2
21797 lbnn2=1
21798 xmnn1=amn
21799 xmnn2=amp
21800 ELSE
21801* (3) FOR Deuteron+(pi-,rho-) -> N+N or DeuteronBar+(pi+,rho+)-> NBar+NBar:
21802 lbnn1=2
21803 lbnn2=2
21804 xmnn1=amn
21805 xmnn2=amn
21806 ENDIF
21807 if(srt.gt.(xmnn1+xmnn2)) then
21808 pfinal=sqrt((s-(xmnn1+xmnn2)**2)*(s-(xmnn1-xmnn2)**2))/2./srt
21809 if(idxsec.eq.1) then
21810c 1: assume the same |matrix element|**2 (after averaging over initial
21811c spins and isospins) for B+B -> deuteron+meson at the same sqrt(s);
21812 sdmnn=fs*pfinal/pinitial*3./16.*xnnfactor
21813 elseif(idxsec.eq.2.or.idxsec.eq.4) then
21814 threshold=amax1(xmnn1+xmnn2,em1+em2)
21815 snew=(srt-threshold+srt0)**2
21816 if(idxsec.eq.2) then
21817c 2: assume the same |matrix element|**2 for B+B -> deuteron+meson
21818c at the same sqrt(s)-threshold:
21819 sdmnn=fnndpi(snew)*pfinal/pinitial*3./16.*xnnfactor
21820 elseif(idxsec.eq.4) then
21821c 4: assume the same |matrix element|**2 for B+B <- deuteron+meson
21822c at the same sqrt(s)-threshold:
21823 sdmnn=fnndpi(snew)*pfinal/pinitial/6.
21824 endif
21825 elseif(idxsec.eq.3) then
21826c 3: assume the same |matrix element|**2 for B+B <- deuteron+meson
21827c at the same sqrt(s):
21828 sdmnn=fs*pfinal/pinitial/6.
21829 endif
21830 endif
21831c
21832* ND: DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
21833 lbnd1=1+int(2*RANART(NSEED))
21834 lbnd2=6+int(4*RANART(NSEED))
21835 if(lbnd1.eq.1) then
21836 xmnd1=amp
21837 elseif(lbnd1.eq.2) then
21838 xmnd1=amn
21839 endif
21840 xmnd2=am0
21841 if(srt.gt.(xmnd1+xmnd2)) then
21842 pfinal=sqrt((s-(xmnd1+xmnd2)**2)*(s-(xmnd1-xmnd2)**2))/2./srt
21843 if(idxsec.eq.1) then
21844c The spin- and isospin-averaged factor is 8-times larger for ND:
21845 sdmnd=fs*pfinal/pinitial*3./16.*(xnnfactor*8.)
21846 elseif(idxsec.eq.2.or.idxsec.eq.4) then
21847 threshold=amax1(xmnd1+xmnd2,em1+em2)
21848 snew=(srt-threshold+srt0)**2
21849 if(idxsec.eq.2) then
21850 sdmnd=fnndpi(snew)*pfinal/pinitial*3./16.*(xnnfactor*8.)
21851 elseif(idxsec.eq.4) then
21852 sdmnd=fnndpi(snew)*pfinal/pinitial/6.
21853 endif
21854 elseif(idxsec.eq.3) then
21855 sdmnd=fs*pfinal/pinitial/6.
21856 endif
21857 endif
21858c
21859* NS: DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
21860 lbns1=1+int(2*RANART(NSEED))
21861 lbns2=10+int(2*RANART(NSEED))
21862 if(lbns1.eq.1) then
21863 xmns1=amp
21864 elseif(lbns1.eq.2) then
21865 xmns1=amn
21866 endif
21867 xmns2=am1440
21868 if(srt.gt.(xmns1+xmns2)) then
21869 pfinal=sqrt((s-(xmns1+xmns2)**2)*(s-(xmns1-xmns2)**2))/2./srt
21870 if(idxsec.eq.1) then
21871 sdmns=fs*pfinal/pinitial*3./16.*(xnnfactor*2.)
21872 elseif(idxsec.eq.2.or.idxsec.eq.4) then
21873 threshold=amax1(xmns1+xmns2,em1+em2)
21874 snew=(srt-threshold+srt0)**2
21875 if(idxsec.eq.2) then
21876 sdmns=fnndpi(snew)*pfinal/pinitial*3./16.*(xnnfactor*2.)
21877 elseif(idxsec.eq.4) then
21878 sdmns=fnndpi(snew)*pfinal/pinitial/6.
21879 endif
21880 elseif(idxsec.eq.3) then
21881 sdmns=fs*pfinal/pinitial/6.
21882 endif
21883 endif
21884c
21885* NP: DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
21886 lbnp1=1+int(2*RANART(NSEED))
21887 lbnp2=12+int(2*RANART(NSEED))
21888 if(lbnp1.eq.1) then
21889 xmnp1=amp
21890 elseif(lbnp1.eq.2) then
21891 xmnp1=amn
21892 endif
21893 xmnp2=am1535
21894 if(srt.gt.(xmnp1+xmnp2)) then
21895 pfinal=sqrt((s-(xmnp1+xmnp2)**2)*(s-(xmnp1-xmnp2)**2))/2./srt
21896 if(idxsec.eq.1) then
21897 sdmnp=fs*pfinal/pinitial*3./16.*(xnnfactor*2.)
21898 elseif(idxsec.eq.2.or.idxsec.eq.4) then
21899 threshold=amax1(xmnp1+xmnp2,em1+em2)
21900 snew=(srt-threshold+srt0)**2
21901 if(idxsec.eq.2) then
21902 sdmnp=fnndpi(snew)*pfinal/pinitial*3./16.*(xnnfactor*2.)
21903 elseif(idxsec.eq.4) then
21904 sdmnp=fnndpi(snew)*pfinal/pinitial/6.
21905 endif
21906 elseif(idxsec.eq.3) then
21907 sdmnp=fs*pfinal/pinitial/6.
21908 endif
21909 endif
21910c
21911* DD: DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
21912 lbdd1=6+int(4*RANART(NSEED))
21913 lbdd2=6+int(4*RANART(NSEED))
21914 xmdd1=am0
21915 xmdd2=am0
21916 if(srt.gt.(xmdd1+xmdd2)) then
21917 pfinal=sqrt((s-(xmdd1+xmdd2)**2)*(s-(xmdd1-xmdd2)**2))/2./srt
21918 if(idxsec.eq.1) then
21919 sdmdd=fs*pfinal/pinitial*3./16.*(xnnfactor*16.)
21920 elseif(idxsec.eq.2.or.idxsec.eq.4) then
21921 threshold=amax1(xmdd1+xmdd2,em1+em2)
21922 snew=(srt-threshold+srt0)**2
21923 if(idxsec.eq.2) then
21924 sdmdd=fnndpi(snew)*pfinal/pinitial*3./16.*(xnnfactor*16.)
21925 elseif(idxsec.eq.4) then
21926 sdmdd=fnndpi(snew)*pfinal/pinitial/6.
21927 endif
21928 elseif(idxsec.eq.3) then
21929 sdmdd=fs*pfinal/pinitial/6.
21930 endif
21931 endif
21932c
21933* DS: DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
21934 lbds1=6+int(4*RANART(NSEED))
21935 lbds2=10+int(2*RANART(NSEED))
21936 xmds1=am0
21937 xmds2=am1440
21938 if(srt.gt.(xmds1+xmds2)) then
21939 pfinal=sqrt((s-(xmds1+xmds2)**2)*(s-(xmds1-xmds2)**2))/2./srt
21940 if(idxsec.eq.1) then
21941 sdmds=fs*pfinal/pinitial*3./16.*(xnnfactor*8.)
21942 elseif(idxsec.eq.2.or.idxsec.eq.4) then
21943 threshold=amax1(xmds1+xmds2,em1+em2)
21944 snew=(srt-threshold+srt0)**2
21945 if(idxsec.eq.2) then
21946 sdmds=fnndpi(snew)*pfinal/pinitial*3./16.*(xnnfactor*8.)
21947 elseif(idxsec.eq.4) then
21948 sdmds=fnndpi(snew)*pfinal/pinitial/6.
21949 endif
21950 elseif(idxsec.eq.3) then
21951 sdmds=fs*pfinal/pinitial/6.
21952 endif
21953 endif
21954c
21955* DP: DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
21956 lbdp1=6+int(4*RANART(NSEED))
21957 lbdp2=12+int(2*RANART(NSEED))
21958 xmdp1=am0
21959 xmdp2=am1535
21960 if(srt.gt.(xmdp1+xmdp2)) then
21961 pfinal=sqrt((s-(xmdp1+xmdp2)**2)*(s-(xmdp1-xmdp2)**2))/2./srt
21962 if(idxsec.eq.1) then
21963 sdmdp=fs*pfinal/pinitial*3./16.*(xnnfactor*8.)
21964 elseif(idxsec.eq.2.or.idxsec.eq.4) then
21965 threshold=amax1(xmdp1+xmdp2,em1+em2)
21966 snew=(srt-threshold+srt0)**2
21967 if(idxsec.eq.2) then
21968 sdmdp=fnndpi(snew)*pfinal/pinitial*3./16.*(xnnfactor*8.)
21969 elseif(idxsec.eq.4) then
21970 sdmdp=fnndpi(snew)*pfinal/pinitial/6.
21971 endif
21972 elseif(idxsec.eq.3) then
21973 sdmdp=fs*pfinal/pinitial/6.
21974 endif
21975 endif
21976c
21977* SS: DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
21978 lbss1=10+int(2*RANART(NSEED))
21979 lbss2=10+int(2*RANART(NSEED))
21980 xmss1=am1440
21981 xmss2=am1440
21982 if(srt.gt.(xmss1+xmss2)) then
21983 pfinal=sqrt((s-(xmss1+xmss2)**2)*(s-(xmss1-xmss2)**2))/2./srt
21984 if(idxsec.eq.1) then
21985 sdmss=fs*pfinal/pinitial*3./16.*xnnfactor
21986 elseif(idxsec.eq.2.or.idxsec.eq.4) then
21987 threshold=amax1(xmss1+xmss2,em1+em2)
21988 snew=(srt-threshold+srt0)**2
21989 if(idxsec.eq.2) then
21990 sdmss=fnndpi(snew)*pfinal/pinitial*3./16.*xnnfactor
21991 elseif(idxsec.eq.4) then
21992 sdmss=fnndpi(snew)*pfinal/pinitial/6.
21993 endif
21994 elseif(idxsec.eq.3) then
21995 sdmns=fs*pfinal/pinitial/6.
21996 endif
21997 endif
21998c
21999* SP: DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
22000 lbsp1=10+int(2*RANART(NSEED))
22001 lbsp2=12+int(2*RANART(NSEED))
22002 xmsp1=am1440
22003 xmsp2=am1535
22004 if(srt.gt.(xmsp1+xmsp2)) then
22005 pfinal=sqrt((s-(xmsp1+xmsp2)**2)*(s-(xmsp1-xmsp2)**2))/2./srt
22006 if(idxsec.eq.1) then
22007 sdmsp=fs*pfinal/pinitial*3./16.*(xnnfactor*2.)
22008 elseif(idxsec.eq.2.or.idxsec.eq.4) then
22009 threshold=amax1(xmsp1+xmsp2,em1+em2)
22010 snew=(srt-threshold+srt0)**2
22011 if(idxsec.eq.2) then
22012 sdmsp=fnndpi(snew)*pfinal/pinitial*3./16.*(xnnfactor*2.)
22013 elseif(idxsec.eq.4) then
22014 sdmsp=fnndpi(snew)*pfinal/pinitial/6.
22015 endif
22016 elseif(idxsec.eq.3) then
22017 sdmsp=fs*pfinal/pinitial/6.
22018 endif
22019 endif
22020c
22021* PP: DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
22022 lbpp1=12+int(2*RANART(NSEED))
22023 lbpp2=12+int(2*RANART(NSEED))
22024 xmpp1=am1535
22025 xmpp2=am1535
22026 if(srt.gt.(xmpp1+xmpp2)) then
22027 pfinal=sqrt((s-(xmpp1+xmpp2)**2)*(s-(xmpp1-xmpp2)**2))/2./srt
22028 if(idxsec.eq.1) then
22029 sdmpp=fs*pfinal/pinitial*3./16.*xnnfactor
22030 elseif(idxsec.eq.2.or.idxsec.eq.4) then
22031 threshold=amax1(xmpp1+xmpp2,em1+em2)
22032 snew=(srt-threshold+srt0)**2
22033 if(idxsec.eq.2) then
22034 sdmpp=fnndpi(snew)*pfinal/pinitial*3./16.*xnnfactor
22035 elseif(idxsec.eq.4) then
22036 sdmpp=fnndpi(snew)*pfinal/pinitial/6.
22037 endif
22038 elseif(idxsec.eq.3) then
22039 sdmpp=fs*pfinal/pinitial/6.
22040 endif
22041 endif
22042c
22043 sdm=sdmel+sdmnn+sdmnd+sdmns+sdmnp+sdmdd+sdmds+sdmdp
22044 1 +sdmss+sdmsp+sdmpp
22045 if(ianti.eq.1) then
22046 lbnn1=-lbnn1
22047 lbnn2=-lbnn2
22048 lbnd1=-lbnd1
22049 lbnd2=-lbnd2
22050 lbns1=-lbns1
22051 lbns2=-lbns2
22052 lbnp1=-lbnp1
22053 lbnp2=-lbnp2
22054 lbdd1=-lbdd1
22055 lbdd2=-lbdd2
22056 lbds1=-lbds1
22057 lbds2=-lbds2
22058 lbdp1=-lbdp1
22059 lbdp2=-lbdp2
22060 lbss1=-lbss1
22061 lbss2=-lbss2
22062 lbsp1=-lbsp1
22063 lbsp2=-lbsp2
22064 lbpp1=-lbpp1
22065 lbpp2=-lbpp2
22066 endif
22067ctest off
22068c write(98,100) srt,sdmnn,sdmnd,sdmns,sdmnp,sdmdd,sdmds,sdmdp,
22069c 1 sdmss,sdmsp,sdmpp,sdm
22070c 100 format(f5.2,11(1x,f5.1))
22071c
22072 return
22073 end
22074c
22075clin-9/2008 Deuteron+Meson ->B+B and elastic collisions
22076 SUBROUTINE crdmbb(PX,PY,PZ,SRT,I1,I2,IBLOCK,
22077 1 NTAG,sig,NT,ianti)
22078 PARAMETER (MAXSTR=150001,MAXR=1)
22079 COMMON /AA/R(3,MAXSTR)
22080 COMMON /BB/ P(3,MAXSTR)
22081 COMMON /BG/BETAX,BETAY,BETAZ,GAMMA
22082 COMMON /CC/ E(MAXSTR)
22083 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
22084 COMMON /AREVT/ IAEVT, IARUN, MISS
22085 common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
22086 1 px1n,py1n,pz1n,dp1n
22087 common /dpi/em2,lb2
22088 common /para8/ idpert,npertd,idxsec
22089 COMMON /dpert/dpertt(MAXSTR,MAXR),dpertp(MAXSTR),dplast(MAXSTR),
22090 1 dpdcy(MAXSTR),dpdpi(MAXSTR,MAXR),dpt(MAXSTR, MAXR),
22091 2 dpp1(MAXSTR,MAXR),dppion(MAXSTR,MAXR)
22092 common /dpifsl/lbnn1,lbnn2,lbnd1,lbnd2,lbns1,lbns2,lbnp1,lbnp2,
22093 1 lbdd1,lbdd2,lbds1,lbds2,lbdp1,lbdp2,lbss1,lbss2,
22094 2 lbsp1,lbsp2,lbpp1,lbpp2
22095 common /dpifsm/xmnn1,xmnn2,xmnd1,xmnd2,xmns1,xmns2,xmnp1,xmnp2,
22096 1 xmdd1,xmdd2,xmds1,xmds2,xmdp1,xmdp2,xmss1,xmss2,
22097 2 xmsp1,xmsp2,xmpp1,xmpp2
22098 common /dpisig/sdmel,sdmnn,sdmnd,sdmns,sdmnp,sdmdd,sdmds,sdmdp,
22099 1 sdmss,sdmsp,sdmpp
22100 COMMON/RNDF77/NSEED
22101 SAVE
22102*-----------------------------------------------------------------------
22103 IBLOCK=0
22104 NTAG=0
22105 EM1=E(I1)
22106 EM2=E(I2)
22107 s=srt**2
22108 if(sig.le.0) return
22109c
22110 if(iabs(lb1).eq.42) then
22111 ideut=i1
22112 lbm=lb2
22113 idm=i2
22114 else
22115 ideut=i2
22116 lbm=lb1
22117 idm=i1
22118 endif
22119cccc Elastic collision or destruction of perturbatively-produced deuterons:
22120 if((idpert.eq.1.or.idpert.eq.2).and.dpertp(ideut).ne.1.) then
22121c choose reaction channels:
22122 x1=RANART(NSEED)
22123 if(x1.le.sdmel/sig)then
22124c Elastic collisions:
22125c if(ianti.eq.0) then
22126c write(91,*) ' d+',lbm,' (pert d M elastic) @nt=',nt
22127c 1 ,' @prob=',dpertp(ideut)
22128c else
22129c write(91,*) ' d+',lbm,' (pert dbar M elastic) @nt=',nt
22130c 1 ,' @prob=',dpertp(ideut)
22131c endif
22132 pfinal=sqrt((s-(em1+em2)**2)*(s-(em1-em2)**2))/2./srt
22133 CALL dmelangle(pxn,pyn,pzn,pfinal)
22134 CALL ROTATE(PX,PY,PZ,Pxn,Pyn,Pzn)
22135 EdCM=SQRT(E(ideut)**2+Pxn**2+Pyn**2+Pzn**2)
22136 PdBETA=Pxn*BETAX+Pyn*BETAY+Pzn*BETAZ
22137 TRANSF=GAMMA*(GAMMA*PdBETA/(GAMMA+1.)+EdCM)
22138 Pt1d=BETAX*TRANSF+Pxn
22139 Pt2d=BETAY*TRANSF+Pyn
22140 Pt3d=BETAZ*TRANSF+Pzn
22141 p(1,ideut)=pt1d
22142 p(2,ideut)=pt2d
22143 p(3,ideut)=pt3d
22144 IBLOCK=504
22145 PX1=P(1,I1)
22146 PY1=P(2,I1)
22147 PZ1=P(3,I1)
22148 ID(I1)=2
22149 ID(I2)=2
22150c Change the position of the perturbative deuteron to that of
22151c the meson to avoid consecutive collisions between them:
22152 R(1,ideut)=R(1,idm)
22153 R(2,ideut)=R(2,idm)
22154 R(3,ideut)=R(3,idm)
22155 else
22156c Destruction of deuterons:
22157c if(ianti.eq.0) then
22158c write(91,*) ' d+',lbm,' ->BB (pert d destrn) @nt=',nt
22159c 1 ,' @prob=',dpertp(ideut)
22160c else
22161c write(91,*) ' d+',lbm,' ->BB (pert dbar destrn) @nt=',nt
22162c 1 ,' @prob=',dpertp(ideut)
22163c endif
22164 e(ideut)=0.
22165 IBLOCK=502
22166 endif
22167 return
22168 endif
22169c
22170cccc Destruction of regularly-produced deuterons:
22171 IBLOCK=502
22172c choose final state and assign masses here:
22173 x1=RANART(NSEED)
22174 if(x1.le.sdmnn/sig)then
22175 lbb1=lbnn1
22176 lbb2=lbnn2
22177 xmb1=xmnn1
22178 xmb2=xmnn2
22179 elseif(x1.le.(sdmnn+sdmnd)/sig)then
22180 lbb1=lbnd1
22181 lbb2=lbnd2
22182 xmb1=xmnd1
22183 xmb2=xmnd2
22184 elseif(x1.le.(sdmnn+sdmnd+sdmns)/sig)then
22185 lbb1=lbns1
22186 lbb2=lbns2
22187 xmb1=xmns1
22188 xmb2=xmns2
22189 elseif(x1.le.(sdmnn+sdmnd+sdmns+sdmnp)/sig)then
22190 lbb1=lbnp1
22191 lbb2=lbnp2
22192 xmb1=xmnp1
22193 xmb2=xmnp2
22194 elseif(x1.le.(sdmnn+sdmnd+sdmns+sdmnp+sdmdd)/sig)then
22195 lbb1=lbdd1
22196 lbb2=lbdd2
22197 xmb1=xmdd1
22198 xmb2=xmdd2
22199 elseif(x1.le.(sdmnn+sdmnd+sdmns+sdmnp+sdmdd+sdmds)/sig)then
22200 lbb1=lbds1
22201 lbb2=lbds2
22202 xmb1=xmds1
22203 xmb2=xmds2
22204 elseif(x1.le.(sdmnn+sdmnd+sdmns+sdmnp+sdmdd+sdmds+sdmdp)/sig)then
22205 lbb1=lbdp1
22206 lbb2=lbdp2
22207 xmb1=xmdp1
22208 xmb2=xmdp2
22209 elseif(x1.le.(sdmnn+sdmnd+sdmns+sdmnp+sdmdd+sdmds+sdmdp
22210 1 +sdmss)/sig)then
22211 lbb1=lbss1
22212 lbb2=lbss2
22213 xmb1=xmss1
22214 xmb2=xmss2
22215 elseif(x1.le.(sdmnn+sdmnd+sdmns+sdmnp+sdmdd+sdmds+sdmdp
22216 1 +sdmss+sdmsp)/sig)then
22217 lbb1=lbsp1
22218 lbb2=lbsp2
22219 xmb1=xmsp1
22220 xmb2=xmsp2
22221 elseif(x1.le.(sdmnn+sdmnd+sdmns+sdmnp+sdmdd+sdmds+sdmdp
22222 1 +sdmss+sdmsp+sdmpp)/sig)then
22223 lbb1=lbpp1
22224 lbb2=lbpp2
22225 xmb1=xmpp1
22226 xmb2=xmpp2
22227 else
22228c Elastic collision:
22229 lbb1=lb1
22230 lbb2=lb2
22231 xmb1=em1
22232 xmb2=em2
22233 IBLOCK=504
22234 endif
22235 LB(I1)=lbb1
22236 E(i1)=xmb1
22237 LB(I2)=lbb2
22238 E(I2)=xmb2
22239 lb1=lb(i1)
22240 lb2=lb(i2)
22241 pfinal=sqrt((s-(xmb1+xmb2)**2)*(s-(xmb1-xmb2)**2))/2./srt
22242c
22243 if(iblock.eq.502) then
22244 CALL dmangle(pxn,pyn,pzn,nt,ianti,pfinal,lbm)
22245 elseif(iblock.eq.504) then
22246c if(ianti.eq.0) then
22247c write (91,*) ' d+',lbm,' (regular d M elastic) @evt#',
22248c 1 iaevt,' @nt=',nt,' lb1,2=',lb1,lb2
22249c else
22250c write (91,*) ' d+',lbm,' (regular dbar M elastic) @evt#',
22251c 1 iaevt,' @nt=',nt,' lb1,2=',lb1,lb2
22252c endif
22253 CALL dmelangle(pxn,pyn,pzn,pfinal)
22254 else
22255 print *, 'Wrong iblock number in crdmbb()'
22256 stop
22257 endif
22258* ROTATE THE MOMENTA OF PARTICLES IN THE CMS OF P1+P2
22259c (This is not needed for isotropic distributions)
22260 CALL ROTATE(PX,PY,PZ,Pxn,Pyn,Pzn)
22261* LORENTZ-TRANSFORMATION OF THE MOMENTUM OF PARTICLES IN THE FINAL STATE
22262* FROM THE NUCLEUS-NUCLEUS CMS. FRAME INTO LAB FRAME:
22263* For the 1st baryon:
22264 E1CM=SQRT(E(I1)**2+Pxn**2+Pyn**2+Pzn**2)
22265 P1BETA=Pxn*BETAX+Pyn*BETAY+Pzn*BETAZ
22266 TRANSF=GAMMA*(GAMMA*P1BETA/(GAMMA+1.)+E1CM)
22267 Pt1i1=BETAX*TRANSF+Pxn
22268 Pt2i1=BETAY*TRANSF+Pyn
22269 Pt3i1=BETAZ*TRANSF+Pzn
22270c
22271 p(1,i1)=pt1i1
22272 p(2,i1)=pt2i1
22273 p(3,i1)=pt3i1
22274* For the 2nd baryon:
22275 E2CM=SQRT(E(I2)**2+Pxn**2+Pyn**2+Pzn**2)
22276 P2BETA=-Pxn*BETAX-Pyn*BETAY-Pzn*BETAZ
22277 TRANSF=GAMMA*(GAMMA*P2BETA/(GAMMA+1.)+E2CM)
22278 Pt1I2=BETAX*TRANSF-Pxn
22279 Pt2I2=BETAY*TRANSF-Pyn
22280 Pt3I2=BETAZ*TRANSF-Pzn
22281c
22282 p(1,i2)=pt1i2
22283 p(2,i2)=pt2i2
22284 p(3,i2)=pt3i2
22285c
22286 PX1=P(1,I1)
22287 PY1=P(2,I1)
22288 PZ1=P(3,I1)
22289 EM1=E(I1)
22290 EM2=E(I2)
22291 ID(I1)=2
22292 ID(I2)=2
22293 RETURN
22294 END
22295c
22296c Generate angular distribution of BB from d+meson in the CMS frame:
22297 subroutine dmangle(pxn,pyn,pzn,nt,ianti,pfinal,lbm)
22298 PARAMETER (PI=3.1415926)
22299 common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
22300 1 px1n,py1n,pz1n,dp1n
22301 common /dpi/em2,lb2
22302 COMMON /AREVT/ IAEVT, IARUN, MISS
22303 COMMON/RNDF77/NSEED
22304 SAVE
22305c take isotropic distribution for now:
22306 C1=1.0-2.0*RANART(NSEED)
22307 T1=2.0*PI*RANART(NSEED)
22308 S1=SQRT(1.0-C1**2)
22309 CT1=COS(T1)
22310 ST1=SIN(T1)
22311* THE MOMENTUM IN THE CMS IN THE FINAL STATE
22312 Pzn=pfinal*C1
22313 Pxn=pfinal*S1*CT1
22314 Pyn=pfinal*S1*ST1
22315clin-5/2008 track the number of regularly-destructed deuterons:
22316c if(ianti.eq.0) then
22317c write (91,*) ' d+',lbm,' ->BB (regular d destrn) @evt#',
22318c 1 iaevt,' @nt=',nt,' lb1,2=',lb1,lb2
22319c else
22320c write (91,*) ' d+',lbm,' ->BB (regular dbar destrn) @evt#',
22321c 1 iaevt,' @nt=',nt,' lb1,2=',lb1,lb2
22322c endif
22323c
22324 return
22325 end
22326c
22327c Angular distribution of d+meson elastic collisions in the CMS frame:
22328 subroutine dmelangle(pxn,pyn,pzn,pfinal)
22329 PARAMETER (PI=3.1415926)
22330 COMMON/RNDF77/NSEED
22331 SAVE
22332c take isotropic distribution for now:
22333 C1=1.0-2.0*RANART(NSEED)
22334 T1=2.0*PI*RANART(NSEED)
22335 S1=SQRT(1.0-C1**2)
22336 CT1=COS(T1)
22337 ST1=SIN(T1)
22338* THE MOMENTUM IN THE CMS IN THE FINAL STATE
22339 Pzn=pfinal*C1
22340 Pxn=pfinal*S1*CT1
22341 Pyn=pfinal*S1*ST1
22342 return
22343 end
22344c
22345clin-9/2008 Deuteron+Baryon elastic cross section (in mb)
22346 subroutine sdbelastic(SRT,sdb)
22347 PARAMETER (srt0=2.012)
22348 common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
22349 1 px1n,py1n,pz1n,dp1n
22350 common /dpi/em2,lb2
22351 common /para8/ idpert,npertd,idxsec
22352 SAVE
22353c
22354 sdb=0.
22355 sdbel=0.
22356 if(srt.le.(em1+em2)) return
22357 s=srt**2
22358c For elastic collisions:
22359 if(idxsec.eq.1.or.idxsec.eq.3) then
22360c 1/3: assume the same |matrix element|**2 (after averaging over initial
22361c spins and isospins) for d+Baryon elastic at the same sqrt(s);
22362 sdbel=fdbel(s)
22363 elseif(idxsec.eq.2.or.idxsec.eq.4) then
22364c 2/4: assume the same |matrix element|**2 (after averaging over initial
22365c spins and isospins) for d+Baryon elastic at the same sqrt(s)-threshold:
22366 threshold=em1+em2
22367 snew=(srt-threshold+srt0)**2
22368 sdbel=fdbel(snew)
22369 endif
22370 sdb=sdbel
22371 return
22372 end
22373clin-9/2008 Deuteron+Baryon elastic collisions
22374 SUBROUTINE crdbel(PX,PY,PZ,SRT,I1,I2,IBLOCK,
22375 1 NTAG,sig,NT,ianti)
22376 PARAMETER (MAXSTR=150001,MAXR=1)
22377 COMMON /AA/R(3,MAXSTR)
22378 COMMON /BB/ P(3,MAXSTR)
22379 COMMON /BG/BETAX,BETAY,BETAZ,GAMMA
22380 COMMON /CC/ E(MAXSTR)
22381 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
22382 COMMON /AREVT/ IAEVT, IARUN, MISS
22383 common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
22384 1 px1n,py1n,pz1n,dp1n
22385 common /dpi/em2,lb2
22386 common /para8/ idpert,npertd,idxsec
22387 COMMON /dpert/dpertt(MAXSTR,MAXR),dpertp(MAXSTR),dplast(MAXSTR),
22388 1 dpdcy(MAXSTR),dpdpi(MAXSTR,MAXR),dpt(MAXSTR, MAXR),
22389 2 dpp1(MAXSTR,MAXR),dppion(MAXSTR,MAXR)
22390 SAVE
22391*-----------------------------------------------------------------------
22392 IBLOCK=0
22393 NTAG=0
22394 EM1=E(I1)
22395 EM2=E(I2)
22396 s=srt**2
22397 if(sig.le.0) return
22398 IBLOCK=503
22399c
22400 if(iabs(lb1).eq.42) then
22401 ideut=i1
22402 lbb=lb2
22403 idb=i2
22404 else
22405 ideut=i2
22406 lbb=lb1
22407 idb=i1
22408 endif
22409cccc Elastic collision of perturbatively-produced deuterons:
22410 if((idpert.eq.1.or.idpert.eq.2).and.dpertp(ideut).ne.1.) then
22411c if(ianti.eq.0) then
22412c write(91,*) ' d+',lbb,' (pert d B elastic) @nt=',nt
22413c 1 ,' @prob=',dpertp(ideut),p(1,idb),p(2,idb)
22414c 2 ,p(1,ideut),p(2,ideut)
22415c else
22416c write(91,*) ' d+',lbb,' (pert dbar Bbar elastic) @nt=',nt
22417c 1 ,' @prob=',dpertp(ideut),p(1,idb),p(2,idb)
22418c 2 ,p(1,ideut),p(2,ideut)
22419c endif
22420 pfinal=sqrt((s-(em1+em2)**2)*(s-(em1-em2)**2))/2./srt
22421 CALL dbelangle(pxn,pyn,pzn,pfinal)
22422 CALL ROTATE(PX,PY,PZ,Pxn,Pyn,Pzn)
22423 EdCM=SQRT(E(ideut)**2+Pxn**2+Pyn**2+Pzn**2)
22424 PdBETA=Pxn*BETAX+Pyn*BETAY+Pzn*BETAZ
22425 TRANSF=GAMMA*(GAMMA*PdBETA/(GAMMA+1.)+EdCM)
22426 Pt1d=BETAX*TRANSF+Pxn
22427 Pt2d=BETAY*TRANSF+Pyn
22428 Pt3d=BETAZ*TRANSF+Pzn
22429 p(1,ideut)=pt1d
22430 p(2,ideut)=pt2d
22431 p(3,ideut)=pt3d
22432 PX1=P(1,I1)
22433 PY1=P(2,I1)
22434 PZ1=P(3,I1)
22435 ID(I1)=2
22436 ID(I2)=2
22437c Change the position of the perturbative deuteron to that of
22438c the baryon to avoid consecutive collisions between them:
22439 R(1,ideut)=R(1,idb)
22440 R(2,ideut)=R(2,idb)
22441 R(3,ideut)=R(3,idb)
22442 return
22443 endif
22444c
22445c Elastic collision of regularly-produced deuterons:
22446c if(ianti.eq.0) then
22447c write (91,*) ' d+',lbb,' (regular d B elastic) @evt#',
22448c 1 iaevt,' @nt=',nt,' lb1,2=',lb1,lb2
22449c else
22450c write (91,*) ' d+',lbb,' (regular dbar Bbar elastic) @evt#',
22451c 1 iaevt,' @nt=',nt,' lb1,2=',lb1,lb2
22452c endif
22453 pfinal=sqrt((s-(em1+em2)**2)*(s-(em1-em2)**2))/2./srt
22454 CALL dbelangle(pxn,pyn,pzn,pfinal)
22455* ROTATE THE MOMENTA OF PARTICLES IN THE CMS OF P1+P2
22456c (This is not needed for isotropic distributions)
22457 CALL ROTATE(PX,PY,PZ,Pxn,Pyn,Pzn)
22458* LORENTZ-TRANSFORMATION OF THE MOMENTUM OF PARTICLES IN THE FINAL STATE
22459* FROM THE NUCLEUS-NUCLEUS CMS. FRAME INTO LAB FRAME:
22460* For the 1st baryon:
22461 E1CM=SQRT(E(I1)**2+Pxn**2+Pyn**2+Pzn**2)
22462 P1BETA=Pxn*BETAX+Pyn*BETAY+Pzn*BETAZ
22463 TRANSF=GAMMA*(GAMMA*P1BETA/(GAMMA+1.)+E1CM)
22464 Pt1i1=BETAX*TRANSF+Pxn
22465 Pt2i1=BETAY*TRANSF+Pyn
22466 Pt3i1=BETAZ*TRANSF+Pzn
22467c
22468 p(1,i1)=pt1i1
22469 p(2,i1)=pt2i1
22470 p(3,i1)=pt3i1
22471* For the 2nd baryon:
22472 E2CM=SQRT(E(I2)**2+Pxn**2+Pyn**2+Pzn**2)
22473 P2BETA=-Pxn*BETAX-Pyn*BETAY-Pzn*BETAZ
22474 TRANSF=GAMMA*(GAMMA*P2BETA/(GAMMA+1.)+E2CM)
22475 Pt1I2=BETAX*TRANSF-Pxn
22476 Pt2I2=BETAY*TRANSF-Pyn
22477 Pt3I2=BETAZ*TRANSF-Pzn
22478c
22479 p(1,i2)=pt1i2
22480 p(2,i2)=pt2i2
22481 p(3,i2)=pt3i2
22482c
22483 PX1=P(1,I1)
22484 PY1=P(2,I1)
22485 PZ1=P(3,I1)
22486 EM1=E(I1)
22487 EM2=E(I2)
22488 ID(I1)=2
22489 ID(I2)=2
22490 RETURN
22491 END
22492c
22493c Part of the cross section function of NN->Deuteron+Pi (in mb):
22494 function fnndpi(s)
22495 parameter(srt0=2.012)
22496 if(s.le.srt0**2) then
22497 fnndpi=0.
22498 else
22499 fnndpi=26.*exp(-(s-4.65)**2/0.1)+4.*exp(-(s-4.65)**2/2.)
22500 1 +0.28*exp(-(s-6.)**2/10.)
22501 endif
22502 return
22503 end
22504c
22505c Angular distribution of d+baryon elastic collisions in the CMS frame:
22506 subroutine dbelangle(pxn,pyn,pzn,pfinal)
22507 PARAMETER (PI=3.1415926)
22508 COMMON/RNDF77/NSEED
22509 SAVE
22510c take isotropic distribution for now:
22511 C1=1.0-2.0*RANART(NSEED)
22512 T1=2.0*PI*RANART(NSEED)
22513 S1=SQRT(1.0-C1**2)
22514 CT1=COS(T1)
22515 ST1=SIN(T1)
22516* THE MOMENTUM IN THE CMS IN THE FINAL STATE
22517 Pzn=pfinal*C1
22518 Pxn=pfinal*S1*CT1
22519 Pyn=pfinal*S1*ST1
22520 return
22521 end
22522c
22523c Cross section of Deuteron+Pi elastic (in mb):
22524 function fdpiel(s)
22525 parameter(srt0=2.012)
22526 if(s.le.srt0**2) then
22527 fdpiel=0.
22528 else
22529 fdpiel=63.*exp(-(s-4.67)**2/0.15)+15.*exp(-(s-6.25)**2/0.3)
22530 endif
22531 return
22532 end
22533c
22534c Cross section of Deuteron+N elastic (in mb):
22535 function fdbel(s)
22536 parameter(srt0=2.012)
22537 if(s.le.srt0**2) then
22538 fdbel=0.
22539 else
22540 fdbel=2500.*exp(-(s-7.93)**2/0.003)
22541 1 +300.*exp(-(s-7.93)**2/0.1)+10.
22542 endif
22543 return
22544 end