]> 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
Additional renames
[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.
1831 else
1832 T0=0.19733/WID
1833 GFACTR=E1/EM1
1834 T0=T0*GFACTR
1835 IF(T0.GT.0.)THEN
1836 PDECAY=1.-EXP(-DT/T0)
1837 ELSE
1838 PDECAY=0.
1839 ENDIF
1840 endif
1841 XDECAY=RANART(NSEED)
1842
1843cc dilepton production from rho0, omega, phi decay
1844cc if(lb1.eq.26 .or. lb1.eq.28 .or. lb1.eq.29)
1845cc & call dec_ceres(nt,ntmax,irun,i1)
1846cc
1847 IF(XDECAY.LT.PDECAY) THEN
1848clin-10/25/02 get rid of argument usage mismatch in rhocay():
1849 idecay=irun
1850 tfnl=nt*dt
1851clin-10/28/03 keep formation time of hadrons unformed at nt=ntmax-1:
1852 if(nt.eq.ntmax.and.ftsv(i1).gt.((ntmax-1)*dt))
1853 1 tfnl=ftsv(i1)
1854 xfnl=x1
1855 yfnl=y1
1856 zfnl=z1
1857* use PYTHIA to perform decays of eta,rho,omega,phi,K*,(K0s) and Delta:
1858 if(lb1.eq.0.or.lb1.eq.25.or.lb1.eq.26.or.lb1.eq.27
1859 & .or.lb1.eq.28.or.lb1.eq.29.or.iabs(lb1).eq.30
1860 & .or.(iabs(lb1).ge.6.and.iabs(lb1).le.9)
1861 & .or.(iksdcy.eq.1.and.lb1.eq.24)
1862 & .or.iabs(lb1).eq.16) then
1863c previous rho decay performed in rhodecay():
1864c nnn=nnn+1
1865c call rhodecay(idecay,i1,nnn,iseed)
1866c
1867ctest off record decays of phi,K*,Lambda(1520) resonances:
1868c if(lb1.eq.29.or.iabs(lb1).eq.30)
1869c 1 write(18,112) 'decay',lb1,px1,py1,pz1,am1,nt
1870 call resdec(i1,nt,nnn,wid,idecay)
1871 p(1,i1)=px1n
1872 p(2,i1)=py1n
1873 p(3,i1)=pz1n
1874clin-5/2008:
1875 dpertp(i1)=dp1n
1876c add decay time to freezeout positions & time at the last timestep:
1877 if(nt.eq.ntmax) then
1878 R(1,i1)=xfnl
1879 R(2,i1)=yfnl
1880 R(3,i1)=zfnl
1881 tfdcy(i1)=tfnl
1882 endif
1883c
1884* decay number for baryon resonance or L/S decay
1885 if(iabs(lb1).ge.6.and.iabs(lb1).le.9) then
1886 LDECAY=LDECAY+1
1887 endif
1888
1889* for a1 decay
1890c elseif(lb1.eq.32)then
1891c NNN=NNN+1
1892c call a1decay(idecay,i1,nnn,iseed,rhomp)
1893
1894* FOR N*(1440)
1895 elseif(iabs(LB1).EQ.10.OR.iabs(LB1).EQ.11) THEN
1896 NNN=NNN+1
1897 LDECAY=LDECAY+1
1898 PNSTAR=1.
1899 IF(E(I1).GT.1.22)PNSTAR=0.6
1900 IF(RANART(NSEED).LE.PNSTAR)THEN
1901* (1) DECAY TO SINGLE PION+NUCLEON
3006c44b 1902 CALL DECAYA(idecay,I1,NNN,ISEED,wid,nt)
0119ef9a 1903 ELSE
1904* (2) DECAY TO TWO PIONS + NUCLEON
1905 CALL DECAY2(idecay,I1,NNN,ISEED,wid,nt)
1906 NNN=NNN+1
1907 ENDIF
1908c for N*(1535) decay
1909 elseif(iabs(LB1).eq.12.or.iabs(LB1).eq.13) then
1910 NNN=NNN+1
3006c44b 1911 CALL DECAYA(idecay,I1,NNN,ISEED,wid,nt)
0119ef9a 1912 LDECAY=LDECAY+1
1913 endif
1914c
1915*COM: AT HIGH ENERGIES WE USE VERY SHORT TIME STEPS,
1916* IN ORDER TO TAKE INTO ACCOUNT THE FINITE FORMATIOM TIME, WE
1917* DO NOT ALLOW PARTICLES FROM THE DECAY OF RESONANCE TO INTERACT
1918* WITH OTHERS IN THE SAME TIME STEP. CHANGE 9000 TO REVERSE THIS
1919* ASSUMPTION. EFFECTS OF THIS ASSUMPTION CAN BE STUDIED BY CHANGING
1920* THE STATEMENT OF 9000. See notebook for discussions on effects of
1921* changing statement 9000.
1922c
1923c kaons from K* decay are converted to k0short (and k0long),
1924c phi decay may produce rho, K0S or eta, N*(1535) decay may produce eta,
1925c and these decay daughters need to decay again if at the last timestep:
1926c (note: these daughters have been assigned to lb(i1) only, not to lpion)
1927c if(nt.eq.ntmax.and.(lb1.eq.29.or.iabs(lb1).eq.30
1928c 1 .iabs(lb1).eq.12.or.iabs(lb1).eq.13)) then
1929 if(nt.eq.ntmax) then
1930 if(lb(i1).eq.25.or.lb(i1).eq.26.or.lb(i1).eq.27) then
1931 wid=0.151
1932 elseif(lb(i1).eq.0) then
1933 wid=1.18e-6
1934 elseif(lb(i1).eq.24.and.iksdcy.eq.1) then
1935 wid=7.36e-17
1936 else
1937 goto 9000
1938 endif
1939 LB1=LB(I1)
1940 PX1=P(1,I1)
1941 PY1=P(2,I1)
1942 PZ1=P(3,I1)
1943 EM1=E(I1)
1944 E1=SQRT(EM1**2+PX1**2+PY1**2+PZ1**2)
1945 call resdec(i1,nt,nnn,wid,idecay)
1946 p(1,i1)=px1n
1947 p(2,i1)=py1n
1948 p(3,i1)=pz1n
1949 R(1,i1)=xfnl
1950 R(2,i1)=yfnl
1951 R(3,i1)=zfnl
1952 tfdcy(i1)=tfnl
1953clin-5/2008:
1954 dpertp(i1)=dp1n
1955 endif
1956
1957* negelecting the Pauli blocking at high energies
1958 9000 go to 800
1959 ENDIF
1960* LOOP OVER ALL PSEUDOPARTICLES 2 IN THE SAME RUN
1961* SAVE ALL THE COORDINATES FOR POSSIBLE CHANGE IN THE FOLLOWING COLLISION
1962 1 if(nt.eq.ntmax)go to 800
1963 X1 = R(1,I1)
1964 Y1 = R(2,I1)
1965 Z1 = R(3,I1)
1966c
1967 DO 600 J2 = 1,J1-1
1968 I2 = J2 + MSUM
1969* IF I2 IS A MESON BEING ABSORBED, THEN GO OUT OF THE LOOP
1970 IF(E(I2).EQ.0.) GO TO 600
1971clin-5/2008 in case the first particle is already destroyed:
1972 IF(E(I1).EQ.0.) GO TO 800
1973 IF (LB(I2) .LT. -45 .OR. LB(I2) .GT. 45) GOTO 600
1974clin-7/26/03 improve speed
1975 X2=R(1,I2)
1976 Y2=R(2,I2)
1977 Z2=R(3,I2)
1978 dr0max=5.
1979clin-9/2008 deuteron+nucleon elastic cross sections could reach ~2810mb:
1980 ilb1=iabs(LB(I1))
1981 ilb2=iabs(LB(I2))
1982 IF(ilb1.EQ.42.or.ilb2.EQ.42) THEN
1983 if((ILB1.GE.1.AND.ILB1.LE.2)
1984 1 .or.(ILB1.GE.6.AND.ILB1.LE.13)
1985 2 .or.(ILB2.GE.1.AND.ILB2.LE.2)
1986 3 .or.(ILB2.GE.6.AND.ILB2.LE.13)) then
1987 if((lb(i1)*lb(i2)).gt.0) dr0max=10.
1988 endif
1989 ENDIF
1990c
1991 if(((X1-X2)**2+(Y1-Y2)**2+(Z1-Z2)**2).GT.dr0max**2)
1992 1 GO TO 600
1993 IF (ID(I1)*ID(I2).EQ.IAVOID) GOTO 400
1994 ID1=ID(I1)
1995 ID2 = ID(I2)
1996c
1997 ix1= nint(x1/dx)
1998 iy1= nint(y1/dy)
1999 iz1= nint(z1/dz)
2000 PX1=P(1,I1)
2001 PY1=P(2,I1)
2002 PZ1=P(3,I1)
2003 EM1=E(I1)
2004 AM1=EM1
2005 LB1=LB(I1)
2006 E1=SQRT(EM1**2+PX1**2+PY1**2+PZ1**2)
2007 IPX1=NINT(PX1/DPX)
2008 IPY1=NINT(PY1/DPY)
2009 IPZ1=NINT(PZ1/DPZ)
2010 LB2 = LB(I2)
2011 PX2 = P(1,I2)
2012 PY2 = P(2,I2)
2013 PZ2 = P(3,I2)
2014 EM2=E(I2)
2015 AM2=EM2
2016 lb1i=lb(i1)
2017 lb2i=lb(i2)
2018 px1i=P(1,I1)
2019 py1i=P(2,I1)
2020 pz1i=P(3,I1)
2021 em1i=E(I1)
2022 px2i=P(1,I2)
2023 py2i=P(2,I2)
2024 pz2i=P(3,I2)
2025 em2i=E(I2)
2026clin-2/26/03 ctest off check energy conservation after each binary search:
2027 eini=SQRT(E(I1)**2+P(1,I1)**2+P(2,I1)**2+P(3,I1)**2)
2028 1 +SQRT(E(I2)**2+P(1,I2)**2+P(2,I2)**2+P(3,I2)**2)
2029 pxini=P(1,I1)+P(1,I2)
2030 pyini=P(2,I1)+P(2,I2)
2031 pzini=P(3,I1)+P(3,I2)
2032 nnnini=nnn
2033c
2034clin-4/30/03 initialize value:
2035 iblock=0
2036c
2037* TO SAVE COMPUTING TIME we do the following
2038* (1) make a ROUGH estimate to see whether particle i2 will collide with
2039* particle I1, and (2) skip the particle pairs for which collisions are
2040* not modeled in the code.
2041* FOR MESON-BARYON AND MESON-MESON COLLISIONS, we use a maximum
2042* interaction distance DELTR0=2.6
2043* for ppbar production from meson (pi rho omega) interactions:
2044c
2045 DELTR0=3.
2046 if( (iabs(lb1).ge.14.and.iabs(lb1).le.17) .or.
2047 & (iabs(lb1).ge.30.and.iabs(lb1).le.45) ) DELTR0=5.0
2048 if( (iabs(lb2).ge.14.and.iabs(lb2).le.17) .or.
2049 & (iabs(lb2).ge.30.and.iabs(lb2).le.45) ) DELTR0=5.0
2050
2051 if(lb1.eq.28.and.lb2.eq.28) DELTR0=4.84
2052clin-10/08/00 to include pi pi -> rho rho:
2053 if((lb1.ge.3.and.lb1.le.5).and.(lb2.ge.3.and.lb2.le.5)) then
2054 E2=SQRT(EM2**2+PX2**2+PY2**2+PZ2**2)
2055 spipi=(e1+e2)**2-(px1+px2)**2-(py1+py2)**2-(pz1+pz2)**2
2056 if(spipi.ge.(4*0.77**2)) DELTR0=3.5
2057 endif
2058
2059c khyperon
2060 IF (LB1.EQ.23 .AND. (LB2.GE.14.AND.LB2.LE.17)) GOTO 3699
2061 IF (LB2.EQ.23 .AND. (LB1.GE.14.AND.LB1.LE.17)) GOTO 3699
2062
2063* K(K*) + Kbar(K*bar) scattering including
2064* K(K*) + Kbar(K*bar) --> phi + pi(rho,omega) and pi pi(rho,omega)
2065 if(lb1.eq.21.and.lb2.eq.23)go to 3699
2066 if(lb2.eq.21.and.lb1.eq.23)go to 3699
2067 if(lb1.eq.30.and.lb2.eq.21)go to 3699
2068 if(lb2.eq.30.and.lb1.eq.21)go to 3699
2069 if(lb1.eq.-30.and.lb2.eq.23)go to 3699
2070 if(lb2.eq.-30.and.lb1.eq.23)go to 3699
2071 if(lb1.eq.-30.and.lb2.eq.30)go to 3699
2072 if(lb2.eq.-30.and.lb1.eq.30)go to 3699
2073c
2074clin-12/15/00
2075c kaon+rho(omega,eta) collisions:
2076 if(lb1.eq.21.or.lb1.eq.23) then
2077 if(lb2.eq.0.or.(lb2.ge.25.and.lb2.le.28)) then
2078 go to 3699
2079 endif
2080 elseif(lb2.eq.21.or.lb2.eq.23) then
2081 if(lb1.eq.0.or.(lb1.ge.25.and.lb1.le.28)) then
2082 goto 3699
2083 endif
2084 endif
2085
2086clin-8/14/02 K* (pi, rho, omega, eta) collisions:
2087 if(iabs(lb1).eq.30 .and.
2088 1 (lb2.eq.0.or.(lb2.ge.25.and.lb2.le.28)
2089 2 .or.(lb2.ge.3.and.lb2.le.5))) then
2090 go to 3699
2091 elseif(iabs(lb2).eq.30 .and.
2092 1 (lb1.eq.0.or.(lb1.ge.25.and.lb1.le.28)
2093 2 .or.(lb1.ge.3.and.lb1.le.5))) then
2094 goto 3699
2095clin-8/14/02-end
2096c K*/K*-bar + baryon/antibaryon collisions:
2097 elseif( iabs(lb1).eq.30 .and.
2098 1 (iabs(lb2).eq.1.or.iabs(lb2).eq.2.or.
2099 2 (iabs(lb2).ge.6.and.iabs(lb2).le.13)) )then
2100 go to 3699
2101 endif
2102 if( iabs(lb2).eq.30 .and.
2103 1 (iabs(lb1).eq.1.or.iabs(lb1).eq.2.or.
2104 2 (iabs(lb1).ge.6.and.iabs(lb1).le.13)) )then
2105 go to 3699
2106 endif
2107* K^+ baryons and antibaryons:
2108c** K+ + B-bar --> La(Si)-bar + pi
2109* K^- and antibaryons, note K^- and baryons are included in newka():
2110* note that we fail to satisfy charge conjugation for these cross sections:
2111 if((lb1.eq.23.or.lb1.eq.21).and.
2112 1 (iabs(lb2).eq.1.or.iabs(lb2).eq.2.or.
2113 2 (iabs(lb2).ge.6.and.iabs(lb2).le.13))) then
2114 go to 3699
2115 elseif((lb2.eq.23.or.lb2.eq.21).and.
2116 1 (iabs(lb1).eq.1.or.iabs(lb1).eq.2.or.
2117 2 (iabs(lb1).ge.6.and.iabs(lb1).le.13))) then
2118 go to 3699
2119 endif
2120*
2121* For anti-nucleons annihilations:
2122* Assumptions:
2123* (1) for collisions involving a p_bar or n_bar,
2124* we allow only collisions between a p_bar and a baryon or a baryon
2125* resonance (as well as a n_bar and a baryon or a baryon resonance),
2126* we skip all other reactions involving a p_bar or n_bar,
2127* such as collisions between p_bar (n_bar) and mesons,
2128* and collisions between two p_bar's (n_bar's).
2129* (2) we introduce a new parameter rppmax: the maximum interaction
2130* distance to make the quick collision check,rppmax=3.57 fm
2131* corresponding to a cutoff of annihilation xsection= 400mb which is
2132* also used consistently in the actual annihilation xsection to be
2133* used in the following as given in the subroutine xppbar(srt)
2134 rppmax=3.57
2135* anti-baryon on baryons
2136 if((lb1.eq.-1.or.lb1.eq.-2.or.(lb1.ge.-13.and.lb1.le.-6))
2137 1 .and.(lb2.eq.1.or.lb2.eq.2.or.(lb2.ge.6.and.lb2.le.13))) then
2138 DELTR0 = RPPMAX
2139 GOTO 2699
2140 else if((lb2.eq.-1.or.lb2.eq.-2.or.(lb2.ge.-13.and.lb2.le.-6))
2141 1 .and.(lb1.eq.1.or.lb1.eq.2.or.(lb1.ge.6.and.lb1.le.13))) then
2142 DELTR0 = RPPMAX
2143 GOTO 2699
2144 END IF
2145
2146c* ((anti) lambda, cascade, omega should not be rejected)
2147 if( (iabs(lb1).ge.14.and.iabs(lb1).le.17) .or.
2148 & (iabs(lb2).ge.14.and.iabs(lb2).le.17) )go to 3699
2149c
2150clin-9/2008 maximum sigma~2810mb for deuteron+nucleon elastic collisions:
2151 IF (iabs(LB1).EQ.42.or.iabs(LB2).EQ.42) THEN
2152 ilb1=iabs(LB1)
2153 ilb2=iabs(LB2)
2154 if((ILB1.GE.1.AND.ILB1.LE.2)
2155 1 .or.(ILB1.GE.6.AND.ILB1.LE.13)
2156 2 .or.(ILB2.GE.1.AND.ILB2.LE.2)
2157 3 .or.(ILB2.GE.6.AND.ILB2.LE.13)) then
2158 if((lb1*lb2).gt.0) deltr0=9.5
2159 endif
2160 ENDIF
2161c
2162 if( (iabs(lb1).ge.40.and.iabs(lb1).le.45) .or.
2163 & (iabs(lb2).ge.40.and.iabs(lb2).le.45) )go to 3699
2164c
2165c* phi channel --> elastic + inelastic scatt.
2166 IF( (lb1.eq.29 .and.((lb2.ge.1.and.lb2.le.13).or.
2167 & (lb2.ge.21.and.lb2.le.28).or.iabs(lb2).eq.30)) .OR.
2168 & (lb2.eq.29 .and.((lb1.ge.1.and.lb1.le.13).or.
2169 & (lb1.ge.21.and.lb1.le.28).or.iabs(lb1).eq.30)) )THEN
2170 DELTR0=3.0
2171 go to 3699
2172 endif
2173c
2174c La/Si, Cas, Om (bar)-meson elastic colln
2175* pion vs. La & Ca (bar) coll. are treated in resp. subroutines
2176
2177* SKIP all other K* RESCATTERINGS
2178 If(iabs(lb1).eq.30.or.iabs(lb2).eq.30) go to 400
2179* SKIP KAON(+) RESCATTERINGS WITH particles other than pions and baryons
2180 If(lb1.eq.23.and.(lb2.lt.1.or.lb2.gt.17))go to 400
2181 If(lb2.eq.23.and.(lb1.lt.1.or.lb1.gt.17))go to 400
2182c
2183c anti-baryon proccess: B-bar+M, N-bar+R-bar, N-bar+N-bar, R-bar+R-bar
2184c R = (D,N*)
2185 if( ((lb1.le.-1.and.lb1.ge.-13)
2186 & .and.(lb2.eq.0.or.(lb2.ge.3.and.lb2.le.5)
2187 & .or.(lb2.ge.25.and.lb2.le.28)))
2188 & .OR.((lb2.le.-1.and.lb2.ge.-13)
2189 & .and.(lb1.eq.0.or.(lb1.ge.3.and.lb1.le.5)
2190 & .or.(lb1.ge.25.and.lb1.le.28))) ) then
2191 elseIF( ((LB1.eq.-1.or.lb1.eq.-2).
2192 & and.(LB2.LT.-5.and.lb2.ge.-13))
2193 & .OR. ((LB2.eq.-1.or.lb2.eq.-2).
2194 & and.(LB1.LT.-5.and.lb1.ge.-13)) )then
2195 elseIF((LB1.eq.-1.or.lb1.eq.-2)
2196 & .AND.(LB2.eq.-1.or.lb2.eq.-2))then
2197 elseIF((LB1.LT.-5.and.lb1.ge.-13).AND.
2198 & (LB2.LT.-5.and.lb2.ge.-13)) then
2199c elseif((lb1.lt.0).or.(lb2.lt.0)) then
2200c go to 400
2201 endif
2202
2203 2699 CONTINUE
2204* for baryon-baryon collisions
2205 IF (LB1 .EQ. 1 .OR. LB1 .EQ. 2 .OR. (LB1 .GE. 6 .AND.
2206 & LB1 .LE. 17)) THEN
2207 IF (LB2 .EQ. 1 .OR. LB2 .EQ. 2 .OR. (LB2 .GE. 6 .AND.
2208 & LB2 .LE. 17)) THEN
2209 DELTR0 = 2.
2210 END IF
2211 END IF
2212c
2213 3699 RSQARE = (X1-X2)**2 + (Y1-Y2)**2 + (Z1-Z2)**2
2214 IF (RSQARE .GT. DELTR0**2) GO TO 400
2215*NOW PARTICLES ARE CLOSE ENOUGH TO EACH OTHER !
2216* KEEP ALL COORDINATES FOR POSSIBLE PHASE SPACE CHANGE
2217 ix2 = nint(x2/dx)
2218 iy2 = nint(y2/dy)
2219 iz2 = nint(z2/dz)
2220 ipx2 = nint(px2/dpx)
2221 ipy2 = nint(py2/dpy)
2222 ipz2 = nint(pz2/dpz)
2223* FIND MOMENTA OF PARTICLES IN THE CMS OF THE TWO COLLIDING PARTICLES
2224* AND THE CMS ENERGY SRT
2225 CALL CMS(I1,I2,PCX,PCY,PCZ,SRT)
2226clin-7/26/03 improve speed
2227 drmax=dr0max
2228 call distc0(drmax,deltr0,DT,
2229 1 Ifirst,PCX,PCY,PCZ,
2230 2 x1,y1,z1,px1,py1,pz1,em1,x2,y2,z2,px2,py2,pz2,em2)
2231 if(Ifirst.eq.-1) goto 400
2232
2233 ISS=NINT(SRT/ESBIN)
2234clin-4/2008 use last bin if ISS is out of EKAON's upper bound of 2000:
2235 if(ISS.gt.2000) ISS=2000
2236*Sort collisions
2237c
2238clin-8/2008 Deuteron+Meson->B+B;
2239c meson=(pi,rho,omega,eta), B=(n,p,Delta,N*1440,N*1535):
2240 IF (iabs(LB1).EQ.42.or.iabs(LB2).EQ.42) THEN
2241 ilb1=iabs(LB1)
2242 ilb2=iabs(LB2)
2243 if(LB1.eq.0.or.(LB1.GE.3.AND.LB1.LE.5)
2244 1 .or.(LB1.GE.25.AND.LB1.LE.28)
2245 2 .or.
2246 3 LB2.eq.0.or.(LB2.GE.3.AND.LB2.LE.5)
2247 4 .or.(LB2.GE.25.AND.LB2.LE.28)) then
2248 GOTO 505
2249clin-9/2008 Deuteron+Baryon or antiDeuteron+antiBaryon elastic collisions:
2250 elseif(((ILB1.GE.1.AND.ILB1.LE.2)
2251 1 .or.(ILB1.GE.6.AND.ILB1.LE.13)
2252 2 .or.(ILB2.GE.1.AND.ILB2.LE.2)
2253 3 .or.(ILB2.GE.6.AND.ILB2.LE.13))
2254 4 .and.(lb1*lb2).gt.0) then
2255 GOTO 506
2256 else
2257 GOTO 400
2258 endif
2259 ENDIF
2260c
2261* K+ + (N,N*,D)-bar --> L/S-bar + pi
2262 if( ((lb1.eq.23.or.lb1.eq.30).and.
2263 & (lb2.eq.-1.or.lb2.eq.-2.or.(lb2.ge.-13.and.lb2.le.-6)))
2264 & .OR.((lb2.eq.23.or.lb2.eq.30).and.
2265 & (lb1.eq.-1.or.lb1.eq.-2.or.(lb1.ge.-13.and.lb1.le.-6))) )
2266 & then
2267 bmass=0.938
2268 if(srt.le.(bmass+aka)) then
2269 pkaon=0.
2270 else
2271 pkaon=sqrt(((srt**2-(aka**2+bmass**2))
2272 1 /2./bmass)**2-aka**2)
2273 endif
2274clin-10/31/02 cross sections are isospin-averaged, same as those in newka
2275c for K- + (N,N*,D) --> L/S + pi:
2276 sigela = 0.5 * (AKPEL(PKAON) + AKNEL(PKAON))
2277 SIGSGM = 1.5 * AKPSGM(PKAON) + AKNSGM(PKAON)
2278 SIG = sigela + SIGSGM + AKPLAM(PKAON)
2279 if(sig.gt.1.e-7) then
2280c ! K+ + N-bar reactions
2281 icase=3
2282 brel=sigela/sig
2283 brsgm=sigsgm/sig
2284 brsig = sig
2285 nchrg = 1
2286 go to 3555
2287 endif
2288 go to 400
2289 endif
2290c
2291c
2292c meson + hyperon-bar -> K+ + N-bar
2293 if(((lb1.ge.-17.and.lb1.le.-14).and.(lb2.ge.3.and.lb2.le.5))
2294 & .OR.((lb2.ge.-17.and.lb2.le.-14)
2295 & .and.(lb1.ge.3.and.lb1.le.5)))then
2296 nchrg=-100
2297
2298C* first classify the reactions due to total charge.
2299 if((lb1.eq.-15.and.(lb2.eq.5.or.lb2.eq.27)).OR.
2300 & (lb2.eq.-15.and.(lb1.eq.5.or.lb1.eq.27))) then
2301 nchrg=-2
2302c ! D-(bar)
2303 bmass=1.232
2304 go to 110
2305 endif
2306 if( (lb1.eq.-15.and.(lb2.eq.0.or.lb2.eq.4.or.lb2.eq.26.or.
2307 & lb2.eq.28)).OR.(lb2.eq.-15.and.(lb1.eq.0.or.
2308 & lb1.eq.4.or.lb1.eq.26.or.lb1.eq.28)).OR.
2309 & ((lb1.eq.-14.or.lb1.eq.-16).and.(lb2.eq.5.or.lb2.eq.27)).OR.
2310 & ((lb2.eq.-14.or.lb2.eq.-16).and.(lb1.eq.5.or.lb1.eq.27)) )then
2311 nchrg=-1
2312c ! n-bar
2313 bmass=0.938
2314 go to 110
2315 endif
2316 if( (lb1.eq.-15.and.(lb2.eq.3.or.lb2.eq.25)).OR.
2317 & (lb2.eq.-15.and.(lb1.eq.3.or.lb1.eq.25)).OR.
2318 & (lb1.eq.-17.and.(lb2.eq.5.or.lb2.eq.27)).OR.
2319 & (lb2.eq.-17.and.(lb1.eq.5.or.lb1.eq.27)).OR.
2320 & ((lb1.eq.-14.or.lb1.eq.-16).and.(lb2.eq.0.or.lb2.eq.4
2321 & .or.lb2.eq.26.or.lb2.eq.28)).OR.
2322 & ((lb2.eq.-14.or.lb2.eq.-16).and.(lb1.eq.0.or.lb1.eq.4
2323 & .or.lb1.eq.26.or.lb1.eq.28)) )then
2324 nchrg=0
2325c ! p-bar
2326 bmass=0.938
2327 go to 110
2328 endif
2329 if( (lb1.eq.-17.and.(lb2.eq.0.or.lb2.eq.4.or.lb2.eq.26.or.
2330 & lb2.eq.28)).OR.(lb2.eq.-17.and.(lb1.eq.0.or.
2331 & lb1.eq.4.or.lb1.eq.26.or.lb1.eq.28)).OR.
2332 & ((lb1.eq.-14.or.lb1.eq.-16).and.(lb2.eq.3.or.lb2.eq.25)).OR.
2333 & ((lb2.eq.-14.or.lb2.eq.-16).and.(lb1.eq.3.or.lb1.eq.25)))then
2334 nchrg=1
2335c ! D++(bar)
2336 bmass=1.232
2337 endif
2338c
2339c 110 if(nchrg.ne.-100.and.srt.ge.(aka+bmass))then !! for elastic
2340 110 sig = 0.
2341c !! for elastic
2342 if(nchrg.ne.-100.and.srt.ge.(aka+bmass))then
2343cc110 if(nchrg.eq.-100.or.srt.lt.(aka+bmass)) go to 400
2344c ! PI + La(Si)-bar => K+ + N-bar reactions
2345 icase=4
2346cc pkaon=sqrt(((srt**2-(aka**2+bmass**2))/2./bmass)**2-aka**2)
2347 pkaon=sqrt(((srt**2-(aka**2+0.938**2))/2./0.938)**2-aka**2)
2348c ! lambda-bar + Pi
2349 if(lb1.eq.-14.or.lb2.eq.-14) then
2350 if(nchrg.ge.0) sigma0=akPlam(pkaon)
2351 if(nchrg.lt.0) sigma0=akNlam(pkaon)
2352c ! sigma-bar + pi
2353 else
2354c !K-p or K-D++
2355 if(nchrg.ge.0) sigma0=akPsgm(pkaon)
2356c !K-n or K-D-
2357 if(nchrg.lt.0) sigma0=akNsgm(pkaon)
2358 SIGMA0 = 1.5 * AKPSGM(PKAON) + AKNSGM(PKAON)
2359 endif
2360 sig=(srt**2-(aka+bmass)**2)*(srt**2-(aka-bmass)**2)/
2361 & (srt**2-(em1+em2)**2)/(srt**2-(em1-em2)**2)*sigma0
2362c ! K0barD++, K-D-
2363 if(nchrg.eq.-2.or.nchrg.eq.2) sig=2.*sig
2364C* the factor 2 comes from spin of delta, which is 3/2
2365C* detailed balance. copy from Page 423 of N.P. A614 1997
2366 IF (LB1 .EQ. -14 .OR. LB2 .EQ. -14) THEN
2367 SIG = 4.0 / 3.0 * SIG
2368 ELSE IF (NCHRG .EQ. -2 .OR. NCHRG .EQ. 2) THEN
2369 SIG = 8.0 / 9.0 * SIG
2370 ELSE
2371 SIG = 4.0 / 9.0 * SIG
2372 END IF
2373cc brel=0.
2374cc brsgm=0.
2375cc brsig = sig
2376cc if(sig.lt.1.e-7) go to 400
2377*-
2378 endif
2379c ! PI + La(Si)-bar => elastic included
2380 icase=4
2381 sigela = 10.
2382 sig = sig + sigela
2383 brel= sigela/sig
2384 brsgm=0.
2385 brsig = sig
2386*-
2387 go to 3555
2388 endif
2389
2390** MULTISTRANGE PARTICLE (Cas,Omega -bar) PRODUCTION - (NON)PERTURBATIVE
2391
2392* K-/K*0bar + La/Si --> cascade + pi/eta
2393 if( ((lb1.eq.21.or.lb1.eq.-30).and.(lb2.ge.14.and.lb2.le.17)).OR.
2394 & ((lb2.eq.21.or.lb2.eq.-30).and.(lb1.ge.14.and.lb1.le.17)) )then
2395 kp = 0
2396 go to 3455
2397 endif
2398c K+/K*0 + La/Si(bar) --> cascade-bar + pi/eta
2399 if( ((lb1.eq.23.or.lb1.eq.30).and.(lb2.le.-14.and.lb2.ge.-17)).OR.
2400 & ((lb2.eq.23.or.lb2.eq.30).and.(lb1.le.-14.and.lb1.ge.-17)) )then
2401 kp = 1
2402 go to 3455
2403 endif
2404* K-/K*0bar + cascade --> omega + pi
2405 if( ((lb1.eq.21.or.lb1.eq.-30).and.(lb2.eq.40.or.lb2.eq.41)).OR.
2406 & ((lb2.eq.21.or.lb2.eq.-30).and.(lb1.eq.40.or.lb1.eq.41)) )then
2407 kp = 0
2408 go to 3455
2409 endif
2410* K+/K*0 + cascade-bar --> omega-bar + pi
2411 if( ((lb1.eq.23.or.lb1.eq.30).and.(lb2.eq.-40.or.lb2.eq.-41)).OR.
2412 & ((lb2.eq.23.or.lb2.eq.30).and.(lb1.eq.-40.or.lb1.eq.-41)) )then
2413 kp = 1
2414 go to 3455
2415 endif
2416* Omega + Omega --> Di-Omega + photon(eta)
2417cc if( lb1.eq.45.and.lb2.eq.45 ) go to 3455
2418
2419c annhilation of cascade(bar), omega(bar)
2420 kp = 3
2421* K- + L/S <-- cascade(bar) + pi/eta
2422 if( (((lb1.ge.3.and.lb1.le.5).or.lb1.eq.0)
2423 & .and.(iabs(lb2).eq.40.or.iabs(lb2).eq.41))
2424 & .OR. (((lb2.ge.3.and.lb2.le.5).or.lb2.eq.0)
2425 & .and.(iabs(lb1).eq.40.or.iabs(lb1).eq.41)) )go to 3455
2426* K- + cascade(bar) <-- omega(bar) + pi
2427* if( (lb1.eq.0.and.iabs(lb2).eq.45)
2428* & .OR. (lb2.eq.0.and.iabs(lb1).eq.45) )go to 3455
2429 if( ((lb1.ge.3.and.lb1.le.5).and.iabs(lb2).eq.45)
2430 & .OR.((lb2.ge.3.and.lb2.le.5).and.iabs(lb1).eq.45) )go to 3455
2431c
2432
2433*** MULTISTRANGE PARTICLE PRODUCTION (END)
2434
2435c* K+ + La(Si) --> Meson + B
2436 IF (LB1.EQ.23 .AND. (LB2.GE.14.AND.LB2.LE.17)) GOTO 5699
2437 IF (LB2.EQ.23 .AND. (LB1.GE.14.AND.LB1.LE.17)) GOTO 5699
2438c* K- + La(Si)-bar --> Meson + B-bar
2439 IF (LB1.EQ.21 .AND. (LB2.GE.-17.AND.LB2.LE.-14)) GOTO 5699
2440 IF (LB2.EQ.21 .AND. (LB1.GE.-17.AND.LB1.LE.-14)) GOTO 5699
2441
2442c La/Si-bar + B --> pi + K+
2443 IF( (((LB1.eq.1.or.LB1.eq.2).or.(LB1.ge.6.and.LB1.le.13))
2444 & .AND.(LB2.GE.-17.AND.LB2.LE.-14)) .OR.
2445 & (((LB2.eq.1.or.LB2.eq.2).or.(LB2.ge.6.and.LB2.le.13))
2446 & .AND.(LB1.GE.-17.AND.LB1.LE.-14)) )go to 5999
2447c La/Si + B-bar --> pi + K-
2448 IF( (((LB1.eq.-1.or.LB1.eq.-2).or.(LB1.le.-6.and.LB1.ge.-13))
2449 & .AND.(LB2.GE.14.AND.LB2.LE.17)) .OR.
2450 & (((LB2.eq.-1.or.LB2.eq.-2).or.(LB2.le.-6.and.LB2.ge.-13))
2451 & .AND.(LB1.GE.14.AND.LB1.LE.17)) )go to 5999
2452*
2453*
2454* K(K*) + Kbar(K*bar) --> phi + pi(rho,omega), M + M (M=pi,rho,omega,eta)
2455 if(lb1.eq.21.and.lb2.eq.23) go to 8699
2456 if(lb2.eq.21.and.lb1.eq.23) go to 8699
2457 if(lb1.eq.30.and.lb2.eq.21) go to 8699
2458 if(lb2.eq.30.and.lb1.eq.21) go to 8699
2459 if(lb1.eq.-30.and.lb2.eq.23) go to 8699
2460 if(lb2.eq.-30.and.lb1.eq.23) go to 8699
2461 if(lb1.eq.-30.and.lb2.eq.30) go to 8699
2462 if(lb2.eq.-30.and.lb1.eq.30) go to 8699
2463c* (K,K*)-bar + rho(omega) --> phi +(K,K*)-bar, piK and elastic
2464 IF( ((lb1.eq.23.or.lb1.eq.21.or.iabs(lb1).eq.30) .and.
2465 & (lb2.ge.25.and.lb2.le.28)) .OR.
2466 & ((lb2.eq.23.or.lb2.eq.21.or.iabs(lb2).eq.30) .and.
2467 & (lb1.ge.25.and.lb1.le.28)) ) go to 8799
2468c
2469c* K*(-bar) + pi --> phi + (K,K*)-bar
2470 IF( (iabs(lb1).eq.30.and.(lb2.ge.3.and.lb2.le.5)) .OR.
2471 & (iabs(lb2).eq.30.and.(lb1.ge.3.and.lb1.le.5)) )go to 8799
2472*
2473c
2474c* phi + N --> pi+N(D), rho+N(D), K+ +La
2475c* phi + D --> pi+N(D), rho+N(D)
2476 IF( (lb1.eq.29 .and.(lb2.eq.1.or.lb2.eq.2.or.
2477 & (lb2.ge.6.and.lb2.le.9))) .OR.
2478 & (lb2.eq.29 .and.(lb1.eq.1.or.lb1.eq.2.or.
2479 & (lb1.ge.6.and.lb1.le.9))) )go to 7222
2480c
2481c* phi + (pi,rho,ome,K,K*-bar) --> K+K, K+K*, K*+K*, (pi,rho,omega)+(K,K*-bar)
2482 IF( (lb1.eq.29 .and.((lb2.ge.3.and.lb2.le.5).or.
2483 & (lb2.ge.21.and.lb2.le.28).or.iabs(lb2).eq.30)) .OR.
2484 & (lb2.eq.29 .and.((lb1.ge.3.and.lb1.le.5).or.
2485 & (lb1.ge.21.and.lb1.le.28).or.iabs(lb1).eq.30)) )THEN
2486 go to 7444
2487 endif
2488*
2489c
2490* La/Si, Cas, Om (bar)-(rho,omega,phi) elastic colln
2491* pion vs. La, Ca, Omega-(bar) elastic coll. treated in resp. subroutines
2492 if( ((iabs(lb1).ge.14.and.iabs(lb1).le.17).or.iabs(lb1).ge.40)
2493 & .and.((lb2.ge.25.and.lb2.le.29).or.lb2.eq.0) )go to 888
2494 if( ((iabs(lb2).ge.14.and.iabs(lb2).le.17).or.iabs(lb2).ge.40)
2495 & .and.((lb1.ge.25.and.lb1.le.29).or.lb1.eq.0) )go to 888
2496c
2497c K+/K* (N,R) OR K-/K*- (N,R)-bar elastic scatt
2498 if( ((lb1.eq.23.or.lb1.eq.30).and.(lb2.eq.1.or.lb2.eq.2.or.
2499 & (lb2.ge.6.and.lb2.le.13))) .OR.
2500 & ((lb2.eq.23.or.lb2.eq.30).and.(lb1.eq.1.or.lb1.eq.2.or.
2501 & (lb1.ge.6.and.lb1.le.13))) ) go to 888
2502 if( ((lb1.eq.21.or.lb1.eq.-30).and.(lb2.eq.-1.or.lb2.eq.-2.or.
2503 & (lb2.ge.-13.and.lb2.le.-6))) .OR.
2504 & ((lb2.eq.21.or.lb2.eq.-30).and.(lb1.eq.-1.or.lb1.eq.-2.or.
2505 & (lb1.ge.-13.and.lb1.le.-6))) ) go to 888
2506c
2507* L/S-baryon elastic collision
2508 If( ((lb1.ge.14.and.lb1.le.17).and.(lb2.ge.6.and.lb2.le.13))
2509 & .OR.((lb2.ge.14.and.lb2.le.17).and.(lb1.ge.6.and.lb1.le.13)) )
2510 & go to 7799
2511 If(((lb1.le.-14.and.lb1.ge.-17).and.(lb2.le.-6.and.lb2.ge.-13))
2512 &.OR.((lb2.le.-14.and.lb2.ge.-17).and.(lb1.le.-6.and.lb1.ge.-13)))
2513 & go to 7799
2514c
2515c skip other collns with perturbative particles or hyperon-bar
2516 if( iabs(lb1).ge.40 .or. iabs(lb2).ge.40
2517 & .or. (lb1.le.-14.and.lb1.ge.-17)
2518 & .or. (lb2.le.-14.and.lb2.ge.-17) )go to 400
2519c
2520c
2521* anti-baryon on baryon resonaces
2522 if((lb1.eq.-1.or.lb1.eq.-2.or.(lb1.ge.-13.and.lb1.le.-6))
2523 1 .and.(lb2.eq.1.or.lb2.eq.2.or.(lb2.ge.6.and.lb2.le.13))) then
2524 GOTO 2799
2525 else if((lb2.eq.-1.or.lb2.eq.-2.or.(lb2.ge.-13.and.lb2.le.-6))
2526 1 .and.(lb1.eq.1.or.lb1.eq.2.or.(lb1.ge.6.and.lb1.le.13))) then
2527 GOTO 2799
2528 END IF
2529c
2530clin-10/25/02 get rid of argument usage mismatch in newka():
2531 inewka=irun
2532c call newka(icase,irun,iseed,dt,nt,
2533clin-5/01/03 set iblock value in art1f.f, necessary for resonance studies:
2534c call newka(icase,inewka,iseed,dt,nt,
2535c & ictrl,i1,i2,srt,pcx,pcy,pcz)
2536 call newka(icase,inewka,iseed,dt,nt,
2537 & ictrl,i1,i2,srt,pcx,pcy,pcz,iblock)
2538
2539clin-10/25/02-end
2540 IF (ICTRL .EQ. 1) GOTO 400
2541c
2542* SEPARATE NUCLEON+NUCLEON( BARYON RESONANCE+ BARYON RESONANCE ELASTIC
2543* COLLISION), BARYON RESONANCE+NUCLEON AND BARYON-PION
2544* COLLISIONS INTO THREE PARTS TO CHECK IF THEY ARE GOING TO SCATTER,
2545* WE only allow L/S to COLLIDE elastically with a nucleon and meson
2546 if((iabs(lb1).ge.14.and.iabs(lb1).le.17).
2547 & or.(iabs(lb2).ge.14.and.iabs(lb2).le.17))go to 400
2548* IF PION+PION COLLISIONS GO TO 777
2549* if pion+eta, eta+eta to create kaons go to 777
2550 IF((lb1.ge.3.and.lb1.le.5).and.(lb2.ge.3.and.lb2.le.5))GO TO 777
2551 if(lb1.eq.0.and.(lb2.ge.3.and.lb2.le.5)) go to 777
2552 if(lb2.eq.0.and.(lb1.ge.3.and.lb1.le.5)) go to 777
2553 if(lb1.eq.0.and.lb2.eq.0)go to 777
2554* we assume that rho and omega behave the same way as pions in
2555* kaon production
2556* (1) rho(omega)+rho(omega)
2557 if( (lb1.ge.25.and.lb1.le.28).and.
2558 & (lb2.ge.25.and.lb2.le.28) )goto 777
2559* (2) rho(omega)+pion
2560 If((lb1.ge.25.and.lb1.le.28).and.(lb2.ge.3.and.lb2.le.5))go to 777
2561 If((lb2.ge.25.and.lb2.le.28).and.(lb1.ge.3.and.lb1.le.5))go to 777
2562* (3) rho(omega)+eta
2563 if((lb1.ge.25.and.lb1.le.28).and.lb2.eq.0)go to 777
2564 if((lb2.ge.25.and.lb2.le.28).and.lb1.eq.0)go to 777
2565c
2566* if kaon+pion collisions go to 889
2567 if((lb1.eq.23.or.lb1.eq.21).and.(lb2.ge.3.and.lb2.le.5))go to 889
2568 if((lb2.eq.23.or.lb2.eq.21).and.(lb1.ge.3.and.lb1.le.5))go to 889
2569c
2570clin-2/06/03 skip all other (K K* Kbar K*bar) channels:
2571* SKIP all other K and K* RESCATTERINGS
2572 If(iabs(lb1).eq.30.or.iabs(lb2).eq.30) go to 400
2573 If(lb1.eq.21.or.lb2.eq.21) go to 400
2574 If(lb1.eq.23.or.lb2.eq.23) go to 400
2575c
2576* IF PION+baryon COLLISION GO TO 3
2577 IF( (LB1.ge.3.and.LB1.le.5) .and.
2578 & (iabs(LB2).eq.1.or.iabs(LB2).eq.2.or.
2579 & (iabs(LB2).ge.6.and.iabs(LB2).le.13)) )GO TO 3
2580 IF( (LB2.ge.3.and.LB2.le.5) .and.
2581 & (iabs(LB1).eq.1.or.iabs(LB1).eq.2.or.
2582 & (iabs(LB1).ge.6.and.iabs(LB1).le.13)) )GO TO 3
2583c
2584* IF rho(omega)+NUCLEON (baryon resonance) COLLISION GO TO 33
2585 IF( (LB1.ge.25.and.LB1.le.28) .and.
2586 & (iabs(LB2).eq.1.or.iabs(LB2).eq.2.or.
2587 & (iabs(LB2).ge.6.and.iabs(LB2).le.13)) )GO TO 33
2588 IF( (LB2.ge.25.and.LB2.le.28) .and.
2589 & (iabs(LB1).eq.1.or.iabs(LB1).eq.2.or.
2590 & (iabs(LB1).ge.6.and.iabs(LB1).le.13)) )GO TO 33
2591c
2592* IF ETA+NUCLEON (baryon resonance) COLLISIONS GO TO 547
2593 IF( LB1.eq.0 .and.
2594 & (iabs(LB2).eq.1.or.iabs(LB2).eq.2.or.
2595 & (iabs(LB2).ge.6.and.iabs(LB2).le.13)) )GO TO 547
2596 IF( LB2.eq.0 .and.
2597 & (iabs(LB1).eq.1.or.iabs(LB1).eq.2.or.
2598 & (iabs(LB1).ge.6.and.iabs(LB1).le.13)) )GO TO 547
2599c
2600* IF NUCLEON+BARYON RESONANCE COLLISION GO TO 44
2601 IF((LB1.eq.1.or.lb1.eq.2).
2602 & AND.(LB2.GT.5.and.lb2.le.13))GOTO 44
2603 IF((LB2.eq.1.or.lb2.eq.2).
2604 & AND.(LB1.GT.5.and.lb1.le.13))GOTO 44
2605 IF((LB1.eq.-1.or.lb1.eq.-2).
2606 & AND.(LB2.LT.-5.and.lb2.ge.-13))GOTO 44
2607 IF((LB2.eq.-1.or.lb2.eq.-2).
2608 & AND.(LB1.LT.-5.and.lb1.ge.-13))GOTO 44
2609c
2610* IF NUCLEON+NUCLEON COLLISION GO TO 4
2611 IF((LB1.eq.1.or.lb1.eq.2).AND.(LB2.eq.1.or.lb2.eq.2))GOTO 4
2612 IF((LB1.eq.-1.or.lb1.eq.-2).AND.(LB2.eq.-1.or.lb2.eq.-2))GOTO 4
2613c
2614* IF BARYON RESONANCE+BARYON RESONANCE COLLISION GO TO 444
2615 IF((LB1.GT.5.and.lb1.le.13).AND.
2616 & (LB2.GT.5.and.lb2.le.13)) GOTO 444
2617 IF((LB1.LT.-5.and.lb1.ge.-13).AND.
2618 & (LB2.LT.-5.and.lb2.ge.-13)) GOTO 444
2619c
2620* if L/S+L/S or L/s+nucleon go to 400
2621* otherwise, develop a model for their collisions
2622 if((lb1.lt.3).and.(lb2.ge.14.and.lb2.le.17))goto 400
2623 if((lb2.lt.3).and.(lb1.ge.14.and.lb1.le.17))goto 400
2624 if((lb1.ge.14.and.lb1.le.17).and.
2625 & (lb2.ge.14.and.lb2.le.17))goto 400
2626c
2627* otherwise, go out of the loop
2628 go to 400
2629*
2630*
2631547 IF(LB1*LB2.EQ.0)THEN
2632* (1) FOR ETA+NUCLEON SYSTEM, we allow both elastic collision,
2633* i.e. N*(1535) formation and kaon production
2634* the total kaon production cross section is
2635* ASSUMED to be THE SAME AS PION+NUCLEON COLLISIONS
2636* (2) for eta+baryon resonance we only allow kaon production
2637 ece=(em1+em2+0.02)**2
2638 xkaon0=0.
2639 if(srt.ge.1.63.AND.SRT.LE.1.7)xkaon0=pnlka(srt)
2640 IF(SRT.GT.1.7)XKAON0=PNLKA(SRT)+pnska(srt)
2641cbz3/7/99 neutralk
2642 XKAON0 = 2.0 * XKAON0
2643cbz3/7/99 neutralk end
2644
2645* Here we negelect eta+n inelastic collisions other than the
2646* kaon production, therefore the total inelastic cross section
2647* xkaon equals to the xkaon0 (kaon production cross section)
2648 xkaon=xkaon0
2649* note here the xkaon is in unit of fm**2
2650 XETA=XN1535(I1,I2,0)
2651 If((iabs(LB(I1)).ge.6.and.iabs(LB(I1)).le.13).or.
2652 & (iabs(LB(I2)).ge.6.and.iabs(LB(I2)).le.13)) xeta=0.
2653 IF((XETA+xkaon).LE.1.e-06)GO TO 400
2654 DSE=SQRT((XETA+XKAON)/PI)
2655 DELTRE=DSE+0.1
2656 px1cm=pcx
2657 py1cm=pcy
2658 pz1cm=pcz
2659* CHECK IF N*(1535) resonance CAN BE FORMED
2660 CALL DISTCE(I1,I2,DELTRE,DSE,DT,ECE,SRT,IC,
2661 1 PCX,PCY,PCZ)
2662 IF(IC.EQ.-1) GO TO 400
2663 ekaon(4,iss)=ekaon(4,iss)+1
2664 IF(XKAON0/(XKAON+XETA).GT.RANART(NSEED))then
2665* kaon production, USE CREN TO CALCULATE THE MOMENTUM OF L/S K+
2666 CALL CREN(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK)
2667* kaon production
2668 IF(IBLOCK.EQ.7) then
2669 LPN=LPN+1
2670 elseIF(IBLOCK.EQ.-7) then
2671 endif
2672c
2673 em1=e(i1)
2674 em2=e(i2)
2675 GO TO 440
2676 endif
2677* N*(1535) FORMATION
2678 resona=1.
2679 GO TO 98
2680 ENDIF
2681*IF PION+NUCLEON (baryon resonance) COLLISION THEN
26823 CONTINUE
2683 px1cm=pcx
2684 py1cm=pcy
2685 pz1cm=pcz
2686* the total kaon production cross section for pion+baryon (resonance) is
2687* assumed to be the same as in pion+nucleon
2688 xkaon0=0.
2689 if(srt.ge.1.63.AND.SRT.LE.1.7)xkaon0=pnlka(srt)
2690 IF(SRT.GT.1.7)XKAON0=PNLKA(SRT)+pnska(srt)
2691 XKAON0 = 2.0 * XKAON0
2692c
2693c sp11/21/01 phi production: pi +N(D) -> phi + N(D)
2694 Xphi = 0.
2695 if( ( ((lb1.ge.1.and.lb1.le.2).or.
2696 & (lb1.ge.6.and.lb1.le.9))
2697 & .OR.((lb2.ge.1.and.lb2.le.2).or.
2698 & (lb2.ge.6.and.lb2.le.9)) )
2699 & .AND. srt.gt.1.958)
2700 & call pibphi(srt,lb1,lb2,em1,em2,Xphi,xphin)
2701c !! in fm^2 above
2702
2703* if a pion collide with a baryon resonance,
2704* we only allow kaon production AND the reabsorption
2705* processes: Delta+pion-->N+pion, N*+pion-->N+pion
2706* Later put in pion+baryon resonance elastic
2707* cross through forming higher resonances implicitly.
2708c If(em1.gt.1.or.em2.gt.1.)go to 31
2709 If((iabs(LB(I1)).ge.6.and.iabs(LB(I1)).le.13).or.
2710 & (iabs(LB(I2)).ge.6.and.iabs(LB(I2)).le.13)) go to 31
2711* For pion+nucleon collisions:
2712* using the experimental pion+nucleon inelastic cross section, we assume it
2713* is exhausted by the Delta+pion, Delta+rho and Delta+omega production
2714* and kaon production. In the following we first check whether
2715* inelastic pion+n collision can happen or not, then determine in
2716* crpn whether it is through pion production or through kaon production
2717* note that the xkaon0 is the kaon production cross section
2718* Note in particular that:
2719* xkaon in the following is the total pion+nucleon inelastic cross section
2720* note here the xkaon is in unit of fm**2, xnpi is also in unit of fm**2
2721* FOR PION+NUCLEON SYSTEM, THE MINIMUM S IS 1.2056 the minimum srt for
2722* elastic scattering, and it is 1.60 for pion production, 1.63 for LAMBDA+kaon
2723* production and 1.7 FOR SIGMA+KAON
2724* (EC = PION MASS+NUCLEON MASS+20MEV)**2
2725 EC=(em1+em2+0.02)**2
2726 xkaon=0.
2727 if(srt.gt.1.23)xkaon=(pionpp(srt)+PIPP1(SRT))/2.
2728* pion+nucleon elastic cross section is divided into two parts:
2729* (1) forming D(1232)+N*(1440) +N*(1535)
2730* (2) cross sections forming higher resonances are calculated as
2731* the difference between the total elastic and (1), this part is
2732* treated as direct process since we do not explicitLY include
2733* higher resonances.
2734* the following is the resonance formation cross sections.
2735*1. PION(+)+PROTON-->DELTA++,PION(-)+NEUTRON-->DELTA(-)
2736 IF( (LB1*LB2.EQ.5.OR.((LB1*LB2.EQ.6).AND.
2737 & (LB1.EQ.3.OR.LB2.EQ.3)))
2738 & .OR. (LB1*LB2.EQ.-3.OR.((LB1*LB2.EQ.-10).AND.
2739 & (LB1.EQ.5.OR.LB2.EQ.5))) )then
2740 XMAX=190.
2741 xmaxn=0
2742 xmaxn1=0
2743 xdirct=dirct1(srt)
2744 go to 678
2745 endif
2746*2. PION(-)+PROTON-->DELTA0,PION(+)+NEUTRON-->DELTA+
2747* or N*(+)(1440) or N*(+)(1535)
2748* note the factor 2/3 is from the isospin consideration and
2749* the factor 0.6 or 0.5 is the branching ratio for the resonance to decay
2750* into pion+nucleon
2751 IF( (LB1*LB2.EQ.3.OR.((LB1*LB2.EQ.10).AND.
2752 & (LB1.EQ.5.OR.LB2.EQ.5)))
2753 & .OR. (LB1*LB2.EQ.-5.OR.((LB1*LB2.EQ.-6).AND.
2754 & (LB1.EQ.3.OR.LB2.EQ.3))) )then
2755 XMAX=27.
2756 xmaxn=2./3.*25.*0.6
2757 xmaxn1=2./3.*40.*0.5
2758 xdirct=dirct2(srt)
2759 go to 678
2760 endif
2761*3. PION0+PROTON-->DELTA+,PION0+NEUTRON-->DELTA0, or N*(0)(1440) or N*(0)(1535)
2762 IF((LB1.EQ.4.OR.LB2.EQ.4).AND.
2763 & (iabs(LB1*LB2).EQ.4.OR.iabs(LB1*LB2).EQ.8))then
2764 XMAX=50.
2765 xmaxn=1./3.*25*0.6
2766 xmaxn1=1/3.*40.*0.5
2767 xdirct=dirct3(srt)
2768 go to 678
2769 endif
2770678 xnpin1=0
2771 xnpin=0
2772 XNPID=XNPI(I1,I2,1,XMAX)
2773 if(xmaxn1.ne.0)xnpin1=XNPI(i1,i2,2,XMAXN1)
2774 if(xmaxn.ne.0)XNPIN=XNPI(I1,I2,0,XMAXN)
2775* the following
2776 xres=xnpid+xnpin+xnpin1
2777 xnelas=xres+xdirct
2778 icheck=1
2779 go to 34
2780* For pion + baryon resonance the reabsorption
2781* cross section is calculated from the detailed balance
2782* using reab(i1,i2,srt,ictrl), ictrl=1, 2 and 3
2783* for pion, rho and omega + baryon resonance
278431 ec=(em1+em2+0.02)**2
2785 xreab=reab(i1,i2,srt,1)
2786
2787clin-12/02/00 to satisfy detailed balance, forbid N* absorptions:
2788 if((iabs(lb1).ge.10.and.iabs(lb1).le.13)
2789 1 .or.(iabs(lb2).ge.10.and.iabs(lb2).le.13)) XREAB = 0.
2790
2791 xkaon=xkaon0+xreab
2792* a constant of 10 mb IS USED FOR PION + N* RESONANCE,
2793 IF((iabs(LB1).GT.9.AND.iabs(LB1).LE.13) .OR.
2794 & (iabs(LB2).GT.9.AND.iabs(LB2).LE.13))THEN
2795 Xnelas=1.0
2796 ELSE
2797 XNELAS=DPION(EM1,EM2,LB1,LB2,SRT)
2798 ENDIF
2799 icheck=2
280034 IF((Xnelas+xkaon+Xphi).LE.0.000001)GO TO 400
2801 DS=SQRT((Xnelas+xkaon+Xphi)/PI)
2802csp09/20/01
2803c totcr = xnelas+xkaon
2804c if(srt .gt. 3.5)totcr = max1(totcr,3.)
2805c DS=SQRT(totcr/PI)
2806csp09/20/01 end
2807
2808 deltar=ds+0.1
2809 CALL DISTCE(I1,I2,DELTAR,DS,DT,EC,SRT,IC,
2810 1 PCX,PCY,PCZ)
2811 IF(IC.EQ.-1) GO TO 400
2812 ekaon(4,iss)=ekaon(4,iss)+1
2813c***
2814* check what kind of collision has happened
2815* (1) pion+baryon resonance
2816* if direct elastic process
2817 if(icheck.eq.2)then
2818c !!sp11/21/01
2819 if(xnelas/(xnelas+xkaon+Xphi).ge.RANART(NSEED))then
2820c call Crdir(PX1CM,PY1CM,PZ1CM,SRT,I1,I2)
2821 call Crdir(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK)
2822 go to 440
2823 else
2824* for inelastic process, go to 96 to check
2825* kaon production and pion reabsorption : pion+D(N*)-->pion+N
2826 go to 96
2827 endif
2828 endif
2829*(2) pion+n
2830* CHECK IF inELASTIC COLLISION IS POSSIBLE FOR PION+N COLLISIONS
2831clin-8/17/00 typo corrected, many other occurences:
2832c IF(XKAON/(XKAON+Xnelas).GT.RANART(NSEED))GO TO 95
2833 IF((XKAON+Xphi)/(XKAON+Xphi+Xnelas).GT.RANART(NSEED))GO TO 95
2834
2835* direct process
2836 if(xdirct/xnelas.ge.RANART(NSEED))then
2837c call Crdir(PX1CM,PY1CM,PZ1CM,SRT,I1,I2)
2838 call Crdir(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK)
2839 go to 440
2840 endif
2841* now resonance formation or direct process (higher resonances)
2842 IF( (LB1*LB2.EQ.5.OR.((LB1*LB2.EQ.6).AND.
2843 & (LB1.EQ.3.OR.LB2.EQ.3)))
2844 & .OR. (LB1*LB2.EQ.-3.OR.((LB1*LB2.EQ.-10).AND.
2845 & (LB1.EQ.5.OR.LB2.EQ.5))) )then
2846c
2847* ONLY DELTA RESONANCE IS POSSIBLE, go to 99
2848 GO TO 99
2849 else
2850* NOW BOTH DELTA AND N* RESORANCE ARE POSSIBLE
2851* DETERMINE THE RESORANT STATE BY USING THE MONTRE CARLO METHOD
2852 XX=(XNPIN+xnpin1)/xres
2853 IF(RANART(NSEED).LT.XX)THEN
2854* N* RESONANCE IS SELECTED
2855* decide N*(1440) or N*(1535) formation
2856 xx0=xnpin/(xnpin+xnpin1)
2857 if(RANART(NSEED).lt.xx0)then
2858 RESONA=0.
2859* N*(1440) formation
2860 GO TO 97
2861 else
2862* N*(1535) formation
2863 resona=1.
2864 GO TO 98
2865 endif
2866 ELSE
2867* DELTA RESONANCE IS SELECTED
2868 GO TO 99
2869 ENDIF
2870 ENDIF
287197 CONTINUE
2872 IF(RESONA.EQ.0.)THEN
2873*N*(1440) IS PRODUCED,WE DETERMINE THE CHARGE STATE OF THE PRODUCED N*
2874 I=I1
2875 IF(EM1.LT.0.6)I=I2
2876* (0.1) n+pion(+)-->N*(+)
2877 IF( (LB1*LB2.EQ.10.AND.(LB1.EQ.5.OR.LB2.EQ.5))
2878 & .OR.(LB1*LB2.EQ.-6.AND.(LB1.EQ.3.OR.LB2.EQ.3)) )THEN
2879 LB(I)=11
2880 go to 303
2881 ENDIF
2882* (0.2) p+pion(0)-->N*(+)
2883c IF(LB(I1)*LB(I2).EQ.4.AND.(LB(I1).EQ.1.OR.LB(I2).EQ.1))THEN
2884 IF(iabs(LB(I1)*LB(I2)).EQ.4.AND.
2885 & (LB(I1).EQ.4.OR.LB(I2).EQ.4))THEN
2886 LB(I)=11
2887 go to 303
2888 ENDIF
2889* (0.3) n+pion(0)-->N*(0)
2890c IF(LB(I1)*LB(I2).EQ.8.AND.(LB(I1).EQ.2.OR.LB(I2).EQ.2))THEN
2891 IF(iabs(LB(I1)*LB(I2)).EQ.8.AND.
2892 & (LB(I1).EQ.4.OR.LB(I2).EQ.4))THEN
2893 LB(I)=10
2894 go to 303
2895 ENDIF
2896* (0.4) p+pion(-)-->N*(0)
2897c IF(LB(I1)*LB(I2).EQ.3)THEN
2898 IF( (LB(I1)*LB(I2).EQ.3)
2899 & .OR.(LB(I1)*LB(I2).EQ.-5) )THEN
2900 LB(I)=10
2901 ENDIF
2902303 CALL DRESON(I1,I2)
2903 if(LB1.lt.0.or.LB2.lt.0) LB(I)=-LB(I)
2904 lres=lres+1
2905 GO TO 101
2906*COM: GO TO 101 TO CHANGE THE PHASE SPACE DENSITY OF THE NUCLEON
2907 ENDIF
290898 IF(RESONA.EQ.1.)THEN
2909*N*(1535) IS PRODUCED, WE DETERMINE THE CHARGE STATE OF THE PRODUCED N*
2910 I=I1
2911 IF(EM1.LT.0.6)I=I2
2912* note: this condition applies to both eta and pion
2913* (0.1) n+pion(+)-->N*(+)
2914c IF(LB1*LB2.EQ.10.AND.(LB1.EQ.2.OR.LB2.EQ.2))THEN
2915 IF( (LB1*LB2.EQ.10.AND.(LB1.EQ.5.OR.LB2.EQ.5))
2916 & .OR.(LB1*LB2.EQ.-6.AND.(LB1.EQ.3.OR.LB2.EQ.3)) )THEN
2917 LB(I)=13
2918 go to 304
2919 ENDIF
2920* (0.2) p+pion(0)-->N*(+)
2921c IF(LB(I1)*LB(I2).EQ.4.AND.(LB(I1).EQ.1.OR.LB(I2).EQ.1))THEN
2922 IF(iabs(LB(I1)*LB(I2)).EQ.4.AND.
2923 & (LB(I1).EQ.4.OR.LB(I2).EQ.4))THEN
2924 LB(I)=13
2925 go to 304
2926 ENDIF
2927* (0.3) n+pion(0)-->N*(0)
2928c IF(LB(I1)*LB(I2).EQ.8.AND.(LB(I1).EQ.2.OR.LB(I2).EQ.2))THEN
2929 IF(iabs(LB(I1)*LB(I2)).EQ.8.AND.
2930 & (LB(I1).EQ.4.OR.LB(I2).EQ.4))THEN
2931 LB(I)=12
2932 go to 304
2933 ENDIF
2934* (0.4) p+pion(-)-->N*(0)
2935c IF(LB(I1)*LB(I2).EQ.3)THEN
2936 IF( (LB(I1)*LB(I2).EQ.3)
2937 & .OR.(LB(I1)*LB(I2).EQ.-5) )THEN
2938 LB(I)=12
2939 go to 304
2940 endif
2941* (0.5) p+eta-->N*(+)(1535),n+eta-->N*(0)(1535)
2942 if(lb(i1)*lb(i2).eq.0)then
2943c if((lb(i1).eq.1).or.(lb(i2).eq.1))then
2944 if(iabs(lb(i1)).eq.1.or.iabs(lb(i2)).eq.1)then
2945 LB(I)=13
2946 go to 304
2947 ELSE
2948 LB(I)=12
2949 ENDIF
2950 endif
2951304 CALL DRESON(I1,I2)
2952 if(LB1.lt.0.or.LB2.lt.0) LB(I)=-LB(I)
2953 lres=lres+1
2954 GO TO 101
2955*COM: GO TO 101 TO CHANGE THE PHASE SPACE DENSITY OF THE NUCLEON
2956 ENDIF
2957*DELTA IS PRODUCED,IN THE FOLLOWING WE DETERMINE THE
2958*CHARGE STATE OF THE PRODUCED DELTA
295999 LRES=LRES+1
2960 I=I1
2961 IF(EM1.LE.0.6)I=I2
2962* (1) p+pion(+)-->DELTA(++)
2963c IF(LB(I1)*LB(I2).EQ.5)THEN
2964 IF( (LB(I1)*LB(I2).EQ.5)
2965 & .OR.(LB(I1)*LB(I2).EQ.-3) )THEN
2966 LB(I)=9
2967 go to 305
2968 ENDIF
2969* (2) p+pion(0)-->delta(+)
2970c IF(LB(I1)*LB(I2).EQ.4.AND.(LB(I1).EQ.1.OR.LB(I2).EQ.1))then
2971 IF(iabs(LB(I1)*LB(I2)).EQ.4.AND.(LB(I1).EQ.4.OR.LB(I2).EQ.4))then
2972 LB(I)=8
2973 go to 305
2974 ENDIF
2975* (3) n+pion(+)-->delta(+)
2976c IF(LB(I1)*LB(I2).EQ.10.AND.(LB(I1).EQ.2.OR.LB(I2).EQ.2))THEN
2977 IF( (LB(I1)*LB(I2).EQ.10.AND.(LB(I1).EQ.5.OR.LB(I2).EQ.5))
2978 & .OR.(LB(I1)*LB(I2).EQ.-6.AND.(LB(I1).EQ.3.OR.LB(I2).EQ.3)) )THEN
2979 LB(I)=8
2980 go to 305
2981 ENDIF
2982* (4) n+pion(0)-->delta(0)
2983c IF(LB(I1)*LB(I2).EQ.8.AND.(LB(I1).EQ.2.OR.LB(I2).EQ.2))THEN
2984 IF(iabs(LB(I1)*LB(I2)).EQ.8.AND.(LB(I1).EQ.4.OR.LB(I2).EQ.4))THEN
2985 LB(I)=7
2986 go to 305
2987 ENDIF
2988* (5) p+pion(-)-->delta(0)
2989c IF(LB(I1)*LB(I2).EQ.3)THEN
2990 IF( (LB(I1)*LB(I2).EQ.3)
2991 & .OR.(LB(I1)*LB(I2).EQ.-5) )THEN
2992 LB(I)=7
2993 go to 305
2994 ENDIF
2995* (6) n+pion(-)-->delta(-)
2996c IF(LB(I1)*LB(I2).EQ.6.AND.(LB(I1).EQ.2.OR.LB(I2).EQ.2))THEN
2997 IF( (LB(I1)*LB(I2).EQ.6.AND.(LB(I1).EQ.3.OR.LB(I2).EQ.3))
2998 & .OR.(LB(I1)*LB(I2).EQ.-10.AND.(LB(I1).EQ.5.OR.LB(I2).EQ.5)) )THEN
2999 LB(I)=6
3000 ENDIF
3001305 CALL DRESON(I1,I2)
3002 if(LB1.lt.0.or.LB2.lt.0) LB(I)=-LB(I)
3003 GO TO 101
3004
3005csp-11/08/01 K*
3006* FOR kaON+pion COLLISIONS, form K* (bar) or
3007c La/Si-bar + N <-- pi + K+
3008c La/Si + N-bar <-- pi + K-
3009c phi + K <-- pi + K
3010clin (rho,omega) + K* <-- pi + K
3011889 CONTINUE
3012 PX1CM=PCX
3013 PY1CM=PCY
3014 PZ1CM=PCZ
3015 EC=(em1+em2+0.02)**2
3016* the cross section is from C.M. Ko, PRC 23, 2760 (1981).
3017 spika=60./(1.+4.*(srt-0.895)**2/(0.05)**2)
3018c
3019cc if(lb(i1).eq.23.or.lb(i2).eq.23)then !! block K- + pi->La + B-bar
3020
3021 call Crkpla(PX1CM,PY1CM,PZ1CM,EC,SRT,spika,
3022 & emm1,emm2,lbp1,lbp2,I1,I2,icase,srhoks)
3023cc
3024c* only K* or K*bar formation
3025c else
3026c DSkn=SQRT(spika/PI/10.)
3027c dsknr=dskn+0.1
3028c CALL DISTCE(I1,I2,dsknr,DSkn,DT,EC,SRT,IC,
3029c 1 PX1CM,PY1CM,PZ1CM)
3030c IF(IC.EQ.-1) GO TO 400
3031c icase = 1
3032c endif
3033c
3034 if(icase .eq. 0) then
3035 iblock=0
3036 go to 400
3037 endif
3038
3039 if(icase .eq. 1)then
3040 call KSRESO(I1,I2)
3041clin-4/30/03 give non-zero iblock for resonance selections:
3042 iblock = 171
3043ctest off for resonance (phi, K*) studies:
3044c if(iabs(lb(i1)).eq.30) then
3045c write(17,112) 'ks',lb(i1),p(1,i1),p(2,i1),p(3,i1),e(i1),nt
3046c elseif(iabs(lb(i2)).eq.30) then
3047c write(17,112) 'ks',lb(i2),p(1,i2),p(2,i2),p(3,i2),e(i2),nt
3048c endif
3049c
3050 lres=lres+1
3051 go to 101
3052 elseif(icase .eq. 2)then
3053 iblock = 71
3054c
3055* La/Si (bar) formation
3056
3057 elseif(iabs(icase).eq.5)then
3058 iblock = 88
3059
3060 else
3061*
3062* phi formation
3063 iblock = 222
3064 endif
3065 LB(I1) = lbp1
3066 LB(I2) = lbp2
3067 E(I1) = emm1
3068 E(I2) = emm2
3069 em1=e(i1)
3070 em2=e(i2)
3071 ntag = 0
3072 go to 440
3073c
307433 continue
3075 em1=e(i1)
3076 em2=e(i2)
3077* (1) if rho or omega collide with a nucleon we allow both elastic
3078* scattering and kaon production to happen if collision conditions
3079* are satisfied.
3080* (2) if rho or omega collide with a baryon resonance we allow
3081* kaon production, pion reabsorption: rho(omega)+D(N*)-->pion+N
3082* and NO elastic scattering to happen
3083 xelstc=0
3084 if((lb1.ge.25.and.lb1.le.28).and.
3085 & (iabs(lb2).eq.1.or.iabs(lb2).eq.2))
3086 & xelstc=ERHON(EM1,EM2,LB1,LB2,SRT)
3087 if((lb2.ge.25.and.lb2.le.28).and.
3088 & (iabs(lb1).eq.1.or.iabs(lb1).eq.2))
3089 & xelstc=ERHON(EM1,EM2,LB1,LB2,SRT)
3090 ec=(em1+em2+0.02)**2
3091* the kaon production cross section is
3092 xkaon0=0
3093 if(srt.ge.1.63.AND.SRT.LE.1.7)xkaon0=pnlka(srt)
3094 IF(SRT.GT.1.7)XKAON0=PNLKA(SRT)+pnska(srt)
3095 if(xkaon0.lt.0)xkaon0=0
3096
3097cbz3/7/99 neutralk
3098 XKAON0 = 2.0 * XKAON0
3099cbz3/7/99 neutralk end
3100
3101* the total inelastic cross section for rho(omega)+N is
3102 xkaon=xkaon0
3103 ichann=0
3104* the total inelastic cross section for rho (omega)+D(N*) is
3105* xkaon=xkaon0+reab(**)
3106
3107c sp11/21/01 phi production: rho + N(D) -> phi + N(D)
3108 Xphi = 0.
3109 if( ( (((lb1.ge.1.and.lb1.le.2).or.
3110 & (lb1.ge.6.and.lb1.le.9))
3111 & .and.(lb2.ge.25.and.lb2.le.27))
3112 & .OR.(((lb2.ge.1.and.lb2.le.2).or.
3113 & (lb2.ge.6.and.lb2.le.9))
3114 & .and.(lb1.ge.25.and.lb1.le.27)) ).AND. srt.gt.1.958)
3115 & call pibphi(srt,lb1,lb2,em1,em2,Xphi,xphin)
3116c !! in fm^2 above
3117c
3118 if((iabs(lb1).ge.6.and.lb2.ge.25).or.
3119 & (lb1.ge.25.and.iabs(lb2).ge.6))then
3120 ichann=1
3121 ictrl=2
3122 if(lb1.eq.28.or.lb2.eq.28)ictrl=3
3123 xreab=reab(i1,i2,srt,ictrl)
3124
3125clin-12/02/00 to satisfy detailed balance, forbid N* absorptions:
3126 if((iabs(lb1).ge.10.and.iabs(lb1).le.13)
3127 1 .or.(iabs(lb2).ge.10.and.iabs(lb2).le.13)) XREAB = 0.
3128
3129 if(xreab.lt.0)xreab=1.E-06
3130 xkaon=xkaon0+xreab
3131 XELSTC=1.0
3132 endif
3133 DS=SQRT((XKAON+Xphi+xelstc)/PI)
3134c
3135csp09/20/01
3136c totcr = xelstc+xkaon
3137c if(srt .gt. 3.5)totcr = max1(totcr,3.)
3138c DS=SQRT(totcr/PI)
3139csp09/20/01 end
3140c
3141 DELTAR=DS+0.1
3142 px1cm=pcx
3143 py1cm=pcy
3144 pz1cm=pcz
3145* CHECK IF the collision can happen
3146 CALL DISTCE(I1,I2,DELTAR,DS,DT,EC,SRT,IC,
3147 1 PCX,PCY,PCZ)
3148 IF(IC.EQ.-1) GO TO 400
3149 ekaon(4,iss)=ekaon(4,iss)+1
3150c*
3151* NOW rho(omega)+N or D(N*) COLLISION IS POSSIBLE
3152* (1) check elastic collision
3153 if(xelstc/(xelstc+xkaon+Xphi).gt.RANART(NSEED))then
3154c call crdir(px1CM,py1CM,pz1CM,srt,I1,i2)
3155 call crdir(px1CM,py1CM,pz1CM,srt,I1,i2,IBLOCK)
3156 go to 440
3157 endif
3158* (2) check pion absorption or kaon production
3159 CALL CRRD(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3160 1 IBLOCK,xkaon0,xkaon,Xphi,xphin)
3161
3162* kaon production
3163csp05/16/01
3164 IF(IBLOCK.EQ.7) then
3165 LPN=LPN+1
3166 elseIF(IBLOCK.EQ.-7) then
3167 endif
3168csp05/16/01 end
3169* rho obsorption
3170 if(iblock.eq.81) lrhor=lrhor+1
3171* omega obsorption
3172 if(iblock.eq.82) lomgar=lomgar+1
3173 em1=e(i1)
3174 em2=e(i2)
3175 GO TO 440
3176* for pion+n now using the subroutine crpn to change
3177* the particle label and set the new momentum of L/S+K final state
317895 continue
3179* NOW PION+N INELASTIC COLLISION IS POSSIBLE
3180* check pion production or kaon production
3181 CALL CRPN(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3182 1 IBLOCK,xkaon0,xkaon,Xphi,xphin)
3183
3184* kaon production
3185csp05/16/01
3186 IF(IBLOCK.EQ.7) then
3187 LPN=LPN+1
3188 elseIF(IBLOCK.EQ.-7) then
3189 endif
3190csp05/16/01 end
3191* pion production
3192 if(iblock.eq.77) lpd=lpd+1
3193* rho production
3194 if(iblock.eq.78) lrho=lrho+1
3195* omega production
3196 if(iblock.eq.79) lomega=lomega+1
3197 em1=e(i1)
3198 em2=e(i2)
3199 GO TO 440
3200* for pion+D(N*) now using the subroutine crpd to
3201* (1) check kaon production or pion reabsorption
3202* (2) change the particle label and set the new
3203* momentum of L/S+K final state
320496 continue
3205 CALL CRPD(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3206 1 IBLOCK,xkaon0,xkaon,Xphi,xphin)
3207
3208* kaon production
3209csp05/16/01
3210 IF(IBLOCK.EQ.7) then
3211 LPN=LPN+1
3212 elseIF(IBLOCK.EQ.-7) then
3213 endif
3214csp05/16/01 end
3215* pion obserption
3216 if(iblock.eq.80) lpdr=lpdr+1
3217 em1=e(i1)
3218 em2=e(i2)
3219 GO TO 440
3220* CALCULATE KAON PRODUCTION PROBABILITY FROM PION + N COLLISIONS
3221C IF(SRT.GT.1.615)THEN
3222C CALL PKAON(SRT,XXp,PK)
3223C TKAON(7)=TKAON(7)+PK
3224C EKAON(7,ISS)=EKAON(7,ISS)+1
3225c CALL KSPEC1(SRT,PK)
3226C call LK(3,srt,iseed,pk)
3227C ENDIF
3228* negelecting the pauli blocking at high energies
3229
3230101 continue
3231 IF(E(I2).EQ.0.)GO TO 600
3232 IF(E(I1).EQ.0.)GO TO 800
3233* IF NUCLEON+BARYON RESONANCE COLLISIONS
323444 CONTINUE
3235* CALCULATE THE TOTAL CROSS SECTION OF NUCLEON+ BARYON RESONANCE COLLISION
3236* WE ASSUME THAT THE ELASTIC CROSS SECTION IS THE SAME AS NUCLEON+NUCLEON
3237* COM: WE USE THE PARAMETERISATION BY CUGNON FOR LOW ENERGIES
3238* AND THE PARAMETERIZATIONS FROM CERN DATA BOOK FOR HIGHER
3239* ENERGIES. THE CUTOFF FOR THE TOTAL CROSS SECTION IS 55 MB
3240 cutoff=em1+em2+0.02
3241 IF(SRT.LE.CUTOFF)GO TO 400
3242 IF(SRT.GT.2.245)THEN
3243 SIGNN=PP2(SRT)
3244 ELSE
3245 SIGNN = 35.0 / (1. + (SRT - CUTOFF) * 100.0) + 20.0
3246 ENDIF
3247 call XND(pcx,pcy,pcz,srt,I1,I2,xinel,
3248 & sigk,xsk1,xsk2,xsk3,xsk4,xsk5)
3249 sig=signn+xinel
3250* For nucleon+baryon resonance collision, the minimum cms**2 energy is
3251 EC=(EM1+EM2+0.02)**2
3252* CHECK THE DISTENCE BETWEEN THE TWO PARTICLES
3253 PX1CM=PCX
3254 PY1CM=PCY
3255 PZ1CM=PCZ
3256
3257clin-6/2008 Deuteron production:
3258 ianti=0
3259 if(lb(i1).lt.0 .and. lb(i2).lt.0) ianti=1
3260 call sbbdm(srt,sdprod,ianti,lbm,xmm,pfinal)
3261 sig=sig+sdprod
3262clin-6/2008 perturbative treatment of deuterons:
3263 ipdflag=0
3264 if(idpert.eq.1) then
3265 ipert1=1
3266 sigr0=sig
3267 dspert=sqrt(sigr0/pi/10.)
3268 dsrpert=dspert+0.1
3269 CALL DISTCE(I1,I2,dsrpert,dspert,DT,EC,SRT,IC,
3270 1 PX1CM,PY1CM,PZ1CM)
3271 IF(IC.EQ.-1) GO TO 363
3272 signn0=0.
3273 CALL CRND(IRUN,PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3274 & IBLOCK,SIGNN0,SIGr0,sigk,xsk1,xsk2,xsk3,xsk4,xsk5,NT,ipert1)
3275c & IBLOCK,SIGNN,SIG,sigk,xsk1,xsk2,xsk3,xsk4,xsk5)
3276 ipdflag=1
3277 363 continue
3278 ipert1=0
3279 endif
3280 if(idpert.eq.2) ipert1=1
3281c
3282 DS=SQRT(SIG/(10.*PI))
3283 DELTAR=DS+0.1
3284 CALL DISTCE(I1,I2,DELTAR,DS,DT,EC,SRT,IC,
3285 1 PX1CM,PY1CM,PZ1CM)
3286c IF(IC.EQ.-1)GO TO 400
3287 IF(IC.EQ.-1) then
3288 if(ipdflag.eq.1) iblock=501
3289 GO TO 400
3290 endif
3291
3292 ekaon(3,iss)=ekaon(3,iss)+1
3293* CALCULATE KAON PRODUCTION PROBABILITY FROM NUCLEON + BARYON RESONANCE
3294* COLLISIONS
3295 go to 361
3296
3297* CHECK WHAT KIND OF COLLISION HAS HAPPENED
3298 361 continue
3299 CALL CRND(IRUN,PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3300 & IBLOCK,SIGNN,SIG,sigk,xsk1,xsk2,xsk3,xsk4,xsk5,NT,ipert1)
3301c & IBLOCK,SIGNN,SIG,sigk,xsk1,xsk2,xsk3,xsk4,xsk5)
3302 IF(iblock.eq.0.and.ipdflag.eq.1) iblock=501
3303 IF(IBLOCK.EQ.11)THEN
3304 LNDK=LNDK+1
3305 GO TO 400
3306c elseIF(IBLOCK.EQ.-11) then
3307 elseIF(IBLOCK.EQ.-11.or.iblock.eq.501) then
3308 GO TO 400
3309 ENDIF
3310 if(iblock .eq. 222)then
3311c !! sp12/17/01
3312 GO TO 400
3313 ENDIF
3314 em1=e(i1)
3315 em2=e(i2)
3316 GO TO 440
3317* IF NUCLEON+NUCLEON OR BARYON RESONANCE+BARYON RESONANCE COLLISIONS
33184 CONTINUE
3319* PREPARE THE EALSTIC CROSS SECTION FOR BARYON+BARYON COLLISIONS
3320* COM: WE USE THE PARAMETERISATION BY CUGNON FOR SRT LEQ 2.0 GEV
3321* AND THE PARAMETERIZATIONS FROM CERN DATA BOOK FOR HIGHER
3322* ENERGIES. THE CUTOFF FOR THE TOTAL CROSS SECTION IS 55 MB
3323* WITH LOW-ENERGY-CUTOFF
3324 CUTOFF=em1+em2+0.14
3325* AT HIGH ENERGIES THE ISOSPIN DEPENDENCE IS NEGLIGIBLE
3326* THE TOTAL CROSS SECTION IS TAKEN AS THAT OF THE PP
3327* ABOVE E_KIN=800 MEV, WE USE THE ISOSPIN INDEPENDNET XSECTION
3328 IF(SRT.GT.2.245)THEN
3329 SIG=ppt(srt)
3330 SIGNN=SIG-PP1(SRT)
3331 ELSE
3332* AT LOW ENERGIES THE ISOSPIN DEPENDENCE FOR NN COLLISION IS STRONG
3333 SIG=XPP(SRT)
3334 IF(ZET(LB(I1))*ZET(LB(I2)).LE.0)SIG=XNP(SRT)
3335 IF(ZET(LB(I1))*ZET(LB(I2)).GT.0)SIG=XPP(SRT)
3336 IF(ZET(LB(I1)).EQ.0.
3337 & AND.ZET(LB(I2)).EQ.0)SIG=XPP(SRT)
3338 if((lb(i1).eq.-1.and.lb(i2).eq.-2) .or.
3339 & (lb(i2).eq.-1.and.lb(i1).eq.-2))sig=xnp(srt)
3340* WITH LOW-ENERGY-CUTOFF
3341 IF (SRT .LT. 1.897) THEN
3342 SIGNN = SIG
3343 ELSE
3344 SIGNN = 35.0 / (1. + (SRT - 1.897) * 100.0) + 20.0
3345 ENDIF
3346 ENDIF
3347 PX1CM=PCX
3348 PY1CM=PCY
3349 PZ1CM=PCZ
3350clin-5/2008 Deuteron production cross sections were not included
3351c in the previous parameterized inelastic cross section of NN collisions
3352c (SIGinel=SIG-SIGNN), so they are added here:
3353 ianti=0
3354 if(lb(i1).lt.0 .and. lb(i2).lt.0) ianti=1
3355 call sbbdm(srt,sdprod,ianti,lbm,xmm,pfinal)
3356 sig=sig+sdprod
3357c
3358clin-5/2008 perturbative treatment of deuterons:
3359 ipdflag=0
3360 if(idpert.eq.1) then
3361c For idpert=1: ipert1=1 means we will first treat deuteron perturbatively,
3362c then we set ipert1=0 to treat regular NN or NbarNbar collisions including
3363c the regular deuteron productions.
3364c ipdflag=1 means perturbative deuterons are produced here:
3365 ipert1=1
3366 EC=2.012**2
3367c Use the same cross section for NN/NNBAR collisions
3368c to trigger perturbative production
3369 sigr0=sig
3370c One can also trigger with X*sbbdm() so the weight will not be too small;
3371c but make sure to limit the maximum trigger Xsec:
3372c sigr0=sdprod*25.
3373c if(sigr0.ge.100.) sigr0=100.
3374 dspert=sqrt(sigr0/pi/10.)
3375 dsrpert=dspert+0.1
3376 CALL DISTCE(I1,I2,dsrpert,dspert,DT,EC,SRT,IC,
3377 1 PX1CM,PY1CM,PZ1CM)
3378 IF(IC.EQ.-1) GO TO 365
3379 signn0=0.
3380 CALL CRNN(IRUN,PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK,
3381 1 NTAG,signn0,sigr0,NT,ipert1)
3382 ipdflag=1
3383 365 continue
3384 ipert1=0
3385 endif
3386 if(idpert.eq.2) ipert1=1
3387c
3388clin-5/2008 in case perturbative deuterons are produced for idpert=1:
3389c IF(SIGNN.LE.0)GO TO 400
3390 IF(SIGNN.LE.0) then
3391 if(ipdflag.eq.1) iblock=501
3392 GO TO 400
3393 endif
3394c
3395 EC=3.59709
3396 ds=sqrt(sig/pi/10.)
3397 dsr=ds+0.1
3398 IF((E(I1).GE.1.).AND.(e(I2).GE.1.))EC=4.75
3399 CALL DISTCE(I1,I2,dsr,ds,DT,EC,SRT,IC,
3400 1 PX1CM,PY1CM,PZ1CM)
3401clin-5/2008 in case perturbative deuterons are produced above:
3402c IF(IC.EQ.-1) GO TO 400
3403 IF(IC.EQ.-1) then
3404 if(ipdflag.eq.1) iblock=501
3405 GO TO 400
3406 endif
3407c
3408* CALCULATE KAON PRODUCTION PROBABILITY FROM NUCLEON+NUCLEON OR
3409* RESONANCE+RESONANCE COLLISIONS
3410 go to 362
3411
3412C CHECK WHAT KIND OF COLLISION HAS HAPPENED
3413 362 ekaon(1,iss)=ekaon(1,iss)+1
3414 CALL CRNN(IRUN,PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK,
3415 1 NTAG,SIGNN,SIG,NT,ipert1)
3416clin-5/2008 give iblock # in case pert deuterons are produced for idpert=1:
3417 IF(iblock.eq.0.and.ipdflag.eq.1) iblock=501
3418clin-5/2008 add iblock # for deuteron formation:
3419c IF(IBLOCK.EQ.4.OR.IBLOCK.Eq.9.or.iblock.ge.44.OR.IBLOCK.EQ.-9
3420c & .or.iblock.eq.222)THEN
3421 IF(IBLOCK.EQ.4.OR.IBLOCK.Eq.9.or.iblock.ge.44.OR.IBLOCK.EQ.-9
3422 & .or.iblock.eq.222.or.iblock.eq.501)THEN
3423c
3424c !! sp12/17/01 above
3425* momentum of the three particles in the final state have been calculated
3426* in the crnn, go out of the loop
3427 LCOLL=LCOLL+1
3428 if(iblock.eq.4)then
3429 LDIRT=LDIRT+1
3430 elseif(iblock.eq.44)then
3431 LDdrho=LDdrho+1
3432 elseif(iblock.eq.45)then
3433 Lnnrho=Lnnrho+1
3434 elseif(iblock.eq.46)then
3435 Lnnom=Lnnom+1
3436 elseif(iblock .eq. 222)then
3437 elseIF(IBLOCK.EQ.9) then
3438 LNNK=LNNK+1
3439 elseIF(IBLOCK.EQ.-9) then
3440 endif
3441 GO TO 400
3442 ENDIF
3443
3444 em1=e(i1)
3445 em2=e(i2)
3446 GO TO 440
3447clin-8/2008 B+B->Deuteron+Meson over
3448c
3449clin-8/2008 Deuteron+Meson->B+B collisions:
3450 505 continue
3451 ianti=0
3452 if(lb(i1).lt.0 .or. lb(i2).lt.0) ianti=1
3453 call sdmbb(SRT,sdm,ianti)
3454 PX1CM=PCX
3455 PY1CM=PCY
3456 PZ1CM=PCZ
3457c minimum srt**2, note a 2.012GeV lower cutoff is used in N+N->Deuteron+pi:
3458 EC=2.012**2
3459 ds=sqrt(sdm/31.4)
3460 dsr=ds+0.1
3461 CALL DISTCE(I1,I2,dsr,ds,DT,EC,SRT,IC,PX1CM,PY1CM,PZ1CM)
3462 IF(IC.EQ.-1) GO TO 400
3463 CALL crdmbb(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK,
3464 1 NTAG,sdm,NT,ianti)
3465 LCOLL=LCOLL+1
3466 GO TO 400
3467clin-8/2008 Deuteron+Meson->B+B collisions over
3468c
3469clin-9/2008 Deuteron+Baryon elastic collisions:
3470 506 continue
3471 ianti=0
3472 if(lb(i1).lt.0 .or. lb(i2).lt.0) ianti=1
3473 call sdbelastic(SRT,sdb)
3474 PX1CM=PCX
3475 PY1CM=PCY
3476 PZ1CM=PCZ
3477c minimum srt**2, note a 2.012GeV lower cutoff is used in N+N->Deuteron+pi:
3478 EC=2.012**2
3479 ds=sqrt(sdb/31.4)
3480 dsr=ds+0.1
3481 CALL DISTCE(I1,I2,dsr,ds,DT,EC,SRT,IC,PX1CM,PY1CM,PZ1CM)
3482 IF(IC.EQ.-1) GO TO 400
3483 CALL crdbel(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK,
3484 1 NTAG,sdb,NT,ianti)
3485 LCOLL=LCOLL+1
3486 GO TO 400
3487clin-9/2008 Deuteron+Baryon elastic collisions over
3488c
3489* IF BARYON RESONANCE+BARYON RESONANCE COLLISIONS
3490 444 CONTINUE
3491* PREPARE THE EALSTIC CROSS SECTION FOR BARYON+BARYON COLLISIONS
3492 CUTOFF=em1+em2+0.02
3493* AT HIGH ENERGIES THE ISOSPIN DEPENDENCE IS NEGLIGIBLE
3494* THE TOTAL CROSS SECTION IS TAKEN AS THAT OF THE PP
3495 IF(SRT.LE.CUTOFF)GO TO 400
3496 IF(SRT.GT.2.245)THEN
3497 SIGNN=PP2(SRT)
3498 ELSE
3499 SIGNN = 35.0 / (1. + (SRT - CUTOFF) * 100.0) + 20.0
3500 ENDIF
3501 IF(SIGNN.LE.0)GO TO 400
3502 CALL XDDIN(PCX,PCY,PCZ,SRT,I1,I2,
3503 &XINEL,SIGK,XSK1,XSK2,XSK3,XSK4,XSK5)
3504 SIG=SIGNN+XINEL
3505 EC=(EM1+EM2+0.02)**2
3506 PX1CM=PCX
3507 PY1CM=PCY
3508 PZ1CM=PCZ
3509
3510clin-6/2008 Deuteron production:
3511 ianti=0
3512 if(lb(i1).lt.0 .and. lb(i2).lt.0) ianti=1
3513 call sbbdm(srt,sdprod,ianti,lbm,xmm,pfinal)
3514 sig=sig+sdprod
3515clin-6/2008 perturbative treatment of deuterons:
3516 ipdflag=0
3517 if(idpert.eq.1) then
3518 ipert1=1
3519 sigr0=sig
3520 dspert=sqrt(sigr0/pi/10.)
3521 dsrpert=dspert+0.1
3522 CALL DISTCE(I1,I2,dsrpert,dspert,DT,EC,SRT,IC,
3523 1 PX1CM,PY1CM,PZ1CM)
3524 IF(IC.EQ.-1) GO TO 367
3525 signn0=0.
3526 CALL CRDD(IRUN,PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3527 1 IBLOCK,NTAG,SIGNN0,SIGr0,NT,ipert1)
3528c 1 IBLOCK,NTAG,SIGNN,SIG)
3529 ipdflag=1
3530 367 continue
3531 ipert1=0
3532 endif
3533 if(idpert.eq.2) ipert1=1
3534c
3535 ds=sqrt(sig/31.4)
3536 dsr=ds+0.1
3537 CALL DISTCE(I1,I2,dsr,ds,DT,EC,SRT,IC,
3538 1 PX1CM,PY1CM,PZ1CM)
3539c IF(IC.EQ.-1) GO TO 400
3540 IF(IC.EQ.-1) then
3541 if(ipdflag.eq.1) iblock=501
3542 GO TO 400
3543 endif
3544
3545* CALCULATE KAON PRODUCTION PROBABILITY FROM NUCLEON+NUCLEON OR
3546* RESONANCE+RESONANCE COLLISIONS
3547 go to 364
3548
3549C CHECK WHAT KIND OF COLLISION HAS HAPPENED
3550364 ekaon(2,iss)=ekaon(2,iss)+1
3551* for resonance+resonance
3552clin-6/2008:
3553 CALL CRDD(IRUN,PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3554 1 IBLOCK,NTAG,SIGNN,SIG,NT,ipert1)
3555c 1 IBLOCK,NTAG,SIGNN,SIG)
3556 IF(iblock.eq.0.and.ipdflag.eq.1) iblock=501
3557c
3558 IF(iabs(IBLOCK).EQ.10)THEN
3559* momentum of the three particles in the final state have been calculated
3560* in the crnn, go out of the loop
3561 LCOLL=LCOLL+1
3562 IF(IBLOCK.EQ.10)THEN
3563 LDDK=LDDK+1
3564 elseIF(IBLOCK.EQ.-10) then
3565 endif
3566 GO TO 400
3567 ENDIF
3568clin-6/2008
3569c if(iblock .eq. 222)then
3570 if(iblock .eq. 222.or.iblock.eq.501)then
3571c !! sp12/17/01
3572 GO TO 400
3573 ENDIF
3574 em1=e(i1)
3575 em2=e(i2)
3576 GO TO 440
3577* FOR PION+PION,pion+eta, eta+eta and rho(omega)+pion(rho,omega) or eta
3578777 CONTINUE
3579 PX1CM=PCX
3580 PY1CM=PCY
3581 PZ1CM=PCZ
3582* energy thresh for collisions
3583 ec0=em1+em2+0.02
3584 IF(SRT.LE.ec0)GO TO 400
3585 ec=(em1+em2+0.02)**2
3586* we negelect the elastic collision between mesons except that betwen
3587* two pions because of the lack of information about these collisions
3588* However, we do let them to collide inelastically to produce kaons
3589clin-8/15/02 ppel=1.e-09
3590 ppel=20.
3591 ipp=1
3592 if(lb1.lt.3.or.lb1.gt.5.or.lb2.lt.3.or.lb2.gt.5)go to 778
3593 CALL PPXS(LB1,LB2,SRT,PPSIG,spprho,IPP)
3594 ppel=ppsig
3595778 ppink=pipik(srt)
3596
3597* pi+eta and eta+eta are assumed to be the same as pipik( for pi+pi -> K+K-)
3598* estimated from Ko's paper:
3599 ppink = 2.0 * ppink
3600 if(lb1.ge.25.and.lb2.ge.25) ppink=rrkk
3601
3602clin-2/13/03 include omega the same as rho, eta the same as pi:
3603c if(((lb1.ge.3.and.lb1.le.5).and.(lb2.ge.25.and.lb2.le.27))
3604c 1 .or.((lb2.ge.3.and.lb2.le.5).and.(lb1.ge.25.and.lb1.le.27)))
3605 if( ( (lb1.eq.0.or.(lb1.ge.3.and.lb1.le.5))
3606 1 .and.(lb2.ge.25.and.lb2.le.28))
3607 2 .or. ( (lb2.eq.0.or.(lb2.ge.3.and.lb2.le.5))
3608 3 .and.(lb1.ge.25.and.lb1.le.28))) then
3609 ppink=0.
3610 if(srt.ge.(aka+aks)) ppink = prkk
3611 endif
3612
3613c pi pi <-> rho rho:
3614 call spprr(lb1,lb2,srt)
3615clin-4/03/02 pi pi <-> eta eta:
3616 call sppee(lb1,lb2,srt)
3617clin-4/03/02 pi pi <-> pi eta:
3618 call spppe(lb1,lb2,srt)
3619clin-4/03/02 rho pi <-> rho eta:
3620 call srpre(lb1,lb2,srt)
3621clin-4/03/02 omega pi <-> omega eta:
3622 call sopoe(lb1,lb2,srt)
3623clin-4/03/02 rho rho <-> eta eta:
3624 call srree(lb1,lb2,srt)
3625
3626 ppinnb=0.
3627 if(srt.gt.thresh(1)) then
3628 call getnst(srt)
3629 if(lb1.ge.3.and.lb1.le.5.and.lb2.ge.3.and.lb2.le.5) then
3630 ppinnb=ppbbar(srt)
3631 elseif((lb1.ge.3.and.lb1.le.5.and.lb2.ge.25.and.lb2.le.27)
3632 1 .or.(lb2.ge.3.and.lb2.le.5.and.lb1.ge.25.and.lb1.le.27)) then
3633 ppinnb=prbbar(srt)
3634 elseif(lb1.ge.25.and.lb1.le.27
3635 1 .and.lb2.ge.25.and.lb2.le.27) then
3636 ppinnb=rrbbar(srt)
3637 elseif((lb1.ge.3.and.lb1.le.5.and.lb2.eq.28)
3638 1 .or.(lb2.ge.3.and.lb2.le.5.and.lb1.eq.28)) then
3639 ppinnb=pobbar(srt)
3640 elseif((lb1.ge.25.and.lb1.le.27.and.lb2.eq.28)
3641 1 .or.(lb2.ge.25.and.lb2.le.27.and.lb1.eq.28)) then
3642 ppinnb=robbar(srt)
3643 elseif(lb1.eq.28.and.lb2.eq.28) then
3644 ppinnb=oobbar(srt)
3645 else
3646 if(lb1.ne.0.and.lb2.ne.0)
3647 1 write(6,*) 'missed MM lb1,lb2=',lb1,lb2
3648 endif
3649 endif
3650 ppin=ppink+ppinnb+pprr+ppee+pppe+rpre+xopoe+rree
3651
3652* check if a collision can happen
3653 if((ppel+ppin).le.0.01)go to 400
3654 DSPP=SQRT((ppel+ppin)/31.4)
3655 dsppr=dspp+0.1
3656 CALL DISTCE(I1,I2,dsppr,DSPP,DT,EC,SRT,IC,
3657 1 PX1CM,PY1CM,PZ1CM)
3658 IF(IC.EQ.-1) GO TO 400
3659 if(ppel.eq.0)go to 400
3660* the collision can happen
3661* check what kind collision has happened
3662 ekaon(5,iss)=ekaon(5,iss)+1
3663 CALL CRPP(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3664 1 IBLOCK,ppel,ppin,spprho,ipp)
3665
3666* rho formation, go to 400
3667c if(iblock.eq.666)go to 600
3668 if(iblock.eq.666)go to 555
3669 if(iblock.eq.6)LPP=LPP+1
3670 if(iblock.eq.66)then
3671 LPPk=LPPk+1
3672 elseif(iblock.eq.366)then
3673 LPPk=LPPk+1
3674 elseif(iblock.eq.367)then
3675 LPPk=LPPk+1
3676 endif
3677 em1=e(i1)
3678 em2=e(i2)
3679 go to 440
3680
3681* In this block we treat annihilations of
3682clin-9/28/00* an anti-nucleon and a baryon or baryon resonance
3683* an anti-baryon and a baryon (including resonances)
36842799 CONTINUE
3685 PX1CM=PCX
3686 PY1CM=PCY
3687 PZ1CM=PCZ
3688 EC=(em1+em2+0.02)**2
3689clin assume the same cross section (as a function of sqrt s) as for PPbar:
3690
3691clin-ctest annih maximum
3692c DSppb=SQRT(amin1(xppbar(srt),30.)/PI/10.)
3693 DSppb=SQRT(xppbar(srt)/PI/10.)
3694 dsppbr=dsppb+0.1
3695 CALL DISTCE(I1,I2,dsppbr,DSppb,DT,EC,SRT,IC,
3696 1 PX1CM,PY1CM,PZ1CM)
3697 IF(IC.EQ.-1) GO TO 400
3698 CALL Crppba(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3699 1 IBLOCK)
3700 em1=e(i1)
3701 em2=e(i2)
3702 go to 440
3703c
37043555 PX1CM=PCX
3705 PY1CM=PCY
3706 PZ1CM=PCZ
3707 EC=(em1+em2+0.02)**2
3708 DSkk=SQRT(SIG/PI/10.)
3709 dskk0=dskk+0.1
3710 CALL DISTCE(I1,I2,dskk0,DSkk,DT,EC,SRT,IC,
3711 1 PX1CM,PY1CM,PZ1CM)
3712 IF(IC.EQ.-1) GO TO 400
3713 CALL Crlaba(PX1CM,PY1CM,PZ1CM,SRT,brel,brsgm,
3714 & I1,I2,nt,IBLOCK,nchrg,icase)
3715 em1=e(i1)
3716 em2=e(i2)
3717 go to 440
3718*
3719c perturbative production of cascade and omega
37203455 PX1CM=PCX
3721 PY1CM=PCY
3722 PZ1CM=PCZ
3723 call pertur(PX1CM,PY1CM,PZ1CM,SRT,IRUN,I1,I2,nt,kp,icontp)
3724 if(icontp .eq. 0)then
3725c inelastic collisions:
3726 em1 = e(i1)
3727 em2 = e(i2)
3728 iblock = 727
3729 go to 440
3730 endif
3731c elastic collisions:
3732 if (e(i1) .eq. 0.) go to 800
3733 if (e(i2) .eq. 0.) go to 600
3734 go to 400
3735*
3736c* phi + N --> pi+N(D), N(D,N*)+N(D,N*), K+ +La
3737c* phi + D --> pi+N(D)
37387222 CONTINUE
3739 PX1CM=PCX
3740 PY1CM=PCY
3741 PZ1CM=PCZ
3742 EC=(em1+em2+0.02)**2
3743 CALL XphiB(LB1, LB2, EM1, EM2, SRT,
3744 & XSK1, XSK2, XSK3, XSK4, XSK5, SIGP)
3745 DSkk=SQRT(SIGP/PI/10.)
3746 dskk0=dskk+0.1
3747 CALL DISTCE(I1,I2,dskk0,DSkk,DT,EC,SRT,IC,
3748 1 PX1CM,PY1CM,PZ1CM)
3749 IF(IC.EQ.-1) GO TO 400
3750 CALL CRPHIB(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3751 & XSK1, XSK2, XSK3, XSK4, XSK5, SIGP, IBLOCK)
3752 em1=e(i1)
3753 em2=e(i2)
3754 go to 440
3755*
3756c* phi + M --> K+ + K* .....
37577444 CONTINUE
3758 PX1CM=PCX
3759 PY1CM=PCY
3760 PZ1CM=PCZ
3761 EC=(em1+em2+0.02)**2
3762 CALL PHIMES(I1, I2, SRT, XSK1, XSK2, XSK3, XSK4, XSK5,
3763 1 XSK6, XSK7, SIGPHI)
3764 DSkk=SQRT(SIGPHI/PI/10.)
3765 dskk0=dskk+0.1
3766 CALL DISTCE(I1,I2,dskk0,DSkk,DT,EC,SRT,IC,
3767 1 PX1CM,PY1CM,PZ1CM)
3768 IF(IC.EQ.-1) GO TO 400
3769c*---
3770 PZRT = p(3,i1)+p(3,i2)
3771 ER1 = sqrt( p(1,i1)**2+p(2,i1)**2+p(3,i1)**2+E(i1)**2 )
3772 ER2 = sqrt( p(1,i2)**2+p(2,i2)**2+p(3,i2)**2+E(i2)**2 )
3773 ERT = ER1+ER2
3774 yy = 0.5*log( (ERT+PZRT)/(ERT-PZRT) )
3775c*------
3776 CALL CRPHIM(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3777 & XSK1, XSK2, XSK3, XSK4, XSK5, XSK6, SIGPHI, IKKG, IKKL, IBLOCK)
3778 em1=e(i1)
3779 em2=e(i2)
3780 go to 440
3781c
3782c lambda-N elastic xsection, Li & Ko, PRC 54(1996)1897.
3783 7799 CONTINUE
3784 PX1CM=PCX
3785 PY1CM=PCY
3786 PZ1CM=PCZ
3787 EC=(em1+em2+0.02)**2
3788 call lambar(i1,i2,srt,siglab)
3789 DShn=SQRT(siglab/PI/10.)
3790 dshnr=dshn+0.1
3791 CALL DISTCE(I1,I2,dshnr,DShn,DT,EC,SRT,IC,
3792 1 PX1CM,PY1CM,PZ1CM)
3793 IF(IC.EQ.-1) GO TO 400
3794 CALL Crhb(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK)
3795 em1=e(i1)
3796 em2=e(i2)
3797 go to 440
3798c
3799c* K+ + La(Si) --> Meson + B
3800c* K- + La(Si)-bar --> Meson + B-bar
38015699 CONTINUE
3802 PX1CM=PCX
3803 PY1CM=PCY
3804 PZ1CM=PCZ
3805 EC=(em1+em2+0.02)**2
3806 CALL XKHYPE(I1, I2, SRT, XKY1, XKY2, XKY3, XKY4, XKY5,
3807 & XKY6, XKY7, XKY8, XKY9, XKY10, XKY11, XKY12, XKY13,
3808 & XKY14, XKY15, XKY16, XKY17, SIGK)
3809 DSkk=SQRT(sigk/PI)
3810 dskk0=dskk+0.1
3811 CALL DISTCE(I1,I2,dskk0,DSkk,DT,EC,SRT,IC,
3812 1 PX1CM,PY1CM,PZ1CM)
3813 IF(IC.EQ.-1) GO TO 400
3814c
3815 if(lb(i1).eq.23 .or. lb(i2).eq.23)then
3816 IKMP = 1
3817 else
3818 IKMP = -1
3819 endif
3820 CALL Crkhyp(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3821 & XKY1, XKY2, XKY3, XKY4, XKY5,
3822 & XKY6, XKY7, XKY8, XKY9, XKY10, XKY11, XKY12, XKY13,
3823 & XKY14, XKY15, XKY16, XKY17, SIGK, IKMP,
3824 1 IBLOCK)
3825 em1=e(i1)
3826 em2=e(i2)
3827 go to 440
3828c khyperon end
3829*
3830csp11/03/01 La/Si-bar + N --> pi + K+
3831c La/Si + N-bar --> pi + K-
38325999 CONTINUE
3833 PX1CM=PCX
3834 PY1CM=PCY
3835 PZ1CM=PCZ
3836 EC=(em1+em2+0.02)**2
3837 sigkp = 15.
3838c if((lb1.ge.14.and.lb1.le.17)
3839c & .or.(lb2.ge.14.and.lb2.le.17))sigkp=10.
3840 DSkk=SQRT(SIGKP/PI/10.)
3841 dskk0=dskk+0.1
3842 CALL DISTCE(I1,I2,dskk0,DSkk,DT,EC,SRT,IC,
3843 1 PX1CM,PY1CM,PZ1CM)
3844 IF(IC.EQ.-1) GO TO 400
3845c
3846 CALL CRLAN(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK)
3847 em1=e(i1)
3848 em2=e(i2)
3849 go to 440
3850c
3851c*
3852* K(K*) + K(K*) --> phi + pi(rho,omega)
38538699 CONTINUE
3854 PX1CM=PCX
3855 PY1CM=PCY
3856 PZ1CM=PCZ
3857 EC=(em1+em2+0.02)**2
3858* CALL CROSSKKPHI(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK) used for KK*->phi+rho
3859
3860 CALL Crkphi(PX1CM,PY1CM,PZ1CM,EC,SRT,IBLOCK,
3861 & emm1,emm2,lbp1,lbp2,I1,I2,ikk,icase,rrkk,prkk)
3862 if(icase .eq. 0) then
3863 iblock=0
3864 go to 400
3865 endif
3866
3867c*---
3868 if(lbp1.eq.29.or.lbp2.eq.29) then
3869 PZRT = p(3,i1)+p(3,i2)
3870 ER1 = sqrt( p(1,i1)**2+p(2,i1)**2+p(3,i1)**2+E(i1)**2 )
3871 ER2 = sqrt( p(1,i2)**2+p(2,i2)**2+p(3,i2)**2+E(i2)**2 )
3872 ERT = ER1+ER2
3873 yy = 0.5*log( (ERT+PZRT)/(ERT-PZRT) )
3874c*------
3875 iblock = 222
3876 ntag = 0
3877 endif
3878
3879 LB(I1) = lbp1
3880 LB(I2) = lbp2
3881 E(I1) = emm1
3882 E(I2) = emm2
3883 em1=e(i1)
3884 em2=e(i2)
3885 go to 440
3886c*
3887* rho(omega) + K(K*) --> phi + K(K*)
38888799 CONTINUE
3889 PX1CM=PCX
3890 PY1CM=PCY
3891 PZ1CM=PCZ
3892 EC=(em1+em2+0.02)**2
3893* CALL CROSSKKPHI(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,IBLOCK) used for KK*->phi+rho
3894 CALL Crksph(PX1CM,PY1CM,PZ1CM,EC,SRT,
3895 & emm1,emm2,lbp1,lbp2,I1,I2,ikkg,ikkl,iblock,icase,srhoks)
3896 if(icase .eq. 0) then
3897 iblock=0
3898 go to 400
3899 endif
3900c
3901 if(lbp1.eq.29.or.lbp2.eq.20) then
3902c*---
3903 PZRT = p(3,i1)+p(3,i2)
3904 ER1 = sqrt( p(1,i1)**2+p(2,i1)**2+p(3,i1)**2+E(i1)**2 )
3905 ER2 = sqrt( p(1,i2)**2+p(2,i2)**2+p(3,i2)**2+E(i2)**2 )
3906 ERT = ER1+ER2
3907 yy = 0.5*log( (ERT+PZRT)/(ERT-PZRT) )
3908 endif
3909
3910 LB(I1) = lbp1
3911 LB(I2) = lbp2
3912 E(I1) = emm1
3913 E(I2) = emm2
3914 em1=e(i1)
3915 em2=e(i2)
3916 go to 440
3917
3918* for kaon+baryon scattering, using a constant xsection of 10 mb.
3919888 CONTINUE
3920 PX1CM=PCX
3921 PY1CM=PCY
3922 PZ1CM=PCZ
3923 EC=(em1+em2+0.02)**2
3924 sig = 10.
3925 if(iabs(lb1).eq.14.or.iabs(lb2).eq.14 .or.
3926 & iabs(lb1).eq.30.or.iabs(lb2).eq.30)sig=20.
3927 if(lb1.eq.29.or.lb2.eq.29)sig=5.0
3928
3929 DSkn=SQRT(sig/PI/10.)
3930 dsknr=dskn+0.1
3931 CALL DISTCE(I1,I2,dsknr,DSkn,DT,EC,SRT,IC,
3932 1 PX1CM,PY1CM,PZ1CM)
3933 IF(IC.EQ.-1) GO TO 400
3934 CALL Crkn(PX1CM,PY1CM,PZ1CM,SRT,I1,I2,
3935 1 IBLOCK)
3936 em1=e(i1)
3937 em2=e(i2)
3938 go to 440
3939***
3940
3941 440 CONTINUE
3942* IBLOCK = 0 ; NOTHING HAS HAPPENED
3943* IBLOCK = 1 ; ELASTIC N-N COLLISION
3944* IBLOCK = 2 ; N + N -> N + DELTA
3945* IBLOCK = 3 ; N + DELTA -> N + N
3946* IBLOCK = 4 ; N + N -> d + d + PION,DIRECT PROCESS
3947* IBLOCK = 5 ; D(N*)+D(N*) COLLISIONS
3948* IBLOCK = 6 ; PION+PION COLLISIONS
3949* iblock = 7 ; pion+nucleon-->l/s+kaon
3950* iblock =77; pion+nucleon-->delta+pion
3951* iblock = 8 ; kaon+baryon rescattering
3952* IBLOCK = 9 ; NN-->KAON+X
3953* IBLOCK = 10; DD-->KAON+X
3954* IBLOCK = 11; ND-->KAON+X
3955cbali2/1/99
3956*
3957* iblock - 1902 annihilation-->pion(+)+pion(-) (2 pion)
3958* iblock - 1903 annihilation-->pion(+)+rho(-) (3 pion)
3959* iblock - 1904 annihilation-->rho(+)+rho(-) (4 pion)
3960* iblock - 1905 annihilation-->rho(0)+omega (5 pion)
3961* iblock - 1906 annihilation-->omega+omega (6 pion)
3962cbali3/5/99
3963* iblock - 1907 K+K- to pi+pi-
3964cbali3/5/99 end
3965cbz3/9/99 khyperon
3966* iblock - 1908 K+Y -> piN
3967cbz3/9/99 khyperon end
3968cbali2/1/99end
3969
3970clin-9/28/00 Processes: m(pi rho omega)+m(pi rho omega)
3971c to anti-(p n D N*1 N*2)+(p n D N*1 N*2):
3972* iblock - 1801 mm -->pbar p
3973* iblock - 18021 mm -->pbar n
3974* iblock - 18022 mm -->nbar p
3975* iblock - 1803 mm -->nbar n
3976* iblock - 18041 mm -->pbar Delta
3977* iblock - 18042 mm -->anti-Delta p
3978* iblock - 18051 mm -->nbar Delta
3979* iblock - 18052 mm -->anti-Delta n
3980* iblock - 18061 mm -->pbar N*(1400)
3981* iblock - 18062 mm -->anti-N*(1400) p
3982* iblock - 18071 mm -->nbar N*(1400)
3983* iblock - 18072 mm -->anti-N*(1400) n
3984* iblock - 1808 mm -->anti-Delta Delta
3985* iblock - 18091 mm -->pbar N*(1535)
3986* iblock - 18092 mm -->anti-N*(1535) p
3987* iblock - 18101 mm -->nbar N*(1535)
3988* iblock - 18102 mm -->anti-N*(1535) n
3989* iblock - 18111 mm -->anti-Delta N*(1440)
3990* iblock - 18112 mm -->anti-N*(1440) Delta
3991* iblock - 18121 mm -->anti-Delta N*(1535)
3992* iblock - 18122 mm -->anti-N*(1535) Delta
3993* iblock - 1813 mm -->anti-N*(1440) N*(1440)
3994* iblock - 18141 mm -->anti-N*(1440) N*(1535)
3995* iblock - 18142 mm -->anti-N*(1535) N*(1440)
3996* iblock - 1815 mm -->anti-N*(1535) N*(1535)
3997clin-9/28/00-end
3998
3999clin-10/08/00 Processes: pi pi <-> rho rho
4000* iblock - 1850 pi pi -> rho rho
4001* iblock - 1851 rho rho -> pi pi
4002clin-10/08/00-end
4003
4004clin-08/14/02 Processes: pi pi <-> eta eta
4005* iblock - 1860 pi pi -> eta eta
4006* iblock - 1861 eta eta -> pi pi
4007* Processes: pi pi <-> pi eta
4008* iblock - 1870 pi pi -> pi eta
4009* iblock - 1871 pi eta -> pi pi
4010* Processes: rho pi <-> rho eta
4011* iblock - 1880 pi pi -> pi eta
4012* iblock - 1881 pi eta -> pi pi
4013* Processes: omega pi <-> omega eta
4014* iblock - 1890 pi pi -> pi eta
4015* iblock - 1891 pi eta -> pi pi
4016* Processes: rho rho <-> eta eta
4017* iblock - 1895 rho rho -> eta eta
4018* iblock - 1896 eta eta -> rho rho
4019clin-08/14/02-end
4020
4021clin-11/07/00 Processes:
4022* iblock - 366 pi rho -> K* Kbar or K*bar K
4023* iblock - 466 pi rho <- K* Kbar or K*bar K
4024
4025clin-9/2008 Deuteron:
4026* iblock - 501 B+B -> Deuteron+Meson
4027* iblock - 502 Deuteron+Meson -> B+B
4028* iblock - 503 Deuteron+Baryon elastic
4029* iblock - 504 Deuteron+Meson elastic
4030c
4031 IF(IBLOCK.EQ.0) GOTO 400
4032*COM: FOR DIRECT PROCESS WE HAVE TREATED THE PAULI BLOCKING AND FIND
4033* THE MOMENTUM OF PARTICLES IN THE ''LAB'' FRAME. SO GO TO 400
4034* A COLLISION HAS TAKEN PLACE !!
4035 LCOLL = LCOLL +1
4036* WAS COLLISION PAULI-FORBIDEN? IF YES, NTAG = -1
4037 NTAG = 0
4038*
4039* LORENTZ-TRANSFORMATION INTO CMS FRAME
4040 E1CM = SQRT (EM1**2 + PX1CM**2 + PY1CM**2 + PZ1CM**2)
4041 P1BETA = PX1CM*BETAX + PY1CM*BETAY + PZ1CM*BETAZ
4042 TRANSF = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) + E1CM )
4043 Pt1I1 = BETAX * TRANSF + PX1CM
4044 Pt2I1 = BETAY * TRANSF + PY1CM
4045 Pt3I1 = BETAZ * TRANSF + PZ1CM
4046* negelect the pauli blocking at high energies
4047 go to 90002
4048
4049clin-10/25/02-comment out following, since there is no path to it:
4050c*CHECK IF PARTICLE #1 IS PAULI BLOCKED
4051c CALL PAULat(I1,occup)
4052c if (RANART(NSEED) .lt. occup) then
4053c ntag = -1
4054c else
4055c ntag = 0
4056c end if
4057clin-10/25/02-end
4058
405990002 continue
4060*IF PARTICLE #1 IS NOT PAULI BLOCKED
4061c IF (NTAG .NE. -1) THEN
4062 E2CM = SQRT (EM2**2 + PX1CM**2 + PY1CM**2 + PZ1CM**2)
4063 TRANSF = GAMMA * (-GAMMA*P1BETA / (GAMMA + 1.) + E2CM)
4064 Pt1I2 = BETAX * TRANSF - PX1CM
4065 Pt2I2 = BETAY * TRANSF - PY1CM
4066 Pt3I2 = BETAZ * TRANSF - PZ1CM
4067 go to 90003
4068
4069clin-10/25/02-comment out following, since there is no path to it:
4070c*CHECK IF PARTICLE #2 IS PAULI BLOCKED
4071c CALL PAULat(I2,occup)
4072c if (RANART(NSEED) .lt. occup) then
4073c ntag = -1
4074c else
4075c ntag = 0
4076c end if
4077cc END IF
4078c* IF COLLISION IS BLOCKED,RESTORE THE MOMENTUM,MASSES
4079c* AND LABELS OF I1 AND I2
4080cc IF (NTAG .EQ. -1) THEN
4081c LBLOC = LBLOC + 1
4082c P(1,I1) = PX1
4083c P(2,I1) = PY1
4084c P(3,I1) = PZ1
4085c P(1,I2) = PX2
4086c P(2,I2) = PY2
4087c P(3,I2) = PZ2
4088c E(I1) = EM1
4089c E(I2) = EM2
4090c LB(I1) = LB1
4091c LB(I2) = LB2
4092cc ELSE
4093clin-10/25/02-end
4094
409590003 IF(IBLOCK.EQ.1) LCNNE=LCNNE+1
4096 IF(IBLOCK.EQ.5) LDD=LDD+1
4097 if(iblock.eq.2) LCNND=LCNND+1
4098 IF(IBLOCK.EQ.8) LKN=LKN+1
4099 if(iblock.eq.43) Ldou=Ldou+1
4100c IF(IBLOCK.EQ.2) THEN
4101* CALCULATE THE AVERAGE SRT FOR N + N---> N + DELTA PROCESS
4102C NODELT=NODELT+1
4103C SUMSRT=SUMSRT+SRT
4104c ENDIF
4105 IF(IBLOCK.EQ.3) LCNDN=LCNDN+1
4106* assign final momenta to particles while keep the leadng particle
4107* behaviour
4108C if((pt1i1*px1+pt2i1*py1+pt3i1*pz1).gt.0)then
4109 p(1,i1)=pt1i1
4110 p(2,i1)=pt2i1
4111 p(3,i1)=pt3i1
4112 p(1,i2)=pt1i2
4113 p(2,i2)=pt2i2
4114 p(3,i2)=pt3i2
4115C else
4116C p(1,i1)=pt1i2
4117C p(2,i1)=pt2i2
4118C p(3,i1)=pt3i2
4119C p(1,i2)=pt1i1
4120C p(2,i2)=pt2i1
4121C p(3,i2)=pt3i1
4122C endif
4123 PX1 = P(1,I1)
4124 PY1 = P(2,I1)
4125 PZ1 = P(3,I1)
4126 EM1 = E(I1)
4127 EM2 = E(I2)
4128 LB1 = LB(I1)
4129 LB2 = LB(I2)
4130 ID(I1) = 2
4131 ID(I2) = 2
4132 E1 = SQRT( EM1**2 + PX1**2 + PY1**2 + PZ1**2 )
4133 ID1 = ID(I1)
4134 go to 90004
4135clin-10/25/02-comment out following, since there is no path to it:
4136c* change phase space density FOR NUCLEONS INVOLVED :
4137c* NOTE THAT f is the phase space distribution function for nucleons only
4138c if ((abs(ix1).le.mx) .and. (abs(iy1).le.my) .and.
4139c & (abs(iz1).le.mz)) then
4140c ipx1p = nint(p(1,i1)/dpx)
4141c ipy1p = nint(p(2,i1)/dpy)
4142c ipz1p = nint(p(3,i1)/dpz)
4143c if ((ipx1p.ne.ipx1) .or. (ipy1p.ne.ipy1) .or.
4144c & (ipz1p.ne.ipz1)) then
4145c if ((abs(ipx1).le.mpx) .and. (abs(ipy1).le.my)
4146c & .and. (ipz1.ge.-mpz) .and. (ipz1.le.mpzp)
4147c & .AND. (AM1.LT.1.))
4148c & f(ix1,iy1,iz1,ipx1,ipy1,ipz1) =
4149c & f(ix1,iy1,iz1,ipx1,ipy1,ipz1) - 1.
4150c if ((abs(ipx1p).le.mpx) .and. (abs(ipy1p).le.my)
4151c & .and. (ipz1p.ge.-mpz).and. (ipz1p.le.mpzp)
4152c & .AND. (EM1.LT.1.))
4153c & f(ix1,iy1,iz1,ipx1p,ipy1p,ipz1p) =
4154c & f(ix1,iy1,iz1,ipx1p,ipy1p,ipz1p) + 1.
4155c end if
4156c end if
4157c if ((abs(ix2).le.mx) .and. (abs(iy2).le.my) .and.
4158c & (abs(iz2).le.mz)) then
4159c ipx2p = nint(p(1,i2)/dpx)
4160c ipy2p = nint(p(2,i2)/dpy)
4161c ipz2p = nint(p(3,i2)/dpz)
4162c if ((ipx2p.ne.ipx2) .or. (ipy2p.ne.ipy2) .or.
4163c & (ipz2p.ne.ipz2)) then
4164c if ((abs(ipx2).le.mpx) .and. (abs(ipy2).le.my)
4165c & .and. (ipz2.ge.-mpz) .and. (ipz2.le.mpzp)
4166c & .AND. (AM2.LT.1.))
4167c & f(ix2,iy2,iz2,ipx2,ipy2,ipz2) =
4168c & f(ix2,iy2,iz2,ipx2,ipy2,ipz2) - 1.
4169c if ((abs(ipx2p).le.mpx) .and. (abs(ipy2p).le.my)
4170c & .and. (ipz2p.ge.-mpz) .and. (ipz2p.le.mpzp)
4171c & .AND. (EM2.LT.1.))
4172c & f(ix2,iy2,iz2,ipx2p,ipy2p,ipz2p) =
4173c & f(ix2,iy2,iz2,ipx2p,ipy2p,ipz2p) + 1.
4174c end if
4175c end if
4176clin-10/25/02-end
4177
417890004 continue
4179 AM1=EM1
4180 AM2=EM2
4181c END IF
4182
4183
4184 400 CONTINUE
4185c
4186clin-6/10/03 skips the info output on resonance creations:
4187c goto 550
4188cclin-4/30/03 study phi,K*,Lambda(1520) resonances at creation:
4189cc note that no decays give these particles, so don't need to consider nnn:
4190c if(iblock.ne.0.and.(lb(i1).eq.29.or.iabs(lb(i1)).eq.30
4191c 1 .or.lb(i2).eq.29.or.iabs(lb(i2)).eq.30
4192c 2 .or.lb1i.eq.29.or.iabs(lb1i).eq.30
4193c 3 .or.lb2i.eq.29.or.iabs(lb2i).eq.30)) then
4194c lb1now=lb(i1)
4195c lb2now=lb(i2)
4196cc
4197c nphi0=0
4198c nksp0=0
4199c nksm0=0
4200cc nlar0=0
4201cc nlarbar0=0
4202c if(lb1i.eq.29) then
4203c nphi0=nphi0+1
4204c elseif(lb1i.eq.30) then
4205c nksp0=nksp0+1
4206c elseif(lb1i.eq.-30) then
4207c nksm0=nksm0+1
4208c endif
4209c if(lb2i.eq.29) then
4210c nphi0=nphi0+1
4211c elseif(lb2i.eq.30) then
4212c nksp0=nksp0+1
4213c elseif(lb2i.eq.-30) then
4214c nksm0=nksm0+1
4215c endif
4216cc
4217c nphi=0
4218c nksp=0
4219c nksm=0
4220c nlar=0
4221c nlarbar=0
4222c if(lb1now.eq.29) then
4223c nphi=nphi+1
4224c elseif(lb1now.eq.30) then
4225c nksp=nksp+1
4226c elseif(lb1now.eq.-30) then
4227c nksm=nksm+1
4228c endif
4229c if(lb2now.eq.29) then
4230c nphi=nphi+1
4231c elseif(lb2now.eq.30) then
4232c nksp=nksp+1
4233c elseif(lb2now.eq.-30) then
4234c nksm=nksm+1
4235c endif
4236cc
4237c if(nphi.eq.2.or.nksp.eq.2.or.nksm.eq.2) then
4238c write(91,*) '2 same resonances in one reaction!'
4239c write(91,*) nphi,nksp,nksm,iblock
4240c endif
4241c
4242cc All reactions create or destroy no more than 1 these resonance,
4243cc otherwise file "fort.91" warns us:
4244c do 222 ires=1,3
4245c if(ires.eq.1.and.nphi.ne.nphi0) then
4246c idr=29
4247c elseif(ires.eq.2.and.nksp.ne.nksp0) then
4248c idr=30
4249c elseif(ires.eq.3.and.nksm.ne.nksm0) then
4250c idr=-30
4251c else
4252c goto 222
4253c endif
4254cctest off for resonance (phi, K*) studies:
4255cc if(lb1now.eq.idr) then
4256cc write(17,112) 'collision',lb1now,P(1,I1),P(2,I1),P(3,I1),e(I1),nt
4257cc elseif(lb2now.eq.idr) then
4258cc write(17,112) 'collision',lb2now,P(1,I2),P(2,I2),P(3,I2),e(I2),nt
4259cc elseif(lb1i.eq.idr) then
4260cc write(18,112) 'collision',lb1i,px1i,py1i,pz1i,em1i,nt
4261cc elseif(lb2i.eq.idr) then
4262cc write(18,112) 'collision',lb2i,px2i,py2i,pz2i,em2i,nt
4263cc endif
4264c 222 continue
4265c
4266c else
4267c endif
4268cc 112 format(a10,I4,4(1x,f9.3),1x,I4)
4269c
4270clin-2/26/03 skips the check of energy conservation after each binary search:
4271c 550 goto 555
4272c pxfin=0
4273c pyfin=0
4274c pzfin=0
4275c efin=0
4276c if(e(i1).ne.0.or.lb(i1).eq.10022) then
4277c efin=efin+SQRT(E(I1)**2+P(1,I1)**2+P(2,I1)**2+P(3,I1)**2)
4278c pxfin=pxfin+P(1,I1)
4279c pyfin=pyfin+P(2,I1)
4280c pzfin=pzfin+P(3,I1)
4281c endif
4282c if(e(i2).ne.0.or.lb(i2).eq.10022) then
4283c efin=efin+SQRT(E(I2)**2+P(1,I2)**2+P(2,I2)**2+P(3,I2)**2)
4284c pxfin=pxfin+P(1,I2)
4285c pyfin=pyfin+P(2,I2)
4286c pzfin=pzfin+P(3,I2)
4287c endif
4288c if((nnn-nnnini).ge.1) then
4289c do imore=nnnini+1,nnn
4290c if(EPION(imore,IRUN).ne.0) then
4291c efin=efin+SQRT(EPION(imore,IRUN)**2
4292c 1 +PPION(1,imore,IRUN)**2+PPION(2,imore,IRUN)**2
4293c 2 +PPION(3,imore,IRUN)**2)
4294c pxfin=pxfin+PPION(1,imore,IRUN)
4295c pyfin=pyfin+PPION(2,imore,IRUN)
4296c pzfin=pzfin+PPION(3,imore,IRUN)
4297c endif
4298c enddo
4299c endif
4300c devio=sqrt((pxfin-pxini)**2+(pyfin-pyini)**2
4301c 1 +(pzfin-pzini)**2+(efin-eini)**2)
4302cc
4303c if(devio.ge.0.1) then
4304c write(92,'a20,5(1x,i6),2(1x,f8.3)') 'iblock,lb,npi=',
4305c 1 iblock,lb1i,lb2i,lb(i1),lb(i2),e(i1),e(i2)
4306c do imore=nnnini+1,nnn
4307c if(EPION(imore,IRUN).ne.0) then
4308c write(92,'a10,2(1x,i6)') 'ipi,lbm=',
4309c 1 imore,LPION(imore,IRUN)
4310c endif
4311c enddo
4312c write(92,'a3,4(1x,f8.3)') 'I:',eini,pxini,pyini,pzini
4313c write(92,'a3,5(1x,f8.3)')
4314c 1 'F:',efin,pxfin,pyfin,pzfin,devio
4315c endif
4316c
4317 555 continue
4318ctest off only one collision for the same 2 particles in the same timestep:
4319c if(iblock.ne.0) then
4320c goto 800
4321c endif
4322ctest off collisions history:
4323c if(iblock.ne.0) then
4324c write(10,*) nt,i1,i2,iblock,x1,z1,x2,z2
4325c endif
4326
4327 600 CONTINUE
4328 800 CONTINUE
4329* RELABLE MESONS LEFT IN THIS RUN EXCLUDING THOSE BEING CREATED DURING
4330* THIS TIME STEP AND COUNT THE TOTAL NO. OF PARTICLES IN THIS RUN
4331* note that the first mass=mta+mpr particles are baryons
4332c write(*,*)'I: NNN,massr ', nnn,massr(irun)
4333 N0=MASS+MSUM
4334 DO 1005 N=N0+1,MASSR(IRUN)+MSUM
4335cbz11/25/98
4336clin-2/19/03 lb>5000: keep particles with no LB codes in ART(photon,lepton,..):
4337c IF(E(N).GT.0.)THEN
4338 IF(E(N) .GT. 0. .OR. LB(N) .GT. 5000)THEN
4339cbz11/25/98end
4340 NNN=NNN+1
4341 RPION(1,NNN,IRUN)=R(1,N)
4342 RPION(2,NNN,IRUN)=R(2,N)
4343 RPION(3,NNN,IRUN)=R(3,N)
4344clin-10/28/03:
4345 if(nt.eq.ntmax) then
4346 ftpisv(NNN,IRUN)=ftsv(N)
4347 tfdpi(NNN,IRUN)=tfdcy(N)
4348 endif
4349c
4350 PPION(1,NNN,IRUN)=P(1,N)
4351 PPION(2,NNN,IRUN)=P(2,N)
4352 PPION(3,NNN,IRUN)=P(3,N)
4353 EPION(NNN,IRUN)=E(N)
4354 LPION(NNN,IRUN)=LB(N)
4355c !! sp 12/19/00
4356 PROPI(NNN,IRUN)=PROPER(N)
4357clin-5/2008:
4358 dppion(NNN,IRUN)=dpertp(N)
4359c if(lb(n) .eq. 45)
4360c & write(*,*)'IN-1 NT,NNN,LB,P ',nt,NNN,lb(n),proper(n)
4361 ENDIF
4362 1005 CONTINUE
4363 MASSRN(IRUN)=NNN+MASS
4364c write(*,*)'F: NNN,massrn ', nnn,massrn(irun)
43651000 CONTINUE
4366* CALCULATE THE AVERAGE SRT FOR N + N--->N +DELTA PROCESSES
4367C IF(NODELT.NE.0)THEN
4368C AVSRT=SUMSRT/FLOAT(NODELT)
4369C ELSE
4370C AVSRT=0.
4371C ENDIF
4372C WRITE(1097,'(F8.2,2X,E10.3)')FLOAT(NT)*DT,AVSRT
4373* RELABLE ALL THE PARTICLES EXISTING AFTER THIS TIME STEP
4374 IA=0
4375 IB=0
4376 DO 10001 IRUN=1,NUM
4377 IA=IA+MASSR(IRUN-1)
4378 IB=IB+MASSRN(IRUN-1)
4379 DO 10001 IC=1,MASSRN(IRUN)
4380 IE=IA+IC
4381 IG=IB+IC
4382 IF(IC.LE.MASS)THEN
4383 RT(1,IG)=R(1,IE)
4384 RT(2,IG)=R(2,IE)
4385 RT(3,IG)=R(3,IE)
4386clin-10/28/03:
4387 if(nt.eq.ntmax) then
4388 fttemp(IG)=ftsv(IE)
4389 tft(IG)=tfdcy(IE)
4390 endif
4391c
4392 PT(1,IG)=P(1,IE)
4393 PT(2,IG)=P(2,IE)
4394 PT(3,IG)=P(3,IE)
4395 ET(IG)=E(IE)
4396 LT(IG)=LB(IE)
4397 PROT(IG)=PROPER(IE)
4398clin-5/2008:
4399 dptemp(IG)=dpertp(IE)
4400 ELSE
4401 I0=IC-MASS
4402 RT(1,IG)=RPION(1,I0,IRUN)
4403 RT(2,IG)=RPION(2,I0,IRUN)
4404 RT(3,IG)=RPION(3,I0,IRUN)
4405clin-10/28/03:
4406 if(nt.eq.ntmax) then
4407 fttemp(IG)=ftpisv(I0,IRUN)
4408 tft(IG)=tfdpi(I0,IRUN)
4409 endif
4410c
4411 PT(1,IG)=PPION(1,I0,IRUN)
4412 PT(2,IG)=PPION(2,I0,IRUN)
4413 PT(3,IG)=PPION(3,I0,IRUN)
4414 ET(IG)=EPION(I0,IRUN)
4415 LT(IG)=LPION(I0,IRUN)
4416 PROT(IG)=PROPI(I0,IRUN)
4417clin-5/2008:
4418 dptemp(IG)=dppion(I0,IRUN)
4419 ENDIF
442010001 CONTINUE
4421c
4422 IL=0
4423clin-10/26/01-hbt:
4424c DO 10002 IRUN=1,NUM
4425 DO 10003 IRUN=1,NUM
4426
4427 MASSR(IRUN)=MASSRN(IRUN)
4428 IL=IL+MASSR(IRUN-1)
4429 DO 10002 IM=1,MASSR(IRUN)
4430 IN=IL+IM
4431 R(1,IN)=RT(1,IN)
4432 R(2,IN)=RT(2,IN)
4433 R(3,IN)=RT(3,IN)
4434clin-10/28/03:
4435 if(nt.eq.ntmax) then
4436 ftsv(IN)=fttemp(IN)
4437 tfdcy(IN)=tft(IN)
4438 endif
4439 P(1,IN)=PT(1,IN)
4440 P(2,IN)=PT(2,IN)
4441 P(3,IN)=PT(3,IN)
4442 E(IN)=ET(IN)
4443 LB(IN)=LT(IN)
4444 PROPER(IN)=PROT(IN)
4445clin-5/2008:
4446 dpertp(IN)=dptemp(IN)
4447 IF(LB(IN).LT.1.OR.LB(IN).GT.2)ID(IN)=0
444810002 CONTINUE
4449clin-ctest off check energy conservation after each timestep
4450c enetot=0.
4451c do ip=1,MASSR(IRUN)
4452c if(e(ip).ne.0.or.lb(ip).eq.10022) enetot=enetot
4453c 1 +sqrt(p(1,ip)**2+p(2,ip)**2+p(3,ip)**2+e(ip)**2)
4454c enddo
4455c write(91,*) 'B:',nt,enetot,massr(irun),bimp
4456clin-3/2009 move to the end of a timestep to take care of freezeout spacetime:
4457c call hbtout(MASSR(IRUN),nt,ntmax)
445810003 CONTINUE
4459c
4460 RETURN
4461 END
4462****************************************
4463 SUBROUTINE CMS(I1,I2,PX1CM,PY1CM,PZ1CM,SRT)
4464* PURPOSE : FIND THE MOMENTA OF PARTICLES IN THE CMS OF THE
4465* TWO COLLIDING PARTICLES
4466* VARIABLES :
4467*****************************************
4468 PARAMETER (MAXSTR=150001)
4469 COMMON /AA/ R(3,MAXSTR)
4470cc SAVE /AA/
4471 COMMON /BB/ P(3,MAXSTR)
4472cc SAVE /BB/
4473 COMMON /CC/ E(MAXSTR)
4474cc SAVE /CC/
4475 COMMON /BG/ BETAX,BETAY,BETAZ,GAMMA
4476cc SAVE /BG/
4477 SAVE
4478 PX1=P(1,I1)
4479 PY1=P(2,I1)
4480 PZ1=P(3,I1)
4481 PX2=P(1,I2)
4482 PY2=P(2,I2)
4483 PZ2=P(3,I2)
4484 EM1=E(I1)
4485 EM2=E(I2)
4486 E1=SQRT(EM1**2+PX1**2+PY1**2+PZ1**2)
4487 E2=SQRT(EM2**2 + PX2**2 + PY2**2 + PZ2**2 )
4488 S=(E1+E2)**2-(PX1+PX2)**2-(PY1+PY2)**2-(PZ1+PZ2)**2
4489 SRT=SQRT(S)
4490*LORENTZ-TRANSFORMATION IN I1-I2-C.M. SYSTEM
4491 ETOTAL = E1 + E2
4492 BETAX = (PX1+PX2) / ETOTAL
4493 BETAY = (PY1+PY2) / ETOTAL
4494 BETAZ = (PZ1+PZ2) / ETOTAL
4495 GAMMA = 1.0 / SQRT(1.0-BETAX**2-BETAY**2-BETAZ**2)
4496*TRANSFORMATION OF MOMENTA (PX1CM = - PX2CM)
4497 P1BETA = PX1*BETAX + PY1*BETAY + PZ1 * BETAZ
4498 TRANSF = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) - E1 )
4499 PX1CM = BETAX * TRANSF + PX1
4500 PY1CM = BETAY * TRANSF + PY1
4501 PZ1CM = BETAZ * TRANSF + PZ1
4502 RETURN
4503 END
4504***************************************
4505 SUBROUTINE DISTCE(I1,I2,DELTAR,DS,DT,EC,SRT
4506 1 ,IC,PX1CM,PY1CM,PZ1CM)
4507* PURPOSE : CHECK IF THE COLLISION BETWEEN TWO PARTICLES CAN HAPPEN
4508* BY CHECKING
4509* (1) IF THE DISTANCE BETWEEN THEM IS SMALLER
4510* THAN THE MAXIMUM DISTANCE DETERMINED FROM THE CROSS SECTION.
4511* (2) IF PARTICLE WILL PASS EACH OTHER WITHIN
4512* TWO HARD CORE RADIUS.
4513* (3) IF PARTICLES WILL GET CLOSER.
4514* VARIABLES :
4515* IC=1 COLLISION HAPPENED
4516* IC=-1 COLLISION CAN NOT HAPPEN
4517*****************************************
4518 PARAMETER (MAXSTR=150001)
4519 COMMON /AA/ R(3,MAXSTR)
4520cc SAVE /AA/
4521 COMMON /BB/ P(3,MAXSTR)
4522cc SAVE /BB/
4523 COMMON /CC/ E(MAXSTR)
4524cc SAVE /CC/
4525 COMMON /BG/ BETAX,BETAY,BETAZ,GAMMA
4526 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
4527cc SAVE /BG/
4528 common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
4529 1 px1n,py1n,pz1n,dp1n
4530 common /dpi/em2,lb2
4531 SAVE
4532 IC=0
4533 X1=R(1,I1)
4534 Y1=R(2,I1)
4535 Z1=R(3,I1)
4536 PX1=P(1,I1)
4537 PY1=P(2,I1)
4538 PZ1=P(3,I1)
4539 X2=R(1,I2)
4540 Y2=R(2,I2)
4541 Z2=R(3,I2)
4542 PX2=P(1,I2)
4543 PY2=P(2,I2)
4544 PZ2=P(3,I2)
4545 EM1=E(I1)
4546 EM2=E(I2)
4547 E1=SQRT(EM1**2+PX1**2+PY1**2+PZ1**2)
4548c IF (ABS(X1-X2) .GT. DELTAR) GO TO 400
4549c IF (ABS(Y1-Y2) .GT. DELTAR) GO TO 400
4550c IF (ABS(Z1-Z2) .GT. DELTAR) GO TO 400
4551 RSQARE = (X1-X2)**2 + (Y1-Y2)**2 + (Z1-Z2)**2
4552 IF (RSQARE .GT. DELTAR**2) GO TO 400
4553*NOW PARTICLES ARE CLOSE ENOUGH TO EACH OTHER !
4554 E2 = SQRT ( EM2**2 + PX2**2 + PY2**2 + PZ2**2 )
4555 S = SRT*SRT
4556 IF (S .LT. EC) GO TO 400
4557*NOW THERE IS ENOUGH ENERGY AVAILABLE !
4558*LORENTZ-TRANSFORMATION IN I1-I2-C.M. SYSTEM
4559* BETAX, BETAY, BETAZ AND GAMMA HAVE BEEN GIVEN IN THE SUBROUTINE CMS
4560*TRANSFORMATION OF MOMENTA (PX1CM = - PX2CM)
4561 P1BETA = PX1*BETAX + PY1*BETAY + PZ1 * BETAZ
4562 TRANSF = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) - E1 )
4563 PRCM = SQRT (PX1CM**2 + PY1CM**2 + PZ1CM**2)
4564 IF (PRCM .LE. 0.00001) GO TO 400
4565*TRANSFORMATION OF SPATIAL DISTANCE
4566 DRBETA = BETAX*(X1-X2) + BETAY*(Y1-Y2) + BETAZ*(Z1-Z2)
4567 TRANSF = GAMMA * GAMMA * DRBETA / (GAMMA + 1)
4568 DXCM = BETAX * TRANSF + X1 - X2
4569 DYCM = BETAY * TRANSF + Y1 - Y2
4570 DZCM = BETAZ * TRANSF + Z1 - Z2
4571*DETERMINING IF THIS IS THE POINT OF CLOSEST APPROACH
4572 DRCM = SQRT (DXCM**2 + DYCM**2 + DZCM**2 )
4573 DZZ = (PX1CM*DXCM + PY1CM*DYCM + PZ1CM*DZCM) / PRCM
4574 if ((drcm**2 - dzz**2) .le. 0.) then
4575 BBB = 0.
4576 else
4577 BBB = SQRT (DRCM**2 - DZZ**2)
4578 end if
4579*WILL PARTICLE PASS EACH OTHER WITHIN 2 * HARD CORE RADIUS ?
4580 IF (BBB .GT. DS) GO TO 400
4581 RELVEL = PRCM * (1.0/E1 + 1.0/E2)
4582 DDD = RELVEL * DT * 0.5
4583*WILL PARTICLES GET CLOSER ?
4584 IF (ABS(DDD) .LT. ABS(DZZ)) GO TO 400
4585 IC=1
4586 GO TO 500
4587400 IC=-1
4588500 CONTINUE
4589 RETURN
4590 END
4591****************************************
4592* *
4593* *
4594 SUBROUTINE CRNN(IRUN,PX,PY,PZ,SRT,I1,I2,IBLOCK,
4595 1NTAG,SIGNN,SIG,NT,ipert1)
4596* PURPOSE: *
4597* DEALING WITH NUCLEON-NUCLEON COLLISIONS *
4598* NOTE : *
4599* QUANTITIES: *
4600* PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
4601* SRT - SQRT OF S *
4602* NSTAR =1 INCLUDING N* RESORANCE,ELSE NOT *
4603* NDIRCT=1 INCLUDING DIRECT PION PRODUCTION PROCESS *
4604* IBLOCK - THE INFORMATION BACK *
4605* 0-> COLLISION CANNOT HAPPEN *
4606* 1-> N-N ELASTIC COLLISION *
4607* 2-> N+N->N+DELTA,OR N+N->N+N* REACTION *
4608* 3-> N+DELTA->N+N OR N+N*->N+N REACTION *
4609* 4-> N+N->D+D+pion reaction
4610* 43->N+N->D(N*)+D(N*) reaction
4611* 44->N+N->D+D+rho reaction
4612* 45->N+N->N+N+rho
4613* 46->N+N->N+N+omega
4614* N12 - IS USED TO SPECIFY BARYON-BARYON REACTION *
4615* CHANNELS. M12 IS THE REVERSAL CHANNEL OF N12 *
4616* N12, *
4617* M12=1 FOR p+n-->delta(+)+ n *
4618* 2 p+n-->delta(0)+ p *
4619* 3 p+p-->delta(++)+n *
4620* 4 p+p-->delta(+)+p *
4621* 5 n+n-->delta(0)+n *
4622* 6 n+n-->delta(-)+p *
4623* 7 n+p-->N*(0)(1440)+p *
4624* 8 n+p-->N*(+)(1440)+n *
4625* 9 p+p-->N*(+)(1535)+p *
4626* 10 n+n-->N*(0)(1535)+n *
4627* 11 n+p-->N*(+)(1535)+n *
4628* 12 n+p-->N*(0)(1535)+p
4629* 13 D(++)+D(-)-->N*(+)(1440)+n
4630* 14 D(++)+D(-)-->N*(0)(1440)+p
4631* 15 D(+)+D(0)--->N*(+)(1440)+n
4632* 16 D(+)+D(0)--->N*(0)(1440)+p
4633* 17 D(++)+D(0)-->N*(+)(1535)+p
4634* 18 D(++)+D(-)-->N*(0)(1535)+p
4635* 19 D(++)+D(-)-->N*(+)(1535)+n
4636* 20 D(+)+D(+)-->N*(+)(1535)+p
4637* 21 D(+)+D(0)-->N*(+)(1535)+n
4638* 22 D(+)+D(0)-->N*(0)(1535)+p
4639* 23 D(+)+D(-)-->N*(0)(1535)+n
4640* 24 D(0)+D(0)-->N*(0)(1535)+n
4641* 25 N*(+)(14)+N*(+)(14)-->N*(+)(15)+p
4642* 26 N*(0)(14)+N*(0)(14)-->N*(0)(15)+n
4643* 27 N*(+)(14)+N*(0)(14)-->N*(+)(15)+n
4644* 28 N*(+)(14)+N*(0)(14)-->N*(0)(15)+p
4645* 29 N*(+)(14)+D+-->N*(+)(15)+p
4646* 30 N*(+)(14)+D0-->N*(+)(15)+n
4647* 31 N*(+)(14)+D(-)-->N*(0)(1535)+n
4648* 32 N*(0)(14)+D++--->N*(+)(15)+p
4649* 33 N*(0)(14)+D+--->N*(+)(15)+n
4650* 34 N*(0)(14)+D+--->N*(0)(15)+p
4651* 35 N*(0)(14)+D0-->N*(0)(15)+n
4652* 36 N*(+)(14)+D0--->N*(0)(15)+p
4653* ++ see the note book for more listing
4654*
4655*
4656* NOTE ABOUT N*(1440) RESORANCE IN Nucleon+NUCLEON COLLISION: *
4657* As it has been discussed in VerWest's paper,I= 1(initial isospin)*
4658* channel can all be attributed to delta resorance while I= 0 *
4659* channel can all be attribured to N* resorance.Only in n+p *
4660* one can have I=0 channel so is the N*(1440) resonance *
4661* *
4662* REFERENCES: *
4663* J. CUGNON ET AL., NUCL. PHYS. A352, 505 (1981) *
4664* Y. KITAZOE ET AL., PHYS. LETT. 166B, 35 (1986) *
4665* B. VerWest el al., PHYS. PRV. C25 (1982)1979 *
4666* Gy. Wolf et al, Nucl Phys A517 (1990) 615; *
4667* Nucl phys A552 (1993) 349. *
4668**********************************
4669 PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
4670 1 AMP=0.93828,AP1=0.13496,aka=0.498,AP2=0.13957,AM0=1.232,
4671 2 PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383,APHI=1.020)
4672 parameter (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
4673 parameter (xmd=1.8756,npdmax=10000)
4674 COMMON /AA/ R(3,MAXSTR)
4675cc SAVE /AA/
4676 COMMON /BB/ P(3,MAXSTR)
4677cc SAVE /BB/
4678 COMMON /CC/ E(MAXSTR)
4679cc SAVE /CC/
4680 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
4681cc SAVE /EE/
4682 common /ff/f(-mx:mx,-my:my,-mz:mz,-mpx:mpx,-mpy:mpy,-mpz:mpzp)
4683cc SAVE /ff/
4684 common /gg/ dx,dy,dz,dpx,dpy,dpz
4685cc SAVE /gg/
4686 COMMON /INPUT/ NSTAR,NDIRCT,DIR
4687cc SAVE /INPUT/
4688 COMMON /NN/NNN
4689cc SAVE /NN/
4690 COMMON /BG/BETAX,BETAY,BETAZ,GAMMA
4691cc SAVE /BG/
4692 COMMON /RUN/NUM
4693cc SAVE /RUN/
4694 COMMON /PA/RPION(3,MAXSTR,MAXR)
4695cc SAVE /PA/
4696 COMMON /PB/PPION(3,MAXSTR,MAXR)
4697cc SAVE /PB/
4698 COMMON /PC/EPION(MAXSTR,MAXR)
4699cc SAVE /PC/
4700 COMMON /PD/LPION(MAXSTR,MAXR)
4701cc SAVE /PD/
4702 COMMON/TABLE/ xarray(0:1000),earray(0:1000)
4703cc SAVE /TABLE/
4704 common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
4705cc SAVE /input1/
4706 common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
4707 1 px1n,py1n,pz1n,dp1n
4708cc SAVE /leadng/
4709 COMMON/RNDF77/NSEED
4710cc SAVE /RNDF77/
4711 common /dpi/em2,lb2
4712 COMMON /dpert/dpertt(MAXSTR,MAXR),dpertp(MAXSTR),dplast(MAXSTR),
4713 1 dpdcy(MAXSTR),dpdpi(MAXSTR,MAXR),dpt(MAXSTR, MAXR),
4714 2 dpp1(MAXSTR,MAXR),dppion(MAXSTR,MAXR)
4715 common /para8/ idpert,npertd,idxsec
4716 dimension ppd(3,npdmax),lbpd(npdmax)
4717 SAVE
4718*-----------------------------------------------------------------------
4719 n12=0
4720 m12=0
4721 IBLOCK=0
4722 NTAG=0
4723 EM1=E(I1)
4724 EM2=E(I2)
4725 PR=SQRT( PX**2 + PY**2 + PZ**2 )
4726 C2=PZ / PR
4727 X1=RANART(NSEED)
4728 ianti=0
4729 if(lb(i1).lt.0 .and. lb(i2).lt.0) ianti=1
4730 call sbbdm(srt,sdprod,ianti,lbm,xmm,pfinal)
4731clin-5/2008 Production of perturbative deuterons for idpert=1:
4732 if(idpert.eq.1.and.ipert1.eq.1) then
4733 IF (SRT .LT. 2.012) RETURN
4734 if((iabs(lb(i1)).eq.1.or.iabs(lb(i1)).eq.2)
4735 1 .and.(iabs(lb(i2)).eq.1.or.iabs(lb(i2)).eq.2)) then
4736 goto 108
4737 else
4738 return
4739 endif
4740 endif
4741c
4742*-----------------------------------------------------------------------
4743*COM: TEST FOR ELASTIC SCATTERING (EITHER N-N OR DELTA-DELTA 0R
4744* N-DELTA OR N*-N* or N*-Delta)
4745c IF (X1 .LE. SIGNN/SIG) THEN
4746 IF (X1.LE.(SIGNN/SIG)) THEN
4747*COM: PARAMETRISATION IS TAKEN FROM THE CUGNON-PAPER
4748 AS = ( 3.65 * (SRT - 1.8766) )**6
4749 A = 6.0 * AS / (1.0 + AS)
4750 TA = -2.0 * PR**2
4751 X = RANART(NSEED)
4752clin-10/24/02 T1 = DLOG( (1-X) * DEXP(dble(A)*dble(TA)) + X ) / A
4753 T1 = sngl(DLOG(dble(1.-X)*DEXP(dble(A)*dble(TA))+dble(X)))/ A
4754 C1 = 1.0 - T1/TA
4755 T1 = 2.0 * PI * RANART(NSEED)
4756 IBLOCK=1
4757 GO TO 107
4758 ELSE
4759*COM: TEST FOR INELASTIC SCATTERING
4760* IF THE AVAILABLE ENERGY IS LESS THAN THE PION-MASS, NOTHING
4761* CAN HAPPEN ANY MORE ==> RETURN (2.012 = 2*AVMASS + PI-MASS)
4762clin-5/2008: Mdeuteron+Mpi=2.0106 to 2.0152 GeV/c2, so we can still use this:
4763 IF (SRT .LT. 2.012) RETURN
4764* calculate the N*(1535) production cross section in N+N collisions
4765* note that the cross sections in this subroutine are in units of mb
4766* as only ratios of the cross sections are used to determine the
4767* reaction channels
4768 call N1535(iabs(lb(i1)),iabs(lb(i2)),srt,x1535)
4769*COM: HERE WE HAVE A PROCESS N+N ==> N+DELTA,OR N+N==>N+N*(144) or N*(1535)
4770* OR
4771* 3 pi channel : N+N==>d1+d2+PION
4772 SIG3=3.*(X3pi(SRT)+x33pi(srt))
4773* 2 pi channel : N+N==>d1+d2+d1*n*+n*n*
4774 SIG4=4.*X2pi(srt)
4775* 4 pi channel : N+N==>d1+d2+rho
4776 s4pi=x4pi(srt)
4777* N+N-->NN+rho channel
4778 srho=xrho(srt)
4779* N+N-->NN+omega
4780 somega=omega(srt)
4781* CROSS SECTION FOR KAON PRODUCTION from the four channels
4782* for NLK channel
4783 akp=0.498
4784 ak0=0.498
4785 ana=0.94
4786 ada=1.232
4787 al=1.1157
4788 as=1.1197
4789 xsk1=0
4790 xsk2=0
4791 xsk3=0
4792 xsk4=0
4793 xsk5=0
4794 t1nlk=ana+al+akp
4795 if(srt.le.t1nlk)go to 222
4796 XSK1=1.5*PPLPK(SRT)
4797* for DLK channel
4798 t1dlk=ada+al+akp
4799 t2dlk=ada+al-akp
4800 if(srt.le.t1dlk)go to 222
4801 es=srt
4802 pmdlk2=(es**2-t1dlk**2)*(es**2-t2dlk**2)/(4.*es**2)
4803 pmdlk=sqrt(pmdlk2)
4804 XSK3=1.5*PPLPK(srt)
4805* for NSK channel
4806 t1nsk=ana+as+akp
4807 t2nsk=ana+as-akp
4808 if(srt.le.t1nsk)go to 222
4809 pmnsk2=(es**2-t1nsk**2)*(es**2-t2nsk**2)/(4.*es**2)
4810 pmnsk=sqrt(pmnsk2)
4811 XSK2=1.5*(PPK1(srt)+PPK0(srt))
4812* for DSK channel
4813 t1DSk=aDa+aS+akp
4814 t2DSk=aDa+aS-akp
4815 if(srt.le.t1dsk)go to 222
4816 pmDSk2=(es**2-t1DSk**2)*(es**2-t2DSk**2)/(4.*es**2)
4817 pmDSk=sqrt(pmDSk2)
4818 XSK4=1.5*(PPK1(srt)+PPK0(srt))
4819csp11/21/01
4820c phi production
4821 if(srt.le.(2.*amn+aphi))go to 222
4822c !! mb put the correct form
4823 xsk5 = 0.0001
4824csp11/21/01 end
4825c
4826* THE TOTAL KAON+ PRODUCTION CROSS SECTION IS THEN
4827 222 SIGK=XSK1+XSK2+XSK3+XSK4
4828
4829cbz3/7/99 neutralk
4830 XSK1 = 2.0 * XSK1
4831 XSK2 = 2.0 * XSK2
4832 XSK3 = 2.0 * XSK3
4833 XSK4 = 2.0 * XSK4
4834 SIGK = 2.0 * SIGK + xsk5
4835cbz3/7/99 neutralk end
4836c
4837** FOR P+P or L/S+L/S COLLISION:
4838c lb1=lb(i1)
4839c lb2=lb(i2)
4840 lb1=iabs(lb(i1))
4841 lb2=iabs(lb(i2))
4842 IF((LB(I1)*LB(I2).EQ.1).or.
4843 & ((lb1.le.17.and.lb1.ge.14).and.(lb2.le.17.and.lb2.ge.14)).
4844 & or.((lb1.le.2).and.(lb2.le.17.and.lb2.ge.14)).
4845 & or.((lb2.le.2).and.(lb1.le.17.and.lb1.ge.14)))THEN
4846clin-8/2008 PP->d+meson here:
4847 IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
4848 SIG1=SIGMA(SRT,1,1,0)+0.5*SIGMA(SRT,1,1,1)
4849 SIG2=1.5*SIGMA(SRT,1,1,1)
4850 SIGND=SIG1+SIG2+SIG3+SIG4+X1535+SIGK+s4pi+srho+somega
4851clin-5/2008:
4852c IF (X1.GT.(SIGNN+SIGND)/SIG)RETURN
4853 IF (X1.GT.(SIGNN+SIGND+sdprod)/SIG)RETURN
4854 DIR=SIG3/SIGND
4855 IF(RANART(NSEED).LE.DIR)GO TO 106
4856 IF(RANART(NSEED).LE.SIGK/(SIGK+X1535+SIG4+SIG2+SIG1
4857 & +s4pi+srho+somega))GO TO 306
4858 if(RANART(NSEED).le.s4pi/(x1535+sig4+sig2+sig1
4859 & +s4pi+srho+somega))go to 307
4860 if(RANART(NSEED).le.srho/(x1535+sig4+sig2+sig1
4861 & +srho+somega))go to 308
4862 if(RANART(NSEED).le.somega/(x1535+sig4+sig2+sig1
4863 & +somega))go to 309
4864 if(RANART(NSEED).le.x1535/(sig1+sig2+sig4+x1535))then
4865* N*(1535) production
4866 N12=9
4867 ELSE
4868 IF(RANART(NSEED).LE.SIG4/(SIG1+sig2+sig4))THEN
4869* DOUBLE DELTA PRODUCTION
4870 N12=66
4871 GO TO 1012
4872 else
4873*DELTA PRODUCTION
4874 N12=3
4875 IF (RANART(NSEED).GT.SIG1/(SIG1+SIG2))N12=4
4876 ENDIF
4877 endif
4878 GO TO 1011
4879 ENDIF
4880** FOR N+N COLLISION:
4881 IF(iabs(LB(I1)).EQ.2.AND.iabs(LB(I2)).EQ.2)THEN
4882clin-8/2008 NN->d+meson here:
4883 IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
4884 SIG1=SIGMA(SRT,1,1,0)+0.5*SIGMA(SRT,1,1,1)
4885 SIG2=1.5*SIGMA(SRT,1,1,1)
4886 SIGND=SIG1+SIG2+X1535+SIG3+SIG4+SIGK+s4pi+srho+somega
4887clin-5/2008:
4888c IF (X1.GT.(SIGNN+SIGND)/SIG)RETURN
4889 IF (X1.GT.(SIGNN+SIGND+sdprod)/SIG)RETURN
4890 dir=sig3/signd
4891 IF(RANART(NSEED).LE.DIR)GO TO 106
4892 IF(RANART(NSEED).LE.SIGK/(SIGK+X1535+SIG4+SIG2+SIG1
4893 & +s4pi+srho+somega))GO TO 306
4894 if(RANART(NSEED).le.s4pi/(x1535+sig4+sig2+sig1
4895 & +s4pi+srho+somega))go to 307
4896 if(RANART(NSEED).le.srho/(x1535+sig4+sig2+sig1
4897 & +srho+somega))go to 308
4898 if(RANART(NSEED).le.somega/(x1535+sig4+sig2+sig1
4899 & +somega))go to 309
4900 IF(RANART(NSEED).LE.X1535/(x1535+sig1+sig2+sig4))THEN
4901* N*(1535) PRODUCTION
4902 N12=10
4903 ELSE
4904 if(RANART(NSEED).le.sig4/(sig1+sig2+sig4))then
4905* double delta production
4906 N12=67
4907 GO TO 1013
4908 else
4909* DELTA PRODUCTION
4910 N12=6
4911 IF (RANART(NSEED).GT.SIG1/(SIG1+SIG2))N12=5
4912 ENDIF
4913 endif
4914 GO TO 1011
4915 ENDIF
4916** FOR N+P COLLISION
4917 IF(LB(I1)*LB(I2).EQ.2)THEN
4918clin-5/2008 NP->d+meson here:
4919 IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
4920 SIG1=0.5*SIGMA(SRT,1,1,1)+0.25*SIGMA(SRT,1,1,0)
4921 IF(NSTAR.EQ.1)THEN
4922 SIG2=(3./4.)*SIGMA(SRT,2,0,1)
4923 ELSE
4924 SIG2=0.
4925 ENDIF
4926 SIGND=2.*(SIG1+SIG2+X1535)+sig3+sig4+SIGK+s4pi+srho+somega
4927clin-5/2008:
4928c IF (X1.GT.(SIGNN+SIGND)/SIG)RETURN
4929 IF (X1.GT.(SIGNN+SIGND+sdprod)/SIG)RETURN
4930 dir=sig3/signd
4931 IF(RANART(NSEED).LE.DIR)GO TO 106
4932 IF(RANART(NSEED).LE.SIGK/(SIGND-SIG3))GO TO 306
4933 if(RANART(NSEED).le.s4pi/(signd-sig3-sigk))go to 307
4934 if(RANART(NSEED).le.srho/(signd-sig3-sigk-s4pi))go to 308
4935 if(RANART(NSEED).le.somega/(signd-sig3-sigk-s4pi-srho))
4936 1 go to 309
4937 IF(RANART(NSEED).LT.X1535/(SIG1+SIG2+X1535+0.5*sig4))THEN
4938* N*(1535) PRODUCTION
4939 N12=11
4940 IF(RANART(NSEED).LE.0.5)N12=12
4941 ELSE
4942 if(RANART(NSEED).le.sig4/(sig4+2.*(sig1+sig2)))then
4943* double resonance production
4944 N12=68
4945 GO TO 1014
4946 else
4947 IF(RANART(NSEED).LE.SIG1/(SIG1+SIG2))THEN
4948* DELTA PRODUCTION
4949 N12=2
4950 IF(RANART(NSEED).GE.0.5)N12=1
4951 ELSE
4952* N*(1440) PRODUCTION
4953 N12=8
4954 IF(RANART(NSEED).GE.0.5)N12=7
4955 ENDIF
4956 ENDIF
4957 ENDIF
4958 endif
4959 1011 iblock=2
4960 CONTINUE
4961*PARAMETRIZATION OF THE SHAPE OF THE DELTA RESONANCE ACCORDING
4962* TO kitazoe's or J.D.JACKSON'S MASS FORMULA AND BREIT WIGNER
4963* FORMULA FOR N* RESORANCE
4964* DETERMINE DELTA MASS VIA REJECTION METHOD.
4965 DMAX = SRT - AVMASS-0.005
4966 DMAX = SRT - AVMASS-0.005
4967 DMIN = 1.078
4968 IF(N12.LT.7)THEN
4969* Delta(1232) production
4970 IF(DMAX.LT.1.232) THEN
4971 FM=FDE(DMAX,SRT,0.)
4972 ELSE
4973
4974clin-10/25/02 get rid of argument usage mismatch in FDE():
4975 xdmass=1.232
4976c FM=FDE(1.232,SRT,1.)
4977 FM=FDE(xdmass,SRT,1.)
4978clin-10/25/02-end
4979
4980 ENDIF
4981 IF(FM.EQ.0.)FM=1.E-09
4982 NTRY1=0
498310 DM = RANART(NSEED) * (DMAX-DMIN) + DMIN
4984 NTRY1=NTRY1+1
4985 IF((RANART(NSEED) .GT. FDE(DM,SRT,1.)/FM).AND.
4986 1 (NTRY1.LE.30)) GOTO 10
4987
4988clin-2/26/03 limit the Delta mass below a certain value
4989c (here taken as its central value + 2* B-W fullwidth):
4990 if(dm.gt.1.47) goto 10
4991
4992 GO TO 13
4993 ENDIF
4994 IF((n12.eq.7).or.(n12.eq.8))THEN
4995* N*(1440) production
4996 IF(DMAX.LT.1.44) THEN
4997 FM=FNS(DMAX,SRT,0.)
4998 ELSE
4999
5000clin-10/25/02 get rid of argument usage mismatch in FNS():
5001 xdmass=1.44
5002c FM=FNS(1.44,SRT,1.)
5003 FM=FNS(xdmass,SRT,1.)
5004clin-10/25/02-end
5005
5006 ENDIF
5007 IF(FM.EQ.0.)FM=1.E-09
5008 NTRY2=0
500911 DM=RANART(NSEED)*(DMAX-DMIN)+DMIN
5010 NTRY2=NTRY2+1
5011 IF((RANART(NSEED).GT.FNS(DM,SRT,1.)/FM).AND.
5012 1 (NTRY2.LE.10)) GO TO 11
5013
5014clin-2/26/03 limit the N* mass below a certain value
5015c (here taken as its central value + 2* B-W fullwidth):
5016 if(dm.gt.2.14) goto 11
5017
5018 GO TO 13
5019 ENDIF
5020 IF(n12.ge.17)then
5021* N*(1535) production
5022 IF(DMAX.LT.1.535) THEN
5023 FM=FD5(DMAX,SRT,0.)
5024 ELSE
5025
5026clin-10/25/02 get rid of argument usage mismatch in FNS():
5027 xdmass=1.535
5028c FM=FD5(1.535,SRT,1.)
5029 FM=FD5(xdmass,SRT,1.)
5030clin-10/25/02-end
5031
5032 ENDIF
5033 IF(FM.EQ.0.)FM=1.E-09
5034 NTRY1=0
503512 DM = RANART(NSEED) * (DMAX-DMIN) + DMIN
5036 NTRY1=NTRY1+1
5037 IF((RANART(NSEED) .GT. FD5(DM,SRT,1.)/FM).AND.
5038 1 (NTRY1.LE.10)) GOTO 12
5039
5040clin-2/26/03 limit the N* mass below a certain value
5041c (here taken as its central value + 2* B-W fullwidth):
5042 if(dm.gt.1.84) goto 12
5043
5044 GO TO 13
5045 ENDIF
5046* CALCULATE THE MASSES OF BARYON RESONANCES IN THE DOUBLE RESONANCE
5047* PRODUCTION PROCESS AND RELABLE THE PARTICLES
50481012 iblock=43
5049 call Rmasdd(srt,1.232,1.232,1.08,
5050 & 1.08,ISEED,1,dm1,dm2)
5051 call Rmasdd(srt,1.232,1.44,1.08,
5052 & 1.08,ISEED,3,dm1n,dm2n)
5053 IF(N12.EQ.66)THEN
5054*(1) PP-->DOUBLE RESONANCES
5055* DETERMINE THE FINAL STATE
5056 XFINAL=RANART(NSEED)
5057 IF(XFINAL.LE.0.25)THEN
5058* (1.1) D+++D0
5059 LB(I1)=9
5060 LB(I2)=7
5061 e(i1)=dm1
5062 e(i2)=dm2
5063 GO TO 200
5064* go to 200 to set the new momentum
5065 ENDIF
5066 IF((XFINAL.gt.0.25).and.(xfinal.le.0.5))THEN
5067* (1.2) D++D+
5068 LB(I1)=8
5069 LB(I2)=8
5070 e(i1)=dm1
5071 e(i2)=dm2
5072 GO TO 200
5073* go to 200 to set the new momentum
5074 ENDIF
5075 IF((XFINAL.gt.0.5).and.(xfinal.le.0.75))THEN
5076* (1.3) D+++N*0
5077 LB(I1)=9
5078 LB(I2)=10
5079 e(i1)=dm1n
5080 e(i2)=dm2n
5081 GO TO 200
5082* go to 200 to set the new momentum
5083 ENDIF
5084 IF(XFINAL.gt.0.75)then
5085* (1.4) D++N*+
5086 LB(I1)=8
5087 LB(I2)=11
5088 e(i1)=dm1n
5089 e(i2)=dm2n
5090 GO TO 200
5091* go to 200 to set the new momentum
5092 ENDIF
5093 ENDIF
50941013 iblock=43
5095 call Rmasdd(srt,1.232,1.232,1.08,
5096 & 1.08,ISEED,1,dm1,dm2)
5097 call Rmasdd(srt,1.232,1.44,1.08,
5098 & 1.08,ISEED,3,dm1n,dm2n)
5099 IF(N12.EQ.67)THEN
5100*(2) NN-->DOUBLE RESONANCES
5101* DETERMINE THE FINAL STATE
5102 XFINAL=RANART(NSEED)
5103 IF(XFINAL.LE.0.25)THEN
5104* (2.1) D0+D0
5105 LB(I1)=7
5106 LB(I2)=7
5107 e(i1)=dm1
5108 e(i2)=dm2
5109 GO TO 200
5110* go to 200 to set the new momentum
5111 ENDIF
5112 IF((XFINAL.gt.0.25).and.(xfinal.le.0.5))THEN
5113* (2.2) D++D+
5114 LB(I1)=6
5115 LB(I2)=8
5116 e(i1)=dm1
5117 e(i2)=dm2
5118 GO TO 200
5119* go to 200 to set the new momentum
5120 ENDIF
5121 IF((XFINAL.gt.0.5).and.(xfinal.le.0.75))THEN
5122* (2.3) D0+N*0
5123 LB(I1)=7
5124 LB(I2)=10
5125 e(i1)=dm1n
5126 e(i2)=dm2n
5127 GO TO 200
5128* go to 200 to set the new momentum
5129 ENDIF
5130 IF(XFINAL.gt.0.75)then
5131* (2.4) D++N*+
5132 LB(I1)=8
5133 LB(I2)=11
5134 e(i1)=dm1n
5135 e(i2)=dm2n
5136 GO TO 200
5137* go to 200 to set the new momentum
5138 ENDIF
5139 ENDIF
51401014 iblock=43
5141 call Rmasdd(srt,1.232,1.232,1.08,
5142 & 1.08,ISEED,1,dm1,dm2)
5143 call Rmasdd(srt,1.232,1.44,1.08,
5144 & 1.08,ISEED,3,dm1n,dm2n)
5145 IF(N12.EQ.68)THEN
5146*(3) NP-->DOUBLE RESONANCES
5147* DETERMINE THE FINAL STATE
5148 XFINAL=RANART(NSEED)
5149 IF(XFINAL.LE.0.25)THEN
5150* (3.1) D0+D+
5151 LB(I1)=7
5152 LB(I2)=8
5153 e(i1)=dm1
5154 e(i2)=dm2
5155 GO TO 200
5156* go to 200 to set the new momentum
5157 ENDIF
5158 IF((XFINAL.gt.0.25).and.(xfinal.le.0.5))THEN
5159* (3.2) D+++D-
5160 LB(I1)=9
5161 LB(I2)=6
5162 e(i1)=dm1
5163 e(i2)=dm2
5164 GO TO 200
5165* go to 200 to set the new momentum
5166 ENDIF
5167 IF((XFINAL.gt.0.5).and.(xfinal.le.0.75))THEN
5168* (3.3) D0+N*+
5169 LB(I1)=7
5170 LB(I2)=11
5171 e(i1)=dm1n
5172 e(i2)=dm2n
5173 GO TO 200
5174* go to 200 to set the new momentum
5175 ENDIF
5176 IF(XFINAL.gt.0.75)then
5177* (3.4) D++N*0
5178 LB(I1)=8
5179 LB(I2)=10
5180 e(i1)=dm1n
5181 e(i2)=dm2n
5182 GO TO 200
5183* go to 200 to set the new momentum
5184 ENDIF
5185 ENDIF
518613 CONTINUE
5187*-------------------------------------------------------
5188* RELABLE BARYON I1 AND I2
5189*1. p+n-->delta(+)+n
5190 IF(N12.EQ.1)THEN
5191 IF(iabs(LB(I1)).EQ.1)THEN
5192 LB(I2)=2
5193 LB(I1)=8
5194 E(I1)=DM
5195 ELSE
5196 LB(I1)=2
5197 LB(I2)=8
5198 E(I2)=DM
5199 ENDIF
5200 GO TO 200
5201 ENDIF
5202*2 p+n-->delta(0)+p
5203 IF(N12.EQ.2)THEN
5204 IF(iabs(LB(I1)).EQ.2)THEN
5205 LB(I2)=1
5206 LB(I1)=7
5207 E(I1)=DM
5208 ELSE
5209 LB(I1)=1
5210 LB(I2)=7
5211 E(I2)=DM
5212 ENDIF
5213 GO TO 200
5214 ENDIF
5215*3 p+p-->delta(++)+n
5216 IF(N12.EQ.3)THEN
5217 LB(I1)=9
5218 E(I1)=DM
5219 LB(I2)=2
5220 E(I2)=AMN
5221 GO TO 200
5222 ENDIF
5223*4 p+p-->delta(+)+p
5224 IF(N12.EQ.4)THEN
5225 LB(I2)=1
5226 LB(I1)=8
5227 E(I1)=DM
5228 GO TO 200
5229 ENDIF
5230*5 n+n--> delta(0)+n
5231 IF(N12.EQ.5)THEN
5232 LB(I2)=2
5233 LB(I1)=7
5234 E(I1)=DM
5235 GO TO 200
5236 ENDIF
5237*6 n+n--> delta(-)+p
5238 IF(N12.EQ.6)THEN
5239 LB(I1)=6
5240 E(I1)=DM
5241 LB(I2)=1
5242 E(I2)=AMP
5243 GO TO 200
5244 ENDIF
5245*7 n+p--> N*(0)+p
5246 IF(N12.EQ.7)THEN
5247 IF(iabs(LB(I1)).EQ.1)THEN
5248 LB(I1)=1
5249 LB(I2)=10
5250 E(I2)=DM
5251 ELSE
5252 LB(I2)=1
5253 LB(I1)=10
5254 E(I1)=DM
5255 ENDIF
5256 GO TO 200
5257 ENDIF
5258*8 n+p--> N*(+)+n
5259 IF(N12.EQ.8)THEN
5260 IF(iabs(LB(I1)).EQ.1)THEN
5261 LB(I2)=2
5262 LB(I1)=11
5263 E(I1)=DM
5264 ELSE
5265 LB(I1)=2
5266 LB(I2)=11
5267 E(I2)=DM
5268 ENDIF
5269 GO TO 200
5270 ENDIF
5271*9 p+p--> N*(+)(1535)+p
5272 IF(N12.EQ.9)THEN
5273 IF(RANART(NSEED).le.0.5)THEN
5274 LB(I2)=1
5275 LB(I1)=13
5276 E(I1)=DM
5277 ELSE
5278 LB(I1)=1
5279 LB(I2)=13
5280 E(I2)=DM
5281 ENDIF
5282 GO TO 200
5283 ENDIF
5284*10 n+n--> N*(0)(1535)+n
5285 IF(N12.EQ.10)THEN
5286 IF(RANART(NSEED).le.0.5)THEN
5287 LB(I2)=2
5288 LB(I1)=12
5289 E(I1)=DM
5290 ELSE
5291 LB(I1)=2
5292 LB(I2)=12
5293 E(I2)=DM
5294 ENDIF
5295 GO TO 200
5296 ENDIF
5297*11 n+p--> N*(+)(1535)+n
5298 IF(N12.EQ.11)THEN
5299 IF(iabs(LB(I1)).EQ.2)THEN
5300 LB(I1)=2
5301 LB(I2)=13
5302 E(I2)=DM
5303 ELSE
5304 LB(I2)=2
5305 LB(I1)=13
5306 E(I1)=DM
5307 ENDIF
5308 GO TO 200
5309 ENDIF
5310*12 n+p--> N*(0)(1535)+p
5311 IF(N12.EQ.12)THEN
5312 IF(iabs(LB(I1)).EQ.1)THEN
5313 LB(I1)=1
5314 LB(I2)=12
5315 E(I2)=DM
5316 ELSE
5317 LB(I2)=1
5318 LB(I1)=12
5319 E(I1)=DM
5320 ENDIF
5321 ENDIF
5322 endif
5323* CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
5324* ENERGY CONSERVATION
5325200 EM1=E(I1)
5326 EM2=E(I2)
5327 PR2 = (SRT**2 - EM1**2 - EM2**2)**2
5328 1 - 4.0 * (EM1*EM2)**2
5329 IF(PR2.LE.0.)PR2=1.e-09
5330 PR=SQRT(PR2)/(2.*SRT)
5331 if(srt.le.2.14)C1= 1.0 - 2.0 * RANART(NSEED)
86c53b9e 5332 if(srt.gt.2.14.and.srt.le.2.4)c1=anga(srt,iseed)
0119ef9a 5333 if(srt.gt.2.4)then
5334
5335clin-10/25/02 get rid of argument usage mismatch in PTR():
5336 xptr=0.33*pr
5337c cc1=ptr(0.33*pr,iseed)
5338 cc1=ptr(xptr,iseed)
5339clin-10/25/02-end
5340
5341 c1=sqrt(pr**2-cc1**2)/pr
5342 endif
5343 T1 = 2.0 * PI * RANART(NSEED)
5344 if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
5345 lb(i1) = -lb(i1)
5346 lb(i2) = -lb(i2)
5347 endif
5348 GO TO 107
5349*FOR THE NN-->D1+D2+PI PROCESS, FIND MOMENTUM OF THE FINAL TWO
5350*DELTAS AND PION IN THE NUCLEUS-NUCLEUS CMS.
5351106 CONTINUE
5352 NTRY1=0
5353123 CALL DDP2(SRT,ISEED,PX3,PY3,PZ3,DM3,PX4,PY4,PZ4,DM4,
5354 & PPX,PPY,PPZ,icou1)
5355 NTRY1=NTRY1+1
5356 if((icou1.lt.0).AND.(NTRY1.LE.40))GO TO 123
5357C if(icou1.lt.0)return
5358* ROTATE THE MOMENTA OF PARTICLES IN THE CMS OF P1+P2
5359 CALL ROTATE(PX,PY,PZ,PX3,PY3,PZ3)
5360 CALL ROTATE(PX,PY,PZ,PX4,PY4,PZ4)
5361 CALL ROTATE(PX,PY,PZ,PPX,PPY,PPZ)
5362 NNN=NNN+1
5363* DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
5364* (1) FOR P+P
5365 XDIR=RANART(NSEED)
5366 IF(LB(I1)*LB(I2).EQ.1)THEN
5367 IF(XDIR.Le.0.2)then
5368* (1.1)P+P-->D+++D0+PION(0)
5369 LPION(NNN,IRUN)=4
5370 EPION(NNN,IRUN)=AP1
5371 LB(I1)=9
5372 LB(I2)=7
5373 GO TO 205
5374 ENDIF
5375* (1.2)P+P -->D++D+PION(0)
5376 IF((XDIR.LE.0.4).AND.(XDIR.GT.0.2))THEN
5377 LPION(NNN,IRUN)=4
5378 EPION(NNN,IRUN)=AP1
5379 LB(I1)=8
5380 LB(I2)=8
5381 GO TO 205
5382 ENDIF
5383* (1.3)P+P-->D+++D+PION(-)
5384 IF((XDIR.LE.0.6).AND.(XDIR.GT.0.4))THEN
5385 LPION(NNN,IRUN)=3
5386 EPION(NNN,IRUN)=AP2
5387 LB(I1)=9
5388 LB(I2)=8
5389 GO TO 205
5390 ENDIF
5391 IF((XDIR.LE.0.8).AND.(XDIR.GT.0.6))THEN
5392 LPION(NNN,IRUN)=5
5393 EPION(NNN,IRUN)=AP2
5394 LB(I1)=9
5395 LB(I2)=6
5396 GO TO 205
5397 ENDIF
5398 IF(XDIR.GT.0.8)THEN
5399 LPION(NNN,IRUN)=5
5400 EPION(NNN,IRUN)=AP2
5401 LB(I1)=7
5402 LB(I2)=8
5403 GO TO 205
5404 ENDIF
5405 ENDIF
5406* (2)FOR N+N
5407 IF(iabs(LB(I1)).EQ.2.AND.iabs(LB(I2)).EQ.2)THEN
5408 IF(XDIR.Le.0.2)then
5409* (2.1)N+N-->D++D-+PION(0)
5410 LPION(NNN,IRUN)=4
5411 EPION(NNN,IRUN)=AP1
5412 LB(I1)=6
5413 LB(I2)=7
5414 GO TO 205
5415 ENDIF
5416* (2.2)N+N -->D+++D-+PION(-)
5417 IF((XDIR.LE.0.4).AND.(XDIR.GT.0.2))THEN
5418 LPION(NNN,IRUN)=3
5419 EPION(NNN,IRUN)=AP2
5420 LB(I1)=6
5421 LB(I2)=9
5422 GO TO 205
5423 ENDIF
5424* (2.3)P+P-->D0+D-+PION(+)
5425 IF((XDIR.GT.0.4).AND.(XDIR.LE.0.6))THEN
5426 LPION(NNN,IRUN)=5
5427 EPION(NNN,IRUN)=AP2
5428 LB(I1)=9
5429 LB(I2)=8
5430 GO TO 205
5431 ENDIF
5432* (2.4)P+P-->D0+D0+PION(0)
5433 IF((XDIR.GT.0.6).AND.(XDIR.LE.0.8))THEN
5434 LPION(NNN,IRUN)=4
5435 EPION(NNN,IRUN)=AP1
5436 LB(I1)=7
5437 LB(I2)=7
5438 GO TO 205
5439 ENDIF
5440* (2.5)P+P-->D0+D++PION(-)
5441 IF(XDIR.GT.0.8)THEN
5442 LPION(NNN,IRUN)=3
5443 EPION(NNN,IRUN)=AP2
5444 LB(I1)=7
5445 LB(I2)=8
5446 GO TO 205
5447 ENDIF
5448 ENDIF
5449* (3)FOR N+P
5450 IF(LB(I1)*LB(I2).EQ.2)THEN
5451 IF(XDIR.Le.0.17)then
5452* (3.1)N+P-->D+++D-+PION(0)
5453 LPION(NNN,IRUN)=4
5454 EPION(NNN,IRUN)=AP1
5455 LB(I1)=6
5456 LB(I2)=9
5457 GO TO 205
5458 ENDIF
5459* (3.2)N+P -->D+++D0+PION(-)
5460 IF((XDIR.LE.0.34).AND.(XDIR.GT.0.17))THEN
5461 LPION(NNN,IRUN)=3
5462 EPION(NNN,IRUN)=AP2
5463 LB(I1)=7
5464 LB(I2)=9
5465 GO TO 205
5466 ENDIF
5467* (3.3)N+P-->D++D-+PION(+)
5468 IF((XDIR.GT.0.34).AND.(XDIR.LE.0.51))THEN
5469 LPION(NNN,IRUN)=5
5470 EPION(NNN,IRUN)=AP2
5471 LB(I1)=7
5472 LB(I2)=8
5473 GO TO 205
5474 ENDIF
5475* (3.4)N+P-->D++D++PION(-)
5476 IF((XDIR.GT.0.51).AND.(XDIR.LE.0.68))THEN
5477 LPION(NNN,IRUN)=3
5478 EPION(NNN,IRUN)=AP2
5479 LB(I1)=8
5480 LB(I2)=8
5481 GO TO 205
5482 ENDIF
5483* (3.5)N+P-->D0+D++PION(0)
5484 IF((XDIR.GT.0.68).AND.(XDIR.LE.0.85))THEN
5485 LPION(NNN,IRUN)=4
5486 EPION(NNN,IRUN)=AP2
5487 LB(I1)=7
5488 LB(I2)=8
5489 GO TO 205
5490 ENDIF
5491* (3.6)N+P-->D0+D0+PION(+)
5492 IF(XDIR.GT.0.85)THEN
5493 LPION(NNN,IRUN)=5
5494 EPION(NNN,IRUN)=AP2
5495 LB(I1)=7
5496 LB(I2)=7
5497 ENDIF
5498 ENDIF
5499* FIND THE MOMENTUM OF PARTICLES IN THE FINAL STATE IN THE NUCLEUS-
5500* NUCLEUS CMS. FRAME
5501* LORENTZ-TRANSFORMATION INTO LAB FRAME FOR DELTA1
5502205 E1CM = SQRT (dm3**2 + PX3**2 + PY3**2 + PZ3**2)
5503 P1BETA = PX3*BETAX + PY3*BETAY + PZ3*BETAZ
5504 TRANSF = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) + E1CM )
5505 Pt1i1 = BETAX * TRANSF + PX3
5506 Pt2i1 = BETAY * TRANSF + PY3
5507 Pt3i1 = BETAZ * TRANSF + PZ3
5508 Eti1 = DM3
5509c
5510 if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
5511 lb(i1) = -lb(i1)
5512 lb(i2) = -lb(i2)
5513 if(LPION(NNN,IRUN) .eq. 3)then
5514 LPION(NNN,IRUN)=5
5515 elseif(LPION(NNN,IRUN) .eq. 5)then
5516 LPION(NNN,IRUN)=3
5517 endif
5518 endif
5519c
5520 lb1=lb(i1)
5521* FOR DELTA2
5522 E2CM = SQRT (dm4**2 + PX4**2 + PY4**2 + PZ4**2)
5523 P2BETA = PX4*BETAX+PY4*BETAY+PZ4*BETAZ
5524 TRANSF = GAMMA * (GAMMA*P2BETA / (GAMMA + 1.) + E2CM)
5525 Pt1I2 = BETAX * TRANSF + PX4
5526 Pt2I2 = BETAY * TRANSF + PY4
5527 Pt3I2 = BETAZ * TRANSF + PZ4
5528 EtI2 = DM4
5529 lb2=lb(i2)
5530* assign delta1 and delta2 to i1 or i2 to keep the leadng particle
5531* behaviour
5532C if((pt1i1*px1+pt2i1*py1+pt3i1*pz1).gt.0)then
5533 p(1,i1)=pt1i1
5534 p(2,i1)=pt2i1
5535 p(3,i1)=pt3i1
5536 e(i1)=eti1
5537 lb(i1)=lb1
5538 p(1,i2)=pt1i2
5539 p(2,i2)=pt2i2
5540 p(3,i2)=pt3i2
5541 e(i2)=eti2
5542 lb(i2)=lb2
5543 PX1 = P(1,I1)
5544 PY1 = P(2,I1)
5545 PZ1 = P(3,I1)
5546 EM1 = E(I1)
5547 ID(I1) = 2
5548 ID(I2) = 2
5549 ID1 = ID(I1)
5550 IBLOCK=4
5551* GET PION'S MOMENTUM AND COORDINATES IN NUCLEUS-NUCLEUS CMS. FRAME
5552 EPCM=SQRT(EPION(NNN,IRUN)**2+PPX**2+PPY**2+PPZ**2)
5553 PPBETA=PPX*BETAX+PPY*BETAY+PPZ*BETAZ
5554 TRANSF=GAMMA*(GAMMA*PPBETA/(GAMMA+1.)+EPCM)
5555 PPION(1,NNN,IRUN)=BETAX*TRANSF+PPX
5556 PPION(2,NNN,IRUN)=BETAY*TRANSF+PPY
5557 PPION(3,NNN,IRUN)=BETAZ*TRANSF+PPZ
5558clin-5/2008:
5559 dppion(nnn,irun)=dpertp(i1)*dpertp(i2)
5560clin-5/2008 do not allow smearing in position of produced particles
5561c to avoid immediate reinteraction with the particle I1, I2 or themselves:
5562c2002 X01 = 1.0 - 2.0 * RANART(NSEED)
5563c Y01 = 1.0 - 2.0 * RANART(NSEED)
5564c Z01 = 1.0 - 2.0 * RANART(NSEED)
5565c IF ((X01*X01+Y01*Y01+Z01*Z01) .GT. 1.0) GOTO 2002
5566c RPION(1,NNN,IRUN)=R(1,I1)+0.5*x01
5567c RPION(2,NNN,IRUN)=R(2,I1)+0.5*y01
5568c RPION(3,NNN,IRUN)=R(3,I1)+0.5*z01
5569 RPION(1,NNN,IRUN)=R(1,I1)
5570 RPION(2,NNN,IRUN)=R(2,I1)
5571 RPION(3,NNN,IRUN)=R(3,I1)
5572c
5573 go to 90005
5574clin-5/2008 N+N->Deuteron+pi:
5575* FIND MOMENTUM OF THE FINAL PARTICLES IN THE NUCLEUS-NUCLEUS CMS.
5576 108 CONTINUE
5577 if(idpert.eq.1.and.ipert1.eq.1.and.npertd.ge.1) then
5578c For idpert=1: we produce npertd pert deuterons:
5579 ndloop=npertd
5580 elseif(idpert.eq.2.and.npertd.ge.1) then
5581c For idpert=2: we first save information for npertd pert deuterons;
5582c at the last ndloop we create the regular deuteron+pi
5583c and those pert deuterons:
5584 ndloop=npertd+1
5585 else
5586c Just create the regular deuteron+pi:
5587 ndloop=1
5588 endif
5589c
5590 dprob1=sdprod/sig/float(npertd)
5591 do idloop=1,ndloop
5592 CALL bbdangle(pxd,pyd,pzd,nt,ipert1,ianti,idloop,pfinal,
5593 1 dprob1,lbm)
5594 CALL ROTATE(PX,PY,PZ,PXd,PYd,PZd)
5595* LORENTZ-TRANSFORMATION OF THE MOMENTUM OF PARTICLES IN THE FINAL STATE
5596* FROM THE NN CMS FRAME INTO THE GLOBAL CMS FRAME:
5597* For the Deuteron:
5598 xmass=xmd
5599 E1dCM=SQRT(xmass**2+PXd**2+PYd**2+PZd**2)
5600 P1dBETA=PXd*BETAX+PYd*BETAY+PZd*BETAZ
5601 TRANSF=GAMMA*(GAMMA*P1dBETA/(GAMMA+1.)+E1dCM)
5602 pxi1=BETAX*TRANSF+PXd
5603 pyi1=BETAY*TRANSF+PYd
5604 pzi1=BETAZ*TRANSF+PZd
5605 if(ianti.eq.0)then
5606 lbd=42
5607 else
5608 lbd=-42
5609 endif
5610 if(idpert.eq.1.and.ipert1.eq.1.and.npertd.ge.1) then
5611cccc Perturbative production for idpert=1:
5612 nnn=nnn+1
5613 PPION(1,NNN,IRUN)=pxi1
5614 PPION(2,NNN,IRUN)=pyi1
5615 PPION(3,NNN,IRUN)=pzi1
5616 EPION(NNN,IRUN)=xmd
5617 LPION(NNN,IRUN)=lbd
5618 RPION(1,NNN,IRUN)=R(1,I1)
5619 RPION(2,NNN,IRUN)=R(2,I1)
5620 RPION(3,NNN,IRUN)=R(3,I1)
5621clin-5/2008 assign the perturbative probability:
5622 dppion(NNN,IRUN)=sdprod/sig/float(npertd)
5623 elseif(idpert.eq.2.and.idloop.le.npertd) then
5624clin-5/2008 For idpert=2, we produce NPERTD perturbative (anti)deuterons
5625c only when a regular (anti)deuteron+pi is produced in NN collisions.
5626c First save the info for the perturbative deuterons:
5627 ppd(1,idloop)=pxi1
5628 ppd(2,idloop)=pyi1
5629 ppd(3,idloop)=pzi1
5630 lbpd(idloop)=lbd
5631 else
5632cccc Regular production:
5633c For the regular pion: do LORENTZ-TRANSFORMATION:
5634 E(i1)=xmm
5635 E2piCM=SQRT(xmm**2+PXd**2+PYd**2+PZd**2)
5636 P2piBETA=-PXd*BETAX-PYd*BETAY-PZd*BETAZ
5637 TRANSF=GAMMA*(GAMMA*P2piBETA/(GAMMA+1.)+E2piCM)
5638 pxi2=BETAX*TRANSF-PXd
5639 pyi2=BETAY*TRANSF-PYd
5640 pzi2=BETAZ*TRANSF-PZd
5641 p(1,i1)=pxi2
5642 p(2,i1)=pyi2
5643 p(3,i1)=pzi2
5644c Remove regular pion to check the equivalence
5645c between the perturbative and regular deuteron results:
5646c E(i1)=0.
5647c
5648 LB(I1)=lbm
5649 PX1=P(1,I1)
5650 PY1=P(2,I1)
5651 PZ1=P(3,I1)
5652 EM1=E(I1)
5653 ID(I1)=2
5654 ID1=ID(I1)
5655 E1=SQRT(EM1**2+PX1**2+PY1**2+PZ1**2)
5656 lb1=lb(i1)
5657c For the regular deuteron:
5658 p(1,i2)=pxi1
5659 p(2,i2)=pyi1
5660 p(3,i2)=pzi1
5661 lb(i2)=lbd
5662 lb2=lb(i2)
5663 E(i2)=xmd
5664 EtI2=E(I2)
5665 ID(I2)=2
5666c For idpert=2: create the perturbative deuterons:
5667 if(idpert.eq.2.and.idloop.eq.ndloop) then
5668 do ipertd=1,npertd
5669 nnn=nnn+1
5670 PPION(1,NNN,IRUN)=ppd(1,ipertd)
5671 PPION(2,NNN,IRUN)=ppd(2,ipertd)
5672 PPION(3,NNN,IRUN)=ppd(3,ipertd)
5673 EPION(NNN,IRUN)=xmd
5674 LPION(NNN,IRUN)=lbpd(ipertd)
5675 RPION(1,NNN,IRUN)=R(1,I1)
5676 RPION(2,NNN,IRUN)=R(2,I1)
5677 RPION(3,NNN,IRUN)=R(3,I1)
5678clin-5/2008 assign the perturbative probability:
5679 dppion(NNN,IRUN)=1./float(npertd)
5680 enddo
5681 endif
5682 endif
5683 enddo
5684 IBLOCK=501
5685 go to 90005
5686clin-5/2008 N+N->Deuteron+pi over
5687* FOR THE NN-->KAON+X PROCESS, FIND MOMENTUM OF THE FINAL PARTICLES IN
5688* THE NUCLEUS-NUCLEUS CMS.
5689306 CONTINUE
5690csp11/21/01 phi production
5691 if(XSK5/sigK.gt.RANART(NSEED))then
5692 pz1=p(3,i1)
5693 pz2=p(3,i2)
5694 LB(I1) = 1 + int(2 * RANART(NSEED))
5695 LB(I2) = 1 + int(2 * RANART(NSEED))
5696 nnn=nnn+1
5697 LPION(NNN,IRUN)=29
5698 EPION(NNN,IRUN)=APHI
5699 iblock = 222
5700 GO TO 208
5701 ENDIF
5702c
5703 IBLOCK=9
5704 if(ianti .eq. 1)iblock=-9
5705c
5706 pz1=p(3,i1)
5707 pz2=p(3,i2)
5708* DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
5709 nnn=nnn+1
5710 LPION(NNN,IRUN)=23
5711 EPION(NNN,IRUN)=Aka
5712 if(srt.le.2.63)then
5713* only lambda production is possible
5714* (1.1)P+P-->p+L+kaon+
5715 ic=1
5716 LB(I1) = 1 + int(2 * RANART(NSEED))
5717 LB(I2)=14
5718 GO TO 208
5719 ENDIF
5720 if(srt.le.2.74.and.srt.gt.2.63)then
5721* both Lambda and sigma production are possible
5722 if(XSK1/(XSK1+XSK2).gt.RANART(NSEED))then
5723* lambda production
5724 ic=1
5725 LB(I1) = 1 + int(2 * RANART(NSEED))
5726 LB(I2)=14
5727 else
5728* sigma production
5729 LB(I1) = 1 + int(2 * RANART(NSEED))
5730 LB(I2) = 15 + int(3 * RANART(NSEED))
5731 ic=2
5732 endif
5733 GO TO 208
5734 endif
5735 if(srt.le.2.77.and.srt.gt.2.74)then
5736* then pp-->Delta lamda kaon can happen
5737 if(xsk1/(xsk1+xsk2+xsk3).
5738 1 gt.RANART(NSEED))then
5739* * (1.1)P+P-->p+L+kaon+
5740 ic=1
5741 LB(I1) = 1 + int(2 * RANART(NSEED))
5742 LB(I2)=14
5743 go to 208
5744 else
5745 if(xsk2/(xsk2+xsk3).gt.RANART(NSEED))then
5746* pp-->psk
5747 ic=2
5748 LB(I1) = 1 + int(2 * RANART(NSEED))
5749 LB(I2) = 15 + int(3 * RANART(NSEED))
5750 else
5751* pp-->D+l+k
5752 ic=3
5753 LB(I1) = 6 + int(4 * RANART(NSEED))
5754 lb(i2)=14
5755 endif
5756 GO TO 208
5757 endif
5758 endif
5759 if(srt.gt.2.77)then
5760* all four channels are possible
5761 if(xsk1/(xsk1+xsk2+xsk3+xsk4).gt.RANART(NSEED))then
5762* p lambda k production
5763 ic=1
5764 LB(I1) = 1 + int(2 * RANART(NSEED))
5765 LB(I2)=14
5766 go to 208
5767 else
5768 if(xsk3/(xsk2+xsk3+xsk4).gt.RANART(NSEED))then
5769* delta l K production
5770 ic=3
5771 LB(I1) = 6 + int(4 * RANART(NSEED))
5772 lb(i2)=14
5773 go to 208
5774 else
5775 if(xsk2/(xsk2+xsk4).gt.RANART(NSEED))then
5776* n sigma k production
5777 LB(I1) = 1 + int(2 * RANART(NSEED))
5778 LB(I2) = 15 + int(3 * RANART(NSEED))
5779 ic=2
5780 else
5781 ic=4
5782 LB(I1) = 6 + int(4 * RANART(NSEED))
5783 LB(I2) = 15 + int(3 * RANART(NSEED))
5784 endif
5785 go to 208
5786 endif
5787 endif
5788 endif
5789208 continue
5790 if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
5791 lb(i1) = - lb(i1)
5792 lb(i2) = - lb(i2)
5793 if(LPION(NNN,IRUN) .eq. 23)LPION(NNN,IRUN)=21
5794 endif
5795* KEEP ALL COORDINATES OF PARTICLE 2 FOR POSSIBLE PHASE SPACE CHANGE
5796 NTRY1=0
5797127 CALL BBKAON(ic,SRT,PX3,PY3,PZ3,DM3,PX4,PY4,PZ4,DM4,
5798 & PPX,PPY,PPZ,icou1)
5799 NTRY1=NTRY1+1
5800 if((icou1.lt.0).AND.(NTRY1.LE.20))GO TO 127
5801c if(icou1.lt.0)return
5802* ROTATE THE MOMENTA OF PARTICLES IN THE CMS OF P1+P2
5803 CALL ROTATE(PX,PY,PZ,PX3,PY3,PZ3)
5804 CALL ROTATE(PX,PY,PZ,PX4,PY4,PZ4)
5805 CALL ROTATE(PX,PY,PZ,PPX,PPY,PPZ)
5806* FIND THE MOMENTUM OF PARTICLES IN THE FINAL STATE IN THE NUCLEUS-
5807* NUCLEUS CMS. FRAME
5808* (1) for the necleon/delta
5809* LORENTZ-TRANSFORMATION INTO LAB FRAME FOR DELTA1
5810 E1CM = SQRT (dm3**2 + PX3**2 + PY3**2 + PZ3**2)
5811 P1BETA = PX3*BETAX + PY3*BETAY + PZ3*BETAZ
5812 TRANSF = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) + E1CM )
5813 Pt1i1 = BETAX * TRANSF + PX3
5814 Pt2i1 = BETAY * TRANSF + PY3
5815 Pt3i1 = BETAZ * TRANSF + PZ3
5816 Eti1 = DM3
5817 lbi1=lb(i1)
5818* (2) for the lambda/sigma
5819 E2CM = SQRT (dm4**2 + PX4**2 + PY4**2 + PZ4**2)
5820 P2BETA = PX4*BETAX+PY4*BETAY+PZ4*BETAZ
5821 TRANSF = GAMMA * (GAMMA*P2BETA / (GAMMA + 1.) + E2CM)
5822 Pt1I2 = BETAX * TRANSF + PX4
5823 Pt2I2 = BETAY * TRANSF + PY4
5824 Pt3I2 = BETAZ * TRANSF + PZ4
5825 EtI2 = DM4
5826 lbi2=lb(i2)
5827* GET the kaon'S MOMENTUM AND COORDINATES IN NUCLEUS-NUCLEUS CMS. FRAME
5828 EPCM=SQRT(aka**2+PPX**2+PPY**2+PPZ**2)
5829 PPBETA=PPX*BETAX+PPY*BETAY+PPZ*BETAZ
5830 TRANSF=GAMMA*(GAMMA*PPBETA/(GAMMA+1.)+EPCM)
5831 PPION(1,NNN,IRUN)=BETAX*TRANSF+PPX
5832 PPION(2,NNN,IRUN)=BETAY*TRANSF+PPY
5833 PPION(3,NNN,IRUN)=BETAZ*TRANSF+PPZ
5834clin-5/2008
5835 dppion(nnn,irun)=dpertp(i1)*dpertp(i2)
5836clin-5/2008
5837c2003 X01 = 1.0 - 2.0 * RANART(NSEED)
5838c Y01 = 1.0 - 2.0 * RANART(NSEED)
5839c Z01 = 1.0 - 2.0 * RANART(NSEED)
5840c IF ((X01*X01+Y01*Y01+Z01*Z01) .GT. 1.0) GOTO 2003
5841c RPION(1,NNN,IRUN)=R(1,I1)+0.5*x01
5842c RPION(2,NNN,IRUN)=R(2,I1)+0.5*y01
5843c RPION(3,NNN,IRUN)=R(3,I1)+0.5*z01
5844 RPION(1,NNN,IRUN)=R(1,I1)
5845 RPION(2,NNN,IRUN)=R(2,I1)
5846 RPION(3,NNN,IRUN)=R(3,I1)
5847c
5848* assign the nucleon/delta and lambda/sigma to i1 or i2 to keep the
5849* leadng particle behaviour
5850C if((pt1i1*px1+pt2i1*py1+pt3i1*pz1).gt.0)then
5851 p(1,i1)=pt1i1
5852 p(2,i1)=pt2i1
5853 p(3,i1)=pt3i1
5854 e(i1)=eti1
5855 lb(i1)=lbi1
5856 p(1,i2)=pt1i2
5857 p(2,i2)=pt2i2
5858 p(3,i2)=pt3i2
5859 e(i2)=eti2
5860 lb(i2)=lbi2
5861 PX1 = P(1,I1)
5862 PY1 = P(2,I1)
5863 PZ1 = P(3,I1)
5864 EM1 = E(I1)
5865 ID(I1) = 2
5866 ID(I2) = 2
5867 ID1 = ID(I1)
5868 go to 90005
5869* FOR THE NN-->Delta+Delta+rho PROCESS, FIND MOMENTUM OF THE FINAL
5870* PARTICLES IN THE NUCLEUS-NUCLEUS CMS.
5871307 CONTINUE
5872 NTRY1=0
5873125 CALL DDrho(SRT,ISEED,PX3,PY3,PZ3,DM3,PX4,PY4,PZ4,DM4,
5874 & PPX,PPY,PPZ,amrho,icou1)
5875 NTRY1=NTRY1+1
5876 if((icou1.lt.0).AND.(NTRY1.LE.20))GO TO 125
5877C if(icou1.lt.0)return
5878* ROTATE THE MOMENTA OF PARTICLES IN THE CMS OF P1+P2
5879 CALL ROTATE(PX,PY,PZ,PX3,PY3,PZ3)
5880 CALL ROTATE(PX,PY,PZ,PX4,PY4,PZ4)
5881 CALL ROTATE(PX,PY,PZ,PPX,PPY,PPZ)
5882 NNN=NNN+1
5883 arho=amrho
5884* DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
5885* (1) FOR P+P
5886 XDIR=RANART(NSEED)
5887 IF(LB(I1)*LB(I2).EQ.1)THEN
5888 IF(XDIR.Le.0.2)then
5889* (1.1)P+P-->D+++D0+rho(0)
5890 LPION(NNN,IRUN)=26
5891 EPION(NNN,IRUN)=Arho
5892 LB(I1)=9
5893 LB(I2)=7
5894 GO TO 2051
5895 ENDIF
5896* (1.2)P+P -->D++D+rho(0)
5897 IF((XDIR.LE.0.4).AND.(XDIR.GT.0.2))THEN
5898 LPION(NNN,IRUN)=26
5899 EPION(NNN,IRUN)=Arho
5900 LB(I1)=8
5901 LB(I2)=8
5902 GO TO 2051
5903 ENDIF
5904* (1.3)P+P-->D+++D+arho(-)
5905 IF((XDIR.LE.0.6).AND.(XDIR.GT.0.4))THEN
5906 LPION(NNN,IRUN)=25
5907 EPION(NNN,IRUN)=Arho
5908 LB(I1)=9
5909 LB(I2)=8
5910 GO TO 2051
5911 ENDIF
5912 IF((XDIR.LE.0.8).AND.(XDIR.GT.0.6))THEN
5913 LPION(NNN,IRUN)=27
5914 EPION(NNN,IRUN)=Arho
5915 LB(I1)=9
5916 LB(I2)=6
5917 GO TO 2051
5918 ENDIF
5919 IF(XDIR.GT.0.8)THEN
5920 LPION(NNN,IRUN)=27
5921 EPION(NNN,IRUN)=Arho
5922 LB(I1)=7
5923 LB(I2)=8
5924 GO TO 2051
5925 ENDIF
5926 ENDIF
5927* (2)FOR N+N
5928 IF(iabs(LB(I1)).EQ.2.AND.iabs(LB(I2)).EQ.2)THEN
5929 IF(XDIR.Le.0.2)then
5930* (2.1)N+N-->D++D-+rho(0)
5931 LPION(NNN,IRUN)=26
5932 EPION(NNN,IRUN)=Arho
5933 LB(I1)=6
5934 LB(I2)=7
5935 GO TO 2051
5936 ENDIF
5937* (2.2)N+N -->D+++D-+rho(-)
5938 IF((XDIR.LE.0.4).AND.(XDIR.GT.0.2))THEN
5939 LPION(NNN,IRUN)=25
5940 EPION(NNN,IRUN)=Arho
5941 LB(I1)=6
5942 LB(I2)=9
5943 GO TO 2051
5944 ENDIF
5945* (2.3)P+P-->D0+D-+rho(+)
5946 IF((XDIR.GT.0.4).AND.(XDIR.LE.0.6))THEN
5947 LPION(NNN,IRUN)=27
5948 EPION(NNN,IRUN)=Arho
5949 LB(I1)=9
5950 LB(I2)=8
5951 GO TO 2051
5952 ENDIF
5953* (2.4)P+P-->D0+D0+rho(0)
5954 IF((XDIR.GT.0.6).AND.(XDIR.LE.0.8))THEN
5955 LPION(NNN,IRUN)=26
5956 EPION(NNN,IRUN)=Arho
5957 LB(I1)=7
5958 LB(I2)=7
5959 GO TO 2051
5960 ENDIF
5961* (2.5)P+P-->D0+D++rho(-)
5962 IF(XDIR.GT.0.8)THEN
5963 LPION(NNN,IRUN)=25
5964 EPION(NNN,IRUN)=Arho
5965 LB(I1)=7
5966 LB(I2)=8
5967 GO TO 2051
5968 ENDIF
5969 ENDIF
5970* (3)FOR N+P
5971 IF(LB(I1)*LB(I2).EQ.2)THEN
5972 IF(XDIR.Le.0.17)then
5973* (3.1)N+P-->D+++D-+rho(0)
5974 LPION(NNN,IRUN)=25
5975 EPION(NNN,IRUN)=Arho
5976 LB(I1)=6
5977 LB(I2)=9
5978 GO TO 2051
5979 ENDIF
5980* (3.2)N+P -->D+++D0+rho(-)
5981 IF((XDIR.LE.0.34).AND.(XDIR.GT.0.17))THEN
5982 LPION(NNN,IRUN)=25
5983 EPION(NNN,IRUN)=Arho
5984 LB(I1)=7
5985 LB(I2)=9
5986 GO TO 2051
5987 ENDIF
5988* (3.3)N+P-->D++D-+rho(+)
5989 IF((XDIR.GT.0.34).AND.(XDIR.LE.0.51))THEN
5990 LPION(NNN,IRUN)=27
5991 EPION(NNN,IRUN)=Arho
5992 LB(I1)=7
5993 LB(I2)=8
5994 GO TO 2051
5995 ENDIF
5996* (3.4)N+P-->D++D++rho(-)
5997 IF((XDIR.GT.0.51).AND.(XDIR.LE.0.68))THEN
5998 LPION(NNN,IRUN)=25
5999 EPION(NNN,IRUN)=Arho
6000 LB(I1)=8
6001 LB(I2)=8
6002 GO TO 2051
6003 ENDIF
6004* (3.5)N+P-->D0+D++rho(0)
6005 IF((XDIR.GT.0.68).AND.(XDIR.LE.0.85))THEN
6006 LPION(NNN,IRUN)=26
6007 EPION(NNN,IRUN)=Arho
6008 LB(I1)=7
6009 LB(I2)=8
6010 GO TO 2051
6011 ENDIF
6012* (3.6)N+P-->D0+D0+rho(+)
6013 IF(XDIR.GT.0.85)THEN
6014 LPION(NNN,IRUN)=27
6015 EPION(NNN,IRUN)=Arho
6016 LB(I1)=7
6017 LB(I2)=7
6018 ENDIF
6019 ENDIF
6020* FIND THE MOMENTUM OF PARTICLES IN THE FINAL STATE IN THE NUCLEUS-
6021* NUCLEUS CMS. FRAME
6022* LORENTZ-TRANSFORMATION INTO LAB FRAME FOR DELTA1
60232051 E1CM = SQRT (dm3**2 + PX3**2 + PY3**2 + PZ3**2)
6024 P1BETA = PX3*BETAX + PY3*BETAY + PZ3*BETAZ
6025 TRANSF = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) + E1CM )
6026 Pt1i1 = BETAX * TRANSF + PX3
6027 Pt2i1 = BETAY * TRANSF + PY3
6028 Pt3i1 = BETAZ * TRANSF + PZ3
6029 Eti1 = DM3
6030c
6031 if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
6032 lb(i1) = -lb(i1)
6033 lb(i2) = -lb(i2)
6034 if(LPION(NNN,IRUN) .eq. 25)then
6035 LPION(NNN,IRUN)=27
6036 elseif(LPION(NNN,IRUN) .eq. 27)then
6037 LPION(NNN,IRUN)=25
6038 endif
6039 endif
6040c
6041 lb1=lb(i1)
6042* FOR DELTA2
6043 E2CM = SQRT (dm4**2 + PX4**2 + PY4**2 + PZ4**2)
6044 P2BETA = PX4*BETAX+PY4*BETAY+PZ4*BETAZ
6045 TRANSF = GAMMA * (GAMMA*P2BETA / (GAMMA + 1.) + E2CM)
6046 Pt1I2 = BETAX * TRANSF + PX4
6047 Pt2I2 = BETAY * TRANSF + PY4
6048 Pt3I2 = BETAZ * TRANSF + PZ4
6049 EtI2 = DM4
6050 lb2=lb(i2)
6051* assign delta1 and delta2 to i1 or i2 to keep the leadng particle
6052* behaviour
6053C if((pt1i1*px1+pt2i1*py1+pt3i1*pz1).gt.0)then
6054 p(1,i1)=pt1i1
6055 p(2,i1)=pt2i1
6056 p(3,i1)=pt3i1
6057 e(i1)=eti1
6058 lb(i1)=lb1
6059 p(1,i2)=pt1i2
6060 p(2,i2)=pt2i2
6061 p(3,i2)=pt3i2
6062 e(i2)=eti2
6063 lb(i2)=lb2
6064 PX1 = P(1,I1)
6065 PY1 = P(2,I1)
6066 PZ1 = P(3,I1)
6067 EM1 = E(I1)
6068 ID(I1) = 2
6069 ID(I2) = 2
6070 ID1 = ID(I1)
6071 IBLOCK=44
6072* GET rho'S MOMENTUM AND COORDINATES IN NUCLEUS-NUCLEUS CMS. FRAME
6073 EPCM=SQRT(EPION(NNN,IRUN)**2+PPX**2+PPY**2+PPZ**2)
6074 PPBETA=PPX*BETAX+PPY*BETAY+PPZ*BETAZ
6075 TRANSF=GAMMA*(GAMMA*PPBETA/(GAMMA+1.)+EPCM)
6076 PPION(1,NNN,IRUN)=BETAX*TRANSF+PPX
6077 PPION(2,NNN,IRUN)=BETAY*TRANSF+PPY
6078 PPION(3,NNN,IRUN)=BETAZ*TRANSF+PPZ
6079clin-5/2008:
6080 dppion(nnn,irun)=dpertp(i1)*dpertp(i2)
6081clin-5/2008:
6082c2004 X01 = 1.0 - 2.0 * RANART(NSEED)
6083c Y01 = 1.0 - 2.0 * RANART(NSEED)
6084c Z01 = 1.0 - 2.0 * RANART(NSEED)
6085c IF ((X01*X01+Y01*Y01+Z01*Z01) .GT. 1.0) GOTO 2004
6086c RPION(1,NNN,IRUN)=R(1,I1)+0.5*x01
6087c RPION(2,NNN,IRUN)=R(2,I1)+0.5*y01
6088c RPION(3,NNN,IRUN)=R(3,I1)+0.5*z01
6089 RPION(1,NNN,IRUN)=R(1,I1)
6090 RPION(2,NNN,IRUN)=R(2,I1)
6091 RPION(3,NNN,IRUN)=R(3,I1)
6092c
6093 go to 90005
6094* FOR THE NN-->N+N+rho PROCESS, FIND MOMENTUM OF THE FINAL
6095* PARTICLES IN THE NUCLEUS-NUCLEUS CMS.
6096308 CONTINUE
6097 NTRY1=0
6098126 CALL pprho(SRT,ISEED,PX3,PY3,PZ3,DM3,PX4,PY4,PZ4,DM4,
6099 & PPX,PPY,PPZ,amrho,icou1)
6100 NTRY1=NTRY1+1
6101 if((icou1.lt.0).AND.(NTRY1.LE.20))GO TO 126
6102C if(icou1.lt.0)return
6103* ROTATE THE MOMENTA OF PARTICLES IN THE CMS OF P1+P2
6104 CALL ROTATE(PX,PY,PZ,PX3,PY3,PZ3)
6105 CALL ROTATE(PX,PY,PZ,PX4,PY4,PZ4)
6106 CALL ROTATE(PX,PY,PZ,PPX,PPY,PPZ)
6107 NNN=NNN+1
6108 arho=amrho
6109* DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
6110* (1) FOR P+P
6111 XDIR=RANART(NSEED)
6112 IF(LB(I1)*LB(I2).EQ.1)THEN
6113 IF(XDIR.Le.0.5)then
6114* (1.1)P+P-->P+P+rho(0)
6115 LPION(NNN,IRUN)=26
6116 EPION(NNN,IRUN)=Arho
6117 LB(I1)=1
6118 LB(I2)=1
6119 GO TO 2052
6120 Else
6121* (1.2)P+P -->p+n+rho(+)
6122 LPION(NNN,IRUN)=27
6123 EPION(NNN,IRUN)=Arho
6124 LB(I1)=1
6125 LB(I2)=2
6126 GO TO 2052
6127 ENDIF
6128 endif
6129* (2)FOR N+N
6130 IF(iabs(LB(I1)).EQ.2.AND.iabs(LB(I2)).EQ.2)THEN
6131 IF(XDIR.Le.0.5)then
6132* (2.1)N+N-->N+N+rho(0)
6133 LPION(NNN,IRUN)=26
6134 EPION(NNN,IRUN)=Arho
6135 LB(I1)=2
6136 LB(I2)=2
6137 GO TO 2052
6138 Else
6139* (2.2)N+N -->N+P+rho(-)
6140 LPION(NNN,IRUN)=25
6141 EPION(NNN,IRUN)=Arho
6142 LB(I1)=1
6143 LB(I2)=2
6144 GO TO 2052
6145 ENDIF
6146 endif
6147* (3)FOR N+P
6148 IF(LB(I1)*LB(I2).EQ.2)THEN
6149 IF(XDIR.Le.0.33)then
6150* (3.1)N+P-->N+P+rho(0)
6151 LPION(NNN,IRUN)=26
6152 EPION(NNN,IRUN)=Arho
6153 LB(I1)=1
6154 LB(I2)=2
6155 GO TO 2052
6156* (3.2)N+P -->P+P+rho(-)
6157 else IF((XDIR.LE.0.67).AND.(XDIR.GT.0.34))THEN
6158 LPION(NNN,IRUN)=25
6159 EPION(NNN,IRUN)=Arho
6160 LB(I1)=1
6161 LB(I2)=1
6162 GO TO 2052
6163 Else
6164* (3.3)N+P-->N+N+rho(+)
6165 LPION(NNN,IRUN)=27
6166 EPION(NNN,IRUN)=Arho
6167 LB(I1)=2
6168 LB(I2)=2
6169 GO TO 2052
6170 ENDIF
6171 endif
6172* FIND THE MOMENTUM OF PARTICLES IN THE FINAL STATE IN THE NUCLEUS-
6173* NUCLEUS CMS. FRAME
6174* LORENTZ-TRANSFORMATION INTO LAB FRAME FOR DELTA1
61752052 E1CM = SQRT (dm3**2 + PX3**2 + PY3**2 + PZ3**2)
6176 P1BETA = PX3*BETAX + PY3*BETAY + PZ3*BETAZ
6177 TRANSF = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) + E1CM )
6178 Pt1i1 = BETAX * TRANSF + PX3
6179 Pt2i1 = BETAY * TRANSF + PY3
6180 Pt3i1 = BETAZ * TRANSF + PZ3
6181 Eti1 = DM3
6182c
6183 if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
6184 lb(i1) = -lb(i1)
6185 lb(i2) = -lb(i2)
6186 if(LPION(NNN,IRUN) .eq. 25)then
6187 LPION(NNN,IRUN)=27
6188 elseif(LPION(NNN,IRUN) .eq. 27)then
6189 LPION(NNN,IRUN)=25
6190 endif
6191 endif
6192c
6193 lb1=lb(i1)
6194* FOR p2
6195 E2CM = SQRT (dm4**2 + PX4**2 + PY4**2 + PZ4**2)
6196 P2BETA = PX4*BETAX+PY4*BETAY+PZ4*BETAZ
6197 TRANSF = GAMMA * (GAMMA*P2BETA / (GAMMA + 1.) + E2CM)
6198 Pt1I2 = BETAX * TRANSF + PX4
6199 Pt2I2 = BETAY * TRANSF + PY4
6200 Pt3I2 = BETAZ * TRANSF + PZ4
6201 EtI2 = DM4
6202 lb2=lb(i2)
6203* assign p1 and p2 to i1 or i2 to keep the leadng particle
6204* behaviour
6205C if((pt1i1*px1+pt2i1*py1+pt3i1*pz1).gt.0)then
6206 p(1,i1)=pt1i1
6207 p(2,i1)=pt2i1
6208 p(3,i1)=pt3i1
6209 e(i1)=eti1
6210 lb(i1)=lb1
6211 p(1,i2)=pt1i2
6212 p(2,i2)=pt2i2
6213 p(3,i2)=pt3i2
6214 e(i2)=eti2
6215 lb(i2)=lb2
6216 PX1 = P(1,I1)
6217 PY1 = P(2,I1)
6218 PZ1 = P(3,I1)
6219 EM1 = E(I1)
6220 ID(I1) = 2
6221 ID(I2) = 2
6222 ID1 = ID(I1)
6223 IBLOCK=45
6224* GET rho'S MOMENTUM AND COORDINATES IN NUCLEUS-NUCLEUS CMS. FRAME
6225 EPCM=SQRT(EPION(NNN,IRUN)**2+PPX**2+PPY**2+PPZ**2)
6226 PPBETA=PPX*BETAX+PPY*BETAY+PPZ*BETAZ
6227 TRANSF=GAMMA*(GAMMA*PPBETA/(GAMMA+1.)+EPCM)
6228 PPION(1,NNN,IRUN)=BETAX*TRANSF+PPX
6229 PPION(2,NNN,IRUN)=BETAY*TRANSF+PPY
6230 PPION(3,NNN,IRUN)=BETAZ*TRANSF+PPZ
6231clin-5/2008:
6232 dppion(nnn,irun)=dpertp(i1)*dpertp(i2)
6233clin-5/2008:
6234c2005 X01 = 1.0 - 2.0 * RANART(NSEED)
6235c Y01 = 1.0 - 2.0 * RANART(NSEED)
6236c Z01 = 1.0 - 2.0 * RANART(NSEED)
6237c IF ((X01*X01+Y01*Y01+Z01*Z01) .GT. 1.0) GOTO 2005
6238c RPION(1,NNN,IRUN)=R(1,I1)+0.5*x01
6239c RPION(2,NNN,IRUN)=R(2,I1)+0.5*y01
6240c RPION(3,NNN,IRUN)=R(3,I1)+0.5*z01
6241 RPION(1,NNN,IRUN)=R(1,I1)
6242 RPION(2,NNN,IRUN)=R(2,I1)
6243 RPION(3,NNN,IRUN)=R(3,I1)
6244c
6245 go to 90005
6246* FOR THE NN-->p+p+omega PROCESS, FIND MOMENTUM OF THE FINAL
6247* PARTICLES IN THE NUCLEUS-NUCLEUS CMS.
6248309 CONTINUE
6249 NTRY1=0
6250138 CALL ppomga(SRT,ISEED,PX3,PY3,PZ3,DM3,PX4,PY4,PZ4,DM4,
6251 & PPX,PPY,PPZ,icou1)
6252 NTRY1=NTRY1+1
6253 if((icou1.lt.0).AND.(NTRY1.LE.20))GO TO 138
6254C if(icou1.lt.0)return
6255* ROTATE THE MOMENTA OF PARTICLES IN THE CMS OF P1+P2
6256 CALL ROTATE(PX,PY,PZ,PX3,PY3,PZ3)
6257 CALL ROTATE(PX,PY,PZ,PX4,PY4,PZ4)
6258 CALL ROTATE(PX,PY,PZ,PPX,PPY,PPZ)
6259 NNN=NNN+1
6260 aomega=0.782
6261* DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
6262* (1) FOR P+P
6263 IF(LB(I1)*LB(I2).EQ.1)THEN
6264* (1.1)P+P-->P+P+omega(0)
6265 LPION(NNN,IRUN)=28
6266 EPION(NNN,IRUN)=Aomega
6267 LB(I1)=1
6268 LB(I2)=1
6269 GO TO 2053
6270 ENDIF
6271* (2)FOR N+N
6272 IF(iabs(LB(I1)).EQ.2.AND.iabs(LB(I2)).EQ.2)THEN
6273* (2.1)N+N-->N+N+omega(0)
6274 LPION(NNN,IRUN)=28
6275 EPION(NNN,IRUN)=Aomega
6276 LB(I1)=2
6277 LB(I2)=2
6278 GO TO 2053
6279 ENDIF
6280* (3)FOR N+P
6281 IF(LB(I1)*LB(I2).EQ.2)THEN
6282* (3.1)N+P-->N+P+omega(0)
6283 LPION(NNN,IRUN)=28
6284 EPION(NNN,IRUN)=Aomega
6285 LB(I1)=1
6286 LB(I2)=2
6287 GO TO 2053
6288 ENDIF
6289* FIND THE MOMENTUM OF PARTICLES IN THE FINAL STATE IN THE NUCLEUS-
6290* NUCLEUS CMS. FRAME
6291* LORENTZ-TRANSFORMATION INTO LAB FRAME FOR DELTA1
62922053 E1CM = SQRT (dm3**2 + PX3**2 + PY3**2 + PZ3**2)
6293 P1BETA = PX3*BETAX + PY3*BETAY + PZ3*BETAZ
6294 TRANSF = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) + E1CM )
6295 Pt1i1 = BETAX * TRANSF + PX3
6296 Pt2i1 = BETAY * TRANSF + PY3
6297 Pt3i1 = BETAZ * TRANSF + PZ3
6298 Eti1 = DM3
6299 if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
6300 lb(i1) = -lb(i1)
6301 lb(i2) = -lb(i2)
6302 endif
6303 lb1=lb(i1)
6304* FOR DELTA2
6305 E2CM = SQRT (dm4**2 + PX4**2 + PY4**2 + PZ4**2)
6306 P2BETA = PX4*BETAX+PY4*BETAY+PZ4*BETAZ
6307 TRANSF = GAMMA * (GAMMA*P2BETA / (GAMMA + 1.) + E2CM)
6308 Pt1I2 = BETAX * TRANSF + PX4
6309 Pt2I2 = BETAY * TRANSF + PY4
6310 Pt3I2 = BETAZ * TRANSF + PZ4
6311 EtI2 = DM4
6312 lb2=lb(i2)
6313* assign delta1 and delta2 to i1 or i2 to keep the leadng particle
6314* behaviour
6315C if((pt1i1*px1+pt2i1*py1+pt3i1*pz1).gt.0)then
6316 p(1,i1)=pt1i1
6317 p(2,i1)=pt2i1
6318 p(3,i1)=pt3i1
6319 e(i1)=eti1
6320 lb(i1)=lb1
6321 p(1,i2)=pt1i2
6322 p(2,i2)=pt2i2
6323 p(3,i2)=pt3i2
6324 e(i2)=eti2
6325 lb(i2)=lb2
6326 PX1 = P(1,I1)
6327 PY1 = P(2,I1)
6328 PZ1 = P(3,I1)
6329 EM1 = E(I1)
6330 ID(I1) = 2
6331 ID(I2) = 2
6332 ID1 = ID(I1)
6333 IBLOCK=46
6334* GET omega'S MOMENTUM AND COORDINATES IN NUCLEUS-NUCLEUS CMS. FRAME
6335 EPCM=SQRT(EPION(NNN,IRUN)**2+PPX**2+PPY**2+PPZ**2)
6336 PPBETA=PPX*BETAX+PPY*BETAY+PPZ*BETAZ
6337 TRANSF=GAMMA*(GAMMA*PPBETA/(GAMMA+1.)+EPCM)
6338 PPION(1,NNN,IRUN)=BETAX*TRANSF+PPX
6339 PPION(2,NNN,IRUN)=BETAY*TRANSF+PPY
6340 PPION(3,NNN,IRUN)=BETAZ*TRANSF+PPZ
6341clin-5/2008:
6342 dppion(nnn,irun)=dpertp(i1)*dpertp(i2)
6343clin-5/2008:
6344c2006 X01 = 1.0 - 2.0 * RANART(NSEED)
6345c Y01 = 1.0 - 2.0 * RANART(NSEED)
6346c Z01 = 1.0 - 2.0 * RANART(NSEED)
6347c IF ((X01*X01+Y01*Y01+Z01*Z01) .GT. 1.0) GOTO 2006
6348c RPION(1,NNN,IRUN)=R(1,I1)+0.5*x01
6349c RPION(2,NNN,IRUN)=R(2,I1)+0.5*y01
6350c RPION(3,NNN,IRUN)=R(3,I1)+0.5*z01
6351 RPION(1,NNN,IRUN)=R(1,I1)
6352 RPION(2,NNN,IRUN)=R(2,I1)
6353 RPION(3,NNN,IRUN)=R(3,I1)
6354c
6355 go to 90005
6356* change phase space density FOR NUCLEONS AFTER THE PROCESS
6357
6358clin-10/25/02-comment out following, since there is no path to it:
6359clin-8/16/02 used before set
6360c IX1,IY1,IZ1,IPX1,IPY1,IPZ1, IX2,IY2,IZ2,IPX2,IPY2,IPZ2:
6361c if ((abs(ix1).le.mx) .and. (abs(iy1).le.my) .and.
6362c & (abs(iz1).le.mz)) then
6363c ipx1p = nint(p(1,i1)/dpx)
6364c ipy1p = nint(p(2,i1)/dpy)
6365c ipz1p = nint(p(3,i1)/dpz)
6366c if ((ipx1p.ne.ipx1) .or. (ipy1p.ne.ipy1) .or.
6367c & (ipz1p.ne.ipz1)) then
6368c if ((abs(ipx1).le.mpx) .and. (abs(ipy1).le.my)
6369c & .and. (ipz1.ge.-mpz) .and. (ipz1.le.mpzp))
6370c & f(ix1,iy1,iz1,ipx1,ipy1,ipz1) =
6371c & f(ix1,iy1,iz1,ipx1,ipy1,ipz1) - 1.
6372c if ((abs(ipx1p).le.mpx) .and. (abs(ipy1p).le.my)
6373c & .and. (ipz1p.ge.-mpz).and. (ipz1p.le.mpzp))
6374c & f(ix1,iy1,iz1,ipx1p,ipy1p,ipz1p) =
6375c & f(ix1,iy1,iz1,ipx1p,ipy1p,ipz1p) + 1.
6376c end if
6377c end if
6378c if ((abs(ix2).le.mx) .and. (abs(iy2).le.my) .and.
6379c & (abs(iz2).le.mz)) then
6380c ipx2p = nint(p(1,i2)/dpx)
6381c ipy2p = nint(p(2,i2)/dpy)
6382c ipz2p = nint(p(3,i2)/dpz)
6383c if ((ipx2p.ne.ipx2) .or. (ipy2p.ne.ipy2) .or.
6384c & (ipz2p.ne.ipz2)) then
6385c if ((abs(ipx2).le.mpx) .and. (abs(ipy2).le.my)
6386c & .and. (ipz2.ge.-mpz) .and. (ipz2.le.mpzp))
6387c & f(ix2,iy2,iz2,ipx2,ipy2,ipz2) =
6388c & f(ix2,iy2,iz2,ipx2,ipy2,ipz2) - 1.
6389c if ((abs(ipx2p).le.mpx) .and. (abs(ipy2p).le.my)
6390c & .and. (ipz2p.ge.-mpz) .and. (ipz2p.le.mpzp))
6391c & f(ix2,iy2,iz2,ipx2p,ipy2p,ipz2p) =
6392c & f(ix2,iy2,iz2,ipx2p,ipy2p,ipz2p) + 1.
6393c end if
6394c end if
6395clin-10/25/02-end
6396
639790005 continue
6398 RETURN
6399*-----------------------------------------------------------------------
6400*COM: SET THE NEW MOMENTUM COORDINATES
6401107 IF(PX .EQ. 0.0 .AND. PY .EQ. 0.0) THEN
6402 T2 = 0.0
6403 ELSE
6404 T2=ATAN2(PY,PX)
6405 END IF
6406 S1 = 1.0 - C1**2
6407 IF(S1.LE.0)S1=0
6408 S1=SQRT(S1)
6409 S2 = SQRT( 1.0 - C2**2 )
6410 CT1 = COS(T1)
6411 ST1 = SIN(T1)
6412 CT2 = COS(T2)
6413 ST2 = SIN(T2)
6414 PZ = PR * ( C1*C2 - S1*S2*CT1 )
6415 SS = C2 * S1 * CT1 + S2 * C1
6416 PX = PR * ( SS*CT2 - S1*ST1*ST2 )
6417 PY = PR * ( SS*ST2 + S1*ST1*CT2 )
6418 RETURN
6419 END
6420clin-5/2008 CRNN over
6421
6422**********************************
6423**********************************
6424* *
6425* *
6426c
6427 SUBROUTINE CRPP(PX,PY,PZ,SRT,I1,I2,IBLOCK,
6428 &ppel,ppin,spprho,ipp)
6429* PURPOSE: *
6430* DEALING WITH PION-PION COLLISIONS *
6431* NOTE : *
6432* VALID ONLY FOR PION-PION-DISTANCES LESS THAN 2.5 FM *
6433* QUANTITIES: *
6434* PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
6435* SRT - SQRT OF S *
6436* IBLOCK - THE INFORMATION BACK *
6437* 6-> Meson+Meson elastic
6438* 66-> Meson+meson-->K+K-
6439**********************************
6440 PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
6441 1 AMP=0.93828,AP1=0.13496,
6442 2 AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
6443 PARAMETER (AKA=0.498,aks=0.895)
6444 parameter (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
6445 COMMON /AA/ R(3,MAXSTR)
6446cc SAVE /AA/
6447 COMMON /BB/ P(3,MAXSTR)
6448cc SAVE /BB/
6449 COMMON /CC/ E(MAXSTR)
6450cc SAVE /CC/
6451 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
6452cc SAVE /EE/
6453 common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
6454cc SAVE /input1/
6455 common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
6456cc SAVE /ppb1/
6457 common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
6458cc SAVE /ppmm/
6459 COMMON/RNDF77/NSEED
6460cc SAVE /RNDF77/
6461 SAVE
6462
6463 lb1i=lb(i1)
6464 lb2i=lb(i2)
6465
6466 PX0=PX
6467 PY0=PY
6468 PZ0=PZ
6469 iblock=1
6470*-----------------------------------------------------------------------
6471* check Meson+Meson inelastic collisions
6472clin-9/28/00
6473c if((srt.gt.1.).and.(ppin/(ppin+ppel).gt.RANART(NSEED)))then
6474c iblock=66
6475c e(i1)=0.498
6476c e(i2)=0.498
6477c lb(i1)=21
6478c lb(i2)=23
6479c go to 10
6480clin-11/07/00
6481c if(srt.gt.1.and.(ppin/(ppin+ppel)).gt.RANART(NSEED)) then
6482clin-4/03/02
6483 if(srt.gt.(2*aka).and.(ppin/(ppin+ppel)).gt.RANART(NSEED)) then
6484c if(ppin/(ppin+ppel).gt.RANART(NSEED)) then
6485clin-10/08/00
6486
6487 ranpi=RANART(NSEED)
6488 if((pprr/ppin).ge.ranpi) then
6489
6490c 1) pi pi <-> rho rho:
6491 call pi2ro2(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
6492
6493clin-4/03/02 eta equilibration:
6494 elseif((pprr+ppee)/ppin.ge.ranpi) then
6495c 4) pi pi <-> eta eta:
6496 call pi2et2(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
6497 elseif(((pprr+ppee+pppe)/ppin).ge.ranpi) then
6498c 5) pi pi <-> pi eta:
6499 call pi3eta(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
6500 elseif(((pprr+ppee+pppe+rpre)/ppin).ge.ranpi) then
6501c 6) rho pi <-> pi eta:
6502 call rpiret(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
6503 elseif(((pprr+ppee+pppe+rpre+xopoe)/ppin).ge.ranpi) then
6504c 7) omega pi <-> omega eta:
6505 call opioet(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
6506 elseif(((pprr+ppee+pppe+rpre+xopoe+rree)
6507 1 /ppin).ge.ranpi) then
6508c 8) rho rho <-> eta eta:
6509 call ro2et2(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
6510clin-4/03/02-end
6511
6512c 2) BBbar production:
6513 elseif(((pprr+ppee+pppe+rpre+xopoe+rree+ppinnb)/ppin)
6514 1 .ge.ranpi) then
6515
6516 call bbarfs(lbb1,lbb2,ei1,ei2,iblock,iseed)
6517c 3) KKbar production:
6518 else
6519 iblock=66
6520 ei1=aka
6521 ei2=aka
6522 lbb1=21
6523 lbb2=23
6524clin-11/07/00 pi rho -> K* Kbar and K*bar K productions:
6525 lb1=lb(i1)
6526 lb2=lb(i2)
6527clin-2/13/03 include omega the same as rho, eta the same as pi:
6528c if(((lb1.ge.3.and.lb1.le.5).and.(lb2.ge.25.and.lb2.le.27))
6529c 1 .or.((lb2.ge.3.and.lb2.le.5).and.(lb1.ge.25.and.lb1.le.27)))
6530 if( ( (lb1.eq.0.or.(lb1.ge.3.and.lb1.le.5))
6531 1 .and.(lb2.ge.25.and.lb2.le.28))
6532 2 .or. ( (lb2.eq.0.or.(lb2.ge.3.and.lb2.le.5))
6533 3 .and.(lb1.ge.25.and.lb1.le.28))) then
6534 ei1=aks
6535 ei2=aka
6536 if(RANART(NSEED).ge.0.5) then
6537 iblock=366
6538 lbb1=30
6539 lbb2=21
6540 else
6541 iblock=367
6542 lbb1=-30
6543 lbb2=23
6544 endif
6545 endif
6546clin-11/07/00-end
6547 endif
6548clin-ppbar-8/25/00
6549 e(i1)=ei1
6550 e(i2)=ei2
6551 lb(i1)=lbb1
6552 lb(i2)=lbb2
6553clin-10/08/00-end
6554
6555 else
6556cbzdbg10/15/99
6557c.....for meson+meson elastic srt.le.2Mk, if not pi+pi collision return
6558 if ((lb(i1).lt.3.or.lb(i1).gt.5).and.
6559 & (lb(i2).lt.3.or.lb(i2).gt.5)) return
6560cbzdbg10/15/99 end
6561
6562* check Meson+Meson elastic collisions
6563 IBLOCK=6
6564* direct process
6565 if(ipp.eq.1.or.ipp.eq.4.or.ipp.eq.6)go to 10
6566 if(spprho/ppel.gt.RANART(NSEED))go to 20
6567 endif
656810 NTAG=0
6569 EM1=E(I1)
6570 EM2=E(I2)
6571
6572*-----------------------------------------------------------------------
6573* CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
6574* ENERGY CONSERVATION
6575 PR2 = (SRT**2 - EM1**2 - EM2**2)**2
6576 1 - 4.0 * (EM1*EM2)**2
6577 IF(PR2.LE.0.)PR2=1.e-09
6578 PR=SQRT(PR2)/(2.*SRT)
6579 C1 = 1.0 - 2.0 * RANART(NSEED)
6580 T1 = 2.0 * PI * RANART(NSEED)
6581 S1 = SQRT( 1.0 - C1**2 )
6582 CT1 = COS(T1)
6583 ST1 = SIN(T1)
6584 PZ = PR * C1
6585 PX = PR * S1*CT1
6586 PY = PR * S1*ST1
6587* for isotropic distribution no need to ROTATE THE MOMENTUM
6588
6589* ROTATE IT
6590 CALL ROTATE(PX0,PY0,PZ0,PX,PY,PZ)
6591
6592 RETURN
659320 continue
6594 iblock=666
6595* treat rho formation in pion+pion collisions
6596* calculate the mass and momentum of rho in the nucleus-nucleus frame
6597 call rhores(i1,i2)
6598 if(ipp.eq.2)lb(i1)=27
6599 if(ipp.eq.3)lb(i1)=26
6600 if(ipp.eq.5)lb(i1)=25
6601 return
6602 END
6603**********************************
6604**********************************
6605* *
6606* *
6607 SUBROUTINE CRND(IRUN,PX,PY,PZ,SRT,I1,I2,IBLOCK,
6608 &SIGNN,SIG,sigk,xsk1,xsk2,xsk3,xsk4,xsk5,NT,ipert1)
6609* PURPOSE: *
6610* DEALING WITH NUCLEON-BARYON RESONANCE COLLISIONS *
6611* NOTE : *
6612* VALID ONLY FOR BARYON-BARYON-DISTANCES LESS THAN 1.32 FM *
6613* (1.32 = 2 * HARD-CORE-RADIUS [HRC] ) *
6614* QUANTITIES: *
6615* PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
6616* SRT - SQRT OF S *
6617* NSTAR =1 INCLUDING N* RESORANCE,ELSE NOT *
6618* NDIRCT=1 INCLUDING DIRECT PION PRODUCTION PROCESS *
6619* IBLOCK - THE INFORMATION BACK *
6620* 0-> COLLISION CANNOT HAPPEN *
6621* 1-> N-N ELASTIC COLLISION *
6622* 2-> N+N->N+DELTA,OR N+N->N+N* REACTION *
6623* 3-> N+DELTA->N+N OR N+N*->N+N REACTION *
6624* 4-> N+N->N+N+PION,DIRTCT PROCESS *
6625* N12 - IS USED TO SPECIFY BARYON-BARYON REACTION *
6626* CHANNELS. M12 IS THE REVERSAL CHANNEL OF N12 *
6627* N12, *
6628* M12=1 FOR p+n-->delta(+)+ n *
6629* 2 p+n-->delta(0)+ p *
6630* 3 p+p-->delta(++)+n *
6631* 4 p+p-->delta(+)+p *
6632* 5 n+n-->delta(0)+n *
6633* 6 n+n-->delta(-)+p *
6634* 7 n+p-->N*(0)(1440)+p *
6635* 8 n+p-->N*(+)(1440)+n *
6636* 9 p+p-->N*(+)(1535)+p *
6637* 10 n+n-->N*(0)(1535)+n *
6638* 11 n+p-->N*(+)(1535)+n *
6639* 12 n+p-->N*(0)(1535)+p
6640* 13 D(++)+D(-)-->N*(+)(1440)+n
6641* 14 D(++)+D(-)-->N*(0)(1440)+p
6642* 15 D(+)+D(0)--->N*(+)(1440)+n
6643* 16 D(+)+D(0)--->N*(0)(1440)+p
6644* 17 D(++)+D(0)-->N*(+)(1535)+p
6645* 18 D(++)+D(-)-->N*(0)(1535)+p
6646* 19 D(++)+D(-)-->N*(+)(1535)+n
6647* 20 D(+)+D(+)-->N*(+)(1535)+p
6648* 21 D(+)+D(0)-->N*(+)(1535)+n
6649* 22 D(+)+D(0)-->N*(0)(1535)+p
6650* 23 D(+)+D(-)-->N*(0)(1535)+n
6651* 24 D(0)+D(0)-->N*(0)(1535)+n
6652* 25 N*(+)(14)+N*(+)(14)-->N*(+)(15)+p
6653* 26 N*(0)(14)+N*(0)(14)-->N*(0)(15)+n
6654* 27 N*(+)(14)+N*(0)(14)-->N*(+)(15)+n
6655* 28 N*(+)(14)+N*(0)(14)-->N*(0)(15)+p
6656* 29 N*(+)(14)+D+-->N*(+)(15)+p
6657* 30 N*(+)(14)+D0-->N*(+)(15)+n
6658* 31 N*(+)(14)+D(-)-->N*(0)(1535)+n
6659* 32 N*(0)(14)+D++--->N*(+)(15)+p
6660* 33 N*(0)(14)+D+--->N*(+)(15)+n
6661* 34 N*(0)(14)+D+--->N*(0)(15)+p
6662* 35 N*(0)(14)+D0-->N*(0)(15)+n
6663* 36 N*(+)(14)+D0--->N*(0)(15)+p
6664* ++ see the note book for more listing
6665**********************************
6666 PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
6667 1 AMP=0.93828,AP1=0.13496,AKA=0.498,APHI=1.020,
6668 2 AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
6669 parameter (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
6670 parameter (xmd=1.8756,npdmax=10000)
6671 COMMON /AA/ R(3,MAXSTR)
6672cc SAVE /AA/
6673 COMMON /BB/ P(3,MAXSTR)
6674cc SAVE /BB/
6675 COMMON /CC/ E(MAXSTR)
6676cc SAVE /CC/
6677 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
6678cc SAVE /EE/
6679 common /ff/f(-mx:mx,-my:my,-mz:mz,-mpx:mpx,-mpy:mpy,-mpz:mpzp)
6680cc SAVE /ff/
6681 common /gg/ dx,dy,dz,dpx,dpy,dpz
6682cc SAVE /gg/
6683 COMMON /INPUT/ NSTAR,NDIRCT,DIR
6684cc SAVE /INPUT/
6685 COMMON /NN/NNN
6686cc SAVE /NN/
6687 COMMON /BG/BETAX,BETAY,BETAZ,GAMMA
6688cc SAVE /BG/
6689 COMMON /RUN/NUM
6690cc SAVE /RUN/
6691 COMMON /PA/RPION(3,MAXSTR,MAXR)
6692cc SAVE /PA/
6693 COMMON /PB/PPION(3,MAXSTR,MAXR)
6694cc SAVE /PB/
6695 COMMON /PC/EPION(MAXSTR,MAXR)
6696cc SAVE /PC/
6697 COMMON /PD/LPION(MAXSTR,MAXR)
6698cc SAVE /PD/
6699 common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
6700cc SAVE /input1/
6701 common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
6702 1 px1n,py1n,pz1n,dp1n
6703cc SAVE /leadng/
6704 COMMON/RNDF77/NSEED
6705cc SAVE /RNDF77/
6706 COMMON /dpert/dpertt(MAXSTR,MAXR),dpertp(MAXSTR),dplast(MAXSTR),
6707 1 dpdcy(MAXSTR),dpdpi(MAXSTR,MAXR),dpt(MAXSTR, MAXR),
6708 2 dpp1(MAXSTR,MAXR),dppion(MAXSTR,MAXR)
6709 common /dpi/em2,lb2
6710 common /para8/ idpert,npertd,idxsec
6711 dimension ppd(3,npdmax),lbpd(npdmax)
6712 SAVE
6713*-----------------------------------------------------------------------
6714 n12=0
6715 m12=0
6716 IBLOCK=0
6717 NTAG=0
6718 EM1=E(I1)
6719 EM2=E(I2)
6720 PR = SQRT( PX**2 + PY**2 + PZ**2 )
6721 C2 = PZ / PR
6722 X1 = RANART(NSEED)
6723 ianti=0
6724 if(lb(i1).lt.0 .and. lb(i2).lt.0)ianti=1
6725
6726clin-6/2008 Production of perturbative deuterons for idpert=1:
6727 call sbbdm(srt,sdprod,ianti,lbm,xmm,pfinal)
6728 if(idpert.eq.1.and.ipert1.eq.1) then
6729 IF (SRT .LT. 2.012) RETURN
6730 if((iabs(lb(i1)).eq.1.or.iabs(lb(i1)).eq.2)
6731 1 .and.(iabs(lb(i2)).ge.6.and.iabs(lb(i2)).le.13)) then
6732 goto 108
6733 elseif((iabs(lb(i2)).eq.1.or.iabs(lb(i2)).eq.2)
6734 1 .and.(iabs(lb(i1)).ge.6.and.iabs(lb(i1)).le.13)) then
6735 goto 108
6736 else
6737 return
6738 endif
6739 endif
6740*-----------------------------------------------------------------------
6741*COM: TEST FOR ELASTIC SCATTERING (EITHER N-N OR DELTA-DELTA 0R
6742* N-DELTA OR N*-N* or N*-Delta)
6743 IF (X1 .LE. SIGNN/SIG) THEN
6744*COM: PARAMETRISATION IS TAKEN FROM THE CUGNON-PAPER
6745 AS = ( 3.65 * (SRT - 1.8766) )**6
6746 A = 6.0 * AS / (1.0 + AS)
6747 TA = -2.0 * PR**2
6748 X = RANART(NSEED)
6749clin-10/24/02 T1 = ALOG( (1-X) * DEXP(dble(A)*dble(TA)) + X ) / A
6750 T1 = sngl(DLOG(dble(1.-X)*DEXP(dble(A)*dble(TA))+dble(X)))/ A
6751 C1 = 1.0 - T1/TA
6752 T1 = 2.0 * PI * RANART(NSEED)
6753 IBLOCK=1
6754 GO TO 107
6755 ELSE
6756*COM: TEST FOR INELASTIC SCATTERING
6757* IF THE AVAILABLE ENERGY IS LESS THAN THE PION-MASS, NOTHING
6758* CAN HAPPEN ANY MORE ==> RETURN (2.04 = 2*AVMASS + PI-MASS+0.02)
6759 IF (SRT .LT. 2.04) RETURN
6760clin-6/2008 add d+meson production for n*N*(0)(1440) and p*N*(+)(1440) channels
6761c (they did not have any inelastic reactions before):
6762 if(((iabs(LB(I1)).EQ.2.or.iabs(LB(I2)).EQ.2).AND.
6763 1 (LB(I1)*LB(I2)).EQ.20).or.(LB(I1)*LB(I2)).EQ.13) then
6764 IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
6765 ENDIF
6766c
6767* Resonance absorption or Delta + N-->N*(1440), N*(1535)
6768* COM: TEST FOR DELTA OR N* ABSORPTION
6769* IN THE PROCESS DELTA+N-->NN, N*+N-->NN
6770 PRF=SQRT(0.25*SRT**2-AVMASS**2)
6771 IF(EM1.GT.1.)THEN
6772 DELTAM=EM1
6773 ELSE
6774 DELTAM=EM2
6775 ENDIF
6776 RENOM=DELTAM*PRF**2/DENOM(SRT,1.)/PR
6777 RENOMN=DELTAM*PRF**2/DENOM(SRT,2.)/PR
6778 RENOM1=DELTAM*PRF**2/DENOM(SRT,-1.)/PR
6779* avoid the inelastic collisions between n+delta- -->N+N
6780* and p+delta++ -->N+N due to charge conservation,
6781* but they can scatter to produce kaons
6782 if((iabs(lb(i1)).eq.2).and.(iabs(lb(i2)).eq.6)) renom=0.
6783 if((iabs(lb(i2)).eq.2).and.(iabs(lb(i1)).eq.6)) renom=0.
6784 if((iabs(lb(i1)).eq.1).and.(iabs(lb(i2)).eq.9)) renom=0.
6785 if((iabs(lb(i2)).eq.1).and.(iabs(lb(i1)).eq.9)) renom=0.
6786 Call M1535(iabs(lb(i1)),iabs(lb(i2)),srt,x1535)
6787 X1440=(3./4.)*SIGMA(SRT,2,0,1)
6788* CROSS SECTION FOR KAON PRODUCTION from the four channels
6789* for NLK channel
6790* avoid the inelastic collisions between n+delta- -->N+N
6791* and p+delta++ -->N+N due to charge conservation,
6792* but they can scatter to produce kaons
6793 if(((iabs(lb(i1)).eq.2).and.(iabs(lb(i2)).eq.6)).OR.
6794 & ((iabs(lb(i2)).eq.2).and.(iabs(lb(i1)).eq.6)).OR.
6795 & ((iabs(lb(i1)).eq.1).and.(iabs(lb(i2)).eq.9)).OR.
6796 & ((iabs(lb(i2)).eq.1).and.(iabs(lb(i1)).eq.9)))THEN
6797clin-6/2008
6798 IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
6799c IF((SIGK+SIGNN)/SIG.GE.X1)GO TO 306
6800 IF((SIGK+SIGNN+sdprod)/SIG.GE.X1)GO TO 306
6801c
6802 ENDIF
6803* WE DETERMINE THE REACTION CHANNELS IN THE FOLLOWING
6804* FOR n+delta(++)-->p+p or n+delta(++)-->n+N*(+)(1440),n+N*(+)(1535)
6805* REABSORPTION OR N*(1535) PRODUCTION LIKE IN P+P OR N*(1440) LIKE PN,
6806 IF(LB(I1)*LB(I2).EQ.18.AND.
6807 & (iabs(LB(I1)).EQ.2.OR.iabs(LB(I2)).EQ.2))then
6808 SIGND=SIGMA(SRT,1,1,0)+0.5*SIGMA(SRT,1,1,1)
6809 SIGDN=0.25*SIGND*RENOM
6810clin-6/2008
6811 IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
6812c IF(X1.GT.(SIGNN+SIGDN+X1440+X1535+SIGK)/SIG)RETURN
6813 IF(X1.GT.(SIGNN+SIGDN+X1440+X1535+SIGK+sdprod)/SIG)RETURN
6814c
6815 IF(SIGK/(SIGK+SIGDN+X1440+X1535).GT.RANART(NSEED))GO TO 306
6816* REABSORPTION:
6817 IF(RANART(NSEED).LT.SIGDN/(SIGDN+X1440+X1535))THEN
6818 M12=3
6819 GO TO 206
6820 ELSE
6821* N* PRODUCTION
6822 IF(RANART(NSEED).LT.X1440/(X1440+X1535))THEN
6823* N*(1440)
6824 M12=37
6825 ELSE
6826* N*(1535) M12=38
6827clin-2/26/03 why is the above commented out? leads to M12=0 but
6828c particle mass is changed after 204 (causes energy violation).
6829c replace by elastic process (return):
6830 return
6831
6832 ENDIF
6833 GO TO 204
6834 ENDIF
6835 ENDIF
6836* FOR p+delta(-)-->n+n or p+delta(-)-->n+N*(0)(1440),n+N*(0)(1535)
6837* REABSORPTION OR N*(1535) PRODUCTION LIKE IN P+P OR N*(1440) LIKE PN,
6838 IF(LB(I1)*LB(I2).EQ.6.AND.
6839 & ((iabs(LB(I1)).EQ.1).OR.(iabs(LB(I2)).EQ.1)))then
6840 SIGND=SIGMA(SRT,1,1,0)+0.5*SIGMA(SRT,1,1,1)
6841 SIGDN=0.25*SIGND*RENOM
6842clin-6/2008
6843 IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
6844c IF (X1.GT.(SIGNN+SIGDN+X1440+X1535+SIGK)/SIG)RETURN
6845 IF (X1.GT.(SIGNN+SIGDN+X1440+X1535+SIGK+sdprod)/SIG)RETURN
6846c
6847 IF(SIGK/(SIGK+SIGDN+X1440+X1535).GT.RANART(NSEED))GO TO 306
6848* REABSORPTION:
6849 IF(RANART(NSEED).LT.SIGDN/(SIGDN+X1440+X1535))THEN
6850 M12=6
6851 GO TO 206
6852 ELSE
6853* N* PRODUCTION
6854 IF(RANART(NSEED).LT.X1440/(X1440+X1535))THEN
6855* N*(1440)
6856 M12=47
6857 ELSE
6858* N*(1535) M12=48
6859clin-2/26/03 causes energy violation, replace by elastic process (return):
6860 return
6861
6862 ENDIF
6863 GO TO 204
6864 ENDIF
6865 ENDIF
6866* FOR p+delta(+)-->p+p, N*(+)(144)+p, N*(+)(1535)+p
6867 IF(LB(I1)*LB(I2).EQ.8.AND.
6868 & (iabs(LB(I1)).EQ.1.OR.iabs(LB(I2)).EQ.1))THEN
6869 SIGND=1.5*SIGMA(SRT,1,1,1)
6870 SIGDN=0.25*SIGND*RENOM
6871clin-6/2008
6872 IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
6873c IF(X1.GT.(SIGNN+SIGDN+x1440+x1535+SIGK)/SIG)RETURN
6874 IF(X1.GT.(SIGNN+SIGDN+x1440+x1535+SIGK+sdprod)/SIG)RETURN
6875c
6876 IF(SIGK/(SIGK+SIGDN+X1440+X1535).GT.RANART(NSEED))GO TO 306
6877 IF(RANART(NSEED).LT.SIGDN/(SIGDN+X1440+X1535))THEN
6878 M12=4
6879 GO TO 206
6880 ELSE
6881 IF(RANART(NSEED).LT.X1440/(X1440+X1535))THEN
6882* N*(144)
6883 M12=39
6884 ELSE
6885 M12=40
6886 ENDIF
6887 GO TO 204
6888 ENDIF
6889 ENDIF
6890* FOR n+delta(0)-->n+n, N*(0)(144)+n, N*(0)(1535)+n
6891 IF(LB(I1)*LB(I2).EQ.14.AND.
6892 & (iabs(LB(I1)).EQ.2.OR.iabs(LB(I2)).EQ.2))THEN
6893 SIGND=1.5*SIGMA(SRT,1,1,1)
6894 SIGDN=0.25*SIGND*RENOM
6895clin-6/2008
6896 IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
6897c IF(X1.GT.(SIGNN+SIGDN+x1440+x1535+SIGK)/SIG)RETURN
6898 IF(X1.GT.(SIGNN+SIGDN+x1440+x1535+SIGK+sdprod)/SIG)RETURN
6899c
6900 IF(SIGK/(SIGK+SIGDN+X1440+X1535).GT.RANART(NSEED))GO TO 306
6901 IF(RANART(NSEED).LT.SIGDN/(SIGDN+X1440+X1535))THEN
6902 M12=5
6903 GO TO 206
6904 ELSE
6905 IF(RANART(NSEED).LT.X1440/(X1440+X1535))THEN
6906* N*(144)
6907 M12=48
6908 ELSE
6909 M12=49
6910 ENDIF
6911 GO TO 204
6912 ENDIF
6913 ENDIF
6914* FOR n+delta(+)-->n+p, N*(+)(1440)+n,N*(0)(1440)+p,
6915* N*(+)(1535)+n,N*(0)(1535)+p
6916 IF(LB(I1)*LB(I2).EQ.16.AND.
6917 & (iabs(LB(I1)).EQ.2.OR.iabs(LB(I2)).EQ.2))THEN
6918 SIGND=0.5*SIGMA(SRT,1,1,1)+0.25*SIGMA(SRT,1,1,0)
6919 SIGDN=0.5*SIGND*RENOM
6920clin-6/2008
6921 IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
6922c IF(X1.GT.(SIGNN+SIGDN+2.*x1440+2.*x1535+SIGK)/SIG)RETURN
6923 IF(X1.GT.(SIGNN+SIGDN+2.*x1440+2.*x1535+SIGK+sdprod)/SIG)RETURN
6924c
6925 IF(SIGK/(SIGK+SIGDN+2*X1440+2*X1535).GT.RANART(NSEED))GO TO 306
6926 IF(RANART(NSEED).LT.SIGDN/(SIGDN+2.*X1440+2.*X1535))THEN
6927 M12=1
6928 GO TO 206
6929 ELSE
6930 IF(RANART(NSEED).LT.X1440/(X1440+X1535))THEN
6931 M12=41
6932 IF(RANART(NSEED).LE.0.5)M12=43
6933 ELSE
6934 M12=42
6935 IF(RANART(NSEED).LE.0.5)M12=44
6936 ENDIF
6937 GO TO 204
6938 ENDIF
6939 ENDIF
6940* FOR p+delta(0)-->n+p, N*(+)(1440)+n,N*(0)(1440)+p,
6941* N*(+)(1535)+n,N*(0)(1535)+p
6942 IF(LB(I1)*LB(I2).EQ.7)THEN
6943 SIGND=0.5*SIGMA(SRT,1,1,1)+0.25*SIGMA(SRT,1,1,0)
6944 SIGDN=0.5*SIGND*RENOM
6945clin-6/2008
6946 IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
6947c IF(X1.GT.(SIGNN+SIGDN+2.*x1440+2.*x1535+SIGK)/SIG)RETURN
6948 IF(X1.GT.(SIGNN+SIGDN+2.*x1440+2.*x1535+SIGK+sdprod)/SIG)RETURN
6949c
6950 IF(SIGK/(SIGK+SIGDN+2*X1440+2*X1535).GT.RANART(NSEED))GO TO 306
6951 IF(RANART(NSEED).LT.SIGDN/(SIGDN+2.*X1440+2.*X1535))THEN
6952 M12=2
6953 GO TO 206
6954 ELSE
6955 IF(RANART(NSEED).LT.X1440/(X1440+X1535))THEN
6956 M12=50
6957 IF(RANART(NSEED).LE.0.5)M12=51
6958 ELSE
6959 M12=52
6960 IF(RANART(NSEED).LE.0.5)M12=53
6961 ENDIF
6962 GO TO 204
6963 ENDIF
6964 ENDIF
6965* FOR p+N*(0)(14)-->p+n, N*(+)(1535)+n,N*(0)(1535)+p
6966* OR P+N*(0)(14)-->D(+)+N, D(0)+P,
6967 IF(LB(I1)*LB(I2).EQ.10.AND.
6968 & (iabs(LB(I1)).EQ.1.OR.iabs(LB(I2)).EQ.1))then
6969 SIGND=(3./4.)*SIGMA(SRT,2,0,1)
6970 SIGDN=SIGND*RENOMN
6971clin-6/2008
6972 IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
6973c IF(X1.GT.(SIGNN+SIGDN+X1535+SIGK)/SIG)RETURN
6974 IF(X1.GT.(SIGNN+SIGDN+X1535+SIGK+sdprod)/SIG)RETURN
6975c
6976 IF(SIGK/(SIGK+SIGDN+X1535).GT.RANART(NSEED))GO TO 306
6977 IF(RANART(NSEED).LT.SIGDN/(SIGDN+X1535))THEN
6978 M12=7
6979 GO TO 206
6980 ELSE
6981 M12=54
6982 IF(RANART(NSEED).LE.0.5)M12=55
6983 ENDIF
6984 GO TO 204
6985 ENDIF
6986* FOR n+N*(+)-->p+n, N*(+)(1535)+n,N*(0)(1535)+p
6987 IF(LB(I1)*LB(I2).EQ.22.AND.
6988 & (iabs(LB(I1)).EQ.2.OR.iabs(LB(I2)).EQ.2))then
6989 SIGND=(3./4.)*SIGMA(SRT,2,0,1)
6990 SIGDN=SIGND*RENOMN
6991clin-6/2008
6992 IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
6993c IF(X1.GT.(SIGNN+SIGDN+X1535+SIGK)/SIG)RETURN
6994 IF(X1.GT.(SIGNN+SIGDN+X1535+SIGK+sdprod)/SIG)RETURN
6995c
6996 IF(SIGK/(SIGK+SIGDN+X1535).GT.RANART(NSEED))GO TO 306
6997 IF(RANART(NSEED).LT.SIGDN/(SIGDN+X1535))THEN
6998 M12=8
6999 GO TO 206
7000 ELSE
7001 M12=56
7002 IF(RANART(NSEED).LE.0.5)M12=57
7003 ENDIF
7004 GO TO 204
7005 ENDIF
7006* FOR N*(1535)+N-->N+N COLLISIONS
7007 IF((iabs(LB(I1)).EQ.12).OR.(iabs(LB(I1)).EQ.13).OR.
7008 1 (iabs(LB(I2)).EQ.12).OR.(iabs(LB(I2)).EQ.13))THEN
7009 SIGND=X1535
7010 SIGDN=SIGND*RENOM1
7011clin-6/2008
7012 IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
7013c IF(X1.GT.(SIGNN+SIGDN+SIGK)/SIG)RETURN
7014 IF(X1.GT.(SIGNN+SIGDN+SIGK+sdprod)/SIG)RETURN
7015c
7016 IF(SIGK/(SIGK+SIGDN).GT.RANART(NSEED))GO TO 306
7017 IF(LB(I1)*LB(I2).EQ.24)M12=10
7018 IF(LB(I1)*LB(I2).EQ.12)M12=12
7019 IF(LB(I1)*LB(I2).EQ.26)M12=11
7020 IF(LB(I1)*LB(I2).EQ.13)M12=9
7021 GO TO 206
7022 ENDIF
7023204 CONTINUE
7024* (1) GENERATE THE MASS FOR THE N*(1440) AND N*(1535)
7025* (2) CALCULATE THE FINAL MOMENTUM OF THE n+N* SYSTEM
7026* (3) RELABLE THE FINAL STATE PARTICLES
7027*PARAMETRIZATION OF THE SHAPE OF THE N* RESONANCE ACCORDING
7028* TO kitazoe's or J.D.JACKSON'S MASS FORMULA AND BREIT WIGNER
7029* FORMULA FOR N* RESORANCE
7030* DETERMINE DELTA MASS VIA REJECTION METHOD.
7031 DMAX = SRT - AVMASS-0.005
7032 DMIN = 1.078
7033 IF((M12.eq.37).or.(M12.eq.39).or.
7034 1 (M12.eQ.41).OR.(M12.eQ.43).OR.(M12.EQ.46).
7035 2 OR.(M12.EQ.48).OR.(M12.EQ.50).OR.(M12.EQ.51))then
7036* N*(1440) production
7037 IF(DMAX.LT.1.44) THEN
7038 FM=FNS(DMAX,SRT,0.)
7039 ELSE
7040
7041clin-10/25/02 get rid of argument usage mismatch in FNS():
7042 xdmass=1.44
7043c FM=FNS(1.44,SRT,1.)
7044 FM=FNS(xdmass,SRT,1.)
7045clin-10/25/02-end
7046
7047 ENDIF
7048 IF(FM.EQ.0.)FM=1.E-09
7049 NTRY2=0
705011 DM=RANART(NSEED)*(DMAX-DMIN)+DMIN
7051 NTRY2=NTRY2+1
7052 IF((RANART(NSEED).GT.FNS(DM,SRT,1.)/FM).AND.
7053 1 (NTRY2.LE.10)) GO TO 11
7054
7055clin-2/26/03 limit the N* mass below a certain value
7056c (here taken as its central value + 2* B-W fullwidth):
7057 if(dm.gt.2.14) goto 11
7058
7059 GO TO 13
7060 ELSE
7061* N*(1535) production
7062 IF(DMAX.LT.1.535) THEN
7063 FM=FD5(DMAX,SRT,0.)
7064 ELSE
7065
7066clin-10/25/02 get rid of argument usage mismatch in FNS():
7067 xdmass=1.535
7068c FM=FD5(1.535,SRT,1.)
7069 FM=FD5(xdmass,SRT,1.)
7070clin-10/25/02-end
7071
7072 ENDIF
7073 IF(FM.EQ.0.)FM=1.E-09
7074 NTRY1=0
707512 DM = RANART(NSEED) * (DMAX-DMIN) + DMIN
7076 NTRY1=NTRY1+1
7077 IF((RANART(NSEED) .GT. FD5(DM,SRT,1.)/FM).AND.
7078 1 (NTRY1.LE.10)) GOTO 12
7079
7080clin-2/26/03 limit the N* mass below a certain value
7081c (here taken as its central value + 2* B-W fullwidth):
7082 if(dm.gt.1.84) goto 12
7083
7084 ENDIF
708513 CONTINUE
7086* (2) DETERMINE THE FINAL MOMENTUM
7087 PRF=0.
7088 PF2=((SRT**2-DM**2+AVMASS**2)/(2.*SRT))**2-AVMASS**2
7089 IF(PF2.GT.0.)PRF=SQRT(PF2)
7090* (3) RELABLE FINAL STATE PARTICLES
7091* 37 D(++)+n-->N*(+)(14)+p
7092 IF(M12.EQ.37)THEN
7093 IF(iabs(LB(I1)).EQ.9)THEN
7094 LB(I1)=1
7095 E(I1)=AMP
7096 LB(I2)=11
7097 E(I2)=DM
7098 ELSE
7099 LB(I2)=1
7100 E(I2)=AMP
7101 LB(I1)=11
7102 E(I1)=DM
7103 ENDIF
7104 GO TO 207
7105 ENDIF
7106* 38 D(++)+n-->N*(+)(15)+p
7107 IF(M12.EQ.38)THEN
7108 IF(iabs(LB(I1)).EQ.9)THEN
7109 LB(I1)=1
7110 E(I1)=AMP
7111 LB(I2)=13
7112 E(I2)=DM
7113 ELSE
7114 LB(I2)=1
7115 E(I2)=AMP
7116 LB(I1)=13
7117 E(I1)=DM
7118 ENDIF
7119 GO TO 207
7120 ENDIF
7121* 39 D(+)+P-->N*(+)(14)+p
7122 IF(M12.EQ.39)THEN
7123 IF(iabs(LB(I1)).EQ.8)THEN
7124 LB(I1)=1
7125 E(I1)=AMP
7126 LB(I2)=11
7127 E(I2)=DM
7128 ELSE
7129 LB(I2)=1
7130 E(I2)=AMP
7131 LB(I1)=11
7132 E(I1)=DM
7133 ENDIF
7134 GO TO 207
7135 ENDIF
7136* 40 D(+)+P-->N*(+)(15)+p
7137 IF(M12.EQ.40)THEN
7138 IF(iabs(LB(I1)).EQ.8)THEN
7139 LB(I1)=1
7140 E(I1)=AMP
7141 LB(I2)=13
7142 E(I2)=DM
7143 ELSE
7144 LB(I2)=1
7145 E(I2)=AMP
7146 LB(I1)=13
7147 E(I1)=DM
7148 ENDIF
7149 GO TO 207
7150 ENDIF
7151* 41 D(+)+N-->N*(+)(14)+N
7152 IF(M12.EQ.41)THEN
7153 IF(iabs(LB(I1)).EQ.8)THEN
7154 LB(I1)=2
7155 E(I1)=AMN
7156 LB(I2)=11
7157 E(I2)=DM
7158 ELSE
7159 LB(I2)=2
7160 E(I2)=AMN
7161 LB(I1)=11
7162 E(I1)=DM
7163 ENDIF
7164 GO TO 207
7165 ENDIF
7166* 42 D(+)+N-->N*(+)(15)+N
7167 IF(M12.EQ.42)THEN
7168 IF(iabs(LB(I1)).EQ.8)THEN
7169 LB(I1)=2
7170 E(I1)=AMN
7171 LB(I2)=13
7172 E(I2)=DM
7173 ELSE
7174 LB(I2)=2
7175 E(I2)=AMN
7176 LB(I1)=13
7177 E(I1)=DM
7178 ENDIF
7179 GO TO 207
7180 ENDIF
7181* 43 D(+)+N-->N*(0)(14)+P
7182 IF(M12.EQ.43)THEN
7183 IF(iabs(LB(I1)).EQ.8)THEN
7184 LB(I1)=1
7185 E(I1)=AMP
7186 LB(I2)=10
7187 E(I2)=DM
7188 ELSE
7189 LB(I2)=1
7190 E(I2)=AMP
7191 LB(I1)=10
7192 E(I1)=DM
7193 ENDIF
7194 GO TO 207
7195 ENDIF
7196* 44 D(+)+N-->N*(0)(15)+P
7197 IF(M12.EQ.44)THEN
7198 IF(iabs(LB(I1)).EQ.8)THEN
7199 LB(I1)=1
7200 E(I1)=AMP
7201 LB(I2)=12
7202 E(I2)=DM
7203 ELSE
7204 LB(I2)=1
7205 E(I2)=AMP
7206 LB(I1)=12
7207 E(I1)=DM
7208 ENDIF
7209 GO TO 207
7210 ENDIF
7211* 46 D(-)+P-->N*(0)(14)+N
7212 IF(M12.EQ.46)THEN
7213 IF(iabs(LB(I1)).EQ.6)THEN
7214 LB(I1)=2
7215 E(I1)=AMN
7216 LB(I2)=10
7217 E(I2)=DM
7218 ELSE
7219 LB(I2)=2
7220 E(I2)=AMN
7221 LB(I1)=10
7222 E(I1)=DM
7223 ENDIF
7224 GO TO 207
7225 ENDIF
7226* 47 D(-)+P-->N*(0)(15)+N
7227 IF(M12.EQ.47)THEN
7228 IF(iabs(LB(I1)).EQ.6)THEN
7229 LB(I1)=2
7230 E(I1)=AMN
7231 LB(I2)=12
7232 E(I2)=DM
7233 ELSE
7234 LB(I2)=2
7235 E(I2)=AMN
7236 LB(I1)=12
7237 E(I1)=DM
7238 ENDIF
7239 GO TO 207
7240 ENDIF
7241* 48 D(0)+N-->N*(0)(14)+N
7242 IF(M12.EQ.48)THEN
7243 IF(iabs(LB(I1)).EQ.7)THEN
7244 LB(I1)=2
7245 E(I1)=AMN
7246 LB(I2)=11
7247 E(I2)=DM
7248 ELSE
7249 LB(I2)=2
7250 E(I2)=AMN
7251 LB(I1)=11
7252 E(I1)=DM
7253 ENDIF
7254 GO TO 207
7255 ENDIF
7256* 49 D(0)+N-->N*(0)(15)+N
7257 IF(M12.EQ.49)THEN
7258 IF(iabs(LB(I1)).EQ.7)THEN
7259 LB(I1)=2
7260 E(I1)=AMN
7261 LB(I2)=12
7262 E(I2)=DM
7263 ELSE
7264 LB(I2)=2
7265 E(I2)=AMN
7266 LB(I1)=12
7267 E(I1)=DM
7268 ENDIF
7269 GO TO 207
7270 ENDIF
7271* 50 D(0)+P-->N*(0)(14)+P
7272 IF(M12.EQ.50)THEN
7273 IF(iabs(LB(I1)).EQ.7)THEN
7274 LB(I1)=1
7275 E(I1)=AMP
7276 LB(I2)=10
7277 E(I2)=DM
7278 ELSE
7279 LB(I2)=1
7280 E(I2)=AMP
7281 LB(I1)=10
7282 E(I1)=DM
7283 ENDIF
7284 GO TO 207
7285 ENDIF
7286* 51 D(0)+P-->N*(+)(14)+N
7287 IF(M12.EQ.51)THEN
7288 IF(iabs(LB(I1)).EQ.7)THEN
7289 LB(I1)=2
7290 E(I1)=AMN
7291 LB(I2)=11
7292 E(I2)=DM
7293 ELSE
7294 LB(I2)=2
7295 E(I2)=AMN
7296 LB(I1)=11
7297 E(I1)=DM
7298 ENDIF
7299 GO TO 207
7300 ENDIF
7301* 52 D(0)+P-->N*(0)(15)+P
7302 IF(M12.EQ.52)THEN
7303 IF(iabs(LB(I1)).EQ.7)THEN
7304 LB(I1)=1
7305 E(I1)=AMP
7306 LB(I2)=12
7307 E(I2)=DM
7308 ELSE
7309 LB(I2)=1
7310 E(I2)=AMP
7311 LB(I1)=12
7312 E(I1)=DM
7313 ENDIF
7314 GO TO 207
7315 ENDIF
7316* 53 D(0)+P-->N*(+)(15)+N
7317 IF(M12.EQ.53)THEN
7318 IF(iabs(LB(I1)).EQ.7)THEN
7319 LB(I1)=2
7320 E(I1)=AMN
7321 LB(I2)=13
7322 E(I2)=DM
7323 ELSE
7324 LB(I2)=2
7325 E(I2)=AMN
7326 LB(I1)=13
7327 E(I1)=DM
7328 ENDIF
7329 GO TO 207
7330 ENDIF
7331* 54 N*(0)(14)+P-->N*(+)(15)+N
7332 IF(M12.EQ.54)THEN
7333 IF(iabs(LB(I1)).EQ.10)THEN
7334 LB(I1)=2
7335 E(I1)=AMN
7336 LB(I2)=13
7337 E(I2)=DM
7338 ELSE
7339 LB(I2)=2
7340 E(I2)=AMN
7341 LB(I1)=13
7342 E(I1)=DM
7343 ENDIF
7344 GO TO 207
7345 ENDIF
7346* 55 N*(0)(14)+P-->N*(0)(15)+P
7347 IF(M12.EQ.55)THEN
7348 IF(iabs(LB(I1)).EQ.10)THEN
7349 LB(I1)=1
7350 E(I1)=AMP
7351 LB(I2)=12
7352 E(I2)=DM
7353 ELSE
7354 LB(I2)=1
7355 E(I2)=AMP
7356 LB(I1)=12
7357 E(I1)=DM
7358 ENDIF
7359 GO TO 207
7360 ENDIF
7361* 56 N*(+)(14)+N-->N*(+)(15)+N
7362 IF(M12.EQ.56)THEN
7363 IF(iabs(LB(I1)).EQ.11)THEN
7364 LB(I1)=2
7365 E(I1)=AMN
7366 LB(I2)=13
7367 E(I2)=DM
7368 ELSE
7369 LB(I2)=2
7370 E(I2)=AMN
7371 LB(I1)=13
7372 E(I1)=DM
7373 ENDIF
7374 GO TO 207
7375 ENDIF
7376* 57 N*(+)(14)+N-->N*(0)(15)+P
7377 IF(M12.EQ.57)THEN
7378 IF(iabs(LB(I1)).EQ.11)THEN
7379 LB(I1)=1
7380 E(I1)=AMP
7381 LB(I2)=12
7382 E(I2)=DM
7383 ELSE
7384 LB(I2)=1
7385 E(I2)=AMP
7386 LB(I1)=12
7387 E(I1)=DM
7388 ENDIF
7389 ENDIF
7390 GO TO 207
7391*------------------------------------------------
7392* RELABLE NUCLEONS AFTER DELTA OR N* BEING ABSORBED
7393*(1) n+delta(+)-->n+p
7394206 IF(M12.EQ.1)THEN
7395 IF(iabs(LB(I1)).EQ.8)THEN
7396 LB(I2)=2
7397 LB(I1)=1
7398 E(I1)=AMP
7399 ELSE
7400 LB(I1)=2
7401 LB(I2)=1
7402 E(I2)=AMP
7403 ENDIF
7404 GO TO 207
7405 ENDIF
7406*(2) p+delta(0)-->p+n
7407 IF(M12.EQ.2)THEN
7408 IF(iabs(LB(I1)).EQ.7)THEN
7409 LB(I2)=1
7410 LB(I1)=2
7411 E(I1)=AMN
7412 ELSE
7413 LB(I1)=1
7414 LB(I2)=2
7415 E(I2)=AMN
7416 ENDIF
7417 GO TO 207
7418 ENDIF
7419*(3) n+delta(++)-->p+p
7420 IF(M12.EQ.3)THEN
7421 LB(I1)=1
7422 LB(I2)=1
7423 E(I1)=AMP
7424 E(I2)=AMP
7425 GO TO 207
7426 ENDIF
7427*(4) p+delta(+)-->p+p
7428 IF(M12.EQ.4)THEN
7429 LB(I1)=1
7430 LB(I2)=1
7431 E(I1)=AMP
7432 E(I2)=AMP
7433 GO TO 207
7434 ENDIF
7435*(5) n+delta(0)-->n+n
7436 IF(M12.EQ.5)THEN
7437 LB(I1)=2
7438 LB(I2)=2
7439 E(I1)=AMN
7440 E(I2)=AMN
7441 GO TO 207
7442 ENDIF
7443*(6) p+delta(-)-->n+n
7444 IF(M12.EQ.6)THEN
7445 LB(I1)=2
7446 LB(I2)=2
7447 E(I1)=AMN
7448 E(I2)=AMN
7449 GO TO 207
7450 ENDIF
7451*(7) p+N*(0)-->n+p
7452 IF(M12.EQ.7)THEN
7453 IF(iabs(LB(I1)).EQ.1)THEN
7454 LB(I1)=1
7455 LB(I2)=2
7456 E(I1)=AMP
7457 E(I2)=AMN
7458 ELSE
7459 LB(I1)=2
7460 LB(I2)=1
7461 E(I1)=AMN
7462 E(I2)=AMP
7463 ENDIF
7464 GO TO 207
7465 ENDIF
7466*(8) n+N*(+)-->n+p
7467 IF(M12.EQ.8)THEN
7468 IF(iabs(LB(I1)).EQ.2)THEN
7469 LB(I1)=2
7470 LB(I2)=1
7471 E(I1)=AMN
7472 E(I2)=AMP
7473 ELSE
7474 LB(I1)=1
7475 LB(I2)=2
7476 E(I1)=AMP
7477 E(I2)=AMN
7478 ENDIF
7479 GO TO 207
7480 ENDIF
7481clin-6/2008
7482c*(9) N*(+)p-->pp
7483*(9) N*(+)(1535) p-->pp
7484 IF(M12.EQ.9)THEN
7485 LB(I1)=1
7486 LB(I2)=1
7487 E(I1)=AMP
7488 E(I2)=AMP
7489 GO TO 207
7490 ENDIF
7491*(12) N*(0)P-->nP
7492 IF(M12.EQ.12)THEN
7493 LB(I1)=2
7494 LB(I2)=1
7495 E(I1)=AMN
7496 E(I2)=AMP
7497 GO TO 207
7498 ENDIF
7499*(11) N*(+)n-->nP
7500 IF(M12.EQ.11)THEN
7501 LB(I1)=2
7502 LB(I2)=1
7503 E(I1)=AMN
7504 E(I2)=AMP
7505 GO TO 207
7506 ENDIF
7507clin-6/2008
7508c*(12) N*(0)p-->Np
7509*(12) N*(0)(1535) p-->Np
7510 IF(M12.EQ.12)THEN
7511 LB(I1)=1
7512 LB(I2)=2
7513 E(I1)=AMP
7514 E(I2)=AMN
7515 ENDIF
7516*----------------------------------------------
7517207 PR = PRF
7518 C1 = 1.0 - 2.0 * RANART(NSEED)
7519 if(srt.le.2.14)C1= 1.0 - 2.0 * RANART(NSEED)
86c53b9e 7520 if(srt.gt.2.14.and.srt.le.2.4)c1=anga(srt,iseed)
0119ef9a 7521 if(srt.gt.2.4)then
7522
7523clin-10/25/02 get rid of argument usage mismatch in PTR():
7524 xptr=0.33*pr
7525c cc1=ptr(0.33*pr,iseed)
7526 cc1=ptr(xptr,iseed)
7527clin-10/25/02-end
7528
7529 c1=sqrt(pr**2-cc1**2)/pr
7530 endif
7531 T1 = 2.0 * PI * RANART(NSEED)
7532 IBLOCK=3
7533 ENDIF
7534 if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
7535 lb(i1) = -lb(i1)
7536 lb(i2) = -lb(i2)
7537 endif
7538
7539*-----------------------------------------------------------------------
7540*COM: SET THE NEW MOMENTUM COORDINATES
7541 107 IF(PX .EQ. 0.0 .AND. PY .EQ. 0.0) THEN
7542 T2 = 0.0
7543 ELSE
7544 T2=ATAN2(PY,PX)
7545 END IF
7546 S1 = SQRT( 1.0 - C1**2 )
7547 S2 = SQRT( 1.0 - C2**2 )
7548 CT1 = COS(T1)
7549 ST1 = SIN(T1)
7550 CT2 = COS(T2)
7551 ST2 = SIN(T2)
7552 PZ = PR * ( C1*C2 - S1*S2*CT1 )
7553 SS = C2 * S1 * CT1 + S2 * C1
7554 PX = PR * ( SS*CT2 - S1*ST1*ST2 )
7555 PY = PR * ( SS*ST2 + S1*ST1*CT2 )
7556 RETURN
7557* FOR THE NN-->KAON+X PROCESS, FIND MOMENTUM OF THE FINAL PARTICLES IN
7558* THE NUCLEUS-NUCLEUS CMS.
7559306 CONTINUE
7560csp11/21/01 phi production
7561 if(XSK5/sigK.gt.RANART(NSEED))then
7562 pz1=p(3,i1)
7563 pz2=p(3,i2)
7564 LB(I1) = 1 + int(2 * RANART(NSEED))
7565 LB(I2) = 1 + int(2 * RANART(NSEED))
7566 nnn=nnn+1
7567 LPION(NNN,IRUN)=29
7568 EPION(NNN,IRUN)=APHI
7569 iblock = 222
7570 GO TO 208
7571 ENDIF
7572csp11/21/01 end
7573 IBLOCK=11
7574 if(ianti .eq. 1)iblock=-11
7575c
7576 pz1=p(3,i1)
7577 pz2=p(3,i2)
7578* DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
7579 nnn=nnn+1
7580 LPION(NNN,IRUN)=23
7581 EPION(NNN,IRUN)=Aka
7582 if(srt.le.2.63)then
7583* only lambda production is possible
7584* (1.1)P+P-->p+L+kaon+
7585 ic=1
7586
7587 LB(I1) = 1 + int(2 * RANART(NSEED))
7588 LB(I2)=14
7589 GO TO 208
7590 ENDIF
7591 if(srt.le.2.74.and.srt.gt.2.63)then
7592* both Lambda and sigma production are possible
7593 if(XSK1/(XSK1+XSK2).gt.RANART(NSEED))then
7594* lambda production
7595 ic=1
7596
7597 LB(I1) = 1 + int(2 * RANART(NSEED))
7598 LB(I2)=14
7599 else
7600* sigma production
7601
7602 LB(I1) = 1 + int(2 * RANART(NSEED))
7603 LB(I2) = 15 + int(3 * RANART(NSEED))
7604 ic=2
7605 endif
7606 GO TO 208
7607 endif
7608 if(srt.le.2.77.and.srt.gt.2.74)then
7609* then pp-->Delta lamda kaon can happen
7610 if(xsk1/(xsk1+xsk2+xsk3).
7611 1 gt.RANART(NSEED))then
7612* * (1.1)P+P-->p+L+kaon+
7613 ic=1
7614
7615 LB(I1) = 1 + int(2 * RANART(NSEED))
7616 LB(I2)=14
7617 go to 208
7618 else
7619 if(xsk2/(xsk2+xsk3).gt.RANART(NSEED))then
7620* pp-->psk
7621 ic=2
7622
7623 LB(I1) = 1 + int(2 * RANART(NSEED))
7624 LB(I2) = 15 + int(3 * RANART(NSEED))
7625
7626 else
7627* pp-->D+l+k
7628 ic=3
7629
7630 LB(I1) = 6 + int(4 * RANART(NSEED))
7631 lb(i2)=14
7632 endif
7633 GO TO 208
7634 endif
7635 endif
7636 if(srt.gt.2.77)then
7637* all four channels are possible
7638 if(xsk1/(xsk1+xsk2+xsk3+xsk4).gt.RANART(NSEED))then
7639* p lambda k production
7640 ic=1
7641
7642 LB(I1) = 1 + int(2 * RANART(NSEED))
7643 LB(I2)=14
7644 go to 208
7645 else
7646 if(xsk3/(xsk2+xsk3+xsk4).gt.RANART(NSEED))then
7647* delta l K production
7648 ic=3
7649
7650 LB(I1) = 6 + int(4 * RANART(NSEED))
7651 lb(i2)=14
7652 go to 208
7653 else
7654 if(xsk2/(xsk2+xsk4).gt.RANART(NSEED))then
7655* n sigma k production
7656
7657 LB(I1) = 1 + int(2 * RANART(NSEED))
7658 LB(I2) = 15 + int(3 * RANART(NSEED))
7659
7660 ic=2
7661 else
7662 ic=4
7663
7664 LB(I1) = 6 + int(4 * RANART(NSEED))
7665 LB(I2) = 15 + int(3 * RANART(NSEED))
7666
7667 endif
7668 go to 208
7669 endif
7670 endif
7671 endif
7672208 continue
7673 if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
7674 lb(i1) = - lb(i1)
7675 lb(i2) = - lb(i2)
7676 if(LPION(NNN,IRUN) .eq. 23)LPION(NNN,IRUN)=21
7677 endif
7678 lbi1=lb(i1)
7679 lbi2=lb(i2)
7680* KEEP ALL COORDINATES OF PARTICLE 2 FOR POSSIBLE PHASE SPACE CHANGE
7681 NTRY1=0
7682128 CALL BBKAON(ic,SRT,PX3,PY3,PZ3,DM3,PX4,PY4,PZ4,DM4,
7683 & PPX,PPY,PPZ,icou1)
7684 NTRY1=NTRY1+1
7685 if((icou1.lt.0).AND.(NTRY1.LE.20))GO TO 128
7686c if(icou1.lt.0)return
7687* ROTATE THE MOMENTA OF PARTICLES IN THE CMS OF P1+P2
7688 CALL ROTATE(PX,PY,PZ,PX3,PY3,PZ3)
7689 CALL ROTATE(PX,PY,PZ,PX4,PY4,PZ4)
7690 CALL ROTATE(PX,PY,PZ,PPX,PPY,PPZ)
7691* FIND THE MOMENTUM OF PARTICLES IN THE FINAL STATE IN THE NUCLEUS-
7692* NUCLEUS CMS. FRAME
7693* (1) for the necleon/delta
7694* LORENTZ-TRANSFORMATION INTO LAB FRAME FOR DELTA1
7695 E1CM = SQRT (dm3**2 + PX3**2 + PY3**2 + PZ3**2)
7696 P1BETA = PX3*BETAX + PY3*BETAY + PZ3*BETAZ
7697 TRANSF = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) + E1CM )
7698 Pt1i1 = BETAX * TRANSF + PX3
7699 Pt2i1 = BETAY * TRANSF + PY3
7700 Pt3i1 = BETAZ * TRANSF + PZ3
7701 Eti1 = DM3
7702* (2) for the lambda/sigma
7703 E2CM = SQRT (dm4**2 + PX4**2 + PY4**2 + PZ4**2)
7704 P2BETA = PX4*BETAX+PY4*BETAY+PZ4*BETAZ
7705 TRANSF = GAMMA * (GAMMA*P2BETA / (GAMMA + 1.) + E2CM)
7706 Pt1I2 = BETAX * TRANSF + PX4
7707 Pt2I2 = BETAY * TRANSF + PY4
7708 Pt3I2 = BETAZ * TRANSF + PZ4
7709 EtI2 = DM4
7710* GET the kaon'S MOMENTUM AND COORDINATES IN NUCLEUS-NUCLEUS CMS. FRAME
7711 EPCM=SQRT(aka**2+PPX**2+PPY**2+PPZ**2)
7712 PPBETA=PPX*BETAX+PPY*BETAY+PPZ*BETAZ
7713 TRANSF=GAMMA*(GAMMA*PPBETA/(GAMMA+1.)+EPCM)
7714 PPION(1,NNN,IRUN)=BETAX*TRANSF+PPX
7715 PPION(2,NNN,IRUN)=BETAY*TRANSF+PPY
7716 PPION(3,NNN,IRUN)=BETAZ*TRANSF+PPZ
7717clin-5/2008:
7718 dppion(nnn,irun)=dpertp(i1)*dpertp(i2)
7719clin-5/2008:
7720c2008 X01 = 1.0 - 2.0 * RANART(NSEED)
7721c Y01 = 1.0 - 2.0 * RANART(NSEED)
7722c Z01 = 1.0 - 2.0 * RANART(NSEED)
7723c IF ((X01*X01+Y01*Y01+Z01*Z01) .GT. 1.0) GOTO 2008
7724c RPION(1,NNN,IRUN)=R(1,I1)+0.5*x01
7725c RPION(2,NNN,IRUN)=R(2,I1)+0.5*y01
7726c RPION(3,NNN,IRUN)=R(3,I1)+0.5*z01
7727 RPION(1,NNN,IRUN)=R(1,I1)
7728 RPION(2,NNN,IRUN)=R(2,I1)
7729 RPION(3,NNN,IRUN)=R(3,I1)
7730c
7731* assign the nucleon/delta and lambda/sigma to i1 or i2 to keep the
7732* leadng particle behaviour
7733C if((pt1i1*px1+pt2i1*py1+pt3i1*pz1).gt.0)then
7734 p(1,i1)=pt1i1
7735 p(2,i1)=pt2i1
7736 p(3,i1)=pt3i1
7737 e(i1)=eti1
7738 lb(i1)=lbi1
7739 p(1,i2)=pt1i2
7740 p(2,i2)=pt2i2
7741 p(3,i2)=pt3i2
7742 e(i2)=eti2
7743 lb(i2)=lbi2
7744 PX1 = P(1,I1)
7745 PY1 = P(2,I1)
7746 PZ1 = P(3,I1)
7747 EM1 = E(I1)
7748 ID(I1) = 2
7749 ID(I2) = 2
7750 ID1 = ID(I1)
7751 if(LPION(NNN,IRUN) .ne. 29) IBLOCK=11
7752 LB1=LB(I1)
7753 LB2=LB(I2)
7754 AM1=EM1
7755 am2=em2
7756 E1= SQRT( EM1**2 + PX1**2 + PY1**2 + PZ1**2 )
7757 RETURN
7758
7759clin-6/2008 N+D->Deuteron+pi:
7760* FIND MOMENTUM OF THE FINAL PARTICLES IN THE NUCLEUS-NUCLEUS CMS.
7761 108 CONTINUE
7762 if(idpert.eq.1.and.ipert1.eq.1.and.npertd.ge.1) then
7763c For idpert=1: we produce npertd pert deuterons:
7764 ndloop=npertd
7765 elseif(idpert.eq.2.and.npertd.ge.1) then
7766c For idpert=2: we first save information for npertd pert deuterons;
7767c at the last ndloop we create the regular deuteron+pi
7768c and those pert deuterons:
7769 ndloop=npertd+1
7770 else
7771c Just create the regular deuteron+pi:
7772 ndloop=1
7773 endif
7774c
7775 dprob1=sdprod/sig/float(npertd)
7776 do idloop=1,ndloop
7777 CALL bbdangle(pxd,pyd,pzd,nt,ipert1,ianti,idloop,pfinal,
7778 1 dprob1,lbm)
7779 CALL ROTATE(PX,PY,PZ,PXd,PYd,PZd)
7780* LORENTZ-TRANSFORMATION OF THE MOMENTUM OF PARTICLES IN THE FINAL STATE
7781* FROM THE NN CMS FRAME INTO THE GLOBAL CMS FRAME:
7782* For the Deuteron:
7783 xmass=xmd
7784 E1dCM=SQRT(xmass**2+PXd**2+PYd**2+PZd**2)
7785 P1dBETA=PXd*BETAX+PYd*BETAY+PZd*BETAZ
7786 TRANSF=GAMMA*(GAMMA*P1dBETA/(GAMMA+1.)+E1dCM)
7787 pxi1=BETAX*TRANSF+PXd
7788 pyi1=BETAY*TRANSF+PYd
7789 pzi1=BETAZ*TRANSF+PZd
7790 if(ianti.eq.0)then
7791 lbd=42
7792 else
7793 lbd=-42
7794 endif
7795 if(idpert.eq.1.and.ipert1.eq.1.and.npertd.ge.1) then
7796cccc Perturbative production for idpert=1:
7797 nnn=nnn+1
7798 PPION(1,NNN,IRUN)=pxi1
7799 PPION(2,NNN,IRUN)=pyi1
7800 PPION(3,NNN,IRUN)=pzi1
7801 EPION(NNN,IRUN)=xmd
7802 LPION(NNN,IRUN)=lbd
7803 RPION(1,NNN,IRUN)=R(1,I1)
7804 RPION(2,NNN,IRUN)=R(2,I1)
7805 RPION(3,NNN,IRUN)=R(3,I1)
7806clin-6/2008 assign the perturbative probability:
7807 dppion(NNN,IRUN)=sdprod/sig/float(npertd)
7808 elseif(idpert.eq.2.and.idloop.le.npertd) then
7809clin-6/2008 For idpert=2, we produce NPERTD perturbative (anti)deuterons
7810c only when a regular (anti)deuteron+pi is produced in NN collisions.
7811c First save the info for the perturbative deuterons:
7812 ppd(1,idloop)=pxi1
7813 ppd(2,idloop)=pyi1
7814 ppd(3,idloop)=pzi1
7815 lbpd(idloop)=lbd
7816 else
7817cccc Regular production:
7818c For the regular pion: do LORENTZ-TRANSFORMATION:
7819 E(i1)=xmm
7820 E2piCM=SQRT(xmm**2+PXd**2+PYd**2+PZd**2)
7821 P2piBETA=-PXd*BETAX-PYd*BETAY-PZd*BETAZ
7822 TRANSF=GAMMA*(GAMMA*P2piBETA/(GAMMA+1.)+E2piCM)
7823 pxi2=BETAX*TRANSF-PXd
7824 pyi2=BETAY*TRANSF-PYd
7825 pzi2=BETAZ*TRANSF-PZd
7826 p(1,i1)=pxi2
7827 p(2,i1)=pyi2
7828 p(3,i1)=pzi2
7829c Remove regular pion to check the equivalence
7830c between the perturbative and regular deuteron results:
7831c E(i1)=0.
7832c
7833 LB(I1)=lbm
7834 PX1=P(1,I1)
7835 PY1=P(2,I1)
7836 PZ1=P(3,I1)
7837 EM1=E(I1)
7838 ID(I1)=2
7839 ID1=ID(I1)
7840 E1=SQRT(EM1**2+PX1**2+PY1**2+PZ1**2)
7841 lb1=lb(i1)
7842c For the regular deuteron:
7843 p(1,i2)=pxi1
7844 p(2,i2)=pyi1
7845 p(3,i2)=pzi1
7846 lb(i2)=lbd
7847 lb2=lb(i2)
7848 E(i2)=xmd
7849 EtI2=E(I2)
7850 ID(I2)=2
7851c For idpert=2: create the perturbative deuterons:
7852 if(idpert.eq.2.and.idloop.eq.ndloop) then
7853 do ipertd=1,npertd
7854 nnn=nnn+1
7855 PPION(1,NNN,IRUN)=ppd(1,ipertd)
7856 PPION(2,NNN,IRUN)=ppd(2,ipertd)
7857 PPION(3,NNN,IRUN)=ppd(3,ipertd)
7858 EPION(NNN,IRUN)=xmd
7859 LPION(NNN,IRUN)=lbpd(ipertd)
7860 RPION(1,NNN,IRUN)=R(1,I1)
7861 RPION(2,NNN,IRUN)=R(2,I1)
7862 RPION(3,NNN,IRUN)=R(3,I1)
7863clin-6/2008 assign the perturbative probability:
7864 dppion(NNN,IRUN)=1./float(npertd)
7865 enddo
7866 endif
7867 endif
7868 enddo
7869 IBLOCK=501
7870 return
7871clin-6/2008 N+D->Deuteron+pi over
7872
7873 END
7874**********************************
7875* *
7876* *
7877 SUBROUTINE CRDD(IRUN,PX,PY,PZ,SRT,I1,I2,IBLOCK,
7878 1NTAG,SIGNN,SIG,NT,ipert1)
7879c 1NTAG,SIGNN,SIG)
7880* PURPOSE: *
7881* DEALING WITH BARYON RESONANCE-BARYON RESONANCE COLLISIONS*
7882* NOTE : *
7883* QUANTITIES: *
7884* PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
7885* SRT - SQRT OF S *
7886* NSTAR =1 INCLUDING N* RESORANCE,ELSE NOT *
7887* NDIRCT=1 INCLUDING DIRECT PION PRODUCTION PROCESS *
7888* IBLOCK - THE INFORMATION BACK *
7889* 0-> COLLISION CANNOT HAPPEN *
7890* 1-> N-N ELASTIC COLLISION *
7891* 2-> N+N->N+DELTA,OR N+N->N+N* REACTION *
7892* 3-> N+DELTA->N+N OR N+N*->N+N REACTION *
7893* 4-> N+N->N+N+PION,DIRTCT PROCESS *
7894* 5-> DELTA(N*)+DELTA(N*) TOTAL COLLISIONS *
7895* N12 - IS USED TO SPECIFY BARYON-BARYON REACTION *
7896* CHANNELS. M12 IS THE REVERSAL CHANNEL OF N12 *
7897* N12, *
7898* M12=1 FOR p+n-->delta(+)+ n *
7899* 2 p+n-->delta(0)+ p *
7900* 3 p+p-->delta(++)+n *
7901* 4 p+p-->delta(+)+p *
7902* 5 n+n-->delta(0)+n *
7903* 6 n+n-->delta(-)+p *
7904* 7 n+p-->N*(0)(1440)+p *
7905* 8 n+p-->N*(+)(1440)+n *
7906* 9 p+p-->N*(+)(1535)+p *
7907* 10 n+n-->N*(0)(1535)+n *
7908* 11 n+p-->N*(+)(1535)+n *
7909* 12 n+p-->N*(0)(1535)+p
7910* 13 D(++)+D(-)-->N*(+)(1440)+n
7911* 14 D(++)+D(-)-->N*(0)(1440)+p
7912* 15 D(+)+D(0)--->N*(+)(1440)+n
7913* 16 D(+)+D(0)--->N*(0)(1440)+p
7914* 17 D(++)+D(0)-->N*(+)(1535)+p
7915* 18 D(++)+D(-)-->N*(0)(1535)+p
7916* 19 D(++)+D(-)-->N*(+)(1535)+n
7917* 20 D(+)+D(+)-->N*(+)(1535)+p
7918* 21 D(+)+D(0)-->N*(+)(1535)+n
7919* 22 D(+)+D(0)-->N*(0)(1535)+p
7920* 23 D(+)+D(-)-->N*(0)(1535)+n
7921* 24 D(0)+D(0)-->N*(0)(1535)+n
7922* 25 N*(+)(14)+N*(+)(14)-->N*(+)(15)+p
7923* 26 N*(0)(14)+N*(0)(14)-->N*(0)(15)+n
7924* 27 N*(+)(14)+N*(0)(14)-->N*(+)(15)+n
7925* 28 N*(+)(14)+N*(0)(14)-->N*(0)(15)+p
7926* 29 N*(+)(14)+D+-->N*(+)(15)+p
7927* 30 N*(+)(14)+D0-->N*(+)(15)+n
7928* 31 N*(+)(14)+D(-)-->N*(0)(1535)+n
7929* 32 N*(0)(14)+D++--->N*(+)(15)+p
7930* 33 N*(0)(14)+D+--->N*(+)(15)+n
7931* 34 N*(0)(14)+D+--->N*(0)(15)+p
7932* 35 N*(0)(14)+D0-->N*(0)(15)+n
7933* 36 N*(+)(14)+D0--->N*(0)(15)+p
7934* +++
7935* AND MORE CHANNELS AS LISTED IN THE NOTE BOOK
7936*
7937* NOTE ABOUT N*(1440) RESORANCE: *
7938* As it has been discussed in VerWest's paper,I= 1 (initial isospin)
7939* channel can all be attributed to delta resorance while I= 0 *
7940* channel can all be attribured to N* resorance.Only in n+p *
7941* one can have I=0 channel so is the N*(1440) resorance *
7942* REFERENCES: J. CUGNON ET AL., NUCL. PHYS. A352, 505 (1981) *
7943* Y. KITAZOE ET AL., PHYS. LETT. 166B, 35 (1986) *
7944* B. VerWest el al., PHYS. PRV. C25 (1982)1979 *
7945* Gy. Wolf et al, Nucl Phys A517 (1990) 615 *
7946* CUTOFF = 2 * AVMASS + 20 MEV *
7947* *
7948* for N*(1535) we use the parameterization by Gy. Wolf et al *
7949* Nucl phys A552 (1993) 349, added May 18, 1994 *
7950**********************************
7951 PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
7952 1 AMP=0.93828,AP1=0.13496,AKA=0.498,APHI=1.020,
7953 2 AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
7954 parameter (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
7955 parameter (xmd=1.8756,npdmax=10000)
7956 COMMON /AA/ R(3,MAXSTR)
7957cc SAVE /AA/
7958 COMMON /BB/ P(3,MAXSTR)
7959cc SAVE /BB/
7960 COMMON /CC/ E(MAXSTR)
7961cc SAVE /CC/
7962 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
7963cc SAVE /EE/
7964 common /ff/f(-mx:mx,-my:my,-mz:mz,-mpx:mpx,-mpy:mpy,-mpz:mpzp)
7965cc SAVE /ff/
7966 common /gg/ dx,dy,dz,dpx,dpy,dpz
7967cc SAVE /gg/
7968 COMMON /INPUT/ NSTAR,NDIRCT,DIR
7969cc SAVE /INPUT/
7970 COMMON /NN/NNN
7971cc SAVE /NN/
7972 COMMON /BG/BETAX,BETAY,BETAZ,GAMMA
7973cc SAVE /BG/
7974 COMMON /RUN/NUM
7975cc SAVE /RUN/
7976 COMMON /PA/RPION(3,MAXSTR,MAXR)
7977cc SAVE /PA/
7978 COMMON /PB/PPION(3,MAXSTR,MAXR)
7979cc SAVE /PB/
7980 COMMON /PC/EPION(MAXSTR,MAXR)
7981cc SAVE /PC/
7982 COMMON /PD/LPION(MAXSTR,MAXR)
7983cc SAVE /PD/
7984 common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
7985cc SAVE /input1/
7986 common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
7987 1 px1n,py1n,pz1n,dp1n
7988cc SAVE /leadng/
7989 COMMON/RNDF77/NSEED
7990cc SAVE /RNDF77/
7991 COMMON /dpert/dpertt(MAXSTR,MAXR),dpertp(MAXSTR),dplast(MAXSTR),
7992 1 dpdcy(MAXSTR),dpdpi(MAXSTR,MAXR),dpt(MAXSTR, MAXR),
7993 2 dpp1(MAXSTR,MAXR),dppion(MAXSTR,MAXR)
7994 common /dpi/em2,lb2
7995 common /para8/ idpert,npertd,idxsec
7996 dimension ppd(3,npdmax),lbpd(npdmax)
7997 SAVE
7998*-----------------------------------------------------------------------
7999 n12=0
8000 m12=0
8001 IBLOCK=0
8002 NTAG=0
8003 EM1=E(I1)
8004 EM2=E(I2)
8005 PR = SQRT( PX**2 + PY**2 + PZ**2 )
8006 C2 = PZ / PR
8007 IF(PX .EQ. 0.0 .AND. PY .EQ. 0.0) THEN
8008 T2 = 0.0
8009 ELSE
8010 T2=ATAN2(PY,PX)
8011 END IF
8012 X1 = RANART(NSEED)
8013 ianti=0
8014 if(lb(i1).lt.0 .and. lb(i2).lt.0)ianti=1
8015
8016clin-6/2008 Production of perturbative deuterons for idpert=1:
8017 call sbbdm(srt,sdprod,ianti,lbm,xmm,pfinal)
8018 if(idpert.eq.1.and.ipert1.eq.1) then
8019 IF (SRT .LT. 2.012) RETURN
8020 if((iabs(lb(i1)).ge.6.and.iabs(lb(i1)).le.13)
8021 1 .and.(iabs(lb(i2)).ge.6.and.iabs(lb(i2)).le.13)) then
8022 goto 108
8023 else
8024 return
8025 endif
8026 endif
8027
8028*-----------------------------------------------------------------------
8029*COM: TEST FOR ELASTIC SCATTERING (EITHER N-N OR DELTA-DELTA 0R
8030* N-DELTA OR N*-N* or N*-Delta)
8031 IF (X1 .LE. SIGNN/SIG) THEN
8032*COM: PARAMETRISATION IS TAKEN FROM THE CUGNON-PAPER
8033 AS = ( 3.65 * (SRT - 1.8766) )**6
8034 A = 6.0 * AS / (1.0 + AS)
8035 TA = -2.0 * PR**2
8036 X = RANART(NSEED)
8037clin-10/24/02 T1 = DLOG( (1-X) * DEXP(dble(A)*dble(TA)) + X ) / A
8038 T1 = sngl(DLOG(dble(1.-X)*DEXP(dble(A)*dble(TA))+dble(X)))/ A
8039 C1 = 1.0 - T1/TA
8040 T1 = 2.0 * PI * RANART(NSEED)
8041 IBLOCK=20
8042 GO TO 107
8043 ELSE
8044*COM: TEST FOR INELASTIC SCATTERING
8045* IF THE AVAILABLE ENERGY IS LESS THAN THE PION-MASS, NOTHING
8046* CAN HAPPEN ANY MORE ==> RETURN (2.15 = 2*AVMASS +2*PI-MASS)
8047 IF (SRT .LT. 2.15) RETURN
8048* IF THERE WERE 2 N*(1535) AND THEY DIDN'T SCATT. ELAST.,
8049* ALLOW THEM TO PRODUCE KAONS. NO OTHER INELASTIC CHANNELS
8050* ARE KNOWN
8051C if((lb(i1).ge.12).and.(lb(i2).ge.12))return
8052* ALL the inelastic collisions between N*(1535) and Delta as well
8053* as N*(1440) TO PRODUCE KAONS, NO OTHER CHANNELS ARE KNOWN
8054C if((lb(i1).ge.12).and.(lb(i2).ge.3))return
8055C if((lb(i2).ge.12).and.(lb(i1).ge.3))return
8056* calculate the N*(1535) production cross section in I1+I2 collisions
8057 call N1535(iabs(lb(i1)),iabs(lb(i2)),srt,X1535)
8058
8059* for Delta+Delta-->N*(1440 OR 1535)+N AND N*(1440)+N*(1440)-->N*(1535)+X
8060* AND DELTA+N*(1440)-->N*(1535)+X
8061* WE ASSUME THEY HAVE THE SAME CROSS SECTIONS as CORRESPONDING N+N COLLISION):
8062* FOR D++D0, D+D+,D+D-,D0D0,N*+N*+,N*0N*0,N*(+)D+,N*(+)D(-),N*(0)D(0)
8063* N*(1535) production, kaon production and reabsorption through
8064* D(N*)+D(N*)-->NN are ALLOWED.
8065* CROSS SECTION FOR KAON PRODUCTION from the four channels are
8066* for NLK channel
8067 akp=0.498
8068 ak0=0.498
8069 ana=0.938
8070 ada=1.232
8071 al=1.1157
8072 as=1.1197
8073 xsk1=0
8074 xsk2=0
8075 xsk3=0
8076 xsk4=0
8077 xsk5=0
8078 t1nlk=ana+al+akp
8079 if(srt.le.t1nlk)go to 222
8080 XSK1=1.5*PPLPK(SRT)
8081* for DLK channel
8082 t1dlk=ada+al+akp
8083 t2dlk=ada+al-akp
8084 if(srt.le.t1dlk)go to 222
8085 es=srt
8086 pmdlk2=(es**2-t1dlk**2)*(es**2-t2dlk**2)/(4.*es**2)
8087 pmdlk=sqrt(pmdlk2)
8088 XSK3=1.5*PPLPK(srt)
8089* for NSK channel
8090 t1nsk=ana+as+akp
8091 t2nsk=ana+as-akp
8092 if(srt.le.t1nsk)go to 222
8093 pmnsk2=(es**2-t1nsk**2)*(es**2-t2nsk**2)/(4.*es**2)
8094 pmnsk=sqrt(pmnsk2)
8095 XSK2=1.5*(PPK1(srt)+PPK0(srt))
8096* for DSK channel
8097 t1DSk=aDa+aS+akp
8098 t2DSk=aDa+aS-akp
8099 if(srt.le.t1dsk)go to 222
8100 pmDSk2=(es**2-t1DSk**2)*(es**2-t2DSk**2)/(4.*es**2)
8101 pmDSk=sqrt(pmDSk2)
8102 XSK4=1.5*(PPK1(srt)+PPK0(srt))
8103csp11/21/01
8104c phi production
8105 if(srt.le.(2.*amn+aphi))go to 222
8106c !! mb put the correct form
8107 xsk5 = 0.0001
8108csp11/21/01 end
8109* THE TOTAL KAON+ PRODUCTION CROSS SECTION IS THEN
8110222 SIGK=XSK1+XSK2+XSK3+XSK4
8111
8112cbz3/7/99 neutralk
8113 XSK1 = 2.0 * XSK1
8114 XSK2 = 2.0 * XSK2
8115 XSK3 = 2.0 * XSK3
8116 XSK4 = 2.0 * XSK4
8117 SIGK = 2.0 * SIGK + xsk5
8118cbz3/7/99 neutralk end
8119
8120* The reabsorption cross section for the process
8121* D(N*)D(N*)-->NN is
8122 s2d=reab2d(i1,i2,srt)
8123
8124cbz3/16/99 pion
8125 S2D = 0.
8126cbz3/16/99 pion end
8127
8128*(1) N*(1535)+D(N*(1440)) reactions
8129* we allow kaon production and reabsorption only
8130 if(((iabs(lb(i1)).ge.12).and.(iabs(lb(i2)).ge.12)).OR.
8131 & ((iabs(lb(i1)).ge.12).and.(iabs(lb(i2)).ge.6)).OR.
8132 & ((iabs(lb(i2)).ge.12).and.(iabs(lb(i1)).ge.6)))THEN
8133 signd=sigk+s2d
8134clin-6/2008
8135 IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
8136c if(x1.gt.(signd+signn)/sig)return
8137 if(x1.gt.(signd+signn+sdprod)/sig)return
8138c
8139* if kaon production
8140clin-6/2008
8141c IF(SIGK/SIG.GE.RANART(NSEED))GO TO 306
8142 IF((SIGK+sdprod)/SIG.GE.RANART(NSEED))GO TO 306
8143c
8144* if reabsorption
8145 go to 1012
8146 ENDIF
8147 IDD=iabs(LB(I1)*LB(I2))
8148* channels have the same charge as pp
8149 IF((IDD.EQ.63).OR.(IDD.EQ.64).OR.(IDD.EQ.48).
8150 1 OR.(IDD.EQ.49).OR.(IDD.EQ.11*11).OR.(IDD.EQ.10*10).
8151 2 OR.(IDD.EQ.88).OR.(IDD.EQ.66).
8152 3 OR.(IDD.EQ.90).OR.(IDD.EQ.70))THEN
8153 SIGND=X1535+SIGK+s2d
8154clin-6/2008
8155 IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
8156c IF (X1.GT.(SIGNN+SIGND)/SIG)RETURN
8157 IF (X1.GT.(SIGNN+SIGND+sdprod)/SIG)RETURN
8158c
8159* if kaon production
8160 IF(SIGK/SIGND.GT.RANART(NSEED))GO TO 306
8161* if reabsorption
8162 if(s2d/(x1535+s2d).gt.RANART(NSEED))go to 1012
8163* if N*(1535) production
8164 IF(IDD.EQ.63)N12=17
8165 IF(IDD.EQ.64)N12=20
8166 IF(IDD.EQ.48)N12=23
8167 IF(IDD.EQ.49)N12=24
8168 IF(IDD.EQ.121)N12=25
8169 IF(IDD.EQ.100)N12=26
8170 IF(IDD.EQ.88)N12=29
8171 IF(IDD.EQ.66)N12=31
8172 IF(IDD.EQ.90)N12=32
8173 IF(IDD.EQ.70)N12=35
8174 GO TO 1011
8175 ENDIF
8176* IN DELTA+N*(1440) and N*(1440)+N*(1440) COLLISIONS,
8177* N*(1535), kaon production and reabsorption are ALLOWED
8178* IN N*(1440)+N*(1440) COLLISIONS, ONLY N*(1535) IS ALLOWED
8179 IF((IDD.EQ.110).OR.(IDD.EQ.77).OR.(IDD.EQ.80))THEN
8180clin-6/2008
8181 IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
8182c IF(X1.GT.(SIGNN+X1535+SIGK+s2d)/SIG)RETURN
8183 IF(X1.GT.(SIGNN+X1535+SIGK+s2d+sdprod)/SIG)RETURN
8184c
8185 IF(SIGK/(X1535+SIGK+s2d).GT.RANART(NSEED))GO TO 306
8186 if(s2d/(x1535+s2d).gt.RANART(NSEED))go to 1012
8187 IF(IDD.EQ.77)N12=30
8188 IF((IDD.EQ.77).AND.(RANART(NSEED).LE.0.5))N12=36
8189 IF(IDD.EQ.80)N12=34
8190 IF((IDD.EQ.80).AND.(RANART(NSEED).LE.0.5))N12=35
8191 IF(IDD.EQ.110)N12=27
8192 IF((IDD.EQ.110).AND.(RANART(NSEED).LE.0.5))N12=28
8193 GO TO 1011
8194 ENDIF
8195 IF((IDD.EQ.54).OR.(IDD.EQ.56))THEN
8196* LIKE FOR N+P COLLISION,
8197* IN DELTA+DELTA COLLISIONS BOTH N*(1440) AND N*(1535) CAN BE PRODUCED
8198 SIG2=(3./4.)*SIGMA(SRT,2,0,1)
8199 SIGND=2.*(SIG2+X1535)+SIGK+s2d
8200clin-6/2008
8201 IF(X1.LE.((SIGNN+sdprod)/SIG)) GO TO 108
8202c IF(X1.GT.(SIGNN+SIGND)/SIG)RETURN
8203 IF(X1.GT.(SIGNN+SIGND+sdprod)/SIG)RETURN
8204c
8205 IF(SIGK/SIGND.GT.RANART(NSEED))GO TO 306
8206 if(s2d/(2.*(sig2+x1535)+s2d).gt.RANART(NSEED))go to 1012
8207 IF(RANART(NSEED).LT.X1535/(SIG2+X1535))THEN
8208* N*(1535) PRODUCTION
8209 IF(IDD.EQ.54)N12=18
8210 IF((IDD.EQ.54).AND.(RANART(NSEED).LE.0.5))N12=19
8211 IF(IDD.EQ.56)N12=21
8212 IF((IDD.EQ.56).AND.(RANART(NSEED).LE.0.5))N12=22
8213 ELSE
8214* N*(144) PRODUCTION
8215 IF(IDD.EQ.54)N12=13
8216 IF((IDD.EQ.54).AND.(RANART(NSEED).LE.0.5))N12=14
8217 IF(IDD.EQ.56)N12=15
8218 IF((IDD.EQ.56).AND.(RANART(NSEED).LE.0.5))N12=16
8219 ENDIF
8220 ENDIF
82211011 CONTINUE
8222 iblock=5
8223*PARAMETRIZATION OF THE SHAPE OF THE N*(1440) AND N*(1535)
8224* RESONANCE ACCORDING
8225* TO kitazoe's or J.D.JACKSON'S MASS FORMULA AND BREIT WIGNER
8226* FORMULA FOR N* RESORANCE
8227* DETERMINE DELTA MASS VIA REJECTION METHOD.
8228 DMAX = SRT - AVMASS-0.005
8229 DMIN = 1.078
8230 IF((n12.ge.13).and.(n12.le.16))then
8231* N*(1440) production
8232 IF(DMAX.LT.1.44) THEN
8233 FM=FNS(DMAX,SRT,0.)
8234 ELSE
8235
8236clin-10/25/02 get rid of argument usage mismatch in FNS():
8237 xdmass=1.44
8238c FM=FNS(1.44,SRT,1.)
8239 FM=FNS(xdmass,SRT,1.)
8240clin-10/25/02-end
8241
8242 ENDIF
8243 IF(FM.EQ.0.)FM=1.E-09
8244 NTRY2=0
824511 DM=RANART(NSEED)*(DMAX-DMIN)+DMIN
8246 NTRY2=NTRY2+1
8247 IF((RANART(NSEED).GT.FNS(DM,SRT,1.)/FM).AND.
8248 1 (NTRY2.LE.10)) GO TO 11
8249
8250clin-2/26/03 limit the N* mass below a certain value
8251c (here taken as its central value + 2* B-W fullwidth):
8252 if(dm.gt.2.14) goto 11
8253
8254 GO TO 13
8255 ENDIF
8256 IF((n12.ge.17).AND.(N12.LE.36))then
8257* N*(1535) production
8258 IF(DMAX.LT.1.535) THEN
8259 FM=FD5(DMAX,SRT,0.)
8260 ELSE
8261
8262clin-10/25/02 get rid of argument usage mismatch in FNS():
8263 xdmass=1.535
8264c FM=FD5(1.535,SRT,1.)
8265 FM=FD5(xdmass,SRT,1.)
8266clin-10/25/02-end
8267
8268 ENDIF
8269 IF(FM.EQ.0.)FM=1.E-09
8270 NTRY1=0
827112 DM = RANART(NSEED) * (DMAX-DMIN) + DMIN
8272 NTRY1=NTRY1+1
8273 IF((RANART(NSEED) .GT. FD5(DM,SRT,1.)/FM).AND.
8274 1 (NTRY1.LE.10)) GOTO 12
8275
8276clin-2/26/03 limit the N* mass below a certain value
8277c (here taken as its central value + 2* B-W fullwidth):
8278 if(dm.gt.1.84) goto 12
8279
8280 ENDIF
828113 CONTINUE
8282*-------------------------------------------------------
8283* RELABLE BARYON I1 AND I2
8284*13 D(++)+D(-)--> N*(+)(14)+n
8285 IF(N12.EQ.13)THEN
8286 IF(RANART(NSEED).LE.0.5)THEN
8287 LB(I2)=11
8288 E(I2)=DM
8289 LB(I1)=2
8290 E(I1)=AMN
8291 ELSE
8292 LB(I1)=11
8293 E(I1)=DM
8294 LB(I2)=2
8295 E(I2)=AMN
8296 ENDIF
8297 go to 200
8298 ENDIF
8299*14 D(++)+D(-)--> N*(0)(14)+P
8300 IF(N12.EQ.14)THEN
8301 IF(RANART(NSEED).LE.0.5)THEN
8302 LB(I2)=10
8303 E(I2)=DM
8304 LB(I1)=1
8305 E(I1)=AMP
8306 ELSE
8307 LB(I1)=10
8308 E(I1)=DM
8309 LB(I2)=1
8310 E(I2)=AMP
8311 ENDIF
8312 go to 200
8313 ENDIF
8314*15 D(+)+D(0)--> N*(+)(14)+n
8315 IF(N12.EQ.15)THEN
8316 IF(RANART(NSEED).LE.0.5)THEN
8317 LB(I2)=11
8318 E(I2)=DM
8319 LB(I1)=2
8320 E(I1)=AMN
8321 ELSE
8322 LB(I1)=11
8323 E(I1)=DM
8324 LB(I2)=2
8325 E(I2)=AMN
8326 ENDIF
8327 go to 200
8328 ENDIF
8329*16 D(+)+D(0)--> N*(0)(14)+P
8330 IF(N12.EQ.16)THEN
8331 IF(RANART(NSEED).LE.0.5)THEN
8332 LB(I2)=10
8333 E(I2)=DM
8334 LB(I1)=1
8335 E(I1)=AMP
8336 ELSE
8337 LB(I1)=10
8338 E(I1)=DM
8339 LB(I2)=1
8340 E(I2)=AMP
8341 ENDIF
8342 go to 200
8343 ENDIF
8344*17 D(++)+D(0)--> N*(+)(14)+P
8345 IF(N12.EQ.17)THEN
8346 LB(I2)=13
8347 E(I2)=DM
8348 LB(I1)=1
8349 E(I1)=AMP
8350 go to 200
8351 ENDIF
8352*18 D(++)+D(-)--> N*(0)(15)+P
8353 IF(N12.EQ.18)THEN
8354 IF(RANART(NSEED).LE.0.5)THEN
8355 LB(I2)=12
8356 E(I2)=DM
8357 LB(I1)=1
8358 E(I1)=AMP
8359 ELSE
8360 LB(I1)=12
8361 E(I1)=DM
8362 LB(I2)=1
8363 E(I2)=AMP
8364 ENDIF
8365 go to 200
8366 ENDIF
8367*19 D(++)+D(-)--> N*(+)(15)+N
8368 IF(N12.EQ.19)THEN
8369 IF(RANART(NSEED).LE.0.5)THEN
8370 LB(I2)=13
8371 E(I2)=DM
8372 LB(I1)=2
8373 E(I1)=AMN
8374 ELSE
8375 LB(I1)=13
8376 E(I1)=DM
8377 LB(I2)=2
8378 E(I2)=AMN
8379 ENDIF
8380 go to 200
8381 ENDIF
8382*20 D(+)+D(+)--> N*(+)(15)+P
8383 IF(N12.EQ.20)THEN
8384 IF(RANART(NSEED).LE.0.5)THEN
8385 LB(I2)=13
8386 E(I2)=DM
8387 LB(I1)=1
8388 E(I1)=AMP
8389 ELSE
8390 LB(I1)=13
8391 E(I1)=DM
8392 LB(I2)=1
8393 E(I2)=AMP
8394 ENDIF
8395 go to 200
8396 ENDIF
8397*21 D(+)+D(0)--> N*(+)(15)+N
8398 IF(N12.EQ.21)THEN
8399 IF(RANART(NSEED).LE.0.5)THEN
8400 LB(I2)=13
8401 E(I2)=DM
8402 LB(I1)=2
8403 E(I1)=AMN
8404 ELSE
8405 LB(I1)=13
8406 E(I1)=DM
8407 LB(I2)=2
8408 E(I2)=AMN
8409 ENDIF
8410 go to 200
8411 ENDIF
8412*22 D(+)+D(0)--> N*(0)(15)+P
8413 IF(N12.EQ.22)THEN
8414 IF(RANART(NSEED).LE.0.5)THEN
8415 LB(I2)=12
8416 E(I2)=DM
8417 LB(I1)=1
8418 E(I1)=AMP
8419 ELSE
8420 LB(I1)=12
8421 E(I1)=DM
8422 LB(I2)=1
8423 E(I2)=AMP
8424 ENDIF
8425 go to 200
8426 ENDIF
8427*23 D(+)+D(-)--> N*(0)(15)+N
8428 IF(N12.EQ.23)THEN
8429 IF(RANART(NSEED).LE.0.5)THEN
8430 LB(I2)=12
8431 E(I2)=DM
8432 LB(I1)=2
8433 E(I1)=AMN
8434 ELSE
8435 LB(I1)=12
8436 E(I1)=DM
8437 LB(I2)=2
8438 E(I2)=AMN
8439 ENDIF
8440 go to 200
8441 ENDIF
8442*24 D(0)+D(0)--> N*(0)(15)+N
8443 IF(N12.EQ.24)THEN
8444 LB(I2)=12
8445 E(I2)=DM
8446 LB(I1)=2
8447 E(I1)=AMN
8448 go to 200
8449 ENDIF
8450*25 N*(+)+N*(+)--> N*(0)(15)+P
8451 IF(N12.EQ.25)THEN
8452 LB(I2)=12
8453 E(I2)=DM
8454 LB(I1)=1
8455 E(I1)=AMP
8456 go to 200
8457 ENDIF
8458*26 N*(0)+N*(0)--> N*(0)(15)+N
8459 IF(N12.EQ.26)THEN
8460 LB(I2)=12
8461 E(I2)=DM
8462 LB(I1)=2
8463 E(I1)=AMN
8464 go to 200
8465 ENDIF
8466*27 N*(+)+N*(0)--> N*(+)(15)+N
8467 IF(N12.EQ.27)THEN
8468 IF(RANART(NSEED).LE.0.5)THEN
8469 LB(I2)=13
8470 E(I2)=DM
8471 LB(I1)=2
8472 E(I1)=AMN
8473 ELSE
8474 LB(I1)=13
8475 E(I1)=DM
8476 LB(I2)=2
8477 E(I2)=AMN
8478 ENDIF
8479 go to 200
8480 ENDIF
8481*28 N*(+)+N*(0)--> N*(0)(15)+P
8482 IF(N12.EQ.28)THEN
8483 IF(RANART(NSEED).LE.0.5)THEN
8484 LB(I2)=12
8485 E(I2)=DM
8486 LB(I1)=1
8487 E(I1)=AMP
8488 ELSE
8489 LB(I1)=12
8490 E(I1)=DM
8491 LB(I2)=1
8492 E(I2)=AMP
8493 ENDIF
8494 go to 200
8495 ENDIF
8496*27 N*(+)+N*(0)--> N*(+)(15)+N
8497 IF(N12.EQ.27)THEN
8498 IF(RANART(NSEED).LE.0.5)THEN
8499 LB(I2)=13
8500 E(I2)=DM
8501 LB(I1)=2
8502 E(I1)=AMN
8503 ELSE
8504 LB(I1)=13
8505 E(I1)=DM
8506 LB(I2)=2
8507 E(I2)=AMN
8508 ENDIF
8509 go to 200
8510 ENDIF
8511*29 N*(+)+D(+)--> N*(+)(15)+P
8512 IF(N12.EQ.29)THEN
8513 IF(RANART(NSEED).LE.0.5)THEN
8514 LB(I2)=13
8515 E(I2)=DM
8516 LB(I1)=1
8517 E(I1)=AMP
8518 ELSE
8519 LB(I1)=13
8520 E(I1)=DM
8521 LB(I2)=1
8522 E(I2)=AMP
8523 ENDIF
8524 go to 200
8525 ENDIF
8526*30 N*(+)+D(0)--> N*(+)(15)+N
8527 IF(N12.EQ.30)THEN
8528 IF(RANART(NSEED).LE.0.5)THEN
8529 LB(I2)=13
8530 E(I2)=DM
8531 LB(I1)=2
8532 E(I1)=AMN
8533 ELSE
8534 LB(I1)=13
8535 E(I1)=DM
8536 LB(I2)=2
8537 E(I2)=AMN
8538 ENDIF
8539 go to 200
8540 ENDIF
8541*31 N*(+)+D(-)--> N*(0)(15)+N
8542 IF(N12.EQ.31)THEN
8543 IF(RANART(NSEED).LE.0.5)THEN
8544 LB(I2)=12
8545 E(I2)=DM
8546 LB(I1)=2
8547 E(I1)=AMN
8548 ELSE
8549 LB(I1)=12
8550 E(I1)=DM
8551 LB(I2)=2
8552 E(I2)=AMN
8553 ENDIF
8554 go to 200
8555 ENDIF
8556*32 N*(0)+D(++)--> N*(+)(15)+P
8557 IF(N12.EQ.32)THEN
8558 IF(RANART(NSEED).LE.0.5)THEN
8559 LB(I2)=13
8560 E(I2)=DM
8561 LB(I1)=1
8562 E(I1)=AMP
8563 ELSE
8564 LB(I1)=13
8565 E(I1)=DM
8566 LB(I2)=1
8567 E(I2)=AMP
8568 ENDIF
8569 go to 200
8570 ENDIF
8571*33 N*(0)+D(+)--> N*(+)(15)+N
8572 IF(N12.EQ.33)THEN
8573 IF(RANART(NSEED).LE.0.5)THEN
8574 LB(I2)=13
8575 E(I2)=DM
8576 LB(I1)=2
8577 E(I1)=AMN
8578 ELSE
8579 LB(I1)=13
8580 E(I1)=DM
8581 LB(I2)=2
8582 E(I2)=AMN
8583 ENDIF
8584 go to 200
8585 ENDIF
8586*34 N*(0)+D(+)--> N*(0)(15)+P
8587 IF(N12.EQ.34)THEN
8588 IF(RANART(NSEED).LE.0.5)THEN
8589 LB(I2)=12
8590 E(I2)=DM
8591 LB(I1)=1
8592 E(I1)=AMP
8593 ELSE
8594 LB(I1)=12
8595 E(I1)=DM
8596 LB(I2)=1
8597 E(I2)=AMP
8598 ENDIF
8599 go to 200
8600 ENDIF
8601*35 N*(0)+D(0)--> N*(0)(15)+N
8602 IF(N12.EQ.35)THEN
8603 IF(RANART(NSEED).LE.0.5)THEN
8604 LB(I2)=12
8605 E(I2)=DM
8606 LB(I1)=2
8607 E(I1)=AMN
8608 ELSE
8609 LB(I1)=12
8610 E(I1)=DM
8611 LB(I2)=2
8612 E(I2)=AMN
8613 ENDIF
8614 go to 200
8615 ENDIF
8616*36 N*(+)+D(0)--> N*(0)(15)+P
8617 IF(N12.EQ.36)THEN
8618 IF(RANART(NSEED).LE.0.5)THEN
8619 LB(I2)=12
8620 E(I2)=DM
8621 LB(I1)=1
8622 E(I1)=AMP
8623 ELSE
8624 LB(I1)=12
8625 E(I1)=DM
8626 LB(I2)=1
8627 E(I2)=AMP
8628 ENDIF
8629 go to 200
8630 ENDIF
86311012 continue
8632 iblock=55
8633 lb1=lb(i1)
8634 lb2=lb(i2)
8635 ich=iabs(lb1*lb2)
8636*-------------------------------------------------------
8637* RELABLE BARYON I1 AND I2 in the reabsorption processes
8638*37 D(++)+D(-)--> n+p
8639 IF(ich.EQ.9*6)THEN
8640 IF(RANART(NSEED).LE.0.5)THEN
8641 LB(I2)=1
8642 E(I2)=amp
8643 LB(I1)=2
8644 E(I1)=AMN
8645 ELSE
8646 LB(I1)=1
8647 E(I1)=amp
8648 LB(I2)=2
8649 E(I2)=AMN
8650 ENDIF
8651 go to 200
8652 ENDIF
8653*38 D(+)+D(0)--> n+p
8654 IF(ich.EQ.8*7)THEN
8655 IF(RANART(NSEED).LE.0.5)THEN
8656 LB(I2)=1
8657 E(I2)=amp
8658 LB(I1)=2
8659 E(I1)=AMN
8660 ELSE
8661 LB(I1)=1
8662 E(I1)=amp
8663 LB(I2)=2
8664 E(I2)=AMN
8665 ENDIF
8666 go to 200
8667 ENDIF
8668*39 D(++)+D(0)--> p+p
8669 IF(ich.EQ.9*7)THEN
8670 LB(I2)=1
8671 E(I2)=amp
8672 LB(I1)=1
8673 E(I1)=AMP
8674 go to 200
8675 ENDIF
8676*40 D(+)+D(+)--> p+p
8677 IF(ich.EQ.8*8)THEN
8678 LB(I2)=1
8679 E(I2)=amp
8680 LB(I1)=1
8681 E(I1)=AMP
8682 go to 200
8683 ENDIF
8684*41 D(+)+D(-)--> n+n
8685 IF(ich.EQ.8*6)THEN
8686 LB(I2)=2
8687 E(I2)=amn
8688 LB(I1)=2
8689 E(I1)=AMN
8690 go to 200
8691 ENDIF
8692*42 D(0)+D(0)--> n+n
8693 IF(ich.EQ.6*6)THEN
8694 LB(I2)=2
8695 E(I2)=amn
8696 LB(I1)=2
8697 E(I1)=AMN
8698 go to 200
8699 ENDIF
8700*43 N*(+)+N*(+)--> p+p
8701 IF(ich.EQ.11*11.or.ich.eq.13*13.or.ich.eq.11*13)THEN
8702 LB(I2)=1
8703 E(I2)=amp
8704 LB(I1)=1
8705 E(I1)=AMP
8706 go to 200
8707 ENDIF
8708*44 N*(0)(1440)+N*(0)--> n+n
8709 IF(ich.EQ.10*10.or.ich.eq.12*12.or.ich.eq.10*12)THEN
8710 LB(I2)=2
8711 E(I2)=amn
8712 LB(I1)=2
8713 E(I1)=AMN
8714 go to 200
8715 ENDIF
8716*45 N*(+)+N*(0)--> n+p
8717 IF(ich.EQ.10*11.or.ich.eq.12*13.or.ich.
8718 & eq.10*13.or.ich.eq.11*12)THEN
8719 IF(RANART(NSEED).LE.0.5)THEN
8720 LB(I2)=1
8721 E(I2)=amp
8722 LB(I1)=2
8723 E(I1)=AMN
8724 ELSE
8725 LB(I1)=1
8726 E(I1)=amp
8727 LB(I2)=2
8728 E(I2)=AMN
8729 ENDIF
8730 go to 200
8731 ENDIF
8732*46 N*(+)+D(+)--> p+p
8733 IF(ich.eq.11*8.or.ich.eq.13*8)THEN
8734 LB(I2)=1
8735 E(I2)=amp
8736 LB(I1)=1
8737 E(I1)=AMP
8738 go to 200
8739 ENDIF
8740*47 N*(+)+D(0)--> n+p
8741 IF(ich.EQ.11*7.or.ich.eq.13*7)THEN
8742 IF(RANART(NSEED).LE.0.5)THEN
8743 LB(I2)=1
8744 E(I2)=amp
8745 LB(I1)=2
8746 E(I1)=AMN
8747 ELSE
8748 LB(I1)=1
8749 E(I1)=amp
8750 LB(I2)=2
8751 E(I2)=AMN
8752 ENDIF
8753 go to 200
8754 ENDIF
8755*48 N*(+)+D(-)--> n+n
8756 IF(ich.EQ.11*6.or.ich.eq.13*6)THEN
8757 LB(I2)=2
8758 E(I2)=amn
8759 LB(I1)=2
8760 E(I1)=AMN
8761 go to 200
8762 ENDIF
8763*49 N*(0)+D(++)--> p+p
8764 IF(ich.EQ.10*9.or.ich.eq.12*9)THEN
8765 LB(I2)=1
8766 E(I2)=amp
8767 LB(I1)=1
8768 E(I1)=AMP
8769 go to 200
8770 ENDIF
8771*50 N*(0)+D(0)--> n+n
8772 IF(ich.EQ.10*7.or.ich.eq.12*7)THEN
8773 LB(I2)=2
8774 E(I2)=amn
8775 LB(I1)=2
8776 E(I1)=AMN
8777 go to 200
8778 ENDIF
8779*51 N*(0)+D(+)--> n+p
8780 IF(ich.EQ.10*8.or.ich.eq.12*8)THEN
8781 IF(RANART(NSEED).LE.0.5)THEN
8782 LB(I2)=2
8783 E(I2)=amn
8784 LB(I1)=1
8785 E(I1)=AMP
8786 ELSE
8787 LB(I1)=2
8788 E(I1)=amn
8789 LB(I2)=1
8790 E(I2)=AMP
8791 ENDIF
8792 go to 200
8793 ENDIF
8794 lb(i1)=1
8795 e(i1)=amp
8796 lb(i2)=2
8797 e(i2)=amn
8798* CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
8799* ENERGY CONSERVATION
8800* resonance production or absorption in resonance+resonance collisions is
8801* assumed to have the same pt distribution as pp
8802200 EM1=E(I1)
8803 EM2=E(I2)
8804 PR2 = (SRT**2 - EM1**2 - EM2**2)**2
8805 1 - 4.0 * (EM1*EM2)**2
8806 IF(PR2.LE.0.)PR2=1.e-09
8807 PR=SQRT(PR2)/(2.*SRT)
8808 if(srt.le.2.14)C1= 1.0 - 2.0 * RANART(NSEED)
86c53b9e 8809 if(srt.gt.2.14.and.srt.le.2.4)c1=anga(srt,iseed)
0119ef9a 8810 if(srt.gt.2.4)then
8811
8812clin-10/25/02 get rid of argument usage mismatch in PTR():
8813 xptr=0.33*pr
8814c cc1=ptr(0.33*pr,iseed)
8815 cc1=ptr(xptr,iseed)
8816clin-10/25/02-end
8817
8818 c1=sqrt(pr**2-cc1**2)/pr
8819 endif
8820 T1 = 2.0 * PI * RANART(NSEED)
8821 if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
8822 lb(i1) = -lb(i1)
8823 lb(i2) = -lb(i2)
8824 endif
8825 ENDIF
8826*COM: SET THE NEW MOMENTUM COORDINATES
8827107 S1 = SQRT( 1.0 - C1**2 )
8828 S2 = SQRT( 1.0 - C2**2 )
8829 CT1 = COS(T1)
8830 ST1 = SIN(T1)
8831 CT2 = COS(T2)
8832 ST2 = SIN(T2)
8833 PZ = PR * ( C1*C2 - S1*S2*CT1 )
8834 SS = C2 * S1 * CT1 + S2 * C1
8835 PX = PR * ( SS*CT2 - S1*ST1*ST2 )
8836 PY = PR * ( SS*ST2 + S1*ST1*CT2 )
8837 RETURN
8838* FOR THE DD-->KAON+X PROCESS, FIND MOMENTUM OF THE FINAL PARTICLES IN
8839* THE NUCLEUS-NUCLEUS CMS.
8840306 CONTINUE
8841csp11/21/01 phi production
8842 if(XSK5/sigK.gt.RANART(NSEED))then
8843 pz1=p(3,i1)
8844 pz2=p(3,i2)
8845 LB(I1) = 1 + int(2 * RANART(NSEED))
8846 LB(I2) = 1 + int(2 * RANART(NSEED))
8847 nnn=nnn+1
8848 LPION(NNN,IRUN)=29
8849 EPION(NNN,IRUN)=APHI
8850 iblock = 222
8851 GO TO 208
8852 ENDIF
8853 iblock=10
8854 if(ianti .eq. 1)iblock=-10
8855 pz1=p(3,i1)
8856 pz2=p(3,i2)
8857* DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
8858 nnn=nnn+1
8859 LPION(NNN,IRUN)=23
8860 EPION(NNN,IRUN)=Aka
8861 if(srt.le.2.63)then
8862* only lambda production is possible
8863* (1.1)P+P-->p+L+kaon+
8864 ic=1
8865 LB(I1) = 1 + int(2 * RANART(NSEED))
8866 LB(I2)=14
8867 GO TO 208
8868 ENDIF
8869 if(srt.le.2.74.and.srt.gt.2.63)then
8870* both Lambda and sigma production are possible
8871 if(XSK1/(XSK1+XSK2).gt.RANART(NSEED))then
8872* lambda production
8873 ic=1
8874 LB(I1) = 1 + int(2 * RANART(NSEED))
8875 LB(I2)=14
8876 else
8877* sigma production
8878 LB(I1) = 1 + int(2 * RANART(NSEED))
8879 LB(I2) = 15 + int(3 * RANART(NSEED))
8880 ic=2
8881 endif
8882 GO TO 208
8883 endif
8884 if(srt.le.2.77.and.srt.gt.2.74)then
8885* then pp-->Delta lamda kaon can happen
8886 if(xsk1/(xsk1+xsk2+xsk3).gt.RANART(NSEED))then
8887* * (1.1)P+P-->p+L+kaon+
8888 ic=1
8889 LB(I1) = 1 + int(2 * RANART(NSEED))
8890 LB(I2)=14
8891 go to 208
8892 else
8893 if(xsk2/(xsk2+xsk3).gt.RANART(NSEED))then
8894* pp-->psk
8895 ic=2
8896 LB(I1) = 1 + int(2 * RANART(NSEED))
8897 LB(I2) = 15 + int(3 * RANART(NSEED))
8898 else
8899* pp-->D+l+k
8900 ic=3
8901 LB(I1) = 6 + int(4 * RANART(NSEED))
8902 lb(i2)=14
8903 endif
8904 GO TO 208
8905 endif
8906 endif
8907 if(srt.gt.2.77)then
8908* all four channels are possible
8909 if(xsk1/(xsk1+xsk2+xsk3+xsk4).gt.RANART(NSEED))then
8910* p lambda k production
8911 ic=1
8912 LB(I1) = 1 + int(2 * RANART(NSEED))
8913 LB(I2)=14
8914 go to 208
8915 else
8916 if(xsk3/(xsk2+xsk3+xsk4).gt.RANART(NSEED))then
8917* delta l K production
8918 ic=3
8919 LB(I1) = 6 + int(4 * RANART(NSEED))
8920 lb(i2)=14
8921 go to 208
8922 else
8923 if(xsk2/(xsk2+xsk4).gt.RANART(NSEED))then
8924* n sigma k production
8925 LB(I1) = 1 + int(2 * RANART(NSEED))
8926 LB(I2) = 15 + int(3 * RANART(NSEED))
8927 ic=2
8928 else
8929* D sigma K
8930 ic=4
8931 LB(I1) = 6 + int(4 * RANART(NSEED))
8932 LB(I2) = 15 + int(3 * RANART(NSEED))
8933 endif
8934 go to 208
8935 endif
8936 endif
8937 endif
8938208 continue
8939 if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
8940 lb(i1) = - lb(i1)
8941 lb(i2) = - lb(i2)
8942 if(LPION(NNN,IRUN) .eq. 23)LPION(NNN,IRUN)=21
8943 endif
8944 lbi1=lb(i1)
8945 lbi2=lb(i2)
8946* KEEP ALL COORDINATES OF PARTICLE 2 FOR POSSIBLE PHASE SPACE CHANGE
8947 NTRY1=0
8948129 CALL BBKAON(ic,SRT,PX3,PY3,PZ3,DM3,PX4,PY4,PZ4,DM4,
8949 & PPX,PPY,PPZ,icou1)
8950 NTRY1=NTRY1+1
8951 if((icou1.lt.0).AND.(NTRY1.LE.20))GO TO 129
8952c if(icou1.lt.0)return
8953* ROTATE THE MOMENTA OF PARTICLES IN THE CMS OF P1+P2
8954 CALL ROTATE(PX,PY,PZ,PX3,PY3,PZ3)
8955 CALL ROTATE(PX,PY,PZ,PX4,PY4,PZ4)
8956 CALL ROTATE(PX,PY,PZ,PPX,PPY,PPZ)
8957* FIND THE MOMENTUM OF PARTICLES IN THE FINAL STATE IN THE NUCLEUS-
8958* NUCLEUS CMS. FRAME
8959* (1) for the necleon/delta
8960* LORENTZ-TRANSFORMATION INTO LAB FRAME FOR DELTA1
8961 E1CM = SQRT (dm3**2 + PX3**2 + PY3**2 + PZ3**2)
8962 P1BETA = PX3*BETAX + PY3*BETAY + PZ3*BETAZ
8963 TRANSF = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) + E1CM )
8964 Pt1i1 = BETAX * TRANSF + PX3
8965 Pt2i1 = BETAY * TRANSF + PY3
8966 Pt3i1 = BETAZ * TRANSF + PZ3
8967 Eti1 = DM3
8968* (2) for the lambda/sigma
8969 E2CM = SQRT (dm4**2 + PX4**2 + PY4**2 + PZ4**2)
8970 P2BETA = PX4*BETAX+PY4*BETAY+PZ4*BETAZ
8971 TRANSF = GAMMA * (GAMMA*P2BETA / (GAMMA + 1.) + E2CM)
8972 Pt1I2 = BETAX * TRANSF + PX4
8973 Pt2I2 = BETAY * TRANSF + PY4
8974 Pt3I2 = BETAZ * TRANSF + PZ4
8975 EtI2 = DM4
8976* GET the kaon'S MOMENTUM AND COORDINATES IN NUCLEUS-NUCLEUS CMS. FRAME
8977 EPCM=SQRT(aka**2+PPX**2+PPY**2+PPZ**2)
8978 PPBETA=PPX*BETAX+PPY*BETAY+PPZ*BETAZ
8979 TRANSF=GAMMA*(GAMMA*PPBETA/(GAMMA+1.)+EPCM)
8980 PPION(1,NNN,IRUN)=BETAX*TRANSF+PPX
8981 PPION(2,NNN,IRUN)=BETAY*TRANSF+PPY
8982 PPION(3,NNN,IRUN)=BETAZ*TRANSF+PPZ
8983clin-5/2008:
8984 dppion(nnn,irun)=dpertp(i1)*dpertp(i2)
8985clin-5/2008:
8986c2007 X01 = 1.0 - 2.0 * RANART(NSEED)
8987c Y01 = 1.0 - 2.0 * RANART(NSEED)
8988c Z01 = 1.0 - 2.0 * RANART(NSEED)
8989c IF ((X01*X01+Y01*Y01+Z01*Z01) .GT. 1.0) GOTO 2007
8990c RPION(1,NNN,IRUN)=R(1,I1)+0.5*x01
8991c RPION(2,NNN,IRUN)=R(2,I1)+0.5*y01
8992c RPION(3,NNN,IRUN)=R(3,I1)+0.5*z01
8993 RPION(1,NNN,IRUN)=R(1,I1)
8994 RPION(2,NNN,IRUN)=R(2,I1)
8995 RPION(3,NNN,IRUN)=R(3,I1)
8996c
8997* assign the nucleon/delta and lambda/sigma to i1 or i2 to keep the
8998* leadng particle behaviour
8999C if((pt1i1*px1+pt2i1*py1+pt3i1*pz1).gt.0)then
9000 p(1,i1)=pt1i1
9001 p(2,i1)=pt2i1
9002 p(3,i1)=pt3i1
9003 e(i1)=eti1
9004 lb(i1)=lbi1
9005 p(1,i2)=pt1i2
9006 p(2,i2)=pt2i2
9007 p(3,i2)=pt3i2
9008 e(i2)=eti2
9009 lb(i2)=lbi2
9010 PX1 = P(1,I1)
9011 PY1 = P(2,I1)
9012 PZ1 = P(3,I1)
9013 EM1 = E(I1)
9014 ID(I1) = 2
9015 ID(I2) = 2
9016 ID1 = ID(I1)
9017 LB1=LB(I1)
9018 LB2=LB(I2)
9019 AM1=EM1
9020 am2=em2
9021 E1= SQRT( EM1**2 + PX1**2 + PY1**2 + PZ1**2 )
9022 RETURN
9023
9024clin-6/2008 D+D->Deuteron+pi:
9025* FIND MOMENTUM OF THE FINAL PARTICLES IN THE NUCLEUS-NUCLEUS CMS.
9026 108 CONTINUE
9027 if(idpert.eq.1.and.ipert1.eq.1.and.npertd.ge.1) then
9028c For idpert=1: we produce npertd pert deuterons:
9029 ndloop=npertd
9030 elseif(idpert.eq.2.and.npertd.ge.1) then
9031c For idpert=2: we first save information for npertd pert deuterons;
9032c at the last ndloop we create the regular deuteron+pi
9033c and those pert deuterons:
9034 ndloop=npertd+1
9035 else
9036c Just create the regular deuteron+pi:
9037 ndloop=1
9038 endif
9039c
9040 dprob1=sdprod/sig/float(npertd)
9041 do idloop=1,ndloop
9042 CALL bbdangle(pxd,pyd,pzd,nt,ipert1,ianti,idloop,pfinal,
9043 1 dprob1,lbm)
9044 CALL ROTATE(PX,PY,PZ,PXd,PYd,PZd)
9045* LORENTZ-TRANSFORMATION OF THE MOMENTUM OF PARTICLES IN THE FINAL STATE
9046* FROM THE NN CMS FRAME INTO THE GLOBAL CMS FRAME:
9047* For the Deuteron:
9048 xmass=xmd
9049 E1dCM=SQRT(xmass**2+PXd**2+PYd**2+PZd**2)
9050 P1dBETA=PXd*BETAX+PYd*BETAY+PZd*BETAZ
9051 TRANSF=GAMMA*(GAMMA*P1dBETA/(GAMMA+1.)+E1dCM)
9052 pxi1=BETAX*TRANSF+PXd
9053 pyi1=BETAY*TRANSF+PYd
9054 pzi1=BETAZ*TRANSF+PZd
9055 if(ianti.eq.0)then
9056 lbd=42
9057 else
9058 lbd=-42
9059 endif
9060 if(idpert.eq.1.and.ipert1.eq.1.and.npertd.ge.1) then
9061cccc Perturbative production for idpert=1:
9062 nnn=nnn+1
9063 PPION(1,NNN,IRUN)=pxi1
9064 PPION(2,NNN,IRUN)=pyi1
9065 PPION(3,NNN,IRUN)=pzi1
9066 EPION(NNN,IRUN)=xmd
9067 LPION(NNN,IRUN)=lbd
9068 RPION(1,NNN,IRUN)=R(1,I1)
9069 RPION(2,NNN,IRUN)=R(2,I1)
9070 RPION(3,NNN,IRUN)=R(3,I1)
9071clin-6/2008 assign the perturbative probability:
9072 dppion(NNN,IRUN)=sdprod/sig/float(npertd)
9073 elseif(idpert.eq.2.and.idloop.le.npertd) then
9074clin-6/2008 For idpert=2, we produce NPERTD perturbative (anti)deuterons
9075c only when a regular (anti)deuteron+pi is produced in NN collisions.
9076c First save the info for the perturbative deuterons:
9077 ppd(1,idloop)=pxi1
9078 ppd(2,idloop)=pyi1
9079 ppd(3,idloop)=pzi1
9080 lbpd(idloop)=lbd
9081 else
9082cccc Regular production:
9083c For the regular pion: do LORENTZ-TRANSFORMATION:
9084 E(i1)=xmm
9085 E2piCM=SQRT(xmm**2+PXd**2+PYd**2+PZd**2)
9086 P2piBETA=-PXd*BETAX-PYd*BETAY-PZd*BETAZ
9087 TRANSF=GAMMA*(GAMMA*P2piBETA/(GAMMA+1.)+E2piCM)
9088 pxi2=BETAX*TRANSF-PXd
9089 pyi2=BETAY*TRANSF-PYd
9090 pzi2=BETAZ*TRANSF-PZd
9091 p(1,i1)=pxi2
9092 p(2,i1)=pyi2
9093 p(3,i1)=pzi2
9094c Remove regular pion to check the equivalence
9095c between the perturbative and regular deuteron results:
9096c E(i1)=0.
9097c
9098 LB(I1)=lbm
9099 PX1=P(1,I1)
9100 PY1=P(2,I1)
9101 PZ1=P(3,I1)
9102 EM1=E(I1)
9103 ID(I1)=2
9104 ID1=ID(I1)
9105 E1=SQRT(EM1**2+PX1**2+PY1**2+PZ1**2)
9106 lb1=lb(i1)
9107c For the regular deuteron:
9108 p(1,i2)=pxi1
9109 p(2,i2)=pyi1
9110 p(3,i2)=pzi1
9111 lb(i2)=lbd
9112 lb2=lb(i2)
9113 E(i2)=xmd
9114 EtI2=E(I2)
9115 ID(I2)=2
9116c For idpert=2: create the perturbative deuterons:
9117 if(idpert.eq.2.and.idloop.eq.ndloop) then
9118 do ipertd=1,npertd
9119 nnn=nnn+1
9120 PPION(1,NNN,IRUN)=ppd(1,ipertd)
9121 PPION(2,NNN,IRUN)=ppd(2,ipertd)
9122 PPION(3,NNN,IRUN)=ppd(3,ipertd)
9123 EPION(NNN,IRUN)=xmd
9124 LPION(NNN,IRUN)=lbpd(ipertd)
9125 RPION(1,NNN,IRUN)=R(1,I1)
9126 RPION(2,NNN,IRUN)=R(2,I1)
9127 RPION(3,NNN,IRUN)=R(3,I1)
9128clin-6/2008 assign the perturbative probability:
9129 dppion(NNN,IRUN)=1./float(npertd)
9130 enddo
9131 endif
9132 endif
9133 enddo
9134 IBLOCK=501
9135 return
9136clin-6/2008 D+D->Deuteron+pi over
9137
9138 END
9139**********************************
9140**********************************
9141* *
9142 SUBROUTINE INIT(MINNUM,MAXNUM,NUM,RADIUS,X0,Z0,P0,
9143 & GAMMA,ISEED,MASS,IOPT)
9144* *
9145* PURPOSE: PROVIDING INITIAL CONDITIONS FOR PHASE-SPACE *
9146* DISTRIBUTION OF TESTPARTICLES *
9147* VARIABLES: (ALL INPUT) *
9148* MINNUM - FIRST TESTPARTICLE TREATED IN ONE RUN (INTEGER) *
9149* MAXNUM - LAST TESTPARTICLE TREATED IN ONE RUN (INTEGER) *
9150* NUM - NUMBER OF TESTPARTICLES PER NUCLEON (INTEGER) *
9151* RADIUS - RADIUS OF NUCLEUS "FM" (REAL) *
9152* X0,Z0 - DISPLACEMENT OF CENTER OF NUCLEUS IN X,Z- *
9153* DIRECTION "FM" (REAL) *
9154* P0 - MOMENTUM-BOOST IN C.M. FRAME "GEV/C" (REAL) *
9155* GAMMA - RELATIVISTIC GAMMA-FACTOR (REAL) *
9156* ISEED - SEED FOR RANDOM-NUMBER GENERATOR (INTEGER) *
9157* MASS - TOTAL MASS OF THE SYSTEM (INTEGER) *
9158* IOPT - OPTION FOR DIFFERENT OCCUPATION OF MOMENTUM *
9159* SPACE (INTEGER) *
9160* *
9161**********************************
9162 PARAMETER (MAXSTR=150001, AMU = 0.9383)
9163 PARAMETER (MAXX = 20, MAXZ = 24)
9164 PARAMETER (PI=3.1415926)
9165*
9166 REAL PTOT(3)
9167 COMMON /AA/ R(3,MAXSTR)
9168cc SAVE /AA/
9169 COMMON /BB/ P(3,MAXSTR)
9170cc SAVE /BB/
9171 COMMON /CC/ E(MAXSTR)
9172cc SAVE /CC/
9173 COMMON /DD/ RHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
9174 & RHOP(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
9175 & RHON(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
9176cc SAVE /DD/
9177 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
9178cc SAVE /EE/
9179 common /ss/ inout(20)
9180cc SAVE /ss/
9181 COMMON/RNDF77/NSEED
9182cc SAVE /RNDF77/
9183 SAVE
9184*----------------------------------------------------------------------
9185* PREPARATION FOR LORENTZ-TRANSFORMATIONS
9186*
9187 ISEED=ISEED
9188 IF (P0 .NE. 0.) THEN
9189 SIGN = P0 / ABS(P0)
9190 ELSE
9191 SIGN = 0.
9192 END IF
9193 BETA = SIGN * SQRT(GAMMA**2-1.)/GAMMA
9194*-----------------------------------------------------------------------
9195* TARGET-ID = 1 AND PROJECTILE-ID = -1
9196*
9197 IF (MINNUM .EQ. 1) THEN
9198 IDNUM = 1
9199 ELSE
9200 IDNUM = -1
9201 END IF
9202*-----------------------------------------------------------------------
9203* IDENTIFICATION OF TESTPARTICLES AND ASSIGMENT OF RESTMASS
9204*
9205* LOOP OVER ALL PARALLEL RUNS:
9206 DO 400 IRUN = 1,NUM
9207 DO 100 I = MINNUM+(IRUN-1)*MASS,MAXNUM+(IRUN-1)*MASS
9208 ID(I) = IDNUM
9209 E(I) = AMU
9210 100 CONTINUE
9211*-----------------------------------------------------------------------
9212* OCCUPATION OF COORDINATE-SPACE
9213*
9214 DO 300 I = MINNUM+(IRUN-1)*MASS,MAXNUM+(IRUN-1)*MASS
9215 200 CONTINUE
9216 X = 1.0 - 2.0 * RANART(NSEED)
9217 Y = 1.0 - 2.0 * RANART(NSEED)
9218 Z = 1.0 - 2.0 * RANART(NSEED)
9219 IF ((X*X+Y*Y+Z*Z) .GT. 1.0) GOTO 200
9220 R(1,I) = X * RADIUS
9221 R(2,I) = Y * RADIUS
9222 R(3,I) = Z * RADIUS
9223 300 CONTINUE
9224 400 CONTINUE
9225*=======================================================================
9226 IF (IOPT .NE. 3) THEN
9227*-----
9228* OPTION 1: USE WOODS-SAXON PARAMETRIZATION FOR DENSITY AND
9229*----- CALCULATE LOCAL FERMI-MOMENTUM
9230*
9231 RHOW0 = 0.168
9232 DO 1000 IRUN = 1,NUM
9233 DO 600 I = MINNUM+(IRUN-1)*MASS,MAXNUM+(IRUN-1)*MASS
9234 500 CONTINUE
9235 PX = 1.0 - 2.0 * RANART(NSEED)
9236 PY = 1.0 - 2.0 * RANART(NSEED)
9237 PZ = 1.0 - 2.0 * RANART(NSEED)
9238 IF (PX*PX+PY*PY+PZ*PZ .GT. 1.0) GOTO 500
9239 RDIST = SQRT( R(1,I)**2 + R(2,I)**2 + R(3,I)**2 )
9240 RHOWS = RHOW0 / ( 1.0 + EXP( (RDIST-RADIUS) / 0.55 ) )
9241 PFERMI = 0.197 * (1.5 * PI*PI * RHOWS)**(1./3.)
9242*-----
9243* OPTION 2: NUCLEAR MATTER CASE
9244 IF(IOPT.EQ.2) PFERMI=0.27
9245 if(iopt.eq.4) pfermi=0.
9246*-----
9247 P(1,I) = PFERMI * PX
9248 P(2,I) = PFERMI * PY
9249 P(3,I) = PFERMI * PZ
9250 600 CONTINUE
9251*
9252* SET TOTAL MOMENTUM TO 0 IN REST FRAME AND BOOST
9253*
9254 DO 700 IDIR = 1,3
9255 PTOT(IDIR) = 0.0
9256 700 CONTINUE
9257 NPART = 0
9258 DO 900 I = MINNUM+(IRUN-1)*MASS,MAXNUM+(IRUN-1)*MASS
9259 NPART = NPART + 1
9260 DO 800 IDIR = 1,3
9261 PTOT(IDIR) = PTOT(IDIR) + P(IDIR,I)
9262 800 CONTINUE
9263 900 CONTINUE
9264 DO 950 I = MINNUM+(IRUN-1)*MASS,MAXNUM+(IRUN-1)*MASS
9265 DO 925 IDIR = 1,3
9266 P(IDIR,I) = P(IDIR,I) - PTOT(IDIR) / FLOAT(NPART)
9267 925 CONTINUE
9268* BOOST
9269 IF ((IOPT .EQ. 1).or.(iopt.eq.2)) THEN
9270 EPART = SQRT(P(1,I)**2+P(2,I)**2+P(3,I)**2+AMU**2)
9271 P(3,I) = GAMMA*(P(3,I) + BETA*EPART)
9272 ELSE
9273 P(3,I) = P(3,I) + P0
9274 END IF
9275 950 CONTINUE
9276 1000 CONTINUE
9277*-----
9278 ELSE
9279*-----
9280* OPTION 3: GIVE ALL NUCLEONS JUST A Z-MOMENTUM ACCORDING TO
9281* THE BOOST OF THE NUCLEI
9282*
9283 DO 1200 IRUN = 1,NUM
9284 DO 1100 I = MINNUM+(IRUN-1)*MASS,MAXNUM+(IRUN-1)*MASS
9285 P(1,I) = 0.0
9286 P(2,I) = 0.0
9287 P(3,I) = P0
9288 1100 CONTINUE
9289 1200 CONTINUE
9290*-----
9291 END IF
9292*=======================================================================
9293* PUT PARTICLES IN THEIR POSITION IN COORDINATE-SPACE
9294* (SHIFT AND RELATIVISTIC CONTRACTION)
9295*
9296 DO 1400 IRUN = 1,NUM
9297 DO 1300 I = MINNUM+(IRUN-1)*MASS,MAXNUM+(IRUN-1)*MASS
9298 R(1,I) = R(1,I) + X0
9299* two nuclei in touch after contraction
9300 R(3,I) = (R(3,I)+Z0)/ GAMMA
9301* two nuclei in touch before contraction
9302c R(3,I) = R(3,I) / GAMMA + Z0
9303 1300 CONTINUE
9304 1400 CONTINUE
9305*
9306 RETURN
9307 END
9308**********************************
9309* *
9310 SUBROUTINE DENS(IPOT,MASS,NUM,NESC)
9311* *
9312* PURPOSE: CALCULATION OF LOCAL BARYON, MESON AND ENERGY *
9313* DENSITY FROM SPATIAL DISTRIBUTION OF TESTPARTICLES*
9314* *
9315* VARIABLES (ALL INPUT, ALL INTEGER) *
9316* MASS - MASS NUMBER OF THE SYSTEM *
9317* NUM - NUMBER OF TESTPARTICLES PER NUCLEON *
9318* *
9319* NESC - NUMBER OF ESCAPED PARTICLES (INTEGER,OUTPUT) *
9320* *
9321**********************************
9322 PARAMETER (MAXSTR= 150001,MAXR=1)
9323 PARAMETER (MAXX = 20, MAXZ = 24)
9324*
9325 dimension pxl(-maxx:maxx,-maxx:maxx,-maxz:maxz),
9326 1 pyl(-maxx:maxx,-maxx:maxx,-maxz:maxz),
9327 2 pzl(-maxx:maxx,-maxx:maxx,-maxz:maxz)
9328 COMMON /AA/ R(3,MAXSTR)
9329cc SAVE /AA/
9330 COMMON /BB/ P(3,MAXSTR)
9331cc SAVE /BB/
9332 COMMON /CC/ E(MAXSTR)
9333cc SAVE /CC/
9334 COMMON /DD/ RHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
9335 & RHOP(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
9336 & RHON(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
9337cc SAVE /DD/
9338 COMMON /DDpi/ piRHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
9339cc SAVE /DDpi/
9340 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
9341cc SAVE /EE/
9342 common /ss/ inout(20)
9343cc SAVE /ss/
9344 COMMON /RR/ MASSR(0:MAXR)
9345cc SAVE /RR/
9346 common /tt/ PEL(-maxx:maxx,-maxx:maxx,-maxz:maxz)
9347 &,rxy(-maxx:maxx,-maxx:maxx,-maxz:maxz)
9348cc SAVE /tt/
9349 common /bbb/ bxx(-maxx:maxx,-maxx:maxx,-maxz:maxz),
9350 &byy(-maxx:maxx,-maxx:maxx,-maxz:maxz),
9351 &bzz(-maxx:maxx,-maxx:maxx,-maxz:maxz)
9352*
9353 real zet(-45:45)
9354 SAVE
9355 data zet /
9356 4 1.,0.,0.,0.,0.,
9357 3 1.,0.,0.,0.,0.,0.,0.,0.,0.,0.,
9358 2 -1.,0.,0.,0.,0.,0.,0.,0.,0.,0.,
9359 1 0.,0.,0.,-1.,0.,1.,0.,-1.,0.,-1.,
9360 s 0.,-2.,-1.,0.,1.,0.,0.,0.,0.,-1.,
9361 e 0.,
9362 s 1.,0.,-1.,0.,1.,-1.,0.,1.,2.,0.,
9363 1 1.,0.,1.,0.,-1.,0.,1.,0.,0.,0.,
9364 2 -1.,0.,1.,0.,-1.,0.,1.,0.,0.,1.,
9365 3 0.,0.,0.,0.,0.,0.,0.,0.,0.,-1.,
9366 4 0.,0.,0.,0.,-1./
9367
9368 DO 300 IZ = -MAXZ,MAXZ
9369 DO 200 IY = -MAXX,MAXX
9370 DO 100 IX = -MAXX,MAXX
9371 RHO(IX,IY,IZ) = 0.0
9372 RHOn(IX,IY,IZ) = 0.0
9373 RHOp(IX,IY,IZ) = 0.0
9374 piRHO(IX,IY,IZ) = 0.0
9375 pxl(ix,iy,iz) = 0.0
9376 pyl(ix,iy,iz) = 0.0
9377 pzl(ix,iy,iz) = 0.0
9378 pel(ix,iy,iz) = 0.0
9379 bxx(ix,iy,iz) = 0.0
9380 byy(ix,iy,iz) = 0.0
9381 bzz(ix,iy,iz) = 0.0
9382 100 CONTINUE
9383 200 CONTINUE
9384 300 CONTINUE
9385*
9386 NESC = 0
9387 BIG = 1.0 / ( 3.0 * FLOAT(NUM) )
9388 SMALL = 1.0 / ( 9.0 * FLOAT(NUM) )
9389*
9390 MSUM=0
9391 DO 400 IRUN = 1,NUM
9392 MSUM=MSUM+MASSR(IRUN-1)
9393 DO 400 J=1,MASSr(irun)
9394 I=J+MSUM
9395 IX = NINT( R(1,I) )
9396 IY = NINT( R(2,I) )
9397 IZ = NINT( R(3,I) )
9398 IF( IX .LE. -MAXX .OR. IX .GE. MAXX .OR.
9399 & IY .LE. -MAXX .OR. IY .GE. MAXX .OR.
9400 & IZ .LE. -MAXZ .OR. IZ .GE. MAXZ ) THEN
9401 NESC = NESC + 1
9402 ELSE
9403c
9404csp01/04/02 include baryon density
9405 if(j.gt.mass)go to 30
9406c if( (lb(i).eq.1.or.lb(i).eq.2) .or.
9407c & (lb(i).ge.6.and.lb(i).le.17) )then
9408* (1) baryon density
9409 RHO(IX, IY, IZ ) = RHO(IX, IY, IZ ) + BIG
9410 RHO(IX+1,IY, IZ ) = RHO(IX+1,IY, IZ ) + SMALL
9411 RHO(IX-1,IY, IZ ) = RHO(IX-1,IY, IZ ) + SMALL
9412 RHO(IX, IY+1,IZ ) = RHO(IX, IY+1,IZ ) + SMALL
9413 RHO(IX, IY-1,IZ ) = RHO(IX, IY-1,IZ ) + SMALL
9414 RHO(IX, IY, IZ+1) = RHO(IX, IY, IZ+1) + SMALL
9415 RHO(IX, IY, IZ-1) = RHO(IX, IY, IZ-1) + SMALL
9416* (2) CALCULATE THE PROTON DENSITY
9417 IF(ZET(LB(I)).NE.0)THEN
9418 RHOP(IX, IY, IZ ) = RHOP(IX, IY, IZ ) + BIG
9419 RHOP(IX+1,IY, IZ ) = RHOP(IX+1,IY, IZ ) + SMALL
9420 RHOP(IX-1,IY, IZ ) = RHOP(IX-1,IY, IZ ) + SMALL
9421 RHOP(IX, IY+1,IZ ) = RHOP(IX, IY+1,IZ ) + SMALL
9422 RHOP(IX, IY-1,IZ ) = RHOP(IX, IY-1,IZ ) + SMALL
9423 RHOP(IX, IY, IZ+1) = RHOP(IX, IY, IZ+1) + SMALL
9424 RHOP(IX, IY, IZ-1) = RHOP(IX, IY, IZ-1) + SMALL
9425 go to 40
9426 ENDIF
9427* (3) CALCULATE THE NEUTRON DENSITY
9428 IF(ZET(LB(I)).EQ.0)THEN
9429 RHON(IX, IY, IZ ) = RHON(IX, IY, IZ ) + BIG
9430 RHON(IX+1,IY, IZ ) = RHON(IX+1,IY, IZ ) + SMALL
9431 RHON(IX-1,IY, IZ ) = RHON(IX-1,IY, IZ ) + SMALL
9432 RHON(IX, IY+1,IZ ) = RHON(IX, IY+1,IZ ) + SMALL
9433 RHON(IX, IY-1,IZ ) = RHON(IX, IY-1,IZ ) + SMALL
9434 RHON(IX, IY, IZ+1) = RHON(IX, IY, IZ+1) + SMALL
9435 RHON(IX, IY, IZ-1) = RHON(IX, IY, IZ-1) + SMALL
9436 go to 40
9437 END IF
9438c else !! sp01/04/02
9439* (4) meson density
944030 piRHO(IX, IY, IZ ) = piRHO(IX, IY, IZ ) + BIG
9441 piRHO(IX+1,IY, IZ ) = piRHO(IX+1,IY, IZ ) + SMALL
9442 piRHO(IX-1,IY, IZ ) = piRHO(IX-1,IY, IZ ) + SMALL
9443 piRHO(IX, IY+1,IZ ) = piRHO(IX, IY+1,IZ ) + SMALL
9444 piRHO(IX, IY-1,IZ ) = piRHO(IX, IY-1,IZ ) + SMALL
9445 piRHO(IX, IY, IZ+1) = piRHO(IX, IY, IZ+1) + SMALL
9446 piRHO(IX, IY, IZ-1) = piRHO(IX, IY, IZ-1) + SMALL
9447c endif !! sp01/04/02
9448* to calculate the Gamma factor in each cell
9449*(1) PX
945040 pxl(ix,iy,iz)=pxl(ix,iy,iz)+p(1,I)*BIG
9451 pxl(ix+1,iy,iz)=pxl(ix+1,iy,iz)+p(1,I)*SMALL
9452 pxl(ix-1,iy,iz)=pxl(ix-1,iy,iz)+p(1,I)*SMALL
9453 pxl(ix,iy+1,iz)=pxl(ix,iy+1,iz)+p(1,I)*SMALL
9454 pxl(ix,iy-1,iz)=pxl(ix,iy-1,iz)+p(1,I)*SMALL
9455 pxl(ix,iy,iz+1)=pxl(ix,iy,iz+1)+p(1,I)*SMALL
9456 pxl(ix,iy,iz-1)=pxl(ix,iy,iz-1)+p(1,I)*SMALL
9457*(2) PY
9458 pYl(ix,iy,iz)=pYl(ix,iy,iz)+p(2,I)*BIG
9459 pYl(ix+1,iy,iz)=pYl(ix+1,iy,iz)+p(2,I)*SMALL
9460 pYl(ix-1,iy,iz)=pYl(ix-1,iy,iz)+p(2,I)*SMALL
9461 pYl(ix,iy+1,iz)=pYl(ix,iy+1,iz)+p(2,I)*SMALL
9462 pYl(ix,iy-1,iz)=pYl(ix,iy-1,iz)+p(2,I)*SMALL
9463 pYl(ix,iy,iz+1)=pYl(ix,iy,iz+1)+p(2,I)*SMALL
9464 pYl(ix,iy,iz-1)=pYl(ix,iy,iz-1)+p(2,I)*SMALL
9465* (3) PZ
9466 pZl(ix,iy,iz)=pZl(ix,iy,iz)+p(3,I)*BIG
9467 pZl(ix+1,iy,iz)=pZl(ix+1,iy,iz)+p(3,I)*SMALL
9468 pZl(ix-1,iy,iz)=pZl(ix-1,iy,iz)+p(3,I)*SMALL
9469 pZl(ix,iy+1,iz)=pZl(ix,iy+1,iz)+p(3,I)*SMALL
9470 pZl(ix,iy-1,iz)=pZl(ix,iy-1,iz)+p(3,I)*SMALL
9471 pZl(ix,iy,iz+1)=pZl(ix,iy,iz+1)+p(3,I)*SMALL
9472 pZl(ix,iy,iz-1)=pZl(ix,iy,iz-1)+p(3,I)*SMALL
9473* (4) ENERGY
9474 pel(ix,iy,iz)=pel(ix,iy,iz)
9475 1 +sqrt(e(I)**2+p(1,i)**2+p(2,I)**2+p(3,I)**2)*BIG
9476 pel(ix+1,iy,iz)=pel(ix+1,iy,iz)
9477 1 +sqrt(e(I)**2+p(1,i)**2+p(2,I)**2+p(3,I)**2)*SMALL
9478 pel(ix-1,iy,iz)=pel(ix-1,iy,iz)
9479 1 +sqrt(e(I)**2+p(1,i)**2+p(2,I)**2+p(3,I)**2)*SMALL
9480 pel(ix,iy+1,iz)=pel(ix,iy+1,iz)
9481 1 +sqrt(e(I)**2+p(1,i)**2+p(2,I)**2+p(3,I)**2)*SMALL
9482 pel(ix,iy-1,iz)=pel(ix,iy-1,iz)
9483 1 +sqrt(e(I)**2+p(1,i)**2+p(2,I)**2+p(3,I)**2)*SMALL
9484 pel(ix,iy,iz+1)=pel(ix,iy,iz+1)
9485 1 +sqrt(e(I)**2+p(1,i)**2+p(2,I)**2+p(3,I)**2)*SMALL
9486 pel(ix,iy,iz-1)=pel(ix,iy,iz-1)
9487 1 +sqrt(e(I)**2+p(1,i)**2+p(2,I)**2+p(3,I)**2)*SMALL
9488 END IF
9489 400 CONTINUE
9490*
9491 DO 301 IZ = -MAXZ,MAXZ
9492 DO 201 IY = -MAXX,MAXX
9493 DO 101 IX = -MAXX,MAXX
9494 IF((RHO(IX,IY,IZ).EQ.0).OR.(PEL(IX,IY,IZ).EQ.0))
9495 1GO TO 101
9496 SMASS2=PEL(IX,IY,IZ)**2-PXL(IX,IY,IZ)**2
9497 1-PYL(IX,IY,IZ)**2-PZL(IX,IY,IZ)**2
9498 IF(SMASS2.LE.0)SMASS2=1.E-06
9499 SMASS=SQRT(SMASS2)
9500 IF(SMASS.EQ.0.)SMASS=1.e-06
9501 GAMMA=PEL(IX,IY,IZ)/SMASS
9502 if(gamma.eq.0)go to 101
9503 bxx(ix,iy,iz)=pxl(ix,iy,iz)/pel(ix,iy,iz)
9504 byy(ix,iy,iz)=pyl(ix,iy,iz)/pel(ix,iy,iz)
9505 bzz(ix,iy,iz)=pzl(ix,iy,iz)/pel(ix,iy,iz)
9506 RHO(IX,IY,IZ) = RHO(IX,IY,IZ)/GAMMA
9507 RHOn(IX,IY,IZ) = RHOn(IX,IY,IZ)/GAMMA
9508 RHOp(IX,IY,IZ) = RHOp(IX,IY,IZ)/GAMMA
9509 piRHO(IX,IY,IZ) = piRHO(IX,IY,IZ)/GAMMA
9510 pEL(IX,IY,IZ) = pEL(IX,IY,IZ)/(GAMMA**2)
9511 rho0=0.163
9512 IF(IPOT.EQ.0)THEN
9513 U=0
9514 GO TO 70
9515 ENDIF
9516 IF(IPOT.EQ.1.or.ipot.eq.6)THEN
9517 A=-0.1236
9518 B=0.0704
9519 S=2
9520 GO TO 60
9521 ENDIF
9522 IF(IPOT.EQ.2.or.ipot.eq.7)THEN
9523 A=-0.218
9524 B=0.164
9525 S=4./3.
9526 ENDIF
9527 IF(IPOT.EQ.3)THEN
9528 a=-0.3581
9529 b=0.3048
9530 S=1.167
9531 GO TO 60
9532 ENDIF
9533 IF(IPOT.EQ.4)THEN
9534 denr=rho(ix,iy,iz)/rho0
9535 b=0.3048
9536 S=1.167
9537 if(denr.le.4.or.denr.gt.7)then
9538 a=-0.3581
9539 else
9540 a=-b*denr**(1./6.)-2.*0.036/3.*denr**(-0.333)
9541 endif
9542 GO TO 60
9543 ENDIF
954460 U = 0.5*A*RHO(IX,IY,IZ)**2/RHO0
9545 1 + B/(1+S) * (RHO(IX,IY,IZ)/RHO0)**S*RHO(IX,IY,IZ)
954670 PEL(IX,IY,IZ)=PEL(IX,IY,IZ)+U
9547 101 CONTINUE
9548 201 CONTINUE
9549 301 CONTINUE
9550 RETURN
9551 END
9552
9553**********************************
9554* *
9555 SUBROUTINE GRADU(IOPT,IX,IY,IZ,GRADX,GRADY,GRADZ)
9556* *
9557* PURPOSE: DETERMINE GRAD(U(RHO(X,Y,Z))) *
9558* VARIABLES: *
9559* IOPT - METHOD FOR EVALUATING THE GRADIENT *
9560* (INTEGER,INPUT) *
9561* IX, IY, IZ - COORDINATES OF POINT (INTEGER,INPUT) *
9562* GRADX, GRADY, GRADZ - GRADIENT OF U (REAL,OUTPUT) *
9563* *
9564**********************************
9565 PARAMETER (MAXX = 20, MAXZ = 24)
9566 PARAMETER (RHO0 = 0.167)
9567*
9568 COMMON /DD/ RHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
9569 & RHOP(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
9570 & RHON(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
9571cc SAVE /DD/
9572 common /ss/ inout(20)
9573cc SAVE /ss/
9574 common /tt/ PEL(-maxx:maxx,-maxx:maxx,-maxz:maxz)
9575 &,rxy(-maxx:maxx,-maxx:maxx,-maxz:maxz)
9576cc SAVE /tt/
9577 SAVE
9578*
9579 RXPLUS = RHO(IX+1,IY, IZ ) / RHO0
9580 RXMINS = RHO(IX-1,IY, IZ ) / RHO0
9581 RYPLUS = RHO(IX, IY+1,IZ ) / RHO0
9582 RYMINS = RHO(IX, IY-1,IZ ) / RHO0
9583 RZPLUS = RHO(IX, IY, IZ+1) / RHO0
9584 RZMINS = RHO(IX, IY, IZ-1) / RHO0
9585 den0 = RHO(IX, IY, IZ) / RHO0
9586 ene0 = pel(IX, IY, IZ)
9587*-----------------------------------------------------------------------
9588 GOTO (1,2,3,4,5) IOPT
9589 if(iopt.eq.6)go to 6
9590 if(iopt.eq.7)go to 7
9591*
9592 1 CONTINUE
9593* POTENTIAL USED IN 1) (STIFF):
9594* U = -.124 * RHO/RHO0 + .0705 (RHO/RHO0)**2 GEV
9595*
9596 GRADX = -0.062 * (RXPLUS - RXMINS) + 0.03525 * (RXPLUS**2 -
9597 & RXMINS**2)
9598 GRADY = -0.062 * (RYPLUS - RYMINS) + 0.03525 * (RYPLUS**2 -
9599 & RYMINS**2)
9600 GRADZ = -0.062 * (RZPLUS - RZMINS) + 0.03525 * (RZPLUS**2 -
9601 & RZMINS**2)
9602 RETURN
9603*
9604 2 CONTINUE
9605* POTENTIAL USED IN 2):
9606* U = -.218 * RHO/RHO0 + .164 (RHO/RHO0)**(4/3) GEV
9607*
9608 EXPNT = 1.3333333
9609 GRADX = -0.109 * (RXPLUS - RXMINS)
9610 & + 0.082 * (RXPLUS**EXPNT-RXMINS**EXPNT)
9611 GRADY = -0.109 * (RYPLUS - RYMINS)
9612 & + 0.082 * (RYPLUS**EXPNT-RYMINS**EXPNT)
9613 GRADZ = -0.109 * (RZPLUS - RZMINS)
9614 & + 0.082 * (RZPLUS**EXPNT-RZMINS**EXPNT)
9615 RETURN
9616*
9617 3 CONTINUE
9618* POTENTIAL USED IN 3) (SOFT):
9619* U = -.356 * RHO/RHO0 + .303 * (RHO/RHO0)**(7/6) GEV
9620*
9621 EXPNT = 1.1666667
9622 acoef = 0.178
9623 GRADX = -acoef * (RXPLUS - RXMINS)
9624 & + 0.1515 * (RXPLUS**EXPNT-RXMINS**EXPNT)
9625 GRADY = -acoef * (RYPLUS - RYMINS)
9626 & + 0.1515 * (RYPLUS**EXPNT-RYMINS**EXPNT)
9627 GRADZ = -acoef * (RZPLUS - RZMINS)
9628 & + 0.1515 * (RZPLUS**EXPNT-RZMINS**EXPNT)
9629 RETURN
9630*
9631*
9632 4 CONTINUE
9633* POTENTIAL USED IN 4) (super-soft in the mixed phase of 4 < rho/rho <7):
9634* U1 = -.356 * RHO/RHO0 + .303 * (RHO/RHO0)**(7/6) GEV
9635* normal phase, soft eos of iopt=3
9636* U2 = -.02 * (RHO/RHO0)**(2/3) -0.0253 * (RHO/RHO0)**(7/6) GEV
9637*
9638 eh=4.
9639 eqgp=7.
9640 acoef=0.178
9641 EXPNT = 1.1666667
9642 denr=rho(ix,iy,iz)/rho0
9643 if(denr.le.eh.or.denr.ge.eqgp)then
9644 GRADX = -acoef * (RXPLUS - RXMINS)
9645 & + 0.1515 * (RXPLUS**EXPNT-RXMINS**EXPNT)
9646 GRADY = -acoef * (RYPLUS - RYMINS)
9647 & + 0.1515 * (RYPLUS**EXPNT-RYMINS**EXPNT)
9648 GRADZ = -acoef * (RZPLUS - RZMINS)
9649 & + 0.1515 * (RZPLUS**EXPNT-RZMINS**EXPNT)
9650 else
9651 acoef1=0.178
9652 acoef2=0.0
9653 expnt2=2./3.
9654 GRADX =-acoef1* (RXPLUS**EXPNT-RXMINS**EXPNT)
9655 & -acoef2* (RXPLUS**expnt2 - RXMINS**expnt2)
9656 GRADy =-acoef1* (RyPLUS**EXPNT-RyMINS**EXPNT)
9657 & -acoef2* (RyPLUS**expnt2 - RyMINS**expnt2)
9658 GRADz =-acoef1* (RzPLUS**EXPNT-RzMINS**EXPNT)
9659 & -acoef2* (RzPLUS**expnt2 - RzMINS**expnt2)
9660 endif
9661 return
9662*
9663 5 CONTINUE
9664* POTENTIAL USED IN 5) (SUPER STIFF):
9665* U = -.10322 * RHO/RHO0 + .04956 * (RHO/RHO0)**(2.77) GEV
9666*
9667 EXPNT = 2.77
9668 GRADX = -0.0516 * (RXPLUS - RXMINS)
9669 & + 0.02498 * (RXPLUS**EXPNT-RXMINS**EXPNT)
9670 GRADY = -0.0516 * (RYPLUS - RYMINS)
9671 & + 0.02498 * (RYPLUS**EXPNT-RYMINS**EXPNT)
9672 GRADZ = -0.0516 * (RZPLUS - RZMINS)
9673 & + 0.02498 * (RZPLUS**EXPNT-RZMINS**EXPNT)
9674 RETURN
9675*
9676 6 CONTINUE
9677* POTENTIAL USED IN 6) (STIFF-qgp):
9678* U = -.124 * RHO/RHO0 + .0705 (RHO/RHO0)**2 GEV
9679*
9680 if(ene0.le.0.5)then
9681 GRADX = -0.062 * (RXPLUS - RXMINS) + 0.03525 * (RXPLUS**2 -
9682 & RXMINS**2)
9683 GRADY = -0.062 * (RYPLUS - RYMINS) + 0.03525 * (RYPLUS**2 -
9684 & RYMINS**2)
9685 GRADZ = -0.062 * (RZPLUS - RZMINS) + 0.03525 * (RZPLUS**2 -
9686 & RZMINS**2)
9687 RETURN
9688 endif
9689 if(ene0.gt.0.5.and.ene0.le.1.5)then
9690* U=c1-ef*rho/rho0**2/3
9691 ef=36./1000.
9692 GRADX = -0.5*ef* (RXPLUS**0.67-RXMINS**0.67)
9693 GRADy = -0.5*ef* (RyPLUS**0.67-RyMINS**0.67)
9694 GRADz = -0.5*ef* (RzPLUS**0.67-RzMINS**0.67)
9695 RETURN
9696 endif
9697 if(ene0.gt.1.5)then
9698* U=800*(rho/rho0)**1/3.-Ef*(rho/rho0)**2/3.-c2
9699 ef=36./1000.
9700 cf0=0.8
9701 GRADX =0.5*cf0*(rxplus**0.333-rxmins**0.333)
9702 & -0.5*ef* (RXPLUS**0.67-RXMINS**0.67)
9703 GRADy =0.5*cf0*(ryplus**0.333-rymins**0.333)
9704 & -0.5*ef* (RyPLUS**0.67-RyMINS**0.67)
9705 GRADz =0.5*cf0*(rzplus**0.333-rzmins**0.333)
9706 & -0.5*ef* (RzPLUS**0.67-RzMINS**0.67)
9707 RETURN
9708 endif
9709*
9710 7 CONTINUE
9711* POTENTIAL USED IN 7) (Soft-qgp):
9712 if(den0.le.4.5)then
9713* POTENTIAL USED is the same as IN 3) (SOFT):
9714* U = -.356 * RHO/RHO0 + .303 * (RHO/RHO0)**(7/6) GEV
9715*
9716 EXPNT = 1.1666667
9717 acoef = 0.178
9718 GRADX = -acoef * (RXPLUS - RXMINS)
9719 & + 0.1515 * (RXPLUS**EXPNT-RXMINS**EXPNT)
9720 GRADY = -acoef * (RYPLUS - RYMINS)
9721 & + 0.1515 * (RYPLUS**EXPNT-RYMINS**EXPNT)
9722 GRADZ = -acoef * (RZPLUS - RZMINS)
9723 & + 0.1515 * (RZPLUS**EXPNT-RZMINS**EXPNT)
9724 return
9725 endif
9726 if(den0.gt.4.5.and.den0.le.5.1)then
9727* U=c1-ef*rho/rho0**2/3
9728 ef=36./1000.
9729 GRADX = -0.5*ef* (RXPLUS**0.67-RXMINS**0.67)
9730 GRADy = -0.5*ef* (RyPLUS**0.67-RyMINS**0.67)
9731 GRADz = -0.5*ef* (RzPLUS**0.67-RzMINS**0.67)
9732 RETURN
9733 endif
9734 if(den0.gt.5.1)then
9735* U=800*(rho/rho0)**1/3.-Ef*(rho/rho0)**2/3.-c2
9736 ef=36./1000.
9737 cf0=0.8
9738 GRADX =0.5*cf0*(rxplus**0.333-rxmins**0.333)
9739 & -0.5*ef* (RXPLUS**0.67-RXMINS**0.67)
9740 GRADy =0.5*cf0*(ryplus**0.333-rymins**0.333)
9741 & -0.5*ef* (RyPLUS**0.67-RyMINS**0.67)
9742 GRADz =0.5*cf0*(rzplus**0.333-rzmins**0.333)
9743 & -0.5*ef* (RzPLUS**0.67-RzMINS**0.67)
9744 RETURN
9745 endif
9746 END
9747**********************************
9748* *
9749 SUBROUTINE GRADUK(IX,IY,IZ,GRADXk,GRADYk,GRADZk)
9750* *
9751* PURPOSE: DETERMINE the baryon density gradient for *
9752* proporgating kaons in a mean field caused by *
9753* surrounding baryons *
9754* VARIABLES: *
9755* IX, IY, IZ - COORDINATES OF POINT (INTEGER,INPUT) *
9756* GRADXk, GRADYk, GRADZk (REAL,OUTPUT) *
9757* *
9758**********************************
9759 PARAMETER (MAXX = 20, MAXZ = 24)
9760 PARAMETER (RHO0 = 0.168)
9761*
9762 COMMON /DD/ RHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
9763 & RHOP(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
9764 & RHON(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
9765cc SAVE /DD/
9766 common /ss/ inout(20)
9767cc SAVE /ss/
9768 SAVE
9769*
9770 RXPLUS = RHO(IX+1,IY, IZ )
9771 RXMINS = RHO(IX-1,IY, IZ )
9772 RYPLUS = RHO(IX, IY+1,IZ )
9773 RYMINS = RHO(IX, IY-1,IZ )
9774 RZPLUS = RHO(IX, IY, IZ+1)
9775 RZMINS = RHO(IX, IY, IZ-1)
9776 GRADXk = (RXPLUS - RXMINS)/2.
9777 GRADYk = (RYPLUS - RYMINS)/2.
9778 GRADZk = (RZPLUS - RZMINS)/2.
9779 RETURN
9780 END
9781*-----------------------------------------------------------------------
9782 SUBROUTINE GRADUP(IX,IY,IZ,GRADXP,GRADYP,GRADZP)
9783* *
9784* PURPOSE: DETERMINE THE GRADIENT OF THE PROTON DENSITY *
9785* VARIABLES: *
9786* *
9787* IX, IY, IZ - COORDINATES OF POINT (INTEGER,INPUT) *
9788* GRADXP, GRADYP, GRADZP - GRADIENT OF THE PROTON *
9789* DENSITY(REAL,OUTPUT) *
9790* *
9791**********************************
9792 PARAMETER (MAXX = 20, MAXZ = 24)
9793 PARAMETER (RHO0 = 0.168)
9794*
9795 COMMON /DD/ RHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
9796 & RHOP(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
9797 & RHON(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
9798cc SAVE /DD/
9799 common /ss/ inout(20)
9800cc SAVE /ss/
9801 SAVE
9802*
9803 RXPLUS = RHOP(IX+1,IY, IZ ) / RHO0
9804 RXMINS = RHOP(IX-1,IY, IZ ) / RHO0
9805 RYPLUS = RHOP(IX, IY+1,IZ ) / RHO0
9806 RYMINS = RHOP(IX, IY-1,IZ ) / RHO0
9807 RZPLUS = RHOP(IX, IY, IZ+1) / RHO0
9808 RZMINS = RHOP(IX, IY, IZ-1) / RHO0
9809*-----------------------------------------------------------------------
9810*
9811 GRADXP = (RXPLUS - RXMINS)/2.
9812 GRADYP = (RYPLUS - RYMINS)/2.
9813 GRADZP = (RZPLUS - RZMINS)/2.
9814 RETURN
9815 END
9816*-----------------------------------------------------------------------
9817 SUBROUTINE GRADUN(IX,IY,IZ,GRADXN,GRADYN,GRADZN)
9818* *
9819* PURPOSE: DETERMINE THE GRADIENT OF THE NEUTRON DENSITY *
9820* VARIABLES: *
9821* *
9822* IX, IY, IZ - COORDINATES OF POINT (INTEGER,INPUT) *
9823* GRADXN, GRADYN, GRADZN - GRADIENT OF THE NEUTRON *
9824* DENSITY(REAL,OUTPUT) *
9825* *
9826**********************************
9827 PARAMETER (MAXX = 20, MAXZ = 24)
9828 PARAMETER (RHO0 = 0.168)
9829*
9830 COMMON /DD/ RHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
9831 & RHOP(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
9832 & RHON(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
9833cc SAVE /DD/
9834 common /ss/ inout(20)
9835cc SAVE /ss/
9836 SAVE
9837*
9838 RXPLUS = RHON(IX+1,IY, IZ ) / RHO0
9839 RXMINS = RHON(IX-1,IY, IZ ) / RHO0
9840 RYPLUS = RHON(IX, IY+1,IZ ) / RHO0
9841 RYMINS = RHON(IX, IY-1,IZ ) / RHO0
9842 RZPLUS = RHON(IX, IY, IZ+1) / RHO0
9843 RZMINS = RHON(IX, IY, IZ-1) / RHO0
9844*-----------------------------------------------------------------------
9845*
9846 GRADXN = (RXPLUS - RXMINS)/2.
9847 GRADYN = (RYPLUS - RYMINS)/2.
9848 GRADZN = (RZPLUS - RZMINS)/2.
9849 RETURN
9850 END
9851
9852*-----------------------------------------------------------------------------
9853*FUNCTION FDE(DMASS) GIVES DELTA MASS DISTRIBUTION BY USING OF
9854*KITAZOE'S FORMULA
9855 REAL FUNCTION FDE(DMASS,SRT,CON)
9856 SAVE
9857 AMN=0.938869
9858 AVPI=0.13803333
9859 AM0=1.232
9860 FD=4.*(AM0**2)*WIDTH(DMASS)/((DMASS**2-1.232**2)**2
9861 1 +AM0**2*WIDTH(DMASS)**2)
9862 IF(CON.EQ.1.)THEN
9863 P11=(SRT**2+DMASS**2-AMN**2)**2
9864 1 /(4.*SRT**2)-DMASS**2
9865 if(p11.le.0)p11=1.E-06
9866 p1=sqrt(p11)
9867 ELSE
9868 DMASS=AMN+AVPI
9869 P11=(SRT**2+DMASS**2-AMN**2)**2
9870 1 /(4.*SRT**2)-DMASS**2
9871 if(p11.le.0)p11=1.E-06
9872 p1=sqrt(p11)
9873 ENDIF
9874 FDE=FD*P1*DMASS
9875 RETURN
9876 END
9877*-------------------------------------------------------------
9878*FUNCTION FDE(DMASS) GIVES N*(1535) MASS DISTRIBUTION BY USING OF
9879*KITAZOE'S FORMULA
9880 REAL FUNCTION FD5(DMASS,SRT,CON)
9881 SAVE
9882 AMN=0.938869
9883 AVPI=0.13803333
9884 AM0=1.535
9885 FD=4.*(AM0**2)*W1535(DMASS)/((DMASS**2-1.535**2)**2
9886 1 +AM0**2*W1535(DMASS)**2)
9887 IF(CON.EQ.1.)THEN
9888 P1=SQRT((SRT**2+DMASS**2-AMN**2)**2
9889 1 /(4.*SRT**2)-DMASS**2)
9890 ELSE
9891 DMASS=AMN+AVPI
9892 P1=SQRT((SRT**2+DMASS**2-AMN**2)**2
9893 1 /(4.*SRT**2)-DMASS**2)
9894 ENDIF
9895 FD5=FD*P1*DMASS
9896 RETURN
9897 END
9898*--------------------------------------------------------------------------
9899*FUNCTION FNS(DMASS) GIVES N* MASS DISTRIBUTION
9900c BY USING OF BREIT-WIGNER FORMULA
9901 REAL FUNCTION FNS(DMASS,SRT,CON)
9902 SAVE
9903 WIDTH=0.2
9904 AMN=0.938869
9905 AVPI=0.13803333
9906 AN0=1.43
9907 FN=4.*(AN0**2)*WIDTH/((DMASS**2-1.44**2)**2+AN0**2*WIDTH**2)
9908 IF(CON.EQ.1.)THEN
9909 P1=SQRT((SRT**2+DMASS**2-AMN**2)**2
9910 1 /(4.*SRT**2)-DMASS**2)
9911 ELSE
9912 DMASS=AMN+AVPI
9913 P1=SQRT((SRT**2+DMASS**2-AMN**2)**2
9914 1 /(4.*SRT**2)-DMASS**2)
9915 ENDIF
9916 FNS=FN*P1*DMASS
9917 RETURN
9918 END
9919*-----------------------------------------------------------------------------
9920*-----------------------------------------------------------------------------
9921* PURPOSE:1. SORT N*(1440) and N*(1535) 2-body DECAY PRODUCTS
9922* 2. DETERMINE THE MOMENTUM AND COORDINATES OF NUCLEON AND PION
9923* AFTER THE DELTA OR N* DECAYING
9924* DATE : JAN. 24,1990, MODIFIED ON MAY 17, 1994 TO INCLUDE ETA
3006c44b 9925 SUBROUTINE DECAYA(IRUN,I,NNN,ISEED,wid,nt)
0119ef9a 9926 PARAMETER (MAXSTR=150001,MAXR=1,
9927 1 AMN=0.939457,ETAM=0.5475,AMP=0.93828,AP1=0.13496,
9928 2 AP2=0.13957,AM0=1.232,PI=3.1415926)
9929 COMMON /AA/ R(3,MAXSTR)
9930cc SAVE /AA/
9931 COMMON /BB/ P(3,MAXSTR)
9932cc SAVE /BB/
9933 COMMON /CC/ E(MAXSTR)
9934cc SAVE /CC/
9935 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
9936cc SAVE /EE/
9937 COMMON /RUN/NUM
9938cc SAVE /RUN/
9939 COMMON /PA/RPION(3,MAXSTR,MAXR)
9940cc SAVE /PA/
9941 COMMON /PB/PPION(3,MAXSTR,MAXR)
9942cc SAVE /PB/
9943 COMMON /PC/EPION(MAXSTR,MAXR)
9944cc SAVE /PC/
9945 COMMON /PD/LPION(MAXSTR,MAXR)
9946cc SAVE /PD/
9947 COMMON /INPUT2/ ILAB, MANYB, NTMAX, ICOLL, INSYS, IPOT, MODE,
9948 & IMOMEN, NFREQ, ICFLOW, ICRHO, ICOU, KPOTEN, KMUL
9949cc SAVE /INPUT2/
9950 COMMON/RNDF77/NSEED
9951 COMMON /dpert/dpertt(MAXSTR,MAXR),dpertp(MAXSTR),dplast(MAXSTR),
9952 1 dpdcy(MAXSTR),dpdpi(MAXSTR,MAXR),dpt(MAXSTR, MAXR),
9953 2 dpp1(MAXSTR,MAXR),dppion(MAXSTR,MAXR)
9954cc SAVE /RNDF77/
9955 SAVE
9956 lbanti=LB(I)
9957c
9958 DM=E(I)
9959*1. FOR N*+(1440) DECAY
9960 IF(iabs(LB(I)).EQ.11)THEN
9961 X3=RANART(NSEED)
9962 IF(X3.GT.(1./3.))THEN
9963 LB(I)=2
9964 NLAB=2
9965 LPION(NNN,IRUN)=5
9966 EPION(NNN,IRUN)=AP2
9967 ELSE
9968 LB(I)=1
9969 NLAB=1
9970 LPION(NNN,IRUN)=4
9971 EPION(NNN,IRUN)=AP1
9972 ENDIF
9973*2. FOR N*0(1440) DECAY
9974 ELSEIF(iabs(LB(I)).EQ.10)THEN
9975 X4=RANART(NSEED)
9976 IF(X4.GT.(1./3.))THEN
9977 LB(I)=1
9978 NLAB=1
9979 LPION(NNN,IRUN)=3
9980 EPION(NNN,IRUN)=AP2
9981 ELSE
9982 LB(I)=2
9983 NALB=2
9984 LPION(NNN,IRUN)=4
9985 EPION(NNN,IRUN)=AP1
9986 ENDIF
9987* N*(1535) CAN DECAY TO A PION OR AN ETA IF DM > 1.49 GeV
9988*3 N*(0)(1535) DECAY
9989 ELSEIF(iabs(LB(I)).EQ.12)THEN
9990 CTRL=0.65
9991 IF(DM.lE.1.49)ctrl=-1.
9992 X5=RANART(NSEED)
9993 IF(X5.GE.ctrl)THEN
9994* DECAY TO PION+NUCLEON
9995 X6=RANART(NSEED)
9996 IF(X6.GT.(1./3.))THEN
9997 LB(I)=1
9998 NLAB=1
9999 LPION(NNN,IRUN)=3
10000 EPION(NNN,IRUN)=AP2
10001 ELSE
10002 LB(I)=2
10003 NALB=2
10004 LPION(NNN,IRUN)=4
10005 EPION(NNN,IRUN)=AP1
10006 ENDIF
10007 ELSE
10008* DECAY TO ETA+NEUTRON
10009 LB(I)=2
10010 NLAB=2
10011 LPION(NNN,IRUN)=0
10012 EPION(NNN,IRUN)=ETAM
10013 ENDIF
10014*4. FOR N*+(1535) DECAY
10015 ELSEIF(iabs(LB(I)).EQ.13)THEN
10016 CTRL=0.65
10017 IF(DM.lE.1.49)ctrl=-1.
10018 X5=RANART(NSEED)
10019 IF(X5.GE.ctrl)THEN
10020* DECAY TO PION+NUCLEON
10021 X8=RANART(NSEED)
10022 IF(X8.GT.(1./3.))THEN
10023 LB(I)=2
10024 NLAB=2
10025 LPION(NNN,IRUN)=5
10026 EPION(NNN,IRUN)=AP2
10027 ELSE
10028 LB(I)=1
10029 NLAB=1
10030 LPION(NNN,IRUN)=4
10031 EPION(NNN,IRUN)=AP1
10032 ENDIF
10033 ELSE
10034* DECAY TO ETA+NUCLEON
10035 LB(I)=1
10036 NLAB=1
10037 LPION(NNN,IRUN)=0
10038 EPION(NNN,IRUN)=ETAM
10039 ENDIF
10040 ENDIF
10041c
10042 CALL DKINE(IRUN,I,NNN,NLAB,ISEED,wid,nt)
10043c
10044c anti-particle ID for anti-N* decays:
10045 if(lbanti.lt.0) then
10046 lbi=LB(I)
10047 if(lbi.eq.1.or.lbi.eq.2) then
10048 lbi=-lbi
10049 elseif(lbi.eq.3) then
10050 lbi=5
10051 elseif(lbi.eq.5) then
10052 lbi=3
10053 endif
10054 LB(I)=lbi
10055c
10056 lbi=LPION(NNN,IRUN)
10057 if(lbi.eq.3) then
10058 lbi=5
10059 elseif(lbi.eq.5) then
10060 lbi=3
10061 elseif(lbi.eq.1.or.lbi.eq.2) then
10062 lbi=-lbi
10063 endif
10064 LPION(NNN,IRUN)=lbi
10065 endif
10066c
10067 if(nt.eq.ntmax) then
10068c at the last timestep, assign rho or eta (decay daughter)
10069c to lb(i1) only (not to lpion) in order to decay them again:
10070 lbm=LPION(NNN,IRUN)
10071 if(lbm.eq.0.or.lbm.eq.25
10072 1 .or.lbm.eq.26.or.lbm.eq.27) then
10073c switch rho or eta with baryon, positions are the same (no change needed):
10074 lbsave=lbm
10075 xmsave=EPION(NNN,IRUN)
10076 pxsave=PPION(1,NNN,IRUN)
10077 pysave=PPION(2,NNN,IRUN)
10078 pzsave=PPION(3,NNN,IRUN)
10079clin-5/2008:
10080 dpsave=dppion(NNN,IRUN)
10081 LPION(NNN,IRUN)=LB(I)
10082 EPION(NNN,IRUN)=E(I)
10083 PPION(1,NNN,IRUN)=P(1,I)
10084 PPION(2,NNN,IRUN)=P(2,I)
10085 PPION(3,NNN,IRUN)=P(3,I)
10086clin-5/2008:
10087 dppion(NNN,IRUN)=dpertp(I)
10088 LB(I)=lbsave
10089 E(I)=xmsave
10090 P(1,I)=pxsave
10091 P(2,I)=pysave
10092 P(3,I)=pzsave
10093clin-5/2008:
10094 dpertp(I)=dpsave
10095 endif
10096 endif
10097
10098 RETURN
10099 END
10100
10101*-------------------------------------------------------------------
10102*-------------------------------------------------------------------
10103* PURPOSE:
10104* CALCULATE THE MOMENTUM OF NUCLEON AND PION (OR ETA)
10105* IN THE LAB. FRAME AFTER DELTA OR N* DECAY
10106* DATE : JAN. 24,1990, MODIFIED ON MAY 17, 1994 TO INCLUDE ETA PRODUCTION
10107 SUBROUTINE DKINE(IRUN,I,NNN,NLAB,ISEED,wid,nt)
10108 PARAMETER (hbarc=0.19733)
10109 PARAMETER (MAXSTR=150001,MAXR=1,
10110 1 AMN=0.939457,AMP=0.93828,ETAM=0.5475,
10111 2 AP1=0.13496,AP2=0.13957,AM0=1.232,PI=3.1415926)
10112 COMMON /AA/ R(3,MAXSTR)
10113cc SAVE /AA/
10114 COMMON /BB/ P(3,MAXSTR)
10115cc SAVE /BB/
10116 COMMON /CC/ E(MAXSTR)
10117cc SAVE /CC/
10118 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
10119cc SAVE /EE/
10120 COMMON /RUN/NUM
10121cc SAVE /RUN/
10122 COMMON /PA/RPION(3,MAXSTR,MAXR)
10123cc SAVE /PA/
10124 COMMON /PB/PPION(3,MAXSTR,MAXR)
10125cc SAVE /PB/
10126 COMMON /PC/EPION(MAXSTR,MAXR)
10127cc SAVE /PC/
10128 COMMON /PD/LPION(MAXSTR,MAXR)
10129cc SAVE /PD/
10130 common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
10131 1 px1n,py1n,pz1n,dp1n
10132cc SAVE /leadng/
10133 COMMON/tdecay/tfdcy(MAXSTR),tfdpi(MAXSTR,MAXR),tft(MAXSTR)
10134cc SAVE /tdecay/
10135 COMMON /INPUT2/ ILAB, MANYB, NTMAX, ICOLL, INSYS, IPOT, MODE,
10136 & IMOMEN, NFREQ, ICFLOW, ICRHO, ICOU, KPOTEN, KMUL
10137cc SAVE /INPUT2/
10138 COMMON/RNDF77/NSEED
10139cc SAVE /RNDF77/
10140 COMMON /dpert/dpertt(MAXSTR,MAXR),dpertp(MAXSTR),dplast(MAXSTR),
10141 1 dpdcy(MAXSTR),dpdpi(MAXSTR,MAXR),dpt(MAXSTR, MAXR),
10142 2 dpp1(MAXSTR,MAXR),dppion(MAXSTR,MAXR)
10143 EXTERNAL IARFLV, INVFLV
10144 SAVE
10145 ISEED=ISEED
10146* READ IN THE COORDINATES OF DELTA OR N* UNDERGOING DECAY
10147 PX=P(1,I)
10148 PY=P(2,I)
10149 PZ=P(3,I)
10150 RX=R(1,I)
10151 RY=R(2,I)
10152 RZ=R(3,I)
10153 DM=E(I)
10154 EDELTA=SQRT(DM**2+PX**2+PY**2+PZ**2)
10155 PM=EPION(NNN,IRUN)
10156 AM=AMP
10157 IF(NLAB.EQ.2)AM=AMN
10158* FIND OUT THE MOMENTUM AND ENERGY OF PION AND NUCLEON IN DELTA REST FRAME
10159* THE MAGNITUDE OF MOMENTUM IS DETERMINED BY ENERGY CONSERVATION ,THE FORMULA
10160* CAN BE FOUND ON PAGE 716,W BAUER P.R.C40,1989
10161* THE DIRECTION OF THE MOMENTUM IS ASSUMED ISOTROPIC. NOTE THAT P(PION)=-P(N)
10162 Q2=((DM**2-AM**2+PM**2)/(2.*DM))**2-PM**2
10163 IF(Q2.LE.0.)Q2=1.e-09
10164 Q=SQRT(Q2)
1016511 QX=1.-2.*RANART(NSEED)
10166 QY=1.-2.*RANART(NSEED)
10167 QZ=1.-2.*RANART(NSEED)
10168 QS=QX**2+QY**2+QZ**2
10169 IF(QS.GT.1.) GO TO 11
10170 PXP=Q*QX/SQRT(QS)
10171 PYP=Q*QY/SQRT(QS)
10172 PZP=Q*QZ/SQRT(QS)
10173 EP=SQRT(Q**2+PM**2)
10174 PXN=-PXP
10175 PYN=-PYP
10176 PZN=-PZP
10177 EN=SQRT(Q**2+AM**2)
10178* TRANSFORM INTO THE LAB. FRAME. THE GENERAL LORENTZ TRANSFORMATION CAN
10179* BE FOUND ON PAGE 34 OF R. HAGEDORN " RELATIVISTIC KINEMATICS"
10180 GD=EDELTA/DM
10181 FGD=GD/(1.+GD)
10182 BDX=PX/EDELTA
10183 BDY=PY/EDELTA
10184 BDZ=PZ/EDELTA
10185 BPP=BDX*PXP+BDY*PYP+BDZ*PZP
10186 BPN=BDX*PXN+BDY*PYN+BDZ*PZN
10187 P(1,I)=PXN+BDX*GD*(FGD*BPN+EN)
10188 P(2,I)=PYN+BDY*GD*(FGD*BPN+EN)
10189 P(3,I)=PZN+BDZ*GD*(FGD*BPN+EN)
10190 E(I)=AM
10191* WE ASSUME THAT THE SPACIAL COORDINATE OF THE NUCLEON
10192* IS THAT OF THE DELTA
10193 PPION(1,NNN,IRUN)=PXP+BDX*GD*(FGD*BPP+EP)
10194 PPION(2,NNN,IRUN)=PYP+BDY*GD*(FGD*BPP+EP)
10195 PPION(3,NNN,IRUN)=PZP+BDZ*GD*(FGD*BPP+EP)
10196clin-5/2008:
10197 dppion(NNN,IRUN)=dpertp(I)
10198* WE ASSUME THE PION OR ETA COMING FROM DELTA DECAY IS LOCATED ON THE SPHERE
10199* OF RADIUS 0.5FM AROUND DELTA, THIS POINT NEED TO BE CHECKED
10200* AND OTHER CRIERTION MAY BE TRIED
10201clin-2/20/03 no additional smearing for position of decay daughters:
10202c200 X0 = 1.0 - 2.0 * RANART(NSEED)
10203c Y0 = 1.0 - 2.0 * RANART(NSEED)
10204c Z0 = 1.0 - 2.0 * RANART(NSEED)
10205c IF ((X0*X0+Y0*Y0+Z0*Z0) .GT. 1.0) GOTO 200
10206c RPION(1,NNN,IRUN)=R(1,I)+0.5*x0
10207c RPION(2,NNN,IRUN)=R(2,I)+0.5*y0
10208c RPION(3,NNN,IRUN)=R(3,I)+0.5*z0
10209 RPION(1,NNN,IRUN)=R(1,I)
10210 RPION(2,NNN,IRUN)=R(2,I)
10211 RPION(3,NNN,IRUN)=R(3,I)
10212c
10213 devio=SQRT(EPION(NNN,IRUN)**2+PPION(1,NNN,IRUN)**2
10214 1 +PPION(2,NNN,IRUN)**2+PPION(3,NNN,IRUN)**2)
10215 2 +SQRT(E(I)**2+P(1,I)**2+P(2,I)**2+P(3,I)**2)-e1
10216c if(abs(devio).gt.0.02) write(93,*) 'decay(): nt=',nt,devio,lb1
10217
10218c add decay time to daughter's formation time at the last timestep:
10219 if(nt.eq.ntmax) then
10220 tau0=hbarc/wid
10221 taudcy=tau0*(-1.)*alog(1.-RANART(NSEED))
10222c lorentz boost:
10223 taudcy=taudcy*e1/em1
10224 tfnl=tfnl+taudcy
10225 xfnl=xfnl+px1/e1*taudcy
10226 yfnl=yfnl+py1/e1*taudcy
10227 zfnl=zfnl+pz1/e1*taudcy
10228 R(1,I)=xfnl
10229 R(2,I)=yfnl
10230 R(3,I)=zfnl
10231 tfdcy(I)=tfnl
10232 RPION(1,NNN,IRUN)=xfnl
10233 RPION(2,NNN,IRUN)=yfnl
10234 RPION(3,NNN,IRUN)=zfnl
10235 tfdpi(NNN,IRUN)=tfnl
10236 endif
10237
10238cc 200 format(a30,2(1x,e10.4))
10239cc 210 format(i6,5(1x,f8.3))
10240cc 220 format(a2,i5,5(1x,f8.3))
10241
10242 RETURN
10243 END
10244
10245*-----------------------------------------------------------------------------
10246*-----------------------------------------------------------------------------
10247* PURPOSE:1. N*-->N+PION+PION DECAY PRODUCTS
10248* 2. DETERMINE THE MOMENTUM AND COORDINATES OF NUCLEON AND PION
10249* AFTER THE DELTA OR N* DECAYING
10250* DATE : NOV.7,1994
10251*----------------------------------------------------------------------------
10252 SUBROUTINE DECAY2(IRUN,I,NNN,ISEED,wid,nt)
10253 PARAMETER (MAXSTR=150001,MAXR=1,
10254 1 AMN=0.939457,ETAM=0.5475,AMP=0.93828,AP1=0.13496,
10255 2 AP2=0.13957,AM0=1.232,PI=3.1415926)
10256 COMMON /AA/ R(3,MAXSTR)
10257cc SAVE /AA/
10258 COMMON /BB/ P(3,MAXSTR)
10259cc SAVE /BB/
10260 COMMON /CC/ E(MAXSTR)
10261cc SAVE /CC/
10262 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
10263cc SAVE /EE/
10264 COMMON /RUN/NUM
10265cc SAVE /RUN/
10266 COMMON /PA/RPION(3,MAXSTR,MAXR)
10267cc SAVE /PA/
10268 COMMON /PB/PPION(3,MAXSTR,MAXR)
10269cc SAVE /PB/
10270 COMMON /PC/EPION(MAXSTR,MAXR)
10271cc SAVE /PC/
10272 COMMON /PD/LPION(MAXSTR,MAXR)
10273cc SAVE /PD/
10274 COMMON/RNDF77/NSEED
10275cc SAVE /RNDF77/
10276 SAVE
10277
10278 lbanti=LB(I)
10279c
10280 DM=E(I)
10281* DETERMINE THE DECAY PRODUCTS
10282* FOR N*+(1440) DECAY
10283 IF(iabs(LB(I)).EQ.11)THEN
10284 X3=RANART(NSEED)
10285 IF(X3.LT.(1./3))THEN
10286 LB(I)=2
10287 NLAB=2
10288 LPION(NNN,IRUN)=5
10289 EPION(NNN,IRUN)=AP2
10290 LPION(NNN+1,IRUN)=4
10291 EPION(NNN+1,IRUN)=AP1
10292 ELSEIF(X3.LT.2./3.AND.X3.GT.1./3.)THEN
10293 LB(I)=1
10294 NLAB=1
10295 LPION(NNN,IRUN)=5
10296 EPION(NNN,IRUN)=AP2
10297 LPION(NNN+1,IRUN)=3
10298 EPION(NNN+1,IRUN)=AP2
10299 ELSE
10300 LB(I)=1
10301 NLAB=1
10302 LPION(NNN,IRUN)=4
10303 EPION(NNN,IRUN)=AP1
10304 LPION(NNN+1,IRUN)=4
10305 EPION(NNN+1,IRUN)=AP1
10306 ENDIF
10307* FOR N*0(1440) DECAY
10308 ELSEIF(iabs(LB(I)).EQ.10)THEN
10309 X3=RANART(NSEED)
10310 IF(X3.LT.(1./3))THEN
10311 LB(I)=2
10312 NLAB=2
10313 LPION(NNN,IRUN)=4
10314 EPION(NNN,IRUN)=AP1
10315 LPION(NNN+1,IRUN)=4
10316 EPION(NNN+1,IRUN)=AP1
10317 ELSEIF(X3.LT.2./3.AND.X3.GT.1./3.)THEN
10318 LB(I)=1
10319 NLAB=1
10320 LPION(NNN,IRUN)=3
10321 EPION(NNN,IRUN)=AP2
10322 LPION(NNN+1,IRUN)=4
10323 EPION(NNN+1,IRUN)=AP1
10324 ELSE
10325 LB(I)=2
10326 NLAB=2
10327 LPION(NNN,IRUN)=5
10328 EPION(NNN,IRUN)=AP2
10329 LPION(NNN+1,IRUN)=3
10330 EPION(NNN+1,IRUN)=AP2
10331 ENDIF
10332 ENDIF
10333
10334 CALL DKINE2(IRUN,I,NNN,NLAB,ISEED,wid,nt)
10335c
10336c anti-particle ID for anti-N* decays:
10337 if(lbanti.lt.0) then
10338 lbi=LB(I)
10339 if(lbi.eq.1.or.lbi.eq.2) then
10340 lbi=-lbi
10341 elseif(lbi.eq.3) then
10342 lbi=5
10343 elseif(lbi.eq.5) then
10344 lbi=3
10345 endif
10346 LB(I)=lbi
10347c
10348 lbi=LPION(NNN,IRUN)
10349 if(lbi.eq.3) then
10350 lbi=5
10351 elseif(lbi.eq.5) then
10352 lbi=3
10353 elseif(lbi.eq.1.or.lbi.eq.2) then
10354 lbi=-lbi
10355 endif
10356 LPION(NNN,IRUN)=lbi
10357c
10358 lbi=LPION(NNN+1,IRUN)
10359 if(lbi.eq.3) then
10360 lbi=5
10361 elseif(lbi.eq.5) then
10362 lbi=3
10363 elseif(lbi.eq.1.or.lbi.eq.2) then
10364 lbi=-lbi
10365 endif
10366 LPION(NNN+1,IRUN)=lbi
10367 endif
10368c
10369 RETURN
10370 END
10371*-------------------------------------------------------------------
10372*--------------------------------------------------------------------------
10373* CALCULATE THE MOMENTUM OF NUCLEON AND PION (OR ETA)
10374* IN THE LAB. FRAME AFTER DELTA OR N* DECAY
10375* DATE : JAN. 24,1990, MODIFIED ON MAY 17, 1994 TO INCLUDE ETA PRODUCTION
10376*--------------------------------------------------------------------------
10377 SUBROUTINE DKINE2(IRUN,I,NNN,NLAB,ISEED,wid,nt)
10378 PARAMETER (hbarc=0.19733)
10379 PARAMETER (MAXSTR=150001,MAXR=1,
10380 1 AMN=0.939457,AMP=0.93828,ETAM=0.5475,
10381 2 AP1=0.13496,AP2=0.13957,AM0=1.232,PI=3.1415926)
10382 COMMON /AA/ R(3,MAXSTR)
10383cc SAVE /AA/
10384 COMMON /BB/ P(3,MAXSTR)
10385cc SAVE /BB/
10386 COMMON /CC/ E(MAXSTR)
10387cc SAVE /CC/
10388 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
10389cc SAVE /EE/
10390 COMMON /RUN/NUM
10391cc SAVE /RUN/
10392 COMMON /PA/RPION(3,MAXSTR,MAXR)
10393cc SAVE /PA/
10394 COMMON /PB/PPION(3,MAXSTR,MAXR)
10395cc SAVE /PB/
10396 COMMON /PC/EPION(MAXSTR,MAXR)
10397cc SAVE /PC/
10398 COMMON /PD/LPION(MAXSTR,MAXR)
10399cc SAVE /PD/
10400 common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
10401 1 px1n,py1n,pz1n,dp1n
10402cc SAVE /leadng/
10403 COMMON/tdecay/tfdcy(MAXSTR),tfdpi(MAXSTR,MAXR),tft(MAXSTR)
10404cc SAVE /tdecay/
10405 COMMON /INPUT2/ ILAB, MANYB, NTMAX, ICOLL, INSYS, IPOT, MODE,
10406 & IMOMEN, NFREQ, ICFLOW, ICRHO, ICOU, KPOTEN, KMUL
10407cc SAVE /INPUT2/
10408 EXTERNAL IARFLV, INVFLV
10409 COMMON/RNDF77/NSEED
10410cc SAVE /RNDF77/
10411 COMMON /dpert/dpertt(MAXSTR,MAXR),dpertp(MAXSTR),dplast(MAXSTR),
10412 1 dpdcy(MAXSTR),dpdpi(MAXSTR,MAXR),dpt(MAXSTR, MAXR),
10413 2 dpp1(MAXSTR,MAXR),dppion(MAXSTR,MAXR)
10414 SAVE
10415
10416 ISEED=ISEED
10417* READ IN THE COORDINATES OF THE N*(1440) UNDERGOING DECAY
10418 PX=P(1,I)
10419 PY=P(2,I)
10420 PZ=P(3,I)
10421 RX=R(1,I)
10422 RY=R(2,I)
10423 RZ=R(3,I)
10424 DM=E(I)
10425 EDELTA=SQRT(DM**2+PX**2+PY**2+PZ**2)
10426 PM1=EPION(NNN,IRUN)
10427 PM2=EPION(NNN+1,IRUN)
10428 AM=AMN
10429 IF(NLAB.EQ.1)AM=AMP
10430* THE MAXIMUM MOMENTUM OF THE NUCLEON FROM THE DECAY OF A N*
10431 PMAX2=(DM**2-(AM+PM1+PM2)**2)*(DM**2-(AM-PM1-PM2)**2)/4/DM**2
10432 PMAX=SQRT(PMAX2)
10433* GENERATE THE MOMENTUM OF THE NUCLEON IN THE N* REST FRAME
10434 CSS=1.-2.*RANART(NSEED)
10435 SSS=SQRT(1-CSS**2)
10436 FAI=2*PI*RANART(NSEED)
10437 PX0=PMAX*SSS*COS(FAI)
10438 PY0=PMAX*SSS*SIN(FAI)
10439 PZ0=PMAX*CSS
10440 EP0=SQRT(PX0**2+PY0**2+PZ0**2+AM**2)
10441clin-5/23/01 bug: P0 for pion0 is equal to PMAX, leaving pion+ and pion-
10442c without no relative momentum, thus producing them with equal momenta,
10443* BETA AND GAMMA OF THE CMS OF PION+-PION-
10444 BETAX=-PX0/(DM-EP0)
10445 BETAY=-PY0/(DM-EP0)
10446 BETAZ=-PZ0/(DM-EP0)
10447 GD1=1./SQRT(1-BETAX**2-BETAY**2-BETAZ**2)
10448 FGD1=GD1/(1+GD1)
10449* GENERATE THE MOMENTA OF PIONS IN THE CMS OF PION+PION-
10450 Q2=((DM-EP0)/(2.*GD1))**2-PM1**2
10451 IF(Q2.LE.0.)Q2=1.E-09
10452 Q=SQRT(Q2)
1045311 QX=1.-2.*RANART(NSEED)
10454 QY=1.-2.*RANART(NSEED)
10455 QZ=1.-2.*RANART(NSEED)
10456 QS=QX**2+QY**2+QZ**2
10457 IF(QS.GT.1.) GO TO 11
10458 PXP=Q*QX/SQRT(QS)
10459 PYP=Q*QY/SQRT(QS)
10460 PZP=Q*QZ/SQRT(QS)
10461 EP=SQRT(Q**2+PM1**2)
10462 PXN=-PXP
10463 PYN=-PYP
10464 PZN=-PZP
10465 EN=SQRT(Q**2+PM2**2)
10466* TRANSFORM THE MOMENTA OF PION+PION- INTO THE N* REST FRAME
10467 BPP1=BETAX*PXP+BETAY*PYP+BETAZ*PZP
10468 BPN1=BETAX*PXN+BETAY*PYN+BETAZ*PZN
10469* FOR PION-
10470 P1M=PXN+BETAX*GD1*(FGD1*BPN1+EN)
10471 P2M=PYN+BETAY*GD1*(FGD1*BPN1+EN)
10472 P3M=PZN+BETAZ*GD1*(FGD1*BPN1+EN)
10473 EPN=SQRT(P1M**2+P2M**2+P3M**2+PM2**2)
10474* FOR PION+
10475 P1P=PXP+BETAX*GD1*(FGD1*BPP1+EP)
10476 P2P=PYP+BETAY*GD1*(FGD1*BPP1+EP)
10477 P3P=PZP+BETAZ*GD1*(FGD1*BPP1+EP)
10478 EPP=SQRT(P1P**2+P2P**2+P3P**2+PM1**2)
10479* TRANSFORM MOMENTA OF THE THREE PIONS INTO THE
10480* THE NUCLEUS-NUCLEUS CENTER OF MASS FRAME.
10481* THE GENERAL LORENTZ TRANSFORMATION CAN
10482* BE FOUND ON PAGE 34 OF R. HAGEDORN " RELATIVISTIC KINEMATICS"
10483 GD=EDELTA/DM
10484 FGD=GD/(1.+GD)
10485 BDX=PX/EDELTA
10486 BDY=PY/EDELTA
10487 BDZ=PZ/EDELTA
10488 BP0=BDX*PX0+BDY*PY0+BDZ*PZ0
10489 BPP=BDX*P1P+BDY*P2P+BDZ*P3P
10490 BPN=BDX*P1M+BDY*P2M+BDZ*P3M
10491* FOR THE NUCLEON
10492 P(1,I)=PX0+BDX*GD*(FGD*BP0+EP0)
10493 P(2,I)=PY0+BDY*GD*(FGD*BP0+EP0)
10494 P(3,I)=PZ0+BDZ*GD*(FGD*BP0+EP0)
10495 E(I)=am
10496 ID(I)=0
10497 enucl=sqrt(p(1,i)**2+p(2,i)**2+p(3,i)**2+e(i)**2)
10498* WE ASSUME THAT THE SPACIAL COORDINATE OF THE PION0
10499* IS in a sphere of radius 0.5 fm around N*
10500* FOR PION+
10501 PPION(1,NNN,IRUN)=P1P+BDX*GD*(FGD*BPP+EPP)
10502 PPION(2,NNN,IRUN)=P2P+BDY*GD*(FGD*BPP+EPP)
10503 PPION(3,NNN,IRUN)=P3P+BDZ*GD*(FGD*BPP+EPP)
10504 epion1=sqrt(ppion(1,nnn,irun)**2
10505 & +ppion(2,nnn,irun)**2+ppion(3,nnn,irun)**2
10506 & +epion(nnn,irun)**2)
10507clin-2/20/03 no additional smearing for position of decay daughters:
10508c200 X0 = 1.0 - 2.0 * RANART(NSEED)
10509c Y0 = 1.0 - 2.0 * RANART(NSEED)
10510c Z0 = 1.0 - 2.0 * RANART(NSEED)
10511c IF ((X0*X0+Y0*Y0+Z0*Z0) .GT. 1.0) GOTO 200
10512c RPION(1,NNN,IRUN)=R(1,I)+0.5*x0
10513c RPION(2,NNN,IRUN)=R(2,I)+0.5*y0
10514c RPION(3,NNN,IRUN)=R(3,I)+0.5*z0
10515 RPION(1,NNN,IRUN)=R(1,I)
10516 RPION(2,NNN,IRUN)=R(2,I)
10517 RPION(3,NNN,IRUN)=R(3,I)
10518* FOR PION-
10519 PPION(1,NNN+1,IRUN)=P1M+BDX*GD*(FGD*BPN+EPN)
10520 PPION(2,NNN+1,IRUN)=P2M+BDY*GD*(FGD*BPN+EPN)
10521 PPION(3,NNN+1,IRUN)=P3M+BDZ*GD*(FGD*BPN+EPN)
10522clin-5/2008:
10523 dppion(NNN,IRUN)=dpertp(I)
10524 dppion(NNN+1,IRUN)=dpertp(I)
10525c
10526 epion2=sqrt(ppion(1,nnn+1,irun)**2
10527 & +ppion(2,nnn+1,irun)**2+ppion(3,nnn+1,irun)**2
10528 & +epion(nnn+1,irun)**2)
10529clin-2/20/03 no additional smearing for position of decay daughters:
10530c300 X0 = 1.0 - 2.0 * RANART(NSEED)
10531c Y0 = 1.0 - 2.0 * RANART(NSEED)
10532c Z0 = 1.0 - 2.0 * RANART(NSEED)
10533c IF ((X0*X0+Y0*Y0+Z0*Z0) .GT. 1.0) GOTO 300
10534c RPION(1,NNN+1,IRUN)=R(1,I)+0.5*x0
10535c RPION(2,NNN+1,IRUN)=R(2,I)+0.5*y0
10536c RPION(3,NNN+1,IRUN)=R(3,I)+0.5*z0
10537 RPION(1,NNN+1,IRUN)=R(1,I)
10538 RPION(2,NNN+1,IRUN)=R(2,I)
10539 RPION(3,NNN+1,IRUN)=R(3,I)
10540c
10541* check energy conservation in the decay
10542c efinal=enucl+epion1+epion2
10543c DEEE=(EDELTA-EFINAL)/EDELTA
10544c IF(ABS(DEEE).GE.1.E-03)write(6,*)1,edelta,efinal
10545
10546 devio=SQRT(EPION(NNN,IRUN)**2+PPION(1,NNN,IRUN)**2
10547 1 +PPION(2,NNN,IRUN)**2+PPION(3,NNN,IRUN)**2)
10548 2 +SQRT(E(I)**2+P(1,I)**2+P(2,I)**2+P(3,I)**2)
10549 3 +SQRT(EPION(NNN+1,IRUN)**2+PPION(1,NNN+1,IRUN)**2
10550 4 +PPION(2,NNN+1,IRUN)**2+PPION(3,NNN+1,IRUN)**2)-e1
10551c if(abs(devio).gt.0.02) write(93,*) 'decay2(): nt=',nt,devio,lb1
10552
10553c add decay time to daughter's formation time at the last timestep:
10554 if(nt.eq.ntmax) then
10555 tau0=hbarc/wid
10556 taudcy=tau0*(-1.)*alog(1.-RANART(NSEED))
10557c lorentz boost:
10558 taudcy=taudcy*e1/em1
10559 tfnl=tfnl+taudcy
10560 xfnl=xfnl+px1/e1*taudcy
10561 yfnl=yfnl+py1/e1*taudcy
10562 zfnl=zfnl+pz1/e1*taudcy
10563 R(1,I)=xfnl
10564 R(2,I)=yfnl
10565 R(3,I)=zfnl
10566 tfdcy(I)=tfnl
10567 RPION(1,NNN,IRUN)=xfnl
10568 RPION(2,NNN,IRUN)=yfnl
10569 RPION(3,NNN,IRUN)=zfnl
10570 tfdpi(NNN,IRUN)=tfnl
10571 RPION(1,NNN+1,IRUN)=xfnl
10572 RPION(2,NNN+1,IRUN)=yfnl
10573 RPION(3,NNN+1,IRUN)=zfnl
10574 tfdpi(NNN+1,IRUN)=tfnl
10575 endif
10576
10577cc 200 format(a30,2(1x,e10.4))
10578cc 210 format(i6,5(1x,f8.3))
10579cc 220 format(a2,i5,5(1x,f8.3))
10580
10581 RETURN
10582 END
10583*---------------------------------------------------------------------------
10584*---------------------------------------------------------------------------
10585* PURPOSE : CALCULATE THE MASS AND MOMENTUM OF BARYON RESONANCE
10586* AFTER PION OR ETA BEING ABSORBED BY A NUCLEON
10587* NOTE :
10588*
10589* DATE : JAN.29,1990
10590 SUBROUTINE DRESON(I1,I2)
10591 PARAMETER (MAXSTR=150001,MAXR=1,
10592 1 AMN=0.939457,AMP=0.93828,
10593 2 AP1=0.13496,AP2=0.13957,AM0=1.232,PI=3.1415926)
10594 COMMON /AA/ R(3,MAXSTR)
10595cc SAVE /AA/
10596 COMMON /BB/ P(3,MAXSTR)
10597cc SAVE /BB/
10598 COMMON /CC/ E(MAXSTR)
10599cc SAVE /CC/
10600 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
10601cc SAVE /EE/
10602 COMMON /RUN/NUM
10603cc SAVE /RUN/
10604 COMMON /PA/RPION(3,MAXSTR,MAXR)
10605cc SAVE /PA/
10606 COMMON /PB/PPION(3,MAXSTR,MAXR)
10607cc SAVE /PB/
10608 COMMON /PC/EPION(MAXSTR,MAXR)
10609cc SAVE /PC/
10610 COMMON /PD/LPION(MAXSTR,MAXR)
10611cc SAVE /PD/
10612 SAVE
10613* 1. DETERMINE THE MOMENTUM COMPONENT OF DELTA/N* IN THE LAB. FRAME
10614 E10=SQRT(E(I1)**2+P(1,I1)**2+P(2,I1)**2+P(3,I1)**2)
10615 E20=SQRT(E(I2)**2+P(1,I2)**2+P(2,I2)**2+P(3,I2)**2)
10616 IF(iabs(LB(I2)) .EQ. 1 .OR. iabs(LB(I2)) .EQ. 2 .OR.
10617 & (iabs(LB(I2)) .GE. 6 .AND. iabs(LB(I2)) .LE. 17)) THEN
10618 E(I1)=0.
10619 I=I2
10620 ELSE
10621 E(I2)=0.
10622 I=I1
10623 ENDIF
10624 P(1,I)=P(1,I1)+P(1,I2)
10625 P(2,I)=P(2,I1)+P(2,I2)
10626 P(3,I)=P(3,I1)+P(3,I2)
10627* 2. DETERMINE THE MASS OF DELTA/N* BY USING THE REACTION KINEMATICS
10628 DM=SQRT((E10+E20)**2-P(1,I)**2-P(2,I)**2-P(3,I)**2)
10629 E(I)=DM
10630 RETURN
10631 END
10632*---------------------------------------------------------------------------
10633* PURPOSE : CALCULATE THE MASS AND MOMENTUM OF RHO RESONANCE
10634* AFTER PION + PION COLLISION
10635* DATE : NOV. 30,1994
10636 SUBROUTINE RHORES(I1,I2)
10637 PARAMETER (MAXSTR=150001,MAXR=1,
10638 1 AMN=0.939457,AMP=0.93828,
10639 2 AP1=0.13496,AP2=0.13957,AM0=1.232,PI=3.1415926)
10640 COMMON /AA/ R(3,MAXSTR)
10641cc SAVE /AA/
10642 COMMON /BB/ P(3,MAXSTR)
10643cc SAVE /BB/
10644 COMMON /CC/ E(MAXSTR)
10645cc SAVE /CC/
10646 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
10647cc SAVE /EE/
10648 COMMON /RUN/NUM
10649cc SAVE /RUN/
10650 COMMON /PA/RPION(3,MAXSTR,MAXR)
10651cc SAVE /PA/
10652 COMMON /PB/PPION(3,MAXSTR,MAXR)
10653cc SAVE /PB/
10654 COMMON /PC/EPION(MAXSTR,MAXR)
10655cc SAVE /PC/
10656 COMMON /PD/LPION(MAXSTR,MAXR)
10657cc SAVE /PD/
10658 SAVE
10659* 1. DETERMINE THE MOMENTUM COMPONENT OF THE RHO IN THE CMS OF NN FRAME
10660* WE LET I1 TO BE THE RHO AND ABSORB I2
10661 E10=SQRT(E(I1)**2+P(1,I1)**2+P(2,I1)**2+P(3,I1)**2)
10662 E20=SQRT(E(I2)**2+P(1,I2)**2+P(2,I2)**2+P(3,I2)**2)
10663 P(1,I1)=P(1,I1)+P(1,I2)
10664 P(2,I1)=P(2,I1)+P(2,I2)
10665 P(3,I1)=P(3,I1)+P(3,I2)
10666* 2. DETERMINE THE MASS OF THE RHO BY USING THE REACTION KINEMATICS
10667 DM=SQRT((E10+E20)**2-P(1,I1)**2-P(2,I1)**2-P(3,I1)**2)
10668 E(I1)=DM
10669 E(I2)=0
10670 RETURN
10671 END
10672*---------------------------------------------------------------------------
10673* PURPOSE : CALCULATE THE PION+NUCLEON CROSS SECTION ACCORDING TO THE
10674* BREIT-WIGNER FORMULA/(p*)**2
10675* VARIABLE : LA = 1 FOR DELTA RESONANCE
10676* LA = 0 FOR N*(1440) RESONANCE
10677* LA = 2 FRO N*(1535) RESONANCE
10678* DATE : JAN.29,1990
10679 REAL FUNCTION XNPI(I1,I2,LA,XMAX)
10680 PARAMETER (MAXSTR=150001,MAXR=1,
10681 1 AMN=0.939457,AMP=0.93828,
10682 2 AP1=0.13496,AP2=0.13957,AM0=1.232,PI=3.1415926)
10683 COMMON /AA/ R(3,MAXSTR)
10684cc SAVE /AA/
10685 COMMON /BB/ P(3,MAXSTR)
10686cc SAVE /BB/
10687 COMMON /CC/ E(MAXSTR)
10688cc SAVE /CC/
10689 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
10690cc SAVE /EE/
10691 COMMON /RUN/NUM
10692cc SAVE /RUN/
10693 COMMON /PA/RPION(3,MAXSTR,MAXR)
10694cc SAVE /PA/
10695 COMMON /PB/PPION(3,MAXSTR,MAXR)
10696cc SAVE /PB/
10697 COMMON /PC/EPION(MAXSTR,MAXR)
10698cc SAVE /PC/
10699 COMMON /PD/LPION(MAXSTR,MAXR)
10700cc SAVE /PD/
10701 SAVE
10702 AVMASS=0.5*(AMN+AMP)
10703 AVPI=(2.*AP2+AP1)/3.
10704* 1. DETERMINE THE MOMENTUM COMPONENT OF DELTA IN THE LAB. FRAME
10705 E10=SQRT(E(I1)**2+P(1,I1)**2+P(2,I1)**2+P(3,I1)**2)
10706 E20=SQRT(E(I2)**2+P(1,I2)**2+P(2,I2)**2+P(3,I2)**2)
10707 P1=P(1,I1)+P(1,I2)
10708 P2=P(2,I1)+P(2,I2)
10709 P3=P(3,I1)+P(3,I2)
10710* 2. DETERMINE THE MASS OF DELTA BY USING OF THE REACTION KINEMATICS
10711 DM=SQRT((E10+E20)**2-P1**2-P2**2-P3**2)
10712 IF(DM.LE.1.1) THEN
10713 XNPI=1.e-09
10714 RETURN
10715 ENDIF
10716* 3. DETERMINE THE PION+NUCLEON CROSS SECTION ACCORDING TO THE
10717* BREIT-WIGNER FORMULA IN UNIT OF FM**2
10718 IF(LA.EQ.1)THEN
10719 GAM=WIDTH(DM)
10720 F1=0.25*GAM**2/(0.25*GAM**2+(DM-1.232)**2)
10721 PDELT2=0.051622
10722 GO TO 10
10723 ENDIF
10724 IF(LA.EQ.0)THEN
10725 GAM=W1440(DM)
10726 F1=0.25*GAM**2/(0.25*GAM**2+(DM-1.440)**2)
10727 PDELT2=0.157897
10728 GO TO 10
10729 ENDIF
10730 IF(LA.EQ.2)THEN
10731 GAM=W1535(DM)
10732 F1=0.25*GAM**2/(0.25*GAM**2+(DM-1.535)**2)
10733 PDELT2=0.2181
10734 ENDIF
1073510 PSTAR2=((DM**2-AVMASS**2+AVPI**2)/(2.*DM))**2-AVPI**2
10736 IF(PSTAR2.LE.0.)THEN
10737 XNPI=1.e-09
10738 ELSE
10739* give the cross section in unit of fm**2
10740 XNPI=F1*(PDELT2/PSTAR2)*XMAX/10.
10741 ENDIF
10742 RETURN
10743 END
10744*------------------------------------------------------------------------------
10745*****************************************
10746 REAL FUNCTION SIGMA(SRT,ID,IOI,IOF)
10747*PURPOSE : THIS IS THE PROGRAM TO CALCULATE THE ISOSPIN DECOMPOSED CROSS
10748* SECTION BY USING OF B.J.VerWEST AND R.A.ARNDT'S PARAMETERIZATION
10749*REFERENCE: PHYS. REV. C25(1982)1979
10750*QUANTITIES: IOI -- INITIAL ISOSPIN OF THE TWO NUCLEON SYSTEM
10751* IOF -- FINAL ISOSPIN -------------------------
10752* ID -- =1 FOR DELTA RESORANCE
10753* =2 FOR N* RESORANCE
10754*DATE : MAY 15,1990
10755*****************************************
10756 PARAMETER (AMU=0.9383,AMP=0.1384,PI=3.1415926,HC=0.19733)
10757 SAVE
10758 IF(ID.EQ.1)THEN
10759 AMASS0=1.22
10760 T0 =0.12
10761 ELSE
10762 AMASS0=1.43
10763 T0 =0.2
10764 ENDIF
10765 IF((IOI.EQ.1).AND.(IOF.EQ.1))THEN
10766 ALFA=3.772
10767 BETA=1.262
10768 AM0=1.188
10769 T=0.09902
10770 ENDIF
10771 IF((IOI.EQ.1).AND.(IOF.EQ.0))THEN
10772 ALFA=15.28
10773 BETA=0.
10774 AM0=1.245
10775 T=0.1374
10776 ENDIF
10777 IF((IOI.EQ.0).AND.(IOF.EQ.1))THEN
10778 ALFA=146.3
10779 BETA=0.
10780 AM0=1.472
10781 T=0.02649
10782 ENDIF
10783 ZPLUS=(SRT-AMU-AMASS0)*2./T0
10784 ZMINUS=(AMU+AMP-AMASS0)*2./T0
10785 deln=ATAN(ZPLUS)-ATAN(ZMINUS)
10786 if(deln.eq.0)deln=1.E-06
10787 AMASS=AMASS0+(T0/4.)*ALOG((1.+ZPLUS**2)/(1.+ZMINUS**2))
10788 1 /deln
10789 S=SRT**2
10790 P2=S/4.-AMU**2
10791 S0=(AMU+AM0)**2
10792 P02=S0/4.-AMU**2
10793 P0=SQRT(P02)
10794 PR2=(S-(AMU-AMASS)**2)*(S-(AMU+AMASS)**2)/(4.*S)
10795 IF(PR2.GT.1.E-06)THEN
10796 PR=SQRT(PR2)
10797 ELSE
10798 PR=0.
10799 SIGMA=1.E-06
10800 RETURN
10801 ENDIF
10802 SS=AMASS**2
10803 Q2=(SS-(AMU-AMP)**2)*(SS-(AMU+AMP)**2)/(4.*SS)
10804 IF(Q2.GT.1.E-06)THEN
10805 Q=SQRT(Q2)
10806 ELSE
10807 Q=0.
10808 SIGMA=1.E-06
10809 RETURN
10810 ENDIF
10811 SS0=AM0**2
10812 Q02=(SS0-(AMU-AMP)**2)*(SS0-(AMU+AMP)**2)/(4.*SS0)
10813 Q0=SQRT(Q02)
10814 SIGMA=PI*(HC)**2/(2.*P2)*ALFA*(PR/P0)**BETA*AM0**2*T**2
10815 1 *(Q/Q0)**3/((SS-AM0**2)**2+AM0**2*T**2)
10816 SIGMA=SIGMA*10.
10817 IF(SIGMA.EQ.0)SIGMA=1.E-06
10818 RETURN
10819 END
10820
10821*****************************
10822 REAL FUNCTION DENOM(SRT,CON)
10823* NOTE: CON=1 FOR DELTA RESONANCE, CON=2 FOR N*(1440) RESONANCE
10824* con=-1 for N*(1535)
10825* PURPOSE : CALCULATE THE INTEGRAL IN THE DETAILED BALANCE
10826*
10827* DATE : NOV. 15, 1991
10828*******************************
10829 PARAMETER (AP1=0.13496,
10830 1 AP2=0.13957,PI=3.1415926,AVMASS=0.9383)
10831 SAVE
10832 AVPI=(AP1+2.*AP2)/3.
10833 AM0=1.232
10834 AMN=AVMASS
10835 AMP=AVPI
10836 AMAX=SRT-AVMASS
10837 AMIN=AVMASS+AVPI
10838 NMAX=200
10839 DMASS=(AMAX-AMIN)/FLOAT(NMAX)
10840 SUM=0.
10841 DO 10 I=1,NMAX+1
10842 DM=AMIN+FLOAT(I-1)*DMASS
10843 IF(CON.EQ.1.)THEN
10844 Q2=((DM**2-AMN**2+AMP**2)/(2.*DM))**2-AMP**2
10845 IF(Q2.GT.0.)THEN
10846 Q=SQRT(Q2)
10847 ELSE
10848 Q=1.E-06
10849 ENDIF
10850 TQ=0.47*(Q**3)/(AMP**2*(1.+0.6*(Q/AMP)**2))
10851 ELSE if(con.eq.2)then
10852 TQ=0.2
10853 AM0=1.44
10854 else if(con.eq.-1.)then
10855 tq=0.1
10856 am0=1.535
10857 ENDIF
10858 A1=4.*TQ*AM0**2/(AM0**2*TQ**2+(DM**2-AM0**2)**2)
10859 S=SRT**2
10860 P0=(S+DM**2-AMN**2)**2/(4.*S)-DM**2
10861 IF(P0.LE.0.)THEN
10862 P1=1.E-06
10863 ELSE
10864 P1=SQRT(P0)
10865 ENDIF
10866 F=DM*A1*P1
10867 IF((I.EQ.1).OR.(I.EQ.(NMAX+1)))THEN
10868 SUM=SUM+F*0.5
10869 ELSE
10870 SUM=SUM+F
10871 ENDIF
1087210 CONTINUE
10873 DENOM=SUM*DMASS/(2.*PI)
10874 RETURN
10875 END
10876**********************************
10877* subroutine : ang.FOR
10878* PURPOSE : Calculate the angular distribution of Delta production process
10879* DATE : Nov. 19, 1992
10880* REFERENCE: G. WOLF ET. AL., NUCL. PHYS. A517 (1990) 615
10881* Note: this function applies when srt is larger than 2.14 GeV,
10882* for less energetic reactions, we assume the angular distribution
10883* is isotropic.
10884***********************************
3006c44b 10885 real function anga(srt,iseed)
0119ef9a 10886 COMMON/RNDF77/NSEED
10887cc SAVE /RNDF77/
10888 SAVE
10889 ISEED=ISEED
10890c if(srt.le.2.14)then
10891c b1s=0.5
10892c b2s=0.
10893c endif
10894 if((srt.gt.2.14).and.(srt.le.2.4))then
10895 b1s=29.03-23.75*srt+4.865*srt**2
10896 b2s=-30.33+25.53*srt-5.301*srt**2
10897 endif
10898 if(srt.gt.2.4)then
10899 b1s=0.06
10900 b2s=0.4
10901 endif
10902 x=RANART(NSEED)
10903 p=b1s/b2s
10904 q=(2.*x-1.)*(b1s+b2s)/b2s
10905 IF((-q/2.+sqrt((q/2.)**2+(p/3.)**3)).GE.0.)THEN
10906 ang1=(-q/2.+sqrt((q/2.)**2+(p/3.)**3))**(1./3.)
10907 ELSE
10908 ang1=-(q/2.-sqrt((q/2.)**2+(p/3.)**3))**(1./3.)
10909 ENDIF
10910 IF((-q/2.-sqrt((q/2.)**2+(p/3.)**3).GE.0.))THEN
10911 ang2=(-q/2.-sqrt((q/2.)**2+(p/3.)**3))**(1./3.)
10912 ELSE
10913 ang2=-(q/2.+sqrt((q/2.)**2+(p/3.)**3))**(1./3.)
10914 ENDIF
3006c44b 10915 ANGA=ANG1+ANG2
0119ef9a 10916 return
10917 end
10918*--------------------------------------------------------------------------
10919*****subprogram * kaon production from pi+B collisions *******************
10920 real function PNLKA(srt)
10921 SAVE
10922* units: fm**2
10923***********************************C
10924 ala=1.116
10925 aka=0.498
10926 ana=0.939
10927 t1=ala+aka
10928 if(srt.le.t1) THEN
10929 Pnlka=0
10930 Else
10931 IF(SRT.LT.1.7)sbbk=(0.9/0.091)*(SRT-T1)
10932 IF(SRT.GE.1.7)sbbk=0.09/(SRT-1.6)
10933 Pnlka=0.25*sbbk
10934* give the cross section in units of fm**2
10935 pnlka=pnlka/10.
10936 endif
10937 return
10938 end
10939*-------------------------------------------------------------------------
10940*****subprogram * kaon production from pi+B collisions *******************
10941 real function PNSKA(srt)
10942 SAVE
10943***********************************
10944 if(srt.gt.3.0)then
10945 pnska=0
10946 return
10947 endif
10948 ala=1.116
10949 aka=0.498
10950 ana=0.939
10951 asa=1.197
10952 t1=asa+aka
10953 if(srt.le.t1) THEN
10954 Pnska=0
10955 return
10956 Endif
10957 IF(SRT.LT.1.9)SBB1=(0.7/0.218)*(SRT-T1)
10958 IF(SRT.GE.1.9)SBB1=0.14/(SRT-1.7)
10959 sbb2=0.
10960 if(srt.gT.1.682)sbb2=0.5*(1.-0.75*(srt-1.682))
10961 pnska=0.25*(sbb1+sbb2)
10962* give the cross section in fm**2
10963 pnska=pnska/10.
10964 return
10965 end
10966
10967********************************
10968*
10969* Kaon momentum distribution in baryon-baryon-->N lamda K process
10970*
10971* NOTE: dsima/dp is prototional to (1-p/p_max)(p/p_max)^2
10972* we use rejection method to generate kaon momentum
10973*
10974* Variables: Fkaon = F(p)/F_max
10975* srt = cms energy of the colliding pair,
10976* used to calculate the P_max
10977* Date: Feb. 8, 1994
10978*
10979* Reference: C. M. Ko et al.
10980********************************
10981 Real function fkaon(p,pmax)
10982 SAVE
10983 fmax=0.148
10984 if(pmax.eq.0.)pmax=0.000001
10985 fkaon=(1.-p/pmax)*(p/pmax)**2
10986 if(fkaon.gt.fmax)fkaon=fmax
10987 fkaon=fkaon/fmax
10988 return
10989 end
10990
10991*************************
10992* cross section for N*(1535) production in ND OR NN* collisions
10993* VARIABLES:
10994* LB1,LB2 ARE THE LABLES OF THE TWO COLLIDING PARTICLES
10995* SRT IS THE CMS ENERGY
10996* X1535 IS THE N*(1535) PRODUCTION CROSS SECTION
10997* NOTE THAT THE N*(1535) PRODUCTION CROSS SECTION IS 2 TIMES THE ETA
10998* PRODUCTION CROSS SECTION
10999* DATE: MAY 18, 1994
11000* ***********************
11001 Subroutine M1535(LB1,LB2,SRT,X1535)
11002 SAVE
11003 S0=2.424
11004 x1535=0.
11005 IF(SRT.LE.S0)RETURN
11006 SIGMA=2.*0.102*(SRT-S0)/(0.058+(SRT-S0)**2)
11007* I N*(1535) PRODUCTION IN NUCLEON-DELTA COLLISIONS
11008*(1) nD(++)->pN*(+)(1535), pD(-)->nN*(0)(1535),pD(+)-->N*(+)p
11009cbz11/25/98
11010c IF((LB1*LB2.EQ.18).OR.(LB1*LB2.EQ.6).
11011c 1 or.(lb1*lb2).eq.8)then
11012 IF((LB1*LB2.EQ.18.AND.(LB1.EQ.2.OR.LB2.EQ.2)).OR.
11013 & (LB1*LB2.EQ.6.AND.(LB1.EQ.1.OR.LB2.EQ.1)).or.
11014 & (lb1*lb2.eq.8.AND.(LB1.EQ.1.OR.LB2.EQ.1)))then
11015cbz11/25/98end
11016 X1535=SIGMA
11017 return
11018 ENDIF
11019*(2) pD(0)->pN*(0)(1535),pD(0)->nN*(+)(1535)
11020 IF(LB1*LB2.EQ.7)THEN
11021 X1535=3.*SIGMA
11022 RETURN
11023 ENDIF
11024* II N*(1535) PRODUCTION IN N*(1440)+NUCLEON REACTIONS
11025*(3) N*(+)(1440)p->N*(0+)(1535)p, N*(0)(1440)n->N*(0)(1535)
11026cbz11/25/98
11027c IF((LB1*LB2.EQ.11).OR.(LB1*LB2.EQ.20))THEN
11028 IF((LB1*LB2.EQ.11).OR.
11029 & (LB1*LB2.EQ.20.AND.(LB1.EQ.2.OR.LB2.EQ.2)))THEN
11030cbz11/25/98end
11031 X1535=SIGMA
11032 RETURN
11033 ENDIF
11034*(4) N*(0)(1440)p->N*(0+) or N*(+)(1440)n->N*(0+)(1535)
11035cbz11/25/98
11036c IF((LB1*LB2.EQ.10).OR.(LB1*LB2.EQ.22))X1535=3.*SIGMA
11037 IF((LB1*LB2.EQ.10.AND.(LB1.EQ.1.OR.LB2.EQ.1)).OR.
11038 & (LB1*LB2.EQ.22.AND.(LB1.EQ.2.OR.LB2.EQ.2)))
11039 & X1535=3.*SIGMA
11040cbz11/25/98end
11041 RETURN
11042 END
11043*************************
11044* cross section for N*(1535) production in NN collisions
11045* VARIABLES:
11046* LB1,LB2 ARE THE LABLES OF THE TWO COLLIDING PARTICLES
11047* SRT IS THE CMS ENERGY
11048* X1535 IS THE N*(1535) PRODUCTION CROSS SECTION
11049* NOTE THAT THE N*(1535) PRODUCTION CROSS SECTION IS 2 TIMES THE ETA
11050* PRODUCTION CROSS SECTION
11051* DATE: MAY 18, 1994
11052* ***********************
11053 Subroutine N1535(LB1,LB2,SRT,X1535)
11054 SAVE
11055 S0=2.424
11056 x1535=0.
11057 IF(SRT.LE.S0)RETURN
11058 SIGMA=2.*0.102*(SRT-S0)/(0.058+(SRT-S0)**2)
11059* I N*(1535) PRODUCTION IN NUCLEON-NUCLEON COLLISIONS
11060*(1) pp->pN*(+)(1535), nn->nN*(0)(1535)
11061cbdbg11/25/98
11062c IF((LB1*LB2.EQ.1).OR.(LB1*LB2.EQ.4))then
11063 IF((LB1*LB2.EQ.1).OR.
11064 & (LB1.EQ.2.AND.LB2.EQ.2))then
11065cbz11/25/98end
11066 X1535=SIGMA
11067 return
11068 endif
11069*(2) pn->pN*(0)(1535),pn->nN*(+)(1535)
11070 IF(LB1*LB2.EQ.2)then
11071 X1535=3.*SIGMA
11072 return
11073 endif
11074* III N*(1535) PRODUCTION IN DELTA+DELTA REACTIONS
11075* (5) D(++)+D(0), D(+)+D(+),D(+)+D(-),D(0)+D(0)
11076cbz11/25/98
11077c IF((LB1*LB2.EQ.63).OR.(LB1*LB2.EQ.64).OR.(LB1*LB2.EQ.48).
11078c 1 OR.(LB1*LB2.EQ.49))then
11079 IF((LB1*LB2.EQ.63.AND.(LB1.EQ.7.OR.LB2.EQ.7)).OR.
11080 & (LB1*LB2.EQ.64.AND.(LB1.EQ.8.OR.LB2.EQ.8)).OR.
11081 & (LB1*LB2.EQ.48.AND.(LB1.EQ.6.OR.LB2.EQ.6)).OR.
11082 & (LB1*LB2.EQ.49.AND.(LB1.EQ.7.OR.LB2.EQ.7)))then
11083cbz11/25/98end
11084 X1535=SIGMA
11085 return
11086 endif
11087* (6) D(++)+D(-),D(+)+D(0)
11088cbz11/25/98
11089c IF((LB1*LB2.EQ.54).OR.(LB1*LB2.EQ.56))then
11090 IF((LB1*LB2.EQ.54.AND.(LB1.EQ.6.OR.LB2.EQ.6)).OR.
11091 & (LB1*LB2.EQ.56.AND.(LB1.EQ.7.OR.LB2.EQ.7)))then
11092cbz11/25/98end
11093 X1535=3.*SIGMA
11094 return
11095 endif
11096* IV N*(1535) PRODUCTION IN N*(1440)+N*(1440) REACTIONS
11097cbz11/25/98
11098c IF((LB1*LB2.EQ.100).OR.(LB1*LB2.EQ.11*11))X1535=SIGMA
11099 IF((LB1.EQ.10.AND.LB2.EQ.10).OR.
11100 & (LB1.EQ.11.AND.LB2.EQ.11))X1535=SIGMA
11101c IF(LB1*LB2.EQ.110)X1535=3.*SIGMA
11102 IF(LB1*LB2.EQ.110.AND.(LB1.EQ.10.OR.LB2.EQ.10))X1535=3.*SIGMA
11103cbdbg11/25/98end
11104 RETURN
11105 END
11106************************************
11107* FUNCTION WA1(DMASS) GIVES THE A1 DECAY WIDTH
11108
11109 subroutine WIDA1(DMASS,rhomp,wa1,iseed)
11110 SAVE
11111c
11112 PIMASS=0.137265
11113 coupa = 14.8
11114c
11115 RHOMAX = DMASS-PIMASS-0.02
11116 IF(RHOMAX.LE.0)then
11117 rhomp=0.
11118c !! no decay
11119 wa1=-10.
11120 endif
11121 icount = 0
11122711 rhomp=RHOMAS(RHOMAX,ISEED)
11123 icount=icount+1
11124 if(dmass.le.(pimass+rhomp)) then
11125 if(icount.le.100) then
11126 goto 711
11127 else
11128 rhomp=0.
11129c !! no decay
11130 wa1=-10.
11131 return
11132 endif
11133 endif
11134 qqp2=(dmass**2-(rhomp+pimass)**2)*(dmass**2-(rhomp-pimass)**2)
11135 qqp=sqrt(qqp2)/(2.0*dmass)
11136 epi=sqrt(pimass**2+qqp**2)
11137 erho=sqrt(rhomp**2+qqp**2)
11138 epirho=2.0*(epi*erho+qqp**2)**2+rhomp**2*epi**2
11139 wa1=coupa**2*qqp*epirho/(24.0*3.1416*dmass**2)
11140 return
11141 end
11142************************************
11143* FUNCTION W1535(DMASS) GIVES THE N*(1535) DECAY WIDTH
11144c FOR A GIVEN N*(1535) MASS
11145* HERE THE FORMULA GIVEN BY KITAZOE IS USED
11146 REAL FUNCTION W1535(DMASS)
11147 SAVE
11148 AVMASS=0.938868
11149 PIMASS=0.137265
11150 AUX = 0.25*(DMASS**2-AVMASS**2-PIMASS**2)**2
11151 & -(AVMASS*PIMASS)**2
11152 IF (AUX .GT. 0.) THEN
11153 QAVAIL = SQRT(AUX / DMASS**2)
11154 ELSE
11155 QAVAIL = 1.E-06
11156 END IF
11157 W1535 = 0.15* QAVAIL/0.467
11158c W1535=0.15
11159 RETURN
11160 END
11161************************************
11162* FUNCTION W1440(DMASS) GIVES THE N*(1440) DECAY WIDTH
11163c FOR A GIVEN N*(1535) MASS
11164* HERE THE FORMULA GIVEN BY KITAZOE IS USED
11165 REAL FUNCTION W1440(DMASS)
11166 SAVE
11167 AVMASS=0.938868
11168 PIMASS=0.137265
11169 AUX = 0.25*(DMASS**2-AVMASS**2-PIMASS**2)**2
11170 & -(AVMASS*PIMASS)**2
11171 IF (AUX .GT. 0.) THEN
11172 QAVAIL = SQRT(AUX)/DMASS
11173 ELSE
11174 QAVAIL = 1.E-06
11175 END IF
11176c w1440=0.2
11177 W1440 = 0.2* (QAVAIL/0.397)**3
11178 RETURN
11179 END
11180****************
11181* PURPOSE : CALCULATE THE PION(ETA)+NUCLEON CROSS SECTION
11182* ACCORDING TO THE BREIT-WIGNER FORMULA,
11183* NOTE THAT N*(1535) IS S_11
11184* VARIABLE : LA = 1 FOR PI+N
11185* LA = 0 FOR ETA+N
11186* DATE : MAY 16, 1994
11187****************
11188 REAL FUNCTION XN1535(I1,I2,LA)
11189 PARAMETER (MAXSTR=150001,MAXR=1,
11190 1 AMN=0.939457,AMP=0.93828,ETAM=0.5475,
11191 2 AP1=0.13496,AP2=0.13957,AM0=1.232,PI=3.1415926)
11192 COMMON /AA/ R(3,MAXSTR)
11193cc SAVE /AA/
11194 COMMON /BB/ P(3,MAXSTR)
11195cc SAVE /BB/
11196 COMMON /CC/ E(MAXSTR)
11197cc SAVE /CC/
11198 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
11199cc SAVE /EE/
11200 COMMON /RUN/NUM
11201cc SAVE /RUN/
11202 COMMON /PA/RPION(3,MAXSTR,MAXR)
11203cc SAVE /PA/
11204 COMMON /PB/PPION(3,MAXSTR,MAXR)
11205cc SAVE /PB/
11206 COMMON /PC/EPION(MAXSTR,MAXR)
11207cc SAVE /PC/
11208 COMMON /PD/LPION(MAXSTR,MAXR)
11209cc SAVE /PD/
11210 SAVE
11211 AVMASS=0.5*(AMN+AMP)
11212 AVPI=(2.*AP2+AP1)/3.
11213* 1. DETERMINE THE MOMENTUM COMPONENT OF N*(1535) IN THE LAB. FRAME
11214 E10=SQRT(E(I1)**2+P(1,I1)**2+P(2,I1)**2+P(3,I1)**2)
11215 E20=SQRT(E(I2)**2+P(1,I2)**2+P(2,I2)**2+P(3,I2)**2)
11216 P1=P(1,I1)+P(1,I2)
11217 P2=P(2,I1)+P(2,I2)
11218 P3=P(3,I1)+P(3,I2)
11219* 2. DETERMINE THE MASS OF DELTA BY USING OF THE REACTION KINEMATICS
11220 DM=SQRT((E10+E20)**2-P1**2-P2**2-P3**2)
11221 IF(DM.LE.1.1) THEN
11222 XN1535=1.E-06
11223 RETURN
11224 ENDIF
11225* 3. DETERMINE THE PION(ETA)+NUCLEON->N*(1535) CROSS SECTION ACCORDING TO THE
11226* BREIT-WIGNER FORMULA IN UNIT OF FM**2
11227 GAM=W1535(DM)
11228 GAM0=0.15
11229 F1=0.25*GAM0**2/(0.25*GAM**2+(DM-1.535)**2)
11230 IF(LA.EQ.1)THEN
11231 XMAX=11.3
11232 ELSE
11233 XMAX=74.
11234 ENDIF
11235 XN1535=F1*XMAX/10.
11236 RETURN
11237 END
11238***************************8
11239*FUNCTION FDE(DMASS) GIVES DELTA MASS DISTRIBUTION BY USING OF
11240*KITAZOE'S FORMULA
11241 REAL FUNCTION FDELTA(DMASS)
11242 SAVE
11243 AMN=0.938869
11244 AVPI=0.13803333
11245 AM0=1.232
11246 FD=0.25*WIDTH(DMASS)**2/((DMASS-1.232)**2
11247 1 +0.25*WIDTH(DMASS)**2)
11248 FDELTA=FD
11249 RETURN
11250 END
11251* FUNCTION WIDTH(DMASS) GIVES THE DELTA DECAY WIDTH FOR A GIVEN DELTA MASS
11252* HERE THE FORMULA GIVEN BY KITAZOE IS USED
11253 REAL FUNCTION WIDTH(DMASS)
11254 SAVE
11255 AVMASS=0.938868
11256 PIMASS=0.137265
11257 AUX = 0.25*(DMASS**2-AVMASS**2-PIMASS**2)**2
11258 & -(AVMASS*PIMASS)**2
11259 IF (AUX .GT. 0.) THEN
11260 QAVAIL = SQRT(AUX / DMASS**2)
11261 ELSE
11262 QAVAIL = 1.E-06
11263 END IF
11264 WIDTH = 0.47 * QAVAIL**3 /
11265 & (PIMASS**2 * (1.+0.6*(QAVAIL/PIMASS)**2))
11266c width=0.115
11267 RETURN
11268 END
11269************************************
11270 SUBROUTINE ddp2(SRT,ISEED,PX,PY,PZ,DM1,PNX,
11271 & PNY,PNZ,DM2,PPX,PPY,PPZ,icou1)
11272* PURPOSE : CALCULATE MOMENTUM OF PARTICLES IN THE FINAL SATAT FROM
11273* THE PROCESS N+N--->D1+D2+PION
11274* DATE : July 25, 1994
11275* Generate the masses and momentum for particles in the NN-->DDpi process
11276* for a given center of mass energy srt, the momenta are given in the center
11277* of mass of the NN
11278*****************************************
11279 COMMON/TABLE/ xarray(0:1000),earray(0:1000)
11280cc SAVE /TABLE/
11281 COMMON/RNDF77/NSEED
11282cc SAVE /RNDF77/
11283 SAVE
11284 icou1=0
11285 pi=3.1415926
11286 AMN=938.925/1000.
11287 AMP=137.265/1000.
11288* (1) GENGRATE THE MASS OF DELTA1 AND DELTA2 USING
11289 srt1=srt-amp-0.02
11290 ntrym=0
112918 call Rmasdd(srt1,1.232,1.232,1.08,
11292 & 1.08,ISEED,1,dm1,dm2)
11293 ntrym=ntrym+1
11294* CONSTANTS FOR GENERATING THE LONGITUDINAL MOMENTUM
11295* FOR ONE OF THE RESONANCES
11296 V=0.43
11297 W=-0.84
11298* (2) Generate the transverse momentum
11299* OF DELTA1
11300* (2.1) estimate the maximum transverse momentum
11301 PTMAX2=(SRT**2-(DM1+DM2+AMP)**2)*
11302 1 (SRT**2-(DM1-AMP-DM2)**2)/4./SRT**2
11303 if(ptmax2.le.0)go to 8
11304 PTMAX=SQRT(PTMAX2)*1./3.
113057 PT=PTR(PTMAX,ISEED)
11306* (3.1) THE MAXIMUM LONGITUDINAL MOMENTUM IS
11307 PZMAX2=(SRT**2-(DM1+DM2+AMP)**2)*
11308 1 (SRT**2-(DM1-AMP-DM2)**2)/4./SRT**2-PT**2
11309 IF((PZMAX2.LT.0.).and.ntrym.le.100)then
11310 go to 7
11311 else
11312 pzmax2=1.E-09
11313 endif
11314 PZMAX=SQRT(PZMAX2)
11315 XMAX=2.*PZMAX/SRT
11316* (3.2) THE GENERATED X IS
11317* THE DSTRIBUTION HAS A MAXIMUM AT X0=-V/(2*w), f(X0)=1.056
11318 ntryx=0
11319 fmax00=1.056
11320 x00=0.26
11321 if(abs(xmax).gt.0.26)then
11322 f00=fmax00
11323 else
11324 f00=1.+v*abs(xmax)+w*xmax**2
11325 endif
113269 X=XMAX*(1.-2.*RANART(NSEED))
11327 ntryx=ntryx+1
11328 xratio=(1.+V*ABS(X)+W*X**2)/f00
11329clin-8/17/00 IF(xratio.LT.RANART(NSEED).and.ntryx.le.50)GO TO 9
11330 IF(xratio.LT.RANART(NSEED).and.ntryx.le.50)GO TO 9
11331* (3.5) THE PZ IS
11332 PZ=0.5*SRT*X
11333* The x and y components of the deltA1
11334 fai=2.*pi*RANART(NSEED)
11335 Px=pt*cos(fai)
11336 Py=pt*sin(fai)
11337* find the momentum of delta2 and pion
11338* the energy of the delta1
11339 ek=sqrt(dm1**2+PT**2+Pz**2)
11340* (1) Generate the momentum of the delta2 in the cms of delta2 and pion
11341* the energy of the cms of DP
11342 eln=srt-ek
11343 IF(ELN.lE.0)then
11344 icou1=-1
11345 return
11346 endif
11347* beta and gamma of the cms of delta2+pion
11348 bx=-Px/eln
11349 by=-Py/eln
11350 bz=-Pz/eln
11351 ga=1./sqrt(1.-bx**2-by**2-bz**2)
11352* the momentum of delta2 and pion in their cms frame
11353 elnc=eln/ga
11354 pn2=((elnc**2+dm2**2-amp**2)/(2.*elnc))**2-dm2**2
11355 if(pn2.le.0)then
11356 icou1=-1
11357 return
11358 endif
11359 pn=sqrt(pn2)
11360
11361clin-10/25/02 get rid of argument usage mismatch in PTR():
11362 xptr=0.33*PN
11363c PNT=PTR(0.33*PN,ISEED)
11364 PNT=PTR(xptr,ISEED)
11365clin-10/25/02-end
11366
11367 fain=2.*pi*RANART(NSEED)
11368 pnx=pnT*cos(fain)
11369 pny=pnT*sin(fain)
11370 SIG=1
11371 IF(X.GT.0)SIG=-1
11372 pnz=SIG*SQRT(pn**2-PNT**2)
11373 en=sqrt(dm2**2+pnx**2+pny**2+pnz**2)
11374* (2) the momentum for the pion
11375 ppx=-pnx
11376 ppy=-pny
11377 ppz=-pnz
11378 ep=sqrt(amp**2+ppx**2+ppy**2+ppz**2)
11379* (3) for the delta2, LORENTZ-TRANSFORMATION INTO nn cms FRAME
11380 PBETA = PnX*BX + PnY*By+ PnZ*Bz
11381 TRANS0 = GA * ( GA * PBETA / (GA + 1.) + En )
11382 Pnx = BX * TRANS0 + PnX
11383 Pny = BY * TRANS0 + PnY
11384 Pnz = BZ * TRANS0 + PnZ
11385* (4) for the pion, LORENTZ-TRANSFORMATION INTO nn cms FRAME
11386 if(ep.eq.0.)ep=1.E-09
11387 PBETA = PPX*BX + PPY*By+ PPZ*Bz
11388 TRANS0 = GA * ( GA * PBETA / (GA + 1.) + EP )
11389 PPx = BX * TRANS0 + PPX
11390 PPy = BY * TRANS0 + PPY
11391 PPz = BZ * TRANS0 + PPZ
11392 return
11393 end
11394****************************************
11395 SUBROUTINE ddrho(SRT,ISEED,PX,PY,PZ,DM1,PNX,
11396 & PNY,PNZ,DM2,PPX,PPY,PPZ,amp,icou1)
11397* PURPOSE : CALCULATE MOMENTUM OF PARTICLES IN THE FINAL SATAT FROM
11398* THE PROCESS N+N--->D1+D2+rho
11399* DATE : Nov.5, 1994
11400* Generate the masses and momentum for particles in the NN-->DDrho process
11401* for a given center of mass energy srt, the momenta are given in the center
11402* of mass of the NN
11403*****************************************
11404 COMMON/TABLE/ xarray(0:1000),earray(0:1000)
11405cc SAVE /TABLE/
11406 COMMON/RNDF77/NSEED
11407cc SAVE /RNDF77/
11408 SAVE
11409 icou1=0
11410 pi=3.1415926
11411 AMN=938.925/1000.
11412 AMP=770./1000.
11413* (1) GENGRATE THE MASS OF DELTA1 AND DELTA2 USING
11414 srt1=srt-amp-0.02
11415 ntrym=0
114168 call Rmasdd(srt1,1.232,1.232,1.08,
11417 & 1.08,ISEED,1,dm1,dm2)
11418 ntrym=ntrym+1
11419* GENERATE THE MASS FOR THE RHO
11420 RHOMAX = SRT-DM1-DM2-0.02
11421 IF(RHOMAX.LE.0.and.ntrym.le.20)go to 8
11422 AMP=RHOMAS(RHOMAX,ISEED)
11423* CONSTANTS FOR GENERATING THE LONGITUDINAL MOMENTUM
11424* FOR ONE OF THE RESONANCES
11425 V=0.43
11426 W=-0.84
11427* (2) Generate the transverse momentum
11428* OF DELTA1
11429* (2.1) estimate the maximum transverse momentum
11430 PTMAX2=(SRT**2-(DM1+DM2+AMP)**2)*
11431 1 (SRT**2-(DM1-AMP-DM2)**2)/4./SRT**2
11432 PTMAX=SQRT(PTMAX2)*1./3.
114337 PT=PTR(PTMAX,ISEED)
11434* (3) GENGRATE THE LONGITUDINAL MOMENTUM FOR DM1
11435* USING THE GIVEN DISTRIBUTION
11436* (3.1) THE MAXIMUM LONGITUDINAL MOMENTUM IS
11437 PZMAX2=(SRT**2-(DM1+DM2+AMP)**2)*
11438 1 (SRT**2-(DM1-AMP-DM2)**2)/4./SRT**2-PT**2
11439 IF((PZMAX2.LT.0.).and.ntrym.le.100)then
11440 go to 7
11441 else
11442 pzmax2=1.E-06
11443 endif
11444 PZMAX=SQRT(PZMAX2)
11445 XMAX=2.*PZMAX/SRT
11446* (3.2) THE GENERATED X IS
11447* THE DSTRIBUTION HAS A MAXIMUM AT X0=-V/(2*w), f(X0)=1.056
11448 ntryx=0
11449 fmax00=1.056
11450 x00=0.26
11451 if(abs(xmax).gt.0.26)then
11452 f00=fmax00
11453 else
11454 f00=1.+v*abs(xmax)+w*xmax**2
11455 endif
114569 X=XMAX*(1.-2.*RANART(NSEED))
11457 ntryx=ntryx+1
11458 xratio=(1.+V*ABS(X)+W*X**2)/f00
11459clin-8/17/00 IF(xratio.LT.RANART(NSEED).and.ntryx.le.50)GO TO 9
11460 IF(xratio.LT.RANART(NSEED).and.ntryx.le.50)GO TO 9
11461* (3.5) THE PZ IS
11462 PZ=0.5*SRT*X
11463* The x and y components of the delta1
11464 fai=2.*pi*RANART(NSEED)
11465 Px=pt*cos(fai)
11466 Py=pt*sin(fai)
11467* find the momentum of delta2 and rho
11468* the energy of the delta1
11469 ek=sqrt(dm1**2+PT**2+Pz**2)
11470* (1) Generate the momentum of the delta2 in the cms of delta2 and rho
11471* the energy of the cms of Drho
11472 eln=srt-ek
11473 IF(ELN.lE.0)then
11474 icou1=-1
11475 return
11476 endif
11477* beta and gamma of the cms of delta2 and rho
11478 bx=-Px/eln
11479 by=-Py/eln
11480 bz=-Pz/eln
11481 ga=1./sqrt(1.-bx**2-by**2-bz**2)
11482 elnc=eln/ga
11483 pn2=((elnc**2+dm2**2-amp**2)/(2.*elnc))**2-dm2**2
11484 if(pn2.le.0)then
11485 icou1=-1
11486 return
11487 endif
11488 pn=sqrt(pn2)
11489
11490clin-10/25/02 get rid of argument usage mismatch in PTR():
11491 xptr=0.33*PN
11492c PNT=PTR(0.33*PN,ISEED)
11493 PNT=PTR(xptr,ISEED)
11494clin-10/25/02-end
11495
11496 fain=2.*pi*RANART(NSEED)
11497 pnx=pnT*cos(fain)
11498 pny=pnT*sin(fain)
11499 SIG=1
11500 IF(X.GT.0)SIG=-1
11501 pnz=SIG*SQRT(pn**2-PNT**2)
11502 en=sqrt(dm2**2+pnx**2+pny**2+pnz**2)
11503* (2) the momentum for the rho
11504 ppx=-pnx
11505 ppy=-pny
11506 ppz=-pnz
11507 ep=sqrt(amp**2+ppx**2+ppy**2+ppz**2)
11508* (3) for the delta2, LORENTZ-TRANSFORMATION INTO nn cms FRAME
11509 PBETA = PnX*BX + PnY*By+ PnZ*Bz
11510 TRANS0 = GA * ( GA * PBETA / (GA + 1.) + En )
11511 Pnx = BX * TRANS0 + PnX
11512 Pny = BY * TRANS0 + PnY
11513 Pnz = BZ * TRANS0 + PnZ
11514* (4) for the rho, LORENTZ-TRANSFORMATION INTO nn cms FRAME
11515 if(ep.eq.0.)ep=1.e-09
11516 PBETA = PPX*BX + PPY*By+ PPZ*Bz
11517 TRANS0 = GA * ( GA * PBETA / (GA + 1.) + EP )
11518 PPx = BX * TRANS0 + PPX
11519 PPy = BY * TRANS0 + PPY
11520 PPz = BZ * TRANS0 + PPZ
11521 return
11522 end
11523****************************************
11524 SUBROUTINE pprho(SRT,ISEED,PX,PY,PZ,DM1,PNX,
11525 & PNY,PNZ,DM2,PPX,PPY,PPZ,amp,icou1)
11526* PURPOSE : CALCULATE MOMENTUM OF PARTICLES IN THE FINAL SATAT FROM
11527* THE PROCESS N+N--->N1+N2+rho
11528* DATE : Nov.5, 1994
11529* Generate the masses and momentum for particles in the NN--> process
11530* for a given center of mass energy srt, the momenta are given in the center
11531* of mass of the NN
11532*****************************************
11533 COMMON/TABLE/ xarray(0:1000),earray(0:1000)
11534cc SAVE /TABLE/
11535 COMMON/RNDF77/NSEED
11536cc SAVE /RNDF77/
11537 SAVE
11538 ntrym=0
11539 icou1=0
11540 pi=3.1415926
11541 AMN=938.925/1000.
11542* AMP=770./1000.
11543 DM1=amn
11544 DM2=amn
11545* GENERATE THE MASS FOR THE RHO
11546 RHOMAX=SRT-DM1-DM2-0.02
11547 IF(RHOMAX.LE.0)THEN
11548 ICOU=-1
11549 RETURN
11550 ENDIF
11551 AMP=RHOMAS(RHOMAX,ISEED)
11552* CONSTANTS FOR GENERATING THE LONGITUDINAL MOMENTUM
11553* FOR ONE OF THE nucleons
11554 V=0.43
11555 W=-0.84
11556* (2) Generate the transverse momentum
11557* OF p1
11558* (2.1) estimate the maximum transverse momentum
11559 PTMAX2=(SRT**2-(DM1+DM2+AMP)**2)*
11560 1 (SRT**2-(DM1-AMP-DM2)**2)/4./SRT**2
11561 PTMAX=SQRT(PTMAX2)*1./3.
115627 PT=PTR(PTMAX,ISEED)
11563* (3) GENGRATE THE LONGITUDINAL MOMENTUM FOR DM1
11564* USING THE GIVEN DISTRIBUTION
11565* (3.1) THE MAXIMUM LONGITUDINAL MOMENTUM IS
11566 PZMAX2=(SRT**2-(DM1+DM2+AMP)**2)*
11567 1 (SRT**2-(DM1-AMP-DM2)**2)/4./SRT**2-PT**2
11568 NTRYM=NTRYM+1
11569 IF((PZMAX2.LT.0.).and.ntrym.le.100)then
11570 go to 7
11571 else
11572 pzmax2=1.E-06
11573 endif
11574 PZMAX=SQRT(PZMAX2)
11575 XMAX=2.*PZMAX/SRT
11576* (3.2) THE GENERATED X IS
11577* THE DSTRIBUTION HAS A MAXIMUM AT X0=-V/(2*w), f(X0)=1.056
11578 ntryx=0
11579 fmax00=1.056
11580 x00=0.26
11581 if(abs(xmax).gt.0.26)then
11582 f00=fmax00
11583 else
11584 f00=1.+v*abs(xmax)+w*xmax**2
11585 endif
115869 X=XMAX*(1.-2.*RANART(NSEED))
11587 ntryx=ntryx+1
11588 xratio=(1.+V*ABS(X)+W*X**2)/f00
11589clin-8/17/00 IF(xratio.LT.RANART(NSEED).and.ntryx.le.50)GO TO 9
11590 IF(xratio.LT.RANART(NSEED).and.ntryx.le.50)GO TO 9
11591* (3.5) THE PZ IS
11592 PZ=0.5*SRT*X
11593* The x and y components of the delta1
11594 fai=2.*pi*RANART(NSEED)
11595 Px=pt*cos(fai)
11596 Py=pt*sin(fai)
11597* find the momentum of delta2 and rho
11598* the energy of the delta1
11599 ek=sqrt(dm1**2+PT**2+Pz**2)
11600* (1) Generate the momentum of the delta2 in the cms of delta2 and rho
11601* the energy of the cms of Drho
11602 eln=srt-ek
11603 IF(ELN.lE.0)then
11604 icou1=-1
11605 return
11606 endif
11607* beta and gamma of the cms of the two partciles
11608 bx=-Px/eln
11609 by=-Py/eln
11610 bz=-Pz/eln
11611 ga=1./sqrt(1.-bx**2-by**2-bz**2)
11612 elnc=eln/ga
11613 pn2=((elnc**2+dm2**2-amp**2)/(2.*elnc))**2-dm2**2
11614 if(pn2.le.0)then
11615 icou1=-1
11616 return
11617 endif
11618 pn=sqrt(pn2)
11619
11620clin-10/25/02 get rid of argument usage mismatch in PTR():
11621 xptr=0.33*PN
11622c PNT=PTR(0.33*PN,ISEED)
11623 PNT=PTR(xptr,ISEED)
11624clin-10/25/02-end
11625
11626 fain=2.*pi*RANART(NSEED)
11627 pnx=pnT*cos(fain)
11628 pny=pnT*sin(fain)
11629 SIG=1
11630 IF(X.GT.0)SIG=-1
11631 pnz=SIG*SQRT(pn**2-PNT**2)
11632 en=sqrt(dm2**2+pnx**2+pny**2+pnz**2)
11633* (2) the momentum for the rho
11634 ppx=-pnx
11635 ppy=-pny
11636 ppz=-pnz
11637 ep=sqrt(amp**2+ppx**2+ppy**2+ppz**2)
11638* (3) for the delta2, LORENTZ-TRANSFORMATION INTO nn cms FRAME
11639 PBETA = PnX*BX + PnY*By+ PnZ*Bz
11640 TRANS0 = GA * ( GA * PBETA / (GA + 1.) + En )
11641 Pnx = BX * TRANS0 + PnX
11642 Pny = BY * TRANS0 + PnY
11643 Pnz = BZ * TRANS0 + PnZ
11644* (4) for the rho, LORENTZ-TRANSFORMATION INTO nn cms FRAME
11645 if(ep.eq.0.)ep=1.e-09
11646 PBETA = PPX*BX + PPY*By+ PPZ*Bz
11647 TRANS0 = GA * ( GA * PBETA / (GA + 1.) + EP )
11648 PPx = BX * TRANS0 + PPX
11649 PPy = BY * TRANS0 + PPY
11650 PPz = BZ * TRANS0 + PPZ
11651 return
11652 end
11653***************************8
11654****************************************
11655 SUBROUTINE ppomga(SRT,ISEED,PX,PY,PZ,DM1,PNX,
11656 & PNY,PNZ,DM2,PPX,PPY,PPZ,icou1)
11657* PURPOSE : CALCULATE MOMENTUM OF PARTICLES IN THE FINAL SATAT FROM
11658* THE PROCESS N+N--->N1+N2+OMEGA
11659* DATE : Nov.5, 1994
11660* Generate the masses and momentum for particles in the NN--> process
11661* for a given center of mass energy srt, the momenta are given in the center
11662* of mass of the NN
11663*****************************************
11664 COMMON/TABLE/ xarray(0:1000),earray(0:1000)
11665cc SAVE /TABLE/
11666 COMMON/RNDF77/NSEED
11667cc SAVE /RNDF77/
11668 SAVE
11669 ntrym=0
11670 icou1=0
11671 pi=3.1415926
11672 AMN=938.925/1000.
11673 AMP=782./1000.
11674 DM1=amn
11675 DM2=amn
11676* CONSTANTS FOR GENERATING THE LONGITUDINAL MOMENTUM
11677* FOR ONE OF THE nucleons
11678 V=0.43
11679 W=-0.84
11680* (2) Generate the transverse momentum
11681* OF p1
11682* (2.1) estimate the maximum transverse momentum
11683 PTMAX2=(SRT**2-(DM1+DM2+AMP)**2)*
11684 1 (SRT**2-(DM1-AMP-DM2)**2)/4./SRT**2
11685 PTMAX=SQRT(PTMAX2)*1./3.
116867 PT=PTR(PTMAX,ISEED)
11687* (3) GENGRATE THE LONGITUDINAL MOMENTUM FOR DM1
11688* USING THE GIVEN DISTRIBUTION
11689* (3.1) THE MAXIMUM LONGITUDINAL MOMENTUM IS
11690 PZMAX2=(SRT**2-(DM1+DM2+AMP)**2)*
11691 1 (SRT**2-(DM1-AMP-DM2)**2)/4./SRT**2-PT**2
11692 NTRYM=NTRYM+1
11693 IF((PZMAX2.LT.0.).and.ntrym.le.100)then
11694 go to 7
11695 else
11696 pzmax2=1.E-09
11697 endif
11698 PZMAX=SQRT(PZMAX2)
11699 XMAX=2.*PZMAX/SRT
11700* (3.2) THE GENERATED X IS
11701* THE DSTRIBUTION HAS A MAXIMUM AT X0=-V/(2*w), f(X0)=1.056
11702 ntryx=0
11703 fmax00=1.056
11704 x00=0.26
11705 if(abs(xmax).gt.0.26)then
11706 f00=fmax00
11707 else
11708 f00=1.+v*abs(xmax)+w*xmax**2
11709 endif
117109 X=XMAX*(1.-2.*RANART(NSEED))
11711 ntryx=ntryx+1
11712 xratio=(1.+V*ABS(X)+W*X**2)/f00
11713clin-8/17/00 IF(xratio.LT.RANART(NSEED).and.ntryx.le.50)GO TO 9
11714 IF(xratio.LT.RANART(NSEED).and.ntryx.le.50)GO TO 9
11715* (3.5) THE PZ IS
11716 PZ=0.5*SRT*X
11717* The x and y components of the delta1
11718 fai=2.*pi*RANART(NSEED)
11719 Px=pt*cos(fai)
11720 Py=pt*sin(fai)
11721* find the momentum of delta2 and rho
11722* the energy of the delta1
11723 ek=sqrt(dm1**2+PT**2+Pz**2)
11724* (1) Generate the momentum of the delta2 in the cms of delta2 and rho
11725* the energy of the cms of Drho
11726 eln=srt-ek
11727 IF(ELN.lE.0)then
11728 icou1=-1
11729 return
11730 endif
11731 bx=-Px/eln
11732 by=-Py/eln
11733 bz=-Pz/eln
11734 ga=1./sqrt(1.-bx**2-by**2-bz**2)
11735 elnc=eln/ga
11736 pn2=((elnc**2+dm2**2-amp**2)/(2.*elnc))**2-dm2**2
11737 if(pn2.le.0)then
11738 icou1=-1
11739 return
11740 endif
11741 pn=sqrt(pn2)
11742
11743clin-10/25/02 get rid of argument usage mismatch in PTR():
11744 xptr=0.33*PN
11745c PNT=PTR(0.33*PN,ISEED)
11746 PNT=PTR(xptr,ISEED)
11747clin-10/25/02-end
11748
11749 fain=2.*pi*RANART(NSEED)
11750 pnx=pnT*cos(fain)
11751 pny=pnT*sin(fain)
11752 SIG=1
11753 IF(X.GT.0)SIG=-1
11754 pnz=SIG*SQRT(pn**2-PNT**2)
11755 en=sqrt(dm2**2+pnx**2+pny**2+pnz**2)
11756* (2) the momentum for the rho
11757 ppx=-pnx
11758 ppy=-pny
11759 ppz=-pnz
11760 ep=sqrt(amp**2+ppx**2+ppy**2+ppz**2)
11761* (3) for the delta2, LORENTZ-TRANSFORMATION INTO nn cms FRAME
11762 PBETA = PnX*BX + PnY*By+ PnZ*Bz
11763 TRANS0 = GA * ( GA * PBETA / (GA + 1.) + En )
11764 Pnx = BX * TRANS0 + PnX
11765 Pny = BY * TRANS0 + PnY
11766 Pnz = BZ * TRANS0 + PnZ
11767* (4) for the rho, LORENTZ-TRANSFORMATION INTO nn cms FRAME
11768 if(ep.eq.0.)ep=1.E-09
11769 PBETA = PPX*BX + PPY*By+ PPZ*Bz
11770 TRANS0 = GA * ( GA * PBETA / (GA + 1.) + EP )
11771 PPx = BX * TRANS0 + PPX
11772 PPy = BY * TRANS0 + PPY
11773 PPz = BZ * TRANS0 + PPZ
11774 return
11775 end
11776***************************8
11777***************************8
11778* DELTA MASS GENERATOR
11779 REAL FUNCTION RMASS(DMAX,ISEED)
11780 COMMON/RNDF77/NSEED
11781cc SAVE /RNDF77/
11782 SAVE
11783 ISEED=ISEED
11784* THE MINIMUM MASS FOR DELTA
11785 DMIN = 1.078
11786* Delta(1232) production
11787 IF(DMAX.LT.1.232) THEN
11788 FM=FDELTA(DMAX)
11789 ELSE
11790 FM=1.
11791 ENDIF
11792 IF(FM.EQ.0.)FM=1.E-06
11793 NTRY1=0
1179410 DM = RANART(NSEED) * (DMAX-DMIN) + DMIN
11795 NTRY1=NTRY1+1
11796 IF((RANART(NSEED) .GT. FDELTA(DM)/FM).AND.
11797 1 (NTRY1.LE.10)) GOTO 10
11798clin-2/26/03 sometimes Delta mass can reach very high values (e.g. 15.GeV),
11799c thus violating the thresh of the collision which produces it
11800c and leads to large violation of energy conservation.
11801c To limit the above, limit the Delta mass below a certain value
11802c (here taken as its central value + 2* B-W fullwidth):
11803 if(dm.gt.1.47) goto 10
11804
11805 RMASS=DM
11806 RETURN
11807 END
11808
11809*------------------------------------------------------------------
11810* THE Breit Wigner FORMULA
11811 REAL FUNCTION FRHO(DMASS)
11812 SAVE
11813 AM0=0.77
11814 WID=0.153
11815 FD=0.25*wid**2/((DMASS-AM0)**2+0.25*WID**2)
11816 FRHO=FD
11817 RETURN
11818 END
11819***************************8
11820* RHO MASS GENERATOR
11821 REAL FUNCTION RHOMAS(DMAX,ISEED)
11822 COMMON/RNDF77/NSEED
11823cc SAVE /RNDF77/
11824 SAVE
11825 ISEED=ISEED
11826* THE MINIMUM MASS FOR DELTA
11827 DMIN = 0.28
11828* RHO(770) production
11829 IF(DMAX.LT.0.77) THEN
11830 FM=FRHO(DMAX)
11831 ELSE
11832 FM=1.
11833 ENDIF
11834 IF(FM.EQ.0.)FM=1.E-06
11835 NTRY1=0
1183610 DM = RANART(NSEED) * (DMAX-DMIN) + DMIN
11837 NTRY1=NTRY1+1
11838 IF((RANART(NSEED) .GT. FRHO(DM)/FM).AND.
11839 1 (NTRY1.LE.10)) GOTO 10
11840clin-2/26/03 limit the rho mass below a certain value
11841c (here taken as its central value + 2* B-W fullwidth):
11842 if(dm.gt.1.07) goto 10
11843
11844 RHOMAS=DM
11845 RETURN
11846 END
11847******************************************
11848* for pp-->pp+2pi
11849c real*4 function X2pi(srt)
11850 real function X2pi(srt)
11851* This function contains the experimental
11852c total pp-pp+pi(+)pi(-) Xsections *
11853* srt = DSQRT(s) in GeV *
11854* xsec = production cross section in mb *
11855* earray = EXPerimental table with proton momentum in GeV/c *
11856* xarray = EXPerimental table with cross sections in mb (curve to guide eye)*
11857* *
11858******************************************
11859c real*4 xarray(15), earray(15)
11860 real xarray(15), earray(15)
11861 SAVE
11862 data earray /2.23,2.81,3.67,4.0,4.95,5.52,5.97,6.04,
11863 &6.6,6.9,7.87,8.11,10.01,16.0,19./
11864 data xarray /1.22,2.51,2.67,2.95,2.96,2.84,2.8,3.2,
11865 &2.7,3.0,2.54,2.46,2.4,1.66,1.5/
11866
11867 pmass=0.9383
11868* 1.Calculate p(lab) from srt [GeV]
11869* Formula used: DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
11870c ekin = 2.*pmass*((srt/(2.*pmass))**2 - 1.)
11871 x2pi=0.000001
11872 if(srt.le.2.2)return
11873 plab=sqrt(((srt**2-2.*pmass**2)/(2.*pmass))**2-pmass**2)
11874 if (plab .lt. earray(1)) then
11875 x2pi = xarray(1)
11876 return
11877 end if
11878*
11879* 2.Interpolate double logarithmically to find sigma(srt)
11880*
11881 do 1001 ie = 1,15
11882 if (earray(ie) .eq. plab) then
11883 x2pi= xarray(ie)
11884 return
11885 else if (earray(ie) .gt. plab) then
11886 ymin = alog(xarray(ie-1))
11887 ymax = alog(xarray(ie))
11888 xmin = alog(earray(ie-1))
11889 xmax = alog(earray(ie))
11890 X2pi = exp(ymin + (alog(plab)-xmin)*(ymax-ymin)
11891 & /(xmax-xmin) )
11892 return
11893 end if
11894 1001 continue
11895 return
11896 END
11897******************************************
11898* for pp-->pn+pi(+)pi(+)pi(-)
11899c real*4 function X3pi(srt)
11900 real function X3pi(srt)
11901* This function contains the experimental pp->pp+3pi cross sections *
11902* srt = DSQRT(s) in GeV *
11903* xsec = production cross section in mb *
11904* earray = EXPerimental table with proton energies in MeV *
11905* xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
11906* *
11907******************************************
11908c real*4 xarray(12), earray(12)
11909 real xarray(12), earray(12)
11910 SAVE
11911 data xarray /0.02,0.4,1.15,1.60,2.19,2.85,2.30,
11912 &3.10,2.47,2.60,2.40,1.70/
11913 data earray /2.23,2.81,3.67,4.00,4.95,5.52,5.97,
11914 &6.04,6.60,6.90,10.01,19./
11915
11916 pmass=0.9383
11917* 1.Calculate p(lab) from srt [GeV]
11918* Formula used: DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
11919c ekin = 2.*pmass*((srt/(2.*pmass))**2 - 1.)
11920 x3pi=1.E-06
11921 if(srt.le.2.3)return
11922 plab=sqrt(((srt**2-2.*pmass**2)/(2.*pmass))**2-pmass**2)
11923 if (plab .lt. earray(1)) then
11924 x3pi = xarray(1)
11925 return
11926 end if
11927*
11928* 2.Interpolate double logarithmically to find sigma(srt)
11929*
11930 do 1001 ie = 1,12
11931 if (earray(ie) .eq. plab) then
11932 x3pi= xarray(ie)
11933 return
11934 else if (earray(ie) .gt. plab) then
11935 ymin = alog(xarray(ie-1))
11936 ymax = alog(xarray(ie))
11937 xmin = alog(earray(ie-1))
11938 xmax = alog(earray(ie))
11939 X3pi= exp(ymin + (alog(plab)-xmin)*(ymax-ymin)
11940 & /(xmax-xmin) )
11941 return
11942 end if
11943 1001 continue
11944 return
11945 END
11946******************************************
11947******************************************
11948* for pp-->pp+pi(+)pi(-)pi(0)
11949c real*4 function X33pi(srt)
11950 real function X33pi(srt)
11951* This function contains the experimental pp->pp+3pi cross sections *
11952* srt = DSQRT(s) in GeV *
11953* xsec = production cross section in mb *
11954* earray = EXPerimental table with proton energies in MeV *
11955* xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
11956* *
11957******************************************
11958c real*4 xarray(12), earray(12)
11959 real xarray(12), earray(12)
11960 SAVE
11961 data xarray /0.02,0.22,0.74,1.10,1.76,1.84,2.20,
11962 &2.40,2.15,2.60,2.30,1.70/
11963 data earray /2.23,2.81,3.67,4.00,4.95,5.52,5.97,
11964 &6.04,6.60,6.90,10.01,19./
11965
11966 pmass=0.9383
11967 x33pi=1.E-06
11968 if(srt.le.2.3)return
11969* 1.Calculate p(lab) from srt [GeV]
11970* Formula used: DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
11971c ekin = 2.*pmass*((srt/(2.*pmass))**2 - 1.)
11972 plab=sqrt(((srt**2-2.*pmass**2)/(2.*pmass))**2-pmass**2)
11973 if (plab .lt. earray(1)) then
11974 x33pi = xarray(1)
11975 return
11976 end if
11977*
11978* 2.Interpolate double logarithmically to find sigma(srt)
11979*
11980 do 1001 ie = 1,12
11981 if (earray(ie) .eq. plab) then
11982 x33pi= xarray(ie)
11983 return
11984 else if (earray(ie) .gt. plab) then
11985 ymin = alog(xarray(ie-1))
11986 ymax = alog(xarray(ie))
11987 xmin = alog(earray(ie-1))
11988 xmax = alog(earray(ie))
11989 x33pi= exp(ymin + (alog(plab)-xmin)*(ymax-ymin)
11990 & /(xmax-xmin))
11991 return
11992 end if
11993 1001 continue
11994 return
11995 END
11996******************************************
11997c REAL*4 FUNCTION X4pi(SRT)
11998 REAL FUNCTION X4pi(SRT)
11999 SAVE
12000* CROSS SECTION FOR NN-->DD+rho PROCESS
12001* *****************************
12002 akp=0.498
12003 ak0=0.498
12004 ana=0.94
12005 ada=1.232
12006 al=1.1157
12007 as=1.1197
12008 pmass=0.9383
12009 ES=SRT
12010 IF(ES.LE.4)THEN
12011 X4pi=0.
12012 ELSE
12013* cross section for two resonance pp-->DD+DN*+N*N*
12014 xpp2pi=4.*x2pi(es)
12015* cross section for pp-->pp+spi
12016 xpp3pi=3.*(x3pi(es)+x33pi(es))
12017* cross section for pp-->pD+ and nD++
12018 pps1=sigma(es,1,1,0)+0.5*sigma(es,1,1,1)
12019 pps2=1.5*sigma(es,1,1,1)
12020 ppsngl=pps1+pps2+s1535(es)
12021* CROSS SECTION FOR KAON PRODUCTION from the four channels
12022* for NLK channel
12023 xk1=0
12024 xk2=0
12025 xk3=0
12026 xk4=0
12027 t1nlk=ana+al+akp
12028 t2nlk=ana+al-akp
12029 if(es.le.t1nlk)go to 333
12030 pmnlk2=(es**2-t1nlk**2)*(es**2-t2nlk**2)/(4.*es**2)
12031 pmnlk=sqrt(pmnlk2)
12032 xk1=pplpk(es)
12033* for DLK channel
12034 t1dlk=ada+al+akp
12035 t2dlk=ada+al-akp
12036 if(es.le.t1dlk)go to 333
12037 pmdlk2=(es**2-t1dlk**2)*(es**2-t2dlk**2)/(4.*es**2)
12038 pmdlk=sqrt(pmdlk2)
12039 xk3=pplpk(es)
12040* for NSK channel
12041 t1nsk=ana+as+akp
12042 t2nsk=ana+as-akp
12043 if(es.le.t1nsk)go to 333
12044 pmnsk2=(es**2-t1nsk**2)*(es**2-t2nsk**2)/(4.*es**2)
12045 pmnsk=sqrt(pmnsk2)
12046 xk2=ppk1(es)+ppk0(es)
12047* for DSK channel
12048 t1DSk=aDa+aS+akp
12049 t2DSk=aDa+aS-akp
12050 if(es.le.t1dsk)go to 333
12051 pmDSk2=(es**2-t1DSk**2)*(es**2-t2DSk**2)/(4.*es**2)
12052 pmDSk=sqrt(pmDSk2)
12053 xk4=ppk1(es)+ppk0(es)
12054* THE TOTAL KAON+ AND KAON0 PRODUCTION CROSS SECTION IS THEN
12055333 XKAON=3.*(xk1+xk2+xk3+xk4)
12056* cross section for pp-->DD+rho
12057 x4pi=pp1(es)-ppsngl-xpp2pi-xpp3pi-XKAON
12058 if(x4pi.le.0)x4pi=1.E-06
12059 ENDIF
12060 RETURN
12061 END
12062******************************************
12063* for pp-->inelastic
12064c real*4 function pp1(srt)
12065 real function pp1(srt)
12066 SAVE
12067* srt = DSQRT(s) in GeV *
12068* xsec = production cross section in mb *
12069* earray = EXPerimental table with proton energies in MeV *
12070* xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
12071* *
12072******************************************
12073 pmass=0.9383
12074 PP1=0.
12075* 1.Calculate p(lab) from srt [GeV]
12076* Formula used: DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
12077c ekin = 2.*pmass*((srt/(2.*pmass))**2 - 1.)
12078 plab2=((srt**2-2.*pmass**2)/(2.*pmass))**2-pmass**2
12079 IF(PLAB2.LE.0)RETURN
12080 plab=sqrt(PLAB2)
12081 pmin=0.968
12082 pmax=2080
12083 if ((plab .lt. pmin).or.(plab.gt.pmax)) then
12084 pp1 = 0.
12085 return
12086 end if
12087c* fit parameters
12088 a=30.9
12089 b=-28.9
12090 c=0.192
12091 d=-0.835
12092 an=-2.46
12093 pp1 = a+b*(plab**an)+c*(alog(plab))**2
12094 if(pp1.le.0)pp1=0.0
12095 return
12096 END
12097******************************************
12098* for pp-->elastic
12099c real*4 function pp2(srt)
12100 real function pp2(srt)
12101 SAVE
12102* srt = DSQRT(s) in GeV *
12103* xsec = production cross section in mb *
12104* earray = EXPerimental table with proton energies in MeV *
12105* xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
12106* *
12107******************************************
12108 pmass=0.9383
12109* 1.Calculate p(lab) from srt [GeV]
12110* Formula used: DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
12111c ekin = 2.*pmass*((srt/(2.*pmass))**2 - 1.)
12112 plab=sqrt(((srt**2-2.*pmass**2)/(2.*pmass))**2-pmass**2)
12113 pmin=2.
12114 pmax=2050
12115 if(plab.gt.pmax)then
12116 pp2=8.
12117 return
12118 endif
12119 if(plab .lt. pmin)then
12120 pp2 = 25.
12121 return
12122 end if
12123c* fit parameters
12124 a=11.2
12125 b=25.5
12126 c=0.151
12127 d=-1.62
12128 an=-1.12
12129 pp2 = a+b*(plab**an)+c*(alog(plab))**2+d*alog(plab)
12130 if(pp2.le.0)pp2=0
12131 return
12132 END
12133
12134******************************************
12135* for pp-->total
12136c real*4 function ppt(srt)
12137 real function ppt(srt)
12138 SAVE
12139* srt = DSQRT(s) in GeV *
12140* xsec = production cross section in mb *
12141* earray = EXPerimental table with proton energies in MeV *
12142* xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
12143* *
12144******************************************
12145 pmass=0.9383
12146* 1.Calculate p(lab) from srt [GeV]
12147* Formula used: DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
12148c ekin = 2.*pmass*((srt/(2.*pmass))**2 - 1.)
12149 plab=sqrt(((srt**2-2.*pmass**2)/(2.*pmass))**2-pmass**2)
12150 pmin=3.
12151 pmax=2100
12152 if ((plab .lt. pmin).or.(plab.gt.pmax)) then
12153 ppt = 55.
12154 return
12155 end if
12156c* fit parameters
12157 a=45.6
12158 b=219.0
12159 c=0.410
12160 d=-3.41
12161 an=-4.23
12162 ppt = a+b*(plab**an)+c*(alog(plab))**2+d*alog(plab)
12163 if(ppt.le.0)ppt=0.0
12164 return
12165 END
12166
12167*************************
12168* cross section for N*(1535) production in PP collisions
12169* VARIABLES:
12170* LB1,LB2 ARE THE LABLES OF THE TWO COLLIDING PARTICLES
12171* SRT IS THE CMS ENERGY
12172* X1535 IS THE N*(1535) PRODUCTION CROSS SECTION
12173* NOTE THAT THE N*(1535) PRODUCTION CROSS SECTION IS 2 TIMES THE ETA
12174* PRODUCTION CROSS SECTION
12175* DATE: Aug. 1 , 1994
12176* ********************************
12177 real function s1535(SRT)
12178 SAVE
12179 S0=2.424
12180 s1535=0.
12181 IF(SRT.LE.S0)RETURN
12182 S1535=2.*0.102*(SRT-S0)/(0.058+(SRT-S0)**2)
12183 return
12184 end
12185****************************************
12186* generate a table for pt distribution for
12187 subroutine tablem
12188* THE PROCESS N+N--->N+N+PION
12189* DATE : July 11, 1994
12190*****************************************
12191 COMMON/TABLE/ xarray(0:1000),earray(0:1000)
12192cc SAVE /TABLE/
12193 SAVE
12194 ptmax=2.01
12195 anorm=ptdis(ptmax)
12196 do 10 L=0,200
12197 x=0.01*float(L+1)
12198 rr=ptdis(x)/anorm
12199 earray(l)=rr
12200 xarray(l)=x
1220110 continue
12202 RETURN
12203 end
12204*********************************
12205 real function ptdis(x)
12206 SAVE
12207* NUCLEON TRANSVERSE MOMENTUM DISTRIBUTION AT HIGH ENERGIES
12208* DATE: Aug. 11, 1994
12209*********************************
12210 b=3.78
12211 c=0.47
12212 d=3.60
12213c b=b*3
12214c d=d*3
12215 ptdis=1./(2.*b)*(1.-exp(-b*x**2))-c/d*x*exp(-d*x)
12216 1 -c/D**2*(exp(-d*x)-1.)
12217 return
12218 end
12219*****************************
12220 subroutine ppxS(lb1,lb2,srt,ppsig,spprho,ipp)
12221* purpose: this subroutine gives the cross section for pion+pion
12222* elastic collision
12223* variables:
12224* input: lb1,lb2 and srt are the labels and srt for I1 and I2
12225* output: ppsig: pp xsection
12226* ipp: label for the pion+pion channel
12227* Ipp=0 NOTHING HAPPEND
12228* 1 for Pi(+)+PI(+) DIRECT
12229* 2 PI(+)+PI(0) FORMING RHO(+)
12230* 3 PI(+)+PI(-) FORMING RHO(0)
12231* 4 PI(0)+PI(O) DIRECT
12232* 5 PI(0)+PI(-) FORMING RHO(-)
12233* 6 PI(-)+PI(-) DIRECT
12234* reference: G.F. Bertsch, Phys. Rev. D37 (1988) 1202.
12235* date : Aug 29, 1994
12236*****************************
12237 parameter (amp=0.14,pi=3.1415926)
12238 SAVE
12239 PPSIG=0.0
12240
12241cbzdbg10/15/99
12242 spprho=0.0
12243cbzdbg10/15/99 end
12244
12245 IPP=0
12246 IF(SRT.LE.0.3)RETURN
12247 q=sqrt((srt/2)**2-amp**2)
12248 esigma=5.8*amp
12249 tsigma=2.06*q
12250 erho=0.77
12251 trho=0.095*q*(q/amp/(1.+(q/erho)**2))**2
12252 esi=esigma-srt
12253 if(esi.eq.0)then
12254 d00=pi/2.
12255 go to 10
12256 endif
12257 d00=atan(tsigma/2./esi)
1225810 erh=erho-srt
12259 if(erh.eq.0.)then
12260 d11=pi/2.
12261 go to 20
12262 endif
12263 d11=atan(trho/2./erh)
1226420 d20=-0.12*q/amp
12265 s0=8.*pi*sin(d00)**2/q**2
12266 s1=8*pi*3*sin(d11)**2/q**2
12267 s2=8*pi*5*sin(d20)**2/q**2
12268c !! GeV^-2 to mb
12269 s0=s0*0.197**2*10.
12270 s1=s1*0.197**2*10.
12271 s2=s2*0.197**2*10.
12272C ppXS=s0/9.+s1/3.+s2*0.56
12273C if(ppxs.le.0)ppxs=0.00001
12274 spprho=s1/2.
12275* (1) PI(+)+PI(+)
12276 IF(LB1.EQ.5.AND.LB2.EQ.5)THEN
12277 IPP=1
12278 PPSIG=S2
12279 RETURN
12280 ENDIF
12281* (2) PI(+)+PI(0)
12282 IF((LB1.EQ.5.AND.LB2.EQ.4).OR.(LB1.EQ.4.AND.LB2.EQ.5))THEN
12283 IPP=2
12284 PPSIG=S2/2.+S1/2.
12285 RETURN
12286 ENDIF
12287* (3) PI(+)+PI(-)
12288 IF((LB1.EQ.5.AND.LB2.EQ.3).OR.(LB1.EQ.3.AND.LB2.EQ.5))THEN
12289 IPP=3
12290 PPSIG=S2/6.+S1/2.+S0/3.
12291 RETURN
12292 ENDIF
12293* (4) PI(0)+PI(0)
12294 IF(LB1.EQ.4.AND.LB2.EQ.4)THEN
12295 IPP=4
12296 PPSIG=2*S2/3.+S0/3.
12297 RETURN
12298 ENDIF
12299* (5) PI(0)+PI(-)
12300 IF((LB1.EQ.4.AND.LB2.EQ.3).OR.(LB1.EQ.3.AND.LB2.EQ.4))THEN
12301 IPP=5
12302 PPSIG=S2/2.+S1/2.
12303 RETURN
12304 ENDIF
12305* (6) PI(-)+PI(-)
12306 IF(LB1.EQ.3.AND.LB2.EQ.3)THEN
12307 IPP=6
12308 PPSIG=S2
12309 ENDIF
12310 return
12311 end
12312**********************************
12313* elementary kaon production cross sections
12314* from the CERN data book
12315* date: Sept.2, 1994
12316* for pp-->pLK+
12317c real*4 function pplpk(srt)
12318 real function pplpk(srt)
12319 SAVE
12320* srt = DSQRT(s) in GeV *
12321* xsec = production cross section in mb *
12322* earray = EXPerimental table with proton energies in MeV *
12323* xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
12324* *
12325******************************************
12326 pmass=0.9383
12327* 1.Calculate p(lab) from srt [GeV]
12328* Formula used: DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
12329* find the center of mass energy corresponding to the given pm as
12330* if Lambda+N+K are produced
12331 pplpk=0.
12332 plab=sqrt(((srt**2-2.*pmass**2)/(2.*pmass))**2-pmass**2)
12333 pmin=2.82
12334 pmax=25.0
12335 if(plab.gt.pmax)then
12336 pplpk=0.036
12337 return
12338 endif
12339 if(plab .lt. pmin)then
12340 pplpk = 0.
12341 return
12342 end if
12343c* fit parameters
12344 a=0.0654
12345 b=-3.16
12346 c=-0.0029
12347 an=-4.14
12348 pplpk = a+b*(plab**an)+c*(alog(plab))**2
12349 if(pplpk.le.0)pplpk=0
12350 return
12351 END
12352
12353******************************************
12354* for pp-->pSigma+K0
12355c real*4 function ppk0(srt)
12356 real function ppk0(srt)
12357* srt = DSQRT(s) in GeV *
12358* xsec = production cross section in mb *
12359* *
12360******************************************
12361c real*4 xarray(7), earray(7)
12362 real xarray(7), earray(7)
12363 SAVE
12364 data xarray /0.030,0.025,0.025,0.026,0.02,0.014,0.06/
12365 data earray /3.67,4.95,5.52,6.05,6.92,7.87,10./
12366
12367 pmass=0.9383
12368* 1.Calculate p(lab) from srt [GeV]
12369* Formula used: DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
12370c ekin = 2.*pmass*((srt/(2.*pmass))**2 - 1.)
12371 ppk0=0
12372 if(srt.le.2.63)return
12373 if(srt.gt.4.54)then
12374 ppk0=0.037
12375 return
12376 endif
12377 plab=sqrt(((srt**2-2.*pmass**2)/(2.*pmass))**2-pmass**2)
12378 if (plab .lt. earray(1)) then
12379 ppk0 = xarray(1)
12380 return
12381 end if
12382*
12383* 2.Interpolate double logarithmically to find sigma(srt)
12384*
12385 do 1001 ie = 1,7
12386 if (earray(ie) .eq. plab) then
12387 ppk0 = xarray(ie)
12388 go to 10
12389 else if (earray(ie) .gt. plab) then
12390 ymin = alog(xarray(ie-1))
12391 ymax = alog(xarray(ie))
12392 xmin = alog(earray(ie-1))
12393 xmax = alog(earray(ie))
12394 ppk0 = exp(ymin + (alog(plab)-xmin)*(ymax-ymin)
12395 &/(xmax-xmin) )
12396 go to 10
12397 end if
12398 1001 continue
1239910 continue
12400 return
12401 END
12402******************************************
12403* for pp-->pSigma0K+
12404c real*4 function ppk1(srt)
12405 real function ppk1(srt)
12406* srt = DSQRT(s) in GeV *
12407* xsec = production cross section in mb *
12408* *
12409******************************************
12410c real*4 xarray(7), earray(7)
12411 real xarray(7), earray(7)
12412 SAVE
12413 data xarray /0.013,0.025,0.016,0.012,0.017,0.029,0.025/
12414 data earray /3.67,4.95,5.52,5.97,6.05,6.92,7.87/
12415
12416 pmass=0.9383
12417* 1.Calculate p(lab) from srt [GeV]
12418* Formula used: DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
12419c ekin = 2.*pmass*((srt/(2.*pmass))**2 - 1.)
12420 ppk1=0.
12421 if(srt.le.2.63)return
12422 if(srt.gt.4.08)then
12423 ppk1=0.025
12424 return
12425 endif
12426 plab=sqrt(((srt**2-2.*pmass**2)/(2.*pmass))**2-pmass**2)
12427 if (plab .lt. earray(1)) then
12428 ppk1 =xarray(1)
12429 return
12430 end if
12431*
12432* 2.Interpolate double logarithmically to find sigma(srt)
12433*
12434 do 1001 ie = 1,7
12435 if (earray(ie) .eq. plab) then
12436 ppk1 = xarray(ie)
12437 go to 10
12438 else if (earray(ie) .gt. plab) then
12439 ymin = alog(xarray(ie-1))
12440 ymax = alog(xarray(ie))
12441 xmin = alog(earray(ie-1))
12442 xmax = alog(earray(ie))
12443 ppk1 = exp(ymin + (alog(plab)-xmin)*(ymax-ymin)
12444 &/(xmax-xmin) )
12445 go to 10
12446 end if
12447 1001 continue
1244810 continue
12449 return
12450 END
12451**********************************
12452* *
12453* *
12454 SUBROUTINE CRPN(PX,PY,PZ,SRT,I1,I2,
12455 & IBLOCK,xkaon0,xkaon,Xphi,xphin)
12456* PURPOSE: *
12457* DEALING WITH PION+N-->L/S+KAON PROCESS AND PION PRODUCTION *
12458* NOTE : *
12459*
12460* QUANTITIES: *
12461* PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
12462* SRT - SQRT OF S *
12463* IBLOCK - THE INFORMATION BACK *
12464* 7 PION+N-->L/S+KAON
12465* iblock - 77 pion+N-->Delta+pion
12466* iblock - 78 pion+N-->Delta+RHO
12467* iblock - 79 pion+N-->Delta+OMEGA
12468* iblock - 222 pion+N-->Phi
12469**********************************
12470 PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
12471 1 AMP=0.93828,AP1=0.13496,APHI=1.020,
12472 2 AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
12473 PARAMETER (AKA=0.498,ALA=1.1157,ASA=1.1974)
12474 parameter (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
12475 COMMON /AA/ R(3,MAXSTR)
12476cc SAVE /AA/
12477 COMMON /BB/ P(3,MAXSTR)
12478cc SAVE /BB/
12479 COMMON /CC/ E(MAXSTR)
12480cc SAVE /CC/
12481 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
12482cc SAVE /EE/
12483 common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
12484cc SAVE /input1/
12485 COMMON/RNDF77/NSEED
12486cc SAVE /RNDF77/
12487 SAVE
12488
12489 PX0=PX
12490 PY0=PY
12491 PZ0=PZ
12492 iblock=1
12493 x1=RANART(NSEED)
12494 ianti=0
12495 if(lb(i1).lt.0 .or. lb(i2).lt.0) ianti=1
12496 if(xkaon0/(xkaon+Xphi).ge.x1)then
12497* kaon production
12498*-----------------------------------------------------------------------
12499 IBLOCK=7
12500 if(ianti .eq. 1)iblock=-7
12501 NTAG=0
12502* RELABLE PARTICLES FOR THE PROCESS PION+n-->LAMBDA K OR SIGMA k
12503* DECIDE LAMBDA OR SIGMA PRODUCTION, AND TO CALCULATE THE NEW
12504* MOMENTA FOR PARTICLES IN THE FINAL STATE.
12505 KAONC=0
12506 IF(PNLKA(SRT)/(PNLKA(SRT)
12507 & +PNSKA(SRT)).GT.RANART(NSEED))KAONC=1
12508 IF(E(I1).LE.0.2)THEN
12509 LB(I1)=23
12510 E(I1)=AKA
12511 IF(KAONC.EQ.1)THEN
12512 LB(I2)=14
12513 E(I2)=ALA
12514 ELSE
12515 LB(I2) = 15 + int(3 * RANART(NSEED))
12516 E(I2)=ASA
12517 ENDIF
12518 if(ianti .eq. 1)then
12519 lb(i1) = 21
12520 lb(i2) = -lb(i2)
12521 endif
12522 ELSE
12523 LB(I2)=23
12524 E(I2)=AKA
12525 IF(KAONC.EQ.1)THEN
12526 LB(I1)=14
12527 E(I1)=ALA
12528 ELSE
12529 LB(I1) = 15 + int(3 * RANART(NSEED))
12530 E(I1)=ASA
12531 ENDIF
12532 if(ianti .eq. 1)then
12533 lb(i2) = 21
12534 lb(i1) = -lb(i1)
12535 endif
12536 ENDIF
12537 EM1=E(I1)
12538 EM2=E(I2)
12539 go to 50
12540* to gererate the momentum for the kaon and L/S
12541 elseif(Xphi/(xkaon+Xphi).ge.x1)then
12542 iblock=222
12543 if(xphin/Xphi .ge. RANART(NSEED))then
12544 LB(I1)= 1+int(2*RANART(NSEED))
12545 E(I1)=AMN
12546 else
12547 LB(I1)= 6+int(4*RANART(NSEED))
12548 E(I1)=AM0
12549 endif
12550c !! at present only baryon
12551 if(ianti .eq. 1)lb(i1)=-lb(i1)
12552 LB(I2)= 29
12553 E(I2)=APHI
12554 EM1=E(I1)
12555 EM2=E(I2)
12556 go to 50
12557 else
12558* CHECK WHAT KIND OF PION PRODUCTION PROCESS HAS HAPPENED
12559 IF(RANART(NSEED).LE.TWOPI(SRT)/
12560 & (TWOPI(SRT)+THREPI(SRT)+FOURPI(SRT)))THEN
12561 iblock=77
12562 ELSE
12563 IF(THREPI(SRT)/(THREPI(SRT)+FOURPI(SRT)).
12564 & GT.RANART(NSEED))THEN
12565 IBLOCK=78
12566 ELSE
12567 IBLOCK=79
12568 ENDIF
12569 endif
12570 ntag=0
12571* pion production (Delta+pion/rho/omega in the final state)
12572* generate the mass of the delta resonance
12573 X2=RANART(NSEED)
12574* relable the particles
12575 if(iblock.eq.77)then
12576* GENERATE THE DELTA MASS
12577 dmax=srt-ap1-0.02
12578 dm=rmass(dmax,iseed)
12579* pion+baryon-->pion+delta
12580* Relable particles, I1 is assigned to the Delta and I2 is assigned to the
12581* meson
12582*(1) for pi(+)+p-->D(+)+P(+) OR D(++)+p(0)
12583 if( ((lb(i1).eq.1.and.lb(i2).eq.5).
12584 & or.(lb(i1).eq.5.and.lb(i2).eq.1))
12585 & .OR. ((lb(i1).eq.-1.and.lb(i2).eq.3).
12586 & or.(lb(i1).eq.3.and.lb(i2).eq.-1)) )then
12587 if(iabs(lb(i1)).eq.1)then
12588 ii = i1
12589 IF(X2.LE.0.5)THEN
12590 lb(i1)=8
12591 e(i1)=dm
12592 lb(i2)=5
12593 e(i2)=ap1
12594 go to 40
12595 ELSE
12596 lb(i1)=9
12597 e(i1)=dm
12598 lb(i2)=4
12599 ipi = 4
12600 e(i2)=ap1
12601 go to 40
12602 endif
12603 else
12604 ii = i2
12605 IF(X2.LE.0.5)THEN
12606 lb(i2)=8
12607 e(i2)=dm
12608 lb(i1)=5
12609 e(i1)=ap1
12610 go to 40
12611 ELSE
12612 lb(i2)=9
12613 e(i2)=dm
12614 lb(i1)=4
12615 e(i1)=ap1
12616 go to 40
12617 endif
12618 endif
12619 endif
12620*(2) for pi(-)+p-->D(0)+P(0) OR D(+)+p(-),or D(-)+p(+)
12621 if( ((lb(i1).eq.1.and.lb(i2).eq.3).
12622 & or.(lb(i1).eq.3.and.lb(i2).eq.1))
12623 & .OR. ((lb(i1).eq.-1.and.lb(i2).eq.5).
12624 & or.(lb(i1).eq.5.and.lb(i2).eq.-1)) )then
12625 if(iabs(lb(i1)).eq.1)then
12626 ii = i1
12627 IF(X2.LE.0.33)THEN
12628 lb(i1)=6
12629 e(i1)=dm
12630 lb(i2)=5
12631 e(i2)=ap1
12632 go to 40
12633 ENDIF
12634 if(X2.gt.0.33.and.X2.le.0.67)then
12635 lb(i1)=7
12636 e(i1)=dm
12637 lb(i2)=4
12638 e(i2)=ap1
12639 go to 40
12640 endif
12641 if(X2.gt.0.67)then
12642 lb(i1)=8
12643 e(i1)=dm
12644 lb(i2)=3
12645 e(i2)=ap1
12646 go to 40
12647 endif
12648 else
12649 ii = i2
12650 IF(X2.LE.0.33)THEN
12651 lb(i2)=6
12652 e(i2)=dm
12653 lb(i1)=5
12654 e(i1)=ap1
12655 go to 40
12656 ENDIF
12657 if(X2.gt.0.33.and.X2.le.0.67)then
12658 lb(i2)=7
12659 e(i2)=dm
12660 lb(i1)=4
12661 e(i1)=ap1
12662 go to 40
12663 endif
12664 if(X2.gt.0.67)then
12665 lb(i2)=8
12666 e(i2)=dm
12667 lb(i1)=3
12668 e(i1)=ap1
12669 go to 40
12670 endif
12671 endif
12672 endif
12673*(3) for pi(+)+n-->D(+)+Pi(0) OR D(++)+p(-) or D(0)+pi(+)
12674 if( ((lb(i1).eq.2.and.lb(i2).eq.5).
12675 & or.(lb(i1).eq.5.and.lb(i2).eq.2))
12676 & .OR. ((lb(i1).eq.-2.and.lb(i2).eq.3).
12677 & or.(lb(i1).eq.3.and.lb(i2).eq.-2)) )then
12678 if(iabs(lb(i1)).eq.2)then
12679 ii = i1
12680 IF(X2.LE.0.33)THEN
12681 lb(i1)=8
12682 e(i1)=dm
12683 lb(i2)=4
12684 e(i2)=ap1
12685 go to 40
12686 ENDIF
12687 if(X2.gt.0.33.and.X2.le.0.67)then
12688 lb(i1)=7
12689 e(i1)=dm
12690 lb(i2)=5
12691 e(i2)=ap1
12692 go to 40
12693 endif
12694 if(X2.gt.0.67)then
12695 lb(i1)=9
12696 e(i1)=dm
12697 lb(i2)=3
12698 e(i2)=ap1
12699 go to 40
12700 endif
12701 else
12702 ii = i2
12703 IF(X2.LE.0.33)THEN
12704 lb(i2)=8
12705 e(i2)=dm
12706 lb(i1)=4
12707 e(i1)=ap1
12708 go to 40
12709 ENDIF
12710 if(X2.gt.0.33.and.X2.le.0.67)then
12711 lb(i2)=7
12712 e(i2)=dm
12713 lb(i1)=5
12714 e(i1)=ap1
12715 go to 40
12716 endif
12717 if(X2.gt.0.67)then
12718 lb(i2)=9
12719 e(i2)=dm
12720 lb(i1)=3
12721 e(i1)=ap1
12722 go to 40
12723 endif
12724 endif
12725 endif
12726*(4) for pi(0)+p-->D(+)+Pi(0) OR D(++)+p(-) or D(0)+pi(+)
12727 if((iabs(lb(i1)).eq.1.and.lb(i2).eq.4).
12728 & or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.1))then
12729 if(iabs(lb(i1)).eq.1)then
12730 ii = i1
12731 IF(X2.LE.0.33)THEN
12732 lb(i1)=8
12733 e(i1)=dm
12734 lb(i2)=4
12735 e(i2)=ap1
12736 go to 40
12737 ENDIF
12738 if(X2.gt.0.33.and.X2.le.0.67)then
12739 lb(i1)=7
12740 e(i1)=dm
12741 lb(i2)=5
12742 e(i2)=ap1
12743 go to 40
12744 endif
12745 if(X2.gt.0.67)then
12746 lb(i1)=9
12747 e(i1)=dm
12748 lb(i2)=3
12749 e(i2)=ap1
12750 go to 40
12751 endif
12752 else
12753 ii = i2
12754 IF(X2.LE.0.33)THEN
12755 lb(i2)=8
12756 e(i2)=dm
12757 lb(i1)=4
12758 e(i1)=ap1
12759 go to 40
12760 ENDIF
12761 if(X2.gt.0.33.and.X2.le.0.67)then
12762 lb(i2)=7
12763 e(i2)=dm
12764 lb(i1)=5
12765 e(i1)=ap1
12766 go to 40
12767 endif
12768 if(X2.gt.0.67)then
12769 lb(i2)=9
12770 e(i2)=dm
12771 lb(i1)=3
12772 e(i1)=ap1
12773 go to 40
12774 endif
12775 endif
12776 endif
12777*(5) for pi(-)+n-->D(-)+P(0) OR D(0)+p(-)
12778 if( ((lb(i1).eq.2.and.lb(i2).eq.3).
12779 & or.(lb(i1).eq.3.and.lb(i2).eq.2))
12780 & .OR. ((lb(i1).eq.-2.and.lb(i2).eq.5).
12781 & or.(lb(i1).eq.5.and.lb(i2).eq.-2)) )then
12782 if(iabs(lb(i1)).eq.2)then
12783 ii = i1
12784 IF(X2.LE.0.5)THEN
12785 lb(i1)=6
12786 e(i1)=dm
12787 lb(i2)=4
12788 e(i2)=ap1
12789 go to 40
12790 ELSE
12791 lb(i1)=7
12792 e(i1)=dm
12793 lb(i2)=3
12794 e(i2)=ap1
12795 go to 40
12796 endif
12797 else
12798 ii = i2
12799 IF(X2.LE.0.5)THEN
12800 lb(i2)=6
12801 e(i2)=dm
12802 lb(i1)=4
12803 e(i1)=ap1
12804 go to 40
12805 ELSE
12806 lb(i2)=7
12807 e(i2)=dm
12808 lb(i1)=3
12809 e(i1)=ap1
12810 go to 40
12811 endif
12812 endif
12813 ENDIF
12814*(6) for pi(0)+n-->D(0)+P(0), D(-)+p(+) or D(+)+p(-)
12815 if((iabs(lb(i1)).eq.2.and.lb(i2).eq.4).
12816 & or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.2))then
12817 if(iabs(lb(i1)).eq.2)then
12818 ii = i1
12819 IF(X2.LE.0.33)THEN
12820 lb(i1)=7
12821 e(i1)=dm
12822 lb(i2)=4
12823 e(i2)=ap1
12824 go to 40
12825 Endif
12826 IF(X2.LE.0.67.AND.X2.GT.0.33)THEN
12827 lb(i1)=6
12828 e(i1)=dm
12829 lb(i2)=5
12830 e(i2)=ap1
12831 go to 40
12832 endif
12833 IF(X2.GT.0.67)THEN
12834 LB(I1)=8
12835 E(I1)=DM
12836 LB(I2)=3
12837 E(I2)=AP1
12838 GO TO 40
12839 ENDIF
12840 else
12841 ii = i2
12842 IF(X2.LE.0.33)THEN
12843 lb(i2)=7
12844 e(i2)=dm
12845 lb(i1)=4
12846 e(i1)=ap1
12847 go to 40
12848 ENDIF
12849 IF(X2.LE.0.67.AND.X2.GT.0.33)THEN
12850 lb(i2)=6
12851 e(i2)=dm
12852 lb(i1)=5
12853 e(i1)=ap1
12854 go to 40
12855 endif
12856 IF(X2.GT.0.67)THEN
12857 LB(I2)=8
12858 E(I2)=DM
12859 LB(I1)=3
12860 E(I1)=AP1
12861 GO TO 40
12862 ENDIF
12863 endif
12864 endif
12865 ENDIF
12866 if(iblock.eq.78)then
12867 call Rmasdd(srt,1.232,0.77,1.08,
12868 & 0.28,ISEED,4,dm,ameson)
12869 arho=AMESON
12870* pion+baryon-->Rho+delta
12871*(1) for pi(+)+p-->D(+)+rho(+) OR D(++)+rho(0)
12872 if( ((lb(i1).eq.1.and.lb(i2).eq.5).
12873 & or.(lb(i1).eq.5.and.lb(i2).eq.1))
12874 & .OR. ((lb(i1).eq.-1.and.lb(i2).eq.3).
12875 & or.(lb(i1).eq.3.and.lb(i2).eq.-1)) )then
12876 if(iabs(lb(i1)).eq.1)then
12877 ii = i1
12878 IF(X2.LE.0.5)THEN
12879 lb(i1)=8
12880 e(i1)=dm
12881 lb(i2)=27
12882 e(i2)=arho
12883 go to 40
12884 ELSE
12885 lb(i1)=9
12886 e(i1)=dm
12887 lb(i2)=26
12888 e(i2)=arho
12889 go to 40
12890 endif
12891 else
12892 ii = i2
12893 IF(X2.LE.0.5)THEN
12894 lb(i2)=8
12895 e(i2)=dm
12896 lb(i1)=27
12897 e(i1)=arho
12898 go to 40
12899 ELSE
12900 lb(i2)=9
12901 e(i2)=dm
12902 lb(i1)=26
12903 e(i1)=arho
12904 go to 40
12905 endif
12906 endif
12907 endif
12908*(2) for pi(-)+p-->D(+)+rho(-) OR D(0)+rho(0) or D(-)+rho(+)
12909 if( ((lb(i1).eq.1.and.lb(i2).eq.3).
12910 & or.(lb(i1).eq.3.and.lb(i2).eq.1))
12911 & .OR. ((lb(i1).eq.-1.and.lb(i2).eq.5).
12912 & or.(lb(i1).eq.5.and.lb(i2).eq.-1)) )then
12913 if(iabs(lb(i1)).eq.1)then
12914 ii = i1
12915 IF(X2.LE.0.33)THEN
12916 lb(i1)=6
12917 e(i1)=dm
12918 lb(i2)=27
12919 e(i2)=arho
12920 go to 40
12921 ENDIF
12922 if(X2.gt.0.33.and.X2.le.0.67)then
12923 lb(i1)=7
12924 e(i1)=dm
12925 lb(i2)=26
12926 e(i2)=arho
12927 go to 40
12928 endif
12929 if(X2.gt.0.67)then
12930 lb(i1)=8
12931 e(i1)=dm
12932 lb(i2)=25
12933 e(i2)=arho
12934 go to 40
12935 endif
12936 else
12937 ii = i2
12938 IF(X2.LE.0.33)THEN
12939 lb(i2)=6
12940 e(i2)=dm
12941 lb(i1)=27
12942 e(i1)=arho
12943 go to 40
12944 ENDIF
12945 if(X2.gt.0.33.and.X2.le.0.67)then
12946 lb(i2)=7
12947 e(i2)=dm
12948 lb(i1)=26
12949 e(i1)=arho
12950 go to 40
12951 endif
12952 if(X2.gt.0.67)then
12953 lb(i2)=8
12954 e(i2)=dm
12955 lb(i1)=25
12956 e(i1)=arho
12957 go to 40
12958 endif
12959 endif
12960 endif
12961*(3) for pi(+)+n-->D(+)+rho(0) OR D(++)+rho(-) or D(0)+rho(+)
12962 if( ((lb(i1).eq.2.and.lb(i2).eq.5).
12963 & or.(lb(i1).eq.5.and.lb(i2).eq.2))
12964 & .OR.((lb(i1).eq.-2.and.lb(i2).eq.3).
12965 & or.(lb(i1).eq.3.and.lb(i2).eq.-2)) )then
12966 if(iabs(lb(i1)).eq.2)then
12967 ii = i1
12968 IF(X2.LE.0.33)THEN
12969 lb(i1)=8
12970 e(i1)=dm
12971 lb(i2)=26
12972 e(i2)=arho
12973 go to 40
12974 ENDIF
12975 if(X2.gt.0.33.and.X2.le.0.67)then
12976 lb(i1)=7
12977 e(i1)=dm
12978 lb(i2)=27
12979 e(i2)=arho
12980 go to 40
12981 endif
12982 if(X2.gt.0.67)then
12983 lb(i1)=9
12984 e(i1)=dm
12985 lb(i2)=25
12986 e(i2)=arho
12987 go to 40
12988 endif
12989 else
12990 ii = i2
12991 IF(X2.LE.0.33)THEN
12992 lb(i2)=8
12993 e(i2)=dm
12994 lb(i1)=26
12995 e(i1)=arho
12996 go to 40
12997 ENDIF
12998 if(X2.gt.0.33.and.X2.le.0.67)then
12999 lb(i2)=7
13000 e(i2)=dm
13001 lb(i1)=27
13002 e(i1)=arho
13003 go to 40
13004 endif
13005 if(X2.gt.0.67)then
13006 lb(i2)=9
13007 e(i2)=dm
13008 lb(i1)=25
13009 e(i1)=arho
13010 go to 40
13011 endif
13012 endif
13013 endif
13014*(4) for pi(0)+p-->D(+)+rho(0) OR D(++)+rho(-) or D(0)+rho(+)
13015 if((iabs(lb(i1)).eq.1.and.lb(i2).eq.4).
13016 & or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.1))then
13017 if(iabs(lb(i1)).eq.1)then
13018 ii = i1
13019 IF(X2.LE.0.33)THEN
13020 lb(i1)=7
13021 e(i1)=dm
13022 lb(i2)=27
13023 e(i2)=arho
13024 go to 40
13025 ENDIF
13026 if(X2.gt.0.33.and.X2.le.0.67)then
13027 lb(i1)=8
13028 e(i1)=dm
13029 lb(i2)=26
13030 e(i2)=arho
13031 go to 40
13032 endif
13033 if(X2.gt.0.67)then
13034 lb(i1)=9
13035 e(i1)=dm
13036 lb(i2)=25
13037 e(i2)=arho
13038 go to 40
13039 endif
13040 else
13041 ii = i2
13042 IF(X2.LE.0.33)THEN
13043 lb(i2)=7
13044 e(i2)=dm
13045 lb(i1)=27
13046 e(i1)=arho
13047 go to 40
13048 ENDIF
13049 if(X2.gt.0.33.and.X2.le.0.67)then
13050 lb(i2)=8
13051 e(i2)=dm
13052 lb(i1)=26
13053 e(i1)=arho
13054 go to 40
13055 endif
13056 if(X2.gt.0.67)then
13057 lb(i2)=9
13058 e(i2)=dm
13059 lb(i1)=25
13060 e(i1)=arho
13061 go to 40
13062 endif
13063 endif
13064 endif
13065*(5) for pi(-)+n-->D(-)+rho(0) OR D(0)+rho(-)
13066 if( ((lb(i1).eq.2.and.lb(i2).eq.3).
13067 & or.(lb(i1).eq.3.and.lb(i2).eq.2))
13068 & .OR. ((lb(i1).eq.-2.and.lb(i2).eq.5).
13069 & or.(lb(i1).eq.5.and.lb(i2).eq.-2)) )then
13070 if(iabs(lb(i1)).eq.2)then
13071 ii = i1
13072 IF(X2.LE.0.5)THEN
13073 lb(i1)=6
13074 e(i1)=dm
13075 lb(i2)=26
13076 e(i2)=arho
13077 go to 40
13078 ELSE
13079 lb(i1)=7
13080 e(i1)=dm
13081 lb(i2)=25
13082 e(i2)=arho
13083 go to 40
13084 endif
13085 else
13086 ii = i2
13087 IF(X2.LE.0.5)THEN
13088 lb(i2)=6
13089 e(i2)=dm
13090 lb(i1)=26
13091 e(i1)=arho
13092 go to 40
13093 ELSE
13094 lb(i2)=7
13095 e(i2)=dm
13096 lb(i1)=25
13097 e(i1)=arho
13098 go to 40
13099 endif
13100 endif
13101 ENDIF
13102*(6) for pi(0)+n-->D(0)+rho(0), D(-)+rho(+) and D(+)+rho(-)
13103 if((iabs(lb(i1)).eq.2.and.lb(i2).eq.4).
13104 & or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.2))then
13105 if(iabs(lb(i1)).eq.2)then
13106 ii = i1
13107 IF(X2.LE.0.33)THEN
13108 lb(i1)=7
13109 e(i1)=dm
13110 lb(i2)=26
13111 e(i2)=arho
13112 go to 40
13113 endif
13114 if(x2.gt.0.33.and.x2.le.0.67)then
13115 lb(i1)=6
13116 e(i1)=dm
13117 lb(i2)=27
13118 e(i2)=arho
13119 go to 40
13120 endif
13121 if(x2.gt.0.67)then
13122 lb(i1)=8
13123 e(i1)=dm
13124 lb(i2)=25
13125 e(i2)=arho
13126 endif
13127 else
13128 ii = i2
13129 IF(X2.LE.0.33)THEN
13130 lb(i2)=7
13131 e(i2)=dm
13132 lb(i1)=26
13133 e(i1)=arho
13134 go to 40
13135 endif
13136 if(x2.le.0.67.and.x2.gt.0.33)then
13137 lb(i2)=6
13138 e(i2)=dm
13139 lb(i1)=27
13140 e(i1)=arho
13141 go to 40
13142 endif
13143 if(x2.gt.0.67)then
13144 lb(i2)=8
13145 e(i2)=dm
13146 lb(i1)=25
13147 e(i1)=arho
13148 endif
13149 endif
13150 endif
13151 Endif
13152 if(iblock.eq.79)then
13153 aomega=0.782
13154* GENERATE THE DELTA MASS
13155 dmax=srt-0.782-0.02
13156 dm=rmass(dmax,iseed)
13157* pion+baryon-->omega+delta
13158*(1) for pi(+)+p-->D(++)+omega(0)
13159 if( ((lb(i1).eq.1.and.lb(i2).eq.5).
13160 & or.(lb(i1).eq.5.and.lb(i2).eq.1))
13161 & .OR.((lb(i1).eq.-1.and.lb(i2).eq.3).
13162 & or.(lb(i1).eq.3.and.lb(i2).eq.-1)) )then
13163 if(iabs(lb(i1)).eq.1)then
13164 ii = i1
13165 lb(i1)=9
13166 e(i1)=dm
13167 lb(i2)=28
13168 e(i2)=aomega
13169 go to 40
13170 else
13171 ii = i2
13172 lb(i2)=9
13173 e(i2)=dm
13174 lb(i1)=28
13175 e(i1)=aomega
13176 go to 40
13177 endif
13178 endif
13179*(2) for pi(-)+p-->D(0)+omega(0)
13180 if( ((lb(i1).eq.1.and.lb(i2).eq.3).
13181 & or.(lb(i1).eq.3.and.lb(i2).eq.1))
13182 & .OR. ((lb(i1).eq.-1.and.lb(i2).eq.5).
13183 & or.(lb(i1).eq.5.and.lb(i2).eq.-1)) )then
13184 if(iabs(lb(i1)).eq.1)then
13185 ii = i1
13186 lb(i1)=7
13187 e(i1)=dm
13188 lb(i2)=28
13189 e(i2)=aomega
13190 go to 40
13191 else
13192 ii = i2
13193 lb(i2)=7
13194 e(i2)=dm
13195 lb(i1)=28
13196 e(i1)=aomega
13197 go to 40
13198 endif
13199 endif
13200*(3) for pi(+)+n-->D(+)+omega(0)
13201 if( ((lb(i1).eq.2.and.lb(i2).eq.5).
13202 & or.(lb(i1).eq.5.and.lb(i2).eq.2))
13203 & .OR. ((lb(i1).eq.-2.and.lb(i2).eq.3).
13204 & or.(lb(i1).eq.3.and.lb(i2).eq.-2)) )then
13205 if(iabs(lb(i1)).eq.2)then
13206 ii = i1
13207 lb(i1)=8
13208 e(i1)=dm
13209 lb(i2)=28
13210 e(i2)=aomega
13211 go to 40
13212 else
13213 ii = i2
13214 lb(i2)=8
13215 e(i2)=dm
13216 lb(i1)=28
13217 e(i1)=aomega
13218 go to 40
13219 endif
13220 endif
13221*(4) for pi(0)+p-->D(+)+omega(0)
13222 if((iabs(lb(i1)).eq.1.and.lb(i2).eq.4).
13223 & or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.1))then
13224 if(iabs(lb(i1)).eq.1)then
13225 ii = i1
13226 lb(i1)=8
13227 e(i1)=dm
13228 lb(i2)=28
13229 e(i2)=aomega
13230 go to 40
13231 else
13232 ii = i2
13233 lb(i2)=8
13234 e(i2)=dm
13235 lb(i1)=28
13236 e(i1)=aomega
13237 go to 40
13238 endif
13239 endif
13240*(5) for pi(-)+n-->D(-)+omega(0)
13241 if( ((lb(i1).eq.2.and.lb(i2).eq.3).
13242 & or.(lb(i1).eq.3.and.lb(i2).eq.2))
13243 & .OR. ((lb(i1).eq.-2.and.lb(i2).eq.5).
13244 & or.(lb(i1).eq.5.and.lb(i2).eq.-2)) )then
13245 if(iabs(lb(i1)).eq.2)then
13246 ii = i1
13247 lb(i1)=6
13248 e(i1)=dm
13249 lb(i2)=28
13250 e(i2)=aomega
13251 go to 40
13252 ELSE
13253 ii = i2
13254 lb(i2)=6
13255 e(i2)=dm
13256 lb(i1)=28
13257 e(i1)=aomega
13258 endif
13259 ENDIF
13260*(6) for pi(0)+n-->D(0)+omega(0)
13261 if((iabs(lb(i1)).eq.2.and.lb(i2).eq.4).
13262 & or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.2))then
13263 if(iabs(lb(i1)).eq.2)then
13264 ii = i1
13265 lb(i1)=7
13266 e(i1)=dm
13267 lb(i2)=28
13268 e(i2)=aomega
13269 go to 40
13270 else
13271 ii = i2
13272 lb(i2)=7
13273 e(i2)=dm
13274 lb(i1)=26
13275 e(i1)=arho
13276 go to 40
13277 endif
13278 endif
13279 Endif
1328040 em1=e(i1)
13281 em2=e(i2)
13282 if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
13283 lb(ii) = -lb(ii)
13284 jj = i2
13285 if(ii .eq. i2)jj = i1
13286 if(iblock .eq. 77)then
13287 if(lb(jj).eq.3)then
13288 lb(jj) = 5
13289 elseif(lb(jj).eq.5)then
13290 lb(jj) = 3
13291 endif
13292 elseif(iblock .eq. 78)then
13293 if(lb(jj).eq.25)then
13294 lb(jj) = 27
13295 elseif(lb(jj).eq.27)then
13296 lb(jj) = 25
13297 endif
13298 endif
13299 endif
13300 endif
13301*-----------------------------------------------------------------------
13302* CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
13303* ENERGY CONSERVATION
1330450 PR2 = (SRT**2 - EM1**2 - EM2**2)**2
13305 1 - 4.0 * (EM1*EM2)**2
13306 IF(PR2.LE.0.)PR2=0.00000001
13307 PR=SQRT(PR2)/(2.*SRT)
13308* here we use the same transverse momentum distribution as for
13309* pp collisions, it might be necessary to use a different distribution
13310
13311clin-10/25/02 get rid of argument usage mismatch in PTR():
13312 xptr=0.33*pr
13313c cc1=ptr(0.33*pr,iseed)
13314 cc1=ptr(xptr,iseed)
13315clin-10/25/02-end
13316
13317 c1=sqrt(pr**2-cc1**2)/pr
13318* C1 = 1.0 - 2.0 * RANART(NSEED)
13319 T1 = 2.0 * PI * RANART(NSEED)
13320 S1 = SQRT( 1.0 - C1**2 )
13321 CT1 = COS(T1)
13322 ST1 = SIN(T1)
13323* THE MOMENTUM IN THE CMS IN THE FINAL STATE
13324 PZ = PR * C1
13325 PX = PR * S1*CT1
13326 PY = PR * S1*ST1
13327* ROTATE IT
13328 CALL ROTATE(PX0,PY0,PZ0,PX,PY,PZ)
13329 RETURN
13330 END
13331**********************************
13332* *
13333* *
13334 SUBROUTINE CREN(PX,PY,PZ,SRT,I1,I2,IBLOCK)
13335* PURPOSE: *
13336* DEALING WITH ETA+N-->L/S+KAON PROCESS *
13337* NOTE : *
13338*
13339* QUANTITIES: *
13340* PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
13341* SRT - SQRT OF S *
13342* IBLOCK - THE INFORMATION BACK *
13343* 7 ETA+N-->L/S+KAON
13344**********************************
13345 PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
13346 1 AMP=0.93828,AP1=0.13496,
13347 2 AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
13348 PARAMETER (AKA=0.498,ALA=1.1157,ASA=1.1974)
13349 parameter (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
13350 COMMON /AA/ R(3,MAXSTR)
13351cc SAVE /AA/
13352 COMMON /BB/ P(3,MAXSTR)
13353cc SAVE /BB/
13354 COMMON /CC/ E(MAXSTR)
13355cc SAVE /CC/
13356 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
13357cc SAVE /EE/
13358 common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
13359cc SAVE /input1/
13360 COMMON/RNDF77/NSEED
13361cc SAVE /RNDF77/
13362 SAVE
13363
13364 PX0=PX
13365 PY0=PY
13366 PZ0=PZ
13367 NTAG=0
13368 IBLOCK=7
13369 ianti=0
13370 if(lb(i1).lt.0 .or. lb(i2).lt.0)then
13371 ianti=1
13372 iblock=-7
13373 endif
13374* RELABLE PARTICLES FOR THE PROCESS eta+n-->LAMBDA K OR SIGMA k
13375* DECIDE LAMBDA OR SIGMA PRODUCTION, AND TO CALCULATE THE NEW
13376* MOMENTA FOR PARTICLES IN THE FINAL STATE.
13377 KAONC=0
13378 IF(PNLKA(SRT)/(PNLKA(SRT)
13379 & +PNSKA(SRT)).GT.RANART(NSEED))KAONC=1
13380 IF(E(I1).LE.0.6)THEN
13381 LB(I1)=23
13382 E(I1)=AKA
13383 IF(KAONC.EQ.1)THEN
13384 LB(I2)=14
13385 E(I2)=ALA
13386 ELSE
13387 LB(I2) = 15 + int(3 * RANART(NSEED))
13388 E(I2)=ASA
13389 ENDIF
13390 if(ianti .eq. 1)then
13391 lb(i1)=21
13392 lb(i2)=-lb(i2)
13393 endif
13394 ELSE
13395 LB(I2)=23
13396 E(I2)=AKA
13397 IF(KAONC.EQ.1)THEN
13398 LB(I1)=14
13399 E(I1)=ALA
13400 ELSE
13401 LB(I1) = 15 + int(3 * RANART(NSEED))
13402 E(I1)=ASA
13403 ENDIF
13404 if(ianti .eq. 1)then
13405 lb(i2)=21
13406 lb(i1)=-lb(i1)
13407 endif
13408 ENDIF
13409 EM1=E(I1)
13410 EM2=E(I2)
13411*-----------------------------------------------------------------------
13412* CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
13413* ENERGY CONSERVATION
13414 PR2 = (SRT**2 - EM1**2 - EM2**2)**2
13415 1 - 4.0 * (EM1*EM2)**2
13416 IF(PR2.LE.0.)PR2=1.e-09
13417 PR=SQRT(PR2)/(2.*SRT)
13418 C1 = 1.0 - 2.0 * RANART(NSEED)
13419 T1 = 2.0 * PI * RANART(NSEED)
13420 S1 = SQRT( 1.0 - C1**2 )
13421 CT1 = COS(T1)
13422 ST1 = SIN(T1)
13423* THE MOMENTUM IN THE CMS IN THE FINAL STATE
13424 PZ = PR * C1
13425 PX = PR * S1*CT1
13426 PY = PR * S1*ST1
13427* FOR THE ISOTROPIC DISTRIBUTION THERE IS NO NEED TO ROTATE
13428 RETURN
13429 END
13430**********************************
13431* *
13432* *
13433c SUBROUTINE Crdir(PX,PY,PZ,SRT,I1,I2)
13434 SUBROUTINE Crdir(PX,PY,PZ,SRT,I1,I2,IBLOCK)
13435* PURPOSE: *
13436* DEALING WITH pion+N-->pion+N PROCESS *
13437* NOTE : *
13438*
13439* QUANTITIES: *
13440* PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
13441* SRT - SQRT OF S *
13442* IBLOCK - THE INFORMATION BACK *
13443*
13444**********************************
13445 PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
13446 1 AMP=0.93828,AP1=0.13496,
13447 2 AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
13448 PARAMETER (AKA=0.498,ALA=1.1157,ASA=1.1974)
13449 parameter (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
13450 COMMON /AA/ R(3,MAXSTR)
13451cc SAVE /AA/
13452 COMMON /BB/ P(3,MAXSTR)
13453cc SAVE /BB/
13454 COMMON /CC/ E(MAXSTR)
13455cc SAVE /CC/
13456 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
13457cc SAVE /EE/
13458 common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
13459cc SAVE /input1/
13460 COMMON/RNDF77/NSEED
13461cc SAVE /RNDF77/
13462 SAVE
13463
13464 PX0=PX
13465 PY0=PY
13466 PZ0=PZ
13467 IBLOCK=999
13468 NTAG=0
13469 EM1=E(I1)
13470 EM2=E(I2)
13471*-----------------------------------------------------------------------
13472* CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
13473* ENERGY CONSERVATION
13474 PR2 = (SRT**2 - EM1**2 - EM2**2)**2
13475 1 - 4.0 * (EM1*EM2)**2
13476 IF(PR2.LE.0.)PR2=1.e-09
13477 PR=SQRT(PR2)/(2.*SRT)
13478
13479clin-10/25/02 get rid of argument usage mismatch in PTR():
13480 xptr=0.33*pr
13481c cc1=ptr(0.33*pr,iseed)
13482 cc1=ptr(xptr,iseed)
13483clin-10/25/02-end
13484
13485 c1=sqrt(pr**2-cc1**2)/pr
13486 T1 = 2.0 * PI * RANART(NSEED)
13487 S1 = SQRT( 1.0 - C1**2 )
13488 CT1 = COS(T1)
13489 ST1 = SIN(T1)
13490* THE MOMENTUM IN THE CMS IN THE FINAL STATE
13491 PZ = PR * C1
13492 PX = PR * S1*CT1
13493 PY = PR * S1*ST1
13494* ROTATE the momentum
13495 call rotate(px0,py0,pz0,px,py,pz)
13496 RETURN
13497 END
13498**********************************
13499* *
13500* *
13501 SUBROUTINE CRPD(PX,PY,PZ,SRT,I1,I2,
13502 & IBLOCK,xkaon0,xkaon,Xphi,xphin)
13503* PURPOSE: *
13504* DEALING WITH PION+D(N*)-->PION +N OR
13505* L/S+KAON PROCESS *
13506* NOTE : *
13507*
13508* QUANTITIES: *
13509* PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
13510* SRT - SQRT OF S *
13511* IBLOCK - THE INFORMATION BACK *
13512* 7 PION+D(N*)-->L/S+KAON
13513* iblock - 80 pion+D(N*)-->pion+N
13514* iblock - 81 RHO+D(N*)-->PION+N
13515* iblock - 82 OMEGA+D(N*)-->PION+N
13516* 222 PION+D --> PHI
13517**********************************
13518 PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
13519 1 AMP=0.93828,AP1=0.13496,APHI=1.020,
13520 2 AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
13521 PARAMETER (AKA=0.498,ALA=1.1157,ASA=1.1974)
13522 parameter (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
13523 COMMON /AA/ R(3,MAXSTR)
13524cc SAVE /AA/
13525 COMMON /BB/ P(3,MAXSTR)
13526cc SAVE /BB/
13527 COMMON /CC/ E(MAXSTR)
13528cc SAVE /CC/
13529 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
13530cc SAVE /EE/
13531 common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
13532cc SAVE /input1/
13533 COMMON/RNDF77/NSEED
13534cc SAVE /RNDF77/
13535 SAVE
13536
13537 PX0=PX
13538 PY0=PY
13539 PZ0=PZ
13540 IBLOCK=1
13541 x1=RANART(NSEED)
13542 ianti=0
13543 if(lb(i1).lt.0 .or. lb(i2).lt.0)ianti=1
13544 if(xkaon0/(xkaon+Xphi).ge.x1)then
13545* kaon production
13546*-----------------------------------------------------------------------
13547 IBLOCK=7
13548 if(ianti .eq. 1)iblock=-7
13549 NTAG=0
13550* RELABLE PARTICLES FOR THE PROCESS PION+n-->LAMBDA K OR SIGMA k
13551* DECIDE LAMBDA OR SIGMA PRODUCTION, AND TO CALCULATE THE NEW
13552* MOMENTA FOR PARTICLES IN THE FINAL STATE.
13553 KAONC=0
13554 IF(PNLKA(SRT)/(PNLKA(SRT)
13555 & +PNSKA(SRT)).GT.RANART(NSEED))KAONC=1
13556clin-8/17/00 & +PNSKA(SRT)).GT.RANART(NSEED))KAONC=1
13557 IF(E(I1).LE.0.2)THEN
13558 LB(I1)=23
13559 E(I1)=AKA
13560 IF(KAONC.EQ.1)THEN
13561 LB(I2)=14
13562 E(I2)=ALA
13563 ELSE
13564 LB(I2) = 15 + int(3 * RANART(NSEED))
13565 E(I2)=ASA
13566 ENDIF
13567 if(ianti .eq. 1)then
13568 lb(i1)=21
13569 lb(i2)=-lb(i2)
13570 endif
13571 ELSE
13572 LB(I2)=23
13573 E(I2)=AKA
13574 IF(KAONC.EQ.1)THEN
13575 LB(I1)=14
13576 E(I1)=ALA
13577 ELSE
13578 LB(I1) = 15 + int(3 * RANART(NSEED))
13579 E(I1)=ASA
13580 ENDIF
13581 if(ianti .eq. 1)then
13582 lb(i2)=21
13583 lb(i1)=-lb(i1)
13584 endif
13585 ENDIF
13586 EM1=E(I1)
13587 EM2=E(I2)
13588 go to 50
13589* to gererate the momentum for the kaon and L/S
13590c
13591c* Phi production
13592 elseif(Xphi/(xkaon+Xphi).ge.x1)then
13593 iblock=222
13594 if(xphin/Xphi .ge. RANART(NSEED))then
13595 LB(I1)= 1+int(2*RANART(NSEED))
13596 E(I1)=AMN
13597 else
13598 LB(I1)= 6+int(4*RANART(NSEED))
13599 E(I1)=AM0
13600 endif
13601c !! at present only baryon
13602 if(ianti .eq. 1)lb(i1)=-lb(i1)
13603 LB(I2)= 29
13604 E(I2)=APHI
13605 EM1=E(I1)
13606 EM2=E(I2)
13607 go to 50
13608 else
13609* PION REABSORPTION HAS HAPPENED
13610 X2=RANART(NSEED)
13611 IBLOCK=80
13612 ntag=0
13613* Relable particles, I1 is assigned to the nucleon
13614* and I2 is assigned to the pion
13615* for the reverse of the following process
13616*(1) for D(+)+P(+)-->p+pion(+)
13617 if( ((lb(i1).eq.8.and.lb(i2).eq.5).
13618 & or.(lb(i1).eq.5.and.lb(i2).eq.8))
13619 & .OR.((lb(i1).eq.-8.and.lb(i2).eq.3).
13620 & or.(lb(i1).eq.3.and.lb(i2).eq.-8)) )then
13621 if(iabs(lb(i1)).eq.8)then
13622 ii = i1
13623 lb(i1)=1
13624 e(i1)=amn
13625 lb(i2)=5
13626 e(i2)=ap1
13627 go to 40
13628 else
13629 ii = i2
13630 lb(i2)=1
13631 e(i2)=amn
13632 lb(i1)=5
13633 e(i1)=ap1
13634 go to 40
13635 endif
13636 endif
13637c
13638*(2) for D(0)+P(0)-->n+pi(0) or p+pi(-)
13639 if((iabs(lb(i1)).eq.7.and.lb(i2).eq.4).
13640 & or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.7))then
13641 if(iabs(lb(i1)).eq.7)then
13642 ii = i1
13643 IF(X2.LE.0.5)THEN
13644 lb(i1)=2
13645 e(i1)=amn
13646 lb(i2)=4
13647 e(i2)=ap1
13648 go to 40
13649 Else
13650 lb(i1)=1
13651 e(i1)=amn
13652 lb(i2)=3
13653 e(i2)=ap1
13654 go to 40
13655 endif
13656 else
13657 ii = i2
13658 IF(X2.LE.0.5)THEN
13659 lb(i2)=2
13660 e(i2)=amn
13661 lb(i1)=4
13662 e(i1)=ap1
13663 go to 40
13664 Else
13665 lb(i2)=1
13666 e(i2)=amn
13667 lb(i1)=3
13668 e(i1)=ap1
13669 go to 40
13670 endif
13671 endif
13672 endif
13673*(3) for D(+)+Pi(0)-->pi(+)+n or pi(0)+p
13674 if((iabs(lb(i1)).eq.8.and.lb(i2).eq.4).
13675 & or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.8))then
13676 if(iabs(lb(i1)).eq.8)then
13677 ii = i1
13678 IF(X2.LE.0.5)THEN
13679 lb(i1)=2
13680 e(i1)=amn
13681 lb(i2)=5
13682 e(i2)=ap1
13683 go to 40
13684 Else
13685 lb(i1)=1
13686 e(i1)=amn
13687 lb(i2)=4
13688 e(i2)=ap1
13689 go to 40
13690 endif
13691 else
13692 ii = i2
13693 IF(X2.LE.0.5)THEN
13694 lb(i2)=2
13695 e(i2)=amn
13696 lb(i1)=5
13697 e(i1)=ap1
13698 go to 40
13699 Else
13700 lb(i2)=1
13701 e(i2)=amn
13702 lb(i1)=4
13703 e(i1)=ap1
13704 go to 40
13705 endif
13706 endif
13707 endif
13708*(4) for D(-)+Pi(0)-->n+pi(-)
13709 if((iabs(lb(i1)).eq.6.and.lb(i2).eq.4).
13710 & or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.6))then
13711 if(iabs(lb(i1)).eq.6)then
13712 ii = i1
13713 lb(i1)=2
13714 e(i1)=amn
13715 lb(i2)=3
13716 e(i2)=ap1
13717 go to 40
13718 else
13719 ii = i2
13720 lb(i2)=2
13721 e(i2)=amn
13722 lb(i1)=3
13723 e(i1)=ap1
13724 go to 40
13725 ENDIF
13726 endif
13727*(5) for D(+)+Pi(-)-->pi(0)+n or pi(-)+p
13728 if( ((lb(i1).eq.8.and.lb(i2).eq.3).
13729 & or.(lb(i1).eq.3.and.lb(i2).eq.8))
13730 & .OR.((lb(i1).eq.-8.and.lb(i2).eq.5).
13731 & or.(lb(i1).eq.5.and.lb(i2).eq.-8)) )then
13732 if(iabs(lb(i1)).eq.8)then
13733 ii = i1
13734 IF(X2.LE.0.5)THEN
13735 lb(i1)=2
13736 e(i1)=amn
13737 lb(i2)=4
13738 e(i2)=ap1
13739 go to 40
13740 ELSE
13741 lb(i1)=1
13742 e(i1)=amn
13743 lb(i2)=3
13744 e(i2)=ap1
13745 go to 40
13746 endif
13747 else
13748 ii = i2
13749 IF(X2.LE.0.5)THEN
13750 lb(i2)=2
13751 e(i2)=amn
13752 lb(i1)=4
13753 e(i1)=ap1
13754 go to 40
13755 ELSE
13756 lb(i2)=1
13757 e(i2)=amn
13758 lb(i1)=3
13759 e(i1)=ap1
13760 go to 40
13761 endif
13762 endif
13763 ENDIF
13764*(6) D(0)+P(+)-->n+pi(+) or p+pi(0)
13765 if( ((lb(i1).eq.7.and.lb(i2).eq.5).
13766 & or.(lb(i1).eq.5.and.lb(i2).eq.7))
13767 & .OR.((lb(i1).eq.-7.and.lb(i2).eq.3).
13768 & or.(lb(i1).eq.3.and.lb(i2).eq.-7)) )then
13769 if(iabs(lb(i1)).eq.7)then
13770 ii = i1
13771 IF(X2.LE.0.5)THEN
13772 lb(i1)=2
13773 e(i1)=amn
13774 lb(i2)=5
13775 e(i2)=ap1
13776 go to 40
13777 else
13778 lb(i1)=1
13779 e(i1)=amn
13780 lb(i2)=4
13781 e(i2)=ap1
13782 go to 40
13783 endif
13784 else
13785 ii = i2
13786 IF(X2.LE.0.5)THEN
13787 lb(i2)=2
13788 e(i2)=amn
13789 lb(i1)=5
13790 e(i1)=ap1
13791 go to 40
13792 Else
13793 lb(i2)=1
13794 e(i2)=amn
13795 lb(i1)=4
13796 e(i1)=ap1
13797 go to 40
13798 endif
13799 endif
13800 ENDIF
13801*(7) for D(0)+Pi(-)-->n+pi(-)
13802 if( ((lb(i1).eq.7.and.lb(i2).eq.3).
13803 & or.(lb(i1).eq.3.and.lb(i2).eq.7))
13804 & .OR.((lb(i1).eq.-7.and.lb(i2).eq.5).
13805 & or.(lb(i1).eq.5.and.lb(i2).eq.-7)) )then
13806 if(iabs(lb(i1)).eq.7)then
13807 ii = i1
13808 lb(i1)=2
13809 e(i1)=amn
13810 lb(i2)=3
13811 e(i2)=ap1
13812 go to 40
13813 else
13814 ii = i2
13815 lb(i2)=2
13816 e(i2)=amn
13817 lb(i1)=3
13818 e(i1)=ap1
13819 go to 40
13820 ENDIF
13821 endif
13822*(8) D(-)+P(+)-->n+pi(0) or p+pi(-)
13823 if( ((lb(i1).eq.6.and.lb(i2).eq.5)
13824 & .or.(lb(i1).eq.5.and.lb(i2).eq.6))
13825 & .OR.((lb(i1).eq.-6.and.lb(i2).eq.3).
13826 & or.(lb(i1).eq.3.and.lb(i2).eq.-6)) )then
13827 if(iabs(lb(i1)).eq.6)then
13828 ii = i1
13829 IF(X2.LE.0.5)THEN
13830 lb(i1)=2
13831 e(i1)=amn
13832 lb(i2)=4
13833 e(i2)=ap1
13834 go to 40
13835 else
13836 lb(i1)=1
13837 e(i1)=amn
13838 lb(i2)=3
13839 e(i2)=ap1
13840 go to 40
13841 endif
13842 else
13843 ii = i2
13844 IF(X2.LE.0.5)THEN
13845 lb(i2)=2
13846 e(i2)=amn
13847 lb(i1)=4
13848 e(i1)=ap1
13849 go to 40
13850 Else
13851 lb(i2)=1
13852 e(i2)=amn
13853 lb(i1)=3
13854 e(i1)=ap1
13855 go to 40
13856 endif
13857 endif
13858 ENDIF
13859c
13860*(9) D(++)+P(-)-->n+pi(+) or p+pi(0)
13861 if( ((lb(i1).eq.9.and.lb(i2).eq.3)
13862 & .or.(lb(i1).eq.3.and.lb(i2).eq.9))
13863 & .OR. ((lb(i1).eq.-9.and.lb(i2).eq.5)
13864 & .or.(lb(i1).eq.5.and.lb(i2).eq.-9)) )then
13865 if(iabs(lb(i1)).eq.9)then
13866 ii = i1
13867 IF(X2.LE.0.5)THEN
13868 lb(i1)=2
13869 e(i1)=amn
13870 lb(i2)=5
13871 e(i2)=ap1
13872 go to 40
13873 else
13874 lb(i1)=1
13875 e(i1)=amn
13876 lb(i2)=4
13877 e(i2)=ap1
13878 go to 40
13879 endif
13880 else
13881 ii = i2
13882 IF(X2.LE.0.5)THEN
13883 lb(i2)=2
13884 e(i2)=amn
13885 lb(i1)=5
13886 e(i1)=ap1
13887 go to 40
13888 Else
13889 lb(i2)=1
13890 e(i2)=amn
13891 lb(i1)=4
13892 e(i1)=ap1
13893 go to 40
13894 endif
13895 endif
13896 ENDIF
13897*(10) for D(++)+Pi(0)-->p+pi(+)
13898 if((iabs(lb(i1)).eq.9.and.lb(i2).eq.4)
13899 & .or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.9))then
13900 if(iabs(lb(i1)).eq.9)then
13901 ii = i1
13902 lb(i1)=1
13903 e(i1)=amn
13904 lb(i2)=5
13905 e(i2)=ap1
13906 go to 40
13907 else
13908 ii = i2
13909 lb(i2)=1
13910 e(i2)=amn
13911 lb(i1)=5
13912 e(i1)=ap1
13913 go to 40
13914 ENDIF
13915 endif
13916*(11) for N*(1440)(+)or N*(1535)(+)+P(+)-->p+pion(+)
13917 if( ((lb(i1).eq.11.and.lb(i2).eq.5).
13918 & or.(lb(i1).eq.5.and.lb(i2).eq.11).
13919 & or.(lb(i1).eq.13.and.lb(i2).eq.5).
13920 & or.(lb(i1).eq.5.and.lb(i2).eq.13))
13921 & .OR.((lb(i1).eq.-11.and.lb(i2).eq.3).
13922 & or.(lb(i1).eq.3.and.lb(i2).eq.-11).
13923 & or.(lb(i1).eq.-13.and.lb(i2).eq.3).
13924 & or.(lb(i1).eq.3.and.lb(i2).eq.-13)) )then
13925 if(iabs(lb(i1)).eq.11.or.iabs(lb(i1)).eq.13)then
13926 ii = i1
13927 lb(i1)=1
13928 e(i1)=amn
13929 lb(i2)=5
13930 e(i2)=ap1
13931 go to 40
13932 else
13933 ii = i2
13934 lb(i2)=1
13935 e(i2)=amn
13936 lb(i1)=5
13937 e(i1)=ap1
13938 go to 40
13939 endif
13940 endif
13941*(12) for N*(1440) or N*(1535)(0)+P(0)-->n+pi(0) or p+pi(-)
13942 if((iabs(lb(i1)).eq.10.and.lb(i2).eq.4).
13943 & or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.10).
13944 & or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.12).
13945 & or.(lb(i2).eq.4.and.iabs(lb(i1)).eq.12))then
13946 if(iabs(lb(i1)).eq.10.or.iabs(lb(i1)).eq.12)then
13947 ii = i1
13948 IF(X2.LE.0.5)THEN
13949 lb(i1)=2
13950 e(i1)=amn
13951 lb(i2)=4
13952 e(i2)=ap1
13953 go to 40
13954 Else
13955 lb(i1)=1
13956 e(i1)=amn
13957 lb(i2)=3
13958 e(i2)=ap1
13959 go to 40
13960 endif
13961 else
13962 ii = i2
13963 IF(X2.LE.0.5)THEN
13964 lb(i2)=2
13965 e(i2)=amn
13966 lb(i1)=4
13967 e(i1)=ap1
13968 go to 40
13969 Else
13970 lb(i2)=1
13971 e(i2)=amn
13972 lb(i1)=3
13973 e(i1)=ap1
13974 go to 40
13975 endif
13976 endif
13977 endif
13978*(13) for N*(1440) or N*(1535)(+)+Pi(0)-->pi(+)+n or pi(0)+p
13979 if((iabs(lb(i1)).eq.11.and.lb(i2).eq.4).
13980 & or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.11).
13981 & or.(lb(i1).eq.4.and.iabs(lb(i2)).eq.13).
13982 & or.(lb(i2).eq.4.and.iabs(lb(i1)).eq.13))then
13983 if(iabs(lb(i1)).eq.11.or.iabs(lb(i1)).eq.13)then
13984 ii = i1
13985 IF(X2.LE.0.5)THEN
13986 lb(i1)=2
13987 e(i1)=amn
13988 lb(i2)=5
13989 e(i2)=ap1
13990 go to 40
13991 Else
13992 lb(i1)=1
13993 e(i1)=amn
13994 lb(i2)=4
13995 e(i2)=ap1
13996 go to 40
13997 endif
13998 else
13999 ii = i2
14000 IF(X2.LE.0.5)THEN
14001 lb(i2)=2
14002 e(i2)=amn
14003 lb(i1)=5
14004 e(i1)=ap1
14005 go to 40
14006 Else
14007 lb(i2)=1
14008 e(i2)=amn
14009 lb(i1)=4
14010 e(i1)=ap1
14011 go to 40
14012 endif
14013 endif
14014 endif
14015*(14) for N*(1440) or N*(1535)(+)+Pi(-)-->pi(0)+n or pi(-)+p
14016 if( ((lb(i1).eq.11.and.lb(i2).eq.3).
14017 & or.(lb(i1).eq.3.and.lb(i2).eq.11).
14018 & or.(lb(i1).eq.3.and.lb(i2).eq.13).
14019 & or.(lb(i2).eq.3.and.lb(i1).eq.13))
14020 & .OR.((lb(i1).eq.-11.and.lb(i2).eq.5).
14021 & or.(lb(i1).eq.5.and.lb(i2).eq.-11).
14022 & or.(lb(i1).eq.5.and.lb(i2).eq.-13).
14023 & or.(lb(i2).eq.5.and.lb(i1).eq.-13)) )then
14024 if(iabs(lb(i1)).eq.11.or.iabs(lb(i1)).eq.13)then
14025 ii = i1
14026 IF(X2.LE.0.5)THEN
14027 lb(i1)=2
14028 e(i1)=amn
14029 lb(i2)=4
14030 e(i2)=ap1
14031 go to 40
14032 ELSE
14033 lb(i1)=1
14034 e(i1)=amn
14035 lb(i2)=3
14036 e(i2)=ap1
14037 go to 40
14038 endif
14039 else
14040 ii = i2
14041 IF(X2.LE.0.5)THEN
14042 lb(i2)=2
14043 e(i2)=amn
14044 lb(i1)=4
14045 e(i1)=ap1
14046 go to 40
14047 ELSE
14048 lb(i2)=1
14049 e(i2)=amn
14050 lb(i1)=3
14051 e(i1)=ap1
14052 go to 40
14053 endif
14054 endif
14055 ENDIF
14056*(15) N*(1440) or N*(1535)(0)+P(+)-->n+pi(+) or p+pi(0)
14057 if( ((lb(i1).eq.10.and.lb(i2).eq.5).
14058 & or.(lb(i1).eq.5.and.lb(i2).eq.10).
14059 & or.(lb(i1).eq.12.and.lb(i2).eq.5).
14060 & or.(lb(i1).eq.5.and.lb(i2).eq.12))
14061 & .OR.((lb(i1).eq.-10.and.lb(i2).eq.3).
14062 & or.(lb(i1).eq.3.and.lb(i2).eq.-10).
14063 & or.(lb(i1).eq.-12.and.lb(i2).eq.3).
14064 & or.(lb(i1).eq.3.and.lb(i2).eq.-12)) )then
14065 if(iabs(lb(i1)).eq.10.or.iabs(lb(i1)).eq.12)then
14066 ii = i1
14067 IF(X2.LE.0.5)THEN
14068 lb(i1)=2
14069 e(i1)=amn
14070 lb(i2)=5
14071 e(i2)=ap1
14072 go to 40
14073 else
14074 lb(i1)=1
14075 e(i1)=amn
14076 lb(i2)=4
14077 e(i2)=ap1
14078 go to 40
14079 endif
14080 else
14081 ii = i2
14082 IF(X2.LE.0.5)THEN
14083 lb(i2)=2
14084 e(i2)=amn
14085 lb(i1)=5
14086 e(i1)=ap1
14087 go to 40
14088 Else
14089 lb(i2)=1
14090 e(i2)=amn
14091 lb(i1)=4
14092 e(i1)=ap1
14093 go to 40
14094 endif
14095 endif
14096 ENDIF
14097*(16) for N*(1440) or N*(1535) (0)+Pi(-)-->n+pi(-)
14098 if( ((lb(i1).eq.10.and.lb(i2).eq.3).
14099 & or.(lb(i1).eq.3.and.lb(i2).eq.10).
14100 & or.(lb(i1).eq.3.and.lb(i2).eq.12).
14101 & or.(lb(i1).eq.12.and.lb(i2).eq.3))
14102 & .OR.((lb(i1).eq.-10.and.lb(i2).eq.5).
14103 & or.(lb(i1).eq.5.and.lb(i2).eq.-10).
14104 & or.(lb(i1).eq.5.and.lb(i2).eq.-12).
14105 & or.(lb(i1).eq.-12.and.lb(i2).eq.5)) )then
14106 if(iabs(lb(i1)).eq.10.or.iabs(lb(i1)).eq.12)then
14107 ii = i1
14108 lb(i1)=2
14109 e(i1)=amn
14110 lb(i2)=3
14111 e(i2)=ap1
14112 go to 40
14113 else
14114 ii = i2
14115 lb(i2)=2
14116 e(i2)=amn
14117 lb(i1)=3
14118 e(i1)=ap1
14119 go to 40
14120 ENDIF
14121 endif
1412240 em1=e(i1)
14123 em2=e(i2)
14124 if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
14125 lb(ii) = -lb(ii)
14126 jj = i2
14127 if(ii .eq. i2)jj = i1
14128 if(lb(jj).eq.3)then
14129 lb(jj) = 5
14130 elseif(lb(jj).eq.5)then
14131 lb(jj) = 3
14132 endif
14133 endif
14134 endif
14135*-----------------------------------------------------------------------
14136* CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
14137* ENERGY CONSERVATION
1413850 PR2 = (SRT**2 - EM1**2 - EM2**2)**2
14139 1 - 4.0 * (EM1*EM2)**2
14140 IF(PR2.LE.0.)PR2=1.E-09
14141 PR=SQRT(PR2)/(2.*SRT)
14142
14143clin-10/25/02 get rid of argument usage mismatch in PTR():
14144 xptr=0.33*pr
14145c cc1=ptr(0.33*pr,iseed)
14146 cc1=ptr(xptr,iseed)
14147clin-10/25/02-end
14148
14149 c1=sqrt(pr**2-cc1**2)/pr
14150c C1 = 1.0 - 2.0 * RANART(NSEED)
14151 T1 = 2.0 * PI * RANART(NSEED)
14152 S1 = SQRT( 1.0 - C1**2 )
14153 CT1 = COS(T1)
14154 ST1 = SIN(T1)
14155 PZ = PR * C1
14156 PX = PR * S1*CT1
14157 PY = PR * S1*ST1
14158* rotate the momentum
14159 call rotate(px0,py0,pz0,px,py,pz)
14160 RETURN
14161 END
14162**********************************
14163* *
14164* *
14165 SUBROUTINE CRRD(PX,PY,PZ,SRT,I1,I2,
14166 & IBLOCK,xkaon0,xkaon,Xphi,xphin)
14167* PURPOSE: *
14168* DEALING WITH rho(omega)+N or D(N*)-->PION +N OR
14169* L/S+KAON PROCESS *
14170* NOTE : *
14171*
14172* QUANTITIES: *
14173* PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
14174* SRT - SQRT OF S *
14175* IBLOCK - THE INFORMATION BACK *
14176* 7 rho(omega)+N or D(N*)-->L/S+KAON
14177* iblock - 80 pion+D(N*)-->pion+N
14178* iblock - 81 RHO+D(N*)-->PION+N
14179* iblock - 82 OMEGA+D(N*)-->PION+N
14180* iblock - 222 pion+N-->Phi
14181**********************************
14182 PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
14183 1 AMP=0.93828,AP1=0.13496,
14184 2 AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
14185 PARAMETER (AKA=0.498,ALA=1.1157,ASA=1.1974,APHI=1.02)
14186 parameter (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
14187 COMMON /AA/ R(3,MAXSTR)
14188cc SAVE /AA/
14189 COMMON /BB/ P(3,MAXSTR)
14190cc SAVE /BB/
14191 COMMON /CC/ E(MAXSTR)
14192cc SAVE /CC/
14193 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
14194cc SAVE /EE/
14195 common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
14196cc SAVE /input1/
14197 COMMON/RNDF77/NSEED
14198cc SAVE /RNDF77/
14199 SAVE
14200
14201 PX0=PX
14202 PY0=PY
14203 PZ0=PZ
14204 IBLOCK=1
14205 ianti=0
14206 if(lb(i1).lt.0 .or. lb(i2).lt.0) ianti=1
14207 x1=RANART(NSEED)
14208 if(xkaon0/(xkaon+Xphi).ge.x1)then
14209* kaon production
14210*-----------------------------------------------------------------------
14211 IBLOCK=7
14212 if(ianti .eq. 1)iblock=-7
14213 NTAG=0
14214* RELABLE PARTICLES FOR THE PROCESS PION+n-->LAMBDA K OR SIGMA k
14215* DECIDE LAMBDA OR SIGMA PRODUCTION, AND TO CALCULATE THE NEW
14216* MOMENTA FOR PARTICLES IN THE FINAL STATE.
14217 KAONC=0
14218 IF(PNLKA(SRT)/(PNLKA(SRT)
14219 & +PNSKA(SRT)).GT.RANART(NSEED))KAONC=1
14220clin-8/17/00 & +PNSKA(SRT)).GT.RANART(NSEED))KAONC=1
14221 IF(E(I1).LE.0.92)THEN
14222 LB(I1)=23
14223 E(I1)=AKA
14224 IF(KAONC.EQ.1)THEN
14225 LB(I2)=14
14226 E(I2)=ALA
14227 ELSE
14228 LB(I2) = 15 + int(3 * RANART(NSEED))
14229 E(I2)=ASA
14230 ENDIF
14231 if(ianti .eq. 1)then
14232 lb(i1) = 21
14233 lb(i2) = -lb(i2)
14234 endif
14235 ELSE
14236 LB(I2)=23
14237 E(I2)=AKA
14238 IF(KAONC.EQ.1)THEN
14239 LB(I1)=14
14240 E(I1)=ALA
14241 ELSE
14242 LB(I1) = 15 + int(3 * RANART(NSEED))
14243 E(I1)=ASA
14244 ENDIF
14245 if(ianti .eq. 1)then
14246 lb(i2) = 21
14247 lb(i1) = -lb(i1)
14248 endif
14249 ENDIF
14250 EM1=E(I1)
14251 EM2=E(I2)
14252 go to 50
14253* to gererate the momentum for the kaon and L/S
14254c
14255c* Phi production
14256 elseif(Xphi/(xkaon+Xphi).ge.x1)then
14257 iblock=222
14258 if(xphin/Xphi .ge. RANART(NSEED))then
14259 LB(I1)= 1+int(2*RANART(NSEED))
14260 E(I1)=AMN
14261 else
14262 LB(I1)= 6+int(4*RANART(NSEED))
14263 E(I1)=AM0
14264 endif
14265c !! at present only baryon
14266 if(ianti .eq. 1)lb(i1)=-lb(i1)
14267 LB(I2)= 29
14268 E(I2)=APHI
14269 EM1=E(I1)
14270 EM2=E(I2)
14271 go to 50
14272 else
14273* rho(omega) REABSORPTION HAS HAPPENED
14274 X2=RANART(NSEED)
14275 IBLOCK=81
14276 ntag=0
14277 if(lb(i1).eq.28.or.lb(i2).eq.28)go to 60
14278* we treat Rho reabsorption in the following
14279* Relable particles, I1 is assigned to the Delta
14280* and I2 is assigned to the meson
14281* for the reverse of the following process
14282*(1) for D(+)+rho(+)-->p+pion(+)
14283 if( ((lb(i1).eq.8.and.lb(i2).eq.27).
14284 & or.(lb(i1).eq.27.and.lb(i2).eq.8))
14285 & .OR. ((lb(i1).eq.-8.and.lb(i2).eq.25).
14286 & or.(lb(i1).eq.25.and.lb(i2).eq.-8)) )then
14287 if(iabs(lb(i1)).eq.8)then
14288 ii = i1
14289 lb(i1)=1
14290 e(i1)=amn
14291 lb(i2)=5
14292 e(i2)=ap1
14293 go to 40
14294 else
14295 ii = i2
14296 lb(i2)=1
14297 e(i2)=amn
14298 lb(i1)=5
14299 e(i1)=ap1
14300 go to 40
14301 endif
14302 endif
14303*(2) for D(0)+rho(0)-->n+pi(0) or p+pi(-)
14304 if((iabs(lb(i1)).eq.7.and.lb(i2).eq.26).
14305 & or.(lb(i1).eq.26.and.iabs(lb(i2)).eq.7))then
14306 if(iabs(lb(i1)).eq.7)then
14307 ii = i1
14308 IF(X2.LE.0.5)THEN
14309 lb(i1)=2
14310 e(i1)=amn
14311 lb(i2)=4
14312 e(i2)=ap1
14313 go to 40
14314 Else
14315 lb(i1)=1
14316 e(i1)=amn
14317 lb(i2)=3
14318 e(i2)=ap1
14319 go to 40
14320 endif
14321 else
14322 ii = i2
14323 IF(X2.LE.0.5)THEN
14324 lb(i2)=2
14325 e(i2)=amn
14326 lb(i1)=4
14327 e(i1)=ap1
14328 go to 40
14329 Else
14330 lb(i2)=1
14331 e(i2)=amn
14332 lb(i1)=3
14333 e(i1)=ap1
14334 go to 40
14335 endif
14336 endif
14337 endif
14338*(3) for D(+)+rho(0)-->pi(+)+n or pi(0)+p
14339 if((iabs(lb(i1)).eq.8.and.lb(i2).eq.26).
14340 & or.(lb(i1).eq.26.and.iabs(lb(i2)).eq.8))then
14341 if(iabs(lb(i1)).eq.8)then
14342 ii = i1
14343 IF(X2.LE.0.5)THEN
14344 lb(i1)=2
14345 e(i1)=amn
14346 lb(i2)=5
14347 e(i2)=ap1
14348 go to 40
14349 Else
14350 lb(i1)=1
14351 e(i1)=amn
14352 lb(i2)=4
14353 e(i2)=ap1
14354 go to 40
14355 endif
14356 else
14357 ii = i2
14358 IF(X2.LE.0.5)THEN
14359 lb(i2)=2
14360 e(i2)=amn
14361 lb(i1)=5
14362 e(i1)=ap1
14363 go to 40
14364 Else
14365 lb(i2)=1
14366 e(i2)=amn
14367 lb(i1)=4
14368 e(i1)=ap1
14369 go to 40
14370 endif
14371 endif
14372 endif
14373*(4) for D(-)+rho(0)-->n+pi(-)
14374 if((iabs(lb(i1)).eq.6.and.lb(i2).eq.26).
14375 & or.(lb(i1).eq.26.and.iabs(lb(i2)).eq.6))then
14376 if(iabs(lb(i1)).eq.6)then
14377 ii = i1
14378 lb(i1)=2
14379 e(i1)=amn
14380 lb(i2)=3
14381 e(i2)=ap1
14382 go to 40
14383 else
14384 ii = i2
14385 lb(i2)=2
14386 e(i2)=amn
14387 lb(i1)=3
14388 e(i1)=ap1
14389 go to 40
14390 ENDIF
14391 endif
14392*(5) for D(+)+rho(-)-->pi(0)+n or pi(-)+p
14393 if( ((lb(i1).eq.8.and.lb(i2).eq.25).
14394 & or.(lb(i1).eq.25.and.lb(i2).eq.8))
14395 & .OR. ((lb(i1).eq.-8.and.lb(i2).eq.27).
14396 & or.(lb(i1).eq.27.and.lb(i2).eq.-8)) )then
14397 if(iabs(lb(i1)).eq.8)then
14398 ii = i1
14399 IF(X2.LE.0.5)THEN
14400 lb(i1)=2
14401 e(i1)=amn
14402 lb(i2)=4
14403 e(i2)=ap1
14404 go to 40
14405 ELSE
14406 lb(i1)=1
14407 e(i1)=amn
14408 lb(i2)=3
14409 e(i2)=ap1
14410 go to 40
14411 endif
14412 else
14413 ii = i2
14414 IF(X2.LE.0.5)THEN
14415 lb(i2)=2
14416 e(i2)=amn
14417 lb(i1)=4
14418 e(i1)=ap1
14419 go to 40
14420 ELSE
14421 lb(i2)=1
14422 e(i2)=amn
14423 lb(i1)=3
14424 e(i1)=ap1
14425 go to 40
14426 endif
14427 endif
14428 ENDIF
14429*(6) D(0)+rho(+)-->n+pi(+) or p+pi(0)
14430 if( ((lb(i1).eq.7.and.lb(i2).eq.27).
14431 & or.(lb(i1).eq.27.and.lb(i2).eq.7))
14432 & .OR.((lb(i1).eq.-7.and.lb(i2).eq.25).
14433 & or.(lb(i1).eq.25.and.lb(i2).eq.-7)) )then
14434 if(iabs(lb(i1)).eq.7)then
14435 ii = i1
14436 IF(X2.LE.0.5)THEN
14437 lb(i1)=2
14438 e(i1)=amn
14439 lb(i2)=5
14440 e(i2)=ap1
14441 go to 40
14442 else
14443 lb(i1)=1
14444 e(i1)=amn
14445 lb(i2)=4
14446 e(i2)=ap1
14447 go to 40
14448 endif
14449 else
14450 ii = i2
14451 IF(X2.LE.0.5)THEN
14452 lb(i2)=2
14453 e(i2)=amn
14454 lb(i1)=5
14455 e(i1)=ap1
14456 go to 40
14457 Else
14458 lb(i2)=1
14459 e(i2)=amn
14460 lb(i1)=4
14461 e(i1)=ap1
14462 go to 40
14463 endif
14464 endif
14465 ENDIF
14466*(7) for D(0)+rho(-)-->n+pi(-)
14467 if( ((lb(i1).eq.7.and.lb(i2).eq.25).
14468 & or.(lb(i1).eq.25.and.lb(i2).eq.7))
14469 & .OR.((lb(i1).eq.-7.and.lb(i2).eq.27).
14470 & or.(lb(i1).eq.27.and.lb(i2).eq.-7)) )then
14471 if(iabs(lb(i1)).eq.7)then
14472 ii = i1
14473 lb(i1)=2
14474 e(i1)=amn
14475 lb(i2)=3
14476 e(i2)=ap1
14477 go to 40
14478 else
14479 ii = i2
14480 lb(i2)=2
14481 e(i2)=amn
14482 lb(i1)=3
14483 e(i1)=ap1
14484 go to 40
14485 ENDIF
14486 endif
14487*(8) D(-)+rho(+)-->n+pi(0) or p+pi(-)
14488 if( ((lb(i1).eq.6.and.lb(i2).eq.27).
14489 & or.(lb(i1).eq.27.and.lb(i2).eq.6))
14490 & .OR. ((lb(i1).eq.-6.and.lb(i2).eq.25).
14491 & or.(lb(i1).eq.25.and.lb(i2).eq.-6)) )then
14492 if(iabs(lb(i1)).eq.6)then
14493 ii = i1
14494 IF(X2.LE.0.5)THEN
14495 lb(i1)=2
14496 e(i1)=amn
14497 lb(i2)=4
14498 e(i2)=ap1
14499 go to 40
14500 else
14501 lb(i1)=1
14502 e(i1)=amn
14503 lb(i2)=3
14504 e(i2)=ap1
14505 go to 40
14506 endif
14507 else
14508 ii = i2
14509 IF(X2.LE.0.5)THEN
14510 lb(i2)=2
14511 e(i2)=amn
14512 lb(i1)=4
14513 e(i1)=ap1
14514 go to 40
14515 Else
14516 lb(i2)=1
14517 e(i2)=amn
14518 lb(i1)=3
14519 e(i1)=ap1
14520 go to 40
14521 endif
14522 endif
14523 ENDIF
14524*(9) D(++)+rho(-)-->n+pi(+) or p+pi(0)
14525 if( ((lb(i1).eq.9.and.lb(i2).eq.25).
14526 & or.(lb(i1).eq.25.and.lb(i2).eq.9))
14527 & .OR.((lb(i1).eq.-9.and.lb(i2).eq.27).
14528 & or.(lb(i1).eq.27.and.lb(i2).eq.-9)) )then
14529 if(iabs(lb(i1)).eq.9)then
14530 ii = i1
14531 IF(X2.LE.0.5)THEN
14532 lb(i1)=2
14533 e(i1)=amn
14534 lb(i2)=5
14535 e(i2)=ap1
14536 go to 40
14537 else
14538 lb(i1)=1
14539 e(i1)=amn
14540 lb(i2)=4
14541 e(i2)=ap1
14542 go to 40
14543 endif
14544 else
14545 ii = i2
14546 IF(X2.LE.0.5)THEN
14547 lb(i2)=2
14548 e(i2)=amn
14549 lb(i1)=5
14550 e(i1)=ap1
14551 go to 40
14552 Else
14553 lb(i2)=1
14554 e(i2)=amn
14555 lb(i1)=4
14556 e(i1)=ap1
14557 go to 40
14558 endif
14559 endif
14560 ENDIF
14561*(10) for D(++)+rho(0)-->p+pi(+)
14562 if((iabs(lb(i1)).eq.9.and.lb(i2).eq.26).
14563 & or.(lb(i1).eq.26.and.iabs(lb(i2)).eq.9))then
14564 if(iabs(lb(i1)).eq.9)then
14565 ii = i1
14566 lb(i1)=1
14567 e(i1)=amn
14568 lb(i2)=5
14569 e(i2)=ap1
14570 go to 40
14571 else
14572 ii = i2
14573 lb(i2)=1
14574 e(i2)=amn
14575 lb(i1)=5
14576 e(i1)=ap1
14577 go to 40
14578 ENDIF
14579 endif
14580*(11) for N*(1440)(+)or N*(1535)(+)+rho(+)-->p+pion(+)
14581 if( ((lb(i1).eq.11.and.lb(i2).eq.27).
14582 & or.(lb(i1).eq.27.and.lb(i2).eq.11).
14583 & or.(lb(i1).eq.13.and.lb(i2).eq.27).
14584 & or.(lb(i1).eq.27.and.lb(i2).eq.13))
14585 & .OR. ((lb(i1).eq.-11.and.lb(i2).eq.25).
14586 & or.(lb(i1).eq.25.and.lb(i2).eq.-11).
14587 & or.(lb(i1).eq.-13.and.lb(i2).eq.25).
14588 & or.(lb(i1).eq.25.and.lb(i2).eq.-13)) )then
14589 if(iabs(lb(i1)).eq.11.or.iabs(lb(i1)).eq.13)then
14590 ii = i1
14591 lb(i1)=1
14592 e(i1)=amn
14593 lb(i2)=5
14594 e(i2)=ap1
14595 go to 40
14596 else
14597 ii = i2
14598 lb(i2)=1
14599 e(i2)=amn
14600 lb(i1)=5
14601 e(i1)=ap1
14602 go to 40
14603 endif
14604 endif
14605*(12) for N*(1440) or N*(1535)(0)+rho(0)-->n+pi(0) or p+pi(-)
14606 if((iabs(lb(i1)).eq.10.and.lb(i2).eq.26).
14607 & or.(lb(i1).eq.26.and.iabs(lb(i2)).eq.10).
14608 & or.(lb(i1).eq.26.and.iabs(lb(i2)).eq.12).
14609 & or.(lb(i2).eq.26.and.iabs(lb(i1)).eq.12))then
14610 if(iabs(lb(i1)).eq.10.or.iabs(lb(i1)).eq.12)then
14611 ii = i1
14612 IF(X2.LE.0.5)THEN
14613 lb(i1)=2
14614 e(i1)=amn
14615 lb(i2)=4
14616 e(i2)=ap1
14617 go to 40
14618 Else
14619 lb(i1)=1
14620 e(i1)=amn
14621 lb(i2)=3
14622 e(i2)=ap1
14623 go to 40
14624 endif
14625 else
14626 ii = i2
14627 IF(X2.LE.0.5)THEN
14628 lb(i2)=2
14629 e(i2)=amn
14630 lb(i1)=4
14631 e(i1)=ap1
14632 go to 40
14633 Else
14634 lb(i2)=1
14635 e(i2)=amn
14636 lb(i1)=3
14637 e(i1)=ap1
14638 go to 40
14639 endif
14640 endif
14641 endif
14642*(13) for N*(1440) or N*(1535)(+)+rho(0)-->pi(+)+n or pi(0)+p
14643 if((iabs(lb(i1)).eq.11.and.lb(i2).eq.26).
14644 & or.(lb(i1).eq.26.and.iabs(lb(i2)).eq.11).
14645 & or.(lb(i1).eq.26.and.iabs(lb(i2)).eq.13).
14646 & or.(lb(i2).eq.26.and.iabs(lb(i1)).eq.13))then
14647 if(iabs(lb(i1)).eq.11.or.iabs(lb(i1)).eq.13)then
14648 ii = i1
14649 IF(X2.LE.0.5)THEN
14650 lb(i1)=2
14651 e(i1)=amn
14652 lb(i2)=5
14653 e(i2)=ap1
14654 go to 40
14655 Else
14656 lb(i1)=1
14657 e(i1)=amn
14658 lb(i2)=4
14659 e(i2)=ap1
14660 go to 40
14661 endif
14662 else
14663 ii = i2
14664 IF(X2.LE.0.5)THEN
14665 lb(i2)=2
14666 e(i2)=amn
14667 lb(i1)=5
14668 e(i1)=ap1
14669 go to 40
14670 Else
14671 lb(i2)=1
14672 e(i2)=amn
14673 lb(i1)=4
14674 e(i1)=ap1
14675 go to 40
14676 endif
14677 endif
14678 endif
14679*(14) for N*(1440) or N*(1535)(+)+rho(-)-->pi(0)+n or pi(-)+p
14680 if( ((lb(i1).eq.11.and.lb(i2).eq.25).
14681 & or.(lb(i1).eq.25.and.lb(i2).eq.11).
14682 & or.(lb(i1).eq.25.and.lb(i2).eq.13).
14683 & or.(lb(i2).eq.25.and.lb(i1).eq.13))
14684 & .OR.((lb(i1).eq.-11.and.lb(i2).eq.27).
14685 & or.(lb(i1).eq.27.and.lb(i2).eq.-11).
14686 & or.(lb(i1).eq.27.and.lb(i2).eq.-13).
14687 & or.(lb(i2).eq.27.and.lb(i1).eq.-13)) )then
14688 if(iabs(lb(i1)).eq.11.or.iabs(lb(i1)).eq.13)then
14689 ii = i1
14690 IF(X2.LE.0.5)THEN
14691 lb(i1)=2
14692 e(i1)=amn
14693 lb(i2)=4
14694 e(i2)=ap1
14695 go to 40
14696 ELSE
14697 lb(i1)=1
14698 e(i1)=amn
14699 lb(i2)=3
14700 e(i2)=ap1
14701 go to 40
14702 endif
14703 else
14704 ii = i2
14705 IF(X2.LE.0.5)THEN
14706 lb(i2)=2
14707 e(i2)=amn
14708 lb(i1)=4
14709 e(i1)=ap1
14710 go to 40
14711 ELSE
14712 lb(i2)=1
14713 e(i2)=amn
14714 lb(i1)=3
14715 e(i1)=ap1
14716 go to 40
14717 endif
14718 endif
14719 ENDIF
14720*(15) N*(1440) or N*(1535)(0)+rho(+)-->n+pi(+) or p+pi(0)
14721 if( ((lb(i1).eq.10.and.lb(i2).eq.27).
14722 & or.(lb(i1).eq.27.and.lb(i2).eq.10).
14723 & or.(lb(i1).eq.12.and.lb(i2).eq.27).
14724 & or.(lb(i1).eq.27.and.lb(i2).eq.12))
14725 & .OR.((lb(i1).eq.-10.and.lb(i2).eq.25).
14726 & or.(lb(i1).eq.25.and.lb(i2).eq.-10).
14727 & or.(lb(i1).eq.-12.and.lb(i2).eq.25).
14728 & or.(lb(i1).eq.25.and.lb(i2).eq.-12)) )then
14729 if(iabs(lb(i1)).eq.10.or.iabs(lb(i1)).eq.12)then
14730 ii = i1
14731 IF(X2.LE.0.5)THEN
14732 lb(i1)=2
14733 e(i1)=amn
14734 lb(i2)=5
14735 e(i2)=ap1
14736 go to 40
14737 else
14738 lb(i1)=1
14739 e(i1)=amn
14740 lb(i2)=4
14741 e(i2)=ap1
14742 go to 40
14743 endif
14744 else
14745 ii = i2
14746 IF(X2.LE.0.5)THEN
14747 lb(i2)=2
14748 e(i2)=amn
14749 lb(i1)=5
14750 e(i1)=ap1
14751 go to 40
14752 Else
14753 lb(i2)=1
14754 e(i2)=amn
14755 lb(i1)=4
14756 e(i1)=ap1
14757 go to 40
14758 endif
14759 endif
14760 ENDIF
14761*(16) for N*(1440) or N*(1535) (0)+rho(-)-->n+pi(-)
14762 if( ((lb(i1).eq.10.and.lb(i2).eq.25).
14763 & or.(lb(i1).eq.25.and.lb(i2).eq.10).
14764 & or.(lb(i1).eq.25.and.lb(i2).eq.12).
14765 & or.(lb(i1).eq.12.and.lb(i2).eq.25))
14766 & .OR. ((lb(i1).eq.-10.and.lb(i2).eq.27).
14767 & or.(lb(i1).eq.27.and.lb(i2).eq.-10).
14768 & or.(lb(i1).eq.27.and.lb(i2).eq.-12).
14769 & or.(lb(i1).eq.-12.and.lb(i2).eq.27)) )then
14770 if(iabs(lb(i1)).eq.10.or.iabs(lb(i1)).eq.12)then
14771 ii = i1
14772 lb(i1)=2
14773 e(i1)=amn
14774 lb(i2)=3
14775 e(i2)=ap1
14776 go to 40
14777 else
14778 ii = i2
14779 lb(i2)=2
14780 e(i2)=amn
14781 lb(i1)=3
14782 e(i1)=ap1
14783 go to 40
14784 ENDIF
14785 endif
1478660 IBLOCK=82
14787* FOR OMEGA REABSORPTION
14788* Relable particles, I1 is assigned to the Delta
14789* and I2 is assigned to the meson
14790* for the reverse of the following process
14791*(1) for D(0)+OMEGA(0)-->n+pi(0) or p+pi(-)
14792 if((iabs(lb(i1)).eq.7.and.lb(i2).eq.28).
14793 & or.(lb(i1).eq.28.and.iabs(lb(i2)).eq.7))then
14794 if(iabs(lb(i1)).eq.7)then
14795 ii = i1
14796 IF(X2.LE.0.5)THEN
14797 lb(i1)=2
14798 e(i1)=amn
14799 lb(i2)=4
14800 e(i2)=ap1
14801 go to 40
14802 Else
14803 lb(i1)=1
14804 e(i1)=amn
14805 lb(i2)=3
14806 e(i2)=ap1
14807 go to 40
14808 endif
14809 else
14810 ii = i2
14811 IF(X2.LE.0.5)THEN
14812 lb(i2)=2
14813 e(i2)=amn
14814 lb(i1)=4
14815 e(i1)=ap1
14816 go to 40
14817 Else
14818 lb(i2)=1
14819 e(i2)=amn
14820 lb(i1)=3
14821 e(i1)=ap1
14822 go to 40
14823 endif
14824 endif
14825 endif
14826*(2) for D(+)+OMEGA(0)-->pi(+)+n or pi(0)+p
14827 if((iabs(lb(i1)).eq.8.and.lb(i2).eq.28).
14828 & or.(lb(i1).eq.28.and.iabs(lb(i2)).eq.8))then
14829 if(iabs(lb(i1)).eq.8)then
14830 ii = i1
14831 IF(X2.LE.0.5)THEN
14832 lb(i1)=2
14833 e(i1)=amn
14834 lb(i2)=5
14835 e(i2)=ap1
14836 go to 40
14837 Else
14838 lb(i1)=1
14839 e(i1)=amn
14840 lb(i2)=4
14841 e(i2)=ap1
14842 go to 40
14843 endif
14844 else
14845 ii = i2
14846 IF(X2.LE.0.5)THEN
14847 lb(i2)=2
14848 e(i2)=amn
14849 lb(i1)=5
14850 e(i1)=ap1
14851 go to 40
14852 Else
14853 lb(i2)=1
14854 e(i2)=amn
14855 lb(i1)=4
14856 e(i1)=ap1
14857 go to 40
14858 endif
14859 endif
14860 endif
14861*(3) for D(-)+OMEGA(0)-->n+pi(-)
14862 if((iabs(lb(i1)).eq.6.and.lb(i2).eq.28).
14863 & or.(lb(i1).eq.28.and.iabs(lb(i2)).eq.6))then
14864 if(iabs(lb(i1)).eq.6)then
14865 ii = i1
14866 lb(i1)=2
14867 e(i1)=amn
14868 lb(i2)=3
14869 e(i2)=ap1
14870 go to 40
14871 else
14872 ii = i2
14873 lb(i2)=2
14874 e(i2)=amn
14875 lb(i1)=3
14876 e(i1)=ap1
14877 go to 40
14878 ENDIF
14879 endif
14880*(4) for D(++)+OMEGA(0)-->p+pi(+)
14881 if((iabs(lb(i1)).eq.9.and.lb(i2).eq.28).
14882 & or.(lb(i1).eq.28.and.iabs(lb(i2)).eq.9))then
14883 if(iabs(lb(i1)).eq.9)then
14884 ii = i1
14885 lb(i1)=1
14886 e(i1)=amn
14887 lb(i2)=5
14888 e(i2)=ap1
14889 go to 40
14890 else
14891 ii = i2
14892 lb(i2)=1
14893 e(i2)=amn
14894 lb(i1)=5
14895 e(i1)=ap1
14896 go to 40
14897 ENDIF
14898 endif
14899*(5) for N*(1440) or N*(1535)(0)+omega(0)-->n+pi(0) or p+pi(-)
14900 if((iabs(lb(i1)).eq.10.and.lb(i2).eq.28).
14901 & or.(lb(i1).eq.28.and.iabs(lb(i2)).eq.10).
14902 & or.(lb(i1).eq.28.and.iabs(lb(i2)).eq.12).
14903 & or.(lb(i2).eq.28.and.iabs(lb(i1)).eq.12))then
14904 if(iabs(lb(i1)).eq.10.or.iabs(lb(i1)).eq.12)then
14905 ii = i1
14906 IF(X2.LE.0.5)THEN
14907 lb(i1)=2
14908 e(i1)=amn
14909 lb(i2)=4
14910 e(i2)=ap1
14911 go to 40
14912 Else
14913 lb(i1)=1
14914 e(i1)=amn
14915 lb(i2)=3
14916 e(i2)=ap1
14917 go to 40
14918 endif
14919 else
14920 ii = i2
14921 IF(X2.LE.0.5)THEN
14922 lb(i2)=2
14923 e(i2)=amn
14924 lb(i1)=4
14925 e(i1)=ap1
14926 go to 40
14927 Else
14928 lb(i2)=1
14929 e(i2)=amn
14930 lb(i1)=3
14931 e(i1)=ap1
14932 go to 40
14933 endif
14934 endif
14935 endif
14936*(6) for N*(1440) or N*(1535)(+)+omega(0)-->pi(+)+n or pi(0)+p
14937 if((iabs(lb(i1)).eq.11.and.lb(i2).eq.28).
14938 & or.(lb(i1).eq.28.and.iabs(lb(i2)).eq.11).
14939 & or.(lb(i1).eq.28.and.iabs(lb(i2)).eq.13).
14940 & or.(lb(i2).eq.28.and.iabs(lb(i1)).eq.13))then
14941 if(iabs(lb(i1)).eq.11.or.iabs(lb(i1)).eq.13)then
14942 ii = i1
14943 IF(X2.LE.0.5)THEN
14944 lb(i1)=2
14945 e(i1)=amn
14946 lb(i2)=5
14947 e(i2)=ap1
14948 go to 40
14949 Else
14950 lb(i1)=1
14951 e(i1)=amn
14952 lb(i2)=4
14953 e(i2)=ap1
14954 go to 40
14955 endif
14956 else
14957 ii = i2
14958 IF(X2.LE.0.5)THEN
14959 lb(i2)=2
14960 e(i2)=amn
14961 lb(i1)=5
14962 e(i1)=ap1
14963 go to 40
14964 Else
14965 lb(i2)=1
14966 e(i2)=amn
14967 lb(i1)=4
14968 e(i1)=ap1
14969 go to 40
14970 endif
14971 endif
14972 endif
1497340 em1=e(i1)
14974 em2=e(i2)
14975 if(ianti.eq.1 .and. lb(i1).ge.1 .and. lb(i2).ge.1)then
14976 lb(ii) = -lb(ii)
14977 jj = i2
14978 if(ii .eq. i2)jj = i1
14979 if(lb(jj).eq.3)then
14980 lb(jj) = 5
14981 elseif(lb(jj).eq.5)then
14982 lb(jj) = 3
14983 endif
14984 endif
14985 endif
14986*-----------------------------------------------------------------------
14987* CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
14988* ENERGY CONSERVATION
1498950 PR2 = (SRT**2 - EM1**2 - EM2**2)**2
14990 1 - 4.0 * (EM1*EM2)**2
14991 IF(PR2.LE.0.)PR2=1.E-09
14992 PR=SQRT(PR2)/(2.*SRT)
14993* C1 = 1.0 - 2.0 * RANART(NSEED)
14994
14995clin-10/25/02 get rid of argument usage mismatch in PTR():
14996 xptr=0.33*pr
14997c cc1=ptr(0.33*pr,iseed)
14998 cc1=ptr(xptr,iseed)
14999clin-10/25/02-end
15000
15001 c1=sqrt(pr**2-cc1**2)/pr
15002 T1 = 2.0 * PI * RANART(NSEED)
15003 S1 = SQRT( 1.0 - C1**2 )
15004 CT1 = COS(T1)
15005 ST1 = SIN(T1)
15006 PZ = PR * C1
15007 PX = PR * S1*CT1
15008 PY = PR * S1*ST1
15009* ROTATE THE MOMENTUM
15010 CALL ROTATE(PX0,PY0,PZ0,PX,PY,PZ)
15011 RETURN
15012 END
15013**********************************
15014* sp 03/19/01 *
15015* *
15016 SUBROUTINE Crlaba(PX,PY,PZ,SRT,brel,brsgm,
15017 & I1,I2,nt,IBLOCK,nchrg,icase)
15018* PURPOSE: *
15019* DEALING WITH K+ + N(D,N*)-bar <--> La(Si)-bar + pi *
15020* NOTE : *
15021* *
15022* QUANTITIES: *
15023* PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
15024* SRT - SQRT OF S *
15025* IBLOCK - THE INFORMATION BACK *
15026* 8-> elastic scatt *
15027* 100-> K+ + N-bar -> Sigma-bar + PI
15028* 102-> PI + Sigma(Lambda)-bar -> K+ + N-bar
15029**********************************
15030 PARAMETER (MAXSTR=150001, MAXR=1, AMN=0.939457,
15031 1 AMP=0.93828,AP1=0.13496,
15032 2 AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
15033 PARAMETER (AKA=0.498,ALA=1.1157,ASA=1.1974)
15034 PARAMETER (ETAM=0.5475, AOMEGA=0.782, ARHO=0.77)
15035 COMMON /AA/ R(3,MAXSTR)
15036cc SAVE /AA/
15037 COMMON /BB/ P(3,MAXSTR)
15038cc SAVE /BB/
15039 COMMON /CC/ E(MAXSTR)
15040cc SAVE /CC/
15041 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
15042cc SAVE /EE/
15043 common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
15044cc SAVE /input1/
15045 COMMON/RNDF77/NSEED
15046cc SAVE /RNDF77/
15047 SAVE
15048 NT=NT
15049c
15050 PX0=PX
15051 PY0=PY
15052 PZ0=PZ
15053c
15054 if(icase .eq. 3)then
15055 rrr=RANART(NSEED)
15056 if(rrr.lt.brel) then
15057c !! elastic scat. (avoid in reverse process)
15058 IBLOCK=8
15059 else
15060 IBLOCK=100
15061 if(rrr.lt.(brel+brsgm)) then
15062c* K+ + N-bar -> Sigma-bar + PI
15063 LB(i1) = -15 - int(3 * RANART(NSEED))
15064
15065 e(i1)=asa
15066 else
15067c* K+ + N-bar -> Lambda-bar + PI
15068 LB(i1)= -14
15069 e(i1)=ala
15070 endif
15071 LB(i2) = 3 + int(3 * RANART(NSEED))
15072 e(i2)=0.138
15073 endif
15074 endif
15075c
15076c
15077 if(icase .eq. 4)then
15078 rrr=RANART(NSEED)
15079 if(rrr.lt.brel) then
15080c !! elastic scat.
15081 IBLOCK=8
15082 else
15083 IBLOCK=102
15084c PI + Sigma(Lambda)-bar -> K+ + N-bar
15085c ! K+
15086 LB(i1) = 23
15087 LB(i2) = -1 - int(2 * RANART(NSEED))
15088 if(nchrg.eq.-2) LB(i2) = -6
15089 if(nchrg.eq. 1) LB(i2) = -9
15090 e(i1) = aka
15091 e(i2) = 0.938
15092 if(nchrg.eq.-2.or.nchrg.eq.1) e(i2)=1.232
15093 endif
15094 endif
15095c
15096 EM1=E(I1)
15097 EM2=E(I2)
15098* CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
15099* ENERGY CONSERVATION
15100 PR2 = (SRT**2 - EM1**2 - EM2**2)**2
15101 1 - 4.0 * (EM1*EM2)**2
15102 IF(PR2.LE.0.)PR2=1.e-09
15103 PR=SQRT(PR2)/(2.*SRT)
15104 C1 = 1.0 - 2.0 * RANART(NSEED)
15105 T1 = 2.0 * PI * RANART(NSEED)
15106 S1 = SQRT( 1.0 - C1**2 )
15107 CT1 = COS(T1)
15108 ST1 = SIN(T1)
15109 PZ = PR * C1
15110 PX = PR * S1*CT1
15111 PY = PR * S1*ST1
15112* ROTATE IT
15113 CALL ROTATE(PX0,PY0,PZ0,PX,PY,PZ)
15114 RETURN
15115 END
15116**********************************
15117* *
15118* *
15119 SUBROUTINE Crkn(PX,PY,PZ,SRT,I1,I2,IBLOCK)
15120* PURPOSE: *
15121* DEALING WITH kaON+N/pi-->KAON +N/pi elastic PROCESS *
15122* NOTE : *
15123*
15124* QUANTITIES: *
15125* PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
15126* SRT - SQRT OF S *
15127* IBLOCK - THE INFORMATION BACK *
15128* 8-> PION+N-->L/S+KAON
15129**********************************
15130 PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
15131 1 AMP=0.93828,AP1=0.13496,
15132 2 AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
15133 PARAMETER (AKA=0.498,ALA=1.1157,ASA=1.1974)
15134 parameter (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
15135 COMMON /AA/ R(3,MAXSTR)
15136cc SAVE /AA/
15137 COMMON /BB/ P(3,MAXSTR)
15138cc SAVE /BB/
15139 COMMON /CC/ E(MAXSTR)
15140cc SAVE /CC/
15141 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
15142cc SAVE /EE/
15143 common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
15144cc SAVE /input1/
15145 COMMON/RNDF77/NSEED
15146cc SAVE /RNDF77/
15147 SAVE
15148
15149 PX0=PX
15150 PY0=PY
15151 PZ0=PZ
15152*-----------------------------------------------------------------------
15153 IBLOCK=8
15154 NTAG=0
15155 EM1=E(I1)
15156 EM2=E(I2)
15157*-----------------------------------------------------------------------
15158* CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
15159* ENERGY CONSERVATION
15160 PR2 = (SRT**2 - EM1**2 - EM2**2)**2
15161 1 - 4.0 * (EM1*EM2)**2
15162 IF(PR2.LE.0.)PR2=1.e-09
15163 PR=SQRT(PR2)/(2.*SRT)
15164 C1 = 1.0 - 2.0 * RANART(NSEED)
15165 T1 = 2.0 * PI * RANART(NSEED)
15166 S1 = SQRT( 1.0 - C1**2 )
15167 CT1 = COS(T1)
15168 ST1 = SIN(T1)
15169 PZ = PR * C1
15170 PX = PR * S1*CT1
15171 PY = PR * S1*ST1
15172 RETURN
15173 END
15174**********************************
15175* *
15176* *
15177 SUBROUTINE Crppba(PX,PY,PZ,SRT,I1,I2,IBLOCK)
15178* PURPOSE: *
15179
15180clin-8/29/00* DEALING WITH anti-nucleon annihilation with
15181* DEALING WITH anti-baryon annihilation with
15182
15183* nucleons or baryon resonances
15184* Determine: *
15185* (1) no. of pions in the final state
15186* (2) relable particles in the final state
15187* (3) new momenta of final state particles *
15188*
15189* QUANTITIES: *
15190* PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
15191* SRT - SQRT OF S *
15192* IBLOCK - INFORMATION about the reaction channel *
15193*
15194* iblock - 1902 annihilation-->pion(+)+pion(-) (2 pion)
15195* iblock - 1903 annihilation-->pion(+)+rho(-) (3 pion)
15196* iblock - 1904 annihilation-->rho(+)+rho(-) (4 pion)
15197* iblock - 1905 annihilation-->rho(0)+omega (5 pion)
15198* iblock - 1906 annihilation-->omega+omega (6 pion)
15199* charge conservation is enforced in relabling particles
15200* in the final state (note: at the momentum we don't check the
15201* initial charges while dealing with annihilation, since some
15202* annihilation channels between antinucleons and nucleons (baryon
15203* resonances) might be forbiden by charge conservation, this effect
15204* should be small, but keep it in mind.
15205**********************************
15206 PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
15207 1 AMP=0.93828,AP1=0.13496,AMRHO=0.769,AMOMGA=0.782,
15208 2 AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
15209 PARAMETER (AKA=0.498,ALA=1.1157,ASA=1.1974)
15210 parameter (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
15211 COMMON /AA/ R(3,MAXSTR)
15212cc SAVE /AA/
15213 COMMON /BB/ P(3,MAXSTR)
15214cc SAVE /BB/
15215 COMMON /CC/ E(MAXSTR)
15216cc SAVE /CC/
15217 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
15218cc SAVE /EE/
15219 common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
15220cc SAVE /input1/
15221 COMMON/RNDF77/NSEED
15222cc SAVE /RNDF77/
15223 SAVE
15224
15225 PX0=PX
15226 PY0=PY
15227 PZ0=PZ
15228* determine the no. of pions in the final state using a
15229* statistical model
15230 call pbarfs(srt,npion,iseed)
15231* find the masses of the final state particles before calculate
15232* their momenta, and relable them. The masses of rho and omega
15233* will be generated according to the Breit Wigner formula (NOTE!!!
15234* NOT DONE YET, AT THE MOMENT LET US USE FIXED RHO AND OMEGA MAEES)
15235cbali2/22/99
15236* Here we generate two stes of integer random numbers (3,4,5)
15237* one or both of them are used directly as the lables of pions
15238* similarly, 22+nchrg1 and 22+nchrg2 are used directly
15239* to label rhos
15240 nchrg1=3+int(3*RANART(NSEED))
15241 nchrg2=3+int(3*RANART(NSEED))
15242* the corresponding masses of pions
15243 pmass1=ap1
15244 pmass2=ap1
15245 if(nchrg1.eq.3.or.nchrg1.eq.5)pmass1=ap2
15246 if(nchrg2.eq.3.or.nchrg2.eq.5)pmass2=ap2
15247* (1) for 2 pion production
15248 IF(NPION.EQ.2)THEN
15249 IBLOCK=1902
15250* randomly generate the charges of final state particles,
15251 LB(I1)=nchrg1
15252 E(I1)=pmass1
15253 LB(I2)=nchrg2
15254 E(I2)=pmass2
15255* TO CALCULATE THE FINAL MOMENTA
15256 GO TO 50
15257 ENDIF
15258* (2) FOR 3 PION PRODUCTION
15259 IF(NPION.EQ.3)THEN
15260 IBLOCK=1903
15261 LB(I1)=nchrg1
15262 E(I1)=pmass1
15263 LB(I2)=22+nchrg2
15264 E(I2)=AMRHO
15265 GO TO 50
15266 ENDIF
15267* (3) FOR 4 PION PRODUCTION
15268* we allow both rho+rho and pi+omega with 50-50% probability
15269 IF(NPION.EQ.4)THEN
15270 IBLOCK=1904
15271* determine rho+rho or pi+omega
15272 if(RANART(NSEED).ge.0.5)then
15273* rho+rho
15274 LB(I1)=22+nchrg1
15275 E(I1)=AMRHO
15276 LB(I2)=22+nchrg2
15277 E(I2)=AMRHO
15278 else
15279* pion+omega
15280 LB(I1)=nchrg1
15281 E(I1)=pmass1
15282 LB(I2)=28
15283 E(I2)=AMOMGA
15284 endif
15285 GO TO 50
15286 ENDIF
15287* (4) FOR 5 PION PRODUCTION
15288 IF(NPION.EQ.5)THEN
15289 IBLOCK=1905
15290* RHO AND OMEGA
15291 LB(I1)=22+nchrg1
15292 E(I1)=AMRHO
15293 LB(I2)=28
15294 E(I2)=AMOMGA
15295 GO TO 50
15296 ENDIF
15297* (5) FOR 6 PION PRODUCTION
15298 IF(NPION.EQ.6)THEN
15299 IBLOCK=1906
15300* OMEGA AND OMEGA
15301 LB(I1)=28
15302 E(I1)=AMOMGA
15303 LB(I2)=28
15304 E(I2)=AMOMGA
15305 ENDIF
15306cbali2/22/99
1530750 EM1=E(I1)
15308 EM2=E(I2)
15309*-----------------------------------------------------------------------
15310* CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
15311* ENERGY CONSERVATION
15312 PR2 = (SRT**2 - EM1**2 - EM2**2)**2
15313 1 - 4.0 * (EM1*EM2)**2
15314 IF(PR2.LE.0.)PR2=1.E-08
15315 PR=SQRT(PR2)/(2.*SRT)
15316* WE ASSUME AN ISOTROPIC ANGULAR DISTRIBUTION IN THE CMS
15317 C1 = 1.0 - 2.0 * RANART(NSEED)
15318 T1 = 2.0 * PI * RANART(NSEED)
15319 S1 = SQRT( 1.0 - C1**2 )
15320 CT1 = COS(T1)
15321 ST1 = SIN(T1)
15322* THE MOMENTUM IN THE CMS IN THE FINAL STATE
15323 PZ = PR * C1
15324 PX = PR * S1*CT1
15325 PY = PR * S1*ST1
15326* ROTATE IT
15327 CALL ROTATE(PX0,PY0,PZ0,PX,PY,PZ)
15328 RETURN
15329 END
15330cbali2/7/99end
15331cbali3/5/99
15332**********************************
15333* PURPOSE: *
15334* assign final states for K+K- --> light mesons
15335*
15336 SUBROUTINE crkkpi(I1,I2,XSK1, XSK2, XSK3, XSK4,
15337 & XSK5, XSK6, XSK7, XSK8, XSK9, XSK10, XSK11, SIGK,
15338 & IBLOCK,lbp1,lbp2,emm1,emm2)
15339*
15340* QUANTITIES: *
15341* IBLOCK - INFORMATION about the reaction channel *
15342*
15343* iblock - 1907
15344**********************************
15345 PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
15346 1 AMP=0.93828,AP1=0.13496,AMRHO=0.769,AMOMGA=0.782,
15347 & AMETA = 0.5473,
15348 2 AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
15349 PARAMETER (AKA=0.498,ALA=1.1157,ASA=1.1974)
15350 parameter (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
15351 COMMON /AA/ R(3,MAXSTR)
15352cc SAVE /AA/
15353 COMMON /BB/ P(3,MAXSTR)
15354cc SAVE /BB/
15355 COMMON /CC/ E(MAXSTR)
15356cc SAVE /CC/
15357 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
15358cc SAVE /EE/
15359 common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
15360cc SAVE /input1/
15361 COMMON/RNDF77/NSEED
15362cc SAVE /RNDF77/
15363 SAVE
15364
15365 XSK11=XSK11
15366 IBLOCK=1907
15367 X1 = RANART(NSEED) * SIGK
15368 XSK2 = XSK1 + XSK2
15369 XSK3 = XSK2 + XSK3
15370 XSK4 = XSK3 + XSK4
15371 XSK5 = XSK4 + XSK5
15372 XSK6 = XSK5 + XSK6
15373 XSK7 = XSK6 + XSK7
15374 XSK8 = XSK7 + XSK8
15375 XSK9 = XSK8 + XSK9
15376 XSK10 = XSK9 + XSK10
15377 IF (X1 .LE. XSK1) THEN
15378 LB(I1) = 3 + int(3 * RANART(NSEED))
15379 LB(I2) = 3 + int(3 * RANART(NSEED))
15380 E(I1) = AP2
15381 E(I2) = AP2
15382 GOTO 100
15383 ELSE IF (X1 .LE. XSK2) THEN
15384 LB(I1) = 3 + int(3 * RANART(NSEED))
15385 LB(I2) = 25 + int(3 * RANART(NSEED))
15386 E(I1) = AP2
15387 E(I2) = AMRHO
15388 GOTO 100
15389 ELSE IF (X1 .LE. XSK3) THEN
15390 LB(I1) = 3 + int(3 * RANART(NSEED))
15391 LB(I2) = 28
15392 E(I1) = AP2
15393 E(I2) = AMOMGA
15394 GOTO 100
15395 ELSE IF (X1 .LE. XSK4) THEN
15396 LB(I1) = 3 + int(3 * RANART(NSEED))
15397 LB(I2) = 0
15398 E(I1) = AP2
15399 E(I2) = AMETA
15400 GOTO 100
15401 ELSE IF (X1 .LE. XSK5) THEN
15402 LB(I1) = 25 + int(3 * RANART(NSEED))
15403 LB(I2) = 25 + int(3 * RANART(NSEED))
15404 E(I1) = AMRHO
15405 E(I2) = AMRHO
15406 GOTO 100
15407 ELSE IF (X1 .LE. XSK6) THEN
15408 LB(I1) = 25 + int(3 * RANART(NSEED))
15409 LB(I2) = 28
15410 E(I1) = AMRHO
15411 E(I2) = AMOMGA
15412 GOTO 100
15413 ELSE IF (X1 .LE. XSK7) THEN
15414 LB(I1) = 25 + int(3 * RANART(NSEED))
15415 LB(I2) = 0
15416 E(I1) = AMRHO
15417 E(I2) = AMETA
15418 GOTO 100
15419 ELSE IF (X1 .LE. XSK8) THEN
15420 LB(I1) = 28
15421 LB(I2) = 28
15422 E(I1) = AMOMGA
15423 E(I2) = AMOMGA
15424 GOTO 100
15425 ELSE IF (X1 .LE. XSK9) THEN
15426 LB(I1) = 28
15427 LB(I2) = 0
15428 E(I1) = AMOMGA
15429 E(I2) = AMETA
15430 GOTO 100
15431 ELSE IF (X1 .LE. XSK10) THEN
15432 LB(I1) = 0
15433 LB(I2) = 0
15434 E(I1) = AMETA
15435 E(I2) = AMETA
15436 ELSE
15437 iblock = 222
15438 call rhores(i1,i2)
15439c !! phi
15440 lb(i1) = 29
15441c return
15442 e(i2)=0.
15443 END IF
15444
15445 100 CONTINUE
15446 lbp1=lb(i1)
15447 lbp2=lb(i2)
15448 emm1=e(i1)
15449 emm2=e(i2)
15450
15451 RETURN
15452 END
15453**********************************
15454* PURPOSE: *
15455* DEALING WITH K+Y -> piN scattering
15456*
15457 SUBROUTINE Crkhyp(PX,PY,PZ,SRT,I1,I2,
15458 & XKY1, XKY2, XKY3, XKY4, XKY5,
15459 & XKY6, XKY7, XKY8, XKY9, XKY10, XKY11, XKY12, XKY13,
15460 & XKY14, XKY15, XKY16, XKY17, SIGK, IKMP,
15461 & IBLOCK)
15462*
15463* Determine: *
15464* (1) relable particles in the final state *
15465* (2) new momenta of final state particles *
15466* *
15467* QUANTITIES: *
15468* PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
15469* SRT - SQRT OF S *
15470* IBLOCK - INFORMATION about the reaction channel *
15471* *
15472* iblock - 1908 *
15473* iblock - 222 !! phi *
15474**********************************
15475 PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
15476 1 AMP=0.93828,AP1=0.13496,AMRHO=0.769,AMOMGA=0.782,APHI=1.02,
15477 2 AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
15478 parameter (pimass=0.140, AMETA = 0.5473, aka=0.498,
15479 & aml=1.116,ams=1.193, AM1440 = 1.44, AM1535 = 1.535)
15480 parameter (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
15481 COMMON /AA/ R(3,MAXSTR)
15482cc SAVE /AA/
15483 COMMON /BB/ P(3,MAXSTR)
15484cc SAVE /BB/
15485 COMMON /CC/ E(MAXSTR)
15486cc SAVE /CC/
15487 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
15488cc SAVE /EE/
15489 common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
15490cc SAVE /input1/
15491 COMMON/RNDF77/NSEED
15492cc SAVE /RNDF77/
15493 SAVE
15494
15495 XKY17=XKY17
15496 PX0=PX
15497 PY0=PY
15498 PZ0=PZ
15499 IBLOCK=1908
15500c
15501 X1 = RANART(NSEED) * SIGK
15502 XKY2 = XKY1 + XKY2
15503 XKY3 = XKY2 + XKY3
15504 XKY4 = XKY3 + XKY4
15505 XKY5 = XKY4 + XKY5
15506 XKY6 = XKY5 + XKY6
15507 XKY7 = XKY6 + XKY7
15508 XKY8 = XKY7 + XKY8
15509 XKY9 = XKY8 + XKY9
15510 XKY10 = XKY9 + XKY10
15511 XKY11 = XKY10 + XKY11
15512 XKY12 = XKY11 + XKY12
15513 XKY13 = XKY12 + XKY13
15514 XKY14 = XKY13 + XKY14
15515 XKY15 = XKY14 + XKY15
15516 XKY16 = XKY15 + XKY16
15517 IF (X1 .LE. XKY1) THEN
15518 LB(I1) = 3 + int(3 * RANART(NSEED))
15519 LB(I2) = 1 + int(2 * RANART(NSEED))
15520 E(I1) = PIMASS
15521 E(I2) = AMP
15522 GOTO 100
15523 ELSE IF (X1 .LE. XKY2) THEN
15524 LB(I1) = 3 + int(3 * RANART(NSEED))
15525 LB(I2) = 6 + int(4 * RANART(NSEED))
15526 E(I1) = PIMASS
15527 E(I2) = AM0
15528 GOTO 100
15529 ELSE IF (X1 .LE. XKY3) THEN
15530 LB(I1) = 3 + int(3 * RANART(NSEED))
15531 LB(I2) = 10 + int(2 * RANART(NSEED))
15532 E(I1) = PIMASS
15533 E(I2) = AM1440
15534 GOTO 100
15535 ELSE IF (X1 .LE. XKY4) THEN
15536 LB(I1) = 3 + int(3 * RANART(NSEED))
15537 LB(I2) = 12 + int(2 * RANART(NSEED))
15538 E(I1) = PIMASS
15539 E(I2) = AM1535
15540 GOTO 100
15541 ELSE IF (X1 .LE. XKY5) THEN
15542 LB(I1) = 25 + int(3 * RANART(NSEED))
15543 LB(I2) = 1 + int(2 * RANART(NSEED))
15544 E(I1) = AMRHO
15545 E(I2) = AMP
15546 GOTO 100
15547 ELSE IF (X1 .LE. XKY6) THEN
15548 LB(I1) = 25 + int(3 * RANART(NSEED))
15549 LB(I2) = 6 + int(4 * RANART(NSEED))
15550 E(I1) = AMRHO
15551 E(I2) = AM0
15552 GOTO 100
15553 ELSE IF (X1 .LE. XKY7) THEN
15554 LB(I1) = 25 + int(3 * RANART(NSEED))
15555 LB(I2) = 10 + int(2 * RANART(NSEED))
15556 E(I1) = AMRHO
15557 E(I2) = AM1440
15558 GOTO 100
15559 ELSE IF (X1 .LE. XKY8) THEN
15560 LB(I1) = 25 + int(3 * RANART(NSEED))
15561 LB(I2) = 12 + int(2 * RANART(NSEED))
15562 E(I1) = AMRHO
15563 E(I2) = AM1535
15564 GOTO 100
15565 ELSE IF (X1 .LE. XKY9) THEN
15566 LB(I1) = 28
15567 LB(I2) = 1 + int(2 * RANART(NSEED))
15568 E(I1) = AMOMGA
15569 E(I2) = AMP
15570 GOTO 100
15571 ELSE IF (X1 .LE. XKY10) THEN
15572 LB(I1) = 28
15573 LB(I2) = 6 + int(4 * RANART(NSEED))
15574 E(I1) = AMOMGA
15575 E(I2) = AM0
15576 GOTO 100
15577 ELSE IF (X1 .LE. XKY11) THEN
15578 LB(I1) = 28
15579 LB(I2) = 10 + int(2 * RANART(NSEED))
15580 E(I1) = AMOMGA
15581 E(I2) = AM1440
15582 GOTO 100
15583 ELSE IF (X1 .LE. XKY12) THEN
15584 LB(I1) = 28
15585 LB(I2) = 12 + int(2 * RANART(NSEED))
15586 E(I1) = AMOMGA
15587 E(I2) = AM1535
15588 GOTO 100
15589 ELSE IF (X1 .LE. XKY13) THEN
15590 LB(I1) = 0
15591 LB(I2) = 1 + int(2 * RANART(NSEED))
15592 E(I1) = AMETA
15593 E(I2) = AMP
15594 GOTO 100
15595 ELSE IF (X1 .LE. XKY14) THEN
15596 LB(I1) = 0
15597 LB(I2) = 6 + int(4 * RANART(NSEED))
15598 E(I1) = AMETA
15599 E(I2) = AM0
15600 GOTO 100
15601 ELSE IF (X1 .LE. XKY15) THEN
15602 LB(I1) = 0
15603 LB(I2) = 10 + int(2 * RANART(NSEED))
15604 E(I1) = AMETA
15605 E(I2) = AM1440
15606 GOTO 100
15607 ELSE IF (X1 .LE. XKY16) THEN
15608 LB(I1) = 0
15609 LB(I2) = 12 + int(2 * RANART(NSEED))
15610 E(I1) = AMETA
15611 E(I2) = AM1535
15612 GOTO 100
15613 ELSE
15614 LB(I1) = 29
15615 LB(I2) = 1 + int(2 * RANART(NSEED))
15616 E(I1) = APHI
15617 E(I2) = AMN
15618 IBLOCK=222
15619 GOTO 100
15620 END IF
15621
15622 100 CONTINUE
15623 if(IKMP .eq. -1) LB(I2) = -LB(I2)
15624
15625 EM1=E(I1)
15626 EM2=E(I2)
15627*-----------------------------------------------------------------------
15628* CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
15629* ENERGY CONSERVATION
15630 PR2 = (SRT**2 - EM1**2 - EM2**2)**2
15631 1 - 4.0 * (EM1*EM2)**2
15632 IF(PR2.LE.0.)PR2=1.E-08
15633 PR=SQRT(PR2)/(2.*SRT)
15634* WE ASSUME AN ISOTROPIC ANGULAR DISTRIBUTION IN THE CMS
15635 C1 = 1.0 - 2.0 * RANART(NSEED)
15636 T1 = 2.0 * PI * RANART(NSEED)
15637 S1 = SQRT( 1.0 - C1**2 )
15638 CT1 = COS(T1)
15639 ST1 = SIN(T1)
15640* THE MOMENTUM IN THE CMS IN THE FINAL STATE
15641 PZ = PR * C1
15642 PX = PR * S1*CT1
15643 PY = PR * S1*ST1
15644* ROTATE IT
15645 CALL ROTATE(PX0,PY0,PZ0,PX,PY,PZ)
15646 RETURN
15647 END
15648**********************************
15649* *
15650* *
15651 SUBROUTINE CRLAN(PX,PY,PZ,SRT,I1,I2,IBLOCK)
15652* PURPOSE: *
15653* DEALING WITH La/Si-bar + N --> K+ + pi PROCESS *
15654* La/Si + N-bar --> K- + pi *
15655* NOTE : *
15656*
15657* QUANTITIES: *
15658* PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
15659* SRT - SQRT OF S *
15660* IBLOCK - THE INFORMATION BACK *
15661* 71
15662**********************************
15663 PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
15664 1 AMP=0.93828,AP1=0.13496,
15665 2 AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
15666 PARAMETER (AKA=0.498,ALA=1.1157,ASA=1.1974)
15667 parameter (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
15668 COMMON /AA/ R(3,MAXSTR)
15669cc SAVE /AA/
15670 COMMON /BB/ P(3,MAXSTR)
15671cc SAVE /BB/
15672 COMMON /CC/ E(MAXSTR)
15673cc SAVE /CC/
15674 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
15675cc SAVE /EE/
15676 common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
15677cc SAVE /input1/
15678 COMMON/RNDF77/NSEED
15679cc SAVE /RNDF77/
15680 SAVE
15681
15682 PX0=PX
15683 PY0=PY
15684 PZ0=PZ
15685 IBLOCK=71
15686 NTAG=0
15687 if( (lb(i1).ge.14.and.lb(i1).le.17) .OR.
15688 & (lb(i2).ge.14.and.lb(i2).le.17) )then
15689 LB(I1)=21
15690 else
15691 LB(I1)=23
15692 endif
15693 LB(I2)= 3 + int(3 * RANART(NSEED))
15694 E(I1)=AKA
15695 E(I2)=0.138
15696 EM1=E(I1)
15697 EM2=E(I2)
15698*-----------------------------------------------------------------------
15699* CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
15700* ENERGY CONSERVATION
15701 PR2 = (SRT**2 - EM1**2 - EM2**2)**2
15702 1 - 4.0 * (EM1*EM2)**2
15703 IF(PR2.LE.0.)PR2=1.e-09
15704 PR=SQRT(PR2)/(2.*SRT)
15705 C1 = 1.0 - 2.0 * RANART(NSEED)
15706 T1 = 2.0 * PI * RANART(NSEED)
15707 S1 = SQRT( 1.0 - C1**2 )
15708 CT1 = COS(T1)
15709 ST1 = SIN(T1)
15710* THE MOMENTUM IN THE CMS IN THE FINAL STATE
15711 PZ = PR * C1
15712 PX = PR * S1*CT1
15713 PY = PR * S1*ST1
15714* FOR THE ISOTROPIC DISTRIBUTION THERE IS NO NEED TO ROTATE
15715 RETURN
15716 END
15717csp11/03/01 end
15718**********************************
15719**********************************
15720* *
15721* *
15722 SUBROUTINE Crkpla(PX,PY,PZ,EC,SRT,spika,
15723 & emm1,emm2,lbp1,lbp2,I1,I2,icase,srhoks)
15724
15725* PURPOSE: *
15726* DEALING WITH K+ + Pi ---> La/Si-bar + B, phi+K, phi+K* OR K* *
15727* K- + Pi ---> La/Si + B-bar OR K*-bar *
15728
15729* NOTE : *
15730*
15731* QUANTITIES: *
15732* PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
15733* SRT - SQRT OF S *
15734* IBLOCK - THE INFORMATION BACK *
15735* 71
15736**********************************
15737 PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
15738 1 AMP=0.93828,AP1=0.13496,AP2=0.13957,AMRHO=0.769,AMOMGA=0.782,
15739 2 AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
15740 PARAMETER (AKA=0.498,AKS=0.895,ALA=1.1157,ASA=1.1974
15741 1 ,APHI=1.02)
15742 PARAMETER (AM1440 = 1.44, AM1535 = 1.535)
15743 parameter (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
15744 COMMON /AA/ R(3,MAXSTR)
15745cc SAVE /AA/
15746 COMMON /BB/ P(3,MAXSTR)
15747cc SAVE /BB/
15748 COMMON /CC/ E(MAXSTR)
15749cc SAVE /CC/
15750 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
15751cc SAVE /EE/
15752 common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
15753cc SAVE /input1/
15754 COMMON/RNDF77/NSEED
15755cc SAVE /RNDF77/
15756 SAVE
15757
15758 emm1=0.
15759 emm2=0.
15760 lbp1=0
15761 lbp2=0
15762 XKP0 = spika
15763 XKP1 = 0.
15764 XKP2 = 0.
15765 XKP3 = 0.
15766 XKP4 = 0.
15767 XKP5 = 0.
15768 XKP6 = 0.
15769 XKP7 = 0.
15770 XKP8 = 0.
15771 XKP9 = 0.
15772 XKP10 = 0.
15773 sigm = 15.
15774c if(lb(i1).eq.21.or.lb(i2).eq.21)sigm=10.
15775 pdd = (srt**2-(aka+ap1)**2)*(srt**2-(aka-ap1)**2)
15776c
15777 if(srt .lt. (ala+amn))go to 70
15778 XKP1 = sigm*(4./3.)*(srt**2-(ala+amn)**2)*
15779 & (srt**2-(ala-amn)**2)/pdd
15780 if(srt .gt. (ala+am0))then
15781 XKP2 = sigm*(16./3.)*(srt**2-(ala+am0)**2)*
15782 & (srt**2-(ala-am0)**2)/pdd
15783 endif
15784 if(srt .gt. (ala+am1440))then
15785 XKP3 = sigm*(4./3.)*(srt**2-(ala+am1440)**2)*
15786 & (srt**2-(ala-am1440)**2)/pdd
15787 endif
15788 if(srt .gt. (ala+am1535))then
15789 XKP4 = sigm*(4./3.)*(srt**2-(ala+am1535)**2)*
15790 & (srt**2-(ala-am1535)**2)/pdd
15791 endif
15792c
15793 if(srt .gt. (asa+amn))then
15794 XKP5 = sigm*4.*(srt**2-(asa+amn)**2)*
15795 & (srt**2-(asa-amn)**2)/pdd
15796 endif
15797 if(srt .gt. (asa+am0))then
15798 XKP6 = sigm*16.*(srt**2-(asa+am0)**2)*
15799 & (srt**2-(asa-am0)**2)/pdd
15800 endif
15801 if(srt .gt. (asa+am1440))then
15802 XKP7 = sigm*4.*(srt**2-(asa+am1440)**2)*
15803 & (srt**2-(asa-am1440)**2)/pdd
15804 endif
15805 if(srt .gt. (asa+am1535))then
15806 XKP8 = sigm*4.*(srt**2-(asa+am1535)**2)*
15807 & (srt**2-(asa-am1535)**2)/pdd
15808 endif
1580970 continue
15810 sig1 = 195.639
15811 sig2 = 372.378
15812 if(srt .gt. aphi+aka)then
15813 pff = sqrt((srt**2-(aphi+aka)**2)*(srt**2-(aphi-aka)**2))
15814 XKP9 = sig1*pff/sqrt(pdd)*1./32./pi/srt**2
15815 if(srt .gt. aphi+aks)then
15816 pff = sqrt((srt**2-(aphi+aks)**2)*(srt**2-(aphi-aks)**2))
15817 XKP10 = sig2*pff/sqrt(pdd)*3./32./pi/srt**2
15818 endif
15819 endif
15820
15821clin-8/15/02 K pi -> K* (rho omega), from detailed balance,
15822c neglect rho and omega mass difference for now:
15823 sigpik=0.
15824 if(srt.gt.(amrho+aks)) then
15825 sigpik=srhoks*9.
15826 1 *(srt**2-(0.77-aks)**2)*(srt**2-(0.77+aks)**2)/4
15827 2 /srt**2/(px**2+py**2+pz**2)
15828 if(srt.gt.(amomga+aks)) sigpik=sigpik*12./9.
15829 endif
15830
15831c
15832 sigkp = XKP0 + XKP1 + XKP2 + XKP3 + XKP4
15833 & + XKP5 + XKP6 + XKP7 + XKP8 + XKP9 + XKP10 +sigpik
15834 icase = 0
15835 DSkn=SQRT(sigkp/PI/10.)
15836 dsknr=dskn+0.1
15837 CALL DISTCE(I1,I2,dsknr,DSkn,DT,EC,SRT,IC,
15838 1 PX,PY,PZ)
15839 IF(IC.EQ.-1)return
15840c
15841 randu = RANART(NSEED)*sigkp
15842 XKP1 = XKP0 + XKP1
15843 XKP2 = XKP1 + XKP2
15844 XKP3 = XKP2 + XKP3
15845 XKP4 = XKP3 + XKP4
15846 XKP5 = XKP4 + XKP5
15847 XKP6 = XKP5 + XKP6
15848 XKP7 = XKP6 + XKP7
15849 XKP8 = XKP7 + XKP8
15850 XKP9 = XKP8 + XKP9
15851
15852 XKP10 = XKP9 + XKP10
15853c
15854c !! K* formation
15855 if(randu .le. XKP0)then
15856 icase = 1
15857 return
15858 else
15859* La/Si-bar + B formation
15860 icase = 2
15861 if( randu .le. XKP1 )then
15862 lbp1 = -14
15863 lbp2 = 1 + int(2*RANART(NSEED))
15864 emm1 = ala
15865 emm2 = amn
15866 go to 60
15867 elseif( randu .le. XKP2 )then
15868 lbp1 = -14
15869 lbp2 = 6 + int(4*RANART(NSEED))
15870 emm1 = ala
15871 emm2 = am0
15872 go to 60
15873 elseif( randu .le. XKP3 )then
15874 lbp1 = -14
15875 lbp2 = 10 + int(2*RANART(NSEED))
15876 emm1 = ala
15877 emm2 = am1440
15878 go to 60
15879 elseif( randu .le. XKP4 )then
15880 lbp1 = -14
15881 lbp2 = 12 + int(2*RANART(NSEED))
15882 emm1 = ala
15883 emm2 = am1535
15884 go to 60
15885 elseif( randu .le. XKP5 )then
15886 lbp1 = -15 - int(3*RANART(NSEED))
15887 lbp2 = 1 + int(2*RANART(NSEED))
15888 emm1 = asa
15889 emm2 = amn
15890 go to 60
15891 elseif( randu .le. XKP6 )then
15892 lbp1 = -15 - int(3*RANART(NSEED))
15893 lbp2 = 6 + int(4*RANART(NSEED))
15894 emm1 = asa
15895 emm2 = am0
15896 go to 60
15897 elseif( randu .lt. XKP7 )then
15898 lbp1 = -15 - int(3*RANART(NSEED))
15899 lbp2 = 10 + int(2*RANART(NSEED))
15900 emm1 = asa
15901 emm2 = am1440
15902 go to 60
15903 elseif( randu .lt. XKP8 )then
15904 lbp1 = -15 - int(3*RANART(NSEED))
15905 lbp2 = 12 + int(2*RANART(NSEED))
15906 emm1 = asa
15907 emm2 = am1535
15908 go to 60
15909 elseif( randu .lt. XKP9 )then
15910c !! phi +K formation (iblock=224)
15911 icase = 3
15912 lbp1 = 29
15913 lbp2 = 23
15914 emm1 = aphi
15915 emm2 = aka
15916 if(lb(i1).eq.21.or.lb(i2).eq.21)then
15917c !! phi +K-bar formation (iblock=124)
15918 lbp2 = 21
15919 icase = -3
15920 endif
15921 go to 60
15922 elseif( randu .lt. XKP10 )then
15923c !! phi +K* formation (iblock=226)
15924 icase = 4
15925 lbp1 = 29
15926 lbp2 = 30
15927 emm1 = aphi
15928 emm2 = aks
15929 if(lb(i1).eq.21.or.lb(i2).eq.21)then
15930 lbp2 = -30
15931 icase = -4
15932 endif
15933 go to 60
15934
15935 else
15936c !! (rho,omega) +K* formation (iblock=88)
15937 icase=5
15938 lbp1=25+int(3*RANART(NSEED))
15939 lbp2=30
15940 emm1=amrho
15941 emm2=aks
15942 if(srt.gt.(amomga+aks).and.RANART(NSEED).lt.0.25) then
15943 lbp1=28
15944 emm1=amomga
15945 endif
15946 if(lb(i1).eq.21.or.lb(i2).eq.21)then
15947 lbp2=-30
15948 icase=-5
15949 endif
15950
15951 endif
15952 endif
15953c
1595460 if( icase.eq.2 .and. (lb(i1).eq.21.or.lb(i2).eq.21) )then
15955 lbp1 = -lbp1
15956 lbp2 = -lbp2
15957 endif
15958 PX0=PX
15959 PY0=PY
15960 PZ0=PZ
15961*-----------------------------------------------------------------------
15962* CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
15963* ENERGY CONSERVATION
15964 PR2 = (SRT**2 - EMM1**2 - EMM2**2)**2
15965 1 - 4.0 * (EMM1*EMM2)**2
15966 IF(PR2.LE.0.)PR2=1.e-09
15967 PR=SQRT(PR2)/(2.*SRT)
15968 C1 = 1.0 - 2.0 * RANART(NSEED)
15969 T1 = 2.0 * PI * RANART(NSEED)
15970 S1 = SQRT( 1.0 - C1**2 )
15971 CT1 = COS(T1)
15972 ST1 = SIN(T1)
15973* THE MOMENTUM IN THE CMS IN THE FINAL STATE
15974 PZ = PR * C1
15975 PX = PR * S1*CT1
15976 PY = PR * S1*ST1
15977* FOR THE ISOTROPIC DISTRIBUTION THERE IS NO NEED TO ROTATE
15978 RETURN
15979 END
15980**********************************
15981* *
15982* *
15983 SUBROUTINE Crkphi(PX,PY,PZ,EC,SRT,IBLOCK,
15984 & emm1,emm2,lbp1,lbp2,I1,I2,ikk,icase,rrkk,prkk)
15985
15986* PURPOSE: *
15987* DEALING WITH KKbar, KK*bar, KbarK*, K*K*bar --> Phi + pi(rho,omega)
15988* and KKbar --> (pi eta) (pi eta), (rho omega) (rho omega)
15989* and KK*bar or Kbar K* --> (pi eta) (rho omega)
15990*
15991* NOTE : *
15992*
15993* QUANTITIES: *
15994* PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
15995* SRT - SQRT OF S *
15996* IBLOCK - THE INFORMATION BACK *
15997* 222
15998**********************************
15999 PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
16000 1 AMP=0.93828,AP1=0.13496,AP2=0.13957,APHI=1.02,
16001 2 AM0=1.232,AMNS=1.52,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
16002 PARAMETER (AKA=0.498,ALA=1.1157,ASA=1.1974,ACAS=1.3213)
16003 PARAMETER (AKS=0.895,AOMEGA=0.7819, ARHO=0.77)
16004 parameter (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
16005 COMMON /AA/ R(3,MAXSTR)
16006cc SAVE /AA/
16007 COMMON /BB/ P(3,MAXSTR)
16008cc SAVE /BB/
16009 COMMON /CC/ E(MAXSTR)
16010cc SAVE /CC/
16011 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
16012cc SAVE /EE/
16013 common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
16014cc SAVE /input1/
16015 COMMON/RNDF77/NSEED
16016cc SAVE /RNDF77/
16017 SAVE
16018
16019 lb1 = lb(i1)
16020 lb2 = lb(i2)
16021 icase = 0
16022
16023c if(srt .lt. aphi+ap1)return
16024cc if(srt .lt. aphi+ap1) then
16025 if(srt .lt. (aphi+ap1)) then
16026 sig1 = 0.
16027 sig2 = 0.
16028 sig3 = 0.
16029 else
16030c
16031 if((lb1.eq.23.and.lb2.eq.21).or.(lb2.eq.23.and.lb1.eq.21))then
16032 dnr = 4.
16033 ikk = 2
16034 elseif((lb1.eq.21.and.lb2.eq.30).or.(lb2.eq.21.and.lb1.eq.30)
16035 & .or.(lb1.eq.23.and.lb2.eq.-30).or.(lb2.eq.23.and.lb1.eq.-30))then
16036 dnr = 12.
16037 ikk = 1
16038 else
16039 dnr = 36.
16040 ikk = 0
16041 endif
16042
16043 sig1 = 0.
16044 sig2 = 0.
16045 sig3 = 0.
16046 srri = E(i1)+E(i2)
16047 srr1 = aphi+ap1
16048 srr2 = aphi+aomega
16049 srr3 = aphi+arho
16050c
16051 pii = (srt**2-(e(i1)+e(i2))**2)*(srt**2-(e(i1)-e(i2))**2)
16052 srrt = srt - amax1(srri,srr1)
16053cc to avoid divergent/negative values at small srrt:
16054c if(srrt .lt. 0.3)then
16055 if(srrt .lt. 0.3 .and. srrt .gt. 0.01)then
16056 sig = 1.69/(srrt**0.141 - 0.407)
16057 else
16058 sig = 3.74 + 0.008*srrt**1.9
16059 endif
16060 sig1=sig*(9./dnr)*(srt**2-(aphi+ap1)**2)*
16061 & (srt**2-(aphi-ap1)**2)/pii
16062 if(srt .gt. aphi+aomega)then
16063 srrt = srt - amax1(srri,srr2)
16064cc if(srrt .lt. 0.3)then
16065 if(srrt .lt. 0.3 .and. srrt .gt. 0.01)then
16066 sig = 1.69/(srrt**0.141 - 0.407)
16067 else
16068 sig = 3.74 + 0.008*srrt**1.9
16069 endif
16070 sig2=sig*(9./dnr)*(srt**2-(aphi+aomega)**2)*
16071 & (srt**2-(aphi-aomega)**2)/pii
16072 endif
16073 if(srt .gt. aphi+arho)then
16074 srrt = srt - amax1(srri,srr3)
16075cc if(srrt .lt. 0.3)then
16076 if(srrt .lt. 0.3 .and. srrt .gt. 0.01)then
16077 sig = 1.69/(srrt**0.141 - 0.407)
16078 else
16079 sig = 3.74 + 0.008*srrt**1.9
16080 endif
16081 sig3=sig*(27./dnr)*(srt**2-(aphi+arho)**2)*
16082 & (srt**2-(aphi-arho)**2)/pii
16083 endif
16084c sig1 = amin1(20.,sig1)
16085c sig2 = amin1(20.,sig2)
16086c sig3 = amin1(20.,sig3)
16087 endif
16088
16089 rrkk0=rrkk
16090 prkk0=prkk
16091 SIGM=0.
16092 if((lb1.eq.23.and.lb2.eq.21).or.(lb2.eq.23.and.lb1.eq.21))then
16093 CALL XKKANN(SRT, XSK1, XSK2, XSK3, XSK4, XSK5,
16094 & XSK6, XSK7, XSK8, XSK9, XSK10, XSK11, SIGM, rrkk0)
16095 elseif((lb1.eq.21.and.lb2.eq.30).or.(lb2.eq.21.and.lb1.eq.30)
16096 & .or.(lb1.eq.23.and.lb2.eq.-30).or.(lb2.eq.23.and.lb1.eq.-30))then
16097 CALL XKKSAN(i1,i2,SRT,SIGKS1,SIGKS2,SIGKS3,SIGKS4,SIGM,prkk0)
16098 else
16099 endif
16100c
16101c sigks = sig1 + sig2 + sig3
16102 sigm0=sigm
16103 sigks = sig1 + sig2 + sig3 + SIGM
16104 DSkn=SQRT(sigks/PI/10.)
16105 dsknr=dskn+0.1
16106 CALL DISTCE(I1,I2,dsknr,DSkn,DT,EC,SRT,IC,
16107 1 PX,PY,PZ)
16108 IF(IC.EQ.-1)return
16109 icase = 1
16110 ranx = RANART(NSEED)
16111
16112 lbp1 = 29
16113 emm1 = aphi
16114 if(ranx .le. sig1/sigks)then
16115 lbp2 = 3 + int(3*RANART(NSEED))
16116 emm2 = ap1
16117 elseif(ranx .le. (sig1+sig2)/sigks)then
16118 lbp2 = 28
16119 emm2 = aomega
16120 elseif(ranx .le. (sig1+sig2+sig3)/sigks)then
16121 lbp2 = 25 + int(3*RANART(NSEED))
16122 emm2 = arho
16123 else
16124 if((lb1.eq.23.and.lb2.eq.21)
16125 & .or.(lb2.eq.23.and.lb1.eq.21))then
16126 CALL crkkpi(I1,I2,XSK1, XSK2, XSK3, XSK4,
16127 & XSK5, XSK6, XSK7, XSK8, XSK9, XSK10, XSK11, SIGM0,
16128 & IBLOCK,lbp1,lbp2,emm1,emm2)
16129 elseif((lb1.eq.21.and.lb2.eq.30)
16130 & .or.(lb2.eq.21.and.lb1.eq.30)
16131 & .or.(lb1.eq.23.and.lb2.eq.-30)
16132 & .or.(lb2.eq.23.and.lb1.eq.-30))then
16133 CALL crkspi(I1,I2,SIGKS1, SIGKS2, SIGKS3, SIGKS4,
16134 & SIGM0,IBLOCK,lbp1,lbp2,emm1,emm2)
16135 else
16136 endif
16137 endif
16138*
16139 PX0=PX
16140 PY0=PY
16141 PZ0=PZ
16142*-----------------------------------------------------------------------
16143* CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
16144* ENERGY CONSERVATION
16145 PR2 = (SRT**2 - EMM1**2 - EMM2**2)**2
16146 1 - 4.0 * (EMM1*EMM2)**2
16147 IF(PR2.LE.0.)PR2=1.e-09
16148 PR=SQRT(PR2)/(2.*SRT)
16149 C1 = 1.0 - 2.0 * RANART(NSEED)
16150 T1 = 2.0 * PI * RANART(NSEED)
16151 S1 = SQRT( 1.0 - C1**2 )
16152 CT1 = COS(T1)
16153 ST1 = SIN(T1)
16154* THE MOMENTUM IN THE CMS IN THE FINAL STATE
16155 PZ = PR * C1
16156 PX = PR * S1*CT1
16157 PY = PR * S1*ST1
16158* FOR THE ISOTROPIC DISTRIBUTION THERE IS NO NEED TO ROTATE
16159 RETURN
16160 END
16161csp11/21/01 end
16162**********************************
16163* *
16164* *
16165 SUBROUTINE Crksph(PX,PY,PZ,EC,SRT,
16166 & emm1,emm2,lbp1,lbp2,I1,I2,ikkg,ikkl,iblock,
16167 & icase,srhoks)
16168
16169* PURPOSE: *
16170* DEALING WITH K + rho(omega) or K* + pi(rho,omega)
16171* --> Phi + K(K*), pi + K* or pi + K, and elastic
16172* NOTE : *
16173*
16174* QUANTITIES: *
16175* PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
16176* SRT - SQRT OF S *
16177* IBLOCK - THE INFORMATION BACK *
16178* 222
16179* 223 --> phi + pi(rho,omega)
16180* 224 --> phi + K <-> K + pi(rho,omega)
16181* 225 --> phi + K <-> K* + pi(rho,omega)
16182* 226 --> phi + K* <-> K + pi(rho,omega)
16183* 227 --> phi + K* <-> K* + pi(rho,omega)
16184**********************************
16185 PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
16186 1 AMP=0.93828,AP1=0.13496,AP2=0.13957,APHI=1.02,
16187 2 AM0=1.232,AMNS=1.52,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
16188 PARAMETER (AKA=0.498,ALA=1.1157,ASA=1.1974,ACAS=1.3213)
16189 PARAMETER (AKS=0.895,AOMEGA=0.7819, ARHO=0.77)
16190 parameter (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
16191 COMMON /AA/ R(3,MAXSTR)
16192cc SAVE /AA/
16193 COMMON /BB/ P(3,MAXSTR)
16194cc SAVE /BB/
16195 COMMON /CC/ E(MAXSTR)
16196cc SAVE /CC/
16197 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
16198cc SAVE /EE/
16199 common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
16200cc SAVE /input1/
16201 COMMON/RNDF77/NSEED
16202cc SAVE /RNDF77/
16203 SAVE
16204
16205 lb1 = lb(i1)
16206 lb2 = lb(i2)
16207 icase = 0
16208 sigela=10.
16209 sigkm=0.
16210c K(K*) + rho(omega) -> pi K*(K)
16211 if((lb1.ge.25.and.lb1.le.28).or.(lb2.ge.25.and.lb2.le.28)) then
16212 if(iabs(lb1).eq.30.or.iabs(lb2).eq.30) then
16213 sigkm=srhoks
16214clin-2/26/03 check whether (rho K) is above the (pi K*) thresh:
16215 elseif((lb1.eq.23.or.lb1.eq.21.or.lb2.eq.23.or.lb2.eq.21)
16216 1 .and.srt.gt.(ap2+aks)) then
16217 sigkm=srhoks
16218 endif
16219 endif
16220
16221c if(srt .lt. aphi+aka)return
16222 if(srt .lt. (aphi+aka)) then
16223 sig11=0.
16224 sig22=0.
16225 else
16226
16227c K*-bar +pi --> phi + (K,K*)-bar
16228 if( (iabs(lb1).eq.30.and.(lb2.ge.3.and.lb2.le.5)) .or.
16229 & (iabs(lb2).eq.30.and.(lb1.ge.3.and.lb1.le.5)) )then
16230 dnr = 18.
16231 ikkl = 0
16232 IBLOCK = 225
16233c sig1 = 15.0
16234c sig2 = 30.0
16235clin-2/06/03 these large values reduces to ~10 mb for sig11 or sig22
16236c due to the factors of ~1/(32*pi*s)~1/200:
16237 sig1 = 2047.042
16238 sig2 = 1496.692
16239c K(-bar)+rho --> phi + (K,K*)-bar
16240 elseif((lb1.eq.23.or.lb1.eq.21.and.(lb2.ge.25.and.lb2.le.27)).or.
16241 & (lb2.eq.23.or.lb2.eq.21.and.(lb1.ge.25.and.lb1.le.27)) )then
16242 dnr = 18.
16243 ikkl = 1
16244 IBLOCK = 224
16245c sig1 = 3.5
16246c sig2 = 9.0
16247 sig1 = 526.702
16248 sig2 = 1313.960
16249c K*(-bar) +rho
16250 elseif( (iabs(lb1).eq.30.and.(lb2.ge.25.and.lb2.le.27)) .or.
16251 & (iabs(lb2).eq.30.and.(lb1.ge.25.and.lb1.le.27)) )then
16252 dnr = 54.
16253 ikkl = 0
16254 IBLOCK = 225
16255c sig1 = 3.5
16256c sig2 = 9.0
16257 sig1 = 1371.257
16258 sig2 = 6999.840
16259c K(-bar) + omega
16260 elseif( ((lb1.eq.23.or.lb1.eq.21) .and. lb2.eq.28).or.
16261 & ((lb2.eq.23.or.lb2.eq.21) .and. lb1.eq.28) )then
16262 dnr = 6.
16263 ikkl = 1
16264 IBLOCK = 224
16265c sig1 = 3.5
16266c sig2 = 6.5
16267 sig1 = 355.429
16268 sig2 = 440.558
16269c K*(-bar) +omega
16270 else
16271 dnr = 18.
16272 ikkl = 0
16273 IBLOCK = 225
16274c sig1 = 3.5
16275c sig2 = 15.0
16276 sig1 = 482.292
16277 sig2 = 1698.903
16278 endif
16279
16280 sig11 = 0.
16281 sig22 = 0.
16282c sig11=sig1*(6./dnr)*(srt**2-(aphi+aka)**2)*
16283c & (srt**2-(aphi-aka)**2)/(srt**2-(e(i1)+e(i2))**2)/
16284c & (srt**2-(e(i1)-e(i2))**2)
16285 pii = sqrt((srt**2-(e(i1)+e(i2))**2)*(srt**2-(e(i1)-e(i2))**2))
16286 pff = sqrt((srt**2-(aphi+aka)**2)*(srt**2-(aphi-aka)**2))
16287 sig11 = sig1*pff/pii*6./dnr/32./pi/srt**2
16288c
16289 if(srt .gt. aphi+aks)then
16290c sig22=sig2*(18./dnr)*(srt**2-(aphi+aks)**2)*
16291c & (srt**2-(aphi-aks)**2)/(srt**2-(e(i1)+e(i2))**2)/
16292c & (srt**2-(e(i1)-e(i2))**2)
16293 pff = sqrt((srt**2-(aphi+aks)**2)*(srt**2-(aphi-aks)**2))
16294 sig22 = sig2*pff/pii*18./dnr/32./pi/srt**2
16295 endif
16296c sig11 = amin1(20.,sig11)
16297c sig22 = amin1(20.,sig22)
16298c
16299 endif
16300
16301c sigks = sig11 + sig22
16302 sigks=sig11+sig22+sigela+sigkm
16303c
16304 DSkn=SQRT(sigks/PI/10.)
16305 dsknr=dskn+0.1
16306 CALL DISTCE(I1,I2,dsknr,DSkn,DT,EC,SRT,IC,
16307 1 PX,PY,PZ)
16308 IF(IC.EQ.-1)return
16309 icase = 1
16310 ranx = RANART(NSEED)
16311
16312 if(ranx .le. (sigela/sigks))then
16313 lbp1=lb1
16314 emm1=e(i1)
16315 lbp2=lb2
16316 emm2=e(i2)
16317 iblock=111
16318 elseif(ranx .le. ((sigela+sigkm)/sigks))then
16319 lbp1=3+int(3*RANART(NSEED))
16320 emm1=0.14
16321 if(lb1.eq.23.or.lb2.eq.23) then
16322 lbp2=30
16323 emm2=aks
16324 elseif(lb1.eq.21.or.lb2.eq.21) then
16325 lbp2=-30
16326 emm2=aks
16327 elseif(lb1.eq.30.or.lb2.eq.30) then
16328 lbp2=23
16329 emm2=aka
16330 else
16331 lbp2=21
16332 emm2=aka
16333 endif
16334 iblock=112
16335 elseif(ranx .le. ((sigela+sigkm+sig11)/sigks))then
16336 lbp2 = 23
16337 emm2 = aka
16338 ikkg = 1
16339 if(lb1.eq.21.or.lb2.eq.21.or.lb1.eq.-30.or.lb2.eq.-30)then
16340 lbp2=21
16341 iblock=iblock-100
16342 endif
16343 lbp1 = 29
16344 emm1 = aphi
16345 else
16346 lbp2 = 30
16347 emm2 = aks
16348 ikkg = 0
16349 IBLOCK=IBLOCK+2
16350 if(lb1.eq.21.or.lb2.eq.21.or.lb1.eq.-30.or.lb2.eq.-30)then
16351 lbp2=-30
16352 iblock=iblock-100
16353 endif
16354 lbp1 = 29
16355 emm1 = aphi
16356 endif
16357*
16358 PX0=PX
16359 PY0=PY
16360 PZ0=PZ
16361*-----------------------------------------------------------------------
16362* CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
16363* ENERGY CONSERVATION
16364 PR2 = (SRT**2 - EMM1**2 - EMM2**2)**2
16365 1 - 4.0 * (EMM1*EMM2)**2
16366 IF(PR2.LE.0.)PR2=1.e-09
16367 PR=SQRT(PR2)/(2.*SRT)
16368 C1 = 1.0 - 2.0 * RANART(NSEED)
16369 T1 = 2.0 * PI * RANART(NSEED)
16370 S1 = SQRT( 1.0 - C1**2 )
16371 CT1 = COS(T1)
16372 ST1 = SIN(T1)
16373* THE MOMENTUM IN THE CMS IN THE FINAL STATE
16374 PZ = PR * C1
16375 PX = PR * S1*CT1
16376 PY = PR * S1*ST1
16377* FOR THE ISOTROPIC DISTRIBUTION THERE IS NO NEED TO ROTATE
16378 RETURN
16379 END
16380csp11/21/01 end
16381**********************************
16382**********************************
16383 SUBROUTINE bbkaon(ic,SRT,PX,PY,PZ,ana,PlX,
16384 & PlY,PlZ,ala,pkX,PkY,PkZ,icou1)
16385* purpose: generate the momenta for kaon,lambda/sigma and nucleon/delta
16386* in the BB-->nlk process
16387* date: Sept. 9, 1994
16388c
16389 common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
16390cc SAVE /input1/
16391 COMMON/RNDF77/NSEED
16392cc SAVE /RNDF77/
16393 SAVE
16394
16395 PI=3.1415962
16396 icou1=0
16397 aka=0.498
16398 ala=1.116
16399 if(ic.eq.2.or.ic.eq.4)ala=1.197
16400 ana=0.939
16401* generate the mass of the delta
16402 if(ic.gt.2)then
16403 dmax=srt-aka-ala-0.02
16404 DM1=RMASS(DMAX,ISEED)
16405 ana=dm1
16406 endif
16407 t1=aka+ana+ala
16408 t2=ana+ala-aka
16409 if(srt.le.t1)then
16410 icou1=-1
16411 return
16412 endif
16413 pmax=sqrt((srt**2-t1**2)*(srt**2-t2**2))/(2.*srt)
16414 if(pmax.eq.0.)pmax=1.e-09
16415* (1) Generate the momentum of the kaon according to the distribution Fkaon
16416* and assume that the angular distribution is isotropic
16417* in the cms of the colliding pair
16418 ntry=0
164191 pk=pmax*RANART(NSEED)
16420 ntry=ntry+1
16421 prob=fkaon(pk,pmax)
16422 if((prob.lt.RANART(NSEED)).and.(ntry.le.40))go to 1
16423 cs=1.-2.*RANART(NSEED)
16424 ss=sqrt(1.-cs**2)
16425 fai=2.*3.14*RANART(NSEED)
16426 pkx=pk*ss*cos(fai)
16427 pky=pk*ss*sin(fai)
16428 pkz=pk*cs
16429* the energy of the kaon
16430 ek=sqrt(aka**2+pk**2)
16431* (2) Generate the momentum of the nucleon/delta in the cms of N/delta
16432* and lamda/sigma
16433* the energy of the cms of NL
16434 eln=srt-ek
16435 if(eln.le.0)then
16436 icou1=-1
16437 return
16438 endif
16439* beta and gamma of the cms of L/S+N
16440 bx=-pkx/eln
16441 by=-pky/eln
16442 bz=-pkz/eln
16443 ga=1./sqrt(1.-bx**2-by**2-bz**2)
16444 elnc=eln/ga
16445 pn2=((elnc**2+ana**2-ala**2)/(2.*elnc))**2-ana**2
16446 if(pn2.le.0.)pn2=1.e-09
16447 pn=sqrt(pn2)
16448 csn=1.-2.*RANART(NSEED)
16449 ssn=sqrt(1.-csn**2)
16450 fain=2.*3.14*RANART(NSEED)
16451 px=pn*ssn*cos(fain)
16452 py=pn*ssn*sin(fain)
16453 pz=pn*csn
16454 en=sqrt(ana**2+pn2)
16455* the momentum of the lambda/sigma in the n-l cms frame is
16456 plx=-px
16457 ply=-py
16458 plz=-pz
16459* (3) LORENTZ-TRANSFORMATION INTO nn cms FRAME for the neutron/delta
16460 PBETA = PX*BX + PY*By+ PZ*Bz
16461 TRANS0 = GA * ( GA * PBETA / (GA + 1.) + En )
16462 Px = BX * TRANS0 + PX
16463 Py = BY * TRANS0 + PY
16464 Pz = BZ * TRANS0 + PZ
16465* (4) Lorentz-transformation for the lambda/sigma
16466 el=sqrt(ala**2+plx**2+ply**2+plz**2)
16467 PBETA = PlX*BX + PlY*By+ PlZ*Bz
16468 TRANS0 = GA * ( GA * PBETA / (GA + 1.) + El )
16469 Plx = BX * TRANS0 + PlX
16470 Ply = BY * TRANS0 + PlY
16471 Plz = BZ * TRANS0 + PlZ
16472 return
16473 end
16474******************************************
16475* for pion+pion-->K+K-
16476c real*4 function pipik(srt)
16477 real function pipik(srt)
16478* srt = DSQRT(s) in GeV *
16479* xsec = production cross section in mb *
16480* NOTE: DEVIDE THE CROSS SECTION TO OBTAIN K+ PRODUCTION *
16481******************************************
16482c real*4 xarray(5), earray(5)
16483 real xarray(5), earray(5)
16484 SAVE
16485 data xarray /0.001, 0.7,1.5,1.7,2.0/
16486 data earray /1.,1.2,1.6,2.0,2.4/
16487
16488 pmass=0.9383
16489* 1.Calculate p(lab) from srt [GeV]
16490* Formula used: DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
16491c ekin = 2.*pmass*((srt/(2.*pmass))**2 - 1.)
16492 pipik=0.
16493 if(srt.le.1.)return
16494 if(srt.gt.2.4)then
16495 pipik=2.0/2.
16496 return
16497 endif
16498 if (srt .lt. earray(1)) then
16499 pipik =xarray(1)/2.
16500 return
16501 end if
16502*
16503* 2.Interpolate double logarithmically to find sigma(srt)
16504*
16505 do 1001 ie = 1,5
16506 if (earray(ie) .eq. srt) then
16507 pipik = xarray(ie)
16508 go to 10
16509 else if (earray(ie) .gt. srt) then
16510 ymin = alog(xarray(ie-1))
16511 ymax = alog(xarray(ie))
16512 xmin = alog(earray(ie-1))
16513 xmax = alog(earray(ie))
16514 pipik = exp(ymin + (alog(srt)-xmin)*(ymax-ymin)
16515 &/(xmax-xmin) )
16516 go to 10
16517 end if
16518 1001 continue
1651910 PIPIK=PIPIK/2.
16520 continue
16521 return
16522 END
16523**********************************
16524* TOTAL PION-P INELASTIC CROSS SECTION
16525* from the CERN data book
16526* date: Sept.2, 1994
16527* for pion++p-->Delta+pion
16528c real*4 function pionpp(srt)
16529 real function pionpp(srt)
16530 SAVE
16531* srt = DSQRT(s) in GeV *
16532* xsec = production cross section in fm**2 *
16533* earray = EXPerimental table with proton energies in MeV *
16534* xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
16535* *
16536******************************************
16537 pmass=0.14
16538 pmass1=0.938
16539 PIONPP=0.00001
16540 IF(SRT.LE.1.22)RETURN
16541* 1.Calculate p(lab) from srt [GeV]
16542* Formula used: DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
16543c ekin = 2.*pmass*((srt/(2.*pmass))**2 - 1.)
16544 plab=sqrt(((srt**2-pmass**2-pmass1**2)/(2.*pmass1))**2-pmass**2)
16545 pmin=0.3
16546 pmax=25.0
16547 if(plab.gt.pmax)then
16548 pionpp=20./10.
16549 return
16550 endif
16551 if(plab .lt. pmin)then
16552 pionpp = 0.
16553 return
16554 end if
16555c* fit parameters
16556 a=24.3
16557 b=-12.3
16558 c=0.324
16559 an=-1.91
16560 d=-2.44
16561 pionpp = a+b*(plab**an)+c*(alog(plab))**2+d*alog(plab)
16562 if(pionpp.le.0)pionpp=0
16563 pionpp=pionpp/10.
16564 return
16565 END
16566**********************************
16567* elementary cross sections
16568* from the CERN data book
16569* date: Sept.2, 1994
16570* for pion-+p-->INELASTIC
16571c real*4 function pipp1(srt)
16572 real function pipp1(srt)
16573 SAVE
16574* srt = DSQRT(s) in GeV *
16575* xsec = production cross section in fm**2 *
16576* earray = EXPerimental table with proton energies in MeV *
16577* xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
16578* UNITS: FM**2
16579******************************************
16580 pmass=0.14
16581 pmass1=0.938
16582 PIPP1=0.0001
16583 IF(SRT.LE.1.22)RETURN
16584* 1.Calculate p(lab) from srt [GeV]
16585* Formula used: DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
16586c ekin = 2.*pmass*((srt/(2.*pmass))**2 - 1.)
16587 plab=sqrt(((srt**2-pmass**2-pmass1**2)/(2.*pmass1))**2-pmass**2)
16588 pmin=0.3
16589 pmax=25.0
16590 if(plab.gt.pmax)then
16591 pipp1=20./10.
16592 return
16593 endif
16594 if(plab .lt. pmin)then
16595 pipp1 = 0.
16596 return
16597 end if
16598c* fit parameters
16599 a=26.6
16600 b=-7.18
16601 c=0.327
16602 an=-1.86
16603 d=-2.81
16604 pipp1 = a+b*(plab**an)+c*(alog(plab))**2+d*alog(plab)
16605 if(pipp1.le.0)pipp1=0
16606 PIPP1=PIPP1/10.
16607 return
16608 END
16609* *****************************
16610c real*4 function xrho(srt)
16611 real function xrho(srt)
16612 SAVE
16613* xsection for pp-->pp+rho
16614* *****************************
16615 pmass=0.9383
16616 rmass=0.77
16617 trho=0.151
16618 xrho=0.000000001
16619 if(srt.le.2.67)return
16620 ESMIN=2.*0.9383+rmass-trho/2.
16621 ES=srt
16622* the cross section for tho0 production is
16623 xrho0=0.24*(es-esmin)/(1.4+(es-esmin)**2)
16624 xrho=3.*Xrho0
16625 return
16626 end
16627* *****************************
16628c real*4 function omega(srt)
16629 real function omega(srt)
16630 SAVE
16631* xsection for pp-->pp+omega
16632* *****************************
16633 pmass=0.9383
16634 omass=0.782
16635 tomega=0.0084
16636 omega=0.00000001
16637 if(srt.le.2.68)return
16638 ESMIN=2.*0.9383+omass-tomega/2.
16639 es=srt
16640 omega=0.36*(es-esmin)/(1.25+(es-esmin)**2)
16641 return
16642 end
16643******************************************
16644* for ppi(+)-->DELTA+pi
16645c real*4 function TWOPI(srt)
16646 real function TWOPI(srt)
16647* This function contains the experimental pi+p-->DELTA+PION cross sections *
16648* srt = DSQRT(s) in GeV *
16649* xsec = production cross section in mb *
16650* earray = EXPerimental table with proton energies in MeV *
16651* xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
16652* *
16653******************************************
16654c real*4 xarray(19), earray(19)
16655 real xarray(19), earray(19)
16656 SAVE
16657 data xarray /0.300E-05,0.187E+01,0.110E+02,0.149E+02,0.935E+01,
16658 &0.765E+01,0.462E+01,0.345E+01,0.241E+01,0.185E+01,0.165E+01,
16659 &0.150E+01,0.132E+01,0.117E+01,0.116E+01,0.100E+01,0.856E+00,
16660 &0.745E+00,0.300E-05/
16661 data earray /0.122E+01, 0.147E+01, 0.172E+01, 0.197E+01,
16662 &0.222E+01, 0.247E+01, 0.272E+01, 0.297E+01, 0.322E+01,
16663 &0.347E+01, 0.372E+01, 0.397E+01, 0.422E+01, 0.447E+01,
16664 &0.472E+01, 0.497E+01, 0.522E+01, 0.547E+01, 0.572E+01/
16665
16666 pmass=0.14
16667 pmass1=0.938
16668 TWOPI=0.000001
16669 if(srt.le.1.22)return
16670* 1.Calculate p(lab) from srt [GeV]
16671* Formula used: DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
16672 plab=SRT
16673 if (plab .lt. earray(1)) then
16674 TWOPI= 0.00001
16675 return
16676 end if
16677*
16678* 2.Interpolate double logarithmically to find sigma(srt)
16679*
16680 do 1001 ie = 1,19
16681 if (earray(ie) .eq. plab) then
16682 TWOPI= xarray(ie)
16683 return
16684 else if (earray(ie) .gt. plab) then
16685 ymin = alog(xarray(ie-1))
16686 ymax = alog(xarray(ie))
16687 xmin = alog(earray(ie-1))
16688 xmax = alog(earray(ie))
16689 TWOPI= exp(ymin + (alog(plab)-xmin)*(ymax-ymin)
16690 & /(xmax-xmin) )
16691 return
16692 end if
16693 1001 continue
16694 return
16695 END
16696******************************************
16697******************************************
16698* for ppi(+)-->DELTA+RHO
16699c real*4 function THREPI(srt)
16700 real function THREPI(srt)
16701* This function contains the experimental pi+p-->DELTA + rho cross sections *
16702* srt = DSQRT(s) in GeV *
16703* xsec = production cross section in mb *
16704* earray = EXPerimental table with proton energies in MeV *
16705* xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
16706* *
16707******************************************
16708c real*4 xarray(15), earray(15)
16709 real xarray(15), earray(15)
16710 SAVE
16711 data xarray /8.0000000E-06,6.1999999E-05,1.881940,5.025690,
16712 &11.80154,13.92114,15.07308,11.79571,11.53772,10.01197,9.792673,
16713 &9.465264,8.970490,7.944254,6.886320/
16714 data earray /0.122E+01, 0.147E+01, 0.172E+01, 0.197E+01,
16715 &0.222E+01, 0.247E+01, 0.272E+01, 0.297E+01, 0.322E+01,
16716 &0.347E+01, 0.372E+01, 0.397E+01, 0.422E+01, 0.447E+01,
16717 &0.472E+01/
16718
16719 pmass=0.14
16720 pmass1=0.938
16721 THREPI=0.000001
16722 if(srt.le.1.36)return
16723* 1.Calculate p(lab) from srt [GeV]
16724* Formula used: DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
16725 plab=SRT
16726 if (plab .lt. earray(1)) then
16727 THREPI = 0.00001
16728 return
16729 end if
16730*
16731* 2.Interpolate double logarithmically to find sigma(srt)
16732*
16733 do 1001 ie = 1,15
16734 if (earray(ie) .eq. plab) then
16735 THREPI= xarray(ie)
16736 return
16737 else if (earray(ie) .gt. plab) then
16738 ymin = alog(xarray(ie-1))
16739 ymax = alog(xarray(ie))
16740 xmin = alog(earray(ie-1))
16741 xmax = alog(earray(ie))
16742 THREPI = exp(ymin + (alog(plab)-xmin)*(ymax-ymin)
16743 & /(xmax-xmin) )
16744 return
16745 end if
16746 1001 continue
16747 return
16748 END
16749******************************************
16750******************************************
16751* for ppi(+)-->DELTA+omega
16752c real*4 function FOURPI(srt)
16753 real function FOURPI(srt)
16754* This function contains the experimental pi+p-->DELTA+PION cross sections *
16755* srt = DSQRT(s) in GeV *
16756* xsec = production cross section in mb *
16757* earray = EXPerimental table with proton energies in MeV *
16758* xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
16759* *
16760******************************************
16761c real*4 xarray(10), earray(10)
16762 real xarray(10), earray(10)
16763 SAVE
16764 data xarray /0.0001,1.986597,6.411932,7.636956,
16765 &9.598362,9.889740,10.24317,10.80138,11.86988,12.83925/
16766 data earray /2.468,2.718,2.968,0.322E+01,
16767 &0.347E+01, 0.372E+01, 0.397E+01, 0.422E+01, 0.447E+01,
16768 &0.472E+01/
16769
16770 pmass=0.14
16771 pmass1=0.938
16772 FOURPI=0.000001
16773 if(srt.le.1.52)return
16774* 1.Calculate p(lab) from srt [GeV]
16775* Formula used: DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
16776 plab=SRT
16777 if (plab .lt. earray(1)) then
16778 FOURPI= 0.00001
16779 return
16780 end if
16781*
16782* 2.Interpolate double logarithmically to find sigma(srt)
16783*
16784 do 1001 ie = 1,10
16785 if (earray(ie) .eq. plab) then
16786 FOURPI= xarray(ie)
16787 return
16788 else if (earray(ie) .gt. plab) then
16789 ymin = alog(xarray(ie-1))
16790 ymax = alog(xarray(ie))
16791 xmin = alog(earray(ie-1))
16792 xmax = alog(earray(ie))
16793 FOURPI= exp(ymin + (alog(plab)-xmin)*(ymax-ymin)
16794 & /(xmax-xmin) )
16795 return
16796 end if
16797 1001 continue
16798 return
16799 END
16800******************************************
16801******************************************
16802* for pion (rho or omega)+baryon resonance collisions
16803c real*4 function reab(i1,i2,srt,ictrl)
16804 real function reab(i1,i2,srt,ictrl)
16805* This function calculates the cross section for
16806* pi+Delta(N*)-->N+PION process *
16807* srt = DSQRT(s) in GeV *
16808* reab = cross section in fm**2 *
16809* ictrl=1,2,3 for pion, rho and omega+D(N*)
16810****************************************
16811 PARAMETER (MAXSTR=150001,MAXR=1,PI=3.1415926)
16812 parameter (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
16813 PARAMETER (AKA=0.498,ALA=1.1157,ASA=1.1974)
16814 parameter (amn=0.938,ap1=0.14,arho=0.77,aomega=0.782)
16815 parameter (maxx=20,maxz=24)
16816 COMMON /AA/ R(3,MAXSTR)
16817cc SAVE /AA/
16818 COMMON /BB/ P(3,MAXSTR)
16819cc SAVE /BB/
16820 COMMON /CC/ E(MAXSTR)
16821cc SAVE /CC/
16822 COMMON /DD/ RHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
16823 & RHOP(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
16824 & RHON(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
16825cc SAVE /DD/
16826 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
16827cc SAVE /EE/
16828 SAVE
16829 LB1=LB(I1)
16830 LB2=LB(I2)
16831 reab=0
16832 if(ictrl.eq.1.and.srt.le.(amn+2.*ap1+0.02))return
16833 if(ictrl.eq.3.and.srt.le.(amn+ap1+aomega+0.02))return
16834 pin2=((srt**2+ap1**2-amn**2)/(2.*srt))**2-ap1**2
16835 if(pin2.le.0)return
16836* for pion+D(N*)-->pion+N
16837 if(ictrl.eq.1)then
16838 if(e(i1).gt.1)then
16839 ed=e(i1)
16840 else
16841 ed=e(i2)
16842 endif
16843 pout2=((srt**2+ap1**2-ed**2)/(2.*srt))**2-ap1**2
16844 if(pout2.le.0)return
16845 xpro=twopi(srt)/10.
16846 factor=1/3.
16847 if( ((lb1.eq.8.and.lb2.eq.5).or.
16848 & (lb1.eq.5.and.lb2.eq.8))
16849 & .OR.((lb1.eq.-8.and.lb2.eq.3).or.
16850 & (lb1.eq.3.and.lb2.eq.-8)) )factor=1/4.
16851 if((iabs(lb1).ge.10.and.iabs(lb1).le.13).
16852 & or.(iabs(lb2).ge.10.and.iabs(lb2).le.13))factor=1.
16853 reab=factor*pin2/pout2*xpro
16854 return
16855 endif
16856* for rho reabsorption
16857 if(ictrl.eq.2)then
16858 if(lb(i2).ge.25)then
16859 ed=e(i1)
16860 arho1=e(i2)
16861 else
16862 ed=e(i2)
16863 arho1=e(i1)
16864 endif
16865 if(srt.le.(amn+ap1+arho1+0.02))return
16866 pout2=((srt**2+arho1**2-ed**2)/(2.*srt))**2-arho1**2
16867 if(pout2.le.0)return
16868 xpro=threpi(srt)/10.
16869 factor=1/3.
16870 if( ((lb1.eq.8.and.lb2.eq.27).or.
16871 & (lb1.eq.27.and.lb2.eq.8))
16872 & .OR. ((lb1.eq.-8.and.lb2.eq.25).or.
16873 & (lb1.eq.25.and.lb2.eq.-8)) )factor=1/4.
16874 if((iabs(lb1).ge.10.and.iabs(lb1).le.13).
16875 & or.(iabs(lb2).ge.10.and.iabs(lb2).le.13))factor=1.
16876 reab=factor*pin2/pout2*xpro
16877 return
16878 endif
16879* for omega reabsorption
16880 if(ictrl.eq.3)then
16881 if(e(i1).gt.1)ed=e(i1)
16882 if(e(i2).gt.1)ed=e(i2)
16883 pout2=((srt**2+aomega**2-ed**2)/(2.*srt))**2-aomega**2
16884 if(pout2.le.0)return
16885 xpro=fourpi(srt)/10.
16886 factor=1/6.
16887 if((iabs(lb1).ge.10.and.iabs(lb1).le.13).
16888 & or.(iabs(lb2).ge.10.and.iabs(lb2).le.13))factor=1./3.
16889 reab=factor*pin2/pout2*xpro
16890 endif
16891 return
16892 END
16893******************************************
16894* for the reabsorption of two resonances
16895* This function calculates the cross section for
16896* DD-->NN, N*N*-->NN and DN*-->NN
16897c real*4 function reab2d(i1,i2,srt)
16898 real function reab2d(i1,i2,srt)
16899* srt = DSQRT(s) in GeV *
16900* reab = cross section in mb
16901****************************************
16902 PARAMETER (MAXSTR=150001,MAXR=1,PI=3.1415926)
16903 parameter (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
16904 PARAMETER (AKA=0.498,ALA=1.1157,ASA=1.1974)
16905 parameter (amn=0.938,ap1=0.14,arho=0.77,aomega=0.782)
16906 parameter (maxx=20,maxz=24)
16907 COMMON /AA/ R(3,MAXSTR)
16908cc SAVE /AA/
16909 COMMON /BB/ P(3,MAXSTR)
16910cc SAVE /BB/
16911 COMMON /CC/ E(MAXSTR)
16912cc SAVE /CC/
16913 COMMON /DD/ RHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
16914 & RHOP(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
16915 & RHON(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
16916cc SAVE /DD/
16917 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
16918cc SAVE /EE/
16919 SAVE
16920 reab2d=0
16921 LB1=iabs(LB(I1))
16922 LB2=iabs(LB(I2))
16923 ed1=e(i1)
16924 ed2=e(i2)
16925 pin2=(srt/2.)**2-amn**2
16926 pout2=((srt**2+ed1**2-ed2**2)/(2.*srt))**2-ed1**2
16927 if(pout2.le.0)return
16928 xpro=x2pi(srt)
16929 factor=1/4.
16930 if((lb1.ge.10.and.lb1.le.13).and.
16931 & (lb2.ge.10.and.lb2.le.13))factor=1.
16932 if((lb1.ge.6.and.lb1.le.9).and.
16933 & (lb2.gt.10.and.lb2.le.13))factor=1/2.
16934 if((lb2.ge.6.and.lb2.le.9).and.
16935 & (lb1.gt.10.and.lb1.le.13))factor=1/2.
16936 reab2d=factor*pin2/pout2*xpro
16937 return
16938 end
16939***************************************
16940 SUBROUTINE rotate(PX0,PY0,PZ0,px,py,pz)
16941 SAVE
16942* purpose: rotate the momentum of a particle in the CMS of p1+p2 such that
16943* the x' y' and z' in the cms of p1+p2 is the same as the fixed x y and z
16944* quantities:
16945* px0,py0 and pz0 are the cms momentum of the incoming colliding
16946* particles
16947* px, py and pz are the cms momentum of any one of the particles
16948* after the collision to be rotated
16949***************************************
16950* the momentum, polar and azimuthal angles of the incoming momentm
16951 PR0 = SQRT( PX0**2 + PY0**2 + PZ0**2 )
16952 IF(PR0.EQ.0)PR0=0.00000001
16953 C2 = PZ0 / PR0
16954 IF(PX0 .EQ. 0.0 .AND. PY0 .EQ. 0.0) THEN
16955 T2 = 0.0
16956 ELSE
16957 T2=ATAN2(PY0,PX0)
16958 END IF
16959 S2 = SQRT( 1.0 - C2**2 )
16960 CT2 = COS(T2)
16961 ST2 = SIN(T2)
16962* the momentum, polar and azimuthal angles of the momentum to be rotated
16963 PR=SQRT(PX**2+PY**2+PZ**2)
16964 IF(PR.EQ.0)PR=0.0000001
16965 C1=PZ/PR
16966 IF(PX.EQ.0.AND.PY.EQ.0)THEN
16967 T1=0.
16968 ELSE
16969 T1=ATAN2(PY,PX)
16970 ENDIF
16971 S1 = SQRT( 1.0 - C1**2 )
16972 CT1 = COS(T1)
16973 ST1 = SIN(T1)
16974 SS = C2 * S1 * CT1 + S2 * C1
16975* THE MOMENTUM AFTER ROTATION
16976 PX = PR * ( SS*CT2 - S1*ST1*ST2 )
16977 PY = PR * ( SS*ST2 + S1*ST1*CT2 )
16978 PZ = PR * ( C1*C2 - S1*S2*CT1 )
16979 RETURN
16980 END
16981******************************************
16982c real*4 function Xpp(srt)
16983 real function Xpp(srt)
16984* This function contains the experimental total n-p cross sections *
16985* srt = DSQRT(s) in GeV *
16986* xsec = production cross section in mb *
16987* earray = EXPerimental table with proton energies in MeV *
16988* xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
16989* WITH A CUTOFF AT 55MB *
16990******************************************
16991c real*4 xarray(14), earray(14)
16992 real xarray(14), earray(14)
16993 SAVE
16994 data earray /20.,30.,40.,60.,80.,100.,
16995 &170.,250.,310.,
16996 &350.,460.,560.,660.,800./
16997 data xarray /150.,90.,80.6,48.0,36.6,
16998 &31.6,25.9,24.0,23.1,
16999 &24.0,28.3,33.6,41.5,47/
17000
17001 xpp=0.
17002 pmass=0.9383
17003* 1.Calculate E_kin(lab) [MeV] from srt [GeV]
17004* Formula used: DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
17005 ekin = 2000.*pmass*((srt/(2.*pmass))**2 - 1.)
17006 if (ekin .lt. earray(1)) then
17007 xpp = xarray(1)
17008 IF(XPP.GT.55)XPP=55
17009 return
17010 end if
17011 IF(EKIN.GT.EARRAY(14))THEN
17012 XPP=XARRAY(14)
17013 RETURN
17014 ENDIF
17015*
17016*
17017* 2.Interpolate double logarithmically to find sigma(srt)
17018*
17019 do 1001 ie = 1,14
17020 if (earray(ie) .eq. ekin) then
17021 xPP= xarray(ie)
17022 if(xpp.gt.55)xpp=55.
17023 return
17024 endif
17025 if (earray(ie) .gt. ekin) then
17026 ymin = alog(xarray(ie-1))
17027 ymax = alog(xarray(ie))
17028 xmin = alog(earray(ie-1))
17029 xmax = alog(earray(ie))
17030 XPP = exp(ymin + (alog(ekin)-xmin)
17031 & *(ymax-ymin)/(xmax-xmin) )
17032 IF(XPP.GT.55)XPP=55.
17033 go to 50
17034 end if
17035 1001 continue
1703650 continue
17037 return
17038 END
17039******************************************
17040 real function Xnp(srt)
17041* This function contains the experimental total n-p cross sections *
17042* srt = DSQRT(s) in GeV *
17043* xsec = production cross section in mb *
17044* earray = EXPerimental table with proton energies in MeV *
17045* xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
17046* WITH A CUTOFF AT 55MB *
17047******************************************
17048c real*4 xarray(11), earray(11)
17049 real xarray(11), earray(11)
17050 SAVE
17051 data earray /20.,30.,40.,60.,90.,135.0,200.,
17052 &300.,400.,600.,800./
17053 data xarray / 410.,270.,214.5,130.,78.,53.5,
17054 &41.6,35.9,34.2,34.3,34.9/
17055
17056 xnp=0.
17057 pmass=0.9383
17058* 1.Calculate E_kin(lab) [MeV] from srt [GeV]
17059* Formula used: DSQRT(s) = 2 m DSQRT(E_kin/(2m) + 1)
17060 ekin = 2000.*pmass*((srt/(2.*pmass))**2 - 1.)
17061 if (ekin .lt. earray(1)) then
17062 xnp = xarray(1)
17063 IF(XNP.GT.55)XNP=55
17064 return
17065 end if
17066 IF(EKIN.GT.EARRAY(11))THEN
17067 XNP=XARRAY(11)
17068 RETURN
17069 ENDIF
17070*
17071*Interpolate double logarithmically to find sigma(srt)
17072*
17073 do 1001 ie = 1,11
17074 if (earray(ie) .eq. ekin) then
17075 xNP = xarray(ie)
17076 if(xnp.gt.55)xnp=55.
17077 return
17078 endif
17079 if (earray(ie) .gt. ekin) then
17080 ymin = alog(xarray(ie-1))
17081 ymax = alog(xarray(ie))
17082 xmin = alog(earray(ie-1))
17083 xmax = alog(earray(ie))
17084 xNP = exp(ymin + (alog(ekin)-xmin)
17085 & *(ymax-ymin)/(xmax-xmin) )
17086 IF(XNP.GT.55)XNP=55
17087 go to 50
17088 end if
17089 1001 continue
1709050 continue
17091 return
17092 END
17093*******************************
17094 function ptr(ptmax,iseed)
17095* (2) Generate the transverse momentum
17096* OF nucleons
17097*******************************
17098 COMMON/TABLE/ xarray(0:1000),earray(0:1000)
17099cc SAVE /TABLE/
17100 COMMON/RNDF77/NSEED
17101cc SAVE /RNDF77/
17102 SAVE
17103 ISEED=ISEED
17104 ptr=0.
17105 if(ptmax.le.1.e-02)then
17106 ptr=ptmax
17107 return
17108 endif
17109 if(ptmax.gt.2.01)ptmax=2.01
17110 tryial=ptdis(ptmax)/ptdis(2.01)
17111 XT=RANART(NSEED)*tryial
17112* look up the table and
17113*Interpolate double logarithmically to find pt
17114 do 50 ie = 1,200
17115 if (earray(ie) .eq. xT) then
17116 ptr = xarray(ie)
17117 return
17118 end if
17119 if(xarray(ie-1).le.0.00001)go to 50
17120 if(xarray(ie).le.0.00001)go to 50
17121 if(earray(ie-1).le.0.00001)go to 50
17122 if(earray(ie).le.0.00001)go to 50
17123 if (earray(ie) .gt. xT) then
17124 ymin = alog(xarray(ie-1))
17125 ymax = alog(xarray(ie))
17126 xmin = alog(earray(ie-1))
17127 xmax = alog(earray(ie))
17128 ptr= exp(ymin + (alog(xT)-xmin)*(ymax-ymin)
17129 & /(xmax-xmin) )
17130 if(ptr.gt.ptmax)ptr=ptmax
17131 return
17132 endif
1713350 continue
17134 return
17135 end
17136
17137**********************************
17138**********************************
17139* *
17140* *
17141 SUBROUTINE XND(px,py,pz,srt,I1,I2,xinel,
17142 & sigk,xsk1,xsk2,xsk3,xsk4,xsk5)
17143* PURPOSE: *
17144* calculate NUCLEON-BARYON RESONANCE inelatic Xsection *
17145* NOTE : *
17146* QUANTITIES: *
17147* CHANNELS. M12 IS THE REVERSAL CHANNEL OF N12 *
17148* N12, *
17149* M12=1 FOR p+n-->delta(+)+ n *
17150* 2 p+n-->delta(0)+ p *
17151* 3 p+p-->delta(++)+n *
17152* 4 p+p-->delta(+)+p *
17153* 5 n+n-->delta(0)+n *
17154* 6 n+n-->delta(-)+p *
17155* 7 n+p-->N*(0)(1440)+p *
17156* 8 n+p-->N*(+)(1440)+n *
17157* 9 p+p-->N*(+)(1535)+p *
17158* 10 n+n-->N*(0)(1535)+n *
17159* 11 n+p-->N*(+)(1535)+n *
17160* 12 n+p-->N*(0)(1535)+p
17161* 13 D(++)+D(-)-->N*(+)(1440)+n
17162* 14 D(++)+D(-)-->N*(0)(1440)+p
17163* 15 D(+)+D(0)--->N*(+)(1440)+n
17164* 16 D(+)+D(0)--->N*(0)(1440)+p
17165* 17 D(++)+D(0)-->N*(+)(1535)+p
17166* 18 D(++)+D(-)-->N*(0)(1535)+p
17167* 19 D(++)+D(-)-->N*(+)(1535)+n
17168* 20 D(+)+D(+)-->N*(+)(1535)+p
17169* 21 D(+)+D(0)-->N*(+)(1535)+n
17170* 22 D(+)+D(0)-->N*(0)(1535)+p
17171* 23 D(+)+D(-)-->N*(0)(1535)+n
17172* 24 D(0)+D(0)-->N*(0)(1535)+n
17173* 25 N*(+)(14)+N*(+)(14)-->N*(+)(15)+p
17174* 26 N*(0)(14)+N*(0)(14)-->N*(0)(15)+n
17175* 27 N*(+)(14)+N*(0)(14)-->N*(+)(15)+n
17176* 28 N*(+)(14)+N*(0)(14)-->N*(0)(15)+p
17177* 29 N*(+)(14)+D+-->N*(+)(15)+p
17178* 30 N*(+)(14)+D0-->N*(+)(15)+n
17179* 31 N*(+)(14)+D(-)-->N*(0)(1535)+n
17180* 32 N*(0)(14)+D++--->N*(+)(15)+p
17181* 33 N*(0)(14)+D+--->N*(+)(15)+n
17182* 34 N*(0)(14)+D+--->N*(0)(15)+p
17183* 35 N*(0)(14)+D0-->N*(0)(15)+n
17184* 36 N*(+)(14)+D0--->N*(0)(15)+p
17185* and more
17186***********************************
17187 PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
17188 1 AMP=0.93828,AP1=0.13496,AKA=0.498,APHI=1.020,
17189 2 AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
17190 parameter (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
17191 COMMON /AA/ R(3,MAXSTR)
17192cc SAVE /AA/
17193 COMMON /BB/ P(3,MAXSTR)
17194cc SAVE /BB/
17195 COMMON /CC/ E(MAXSTR)
17196cc SAVE /CC/
17197 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
17198cc SAVE /EE/
17199 common /ff/f(-mx:mx,-my:my,-mz:mz,-mpx:mpx,-mpy:mpy,-mpz:mpzp)
17200cc SAVE /ff/
17201 common /gg/ dx,dy,dz,dpx,dpy,dpz
17202cc SAVE /gg/
17203 COMMON /INPUT/ NSTAR,NDIRCT,DIR
17204cc SAVE /INPUT/
17205 COMMON /NN/NNN
17206cc SAVE /NN/
17207 COMMON /BG/BETAX,BETAY,BETAZ,GAMMA
17208cc SAVE /BG/
17209 COMMON /RUN/NUM
17210cc SAVE /RUN/
17211 COMMON /PA/RPION(3,MAXSTR,MAXR)
17212cc SAVE /PA/
17213 COMMON /PB/PPION(3,MAXSTR,MAXR)
17214cc SAVE /PB/
17215 COMMON /PC/EPION(MAXSTR,MAXR)
17216cc SAVE /PC/
17217 COMMON /PD/LPION(MAXSTR,MAXR)
17218cc SAVE /PD/
17219 common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
17220cc SAVE /input1/
17221 SAVE
17222
17223*-----------------------------------------------------------------------
17224 xinel=0.
17225 sigk=0
17226 xsk1=0
17227 xsk2=0
17228 xsk3=0
17229 xsk4=0
17230 xsk5=0
17231 EM1=E(I1)
17232 EM2=E(I2)
17233 PR = SQRT( PX**2 + PY**2 + PZ**2 )
17234* CAN HAPPEN ANY MORE ==> RETURN (2.04 = 2*AVMASS + PI-MASS+0.02)
17235 IF (SRT .LT. 2.04) RETURN
17236* Resonance absorption or Delta + N-->N*(1440), N*(1535)
17237* COM: TEST FOR DELTA OR N* ABSORPTION
17238* IN THE PROCESS DELTA+N-->NN, N*+N-->NN
17239 PRF=SQRT(0.25*SRT**2-AVMASS**2)
17240 IF(EM1.GT.1.)THEN
17241 DELTAM=EM1
17242 ELSE
17243 DELTAM=EM2
17244 ENDIF
17245 RENOM=DELTAM*PRF**2/DENOM(SRT,1.)/PR
17246 RENOMN=DELTAM*PRF**2/DENOM(SRT,2.)/PR
17247 RENOM1=DELTAM*PRF**2/DENOM(SRT,-1.)/PR
17248* avoid the inelastic collisions between n+delta- -->N+N
17249* and p+delta++ -->N+N due to charge conservation,
17250* but they can scatter to produce kaons
17251 if((iabs(lb(i1)).eq.2).and.(iabs(lb(i2)).eq.6)) renom=0.
17252 if((iabs(lb(i2)).eq.2).and.(iabs(lb(i1)).eq.6)) renom=0.
17253 if((iabs(lb(i1)).eq.1).and.(iabs(lb(i2)).eq.9)) renom=0.
17254 if((iabs(lb(i2)).eq.1).and.(iabs(lb(i1)).eq.9)) renom=0.
17255 Call M1535(iabs(lb(i1)),iabs(lb(i2)),srt,x1535)
17256 X1440=(3./4.)*SIGMA(SRT,2,0,1)
17257* CROSS SECTION FOR KAON PRODUCTION from the four channels
17258* for NLK channel
17259 akp=0.498
17260 ak0=0.498
17261 ana=0.94
17262 ada=1.232
17263 al=1.1157
17264 as=1.1197
17265 xsk1=0
17266 xsk2=0
17267 xsk3=0
17268 xsk4=0
17269c !! phi production
17270 xsk5=0
17271 t1nlk=ana+al+akp
17272 if(srt.le.t1nlk)go to 222
17273 XSK1=1.5*PPLPK(SRT)
17274* for DLK channel
17275 t1dlk=ada+al+akp
17276 t2dlk=ada+al-akp
17277 if(srt.le.t1dlk)go to 222
17278 es=srt
17279 pmdlk2=(es**2-t1dlk**2)*(es**2-t2dlk**2)/(4.*es**2)
17280 pmdlk=sqrt(pmdlk2)
17281 XSK3=1.5*PPLPK(srt)
17282* for NSK channel
17283 t1nsk=ana+as+akp
17284 t2nsk=ana+as-akp
17285 if(srt.le.t1nsk)go to 222
17286 pmnsk2=(es**2-t1nsk**2)*(es**2-t2nsk**2)/(4.*es**2)
17287 pmnsk=sqrt(pmnsk2)
17288 XSK2=1.5*(PPK1(srt)+PPK0(srt))
17289* for DSK channel
17290 t1DSk=aDa+aS+akp
17291 t2DSk=aDa+aS-akp
17292 if(srt.le.t1dsk)go to 222
17293 pmDSk2=(es**2-t1DSk**2)*(es**2-t2DSk**2)/(4.*es**2)
17294 pmDSk=sqrt(pmDSk2)
17295 XSK4=1.5*(PPK1(srt)+PPK0(srt))
17296csp11/21/01
17297c phi production
17298 if(srt.le.(2.*amn+aphi))go to 222
17299c !! mb put the correct form
17300 xsk5 = 0.0001
17301csp11/21/01 end
17302
17303* THE TOTAL KAON+ PRODUCTION CROSS SECTION IS THEN
17304222 SIGK=XSK1+XSK2+XSK3+XSK4
17305
17306cbz3/7/99 neutralk
17307 XSK1 = 2.0 * XSK1
17308 XSK2 = 2.0 * XSK2
17309 XSK3 = 2.0 * XSK3
17310 XSK4 = 2.0 * XSK4
17311 SIGK = 2.0 * SIGK + xsk5
17312cbz3/7/99 neutralk end
17313
17314* avoid the inelastic collisions between n+delta- -->N+N
17315* and p+delta++ -->N+N due to charge conservation,
17316* but they can scatter to produce kaons
17317 if(((iabs(lb(i1)).eq.2).and.(iabs(lb(i2)).eq.6)).OR.
17318 & ((iabs(lb(i2)).eq.2).and.(iabs(lb(i1)).eq.6)).OR.
17319 & ((iabs(lb(i1)).eq.1).and.(iabs(lb(i2)).eq.9)).OR.
17320 & ((iabs(lb(i2)).eq.1).and.(iabs(lb(i1)).eq.9)))THEN
17321 xinel=sigk
17322 return
17323 ENDIF
17324* WE DETERMINE THE REACTION CHANNELS IN THE FOLLOWING
17325* FOR n+delta(++)-->p+p or n+delta(++)-->n+N*(+)(1440),n+N*(+)(1535)
17326* REABSORPTION OR N*(1535) PRODUCTION LIKE IN P+P OR N*(1440) LIKE PN,
17327 IF(LB(I1)*LB(I2).EQ.18.AND.
17328 & (iabs(LB(I1)).EQ.2.OR.iabs(LB(I2)).EQ.2))then
17329 SIGND=SIGMA(SRT,1,1,0)+0.5*SIGMA(SRT,1,1,1)
17330 SIGDN=0.25*SIGND*RENOM
17331 xinel=SIGDN+X1440+X1535+SIGK
17332 RETURN
17333 endif
17334* FOR p+delta(-)-->n+n or p+delta(-)-->n+N*(0)(1440),n+N*(0)(1535)
17335* REABSORPTION OR N*(1535) PRODUCTION LIKE IN P+P OR N*(1440) LIKE PN,
17336 IF(LB(I1)*LB(I2).EQ.6.AND.
17337 & (iabs(LB(I1)).EQ.1.OR.iabs(LB(I2)).EQ.1))THEN
17338 SIGND=SIGMA(SRT,1,1,0)+0.5*SIGMA(SRT,1,1,1)
17339 SIGDN=0.25*SIGND*RENOM
17340 xinel=SIGDN+X1440+X1535+SIGK
17341 RETURN
17342 endif
17343* FOR p+delta(+)-->p+p, N*(+)(144)+p, N*(+)(1535)+p
17344cbz11/25/98
17345 IF(LB(I1)*LB(I2).EQ.8.AND.
17346 & (iabs(LB(I1)).EQ.1.OR.iabs(LB(I2)).EQ.1))THEN
17347 SIGND=1.5*SIGMA(SRT,1,1,1)
17348 SIGDN=0.25*SIGND*RENOM
17349 xinel=SIGDN+x1440+x1535+SIGK
17350 RETURN
17351 endif
17352* FOR n+delta(0)-->n+n, N*(0)(144)+n, N*(0)(1535)+n
17353 IF(LB(I1)*LB(I2).EQ.14.AND.
17354 & (iabs(LB(I1)).EQ.2.AND.iabs(LB(I2)).EQ.2))THEN
17355 SIGND=1.5*SIGMA(SRT,1,1,1)
17356 SIGDN=0.25*SIGND*RENOM
17357 xinel=SIGDN+x1440+x1535+SIGK
17358 RETURN
17359 endif
17360* FOR n+delta(+)-->n+p, N*(+)(1440)+n,N*(0)(1440)+p,
17361* N*(+)(1535)+n,N*(0)(1535)+p
17362 IF(LB(I1)*LB(I2).EQ.16.AND.
17363 & (iabs(LB(I1)).EQ.2.OR.iabs(LB(I2)).EQ.2))THEN
17364 SIGND=0.5*SIGMA(SRT,1,1,1)+0.25*SIGMA(SRT,1,1,0)
17365 SIGDN=0.5*SIGND*RENOM
17366 xinel=SIGDN+2.*x1440+2.*x1535+SIGK
17367 RETURN
17368 endif
17369* FOR p+delta(0)-->n+p, N*(+)(1440)+n,N*(0)(1440)+p,
17370* N*(+)(1535)+n,N*(0)(1535)+p
17371 IF(LB(I1)*LB(I2).EQ.7)THEN
17372 SIGND=0.5*SIGMA(SRT,1,1,1)+0.25*SIGMA(SRT,1,1,0)
17373 SIGDN=0.5*SIGND*RENOM
17374 xinel=SIGDN+2.*x1440+2.*x1535+SIGK
17375 RETURN
17376 endif
17377* FOR p+N*(0)(14)-->p+n, N*(+)(1535)+n,N*(0)(1535)+p
17378* OR P+N*(0)(14)-->D(+)+N, D(0)+P,
17379 IF(LB(I1)*LB(I2).EQ.10.AND.
17380 & (iabs(LB(I1)).EQ.1.OR.iabs(LB(I2)).EQ.1))then
17381 SIGND=(3./4.)*SIGMA(SRT,2,0,1)
17382 SIGDN=SIGND*RENOMN
17383 xinel=SIGDN+X1535+SIGK
17384 RETURN
17385 endif
17386* FOR n+N*(+)-->p+n, N*(+)(1535)+n,N*(0)(1535)+p
17387 IF(LB(I1)*LB(I2).EQ.22.AND.
17388 & (iabs(LB(I1)).EQ.2.OR.iabs(LB(I2)).EQ.2))then
17389 SIGND=(3./4.)*SIGMA(SRT,2,0,1)
17390 SIGDN=SIGND*RENOMN
17391 xinel=SIGDN+X1535+SIGK
17392 RETURN
17393 endif
17394* FOR N*(1535)+N-->N+N COLLISIONS
17395 IF((iabs(LB(I1)).EQ.12).OR.(iabs(LB(I1)).EQ.13).OR.
17396 1 (iabs(LB(I2)).EQ.12).OR.(iabs(LB(I2)).EQ.13))THEN
17397 SIGND=X1535
17398 SIGDN=SIGND*RENOM1
17399 xinel=SIGDN+SIGK
17400 RETURN
17401 endif
17402 RETURN
17403 end
17404**********************************
17405* *
17406* *
17407 SUBROUTINE XDDIN(PX,PY,PZ,SRT,I1,I2,
17408 &XINEL,SIGK,XSK1,XSK2,XSK3,XSK4,XSK5)
17409* PURPOSE: *
17410* DEALING WITH BARYON RESONANCE-BARYON RESONANCE COLLISIONS*
17411* NOTE : *
17412* VALID ONLY FOR BARYON-BARYON-DISTANCES LESS THAN 1.32 FM *
17413* (1.32 = 2 * HARD-CORE-RADIUS [HRC] ) *
17414* QUANTITIES: *
17415* PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
17416* SRT - SQRT OF S *
17417* NSTAR =1 INCLUDING N* RESORANCE,ELSE NOT *
17418* NDIRCT=1 INCLUDING DIRECT PION PRODUCTION PROCESS *
17419* IBLOCK - THE INFORMATION BACK *
17420* 0-> COLLISION CANNOT HAPPEN *
17421* 1-> N-N ELASTIC COLLISION *
17422* 2-> N+N->N+DELTA,OR N+N->N+N* REACTION *
17423* 3-> N+DELTA->N+N OR N+N*->N+N REACTION *
17424* 4-> N+N->N+N+PION,DIRTCT PROCESS *
17425* 5-> DELTA(N*)+DELTA(N*) TOTAL COLLISIONS *
17426* N12 - IS USED TO SPECIFY BARYON-BARYON REACTION *
17427* CHANNELS. M12 IS THE REVERSAL CHANNEL OF N12 *
17428* N12, *
17429* M12=1 FOR p+n-->delta(+)+ n *
17430* 2 p+n-->delta(0)+ p *
17431* 3 p+p-->delta(++)+n *
17432* 4 p+p-->delta(+)+p *
17433* 5 n+n-->delta(0)+n *
17434* 6 n+n-->delta(-)+p *
17435* 7 n+p-->N*(0)(1440)+p *
17436* 8 n+p-->N*(+)(1440)+n *
17437* 9 p+p-->N*(+)(1535)+p *
17438* 10 n+n-->N*(0)(1535)+n *
17439* 11 n+p-->N*(+)(1535)+n *
17440* 12 n+p-->N*(0)(1535)+p
17441* 13 D(++)+D(-)-->N*(+)(1440)+n
17442* 14 D(++)+D(-)-->N*(0)(1440)+p
17443* 15 D(+)+D(0)--->N*(+)(1440)+n
17444* 16 D(+)+D(0)--->N*(0)(1440)+p
17445* 17 D(++)+D(0)-->N*(+)(1535)+p
17446* 18 D(++)+D(-)-->N*(0)(1535)+p
17447* 19 D(++)+D(-)-->N*(+)(1535)+n
17448* 20 D(+)+D(+)-->N*(+)(1535)+p
17449* 21 D(+)+D(0)-->N*(+)(1535)+n
17450* 22 D(+)+D(0)-->N*(0)(1535)+p
17451* 23 D(+)+D(-)-->N*(0)(1535)+n
17452* 24 D(0)+D(0)-->N*(0)(1535)+n
17453* 25 N*(+)(14)+N*(+)(14)-->N*(+)(15)+p
17454* 26 N*(0)(14)+N*(0)(14)-->N*(0)(15)+n
17455* 27 N*(+)(14)+N*(0)(14)-->N*(+)(15)+n
17456* 28 N*(+)(14)+N*(0)(14)-->N*(0)(15)+p
17457* 29 N*(+)(14)+D+-->N*(+)(15)+p
17458* 30 N*(+)(14)+D0-->N*(+)(15)+n
17459* 31 N*(+)(14)+D(-)-->N*(0)(1535)+n
17460* 32 N*(0)(14)+D++--->N*(+)(15)+p
17461* 33 N*(0)(14)+D+--->N*(+)(15)+n
17462* 34 N*(0)(14)+D+--->N*(0)(15)+p
17463* 35 N*(0)(14)+D0-->N*(0)(15)+n
17464* 36 N*(+)(14)+D0--->N*(0)(15)+p
17465* +++
17466* AND MORE CHANNELS AS LISTED IN THE NOTE BOOK
17467*
17468* NOTE ABOUT N*(1440) RESORANCE: *
17469* As it has been discussed in VerWest's paper,I= 1 (initial isospin)
17470* channel can all be attributed to delta resorance while I= 0 *
17471* channel can all be attribured to N* resorance.Only in n+p *
17472* one can have I=0 channel so is the N*(1440) resorance *
17473* REFERENCES: J. CUGNON ET AL., NUCL. PHYS. A352, 505 (1981) *
17474* Y. KITAZOE ET AL., PHYS. LETT. 166B, 35 (1986) *
17475* B. VerWest el al., PHYS. PRV. C25 (1982)1979 *
17476* Gy. Wolf et al, Nucl Phys A517 (1990) 615 *
17477* CUTOFF = 2 * AVMASS + 20 MEV *
17478* *
17479* for N*(1535) we use the parameterization by Gy. Wolf et al *
17480* Nucl phys A552 (1993) 349, added May 18, 1994 *
17481**********************************
17482 PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
17483 1 AMP=0.93828,AP1=0.13496,AKA=0.498,APHI=1.020,
17484 2 AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
17485 parameter (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
17486 COMMON /AA/ R(3,MAXSTR)
17487cc SAVE /AA/
17488 COMMON /BB/ P(3,MAXSTR)
17489cc SAVE /BB/
17490 COMMON /CC/ E(MAXSTR)
17491cc SAVE /CC/
17492 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
17493cc SAVE /EE/
17494 common /ff/f(-mx:mx,-my:my,-mz:mz,-mpx:mpx,-mpy:mpy,-mpz:mpzp)
17495cc SAVE /ff/
17496 common /gg/ dx,dy,dz,dpx,dpy,dpz
17497cc SAVE /gg/
17498 COMMON /INPUT/ NSTAR,NDIRCT,DIR
17499cc SAVE /INPUT/
17500 COMMON /NN/NNN
17501cc SAVE /NN/
17502 COMMON /BG/BETAX,BETAY,BETAZ,GAMMA
17503cc SAVE /BG/
17504 COMMON /RUN/NUM
17505cc SAVE /RUN/
17506 COMMON /PA/RPION(3,MAXSTR,MAXR)
17507cc SAVE /PA/
17508 COMMON /PB/PPION(3,MAXSTR,MAXR)
17509cc SAVE /PB/
17510 COMMON /PC/EPION(MAXSTR,MAXR)
17511cc SAVE /PC/
17512 COMMON /PD/LPION(MAXSTR,MAXR)
17513cc SAVE /PD/
17514 common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
17515cc SAVE /input1/
17516 SAVE
17517*-----------------------------------------------------------------------
17518 XINEL=0
17519 SIGK=0
17520 XSK1=0
17521 XSK2=0
17522 XSK3=0
17523 XSK4=0
17524 XSK5=0
17525 EM1=E(I1)
17526 EM2=E(I2)
17527 PR = SQRT( PX**2 + PY**2 + PZ**2 )
17528* IF THERE WERE 2 N*(1535) AND THEY DIDN'T SCATT. ELAST.,
17529* ALLOW THEM TO PRODUCE KAONS. NO OTHER INELASTIC CHANNELS
17530* ARE KNOWN
17531C if((lb(i1).ge.12).and.(lb(i2).ge.12))return
17532* ALL the inelastic collisions between N*(1535) and Delta as well
17533* as N*(1440) TO PRODUCE KAONS, NO OTHER CHANNELS ARE KNOWN
17534C if((lb(i1).ge.12).and.(lb(i2).ge.3))return
17535C if((lb(i2).ge.12).and.(lb(i1).ge.3))return
17536* calculate the N*(1535) production cross section in I1+I2 collisions
17537 call N1535(iabs(lb(i1)),iabs(lb(i2)),srt,X1535)
17538c
17539* for Delta+Delta-->N*(1440 OR 1535)+N AND N*(1440)+N*(1440)-->N*(1535)+X
17540* AND DELTA+N*(1440)-->N*(1535)+X
17541* WE ASSUME THEY HAVE THE SAME CROSS SECTIONS as CORRESPONDING N+N COLLISION):
17542* FOR D++D0, D+D+,D+D-,D0D0,N*+N*+,N*0N*0,N*(+)D+,N*(+)D(-),N*(0)D(0)
17543* N*(1535) production, kaon production and reabsorption through
17544* D(N*)+D(N*)-->NN are ALLOWED.
17545* CROSS SECTION FOR KAON PRODUCTION from the four channels are
17546* for NLK channel
17547 akp=0.498
17548 ak0=0.498
17549 ana=0.94
17550 ada=1.232
17551 al=1.1157
17552 as=1.1197
17553 xsk1=0
17554 xsk2=0
17555 xsk3=0
17556 xsk4=0
17557 t1nlk=ana+al+akp
17558 if(srt.le.t1nlk)go to 222
17559 XSK1=1.5*PPLPK(SRT)
17560* for DLK channel
17561 t1dlk=ada+al+akp
17562 t2dlk=ada+al-akp
17563 if(srt.le.t1dlk)go to 222
17564 es=srt
17565 pmdlk2=(es**2-t1dlk**2)*(es**2-t2dlk**2)/(4.*es**2)
17566 pmdlk=sqrt(pmdlk2)
17567 XSK3=1.5*PPLPK(srt)
17568* for NSK channel
17569 t1nsk=ana+as+akp
17570 t2nsk=ana+as-akp
17571 if(srt.le.t1nsk)go to 222
17572 pmnsk2=(es**2-t1nsk**2)*(es**2-t2nsk**2)/(4.*es**2)
17573 pmnsk=sqrt(pmnsk2)
17574 XSK2=1.5*(PPK1(srt)+PPK0(srt))
17575* for DSK channel
17576 t1DSk=aDa+aS+akp
17577 t2DSk=aDa+aS-akp
17578 if(srt.le.t1dsk)go to 222
17579 pmDSk2=(es**2-t1DSk**2)*(es**2-t2DSk**2)/(4.*es**2)
17580 pmDSk=sqrt(pmDSk2)
17581 XSK4=1.5*(PPK1(srt)+PPK0(srt))
17582csp11/21/01
17583c phi production
17584 if(srt.le.(2.*amn+aphi))go to 222
17585c !! mb put the correct form
17586 xsk5 = 0.0001
17587csp11/21/01 end
17588* THE TOTAL KAON+ PRODUCTION CROSS SECTION IS THEN
17589222 SIGK=XSK1+XSK2+XSK3+XSK4
17590
17591cbz3/7/99 neutralk
17592 XSK1 = 2.0 * XSK1
17593 XSK2 = 2.0 * XSK2
17594 XSK3 = 2.0 * XSK3
17595 XSK4 = 2.0 * XSK4
17596 SIGK = 2.0 * SIGK + xsk5
17597cbz3/7/99 neutralk end
17598
17599 IDD=iabs(LB(I1)*LB(I2))
17600* The reabsorption cross section for the process
17601* D(N*)D(N*)-->NN is
17602 s2d=reab2d(i1,i2,srt)
17603
17604cbz3/16/99 pion
17605 S2D = 0.
17606cbz3/16/99 pion end
17607
17608*(1) N*(1535)+D(N*(1440)) reactions
17609* we allow kaon production and reabsorption only
17610 if(((iabs(lb(i1)).ge.12).and.(iabs(lb(i2)).ge.12)).OR.
17611 & ((iabs(lb(i1)).ge.12).and.(iabs(lb(i2)).ge.6)).OR.
17612 & ((iabs(lb(i2)).ge.12).and.(iabs(lb(i1)).ge.6)))THEN
17613 XINEL=sigk+s2d
17614 RETURN
17615 ENDIF
17616* channels have the same charge as pp
17617 IF((IDD.EQ.63).OR.(IDD.EQ.64).OR.(IDD.EQ.48).
17618 1 OR.(IDD.EQ.49).OR.(IDD.EQ.11*11).OR.(IDD.EQ.10*10).
17619 2 OR.(IDD.EQ.88).OR.(IDD.EQ.66).
17620 3 OR.(IDD.EQ.90).OR.(IDD.EQ.70))THEN
17621 XINEL=X1535+SIGK+s2d
17622 RETURN
17623 ENDIF
17624* IN DELTA+N*(1440) and N*(1440)+N*(1440) COLLISIONS,
17625* N*(1535), kaon production and reabsorption are ALLOWED
17626* IN N*(1440)+N*(1440) COLLISIONS, ONLY N*(1535) IS ALLOWED
17627 IF((IDD.EQ.110).OR.(IDD.EQ.77).OR.(IDD.EQ.80))THEN
17628 XINEL=X1535+SIGK+s2d
17629 RETURN
17630 ENDIF
17631 IF((IDD.EQ.54).OR.(IDD.EQ.56))THEN
17632* LIKE FOR N+P COLLISION,
17633* IN DELTA+DELTA COLLISIONS BOTH N*(1440) AND N*(1535) CAN BE PRODUCED
17634 SIG2=(3./4.)*SIGMA(SRT,2,0,1)
17635 XINEL=2.*(SIG2+X1535)+SIGK+s2d
17636 RETURN
17637 ENDIF
17638 RETURN
17639 END
17640******************************************
17641 real function dirct1(srt)
17642* This function contains the experimental, direct pion(+) + p cross sections *
17643* srt = DSQRT(s) in GeV *
17644* dirct1 = cross section in fm**2 *
17645* earray = EXPerimental table with the srt
17646* xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
17647******************************************
17648c real*4 xarray(122), earray(122)
17649 real xarray(122), earray(122)
17650 SAVE
17651 data earray /
17652 &1.568300,1.578300,1.588300,1.598300,1.608300,1.618300,1.628300,
17653 &1.638300,1.648300,1.658300,1.668300,1.678300,1.688300,1.698300,
17654 &1.708300,1.718300,1.728300,1.738300,1.748300,1.758300,1.768300,
17655 &1.778300,1.788300,1.798300,1.808300,1.818300,1.828300,1.838300,
17656 &1.848300,1.858300,1.868300,1.878300,1.888300,1.898300,1.908300,
17657 &1.918300,1.928300,1.938300,1.948300,1.958300,1.968300,1.978300,
17658 &1.988300,1.998300,2.008300,2.018300,2.028300,2.038300,2.048300,
17659 &2.058300,2.068300,2.078300,2.088300,2.098300,2.108300,2.118300,
17660 &2.128300,2.138300,2.148300,2.158300,2.168300,2.178300,2.188300,
17661 &2.198300,2.208300,2.218300,2.228300,2.238300,2.248300,2.258300,
17662 &2.268300,2.278300,2.288300,2.298300,2.308300,2.318300,2.328300,
17663 &2.338300,2.348300,2.358300,2.368300,2.378300,2.388300,2.398300,
17664 &2.408300,2.418300,2.428300,2.438300,2.448300,2.458300,2.468300,
17665 &2.478300,2.488300,2.498300,2.508300,2.518300,2.528300,2.538300,
17666 &2.548300,2.558300,2.568300,2.578300,2.588300,2.598300,2.608300,
17667 &2.618300,2.628300,2.638300,2.648300,2.658300,2.668300,2.678300,
17668 &2.688300,2.698300,2.708300,2.718300,2.728300,2.738300,2.748300,
17669 &2.758300,2.768300,2.778300/
17670 data xarray/
17671 &1.7764091E-02,0.5643668,0.8150568,1.045565,2.133695,3.327922,
17672 &4.206488,3.471242,4.486876,5.542213,6.800052,7.192446,6.829848,
17673 &6.580306,6.868410,8.527946,10.15720,9.716511,9.298335,8.901310,
17674 &10.31213,10.52185,11.17630,11.61639,12.05577,12.71596,13.46036,
17675 &14.22060,14.65449,14.94775,14.93310,15.32907,16.56481,16.29422,
17676 &15.18548,14.12658,13.72544,13.24488,13.31003,14.42680,12.84423,
17677 &12.49025,12.14858,11.81870,11.18993,11.35816,11.09447,10.83873,
17678 &10.61592,10.53754,9.425521,8.195912,9.661075,9.696192,9.200142,
17679 &8.953734,8.715461,8.484999,8.320765,8.255512,8.190969,8.127125,
17680 &8.079508,8.073004,8.010611,7.948909,7.887895,7.761005,7.626290,
17681 &7.494696,7.366132,7.530178,8.392097,9.046881,8.962544,8.879403,
17682 &8.797427,8.716601,8.636904,8.558312,8.404368,8.328978,8.254617,
17683 &8.181265,8.108907,8.037527,7.967100,7.897617,7.829057,7.761405,
17684 &7.694647,7.628764,7.563742,7.499570,7.387562,7.273281,7.161334,
17685 &6.973375,6.529592,6.280323,6.293136,6.305725,6.318097,6.330258,
17686 &6.342214,6.353968,6.365528,6.376895,6.388079,6.399081,6.409906,
17687 &6.420560,6.431045,6.441367,6.451529,6.461533,6.471386,6.481091,
17688 &6.490650,6.476413,6.297259,6.097826/
17689
17690 dirct1=0
17691 if (srt .lt. earray(1)) then
17692 dirct1 = 0.00001
17693 return
17694 end if
17695 if (srt .gt. earray(122)) then
17696 dirct1 = xarray(122)
17697 dirct1=dirct1/10.
17698 return
17699 end if
17700*
17701*Interpolate double logarithmically to find xdirct2(srt)
17702*
17703 do 1001 ie = 1,122
17704 if (earray(ie) .eq. srt) then
17705 dirct1= xarray(ie)
17706 dirct1=dirct1/10.
17707 return
17708 endif
17709 if (earray(ie) .gt. srt) then
17710 ymin = alog(xarray(ie-1))
17711 ymax = alog(xarray(ie))
17712 xmin = alog(earray(ie-1))
17713 xmax = alog(earray(ie))
17714 dirct1= exp(ymin + (alog(srt)-xmin)
17715 & *(ymax-ymin)/(xmax-xmin) )
17716 dirct1=dirct1/10.
17717 go to 50
17718 end if
17719 1001 continue
1772050 continue
17721 return
17722 END
17723*******************************
17724******************************************
17725 real function dirct2(srt)
17726* This function contains the experimental, direct pion(-) + p cross sections *
17727* srt = DSQRT(s) in GeV *
17728* dirct2 = cross section in fm**2
17729* earray = EXPerimental table with the srt
17730* xarray = EXPerimental table with cross sections in mb (curve to guide eye) *
17731******************************************
17732c real*4 xarray(122), earray(122)
17733 real xarray(122), earray(122)
17734 SAVE
17735 data earray /
17736 &1.568300,1.578300,1.588300,1.598300,1.608300,1.618300,1.628300,
17737 &1.638300,1.648300,1.658300,1.668300,1.678300,1.688300,1.698300,
17738 &1.708300,1.718300,1.728300,1.738300,1.748300,1.758300,1.768300,
17739 &1.778300,1.788300,1.798300,1.808300,1.818300,1.828300,1.838300,
17740 &1.848300,1.858300,1.868300,1.878300,1.888300,1.898300,1.908300,
17741 &1.918300,1.928300,1.938300,1.948300,1.958300,1.968300,1.978300,
17742 &1.988300,1.998300,2.008300,2.018300,2.028300,2.038300,2.048300,
17743 &2.058300,2.068300,2.078300,2.088300,2.098300,2.108300,2.118300,
17744 &2.128300,2.138300,2.148300,2.158300,2.168300,2.178300,2.188300,
17745 &2.198300,2.208300,2.218300,2.228300,2.238300,2.248300,2.258300,
17746 &2.268300,2.278300,2.288300,2.298300,2.308300,2.318300,2.328300,
17747 &2.338300,2.348300,2.358300,2.368300,2.378300,2.388300,2.398300,
17748 &2.408300,2.418300,2.428300,2.438300,2.448300,2.458300,2.468300,
17749 &2.478300,2.488300,2.498300,2.508300,2.518300,2.528300,2.538300,
17750 &2.548300,2.558300,2.568300,2.578300,2.588300,2.598300,2.608300,
17751 &2.618300,2.628300,2.638300,2.648300,2.658300,2.668300,2.678300,
17752 &2.688300,2.698300,2.708300,2.718300,2.728300,2.738300,2.748300,
17753 &2.758300,2.768300,2.778300/
17754 data xarray/0.5773182,1.404156,2.578629,3.832013,4.906011,
17755 &9.076963,13.10492,10.65975,15.31156,19.77611,19.92874,18.68979,
17756 &19.80114,18.39536,14.34269,13.35353,13.58822,14.57031,10.24686,
17757 &11.23386,9.764803,10.35652,10.53539,10.07524,9.582198,9.596469,
17758 &9.818489,9.012848,9.378012,9.529244,9.529698,8.835624,6.671396,
17759 &8.797758,8.133437,7.866227,7.823946,7.808504,7.791755,7.502062,
17760 &7.417275,7.592349,7.752028,7.910585,8.068122,8.224736,8.075289,
17761 &7.895902,7.721359,7.551512,7.386224,7.225343,7.068739,6.916284,
17762 &6.767842,6.623294,6.482520,6.345404,6.211833,7.339510,7.531462,
17763 &7.724824,7.919620,7.848021,7.639856,7.571083,7.508881,7.447474,
17764 &7.386855,7.327011,7.164454,7.001266,6.842526,6.688094,6.537823,
17765 &6.391583,6.249249,6.110689,5.975790,5.894200,5.959503,6.024602,
17766 &6.089505,6.154224,6.218760,6.283128,6.347331,6.297411,6.120248,
17767 &5.948606,6.494864,6.357106,6.222824,6.091910,5.964267,5.839795,
17768 &5.718402,5.599994,5.499146,5.451325,5.404156,5.357625,5.311721,
17769 &5.266435,5.301964,5.343963,5.385833,5.427577,5.469200,5.510702,
17770 &5.552088,5.593359,5.634520,5.675570,5.716515,5.757356,5.798093,
17771 &5.838732,5.879272,5.919717,5.960068,5.980941/
17772
17773 dirct2=0.
17774 if (srt .lt. earray(1)) then
17775 dirct2 = 0.00001
17776 return
17777 end if
17778 if (srt .gt. earray(122)) then
17779 dirct2 = xarray(122)
17780 dirct2=dirct2/10.
17781 return
17782 end if
17783*
17784*Interpolate double logarithmically to find xdirct2(srt)
17785*
17786 do 1001 ie = 1,122
17787 if (earray(ie) .eq. srt) then
17788 dirct2= xarray(ie)
17789 dirct2=dirct2/10.
17790 return
17791 endif
17792 if (earray(ie) .gt. srt) then
17793 ymin = alog(xarray(ie-1))
17794 ymax = alog(xarray(ie))
17795 xmin = alog(earray(ie-1))
17796 xmax = alog(earray(ie))
17797 dirct2= exp(ymin + (alog(srt)-xmin)
17798 & *(ymax-ymin)/(xmax-xmin) )
17799 dirct2=dirct2/10.
17800 go to 50
17801 end if
17802 1001 continue
1780350 continue
17804 return
17805 END
17806*******************************
17807******************************
17808* this program calculates the elastic cross section for rho+nucleon
17809* through higher resonances
17810c real*4 function ErhoN(em1,em2,lb1,lb2,srt)
17811 real function ErhoN(em1,em2,lb1,lb2,srt)
17812* date : Dec. 19, 1994
17813* ****************************
17814c implicit real*4 (a-h,o-z)
17815 dimension arrayj(19),arrayl(19),arraym(19),
17816 &arrayw(19),arrayb(19)
17817 SAVE
17818 data arrayj /0.5,1.5,0.5,0.5,2.5,2.5,1.5,0.5,1.5,3.5,
17819 &1.5,0.5,1.5,0.5,2.5,0.5,1.5,2.5,3.5/
17820 data arrayl/1,2,0,0,2,3,2,1,1,3,
17821 &1,0,2,0,3,1,1,2,3/
17822 data arraym /1.44,1.52,1.535,1.65,1.675,1.68,1.70,1.71,
17823 &1.72,1.99,1.60,1.62,1.70,1.90,1.905,1.910,
17824 &1.86,1.93,1.95/
17825 data arrayw/0.2,0.125,0.15,0.15,0.155,0.125,0.1,0.11,
17826 &0.2,0.29,0.25,0.16,0.28,0.15,0.3,0.22,0.25,
17827 &0.25,0.24/
17828 data arrayb/0.15,0.20,0.05,0.175,0.025,0.125,0.1,0.20,
17829 &0.53,0.34,0.05,0.07,0.15,0.45,0.45,0.058,
17830 &0.08,0.12,0.08/
17831
17832* the minimum energy for pion+delta collision
17833 pi=3.1415926
17834 xs=0
17835* include contribution from each resonance
17836 do 1001 ir=1,19
17837cbz11/25/98
17838 IF(IR.LE.8)THEN
17839c if(lb1*lb2.eq.27.OR.LB1*LB2.EQ.25*2)branch=0.
17840c if(lb1*lb2.eq.26.OR.LB1*LB2.EQ.26*2)branch=1./3.
17841c if(lb1*lb2.eq.27*2.OR.LB1*LB2.EQ.25)branch=2./3.
17842c ELSE
17843c if(lb1*lb2.eq.27.OR.LB1*LB2.EQ.25*2)branch=1.
17844c if(lb1*lb2.eq.26.OR.LB1*LB2.EQ.26*2)branch=2./3.
17845c if(lb1*lb2.eq.27*2.OR.LB1*LB2.EQ.25)branch=1./3.
17846c ENDIF
17847 if( ((lb1*lb2.eq.27.AND.(LB1.EQ.1.OR.LB2.EQ.1)).OR.
17848 & (LB1*LB2.EQ.25*2.AND.(LB1.EQ.2.OR.LB2.EQ.2)))
17849 & .OR.((lb1*lb2.eq.-25.AND.(LB1.EQ.-1.OR.LB2.EQ.-1)).OR.
17850 & (LB1*LB2.EQ.-27*2.AND.(LB1.EQ.-2.OR.LB2.EQ.-2))) )
17851 & branch=0.
17852 if((iabs(lb1*lb2).eq.26.AND.(iabs(LB1).EQ.1.OR.iabs(LB2).EQ.1))
17853 & .OR.(iabs(LB1*LB2).EQ.26*2
17854 & .AND.(iabs(LB1).EQ.2.OR.iabs(LB2).EQ.2)))
17855 & branch=1./3.
17856 if( ((lb1*lb2.eq.27*2.AND.(LB1.EQ.2.OR.LB2.EQ.2)).OR.
17857 & (LB1*LB2.EQ.25.AND.(LB1.EQ.1.OR.LB2.EQ.1)))
17858 & .OR.((lb1*lb2.eq.-25*2.AND.(LB1.EQ.-2.OR.LB2.EQ.-2)).OR.
17859 & (LB1*LB2.EQ.-27.AND.(LB1.EQ.-1.OR.LB2.EQ.-1))) )
17860 & branch=2./3.
17861 ELSE
17862 if( ((lb1*lb2.eq.27.AND.(LB1.EQ.1.OR.LB2.EQ.1)).OR.
17863 & (LB1*LB2.EQ.25*2.AND.(LB1.EQ.2.OR.LB2.EQ.2)))
17864 & .OR.((lb1*lb2.eq.-25.AND.(LB1.EQ.-1.OR.LB2.EQ.-1)).OR.
17865 & (LB1*LB2.EQ.-27*2.AND.(LB1.EQ.-2.OR.LB2.EQ.-2))) )
17866 & branch=1.
17867 if((iabs(lb1*lb2).eq.26.AND.(iabs(LB1).EQ.1.OR.iabs(LB2).EQ.1))
17868 & .OR.(iabs(LB1*LB2).EQ.26*2
17869 & .AND.(iabs(LB1).EQ.2.OR.iabs(LB2).EQ.2)))
17870 & branch=2./3.
17871 if( ((lb1*lb2.eq.27*2.AND.(LB1.EQ.2.OR.LB2.EQ.2)).OR.
17872 & (LB1*LB2.EQ.25.AND.(LB1.EQ.1.OR.LB2.EQ.1)))
17873 & .OR.((lb1*lb2.eq.-25*2.AND.(LB1.EQ.-2.OR.LB2.EQ.-2)).OR.
17874 & (LB1*LB2.EQ.-27.AND.(LB1.EQ.-1.OR.LB2.EQ.-1))) )
17875 & branch=1./3.
17876 ENDIF
17877cbz11/25/98end
17878 xs0=fdR(arraym(ir),arrayj(ir),arrayl(ir),
17879 &arrayw(ir),arrayb(ir),srt,EM1,EM2)
17880 xs=xs+1.3*pi*branch*xs0*(0.1973)**2
17881 1001 continue
17882 Erhon=xs
17883 return
17884 end
17885***************************8
17886*FUNCTION FDE(DMASS) GIVES DELTA MASS DISTRIBUTION BY USING OF
17887*KITAZOE'S FORMULA
17888c REAL*4 FUNCTION FDR(DMASS,aj,al,width,widb0,srt,em1,em2)
17889 REAL FUNCTION FDR(DMASS,aj,al,width,widb0,srt,em1,em2)
17890 SAVE
17891 AMd=em1
17892 AmP=em2
17893 Ak02= 0.25*(DMASS**2-amd**2-amp**2)**2
17894 & -(Amp*amd)**2
17895 IF (ak02 .GT. 0.) THEN
17896 Q0 = SQRT(ak02/DMASS)
17897 ELSE
17898 Q0= 0.0
17899 fdR=0
17900 return
17901 END IF
17902 Ak2= 0.25*(srt**2-amd**2-amp**2)**2
17903 & -(Amp*amd)**2
17904 IF (ak2 .GT. 0.) THEN
17905 Q = SQRT(ak2/DMASS)
17906 ELSE
17907 Q= 0.00
17908 fdR=0
17909 return
17910 END IF
17911 b=widb0*1.2*dmass/srt*(q/q0)**(2.*al+1)
17912 & /(1.+0.2*(q/q0)**(2*al))
17913 FDR=(2.*aj+1)*WIDTH**2*b/((srt-dmass)**2
17914 1 +0.25*WIDTH**2)/(6.*q**2)
17915 RETURN
17916 END
17917******************************
17918* this program calculates the elastic cross section for pion+delta
17919* through higher resonances
17920c REAL*4 FUNCTION DIRCT3(SRT)
17921 REAL FUNCTION DIRCT3(SRT)
17922* date : Dec. 19, 1994
17923* ****************************
17924c implicit real*4 (a-h,o-z)
17925 dimension arrayj(17),arrayl(17),arraym(17),
17926 &arrayw(17),arrayb(17)
17927 SAVE
17928 data arrayj /1.5,0.5,2.5,2.5,1.5,0.5,1.5,3.5,
17929 &1.5,0.5,1.5,0.5,2.5,0.5,1.5,2.5,3.5/
17930 data arrayl/2,0,2,3,2,1,1,3,
17931 &1,0,2,0,3,1,1,2,3/
17932 data arraym /1.52,1.65,1.675,1.68,1.70,1.71,
17933 &1.72,1.99,1.60,1.62,1.70,1.90,1.905,1.910,
17934 &1.86,1.93,1.95/
17935 data arrayw/0.125,0.15,0.155,0.125,0.1,0.11,
17936 &0.2,0.29,0.25,0.16,0.28,0.15,0.3,0.22,0.25,
17937 &0.25,0.24/
17938 data arrayb/0.55,0.6,0.375,0.6,0.1,0.15,
17939 &0.15,0.05,0.35,0.3,0.15,0.1,0.1,0.22,
17940 &0.2,0.09,0.4/
17941
17942* the minimum energy for pion+delta collision
17943 pi=3.1415926
17944 amn=0.938
17945 amp=0.138
17946 xs=0
17947* include contribution from each resonance
17948 branch=1./3.
17949 do 1001 ir=1,17
17950 if(ir.gt.8)branch=2./3.
17951 xs0=fd1(arraym(ir),arrayj(ir),arrayl(ir),
17952 &arrayw(ir),arrayb(ir),srt)
17953 xs=xs+1.3*pi*branch*xs0*(0.1973)**2
17954 1001 continue
17955 DIRCT3=XS
17956 RETURN
17957 end
17958***************************8
17959*FUNCTION FDE(DMASS) GIVES DELTA MASS DISTRIBUTION BY USING OF
17960*KITAZOE'S FORMULA
17961c REAL*4 FUNCTION FD1(DMASS,aj,al,width,widb0,srt)
17962 REAL FUNCTION FD1(DMASS,aj,al,width,widb0,srt)
17963 SAVE
17964 AMN=0.938
17965 AmP=0.138
17966 amd=amn
17967 Ak02= 0.25*(DMASS**2-amd**2-amp**2)**2
17968 & -(Amp*amd)**2
17969 IF (ak02 .GT. 0.) THEN
17970 Q0 = SQRT(ak02/DMASS)
17971 ELSE
17972 Q0= 0.0
17973 fd1=0
17974 return
17975 END IF
17976 Ak2= 0.25*(srt**2-amd**2-amp**2)**2
17977 & -(Amp*amd)**2
17978 IF (ak2 .GT. 0.) THEN
17979 Q = SQRT(ak2/DMASS)
17980 ELSE
17981 Q= 0.00
17982 fd1=0
17983 return
17984 END IF
17985 b=widb0*1.2*dmass/srt*(q/q0)**(2.*al+1)
17986 & /(1.+0.2*(q/q0)**(2*al))
17987 FD1=(2.*aj+1)*WIDTH**2*b/((srt-dmass)**2
17988 1 +0.25*WIDTH**2)/(2.*q**2)
17989 RETURN
17990 END
17991******************************
17992* this program calculates the elastic cross section for pion+delta
17993* through higher resonances
17994c REAL*4 FUNCTION DPION(EM1,EM2,LB1,LB2,SRT)
17995 REAL FUNCTION DPION(EM1,EM2,LB1,LB2,SRT)
17996* date : Dec. 19, 1994
17997* ****************************
17998c implicit real*4 (a-h,o-z)
17999 dimension arrayj(19),arrayl(19),arraym(19),
18000 &arrayw(19),arrayb(19)
18001 SAVE
18002 data arrayj /0.5,1.5,0.5,0.5,2.5,2.5,1.5,0.5,1.5,3.5,
18003 &1.5,0.5,1.5,0.5,2.5,0.5,1.5,2.5,3.5/
18004 data arrayl/1,2,0,0,2,3,2,1,1,3,
18005 &1,0,2,0,3,1,1,2,3/
18006 data arraym /1.44,1.52,1.535,1.65,1.675,1.68,1.70,1.71,
18007 &1.72,1.99,1.60,1.62,1.70,1.90,1.905,1.910,
18008 &1.86,1.93,1.95/
18009 data arrayw/0.2,0.125,0.15,0.15,0.155,0.125,0.1,0.11,
18010 &0.2,0.29,0.25,0.16,0.28,0.15,0.3,0.22,0.25,
18011 &0.25,0.24/
18012 data arrayb/0.15,0.25,0.,0.05,0.575,0.125,0.379,0.10,
18013 &0.10,0.062,0.45,0.60,0.6984,0.05,0.25,0.089,
18014 &0.19,0.2,0.13/
18015
18016* the minimum energy for pion+delta collision
18017 pi=3.1415926
18018 amn=0.94
18019 amp=0.14
18020 xs=0
18021* include contribution from each resonance
18022 do 1001 ir=1,19
18023 BRANCH=0.
18024cbz11/25/98
18025 if(ir.LE.8)THEN
18026c IF(LB1*LB2.EQ.5*7.OR.LB1*LB2.EQ.3*8)branch=1./6.
18027c IF(LB1*LB2.EQ.4*7.OR.LB1*LB2.EQ.4*8)branch=1./3.
18028c IF(LB1*LB2.EQ.5*6.OR.LB1*LB2.EQ.3*9)branch=1./2.
18029c ELSE
18030c IF(LB1*LB2.EQ.5*8.OR.LB1*LB2.EQ.5*6)branch=2./5.
18031c IF(LB1*LB2.EQ.3*9.OR.LB1*LB2.EQ.3*7)branch=2./5.
18032c IF(LB1*LB2.EQ.5*7.OR.LB1*LB2.EQ.3*8)branch=8./15.
18033c IF(LB1*LB2.EQ.4*7.OR.LB1*LB2.EQ.4*8)branch=1./15.
18034c IF(LB1*LB2.EQ.4*9.OR.LB1*LB2.EQ.4*6)branch=3./5.
18035c ENDIF
18036 IF( ((LB1*LB2.EQ.5*7.AND.(LB1.EQ.5.OR.LB2.EQ.5)).OR.
18037 & (LB1*LB2.EQ.3*8.AND.(LB1.EQ.3.OR.LB2.EQ.3)))
18038 & .OR.((LB1*LB2.EQ.-3*7.AND.(LB1.EQ.3.OR.LB2.EQ.3)).OR.
18039 & (LB1*LB2.EQ.-5*8.AND.(LB1.EQ.5.OR.LB2.EQ.5))) )
18040 & branch=1./6.
18041 IF((iabs(LB1*LB2).EQ.4*7.AND.(LB1.EQ.4.OR.LB2.EQ.4)).OR.
18042 & (iabs(LB1*LB2).EQ.4*8.AND.(LB1.EQ.4.OR.LB2.EQ.4)))
18043 & branch=1./3.
18044 IF( ((LB1*LB2.EQ.5*6.AND.(LB1.EQ.5.OR.LB2.EQ.5)).OR.
18045 & (LB1*LB2.EQ.3*9.AND.(LB1.EQ.3.OR.LB2.EQ.3)))
18046 & .OR.((LB1*LB2.EQ.-3*6.AND.(LB1.EQ.3.OR.LB2.EQ.3)).OR.
18047 & (LB1*LB2.EQ.-5*9.AND.(LB1.EQ.5.OR.LB2.EQ.5))) )
18048 & branch=1./2.
18049 ELSE
18050 IF( ((LB1*LB2.EQ.5*8.AND.(LB1.EQ.5.OR.LB2.EQ.5)).OR.
18051 & (LB1*LB2.EQ.5*6.AND.(LB1.EQ.5.OR.LB2.EQ.5)))
18052 & .OR.((LB1*LB2.EQ.-3*8.AND.(LB1.EQ.3.OR.LB2.EQ.3)).OR.
18053 & (LB1*LB2.EQ.-3*6.AND.(LB1.EQ.3.OR.LB2.EQ.3))) )
18054 & branch=2./5.
18055 IF( ((LB1*LB2.EQ.3*9.AND.(LB1.EQ.3.OR.LB2.EQ.3)).OR.
18056 & (LB1*LB2.EQ.3*7.AND.(LB1.EQ.3.OR.LB2.EQ.3)))
18057 & .OR. ((LB1*LB2.EQ.-5*9.AND.(LB1.EQ.5.OR.LB2.EQ.5)).OR.
18058 & (LB1*LB2.EQ.-5*7.AND.(LB1.EQ.5.OR.LB2.EQ.5))) )
18059 & branch=2./5.
18060 IF( ((LB1*LB2.EQ.5*7.AND.(LB1.EQ.5.OR.LB2.EQ.5)).OR.
18061 & (LB1*LB2.EQ.3*8.AND.(LB1.EQ.3.OR.LB2.EQ.3)))
18062 & .OR.((LB1*LB2.EQ.-3*7.AND.(LB1.EQ.3.OR.LB2.EQ.3)).OR.
18063 & (LB1*LB2.EQ.-5*8.AND.(LB1.EQ.5.OR.LB2.EQ.5))) )
18064 & branch=8./15.
18065 IF((iabs(LB1*LB2).EQ.4*7.AND.(LB1.EQ.4.OR.LB2.EQ.4)).OR.
18066 & (iabs(LB1*LB2).EQ.4*8.AND.(LB1.EQ.4.OR.LB2.EQ.4)))
18067 & branch=1./15.
18068 IF((iabs(LB1*LB2).EQ.4*9.AND.(LB1.EQ.4.OR.LB2.EQ.4)).OR.
18069 & (iabs(LB1*LB2).EQ.4*6.AND.(LB1.EQ.4.OR.LB2.EQ.4)))
18070 & branch=3./5.
18071 ENDIF
18072cbz11/25/98end
18073 xs0=fd2(arraym(ir),arrayj(ir),arrayl(ir),
18074 &arrayw(ir),arrayb(ir),EM1,EM2,srt)
18075 xs=xs+1.3*pi*branch*xs0*(0.1973)**2
18076 1001 continue
18077 DPION=XS
18078 RETURN
18079 end
18080***************************8
18081*FUNCTION FDE(DMASS) GIVES DELTA MASS DISTRIBUTION BY USING OF
18082*KITAZOE'S FORMULA
18083c REAL*4 FUNCTION FD2(DMASS,aj,al,width,widb0,EM1,EM2,srt)
18084 REAL FUNCTION FD2(DMASS,aj,al,width,widb0,EM1,EM2,srt)
18085 SAVE
18086 AmP=EM1
18087 amd=EM2
18088 Ak02= 0.25*(DMASS**2-amd**2-amp**2)**2
18089 & -(Amp*amd)**2
18090 IF (ak02 .GT. 0.) THEN
18091 Q0 = SQRT(ak02/DMASS)
18092 ELSE
18093 Q0= 0.0
18094 fd2=0
18095 return
18096 END IF
18097 Ak2= 0.25*(srt**2-amd**2-amp**2)**2
18098 & -(Amp*amd)**2
18099 IF (ak2 .GT. 0.) THEN
18100 Q = SQRT(ak2/DMASS)
18101 ELSE
18102 Q= 0.00
18103 fd2=0
18104 return
18105 END IF
18106 b=widb0*1.2*dmass/srt*(q/q0)**(2.*al+1)
18107 & /(1.+0.2*(q/q0)**(2*al))
18108 FD2=(2.*aj+1)*WIDTH**2*b/((srt-dmass)**2
18109 1 +0.25*WIDTH**2)/(4.*q**2)
18110 RETURN
18111 END
18112***************************8
18113* MASS GENERATOR for two resonances simultaneously
18114 subroutine Rmasdd(srt,am10,am20,
18115 &dmin1,dmin2,ISEED,ic,dm1,dm2)
18116 COMMON/RNDF77/NSEED
18117cc SAVE /RNDF77/
18118 SAVE
18119 ISEED=ISEED
18120 amn=0.94
18121 amp=0.14
18122* the maximum mass for resonance 1
18123 dmax1=srt-dmin2
18124* generate the mass for the first resonance
18125 5 NTRY1=0
18126 ntry2=0
18127 ntry=0
18128 ictrl=0
1812910 DM1 = RANART(NSEED) * (DMAX1-DMIN1) + DMIN1
18130 NTRY1=NTRY1+1
18131* the maximum mass for resonance 2
18132 if(ictrl.eq.0)dmax2=srt-dm1
18133* generate the mass for the second resonance
1813420 dm2=RANART(NSEED)*(dmax2-dmin2)+dmin2
18135 NTRY2=NTRY2+1
18136* check the energy-momentum conservation with two masses
18137* q2 in the following is q**2*4*srt**2
18138 q2=((srt**2-dm1**2-dm2**2)**2-4.*dm1**2*dm2**2)
18139 if(q2.le.0)then
18140 dmax2=dm2-0.01
18141c dmax1=dm1-0.01
18142 ictrl=1
18143 go to 20
18144 endif
18145* determine the weight of the mass pair
18146 IF(DMAX1.LT.am10) THEN
18147 if(ic.eq.1)FM1=Fmassd(DMAX1)
18148 if(ic.eq.2)FM1=Fmassn(DMAX1)
18149 if(ic.eq.3)FM1=Fmassd(DMAX1)
18150 if(ic.eq.4)FM1=Fmassd(DMAX1)
18151 ELSE
18152 if(ic.eq.1)FM1=Fmassd(am10)
18153 if(ic.eq.2)FM1=Fmassn(am10)
18154 if(ic.eq.3)FM1=Fmassd(am10)
18155 if(ic.eq.4)FM1=Fmassd(am10)
18156 ENDIF
18157 IF(DMAX2.LT.am20) THEN
18158 if(ic.eq.1)FM2=Fmassd(DMAX2)
18159 if(ic.eq.2)FM2=Fmassn(DMAX2)
18160 if(ic.eq.3)FM2=Fmassn(DMAX2)
18161 if(ic.eq.4)FM2=Fmassr(DMAX2)
18162 ELSE
18163 if(ic.eq.1)FM2=Fmassd(am20)
18164 if(ic.eq.2)FM2=Fmassn(am20)
18165 if(ic.eq.3)FM2=Fmassn(am20)
18166 if(ic.eq.4)FM2=Fmassr(am20)
18167 ENDIF
18168 IF(FM1.EQ.0.)FM1=1.e-04
18169 IF(FM2.EQ.0.)FM2=1.e-04
18170 prob0=fm1*fm2
18171 if(ic.eq.1)prob=Fmassd(dm1)*fmassd(dm2)
18172 if(ic.eq.2)prob=Fmassn(dm1)*fmassn(dm2)
18173 if(ic.eq.3)prob=Fmassd(dm1)*fmassn(dm2)
18174 if(ic.eq.4)prob=Fmassd(dm1)*fmassr(dm2)
18175 if(prob.le.1.e-06)prob=1.e-06
18176 fff=prob/prob0
18177 ntry=ntry+1
18178 IF(RANART(NSEED).GT.fff.AND.
18179 1 NTRY.LE.20) GO TO 10
18180
18181clin-2/26/03 limit the mass of (rho,Delta,N*1440) below a certain value
18182c (here taken as its central value + 2* B-W fullwidth):
18183 if((abs(am10-0.77).le.0.01.and.dm1.gt.1.07)
18184 1 .or.(abs(am10-1.232).le.0.01.and.dm1.gt.1.47)
18185 2 .or.(abs(am10-1.44).le.0.01.and.dm1.gt.2.14)) goto 5
18186 if((abs(am20-0.77).le.0.01.and.dm2.gt.1.07)
18187 1 .or.(abs(am20-1.232).le.0.01.and.dm2.gt.1.47)
18188 2 .or.(abs(am20-1.44).le.0.01.and.dm2.gt.2.14)) goto 5
18189
18190 RETURN
18191 END
18192*FUNCTION Fmassd(DMASS) GIVES the delta MASS DISTRIBUTION
18193 REAL FUNCTION Fmassd(DMASS)
18194 SAVE
18195 AM0=1.232
18196 Fmassd=am0*WIDTH(DMASS)/((DMASS**2-am0**2)**2
18197 1 +am0**2*WIDTH(DMASS)**2)
18198 RETURN
18199 END
18200*FUNCTION Fmassn(DMASS) GIVES the N* MASS DISTRIBUTION
18201 REAL FUNCTION Fmassn(DMASS)
18202 SAVE
18203 AM0=1.44
18204 Fmassn=am0*W1440(DMASS)/((DMASS**2-am0**2)**2
18205 1 +am0**2*W1440(DMASS)**2)
18206 RETURN
18207 END
18208*FUNCTION Fmassr(DMASS) GIVES the rho MASS DISTRIBUTION
18209 REAL FUNCTION Fmassr(DMASS)
18210 SAVE
18211 AM0=0.77
18212 wid=0.153
18213 Fmassr=am0*Wid/((DMASS**2-am0**2)**2
18214 1 +am0**2*Wid**2)
18215 RETURN
18216 END
18217**********************************
18218* PURPOSE : flow analysis
18219* DATE : Feb. 1, 1995
18220***********************************
18221 subroutine flow(nt)
18222c IMPLICIT REAL*4 (A-H,O-Z)
18223 PARAMETER ( PI=3.1415926,APion=0.13957,aka=0.498)
18224 PARAMETER (MAXSTR=150001,MAXR=1,AMU= 0.9383,etaM=0.5475)
18225 DIMENSION ypion(-80:80),ypr(-80:80),ykaon(-80:80)
18226 dimension pxpion(-80:80),pxpro(-80:80),pxkaon(-80:80)
18227*----------------------------------------------------------------------*
18228 COMMON /AA/ R(3,MAXSTR)
18229cc SAVE /AA/
18230 COMMON /BB/ P(3,MAXSTR)
18231cc SAVE /BB/
18232 COMMON /CC/ E(MAXSTR)
18233cc SAVE /CC/
18234 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
18235cc SAVE /EE/
18236 COMMON /RR/ MASSR(0:MAXR)
18237cc SAVE /RR/
18238 COMMON /RUN/ NUM
18239cc SAVE /RUN/
18240 common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
18241cc SAVE /input1/
18242 SAVE
18243*----------------------------------------------------------------------*
18244 NT=NT
18245 ycut1=-2.6
18246 ycut2=2.6
18247 DY=0.2
18248 LY=NINT((YCUT2-YCUT1)/DY)
18249***********************************
18250C initialize the transverse momentum counters
18251 do 11 kk=-80,80
18252 pxpion(kk)=0
18253 pxpro(kk)=0
18254 pxkaon(kk)=0
1825511 continue
18256 DO 701 J=-LY,LY
18257 ypion(j)=0
18258 ykaon(j)=0
18259 ypr(j)=0
18260 701 CONTINUE
18261 nkaon=0
18262 npr=0
18263 npion=0
18264 IS=0
18265 DO 20 NRUN=1,NUM
18266 IS=IS+MASSR(NRUN-1)
18267 DO 20 J=1,MASSR(NRUN)
18268 I=J+IS
18269* for protons go to 200 to calculate its rapidity and transvese momentum
18270* distributions
18271 e00=sqrt(P(1,I)**2+P(2,i)**2+P(3,i)**2+e(I)**2)
18272 y00=0.5*alog((e00+p(3,i))/(e00-p(3,i)))
18273 if(abs(y00).ge.ycut2)go to 20
18274 iy=nint(y00/DY)
18275 if(abs(iy).ge.80)go to 20
18276 if(e(i).eq.0)go to 20
18277 if(lb(i).ge.25)go to 20
18278 if((lb(i).le.5).and.(lb(i).ge.3))go to 50
18279 if(lb(i).eq.1.or.lb(i).eq.2)go to 200
18280cbz3/10/99
18281c if(lb(i).ge.6.and.lb(i).le.15)go to 200
18282 if(lb(i).ge.6.and.lb(i).le.17)go to 200
18283cbz3/10/99 end
18284 if(lb(i).eq.23)go to 400
18285 go to 20
18286* calculate rapidity and transverse momentum distribution for pions
1828750 npion=npion+1
18288* (2) rapidity distribution in the cms frame
18289 ypion(iy)=ypion(iy)+1
18290 pxpion(iy)=pxpion(iy)+p(1,i)/e(I)
18291 go TO 20
18292* calculate rapidity and transverse energy distribution for baryons
18293200 npr=npr+1
18294 pxpro(iy)=pxpro(iy)+p(1,I)/E(I)
18295 ypr(iy)=ypr(iy)+1.
18296 go to 20
18297400 nkaon=nkaon+1
18298 ykaon(iy)=ykaon(iy)+1.
18299 pxkaon(iy)=pxkaon(iy)+p(1,i)/E(i)
1830020 CONTINUE
18301C PRINT OUT NUCLEON'S TRANSVERSE MOMENTUM distribution
18302c write(1041,*)Nt
18303c write(1042,*)Nt
18304c write(1043,*)Nt
18305c write(1090,*)Nt
18306c write(1091,*)Nt
18307c write(1092,*)Nt
18308 do 3 npt=-10,10
18309 IF(ypr(npt).eq.0) go to 101
18310 pxpro(NPT)=-Pxpro(NPT)/ypr(NPT)
18311 DNUC=Pxpro(NPT)/SQRT(ypr(NPT))
18312c WRITE(1041,*)NPT*DY,Pxpro(NPT),DNUC
18313c print pion's transverse momentum distribution
18314101 IF(ypion(npt).eq.0) go to 102
18315 pxpion(NPT)=-pxpion(NPT)/ypion(NPT)
18316 DNUCp=pxpion(NPT)/SQRT(ypion(NPT))
18317c WRITE(1042,*)NPT*DY,Pxpion(NPT),DNUCp
18318c kaons
18319102 IF(ykaon(npt).eq.0) go to 3
18320 pxkaon(NPT)=-pxkaon(NPT)/ykaon(NPT)
18321 DNUCk=pxkaon(NPT)/SQRT(ykaon(NPT))
18322c WRITE(1043,*)NPT*DY,Pxkaon(NPT),DNUCk
183233 CONTINUE
18324********************************
18325* OUTPUT PION AND PROTON RAPIDITY DISTRIBUTIONS
18326 DO 1001 M=-LY,LY
18327* PROTONS
18328 DYPR=0
18329 IF(YPR(M).NE.0)DYPR=SQRT(YPR(M))/FLOAT(NRUN)/DY
18330 YPR(M)=YPR(M)/FLOAT(NRUN)/DY
18331c WRITE(1090,'(E11.3,2X,E11.3,2X,E11.3)')m*DY,YPR(M),DYPR
18332* PIONS
18333 DYPION=0
18334 IF(YPION(M).NE.0)DYPION=SQRT(YPION(M))/FLOAT(NRUN)/DY
18335 YPION(M)=YPION(M)/FLOAT(NRUN)/DY
18336c WRITE(1091,'(E11.3,2X,E11.3,2X,E11.3)')m*DY,YPION(M),DYPION
18337* KAONS
18338 DYKAON=0
18339 IF(YKAON(M).NE.0)DYKAON=SQRT(YKAON(M))/FLOAT(NRUN)/DY
18340 YKAON(M)=YKAON(M)/FLOAT(NRUN)/DY
18341c WRITE(1092,'(E11.3,2X,E11.3,2X,E11.3)')m*DY,YKAON(M),DYKAON
18342 1001 CONTINUE
18343 return
18344 end
18345cbali1/16/99
18346********************************************
18347* Purpose: pp_bar annihilation cross section as a functon of their cms energy
18348c real*4 function xppbar(srt)
18349 real function xppbar(srt)
18350* srt = DSQRT(s) in GeV *
18351* xppbar = pp_bar annihilation cross section in mb *
18352*
18353* Reference: G.J. Wang, R. Bellwied, C. Pruneau and G. Welke
18354* Proc. of the 14th Winter Workshop on Nuclear Dynamics,
18355* Snowbird, Utah 31, Eds. W. Bauer and H.G. Ritter
18356* (Plenum Publishing, 1998) *
18357*
18358******************************************
18359 Parameter (pmass=0.9383,xmax=400.)
18360 SAVE
18361* Note:
18362* (1) we introduce a new parameter xmax=400 mb:
18363* the maximum annihilation xsection
18364* there are shadowing effects in pp_bar annihilation, with this parameter
18365* we can probably look at these effects
18366* (2) Calculate p(lab) from srt [GeV], since the formular in the
18367* reference applies only to the case of a p_bar on a proton at rest
18368* Formula used: srt**2=2.*pmass*(pmass+sqrt(pmass**2+plab**2))
18369 xppbar=1.e-06
18370 plab2=(srt**2/(2.*pmass)-pmass)**2-pmass**2
18371 if(plab2.gt.0)then
18372 plab=sqrt(plab2)
18373 xppbar=67./(plab**0.7)
18374 if(xppbar.gt.xmax)xppbar=xmax
18375 endif
18376 return
18377 END
18378cbali1/16/99 end
18379**********************************
18380cbali2/6/99
18381********************************************
18382* Purpose: To generate randomly the no. of pions in the final
18383* state of pp_bar annihilation according to a statistical
18384* model by using of the rejection method.
18385cbz2/25/99
18386c real*4 function pbarfs(srt,npion,iseed)
18387 subroutine pbarfs(srt,npion,iseed)
18388cbz2/25/99end
18389* Quantities:
18390* srt: DSQRT(s) in GeV *
18391* npion: No. of pions produced in the annihilation of ppbar at srt *
18392* nmax=6, cutoff of the maximum no. of n the code can handle
18393*
18394* Reference: C.M. Ko and R. Yuan, Phys. Lett. B192 (1987) 31 *
18395*
18396******************************************
18397 parameter (pimass=0.140,pi=3.1415926)
18398 Dimension factor(6),pnpi(6)
18399 COMMON/RNDF77/NSEED
18400cc SAVE /RNDF77/
18401 SAVE
18402 ISEED=ISEED
18403C the factorial coefficients in the pion no. distribution
18404* from n=2 to 6 calculated use the formula in the reference
18405 factor(2)=1.
18406 factor(3)=1.17e-01
18407 factor(4)=3.27e-03
18408 factor(5)=3.58e-05
18409 factor(6)=1.93e-07
18410 ene=(srt/pimass)**3/(6.*pi**2)
18411c the relative probability from n=2 to 6
18412 do 1001 n=2,6
18413 pnpi(n)=ene**n*factor(n)
18414 1001 continue
18415c find the maximum of the probabilities, I checked a
18416c Fortan manual: max() returns the maximum value of
18417c the same type as in the argument list
18418 pmax=max(pnpi(2),pnpi(3),pnpi(4),pnpi(5),pnpi(6))
18419c randomly generate n between 2 and 6
18420 ntry=0
18421 10 npion=2+int(5*RANART(NSEED))
18422clin-4/2008 check bounds:
18423 if(npion.gt.6) goto 10
18424 thisp=pnpi(npion)/pmax
18425 ntry=ntry+1
18426c decide whether to take this npion according to the distribution
18427c using rejection method.
18428 if((thisp.lt.RANART(NSEED)).and.(ntry.le.20)) go to 10
18429c now take the last generated npion and return
18430 return
18431 END
18432**********************************
18433cbali2/6/99 end
18434cbz3/9/99 kkbar
18435cbali3/5/99
18436******************************************
18437* purpose: Xsection for K+ K- to pi+ pi-
18438c real*4 function xkkpi(srt)
18439* srt = DSQRT(s) in GeV *
18440* xkkpi = xsection in mb obtained from
18441* the detailed balance *
18442* ******************************************
18443c parameter (pimass=0.140,aka=0.498)
18444c xkkpi=1.e-08
18445c ppi2=(srt/2)**2-pimass**2
18446c pk2=(srt/2)**2-aka**2
18447c if(ppi2.le.0.or.pk2.le.0)return
18448cbz3/9/99 kkbar
18449c xkkpi=ppi2/pk2*pipik(srt)
18450c xkkpi=9.0 / 4.0 * ppi2/pk2*pipik(srt)
18451c xkkpi = 2.0 * xkkpi
18452cbz3/9/99 kkbar end
18453
18454cbz3/9/99 kkbar
18455c end
18456c return
18457c END
18458cbz3/9/99 kkbar end
18459
18460cbali3/5/99 end
18461cbz3/9/99 kkbar end
18462
18463cbz3/9/99 kkbar
18464*****************************
18465* purpose: Xsection for K+ K- to pi+ pi-
18466 SUBROUTINE XKKANN(SRT, XSK1, XSK2, XSK3, XSK4, XSK5,
18467 & XSK6, XSK7, XSK8, XSK9, XSK10, XSK11, SIGK, rrkk)
18468* srt = DSQRT(s) in GeV *
18469* xsk1 = annihilation into pi pi *
18470* xsk2 = annihilation into pi rho (shifted to XKKSAN) *
18471* xsk3 = annihilation into pi omega (shifted to XKKSAN) *
18472* xsk4 = annihilation into pi eta *
18473* xsk5 = annihilation into rho rho *
18474* xsk6 = annihilation into rho omega *
18475* xsk7 = annihilation into rho eta (shifted to XKKSAN) *
18476* xsk8 = annihilation into omega omega *
18477* xsk9 = annihilation into omega eta (shifted to XKKSAN) *
18478* xsk10 = annihilation into eta eta *
18479* sigk = xsection in mb obtained from *
18480* the detailed balance *
18481* ***************************
18482 PARAMETER (MAXSTR=150001, MAXX=20, MAXZ=24)
18483 PARAMETER (AKA=0.498, PIMASS=0.140, RHOM = 0.770,
18484 & OMEGAM = 0.7819, ETAM = 0.5473, APHI=1.02)
18485 COMMON /AA/ R(3,MAXSTR)
18486cc SAVE /AA/
18487 COMMON /BB/ P(3,MAXSTR)
18488cc SAVE /BB/
18489 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
18490cc SAVE /EE/
18491 COMMON /DD/ RHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
18492 & RHOP(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
18493 & RHON(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
18494cc SAVE /DD/
18495 SAVE
18496
18497 S = SRT ** 2
18498 SIGK = 1.E-08
18499 XSK1 = 0.0
18500 XSK2 = 0.0
18501 XSK3 = 0.0
18502 XSK4 = 0.0
18503 XSK5 = 0.0
18504 XSK6 = 0.0
18505 XSK7 = 0.0
18506 XSK8 = 0.0
18507 XSK9 = 0.0
18508 XSK10 = 0.0
18509 XSK11 = 0.0
18510
18511 XPION0 = PIPIK(SRT)
18512c.....take into account both K+ and K0
18513 XPION0 = 2.0 * XPION0
18514 PI2 = S * (S - 4.0 * AKA ** 2)
18515 if(PI2 .le. 0.0)return
18516
18517 XM1 = PIMASS
18518 XM2 = PIMASS
18519 PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
18520 IF (PF2 .GT. 0.0) THEN
18521 XSK1 = 9.0 / 4.0 * PF2 / PI2 * XPION0
18522 END IF
18523
18524clin-8/28/00 (pi eta) eta -> K+K- is assumed the same as pi pi -> K+K-:
18525 XM1 = PIMASS
18526 XM2 = ETAM
18527 PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
18528 IF (PF2 .GT. 0.0) THEN
18529 XSK4 = 3.0 / 4.0 * PF2 / PI2 * XPION0
18530 END IF
18531
18532 XM1 = ETAM
18533 XM2 = ETAM
18534 PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
18535 IF (PF2 .GT. 0.0) THEN
18536 XSK10 = 1.0 / 4.0 * PF2 / PI2 * XPION0
18537 END IF
18538
18539 XPION0 = rrkk
18540
18541clin-11/07/00: (pi eta) (rho omega) -> K* Kbar (or K*bar K) instead to K Kbar:
18542c XM1 = PIMASS
18543c XM2 = RHOM
18544c PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
18545c IF (PF2 .GT. 0.0) THEN
18546c XSK2 = 27.0 / 4.0 * PF2 / PI2 * XPION0
18547c END IF
18548
18549c XM1 = PIMASS
18550c XM2 = OMEGAM
18551c PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
18552c IF (PF2 .GT. 0.0) THEN
18553c XSK3 = 9.0 / 4.0 * PF2 / PI2 * XPION0
18554c END IF
18555
18556 XM1 = RHOM
18557 XM2 = RHOM
18558 PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
18559 IF (PF2 .GT. 0.0) THEN
18560 XSK5 = 81.0 / 4.0 * PF2 / PI2 * XPION0
18561 END IF
18562
18563 XM1 = RHOM
18564 XM2 = OMEGAM
18565 PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
18566 IF (PF2 .GT. 0.0) THEN
18567 XSK6 = 27.0 / 4.0 * PF2 / PI2 * XPION0
18568 END IF
18569
18570c XM1 = RHOM
18571c XM2 = ETAM
18572c PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
18573c IF (PF2 .GT. 0.0) THEN
18574c XSK7 = 9.0 / 4.0 * PF2 / PI2 * XPION0
18575c END IF
18576
18577 XM1 = OMEGAM
18578 XM2 = OMEGAM
18579 PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
18580 IF (PF2 .GT. 0.0) THEN
18581 XSK8 = 9.0 / 4.0 * PF2 / PI2 * XPION0
18582 END IF
18583
18584c XM1 = OMEGAM
18585c XM2 = ETAM
18586c PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
18587c IF (PF2 .GT. 0.0) THEN
18588c XSK9 = 3.0 / 4.0 * PF2 / PI2 * XPION0
18589c END IF
18590
18591c* K+ + K- --> phi
18592 fwdp = 1.68*(aphi**2-4.*aka**2)**1.5/6./aphi/aphi
18593 pkaon=0.5*sqrt(srt**2-4.0*aka**2)
18594 XSK11 = 30.*3.14159*0.1973**2*(aphi*fwdp)**2/
18595 & ((srt**2-aphi**2)**2+(aphi*fwdp)**2)/pkaon**2
18596c
18597 SIGK = XSK1 + XSK2 + XSK3 + XSK4 + XSK5 +
18598 & XSK6 + XSK7 + XSK8 + XSK9 + XSK10 + XSK11
18599
18600 RETURN
18601 END
18602cbz3/9/99 kkbar end
18603
18604*****************************
18605* purpose: Xsection for Phi + B
18606 SUBROUTINE XphiB(LB1, LB2, EM1, EM2, SRT,
18607 & XSK1, XSK2, XSK3, XSK4, XSK5, SIGP)
18608c
18609* ***************************
18610 PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
18611 1 AMP=0.93828,AP1=0.13496,AP2=0.13957,AM0=1.232,PI=3.1415926)
18612 PARAMETER (AKA=0.498, ALA = 1.1157, PIMASS=0.140, APHI=1.02)
18613 parameter (arho=0.77)
18614 SAVE
18615
18616 SIGP = 1.E-08
18617 XSK1 = 0.0
18618 XSK2 = 0.0
18619 XSK3 = 0.0
18620 XSK4 = 0.0
18621 XSK5 = 0.0
18622 XSK6 = 0.0
18623 srrt = srt - (em1+em2)
18624
18625c* phi + N(D) -> elastic scattering
18626c XSK1 = 0.56 !! mb
18627c !! mb (photo-production xsecn used)
18628 XSK1 = 8.00
18629c
18630c* phi + N(D) -> pi + N
18631 IF (srt .GT. (ap1+amn)) THEN
18632 XSK2 = 0.0235*srrt**(-0.519)
18633 END IF
18634c
18635c* phi + N(D) -> pi + D
18636 IF (srt .GT. (ap1+am0)) THEN
18637 if(srrt .lt. 0.7)then
18638 XSK3 = 0.0119*srrt**(-0.534)
18639 else
18640 XSK3 = 0.0130*srrt**(-0.304)
18641 endif
18642 END IF
18643c
18644c* phi + N(D) -> rho + N
18645 IF (srt .GT. (arho+amn)) THEN
18646 if(srrt .lt. 0.7)then
18647 XSK4 = 0.0166*srrt**(-0.786)
18648 else
18649 XSK4 = 0.0189*srrt**(-0.277)
18650 endif
18651 END IF
18652c
18653c* phi + N(D) -> rho + D (same as pi + D)
18654 IF (srt .GT. (arho+am0)) THEN
18655 if(srrt .lt. 0.7)then
18656 XSK5 = 0.0119*srrt**(-0.534)
18657 else
18658 XSK5 = 0.0130*srrt**(-0.304)
18659 endif
18660 END IF
18661c
18662c* phi + N -> K+ + La
18663 IF( (lb1.ge.1.and.lb1.le.2) .or. (lb2.ge.1.and.lb2.le.2) )THEN
18664 IF (srt .GT. (aka+ala)) THEN
18665 XSK6 = 1.715/((srrt+3.508)**2-12.138)
18666 END IF
18667 END IF
18668 SIGP = XSK1 + XSK2 + XSK3 + XSK4 + XSK5 + XSK6
18669 RETURN
18670 END
18671c
18672**********************************
18673*
18674 SUBROUTINE CRPHIB(PX,PY,PZ,SRT,I1,I2,
18675 & XSK1, XSK2, XSK3, XSK4, XSK5, SIGP, IBLOCK)
18676*
18677* PURPOSE: *
18678* DEALING WITH PHI + N(D) --> pi+N(D), rho+N(D), K+ + La
18679* QUANTITIES: *
18680* PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
18681* SRT - SQRT OF S *
18682* IBLOCK - INFORMATION about the reaction channel *
18683*
18684* iblock - 20 elastic
18685* iblock - 221 K+ formation
18686* iblock - 223 others
18687**********************************
18688 PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
18689 1 AMP=0.93828,AP1=0.13496,AMRHO=0.769,AMOMGA=0.782,
18690 2 AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
18691 PARAMETER (AKA=0.498,ALA=1.1157,ASA=1.1974,ARHO=0.77)
18692 parameter (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
18693 COMMON /AA/ R(3,MAXSTR)
18694cc SAVE /AA/
18695 COMMON /BB/ P(3,MAXSTR)
18696cc SAVE /BB/
18697 COMMON /CC/ E(MAXSTR)
18698cc SAVE /CC/
18699 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
18700cc SAVE /EE/
18701 common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
18702cc SAVE /input1/
18703 COMMON/RNDF77/NSEED
18704cc SAVE /RNDF77/
18705 SAVE
18706c
18707 PX0=PX
18708 PY0=PY
18709 PZ0=PZ
18710 IBLOCK=223
18711c
18712 X1 = RANART(NSEED) * SIGP
18713 XSK2 = XSK1 + XSK2
18714 XSK3 = XSK2 + XSK3
18715 XSK4 = XSK3 + XSK4
18716 XSK5 = XSK4 + XSK5
18717c
18718c !! elastic scatt.
18719 IF (X1 .LE. XSK1) THEN
18720 iblock=20
18721 GOTO 100
18722 ELSE IF (X1 .LE. XSK2) THEN
18723 LB(I1) = 3 + int(3 * RANART(NSEED))
18724 LB(I2) = 1 + int(2 * RANART(NSEED))
18725 E(I1) = AP1
18726 E(I2) = AMN
18727 GOTO 100
18728 ELSE IF (X1 .LE. XSK3) THEN
18729 LB(I1) = 3 + int(3 * RANART(NSEED))
18730 LB(I2) = 6 + int(4 * RANART(NSEED))
18731 E(I1) = AP1
18732 E(I2) = AM0
18733 GOTO 100
18734 ELSE IF (X1 .LE. XSK4) THEN
18735 LB(I1) = 25 + int(3 * RANART(NSEED))
18736 LB(I2) = 1 + int(2 * RANART(NSEED))
18737 E(I1) = ARHO
18738 E(I2) = AMN
18739 GOTO 100
18740 ELSE IF (X1 .LE. XSK5) THEN
18741 LB(I1) = 25 + int(3 * RANART(NSEED))
18742 LB(I2) = 6 + int(4 * RANART(NSEED))
18743 E(I1) = ARHO
18744 E(I2) = AM0
18745 GOTO 100
18746 ELSE
18747 LB(I1) = 23
18748 LB(I2) = 14
18749 E(I1) = AKA
18750 E(I2) = ALA
18751 IBLOCK=221
18752 ENDIF
18753 100 CONTINUE
18754 EM1=E(I1)
18755 EM2=E(I2)
18756*-----------------------------------------------------------------------
18757* CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
18758* ENERGY CONSERVATION
18759 PR2 = (SRT**2 - EM1**2 - EM2**2)**2
18760 1 - 4.0 * (EM1*EM2)**2
18761 IF(PR2.LE.0.)PR2=1.E-08
18762 PR=SQRT(PR2)/(2.*SRT)
18763* WE ASSUME AN ISOTROPIC ANGULAR DISTRIBUTION IN THE CMS
18764 C1 = 1.0 - 2.0 * RANART(NSEED)
18765 T1 = 2.0 * PI * RANART(NSEED)
18766 S1 = SQRT( 1.0 - C1**2 )
18767 CT1 = COS(T1)
18768 ST1 = SIN(T1)
18769* THE MOMENTUM IN THE CMS IN THE FINAL STATE
18770 PZ = PR * C1
18771 PX = PR * S1*CT1
18772 PY = PR * S1*ST1
18773* ROTATE IT
18774 CALL ROTATE(PX0,PY0,PZ0,PX,PY,PZ)
18775 RETURN
18776 END
18777c
18778*****************************
18779* purpose: Xsection for Phi + B
18780c!! in fm^2
18781 SUBROUTINE pibphi(srt,lb1,lb2,em1,em2,Xphi,xphin)
18782c
18783* phi + N(D) <- pi + N
18784* phi + N(D) <- pi + D
18785* phi + N(D) <- rho + N
18786* phi + N(D) <- rho + D (same as pi + D)
18787c
18788* ***************************
18789 PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
18790 1 AMP=0.93828,AP1=0.13496,AP2=0.13957,AM0=1.232,PI=3.1415926)
18791 PARAMETER (AKA=0.498, ALA = 1.1157, PIMASS=0.140, APHI=1.02)
18792 parameter (arho=0.77)
18793 SAVE
18794
18795 Xphi = 0.0
18796 xphin = 0.0
18797 xphid = 0.0
18798c
18799 if( (lb1.ge.3.and.lb1.le.5) .or.
18800 & (lb2.ge.3.and.lb2.le.5) )then
18801c
18802 if( (iabs(lb1).ge.1.and.iabs(lb1).le.2) .or.
18803 & (iabs(lb2).ge.1.and.iabs(lb2).le.2) )then
18804c* phi + N <- pi + N
18805 IF (srt .GT. (aphi+amn)) THEN
18806 srrt = srt - (aphi+amn)
18807 sig = 0.0235*srrt**(-0.519)
18808 xphin=sig*1.*(srt**2-(aphi+amn)**2)*
18809 & (srt**2-(aphi-amn)**2)/(srt**2-(em1+em2)**2)/
18810 & (srt**2-(em1-em2)**2)
18811 END IF
18812c* phi + D <- pi + N
18813 IF (srt .GT. (aphi+am0)) THEN
18814 srrt = srt - (aphi+am0)
18815 sig = 0.0235*srrt**(-0.519)
18816 xphid=sig*4.*(srt**2-(aphi+am0)**2)*
18817 & (srt**2-(aphi-am0)**2)/(srt**2-(em1+em2)**2)/
18818 & (srt**2-(em1-em2)**2)
18819 END IF
18820 else
18821c* phi + N <- pi + D
18822 IF (srt .GT. (aphi+amn)) THEN
18823 srrt = srt - (aphi+amn)
18824 if(srrt .lt. 0.7)then
18825 sig = 0.0119*srrt**(-0.534)
18826 else
18827 sig = 0.0130*srrt**(-0.304)
18828 endif
18829 xphin=sig*(1./4.)*(srt**2-(aphi+amn)**2)*
18830 & (srt**2-(aphi-amn)**2)/(srt**2-(em1+em2)**2)/
18831 & (srt**2-(em1-em2)**2)
18832 END IF
18833c* phi + D <- pi + D
18834 IF (srt .GT. (aphi+am0)) THEN
18835 srrt = srt - (aphi+am0)
18836 if(srrt .lt. 0.7)then
18837 sig = 0.0119*srrt**(-0.534)
18838 else
18839 sig = 0.0130*srrt**(-0.304)
18840 endif
18841 xphid=sig*1.*(srt**2-(aphi+am0)**2)*
18842 & (srt**2-(aphi-am0)**2)/(srt**2-(em1+em2)**2)/
18843 & (srt**2-(em1-em2)**2)
18844 END IF
18845 endif
18846c
18847c
18848C** for rho + N(D) colln
18849c
18850 else
18851c
18852 if( (iabs(lb1).ge.1.and.iabs(lb1).le.2) .or.
18853 & (iabs(lb2).ge.1.and.iabs(lb2).le.2) )then
18854c
18855c* phi + N <- rho + N
18856 IF (srt .GT. (aphi+amn)) THEN
18857 srrt = srt - (aphi+amn)
18858 if(srrt .lt. 0.7)then
18859 sig = 0.0166*srrt**(-0.786)
18860 else
18861 sig = 0.0189*srrt**(-0.277)
18862 endif
18863 xphin=sig*(1./3.)*(srt**2-(aphi+amn)**2)*
18864 & (srt**2-(aphi-amn)**2)/(srt**2-(em1+em2)**2)/
18865 & (srt**2-(em1-em2)**2)
18866 END IF
18867c* phi + D <- rho + N
18868 IF (srt .GT. (aphi+am0)) THEN
18869 srrt = srt - (aphi+am0)
18870 if(srrt .lt. 0.7)then
18871 sig = 0.0166*srrt**(-0.786)
18872 else
18873 sig = 0.0189*srrt**(-0.277)
18874 endif
18875 xphid=sig*(4./3.)*(srt**2-(aphi+am0)**2)*
18876 & (srt**2-(aphi-am0)**2)/(srt**2-(em1+em2)**2)/
18877 & (srt**2-(em1-em2)**2)
18878 END IF
18879 else
18880c* phi + N <- rho + D (same as pi+D->phi+N)
18881 IF (srt .GT. (aphi+amn)) THEN
18882 srrt = srt - (aphi+amn)
18883 if(srrt .lt. 0.7)then
18884 sig = 0.0119*srrt**(-0.534)
18885 else
18886 sig = 0.0130*srrt**(-0.304)
18887 endif
18888 xphin=sig*(1./12.)*(srt**2-(aphi+amn)**2)*
18889 & (srt**2-(aphi-amn)**2)/(srt**2-(em1+em2)**2)/
18890 & (srt**2-(em1-em2)**2)
18891 END IF
18892c* phi + D <- rho + D (same as pi+D->phi+D)
18893 IF (srt .GT. (aphi+am0)) THEN
18894 srrt = srt - (aphi+am0)
18895 if(srrt .lt. 0.7)then
18896 sig = 0.0119*srrt**(-0.534)
18897 else
18898 sig = 0.0130*srrt**(-0.304)
18899 endif
18900 xphid=sig*(1./3.)*(srt**2-(aphi+am0)**2)*
18901 & (srt**2-(aphi-am0)**2)/(srt**2-(em1+em2)**2)/
18902 & (srt**2-(em1-em2)**2)
18903 END IF
18904 endif
18905 END IF
18906c !! in fm^2
18907 xphin = xphin/10.
18908c !! in fm^2
18909 xphid = xphid/10.
18910 Xphi = xphin + xphid
18911
18912 RETURN
18913 END
18914c
18915*****************************
18916* purpose: Xsection for phi +M to K+K etc
18917 SUBROUTINE PHIMES(I1, I2, SRT, XSK1, XSK2, XSK3, XSK4, XSK5,
18918 1 XSK6, XSK7, SIGPHI)
18919
18920* QUANTITIES: *
18921* PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
18922* SRT - SQRT OF S *
18923* IBLOCK - THE INFORMATION BACK *
18924* 223 --> phi destruction
18925* 20 --> elastic
18926**********************************
18927 PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
18928 1 AMP=0.93828,AP1=0.13496,
18929 2 AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
18930 PARAMETER (AKA=0.498, AKS=0.895, AOMEGA=0.7819,
18931 3 ARHO=0.77, APHI=1.02)
18932 parameter (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
18933 PARAMETER (MAXX=20, MAXZ=24)
18934 COMMON /AA/ R(3,MAXSTR)
18935cc SAVE /AA/
18936 COMMON /BB/ P(3,MAXSTR)
18937cc SAVE /BB/
18938 COMMON /CC/ E(MAXSTR)
18939cc SAVE /CC/
18940 COMMON /DD/ RHO(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
18941 & RHOP(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ),
18942 & RHON(-MAXX:MAXX,-MAXX:MAXX,-MAXZ:MAXZ)
18943cc SAVE /DD/
18944 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
18945cc SAVE /EE/
18946 SAVE
18947
18948 S = SRT ** 2
18949 SIGPHI = 1.E-08
18950 XSK1 = 0.0
18951 XSK2 = 0.0
18952 XSK3 = 0.0
18953 XSK4 = 0.0
18954 XSK5 = 0.0
18955 XSK6 = 0.0
18956 XSK7 = 0.0
18957 em1 = E(i1)
18958 em2 = E(i2)
18959 LB1 = LB(i1)
18960 LB2 = LB(i2)
18961 akap = aka
18962c******
18963c
18964c !! mb, elastic
18965 XSK1 = 5.0
18966
18967 pii = sqrt((S-(em1+em2)**2)*(S-(em1-em2)**2))
18968* phi + K(-bar) channel
18969 if( lb1.eq.23.or.lb2.eq.23 .or. lb1.eq.21.or.lb2.eq.21 )then
18970 if(srt .gt. (ap1+akap))then
18971c XSK2 = 2.5
18972 pff = sqrt((S-(ap1+akap)**2)*(S-(ap1-akap)**2))
18973 XSK2 = 195.639*pff/pii/32./pi/S
18974 endif
18975 if(srt .gt. (arho+akap))then
18976c XSK3 = 3.5
18977 pff = sqrt((S-(arho+akap)**2)*(S-(arho-akap)**2))
18978 XSK3 = 526.702*pff/pii/32./pi/S
18979 endif
18980 if(srt .gt. (aomega+akap))then
18981c XSK4 = 3.5
18982 pff = sqrt((S-(aomega+akap)**2)*(S-(aomega-akap)**2))
18983 XSK4 = 355.429*pff/pii/32./pi/S
18984 endif
18985 if(srt .gt. (ap1+aks))then
18986c XSK5 = 15.0
18987 pff = sqrt((S-(ap1+aks)**2)*(S-(ap1-aks)**2))
18988 XSK5 = 2047.042*pff/pii/32./pi/S
18989 endif
18990 if(srt .gt. (arho+aks))then
18991c XSK6 = 3.5
18992 pff = sqrt((S-(arho+aks)**2)*(S-(arho-aks)**2))
18993 XSK6 = 1371.257*pff/pii/32./pi/S
18994 endif
18995 if(srt .gt. (aomega+aks))then
18996c XSK7 = 3.5
18997 pff = sqrt((S-(aomega+aks)**2)*(S-(aomega-aks)**2))
18998 XSK7 = 482.292*pff/pii/32./pi/S
18999 endif
19000c
19001 elseif( iabs(lb1).eq.30.or.iabs(lb2).eq.30 )then
19002* phi + K*(-bar) channel
19003c
19004 if(srt .gt. (ap1+akap))then
19005c XSK2 = 3.5
19006 pff = sqrt((S-(ap1+akap)**2)*(S-(ap1-akap)**2))
19007 XSK2 = 372.378*pff/pii/32./pi/S
19008 endif
19009 if(srt .gt. (arho+akap))then
19010c XSK3 = 9.0
19011 pff = sqrt((S-(arho+akap)**2)*(S-(arho-akap)**2))
19012 XSK3 = 1313.960*pff/pii/32./pi/S
19013 endif
19014 if(srt .gt. (aomega+akap))then
19015c XSK4 = 6.5
19016 pff = sqrt((S-(aomega+akap)**2)*(S-(aomega-akap)**2))
19017 XSK4 = 440.558*pff/pii/32./pi/S
19018 endif
19019 if(srt .gt. (ap1+aks))then
19020c XSK5 = 30.0 !wrong
19021 pff = sqrt((S-(ap1+aks)**2)*(S-(ap1-aks)**2))
19022 XSK5 = 1496.692*pff/pii/32./pi/S
19023 endif
19024 if(srt .gt. (arho+aks))then
19025c XSK6 = 9.0
19026 pff = sqrt((S-(arho+aks)**2)*(S-(arho-aks)**2))
19027 XSK6 = 6999.840*pff/pii/32./pi/S
19028 endif
19029 if(srt .gt. (aomega+aks))then
19030c XSK7 = 15.0
19031 pff = sqrt((S-(aomega+aks)**2)*(S-(aomega-aks)**2))
19032 XSK7 = 1698.903*pff/pii/32./pi/S
19033 endif
19034 else
19035c
19036* phi + rho(pi,omega) channel
19037c
19038 srr1 = em1+em2
19039 if(srt .gt. (akap+akap))then
19040 srrt = srt - srr1
19041cc if(srrt .lt. 0.3)then
19042 if(srrt .lt. 0.3 .and. srrt .gt. 0.01)then
19043 XSK2 = 1.69/(srrt**0.141 - 0.407)
19044 else
19045 XSK2 = 3.74 + 0.008*srrt**1.9
19046 endif
19047 endif
19048 if(srt .gt. (akap+aks))then
19049 srr2 = akap+aks
19050 srr = amax1(srr1,srr2)
19051 srrt = srt - srr
19052cc if(srrt .lt. 0.3)then
19053 if(srrt .lt. 0.3 .and. srrt .gt. 0.01)then
19054 XSK3 = 1.69/(srrt**0.141 - 0.407)
19055 else
19056 XSK3 = 3.74 + 0.008*srrt**1.9
19057 endif
19058 endif
19059 if(srt .gt. (aks+aks))then
19060 srr2 = aks+aks
19061 srr = amax1(srr1,srr2)
19062 srrt = srt - srr
19063cc if(srrt .lt. 0.3)then
19064 if(srrt .lt. 0.3 .and. srrt .gt. 0.01)then
19065 XSK4 = 1.69/(srrt**0.141 - 0.407)
19066 else
19067 XSK4 = 3.74 + 0.008*srrt**1.9
19068 endif
19069 endif
19070c xsk2 = amin1(20.,xsk2)
19071c xsk3 = amin1(20.,xsk3)
19072c xsk4 = amin1(20.,xsk4)
19073 endif
19074
19075 SIGPHI = XSK1 + XSK2 + XSK3 + XSK4 + XSK5 + XSK6 + XSK7
19076
19077 RETURN
19078 END
19079
19080**********************************
19081* PURPOSE: *
19082* DEALING WITH phi+M scatt.
19083*
19084 SUBROUTINE CRPHIM(PX,PY,PZ,SRT,I1,I2,
19085 & XSK1, XSK2, XSK3, XSK4, XSK5, XSK6, SIGPHI, IKKG, IKKL, IBLOCK)
19086*
19087* QUANTITIES: *
19088* PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
19089* SRT - SQRT OF S *
19090* IBLOCK - THE INFORMATION BACK *
19091* 20 --> elastic
19092* 223 --> phi + pi(rho,omega)
19093* 224 --> phi + K -> K + pi(rho,omega)
19094* 225 --> phi + K -> K* + pi(rho,omega)
19095* 226 --> phi + K* -> K + pi(rho,omega)
19096* 227 --> phi + K* -> K* + pi(rho,omega)
19097**********************************
19098 PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
19099 1 AMP=0.93828,AP1=0.13496,ARHO=0.77,AOMEGA=0.7819,
19100 2 AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
19101 PARAMETER (AKA=0.498,AKS=0.895)
19102 parameter (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
19103 COMMON /AA/ R(3,MAXSTR)
19104cc SAVE /AA/
19105 COMMON /BB/ P(3,MAXSTR)
19106cc SAVE /BB/
19107 COMMON /CC/ E(MAXSTR)
19108cc SAVE /CC/
19109 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
19110cc SAVE /EE/
19111 common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
19112cc SAVE /input1/
19113 COMMON/RNDF77/NSEED
19114cc SAVE /RNDF77/
19115 SAVE
19116c
19117 PX0=PX
19118 PY0=PY
19119 PZ0=PZ
19120 LB1 = LB(i1)
19121 LB2 = LB(i2)
19122
19123 X1 = RANART(NSEED) * SIGPHI
19124 XSK2 = XSK1 + XSK2
19125 XSK3 = XSK2 + XSK3
19126 XSK4 = XSK3 + XSK4
19127 XSK5 = XSK4 + XSK5
19128 XSK6 = XSK5 + XSK6
19129 IF (X1 .LE. XSK1) THEN
19130c !! elastic scatt
19131 IBLOCK=20
19132 GOTO 100
19133 ELSE
19134c
19135*phi + (K,K*)-bar
19136 if( lb1.eq.23.or.lb1.eq.21.or.iabs(lb1).eq.30 .OR.
19137 & lb2.eq.23.or.lb2.eq.21.or.iabs(lb2).eq.30 )then
19138c
19139 if(lb1.eq.23.or.lb2.eq.23)then
19140 IKKL=1
19141 IBLOCK=224
19142 iad1 = 23
19143 iad2 = 30
19144 elseif(lb1.eq.30.or.lb2.eq.30)then
19145 IKKL=0
19146 IBLOCK=226
19147 iad1 = 23
19148 iad2 = 30
19149 elseif(lb1.eq.21.or.lb2.eq.21)then
19150 IKKL=1
19151 IBLOCK=124
19152 iad1 = 21
19153 iad2 = -30
19154c !! -30
19155 else
19156 IKKL=0
19157 IBLOCK=126
19158 iad1 = 21
19159 iad2 = -30
19160 endif
19161 IF (X1 .LE. XSK2) THEN
19162 LB(I1) = 3 + int(3 * RANART(NSEED))
19163 LB(I2) = iad1
19164 E(I1) = AP1
19165 E(I2) = AKA
19166 IKKG = 1
19167 GOTO 100
19168 ELSE IF (X1 .LE. XSK3) THEN
19169 LB(I1) = 25 + int(3 * RANART(NSEED))
19170 LB(I2) = iad1
19171 E(I1) = ARHO
19172 E(I2) = AKA
19173 IKKG = 1
19174 GOTO 100
19175 ELSE IF (X1 .LE. XSK4) THEN
19176 LB(I1) = 28
19177 LB(I2) = iad1
19178 E(I1) = AOMEGA
19179 E(I2) = AKA
19180 IKKG = 1
19181 GOTO 100
19182 ELSE IF (X1 .LE. XSK5) THEN
19183 LB(I1) = 3 + int(3 * RANART(NSEED))
19184 LB(I2) = iad2
19185 E(I1) = AP1
19186 E(I2) = AKS
19187 IKKG = 0
19188 IBLOCK=IBLOCK+1
19189 GOTO 100
19190 ELSE IF (X1 .LE. XSK6) THEN
19191 LB(I1) = 25 + int(3 * RANART(NSEED))
19192 LB(I2) = iad2
19193 E(I1) = ARHO
19194 E(I2) = AKS
19195 IKKG = 0
19196 IBLOCK=IBLOCK+1
19197 GOTO 100
19198 ELSE
19199 LB(I1) = 28
19200 LB(I2) = iad2
19201 E(I1) = AOMEGA
19202 E(I2) = AKS
19203 IKKG = 0
19204 IBLOCK=IBLOCK+1
19205 GOTO 100
19206 ENDIF
19207 else
19208c !! phi destruction via (pi,rho,omega)
19209 IBLOCK=223
19210*phi + pi(rho,omega)
19211 IF (X1 .LE. XSK2) THEN
19212 LB(I1) = 23
19213 LB(I2) = 21
19214 E(I1) = AKA
19215 E(I2) = AKA
19216 IKKG = 2
19217 IKKL = 0
19218 GOTO 100
19219 ELSE IF (X1 .LE. XSK3) THEN
19220 LB(I1) = 23
19221c LB(I2) = 30
19222 LB(I2) = -30
19223clin-2/10/03 currently take XSK3 to be the sum of KK*bar & KbarK*:
19224 if(RANART(NSEED).le.0.5) then
19225 LB(I1) = 21
19226 LB(I2) = 30
19227 endif
19228
19229 E(I1) = AKA
19230 E(I2) = AKS
19231 IKKG = 1
19232 IKKL = 0
19233 GOTO 100
19234 ELSE IF (X1 .LE. XSK4) THEN
19235 LB(I1) = 30
19236c LB(I2) = 30
19237 LB(I2) = -30
19238 E(I1) = AKS
19239 E(I2) = AKS
19240 IKKG = 0
19241 IKKL = 0
19242 GOTO 100
19243 ENDIF
19244 endif
19245 ENDIF
19246*
19247100 CONTINUE
19248 EM1=E(I1)
19249 EM2=E(I2)
19250
19251*-----------------------------------------------------------------------
19252* CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
19253* ENERGY CONSERVATION
19254 PR2 = (SRT**2 - EM1**2 - EM2**2)**2
19255 1 - 4.0 * (EM1*EM2)**2
19256 IF(PR2.LE.0.)PR2=1.E-08
19257 PR=SQRT(PR2)/(2.*SRT)
19258* WE ASSUME AN ISOTROPIC ANGULAR DISTRIBUTION IN THE CMS
19259 C1 = 1.0 - 2.0 * RANART(NSEED)
19260 T1 = 2.0 * PI * RANART(NSEED)
19261 S1 = SQRT( 1.0 - C1**2 )
19262 CT1 = COS(T1)
19263 ST1 = SIN(T1)
19264* THE MOMENTUM IN THE CMS IN THE FINAL STATE
19265 PZ = PR * C1
19266 PX = PR * S1*CT1
19267 PY = PR * S1*ST1
19268* ROTATE IT
19269 CALL ROTATE(PX0,PY0,PZ0,PX,PY,PZ)
19270 RETURN
19271 END
19272**********************************
19273**********************************
19274cbz3/9/99 khyperon
19275*************************************
19276* purpose: Xsection for K+Y -> piN *
19277* Xsection for K+Y-bar -> piN-bar !! sp03/29/01 *
19278*
19279 SUBROUTINE XKHYPE(I1, I2, SRT, XKY1, XKY2, XKY3, XKY4, XKY5,
19280 & XKY6, XKY7, XKY8, XKY9, XKY10, XKY11, XKY12, XKY13,
19281 & XKY14, XKY15, XKY16, XKY17, SIGK)
19282c subroutine xkhype(i1, i2, srt, sigk)
19283* srt = DSQRT(s) in GeV *
19284* xkkpi = xsection in mb obtained from *
19285* the detailed balance *
19286* ***********************************
19287 PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
19288 1 AMP=0.93828,AP1=0.13496,AMRHO=0.769,AMOMGA=0.782,APHI=1.02,
19289 2 AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
19290 parameter (pimass=0.140, AMETA = 0.5473, aka=0.498,
19291 & aml=1.116,ams=1.193, AM1440 = 1.44, AM1535 = 1.535)
19292 COMMON /EE/ID(MAXSTR), LB(MAXSTR)
19293cc SAVE /EE/
19294 SAVE
19295
19296 S = SRT ** 2
19297 SIGK=1.E-08
19298 XKY1 = 0.0
19299 XKY2 = 0.0
19300 XKY3 = 0.0
19301 XKY4 = 0.0
19302 XKY5 = 0.0
19303 XKY6 = 0.0
19304 XKY7 = 0.0
19305 XKY8 = 0.0
19306 XKY9 = 0.0
19307 XKY10 = 0.0
19308 XKY11 = 0.0
19309 XKY12 = 0.0
19310 XKY13 = 0.0
19311 XKY14 = 0.0
19312 XKY15 = 0.0
19313 XKY16 = 0.0
19314 XKY17 = 0.0
19315
19316 LB1 = LB(I1)
19317 LB2 = LB(I2)
19318 IF (iabs(LB1) .EQ. 14 .OR. iabs(LB2) .EQ. 14) THEN
19319 XKAON0 = PNLKA(SRT)
19320 XKAON0 = 2.0 * XKAON0
19321 PI2 = (S - (AML + AKA) ** 2) * (S - (AML - AKA) ** 2)
19322 ELSE
19323 XKAON0 = PNSKA(SRT)
19324 XKAON0 = 2.0 * XKAON0
19325 PI2 = (S - (AMS + AKA) ** 2) * (S - (AMS - AKA) ** 2)
19326 END IF
19327 if(PI2 .le. 0.0)return
19328
19329 XM1 = PIMASS
19330 XM2 = AMP
19331 PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19332 IF (PF2 .GT. 0.0) THEN
19333 XKY1 = 3.0 * PF2 / PI2 * XKAON0
19334 END IF
19335
19336 XM1 = PIMASS
19337 XM2 = AM0
19338 PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19339 IF (PF2 .GT. 0.0) THEN
19340 XKY2 = 12.0 * PF2 / PI2 * XKAON0
19341 END IF
19342
19343 XM1 = PIMASS
19344 XM2 = AM1440
19345 PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19346 IF (PF2 .GT. 0.0) THEN
19347 XKY3 = 3.0 * PF2 / PI2 * XKAON0
19348 END IF
19349
19350 XM1 = PIMASS
19351 XM2 = AM1535
19352 PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19353 IF (PF2 .GT. 0.0) THEN
19354 XKY4 = 3.0 * PF2 / PI2 * XKAON0
19355 END IF
19356
19357 XM1 = AMRHO
19358 XM2 = AMP
19359 PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19360 IF (PF2 .GT. 0.0) THEN
19361 XKY5 = 9.0 * PF2 / PI2 * XKAON0
19362 END IF
19363
19364 XM1 = AMRHO
19365 XM2 = AM0
19366 PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19367 IF (PF2 .GT. 0.0) THEN
19368 XKY6 = 36.0 * PF2 / PI2 * XKAON0
19369 END IF
19370
19371 XM1 = AMRHO
19372 XM2 = AM1440
19373 PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19374 IF (PF2 .GT. 0.0) THEN
19375 XKY7 = 9.0 * PF2 / PI2 * XKAON0
19376 END IF
19377
19378 XM1 = AMRHO
19379 XM2 = AM1535
19380 PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19381 IF (PF2 .GT. 0.0) THEN
19382 XKY8 = 9.0 * PF2 / PI2 * XKAON0
19383 END IF
19384
19385 XM1 = AMOMGA
19386 XM2 = AMP
19387 PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19388 IF (PF2 .GT. 0.0) THEN
19389 XKY9 = 3.0 * PF2 / PI2 * XKAON0
19390 END IF
19391
19392 XM1 = AMOMGA
19393 XM2 = AM0
19394 PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19395 IF (PF2 .GT. 0.0) THEN
19396 XKY10 = 12.0 * PF2 / PI2 * XKAON0
19397 END IF
19398
19399 XM1 = AMOMGA
19400 XM2 = AM1440
19401 PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19402 IF (PF2 .GT. 0.0) THEN
19403 XKY11 = 3.0 * PF2 / PI2 * XKAON0
19404 END IF
19405
19406 XM1 = AMOMGA
19407 XM2 = AM1535
19408 PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19409 IF (PF2 .GT. 0.0) THEN
19410 XKY12 = 3.0 * PF2 / PI2 * XKAON0
19411 END IF
19412
19413 XM1 = AMETA
19414 XM2 = AMP
19415 PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19416 IF (PF2 .GT. 0.0) THEN
19417 XKY13 = 1.0 * PF2 / PI2 * XKAON0
19418 END IF
19419
19420 XM1 = AMETA
19421 XM2 = AM0
19422 PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19423 IF (PF2 .GT. 0.0) THEN
19424 XKY14 = 4.0 * PF2 / PI2 * XKAON0
19425 END IF
19426
19427 XM1 = AMETA
19428 XM2 = AM1440
19429 PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19430 IF (PF2 .GT. 0.0) THEN
19431 XKY15 = 1.0 * PF2 / PI2 * XKAON0
19432 END IF
19433
19434 XM1 = AMETA
19435 XM2 = AM1535
19436 PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19437 IF (PF2 .GT. 0.0) THEN
19438 XKY16 = 1.0 * PF2 / PI2 * XKAON0
19439 END IF
19440
19441csp11/21/01 K+ + La --> phi + N
19442 if(lb1.eq.14 .or. lb2.eq.14)then
19443 if(srt .gt. (aphi+amn))then
19444 srrt = srt - (aphi+amn)
19445 sig = 1.715/((srrt+3.508)**2-12.138)
19446 XM1 = AMN
19447 XM2 = APHI
19448 PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
19449c ! fm^-1
19450 XKY17 = 3.0 * PF2 / PI2 * SIG/10.
19451 endif
19452 endif
19453csp11/21/01 end
19454c
19455
19456 IF ((iabs(LB1) .GE. 15 .AND. iabs(LB1) .LE. 17) .OR.
19457 & (iabs(LB2) .GE. 15 .AND. iabs(LB2) .LE. 17)) THEN
19458 DDF = 3.0
19459 XKY1 = XKY1 / DDF
19460 XKY2 = XKY2 / DDF
19461 XKY3 = XKY3 / DDF
19462 XKY4 = XKY4 / DDF
19463 XKY5 = XKY5 / DDF
19464 XKY6 = XKY6 / DDF
19465 XKY7 = XKY7 / DDF
19466 XKY8 = XKY8 / DDF
19467 XKY9 = XKY9 / DDF
19468 XKY10 = XKY10/ DDF
19469 XKY11 = XKY11 / DDF
19470 XKY12 = XKY12 / DDF
19471 XKY13 = XKY13 / DDF
19472 XKY14 = XKY14 / DDF
19473 XKY15 = XKY15 / DDF
19474 XKY16 = XKY16 / DDF
19475 END IF
19476
19477 SIGK = XKY1 + XKY2 + XKY3 + XKY4 +
19478 & XKY5 + XKY6 + XKY7 + XKY8 +
19479 & XKY9 + XKY10 + XKY11 + XKY12 +
19480 & XKY13 + XKY14 + XKY15 + XKY16 + XKY17
19481
19482 RETURN
19483 END
19484
19485C*******************************
19486 BLOCK DATA PPBDAT
19487
19488 parameter (AMP=0.93828,AMN=0.939457,
19489 1 AM0=1.232,AM1440 = 1.44, AM1535 = 1.535)
19490
19491c to give default values to parameters for BbarB production from mesons
19492 COMMON/ppbmas/niso(15),nstate,ppbm(15,2),thresh(15),weight(15)
19493cc SAVE /ppbmas/
19494 common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
19495cc SAVE /ppb1/
19496 common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
19497cc SAVE /ppmm/
19498 SAVE
19499c thresh(i) gives the mass thresh for final channel i:
19500 DATA thresh/1.87656,1.877737,1.878914,2.17028,
19501 1 2.171457,2.37828,2.379457,2.464,2.47328,2.474457,
19502 2 2.672,2.767,2.88,2.975,3.07/
19503c ppbm(i,j=1,2) gives masses for the two final baryons of channel i,
19504c with j=1 for the lighter baryon:
19505 DATA (ppbm(i,1),i=1,15)/amp,amp,amn,amp,amn,amp,amn,
19506 1 am0,amp,amn,am0,am0,am1440,am1440,am1535/
19507 DATA (ppbm(i,2),i=1,15)/amp,amn,amn,am0,am0,am1440,am1440,
19508 1 am0,am1535,am1535,am1440,am1535,am1440,am1535,am1535/
19509c factr2(i) gives weights for producing i pions from ppbar annihilation:
19510 DATA factr2/0,1,1.17e-01,3.27e-03,3.58e-05,1.93e-07/
19511c niso(i) gives the degeneracy factor for final channel i:
19512 DATA niso/1,2,1,16,16,4,4,64,4,4,32,32,4,8,4/
19513
19514 END
19515
19516
19517*****************************************
19518* get the number of BbarB states available for mm collisions of energy srt
19519 subroutine getnst(srt)
19520* srt = DSQRT(s) in GeV *
19521*****************************************
19522 parameter (pimass=0.140,pi=3.1415926)
19523 COMMON/ppbmas/niso(15),nstate,ppbm(15,2),thresh(15),weight(15)
19524cc SAVE /ppbmas/
19525 common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
19526cc SAVE /ppb1/
19527 common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
19528cc SAVE /ppmm/
19529 SAVE
19530
19531 s=srt**2
19532 nstate=0
19533 wtot=0.
19534 if(srt.le.thresh(1)) return
19535 do 1001 i=1,15
19536 weight(i)=0.
19537 if(srt.gt.thresh(i)) nstate=i
19538 1001 continue
19539 do 1002 i=1,nstate
19540 pf2=(s-(ppbm(i,1)+ppbm(i,2))**2)
19541 1 *(s-(ppbm(i,1)-ppbm(i,2))**2)/4/s
19542 weight(i)=pf2*niso(i)
19543 wtot=wtot+weight(i)
19544 1002 continue
19545 ene=(srt/pimass)**3/(6.*pi**2)
19546 fsum=factr2(2)+factr2(3)*ene+factr2(4)*ene**2
19547 1 +factr2(5)*ene**3+factr2(6)*ene**4
19548
19549 return
19550 END
19551
19552*****************************************
19553* for pion+pion-->Bbar B *
19554c real*4 function ppbbar(srt)
19555 real function ppbbar(srt)
19556*****************************************
19557 parameter (pimass=0.140,arho=0.77,aomega=0.782)
19558 common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
19559cc SAVE /ppb1/
19560 common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
19561cc SAVE /ppmm/
19562 SAVE
19563
19564 sppb2p=xppbar(srt)*factr2(2)/fsum
19565 pi2=(s-4*pimass**2)/4
19566 ppbbar=4./9.*sppb2p/pi2*wtot
19567
19568 return
19569 END
19570
19571*****************************************
19572* for pion+rho-->Bbar B *
19573c real*4 function prbbar(srt)
19574 real function prbbar(srt)
19575*****************************************
19576 parameter (pimass=0.140,arho=0.77,aomega=0.782)
19577 common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
19578cc SAVE /ppb1/
19579 common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
19580cc SAVE /ppmm/
19581 SAVE
19582
19583 sppb3p=xppbar(srt)*factr2(3)*ene/fsum
19584 pi2=(s-(pimass+arho)**2)*(s-(pimass-arho)**2)/4/s
19585 prbbar=4./27.*sppb3p/pi2*wtot
19586
19587 return
19588 END
19589
19590*****************************************
19591* for rho+rho-->Bbar B *
19592c real*4 function rrbbar(srt)
19593 real function rrbbar(srt)
19594*****************************************
19595 parameter (pimass=0.140,arho=0.77,aomega=0.782)
19596 common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
19597cc SAVE /ppb1/
19598 common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
19599cc SAVE /ppmm/
19600 SAVE
19601
19602 sppb4p=xppbar(srt)*factr2(4)*ene**2/fsum
19603 pi2=(s-4*arho**2)/4
19604 rrbbar=4./81.*(sppb4p/2)/pi2*wtot
19605
19606 return
19607 END
19608
19609*****************************************
19610* for pi+omega-->Bbar B *
19611c real*4 function pobbar(srt)
19612 real function pobbar(srt)
19613*****************************************
19614 parameter (pimass=0.140,arho=0.77,aomega=0.782)
19615 common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
19616cc SAVE /ppb1/
19617 common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
19618cc SAVE /ppmm/
19619 SAVE
19620
19621 sppb4p=xppbar(srt)*factr2(4)*ene**2/fsum
19622 pi2=(s-(pimass+aomega)**2)*(s-(pimass-aomega)**2)/4/s
19623 pobbar=4./9.*(sppb4p/2)/pi2*wtot
19624
19625 return
19626 END
19627
19628*****************************************
19629* for rho+omega-->Bbar B *
19630c real*4 function robbar(srt)
19631 real function robbar(srt)
19632*****************************************
19633 parameter (pimass=0.140,arho=0.77,aomega=0.782)
19634 common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
19635cc SAVE /ppb1/
19636 common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
19637cc SAVE /ppmm/
19638 SAVE
19639
19640 sppb5p=xppbar(srt)*factr2(5)*ene**3/fsum
19641 pi2=(s-(arho+aomega)**2)*(s-(arho-aomega)**2)/4/s
19642 robbar=4./27.*sppb5p/pi2*wtot
19643
19644 return
19645 END
19646
19647*****************************************
19648* for omega+omega-->Bbar B *
19649c real*4 function oobbar(srt)
19650 real function oobbar(srt)
19651*****************************************
19652 parameter (pimass=0.140,arho=0.77,aomega=0.782)
19653 common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
19654cc SAVE /ppb1/
19655 common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
19656cc SAVE /ppmm/
19657 SAVE
19658
19659 sppb6p=xppbar(srt)*factr2(6)*ene**4/fsum
19660 pi2=(s-4*aomega**2)/4
19661 oobbar=4./9.*sppb6p/pi2*wtot
19662
19663 return
19664 END
19665
19666*****************************************
19667* Generate final states for mm-->Bbar B *
19668 SUBROUTINE bbarfs(lbb1,lbb2,ei1,ei2,iblock,iseed)
19669*****************************************
19670 COMMON/ppbmas/niso(15),nstate,ppbm(15,2),thresh(15),weight(15)
19671cc SAVE /ppbmas/
19672 common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
19673cc SAVE /ppb1/
19674 common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
19675cc SAVE /ppmm/
19676 COMMON/RNDF77/NSEED
19677cc SAVE /RNDF77/
19678 SAVE
19679 ISEED=ISEED
19680c determine which final BbarB channel occurs:
19681 rd=RANART(NSEED)
19682 wsum=0.
19683 do 1001 i=1,nstate
19684 wsum=wsum+weight(i)
19685 if(rd.le.(wsum/wtot)) then
19686 ifs=i
19687 ei1=ppbm(i,1)
19688 ei2=ppbm(i,2)
19689 goto 10
19690 endif
19691 1001 continue
19692 10 continue
19693
19694c1 pbar p
19695 if(ifs.eq.1) then
19696 iblock=1801
19697 lbb1=-1
19698 lbb2=1
19699 elseif(ifs.eq.2) then
19700c2 pbar n
19701 if(RANART(NSEED).le.0.5) then
19702 iblock=18021
19703 lbb1=-1
19704 lbb2=2
19705c2 nbar p
19706 else
19707 iblock=18022
19708 lbb1=1
19709 lbb2=-2
19710 endif
19711c3 nbar n
19712 elseif(ifs.eq.3) then
19713 iblock=1803
19714 lbb1=-2
19715 lbb2=2
19716c4&5 (pbar nbar) Delta, (p n) anti-Delta
19717 elseif(ifs.eq.4.or.ifs.eq.5) then
19718 rd=RANART(NSEED)
19719 if(rd.le.0.5) then
19720c (pbar nbar) Delta
19721 if(ifs.eq.4) then
19722 iblock=18041
19723 lbb1=-1
19724 else
19725 iblock=18051
19726 lbb1=-2
19727 endif
19728 rd2=RANART(NSEED)
19729 if(rd2.le.0.25) then
19730 lbb2=6
19731 elseif(rd2.le.0.5) then
19732 lbb2=7
19733 elseif(rd2.le.0.75) then
19734 lbb2=8
19735 else
19736 lbb2=9
19737 endif
19738 else
19739c (p n) anti-Delta
19740 if(ifs.eq.4) then
19741 iblock=18042
19742 lbb1=1
19743 else
19744 iblock=18052
19745 lbb1=2
19746 endif
19747 rd2=RANART(NSEED)
19748 if(rd2.le.0.25) then
19749 lbb2=-6
19750 elseif(rd2.le.0.5) then
19751 lbb2=-7
19752 elseif(rd2.le.0.75) then
19753 lbb2=-8
19754 else
19755 lbb2=-9
19756 endif
19757 endif
19758c6&7 (pbar nbar) N*(1440), (p n) anti-N*(1440)
19759 elseif(ifs.eq.6.or.ifs.eq.7) then
19760 rd=RANART(NSEED)
19761 if(rd.le.0.5) then
19762c (pbar nbar) N*(1440)
19763 if(ifs.eq.6) then
19764 iblock=18061
19765 lbb1=-1
19766 else
19767 iblock=18071
19768 lbb1=-2
19769 endif
19770 rd2=RANART(NSEED)
19771 if(rd2.le.0.5) then
19772 lbb2=10
19773 else
19774 lbb2=11
19775 endif
19776 else
19777c (p n) anti-N*(1440)
19778 if(ifs.eq.6) then
19779 iblock=18062
19780 lbb1=1
19781 else
19782 iblock=18072
19783 lbb1=2
19784 endif
19785 rd2=RANART(NSEED)
19786 if(rd2.le.0.5) then
19787 lbb2=-10
19788 else
19789 lbb2=-11
19790 endif
19791 endif
19792c8 Delta anti-Delta
19793 elseif(ifs.eq.8) then
19794 iblock=1808
19795 rd1=RANART(NSEED)
19796 if(rd1.le.0.25) then
19797 lbb1=6
19798 elseif(rd1.le.0.5) then
19799 lbb1=7
19800 elseif(rd1.le.0.75) then
19801 lbb1=8
19802 else
19803 lbb1=9
19804 endif
19805 rd2=RANART(NSEED)
19806 if(rd2.le.0.25) then
19807 lbb2=-6
19808 elseif(rd2.le.0.5) then
19809 lbb2=-7
19810 elseif(rd2.le.0.75) then
19811 lbb2=-8
19812 else
19813 lbb2=-9
19814 endif
19815c9&10 (pbar nbar) N*(1535), (p n) anti-N*(1535)
19816 elseif(ifs.eq.9.or.ifs.eq.10) then
19817 rd=RANART(NSEED)
19818 if(rd.le.0.5) then
19819c (pbar nbar) N*(1440)
19820 if(ifs.eq.9) then
19821 iblock=18091
19822 lbb1=-1
19823 else
19824 iblock=18101
19825 lbb1=-2
19826 endif
19827 rd2=RANART(NSEED)
19828 if(rd2.le.0.5) then
19829 lbb2=12
19830 else
19831 lbb2=13
19832 endif
19833 else
19834c (p n) anti-N*(1535)
19835 if(ifs.eq.9) then
19836 iblock=18092
19837 lbb1=1
19838 else
19839 iblock=18102
19840 lbb1=2
19841 endif
19842 rd2=RANART(NSEED)
19843 if(rd2.le.0.5) then
19844 lbb2=-12
19845 else
19846 lbb2=-13
19847 endif
19848 endif
19849c11&12 anti-Delta N*, Delta anti-N*
19850 elseif(ifs.eq.11.or.ifs.eq.12) then
19851 rd=RANART(NSEED)
19852 if(rd.le.0.5) then
19853c anti-Delta N*
19854 rd1=RANART(NSEED)
19855 if(rd1.le.0.25) then
19856 lbb1=-6
19857 elseif(rd1.le.0.5) then
19858 lbb1=-7
19859 elseif(rd1.le.0.75) then
19860 lbb1=-8
19861 else
19862 lbb1=-9
19863 endif
19864 if(ifs.eq.11) then
19865 iblock=18111
19866 rd2=RANART(NSEED)
19867 if(rd2.le.0.5) then
19868 lbb2=10
19869 else
19870 lbb2=11
19871 endif
19872 else
19873 iblock=18121
19874 rd2=RANART(NSEED)
19875 if(rd2.le.0.5) then
19876 lbb2=12
19877 else
19878 lbb2=13
19879 endif
19880 endif
19881 else
19882c Delta anti-N*
19883 rd1=RANART(NSEED)
19884 if(rd1.le.0.25) then
19885 lbb1=6
19886 elseif(rd1.le.0.5) then
19887 lbb1=7
19888 elseif(rd1.le.0.75) then
19889 lbb1=8
19890 else
19891 lbb1=9
19892 endif
19893 if(ifs.eq.11) then
19894 iblock=18112
19895 rd2=RANART(NSEED)
19896 if(rd2.le.0.5) then
19897 lbb2=-10
19898 else
19899 lbb2=-11
19900 endif
19901 else
19902 iblock=18122
19903 rd2=RANART(NSEED)
19904 if(rd2.le.0.5) then
19905 lbb2=-12
19906 else
19907 lbb2=-13
19908 endif
19909 endif
19910 endif
19911c13 N*(1440) anti-N*(1440)
19912 elseif(ifs.eq.13) then
19913 iblock=1813
19914 rd1=RANART(NSEED)
19915 if(rd1.le.0.5) then
19916 lbb1=10
19917 else
19918 lbb1=11
19919 endif
19920 rd2=RANART(NSEED)
19921 if(rd2.le.0.5) then
19922 lbb2=-10
19923 else
19924 lbb2=-11
19925 endif
19926c14 anti-N*(1440) N*(1535), N*(1440) anti-N*(1535)
19927 elseif(ifs.eq.14) then
19928 rd=RANART(NSEED)
19929 if(rd.le.0.5) then
19930c anti-N*(1440) N*(1535)
19931 iblock=18141
19932 rd1=RANART(NSEED)
19933 if(rd1.le.0.5) then
19934 lbb1=-10
19935 else
19936 lbb1=-11
19937 endif
19938 rd2=RANART(NSEED)
19939 if(rd2.le.0.5) then
19940 lbb2=12
19941 else
19942 lbb2=13
19943 endif
19944 else
19945c N*(1440) anti-N*(1535)
19946 iblock=18142
19947 rd1=RANART(NSEED)
19948 if(rd1.le.0.5) then
19949 lbb1=10
19950 else
19951 lbb1=11
19952 endif
19953 rd2=RANART(NSEED)
19954 if(rd2.le.0.5) then
19955 lbb2=-12
19956 else
19957 lbb2=-13
19958 endif
19959 endif
19960c15 N*(1535) anti-N*(1535)
19961 elseif(ifs.eq.15) then
19962 iblock=1815
19963 rd1=RANART(NSEED)
19964 if(rd1.le.0.5) then
19965 lbb1=12
19966 else
19967 lbb1=13
19968 endif
19969 rd2=RANART(NSEED)
19970 if(rd2.le.0.5) then
19971 lbb2=-12
19972 else
19973 lbb2=-13
19974 endif
19975 else
19976 endif
19977
19978 RETURN
19979 END
19980
19981*****************************************
19982* for pi pi <-> rho rho cross sections
19983 SUBROUTINE spprr(lb1,lb2,srt)
19984 parameter (arho=0.77)
19985 common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
19986cc SAVE /ppb1/
19987 common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
19988cc SAVE /ppmm/
19989 SAVE
19990
19991 pprr=0.
19992 if((lb1.ge.3.and.lb1.le.5).and.(lb2.ge.3.and.lb2.le.5)) then
19993c for now, rho mass taken to be the central value in these two processes
19994 if(srt.gt.(2*arho)) pprr=ptor(srt)
19995 elseif((lb1.ge.25.and.lb1.le.27).and.(lb2.ge.25.and.lb2.le.27))
19996 1 then
19997 pprr=rtop(srt)
19998 endif
19999c
20000 return
20001 END
20002
20003*****************************************
20004* for pi pi -> rho rho, determined from detailed balance
20005 real function ptor(srt)
20006*****************************************
20007 parameter (pimass=0.140,arho=0.77)
20008 common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20009cc SAVE /ppb1/
20010 common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20011cc SAVE /ppmm/
20012 SAVE
20013
20014 s2=srt**2
20015 ptor=9*(s2-4*arho**2)/(s2-4*pimass**2)*rtop(srt)
20016
20017 return
20018 END
20019
20020*****************************************
20021* for rho rho -> pi pi, assumed a constant cross section (in mb)
20022 real function rtop(srt)
20023*****************************************
20024 srt=srt
20025 rtop=5.
20026 return
20027 END
20028
20029*****************************************
20030* for pi pi <-> rho rho final states
20031 SUBROUTINE pi2ro2(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
20032 PARAMETER (MAXSTR=150001)
20033 PARAMETER (AP1=0.13496,AP2=0.13957)
20034 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
20035cc SAVE /EE/
20036 common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20037cc SAVE /ppb1/
20038 common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20039cc SAVE /ppmm/
20040 COMMON/RNDF77/NSEED
20041cc SAVE /RNDF77/
20042 SAVE
20043 iseed=iseed
20044 if((lb(i1).ge.3.and.lb(i1).le.5)
20045 1 .and.(lb(i2).ge.3.and.lb(i2).le.5)) then
20046 iblock=1850
20047 ei1=0.77
20048 ei2=0.77
20049c for now, we don't check isospin states(allowing pi+pi+ & pi0pi0 -> 2rho)
20050c thus the cross sections used are considered as the isospin-averaged ones.
20051 lbb1=25+int(3*RANART(NSEED))
20052 lbb2=25+int(3*RANART(NSEED))
20053 elseif((lb(i1).ge.25.and.lb(i1).le.27)
20054 1 .and.(lb(i2).ge.25.and.lb(i2).le.27)) then
20055 iblock=1851
20056 lbb1=3+int(3*RANART(NSEED))
20057 lbb2=3+int(3*RANART(NSEED))
20058 ei1=ap2
20059 ei2=ap2
20060 if(lbb1.eq.4) ei1=ap1
20061 if(lbb2.eq.4) ei2=ap1
20062 endif
20063
20064 return
20065 END
20066
20067*****************************************
20068* for pi pi <-> eta eta cross sections
20069 SUBROUTINE sppee(lb1,lb2,srt)
20070 parameter (ETAM=0.5475)
20071 common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20072cc SAVE /ppb1/
20073 common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20074cc SAVE /ppmm/
20075 SAVE
20076
20077 ppee=0.
20078 if((lb1.ge.3.and.lb1.le.5).and.(lb2.ge.3.and.lb2.le.5)) then
20079 if(srt.gt.(2*ETAM)) ppee=ptoe(srt)
20080 elseif(lb1.eq.0.and.lb2.eq.0) then
20081 ppee=etop(srt)
20082 endif
20083
20084 return
20085 END
20086
20087*****************************************
20088* for pi pi -> eta eta, determined from detailed balance, spin-isospin averaged
20089 real function ptoe(srt)
20090*****************************************
20091 parameter (pimass=0.140,ETAM=0.5475)
20092 common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20093cc SAVE /ppb1/
20094 common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20095cc SAVE /ppmm/
20096 SAVE
20097
20098 s2=srt**2
20099 ptoe=1./9.*(s2-4*etam**2)/(s2-4*pimass**2)*etop(srt)
20100
20101 return
20102 END
20103*****************************************
20104* for eta eta -> pi pi, assumed a constant cross section (in mb)
20105 real function etop(srt)
20106*****************************************
20107 srt=srt
20108c eta equilibration:
20109c most important channel is found to be pi pi <-> pi eta, then
20110c rho pi <-> rho eta.
20111 etop=5.
20112 return
20113 END
20114
20115*****************************************
20116* for pi pi <-> eta eta final states
20117 SUBROUTINE pi2et2(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
20118 PARAMETER (MAXSTR=150001)
20119 PARAMETER (AP1=0.13496,AP2=0.13957,ETAM=0.5475)
20120 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
20121cc SAVE /EE/
20122 common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20123cc SAVE /ppb1/
20124 common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20125cc SAVE /ppmm/
20126 COMMON/RNDF77/NSEED
20127cc SAVE /RNDF77/
20128 SAVE
20129
20130 iseed=iseed
20131 if((lb(i1).ge.3.and.lb(i1).le.5)
20132 1 .and.(lb(i2).ge.3.and.lb(i2).le.5)) then
20133 iblock=1860
20134 ei1=etam
20135 ei2=etam
20136c for now, we don't check isospin states(allowing pi+pi+ & pi0pi0 -> 2rho)
20137c thus the cross sections used are considered as the isospin-averaged ones.
20138 lbb1=0
20139 lbb2=0
20140 elseif(lb(i1).eq.0.and.lb(i2).eq.0) then
20141 iblock=1861
20142 lbb1=3+int(3*RANART(NSEED))
20143 lbb2=3+int(3*RANART(NSEED))
20144 ei1=ap2
20145 ei2=ap2
20146 if(lbb1.eq.4) ei1=ap1
20147 if(lbb2.eq.4) ei2=ap1
20148 endif
20149
20150 return
20151 END
20152
20153*****************************************
20154* for pi pi <-> pi eta cross sections
20155 SUBROUTINE spppe(lb1,lb2,srt)
20156 parameter (pimass=0.140,ETAM=0.5475)
20157 common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20158cc SAVE /ppb1/
20159 common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20160cc SAVE /ppmm/
20161 SAVE
20162
20163 pppe=0.
20164 if((lb1.ge.3.and.lb1.le.5).and.(lb2.ge.3.and.lb2.le.5)) then
20165 if(srt.gt.(ETAM+pimass)) pppe=pptope(srt)
20166 elseif((lb1.ge.3.and.lb1.le.5).and.lb2.eq.0) then
20167 pppe=petopp(srt)
20168 elseif((lb2.ge.3.and.lb2.le.5).and.lb1.eq.0) then
20169 pppe=petopp(srt)
20170 endif
20171
20172 return
20173 END
20174
20175*****************************************
20176* for pi pi -> pi eta, determined from detailed balance, spin-isospin averaged
20177 real function pptope(srt)
20178*****************************************
20179 parameter (pimass=0.140,ETAM=0.5475)
20180 common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20181cc SAVE /ppb1/
20182 common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20183cc SAVE /ppmm/
20184 SAVE
20185
20186 s2=srt**2
20187 pf2=(s2-(pimass+ETAM)**2)*(s2-(pimass-ETAM)**2)/2/sqrt(s2)
20188 pi2=(s2-4*pimass**2)*s2/2/sqrt(s2)
20189 pptope=1./3.*pf2/pi2*petopp(srt)
20190
20191 return
20192 END
20193*****************************************
20194* for pi eta -> pi pi, assumed a constant cross section (in mb)
20195 real function petopp(srt)
20196*****************************************
20197 srt=srt
20198c eta equilibration:
20199 petopp=5.
20200 return
20201 END
20202
20203*****************************************
20204* for pi pi <-> pi eta final states
20205 SUBROUTINE pi3eta(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
20206 PARAMETER (MAXSTR=150001)
20207 PARAMETER (AP1=0.13496,AP2=0.13957,ETAM=0.5475)
20208 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
20209cc SAVE /EE/
20210 common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20211cc SAVE /ppb1/
20212 common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20213cc SAVE /ppmm/
20214 COMMON/RNDF77/NSEED
20215cc SAVE /RNDF77/
20216 SAVE
20217
20218 ISEED=ISEED
20219 if((lb(i1).ge.3.and.lb(i1).le.5)
20220 1 .and.(lb(i2).ge.3.and.lb(i2).le.5)) then
20221 iblock=1870
20222 ei1=ap2
20223 ei2=etam
20224c for now, we don't check isospin states(allowing pi+pi+ & pi0pi0 -> 2rho)
20225c thus the cross sections used are considered as the isospin-averaged ones.
20226 lbb1=3+int(3*RANART(NSEED))
20227 if(lbb1.eq.4) ei1=ap1
20228 lbb2=0
20229 elseif((lb(i1).ge.3.and.lb(i1).le.5.and.lb(i2).eq.0).or.
20230 1 (lb(i2).ge.3.and.lb(i2).le.5.and.lb(i1).eq.0)) then
20231 iblock=1871
20232 lbb1=3+int(3*RANART(NSEED))
20233 lbb2=3+int(3*RANART(NSEED))
20234 ei1=ap2
20235 ei2=ap2
20236 if(lbb1.eq.4) ei1=ap1
20237 if(lbb2.eq.4) ei2=ap1
20238 endif
20239
20240 return
20241 END
20242
20243*****************************************
20244* for rho pi <-> rho eta cross sections
20245 SUBROUTINE srpre(lb1,lb2,srt)
20246 parameter (pimass=0.140,ETAM=0.5475,arho=0.77)
20247 common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20248cc SAVE /ppb1/
20249 common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20250cc SAVE /ppmm/
20251 SAVE
20252
20253 rpre=0.
20254 if(lb1.ge.25.and.lb1.le.27.and.lb2.ge.3.and.lb2.le.5) then
20255 if(srt.gt.(ETAM+arho)) rpre=rptore(srt)
20256 elseif(lb2.ge.25.and.lb2.le.27.and.lb1.ge.3.and.lb1.le.5) then
20257 if(srt.gt.(ETAM+arho)) rpre=rptore(srt)
20258 elseif(lb1.ge.25.and.lb1.le.27.and.lb2.eq.0) then
20259 if(srt.gt.(pimass+arho)) rpre=retorp(srt)
20260 elseif(lb2.ge.25.and.lb2.le.27.and.lb1.eq.0) then
20261 if(srt.gt.(pimass+arho)) rpre=retorp(srt)
20262 endif
20263
20264 return
20265 END
20266
20267*****************************************
20268* for rho pi->rho eta, determined from detailed balance, spin-isospin averaged
20269 real function rptore(srt)
20270*****************************************
20271 parameter (pimass=0.140,ETAM=0.5475,arho=0.77)
20272 common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20273cc SAVE /ppb1/
20274 common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20275cc SAVE /ppmm/
20276 SAVE
20277
20278 s2=srt**2
20279 pf2=(s2-(arho+ETAM)**2)*(s2-(arho-ETAM)**2)/2/sqrt(s2)
20280 pi2=(s2-(arho+pimass)**2)*(s2-(arho-pimass)**2)/2/sqrt(s2)
20281 rptore=1./3.*pf2/pi2*retorp(srt)
20282
20283 return
20284 END
20285*****************************************
20286* for rho eta -> rho pi, assumed a constant cross section (in mb)
20287 real function retorp(srt)
20288*****************************************
20289 srt=srt
20290c eta equilibration:
20291 retorp=5.
20292 return
20293 END
20294
20295*****************************************
20296* for rho pi <-> rho eta final states
20297 SUBROUTINE rpiret(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
20298 PARAMETER (MAXSTR=150001)
20299 PARAMETER (AP1=0.13496,AP2=0.13957,ETAM=0.5475,arho=0.77)
20300 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
20301cc SAVE /EE/
20302 common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20303cc SAVE /ppb1/
20304 common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20305cc SAVE /ppmm/
20306 COMMON/RNDF77/NSEED
20307cc SAVE /RNDF77/
20308 SAVE
20309 ISEED=ISEED
20310 if((lb(i1).ge.25.and.lb(i1).le.27
20311 1 .and.lb(i2).ge.3.and.lb(i2).le.5).or.
20312 2 (lb(i1).ge.3.and.lb(i1).le.5
20313 3 .and.lb(i2).ge.25.and.lb(i2).le.27)) then
20314 iblock=1880
20315 ei1=arho
20316 ei2=etam
20317c for now, we don't check isospin states(allowing pi+pi+ & pi0pi0 -> 2rho)
20318c thus the cross sections used are considered as the isospin-averaged ones.
20319 lbb1=25+int(3*RANART(NSEED))
20320 lbb2=0
20321 elseif((lb(i1).ge.25.and.lb(i1).le.27.and.lb(i2).eq.0).or.
20322 1 (lb(i2).ge.25.and.lb(i2).le.27.and.lb(i1).eq.0)) then
20323 iblock=1881
20324 lbb1=25+int(3*RANART(NSEED))
20325 lbb2=3+int(3*RANART(NSEED))
20326 ei1=arho
20327 ei2=ap2
20328 if(lbb2.eq.4) ei2=ap1
20329 endif
20330
20331 return
20332 END
20333
20334*****************************************
20335* for omega pi <-> omega eta cross sections
20336 SUBROUTINE sopoe(lb1,lb2,srt)
20337 parameter (ETAM=0.5475,aomega=0.782)
20338 common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20339cc SAVE /ppb1/
20340 common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20341cc SAVE /ppmm/
20342 SAVE
20343
20344 xopoe=0.
20345 if((lb1.eq.28.and.lb2.ge.3.and.lb2.le.5).or.
20346 1 (lb2.eq.28.and.lb1.ge.3.and.lb1.le.5)) then
20347 if(srt.gt.(aomega+ETAM)) xopoe=xop2oe(srt)
20348 elseif((lb1.eq.28.and.lb2.eq.0).or.
20349 1 (lb1.eq.0.and.lb2.eq.28)) then
20350 if(srt.gt.(aomega+ETAM)) xopoe=xoe2op(srt)
20351 endif
20352
20353 return
20354 END
20355
20356*****************************************
20357* for omega pi -> omega eta,
20358c determined from detailed balance, spin-isospin averaged
20359 real function xop2oe(srt)
20360*****************************************
20361 parameter (pimass=0.140,ETAM=0.5475,aomega=0.782)
20362 common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20363cc SAVE /ppb1/
20364 common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20365cc SAVE /ppmm/
20366 SAVE
20367
20368 s2=srt**2
20369 pf2=(s2-(aomega+ETAM)**2)*(s2-(aomega-ETAM)**2)/2/sqrt(s2)
20370 pi2=(s2-(aomega+pimass)**2)*(s2-(aomega-pimass)**2)/2/sqrt(s2)
20371 xop2oe=1./3.*pf2/pi2*xoe2op(srt)
20372
20373 return
20374 END
20375*****************************************
20376* for omega eta -> omega pi, assumed a constant cross section (in mb)
20377 real function xoe2op(srt)
20378*****************************************
20379 srt=srt
20380c eta equilibration:
20381 xoe2op=5.
20382 return
20383 END
20384
20385*****************************************
20386* for omega pi <-> omega eta final states
20387 SUBROUTINE opioet(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
20388 PARAMETER (MAXSTR=150001)
20389 PARAMETER (AP1=0.13496,AP2=0.13957,ETAM=0.5475,aomega=0.782)
20390 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
20391cc SAVE /EE/
20392 common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20393cc SAVE /ppb1/
20394 common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20395cc SAVE /ppmm/
20396 COMMON/RNDF77/NSEED
20397cc SAVE /RNDF77/
20398 SAVE
20399
20400 iseed=iseed
20401 if((lb(i1).ge.3.and.lb(i1).le.5.and.lb(i2).eq.28).or.
20402 1 (lb(i2).ge.3.and.lb(i2).le.5.and.lb(i1).eq.28)) then
20403 iblock=1890
20404 ei1=aomega
20405 ei2=etam
20406c for now, we don't check isospin states(allowing pi+pi+ & pi0pi0 -> 2rho)
20407c thus the cross sections used are considered as the isospin-averaged ones.
20408 lbb1=28
20409 lbb2=0
20410 elseif((lb(i1).eq.28.and.lb(i2).eq.0).or.
20411 1 (lb(i1).eq.0.and.lb(i2).eq.28)) then
20412 iblock=1891
20413 lbb1=28
20414 lbb2=3+int(3*RANART(NSEED))
20415 ei1=aomega
20416 ei2=ap2
20417 if(lbb2.eq.4) ei2=ap1
20418 endif
20419
20420 return
20421 END
20422
20423*****************************************
20424* for rho rho <-> eta eta cross sections
20425 SUBROUTINE srree(lb1,lb2,srt)
20426 parameter (ETAM=0.5475,arho=0.77)
20427 common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20428cc SAVE /ppb1/
20429 common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20430cc SAVE /ppmm/
20431 SAVE
20432
20433 rree=0.
20434 if(lb1.ge.25.and.lb1.le.27.and.
20435 1 lb2.ge.25.and.lb2.le.27) then
20436 if(srt.gt.(2*ETAM)) rree=rrtoee(srt)
20437 elseif(lb1.eq.0.and.lb2.eq.0) then
20438 if(srt.gt.(2*arho)) rree=eetorr(srt)
20439 endif
20440
20441 return
20442 END
20443
20444*****************************************
20445* for eta eta -> rho rho
20446c determined from detailed balance, spin-isospin averaged
20447 real function eetorr(srt)
20448*****************************************
20449 parameter (ETAM=0.5475,arho=0.77)
20450 common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20451cc SAVE /ppb1/
20452 common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20453cc SAVE /ppmm/
20454 SAVE
20455
20456 s2=srt**2
20457 eetorr=81.*(s2-4*arho**2)/(s2-4*etam**2)*rrtoee(srt)
20458
20459 return
20460 END
20461*****************************************
20462* for rho rho -> eta eta, assumed a constant cross section (in mb)
20463 real function rrtoee(srt)
20464*****************************************
20465 srt=srt
20466c eta equilibration:
20467 rrtoee=5.
20468 return
20469 END
20470
20471*****************************************
20472* for rho rho <-> eta eta final states
20473 SUBROUTINE ro2et2(i1,i2,lbb1,lbb2,ei1,ei2,iblock,iseed)
20474 PARAMETER (MAXSTR=150001)
20475 parameter (ETAM=0.5475,arho=0.77)
20476 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
20477cc SAVE /EE/
20478 common/ppb1/ene,factr2(6),fsum,ppinnb,s,wtot
20479cc SAVE /ppb1/
20480 common/ppmm/pprr,ppee,pppe,rpre,xopoe,rree
20481cc SAVE /ppmm/
20482 COMMON/RNDF77/NSEED
20483cc SAVE /RNDF77/
20484 SAVE
20485
20486 ISEED=ISEED
20487 if(lb(i1).ge.25.and.lb(i1).le.27.and.
20488 1 lb(i2).ge.25.and.lb(i2).le.27) then
20489 iblock=1895
20490 ei1=etam
20491 ei2=etam
20492c for now, we don't check isospin states(allowing pi+pi+ & pi0pi0 -> 2rho)
20493c thus the cross sections used are considered as the isospin-averaged ones.
20494 lbb1=0
20495 lbb2=0
20496 elseif(lb(i1).eq.0.and.lb(i2).eq.0) then
20497 iblock=1896
20498 lbb1=25+int(3*RANART(NSEED))
20499 lbb2=25+int(3*RANART(NSEED))
20500 ei1=arho
20501 ei2=arho
20502 endif
20503
20504 return
20505 END
20506
20507*****************************
20508* purpose: Xsection for K* Kbar or K*bar K to pi(eta) rho(omega)
20509 SUBROUTINE XKKSAN(i1,i2,SRT,SIGKS1,SIGKS2,SIGKS3,SIGKS4,SIGK,prkk)
20510* srt = DSQRT(s) in GeV *
20511* sigk = xsection in mb obtained from *
20512* the detailed balance *
20513* ***************************
20514 PARAMETER (AKA=0.498, PIMASS=0.140, RHOM = 0.770,aks=0.895,
20515 & OMEGAM = 0.7819, ETAM = 0.5473)
20516 PARAMETER (MAXSTR=150001)
20517 COMMON /CC/ E(MAXSTR)
20518cc SAVE /CC/
20519 SAVE
20520
20521 S = SRT ** 2
20522 SIGKS1 = 1.E-08
20523 SIGKS2 = 1.E-08
20524 SIGKS3 = 1.E-08
20525 SIGKS4 = 1.E-08
20526
20527 XPION0 = prkk
20528clin note that prkk is for pi (rho omega) -> K* Kbar (AND!) K*bar K:
20529 XPION0 = XPION0/2
20530
20531cc
20532c PI2 = (S - (aks + AKA) ** 2) * (S - (aks - AKA) ** 2)
20533 PI2 = (S - (e(i1) + e(i2)) ** 2) * (S - (e(i1) - e(i2)) ** 2)
20534 SIGK = 1.E-08
20535 if(PI2 .le. 0.0) return
20536
20537 XM1 = PIMASS
20538 XM2 = RHOM
20539 PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
20540 IF (PI2 .GT. 0.0 .AND. PF2 .GT. 0.0) THEN
20541 SIGKS1 = 27.0 / 4.0 * PF2 / PI2 * XPION0
20542 END IF
20543
20544 XM1 = PIMASS
20545 XM2 = OMEGAM
20546 PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
20547 IF (PI2 .GT. 0.0 .AND. PF2 .GT. 0.0) THEN
20548 SIGKS2 = 9.0 / 4.0 * PF2 / PI2 * XPION0
20549 END IF
20550
20551 XM1 = RHOM
20552 XM2 = ETAM
20553 PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
20554 IF (PF2 .GT. 0.0) THEN
20555 SIGKS3 = 9.0 / 4.0 * PF2 / PI2 * XPION0
20556 END IF
20557
20558 XM1 = OMEGAM
20559 XM2 = ETAM
20560 PF2 = (S - (XM1 + XM2) ** 2) * (S - (XM1 - XM2) ** 2)
20561 IF (PF2 .GT. 0.0) THEN
20562 SIGKS4 = 3.0 / 4.0 * PF2 / PI2 * XPION0
20563 END IF
20564
20565 SIGK=SIGKS1+SIGKS2+SIGKS3+SIGKS4
20566
20567 RETURN
20568 END
20569
20570**********************************
20571* PURPOSE: *
20572* assign final states for KK*bar or K*Kbar --> light mesons
20573*
20574c SUBROUTINE Crkspi(PX,PY,PZ,SRT,I1,I2,IBLOCK)
20575 SUBROUTINE crkspi(I1,I2,XSK1, XSK2, XSK3, XSK4, SIGK,
20576 & IBLOCK,lbp1,lbp2,emm1,emm2)
20577* iblock - 466
20578**********************************
20579 PARAMETER (MAXSTR=150001,MAXR=1)
20580 PARAMETER (AP1=0.13496,AP2=0.13957,RHOM = 0.770,PI=3.1415926)
20581 PARAMETER (AETA=0.548,AMOMGA=0.782)
20582 parameter (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
20583 COMMON /AA/ R(3,MAXSTR)
20584cc SAVE /AA/
20585 COMMON /BB/ P(3,MAXSTR)
20586cc SAVE /BB/
20587 COMMON /CC/ E(MAXSTR)
20588cc SAVE /CC/
20589 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
20590cc SAVE /EE/
20591 common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
20592cc SAVE /input1/
20593 COMMON/RNDF77/NSEED
20594cc SAVE /RNDF77/
20595 SAVE
20596
20597 IBLOCK=466
20598* charges of final state mesons:
20599
20600 X1 = RANART(NSEED) * SIGK
20601 XSK2 = XSK1 + XSK2
20602 XSK3 = XSK2 + XSK3
20603 XSK4 = XSK3 + XSK4
20604 IF (X1 .LE. XSK1) THEN
20605 LB(I1) = 3 + int(3 * RANART(NSEED))
20606 LB(I2) = 25 + int(3 * RANART(NSEED))
20607 E(I1) = AP2
20608 E(I2) = rhom
20609 ELSE IF (X1 .LE. XSK2) THEN
20610 LB(I1) = 3 + int(3 * RANART(NSEED))
20611 LB(I2) = 28
20612 E(I1) = AP2
20613 E(I2) = AMOMGA
20614 ELSE IF (X1 .LE. XSK3) THEN
20615 LB(I1) = 0
20616 LB(I2) = 25 + int(3 * RANART(NSEED))
20617 E(I1) = AETA
20618 E(I2) = rhom
20619 ELSE
20620 LB(I1) = 0
20621 LB(I2) = 28
20622 E(I1) = AETA
20623 E(I2) = AMOMGA
20624 ENDIF
20625
20626 if(lb(i1).eq.4) E(I1) = AP1
20627 lbp1=lb(i1)
20628 lbp2=lb(i2)
20629 emm1=e(i1)
20630 emm2=e(i2)
20631
20632 RETURN
20633 END
20634
20635*---------------------------------------------------------------------------
20636* PURPOSE : CALCULATE THE MASS AND MOMENTUM OF K* RESONANCE
20637* AFTER PION + KAON COLLISION
20638*clin only here the K* mass may be different from aks=0.895
20639 SUBROUTINE KSRESO(I1,I2)
20640 PARAMETER (MAXSTR=150001,MAXR=1,
20641 1 AMN=0.939457,AMP=0.93828,
20642 2 AP1=0.13496,AP2=0.13957,AM0=1.232,PI=3.1415926)
20643 COMMON /AA/ R(3,MAXSTR)
20644cc SAVE /AA/
20645 COMMON /BB/ P(3,MAXSTR)
20646cc SAVE /BB/
20647 COMMON /CC/ E(MAXSTR)
20648cc SAVE /CC/
20649 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
20650cc SAVE /EE/
20651 COMMON /RUN/NUM
20652cc SAVE /RUN/
20653 COMMON /PA/RPION(3,MAXSTR,MAXR)
20654cc SAVE /PA/
20655 COMMON /PB/PPION(3,MAXSTR,MAXR)
20656cc SAVE /PB/
20657 COMMON /PC/EPION(MAXSTR,MAXR)
20658cc SAVE /PC/
20659 COMMON /PD/LPION(MAXSTR,MAXR)
20660cc SAVE /PD/
20661 SAVE
20662* 1. DETERMINE THE MOMENTUM COMPONENT OF THE K* IN THE CMS OF PI-K FRAME
20663* WE LET I1 TO BE THE K* AND ABSORB I2
20664 E10=SQRT(E(I1)**2+P(1,I1)**2+P(2,I1)**2+P(3,I1)**2)
20665 E20=SQRT(E(I2)**2+P(1,I2)**2+P(2,I2)**2+P(3,I2)**2)
20666 IF(LB(I2) .EQ. 21 .OR. LB(I2) .EQ. 23) THEN
20667 E(I1)=0.
20668 I=I2
20669 ELSE
20670 E(I2)=0.
20671 I=I1
20672 ENDIF
20673 if(LB(I).eq.23) then
20674 LB(I)=30
20675 else if(LB(I).eq.21) then
20676 LB(I)=-30
20677 endif
20678 P(1,I)=P(1,I1)+P(1,I2)
20679 P(2,I)=P(2,I1)+P(2,I2)
20680 P(3,I)=P(3,I1)+P(3,I2)
20681* 2. DETERMINE THE MASS OF K* BY USING THE REACTION KINEMATICS
20682 DM=SQRT((E10+E20)**2-P(1,I)**2-P(2,I)**2-P(3,I)**2)
20683 E(I)=DM
20684 RETURN
20685 END
20686
20687c--------------------------------------------------------
20688*************************************
20689* *
20690 SUBROUTINE pertur(PX,PY,PZ,SRT,IRUN,I1,I2,nt,kp,icont)
20691* *
20692* PURPOSE: TO PRODUCE CASCADE AND OMEGA PERTURBATIVELY *
20693c sp 01/03/01
20694* 40 cascade-
20695* -40 cascade-(bar)
20696* 41 cascade0
20697* -41 cascade0(bar)
20698* 45 Omega baryon
20699* -45 Omega baryon(bar)
20700* 44 Di-Omega
20701**********************************
20702 PARAMETER (MAXSTR=150001,MAXR=1,PI=3.1415926)
20703 parameter (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
20704 PARAMETER (AMN=0.939457,AMP=0.93828,AP1=0.13496,AP2=0.13957)
20705 PARAMETER (AKA=0.498,ALA=1.1157,ASA=1.1974,aks=0.895)
20706 PARAMETER (ACAS=1.3213,AOME=1.6724,AMRHO=0.769,AMOMGA=0.782)
20707 PARAMETER (AETA=0.548,ADIOMG=3.2288)
20708 parameter (maxx=20,maxz=24)
20709 COMMON /AA/ R(3,MAXSTR)
20710cc SAVE /AA/
20711 COMMON /BB/ P(3,MAXSTR)
20712cc SAVE /BB/
20713 COMMON /CC/ E(MAXSTR)
20714cc SAVE /CC/
20715 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
20716cc SAVE /EE/
20717 COMMON /HH/ PROPER(MAXSTR)
20718cc SAVE /HH/
20719 common /ff/f(-mx:mx,-my:my,-mz:mz,-mpx:mpx,-mpy:mpy,-mpz:mpzp)
20720cc SAVE /ff/
20721 common /gg/ dx,dy,dz,dpx,dpy,dpz
20722cc SAVE /gg/
20723 COMMON /INPUT/ NSTAR,NDIRCT,DIR
20724cc SAVE /INPUT/
20725 COMMON /NN/NNN
20726cc SAVE /NN/
20727 COMMON /PA/RPION(3,MAXSTR,MAXR)
20728cc SAVE /PA/
20729 COMMON /PB/PPION(3,MAXSTR,MAXR)
20730cc SAVE /PB/
20731 COMMON /PC/EPION(MAXSTR,MAXR)
20732cc SAVE /PC/
20733 COMMON /PD/LPION(MAXSTR,MAXR)
20734cc SAVE /PD/
20735 COMMON /PE/PROPI(MAXSTR,MAXR)
20736cc SAVE /PE/
20737 COMMON /RR/ MASSR(0:MAXR)
20738cc SAVE /RR/
20739 COMMON /BG/BETAX,BETAY,BETAZ,GAMMA
20740cc SAVE /BG/
20741 common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
20742cc SAVE /input1/
20743c perturbative method is disabled:
20744c common /imulst/ iperts
20745c
20746 COMMON/RNDF77/NSEED
20747cc SAVE /RNDF77/
20748 COMMON /dpert/dpertt(MAXSTR,MAXR),dpertp(MAXSTR),dplast(MAXSTR),
20749 1 dpdcy(MAXSTR),dpdpi(MAXSTR,MAXR),dpt(MAXSTR, MAXR),
20750 2 dpp1(MAXSTR,MAXR),dppion(MAXSTR,MAXR)
20751 SAVE
20752 kp=kp
20753 nt=nt
20754
20755 px0 = px
20756 py0 = py
20757 pz0 = pz
20758 LB1 = LB(I1)
20759 EM1 = E(I1)
20760 X1 = R(1,I1)
20761 Y1 = R(2,I1)
20762 Z1 = R(3,I1)
20763 prob1 = PROPER(I1)
20764c
20765 LB2 = LB(I2)
20766 EM2 = E(I2)
20767 X2 = R(1,I2)
20768 Y2 = R(2,I2)
20769 Z2 = R(3,I2)
20770 prob2 = PROPER(I2)
20771c
20772c !! flag for real 2-body process (1/0=no/yes)
20773 icont = 1
20774c !! flag for elastic scatt only (-1=no)
20775 icsbel = -1
20776
20777* K-/K*0bar + La/Si --> cascade + pi
20778* K+/K*0 + La/Si (bar) --> cascade-bar + pi
20779 if( (lb1.eq.21.or.lb1.eq.23.or.iabs(lb1).eq.30) .and.
20780 & (iabs(lb2).ge.14.and.iabs(lb2).le.17) )go to 60
20781 if( (lb2.eq.21.or.lb2.eq.23.or.iabs(lb2).eq.30) .and.
20782 & (iabs(lb1).ge.14.and.iabs(lb1).le.17) )go to 60
20783* K-/K*0bar + cascade --> omega + pi
20784* K+/K*0 + cascade-bar --> omega-bar + pi
20785 if( (lb1.eq.21.or.lb1.eq.23.or.iabs(lb1).eq.30) .and.
20786 & (iabs(lb2).eq.40.or.iabs(lb2).eq.41) )go to 70
20787 if( (lb2.eq.21.or.lb2.eq.23.or.iabs(lb2).eq.30) .and.
20788 & (iabs(lb1).eq.40.or.iabs(lb1).eq.41) )go to 70
20789c
20790c annhilation of cascade,cascade-bar, omega,omega-bar
20791c
20792* K- + La/Si <-- cascade + pi(eta,rho,omega)
20793* K+ + La/Si(bar) <-- cascade-bar + pi(eta,rho,omega)
20794 if( (((lb1.ge.3.and.lb1.le.5).or.lb1.eq.0)
20795 & .and.(iabs(lb2).eq.40.or.iabs(lb2).eq.41))
20796 & .OR. (((lb2.ge.3.and.lb2.le.5).or.lb2.eq.0)
20797 & .and.(iabs(lb1).eq.40.or.iabs(lb1).eq.41)) )go to 90
20798* K- + cascade <-- omega + pi
20799* K+ + cascade-bar <-- omega-bar + pi
20800c if( (lb1.eq.0.and.iabs(lb2).eq.45)
20801c & .OR. (lb2.eq.0.and.iabs(lb1).eq.45) ) go to 110
20802 if( ((lb1.ge.3.and.lb1.le.5).and.iabs(lb2).eq.45)
20803 & .OR.((lb2.ge.3.and.lb2.le.5).and.iabs(lb1).eq.45) )go to 110
20804c
20805
20806c----------------------------------------------------
20807* for process: K-bar + L(S) --> Ca + pi
20808*
2080960 if(iabs(lb1).ge.14 .and. iabs(lb1).le.17)then
20810 asap = e(i1)
20811 akap = e(i2)
20812 idp = i1
20813 else
20814 asap = e(i2)
20815 akap = e(i1)
20816 idp = i2
20817 endif
20818 app = 0.138
20819 if(srt .lt. (acas+app))return
20820 srrt = srt - (acas+app) + (amn+akap)
20821 pkaon = sqrt(((srrt**2-(amn**2+akap**2))/2./amn)**2 - akap**2)
20822 sigca = 1.5*( akNPsg(pkaon)+akNPsg(pkaon) )
20823clin pii & pff should be each divided by (4*srt**2),
20824c but these two factors cancel out in the ratio pii/pff:
20825 pii = sqrt((srt**2-(amn+akap)**2)*(srt**2-(amn-akap)**2))
20826 pff = sqrt((srt**2-(asap+app)**2)*(srt**2-(asap-app)**2))
20827 cmat = sigca*pii/pff
20828 sigpi = cmat*
20829 & sqrt((srt**2-(acas+app)**2)*(srt**2-(acas-app)**2))/
20830 & sqrt((srt**2-(asap+akap)**2)*(srt**2-(asap-akap)**2))
20831c
20832 sigeta = 0.
20833 if(srt .gt. (acas+aeta))then
20834 srrt = srt - (acas+aeta) + (amn+akap)
20835 pkaon = sqrt(((srrt**2-(amn**2+akap**2))/2./amn)**2 - akap**2)
20836 sigca = 1.5*( akNPsg(pkaon)+akNPsg(pkaon) )
20837 cmat = sigca*pii/pff
20838 sigeta = cmat*
20839 & sqrt((srt**2-(acas+aeta)**2)*(srt**2-(acas-aeta)**2))/
20840 & sqrt((srt**2-(asap+akap)**2)*(srt**2-(asap-akap)**2))
20841 endif
20842c
20843 sigca = sigpi + sigeta
20844 sigpe = 0.
20845clin-2/25/03 disable the perturb option:
20846c if(iperts .eq. 1) sigpe = 40. !! perturbative xsecn
20847 sig = amax1(sigpe,sigca)
20848 ds = sqrt(sig/31.4)
20849 dsr = ds + 0.1
20850 ec = (em1+em2+0.02)**2
20851 call distce(i1,i2,dsr,ds,dt,ec,srt,ic,px,py,pz)
20852 if(ic .eq. -1)return
20853 brpp = sigca/sig
20854c
20855c else particle production
20856 if( (lb1.ge.14.and.lb1.le.17) .or.
20857 & (lb2.ge.14.and.lb2.le.17) )then
20858c !! cascade- or cascde0
20859 lbpp1 = 40 + int(2*RANART(NSEED))
20860 else
20861* elseif(lb1 .eq. -14 .or. lb2 .eq. -14)
20862c !! cascade-bar- or cascde0 -bar
20863 lbpp1 = -40 - int(2*RANART(NSEED))
20864 endif
20865 empp1 = acas
20866 if(RANART(NSEED) .lt. sigpi/sigca)then
20867c !! pion
20868 lbpp2 = 3 + int(3*RANART(NSEED))
20869 empp2 = 0.138
20870 else
20871c !! eta
20872 lbpp2 = 0
20873 empp2 = aeta
20874 endif
20875c* check real process of cascade(bar) and pion formation
20876 if(RANART(NSEED) .lt. brpp)then
20877c !! real process flag
20878 icont = 0
20879 lb(i1) = lbpp1
20880 e(i1) = empp1
20881c !! cascade formed with prob Gam
20882 proper(i1) = brpp
20883 lb(i2) = lbpp2
20884 e(i2) = empp2
20885c !! pion/eta formed with prob 1.
20886 proper(i2) = 1.
20887 endif
20888c else only cascade(bar) formed perturbatively
20889 go to 700
20890
20891c----------------------------------------------------
20892* for process: Cas(bar) + K_bar(K) --> Om(bar) + pi !! eta
20893*
2089470 if(iabs(lb1).eq.40 .or. iabs(lb1).eq.41)then
20895 acap = e(i1)
20896 akap = e(i2)
20897 idp = i1
20898 else
20899 acap = e(i2)
20900 akap = e(i1)
20901 idp = i2
20902 endif
20903 app = 0.138
20904* ames = aeta
20905c !! only pion
20906 ames = 0.138
20907 if(srt .lt. (aome+ames))return
20908 srrt = srt - (aome+ames) + (amn+akap)
20909 pkaon = sqrt(((srrt**2-(amn**2+akap**2))/2./amn)**2 - akap**2)
20910c use K(bar) + Ca --> Om + eta xsecn same as K(bar) + N --> Si + Pi
20911* as Omega have no resonances
20912c** using same matrix elements as K-bar + N -> Si + pi
20913 sigomm = 1.5*( akNPsg(pkaon)+akNPsg(pkaon) )
20914 cmat = sigomm*
20915 & sqrt((srt**2-(amn+akap)**2)*(srt**2-(amn-akap)**2))/
20916 & sqrt((srt**2-(asa+app)**2)*(srt**2-(asa-app)**2))
20917 sigom = cmat*
20918 & sqrt((srt**2-(aome+ames)**2)*(srt**2-(aome-ames)**2))/
20919 & sqrt((srt**2-(acap+akap)**2)*(srt**2-(acap-akap)**2))
20920 sigpe = 0.
20921clin-2/25/03 disable the perturb option:
20922c if(iperts .eq. 1) sigpe = 40. !! perturbative xsecn
20923 sig = amax1(sigpe,sigom)
20924 ds = sqrt(sig/31.4)
20925 dsr = ds + 0.1
20926 ec = (em1+em2+0.02)**2
20927 call distce(i1,i2,dsr,ds,dt,ec,srt,ic,px,py,pz)
20928 if(ic .eq. -1)return
20929 brpp = sigom/sig
20930c
20931c else particle production
20932 if( (lb1.ge.40.and.lb1.le.41) .or.
20933 & (lb2.ge.40.and.lb2.le.41) )then
20934c !! omega
20935 lbpp1 = 45
20936 else
20937* elseif(lb1 .eq. -40 .or. lb2 .eq. -40)
20938c !! omega-bar
20939 lbpp1 = -45
20940 endif
20941 empp1 = aome
20942* lbpp2 = 0 !! eta
20943c !! pion
20944 lbpp2 = 3 + int(3*RANART(NSEED))
20945 empp2 = ames
20946c
20947c* check real process of omega(bar) and pion formation
20948 xrand=RANART(NSEED)
20949 if(xrand .lt. (proper(idp)*brpp))then
20950c !! real process flag
20951 icont = 0
20952 lb(i1) = lbpp1
20953 e(i1) = empp1
20954c !! P_Om = P_Cas*Gam
20955 proper(i1) = proper(idp)*brpp
20956 lb(i2) = lbpp2
20957 e(i2) = empp2
20958c !! pion formed with prob 1.
20959 proper(i2) = 1.
20960 elseif(xrand.lt.brpp) then
20961c else omega(bar) formed perturbatively and cascade destroyed
20962 e(idp) = 0.
20963 endif
20964 go to 700
20965
20966c-----------------------------------------------------------
20967* for process: Ca + pi/eta --> K-bar + L(S)
20968*
2096990 if(iabs(lb1).eq.40 .or. iabs(lb1).eq.41)then
20970 acap = e(i1)
20971 app = e(i2)
20972 idp = i1
20973 idn = i2
20974 else
20975 acap = e(i2)
20976 app = e(i1)
20977 idp = i2
20978 idn = i1
20979 endif
20980c akal = (aka+aks)/2. !! average of K and K* taken
20981c !! using K only
20982 akal = aka
20983c
20984 alas = ala
20985 if(srt .le. (alas+aka))return
20986 srrt = srt - (acap+app) + (amn+aka)
20987 pkaon = sqrt(((srrt**2-(amn**2+aka**2))/2./amn)**2 - aka**2)
20988c** using same matrix elements as K-bar + N -> La/Si + pi
20989 sigca = 1.5*( akNPsg(pkaon)+akNPsg(pkaon) )
20990 cmat = sigca*
20991 & sqrt((srt**2-(amn+aka)**2)*(srt**2-(amn-aka)**2))/
20992 & sqrt((srt**2-(alas+0.138)**2)*(srt**2-(alas-0.138)**2))
20993 sigca = cmat*
20994 & sqrt((srt**2-(acap+app)**2)*(srt**2-(acap-app)**2))/
20995 & sqrt((srt**2-(alas+aka)**2)*(srt**2-(alas-aka)**2))
20996c !! pi
20997 dfr = 1./3.
20998c !! eta
20999 if(lb(idn).eq.0)dfr = 1.
21000 sigcal = sigca*dfr*(srt**2-(alas+aka)**2)*
21001 & (srt**2-(alas-aka)**2)/(srt**2-(acap+app)**2)/
21002 & (srt**2-(acap-app)**2)
21003c
21004 alas = ASA
21005 if(srt .le. (alas+aka))then
21006 sigcas = 0.
21007 else
21008 srrt = srt - (acap+app) + (amn+aka)
21009 pkaon = sqrt(((srrt**2-(amn**2+aka**2))/2./amn)**2 - aka**2)
21010c use K(bar) + La/Si --> Ca + Pi xsecn same as K(bar) + N --> Si + Pi
21011c** using same matrix elements as K-bar + N -> La/Si + pi
21012 sigca = 1.5*( akNPsg(pkaon)+akNPsg(pkaon) )
21013 cmat = sigca*
21014 & sqrt((srt**2-(amn+aka)**2)*(srt**2-(amn-aka)**2))/
21015 & sqrt((srt**2-(alas+0.138)**2)*(srt**2-(alas-0.138)**2))
21016 sigca = cmat*
21017 & sqrt((srt**2-(acap+app)**2)*(srt**2-(acap-app)**2))/
21018 & sqrt((srt**2-(alas+aka)**2)*(srt**2-(alas-aka)**2))
21019c !! pi
21020 dfr = 1.
21021c !! eta
21022 if(lb(idn).eq.0)dfr = 3.
21023 sigcas = sigca*dfr*(srt**2-(alas+aka)**2)*
21024 & (srt**2-(alas-aka)**2)/(srt**2-(acap+app)**2)/
21025 & (srt**2-(acap-app)**2)
21026 endif
21027c
21028 sig = sigcal + sigcas
21029 brpp = 1.
21030 ds = sqrt(sig/31.4)
21031 dsr = ds + 0.1
21032 ec = (em1+em2+0.02)**2
21033 call distce(i1,i2,dsr,ds,dt,ec,srt,ic,px,py,pz)
21034c
21035clin-2/25/03: checking elastic scatt after failure of inelastic scatt gives
21036c conditional probability (in general incorrect), tell Pal to correct:
21037 if(ic .eq. -1)then
21038c check for elastic scatt, no particle annhilation
21039c !! elastic cross section of 20 mb
21040 ds = sqrt(20.0/31.4)
21041 dsr = ds + 0.1
21042 call distce(i1,i2,dsr,ds,dt,ec,srt,icsbel,px,py,pz)
21043 if(icsbel .eq. -1)return
21044 empp1 = EM1
21045 empp2 = EM2
21046 go to 700
21047 endif
21048c
21049c else pert. produced cascade(bar) is annhilated OR real process
21050c
21051* DECIDE LAMBDA OR SIGMA PRODUCTION
21052c
21053 IF(sigcal/sig .GT. RANART(NSEED))THEN
21054 if(lb1.eq.40.or.lb1.eq.41.or.lb2.eq.40.or.lb2.eq.41)then
21055 lbpp1 = 21
21056 lbpp2 = 14
21057 else
21058 lbpp1 = 23
21059 lbpp2 = -14
21060 endif
21061 alas = ala
21062 ELSE
21063 if(lb1.eq.40.or.lb1.eq.41.or.lb2.eq.40.or.lb2.eq.41)then
21064 lbpp1 = 21
21065 lbpp2 = 15 + int(3 * RANART(NSEED))
21066 else
21067 lbpp1 = 23
21068 lbpp2 = -15 - int(3 * RANART(NSEED))
21069 endif
21070 alas = ASA
21071 ENDIF
21072 empp1 = aka
21073 empp2 = alas
21074c
21075c check for real process for L/S(bar) and K(bar) formation
21076 if(RANART(NSEED) .lt. proper(idp))then
21077* real process
21078c !! real process flag
21079 icont = 0
21080 lb(i1) = lbpp1
21081 e(i1) = empp1
21082c !! K(bar) formed with prob 1.
21083 proper(i1) = 1.
21084 lb(i2) = lbpp2
21085 e(i2) = empp2
21086c !! L/S(bar) formed with prob 1.
21087 proper(i2) = 1.
21088 go to 700
21089 else
21090c else only cascade(bar) annhilation & go out
21091 e(idp) = 0.
21092 endif
21093 return
21094c
21095c----------------------------------------------------
21096* for process: Om(bar) + pi --> Cas(bar) + K_bar(K)
21097*
21098110 if(lb1 .eq. 45 .or. lb1 .eq. -45)then
21099 aomp = e(i1)
21100 app = e(i2)
21101 idp = i1
21102 idn = i2
21103 else
21104 aomp = e(i2)
21105 app = e(i1)
21106 idp = i2
21107 idn = i1
21108 endif
21109c akal = (aka+aks)/2. !! average of K and K* taken
21110c !! using K only
21111 akal = aka
21112 if(srt .le. (acas+aka))return
21113 srrt = srt - (aome+app) + (amn+aka)
21114 pkaon = sqrt(((srrt**2-(amn**2+aka**2))/2./amn)**2 - aka**2)
21115c use K(bar) + Ca --> Om + eta xsecn same as K(bar) + N --> Si + Pi
21116c** using same matrix elements as K-bar + N -> La/Si + pi
21117 sigca = 1.5*( akNPsg(pkaon)+akNPsg(pkaon) )
21118 cmat = sigca*
21119 & sqrt((srt**2-(amn+aka)**2)*(srt**2-(amn-aka)**2))/
21120 & sqrt((srt**2-(asa+0.138)**2)*(srt**2-(asa-0.138)**2))
21121 sigom = cmat*
21122 & sqrt((srt**2-(aomp+app)**2)*(srt**2-(aomp-app)**2))/
21123 & sqrt((srt**2-(acas+aka)**2)*(srt**2-(acas-aka)**2))
21124c dfr = 2. !! eta
21125c !! pion
21126 dfr = 2./3.
21127 sigom = sigom*dfr*(srt**2-(acas+aka)**2)*
21128 & (srt**2-(acas-aka)**2)/(srt**2-(aomp+app)**2)/
21129 & (srt**2-(aomp-app)**2)
21130c
21131 brpp = 1.
21132 ds = sqrt(sigom/31.4)
21133 dsr = ds + 0.1
21134 ec = (em1+em2+0.02)**2
21135 call distce(i1,i2,dsr,ds,dt,ec,srt,ic,px,py,pz)
21136c
21137clin-2/25/03: checking elastic scatt after failure of inelastic scatt gives
21138c conditional probability (in general incorrect), tell Pal to correct:
21139 if(ic .eq. -1)then
21140c check for elastic scatt, no particle annhilation
21141c !! elastic cross section of 20 mb
21142 ds = sqrt(20.0/31.4)
21143 dsr = ds + 0.1
21144 call distce(i1,i2,dsr,ds,dt,ec,srt,icsbel,px,py,pz)
21145 if(icsbel .eq. -1)return
21146 empp1 = EM1
21147 empp2 = EM2
21148 go to 700
21149 endif
21150c
21151c else pert. produced omega(bar) annhilated OR real process
21152c annhilate only pert. omega, rest from hijing go out WITHOUT annhil.
21153 if(lb1.eq.45 .or. lb2.eq.45)then
21154c !! Ca
21155 lbpp1 = 40 + int(2*RANART(NSEED))
21156c !! K-
21157 lbpp2 = 21
21158 else
21159* elseif(lb1 .eq. -45 .or. lb2 .eq. -45)
21160c !! Ca-bar
21161 lbpp1 = -40 - int(2*RANART(NSEED))
21162c !! K+
21163 lbpp2 = 23
21164 endif
21165 empp1 = acas
21166 empp2 = aka
21167c
21168c check for real process for Cas(bar) and K(bar) formation
21169 if(RANART(NSEED) .lt. proper(idp))then
21170c !! real process flag
21171 icont = 0
21172 lb(i1) = lbpp1
21173 e(i1) = empp1
21174c !! P_Cas(bar) = P_Om(bar)
21175 proper(i1) = proper(idp)
21176 lb(i2) = lbpp2
21177 e(i2) = empp2
21178c !! K(bar) formed with prob 1.
21179 proper(i2) = 1.
21180c
21181 else
21182c else Cascade(bar) produced and Omega(bar) annhilated
21183 e(idp) = 0.
21184 endif
21185c !! for produced particles
21186 go to 700
21187c
21188c-----------------------------------------------------------
21189700 continue
21190* CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
21191* ENERGY CONSERVATION
21192 PR2 = (SRT**2 - EMpp1**2 - EMpp2**2)**2
21193 & - 4.0 * (EMpp1*EMpp2)**2
21194 IF(PR2.LE.0.)PR2=0.00000001
21195 PR=SQRT(PR2)/(2.*SRT)
21196* using isotropic
21197 C1 = 1.0 - 2.0 * RANART(NSEED)
21198 T1 = 2.0 * PI * RANART(NSEED)
21199 S1 = SQRT( 1.0 - C1**2 )
21200 CT1 = COS(T1)
21201 ST1 = SIN(T1)
21202* THE MOMENTUM IN THE CMS IN THE FINAL STATE
21203 PZ = PR * C1
21204 PX = PR * S1*CT1
21205 PY = PR * S1*ST1
21206* ROTATE IT
21207 CALL ROTATE(PX0,PY0,PZ0,PX,PY,PZ)
21208 if(icont .eq. 0)return
21209c
21210* LORENTZ-TRANSFORMATION INTO CMS FRAME
21211 E1CM = SQRT (EMpp1**2 + PX**2 + PY**2 + PZ**2)
21212 P1BETA = PX*BETAX + PY*BETAY + PZ*BETAZ
21213 TRANSF = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) + E1CM )
21214 Ppt11 = BETAX * TRANSF + PX
21215 Ppt12 = BETAY * TRANSF + PY
21216 Ppt13 = BETAZ * TRANSF + PZ
21217c
21218cc** for elastic scattering update the momentum of pertb particles
21219 if(icsbel .ne. -1)then
21220c if(EMpp1 .gt. 0.9)then
21221 p(1,i1) = Ppt11
21222 p(2,i1) = Ppt12
21223 p(3,i1) = Ppt13
21224c else
21225 E2CM = SQRT (EMpp2**2 + PX**2 + PY**2 + PZ**2)
21226 TRANSF = GAMMA * ( -GAMMA * P1BETA / (GAMMA + 1) + E2CM )
21227 Ppt21 = BETAX * TRANSF - PX
21228 Ppt22 = BETAY * TRANSF - PY
21229 Ppt23 = BETAZ * TRANSF - PZ
21230 p(1,i2) = Ppt21
21231 p(2,i2) = Ppt22
21232 p(3,i2) = Ppt23
21233c endif
21234 return
21235 endif
21236clin-5/2008:
21237c2008 X01 = 1.0 - 2.0 * RANART(NSEED)
21238c Y01 = 1.0 - 2.0 * RANART(NSEED)
21239c Z01 = 1.0 - 2.0 * RANART(NSEED)
21240c IF ((X01*X01+Y01*Y01+Z01*Z01) .GT. 1.0) GOTO 2008
21241c Xpt=X1+0.5*x01
21242c Ypt=Y1+0.5*y01
21243c Zpt=Z1+0.5*z01
21244 Xpt=X1
21245 Ypt=Y1
21246 Zpt=Z1
21247c
21248c
21249c if(lbpp1 .eq. 45)then
21250c write(*,*)'II lb1,lb2,lbpp1,empp1,proper(idp),brpp'
21251c write(*,*)lb1,lb2,lbpp1,empp1,proper(idp),brpp
21252c endif
21253c
21254 NNN=NNN+1
21255 PROPI(NNN,IRUN)= proper(idp)*brpp
21256 LPION(NNN,IRUN)= lbpp1
21257 EPION(NNN,IRUN)= empp1
21258 RPION(1,NNN,IRUN)=Xpt
21259 RPION(2,NNN,IRUN)=Ypt
21260 RPION(3,NNN,IRUN)=Zpt
21261 PPION(1,NNN,IRUN)=Ppt11
21262 PPION(2,NNN,IRUN)=Ppt12
21263 PPION(3,NNN,IRUN)=Ppt13
21264clin-5/2008:
21265 dppion(nnn,irun)=dpertp(i1)*dpertp(i2)
21266 RETURN
21267 END
21268**********************************
21269* sp 12/08/00 *
21270 SUBROUTINE Crhb(PX,PY,PZ,SRT,I1,I2,IBLOCK)
21271* PURPOSE: *
21272* DEALING WITH hyperon+N(D,N*)->hyp+N(D,N*) elastic PROCESS *
21273* NOTE : *
21274*
21275* QUANTITIES: *
21276* PX,PY,PZ - MOMENTUM COORDINATES OF ONE PARTICLE IN CM FRAME*
21277* SRT - SQRT OF S *
21278* IBLOCK - THE INFORMATION BACK *
21279* 144-> hyp+N(D,N*)->hyp+N(D,N*)
21280**********************************
21281 PARAMETER (MAXSTR=150001,MAXR=1,AMN=0.939457,
21282 1 AMP=0.93828,AP1=0.13496,
21283 2 AP2=0.13957,AM0=1.232,PI=3.1415926,CUTOFF=1.8966,AVMASS=0.9383)
21284 PARAMETER (AKA=0.498,ALA=1.1157,ASA=1.1974)
21285 parameter (MX=4,MY=4,MZ=8,MPX=4,MPY=4,mpz=10,mpzp=10)
21286 COMMON /AA/ R(3,MAXSTR)
21287cc SAVE /AA/
21288 COMMON /BB/ P(3,MAXSTR)
21289cc SAVE /BB/
21290 COMMON /CC/ E(MAXSTR)
21291cc SAVE /CC/
21292 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
21293cc SAVE /EE/
21294 common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
21295cc SAVE /input1/
21296 COMMON/RNDF77/NSEED
21297cc SAVE /RNDF77/
21298 SAVE
21299
21300 PX0=PX
21301 PY0=PY
21302 PZ0=PZ
21303*-----------------------------------------------------------------------
21304 IBLOCK=144
21305 NTAG=0
21306 EM1=E(I1)
21307 EM2=E(I2)
21308*-----------------------------------------------------------------------
21309* CALCULATE THE MAGNITUDE OF THE FINAL MOMENTUM THROUGH
21310* ENERGY CONSERVATION
21311 PR2 = (SRT**2 - EM1**2 - EM2**2)**2
21312 1 - 4.0 * (EM1*EM2)**2
21313 IF(PR2.LE.0.)PR2=1.e-09
21314 PR=SQRT(PR2)/(2.*SRT)
21315 C1 = 1.0 - 2.0 * RANART(NSEED)
21316 T1 = 2.0 * PI * RANART(NSEED)
21317 S1 = SQRT( 1.0 - C1**2 )
21318 CT1 = COS(T1)
21319 ST1 = SIN(T1)
21320 PZ = PR * C1
21321 PX = PR * S1*CT1
21322 PY = PR * S1*ST1
21323 RETURN
21324 END
21325****************************************
21326c sp 04/05/01
21327* Purpose: lambda-baryon elastic xsection as a functon of their cms energy
21328 subroutine lambar(i1,i2,srt,siglab)
21329* srt = DSQRT(s) in GeV *
21330* siglab = lambda-nuclar elastic cross section in mb
21331* = 12 + 0.43/p_lab**3.3 (mb)
21332*
21333* (2) Calculate p(lab) from srt [GeV], since the formular in the
21334* reference applies only to the case of a p_bar on a proton at rest
21335* Formula used: srt**2=2.*pmass*(pmass+sqrt(pmass**2+plab**2))
21336*****************************
21337 PARAMETER (MAXSTR=150001)
21338 COMMON /AA/ R(3,MAXSTR)
21339cc SAVE /AA/
21340 COMMON /BB/ P(3,MAXSTR)
21341cc SAVE /BB/
21342 COMMON /CC/ E(MAXSTR)
21343cc SAVE /CC/
21344 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
21345cc SAVE /EE/
21346 SAVE
21347
21348 siglab=1.e-06
21349 if( iabs(lb(i1)).ge.14.and.iabs(lb(i1)).le.17 )then
21350 eml = e(i1)
21351 emb = e(i2)
21352 else
21353 eml = e(i2)
21354 emb = e(i1)
21355 endif
21356 pthr = srt**2-eml**2-emb**2
21357 if(pthr .gt. 0.)then
21358 plab2=(pthr/2./emb)**2-eml**2
21359 if(plab2.gt.0)then
21360 plab=sqrt(plab2)
21361 siglab=12. + 0.43/(plab**3.3)
21362 if(siglab.gt.200.)siglab=200.
21363 endif
21364 endif
21365 return
21366 END
21367C------------------------------------------------------------------
21368clin-7/26/03 improve speed
21369***************************************
21370 SUBROUTINE distc0(drmax,deltr0,DT,
21371 1 Ifirst,PX1CM,PY1CM,PZ1CM,
21372 2 x1,y1,z1,px1,py1,pz1,em1,x2,y2,z2,px2,py2,pz2,em2)
21373* PURPOSE : CHECK IF THE COLLISION BETWEEN TWO PARTICLES CAN HAPPEN
21374* BY CHECKING
21375* (2) IF PARTICLE WILL PASS EACH OTHER WITHIN
21376* TWO HARD CORE RADIUS.
21377* (3) IF PARTICLES WILL GET CLOSER.
21378* VARIABLES :
21379* Ifirst=1 COLLISION may HAPPENED
21380* Ifirst=-1 COLLISION CAN NOT HAPPEN
21381*****************************************
21382 COMMON /BG/ BETAX,BETAY,BETAZ,GAMMA
21383cc SAVE /BG/
21384 SAVE
21385 deltr0=deltr0
21386 Ifirst=-1
21387 E1=SQRT(EM1**2+PX1**2+PY1**2+PZ1**2)
21388*NOW PARTICLES ARE CLOSE ENOUGH TO EACH OTHER !
21389 E2 = SQRT ( EM2**2 + PX2**2 + PY2**2 + PZ2**2 )
21390*NOW THERE IS ENOUGH ENERGY AVAILABLE !
21391*LORENTZ-TRANSFORMATION IN I1-I2-C.M. SYSTEM
21392* BETAX, BETAY, BETAZ AND GAMMA HAVE BEEN GIVEN IN THE SUBROUTINE CMS
21393*TRANSFORMATION OF MOMENTA (PX1CM = - PX2CM)
21394 P1BETA = PX1*BETAX + PY1*BETAY + PZ1 * BETAZ
21395 TRANSF = GAMMA * ( GAMMA * P1BETA / (GAMMA + 1) - E1 )
21396 PRCM = SQRT (PX1CM**2 + PY1CM**2 + PZ1CM**2)
21397 IF (PRCM .LE. 0.00001) return
21398*TRANSFORMATION OF SPATIAL DISTANCE
21399 DRBETA = BETAX*(X1-X2) + BETAY*(Y1-Y2) + BETAZ*(Z1-Z2)
21400 TRANSF = GAMMA * GAMMA * DRBETA / (GAMMA + 1)
21401 DXCM = BETAX * TRANSF + X1 - X2
21402 DYCM = BETAY * TRANSF + Y1 - Y2
21403 DZCM = BETAZ * TRANSF + Z1 - Z2
21404*DETERMINING IF THIS IS THE POINT OF CLOSEST APPROACH
21405 DRCM = SQRT (DXCM**2 + DYCM**2 + DZCM**2 )
21406 DZZ = (PX1CM*DXCM + PY1CM*DYCM + PZ1CM*DZCM) / PRCM
21407 if ((drcm**2 - dzz**2) .le. 0.) then
21408 BBB = 0.
21409 else
21410 BBB = SQRT (DRCM**2 - DZZ**2)
21411 end if
21412*WILL PARTICLE PASS EACH OTHER WITHIN 2 * HARD CORE RADIUS ?
21413 IF (BBB .GT. drmax) return
21414 RELVEL = PRCM * (1.0/E1 + 1.0/E2)
21415 DDD = RELVEL * DT * 0.5
21416*WILL PARTICLES GET CLOSER ?
21417 IF (ABS(DDD) .LT. ABS(DZZ)) return
21418 Ifirst=1
21419 RETURN
21420 END
21421*---------------------------------------------------------------------------
21422c
21423clin-8/2008 B+B->Deuteron+Meson cross section in mb:
21424 subroutine sbbdm(srt,sdprod,ianti,lbm,xmm,pfinal)
21425 PARAMETER (xmd=1.8756,AP1=0.13496,AP2=0.13957,
21426 1 xmrho=0.770,xmomega=0.782,xmeta=0.548,srt0=2.012)
21427 common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
21428 1 px1n,py1n,pz1n,dp1n
21429 common /dpi/em2,lb2
21430 common /para8/ idpert,npertd,idxsec
21431 COMMON/RNDF77/NSEED
21432 SAVE
21433c
21434 sdprod=0.
21435 sbbdpi=0.
21436 sbbdrho=0.
21437 sbbdomega=0.
21438 sbbdeta=0.
21439 if(srt.le.(em1+em2)) return
21440c
21441 ilb1=iabs(lb1)
21442 ilb2=iabs(lb2)
21443ctest off check Xsec using fixed mass for resonances:
21444c if(ilb1.ge.6.and.ilb1.le.9) then
21445c em1=1.232
21446c elseif(ilb1.ge.10.and.ilb1.le.11) then
21447c em1=1.44
21448c elseif(ilb1.ge.12.and.ilb1.le.13) then
21449c em1=1.535
21450c endif
21451c if(ilb2.ge.6.and.ilb2.le.9) then
21452c em2=1.232
21453c elseif(ilb2.ge.10.and.ilb2.le.11) then
21454c em2=1.44
21455c elseif(ilb2.ge.12.and.ilb2.le.13) then
21456c em2=1.535
21457c endif
21458c
21459 s=srt**2
21460 pinitial=sqrt((s-(em1+em2)**2)*(s-(em1-em2)**2))/2./srt
21461 fs=fnndpi(s)
21462c Determine isospin and spin factors for the ratio between
21463c BB->Deuteron+Meson and Deuteron+Meson->BB cross sections:
21464 if(idxsec.eq.1.or.idxsec.eq.2) then
21465c Assume B+B -> d+Meson has the same cross sections as N+N -> d+pi:
21466 else
21467c Assume d+Meson -> B+B has the same cross sections as d+pi -> N+N,
21468c then determine B+B -> d+Meson cross sections:
21469 if(ilb1.ge.1.and.ilb1.le.2.and.
21470 1 ilb2.ge.1.and.ilb2.le.2) then
21471 pifactor=9./8.
21472 elseif((ilb1.ge.1.and.ilb1.le.2.and.
21473 1 ilb2.ge.6.and.ilb2.le.9).or.
21474 2 (ilb2.ge.1.and.ilb2.le.2.and.
21475 1 ilb1.ge.6.and.ilb1.le.9)) then
21476 pifactor=9./64.
21477 elseif((ilb1.ge.1.and.ilb1.le.2.and.
21478 1 ilb2.ge.10.and.ilb2.le.13).or.
21479 2 (ilb2.ge.1.and.ilb2.le.2.and.
21480 1 ilb1.ge.10.and.ilb1.le.13)) then
21481 pifactor=9./16.
21482 elseif(ilb1.ge.6.and.ilb1.le.9.and.
21483 1 ilb2.ge.6.and.ilb2.le.9) then
21484 pifactor=9./128.
21485 elseif((ilb1.ge.6.and.ilb1.le.9.and.
21486 1 ilb2.ge.10.and.ilb2.le.13).or.
21487 2 (ilb2.ge.6.and.ilb2.le.9.and.
21488 1 ilb1.ge.10.and.ilb1.le.13)) then
21489 pifactor=9./64.
21490 elseif((ilb1.ge.10.and.ilb1.le.11.and.
21491 1 ilb2.ge.10.and.ilb2.le.11).or.
21492 2 (ilb2.ge.12.and.ilb2.le.13.and.
21493 1 ilb1.ge.12.and.ilb1.le.13)) then
21494 pifactor=9./8.
21495 elseif((ilb1.ge.10.and.ilb1.le.11.and.
21496 1 ilb2.ge.12.and.ilb2.le.13).or.
21497 2 (ilb2.ge.10.and.ilb2.le.11.and.
21498 1 ilb1.ge.12.and.ilb1.le.13)) then
21499 pifactor=9./16.
21500 endif
21501 endif
21502c d pi: DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
21503* (1) FOR P+P->Deuteron+pi+:
21504 IF((ilb1*ilb2).EQ.1)THEN
21505 lbm=5
21506 if(ianti.eq.1) lbm=3
21507 xmm=ap2
21508* (2)FOR N+N->Deuteron+pi-:
21509 ELSEIF(ilb1.EQ.2.AND.ilb2.EQ.2)THEN
21510 lbm=3
21511 if(ianti.eq.1) lbm=5
21512 xmm=ap2
21513* (3)FOR N+P->Deuteron+pi0:
21514 ELSEIF((ilb1*ilb2).EQ.2)THEN
21515 lbm=4
21516 xmm=ap1
21517 ELSE
21518c For baryon resonances, use isospin-averaged cross sections:
21519 lbm=3+int(3 * RANART(NSEED))
21520 if(lbm.eq.4) then
21521 xmm=ap1
21522 else
21523 xmm=ap2
21524 endif
21525 ENDIF
21526c
21527 if(srt.ge.(xmd+xmm)) then
21528 pfinal=sqrt((s-(xmd+xmm)**2)*(s-(xmd-xmm)**2))/2./srt
21529 if((ilb1.eq.1.and.ilb2.eq.1).or.
21530 1 (ilb1.eq.2.and.ilb2.eq.2)) then
21531c for pp or nn initial states:
21532 sbbdpi=fs*pfinal/pinitial/4.
21533 elseif((ilb1.eq.1.and.ilb2.eq.2).or.
21534 1 (ilb1.eq.2.and.ilb2.eq.1)) then
21535c factor of 1/2 for pn or np initial states:
21536 sbbdpi=fs*pfinal/pinitial/4./2.
21537 else
21538c for other BB initial states (spin- and isospin averaged):
21539 if(idxsec.eq.1) then
21540c 1: assume the same |matrix element|**2 (after averaging over initial
21541c spins and isospins) for B+B -> deuteron+meson at the same sqrt(s);
21542 sbbdpi=fs*pfinal/pinitial*3./16.
21543 elseif(idxsec.eq.2.or.idxsec.eq.4) then
21544 threshold=amax1(xmd+xmm,em1+em2)
21545 snew=(srt-threshold+srt0)**2
21546 if(idxsec.eq.2) then
21547c 2: assume the same |matrix element|**2 for B+B -> deuteron+meson
21548c at the same sqrt(s)-threshold:
21549 sbbdpi=fnndpi(snew)*pfinal/pinitial*3./16.
21550 elseif(idxsec.eq.4) then
21551c 4: assume the same |matrix element|**2 for B+B <- deuteron+meson
21552c at the same sqrt(s)-threshold:
21553 sbbdpi=fnndpi(snew)*pfinal/pinitial/6.*pifactor
21554 endif
21555 elseif(idxsec.eq.3) then
21556c 3: assume the same |matrix element|**2 for B+B <- deuteron+meson
21557c at the same sqrt(s):
21558 sbbdpi=fs*pfinal/pinitial/6.*pifactor
21559 endif
21560c
21561 endif
21562 endif
21563c
21564* d rho: DETERMINE THE CROSS SECTION TO THIS FINAL STATE:
21565 if(srt.gt.(xmd+xmrho)) then
21566 pfinal=sqrt((s-(xmd+xmrho)**2)*(s-(xmd-xmrho)**2))/2./srt
21567 if(idxsec.eq.1) then
21568 sbbdrho=fs*pfinal/pinitial*3./16.
21569 elseif(idxsec.eq.2.or.idxsec.eq.4) then
21570 threshold=amax1(xmd+xmrho,em1+em2)
21571 snew=(srt-threshold+srt0)**2
21572 if(idxsec.eq.2) then
21573 sbbdrho=fnndpi(snew)*pfinal/pinitial*3./16.
21574 elseif(idxsec.eq.4) then
21575c The spin- and isospin-averaged factor is 3-times larger for rho:
21576 sbbdrho=fnndpi(snew)*pfinal/pinitial/6.*(pifactor*3.)
21577 endif
21578 elseif(idxsec.eq.3) then
21579 sbbdrho=fs*pfinal/pinitial/6.*(pifactor*3.)
21580 endif
21581 endif
21582c
21583* d omega: DETERMINE THE CROSS SECTION TO THIS FINAL STATE:
21584 if(srt.gt.(xmd+xmomega)) then
21585 pfinal=sqrt((s-(xmd+xmomega)**2)*(s-(xmd-xmomega)**2))/2./srt
21586 if(idxsec.eq.1) then
21587 sbbdomega=fs*pfinal/pinitial*3./16.
21588 elseif(idxsec.eq.2.or.idxsec.eq.4) then
21589 threshold=amax1(xmd+xmomega,em1+em2)
21590 snew=(srt-threshold+srt0)**2
21591 if(idxsec.eq.2) then
21592 sbbdomega=fnndpi(snew)*pfinal/pinitial*3./16.
21593 elseif(idxsec.eq.4) then
21594 sbbdomega=fnndpi(snew)*pfinal/pinitial/6.*pifactor
21595 endif
21596 elseif(idxsec.eq.3) then
21597 sbbdomega=fs*pfinal/pinitial/6.*pifactor
21598 endif
21599 endif
21600c
21601* d eta: DETERMINE THE CROSS SECTION TO THIS FINAL STATE:
21602 if(srt.gt.(xmd+xmeta)) then
21603 pfinal=sqrt((s-(xmd+xmeta)**2)*(s-(xmd-xmeta)**2))/2./srt
21604 if(idxsec.eq.1) then
21605 sbbdeta=fs*pfinal/pinitial*3./16.
21606 elseif(idxsec.eq.2.or.idxsec.eq.4) then
21607 threshold=amax1(xmd+xmeta,em1+em2)
21608 snew=(srt-threshold+srt0)**2
21609 if(idxsec.eq.2) then
21610 sbbdeta=fnndpi(snew)*pfinal/pinitial*3./16.
21611 elseif(idxsec.eq.4) then
21612 sbbdeta=fnndpi(snew)*pfinal/pinitial/6.*(pifactor/3.)
21613 endif
21614 elseif(idxsec.eq.3) then
21615 sbbdeta=fs*pfinal/pinitial/6.*(pifactor/3.)
21616 endif
21617 endif
21618c
21619 sdprod=sbbdpi+sbbdrho+sbbdomega+sbbdeta
21620ctest off
21621c write(99,111) srt,sbbdpi,sbbdrho,sbbdomega,sbbdeta,sdprod
21622c 111 format(6(f8.2,1x))
21623c
21624 if(sdprod.le.0) return
21625c
21626c choose final state and assign masses here:
21627 x1=RANART(NSEED)
21628 if(x1.le.sbbdpi/sdprod) then
21629c use the above-determined lbm and xmm.
21630 elseif(x1.le.(sbbdpi+sbbdrho)/sdprod) then
21631 lbm=25+int(3*RANART(NSEED))
21632 xmm=xmrho
21633 elseif(x1.le.(sbbdpi+sbbdrho+sbbdomega)/sdprod) then
21634 lbm=28
21635 xmm=xmomega
21636 else
21637 lbm=0
21638 xmm=xmeta
21639 endif
21640c
21641 return
21642 end
21643c
21644c Generate angular distribution of Deuteron in the CMS frame:
21645 subroutine bbdangle(pxd,pyd,pzd,nt,ipert1,ianti,idloop,pfinal,
21646 1 dprob1,lbm)
21647 PARAMETER (PI=3.1415926)
21648 common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
21649 1 px1n,py1n,pz1n,dp1n
21650 common /dpi/em2,lb2
21651 COMMON/RNDF77/NSEED
21652 common /para8/ idpert,npertd,idxsec
21653 COMMON /AREVT/ IAEVT, IARUN, MISS
21654 SAVE
21655c take isotropic distribution for now:
21656 C1=1.0-2.0*RANART(NSEED)
21657 T1=2.0*PI*RANART(NSEED)
21658 S1=SQRT(1.0-C1**2)
21659 CT1=COS(T1)
21660 ST1=SIN(T1)
21661* THE MOMENTUM IN THE CMS IN THE FINAL STATE
21662 PZd=pfinal*C1
21663 PXd=pfinal*S1*CT1
21664 PYd=pfinal*S1*ST1
21665clin-5/2008 track the number of produced deuterons:
21666 if(idpert.eq.1.and.npertd.ge.1) then
21667 dprob=dprob1
21668 elseif(idpert.eq.2.and.npertd.ge.1) then
21669 dprob=1./float(npertd)
21670 endif
21671c if(ianti.eq.0) then
21672c if(idpert.eq.0.or.(idpert.eq.1.and.ipert1.eq.0).or.
21673c 1 (idpert.eq.2.and.idloop.eq.(npertd+1))) then
21674c write (91,*) lb1,' *',lb2,' ->d+',lbm,' (regular d prodn)
21675c 1 @evt#',iaevt,' @nt=',nt
21676c elseif((idpert.eq.1.or.idpert.eq.2).and.idloop.eq.npertd) then
21677c write (91,*) lb1,' *',lb2,' ->d+',lbm,' (pert d prodn)
21678c 1 @evt#',iaevt,' @nt=',nt,' @prob=',dprob
21679c endif
21680c else
21681c if(idpert.eq.0.or.(idpert.eq.1.and.ipert1.eq.0).or.
21682c 1 (idpert.eq.2.and.idloop.eq.(npertd+1))) then
21683c write (91,*) lb1,' *',lb2,' ->d+',lbm,' (regular dbar prodn)
21684c 1 @evt#',iaevt,' @nt=',nt
21685c elseif((idpert.eq.1.or.idpert.eq.2).and.idloop.eq.npertd) then
21686c write (91,*) lb1,' *',lb2,' ->d+',lbm,' (pert dbar prodn)
21687c 1 @evt#',iaevt,' @nt=',nt,' @prob=',dprob
21688c endif
21689c endif
21690c
21691 return
21692 end
21693c
21694c Deuteron+Meson->B+B cross section (in mb)
21695 subroutine sdmbb(SRT,sdm,ianti)
21696 PARAMETER (AMN=0.939457,AMP=0.93828,
21697 1 AM0=1.232,AM1440=1.44,AM1535=1.535,srt0=2.012)
21698 common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
21699 1 px1n,py1n,pz1n,dp1n
21700 common /dpi/em2,lb2
21701 common /dpifsl/lbnn1,lbnn2,lbnd1,lbnd2,lbns1,lbns2,lbnp1,lbnp2,
21702 1 lbdd1,lbdd2,lbds1,lbds2,lbdp1,lbdp2,lbss1,lbss2,
21703 2 lbsp1,lbsp2,lbpp1,lbpp2
21704 common /dpifsm/xmnn1,xmnn2,xmnd1,xmnd2,xmns1,xmns2,xmnp1,xmnp2,
21705 1 xmdd1,xmdd2,xmds1,xmds2,xmdp1,xmdp2,xmss1,xmss2,
21706 2 xmsp1,xmsp2,xmpp1,xmpp2
21707 common /dpisig/sdmel,sdmnn,sdmnd,sdmns,sdmnp,sdmdd,sdmds,sdmdp,
21708 1 sdmss,sdmsp,sdmpp
21709 common /para8/ idpert,npertd,idxsec
21710 COMMON/RNDF77/NSEED
21711 SAVE
21712c
21713 sdm=0.
21714 sdmel=0.
21715 sdmnn=0.
21716 sdmnd=0.
21717 sdmns=0.
21718 sdmnp=0.
21719 sdmdd=0.
21720 sdmds=0.
21721 sdmdp=0.
21722 sdmss=0.
21723 sdmsp=0.
21724 sdmpp=0.
21725ctest off check Xsec using fixed mass for resonances:
21726c if(lb1.ge.25.and.lb1.le.27) then
21727c em1=0.776
21728c elseif(lb1.eq.28) then
21729c em1=0.783
21730c elseif(lb1.eq.0) then
21731c em1=0.548
21732c endif
21733c if(lb2.ge.25.and.lb2.le.27) then
21734c em2=0.776
21735c elseif(lb2.eq.28) then
21736c em2=0.783
21737c elseif(lb2.eq.0) then
21738c em2=0.548
21739c endif
21740c
21741 if(srt.le.(em1+em2)) return
21742 s=srt**2
21743 pinitial=sqrt((s-(em1+em2)**2)*(s-(em1-em2)**2))/2./srt
21744 fs=fnndpi(s)
21745c Determine isospin and spin factors for the ratio between
21746c Deuteron+Meson->BB and BB->Deuteron+Meson cross sections:
21747 if(idxsec.eq.1.or.idxsec.eq.2) then
21748c Assume B+B -> d+Meson has the same cross sections as N+N -> d+pi,
21749c then determine d+Meson -> B+B cross sections:
21750 if((lb1.ge.3.and.lb1.le.5).or.
21751 1 (lb2.ge.3.and.lb2.le.5)) then
21752 xnnfactor=8./9.
21753 elseif((lb1.ge.25.and.lb1.le.27).or.
21754 1 (lb2.ge.25.and.lb2.le.27)) then
21755 xnnfactor=8./27.
21756 elseif(lb1.eq.28.or.lb2.eq.28) then
21757 xnnfactor=8./9.
21758 elseif(lb1.eq.0.or.lb2.eq.0) then
21759 xnnfactor=8./3.
21760 endif
21761 else
21762c Assume d+Meson -> B+B has the same cross sections as d+pi -> N+N:
21763 endif
21764clin-9/2008 For elastic collisions:
21765 if(idxsec.eq.1.or.idxsec.eq.3) then
21766c 1/3: assume the same |matrix element|**2 (after averaging over initial
21767c spins and isospins) for d+Meson elastic at the same sqrt(s);
21768 sdmel=fdpiel(s)
21769 elseif(idxsec.eq.2.or.idxsec.eq.4) then
21770c 2/4: assume the same |matrix element|**2 (after averaging over initial
21771c spins and isospins) for d+Meson elastic at the same sqrt(s)-threshold:
21772 threshold=em1+em2
21773 snew=(srt-threshold+srt0)**2
21774 sdmel=fdpiel(snew)
21775 endif
21776c
21777* NN: DETERMINE THE CHARGE STATES OF PARTICLESIN THE FINAL STATE
21778 IF(((lb1.eq.5.or.lb2.eq.5.or.lb1.eq.27.or.lb2.eq.27)
21779 1 .and.ianti.eq.0).or.
21780 2 ((lb1.eq.3.or.lb2.eq.3.or.lb1.eq.25.or.lb2.eq.25)
21781 3 .and.ianti.eq.1))THEN
21782* (1) FOR Deuteron+(pi+,rho+) -> P+P or DeuteronBar+(pi-,rho-)-> PBar+PBar:
21783 lbnn1=1
21784 lbnn2=1
21785 xmnn1=amp
21786 xmnn2=amp
21787 ELSEIF(lb1.eq.3.or.lb2.eq.3.or.lb1.eq.26.or.lb2.eq.26
21788 1 .or.lb1.eq.28.or.lb2.eq.28.or.lb1.eq.0.or.lb2.eq.0)THEN
21789* (2) FOR Deuteron+(pi0,rho0,omega,eta) -> N+P
21790* or DeuteronBar+(pi0,rho0,omega,eta) ->NBar+PBar:
21791 lbnn1=2
21792 lbnn2=1
21793 xmnn1=amn
21794 xmnn2=amp
21795 ELSE
21796* (3) FOR Deuteron+(pi-,rho-) -> N+N or DeuteronBar+(pi+,rho+)-> NBar+NBar:
21797 lbnn1=2
21798 lbnn2=2
21799 xmnn1=amn
21800 xmnn2=amn
21801 ENDIF
21802 if(srt.gt.(xmnn1+xmnn2)) then
21803 pfinal=sqrt((s-(xmnn1+xmnn2)**2)*(s-(xmnn1-xmnn2)**2))/2./srt
21804 if(idxsec.eq.1) then
21805c 1: assume the same |matrix element|**2 (after averaging over initial
21806c spins and isospins) for B+B -> deuteron+meson at the same sqrt(s);
21807 sdmnn=fs*pfinal/pinitial*3./16.*xnnfactor
21808 elseif(idxsec.eq.2.or.idxsec.eq.4) then
21809 threshold=amax1(xmnn1+xmnn2,em1+em2)
21810 snew=(srt-threshold+srt0)**2
21811 if(idxsec.eq.2) then
21812c 2: assume the same |matrix element|**2 for B+B -> deuteron+meson
21813c at the same sqrt(s)-threshold:
21814 sdmnn=fnndpi(snew)*pfinal/pinitial*3./16.*xnnfactor
21815 elseif(idxsec.eq.4) then
21816c 4: assume the same |matrix element|**2 for B+B <- deuteron+meson
21817c at the same sqrt(s)-threshold:
21818 sdmnn=fnndpi(snew)*pfinal/pinitial/6.
21819 endif
21820 elseif(idxsec.eq.3) then
21821c 3: assume the same |matrix element|**2 for B+B <- deuteron+meson
21822c at the same sqrt(s):
21823 sdmnn=fs*pfinal/pinitial/6.
21824 endif
21825 endif
21826c
21827* ND: DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
21828 lbnd1=1+int(2*RANART(NSEED))
21829 lbnd2=6+int(4*RANART(NSEED))
21830 if(lbnd1.eq.1) then
21831 xmnd1=amp
21832 elseif(lbnd1.eq.2) then
21833 xmnd1=amn
21834 endif
21835 xmnd2=am0
21836 if(srt.gt.(xmnd1+xmnd2)) then
21837 pfinal=sqrt((s-(xmnd1+xmnd2)**2)*(s-(xmnd1-xmnd2)**2))/2./srt
21838 if(idxsec.eq.1) then
21839c The spin- and isospin-averaged factor is 8-times larger for ND:
21840 sdmnd=fs*pfinal/pinitial*3./16.*(xnnfactor*8.)
21841 elseif(idxsec.eq.2.or.idxsec.eq.4) then
21842 threshold=amax1(xmnd1+xmnd2,em1+em2)
21843 snew=(srt-threshold+srt0)**2
21844 if(idxsec.eq.2) then
21845 sdmnd=fnndpi(snew)*pfinal/pinitial*3./16.*(xnnfactor*8.)
21846 elseif(idxsec.eq.4) then
21847 sdmnd=fnndpi(snew)*pfinal/pinitial/6.
21848 endif
21849 elseif(idxsec.eq.3) then
21850 sdmnd=fs*pfinal/pinitial/6.
21851 endif
21852 endif
21853c
21854* NS: DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
21855 lbns1=1+int(2*RANART(NSEED))
21856 lbns2=10+int(2*RANART(NSEED))
21857 if(lbns1.eq.1) then
21858 xmns1=amp
21859 elseif(lbns1.eq.2) then
21860 xmns1=amn
21861 endif
21862 xmns2=am1440
21863 if(srt.gt.(xmns1+xmns2)) then
21864 pfinal=sqrt((s-(xmns1+xmns2)**2)*(s-(xmns1-xmns2)**2))/2./srt
21865 if(idxsec.eq.1) then
21866 sdmns=fs*pfinal/pinitial*3./16.*(xnnfactor*2.)
21867 elseif(idxsec.eq.2.or.idxsec.eq.4) then
21868 threshold=amax1(xmns1+xmns2,em1+em2)
21869 snew=(srt-threshold+srt0)**2
21870 if(idxsec.eq.2) then
21871 sdmns=fnndpi(snew)*pfinal/pinitial*3./16.*(xnnfactor*2.)
21872 elseif(idxsec.eq.4) then
21873 sdmns=fnndpi(snew)*pfinal/pinitial/6.
21874 endif
21875 elseif(idxsec.eq.3) then
21876 sdmns=fs*pfinal/pinitial/6.
21877 endif
21878 endif
21879c
21880* NP: DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
21881 lbnp1=1+int(2*RANART(NSEED))
21882 lbnp2=12+int(2*RANART(NSEED))
21883 if(lbnp1.eq.1) then
21884 xmnp1=amp
21885 elseif(lbnp1.eq.2) then
21886 xmnp1=amn
21887 endif
21888 xmnp2=am1535
21889 if(srt.gt.(xmnp1+xmnp2)) then
21890 pfinal=sqrt((s-(xmnp1+xmnp2)**2)*(s-(xmnp1-xmnp2)**2))/2./srt
21891 if(idxsec.eq.1) then
21892 sdmnp=fs*pfinal/pinitial*3./16.*(xnnfactor*2.)
21893 elseif(idxsec.eq.2.or.idxsec.eq.4) then
21894 threshold=amax1(xmnp1+xmnp2,em1+em2)
21895 snew=(srt-threshold+srt0)**2
21896 if(idxsec.eq.2) then
21897 sdmnp=fnndpi(snew)*pfinal/pinitial*3./16.*(xnnfactor*2.)
21898 elseif(idxsec.eq.4) then
21899 sdmnp=fnndpi(snew)*pfinal/pinitial/6.
21900 endif
21901 elseif(idxsec.eq.3) then
21902 sdmnp=fs*pfinal/pinitial/6.
21903 endif
21904 endif
21905c
21906* DD: DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
21907 lbdd1=6+int(4*RANART(NSEED))
21908 lbdd2=6+int(4*RANART(NSEED))
21909 xmdd1=am0
21910 xmdd2=am0
21911 if(srt.gt.(xmdd1+xmdd2)) then
21912 pfinal=sqrt((s-(xmdd1+xmdd2)**2)*(s-(xmdd1-xmdd2)**2))/2./srt
21913 if(idxsec.eq.1) then
21914 sdmdd=fs*pfinal/pinitial*3./16.*(xnnfactor*16.)
21915 elseif(idxsec.eq.2.or.idxsec.eq.4) then
21916 threshold=amax1(xmdd1+xmdd2,em1+em2)
21917 snew=(srt-threshold+srt0)**2
21918 if(idxsec.eq.2) then
21919 sdmdd=fnndpi(snew)*pfinal/pinitial*3./16.*(xnnfactor*16.)
21920 elseif(idxsec.eq.4) then
21921 sdmdd=fnndpi(snew)*pfinal/pinitial/6.
21922 endif
21923 elseif(idxsec.eq.3) then
21924 sdmdd=fs*pfinal/pinitial/6.
21925 endif
21926 endif
21927c
21928* DS: DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
21929 lbds1=6+int(4*RANART(NSEED))
21930 lbds2=10+int(2*RANART(NSEED))
21931 xmds1=am0
21932 xmds2=am1440
21933 if(srt.gt.(xmds1+xmds2)) then
21934 pfinal=sqrt((s-(xmds1+xmds2)**2)*(s-(xmds1-xmds2)**2))/2./srt
21935 if(idxsec.eq.1) then
21936 sdmds=fs*pfinal/pinitial*3./16.*(xnnfactor*8.)
21937 elseif(idxsec.eq.2.or.idxsec.eq.4) then
21938 threshold=amax1(xmds1+xmds2,em1+em2)
21939 snew=(srt-threshold+srt0)**2
21940 if(idxsec.eq.2) then
21941 sdmds=fnndpi(snew)*pfinal/pinitial*3./16.*(xnnfactor*8.)
21942 elseif(idxsec.eq.4) then
21943 sdmds=fnndpi(snew)*pfinal/pinitial/6.
21944 endif
21945 elseif(idxsec.eq.3) then
21946 sdmds=fs*pfinal/pinitial/6.
21947 endif
21948 endif
21949c
21950* DP: DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
21951 lbdp1=6+int(4*RANART(NSEED))
21952 lbdp2=12+int(2*RANART(NSEED))
21953 xmdp1=am0
21954 xmdp2=am1535
21955 if(srt.gt.(xmdp1+xmdp2)) then
21956 pfinal=sqrt((s-(xmdp1+xmdp2)**2)*(s-(xmdp1-xmdp2)**2))/2./srt
21957 if(idxsec.eq.1) then
21958 sdmdp=fs*pfinal/pinitial*3./16.*(xnnfactor*8.)
21959 elseif(idxsec.eq.2.or.idxsec.eq.4) then
21960 threshold=amax1(xmdp1+xmdp2,em1+em2)
21961 snew=(srt-threshold+srt0)**2
21962 if(idxsec.eq.2) then
21963 sdmdp=fnndpi(snew)*pfinal/pinitial*3./16.*(xnnfactor*8.)
21964 elseif(idxsec.eq.4) then
21965 sdmdp=fnndpi(snew)*pfinal/pinitial/6.
21966 endif
21967 elseif(idxsec.eq.3) then
21968 sdmdp=fs*pfinal/pinitial/6.
21969 endif
21970 endif
21971c
21972* SS: DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
21973 lbss1=10+int(2*RANART(NSEED))
21974 lbss2=10+int(2*RANART(NSEED))
21975 xmss1=am1440
21976 xmss2=am1440
21977 if(srt.gt.(xmss1+xmss2)) then
21978 pfinal=sqrt((s-(xmss1+xmss2)**2)*(s-(xmss1-xmss2)**2))/2./srt
21979 if(idxsec.eq.1) then
21980 sdmss=fs*pfinal/pinitial*3./16.*xnnfactor
21981 elseif(idxsec.eq.2.or.idxsec.eq.4) then
21982 threshold=amax1(xmss1+xmss2,em1+em2)
21983 snew=(srt-threshold+srt0)**2
21984 if(idxsec.eq.2) then
21985 sdmss=fnndpi(snew)*pfinal/pinitial*3./16.*xnnfactor
21986 elseif(idxsec.eq.4) then
21987 sdmss=fnndpi(snew)*pfinal/pinitial/6.
21988 endif
21989 elseif(idxsec.eq.3) then
21990 sdmns=fs*pfinal/pinitial/6.
21991 endif
21992 endif
21993c
21994* SP: DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
21995 lbsp1=10+int(2*RANART(NSEED))
21996 lbsp2=12+int(2*RANART(NSEED))
21997 xmsp1=am1440
21998 xmsp2=am1535
21999 if(srt.gt.(xmsp1+xmsp2)) then
22000 pfinal=sqrt((s-(xmsp1+xmsp2)**2)*(s-(xmsp1-xmsp2)**2))/2./srt
22001 if(idxsec.eq.1) then
22002 sdmsp=fs*pfinal/pinitial*3./16.*(xnnfactor*2.)
22003 elseif(idxsec.eq.2.or.idxsec.eq.4) then
22004 threshold=amax1(xmsp1+xmsp2,em1+em2)
22005 snew=(srt-threshold+srt0)**2
22006 if(idxsec.eq.2) then
22007 sdmsp=fnndpi(snew)*pfinal/pinitial*3./16.*(xnnfactor*2.)
22008 elseif(idxsec.eq.4) then
22009 sdmsp=fnndpi(snew)*pfinal/pinitial/6.
22010 endif
22011 elseif(idxsec.eq.3) then
22012 sdmsp=fs*pfinal/pinitial/6.
22013 endif
22014 endif
22015c
22016* PP: DETERMINE THE CHARGE STATES OF PARTICLES IN THE FINAL STATE
22017 lbpp1=12+int(2*RANART(NSEED))
22018 lbpp2=12+int(2*RANART(NSEED))
22019 xmpp1=am1535
22020 xmpp2=am1535
22021 if(srt.gt.(xmpp1+xmpp2)) then
22022 pfinal=sqrt((s-(xmpp1+xmpp2)**2)*(s-(xmpp1-xmpp2)**2))/2./srt
22023 if(idxsec.eq.1) then
22024 sdmpp=fs*pfinal/pinitial*3./16.*xnnfactor
22025 elseif(idxsec.eq.2.or.idxsec.eq.4) then
22026 threshold=amax1(xmpp1+xmpp2,em1+em2)
22027 snew=(srt-threshold+srt0)**2
22028 if(idxsec.eq.2) then
22029 sdmpp=fnndpi(snew)*pfinal/pinitial*3./16.*xnnfactor
22030 elseif(idxsec.eq.4) then
22031 sdmpp=fnndpi(snew)*pfinal/pinitial/6.
22032 endif
22033 elseif(idxsec.eq.3) then
22034 sdmpp=fs*pfinal/pinitial/6.
22035 endif
22036 endif
22037c
22038 sdm=sdmel+sdmnn+sdmnd+sdmns+sdmnp+sdmdd+sdmds+sdmdp
22039 1 +sdmss+sdmsp+sdmpp
22040 if(ianti.eq.1) then
22041 lbnn1=-lbnn1
22042 lbnn2=-lbnn2
22043 lbnd1=-lbnd1
22044 lbnd2=-lbnd2
22045 lbns1=-lbns1
22046 lbns2=-lbns2
22047 lbnp1=-lbnp1
22048 lbnp2=-lbnp2
22049 lbdd1=-lbdd1
22050 lbdd2=-lbdd2
22051 lbds1=-lbds1
22052 lbds2=-lbds2
22053 lbdp1=-lbdp1
22054 lbdp2=-lbdp2
22055 lbss1=-lbss1
22056 lbss2=-lbss2
22057 lbsp1=-lbsp1
22058 lbsp2=-lbsp2
22059 lbpp1=-lbpp1
22060 lbpp2=-lbpp2
22061 endif
22062ctest off
22063c write(98,100) srt,sdmnn,sdmnd,sdmns,sdmnp,sdmdd,sdmds,sdmdp,
22064c 1 sdmss,sdmsp,sdmpp,sdm
22065c 100 format(f5.2,11(1x,f5.1))
22066c
22067 return
22068 end
22069c
22070clin-9/2008 Deuteron+Meson ->B+B and elastic collisions
22071 SUBROUTINE crdmbb(PX,PY,PZ,SRT,I1,I2,IBLOCK,
22072 1 NTAG,sig,NT,ianti)
22073 PARAMETER (MAXSTR=150001,MAXR=1)
22074 COMMON /AA/R(3,MAXSTR)
22075 COMMON /BB/ P(3,MAXSTR)
22076 COMMON /BG/BETAX,BETAY,BETAZ,GAMMA
22077 COMMON /CC/ E(MAXSTR)
22078 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
22079 COMMON /AREVT/ IAEVT, IARUN, MISS
22080 common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
22081 1 px1n,py1n,pz1n,dp1n
22082 common /dpi/em2,lb2
22083 common /para8/ idpert,npertd,idxsec
22084 COMMON /dpert/dpertt(MAXSTR,MAXR),dpertp(MAXSTR),dplast(MAXSTR),
22085 1 dpdcy(MAXSTR),dpdpi(MAXSTR,MAXR),dpt(MAXSTR, MAXR),
22086 2 dpp1(MAXSTR,MAXR),dppion(MAXSTR,MAXR)
22087 common /dpifsl/lbnn1,lbnn2,lbnd1,lbnd2,lbns1,lbns2,lbnp1,lbnp2,
22088 1 lbdd1,lbdd2,lbds1,lbds2,lbdp1,lbdp2,lbss1,lbss2,
22089 2 lbsp1,lbsp2,lbpp1,lbpp2
22090 common /dpifsm/xmnn1,xmnn2,xmnd1,xmnd2,xmns1,xmns2,xmnp1,xmnp2,
22091 1 xmdd1,xmdd2,xmds1,xmds2,xmdp1,xmdp2,xmss1,xmss2,
22092 2 xmsp1,xmsp2,xmpp1,xmpp2
22093 common /dpisig/sdmel,sdmnn,sdmnd,sdmns,sdmnp,sdmdd,sdmds,sdmdp,
22094 1 sdmss,sdmsp,sdmpp
22095 COMMON/RNDF77/NSEED
22096 SAVE
22097*-----------------------------------------------------------------------
22098 IBLOCK=0
22099 NTAG=0
22100 EM1=E(I1)
22101 EM2=E(I2)
22102 s=srt**2
22103 if(sig.le.0) return
22104c
22105 if(iabs(lb1).eq.42) then
22106 ideut=i1
22107 lbm=lb2
22108 idm=i2
22109 else
22110 ideut=i2
22111 lbm=lb1
22112 idm=i1
22113 endif
22114cccc Elastic collision or destruction of perturbatively-produced deuterons:
22115 if((idpert.eq.1.or.idpert.eq.2).and.dpertp(ideut).ne.1.) then
22116c choose reaction channels:
22117 x1=RANART(NSEED)
22118 if(x1.le.sdmel/sig)then
22119c Elastic collisions:
22120c if(ianti.eq.0) then
22121c write(91,*) ' d+',lbm,' (pert d M elastic) @nt=',nt
22122c 1 ,' @prob=',dpertp(ideut)
22123c else
22124c write(91,*) ' d+',lbm,' (pert dbar M elastic) @nt=',nt
22125c 1 ,' @prob=',dpertp(ideut)
22126c endif
22127 pfinal=sqrt((s-(em1+em2)**2)*(s-(em1-em2)**2))/2./srt
22128 CALL dmelangle(pxn,pyn,pzn,pfinal)
22129 CALL ROTATE(PX,PY,PZ,Pxn,Pyn,Pzn)
22130 EdCM=SQRT(E(ideut)**2+Pxn**2+Pyn**2+Pzn**2)
22131 PdBETA=Pxn*BETAX+Pyn*BETAY+Pzn*BETAZ
22132 TRANSF=GAMMA*(GAMMA*PdBETA/(GAMMA+1.)+EdCM)
22133 Pt1d=BETAX*TRANSF+Pxn
22134 Pt2d=BETAY*TRANSF+Pyn
22135 Pt3d=BETAZ*TRANSF+Pzn
22136 p(1,ideut)=pt1d
22137 p(2,ideut)=pt2d
22138 p(3,ideut)=pt3d
22139 IBLOCK=504
22140 PX1=P(1,I1)
22141 PY1=P(2,I1)
22142 PZ1=P(3,I1)
22143 ID(I1)=2
22144 ID(I2)=2
22145c Change the position of the perturbative deuteron to that of
22146c the meson to avoid consecutive collisions between them:
22147 R(1,ideut)=R(1,idm)
22148 R(2,ideut)=R(2,idm)
22149 R(3,ideut)=R(3,idm)
22150 else
22151c Destruction of deuterons:
22152c if(ianti.eq.0) then
22153c write(91,*) ' d+',lbm,' ->BB (pert d destrn) @nt=',nt
22154c 1 ,' @prob=',dpertp(ideut)
22155c else
22156c write(91,*) ' d+',lbm,' ->BB (pert dbar destrn) @nt=',nt
22157c 1 ,' @prob=',dpertp(ideut)
22158c endif
22159 e(ideut)=0.
22160 IBLOCK=502
22161 endif
22162 return
22163 endif
22164c
22165cccc Destruction of regularly-produced deuterons:
22166 IBLOCK=502
22167c choose final state and assign masses here:
22168 x1=RANART(NSEED)
22169 if(x1.le.sdmnn/sig)then
22170 lbb1=lbnn1
22171 lbb2=lbnn2
22172 xmb1=xmnn1
22173 xmb2=xmnn2
22174 elseif(x1.le.(sdmnn+sdmnd)/sig)then
22175 lbb1=lbnd1
22176 lbb2=lbnd2
22177 xmb1=xmnd1
22178 xmb2=xmnd2
22179 elseif(x1.le.(sdmnn+sdmnd+sdmns)/sig)then
22180 lbb1=lbns1
22181 lbb2=lbns2
22182 xmb1=xmns1
22183 xmb2=xmns2
22184 elseif(x1.le.(sdmnn+sdmnd+sdmns+sdmnp)/sig)then
22185 lbb1=lbnp1
22186 lbb2=lbnp2
22187 xmb1=xmnp1
22188 xmb2=xmnp2
22189 elseif(x1.le.(sdmnn+sdmnd+sdmns+sdmnp+sdmdd)/sig)then
22190 lbb1=lbdd1
22191 lbb2=lbdd2
22192 xmb1=xmdd1
22193 xmb2=xmdd2
22194 elseif(x1.le.(sdmnn+sdmnd+sdmns+sdmnp+sdmdd+sdmds)/sig)then
22195 lbb1=lbds1
22196 lbb2=lbds2
22197 xmb1=xmds1
22198 xmb2=xmds2
22199 elseif(x1.le.(sdmnn+sdmnd+sdmns+sdmnp+sdmdd+sdmds+sdmdp)/sig)then
22200 lbb1=lbdp1
22201 lbb2=lbdp2
22202 xmb1=xmdp1
22203 xmb2=xmdp2
22204 elseif(x1.le.(sdmnn+sdmnd+sdmns+sdmnp+sdmdd+sdmds+sdmdp
22205 1 +sdmss)/sig)then
22206 lbb1=lbss1
22207 lbb2=lbss2
22208 xmb1=xmss1
22209 xmb2=xmss2
22210 elseif(x1.le.(sdmnn+sdmnd+sdmns+sdmnp+sdmdd+sdmds+sdmdp
22211 1 +sdmss+sdmsp)/sig)then
22212 lbb1=lbsp1
22213 lbb2=lbsp2
22214 xmb1=xmsp1
22215 xmb2=xmsp2
22216 elseif(x1.le.(sdmnn+sdmnd+sdmns+sdmnp+sdmdd+sdmds+sdmdp
22217 1 +sdmss+sdmsp+sdmpp)/sig)then
22218 lbb1=lbpp1
22219 lbb2=lbpp2
22220 xmb1=xmpp1
22221 xmb2=xmpp2
22222 else
22223c Elastic collision:
22224 lbb1=lb1
22225 lbb2=lb2
22226 xmb1=em1
22227 xmb2=em2
22228 IBLOCK=504
22229 endif
22230 LB(I1)=lbb1
22231 E(i1)=xmb1
22232 LB(I2)=lbb2
22233 E(I2)=xmb2
22234 lb1=lb(i1)
22235 lb2=lb(i2)
22236 pfinal=sqrt((s-(xmb1+xmb2)**2)*(s-(xmb1-xmb2)**2))/2./srt
22237c
22238 if(iblock.eq.502) then
22239 CALL dmangle(pxn,pyn,pzn,nt,ianti,pfinal,lbm)
22240 elseif(iblock.eq.504) then
22241c if(ianti.eq.0) then
22242c write (91,*) ' d+',lbm,' (regular d M elastic) @evt#',
22243c 1 iaevt,' @nt=',nt,' lb1,2=',lb1,lb2
22244c else
22245c write (91,*) ' d+',lbm,' (regular dbar M elastic) @evt#',
22246c 1 iaevt,' @nt=',nt,' lb1,2=',lb1,lb2
22247c endif
22248 CALL dmelangle(pxn,pyn,pzn,pfinal)
22249 else
22250 print *, 'Wrong iblock number in crdmbb()'
22251 stop
22252 endif
22253* ROTATE THE MOMENTA OF PARTICLES IN THE CMS OF P1+P2
22254c (This is not needed for isotropic distributions)
22255 CALL ROTATE(PX,PY,PZ,Pxn,Pyn,Pzn)
22256* LORENTZ-TRANSFORMATION OF THE MOMENTUM OF PARTICLES IN THE FINAL STATE
22257* FROM THE NUCLEUS-NUCLEUS CMS. FRAME INTO LAB FRAME:
22258* For the 1st baryon:
22259 E1CM=SQRT(E(I1)**2+Pxn**2+Pyn**2+Pzn**2)
22260 P1BETA=Pxn*BETAX+Pyn*BETAY+Pzn*BETAZ
22261 TRANSF=GAMMA*(GAMMA*P1BETA/(GAMMA+1.)+E1CM)
22262 Pt1i1=BETAX*TRANSF+Pxn
22263 Pt2i1=BETAY*TRANSF+Pyn
22264 Pt3i1=BETAZ*TRANSF+Pzn
22265c
22266 p(1,i1)=pt1i1
22267 p(2,i1)=pt2i1
22268 p(3,i1)=pt3i1
22269* For the 2nd baryon:
22270 E2CM=SQRT(E(I2)**2+Pxn**2+Pyn**2+Pzn**2)
22271 P2BETA=-Pxn*BETAX-Pyn*BETAY-Pzn*BETAZ
22272 TRANSF=GAMMA*(GAMMA*P2BETA/(GAMMA+1.)+E2CM)
22273 Pt1I2=BETAX*TRANSF-Pxn
22274 Pt2I2=BETAY*TRANSF-Pyn
22275 Pt3I2=BETAZ*TRANSF-Pzn
22276c
22277 p(1,i2)=pt1i2
22278 p(2,i2)=pt2i2
22279 p(3,i2)=pt3i2
22280c
22281 PX1=P(1,I1)
22282 PY1=P(2,I1)
22283 PZ1=P(3,I1)
22284 EM1=E(I1)
22285 EM2=E(I2)
22286 ID(I1)=2
22287 ID(I2)=2
22288 RETURN
22289 END
22290c
22291c Generate angular distribution of BB from d+meson in the CMS frame:
22292 subroutine dmangle(pxn,pyn,pzn,nt,ianti,pfinal,lbm)
22293 PARAMETER (PI=3.1415926)
22294 common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
22295 1 px1n,py1n,pz1n,dp1n
22296 common /dpi/em2,lb2
22297 COMMON /AREVT/ IAEVT, IARUN, MISS
22298 COMMON/RNDF77/NSEED
22299 SAVE
22300c take isotropic distribution for now:
22301 C1=1.0-2.0*RANART(NSEED)
22302 T1=2.0*PI*RANART(NSEED)
22303 S1=SQRT(1.0-C1**2)
22304 CT1=COS(T1)
22305 ST1=SIN(T1)
22306* THE MOMENTUM IN THE CMS IN THE FINAL STATE
22307 Pzn=pfinal*C1
22308 Pxn=pfinal*S1*CT1
22309 Pyn=pfinal*S1*ST1
22310clin-5/2008 track the number of regularly-destructed deuterons:
22311c if(ianti.eq.0) then
22312c write (91,*) ' d+',lbm,' ->BB (regular d destrn) @evt#',
22313c 1 iaevt,' @nt=',nt,' lb1,2=',lb1,lb2
22314c else
22315c write (91,*) ' d+',lbm,' ->BB (regular dbar destrn) @evt#',
22316c 1 iaevt,' @nt=',nt,' lb1,2=',lb1,lb2
22317c endif
22318c
22319 return
22320 end
22321c
22322c Angular distribution of d+meson elastic collisions in the CMS frame:
22323 subroutine dmelangle(pxn,pyn,pzn,pfinal)
22324 PARAMETER (PI=3.1415926)
22325 COMMON/RNDF77/NSEED
22326 SAVE
22327c take isotropic distribution for now:
22328 C1=1.0-2.0*RANART(NSEED)
22329 T1=2.0*PI*RANART(NSEED)
22330 S1=SQRT(1.0-C1**2)
22331 CT1=COS(T1)
22332 ST1=SIN(T1)
22333* THE MOMENTUM IN THE CMS IN THE FINAL STATE
22334 Pzn=pfinal*C1
22335 Pxn=pfinal*S1*CT1
22336 Pyn=pfinal*S1*ST1
22337 return
22338 end
22339c
22340clin-9/2008 Deuteron+Baryon elastic cross section (in mb)
22341 subroutine sdbelastic(SRT,sdb)
22342 PARAMETER (srt0=2.012)
22343 common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
22344 1 px1n,py1n,pz1n,dp1n
22345 common /dpi/em2,lb2
22346 common /para8/ idpert,npertd,idxsec
22347 SAVE
22348c
22349 sdb=0.
22350 sdbel=0.
22351 if(srt.le.(em1+em2)) return
22352 s=srt**2
22353c For elastic collisions:
22354 if(idxsec.eq.1.or.idxsec.eq.3) then
22355c 1/3: assume the same |matrix element|**2 (after averaging over initial
22356c spins and isospins) for d+Baryon elastic at the same sqrt(s);
22357 sdbel=fdbel(s)
22358 elseif(idxsec.eq.2.or.idxsec.eq.4) then
22359c 2/4: assume the same |matrix element|**2 (after averaging over initial
22360c spins and isospins) for d+Baryon elastic at the same sqrt(s)-threshold:
22361 threshold=em1+em2
22362 snew=(srt-threshold+srt0)**2
22363 sdbel=fdbel(snew)
22364 endif
22365 sdb=sdbel
22366 return
22367 end
22368clin-9/2008 Deuteron+Baryon elastic collisions
22369 SUBROUTINE crdbel(PX,PY,PZ,SRT,I1,I2,IBLOCK,
22370 1 NTAG,sig,NT,ianti)
22371 PARAMETER (MAXSTR=150001,MAXR=1)
22372 COMMON /AA/R(3,MAXSTR)
22373 COMMON /BB/ P(3,MAXSTR)
22374 COMMON /BG/BETAX,BETAY,BETAZ,GAMMA
22375 COMMON /CC/ E(MAXSTR)
22376 COMMON /EE/ ID(MAXSTR),LB(MAXSTR)
22377 COMMON /AREVT/ IAEVT, IARUN, MISS
22378 common/leadng/lb1,px1,py1,pz1,em1,e1,xfnl,yfnl,zfnl,tfnl,
22379 1 px1n,py1n,pz1n,dp1n
22380 common /dpi/em2,lb2
22381 common /para8/ idpert,npertd,idxsec
22382 COMMON /dpert/dpertt(MAXSTR,MAXR),dpertp(MAXSTR),dplast(MAXSTR),
22383 1 dpdcy(MAXSTR),dpdpi(MAXSTR,MAXR),dpt(MAXSTR, MAXR),
22384 2 dpp1(MAXSTR,MAXR),dppion(MAXSTR,MAXR)
22385 SAVE
22386*-----------------------------------------------------------------------
22387 IBLOCK=0
22388 NTAG=0
22389 EM1=E(I1)
22390 EM2=E(I2)
22391 s=srt**2
22392 if(sig.le.0) return
22393 IBLOCK=503
22394c
22395 if(iabs(lb1).eq.42) then
22396 ideut=i1
22397 lbb=lb2
22398 idb=i2
22399 else
22400 ideut=i2
22401 lbb=lb1
22402 idb=i1
22403 endif
22404cccc Elastic collision of perturbatively-produced deuterons:
22405 if((idpert.eq.1.or.idpert.eq.2).and.dpertp(ideut).ne.1.) then
22406c if(ianti.eq.0) then
22407c write(91,*) ' d+',lbb,' (pert d B elastic) @nt=',nt
22408c 1 ,' @prob=',dpertp(ideut),p(1,idb),p(2,idb)
22409c 2 ,p(1,ideut),p(2,ideut)
22410c else
22411c write(91,*) ' d+',lbb,' (pert dbar Bbar elastic) @nt=',nt
22412c 1 ,' @prob=',dpertp(ideut),p(1,idb),p(2,idb)
22413c 2 ,p(1,ideut),p(2,ideut)
22414c endif
22415 pfinal=sqrt((s-(em1+em2)**2)*(s-(em1-em2)**2))/2./srt
22416 CALL dbelangle(pxn,pyn,pzn,pfinal)
22417 CALL ROTATE(PX,PY,PZ,Pxn,Pyn,Pzn)
22418 EdCM=SQRT(E(ideut)**2+Pxn**2+Pyn**2+Pzn**2)
22419 PdBETA=Pxn*BETAX+Pyn*BETAY+Pzn*BETAZ
22420 TRANSF=GAMMA*(GAMMA*PdBETA/(GAMMA+1.)+EdCM)
22421 Pt1d=BETAX*TRANSF+Pxn
22422 Pt2d=BETAY*TRANSF+Pyn
22423 Pt3d=BETAZ*TRANSF+Pzn
22424 p(1,ideut)=pt1d
22425 p(2,ideut)=pt2d
22426 p(3,ideut)=pt3d
22427 PX1=P(1,I1)
22428 PY1=P(2,I1)
22429 PZ1=P(3,I1)
22430 ID(I1)=2
22431 ID(I2)=2
22432c Change the position of the perturbative deuteron to that of
22433c the baryon to avoid consecutive collisions between them:
22434 R(1,ideut)=R(1,idb)
22435 R(2,ideut)=R(2,idb)
22436 R(3,ideut)=R(3,idb)
22437 return
22438 endif
22439c
22440c Elastic collision of regularly-produced deuterons:
22441c if(ianti.eq.0) then
22442c write (91,*) ' d+',lbb,' (regular d B elastic) @evt#',
22443c 1 iaevt,' @nt=',nt,' lb1,2=',lb1,lb2
22444c else
22445c write (91,*) ' d+',lbb,' (regular dbar Bbar elastic) @evt#',
22446c 1 iaevt,' @nt=',nt,' lb1,2=',lb1,lb2
22447c endif
22448 pfinal=sqrt((s-(em1+em2)**2)*(s-(em1-em2)**2))/2./srt
22449 CALL dbelangle(pxn,pyn,pzn,pfinal)
22450* ROTATE THE MOMENTA OF PARTICLES IN THE CMS OF P1+P2
22451c (This is not needed for isotropic distributions)
22452 CALL ROTATE(PX,PY,PZ,Pxn,Pyn,Pzn)
22453* LORENTZ-TRANSFORMATION OF THE MOMENTUM OF PARTICLES IN THE FINAL STATE
22454* FROM THE NUCLEUS-NUCLEUS CMS. FRAME INTO LAB FRAME:
22455* For the 1st baryon:
22456 E1CM=SQRT(E(I1)**2+Pxn**2+Pyn**2+Pzn**2)
22457 P1BETA=Pxn*BETAX+Pyn*BETAY+Pzn*BETAZ
22458 TRANSF=GAMMA*(GAMMA*P1BETA/(GAMMA+1.)+E1CM)
22459 Pt1i1=BETAX*TRANSF+Pxn
22460 Pt2i1=BETAY*TRANSF+Pyn
22461 Pt3i1=BETAZ*TRANSF+Pzn
22462c
22463 p(1,i1)=pt1i1
22464 p(2,i1)=pt2i1
22465 p(3,i1)=pt3i1
22466* For the 2nd baryon:
22467 E2CM=SQRT(E(I2)**2+Pxn**2+Pyn**2+Pzn**2)
22468 P2BETA=-Pxn*BETAX-Pyn*BETAY-Pzn*BETAZ
22469 TRANSF=GAMMA*(GAMMA*P2BETA/(GAMMA+1.)+E2CM)
22470 Pt1I2=BETAX*TRANSF-Pxn
22471 Pt2I2=BETAY*TRANSF-Pyn
22472 Pt3I2=BETAZ*TRANSF-Pzn
22473c
22474 p(1,i2)=pt1i2
22475 p(2,i2)=pt2i2
22476 p(3,i2)=pt3i2
22477c
22478 PX1=P(1,I1)
22479 PY1=P(2,I1)
22480 PZ1=P(3,I1)
22481 EM1=E(I1)
22482 EM2=E(I2)
22483 ID(I1)=2
22484 ID(I2)=2
22485 RETURN
22486 END
22487c
22488c Part of the cross section function of NN->Deuteron+Pi (in mb):
22489 function fnndpi(s)
22490 parameter(srt0=2.012)
22491 if(s.le.srt0**2) then
22492 fnndpi=0.
22493 else
22494 fnndpi=26.*exp(-(s-4.65)**2/0.1)+4.*exp(-(s-4.65)**2/2.)
22495 1 +0.28*exp(-(s-6.)**2/10.)
22496 endif
22497 return
22498 end
22499c
22500c Angular distribution of d+baryon elastic collisions in the CMS frame:
22501 subroutine dbelangle(pxn,pyn,pzn,pfinal)
22502 PARAMETER (PI=3.1415926)
22503 COMMON/RNDF77/NSEED
22504 SAVE
22505c take isotropic distribution for now:
22506 C1=1.0-2.0*RANART(NSEED)
22507 T1=2.0*PI*RANART(NSEED)
22508 S1=SQRT(1.0-C1**2)
22509 CT1=COS(T1)
22510 ST1=SIN(T1)
22511* THE MOMENTUM IN THE CMS IN THE FINAL STATE
22512 Pzn=pfinal*C1
22513 Pxn=pfinal*S1*CT1
22514 Pyn=pfinal*S1*ST1
22515 return
22516 end
22517c
22518c Cross section of Deuteron+Pi elastic (in mb):
22519 function fdpiel(s)
22520 parameter(srt0=2.012)
22521 if(s.le.srt0**2) then
22522 fdpiel=0.
22523 else
22524 fdpiel=63.*exp(-(s-4.67)**2/0.15)+15.*exp(-(s-6.25)**2/0.3)
22525 endif
22526 return
22527 end
22528c
22529c Cross section of Deuteron+N elastic (in mb):
22530 function fdbel(s)
22531 parameter(srt0=2.012)
22532 if(s.le.srt0**2) then
22533 fdbel=0.
22534 else
22535 fdbel=2500.*exp(-(s-7.93)**2/0.003)
22536 1 +300.*exp(-(s-7.93)**2/0.1)+10.
22537 endif
22538 return
22539 end