Geant4  9.6.p02
 All Classes Namespaces Files Functions Variables Typedefs Enumerations Enumerator Friends Macros Groups Pages
dpm25nuc7.f
Go to the documentation of this file.
1 C-------------------------------------------------------------
2 C was dpmlund.f
3 C-------------------------------------------------------------
4 C SUBROUTINE TESLUN
5 C IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6 C SAVE
7 C COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
8 C COMMON/POPCOR/PDB,AJSDEF
9 C COMMON/HARLUN/IHARLU,QLUN
10 C COMMON /HARLUN/ QLUN,IHARLU
11 C--------------------------------------------------
12 C IHARLU=0 soft jets fragmenting
13 C IHARLU=1 hard jets fragmenting
14 C with final state evolution
15 C in JETSET
16 C QLUN = Mass of hard partons at end of
17 C chain
18 C-----------------------------------------------------------
19 C AJSDEF=0.
20 C PDB=0.5
21 C IPRI=2
22 c CALL LUNDIN
23 C IHARLU=0
24 C QLUN=0.
25 C IF(IPRI.GE.2) WRITE(6,111)QLUN
26 c 111 FORMAT(' QLUN= ',F10.2)
27 C CALL BAMLUN(IHAD,1,7,0,0,25.,3,IREJ)
28 C IF(IPRI.GE.2) WRITE(6,111)QLUN
29 C CALL BAMLUN(IHAD,2,8,0,0,25.,3,IREJ)
30 C IF(IPRI.GE.2) WRITE(6,111)QLUN
31 C CALL BAMLUN(IHAD,3,9,0,0,25.,3,IREJ)
32 C IHARLU=1
33 C QLUN=8.
34 C IF(IPRI.GE.2) WRITE(6,111)QLUN
35 C CALL BAMLUN(IHAD,1,7,0,0,25.,3,IREJ)
36 C IF(IPRI.GE.2) WRITE(6,111)QLUN
37 C CALL BAMLUN(IHAD,2,8,0,0,25.,3,IREJ)
38 C IF(IPRI.GE.2) WRITE(6,111)QLUN
39 C CALL BAMLUN(IHAD,3,9,0,0,25.,3,IREJ)
40 c QLUN=6.
41 C IF(IPRI.GE.2) WRITE(6,111)QLUN
42 C CALL BAMLUN(IHAD,1,7,0,0,25.,3,IREJ)
43 C IF(IPRI.GE.2) WRITE(6,111)QLUN
44 C CALL BAMLUN(IHAD,2,8,0,0,25.,3,IREJ)
45 C IF(IPRI.GE.2) WRITE(6,111)QLUN
46 C
47 C CALL BAMLUN(IHAD,2,8,0,0,25.,3,IREJ)
48 C IF(IPRI.GE.2) WRITE(6,111)QLUN
49 C CALL BAMLUN(IHAD,3,9,0,0,25.,3,IREJ)
50 C QLUN=2.
51 C IF(IPRI.GE.2) WRITE(6,111)QLUN
52 C CALL BAMLUN(IHAD,1,7,0,0,25.,3,IREJ)
53 C IF(IPRI.GE.2) WRITE(6,111)QLUN
54 C CALL BAMLUN(IHAD,2,8,0,0,25.,3,IREJ)
55 C IF(IPRI.GE.2) WRITE(6,111)QLUN
56 C CALL BAMLUN(IHAD,3,9,0,0,25.,3,IREJ)
57 C IPRI=0
58 C IHARLU=0
59 C QLUN=0.
60 C RETURN
61 C END
62  SUBROUTINE lundin
63  IMPLICIT DOUBLE PRECISION (a-h,o-z)
64  SAVE
65  INTEGER pycomp
66 C
67 C INITIALIZATION FOR JETSET-7.3 CALL IN DTUNUC 1.04 (J.R. 6/93)
68 C
69  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
70  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
71  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
72  common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)
73  common/popcor/pdb,ajsdef
74  common/promu/ipromu
75  common/ifragm/ifrag
76 C COMMON/HARLUN/IHARLU,QLUN
77  COMMON /harlun/ qlun,iharlu
78  DATA ipromm/0/
79 C--------------------------------------------------
80 C IHARLU=0 soft jets fragmenting
81 C IHARLU=1 hard jets fragmenting
82 C with final state evolution
83 C in JEYTSET
84 C QLUN = Mass of hard partons at end of
85 C chain
86 C-----------------------------------------------------------
87 C defaults for parton showering
88 C QCD type branchings
89  mstj(41)=1
90 C coherent branching, angular
91 C ordering
92  mstj(42)=2
93  mstj(43)=4
94  mstj(44)=2
95 C only u,d,s,c quarks
96  mstj(45)=4
97  mstj(46)=0
98 C no lowest order corrections
99  mstj(47)=0
100  mstj(48)=0
101  mstj(49)=0
102 C Lambda in running alpha(s)
103  parj(81)=0.40d0
104 C M(min) cut-off
105  parj(82)=1.d0
106  parj(83)=1.d0
107 C------------------------------------------------------------------
108  iharlu=0
109  qlun=0.d0
110 C-----------------------------------------------------------------
111  IF(ipromu.NE.0)ipromm=ipromu
112 C IPROMM=1
113 C----------------------------------------------------------------
114 C if AJSDEF=1 set default values for all jetset parameters
115  IF(ajsdef.EQ.1.d0) go to 100
116 C----------------------------------------------------------------
117 C switch off popcorn fragmentation
118 C MSTJ(12) default 2 : popcorn allowed
119  IF(pdb.EQ.0.d0)mstj(12)=1
120 C TEST proton x distribution 19.11.97
121  mstj(12)=3
122  parj(19)=0.1
123 C----------------------------------------------------------------
124 C MODIFY POPCORM mechanism
125 C PARJ(5), default:0.5
126  IF(pdb.GT.0.d0)parj(5)=pdb
127 C
128 C----------------------------------------------------------------
129 C
130 C DEFINE Lund parameters
131 C IFRAG=1
132 C
133 C----------------------------------------------------------------
134 C
135  IF(ifrag.EQ.1)THEN
136 C Probability for meson with spin 1 (d=0.5)
137  parj(11)=0.6d0
138 C----------------------------------------------------------------
139 C Lund b-parameter (default=0.9)
140  parj(42)=0.5d0
141 C----------------------------------------------------------------
142 C Lund a-parameter (default=0.5)
143  parj(41)=0.2d0
144 C----------------------------------------------------------------
145 C d=1 Lund Fragmentation 2: F-F fragmentation
146 C MSTJ(11)=1
147 C F.-F. c-parameter (default=0.77)
148 C PARJ(51)=0.99
149 C PARJ(52)=0.99
150 C PARJ(53)=0.99
151 C----------------------------------------------------------------
152 C Lund sigma parameter in pt distribution
153 C (default=0.35)
154  parj(21)=0.42d0
155 C----------------------------------------------------------------
156 C Some of these parmeters are changed in BAMLUN
157 C!!!!!!!!
158 
159 C----------------------------------------------------------------
160 C Diquark supression (default 0.1)
161  parj(1)=0.07d0
162 C PARJ(1)=0.06D0
163 C----------------------------------------------------------------
164 C STRANGENESS supression (default 0.3)
165 C PARJ(2)=0.27D0
166 C 6.1.95
167  parj(2)=0.25d0
168 C----------------------------------------------------------------
169 C Extra supression of strange diquarks
170 C Default 0.4
171 C PARJ(3)=0.4D0
172 C 6.1.95
173  parj(3)=0.3d0
174 C PARJ(3)=0.5D0
175 C----------------------------------------------------------------
176 C Extra supression of Strangeness in
177 C B-M-B Situation (defaults 0.5)
178 C PARJ(6)=0.75D0
179 C PARJ(7)=0.75D0
180 C 6.1.95
181  parj(6)=0.50d0
182  parj(7)=0.50d0
183 C PARJ(6)=0.75D0
184 C PARJ(7)=0.75D0
185 C----------------------------------------------------------------
186 C
187 C----------------------------------------------------------------
188 C
189 C DEFINE Lund parameters
190 C IFRAG=10
191 C low energy tests
192 C
193 C----------------------------------------------------------------
194  ELSEIF(ifrag.EQ.10)THEN
195 C Probability for meson with spin 1 (d=0.5)
196  parj(11)=0.6d0
197 C----------------------------------------------------------------
198 C Lund b-parameter (default=0.9)
199  parj(42)=0.5
200 C----------------------------------------------------------------
201 C Lund a-parameter (default=0.5)
202 C PARJ(41)=0.51
203 C 14.3.95 like 1
204  parj(41)=0.20d0
205 C----------------------------------------------------------------
206 C d=1 Lund Fragmentation 2: F-F fragmentation
207 C MSTJ(11)=1
208 C F.-F. c-parameter (default=0.77)
209 C PARJ(51)=0.99
210 C PARJ(52)=0.99
211 C PARJ(53)=0.99
212 C----------------------------------------------------------------
213 C Lund sigma parameter in pt distribution
214 C (default=0.35)
215  parj(21)=0.42d0
216 C----------------------------------------------------------------
217 C Some of these parmeters are changed in BAMLUN
218 C!!!!!!!!
219 
220 C----------------------------------------------------------------
221 C Diquark supression (default 0.1)
222  parj(1)=0.07d0
223 C----------------------------------------------------------------
224 C STRANGENESS supression (default 0.3)
225 C PARJ(2)=0.27D0
226 C 6.1.95
227  parj(2)=0.25d0
228 C----------------------------------------------------------------
229 C Extra supression of strange diquarks
230 C Default 0.4
231 C PARJ(3)=0.4D0
232 C 6.1.95
233  parj(3)=0.3d0
234 C----------------------------------------------------------------
235 C Extra supression of Strangeness in
236 C B-M-B Situation (defaults 0.5)
237 C PARJ(6)=0.75D0
238 C PARJ(7)=0.75D0
239 C 6.1.95
240  parj(6)=0.50d0
241  parj(7)=0.50d0
242 C----------------------------------------------------------------
243 C
244 C----------------------------------------------------------------
245 C----------------------------------------------------------------
246  ENDIF
247 C----------------------------------------------------------------
248  100 CONTINUE
249  WRITE (6,2355)pdb,ajsdef,mstj(12),parj(42),parj(21)
250  2355 FORMAT( ' LUNDIN initialization PDB,AJSDEF= ',2f10.3/
251  + ' MSTJ(12) popcorn default=2 : ',i10/
252  + ' PARJ(42 )Lund b,default=0.9 : ',f10.3/
253  + ' PARJ(21) sigma in pt distr,default=0.35 : ',f10.3)
254 C----------------------------------------------------------------
255 C Prevent particles dacaying
256 C KOS
257  kc=pycomp(310)
258  mdcy(kc,1)=0
259 C PIO
260  kc=pycomp(111)
261  mdcy(kc,1)=0
262 C LAMBDA
263  kc=pycomp(3122)
264  mdcy(kc,1)=0
265 C ALAMBDA
266  kc=pycomp(-3122)
267  mdcy(kc,1)=0
268 C SIG+
269  kc=pycomp(3222)
270  mdcy(kc,1)=0
271 C ASIG+
272  kc=pycomp(-3222)
273  mdcy(kc,1)=0
274 C SIG-
275  kc=pycomp(3112)
276  mdcy(kc,1)=0
277 C ASIG-
278  kc=pycomp(-3112)
279  mdcy(kc,1)=0
280 C SIG0
281 C KC=PYCOMP(3212)
282 C MDCY(KC,1)=0
283 C ASIG0
284 C KC=PYCOMP(-3212)
285 C MDCY(KC,1)=0
286 C TET0
287  kc=pycomp(3322)
288  mdcy(kc,1)=0
289 C ATET0
290  kc=pycomp(-3322)
291  mdcy(kc,1)=0
292 C TET-
293  kc=pycomp(3312)
294  mdcy(kc,1)=0
295 C ATET-
296  kc=pycomp(-3312)
297  mdcy(kc,1)=0
298 C OMEGA-
299  kc=pycomp(3334)
300  mdcy(kc,1)=0
301 C AOMEGA-
302  kc=pycomp(-3334)
303  mdcy(kc,1)=0
304 C TAU
305  kc=pycomp(15)
306  mdcy(kc,1)=0
307 C
308 C HAVE CHARMED MESONS DECAYING for IPROMM=1
309 C
310  IF(ipromm.EQ.1)go to 199
311 C D+
312  kc=pycomp(411)
313  mdcy(kc,1)=0
314 C D-
315  kc=pycomp(-411)
316  mdcy(kc,1)=0
317 C D0
318  kc=pycomp(421)
319  mdcy(kc,1)=0
320 C A-D0
321  kc=pycomp(-421)
322  mdcy(kc,1)=0
323 C DS+
324  kc=pycomp(431)
325  mdcy(kc,1)=0
326 C A-DS+
327  kc=pycomp(-431)
328  mdcy(kc,1)=0
329 C ETAC
330  kc=pycomp(441)
331  mdcy(kc,1)=0
332  199 CONTINUE
333 C LAMBDAC+
334  kc=pycomp(4122)
335  mdcy(kc,1)=0
336 C A-LAMBDAC+
337  kc=pycomp(-4122)
338  mdcy(kc,1)=0
339 C SIGMAC++
340  kc=pycomp(4222)
341  mdcy(kc,1)=0
342 C SIGMAC+
343  kc=pycomp(4212)
344  mdcy(kc,1)=0
345 C SIGMAC0
346  kc=pycomp(4112)
347  mdcy(kc,1)=0
348 C A-SIGMAC++
349  kc=pycomp(-4222)
350  mdcy(kc,1)=0
351 C A-SIGMAC+
352  kc=pycomp(-4212)
353  mdcy(kc,1)=0
354 C A-SIGMAC0
355  kc=pycomp(-4112)
356  mdcy(kc,1)=0
357 C KSIC+
358  kc=pycomp(4232)
359  mdcy(kc,1)=0
360 C KSIC0
361  kc=pycomp(4132)
362  mdcy(kc,1)=0
363 C A-KSIC+
364  kc=pycomp(-4232)
365  mdcy(kc,1)=0
366 C A-KSIC0
367  kc=pycomp(-4132)
368  mdcy(kc,1)=0
369  RETURN
370  END
371  SUBROUTINE bamlun(IHAD,KFA1,KFA2,KFA3,KFA4,AEO,IOPT,IREJ)
372 C
373 C IOPT = 3 q -- aq Jet
374 C IOPT = 4 q -- qq Jet
375 C IOPT = 5 qq -- aqaq Jet
376 C IOPT = 10 q -- q -- q Jet Capella-Kopeliovich
377 C
378  IMPLICIT DOUBLE PRECISION (a-h,o-z)
379  SAVE
380 C
381 C INTERFACE FOR JETSET-7.3 CALL IN DTUNUC 1.04 (J.R. 6/93)
382 C
383  common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
384  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
385  common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
386  CHARACTER*8 anf
387  parameter(nfimax=249)
388  COMMON /dfinpa/ anf(nfimax),pxf(nfimax),pyf(nfimax),pzf(nfimax),
389  +hef(nfimax),amf(nfimax), ichf(nfimax),ibarf(nfimax),nref(nfimax)
390  COMMON /dfinpz/iormo(nfimax),idaug1(nfimax),idaug2(nfimax),
391  * istath(nfimax)
392 *KEEP,DPRIN.
393  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
394  CHARACTER*8 aname
395  common/dpar/aname(210),am(210),ga(210),tau(210),ich(210),
396  *ibar(210),k1(210),k2(210)
397  common/diffra/isingd,idiftp,ioudif,iflagd
398  common/capkop/xxx1,xxx3
399  dimension nbamlu(10)
400  dimension koriii(4000)
401  common/promu/ipromu
402  common/popcor/pdb,ajsdef
403  common/ifragm/ifrag
404 C COMMON/HARLUN/IHARLU,QLUN
405  COMMON /harlun/ qlun,iharlu
406  COMMON /nncms/ gamcm,bgcm,umo,pcm,eproj,pproj
407  COMMON /jspart/pxp(1000),pyp(1000),pzp(1000),hep(1000),nnnp
408 C--------------------------------------------------
409 C IHARLU=0 soft jets fragmenting
410 C IHARLU=1 hard jets fragmenting
411 C with final state evolution
412 C in JEYTSET
413 C QLUN = Mass of hard partons at end of
414 C chain
415 C-----------------------------------------------------------
416  dimension ijoin(3)
417  COMMON /jni/jni
418  COMMON /ndon/ndone
419  DATA ijoin/1,2,3/
420  DATA ipromm/0/
421  DATA nbamlu /2,1,3,4,5,6,-2,-1,-3,-4/
422  DATA icoun/0/
423  DATA iwarn/0/
424  DATA nbaml/0/
425  IF(ipromu.NE.0)ipromm=ipromu
426 C
427 C---------------------------------------------------------
428 C
429 C Change Lund parameters depending on energy
430 C
431 C---------------------------------------------------------
432 C
433 C
434 C----------------------------------------------------------------
435 C
436 C DEFINE Lund parameters
437 C IFRAG=1
438 C
439 C----------------------------------------------------------------
440 C
441  IF(ifrag.EQ.1)THEN
442 C--------------------------------------------------------------
443 C--------------------------------------------------------------
444 C Test LUND default 2.2.99
445 C--------------------------------------------------------------
446 C--------------------------------------------------------------
447  IF(aeo.LE.15.d0)THEN
448 C Lund b-parameter (default=0.9)
449 C 2.2.99
450 C PARJ(42)=1.55D0
451 C 22.4.99
452  parj(42)=1.20d0
453 C Lund a-parameter (default=0.5)
454 C 2.2.99
455 c PARJ(41)=0.14D0
456 C 22.4.99
457  parj(41)=0.30d0
458 C Lund sigma parameter in pt distribution
459 C (default=0.35)
460  parj(21)=0.35d0
461  parj(23)=0.2d0
462  parj(24)=2.d0
463  ELSEIF(aeo.GE.30.d0)THEN
464 C Lund b-parameter (default=0.9)
465 C 2.2.99
466  parj(42)=1.1d0
467 C Lund a-parameter (default=0.5)
468 C 2.2.99
469  parj(41)=0.40d0
470 C Lund sigma parameter in pt distribution
471 C (default=0.35)
472  parj(21)=0.38d0
473  parj(23)=0.2d0
474  parj(24)=2.d0
475  ELSE
476  ainter=(aeo-15.d0)/15.d0
477 C Lund b-parameter (default=0.9)
478 C 2.2.99 (das war wohl falsch)
479 C PARJ(42)=1.15D0-AINTER*0.45D0
480 C 22.4.99
481  parj(42)=1.20d0-ainter*0.10d0
482 C Lund a-parameter (default=0.5)
483 C 2.2.99
484 C PARJ(41)=0.14D0+AINTER*0.15D0
485 C 22.4.99
486  parj(41)=0.30d0+ainter*0.10d0
487 C Lund sigma parameter in pt distribution
488 C (default=0.35)
489  parj(21)=0.35d0+ainter*0.03d0
490  parj(23)=0.2d0
491  parj(24)=2.d0
492  ENDIF
493 C Probability for meson with spin 1 (d=0.5)
494  parj(11)=0.4d0
495 C Extra supression for spin 3/2 baryons (d=1.)
496  parj(18)=0.3d0
497 C Extra supression for eta production (d=1.)
498 C taken out since no effect on eta production 5.3.97
499 C PARJ(25)=1.3D0
500 C
501 C
502 C----------------------------------------------------------------
503 C
504 C DEFINE Lund parameters
505 C IFRAG=10
506 C Low energy test
507 C
508 C----------------------------------------------------------------
509  ELSEIF(ifrag.EQ.10)THEN
510  IF(aeo.LT.4.d0)THEN
511 C Supress S=3/2 Baryons at low energy
512 C PARJ(18)=0.D0
513 C Lund b-parameter (default=0.9)
514  IF(pproj.LE.30.d0)THEN
515  parj(42)= 0.6d0
516  ELSEIF(pproj.GE.100.d0)THEN
517  parj(42)= 6.d0
518  ELSE
519  dupar=(pproj-30.d0)/70.d0
520  parj(42)=0.6d0+dupar*5.4d0
521  ENDIF
522 C Popcorn
523  mstj(12)=2
524  parj(5)=pdb
525 C Lund sigma parameter in pt distribution
526 C (default=0.35)
527  parj(21)=0.65d0
528  parj(23)=0.2d0
529  parj(24)=2.d0
530 C extension 16.12--------------------
531  ELSEIF(aeo.LT.7.d0)THEN
532 C 4--7 GeV
533  ainter=-(aeo- 7.d0)/3.d0
534 C Lund b-parameter (default=0.9)
535  IF(pproj.LE.30.d0)THEN
536  dd42=0.25d0
537  ELSEIF(pproj.GE.100.d0)THEN
538  dd42=5.65d0
539  ELSE
540  dupar=(pproj-30.d0)/70.d0
541  dd42=0.25d0+dupar*5.4d0
542  ENDIF
543  parj(42)=0.35d0+ainter*dd42
544 C Lund sigma parameter in pt distribution
545 C (default=0.35)
546  parj(21)=0.65d0
547  parj(23)=0.2d0
548  parj(24)=2.d0
549 C Popcorn
550  mstj(12)=2
551  parj(5)=pdb
552 C extension 16.12--------------------
553  ELSEIF(aeo.LT.10.d0)THEN
554 C-----------------------------------end test-15.12-----------------------
555 C Test unsuccessful p-p multiplicities too low
556 C IF(AEO.LT.10.D0)THEN
557 C Lund b-parameter (default=0.9)
558 C PARJ(42)=6.0 before 4.2.94
559 C PARJ(42)=0.5 before 21.3.94
560  parj(42)=0.35d0
561 C Lund sigma parameter in pt distribution
562 C (default=0.35)
563  parj(21)=0.55d0
564  parj(21)=0.65d0
565  parj(23)=0.2d0
566  parj(24)=2.d0
567 C Popcorn
568  mstj(12)=2
569  parj(5)=pdb
570  ELSEIF(aeo.GE.30.d0)THEN
571 C Lund b-parameter (default=0.9)
572 C PARJ(42)=1.1 D0 before 21.3.94
573  parj(42)=0.5d0
574  parj(42)=0.35d0
575 C Lund sigma parameter in pt distribution
576 C (default=0.35)
577  parj(21)=0.42d0
578  parj(21)=0.52d0
579  parj(23)=0.2d0
580  parj(24)=2.d0
581 C Popcorn
582  mstj(12)=2
583  parj(5)=pdb
584  ELSE
585  ainter=-(aeo-30.d0)/20.d0
586 C Lund b-parameter (default=0.9)
587 C PARJ(42)=1.4D0+AINTER*4.6D0 before 4.2.94
588 c PARJ(42)=1.1D0-AINTER*0.6D0 before 21.3.94
589  parj(42)=0.5d0-ainter*0.15d0
590  parj(42)=0.35d0-ainter*0.00d0
591 C Lund sigma parameter in pt distribution
592 C (default=0.35)
593  parj(21)=0.42d0+ainter*0.13d0
594  parj(21)=0.52d0+ainter*0.13d0
595  parj(23)=0.2d0
596  parj(24)=2.d0
597 C Popcorn
598  mstj(12)=2
599  parj(5)=pdb
600  ENDIF
601 C
602  ENDIF
603 C IF(IOPT.EQ.5)THEN
604 C PARJ(21)=0.46
605 C ELSEIF(IOPT.EQ.3)THEN
606 C PARJ(21)=0.46
607 C ELSEIF(IOPT.EQ.4)THEN
608 C PARJ(21)=0.46
609 C ENDIF
610 C
611 C---------------------------------------------------------
612 C
613 C Change Lund parameters depending on energy
614 C SINGLE DIFFRACTIVE EVENTS
615 C
616 C---------------------------------------------------------
617 C
618  IF(iflagd.EQ.1)THEN
619 C Lund b-parameter (default=0.9)
620  parj(42)=0.23d0
621 C Lund sigma parameter in pt distribution
622 C (default=0.35)
623  parj(21)=0.55d0
624 C IF(AEO.LE.6.D0)THEN
625 C Lund b-parameter (default=0.9)
626 C
627 C PARJ(42)=0.15
628 C ELSEIF(AEO.GE.30.D0)THEN
629 C Lund b-parameter (default=0.9)
630 C PARJ(42)=0.4
631 C ELSE
632 C AINTER=-(AEO-30.)/24.
633 C Lund b-parameter (default=0.9)
634 C PARJ(42)=0.4+AINTER*0.25
635 C ENDIF
636 C IF(AEO.LE.6.D0)THEN
637 C Lund sigma parameter in pt distribution
638 C (default=0.35)
639 C PARJ(21)=0.85
640 C ELSEIF(AEO.LE.10.D0)THEN
641 C AINTER=-(AEO-7.)/4.
642 C Lund sigma parameter in pt distribution
643 C (default=0.35)
644 C PARJ(21)=0.55+AINTER*0.30
645 C ELSEIF(AEO.GE.30.D0)THEN
646 C Lund sigma parameter in pt distribution
647 C (default=0.35)
648 C PARJ(21)=0.40
649 C ELSE
650 C AINTER=-(AEO-30.)/20.
651 C Lund sigma parameter in pt distribution
652 C (default=0.35)
653 C PARJ(21)=0.40+AINTER*0.15
654 C ENDIF
655  ENDIF
656 C
657 C--------------------------------------------------------
658 C
659 C--------------------------------------------------------
660 C
661 C Check and modify flavors at chain ends depending on energy
662 C and define Lund flavor parameters
663 C
664 C--------------------------------------------------------
665 C
666 C IOPT = 3 Quark-Antiquark
667 C
668 C--------------------------------------------------------
669 C
670  111 CONTINUE
671  IF(iopt.EQ.3)THEN
672  IF((kfa1.LE.0.OR.kfa1.GT.10).OR.
673  * (kfa2.LE.0.OR.kfa2.GT.10))THEN
674  kfa11=kfa1
675  kfa22=kfa2
676  kfa1=1
677  kfa2=7
678  iwarn=iwarn+1
679  IF(iwarn.LE.20)WRITE(6,*)
680  * ' BAMLUN KFA1,KFA2:',kfa11,kfa22,
681  * ' changed into :',kfa1,kfa2
682  ENDIF
683  IF(aeo.LE.4.2d0)THEN
684  IF((kfa1.EQ.4).AND.
685  * (kfa2.EQ.10))THEN
686  kfa11=kfa1
687  kfa22=kfa2
688  kfa1=1
689  iwarn=iwarn+1
690  IF(iwarn.LE.20)WRITE(6,*)
691  * ' BAMLUN KFA1,KFA2 at energy AEO:',kfa11,kfa22,aeo,
692  * ' changed into:',kfa1,kfa2
693  ELSEIF((kfa1.EQ.10).AND.
694  * (kfa2.EQ.4))THEN
695  kfa11=kfa1
696  kfa22=kfa2
697  kfa2=1
698  iwarn=iwarn+1
699  IF(iwarn.LE.20)WRITE(6,*)
700  * ' BAMLUN KFA1,KFA2 at energy AEO:',kfa11,kfa22,aeo,
701  * ' changed into:',kfa1,kfa2
702  ENDIF
703  ENDIF
704  IF(aeo.LE.2.5d0)THEN
705  IF(kfa1.EQ.4
706  * )THEN
707  kfa11=kfa1
708  kfa22=kfa2
709  kfa1=1
710  iwarn=iwarn+1
711  IF(iwarn.LE.20)WRITE(6,*)
712  * ' BAMLUN KFA1,KFA2 at energy AEO:',kfa11,kfa22,aeo,
713  * ' changed into:',kfa1,kfa2
714  ELSEIF(kfa1.EQ.10
715  * )THEN
716  kfa11=kfa1
717  kfa22=kfa2
718  kfa1=7
719  iwarn=iwarn+1
720  IF(iwarn.LE.20)WRITE(6,*)
721  * ' BAMLUN KFA1,KFA2 at energy AEO:',kfa11,kfa22,aeo,
722  * ' changed into:',kfa1,kfa2
723  ELSEIF(
724  * kfa2.EQ.4)THEN
725  kfa11=kfa1
726  kfa22=kfa2
727  kfa2=1
728  iwarn=iwarn+1
729  IF(iwarn.LE.20)WRITE(6,*)
730  * ' BAMLUN KFA1,KFA2 at energy AEO:',kfa11,kfa22,aeo,
731  * ' changed into:',kfa1,kfa2
732  ELSEIF(
733  * kfa2.EQ.10)THEN
734  kfa11=kfa1
735  kfa22=kfa2
736  kfa2=7
737  iwarn=iwarn+1
738  IF(iwarn.LE.20)WRITE(6,*)
739  * ' BAMLUN KFA1,KFA2 at energy AEO:',kfa11,kfa22,aeo,
740  * ' changed into:',kfa1,kfa2
741  ENDIF
742  ENDIF
743  IF(((kfa1.EQ.3.OR.kfa1.EQ.9).AND.
744  * (kfa2.EQ.3.OR.kfa2.EQ.9)).AND.aeo.LE.1.5d0)THEN
745  kfa11=kfa1
746  kfa22=kfa2
747  kfa1=2
748  iwarn=iwarn+1
749  IF(iwarn.LE.20)WRITE(6,*)
750  * ' BAMLUN KFA1,KFA2 at energy AEO:',kfa11,kfa22,aeo,
751  * ' changed into:',kfa1,kfa2
752  ENDIF
753  IF(((kfa1.EQ.3.OR.kfa1.EQ.9).OR.
754  * (kfa2.EQ.3.OR.kfa2.EQ.9)).AND.aeo.LE.1.0d0)THEN
755  kfa11=kfa1
756  kfa22=kfa2
757  kfa1=2
758  kfa2=8
759  iwarn=iwarn+1
760  IF(iwarn.LE.20)WRITE(6,*)
761  * ' BAMLUN KFA1,KFA2 at energy AEO:',kfa11,kfa22,aeo,
762  * ' changed into:',kfa1,kfa2
763  ENDIF
764  IF(aeo.LT.0.8d0)THEN
765  irej=1
766  nbaml=nbaml+1
767  IF(nbaml.LT.20)WRITE(6,*)' REJ. IN BAMLUN q-aq A < 0.8',aeo
768  RETURN
769  ENDIF
770  ifla1=nbamlu(kfa1)
771  ifla2=nbamlu(kfa2)
772 C
773 C--------------------------------------------------------
774 C
775 C IOPT = 4 Quark-Diquark
776 C
777 C--------------------------------------------------------
778 C
779  ELSEIF(iopt.EQ.4.OR.iopt.EQ.6)THEN
780  IF(aeo.LT.1.3d0)THEN
781  irej=1
782  nbaml=nbaml+1
783  IF(nbaml.LT.20)WRITE(6,*)' REJ. IN BAMLUN q-qq E< 1.5 ',aeo
784  RETURN
785  ENDIF
786  IF((kfa1.LE.0.OR.kfa1.GT.10).OR.
787  * (kfa2.LE.0.OR.kfa2.GT.10).OR.
788  * (kfa2.LE.0.OR.kfa3.GT.10))THEN
789  kfa11=kfa1
790  kfa22=kfa2
791  kfa33=kfa3
792  kfa1=1
793  kfa2=2
794  kfa3=1
795  iwarn=iwarn+1
796  IF(iwarn.LE.20)WRITE(6,*)
797  * ' BAMLUN IOPT KFA1,KFA2,KFA3:',
798  * iopt,kfa11,kfa22,
799  * kfa33,' changed into :',kfa1,kfa2,kfa3
800  * ,iopt
801  ENDIF
802  IF(aeo.LT.3.5d0)THEN
803  IF(kfa1.EQ.4
804  * )THEN
805  kfa11=kfa1
806  kfa22=kfa2
807  kfa33=kfa3
808  kfa1=1
809  IF(iwarn.LE.20)WRITE(6,*)
810  * ' BAMLUN KFA1,KFA2,KFA3 at energy AEO:',kfa11,kfa22,kfa33,aeo,
811  * ' changed into:',kfa1,kfa2,kfa3
812  * ,iopt
813  ELSEIF(
814  * kfa2.EQ.4
815  * )THEN
816  kfa11=kfa1
817  kfa22=kfa2
818  kfa33=kfa3
819  kfa2=1
820  IF(iwarn.LE.20)WRITE(6,*)
821  * ' BAMLUN KFA1,KFA2,KFA3 at energy AEO:',kfa11,kfa22,kfa33,aeo,
822  * ' changed into:',kfa1,kfa2,kfa3
823  * ,iopt
824  ELSEIF(
825  * kfa3.EQ.4)THEN
826  kfa11=kfa1
827  kfa33=kfa3
828  kfa22=kfa2
829  kfa3=1
830  iwarn=iwarn+1
831  IF(iwarn.LE.20)WRITE(6,*)
832  * ' BAMLUN KFA1,KFA2,KFA3 at energy AEO:',kfa11,kfa22,kfa33,aeo,
833  * ' changed into:',kfa1,kfa2,kfa3
834  * ,iopt
835  ELSEIF(kfa1.EQ.10
836  * )THEN
837  kfa11=kfa1
838  kfa22=kfa2
839  kfa33=kfa3
840  kfa1=7
841  IF(iwarn.LE.20)WRITE(6,*)
842  * ' BAMLUN KFA1,KFA2,KFA3 at energy AEO:',kfa11,kfa22,kfa33,aeo,
843  * ' changed into:',kfa1,kfa2,kfa3
844  * ,iopt
845  ELSEIF(
846  * kfa2.EQ.10
847  * )THEN
848  kfa11=kfa1
849  kfa22=kfa2
850  kfa33=kfa3
851  kfa2=7
852  IF(iwarn.LE.20)WRITE(6,*)
853  * ' BAMLUN KFA1,KFA2,KFA3 at energy AEO:',kfa11,kfa22,kfa33,aeo,
854  * ' changed into:',kfa1,kfa2,kfa3
855  * ,iopt
856  ELSEIF(
857  * kfa3.EQ.10)THEN
858  kfa11=kfa1
859  kfa22=kfa2
860  kfa33=kfa3
861  kfa3=7
862  iwarn=iwarn+1
863  IF(iwarn.LE.20)WRITE(6,*)
864  * ' BAMLUN KFA1,KFA2,KFA3 at energy AEO:',kfa11,kfa22,kfa33,aeo,
865  * ' changed into:',kfa1,kfa2,kfa3
866  * ,iopt
867  ENDIF
868  ENDIF
869  IF(aeo.LT.4.2d0)THEN
870  IF(kfa1.EQ.4
871  * )THEN
872  kfa11=kfa1
873  kfa22=kfa2
874  kfa33=kfa3
875  kfa1=1
876  IF(iwarn.LE.20)WRITE(6,*)
877  * ' BAMLUN KFA1,KFA2,KFA3 at energy AEO:',kfa11,kfa22,kfa33,aeo,
878  * ' changed into:',kfa1,kfa2,kfa3
879  * ,iopt
880  ELSEIF(
881  * kfa2.EQ.4
882  * )THEN
883  kfa11=kfa1
884  kfa22=kfa2
885  kfa33=kfa3
886  kfa2=1
887  IF(iwarn.LE.20)WRITE(6,*)
888  * ' BAMLUN KFA1,KFA2,KFA3 at energy AEO:',kfa11,kfa22,kfa33,aeo,
889  * ' changed into:',kfa1,kfa2,kfa3
890  * ,iopt
891  ELSEIF(
892  * kfa3.EQ.4)THEN
893  kfa11=kfa1
894  kfa33=kfa3
895  kfa22=kfa2
896  kfa3=1
897  iwarn=iwarn+1
898  IF(iwarn.LE.20)WRITE(6,*)
899  * ' BAMLUN KFA1,KFA2,KFA3 at energy AEO:',kfa11,kfa22,kfa33,aeo,
900  * ' changed into:',kfa1,kfa2,kfa3
901  * ,iopt
902  ELSEIF(kfa1.EQ.10
903  * )THEN
904  kfa11=kfa1
905  kfa22=kfa2
906  kfa33=kfa3
907  kfa1=7
908  IF(iwarn.LE.20)WRITE(6,*)
909  * ' BAMLUN KFA1,KFA2,KFA3 at energy AEO:',kfa11,kfa22,kfa33,aeo,
910  * ' changed into:',kfa1,kfa2,kfa3
911  * ,iopt
912  ELSEIF(
913  * kfa2.EQ.10
914  * )THEN
915  kfa11=kfa1
916  kfa22=kfa2
917  kfa33=kfa3
918  kfa2=7
919  IF(iwarn.LE.20)WRITE(6,*)
920  * ' BAMLUN KFA1,KFA2,KFA3 at energy AEO:',kfa11,kfa22,kfa33,aeo,
921  * ' changed into:',kfa1,kfa2,kfa3
922  * ,iopt
923  ELSEIF(
924  * kfa3.EQ.10)THEN
925  kfa11=kfa1
926  kfa22=kfa2
927  kfa33=kfa3
928  kfa3=7
929  iwarn=iwarn+1
930  IF(iwarn.LE.20)WRITE(6,*)
931  * ' BAMLUN KFA1,KFA2,KFA3 at energy AEO:',kfa11,kfa22,kfa33,aeo,
932  * ' changed into:',kfa1,kfa2,kfa3
933  * ,iopt
934  ENDIF
935  ENDIF
936  IF(aeo.LT.1.25d0)THEN
937  kfa11=kfa1
938  kfa22=kfa2
939  kfa33=kfa3
940  kfa1=1
941  kfa2=7
942  kfa3=0
943  iwarn=iwarn+1
944  IF(iwarn.LE.20)WRITE(6,*)
945  * ' BAMLUN KFA1,KFA2,KFA3 at energy AEO:',kfa11,kfa22,kfa33,aeo,
946  * ' changed into:',kfa1,kfa2,kfa3
947  * ,iopt
948  iopt=3
949  go to 111
950  ENDIF
951  ifla1=nbamlu(kfa1)
952  ifl2=nbamlu(kfa2)
953  ifl3=nbamlu(kfa3)
954  IF(abs(ifl3).GT.abs(ifl2))THEN
955  ifl22=ifl2
956  ifl2=ifl3
957  ifl3=ifl22
958  ENDIF
959  ifla2=1000*abs(ifl2)+100*abs(ifl3)
960  iflz=3
961  IF(abs(ifl3).LT.abs(ifl2).AND.rndm(u).LE.0.25d0)iflz=1
962  ifla2=ifla2+iflz
963  IF(ifl2.LT.0)ifla2=-ifla2
964 C IF(IFLA1.EQ.-1.AND.IFLA2.EQ.-3303)IPRI=2
965 C
966 C--------------------------------------------------------
967 C
968 C IOPT = 5 DiQuark-AntiDiquark
969 C
970 C--------------------------------------------------------
971 C
972  ELSEIF(iopt.EQ.5)THEN
973  ifl1=nbamlu(kfa1)
974  ifl2=nbamlu(kfa2)
975  IF(abs(ifl2).GT.abs(ifl1))THEN
976  ifl11=ifl1
977  ifl1=ifl2
978  ifl2=ifl11
979  ENDIF
980  ifl3=nbamlu(kfa3)
981  ifl4=nbamlu(kfa4)
982  IF(abs(ifl4).GT.abs(ifl3))THEN
983  ifl33=ifl3
984  ifl3=ifl4
985  ifl4=ifl33
986  ENDIF
987  ifla1=1000*abs(ifl1)+100*abs(ifl2)
988  ifla2=1000*abs(ifl3)+100*abs(ifl4)
989  iflz=3
990  IF(abs(ifl2).LT.abs(ifl1).AND.rndm(u).LE.0.25d0)iflz=1
991  ifla1=ifla1+iflz
992  IF(ifl1.LT.0)ifla1=-ifla1
993  iflz=3
994  IF(abs(ifl4).LT.abs(ifl3).AND.rndm(u).LE.0.25d0)iflz=1
995  ifla2=ifla2+iflz
996  IF(ifl3.LT.0)ifla2=-ifla2
997 C
998 C--------------------------------------------------------
999 C
1000 C IOPT = 10 DiQuark-AntiDiquark
1001 C
1002 C--------------------------------------------------------
1003 C
1004  ELSEIF(iopt.EQ.10)THEN
1005  ifla1=nbamlu(kfa1)
1006  ifla2=nbamlu(kfa2)
1007  ifla3=nbamlu(kfa3)
1008  ENDIF
1009  IF(ipri.GE.1)WRITE(6,*)ifla1,ifla2,aeo,ifla3
1010 C WRITE(6,103)IFLA1,IFLA2,AEO,' BAMLUN'
1011  103 FORMAT(' BAMLUN',2i10,f10.2,i10)
1012 C
1013 C---------------------------------------------------------------------------
1014 C
1015 C JETSET Call
1016 C
1017 C---------------------------------------------------------------------------
1018 C
1019 C--------------------------------------------------
1020 C IHARLU=0 soft jets fragmenting
1021 C IHARLU=1 hard jets fragmenting
1022 C with final state evolution
1023 C in JETSET
1024 C QLUN = Mass of hard partons at end of
1025 C chain
1026 C-----------------------------------------------------------
1027 C CALL PY2ENT(0,IFLA1,IFLA2,AEO)
1028 C----------------------------------------------------------
1029  IF(iopt.EQ.10)THEN
1030  xx1=xxx1
1031  xx3=xxx3
1032  xx2=1.d0-xx1
1033  icou=0
1034  1234 CONTINUE
1035  icou=icou+1
1036  IF(icou.GE.100)THEN
1037 C WRITE(6,*)" Stop in dpmlund IOPT=10"
1038  stop
1039  ENDIF
1040 C Select sea q--aq pair
1041  CALL xseapa(aeo,xxxx,isq,isaq,xsq,xsaq,irej)
1042  WRITE(6,*)isq,isaq,xsq,xsaq,xx1
1043 C IF(XSQ+XSAQ.GE.XX1/2.D0)GO TO 1234
1044  IF(xsq.GE.xx1/2.d0.OR.xsaq.GE.xx3/2.d0)go to 1234
1045 C IF(XSQ.LE.XX2)GO TO 1234
1046  xx1=xx1-xsq
1047  xx3=xx3-xsaq
1048  iflasq=nbamlu(isq)
1049  iflasa=nbamlu(isaq)
1050 
1051  IF(ifla1.GT.0)THEN
1052 C Form diquark out of IFLA2 and IFLASQ
1053  IF(abs(iflasq).GT.abs(ifla2))THEN
1054  ifl11=ifla2
1055  ifla2=iflasq
1056  iflasq=ifl11
1057  ENDIF
1058  iflad=1000*abs(ifla2)+100*abs(iflasq)
1059  iflz=3
1060  IF(abs(iflasq).LT.abs(ifla2).AND.rndm(u).LE.0.25d0)iflz=1
1061  iflad=iflad+iflz
1062  WRITE(6,'(4I10)')ifla1,iflad,iflasa,ifla3
1063  CALL py4ent(1,ifla1,iflad,iflasa,ifla3,aeo,
1064  * xx1,xx2+xsq,xx3,0.d0,4.d0*xx1*xx3)
1065 C * XX1,XX2+XSQ,XX3,4.D0*XX1*(XX2+XSQ),4.D0*XX1*XX3)
1066 C * XX1,XX2+XSQ,XX3,(XX1-XX2-XSQ)**2,4.D0*XX1*XX3)
1067  ijoin(1)=1
1068  ijoin(2)=3
1069  CALL pyjoin(2,ijoin)
1070  ijoin(1)=2
1071  ijoin(2)=4
1072  CALL pyjoin(2,ijoin)
1073  CALL pyexec
1074  ELSEIF(ifla1.LT.0)THEN
1075 C Form anti-diquark out of IFLA2 and IFLASA
1076  IF(abs(iflasa).GT.abs(ifla2))THEN
1077  ifl11=ifla2
1078  ifla2=iflasa
1079  iflasa=ifl11
1080  ENDIF
1081  iflad=1000*abs(ifla2)+100*abs(iflasa)
1082  iflz=3
1083  IF(abs(iflasa).LT.abs(ifla2).AND.rndm(u).LE.0.25d0)iflz=1
1084  iflad=iflad+iflz
1085  IF(ifla2.LT.0)iflad=-iflad
1086  WRITE(6,'(4I10)')ifla1,iflad,iflasq,ifla3
1087  CALL py4ent(1,ifla1,iflad,iflasq,ifla3,aeo,
1088  * xx1,xx2+xsaq,xx3,0.d0,xx1*xx3)
1089  ijoin(1)=1
1090  ijoin(2)=3
1091  CALL pyjoin(2,ijoin)
1092  ijoin(1)=2
1093  ijoin(2)=4
1094  CALL pyjoin(2,ijoin)
1095  CALL pyexec
1096  ENDIF
1097  ELSE
1098  IF(iharlu.EQ.0)THEN
1099  CALL py2ent(0,ifla1,ifla2,aeo)
1100  pxp(1)=0.
1101  pyp(1)=0.
1102  pzp(1)=aeo/2.d0
1103  hep(1)=aeo/2.d0
1104  pxp(2)=0.d0
1105  pyp(2)=0.d0
1106  pzp(2)=aeo/2.d0
1107  hep(2)=aeo/2.d0
1108  nnnp=2
1109  ELSEIF(iharlu.EQ.1)THEN
1110  CALL py2ent(-1,ifla1,ifla2,aeo)
1111  CALL pyshow(1,2,qlun)
1112  DO 201 i=1,n
1113  IF(k(i,1).EQ.3)THEN
1114  nnnp=nnnp+1
1115  IF(nnnp.LT.1000)THEN
1116  pxp(nnnp)=p(i,1)
1117  pyp(nnnp)=p(i,2)
1118  pzp(nnnp)=p(i,3)
1119  hep(nnnp)=p(i,4)
1120  ENDIF
1121  ENDIF
1122  201 CONTINUE
1123  IF(ipri.GE.2)CALL pylist(1)
1124  CALL pyexec
1125 C CALL PYLIST(1)
1126  ENDIF
1127  ENDIF
1128 C Force all particles wanted to decay
1129  DO 1111 iiii=1,n
1130  IF(k(iiii,1).EQ.4)k(iiii,1)=5
1131  1111 CONTINUE
1132  CALL pyexec
1133 C
1134  IF(ipri.GE.2)WRITE(6,*)' After PYEXEC'
1135  IF(ipri.GE.2)CALL pylist(1)
1136 C CALL PYLIST(1)
1137 C IF(IPRI.GE.2)CALL PYLIST(1)
1138 C
1139 C---------------------------------------------------------------------------
1140 C
1141 C Edit JETSET event
1142 C
1143 C---------------------------------------------------------------------------
1144 C
1145  CALL pyedit(12)
1146  icoun=icoun+1
1147  IF(ipri.GE.2)WRITE(6,*)' After PYEDIT'
1148 C CALL PYLIST(1)
1149  IF(ipri.GE.2)CALL pylist(1)
1150  IF(iharlu.EQ.1.AND.ndone.EQ.-107801)THEN
1151  WRITE(6,*)'NDONE ',ndone
1152  CALL pylist(1)
1153  ENDIF
1154 C
1155 C---------------------------------------------------------------------------
1156 C
1157 C Move JETSET event into BAMJET COMMON
1158 C
1159 C---------------------------------------------------------------------------
1160 C
1161  ihad=0
1162 C EXISTING PARTICLES
1163  IF(ipri.GE.2) WRITE(6,*)' DPMJET COMMON particles'
1164  iorii=0
1165  korjjj=0
1166  korkkk=-2
1167  DO 101 i=1,n
1168 C fragmented string
1169  IF((k(i,1).EQ.11).AND.(k(i,2).EQ.92))THEN
1170 C J.R. 11.2.2000
1171 C---------------------------------------------------
1172 C IF(KORJJJ.NE.0)GO TO 101
1173 C---------------------------------------------------
1174  iorii=999
1175  korii=i
1176 C KORJJJ is the first string
1177  IF(korjjj.EQ.0)korjjj=i
1178  ENDIF
1179 C fragmented cluster
1180  IF((k(i,1).EQ.11).AND.(k(i,2).EQ.91))THEN
1181  iorii=999
1182  korii=i
1183 C KORJJJ is the first string
1184  IF(korjjj.EQ.0)korjjj=i
1185  ENDIF
1186 C KORIII(I) is the string from which particle I comes
1187  koriii(i)=korii
1188 C undecayed particle, decayed particle
1189  IF((k(i,1).EQ.1).OR.(k(i,1).EQ.4).OR.(k(i,1).EQ.11)
1190  * .OR.(k(i,1).EQ.15))THEN
1191 C strings and clusters
1192  IF((k(i,2).EQ.91).OR.(k(i,2).EQ.92).OR.(k(i,2).EQ.94))THEN
1193  korkkk=korkkk+1
1194  go to 101
1195  ENDIF
1196 C quarks
1197  IF(abs(k(i,2)).LE.6) go to 101
1198  IF(abs(k(i,2)).GE.1000) THEN
1199  koo=abs(k(i,2))
1200  kaa=koo/100
1201  kll=koo-kaa*100
1202 C diquarks
1203  IF(kll.EQ.1.OR.kll.EQ.3)go to 101
1204  ENDIF
1205  ihad=ihad+1
1206  IF(ihad.GT.nfimax)THEN
1207  WRITE(6,1112)ihad
1208  1112 FORMAT(.GT.' BAMLUN: IHADNFIMAX INCREASE NFIMAX IHAD=',i10)
1209  go to 101
1210  ENDIF
1211  IF(k(i,3).EQ.koriii(i))THEN
1212 C Hadrons from string
1213  iormo(ihad)=iorii
1214  ELSE
1215 C Hadrons from decaying particle
1216  IF(korjjj.EQ.koriii(k(i,3)))THEN
1217 C IORMO(IHAD)=K(I,3)-KORJJJ
1218 C J.R.15.2.2000
1219  iormo(ihad)=k(i,3)-korjjj
1220  ELSE
1221 C IORMO(IHAD)=K(I,3)-KORJJJ-1
1222 C J.R.15.2.2000
1223  iormo(ihad)=k(i,3)-korjjj-1-korkkk
1224  ENDIF
1225  ENDIF
1226  pxf(ihad)=p(i,1)
1227  pyf(ihad)=p(i,2)
1228  pzf(ihad)=p(i,3)
1229  hef(ihad)=p(i,4)
1230  nrefb=mcihad(k(i,2))
1231  amasss=pymass(k(i,2))
1232  IF(ipri.GE.3)WRITE(6,'(4I10)')i,k(i,1),k(i,2),nrefb
1233  IF(nrefb.LT.1.OR.nrefb.GT.183)nrefb=4
1234  nref(ihad)=nrefb
1235  anf(ihad)=aname(nrefb)
1236 C AMF(IHAD)=AM(NREFB)
1237  amf(ihad)=amasss
1238 C WRITE(6,*)' IHAD,AMF(IHAD),AMASSS ',IHAD,AMF(IHAD),AMASSS
1239  ichf(ihad)=ich(nrefb)
1240  ibarf(ihad)=ibar(nrefb)
1241  istath(ihad)=1
1242  IF(k(i,1).EQ.11.OR.k(i,1).EQ.15)THEN
1243  ibarf(ihad)=500
1244  istath(ihad)=2
1245  ENDIF
1246 C
1247 C IF(NREFB.EQ.31.OR.NREFB.EQ.95)THEN
1248 C WRITE(6,*)'K(I,1),IBARF(IHAD),ISTATH(IHAD)',
1249 C * K(I,1),IBARF(IHAD),ISTATH(IHAD)
1250 C WRITE(6,*)ICOUN,IHAD,K(I,2),NREFB,K(I,3),
1251 C * ISTATH(IHAD),IORMO(IHAD),ANF(IHAD),
1252 C * PXF(IHAD),PYF(IHAD),
1253 C * PZF(IHAD),HEF(IHAD),AMF(IHAD),' BAMLUN'
1254 C ENDIF
1255  IF(ndone.EQ.-107801.AND.iharlu.EQ.1)THEN
1256  WRITE(6,*)i,icoun,ihad,k(i,2),nrefb,k(i,3),
1257  * istath(ihad),ibarf(ihad),iormo(ihad),anf(ihad),
1258  * pxf(ihad),pyf(ihad),
1259  * pzf(ihad),hef(ihad),amf(ihad),koriii(i),
1260  * korjjj,' BAMLUN'
1261  ENDIF
1262  102 FORMAT(' BAMLUN',2i5,5i10,a8,5e12.3)
1263 C
1264  ENDIF
1265  101 CONTINUE
1266 C DECAYED RESONAMCES TO BE PUT INTO EVENT RECORD
1267 C NOTE: PARTICLES with IBARF=500 are decayed
1268  IF(jni.NE.7)go to 777
1269  IF(jni.NE.7)THEN
1270 C WRITE(6,*)' DPMJET COMMON decayed particles'
1271  iorii=0
1272  DO 105 i=1,n
1273  IF(k(i,1).EQ.11.AND.k(i,2).EQ.92)THEN
1274  iorii=999
1275  korii=i
1276  ENDIF
1277  IF(k(i,1).EQ.11.OR.k(i,1).EQ.15)THEN
1278  IF(k(i,2).EQ.92) go to 105
1279  IF(k(i,2).EQ.94) go to 105
1280  IF(abs(k(i,2)).LE.6) go to 105
1281  ihad=ihad+1
1282  IF(ihad.GT.nfimax)THEN
1283  WRITE(6,1112)ihad
1284  go to 107
1285  ENDIF
1286  IF(k(i,3).EQ.korii)THEN
1287 C Hadrons from string
1288  iormo(ihad)=iorii
1289  ELSE
1290  iormo(ihad)=k(i,3)-korii
1291  ENDIF
1292  pxf(ihad)=p(i,1)
1293  pyf(ihad)=p(i,2)
1294  pzf(ihad)=p(i,3)
1295  hef(ihad)=p(i,4)
1296  nrefb=mcihad(k(i,2))
1297  amasss=pymass(k(i,2))
1298  IF(ipri.GE.3)WRITE(6,'(5I10)')i,k(i,1),k(i,2),k(i,3),nrefb
1299  IF(nrefb.LT.1.OR.nrefb.GT.183)nrefb=4
1300  nref(ihad)=nrefb
1301  anf(ihad)=aname(nrefb)
1302 C AMF(IHAD)=AM(NREFB)
1303  amf(ihad)=amasss
1304  ichf(ihad)=ich(nrefb)
1305  ibarf(ihad)=500
1306 C
1307  IF(ipri.GE.3)WRITE(6,102)icoun,ihad,k(i,2),nrefb,k(i,3),
1308  * iormo(ihad),anf(ihad),
1309  * pxf(ihad),pyf(ihad),
1310  * pzf(ihad),hef(ihad),amf(ihad)
1311 C
1312  ENDIF
1313  105 CONTINUE
1314  ENDIF
1315  777 CONTINUE
1316  107 CONTINUE
1317 C
1318 C---------------------------------------------------------------------------
1319 C
1320  IF(ifla1.EQ.-1.AND.ifla2.EQ.-3303)ipri=0
1321  RETURN
1322  END
1323  SUBROUTINE xseapa(ECM,XXXX,IPSQ1,IPSAQ1,XPSQ1,XPSAQ1,IREJ)
1324  IMPLICIT DOUBLE PRECISION(a-h,o-z)
1325  SAVE
1326  COMMON /seasu3/seasq
1327  irej=0
1328  IF(ecm.LT.20.d0)THEN
1329  xpthro=1.5d0*log10(ecm/200.d0)+3.5d0
1330  ELSEIF(ecm.GE.20.d0)THEN
1331  xpthro=5.0d0
1332  ENDIF
1333  xpthr=1.5d0*xpthro/(ecm**1.5d0*14.d0)
1334 C XSTHR2=1.5D0*XPTHR2/(ECM**1.5D0*14.D0)
1335 C WRITE(6,*)' XSEAPA:XPTHR ',XPTHR
1336  i=1
1337  ai=i-1
1338  xpthrx=xpthr-0.5d0*ai/ecm**2
1339  IF (xpthrx.LT.4.d0/ecm**2)xpthrx=4.d0/ecm**2
1340 C---------------------------------------------------------------
1341 C SPLIT GLUON INTO TWO SEA QUARKS
1342 C FLAVORS OF SEA QUARKS
1343 C INCREASE s-quark fraction to acount for larger rejection
1344  seasqq=2.d0*seasq
1345  ai=i
1346  bi=i+i
1347  ipsq1=1.+rndm(ai)*(2.d0+seasqq)
1348  ipsaq1=-ipsq1
1349  ipsaq1=6+ipsq1
1350 C WRITE(6,*)' XSEAPA SEASQQ,IPSQ1,IPSAQ1',SEASQQ,IPSQ1,IPSAQ1
1351 C X-FRAXTIONS OF SEA QUARKS
1352 C------------------------------------------------------j.r.29.4.93
1353  sox1=0.3d0
1354  ncou=0
1355  500 CONTINUE
1356  ncou=ncou+1
1357  IF(ipsq1.EQ.3)THEN
1358  IF(ncou.GE.200)THEN
1359  irej=3
1360  RETURN
1361  ENDIF
1362  ELSE
1363  IF(ncou.GE.50)THEN
1364  irej=1
1365  RETURN
1366  ENDIF
1367  ENDIF
1368  xglu1=sampex(xpthrx,sox1)
1369  IF(ipsq1.LE.2)THEN
1370  xpsq1=(0.2d0+(0.36d0*rndm(ai))**0.50d0)*xglu1
1371  xpsaq1=xglu1-xpsq1
1372  ELSEIF(ipsq1.EQ.3)THEN
1373 C CHANGE J.R. 18.2.99
1374  IF (xpsq1.LE.0.3d0/ecm)go to 500
1375  IF (xpsaq1.LE.0.3d0/ecm)go to 500
1376  ENDIF
1377  IF(xpsaq1.GE.xxxx)go to 500
1378  RETURN
1379  END
1380 C------------------------------------------------------------
1381 C was dpmtcbsh.f
1382 C------------------------------------------------------------
1383 C
1384 C file with changes of r.e. 20.12.93 old file: d4tcbshm.fold
1385 *-- Author :
1386 C PROGRAM SHMAKOV 11/1986
1387 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
1388 C THE PROGRAM SIMULATES THE STARS OF THE SECONDARY PARTICLES IN NUCLEUS
1389 C -NUCLEUS COLLISIONS AT HIGH ENERGIES. THE SIMULATION IS BASED ON
1390 C GLAUBER APPROACH. EACH STAR IS MADE UP AS THE SUM OVER THE ORDERED N-
1391 C N STARS. MESON PRODUCTION IS ONLY TAKEN INTO ACCOUNT.
1392 C LET'S DISCRIBE THE MAIN PARAMETERS OF THE PROGRAM IN FORM:
1393 C FIRST LIST OF THE PARAMETERS - MEANING - (BOUNDS); AND SO ON.
1394 C NA,NB - AMOUNT OF NUCLONS IN NUCLEI A AND B - (GT.1,LT.41,
1395 C PREFERENTIALLY NA LT. NB)
1396 C NCA,NCB - AMOUNT OF PROTONS IN THE NUCLEI
1397 C RA,RB - THE RADII TO USE INTO FORMULARS FOR THE NUCLEAR DENSITIES -(F
1398 C SIG,G,RO - THE PARAMETERS OF THE N-N ELASTIC AMPLITUDE,
1399 C AMLITUDE(B)=SIG*G*(1-I*RO)*EXP(-G*B**2)/2PI - (FM**2,FM**(-2) AND
1400 C DIMENSIONLESS ACCORDIANLY)
1401 C SE2 - QUADRATE OF THE TOTAL 4-MOMENTUM BOTH NUCLEI - (GEV**2,
1402 C GT. (NA+NB)**2,PREFERENTIALLY GT. 4*(NA+NB)**2)
1403 C TF01,TF02 - FERMI ENERGIES IN THE CENTERS OF THE NUCLEI - (GEV)
1404 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
1405 C
1406  SUBROUTINE shmaki(NA,NCA,NB,NCB,RPROJ,RTARG,PPN)
1407  IMPLICIT DOUBLE PRECISION (a-h,o-z)
1408  SAVE
1409 C*** SHMAKOV INITIALIZATION
1410 *KEEP,DSHM.
1411  COMMON /dshm/ rash,rbsh,bmax,bstep,sigsh,rosh,gsh,
1412  * bsite(0:1,200),nstatb,nsiteb
1413  COMMON /dshms/ sigshs
1414 *KEEP,RTAR.
1415  COMMON /rtar/ rtarnu
1416 *KEEP,NUCC.
1417  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
1418 *KEND.
1419  COMMON /zentra/ icentr
1420  COMMON /sigla/siglau
1421  COMMON /kglaub/jglaub
1422 C--------------------------------------
1423  rna=na
1424  rnb=nb
1425  rash=1.12d0*rna**0.33d0
1426  rbsh=1.12d0*rnb**0.33d0
1427  IF(jglaub.EQ.1)THEN
1428  IF(na.EQ.9)rash=2.52d0
1429  IF(na.EQ.10)rash=2.45d0
1430  IF(na.EQ.11)rash=2.37d0
1431  IF(na.EQ.12)rash=2.45d0
1432  IF(na.EQ.13)rash=2.44d0
1433  IF(na.EQ.14)rash=2.55d0
1434  IF(na.EQ.15)rash=2.58d0
1435  IF(na.EQ.16)rash=2.71d0
1436  IF(na.EQ.17)rash=2.66d0
1437  IF(na.EQ.18)rash=2.71d0
1438  IF(nb.EQ.9)rbsh=2.52d0
1439  IF(nb.EQ.10)rbsh=2.45d0
1440  IF(nb.EQ.11)rbsh=2.37d0
1441  IF(nb.EQ.12)rbsh=2.45d0
1442  IF(nb.EQ.13)rbsh=2.44d0
1443  IF(nb.EQ.14)rbsh=2.55d0
1444  IF(nb.EQ.15)rbsh=2.58d0
1445  IF(nb.EQ.16)rbsh=2.71d0
1446  IF(nb.EQ.17)rbsh=2.66d0
1447  IF(nb.EQ.18)rbsh=2.71d0
1448  ENDIF
1449  WRITE(6,*)' SHMAKI: RASH, RBSH = ',rash,rbsh
1450  rproj=rash
1451  rtarg=rbsh
1452  rtarnu=rbsh
1453  nstatb=2000
1454  IF((icentr.EQ.1).AND.(na.GE.200).AND.(nb.GE.200))THEN
1455  nstatb=1000
1456  ENDIF
1457  nsiteb=200
1458  WRITE(6, 1010)nstatb,nsiteb
1459  1000 FORMAT(2i10)
1460  1010 FORMAT(' STATISTIC ON POINT ON B AND NUMBER OF POINTS',2i10)
1461 C*** PARAMETERS IN NN-AMP.
1462  sigsh=4.3
1463  ppnn=ppn
1464  WRITE(6,*)' SMAKI, PPN = ',ppn
1465  sigsh=dshpto(ijproj,ppn)/10.d0
1466 C IF(NA.GT.0.D0)
1467 C *SIGSH=(DSHPTO(IJPROJ,PPNN)-SIGSDS(PPNN*2.D0))/10.D0
1468  IF(jglaub.EQ.2)THEN
1469  sigshs=(dshpto(ijproj,ppnn)-sigsds(ppnn*2.d0))/10.d0
1470  ELSEIF(jglaub.EQ.1)THEN
1471  sigshs=(dshpto(ijproj,ppnn))/10.d0
1472  ENDIF
1473  IF(ijproj.EQ.5)THEN
1474  sigshs=(dshpto(1,ppnn)-sigsds(ppnn*2.d0))/10.d0
1475  ENDIF
1476  sigsh=sigshs
1477  gsh=1.6
1478  bslope=10.d0
1479  sss=2.*ppn
1480  ecm=sqrt(sss)
1481  IF (ijproj.LE.12)bslope=8.5d0*(1.d0+0.065d0*log(sss))
1482  IF (ijproj.GT.12)bslope=6.d0*(1.d0+0.065d0*log(sss))
1483  gsh=1.d0/(2.d0*bslope*0.038938d0)
1484  rosh=-0.43d0
1485  IF (ijproj.LE.12)THEN
1486  IF(ecm.GT.3.0d0.AND.ecm.LE.50.d0) rosh=-0.63d0+
1487  + 0.175d0*log(ecm)
1488  IF(ecm.GT.50.) rosh=0.1d0
1489  ENDIF
1490  IF (ijproj.GT.12) rosh=0.01d0
1491  WRITE(6, 1030)sigsh,rosh,gsh,bslope,ecm
1492  1020 FORMAT(3f10.5)
1493  1030 FORMAT(' PARAMETERS OF THE NN AMPLITUDE SIG,RO,G,BSLOPE,ECM ' /5
1494  +(1pe12.5))
1495  CALL title(na,nb,nca,ncb)
1496  WRITE(6,*)' vor PREVIO(RA,RB,NSTB,BMAX,BSTEP,SIG,RO,G)',
1497  &rash,rbsh,nsiteb,bmax,bstep,sigsh,rosh,gsh
1498  CALL previo(rash,rbsh,nsiteb,bmax,bstep,sigsh,rosh,gsh)
1499  WRITE(6,*)' SHMAKI: RASH, RBSH = ',rash,rbsh
1500  CALL profb(bstep,nstatb,na,rash,nb,rbsh,bsite,nsiteb)
1501  WRITE(37,'(4I5,F15.2,E15.5,F15.2)')
1502  * na,nca,nb,ncb,sigsh,ppn,siglau
1503  RETURN
1504  END
1505  DOUBLE PRECISION FUNCTION sigsds(S)
1506 C Approximate sigma_SD in p-p (mb)
1507  IMPLICIT DOUBLE PRECISION (a-h,o-z)
1508  SAVE
1509  sigsds=4.d0+1.2d0*log10(s)
1510  RETURN
1511  END
1512 *-- Author :
1513 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
1514 C
1515  SUBROUTINE shmakf(NA,NCA,NB,NCB)
1516  IMPLICIT DOUBLE PRECISION (a-h,o-z)
1517  SAVE
1518 C*** SHMAKOV INITIALIZATION
1519 C*** To be called for each material separately
1520 C*** Input of Shmakov data from file:
1521 C*** 1) 'NUCLEUS' IT, ITZ
1522 C*** 2) BMAX, BSTEP, RASH, RBSH
1523 C*** 3) BSITE (energy and projectile dependence)
1524 C-----------------------
1525  CHARACTER*10 bnuc
1526 *KEEP,DSHM.
1527  COMMON /dshm/ rash,rbsh,bmax,bstep,sigsh,rosh,gsh,
1528  * bsite(0:1,200),nstatb,nsiteb
1529  COMMON /dshms/ sigshs
1530 *KEEP,RTAR.
1531  COMMON /rtar/ rtarnu
1532 *KEEP,NUCC.
1533  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
1534 *KEEP,DTUMAT.
1535  COMMON /dtumat/ bsiten(200,24,50),bsitem(200,24,50),
1536  + rprojj(50),rtargg(50),bstepp(50),bmaxx(50),
1537  + ntaxx(50),nztaxx(50),nprxx(50),nzprxx(50)
1538 *KEEP,DAMP.
1539  COMPLEX*16 ca,ci
1540  COMMON /damp/ ca,ci,ga
1541 *KEND.
1542  COMMON /kkmatu/kkmato,kkmata,ipoo,ipoa,ipzoo,ipzoa
1543  *,ibproo,ibproa,ireado
1544  dimension help(200)
1545  DATA matnum /0/
1546 C--------------------------------------
1547  kkmato=0
1548  ipoo=0
1549  ipzoo=0
1550  ibproo=0
1551  ireado=0
1552  rewind 47
1553  matnum=matnum + 1
1554  IF(matnum.GT.50) THEN
1555  WRITE(6,'(2A,I3/A)')
1556  & ' Too large number of materials requested for Glauber',
1557  & ' initialization in SHMAKF / MATNUM=',matnum,
1558  & ' execution stopped in SHMAKF'
1559  stop
1560  ENDIF
1561  WRITE(6,'(A,I3,A)') ' Read Glauber data for material no.',matnum,
1562  & ' from unit 47'
1563 C----------------------------------Read Glauber data----------------
1564  DO 72 i=1,100000
1565  READ(47,'(A10)',end=79) bnuc
1566  IF(bnuc.EQ.' NUCLEUS ') THEN
1567  backspace 47
1568  READ(47,'(A10,4I10)') bnuc,nprx,nzprx,ntax,nztax
1569  IF(nb.EQ.ntax.AND.ncb.EQ.nztax.AND.na.EQ.nprx.
1570  & and.nca.EQ.nzprx) THEN
1571  ntaxx(matnum)=ntax
1572  nztaxx(matnum)=nztax
1573  nprxx(matnum)=nprx
1574  nzprxx(matnum)=nzprx
1575  READ(47,'(4F10.5)') bmaxx(matnum),bstepp(matnum),
1576  & rprojj(matnum),rtargg(matnum)
1577  DO 170 ie=1,24
1578  READ(47,'(5E16.8)') (bsiten(ida,ie,matnum),ida=1,200)
1579  170 CONTINUE
1580  IF(nprx.EQ.1)THEN
1581  DO 171 ie=1,24
1582  READ(47,'(5E16.8)') (bsitem(ida,ie,matnum),ida=1,200)
1583  171 CONTINUE
1584  ENDIF
1585  goto 78
1586  ENDIF
1587  ENDIF
1588  72 CONTINUE
1589  79 CONTINUE
1590  WRITE(6,'(A)') ' GLAUBER DATA NOT FOUND'
1591  stop
1592 
1593  78 CONTINUE
1594  DO 80 i=1,200
1595  help(i)=i*bstepp(matnum)
1596  WRITE (6,1040) help(i),(bsiten(i,ie,matnum),ie=1,24)
1597  1040 FORMAT (f10.4,10(1pe12.4)/10(1pe12.4))
1598  80 CONTINUE
1599 C-------------------------------------------------------------------
1600  RETURN
1601  END
1602 *-- Author :
1603 C
1604 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1605 C
1606  SUBROUTINE shmako(NA,NB,B,INTT,INTA,INTB,JS,JT,PPN,KKMAT)
1607  IMPLICIT DOUBLE PRECISION (a-h,o-z)
1608  SAVE
1609  parameter(namx=248)
1610  parameter(intmx=2488,intmd=252)
1611  dimension js(namx),jt(namx)
1612 *KEEP,DPRIN.
1613  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
1614 *KEEP,NUCKOO.
1615  COMMON /nuckoo/ pkoo(3,intmx),tkoo(3,intmx),ppoo(3,intmx),
1616  +tpoo(3,intmx)
1617 *KEEP,DSHM.
1618  COMMON /dshm/ rash,rbsh,bmax,bstep,sigsh,rosh,gsh,
1619  * bsite(0:1,200),nstatb,nsiteb
1620  COMMON /dshms/ sigshs
1621 *KEEP,NUCC.
1622  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
1623 *KEEP,INTMX.
1624 *KEEP,SHMAKL.
1625 C INCLUDE (SHMAKL)
1626 * NOTE: INTMX set via INCLUDE(INTMX)
1627  common/shmakl/jssh(intmx),jtsh(intmx),inter1(intmx),inter2(intmx)
1628 *KEEP,DTUMAT.
1629  COMMON /dtumat/ bsiten(200,24,50),bsitem(200,24,50),
1630  + rprojj(50),rtargg(50),bstepp(50),bmaxx(50),
1631  + ntaxx(50),nztaxx(50),nprxx(50),nzprxx(50)
1632 *KEEP,RTAR.
1633  COMMON /rtar/ rtarnu
1634 *KEEP,DAMP.
1635  COMPLEX*16 ca,ci
1636  COMMON /damp/ ca,ci,ga
1637 *KEEP,RPTSHM.
1638  COMMON /rptshm/ rproj,rtarg,bimpac
1639 *KEND.
1640  COMMON /kkmatu/kkmato,kkmata,ipoo,ipoa,ipzoo,ipzoa
1641  *,ibproo,ibproa,ireado
1642  COMMON /kglaub/jglaub
1643 C------------------------------------------
1644 *---use predefined values for BSITE array and redefine necessary parameters
1645 *---if initialization by SHMAKI (KKMAT=0) all information directly available
1646  kkmata=kkmat
1647  ipoa=ip
1648  ipzoa=ipz
1649  IF(ip.GE.2)ijproj=1
1650  IF(ip.GE.2)ibproj=1
1651  ibproa=ibproj
1652  IF(kkmat.GT.0) THEN
1653  rash=rprojj(kkmat)
1654  rbsh=rtargg(kkmat)
1655  rproj=rash
1656  rtarg=rbsh
1657  rtarnu=rbsh
1658  bmax=bmaxx(kkmat)
1659  bstep=bstepp(kkmat)
1660 C SIGSH=DSHPTO(IJPROJ,PPN)/10.
1661 C IF(NA.GT.2.D0)
1662 C *SIGSH=(DSHPTO(IJPROJ,PPN)-SIGSDS(PPN*2.D0))/10.D0
1663  IF(jglaub.EQ.2)THEN
1664  sigshs=(dshpto(ijproj,ppn)-sigsds(ppn*2.d0))/10.d0
1665  ELSEIF(jglaub.EQ.1)THEN
1666  sigshs=(dshpto(ijproj,ppn))/10.d0
1667  ENDIF
1668  IF(ijproj.EQ.5)THEN
1669  sigshs=(dshpto(1,ppn)-sigsds(ppn*2.d0))/10.d0
1670  ENDIF
1671  sigsh=sigshs
1672  bslope=10.d0
1673  sss=2.*ppn
1674  ecm=sqrt(sss)
1675  IF (ijproj.LE.12)bslope=8.5d0*(1.d0+0.065d0*log(sss))
1676  IF (ijproj.GT.12)bslope=6.d0*(1.d0+0.065d0*log(sss))
1677 * GSH=1.6D0
1678  gsh=1.d0/(2.d0*bslope*0.038938d0)
1679  rosh=-0.43d0
1680  IF (ibproj.LE.12)THEN
1681  IF(ecm.GT.3.0d0.AND.ecm.LE.50.d0) rosh=-0.63d0+
1682  + 0.175d0*log(ecm)
1683  IF(ecm.GT.50.d0) rosh=0.1
1684  ENDIF
1685  IF (ijproj.GT.12) rosh=0.01
1686  rca=gsh*sigshs/6.2831854d0
1687  fca=-gsh*sigshs*rosh/6.2831854d0
1688  ca=cmplx(rca,fca)
1689  ga=gsh
1690  iread=0
1691  wu10=sqrt(10.0)
1692  DO 73 ipo=1,24
1693  ppo=wu10**(ipo+1) + 10.
1694  IF(ppn.LE.ppo) THEN
1695  iread=iread + ipo - 1
1696  goto 74
1697  ENDIF
1698  73 CONTINUE
1699  74 CONTINUE
1700  IF(iread.LE.0)iread=1
1701  IF(iread.GE.25)iread=24
1702 C old (before 10/98 IF, which might be correct for HEMAS interface
1703 C INTER_DPM calling DPMEVT calling KKINC (to be checked)
1704 C IF (KKMAT.NE.KKMATO.AND.IP.NE.IPOO.AND.
1705 C * IJPROJ.NE.IBPROO.AND.IPZ.NE.IPZOO )THEN
1706  IF ((kkmat.NE.kkmato).OR.(ip.NE.ipoo).OR.
1707  * (ibproj.NE.ibproo).OR.(ipz.NE.ipzoo).OR.(iread.NE.ireado) )THEN
1708  IF(ibproj.NE.0) THEN
1709  DO 75 ii=1,200
1710  bsite(1,ii)=bsiten(ii,iread,kkmat)
1711  75 CONTINUE
1712  ibproo=ibproj
1713 C ADDED 10/98
1714  kkmato=kkmat
1715  ireado=iread
1716  ELSE
1717  DO 76 ii=1,200
1718  bsite(1,ii)=bsitem(ii,iread,kkmat)
1719  76 CONTINUE
1720  ibproo=ibproj
1721 C ADDED 10/98
1722  kkmato=kkmat
1723  ireado=iread
1724  ENDIF
1725  ENDIF
1726  ENDIF
1727  IF(ipev.GE.6) THEN
1728  WRITE(6,'(A)') ' SHMAKO - BEFORE DIAGR'
1729  IF(ipri.GE.6) WRITE(6, 1030)sigsh,rosh,gsh,bslope,ecm
1730  1030 FORMAT(' PARAMETERS OF THE NN AMPLITUDE SIG,RO,G,BSLOPE,ECM ' /5
1731  +(1pe12.5))
1732  ENDIF
1733  CALL diagr(na,nb,b,js,jt,intt,inta,intb)
1734  IF(ipev.GE.6) WRITE(6,1000)na,nb,b,intt,inta,intb,js(1),jt(1),
1735  + pkoo(1,1),tkoo(1,1)
1736  1000 FORMAT(' NA,NB,B,INTT,INTA,INTB,JS(1),JT(1),PKOO(1,1),TKOO(1,1)
1737  + IN SHMAKO '/2i5,f10.4,5i6,2f10.3)
1738  RETURN
1739  END
1740 *-- Author :
1741 C
1742 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1743 C
1744  SUBROUTINE title(NA,NB,NCA,NCB)
1745  IMPLICIT DOUBLE PRECISION (a-h,o-z)
1746  SAVE
1747  WRITE(6,1000)na,nca,nb,ncb
1748  1000 FORMAT(//10x,39hglauber s approach is used to simulate ,
1749  +26hnucleus-nucleus collisions/ 24x,
1750  +40hthe calculation nas been carried out for/
1751  +27h projected nuclei with a = ,i5,12h charge a = ,i5/
1752  +24h TARGET nuclei with b = ,i5,12h charge b = ,i5///)
1753  RETURN
1754  END
1755 *-- Author :
1756 C
1757 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1758 C
1759  SUBROUTINE conucl(X,N,R)
1760  IMPLICIT DOUBLE PRECISION (a-h,o-z)
1761  SAVE
1762 C -----------------------------------
1763  COMMON /kglaub/jglaub
1764  dimension x(3,n),wd(4),rd(3)
1765  LOGICAL istart
1766  DATA sqr2/1.414216d0/
1767  DATA pdif/0.545d0/,r2min/0.16d0/
1768  DATA wd/0.d0,0.178d0,0.465d0,1.d0/
1769  DATA rd/2.09d0,0.935d0,0.697d0/
1770 C DATA RC12/1.6976D0/,WC12/0.4444444D0/
1771  aan=n
1772  IF (n.EQ.1)THEN
1773  goto 10
1774  ELSEIF (n.EQ.2)THEN
1775  goto 20
1776  ELSEIF (n.EQ.4) THEN
1777  goto 60
1778  ELSEIF (n.GE.12) THEN
1779  goto 110
1780  ELSE
1781  go to 110
1782  ENDIF
1783  10 CONTINUE
1784  x(1,1)=0
1785  x(2,1)=0
1786  x(3,1)=0
1787  RETURN
1788  20 CONTINUE
1789  eps=rndm(v)
1790  DO 30 i=1,3
1791  IF ((eps.GE.wd(i)).AND.(eps.LE.wd(i+1))) goto 40
1792 
1793  30 CONTINUE
1794  40 CONTINUE
1795  DO 50 j=1,3
1796  CALL rannor(x1,x2)
1797  x(j,1)=rd(i)*x1
1798  x(j,2)=-x(j,1)
1799  50 CONTINUE
1800  RETURN
1801  60 CONTINUE
1802  sigma=r/sqr2
1803  70 CONTINUE
1804  istart=.true.
1805  CALL rannor(x3,x4)
1806  DO 100 i=1,n
1807  CALL rannor(x1,x2)
1808  x(1,i)=sigma*x1
1809  x(2,i)=sigma*x2
1810  IF (istart) goto 80
1811 
1812  x(3,i)=sigma*x4
1813  CALL rannor(x3,x4)
1814  goto 90
1815  80 CONTINUE
1816  x(3,i)=sigma*x3
1817  90 CONTINUE
1818  istart=.NOT.istart
1819  100 CONTINUE
1820  RETURN
1821  110 CONTINUE
1822  rmax=r+4.605*pdif
1823  DO 140 i=1,n
1824  120 CONTINUE
1825  rad=rmax*(rndm(v))**0.3333333
1826  ct=1.-2.*rndm(v)
1827  fi=6.283185d0*rndm(v)
1828  st=sqrt(1.-ct*ct)
1829  x(1,i)=rad*st*cos(fi)
1830  x(2,i)=rad*st*sin(fi)
1831  x(3,i)=rad*ct
1832  rr=sqrt(x(1,i)**2+x(2,i)**2+x(3,i)**2)
1833  IF(jglaub.EQ.2)f=1./(1.+exp((rr-r)/pdif))
1834  IF(jglaub.EQ.1)THEN
1835  IF(n.GE.11.OR.n.LE.18)THEN
1836  rr0=r*r/(2.5d0-4.d0/aan)
1837  f=(1.d0+(aan-4.d0)*rr**2/(6.d0*rr0))*6.d0/(aan-4.d0)
1838  * *exp(-rr**2/rr0+(aan-10.d0)/(aan-4.d0))
1839 C F=(1.D0+(AAN-4.D0)*RR**2/(6.D0*R0**2))
1840 C * *EXP(-RR**2/R0**2)
1841 C PDIF=0.513
1842 C F=(1.D0-0.051D0*RR**2/R**2)/(1.+EXP((RR-R)/PDIF))
1843  ELSEIF(n.GE.9.AND.n.LE.10)THEN
1844  rr0=r*r/(2.5d0-4.d0/aan)
1845  f=(1.d0+(aan-4.d0)*rr**2/(6.d0*rr0))
1846  * *exp(-rr**2/rr0)
1847  ELSE
1848  f=1./(1.+exp((rr-r)/pdif))
1849  ENDIF
1850  ENDIF
1851  IF (rndm(v).GT.f) goto 120
1852 
1853  IF (i.LT.2) goto 140
1854 
1855  i1=i-1
1856  DO 130 i2=1,i1
1857  dist2=(x(1,i)-x(1,i2))**2+(x(2,i)-x(2,i2))**2+(x(3,i)-x(3,i2))
1858  * **2
1859  IF (dist2.LE.r2min) goto 120
1860 
1861  130 CONTINUE
1862  140 CONTINUE
1863  RETURN
1864  END
1865 *-- Author :
1866 C
1867 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1868 C
1869  SUBROUTINE modb(BSITE,N,BSTEP,B)
1870  IMPLICIT DOUBLE PRECISION (a-h,o-z)
1871  SAVE
1872 *KEEP,ZENTRA.
1873  COMMON /zentra/ icentr
1874  COMMON /dshm/ rash,rbsh,bmax,bstap,sigsh,rosh,gsh,
1875  * bsita(0:1,200),nstatb,nsiteb
1876  COMMON /dshms/ sigshs
1877 *KEND.
1878  dimension bsite(0:1,n)
1879  LOGICAL left
1880 C**** BSITE(1)=0. , BSITE(N)=1.
1881 C
1882 C Central collisions for lead-lead
1883 C
1884 C WRITE(6,*)'RASH,RBSH,BMAX,BSTAP,SIGSH,ROSH,GSH,ICENTR,N',
1885 C *RASH,RBSH,BMAX,BSTAP,SIGSH,ROSH,GSH,ICENTR,N
1886  IF (icentr.EQ.1) THEN
1887  IF(rash.EQ.rbsh)THEN
1888  IF(rash.LE.15.d0)THEN
1889  bb=rndm(v)*9.d0
1890  b=sqrt(bb)
1891  RETURN
1892  ELSEIF(rash.GT.5.d0)THEN
1893  bb=rndm(v)*30.d0
1894  b=sqrt(bb)
1895  RETURN
1896  ENDIF
1897  ELSEIF(rash.LT.rbsh)THEN
1898  bb=rndm(v)*(rbsh-rash+3.d0)**2
1899  b=sqrt(bb)
1900  RETURN
1901  ELSEIF(rash.GT.rbsh)THEN
1902  bb=rndm(v)*(rash-rbsh+3.d0)**2
1903  b=sqrt(bb)
1904  RETURN
1905  ENDIF
1906  ENDIF
1907 C
1908  y=rndm(v)
1909  i0=1
1910  i2=n
1911  10 CONTINUE
1912  i1=(i0+i2)/2
1913  left=((bsite(1,i0)-y)*(bsite(1,i1)-y)).LT.0.d0
1914  IF(left) go to 20
1915  i0=i1
1916  go to 30
1917  20 CONTINUE
1918  i2=i1
1919  30 CONTINUE
1920  IF(i2-i0-2)40,50,60
1921  40 CONTINUE
1922  i1=i2+1
1923  IF(i1.GT.n)i1=i0-1
1924  go to 70
1925  50 CONTINUE
1926  i1=i0+1
1927  go to 70
1928  60 CONTINUE
1929  go to 10
1930  70 CONTINUE
1931  x0=(i0-1)*bstep
1932  x1=(i1-1)*bstep
1933  x2=(i2-1)*bstep
1934  y0=bsite(1,i0)
1935  y1=bsite(1,i1)
1936  y2=bsite(1,i2)
1937  80 CONTINUE
1938  b=x0*(y-y1)*(y-y2)/((y0-y1)*(y0-y2)+1.e-9)+ x1*(y-y0)*(y-y2)
1939  +/((y1-y0)*(y1-y2)+1.e-9)+ x2*(y-y0)*(y-y1)/((y2-y0)*(y2-y1)+1.e-9)
1940 **sr 14.4.98
1941  b = b+0.5d0*bstep
1942  IF (b.LT.0.0d0) b = x1
1943  IF (b.GT.bmax) b = bmax
1944 **
1945 
1946  RETURN
1947  END
1948 *-- Author :
1949 C
1950 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1951 C
1952  SUBROUTINE diagr(NA,NB,B,JS,JT,INT,INTA,INTB)
1953  IMPLICIT DOUBLE PRECISION (a-h,o-z)
1954  SAVE
1955 *---
1956 * -sample new impct parameter B
1957 * -sample nucleon configuration for projectile and target
1958 * -sample number of collisions INT, INTA, INTB
1959 *---
1960 *KEEP,INTMX.
1961  parameter(intmx=2488,intmd=252)
1962 *KEEP,SHMAKL.
1963 C INCLUDE (SHMAKL)
1964 * NOTE: INTMX set via INCLUDE(INTMX)
1965  common/shmakl/jssh(intmx),jtsh(intmx),inter1(intmx),inter2(intmx)
1966 *KEEP,DPRIN.
1967  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
1968 *KEEP,DSHM.
1969  COMMON /dshm/ rash,rbsh,bmax,bstep,sigsh,rosh,gsh,
1970  * bsite(0:1,200),nstatb,nsiteb
1971  COMMON /dshms/ sigshs
1972 *KEEP,NUCKOO.
1973  COMMON /nuckoo/ pkoo(3,intmx),tkoo(3,intmx),ppoo(3,intmx),
1974  +tpoo(3,intmx)
1975 *KEEP,DAMP.
1976 C COMPLEX*16 CA,CI
1977  DOUBLE COMPLEX ca,ci
1978  COMMON /damp/ ca,ci,ga
1979 *KEND.
1980  COMMON /kkmatu/kkmato,kkmata,ipoo,ipoa,ipzoo,ipzoa
1981  *,ibproo,ibproa,ireado
1982  COMMON /fluctu/ifluct
1983  COMMON /fluarr/flusi(1000),fluix(1000),fluixx(1000)
1984  parameter(namx=248)
1985  dimension js(namx),jt(namx)
1986 C COMPLEX*16 C
1987  DOUBLE COMPLEX c
1988  DATA icnt/0/
1989  DATA intco/0/
1990 C------------------------------
1991 **sr 14.4.98
1992  CALL modb(bsite,nsiteb,bstep,b)
1993  intco=0
1994 **
1995  DO 10 i=1,na
1996  10 js(i)=0
1997  DO 20 i=1,nb
1998  20 jt(i)=0
1999 C--------
2000  30 int=0
2001  inta=0
2002  intb=0
2003  intco=intco+1
2004  IF(intco.GE.500)THEN
2005  intco=0
2006  CALL modb(bsite,nsiteb,bstep,b)
2007  ENDIF
2008 C--------
2009 C IF (KKMATO.NE.KKMATA.AND.IPOO.NE.IPOA.AND.
2010 C * IBPROO.NE.IBPROA.AND.IPZOO.NE.IPZOA )THEN
2011  CALL conucl(pkoo,na,rash)
2012  CALL sortin(pkoo,na)
2013  CALL conucl(tkoo,nb,rbsh)
2014  CALL sort(tkoo,nb)
2015  kkmato=kkmata
2016  ipoo=ipoa
2017  ipzoo=ipzoa
2018  ibproo=ibproa
2019 C ELSEIF (KKMATO.EQ.KKMATA.AND.IPOO.EQ.IPOA.AND.
2020 C * IPZOO.EQ.IPZOA)THEN
2021 C IF(MOD(ICNT,5).EQ.0) THEN
2022 C CALL CONUCL(PKOO,NA,RASH)
2023 C CALL SORTIN(PKOO,NA)
2024 C CALL CONUCL(TKOO,NB,RBSH)
2025 C CALL SORT(TKOO,NB)
2026 C ENDIF
2027 C ICNT=ICNT+1
2028 C ENDIF
2029 C
2030  IF(ipev.GE.6) WRITE (6,1000)icnt,pkoo(1,1),tkoo(1,1)
2031  1000 FORMAT (' 111 FORM IN DIAGR ICNT,PKOO(1,1),TKOO(1,1) ',i6,2f10.3)
2032 C--------
2033  DO 40 i=1,na
2034  x1=b-pkoo(1,i)
2035  x2=-pkoo(2,i)
2036  IF(ifluct.EQ.0)THEN
2037  afluk=1.
2038  ELSEIF(ifluct.EQ.1)THEN
2039  ifuk=(rndm(v)+0.001)*1000.
2040  afluk=fluixx(ifuk)
2041  ENDIF
2042  DO 40 j=1,nb
2043  q1=x1+tkoo(1,j )
2044  q2=x2+tkoo(2,j )
2045  xy=ga*(q1*q1+q2*q2)
2046  IF(xy.GT.15.d0) go to 40
2047  e=exp(-xy)
2048  c=ci-ca*e*afluk
2049  ar=REAL(REAL(c))
2050  ai=imag(c)
2051  p=ar*ar+ai*ai
2052  IF(rndm(v).LT.p) go to 40
2053  int=int+1
2054  IF(int.GT.intmx) go to 40
2055  js(i)=js(i)+1
2056  jt(j)=jt(j)+1
2057  inter1(int)=i
2058  inter2(int)=j
2059  40 CONTINUE
2060  DO 50 i=1,na
2061  IF (js(i).NE.0) inta=inta+1
2062  50 CONTINUE
2063  DO 60 j=1,nb
2064  IF (jt(j).NE.0) intb=intb+1
2065  60 CONTINUE
2066  IF(ipev.GE.6) THEN
2067  WRITE(6,'(A)')
2068  + ' DIAGR - AFTER 30 CONTINUE: ICNT, INT, B, NA,RA, NB,RB'
2069  WRITE(6,'(I10,I5,1PE11.3,2(I5,1PE11.3))') icnt, int, b, na,rash,
2070  + nb,rbsh
2071  ENDIF
2072  IF(int.EQ.0) go to 30
2073  RETURN
2074  END
2075 C----------------------------------------------------------------
2076  SUBROUTINE fluini
2077  IMPLICIT DOUBLE PRECISION (a-h,o-z)
2078  SAVE
2079 C INITIALIZE THE ARRAY FOR CROSS SECTION FLUCTUATIONS
2080 C
2081  COMMON /fluarr/ flusi(1000),fluix(1000),fluixx(1000)
2082  dx=0.003d0
2083  b=0.893d0
2084  n=6
2085  a=0.1
2086  om=1.1
2087  flusu=0
2088  flusuu=0
2089  DO 1 i=1,1000
2090  x=i*dx
2091  fluix(i)=x
2092  flus=((x-b)/(om*b))**n
2093  IF(flus.LE.20.)THEN
2094  flusi(i)=(x/b)*exp(-((x-b)/(om*b))**n)/(x/b+a)
2095  ELSE
2096  flusi(i)=0.
2097  ENDIF
2098  flusu=flusu+flusi(i)
2099  1 CONTINUE
2100  DO 2 i=1,1000
2101  flusuu=flusuu+flusi(i)/flusu
2102  flusi(i)=flusuu
2103  2 CONTINUE
2104  WRITE(6,3)
2105  3 FORMAT(' FLUCTUATIONS')
2106  CALL plot(fluix,flusi,1000,1,1000,0.d0,0.06d0,0.d0,0.01d0)
2107  DO 5 i=1,1000
2108  af=i*0.001d0
2109  DO 6 j=1,1000
2110  IF(af.LE.flusi(j))THEN
2111  fluixx(i)=fluix(j)
2112  go to 7
2113  ENDIF
2114  6 CONTINUE
2115  7 CONTINUE
2116  5 CONTINUE
2117  fluixx(1)=fluix(1)
2118  fluixx(1000)=fluix(1000)
2119  RETURN
2120  END
2121 *-- Author :
2122 C
2123 C--------------------------------------------------------------------
2124 C
2125 C FILE TECALBAM
2126 C
2127 C
2128 C--------------------------------------------------------------------
2129 c SUBROUTINE TECALB
2130 C SUBROUTINE TECALBAM
2131 C
2132 C------------------------------------------------------------------
2133 C
2134 C DTNTCBI.FOR
2135 C
2136 C------------------------------------------------------------------
2137 C
2138  SUBROUTINE calbam(NNCH,I1,I2,IFB11,IFB22,IFB33,IFB44,
2139  * amch,nobam,ihad)
2140  IMPLICIT DOUBLE PRECISION (a-h,o-z)
2141  SAVE
2142 C
2143 C--------------------------------------------------------------------
2144 C SAMPLING OF Q-AQ, Q-QQ, QQ-AQQ CHAINS
2145 C USING BAMJET(IHAD,IFB1,IFB2,IFB3,IFB4,AMCH,NOBAM)-----FOR NNCH=0
2146 C OR PARJET(IHAD,ICH1=I1 OR I2)------FOR NNCH=-1 OR +1
2147 C-------------------------------------------------------------------
2148 C IHAD : NUMBER OF PRODUCED PARTICLES
2149 C NNCH : CALL BAMJET FOR NNCH=0
2150 C CALL PARJET FOR NNCH=+1 ICH1=I1
2151 C FOR NNCH=-1 ICH1=I2
2152 C jet not existing for NNCH=+/-99, i.e. IHAD=0
2153 C PRODUCED PARTICLES IN CHAIN REST FRAME ARE IN COMMON /FINPAR/
2154 C AMCH : INVARIANT MASS OF CHAIN (BAMJET)
2155 C
2156 C NOBAM : = 3 QUARK-ANTIQUARK JET QUARK FLAVORS : IFB1,IFB2
2157 C OR ANTIQUARK-QUARK JET IN ANY ORDER
2158 C
2159 C = 4 QUARK-DIQUARK JET, FLAVORS : QU : IFB1, DIQU :IFB2,IFB
2160 C OR ANTIQUARK-ANTIDIQUARK JET
2161 C
2162 C
2163 C = 5 DIQUARK-ANTIDIQUARK JET
2164 C OR ANTIDIQUARK-DIQUARK JET
2165 C FLAVORS : DIQU : IFB1,IFB2, ANTIDIQU : IFB3,IFB4
2166 C IN ANY ORDER
2167 C
2168 C = 6 DIQUARK-QUARK JET, FLAVORS : DIQU : IFB1,IFB2 QU: IFB
2169 C OR ANTIDIQUARK-ANTIQUARK JET
2170 C
2171 C = 10 q -- q -- q Jet Capella Kopeliovich
2172 C or aq -- aq -- aq flavors IFB11,IFB22,IFB33
2173 C
2174 C IFBI : FLAVORS : 1,2,3,4 = U,D,S,C 7,8,9,10 = AU,AD,AS,AC
2175 C
2176 C I1,I2 : NUMBER LABEL OF A HADRON CREATED BY PARJET
2177 C
2178 C NORMALLY IN BAMJET THE QUARKS MOVE FORWARD (POSITIVE Z-DIRECTION)
2179 C THE QUARK FLAVORS ARE FIRST GIVEN
2180 C CALBAM ALLOWS EITHER THE QUARK OR ANTIQUARK (DIQU) TO MOVE FORWARD
2181 C THE FORWARD GOING FLAVORS ARE GIVEN FIRST
2182 C
2183 C =====================================================================
2184 *KEEP,DFINPA.
2185  CHARACTER*8 anf
2186  parameter(nfimax=249)
2187  COMMON /dfinpa/ anf(nfimax),pxf(nfimax),pyf(nfimax),pzf(nfimax),
2188  +hef(nfimax),amf(nfimax), ichf(nfimax),ibarf(nfimax),nref(nfimax)
2189  COMMON /dfinpz/iormo(nfimax),idaug1(nfimax),idaug2(nfimax),
2190  * istath(nfimax)
2191 *KEEP,DPRIN.
2192  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
2193  DATA isymm/0/
2194 *KEND.
2195 C---------------------
2196 C IPCO=6
2197 C-------------------------------------------------------------------------------C
2198 C Symmetrize JETSET and BAMJET at small chain masses
2199 C for NOBAM=4 or 6
2200 C
2201 C-------------------------------------------------------------------------------
2202  IF(nobam.EQ.4.AND.isymm.EQ.1)THEN
2203  ifb4=ifb44
2204  IF (amch.LT.3.d0)THEN
2205  rr=rndm(v)
2206  IF (rr.LT.0.33333d0)THEN
2207  ifb1=ifb11
2208  ifb2=ifb22
2209  ifb3=ifb33
2210  ELSEIF (rr.GT.0.666666d0)THEN
2211  ifb1=ifb22
2212  ifb2=ifb11
2213  ifb3=ifb33
2214  ELSE
2215  ifb1=ifb33
2216  ifb2=ifb22
2217  ifb3=ifb11
2218  ENDIF
2219  ELSEIF(amch.GT.7.d0)THEN
2220  ifb1=ifb11
2221  ifb2=ifb22
2222  ifb3=ifb33
2223  ifb4=ifb44
2224  ELSE
2225  ssss=(7.d0-amch)/4.d0
2226  rrr=rndm(vv)
2227  IF(rrr.LT.1.d0-ssss)THEN
2228  ifb1=ifb11
2229  ifb2=ifb22
2230  ifb3=ifb33
2231  ELSE
2232  rr=rndm(v)
2233  IF (rr.LT.0.33333d0)THEN
2234  ifb1=ifb11
2235  ifb2=ifb22
2236  ifb3=ifb33
2237  ELSEIF (rr.GT.0.666666d0)THEN
2238  ifb1=ifb22
2239  ifb2=ifb11
2240  ifb3=ifb33
2241  ELSE
2242  ifb1=ifb33
2243  ifb2=ifb22
2244  ifb3=ifb11
2245  ENDIF
2246  ENDIF
2247  ENDIF
2248  ELSEIF(nobam.EQ.6.AND.isymm.EQ.1)THEN
2249  ifb4=ifb44
2250  IF (amch.LT.3.d0)THEN
2251  rr=rndm(v)
2252  IF (rr.LT.0.33333d0)THEN
2253  ifb1=ifb11
2254  ifb2=ifb22
2255  ifb3=ifb33
2256  ELSEIF (rr.GT.0.666666d0)THEN
2257  ifb3=ifb22
2258  ifb1=ifb11
2259  ifb2=ifb33
2260  ELSE
2261  ifb3=ifb11
2262  ifb2=ifb22
2263  ifb1=ifb33
2264  ENDIF
2265  ELSEIF(amch.GT.7.d0)THEN
2266  ifb1=ifb11
2267  ifb2=ifb22
2268  ifb3=ifb33
2269  ifb4=ifb44
2270  ELSE
2271  ssss=(7.d0-amch)/4.d0
2272  rrr=rndm(vv)
2273  IF(rrr.LT.1.d0-ssss)THEN
2274  ifb1=ifb11
2275  ifb2=ifb22
2276  ifb3=ifb33
2277  ELSE
2278  rr=rndm(v)
2279  IF (rr.LT.0.33333d0)THEN
2280  ifb1=ifb11
2281  ifb2=ifb22
2282  ifb3=ifb33
2283  ELSEIF (rr.GT.0.666666d0)THEN
2284  ifb3=ifb22
2285  ifb1=ifb11
2286  ifb2=ifb33
2287  ELSE
2288  ifb1=ifb33
2289  ifb2=ifb22
2290  ifb3=ifb11
2291  ENDIF
2292  ENDIF
2293  ENDIF
2294  ELSE
2295  ifb1=ifb11
2296  ifb2=ifb22
2297  ifb3=ifb33
2298  ifb4=ifb44
2299  ENDIF
2300 C------------------------------------------------------------------------------
2301  IF(ipco.GE.6)THEN
2302  WRITE (6,1000)nnch,i1,i2,ifb1,ifb2,ifb3,ifb4,amch,nobam,ihad
2303  1000 FORMAT(' CALBAM:NNCH,I1,I2,IFB1,IFB2,IFB3,IFB4,AMCH,NOBAM,IHAD' /7
2304  +i5,f10.3,2i5)
2305  ENDIF
2306  IF(nobam.EQ.10)THEN
2307  CALL dbamje(ihad,ifb1,ifb2,ifb3,ifb4,amch,nobam)
2308  ENDIF
2309  iturn=0
2310  IF (nnch) 10,30,20
2311  10 CONTINUE
2312  IF(nnch.EQ.-99) THEN
2313  ihad=0
2314  RETURN
2315  ENDIF
2316  ich1=i1
2317  go to 50
2318  20 CONTINUE
2319  IF(nnch.EQ.99) THEN
2320  ihad=0
2321  RETURN
2322  ENDIF
2323  ich1=i2
2324  go to 50
2325  30 CONTINUE
2326 C*** ITURN=0 HJM 24/01/91
2327  IF (ifb1.LE.6) go to 40
2328  iturn=1
2329  IF(nobam.EQ.3) CALL dbamje(ihad,ifb2,ifb1,ifb3,ifb4,amch,nobam)
2330  IF(nobam.EQ.4)THEN
2331  iturn=0
2332  CALL dbamje(ihad,ifb1,ifb2,ifb3,ifb4,amch,nobam)
2333  END IF
2334  IF(nobam.EQ.6) CALL dbamje(ihad,ifb3,ifb1,ifb2,ifb4,amch,4)
2335  IF(nobam.EQ.5)THEN
2336  CALL dbamje(ihad,ifb3,ifb4,ifb1,ifb2,amch,nobam)
2337  ENDIF
2338  go to 60
2339  40 CONTINUE
2340 
2341  IF (nobam.EQ.3.OR.nobam.EQ.4.OR.nobam.EQ.5) THEN
2342  CALL dbamje(ihad,ifb1,ifb2,ifb3,ifb4,amch,nobam)
2343  ELSEIF(nobam.EQ.6)THEN
2344  iturn=1
2345  CALL dbamje(ihad,ifb3,ifb1,ifb2,ifb4,amch,4)
2346  END IF
2347  go to 60
2348  50 CONTINUE
2349  CALL dparje(ihad,ich1)
2350  60 CONTINUE
2351 C CALL DECAY(IHAD,2)
2352  70 CONTINUE
2353 C*** TURN CHAINS AROUND IF NESSESARY
2354  IF (iturn.EQ.0) go to 100
2355 C*** TURN JET AROUND
2356  DO 80 i=1,ihad
2357  pzf(i)=-pzf(i)
2358  80 CONTINUE
2359  90 CONTINUE
2360  100 CONTINUE
2361  IF (ipco.GE.6)THEN
2362  DO 1244 i=1,ihad
2363  WRITE(6,1245)i,pzf(i),hef(i),anf(i)
2364  1245 FORMAT(i5,2f10.4,a8)
2365  1244 CONTINUE
2366  ENDIF
2367  RETURN
2368  END
2369 *-- Author :
2370 C
2371 C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2372 C
2373 C
2374  SUBROUTINE dbamje(IHAD,KFA1,KFA2,KFA3,KFA4,AE0,IOPT)
2375  IMPLICIT DOUBLE PRECISION (a-h,o-z)
2376  SAVE
2377 C*****IHAD=NUMBER OF FINAL HADRONS AND HADRON RESONANCES
2378 C*****AE0=INITIAL ENERGY IN GEV
2379 C*****KFA=INITIAL QUARK FLAVOUR
2380 C*****KFD1,KFD2=FLAVOUR CONTENTS OF A INITIAL DIQUARK
2381 C*****IOPT=1,2,3,4 MEANS: SINGLE QUARK JET,SINGLE DIQUARK JET,
2382 C*****COMPLETE QUARK ANTIQUARK TWOJET EVENT,COMPLETE QUARK-DIQUARK TWO
2383 C*****JET EVENT
2384 C*****IOPT=10 q -- q -- q Jet Capella Kopeliovich (only jetset defined)
2385 C*****COMMON/FINPAR/ CONTAINS THE MOMENTA,ENERGIES AND QUANTUM NUMBERS
2386 C*****OF THE CREATED HADRONS
2387 C*****IV IS THE ACTUAL VERTEX,IV=1,4,5,6,9,10 ARE MESON VERTIZES
2388 C*****IV=2,3,7,8 ARE BARYON VERTIZES
2389 C*****LA=1 MEANS CUT-OFF
2390 C*****LL=0,1 MEANS QUARK JET,ANTIQUARK JET(DIQUARK JET,ANTIDIQUARK JET)
2391 C*****COMMON/REMAIN/ CONTAINS REST JET ENERGY,MOMENTA AND QUANTUMNUMBERS
2392 C------------------
2393 *KEEP,DFINPA.
2394  CHARACTER*8 anf
2395  parameter(nfimax=249)
2396  COMMON /dfinpa/ anf(nfimax),pxf(nfimax),pyf(nfimax),pzf(nfimax),
2397  +hef(nfimax),amf(nfimax), ichf(nfimax),ibarf(nfimax),nref(nfimax)
2398  COMMON /dfinpz/iormo(nfimax),idaug1(nfimax),idaug2(nfimax),
2399  * istath(nfimax)
2400 *KEEP,DINPDA.
2401  COMMON /dinpda/ imps(6,6),imve(6,6),ib08(6,21),ib10(6,21), ia08
2402  +(6,21),ia10(6,21), a1,b1,b2,b3,lt,le,bet,as,b8,ame,diq,isu
2403 *KEND.
2404  CHARACTER*8 aname
2405  COMMON /dpar/ aname(210),am(210),ga(210),tau(210),ich(210), ibar
2406  +(210),k1(210),k2(210)
2407  common/dremai/ rpxr,rpyr,rpzr,rer,kr1r,kr2r
2408  COMMON /bamco/ nvdd
2409  common/ifragm/ifrag
2410  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
2411 *--------------------------- S.Roesler 5/27/93
2412  COMMON /diffra/ isingd,idiftp,ioudif,iflagd
2413 *
2414  dimension rpx(100),rpy(100),re(100)
2415  dimension kfr1(100),kfr2(100),iv(100)
2416  parameter(pimass=0.15d0)
2417 C
2418  IF(ipco.GE.6)lt=1
2419 C-------------------------------------------------------------------
2420  IF (lt.EQ.1)WRITE(6, 1000)ihad,kfa1,kfa2,kfa3,kfa4,ae0,iopt
2421  1000 FORMAT (5i5,e12.4,i5,
2422  + ' BAMJET,IHAD,KFA1,KFA2,KFA3,KFA4,AE0,IOPT')
2423 C------------------------------------------------------------------
2424 C
2425 C JETSET-7.3 FRAGMENTATION j.r.6/93
2426 C
2427  IF(iopt.EQ.10)THEN
2428  irej=0
2429  CALL bamlun(ihad,kfa1,kfa2,kfa3,kfa4,ae0,iopt,irej)
2430  IF(irej.EQ.1)THEN
2431  RETURN
2432  ENDIF
2433  RETURN
2434  ENDIF
2435  IF(ifrag.EQ.1.OR.ifrag.EQ.2.OR.ifrag.GE.10)THEN
2436  irej=0
2437  CALL bamlun(ihad,kfa1,kfa2,kfa3,kfa4,ae0,iopt,irej)
2438  IF(irej.EQ.1)THEN
2439  RETURN
2440  ENDIF
2441  RETURN
2442  ENDIF
2443 C_________________________________________________________________
2444  as=0.5
2445  b8=0.4
2446  a1=0.88
2447 *-------------------------- S.Roesler 5/26/93
2448  b1=3.
2449  b2=3.
2450 *
2451  b3=8.0
2452 C BET=9.5
2453  bet=12.0
2454  IF(nvdd.EQ.15) THEN
2455  a1=0.99
2456  b3=2.0
2457  bet=3.
2458  ENDIF
2459 *-------------------------- S.Roesler 5/26/93
2460 * diffractive chains
2461 *
2462  IF(iflagd.EQ.1)THEN
2463  a1=0.88
2464  b1=6.
2465  b2=9.
2466  b3=4.0
2467  ENDIF
2468 *
2469 C
2470  itry = 0
2471  10 CONTINUE
2472 C
2473 C avoid hang ups
2474  itry = itry+1
2475  IF(itry.GT.10000) THEN
2476  WRITE(6,'(/1X,A)') 'DBAMJE:ERROR: FRAGMENTATION IMPOSSIBLE'
2477  WRITE(6,'(1X,A,5I5,E12.3,I5)')
2478  & 'DBAMJE:IHAD,KFA1,KFA2,KFA3,KFA4,AE0,IOPT ',
2479  & ihad,kfa1,kfa2,kfa3,kfa4,ae0,iopt
2480  stop
2481  ENDIF
2482 C
2483  DO 20 i=1,100
2484  kfr1(i)=0
2485  kfr2(i)=0
2486  20 CONTINUE
2487  30 CONTINUE
2488  iyy=0
2489  ihad=0
2490  it=0
2491  e0=ae0/2.
2492 C low mass asymmetric fragmentation (r.e. 12/93)
2493  IF(itry.GT.100) THEN
2494  IF(iopt.EQ.3) THEN
2495  IF(kfa1.GT.(kfa2-6)) THEN
2496  e0=ae0-max(ae0*0.1,pimass)
2497  ELSE
2498  e0=max(ae0*0.1,pimass)
2499  ENDIF
2500  ENDIF
2501  ENDIF
2502 C
2503  IF(iopt.EQ.1.OR.iopt.EQ.2) e0=ae0
2504  ll=0
2505  pgx=0.
2506  IF(kfa1.GT.6.AND.iopt.EQ.1) ll=1
2507  IF(kfa1.LE.6.AND.iopt.EQ.2) ll=1
2508  IF(kfa1.GT.6.AND.iopt.EQ.4) ll=1
2509  pgy=0.
2510  pgz=0.
2511  rpx0=0.
2512  rpy0=0.
2513  DO 130 i=1,100
2514  la=0
2515  it=it+1
2516  j=it-1
2517  40 CONTINUE
2518 C*****CUT OFF TASK
2519 C CALL DABBRC(IT,LL,LA,LT,E0,PGX,PGY,PGZ,KFR1,KFR2,RE, KR1R,KR2R,
2520 C + KR1L,KR2L,RPX,RPY,RPZ,RPXR,RPYR,RPZR,RPXL,RPYL,RPZL, RER,REL,IV,
2521 C + B1,B2,KFA1,KFA2,KFA3,KFA4,IOPT,IYY)
2522  IF(la.EQ.0) goto60
2523  it=it-1
2524  IF(iopt.EQ.3.AND.ll.EQ.0) goto 50
2525  IF(iopt.EQ.4.AND.kfa1.LE.6.AND.ll.EQ.0) goto 50
2526  IF(iopt.EQ.4.AND.kfa1.GT.6.AND.ll.EQ.1) goto 50
2527  IF(iopt.EQ.5.AND.ll.EQ.0) goto 50
2528 C asymmetric fragmentation (r.e. 12/93)
2529  e0 = ae0/2.
2530  goto 140
2531  50 CONTINUE
2532 C asymmetric fragmentation (r.e. 12/93)
2533  e0 = ae0-e0
2534 C
2535  iyy=1
2536  ll=1
2537  IF(iopt.EQ.4.AND.kfa1.GT.6) ll=0
2538  iar=it
2539  goto120
2540  60 CONTINUE
2541 C*****CHOICE OF THE VERTEX
2542 C CALL DVERTE(IT,LT,LL,KFA1,E0,IV,AME,IOPT)
2543 C*****CHOICE OF THE FLAVOUR
2544 C CALL DFLAVO(IT,LT,LL,E0,IV,RE,KFR1,KFR2,ISU,BET,KFA1,KFA2,KFA3,
2545 C + KFA4,IOPT)
2546 C*****CLASSIFICATION OF THEPARTICLES
2547 C CALL DHKLAS(IT,LT,LA,LL,KFR1,KFR2,KR1R,KR2R,KR1L,KR2L,IV,IMPS,
2548 C + IMVE,IB08,IA08,IB10,IA10,AS,B8,KFA1,KFA2,KFA3,KFA4,IOPT)
2549  IF(it.EQ.1)rx=e0
2550  IF(it.GT.1)rx=re(j)
2551  IF(amf(it).GT.rx) goto 10
2552  IF(amf(it).LE.rx) goto 70
2553  la=1
2554  goto40
2555  70 CONTINUE
2556  ihad=ihad+1
2557  IF(lt.EQ.0) goto80
2558  WRITE(6, 1070)ihad
2559  80 CONTINUE
2560 C*****CHOICE OF THE ENERGY
2561 C CALL DENERG(IT,IV,RE,HMA,HE,E0,A1)
2562 C*****CHOICE OF THE MOMENTUM
2563 C CALL IMPULD(HE,HMA,HPS,HPX,HPY,HPZ,LT,LL,B3)
2564  IF(it.GT.1) goto90
2565  rpx(it)=rpx0-hpx
2566  rpy(it)=rpy0-hpy
2567  goto100
2568  90 rpx(it)=rpx(j)-hpx
2569  rpy(it)=rpy(j)-hpy
2570  100 CONTINUE
2571  IF (iopt.EQ.1.AND.ll.EQ.1)hpz=-hpz
2572  IF(iopt.EQ.2.AND.ll.EQ.1) hpz=-hpz
2573  IF(iopt.EQ.4.AND.kfa1.GT.6) hpz=-hpz
2574  IF(iopt.EQ.5) hpz=-hpz
2575  pgx=pgx+hpx
2576  pgy=pgy+hpy
2577  pgz=pgz+hpz
2578  pxf(it)=hpx
2579  pyf(it)=hpy
2580  pzf(it)=hpz
2581  IF(lt.EQ.0) goto110
2582  WRITE(6, 1010)pgx,pgy,pgz
2583  1010 FORMAT(1h0,12hpgx,pgy,pgz=,3f8.4)
2584  110 CONTINUE
2585  120 CONTINUE
2586  130 CONTINUE
2587  140 CONTINUE
2588  IF(iopt.EQ.1.OR.iopt.EQ.2) goto 150
2589 C*****PUT THE RIGHT AND LEFT JET TOGETHER
2590 C CALL DVEREI(IT,LA,LT,RER,REL,RPXR,RPYR,RPZR,RPXL,RPYL,RPZL,
2591 C *KR1R,KR2R,KR1L,KR2L,IHAD,LL,KFR1,KFR2,IMPS,IMVE,IB08,IA08,
2592 C *IB10,IA10,B3,AS,B8,IAR,KFA1,KFA2,KFA3,KFA4,IOPT)
2593  IF(la.EQ.3) goto 10
2594  IF(la.EQ.2) goto 10
2595  150 CONTINUE
2596  IF(iopt.EQ.3.OR.iopt.EQ.4.OR.iopt.EQ.5) goto 160
2597  IF(ll.EQ.0) goto 160
2598  rpxr=rpxl
2599  rpyr=rpyl
2600  rpzr=rpzl
2601  rer=rel
2602  kr1r=kr1l
2603  kr2r=kr2l
2604  160 CONTINUE
2605  IF(le.EQ.0) goto 180
2606  WRITE(6, 1030)
2607  do170 j=1,it
2608  WRITE(6, 1020)nref(j),anf(j),amf(j),ichf(j),
2609  + ibarf(j),pxf(j),pyf(j),
2610  + pzf(j),hef(j)
2611  1020 FORMAT(2x,i3,a6,f6.3,2i4,4f8.4)
2612  1030 FORMAT(2x,'NF,NAME,MASS,IQ,IB,PX,PY,PZ,E')
2613  170 CONTINUE
2614  180 CONTINUE
2615  1040 FORMAT(1h0,38hnumber of events with prest gt. erest=,i4, /,
2616  +21hnumber of all events=,i4)
2617  1050 FORMAT(1h0,'NUMBER OF EVENTS WITH ONLY ONE PARTICLE=',i4)
2618 C*****TEST OF THE CONSERVATION LAWS
2619 C CALL TERHAL(IT,LE,KFA1,KFA2,IOPT)
2620  IF(lt.EQ.0) goto190
2621  WRITE(6, 1060)ihad
2622  1060 FORMAT(1h0,' MULTIPLIZITAET=',i3)
2623  1070 FORMAT(1h0,13hhadronanzahl=,i3)
2624  190 CONTINUE
2625 C IF (IHAD.EQ.2)THEN
2626 C DO 200 I=1,IHAD
2627 C PZF(I)=-PZF(I)
2628 C 200 CONTINUE
2629 C ENDIF
2630 C
2631  RETURN
2632  END
2633 *-- Author :
2634 C
2635 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2636 C
2637  SUBROUTINE indexd(KA,KB,IND)
2638  IMPLICIT DOUBLE PRECISION (a-h,o-z)
2639  SAVE
2640  kp=ka*kb
2641  ks=ka+kb
2642  IF(kp.EQ.1)ind=1
2643  IF(kp.EQ.2)ind=2
2644  IF(kp.EQ.3)ind=3
2645  IF(kp.EQ.4.AND.ks.EQ.5)ind=4
2646  IF(kp.EQ.5)ind=5
2647  IF(kp.EQ.6.AND.ks.EQ.7)ind=6
2648  IF(kp.EQ.4.AND.ks.EQ.4)ind=7
2649  IF(kp.EQ.6.AND.ks.EQ.5)ind=8
2650  IF(kp.EQ.8)ind=9
2651  IF(kp.EQ.10)ind=10
2652  IF(kp.EQ.12.AND.ks.EQ.8)ind=11
2653  IF(kp.EQ.9)ind=12
2654  IF(kp.EQ.12.AND.ks.EQ.7)ind=13
2655  IF(kp.EQ.15)ind=14
2656  IF(kp.EQ.18)ind=15
2657  IF(kp.EQ.16)ind=16
2658  IF(kp.EQ.20)ind=17
2659  IF(kp.EQ.24)ind=18
2660  IF(kp.EQ.25)ind=19
2661  IF(kp.EQ.30)ind=20
2662  IF(kp.EQ.36)ind=21
2663  RETURN
2664  END
2665 *-- Author :
2666 C
2667 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2668 C
2669 C
2670 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2671 C
2672  DOUBLE PRECISION FUNCTION dbeta(X1,X2,BET)
2673  IMPLICIT DOUBLE PRECISION (a-h,o-z)
2674  SAVE
2675  ax=0.0
2676  betx1=bet*x1
2677  IF(betx1.LT.70.) ax=-1./bet**2*(betx1+1.)*exp(-betx1)
2678  ay=1./bet**2*(bet*x2+1.)*exp(-bet*x2)
2679  dbeta=ax+ay
2680  RETURN
2681  END
2682 *-- Author :
2683 C
2684 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2685 C
2686  SUBROUTINE ddrela(X,Y,Z,COTE,SITE,COPS,SIPS)
2687  IMPLICIT DOUBLE PRECISION (a-h,o-z)
2688  SAVE
2689  x1=cops*x-sips*cote*y+sips*site*z
2690  x2=sips*x+cops*cote*y-cops*site*z
2691  x3=site*y+cote*z
2692  x=x1
2693  y=x2
2694  z=x3
2695  RETURN
2696  END
2697 *-- Author :
2698 C
2699 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2700 C
2701 C SUBROUTINE DPOLI(CS,SI)
2702 C IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2703 C SAVE
2704 C U=RNDM(V)
2705 C CS=RNDM(VV)
2706 C IF (U.LT.0.5) CS=-CS
2707 C SI=SQRT(1.-CS*CS+1.E-10)
2708 C RETURN
2709 C END
2710 C SUBROUTINE ALTRAF(GA,BGA,CX,CY,CZ,COD,COF,SIF,PC,EC,P,PX,PY,PZ,E)
2711 C IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2712 C SAVE
2713 C BGX=BGA*CX
2714 C BGY=BGA*CY
2715 C BGZ=BGA*CZ
2716 C COD2=COD*COD
2717 C IF (COD2.GT.0.999999) COD2=0.999999
2718 C SID=SQRT(1.-COD2)*PC
2719 C PCX=SID*COF
2720 C PCY=SID*SIF
2721 C PCZ=COD*PC
2722 C EP=PCX*BGX+PCY*BGY+PCZ*BGZ
2723 C PE=EP/(GA+1.)+EC
2724 C PX=PCX+BGX*PE
2725 C PY=PCY+BGY*PE
2726 C PZ=PCZ+BGZ*PE
2727 C P=SQRT(PX*PX+PY*PY+PZ*PZ)
2728 C PM=1./P
2729 C PX=PX*PM
2730 C PY=PY*PM
2731 C PZ=PZ*PM
2732 C E=GA*EC+EP
2733 C RETURN
2734 C END
2735 C SUBROUTINE ROTAT(PX,PY,PZ,PXN,PYN,PZN,COTE,SITE,COPS,SIPS)
2736 C IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2737 C SAVE
2738 C PXN=-PX*SIPS-PY*COTE*COPS+PZ*SITE*COPS
2739 C PYN=PX*COPS-PY*COTE*SIPS+PZ*SITE*SIPS
2740 C PZN=PY*SITE+PZ*COTE
2741 C RETURN
2742 C END
2743 C
2744 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2745 
2746 *=== threpd ===========================================================*
2747 *
2748  SUBROUTINE dthrep(UMO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,
2749  &sif1,cod2,cof2,sif2,cod3,cof3,sif3,am1,am2,am3)
2750 
2751 *$ CREATE DBLPRC.ADD
2752 *COPY DBLPRC
2753 * *
2754 *=== dblprc ==========================================================*
2755 * *
2756 *---------------------------------------------------------------------*
2757 * *
2758 * Dblprc: included in any routine *
2759 * *
2760 * !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
2761 * !!!! O N M A C H I N E S W H E R E T H E D O U B L E !!!! *
2762 * !!!! P R E C I S I O N I S N O T R E Q U I R E D R E -!!!! *
2763 * !!!! M O V E T H E D O U B L E P R E C I S I O N !!!! *
2764 * !!!! S T A T E M E N T, S E T K A L G N M = 1 A N D !!!! *
2765 * !!!! C H A N G E A L L N U M E R I C A L C O N S - !!!! *
2766 * !!!! T A N T S T O S I N G L E P R E C I S I O N !!!! *
2767 * !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
2768 * *
2769 * Kalgnm = real address alignment, 2 for double precision, *
2770 * 1 for single precision *
2771 * Anglgb = this parameter should be set equal to the machine *
2772 * "zero" with respect to unit *
2773 * Anglsq = this parameter should be set equal to the square *
2774 * of Anglgb *
2775 * Axcssv = this parameter should be set equal to the number *
2776 * for which unity is negligible for the machine *
2777 * accuracy *
2778 * Andrfl = "underflow" of the machine for floating point *
2779 * operation *
2780 * Avrflw = "overflow" of the machine for floating point *
2781 * operation *
2782 * Ainfnt = code "infinite" *
2783 * Azrzrz = code "zero" *
2784 * Einfnt = natural logarithm of the code "infinite" *
2785 * Ezrzrz = natural logarithm of the code "zero" *
2786 * Onemns = 1- of the machine, it is 1 - 2 x Anglgb *
2787 * Onepls = 1+ of the machine, it is 1 + 2 x Anglgb *
2788 * Csnnrm = maximum tolerable error on cosine normalization, *
2789 * u**2+v**2+w**2: assuming a typical anglgb relative *
2790 * error on each component we would get 2xanglgb: use *
2791 * 4xanglgb to avoid too many normalizations *
2792 * Dmxtrn = "infinite" distance for transport (cm) *
2793 * *
2794 *---------------------------------------------------------------------*
2795 * *
2796  IMPLICIT DOUBLE PRECISION (a-h,o-z)
2797  SAVE
2798  parameter( kalgnm = 2 )
2799  parameter( anglgb = 5.0d-16 )
2800  parameter( anglsq = 2.5d-31 )
2801  parameter( axcssv = 0.2d+16 )
2802  parameter( andrfl = 1.0d-38 )
2803  parameter( avrflw = 1.0d+38 )
2804  parameter( ainfnt = 1.0d+30 )
2805  parameter( azrzrz = 1.0d-30 )
2806  parameter( einfnt = +69.07755278982137 d+00 )
2807  parameter( ezrzrz = -69.07755278982137 d+00 )
2808  parameter( onemns = 0.999999999999999 d+00 )
2809  parameter( onepls = 1.000000000000001 d+00 )
2810  parameter( csnnrm = 2.0d-15 )
2811  parameter( dmxtrn = 1.0d+08 )
2812 *
2813 *======================================================================*
2814 *======================================================================*
2815 *========= ==========*
2816 *========= M A T H E M A T I C A L C O N S T A N T S ==========*
2817 *========= ==========*
2818 *======================================================================*
2819 *======================================================================*
2820 * *
2821 * Numerical constants: *
2822 * *
2823 * Zerzer = 0 *
2824 * Oneone = 1 *
2825 * Twotwo = 2 *
2826 * Thrthr = 3 *
2827 * Foufou = 4 *
2828 * Fivfiv = 5 *
2829 * Sixsix = 6 *
2830 * Sevsev = 7 *
2831 * Eigeig = 8 *
2832 * Aninen = 9 *
2833 * Tenten = 10 *
2834 * Hlfhlf = 1/2 *
2835 * Onethi = 1/3 *
2836 * Twothi = 2/3 *
2837 * Pipipi = Circumference / diameter *
2838 * Eneper = "e", base of natural logarithm *
2839 * Sqrent = square root of "e" *
2840 * *
2841 *----------------------------------------------------------------------*
2842 *
2843  parameter( zerzer = 0.d+00 )
2844  parameter( oneone = 1.d+00 )
2845  parameter( twotwo = 2.d+00 )
2846  parameter( thrthr = 3.d+00 )
2847  parameter( foufou = 4.d+00 )
2848  parameter( fivfiv = 5.d+00 )
2849  parameter( sixsix = 6.d+00 )
2850  parameter( sevsev = 7.d+00 )
2851  parameter( eigeig = 8.d+00 )
2852  parameter( aninen = 9.d+00 )
2853  parameter( tenten = 10.d+00 )
2854  parameter( hlfhlf = 0.5d+00 )
2855  parameter( onethi = oneone / thrthr )
2856  parameter( twothi = twotwo / thrthr )
2857  parameter( pipipi = 3.1415926535897932270 d+00 )
2858  parameter( eneper = 2.7182818284590452354 d+00 )
2859  parameter( sqrent = 1.6487212707001281468 d+00 )
2860 *
2861 *======================================================================*
2862 *======================================================================*
2863 *========= ==========*
2864 *========= P H Y S I C A L C O N S T A N T S ==========*
2865 *========= ==========*
2866 *======================================================================*
2867 *======================================================================*
2868 * *
2869 * Primary constants: *
2870 * *
2871 * Clight = speed of light in cm s-1 *
2872 * Avogad = Avogadro number *
2873 * Amelgr = electron mass (g) *
2874 * Plckbr = reduced Planck constant (erg s) *
2875 * Elccgs = elementary charge (CGS unit) *
2876 * Elcmks = elementary charge (MKS unit) *
2877 * Amugrm = Atomic mass unit (g) *
2878 * Ammumu = Muon mass (amu) *
2879 * *
2880 * Derived constants: *
2881 * *
2882 * Alpfsc = Fine structure constant = e^2/(hbar c) *
2883 * Amelct = Electron mass (GeV) = 10^-16Amelgr Clight^2 / Elcmks*
2884 * Amugev = Atomic mass unit (GeV) = 10^-16Amelgr Clight^2 *
2885 * / Elcmks *
2886 * Ammuon = Muon mass (GeV) = Ammumu * Amugev *
2887 * Fscto2 = (Fine structure constant)^2 *
2888 * Fscto3 = (Fine structure constant)^3 *
2889 * Fscto4 = (Fine structure constant)^4 *
2890 * Plabrc = Reduced Planck constant times the light velocity *
2891 * expressed in GeV fm *
2892 * Rclsel = Classical electron radius (cm) = e^2 / (m_e c^2) *
2893 * Conversion constants: *
2894 * GeVMeV = from GeV to MeV *
2895 * eMVGeV = from MeV to GeV *
2896 * Raddeg = from radians to degrees *
2897 * Degrad = from degrees to radians *
2898 * *
2899 *----------------------------------------------------------------------*
2900 *
2901  parameter( clight = 2.99792458 d+10 )
2902  parameter( avogad = 6.0221367 d+23 )
2903  parameter( amelgr = 9.1093897 d-28 )
2904  parameter( plckbr = 1.05457266 d-27 )
2905  parameter( elccgs = 4.8032068 d-10 )
2906  parameter( elcmks = 1.60217733 d-19 )
2907  parameter( amugrm = 1.6605402 d-24 )
2908  parameter( ammumu = 0.113428913 d+00 )
2909 * PARAMETER ( ALPFSC = 1.D+00 / 137.035989561D+00 )
2910 * PARAMETER ( FSCTO2 = ALPFSC * ALPFSC )
2911 * PARAMETER ( FSCTO3 = FSCTO2 * ALPFSC )
2912 * PARAMETER ( FSCTO4 = FSCTO3 * ALPFSC )
2913 * It is important to set the electron mass exactly with the same
2914 * rounding as in the mass tables, so use the explicit expression
2915 * PARAMETER ( AMELCT = 1.D-16 * AMELGR * CLIGHT * CLIGHT / ELCMKS )
2916 * It is important to set the amu mass exactly with the same
2917 * rounding as in the mass tables, so use the explicit expression
2918 * PARAMETER ( AMUGEV = 1.D-16 * AMUGRM * CLIGHT * CLIGHT / ELCMKS )
2919 * It is important to set the muon mass exactly with the same
2920 * rounding as in the mass tables, so use the explicit expression
2921 * PARAMETER ( AMMUON = AMMUMU * AMUGEV ELCMKS )
2922 * PARAMETER ( RCLSEL = ELCCGS * ELCCGS / CLIGHT / CLIGHT / AMELGR )
2923  parameter( alpfsc = 7.2973530791728595 d-03 )
2924  parameter( fscto2 = 5.3251361962113614 d-05 )
2925  parameter( fscto3 = 3.8859399018437826 d-07 )
2926  parameter( fscto4 = 2.8357075508200407 d-09 )
2927  parameter( plabrc = 0.197327053 d+00 )
2928  parameter( amelct = 0.51099906 d-03 )
2929  parameter( amugev = 0.93149432 d+00 )
2930  parameter( ammuon = 0.105658389 d+00 )
2931  parameter( rclsel = 2.8179409183694872 d-13 )
2932  parameter( gevmev = 1.0 d+03 )
2933  parameter( emvgev = 1.0 d-03 )
2934  parameter( raddeg = 180.d+00 / pipipi )
2935  parameter( degrad = pipipi / 180.d+00 )
2936 
2937 *$ CREATE IOUNIT.ADD
2938 *COPY IOUNIT
2939 * *
2940 *=== iounit ==========================================================*
2941 * *
2942 *---------------------------------------------------------------------*
2943 * *
2944 * Iounit: included in any routine *
2945 * *
2946 * lunin = standard input unit *
2947 * lunout = standard output unit *
2948 * lunerr = standard error unit *
2949 * lunber = input file for bertini nuclear data *
2950 * lunech = echo file for pegs dat *
2951 * lunflu = input file for photoelectric edges and X-ray fluo- *
2952 * rescence data *
2953 * lungeo = scratch file for combinatorial geometry *
2954 * lunpgs = input file for pegs material data *
2955 * lunran = output file for the final random number seed *
2956 * lunxsc = input file for low energy neutron cross sections *
2957 * lunrdb = unit number for reading (extra) auxiliary external *
2958 * files to be closed just after reading *
2959 * *
2960 *---------------------------------------------------------------------*
2961 * *
2962  parameter( lunin = 5 )
2963  parameter( lunout = 6 )
2964  parameter( lunerr = 66 )
2965  parameter( lunber = 14 )
2966  parameter( lunech = 8 )
2967  parameter( lunflu = 86 )
2968  parameter( lungeo = 16 )
2969  parameter( lunpgs = 12 )
2970  parameter( lunran = 2 )
2971  parameter( lunxsc = 81 )
2972  parameter( lunrdb = 1 )
2973 
2974 *$ CREATE DIMPAR.ADD
2975 *COPY DIMPAR
2976 * *
2977 *=== dimpar ==========================================================*
2978 * *
2979 *---------------------------------------------------------------------*
2980 * *
2981 * DIMPAR: included in any routine *
2982 * *
2983 * Mxxrgn = maximum number of regions *
2984 * Mxxmdf = maximum number of media in Fluka *
2985 * Mxxmde = maximum number of media in Emf *
2986 * Mfstck = stack dimension in Fluka *
2987 * Mestck = stack dimension in Emf *
2988 * Nallwp = number of allowed particles *
2989 * Mpdpdx = number of particle types for which EM dE/dx pro- *
2990 * cesses (ion,pair,bremss) have to be computed *
2991 * Icomax = maximum number of materials for compounds (equal *
2992 * to the sum of the number of materials for every *
2993 * compound ) *
2994 * Nstbis = number of stable isotopes recorded in common iso- *
2995 * top *
2996 * Idmaxp = number of particles/resonances defined in common *
2997 * part *
2998 * *
2999 *---------------------------------------------------------------------*
3000 * *
3001  parameter( mxxrgn = 500 )
3002  parameter( mxxmdf = 56 )
3003  parameter( mxxmde = 50 )
3004  parameter( mfstck = 1000 )
3005  parameter( mestck = 100 )
3006  parameter( nallwp = 39 )
3007  parameter( mpdpdx = 8 )
3008  parameter( icomax = 180 )
3009  parameter( nstbis = 304 )
3010  parameter( idmaxp = 210 )
3011 *----------------------------------------------------------------------*
3012 * Threpd89: slight revision by A. Ferrari *
3013 * Last change on 11-oct-93 by Alfredo Ferrari, INFN - Milan *
3014 *----------------------------------------------------------------------*
3015 *
3016  dimension f(5),xx(5)
3017 C***THREE PARTICLE DECAY IN THE CM - SYSTEM
3018  COMMON /dgamre/ redu,amo,amm(15 )
3019  common/ddrei/uumo,aam1,aam2,aam3,s22,umo2,
3020  *am11,am22,am33,s2sup,s2sap(2)
3021 C COMMON/PRUNT/ISYS
3022  common/pritt/isys
3023  SAVE eps
3024  DATA eps/azrzrz/
3025 *
3026  umoo=umo+umo
3027 C***S1, S2, S3 ARE THE INVARIANT MASSES OF THE PARTICLES 1, 2, 3
3028 C***J. VON NEUMANN - RANDOM - SELECTION OF S2
3029 C***CALCULATION OF THE MAXIMUM OF THE S2 - DISTRIBUTION
3030  uumo=umo
3031  aam1=am1
3032  aam2=am2
3033  aam3=am3
3034  gu=(am2+am3)**2
3035  go=(umo-am1)**2
3036 * UFAK=1.0000000000001D0
3037 * IF (GU.GT.GO) UFAK=0.9999999999999D0
3038  IF (gu.GT.go) THEN
3039  ufak=onemns
3040  ELSE
3041  ufak=onepls
3042  END IF
3043  ofak=2.d0-ufak
3044  gu=gu*ufak
3045  go=go*ofak
3046  ds2=(go-gu)/99.d0
3047  am11=am1*am1
3048  am22=am2*am2
3049  am33=am3*am3
3050  umo2=umo*umo
3051  rho2=0.d0
3052  s22=gu
3053  DO 124 i=1,100
3054  s21=s22
3055  s22=gu+(i-1.d0)*ds2
3056  rho1=rho2
3057  rho2=dxlamb(s22,umo2,am11)*dxlamb(s22,am22,am33)/
3058  * (s22+eps)
3059  IF(rho2.LT.rho1) go to 125
3060  124 CONTINUE
3061  125 s2sup=(s22-s21)*.5d0+s21
3062  suprho=dxlamb(s2sup,umo2,am11)*dxlamb(s2sup,am22,am33)/
3063  * (s2sup+eps)
3064  suprho=suprho*1.05d0
3065  xo=s21-ds2
3066  IF (gu.LT.go.AND.xo.LT.gu) xo=gu
3067  IF (gu.GT.go.AND.xo.GT.gu) xo=gu
3068  xx(1)=xo
3069  xx(3)=s22
3070  x1=(xo+s22)*0.5d0
3071  xx(2)=x1
3072  f(3)=rho2
3073  f(1)=dxlamb(xo,umo2,am11)*dxlamb(xo,am22,am33)/(xo+eps)
3074  f(2)=dxlamb(x1,umo2,am11)*dxlamb(x1,am22,am33)/(x1+eps)
3075  DO 126 i=1,16
3076  x4=(xx(1)+xx(2))*0.5d0
3077  x5=(xx(2)+xx(3))*0.5d0
3078  f(4)=dxlamb(x4,umo2,am11)*dxlamb(x4,am22,am33)/
3079  * (x4+eps)
3080  f(5)=dxlamb(x5,umo2,am11)*dxlamb(x5,am22,am33)/
3081  * (x5+eps)
3082  xx(4)=x4
3083  xx(5)=x5
3084  DO 128 ii=1,5
3085  ia=ii
3086  DO 128 iii=ia,5
3087  IF (f(ii).GE.f(iii)) go to 128
3088  fh=f(ii)
3089  f(ii)=f(iii)
3090  f(iii)=fh
3091  fh=xx(ii)
3092  xx(ii)=xx(iii)
3093  xx(iii)=fh
3094 128 CONTINUE
3095  suprho=f(1)
3096  s2sup=xx(1)
3097  DO 129 ii=1,3
3098  ia=ii
3099  DO 129 iii=ia,3
3100  IF (xx(ii).GE.xx(iii)) go to 129
3101  fh=f(ii)
3102  f(ii)=f(iii)
3103  f(iii)=fh
3104  fh=xx(ii)
3105  xx(ii)=xx(iii)
3106  xx(iii)=fh
3107 129 CONTINUE
3108 126 CONTINUE
3109  am23=(am2+am3)**2
3110  ith=0
3111  redu=2.d0
3112  1 CONTINUE
3113  ith=ith+1
3114  IF (ith.GT.200) redu=-9.d0
3115  IF (ith.GT.200) go to 400
3116  c=rndm(c)
3117 * S2=AM23+C*((UMO-AM1)**2-AM23)
3118  s2=am23+c*(umo-am1-am2-am3)*(umo-am1+am2+am3)
3119  y=rndm(y)
3120  y=y*suprho
3121  rho=dxlamb(s2,umo2,am11)*dxlamb(s2,am22,am33)/s2
3122  IF(y.GT.rho) go to 1
3123 C***RANDOM SELECTION OF S3 AND CALCULATION OF S1
3124  s1=rndm(s1)
3125  s1=s1*rho+am11+am22-(s2-umo2+am11)*(s2+am22-am33)/(2.d0*s2)-
3126  &rho*.5d0
3127  s3=umo2+am11+am22+am33-s1-s2
3128  ecm1=(umo2+am11-s2)/umoo
3129  ecm2=(umo2+am22-s3)/umoo
3130  ecm3=(umo2+am33-s1)/umoo
3131  pcm1=sqrt((ecm1+am1)*(ecm1-am1))
3132  pcm2=sqrt((ecm2+am2)*(ecm2-am2))
3133  pcm3=sqrt((ecm3+am3)*(ecm3-am3))
3134  CALL dsfecf(sfe,cfe)
3135 C***TH IS THE ANGLE BETWEEN PARTICLES 1 AND 2
3136 C***TH1, TH2 ARE THE ANGLES BETWEEN PARTICLES 1, 2 AND THE DIRECTION OF
3137  pcm12 = pcm1 * pcm2
3138  IF ( pcm12 .LT. anglsq ) go to 200
3139  costh=(ecm1*ecm2+0.5d+00*(am11+am22-s1))/pcm12
3140  go to 300
3141  200 CONTINUE
3142  uw=rndm(uw)
3143  costh=(uw-0.5d+00)*2.d+00
3144  300 CONTINUE
3145 * IF(ABS(COSTH).GT.0.9999999999999999D0)
3146 * &COSTH=SIGN(0.9999999999999999D0,COSTH)
3147  IF(abs(costh).GT.oneone)
3148  &costh=sign(oneone,costh)
3149  IF (redu.LT.1.d+00) RETURN
3150  costh2=(pcm3*pcm3+pcm2*pcm2-pcm1*pcm1)/(2.d+00*pcm2*pcm3)
3151 * IF(ABS(COSTH2).GT.0.9999999999999999D0)
3152 * &COSTH2=SIGN(0.9999999999999999D0,COSTH2)
3153  IF(abs(costh2).GT.oneone)
3154  &costh2=sign(oneone,costh2)
3155  sinth2=sqrt((oneone-costh2)*(oneone+costh2))
3156  sinth =sqrt((oneone-costh)*(oneone+costh))
3157  sinth1=costh2*sinth-costh*sinth2
3158  costh1=costh*costh2+sinth2*sinth
3159 C***RANDOM SELECTION OF THE SPHERICAL COORDINATES OF THE DIRECTION OF PA
3160 C***CFE, SFE ARE COS AND SIN OF THE ROTATION ANGLE OF THE SYSTEM 1, 2 AR
3161 C***THE DIRECTION OF PARTICLE 3
3162 C***CALCULATION OF THE SPHERICAL COORDINATES OF PARTICLES 1, 2
3163  cx11=-costh1
3164  cy11=sinth1*cfe
3165  cz11=sinth1*sfe
3166  cx22=-costh2
3167  cy22=-sinth2*cfe
3168  cz22=-sinth2*sfe
3169  CALL dsfecf(sif3,cof3)
3170  cod3=twotwo*rndm(cod3)-oneone
3171  sid3=sqrt((1.d+00-cod3)*(1.d+00+cod3))
3172  2 FORMAT(5f20.15)
3173  cod1=cx11*cod3+cz11*sid3
3174  chlp=(oneone-cod1)*(oneone+cod1)
3175  IF(chlp.LT.1.d-14)WRITE(isys,2)cod1,cof3,sid3,
3176  &cx11,cz11
3177  sid1=sqrt(chlp)
3178  cof1=(cx11*sid3*cof3-cy11*sif3-cz11*cod3*cof3)/sid1
3179  sif1=(cx11*sid3*sif3+cy11*cof3-cz11*cod3*sif3)/sid1
3180  cod2=cx22*cod3+cz22*sid3
3181  sid2=sqrt((oneone-cod2)*(oneone+cod2))
3182  cof2=(cx22*sid3*cof3-cy22*sif3-cz22*cod3*cof3)/sid2
3183  sif2=(cx22*sid3*sif3+cy22*cof3-cz22*cod3*sif3)/sid2
3184  400 CONTINUE
3185 * === Energy conservation check: === *
3186  eochck = umo - ecm1 - ecm2 - ecm3
3187 * SID1 = SQRT ( ( ONEONE - COD1 ) * ( ONEONE + COD1 ) )
3188 * SID2 = SQRT ( ( ONEONE - COD2 ) * ( ONEONE + COD2 ) )
3189 * SID3 = SQRT ( ( ONEONE - COD3 ) * ( ONEONE + COD3 ) )
3190  pzchck = pcm1 * cod1 + pcm2 * cod2 + pcm3 * cod3
3191  pxchck = pcm1 * cof1 * sid1 + pcm2 * cof2 * sid2
3192  & + pcm3 * cof3 * sid3
3193  pychck = pcm1 * sif1 * sid1 + pcm2 * sif2 * sid2
3194  & + pcm3 * sif3 * sid3
3195  eocmpr = 1.d-12 * umo
3196  IF ( abs(eochck) + abs(pxchck) + abs(pychck) + abs(pzchck)
3197  & .GT. eocmpr ) THEN
3198  WRITE(lunerr,*)
3199  & ' *** Threpd: energy/momentum conservation failure! ***',
3200  & eochck,pxchck,pychck,pzchck
3201  WRITE(lunerr,*)' *** SID1,SID2,SID3',sid1,sid2,sid3
3202  END IF
3203  RETURN
3204  END
3205 *=== xlamb ============================================================*
3206 *
3207  DOUBLE PRECISION FUNCTION dxlamb(X,Y,Z)
3208  IMPLICIT DOUBLE PRECISION (a-h,o-z)
3209  SAVE
3210  DATA idgb/0/
3211  COMMON /dgamre/ redu,amo,amm(15 )
3212  common/ddrei/test(12)
3213  yz=y-z
3214  dxlamb=x*x-2.d0*x*(y+z)+yz*yz
3215  xlam =dxlamb
3216  IF (idgb.LE.0) go to 11
3217  IF(dxlamb.GT.1.d-12) goto 11
3218  WRITE(6,12)
3219  WRITE(6,10) xlam,x,y,z,test
3220  WRITE(6,13)
3221  12 FORMAT(/,10x,' DXLAMB PRINT')
3222  13 FORMAT(10x,60(1h*))
3223  10 FORMAT(4e20.8,'DXLAMB',/,12f10.5)
3224  11 CONTINUE
3225  IF(dxlamb.LE.0.d0)dxlamb=abs(dxlamb)
3226  dxlamb=sqrt(dxlamb)
3227  RETURN
3228  END
3229 
3230 *-- Author :
3231 C DOUBLE PRECISION FUNCTION DXLAMB(X,Y,Z)
3232 C IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3233 C SAVE
3234 C YZ=Y-Z
3235 C DXLAMB=X*X-2.*X*(Y+Z)+YZ*YZ
3236 C IF(DXLAMB.LE.0.)DXLAMB=ABS(DXLAMB)
3237 C DXLAMB=SQRT(DXLAMB)
3238 C RETURN
3239 C END
3240 *-- Author :
3241 C
3242 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3243 C
3244  SUBROUTINE strafo(GAM,BGAM,CX,CY,CZ,COD,COF,SIF,P,ECM,
3245  1pl,cxl,cyl,czl,el)
3246  IMPLICIT DOUBLE PRECISION (a-h,o-z)
3247  SAVE
3248 C LORENTZ TRANSFORMATION INTO THE LAB - SYSTEM
3249  sid=sqrt((1.-cod)*(1.+cod)+1.e-22)
3250  sif=sqrt((1.-cof)*(1.+cof)+1.e-22)
3251  plx=p*sid*cof
3252  ply=p*sid*sif
3253  pcmz=p*cod
3254  plz=gam*pcmz+bgam*ecm
3255  pl=sqrt(plx*plx+ply*ply+plz*plz)
3256  el=gam*ecm+bgam*pcmz
3257 C ROTATION INTO THE ORIGINAL DIRECTION
3258  coz=plz/pl
3259  IF(coz.GE.1.)coz=0.999999999999
3260  siz=sqrt((1.-coz)*(1.+coz))
3261  CALL drtran(cx,cy,cz,coz,siz,sif,cof,cxl,cyl,czl)
3262  RETURN
3263  END
3264 *-- Author :
3265  SUBROUTINE drtran(XO,YO,ZO,CDE,SDE,SFE,CFE,X,Y,Z)
3266  IMPLICIT DOUBLE PRECISION (a-h,o-z)
3267  SAVE
3268  IF (abs(xo)-0.0001) 10,10,30
3269  10 IF (abs(yo)-0.0001) 20,20,30
3270  20 CONTINUE
3271  x=sde*cfe
3272  y=sde*sfe
3273  z=cde*zo
3274  RETURN
3275  30 CONTINUE
3276  xi=sde*cfe
3277  yi=sde*sfe
3278  zi=cde
3279  a=sqrt(xo**2+yo**2)
3280  x=-yo*xi/a-zo*xo*yi/a+xo*zi
3281  y=xo*xi/a-zo*yo*yi/a+yo*zi
3282  z=a*yi+zo*zi
3283  RETURN
3284  END
3285 *-- Author :
3286 C
3287 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3288 C
3289  SUBROUTINE dchant
3290  IMPLICIT DOUBLE PRECISION (a-h,o-z)
3291  SAVE
3292  CHARACTER*8 zkname
3293 C COMMON/DDECAC/ ZKNAME(540),NZK(540,3),WT(540)
3294 
3295  parameter(idmax9=602)
3296 C CHARACTER*8 ZKNAME
3297  common/ddecac/ zkname(idmax9),wt(idmax9),nzk(idmax9,3)
3298 
3299 
3300  CHARACTER*8 aname
3301  common/dpar/aname(210),am(210),ga(210),tau(210),ich(210),ibar(210)
3302  *,k1(210),k2(210)
3303  dimension hwt(602)
3304 C CHANGE OF WEIGHTS WT FROM ABSOLUT VALUES INTO THE SUM OF WT OF A DEC.
3305  DO 10 j=1,602
3306  10 hwt(j)=0.
3307  DO 30 i=1,210
3308  ik1=k1(i)
3309  ik2=k2(i)
3310  hv=0.
3311  DO 20 j=ik1,ik2
3312  hv=hv+wt(j)
3313  hwt(j)=hv
3314 C IF(HWT(J).GT.1.) WRITE(6,1000) HWT(J),J,I,IK1
3315  20 CONTINUE
3316 C1000 FORMAT(2X,15H ERROR IN HWT =,1F10.5,8H J,I,K1=,3I5)
3317  30 CONTINUE
3318  DO 40 j=1,602
3319  40 wt(j)=hwt(j)
3320  RETURN
3321  END
3322 *-- Author :
3323 C
3324 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3325 C
3326  SUBROUTINE dtwopd(UMO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1, COD2,
3327  +cof2,sif2,am1,am2)
3328  IMPLICIT DOUBLE PRECISION (a-h,o-z)
3329  SAVE
3330 C*****TWO PARTICLE DECAY IN THE CM - SYSTEM
3331 C
3332  IF(umo.LT.(am1+am2)) THEN
3333  WRITE(6,'(/,A/A,3(1PE12.4))')
3334  + ' INCONSISTENT CALL OF TWOPAD / EXECUTION STOPPED',
3335  + ' UMO, AM1, AM2 :', umo, am1, am2
3336  stop
3337  ENDIF
3338 C
3339  ecm1=((umo-am2)*(umo+am2) + am1*am1)/(2.*umo)
3340  ecm2=umo-ecm1
3341  pcm1=sqrt((ecm1-am1)*(ecm1+am1))
3342  pcm2=pcm1
3343  CALL dsfecf(sif1,cof1)
3344  cod1=2.*rndm(x)-1.
3345  cod2=-cod1
3346  cof2=-cof1
3347  sif2=-sif1
3348  RETURN
3349  END
3350 *-- Author :
3351 C
3352 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3353 C
3354  SUBROUTINE dsfecf(SFE,CFE)
3355  IMPLICIT DOUBLE PRECISION (a-h,o-z)
3356  SAVE
3357  10 x=rndm(v)
3358  y=rndm(v)
3359  xx=x*x
3360  yy=y*y
3361  xy=xx+yy
3362  IF(xy.GT.1) goto10
3363  cfe=(xx-yy)/xy
3364  sfe=2.*x*y/xy
3365  IF(rndm(v).LT.0.5d0) goto20
3366  RETURN
3367  20 sfe=-sfe
3368  RETURN
3369  END
3370 *-- Author :
3371 C
3372 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3373 C
3374  SUBROUTINE ddates
3375  IMPLICIT DOUBLE PRECISION (a-h,o-z)
3376  SAVE
3377  CHARACTER*8 zkname,z
3378 C COMMON /DDECAC/ ZKNAME(540),NZK(540,3),WT(540)
3379 
3380  parameter(idmax9=602)
3381 C CHARACTER*8 ZKNAME
3382  common/ddecac/ zkname(idmax9),wt(idmax9),nzk(idmax9,3)
3383 
3384 
3385  CHARACTER*8 aname
3386  COMMON /dpar/ aname(210),am(210),ga(210),tau(210), ich(210),ibar
3387  +(210),k1(210),k2(210)
3388 C----------------------
3389  dimension ichar(210)
3390  equivalence(ich(1),ichar(1))
3391  dimension z(3)
3392 C---------------------------
3393  WRITE(6, 1000)
3394  1000 FORMAT(1h1,' ')
3395  WRITE(6, 1010)
3396  1010 FORMAT(///' TABLE OF USED PARTICLES AND RESONANCES (I)',//
3397  +' I = NUMBER OF PARTICLE OR RESONANCE',/
3398  +' IPDG = P D G NUMBER OF PARTICLE OR RESONANCE',/
3399  +' ANAME = NAME OF I'/, ' AM = MASS OF I (GEV)',/
3400  +' GA = WIDTH OF I (GEV)',/ ' TAU = LIFE TIME OF I (SEC.)',/
3401  +' ICH = ELECTRIC CHARGE OF I, IBAR = BARYONIC CHARGE OF I',/' ', '
3402  +K1 = FIRST DECAY CHANNEL NUMBER, K2 = LAST DECAY CHANNEL NUMBER OF
3403  +I')
3404 
3405 
3406  WRITE(6, 1020)
3407  1020 FORMAT(///
3408  +' I ANAME AM GA TAU ICH IBAR K1 K2'/)
3409  joo=210
3410  DO 10 i=1,joo
3411  ipdg=mpdgha(i)
3412  WRITE(6, 1030)i,ipdg,aname(i),am(i),
3413  + ga(i),tau(i),ich(i),ibar(i), k1
3414  + (i),k2(i)
3415  1030 FORMAT (1i4,i6,2x,1a8,3e11.4,4i4)
3416  IF(i.EQ.43) WRITE(6, 1000)
3417  IF(i.EQ.43) WRITE(6, 1020)
3418  IF(i.EQ.99) WRITE(6, 1000)
3419  IF(i.EQ.99) WRITE(6, 1020)
3420  IF(i.EQ.155) WRITE(6, 1000)
3421  IF(i.EQ.155) WRITE(6, 1020)
3422  10 CONTINUE
3423  WRITE(6, 1000)
3424  WRITE(6, 1040)
3425  1040 FORMAT(///' DECAY CHANNELS OF PARTICLES AND RESONANCES',//)
3426  WRITE(6, 1050)
3427  1050 FORMAT(' ANAME = PARTICLE AND RESONANCE NAME'/,
3428  +' DNAME = DECAY CHANNEL NAME'/, ' J = DECAY CHANNEL NUMBER'/,
3429  +' I = NUMBER OF DECAYING PARTICLE'/,
3430  +' WT = SUM OF DECAY CHANNEL WEIGHTS FROM K1(I) UP TO J'/,
3431  +' NZK = PROGRAM INTERNAL NUMBERS OF DECAY PRODUCTS')
3432 
3433  WRITE(6, 1060)
3434  1060 FORMAT(///' I J ANAME DNAME DECAY
3435  +PRODUCTS WT NZK'/)
3436  DO 60 i=1,joo
3437  ik1=k1(i)
3438  ik2=k2(i)
3439  IF (ik1.LE.0) go to 60
3440  DO 50 ik=ik1,ik2
3441  i1=nzk(ik,1)
3442  i2=nzk(ik,2)
3443  i3=nzk(ik,3)
3444  IF (i1.LE.0) i1=29
3445  IF (i2.LE.0) i2=29
3446  IF (i3.LE.0) i3=29
3447  j1=i1
3448  j2=i2
3449  j3=i3
3450  z(1)=aname(i1)
3451  z(2)=aname(i2)
3452  z(3)=aname(i3)
3453  WRITE(6, 1070)i,ik,aname(i),zkname(ik),(z(j),j=1,3),wt(ik),j1,j2,
3454  + j3
3455  1070 FORMAT(2i5,' DECAY OF ',1a8,' (CHANNEL: ',1a6,' ) TO ',3(1a6,2x),
3456  +1f8.4,3i5)
3457  amtest=am(i)-am(j1)-am(j2)-am(j3)
3458  ibtest=ibar(i)-ibar(j1)-ibar(j2)-ibar(j3)
3459  ictest=ichar(i)-ichar(j1)-ichar(j2)-ichar(j3)
3460  IF (amtest) 20,30,30
3461  20 mtest=1
3462  go to 40
3463  30 mtest=0
3464  40 CONTINUE
3465  IF (mtest+ibtest**2+ictest**2.NE.0) WRITE(6, 1080)amtest,
3466  + ibtest,
3467  + ictest
3468  1080 FORMAT (' ***** ERROR IN MASS, BAR.CH. OR E.CH. ',f10.5,2i6)
3469  IF(ik.EQ.27) WRITE(6, 1000)
3470  IF(ik.EQ.27) WRITE(6, 1060)
3471  IF(ik.EQ.62) WRITE(6, 1000)
3472  IF(ik.EQ.62) WRITE(6, 1060)
3473  IF(ik.EQ.101) WRITE(6, 1000)
3474  IF(ik.EQ.101) WRITE(6, 1060)
3475  IF(ik.EQ.144) WRITE(6, 1000)
3476  IF(ik.EQ.144) WRITE(6, 1060)
3477  IF(ik.EQ.183) WRITE(6, 1000)
3478  IF(ik.EQ.183) WRITE(6, 1060)
3479  IF(ik.EQ.222) WRITE(6, 1000)
3480  IF(ik.EQ.222) WRITE(6, 1060)
3481  IF(ik.EQ.261) WRITE(6, 1000)
3482  IF(ik.EQ.261) WRITE(6, 1060)
3483  IF(ik.EQ.300) WRITE(6, 1000)
3484  IF(ik.EQ.300) WRITE(6, 1060)
3485  IF(ik.EQ.362) WRITE(6, 1000)
3486  IF(ik.EQ.362) WRITE(6, 1060)
3487  IF(ik.EQ.401) WRITE(6, 1000)
3488  IF(ik.EQ.401) WRITE(6, 1060)
3489  IF(ik.EQ.440) WRITE(6, 1000)
3490  IF(ik.EQ.440) WRITE(6, 1060)
3491  IF(ik.EQ.479) WRITE(6, 1000)
3492  IF(ik.EQ.479) WRITE(6, 1060)
3493  IF(ik.EQ.518) WRITE(6, 1000)
3494  IF(ik.EQ.518) WRITE(6, 1060)
3495  50 CONTINUE
3496  60 CONTINUE
3497  RETURN
3498  END
3499 *-- Author :
3500 C
3501 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3502 C
3503  SUBROUTINE ddatar
3504  IMPLICIT DOUBLE PRECISION (a-h,o-z)
3505  SAVE
3506  common/dinpda/imps(6,6),imve(6,6),ib08(6,21),ib10(6,21),
3507  *ia08(6,21),ia10(6,21),a1,b1,b2,b3,lt,lb,bet,as,b8,ame,diq,isu
3508  dimension iv(36),ip(36),ib(126),ibb(126),ia(126),iaa(126)
3509 C DEFINE THE FIELDS FOR PARTICLE CLASSIFICATION
3510 C IMPS=PSEUDO SCALAR MESONS (SPIN=0)
3511 C IMVE=VECTOR MESONS (SPIN=1)
3512 C IB08(IA08)=BARYONS (ANTIBARYONS) (SPIN=1/2)
3513 C IB10(IA10)=BARYONS (ANTIBARYONS) (SPIN=3/2)
3514  DATA ip/
3515  *23,14,16,116,0,0,13,23,25,117,0,0,15,24,31,120,0,0,119,118,121,
3516  *122,14*0/
3517  l=0
3518  DO 20 i=1,6
3519  DO 10 j=1,6
3520  l=l+1
3521  imps(i,j)=ip(l)
3522  10 CONTINUE
3523  20 CONTINUE
3524  DATA iv/
3525  *33,34,38,123,0,0,32,33,39,124,0,0,36,37,96,127,0,0,126,125,128,
3526  *129,14*0/
3527  l=0
3528  DO 40 i=1,6
3529  DO 30 j=1,6
3530  l=l+1
3531  imve(i,j)=iv(l)
3532  30 CONTINUE
3533  40 CONTINUE
3534  DATA ib/
3535  *0,1,21,140,0,0,8,22,137,0,0,97,138,0,0,146,5*0,
3536  *1,8,22,137,0,0,0,20,142,0,0,98,139,0,0,147,5*0,
3537  *21,22,97,138,0,0,20,98,139,0,0,0,145,0,0,148,5*0,
3538  *140,137,138,146,0,0,142,139,147,0,0,145,148,50*0/
3539  l=0
3540  DO 60 i=1,6
3541  DO 50 j=1,21
3542  l=l+1
3543  ib08(i,j)=ib(l)
3544  50 CONTINUE
3545  60 CONTINUE
3546  DATA ibb/
3547  *53,54,104,161,0,0,55,105,162,0,0,107,164,0,0,167,5*0,
3548  *54,55,105,162,0,0,56,106,163,0,0,108,165,0,0,168,5*0,
3549  *104,105,107,164,0,0,106,108,165,0,0,109,166,0,0,169,5*0,
3550  *161,162,164,167,0,0,163,165,168,0,0,166,169,0,0,170,47*0/
3551  l=0
3552  DO 80 i=1,6
3553  DO 70 j=1,21
3554  l=l+1
3555  ib10(i,j)=ibb(l)
3556  70 CONTINUE
3557  80 CONTINUE
3558  DATA ia/
3559  *0,2,99,152,0,0,9,100,149,0,0,102,150,0,0,158,5*0,
3560  *2,9,100,149,0,0,0,101,154,0,0,103,151,0,0,159,5*0,
3561  *99,100,102,150,0,0,101,103,151,0,0,0,157,0,0,160,5*0,
3562  *152,149,150,158,0,0,154,151,159,0,0,157,160,50*0/
3563  l=0
3564  DO 100 i=1,6
3565  DO 90 j=1,21
3566  l=l+1
3567  ia08(i,j)=ia(l)
3568  90 CONTINUE
3569  100 CONTINUE
3570  DATA iaa/
3571  *67,68,110,171,0,0,69,111,172,0,0,113,174,0,0,177,5*0,
3572  *68,69,111,172,0,0,70,112,173,0,0,114,175,0,0,178,5*0,
3573  *110,111,113,174,0,0,112,114,175,0,0,115,176,0,0,179,5*0,
3574  *171,172,174,177,0,0,173,175,178,0,0,176,179,0,0,180,47*0/
3575  l=0
3576  DO 120 i=1,6
3577  DO 110 j=1,21
3578  l=l+1
3579  ia10(i,j)=iaa(l)
3580  110 CONTINUE
3581  120 CONTINUE
3582 C DEFINE THE FREE PARAMETERS FOR THE MONTE-CARLO PROGRAMMES BAMJET
3583 C AND PARJET
3584  a1=0.88
3585  b3=8.0
3586  b1=8.0
3587  b2=8.0
3588  isu=4
3589 c BET=8.0
3590  bet=9.5
3591  bet=12.
3592  as=0.50
3593  ame=0.95
3594  b8=0.40
3595  diq=0.375
3596  lt=0
3597  lb=0
3598 C THE FOLLOWING ARE THE PARAMETERS USED IN ABR8611
3599  a1=0.95
3600  a1=0.50
3601  a1=0.88
3602  b3=8.
3603  b1=6.
3604  b1=3.
3605  b2=6.
3606  b2=3.
3607  as=0.25
3608 * AME=0.95
3609  b8=0.33
3610 C WRITE (6,123)A1,B3,B1,B2,ISU,BET,AS,AME,LT,LB,B8,DIQ
3611 C 123 FORMAT (' DATAR3 INITIALIZATION:PARAMETERS SET LIKE IN ABR8611'/
3612 C *' A1 = ',F10.4/
3613 C *' B3 = ',F10.4/
3614 C *' B1 = ',F10.4/
3615 C *' B2 = ',F10.4/
3616 C *' ISU = ',I10/
3617 C *' BET = ',F10.4/
3618 C *' AS = ',F10.4/
3619 C *' AME = ',F10.4/
3620 C *' LT = ',I10/
3621 C *' LB = ',I10/
3622 C *' B8 = ',F10.4/
3623 C *' DIQ = ',F10.4)
3624  RETURN
3625  END
3626 *-- Author :
3627 C
3628 C
3629 C--------------------------------------------------------------------
3630 C
3631 C FILE TECALBAM
3632 C
3633 C
3634 C--------------------------------------------------------------------
3635  SUBROUTINE tecalb
3636  IMPLICIT DOUBLE PRECISION (a-h,o-z)
3637  SAVE
3638 C SUBROUTINE TECALBAM
3639 C
3640 C TWO CHAIN FRAGMENTATION MODEL FOR PARTICLE PRODUCTION
3641 C TEST OF CALBAM ROUTINE CALLING BAMJET
3642 C JUNE 1987, J.RANFT
3643 C********************************************************************
3644 C
3645 C OPTIONS
3646 C
3647 C JNI=7 BAMJET DISTRIBUTIONS ANALOG TO JNI=2
3648 C
3649 C IP=1=P, IP=2=AP, IP=8=N, IP=9=AN, IP=13=PI+, IP=14=PI-,
3650 C IP=15=K+, IP=16=K-,
3651 C
3652 C**********************************************************************
3653 C
3654 *KEEP,DFINPA.
3655  CHARACTER*8 anf
3656  parameter(nfimax=249)
3657  COMMON /dfinpa/ anf(nfimax),pxf(nfimax),pyf(nfimax),pzf(nfimax),
3658  +hef(nfimax),amf(nfimax), ichf(nfimax),ibarf(nfimax),nref(nfimax)
3659  COMMON /dfinpz/iormo(nfimax),idaug1(nfimax),idaug2(nfimax),
3660  * istath(nfimax)
3661 *KEEP,DINPDA.
3662  COMMON /dinpda/ imps(6,6),imve(6,6),ib08(6,21),ib10(6,21), ia08
3663  +(6,21),ia10(6,21), a1,b1,b2,b3,lt,le,bet,as,b8,ame,diq,isu
3664 *KEEP,DPRIN.
3665  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
3666 *KEND.
3667  common/jni/jni
3668  COMMON /diff/ idiff
3669  COMMON /dkpl/uplo,ipq
3670  COMMON /dinv/pnuc(3),inucvt
3671  common/capkop/xx1,xx3
3672 C----------------------------------------------------------------------
3673  WRITE (6,1000)
3674  1000 FORMAT (' ##############################################'/
3675  +' PROGRAM TECABAPT'/
3676  +' ######################################################')
3677 C CALL PRIBLO
3678 C CALL DATAR3
3679 C CALL CHANWT
3680  init=0
3681  lt=0
3682  it=1
3683  ip=1
3684  ipri=0
3685  10 CONTINUE
3686  READ(5,1010)jni,nevt,ip,ncases,poo,aoo,znuc
3687  1010 FORMAT(4i10,3f10.2)
3688  IF (it.EQ.0) it=1
3689  IF (jni.LE.0) go to 120
3690  WRITE(6, 1010)jni,nevt,ip,ncases,poo,aoo,znuc,it
3691  IF (jni.LT.0)stop
3692 C********** JNI SELECTS OPTION *************************************
3693  jni=7
3694  go to(20,30,40,50,60,70,80,100),jni
3695  20 CONTINUE
3696  30 CONTINUE
3697  40 CONTINUE
3698  50 CONTINUE
3699  60 CONTINUE
3700  70 CONTINUE
3701  go to 110
3702  80 CONTINUE
3703 C*** JNI=7 CALCUL. BAMJET EVENTS
3704 C*** WITH ENERGY POO (CMS ENERGY)
3705  ipri=0
3706  lt=0
3707  init=0
3708  ipq=1
3709  xx1=0.9
3710  xx3=1.
3711  uplo=poo
3712  iii=1
3713  CALL distcm(1,ipq,poo,ipq,ipq)
3714 C CALL DISRES(1,IPQ,POO,IPQ,IPQ)
3715  DO 90 l=1, nevt
3716  IF (ip.EQ.103)CALL calbam(0,1,1,1,7,1,1,poo,3,nhad)
3717  IF (ip.EQ.109)CALL calbam(0,1,1,7,1,1,1,poo,3,nhad)
3718  IF (ip.EQ.104)CALL calbam(0,1,1,1,2,2,1,poo,4,nhad)
3719  IF (ip.EQ.1010)CALL calbam(0,1,1,1,2,3,1,poo,4,nhad)
3720  IF (ip.EQ.105)CALL calbam(0,1,1,1,2,7,8,poo,5,nhad)
3721  IF (ip.EQ.1011)CALL calbam(0,1,1,7,7,1,1,poo,5,nhad)
3722  IF (ip.EQ.106)CALL calbam(0,1,1,1,1,1,1,poo,6,nhad)
3723  IF (ip.EQ.1012)CALL calbam(0,1,1,7,7,7,1,poo,6,nhad)
3724  IF (ip.EQ.1050)CALL calbam(0,1,1,1,1,2,1,poo,10,nhad)
3725 C
3726  CALL ddecay(nhad,2)
3727  CALL distcm(2,nhad,poo,ipq,ncases)
3728  90 CONTINUE
3729 C
3730  WRITE(6, 1020)poo,ip,ncases
3731  1020 FORMAT (' BAMJET (POO,IP,NCASES) = ',1f10.2,2i10)
3732  CALL distcm(3,nevt,poo,ipq,ncases)
3733 C CALL DISRES(3,III*NEVT,POO,IPQ,NCASES)
3734  go to 110
3735  100 CONTINUE
3736  110 CONTINUE
3737  go to 10
3738  120 CONTINUE
3739  RETURN
3740  END
3741 *-- Author :
3742 C
3743 C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3744 C
3745  SUBROUTINE distcm(IOP,NHAD,POLAB,KPROJ,KTARG)
3746  IMPLICIT DOUBLE PRECISION (a-h,o-z)
3747  SAVE
3748 C
3749 C*** 1=P, 2=N, 3=PI+, 4=PI-, 5=PIO, 6=GAM+HYP, 7=K, 8=ANUC, 9=CHARGED
3750 C*** 10=TOT, 11=TOTHAD
3751 C
3752  CHARACTER*8 anh
3753  parameter(nfimax=249)
3754  COMMON /dfinpa/ anh(nfimax),px(nfimax),py(nfimax),pz(nfimax),
3755  +he(nfimax),am(nfimax), ich(nfimax),ibar(nfimax),nr(nfimax)
3756  COMMON /dfinpz/iormo(nfimax),idaug1(nfimax),idaug2(nfimax),
3757  * istath(nfimax)
3758 C---------------------
3759  CHARACTER*8 aname
3760  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),iich(210),
3761  +iibar(210),k1(210),k2(210)
3762 C------------------
3763  COMMON /histo / xmult(100,10),ymult(100,10),xxfl(50,20), yxfl
3764  +(50,20),xyl(50,20),yyl(50,20), yylps(50,20),ptp(50,20),pty(50,20),
3765  +fill(6000)
3766  dimension avmult(12,30),ave(12,30),indx(25),mu(12,30), akno
3767  +(100,2),xkno(100,2),ake(12,30),aaso(12,30)
3768  COMMON /dkpl/uplo,kpl
3769  common/jni/jni
3770 C
3771  DATA ipriop/1/
3772  DATA indx/1,8,10,10,10,10,7,2,7,10,10,7,3,4,5,6,
3773  *11,12,7,13,14,15,16,17,18/
3774 C-----------------------------------------------------------------------
3775  go to(10,60,100),iop
3776  10 CONTINUE
3777  kpl=1
3778  avpt=0.
3779  navpt=0
3780  dxfl=0.04
3781  po=polab
3782 C EEO=SQRT(PO**2+AAM(NHAD)**2)
3783 C UMO=SQRT(AAM(KTARG)**2+AAM(KPROJ)**2+2.*AAM(KTARG)*EEO)
3784  IF(jni.EQ.7) umo=polab
3785  umo=polab
3786  eeo=umo
3787  po=eeo/2.d0
3788  WRITE(6, 1000)eeo,po,nhad
3789  1000 FORMAT (' EEO',f10.2,f10.2,i10)
3790  dy=0.2
3791  dpt=0.10
3792  DO 20 i=1,10
3793  avmult(kpl,i)=1.e-18
3794  ave(kpl,i)=0.
3795  DO 20 j=1,100
3796  xmult(j,i)=j-1
3797  ymult(j,i)=1.d-18
3798  akno(j,1)=1.d-18
3799  akno(j,2)=1.d-18
3800  20 CONTINUE
3801  WRITE(6, 1000)eeo,po,nhad
3802  DO 30 i=1,20
3803  DO 30 j=1,50
3804  xxfl(j,i)=j*dxfl -1.
3805  yxfl(j,i)=1.d-18
3806  xyl(j,i)=-5.0+j*dy
3807  yyl(j,i)=1.d-18
3808  yylps(j,i)=1.e-18
3809  ptp(j,i)=j*dpt
3810  pty(j,i)=1.d-18
3811  30 CONTINUE
3812  WRITE(6, 1000)eeo,po,nhad
3813  40 CONTINUE
3814  DO 50 i=1,30
3815  ave(kpl,i)=1.d-18
3816  avmult(kpl,i)=1.d-18
3817  mu(kpl,i)=0
3818  aaso(kpl,i)=uplo
3819  50 CONTINUE
3820  WRITE(6, 1000)eeo,po,nhad
3821  RETURN
3822 C
3823  60 CONTINUE
3824 C WRITE(6, 1000)EEO,PO,NHAD
3825  avmult(kpl,30)=avmult(kpl,30)+nhad
3826  nnhad=nhad+1
3827  IF (nnhad.GT.100) nnhad=100
3828  ymult(nnhad,10)=ymult(nnhad,10)+1.
3829  DO 70 i=1,30
3830  mu(kpl,i)=0
3831  70 CONTINUE
3832  eetot=0.d0
3833  DO 71 i=1,nhad
3834  IF(ibar(i).NE.500)THEN
3835 C WRITE(6,*)I,ANH(I),HE(I),AM(I),IBAR(I),NR(I)
3836  eetot=eetot+he(i)
3837  ENDIF
3838  71 CONTINUE
3839  IF(eetot.GT.polab+1.d-6)THEN
3840  WRITE(6,*).gt.' eetotpolab ',eetot,polab
3841  ENDIF
3842 C WRITE(6,*)' eetot ',EETOT
3843  DO 80 i=1,nhad
3844  IF(ibar(i).NE.500)THEN
3845  nre=nr(i)
3846  IF (nre.GT.25) nre=3
3847  IF (nre.LT. 1) nre=3
3848  ni=indx(nre)
3849  IF (nre.EQ.28)ni=8
3850  ave(kpl,nre)=ave(kpl,nre)+he(i)
3851  ave(kpl,30)=ave(kpl,30)+he(i)
3852  IF (ni.NE.6) ave(kpl,29)=ave(kpl,29)+he(i)
3853  avmult(kpl,nre)=avmult(kpl,nre)+1.
3854  IF (ni.NE.6) avmult(kpl,29)=avmult(kpl,29)+1.
3855  mu(kpl,ni)=mu(kpl,ni)+1
3856  IF (ich(i).NE.0)mu(kpl,9)=mu(kpl,9)+1
3857 C TOTAL=30 TOTAL-GAMMA=29 ANTIHYP=28
3858 C CHARGED=27
3859  IF (ich(i).NE.0)ave(kpl,27)=ave(kpl,27)+he(i)
3860  IF (ich(i).NE.0)avmult(kpl,27)=avmult(kpl,27)+1
3861 C XFL=PZ(I)/PO
3862  xfl=(pz(i)/abs(pz(i)))*he(i)/po
3863  ixfl=xfl/dxfl+26.
3864  IF (ixfl.LT. 1) ixfl=1
3865  IF (ixfl.GT.50) ixfl=50
3866 C XXXFL=SQRT(XFL**2+(AM(I)+0.3)**2/PO**2)
3867  xxxfl=abs(xfl)
3868  IF (ich(i).NE.0)yxfl(ixfl,9)=yxfl(ixfl,9)+xxxfl
3869  yxfl(ixfl,ni)=yxfl(ixfl,ni)+xxxfl
3870  yxfl(ixfl,10)=yxfl(ixfl,10)+xxxfl
3871  ptt=px(i)**2+py(i)**2
3872  yl=0.5*log(abs((he(i)+pz(i)+1.e-10)/(he(i)-pz(i)+1.e-10)))
3873  ylps=log(abs((pz(i)+sqrt(pz(i)**2+ptt))/sqrt(ptt)+1.e-18))
3874  iylps=(ylps+5.0)/dy
3875  IF (iylps.LT.1)iylps=1
3876  IF (iylps.GT.50)iylps=50
3877  yylps(iylps,ni)=yylps(iylps,ni)+1.
3878  yylps(iylps,10)=yylps(iylps,10)+1.
3879  IF (ich(i).NE.0)yylps(iylps,9)=yylps(iylps,9)+1.
3880  iyl=(yl+5.0)/dy
3881  IF (iyl.LT.1) iyl=1
3882  IF (iyl.GT.50) iyl=50
3883  IF (ich(i).NE.0)yyl(iyl,9)=yyl(iyl,9)+1.
3884  yyl(iyl,ni)=yyl(iyl,ni)+1.
3885  yyl(iyl,10)=yyl(iyl,10)+1.
3886  pt=sqrt(ptt)+0.001
3887  avpt=avpt+pt
3888  navpt=navpt+1
3889  ipt=pt/dpt+1.
3890  IF (ipt.LT.1)ipt=1
3891  IF (ipt.GT.50) ipt=50
3892  IF (ich(i).NE.0)pty(ipt,9)=pty(ipt,9)+1./pt
3893  pty(ipt,ni)=pty(ipt,ni)+1./pt
3894  pty(ipt,10)=pty(ipt,10)+1./pt
3895  ENDIF
3896  80 CONTINUE
3897  DO 90 i=1,9
3898  im=mu(kpl,i)+1
3899  IF (im.GT.100)im=100
3900  ymult(im,i)=ymult(im,i)+1.
3901  90 CONTINUE
3902  RETURN
3903 C------------------------------------------------
3904  100 CONTINUE
3905  WRITE(6, 1000)eeo,po,nhad
3906 C1020 FORMAT (' AVMULT=',11F10.5/,' AVE=',11F10.5)
3907  DO 110 i=1,30
3908  avmult(kpl,i)=avmult(kpl,i)/nhad
3909  ave(kpl,i)=ave(kpl,i)/nhad
3910  110 CONTINUE
3911  avpt=avpt/navpt
3912  WRITE (6,1030)avpt,navpt
3913  1030 FORMAT (' AVERAGE PT= ',f12.4,i10)
3914  WRITE(6, 1040)
3915  1040 FORMAT(' PARTICLE REF,CHAR,IBAR, MASS AVERAGE',
3916  +' ENERGY, MULTIPLICITY, INELASTICITY')
3917  DO 120 i=1,30
3918  ake(kpl,i)=ave(kpl,i)/eeo
3919  WRITE(6, 1050)aname(i),i,iich(i),iibar(i),
3920  + aam(i), ave(kpl,i),avmult
3921  + (kpl,i),ake(kpl,i)
3922  1050 FORMAT (' ',a8,3i5,f10.3,3f18.6)
3923  120 CONTINUE
3924  DO 130 i=1,10
3925  DO 130 j=1,100
3926  ymult(j,i)=ymult(j,i)/nhad
3927  130 CONTINUE
3928  DO 140 i=1,20
3929  DO 140 j=1,50
3930  yxfl(j,i)=yxfl(j,i)/(nhad*dxfl)
3931  yy l(j,i)=yy l(j,i)/(nhad*dy)
3932  yylps(j,i)=yylps(j,i)/(nhad*dy)
3933  pty(j,i)=pty(j,i)/(nhad*dpt)
3934  140 CONTINUE
3935  150 CONTINUE
3936  WRITE(6, 1060)
3937  1060 FORMAT('1 RAPIDITY DISTRIBUTION')
3938  DO 160 j=1,50
3939  WRITE(6, 1070)xyl(j,1),(yyl(j,i),i=1,10)
3940  1070 FORMAT (f10.2,10e11.3)
3941  160 CONTINUE
3942  DO 161 j=1,50
3943  WRITE(6, 1070)xyl(j,1),(yyl(j,i),i=11,20)
3944  161 CONTINUE
3945  WRITE(6, 1060)
3946  WRITE(6,*)' 1=*=p, 2=n, 3=pi+, 4=pi-, 5=K+, 6=K-,',
3947  &' 8=ap, 9=chargd., 10=Z=all, 11=+=Lamb, 12=A=aLam,',
3948  &' 13=O=sig-, 14=B=Sig+, 15=C=Sig0, 16=D=pi0'
3949  CALL plot(xyl,yyl,1000,20,50,-5.d0,dy,0.d0,0.1d0)
3950  WRITE(6,*)' 1=*=p, 2=n, 3=pi+, 4=pi-, 5=K+, 6=K-,',
3951  &' 8=ap, 9=chargd., 10=Z=all, 11=+=Lamb, 12=A=aLam,',
3952  &' 13=O=sig-, 14=B=Sig+, 15=C=Sig0, 16=D=pi0'
3953  CALL plot(xyl,yylps,1000,20,50,-5.d0,dy,0.d0,0.1d0)
3954 C IF (IPRIOP.EQ.1) GO TO 1423
3955  WRITE(6, 1080)
3956  1080 FORMAT ('1 LONG MOMENTUM (SCALED) DISTRIBUTION')
3957  DO 170 j=1,50
3958  WRITE(6, 1070)xxfl(j,1),(yxfl(j,i),i=1,10)
3959  170 CONTINUE
3960  DO 171 j=1,50
3961  WRITE(6, 1070)xxfl(j,1),(yxfl(j,i),i=11,20)
3962  171 CONTINUE
3963  180 CONTINUE
3964  WRITE(6, 1080)
3965  WRITE(6,*)' 1=*=p, 2=n, 3=pi+, 4=pi-, 5=K+, 6=K-,',
3966  &' 8=ap, 9=chargd., 10=Z=all, 11=+=Lamb, 12=A=aLam,',
3967  &' 13=O=sig-, 14=B=Sig+, 15=C=Sig0, 16=D=pi0'
3968  CALL plot(xxfl,yxfl,1000,20,50,-1.d0,dxfl,0.d0,0.05d0)
3969  WRITE(6, 1090)
3970  1090 FORMAT ('1 MULTIPLICITY DISTRIBUTIONS')
3971  simul=0.
3972  sumul=0.
3973  DO 190 j=1,100
3974  sumul=sumul+ymult(j,10)
3975  simul=simul+ymult(j,9)
3976  190 CONTINUE
3977  WRITE(6, 1100)(xmult(j,1),ymult(j,9),ymult(j,10),j=1,100)
3978  1100 FORMAT(f6.1,2e12.4,f6.1,2e12.4,f6.1,2e12.4,f6.1,2e12.4)
3979  WRITE(6, 1090)
3980  WRITE(6,*)' 1=*=p, 2=n, 3=pi+, 4=pi-, 5=K+, 6=K-,',
3981  &' 8=ap, 9=chargd., 10=Z=all, 11=+=Lamb, 12=A=aLam,',
3982  &' 13=O=sig-, 14=B=Sig+, 15=C=Sig0, 16=D=pi0'
3983  CALL plot(xmult,ymult,1000,10,100,0.d0,1.d0,0.d0,0.01d0)
3984  DO 200 i=1,100
3985  xkno(i,1)=i/avmult(kpl,30)
3986  xkno(i,2)=i/avmult(kpl,27)
3987  akno(i,1)=ymult(i,10)*avmult(kpl,30)/sumul
3988  akno(i,2)=ymult(i,9)*avmult(kpl,27)/simul
3989  akno(i,1)=log10(akno(i,1)+1.d-9)
3990  akno(i,2)=log10(akno(i,2)+1.d-9)
3991  200 CONTINUE
3992  WRITE(6, 1110)
3993  1110 FORMAT ('1 KNO MULTIPLICITY DISTRIBUTIONS')
3994  WRITE(6,*)' 1=*=p, 2=n, 3=pi+, 4=pi-, 5=K+, 6=K-,',
3995  &' 8=ap, 9=chargd., 10=Z=all, 11=+=Lamb, 12=A=aLam,',
3996  &' 13=O=sig-, 14=B=Sig+, 15=C=Sig0, 16=D=pi0'
3997  CALL plot(xkno,akno,200,2,100,0.d0,0.08d0,-4.d0,0.05d0)
3998  DO 210 i=1,10
3999  DO 210 j=1,100
4000  ymult(j,i)=log10(ymult(j,i))
4001  210 CONTINUE
4002  DO 220 i=1,20
4003  DO 220 j=1,50
4004  yxfl(j,i)=log10(abs(yxfl(j,i)+1.d-8))
4005  yyl(j,i)=log10(yyl(j,i)+1.d-8)
4006  pty(j,i)=log10(pty(j,i)+1.d-8)
4007  220 CONTINUE
4008  230 CONTINUE
4009  WRITE(6, 1060)
4010  WRITE(6,*)' 1=*=p, 2=n, 3=pi+, 4=pi-, 5=K+, 6=K-,',
4011  &' 8=ap, 9=chargd., 10=Z=all, 11=+=Lamb, 12=A=aLam,',
4012  &' 13=O=sig-, 14=B=Sig+, 15=C=Sig0, 16=D=pi0'
4013  CALL plot(xyl,yyl,1000,20,50,-5.d0,dy,-3.5d0,0.05d0)
4014  DO 240 j=1,50
4015  WRITE(6, 1070)xxfl(j,1),(yxfl(j,i),i=1,10)
4016  240 CONTINUE
4017  DO 241 j=1,50
4018  WRITE(6, 1070)xxfl(j,1),(yxfl(j,i),i=11,20)
4019  241 CONTINUE
4020  WRITE(6, 1080)
4021  WRITE(6,*)' 1=*=p, 2=n, 3=pi+, 4=pi-, 5=K+, 6=K-,',
4022  &' 8=ap, 9=chargd., 10=Z=all, 11=+=Lamb, 12=A=aLam,',
4023  &' 13=O=sig-, 14=B=Sig+, 15=C=Sig0, 16=D=pi0'
4024  CALL plot(xxfl,yxfl,1000,20,50,-1.d0,dxfl,-4.5d0,0.05d0)
4025  WRITE(6,1120)
4026  1120 FORMAT ('1 PT DISTRIBUTION DN/PTDPT')
4027  CALL plot(ptp,pty,1000,20,50,0.d0,dpt,-2.0d0,0.05d0)
4028  IF (ipriop.EQ.1) go to 250
4029  WRITE(6,1090)
4030  WRITE(6,*)' 1=*=p, 2=n, 3=pi+, 4=pi-, 5=K+, 6=K-,',
4031  &' 8=ap, 9=chargd., 10=Z=all, 11=+=Lamb, 12=A=aLam,',
4032  &' 13=O=sig-, 14=B=Sig+, 15=C=Sig0, 16=D=pi0'
4033  CALL plot(xmult,ymult,1000,10,100,0.d0,1.d0, -3.5d0,0.05d0)
4034  250 CONTINUE
4035  IF (kpl.NE.12) go to 270
4036  DO 260 i=1,12
4037  DO 260 j=1,30
4038  aaso(i,j)=log10(aaso(i,j)+1.d-18)
4039  avmult(i,j)=log10(avmult(i,j)+1.d-18)
4040  ake(i,j)=log10(ake(i,j)+1.d-18)
4041  260 CONTINUE
4042  WRITE(6,*)' 1=*=p, 2=n, 3=pi+, 4=pi-, 5=K+, 6=K-,',
4043  &' 8=ap, 9=chargd., 10=Z=all, 11=+=Lamb, 12=A=aLam,',
4044  &' 13=O=sig-, 14=B=Sig+, 15=C=Sig0, 16=D=pi0'
4045  CALL plot(aaso,avmult,360,30,12,0.d0,0.1d0,-3.d0,0.05d0)
4046  WRITE(6,*)' 1=*=p, 2=n, 3=pi+, 4=pi-, 5=K+, 6=K-,',
4047  &' 8=ap, 9=chargd., 10=Z=all, 11=+=Lamb, 12=A=aLam,',
4048  &' 13=O=sig-, 14=B=Sig+, 15=C=Sig0, 16=D=pi0'
4049  CALL plot(aaso,ake,360,30,12,0.d0,0.1d0,-5.d0,0.05d0)
4050  270 CONTINUE
4051  RETURN
4052  END
4053 *-- Author :
4054 C
4055 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4056 C
4057  SUBROUTINE ddecay(IHAD,ISTAB)
4058  IMPLICIT DOUBLE PRECISION (a-h,o-z)
4059  SAVE
4060 C------------------
4061 *KEEP,DFINPA.
4062  CHARACTER*8 anf
4063  parameter(nfimax=249)
4064  COMMON /dfinpa/ anf(nfimax),pxf(nfimax),pyf(nfimax),pzf(nfimax),
4065  +hef(nfimax),amf(nfimax), ichf(nfimax),ibarf(nfimax),nref(nfimax)
4066  COMMON /dfinpz/iormo(nfimax),idaug1(nfimax),idaug2(nfimax),
4067  * istath(nfimax)
4068 *KEND.
4069  CHARACTER*8 zkname
4070  CHARACTER*8 aname
4071 C COMMON/DDECAC/ ZKNAME(540),NZK(540,3),WT(540)
4072 
4073  parameter(idmax9=602)
4074 C CHARACTER*8 ZKNAME
4075  common/ddecac/ zkname(idmax9),wt(idmax9),nzk(idmax9,3)
4076 
4077 
4078  common/dpar/aname(210),am(210),ga(210),tau(210),ich(210),ibar(210)
4079  *,k1(210),k2(210)
4080  common/dmetls/ cxs(149),cys(149),czs(149),els(149),
4081  *pls(149),is,its(149)
4082  common/ddre/ test(12)
4083  common/pritt/isys
4084 C------------------
4085  isys=6
4086  DO 10 i=1,ihad
4087  its(i)=nref(i)
4088  pls(i)=sqrt(pxf(i)**2+pyf(i)**2+pzf(i)**2)
4089  IF(pls(i).NE.0.)cxs(i)=pxf(i)/pls(i)
4090  IF(pls(i).NE.0.)cys(i)=pyf(i)/pls(i)
4091  IF(pls(i).NE.0.)czs(i)=pzf(i)/pls(i)
4092  els(i)=hef(i)
4093  10 CONTINUE
4094  ist=ihad
4095  ir=0
4096  20 CONTINUE
4097 C*****TEST STABLE OR UNSTABLE
4098 C ISTAB=1/2/3 MEANS STRONG + WEAK DECAYS / ONLY STRONG DECAYS /
4099 C STRONG DECAYS + WEAK DECAYS FOR CHARMED PARTICLES AND TAU LEPTONS
4100  IF(istab.EQ.1) goto 30
4101  IF(istab.EQ.2) goto 50
4102  IF(istab.EQ.3) goto 40
4103  30 IF(its(ist).EQ.135.OR.its(ist).EQ.136) goto 60
4104  IF(its(ist).GE.1.AND.its(ist).LE.7) goto 60
4105  goto 70
4106  40 IF(its(ist).GE.1.AND.its(ist).LE.23) goto 60
4107  IF(its(ist).GE. 97.AND.its(ist).LE.103) goto 60
4108 C* IF(ITS(IST).EQ.109.AND.ITS(IST).EQ.115) GOTO 202
4109  IF(its(ist).EQ.109.OR.its(ist).EQ.115) goto 60
4110  IF(its(ist).GE.133.AND.its(ist).LE.136) goto 60
4111  goto 70
4112  50 IF(its(ist).GE. 1.AND.its(ist).LE. 30) goto 60
4113  IF(its(ist).GE. 97.AND.its(ist).LE.103) goto 60
4114  IF(its(ist).GE.115.AND.its(ist).LE.122) goto 60
4115  IF(its(ist).GE.131.AND.its(ist).LE.136) goto 60
4116  IF(its(ist).EQ.109) goto 60
4117  IF(its(ist).GE.137.AND.its(ist).LE.160) goto 60
4118  goto 70
4119  60 ir=ir+1
4120  IF (ir.GT.nfimax)THEN
4121  WRITE (6,1000)ir,nfimax
4122  1000 FORMAT(.GT.' DECAY IRNFIMAX RETURN ',2i10)
4123  RETURN
4124  ENDIF
4125  nref(ir)=its(ist)
4126  itt=its(ist)
4127  amf(ir)=am(itt)
4128  anf(ir)=aname(itt)
4129  ichf(ir)=ich(itt)
4130  ibarf(ir)=ibar(itt)
4131  hef(ir)=els(ist)
4132  pxf(ir)=cxs(ist)*pls(ist)
4133  pyf(ir)=cys(ist)*pls(ist)
4134  pzf(ir)=czs(ist)*pls(ist)
4135  ist=ist-1
4136  IF(ist.GE.1) goto 20
4137  goto140
4138  70 it=its(ist)
4139  gam=els(ist)/am(it)
4140  bgam=pls(ist)/am(it)
4141  eco=am(it)
4142  kz1=k1(it)
4143  80 CONTINUE
4144  vv=rndm(vw)-1.d-17
4145  iik=kz1-1
4146  90 iik=iik+1
4147  IF (vv.GT.wt(iik)) go to 90
4148 C IIK IS THE DECAY CHANNEL
4149  it1=nzk(iik,1)
4150  it2=nzk(iik,2)
4151  IF (it2-1.LT.0) go to 120
4152  it3=nzk(iik,3)
4153 C IT1,IT2, IT3 ARE THE PRODUCED PARTICLES FROM IT
4154  IF(it3.EQ.0) go to 100
4155  CALL dthrep(eco,ecm1,ecm2,ecm3,pcm1,pcm2,pcm3,cod1,cof1,sif1,
4156  *cod2,cof2,sif2,cod3,cof3,sif3,am(it1),am(it2),am(it3))
4157  go to 110
4158  100 CALL dtwopd(eco,ecm1,ecm2,pcm1,pcm2,cod1,cof1,sif1,cod2,cof2,sif2,
4159  +am(it1),am(it2))
4160  110 CONTINUE
4161  120 CONTINUE
4162  its(ist )=it1
4163  IF (it2-1.LT.0) go to 130
4164  its(ist+1) =it2
4165  its(ist+2)=it3
4166  rx=cxs(ist)
4167  ry=cys(ist)
4168  rz=czs(ist)
4169  CALL dtrafo(gam,bgam,rx,ry,rz,cod1,cof1,sif1,pcm1,ecm1,
4170  *pls(ist),cxs(ist),cys(ist),czs(ist),els(ist))
4171  ist=ist+1
4172  CALL dtrafo(gam,bgam,rx,ry,rz,cod2,cof2,sif2,pcm2,ecm2,
4173  *pls(ist),cxs(ist),cys(ist),czs(ist),els(ist))
4174  IF (it3.LE.0) go to 130
4175  ist=ist+1
4176  CALL dtrafo(gam,bgam,rx,ry,rz,cod3,cof3,sif3,pcm3,ecm3,
4177  *pls(ist),cxs(ist),cys(ist),czs(ist),els(ist))
4178  130 CONTINUE
4179  go to 20
4180  140 CONTINUE
4181  IF(ir.GT.7998) WRITE(isys,1010)
4182  1010 FORMAT(2x,' NUMBER OF STAB. FINAL PART. IS GREATER THAN 7998')
4183  ihad=ir
4184  RETURN
4185  END
4186 *-- Author :
4187 C--------------------------------------------------------------------
4188 C
4189 C FILE SHMAK
4190 C
4191 C--------------------------------------------------------------------
4192  SUBROUTINE shmak(ICASE,NN,NNA,NNB,NA,NB,UMO,BIMP)
4193  IMPLICIT DOUBLE PRECISION (a-h,o-z)
4194  SAVE
4195 * scoring of unbiased Glauber events sampled in KKEVT
4196 * (reduction of interactions possible in case event rejection because
4197 * of limitations from kinematics)
4198 *
4199 *KEEP,DPRIN.
4200  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
4201 *KEND.
4202  parameter(namx=248)
4203  dimension fnua(namx),fnub(namx),fnut(namx)
4204  dimension ann(namx)
4205  dimension xb(200),bimpp(200)
4206 C-------------------------------
4207 C---------------------------------------------------------------
4208 C
4209 C plot impact parameter distribution
4210 C
4211 C----------------------------------------------------------------
4212 C DO 7784 II=1,200
4213 C BIMPP(II)=0.D0
4214 CXB(II)=0.1D0*II
4215 C7784 CONTINUE
4216 C IP=207
4217 C IT=207
4218 C KKMAT=1
4219 C PPROJ=PPN
4220 C DO 7785 II=1,100000
4221 C CALL SHMAKO(IP,IT,BIMP,NN,NP,NT,JSSH,JTSH,PPROJ,KKMAT)
4222 C IF(II.LE.1000)WRITE(6,*)' IP,IT,BIMP,NN,NP,NT ',
4223 C * IP,IT,BIMP,NN,NP,NT
4224 C IB=BIMP/0.1D0+1.D0
4225 C IF(IB.GE.200)IB=200
4226 C BIMPP(IB)=BIMPP(IB)+1
4227 C7785 CONTINUE
4228 C WRITE(6,*)' Impact parameter distribution B,BIMPP'
4229 C DO 7786 II=1,200
4230 C WRITE(6,*)XB(II),BIMPP(II)
4231 C7786 CONTINUE
4232 C---------------------------------------------------------------
4233 C
4234 C plot impact parameter distribution
4235 C
4236 C---------------------------------------------------------------
4237  go to(10,30,40),icase
4238  10 CONTINUE
4239  DO 7784 ii=1,200
4240  bimpp(ii)=0.d0
4241  xb(ii)=0.1d0*ii
4242  7784 CONTINUE
4243  bnut=0.
4244  bnua=0.
4245  bnub=0.
4246  bnvv=0.
4247  bnsv=0.
4248  bnvs=0.
4249  bnss=0.
4250  DO 20 i=1,namx
4251  ann(i)=i
4252  fnu a(i)=0.
4253  fnu b(i)=0.
4254  fnu t(i)=0.
4255  20 CONTINUE
4256  anusd=0.d0
4257  RETURN
4258  30 CONTINUE
4259  ib=bimp/0.1d0+1.d0
4260  IF(ib.GE.200)ib=200
4261  bimpp(ib)=bimpp(ib)+1
4262 C Calculate fraction of diffractive events
4263  IF((nn.EQ.1).AND.(nna.EQ.1).AND.(nnb.EQ.1))THEN
4264  CALL sihndi(umo,1,1,singdif,sigdih)
4265  sigabs=siinel(1,1,umo)
4266  anusd=anusd + singdif/sigabs
4267  ENDIF
4268  intt=nn
4269  IF (intt.GT.namx)intt=namx
4270  nua=nna
4271  IF (nua.GT.namx) nua=namx
4272  nub=nnb
4273  IF (nub.GT.namx) nub=namx
4274  fnua(nua)=fnua(nua)+1.
4275  fnut(intt)=fnut(intt)+1.
4276  fnub(nub)=fnub(nub)+1.
4277  bnut=bnut+nn
4278  bnua=bnua+nna
4279  bnub=bnub+nnb
4280  IF(nnb.GE.nna) THEN
4281  nnvv=nna
4282  nnsv=nnb-nna
4283  nnvs=0
4284  nnss=nn-nnb
4285  ELSE
4286  nnvv=nnb
4287  nnsv=0
4288  nnvs=nna-nnb
4289  nnss=nn-nna
4290  ENDIF
4291  bnvv=bnvv + nnvv
4292  bnsv=bnsv + nnsv
4293  bnvs=bnvs + nnvs
4294  bnss=bnss + nnss
4295  RETURN
4296  40 CONTINUE
4297  IF(nn.EQ.0)THEN
4298  WRITE(6,*)' shmak(3,NN,... ) NN= ',nn
4299  RETURN
4300  ENDIF
4301 C WRITE(6,*)' Impact parameter distribution B,BIMPP'
4302 C WRITE(6,*)(XB(II),BIMPP(II),II=1,200)
4303 C WRITE(6,*)' Impact parameter distribution B,BIMPP'
4304 C CALL PLOT(XB,BIMPP,50,1,50,0.,0.4D0,0.,10.D0)
4305  anusd=anusd/nn
4306  bnut=bnut/nn
4307  bnua=bnua/nn
4308  bnub=bnub/nn
4309  bnvv=bnvv/nn
4310  bnsv=bnsv/nn
4311  bnvs=bnvs/nn
4312  bnss=bnss/nn
4313  WRITE(6,'(1H1,50(1H*))')
4314  WRITE(6,'(/10X,A/)') ' OUTPUT FROM SHMAK all events before',
4315  *' diffraction modification'
4316  WRITE(6,'(50(1H*))')
4317  WRITE(6,'(A,I10)') ' NUMBER OF TOTALLY SAMPLED GLAUBER EVENTS',nn
4318  WRITE(6, 1000) bnut,bnua,bnub
4319  WRITE(6,*)' Fraction of diffractive evnts: ',anusd
4320  1000 FORMAT(' AVERAGE NO OF COLLISIONS BNUT,BNUA,BNUB=',3f10.3)
4321  WRITE(6,'(/A)') ' AVERAGE NUMBERS OF DIFFERENT COLLISION TYPES'
4322  WRITE(6,'(4(5X,A,F8.2/))') ' VAL-VAL:',bnvv, ' SEA-VAL:',bnsv,
4323  +' VAL-SEA:',bnvs, ' SEA-SEA:',bnss
4324  IF(ipri.GE.1) THEN
4325  dnna=na/50+1
4326  dnnb=nb/50+1
4327  dnnt=2.*dnnb
4328  WRITE(6,1010)
4329  1010 FORMAT (' FNUA')
4330  WRITE(6,1040) fnua
4331  DO 323 i=1,namx
4332  fnu a(i)=log10(fnu a(i)+1.d-5)
4333  323 CONTINUE
4334  CALL plot(ann,fnu a,namx,1,namx,0.d0,dnna,0.d0,0.05d0)
4335  WRITE(6,1020 )
4336  WRITE(6,1040) fnub
4337  1020 FORMAT (' FNUB')
4338  DO 324 i=1,namx
4339  fnu b(i)=log10(fnu b(i)+1.d-5)
4340  324 CONTINUE
4341  CALL plot(ann,fnu b,namx,1,namx,0.d0,dnnb,0.d0,0.05d0)
4342  WRITE(6,1030 )
4343  WRITE(6,1040) fnut
4344  1030 FORMAT (' FNUT')
4345  DO 325 i=1,namx
4346  fnu t(i)=log10(fnu t(i)+1.e-5)
4347  325 CONTINUE
4348  CALL plot(ann,fnu t,namx,1,namx,0.d0,dnnt,0.d0,0.05d0)
4349  1040 FORMAT (10f12.2)
4350  ENDIF
4351  RETURN
4352  END
4353 C--------------------------------------------------------------------
4354 C
4355 C FILE SHMAK1
4356 C
4357 C--------------------------------------------------------------------
4358  SUBROUTINE shmak1(ICASE,NN,NNA,NNB,NA,NB,UMO,BIMP)
4359  IMPLICIT DOUBLE PRECISION (a-h,o-z)
4360  SAVE
4361 * scoring of unbiased Glauber events sampled in KKEVT
4362 * (reduction of interactions possible in case event rejection because
4363 * of limitations from kinematics)
4364 *
4365 *KEEP,DPRIN.
4366  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
4367 *KEND.
4368  parameter(namx=248)
4369  dimension fnua(namx),fnub(namx),fnut(namx)
4370  dimension ann(namx)
4371  dimension xb(200),bimpp(200)
4372 C-------------------------------
4373  go to(10,30,40),icase
4374  10 CONTINUE
4375  DO 7784 ii=1,200
4376  bimpp(ii)=0.d0
4377  xb(ii)=0.1d0*ii
4378  7784 CONTINUE
4379  bnut=0.
4380  bnua=0.
4381  bnub=0.
4382  anusd=0.d0
4383  DO 20 i=1,namx
4384  ann(i)=i
4385  fnu a(i)=0.
4386  fnu b(i)=0.
4387  fnu t(i)=0.
4388  20 CONTINUE
4389  RETURN
4390  30 CONTINUE
4391  ib=bimp/0.1d0+1.d0
4392  IF(ib.GE.200)ib=200
4393  bimpp(ib)=bimpp(ib)+1
4394 C Calculate fraction of diffractive events
4395  IF((nn.EQ.1).AND.(nna.EQ.1).AND.(nnb.EQ.1))THEN
4396  CALL sihndi(umo,1,1,singdif,sigdih)
4397  sigabs=siinel(1,1,umo)
4398  anusd=anusd + singdif/sigabs
4399  ENDIF
4400  intt=nn
4401  IF (intt.GT.namx)intt=namx
4402  nua=nna
4403  IF (nua.GT.namx) nua=namx
4404  nub=nnb
4405  IF (nub.GT.namx) nub=namx
4406  fnua(nua)=fnua(nua)+1.
4407  fnut(intt)=fnut(intt)+1.
4408  fnub(nub)=fnub(nub)+1.
4409  bnut=bnut+nn
4410  bnua=bnua+nna
4411  bnub=bnub+nnb
4412  RETURN
4413  40 CONTINUE
4414  IF(nn.EQ.0)THEN
4415  WRITE(6,*)' shmak1(3,NN,... ) NN= ',nn
4416  RETURN
4417  ENDIF
4418 C WRITE(6,*)' Impact parameter distribution B,BIMPP'
4419 C WRITE(6,*)(XB(II),BIMPP(II),II=1,200)
4420 C WRITE(6,*)' Impact parameter distribution B,BIMPP'
4421 C CALL PLOT(XB,BIMPP,50,1,50,0.D0,0.4D0,0.D0,10.D0)
4422  bnut=bnut/nn
4423  bnua=bnua/nn
4424  bnub=bnub/nn
4425  anusd=anusd/nn
4426  WRITE(6,'(1H1,50(1H*))')
4427  WRITE(6,'(/10X,A/)') ' OUTPUT FROM SHMAK1 after modification',
4428  *' of Glauber events for diffractive cross section'
4429  WRITE(6,'(50(1H*))')
4430  WRITE(6,'(A,I10)') ' NUMBER OF TOTALLY SAMPLED GLAUBER EVENTS',nn
4431  WRITE(6, 1000) bnut,bnua,bnub
4432  1000 FORMAT(' AVERAGE NO OF COLLISIONS BNUT,BNUA,BNUB=',3f10.3)
4433  WRITE(6,*)' Fraction of diffractive evnts: ',anusd
4434 C WRITE(6,'(/A)') ' AVERAGE NUMBERS OF DIFFERENT COLLISION TYPES'
4435 C WRITE(6,'(4(5X,A,F8.2/))') ' VAL-VAL:',BNVV, ' SEA-VAL:',BNSV,
4436 C +' VAL-SEA:',BNVS, ' SEA-SEA:',BNSS
4437  IF(ipri.GE.1) THEN
4438  dnna=na/50+1
4439  dnnb=nb/50+1
4440  dnnt=2.*dnnb
4441  WRITE(6,1010)
4442  1010 FORMAT (' FNUA')
4443  WRITE(6,1040) fnua
4444  DO 323 i=1,namx
4445  fnu a(i)=log10(fnu a(i)+1.d-5)
4446 323 CONTINUE
4447  CALL plot(ann,fnu a,namx,1,namx,0.d0,dnna,0.d0,0.05d0)
4448  WRITE(6,1020 )
4449  WRITE(6,1040) fnub
4450  1020 FORMAT (' FNUB')
4451  DO 324 i=1,namx
4452  fnu b(i)=log10(fnu b(i)+1.d-5)
4453 324 CONTINUE
4454  CALL plot(ann,fnu b,namx,1,namx,0.d0,dnnb,0.d0,0.05d0)
4455  WRITE(6,1030 )
4456  WRITE(6,1040) fnut
4457 1030 FORMAT (' FNUT')
4458  DO 325 i=1,namx
4459  fnu t(i)=log10(fnu t(i)+1.e-5)
4460 325 CONTINUE
4461  CALL plot(ann,fnu t,namx,1,namx,0.d0,dnnt,0.d0,0.05d0)
4462 1040 FORMAT (10f12.2)
4463  ENDIF
4464  RETURN
4465  END
4466 *-- Author :
4467 C
4468 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4469 C
4470  SUBROUTINE previo(RA,RB,NSTB,BMAX,BSTEP,SIG,RO,G)
4471  IMPLICIT DOUBLE PRECISION (a-h,o-z)
4472  SAVE
4473  COMPLEX*16 ca,ci
4474  common/damp/ca,ci,ga
4475 C WRITE(6,*)' PREVIO(RA,RB,NSTB,BMAX,BSTEP,SIG,RO,G)',
4476 C &RA,RB,NSTB,BMAX,BSTEP,SIG,RO,G
4477 C WRITE(6,*)' /CA,CI,GA/ ',CA,CI,GA
4478 C WRITE(6,*)' PREVIO: RA, RB = ',RA,RB
4479  bmax=4.*(ra+rb)
4480 C WRITE(6,*)' PREVIO(RA,RB,NSTB,BMAX,BSTEP,SIG,RO,G)',
4481 C &RA,RB,NSTB,BMAX,BSTEP,SIG,RO,G
4482 C WRITE(6,*)' /CA,CI,GA/ ',CA,CI,GA
4483 C WRITE(6,*)' PREVIO: RA, RB BMAX= ',RA,RB,BMAX
4484  bstep=bmax/(nstb-1)
4485 C WRITE(6,*)' PREVIO(RA,RB,NSTB,BMAX,BSTEP,SIG,RO,G)',
4486 C &RA,RB,NSTB,BMAX,BSTEP,SIG,RO,G
4487 C WRITE(6,*)' /CA,CI,GA/ ',CA,CI,GA
4488 C WRITE(6,*)' PREVIO: RA, RB ,BSTEP= ',RA,RB,BSTEP
4489  bstep=0.15d0
4490 C WRITE(6,*)' PREVIO(RA,RB,NSTB,BMAX,BSTEP,SIG,RO,G)',
4491 C &RA,RB,NSTB,BMAX,BSTEP,SIG,RO,G
4492 C WRITE(6,*)' /CA,CI,GA/ ',CA,CI,GA
4493 C WRITE(6,*)' PREVIO: RA, RB ,BSTEP= ',RA,RB,BSTEP
4494  ga=g
4495 C WRITE(6,*)' PREVIO(RA,RB,NSTB,BMAX,BSTEP,SIG,RO,G)',
4496 C &RA,RB,NSTB,BMAX,BSTEP,SIG,RO,G
4497 C WRITE(6,*)' /CA,CI,GA/ ',CA,CI,GA
4498 C WRITE(6,*)' PREVIO: RA, RB ,GA= ',RA,RB,GA
4499  rca=ga*sig/6.2831854
4500 C WRITE(6,*)' PREVIO(RA,RB,NSTB,BMAX,BSTEP,SIG,RO,G)',
4501 C &RA,RB,NSTB,BMAX,BSTEP,SIG,RO,G
4502 C WRITE(6,*)' /CA,CI,GA/ ',CA,CI,GA
4503 C WRITE(6,*)' PREVIO: RA, RB ,RCA= ',RA,RB,RCA
4504  fca=-ga*sig*ro/6.2831854
4505 C WRITE(6,*)' PREVIO(RA,RB,NSTB,BMAX,BSTEP,SIG,RO,G)',
4506 C &RA,RB,NSTB,BMAX,BSTEP,SIG,RO,G
4507 C WRITE(6,*)' /CA,CI,GA/ ',CA,CI,GA
4508 C WRITE(6,*)' PREVIO: RA, RB ,FCA= ',RA,RB,FCA
4509  ca=cmplx(rca,fca)
4510 C WRITE(6,*)' PREVIO(RA,RB,NSTB,BMAX,BSTEP,SIG,RO,G)',
4511 C &RA,RB,NSTB,BMAX,BSTEP,SIG,RO,G
4512 C WRITE(6,*)' /CA,CI,GA/ ',CA,CI,GA
4513 C WRITE(6,*)' PREVIO: RA, RB,CA = ',RA,RB,CA
4514  ci=(1.d0,0.d0)
4515  WRITE(6,*)' PREVIO(RA,RB,NSTB,BMAX,BSTEP,SIG,RO,G)',
4516  &ra,rb,nstb,bmax,bstep,sig,ro,g
4517  WRITE(6,*)' /CA,CI,GA/ ',ca,ci,ga
4518  WRITE(6,*)' PREVIO: RA, RB ,CI= ',ra,rb,ci
4519  RETURN
4520  END
4521 *-- Author :
4522 C
4523 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4524 C
4525  SUBROUTINE profb(BSTEP,NSTAT,NA,RA,NB,RB,BSITE,NSITEB)
4526  IMPLICIT DOUBLE PRECISION (a-h,o-z)
4527  SAVE
4528 C
4529 C THE PROGRAM CALCULATES THE PROFIL-FUNCTION AND FILLS
4530 C THE ARRAY BSITE TO APPROXIMATE THE B-DISTRIBUTION.
4531 C-------------------
4532  parameter(intmx=2488,intmd=252)
4533 *KEEP,DROPPT.
4534  LOGICAL intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada, ipadis,
4535  +ishmal,lpauli
4536  COMMON /droppt/ intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada,
4537  +ipadis,ishmal,lpauli
4538 *KEEP,NUCKOO.
4539  COMMON /nuckoo/ pkoo(3,intmx),tkoo(3,intmx),ppoo(3,intmx),
4540  +tpoo(3,intmx)
4541 *KEEP,DAMP.
4542 C COMPLEX*16 CA,CI
4543  DOUBLE COMPLEX ca,ci
4544  COMMON /damp/ ca,ci,ga
4545 *KEND.
4546  dimension bsite(0:1,nsiteb)
4547 C--------
4548  dimension helpp(200)
4549  dimension help(200)
4550  dimension bs(200)
4551  COMMON /sigla/siglau
4552 C COMPLEX*16 C
4553  DOUBLE COMPLEX c
4554  DATA irw /0/
4555 C--------
4556  WRITE(6,*)' PROFB: RA, RB = ',ra,rb
4557  WRITE(6, 1000)bstep,nstat,na,ra,nb,rb,irw,nsiteb
4558  1000 FORMAT (' PROFB',e15.5,2i10,f15.5,i10,e15.5,2i10)
4559  ns=nstat
4560  nsite=nsiteb-1
4561  bst=bstep
4562  DO 10 i=1,nsiteb
4563  bs(i)=0.
4564  10 CONTINUE
4565  DO 40 i=1,ns
4566  CALL conucl(tkoo,nb,rb)
4567 C CALL SORTIN(TKOO,NB)
4568  CALL conucl(pkoo,na,ra)
4569 C CALL SORT(PKOO,NA)
4570  DO 40 i3=1,nsite
4571  b=i3*bst
4572  pi=1.
4573  DO 30 i1=1,na
4574  x1=b-pkoo(1,i1)
4575  IF(pi.LT.1.d-100)go to 31
4576  x2=-pkoo(2,i1)
4577  DO 32 i2=1,nb
4578  q1=x1+tkoo(1,i2)
4579  q2=x2+tkoo(2,i2)
4580  xy=ga*(q1*q1+q2*q2)
4581 C
4582  IF(xy.GT.15.) go to 20
4583  e=exp(-xy)
4584  c=ci-ca*e
4585  ar=REAL(REAL(c))
4586  ai=imag(c)
4587  p=ar*ar+ai*ai
4588 C WRITE(6,'(A,5E13.3,3I6)')' PROFB:Pi,P,AR,AI,Ei,I3,I2,I1',
4589 C *PI,P,AR,AI,Ei,I3,I2,I1
4590  pi=pi*p
4591  20 CONTINUE
4592  32 CONTINUE
4593  31 CONTINUE
4594  30 CONTINUE
4595  bs(i3+1)=bs(i3+1)+1.-pi
4596  40 CONTINUE
4597  bs(1)=bs(2)
4598  sumb=0.
4599  DO 50 i=1,nsiteb
4600  helpp(i)=bs(i)/ns
4601  bs(i)=bs(i)*(i-1)*bst/ns
4602  sumb=sumb+bs(i)
4603  50 CONTINUE
4604  bsite(1,1)=0.
4605  DO 60 i=2,nsiteb
4606  bsite(1,i)=bs(i)/sumb+bsite(1,i-1)
4607  60 CONTINUE
4608  DO 70 i=1,nsiteb
4609  help(i)=i*bst
4610  70 CONTINUE
4611  sumb=sumb*bst*6.2831854
4612  siglau=sumb*10.
4613  WRITE(6,1020) sumb
4614  1020 FORMAT(/5x,7hsigma =,f7.3)
4615  IF(irw.GE.1) RETURN
4616  IF(ishmal) THEN
4617  DO 80 i=1,200
4618  WRITE (6,1030) help(i),helpp(i),bs(i),bsite(1,i)
4619  1030 FORMAT (f10.4,3e15.5)
4620  80 CONTINUE
4621  CALL plot(help,bsite,50,1,50,0.d0,0.5d0,0.d0,0.01d0)
4622  CALL plot(help,bs ,50,1,50,0.d0,0.5d0,0.d0,0.07d0)
4623  ENDIF
4624  RETURN
4625  END
4626 *-- Author :
4627 C
4628 C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4629 C
4630  SUBROUTINE dparje(IHAD,I)
4631  IMPLICIT DOUBLE PRECISION (a-h,o-z)
4632  SAVE
4633 *KEEP,DFINPA.
4634  CHARACTER*8 anf
4635  parameter(nfimax=249)
4636  COMMON /dfinpa/ anf(nfimax),pxf(nfimax),pyf(nfimax),pzf(nfimax),
4637  +hef(nfimax),amf(nfimax), ichf(nfimax),ibarf(nfimax),nref(nfimax)
4638  COMMON /dfinpz/iormo(nfimax),idaug1(nfimax),idaug2(nfimax),
4639  * istath(nfimax)
4640 *KEEP,DINPDA.
4641  COMMON /dinpda/ imps(6,6),imve(6,6),ib08(6,21),ib10(6,21), ia08
4642  +(6,21),ia10(6,21), a1,b1,b2,b3,lt,le,bet,as,b8,ame,diq,isu
4643 *KEEP,DPRIN.
4644  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
4645 *KEND.
4646  CHARACTER*8 aname
4647  COMMON /dpar/ aname(210),am(210),ga(210),tau(210), ich(210),ibar
4648  +(210),k1(210),k2(210)
4649  ihad=1
4650  nref(1)=i
4651  pxf(1)=0.
4652  pyf(1)=0.
4653  pzf(1)=0.
4654  hef(1)=am(i)
4655  amf(1)=am(i)
4656  ichf(1)=ich(i)
4657  ibarf(1)=ibar(i)
4658  anf(1)=aname(i)
4659  IF (ipco.GE.6)THEN
4660  WRITE(6,1000)ihad,i,pxf(1),pyf(1),pzf(1),hef(1),amf(1)
4661  1000 FORMAT(' PARJET: IHAD,I,PXF(1),PYF(1),PZF(1),HEP(1),AMF(1)'/ 2i5,5
4662  +f10.3)
4663  ENDIF
4664  RETURN
4665  END
4666 *-- Author :
4667 C
4668 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4669 C
4670  SUBROUTINE sort(A,N)
4671  IMPLICIT DOUBLE PRECISION (a-h,o-z)
4672  SAVE
4673  dimension a(3,n)
4674  m=n
4675  10 CONTINUE
4676  m=n-1
4677  IF(m.LE.0) RETURN
4678  l=0
4679  DO 20 i=1,m
4680  j=i+1
4681  IF (a(3,i).LE.a(3,j)) go to 20
4682  b=a(3,i)
4683  c=a(1,i)
4684  d=a(2,i)
4685  a(3,i)=a(3,j)
4686  a(2,i)=a(2,j)
4687  a(1,i)=a(1,j)
4688  a(3,j)=b
4689  a(1,j)=c
4690  a(2,j)=d
4691  l=1
4692  20 CONTINUE
4693  IF(l.EQ.1) go to 10
4694  RETURN
4695  END
4696 *-- Author :
4697 C
4698 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4699 C
4700  SUBROUTINE sortin(A,N)
4701  IMPLICIT DOUBLE PRECISION (a-h,o-z)
4702  SAVE
4703  dimension a(3,n)
4704  m=n
4705  10 CONTINUE
4706  m=n-1
4707  IF(m.LE.0) RETURN
4708  l=0
4709  DO 20 i=1,m
4710  j=i+1
4711  IF (a(3,i).GE.a(3,j)) go to 20
4712  b=a(3,i)
4713  c=a(1,i)
4714  d=a(2,i)
4715  a(3,i)=a(3,j)
4716  a(2,i)=a(2,j)
4717  a(1,i)=a(1,j)
4718  a(3,j)=b
4719  a(1,j)=c
4720  a(2,j)=d
4721  l=1
4722  20 CONTINUE
4723  IF(l.EQ.1) go to 10
4724  RETURN
4725  END
4726 *
4727 *=== blkdt6 ===========================================================*
4728 *== *
4729  BLOCK DATA blkd46
4730  IMPLICIT DOUBLE PRECISION (a-h,o-z)
4731  SAVE
4732 *$ CREATE DBLPRC.ADD
4733 *COPY DBLPRC
4734 * *
4735 *=== dblprc ==========================================================*
4736 * *
4737 *---------------------------------------------------------------------*
4738 * *
4739 * Dblprc: included in any routine *
4740 * *
4741 * !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
4742 * !!!! O N M A C H I N E S W H E R E T H E D O U B L E !!!! *
4743 * !!!! P R E C I S I O N I S N O T R E Q U I R E D R E -!!!! *
4744 * !!!! M O V E T H E D O U B L E P R E C I S I O N !!!! *
4745 * !!!! S T A T E M E N T, S E T K A L G N M = 1 A N D !!!! *
4746 * !!!! C H A N G E A L L N U M E R I C A L C O N S - !!!! *
4747 * !!!! T A N T S T O S I N G L E P R E C I S I O N !!!! *
4748 * !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
4749 * *
4750 * Kalgnm = real address alignment, 2 for double precision, *
4751 * 1 for single precision *
4752 * Anglgb = this parameter should be set equal to the machine *
4753 * "zero" with respect to unit *
4754 * Anglsq = this parameter should be set equal to the square *
4755 * of Anglgb *
4756 * Axcssv = this parameter should be set equal to the number *
4757 * for which unity is negligible for the machine *
4758 * accuracy *
4759 * Andrfl = "underflow" of the machine for floating point *
4760 * operation *
4761 * Avrflw = "overflow" of the machine for floating point *
4762 * operation *
4763 * Ainfnt = code "infinite" *
4764 * Azrzrz = code "zero" *
4765 * Einfnt = natural logarithm of the code "infinite" *
4766 * Ezrzrz = natural logarithm of the code "zero" *
4767 * Onemns = 1- of the machine, it is 1 - 2 x Anglgb *
4768 * Onepls = 1+ of the machine, it is 1 + 2 x Anglgb *
4769 * Csnnrm = maximum tolerable error on cosine normalization, *
4770 * u**2+v**2+w**2: assuming a typical anglgb relative *
4771 * error on each component we would get 2xanglgb: use *
4772 * 4xanglgb to avoid too many normalizations *
4773 * Dmxtrn = "infinite" distance for transport (cm) *
4774 * *
4775 *---------------------------------------------------------------------*
4776 * *
4777  parameter( kalgnm = 2 )
4778  parameter( anglgb = 5.0d-16 )
4779  parameter( anglsq = 2.5d-31 )
4780  parameter( axcssv = 0.2d+16 )
4781  parameter( andrfl = 1.0d-38 )
4782  parameter( avrflw = 1.0d+38 )
4783  parameter( ainfnt = 1.0d+30 )
4784  parameter( azrzrz = 1.0d-30 )
4785  parameter( einfnt = +69.07755278982137 d+00 )
4786  parameter( ezrzrz = -69.07755278982137 d+00 )
4787  parameter( onemns = 0.999999999999999 d+00 )
4788  parameter( onepls = 1.000000000000001 d+00 )
4789  parameter( csnnrm = 2.0d-15 )
4790  parameter( dmxtrn = 1.0d+08 )
4791 *
4792 *======================================================================*
4793 *======================================================================*
4794 *========= ==========*
4795 *========= M A T H E M A T I C A L C O N S T A N T S ==========*
4796 *========= ==========*
4797 *======================================================================*
4798 *======================================================================*
4799 * *
4800 * Numerical constants: *
4801 * *
4802 * Zerzer = 0 *
4803 * Oneone = 1 *
4804 * Twotwo = 2 *
4805 * Thrthr = 3 *
4806 * Foufou = 4 *
4807 * Fivfiv = 5 *
4808 * Sixsix = 6 *
4809 * Sevsev = 7 *
4810 * Eigeig = 8 *
4811 * Aninen = 9 *
4812 * Tenten = 10 *
4813 * Hlfhlf = 1/2 *
4814 * Onethi = 1/3 *
4815 * Twothi = 2/3 *
4816 * Pipipi = Circumference / diameter *
4817 * Eneper = "e", base of natural logarithm *
4818 * Sqrent = square root of "e" *
4819 * *
4820 *----------------------------------------------------------------------*
4821 *
4822  parameter( zerzer = 0.d+00 )
4823  parameter( oneone = 1.d+00 )
4824  parameter( twotwo = 2.d+00 )
4825  parameter( thrthr = 3.d+00 )
4826  parameter( foufou = 4.d+00 )
4827  parameter( fivfiv = 5.d+00 )
4828  parameter( sixsix = 6.d+00 )
4829  parameter( sevsev = 7.d+00 )
4830  parameter( eigeig = 8.d+00 )
4831  parameter( aninen = 9.d+00 )
4832  parameter( tenten = 10.d+00 )
4833  parameter( hlfhlf = 0.5d+00 )
4834  parameter( onethi = oneone / thrthr )
4835  parameter( twothi = twotwo / thrthr )
4836  parameter( pipipi = 3.1415926535897932270 d+00 )
4837  parameter( eneper = 2.7182818284590452354 d+00 )
4838  parameter( sqrent = 1.6487212707001281468 d+00 )
4839 *
4840 *======================================================================*
4841 *======================================================================*
4842 *========= ==========*
4843 *========= P H Y S I C A L C O N S T A N T S ==========*
4844 *========= ==========*
4845 *======================================================================*
4846 *======================================================================*
4847 * *
4848 * Primary constants: *
4849 * *
4850 * Clight = speed of light in cm s-1 *
4851 * Avogad = Avogadro number *
4852 * Amelgr = electron mass (g) *
4853 * Plckbr = reduced Planck constant (erg s) *
4854 * Elccgs = elementary charge (CGS unit) *
4855 * Elcmks = elementary charge (MKS unit) *
4856 * Amugrm = Atomic mass unit (g) *
4857 * Ammumu = Muon mass (amu) *
4858 * *
4859 * Derived constants: *
4860 * *
4861 * Alpfsc = Fine structure constant = e^2/(hbar c) *
4862 * Amelct = Electron mass (GeV) = 10^-16Amelgr Clight^2 / Elcmks*
4863 * Amugev = Atomic mass unit (GeV) = 10^-16Amelgr Clight^2 *
4864 * / Elcmks *
4865 * Ammuon = Muon mass (GeV) = Ammumu * Amugev *
4866 * Fscto2 = (Fine structure constant)^2 *
4867 * Fscto3 = (Fine structure constant)^3 *
4868 * Fscto4 = (Fine structure constant)^4 *
4869 * Plabrc = Reduced Planck constant times the light velocity *
4870 * expressed in GeV fm *
4871 * Rclsel = Classical electron radius (cm) = e^2 / (m_e c^2) *
4872 * Conversion constants: *
4873 * GeVMeV = from GeV to MeV *
4874 * eMVGeV = from MeV to GeV *
4875 * Raddeg = from radians to degrees *
4876 * Degrad = from degrees to radians *
4877 * *
4878 *----------------------------------------------------------------------*
4879 *
4880  parameter( clight = 2.99792458 d+10 )
4881  parameter( avogad = 6.0221367 d+23 )
4882  parameter( amelgr = 9.1093897 d-28 )
4883  parameter( plckbr = 1.05457266 d-27 )
4884  parameter( elccgs = 4.8032068 d-10 )
4885  parameter( elcmks = 1.60217733 d-19 )
4886  parameter( amugrm = 1.6605402 d-24 )
4887  parameter( ammumu = 0.113428913 d+00 )
4888 * PARAMETER ( ALPFSC = 1.D+00 / 137.035989561D+00 )
4889 * PARAMETER ( FSCTO2 = ALPFSC * ALPFSC )
4890 * PARAMETER ( FSCTO3 = FSCTO2 * ALPFSC )
4891 * PARAMETER ( FSCTO4 = FSCTO3 * ALPFSC )
4892 * It is important to set the electron mass exactly with the same
4893 * rounding as in the mass tables, so use the explicit expression
4894 * PARAMETER ( AMELCT = 1.D-16 * AMELGR * CLIGHT * CLIGHT / ELCMKS )
4895 * It is important to set the amu mass exactly with the same
4896 * rounding as in the mass tables, so use the explicit expression
4897 * PARAMETER ( AMUGEV = 1.D-16 * AMUGRM * CLIGHT * CLIGHT / ELCMKS )
4898 * It is important to set the muon mass exactly with the same
4899 * rounding as in the mass tables, so use the explicit expression
4900 * PARAMETER ( AMMUON = AMMUMU * AMUGEV ELCMKS )
4901 * PARAMETER ( RCLSEL = ELCCGS * ELCCGS / CLIGHT / CLIGHT / AMELGR )
4902  parameter( alpfsc = 7.2973530791728595 d-03 )
4903  parameter( fscto2 = 5.3251361962113614 d-05 )
4904  parameter( fscto3 = 3.8859399018437826 d-07 )
4905  parameter( fscto4 = 2.8357075508200407 d-09 )
4906  parameter( plabrc = 0.197327053 d+00 )
4907  parameter( amelct = 0.51099906 d-03 )
4908  parameter( amugev = 0.93149432 d+00 )
4909  parameter( ammuon = 0.105658389 d+00 )
4910  parameter( rclsel = 2.8179409183694872 d-13 )
4911  parameter( gevmev = 1.0 d+03 )
4912  parameter( emvgev = 1.0 d-03 )
4913  parameter( raddeg = 180.d+00 / pipipi )
4914  parameter( degrad = pipipi / 180.d+00 )
4915 
4916 *$ CREATE IOUNIT.ADD
4917 *COPY IOUNIT
4918 * *
4919 *=== iounit ==========================================================*
4920 * *
4921 *---------------------------------------------------------------------*
4922 * *
4923 * Iounit: included in any routine *
4924 * *
4925 * lunin = standard input unit *
4926 * lunout = standard output unit *
4927 * lunerr = standard error unit *
4928 * lunber = input file for bertini nuclear data *
4929 * lunech = echo file for pegs dat *
4930 * lunflu = input file for photoelectric edges and X-ray fluo- *
4931 * rescence data *
4932 * lungeo = scratch file for combinatorial geometry *
4933 * lunpgs = input file for pegs material data *
4934 * lunran = output file for the final random number seed *
4935 * lunxsc = input file for low energy neutron cross sections *
4936 * lunrdb = unit number for reading (extra) auxiliary external *
4937 * files to be closed just after reading *
4938 * *
4939 *---------------------------------------------------------------------*
4940 * *
4941  parameter( lunin = 5 )
4942  parameter( lunout = 6 )
4943  parameter( lunerr = 66 )
4944  parameter( lunber = 14 )
4945  parameter( lunech = 8 )
4946  parameter( lunflu = 86 )
4947  parameter( lungeo = 16 )
4948  parameter( lunpgs = 12 )
4949  parameter( lunran = 2 )
4950  parameter( lunxsc = 81 )
4951  parameter( lunrdb = 1 )
4952 
4953 *$ CREATE DIMPAR.ADD
4954 *COPY DIMPAR
4955 * *
4956 *=== dimpar ==========================================================*
4957 * *
4958 *---------------------------------------------------------------------*
4959 * *
4960 * DIMPAR: included in any routine *
4961 * *
4962 * Mxxrgn = maximum number of regions *
4963 * Mxxmdf = maximum number of media in Fluka *
4964 * Mxxmde = maximum number of media in Emf *
4965 * Mfstck = stack dimension in Fluka *
4966 * Mestck = stack dimension in Emf *
4967 * Nallwp = number of allowed particles *
4968 * Mpdpdx = number of particle types for which EM dE/dx pro- *
4969 * cesses (ion,pair,bremss) have to be computed *
4970 * Icomax = maximum number of materials for compounds (equal *
4971 * to the sum of the number of materials for every *
4972 * compound ) *
4973 * Nstbis = number of stable isotopes recorded in common iso- *
4974 * top *
4975 * Idmaxp = number of particles/resonances defined in common *
4976 * part *
4977 * *
4978 *---------------------------------------------------------------------*
4979 * *
4980  parameter( mxxrgn = 500 )
4981  parameter( mxxmdf = 56 )
4982  parameter( mxxmde = 50 )
4983  parameter( mfstck = 1000 )
4984  parameter( mestck = 100 )
4985  parameter( nallwp = 39 )
4986  parameter( mpdpdx = 8 )
4987  parameter( icomax = 180 )
4988  parameter( nstbis = 304 )
4989  parameter( idmaxp = 210 )
4990 
4991 
4992  CHARACTER*8 aname
4993  COMMON /dpar/ aname(210),am(210),ga(210),tau(210),
4994  + ich(210),ibar(210),k1(210),k2(210)
4995 * / Part /
4996 * datas datas datas datas datas *
4997 * --------------------------------------------- *
4998 *
4999 *
5000 * Particle masses Engel version JETSET compatible *
5001 * *
5002  DATA (am(k),k=1,85) /
5003  & .9383d+00, .9383d+00, amelct , amelct , .0000d+00,
5004  & .0000d+00, .0000d+00, .9396d+00, .9396d+00, ammuon ,
5005  & ammuon , .4977d+00, .1396d+00, .1396d+00, .4936d+00,
5006  & .4936d+00, .1116d+01, .1116d+01, .4977d+00, .1197d+01,
5007  & .1189d+01, .1193d+01, .1350d+00, .4977d+00, .4977d+00,
5008  & .0000d+00, .0000d+00, .0000d+00, .0000d+00, .0000d+00,
5009  & .5488d+00, .7669d+00, .7700d+00, .7669d+00, .7820d+00,
5010  & .8921d+00, .8962d+00, .8921d+00, .8962d+00, .1300d+01,
5011  & .1300d+01, .1300d+01, .1300d+01, .1421d+01, .1421d+01,
5012  & .1421d+01, .1421d+01, .1383d+01, .1384d+01, .1387d+01,
5013  & .1820d+01, .2030d+01, .1231d+01, .1232d+01, .1233d+01,
5014  & .1234d+01, .1675d+01, .1675d+01, .1675d+01, .1675d+01,
5015  & .1500d+01, .1500d+01, .1515d+01, .1515d+01, .1775d+01,
5016  & .1775d+01, .1231d+01, .1232d+01, .1233d+01, .1234d+01,
5017  & .1675d+01, .1675d+01, .1675d+01, .1675d+01, .1515d+01,
5018  & .1515d+01, .2500d+01, .4890d+00, .4890d+00, .4890d+00,
5019  & .1300d+01, .1300d+01, .1300d+01, .1300d+01, .2200d+01 /
5020  DATA (am(k),k=86,183) /
5021  & .2200d+01, .2200d+01, .2200d+01, .1700d+01, .1700d+01,
5022  & .1700d+01, .1700d+01, .1820d+01, .2030d+01, .9575d+00,
5023  & .1019d+01, .1315d+01, .1321d+01, .1189d+01, .1193d+01,
5024  & .1197d+01, .1315d+01, .1321d+01, .1383d+01, .1384d+01,
5025  & .1387d+01, .1532d+01, .1535d+01, .1672d+01, .1383d+01,
5026  & .1384d+01, .1387d+01, .1532d+01, .1535d+01, .1672d+01,
5027  & .1865d+01, .1869d+01, .1869d+01, .1865d+01, .1969d+01,
5028  & .1969d+01, .2980d+01, .2007d+01, .2010d+01, .2010d+01,
5029  & .2007d+01, .2113d+01, .2113d+01, .3686d+01, .3097d+01,
5030  & .1777d+01, .1777d+01, .0000d+00, .0000d+00, .0000d+00,
5031  & .0000d+00, .2285d+01, .2460d+01, .2460d+01, .2452d+01,
5032  & .2453d+01, .2454d+01, .2560d+01, .2560d+01, .2730d+01,
5033  & .3610d+01, .3610d+01, .3790d+01, .2285d+01, .2460d+01,
5034  & .2460d+01, .2452d+01, .2453d+01, .2454d+01, .2560d+01,
5035  & .2560d+01, .2730d+01, .3610d+01, .3610d+01, .3790d+01,
5036  & .2490d+01, .2490d+01, .2490d+01, .2610d+01, .2610d+01,
5037  & .2770d+01, .3670d+01, .3670d+01, .3850d+01, .4890d+01,
5038  & .2490d+01, .2490d+01, .2490d+01, .2610d+01, .2610d+01,
5039  & .2770d+01, .3670d+01, .3670d+01, .3850d+01, .4890d+01,
5040  & .1250d+01, .1250d+01, .1250d+01 /
5041  DATA ( am( i ), i = 184,210 ) /
5042  & 1.44000000000000d+00, 1.44000000000000d+00, 1.30000000000000d+00,
5043  & 1.30000000000000d+00, 1.30000000000000d+00, 1.40000000000000d+00,
5044  & 1.46000000000000d+00, 1.46000000000000d+00, 1.46000000000000d+00,
5045  & 1.46000000000000d+00, 1.60000000000000d+00, 1.60000000000000d+00,
5046  & 1.66000000000000d+00, 1.66000000000000d+00, 1.66000000000000d+00,
5047  & 1.66000000000000d+00, 1.66000000000000d+00, 1.66000000000000d+00,
5048  & 1.95000000000000d+00, 1.95000000000000d+00, 1.95000000000000d+00,
5049  & 1.95000000000000d+00, 2.25000000000000d+00, 2.25000000000000d+00,
5050  & 1.44000000000000d+00, 1.44000000000000d+00, 0.00000000000000d+00/
5051 * *
5052 * Particle mean lives *
5053 * *
5054  DATA (tau(k),k=1,183) /
5055  & .1000d+19, .1000d+19, .1000d+19, .1000d+19, .1000d+19,
5056  & .1000d+19, .1000d+19, .9180d+03, .9180d+03, .2200d-05,
5057  & .2200d-05, .5200d-07, .2600d-07, .2600d-07, .1200d-07,
5058  & .1200d-07, .2600d-09, .2600d-09, .9000d-10, .1500d-09,
5059  & .8000d-10, .5000d-14, .8000d-16, .0000d+00, .0000d+00,
5060  & 70*.0000d+00,
5061  & .0000d+00, .3000d-09, .1700d-09, .8000d-10, .1000d-13,
5062  & .1500d-09, .3000d-09, .1700d-09, .0000d+00, .0000d+00,
5063  & .0000d+00, .0000d+00, .0000d+00, .1000d-09, .0000d+00,
5064  & .0000d+00, .0000d+00, .0000d+00, .0000d+00, .1000d-09,
5065  & .0000d+00, .0000d+00, .0000d+00, .0000d+00, .0000d+00,
5066  & .0000d+00, .0000d+00, .0000d+00, .0000d+00, .0000d+00,
5067  & .0000d+00, .0000d+00, .0000d+00, .0000d+00, .0000d+00,
5068  & .9000d-11, .9000d-11, .9000d-11, .9000d-11, .1000d+19,
5069  & .1000d+19, .0000d+00, .0000d+00, .0000d+00, .0000d+00,
5070  & 40*.0000d+00,
5071  & .0000d+00, .0000d+00, .0000d+00 /
5072  DATA ( tau( i ), i = 184,210 ) /
5073  & 0.00000000000000d+00, 0.00000000000000d+00, 0.00000000000000d+00,
5074  & 0.00000000000000d+00, 0.00000000000000d+00, 0.00000000000000d+00,
5075  & 0.00000000000000d+00, 0.00000000000000d+00, 0.00000000000000d+00,
5076  & 0.00000000000000d+00, 0.00000000000000d+00, 0.00000000000000d+00,
5077  & 0.00000000000000d+00, 0.00000000000000d+00, 0.00000000000000d+00,
5078  & 0.00000000000000d+00, 0.00000000000000d+00, 0.00000000000000d+00,
5079  & 0.00000000000000d+00, 0.00000000000000d+00, 0.00000000000000d+00,
5080  & 0.00000000000000d+00, 0.00000000000000d+00, 0.00000000000000d+00,
5081  & 0.00000000000000d+00, 0.00000000000000d+00, 0.00000000000000d+00/
5082 * *
5083 * Resonance width Gamma in GeV *
5084 * *
5085  DATA (ga(k),k= 1,85) /
5086  & 30*.0000d+00,
5087  & .8500d-06, .1520d+00, .1520d+00, .1520d+00, .1000d-01,
5088  & .7900d-01, .7900d-01, .7900d-01, .7900d-01, .4500d+00,
5089  & .4500d+00, .4500d+00, .4500d+00, .1080d+00, .1080d+00,
5090  & .1080d+00, .1080d+00, .5000d-01, .5000d-01, .5000d-01,
5091  & .8500d-01, .1800d+00, .1150d+00, .1150d+00, .1150d+00,
5092  & .1150d+00, .2000d+00, .2000d+00, .2000d+00, .2000d+00,
5093  & .2000d+00, .2000d+00, .1000d+00, .1000d+00, .2000d+00,
5094  & .2000d+00, .1150d+00, .1150d+00, .1150d+00, .1150d+00,
5095  & .2000d+00, .2000d+00, .2000d+00, .2000d+00, .1000d+00,
5096  & .1000d+00, .2000d+00, .1000d+00, .1000d+00, .1000d+00,
5097  & .1000d+00, .1000d+00, .1000d+00, .1000d+00, .2000d+00 /
5098  DATA (ga(k),k= 86,183) /
5099  & .2000d+00, .2000d+00, .2000d+00, .1500d+00, .1500d+00,
5100  & .1500d+00, .1500d+00, .8500d-01, .1800d+00, .2000d-02,
5101  & .4000d-02, .0000d+00, .0000d+00, .0000d+00, .0000d+00,
5102  & .0000d+00, .0000d+00, .0000d+00, .3400d-01, .3400d-01,
5103  & .3600d-01, .9000d-02, .9000d-02, .0000d+00, .3400d-01,
5104  & .3400d-01, .3600d-01, .9000d-02, .9000d-02, .0000d+00,
5105  & .0000d+00, .0000d+00, .0000d+00, .0000d+00, .0000d+00,
5106  & .0000d+00, .0000d+00, .5000d-02, .2000d-02, .2000d-02,
5107  & .5000d-02, .2000d-02, .2000d-02, .2000d-03, .7000d-03,
5108  & 50*.0000d+00,
5109  & .3000d+00, .3000d+00, .3000d+00 /
5110  DATA ( ga( i ), i = 184,210 ) /
5111  & 2.00000000000000d-01, 2.00000000000000d-01, 3.00000000000000d-01,
5112  & 3.00000000000000d-01, 3.00000000000000d-01, 2.70000000000000d-01,
5113  & 2.50000000000000d-01, 2.50000000000000d-01, 2.50000000000000d-01,
5114  & 2.50000000000000d-01, 1.50000000000000d-01, 1.50000000000000d-01,
5115  & 1.00000000000000d-01, 1.00000000000000d-01, 1.00000000000000d-01,
5116  & 1.00000000000000d-01, 1.00000000000000d-01, 1.00000000000000d-01,
5117  & 6.00000000000000d-02, 6.00000000000000d-02, 6.00000000000000d-02,
5118  & 6.00000000000000d-02, 5.50000000000000d-02, 5.50000000000000d-02,
5119  & 2.00000000000000d-01, 2.00000000000000d-01, 0.00000000000000d+00/
5120 * *
5121 * Particle names *
5122 * *
5123 * S+1385+Sigma+(1385) L02030+Lambda0(2030) *
5124 * Rho77=Rho(770) Om783=Omega(783) K*14=K*(1420) and so on *
5125 * designation N*@@ means N*@1(@2) *
5126 * *
5127 * *
5128  DATA (aname(k),k=1,85) /
5129  & 'P ','AP ','E- ','E+ ','NUE ',
5130  & 'ANUE ','GAM ','NEU ','ANEU ','MUE+ ',
5131  & 'MUE- ','K0L ','PI+ ','PI- ','K+ ',
5132  & 'K- ','LAM ','ALAM ','K0S ','SIGM- ',
5133  & 'SIGM+ ','SIGM0 ','PI0 ','K0 ','AK0 ',
5134  & 'BLANK ','BLANK ','BLANK ','BLANK ','BLANK ',
5135  & 'ETA550 ','RHO+77 ','RHO077 ','RHO-77 ','OM0783 ',
5136  & 'K*+892 ','K*0892 ','K*-892 ','AK*089 ','KA+125 ',
5137  & 'KA0125 ','KA-125 ','AKA012 ','K*+142 ','K*0142 ',
5138  & 'K*-142 ','AK*014 ','S+1385 ','S01385 ','S-1385 ',
5139  & 'L01820 ','L02030 ','N*++12 ','N*+ 12 ','N*012 ',
5140  & 'N*-12 ','N*++16 ','N*+16 ','N*016 ','N*-16 ',
5141  & 'N*+14 ','N*014 ','N*+15 ','N*015 ','N*+18 ',
5142  & 'N*018 ','AN--12 ','AN*-12 ','AN*012 ','AN*+12 ',
5143  & 'AN--16 ','AN*-16 ','AN*016 ','AN*+16 ','AN*-15 ',
5144  & 'AN*015 ','DE*=24 ','RPI+49 ','RPI049 ','RPI-49 ',
5145  & 'PIN++ ','PIN+0 ','PIN+- ','PIN-0 ','PPPI ' /
5146  DATA (aname(k),k=86,183) /
5147  & 'PNPI ','APPPI ','APNPI ','K+PPI ','K-PPI ',
5148  & 'K+NPI ','K-NPI ','S+1820 ','S-2030 ','ETA* ',
5149  & 'PHI ','TETA0 ','TETA- ','ASIG- ','ASIG0 ',
5150  & 'ASIG+ ','ATETA0 ','ATETA+ ','SIG*+ ','SIG*0 ',
5151  & 'SIG*- ','TETA*0 ','TETA* ','OMEGA- ','ASIG*- ',
5152  & 'ASIG*0 ','ASIG*+ ','ATET*0 ','ATET*+ ','OMEGA+ ',
5153  & 'D0 ','D+ ','D- ','AD0 ','DS+ ',
5154  & 'DS- ','ETAC ','D*0 ','D*+ ','D*- ',
5155  & 'AD*0 ','DS*+ ','DS*- ','CHI1C ','JPSI ',
5156  & 'TAU+ ','TAU- ','NUET ','ANUET ','NUEM ',
5157  & 'ANUEM ','LAMC+ ','XIC+ ','XIC0 ','SIGC++ ',
5158  & 'SIGC+ ','SIGC0 ','S+ ','S0 ','T0 ',
5159  & 'XU++ ','XD+ ','XS+ ','ALAMC- ','AXIC- ',
5160  & 'AXIC0 ','ASIGC-- ','ASIGC- ','ASIGC0 ','AS- ',
5161  & 'AS0 ','AT0 ','AXU-- ','AXD- ','AXS ',
5162  & 'C1*++ ','C1*+ ','C1*0 ','S*+ ','S*0 ',
5163  & 'T*0 ','XU*++ ','XD*+ ','XS*+ ','TETA++ ',
5164  & 'AC1*-- ','AC1*- ','AC1*0 ','AS*- ','AS*0 ',
5165  & 'AT*0 ','AXU*-- ','AXD*- ','AXS*- ','ATET-- ',
5166  & 'RO ','R+ ','R- ' /
5167  DATA ( aname( i ), i = 184,210 ) /
5168  &'AN*-14 ','AN*014 ','PI+130 ','PI0130 ','PI-130 ','F01400 ',
5169  &'K*+146 ','K*-146 ','K*0146 ','AK0146 ','L01600 ','AL0160 ',
5170  &'S+1660 ','S01660 ','S-1660 ','AS-166 ','AS0166 ','AS+166 ',
5171  &'X01950 ','X-1950 ','AX0195 ','AX+195 ','OM-225 ','AOM+22 ',
5172  &'N*+14 ','N*014 ','BLANK '/
5173 * *
5174 * Charge of particles and resonances *
5175 * *
5176  DATA ( ich( i ), i = 1,210 ) /
5177  & 1, -1, -1, 1, 0, 0, 0, 0, 0, 1, -1, 0, 1, -1, 1,
5178  & -1, 0, 0, 0, -1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
5179  & 0, 1, 0, -1, 0, 1, 0, -1, 0, 1, 0, -1, 0, 1, 0,
5180  & -1, 0, 1, 0, -1, 0, 0, 2, 1, 0, -1, 2, 1, 0, -1,
5181  & 1, 0, 1, 0, 1, 0, -2, -1, 0, 1, -2, -1, 0, 1, -1,
5182  & 0, 1, 1, 0, -1, 2, 1, 0, -1, 2, 1, 0, -1, 2, 0,
5183  & 1, -1, 1, -1, 0, 0, 0, -1, -1, 0, 1, 0, 1, 1, 0,
5184  & -1, 0, -1, -1, -1, 0, 1, 0, 1, 1, 0, 1, -1, 0, 1,
5185  & -1, 0, 0, 1, -1, 0, 1, -1, 0, 0, 1, -1, 0, 0, 0,
5186  & 0, 1, 1, 0, 2, 1, 0, 1, 0, 0, 2, 1, 1, -1, -1,
5187  & 0, -2, -1, 0, -1, 0, 0, -2, -1, -1, 2, 1, 0, 1, 0,
5188  & 0, 2, 1, 1, 2, -2, -1, 0, -1, 0, 0, -2, -1, -1, -2,
5189  & 0, 1, -1, -1, 0, 1, 0, -1, 0, 1, -1, 0, 0, 0, 0,
5190  & 1, 0, -1, -1, 0, 1, 0, -1, 0, 1, -1, 1, 1, 0, 0/
5191 * *
5192 * Particle baryonic charges *
5193 * *
5194  DATA ( ibar( i ), i = 1,210 ) /
5195  & 1, -1, 0, 0, 0, 0, 0, 1, -1, 0, 0, 0, 0, 0, 0,
5196  & 0, 1, -1, 0, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0,
5197  & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
5198  & 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
5199  & 1, 1, 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
5200  & -1, 2, 0, 0, 0, 1, 1, 1, 1, 2, 2, 0, 0, 1, 1,
5201  & 1, 1, 1, 1, 0, 0, 1, 1, -1, -1, -1, -1, -1, 1, 1,
5202  & 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, 0, 0, 0, 0, 0,
5203  & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
5204  & 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, -1, -1,
5205  & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 1, 1, 1, 1, 1,
5206  & 1, 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
5207  & 0, 0, 0, -1, -1, 0, 0, 0, 0, 0, 0, 0, 0, 1, -1,
5208  & 1, 1, 1, -1, -1, -1, 1, 1, -1, -1, 1, -1, 1, 1, 0/
5209 * *
5210 * First number of decay channels used for resonances *
5211 * and decaying particles *
5212 * *
5213  DATA k1/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 16, 17,
5214  & 18, 24, 30, 34, 38, 40, 41, 43, 44, 136, 138, 330, 327, 328,
5215  & 2*330, 46, 51, 52, 54, 55, 58,
5216  & 60, 62, 64, 66, 68, 70, 72, 74, 82, 90, 98, 106, 109, 112, 114,
5217  & 123, 140, 141, 143, 145, 146, 150, 157, 164, 168, 174, 180, 187,
5218  & 194, 202, 210, 211, 213, 215, 216, 220, 227, 234, 238, 245, 252,
5219  & 254, 255, 256, 257, 259, 262, 265, 267, 269, 272, 276, 279, 282,
5220  & 286, 290, 293, 299, 331, 335, 339, 340, 341, 343, 344, 345, 346,
5221  & 347, 350, 353, 356, 358, 360, 363, 366, 369, 372, 374, 376, 379,
5222  & 383, 385, 387, 391, 394, 397, 400, 402, 405, 408, 410, 412, 414,
5223  & 417, 420, 425, 430, 431, 432, 433, 434, 448, 452, 457, 458, 459,
5224  & 460, 461, 462, 466, 468, 470, 472, 486, 490, 495, 496, 497, 498,
5225  & 499, 500, 504, 506, 508, 510, 511, 512, 513, 514, 515, 516, 517,
5226  & 518, 519, 522, 523, 524, 525, 526, 527, 528, 529, 530, 531, 534,
5227  & 537, 539, 541, 547, 553, 558, 563, 568, 572, 573, 574, 575, 576,
5228  & 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588, 589,
5229  & 590, 596, 602 /
5230 * *
5231 * Last number of decay channels used for resonances *
5232 * and decaying particles *
5233 * *
5234  DATA k2/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 15, 16, 17,
5235  & 23, 29, 31, 35, 39, 40, 42, 43, 45, 137, 139, 330, 327, 328,
5236  & 2* 330, 50, 51, 53, 54, 57,
5237  & 59, 61, 63, 65, 67, 69, 71, 73, 81, 89, 97, 105, 108, 111, 113,
5238  & 122, 135, 140, 142, 144, 145, 149, 156, 163, 167, 173, 179, 186,
5239  & 193, 201, 209, 210, 212, 214, 215, 219, 226, 233, 237, 244, 251,
5240  & 253, 254, 255, 256, 258, 261, 264, 266, 268, 271, 275, 278, 281,
5241  & 285, 289, 292, 298, 307, 334, 338, 339, 340, 342, 343, 344, 345,
5242  & 346, 349, 352, 355, 357, 359, 362, 365, 368, 371, 373, 375, 378,
5243  & 382, 384, 386, 390, 393, 396, 399, 401, 404, 407, 409, 411, 413,
5244  & 416, 419, 424, 429, 430, 431, 432, 433, 447, 451, 456, 457, 458,
5245  & 459, 460, 461, 465, 467, 469, 471, 485, 489, 494, 495, 496, 497,
5246  & 498, 499, 503, 505, 507, 509, 510, 511, 512, 513, 514, 515, 516,
5247  & 517, 518, 521, 522, 523, 524, 525, 526, 527, 528, 529, 530, 533,
5248  & 536, 538, 540, 546, 552, 557, 562, 567, 571, 572, 573, 574, 575,
5249  & 576, 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588,
5250  & 589, 595, 601, 602 /
5251 * *
5252 *
5253  END
5254 *
5255 
5256 *=== blkdt7 ===========================================================*
5257 *== *
5258  BLOCK DATA blkd47
5259  IMPLICIT DOUBLE PRECISION (a-h,o-z)
5260  SAVE
5261 * * Block data 7 (ex 2) *
5262 C INCLUDE '(DECAYC)'
5263 C***********************************************************************
5264  parameter(idmax9=602)
5265  CHARACTER*8 zkname
5266  common/ddecac/ zkname(idmax9),wt(idmax9),nzk(idmax9,3)
5267 
5268 
5269 * *
5270 * Name of decay channel *
5271 * *
5272 * *
5273 * Designation N*@ means N*@1(1236) *
5274 * @1=# means ++, @1 = = means -- *
5275 * Designation P+/0/- means Pi+/Pi0/Pi- , respectively *
5276 * *
5277  DATA (zkname(k),k= 1, 85) /
5278  & 'P ','AP ','E- ','E+ ','NUE ',
5279  & 'ANUE ','GAM ','PE-NUE ','APEANU ','EANUNU ',
5280  & 'E-NUAN ','3PI0 ','PI+-0 ','PIMUNU ','PIE-NU ',
5281  & 'MU+NUE ','MU-NUE ','MU+NUE ','PI+PI0 ','PI++- ',
5282  & 'PI+00 ','M+P0NU ','E+P0NU ','MU-NU ','PI-0 ',
5283  & 'PI+-- ','PI-00 ','M-P0NU ','E-P0NU ','PPI- ',
5284  & 'NPI0 ','PD-NUE ','PM-NUE ','APPI+ ','ANPI0 ',
5285  & 'APE+NU ','APM+NU ','PI+PI- ','PI0PI0 ','NPI- ',
5286  & 'PPI0 ','NPI+ ','LAGA ','GAGA ','GAE+E- ',
5287  & 'GAGA ','GAGAP0 ','PI000 ','PI+-0 ','PI+-GA ',
5288  & 'PI+0 ','PI+- ','PI00 ','PI-0 ','PI+-0 ',
5289  & 'PI+- ','PI0GA ','K+PI0 ','K0PI+ ','KOPI0 ',
5290  & 'K+PI- ','K-PI0 ','AK0PI- ','AK0PI0 ','K-PI+ ',
5291  & 'K+PI0 ','K0PI+ ','K0PI0 ','K+PI- ','K-PI0 ',
5292  & 'K0PI- ','AK0PI0 ','K-PI+ ','K+PI0 ','K0PI+ ',
5293  & 'K+89P0 ','K08PI+ ','K+RO77 ','K0RO+7 ','K+OM07 ',
5294  & 'K+E055 ','K0PI0 ','K+PI+ ','K089P0 ','K+8PI- ' /
5295  DATA (zkname(k),k= 86,170) /
5296  & 'K0R077 ','K+R-77 ','K+R-77 ','K0OM07 ','K0E055 ',
5297  & 'K-PI0 ','K0PI- ','K-89P0 ','AK08P- ','K-R077 ',
5298  & 'AK0R-7 ','K-OM07 ','K-E055 ','AK0PI0 ','K-PI+ ',
5299  & 'AK08P0 ','K-8PI+ ','AK0R07 ','AK0OM7 ','AK0E05 ',
5300  & 'LA0PI+ ','SI0PI+ ','SI+PI0 ','LA0PI0 ','SI+PI- ',
5301  & 'SI-PI+ ','LA0PI- ','SI0PI- ','NEUAK0 ','PK- ',
5302  & 'SI+PI- ','SI0PI0 ','SI-PI+ ','LA0ET0 ','S+1PI- ',
5303  & 'S-1PI+ ','SO1PI0 ','NEUAK0 ','PK- ','LA0PI0 ',
5304  & 'LA0OM0 ','LA0RO0 ','SI+RO- ','SI-RO+ ','SI0RO0 ',
5305  & 'LA0ET0 ','SI0ET0 ','SI+PI- ','SI-PI+ ','SI0PI0 ',
5306  & 'K0S ','K0L ','K0S ','K0L ','P PI+ ',
5307  & 'P PI0 ','N PI+ ','P PI- ','N PI0 ','N PI- ',
5308  & 'P PI+ ','N*#PI0 ','N*+PI+ ','PRHO+ ','P PI0 ',
5309  & 'N PI+ ','N*#PI- ','N*+PI0 ','N*0PI+ ','PRHO0 ',
5310  & 'NRHO+ ','P PI- ','N PI0 ','N*+PI- ','N*0PI0 ',
5311  & 'N*-PI+ ','PRHO- ','NRHO0 ','N PI- ','N*0PI- ',
5312  & 'N*-PI0 ','NRHO- ','PETA0 ','N*#PI- ','N*+PI0 ' /
5313  DATA (zkname(k),k=171,255) /
5314  & 'N*0PI+ ','PRHO0 ','NRHO+ ','NETA0 ','N*+PI- ',
5315  & 'N*0PI0 ','N*-PI+ ','PRHO- ','NRHO0 ','P PI0 ',
5316  & 'N PI+ ','N*#PI- ','N*+PI0 ','N*0PI+ ','PRHO0 ',
5317  & 'NRHO+ ','P PI- ','N PI0 ','N*+PI- ','N*0PI0 ',
5318  & 'N*-PI+ ','PRHO- ','NRHO0 ','P PI0 ','N PI+ ',
5319  & 'PRHO0 ','NRHO+ ','LAMK+ ','S+ K0 ','S0 K+ ',
5320  & 'PETA0 ','P PI- ','N PI0 ','PRHO- ','NRHO0 ',
5321  & 'LAMK0 ','S0 K0 ','S- K+ ','NETA/ ','APPI- ',
5322  & 'APPI0 ','ANPI- ','APPI+ ','ANPI0 ','ANPI+ ',
5323  & 'APPI- ','AN*=P0 ','AN*-P- ','APRHO- ','APPI0 ',
5324  & 'ANPI- ','AN*=P+ ','AN*-P0 ','AN*0P- ','APRHO0 ',
5325  & 'ANRHO- ','APPI+ ','ANPI0 ','AN*-P+ ','AN*0P0 ',
5326  & 'AN*+P- ','APRHO+ ','ANRHO0 ','ANPI+ ','AN*0P+ ',
5327  & 'AN*+P0 ','ANRHO+ ','APPI0 ','ANPI- ','AN*=P+ ',
5328  & 'AN*-P0 ','AN*0P- ','APRHO0 ','ANRHO- ','APPI+, ',
5329  & 'ANPI0 ','AN*-P+ ','AN*0P0 ','AN*+P- ','APRHO+ ',
5330  & 'ANRHO0 ','PN*014 ','NN*=14 ','PI+0 ','PI+- ' /
5331  DATA (zkname(k),k=256,340) /
5332  & 'PI-0 ','P+0 ','N++ ','P+- ','P00 ',
5333  & 'N+0 ','N+- ','N00 ','P-0 ','N-0 ',
5334  & 'P-- ','PPPI0 ','PNPI+ ','PNPI0 ','PPPI- ',
5335  & 'NNPI+ ','APPPI0 ','APNPI+ ','ANNPI0 ','ANPPI- ',
5336  & 'APNPI0 ','APPPI- ','ANNPI- ','K+PPI0 ','K+NPI+ ',
5337  & 'K0PPI0 ','K-PPI0 ','K-NPI+ ','AKPPI- ','AKNPI0 ',
5338  & 'K+NPI0 ','K+PPI- ','K0PPI0 ','K0NPI+ ','K-NPI0 ',
5339  & 'K-PPI- ','AKNPI- ','PAK0 ','SI+PI0 ','SI0PI+ ',
5340  & 'SI+ETA ','S+1PI0 ','S01PI+ ','NEUK- ','LA0PI- ',
5341  & 'SI-OM0 ','LA0RO- ','SI0RO- ','SI-RO0 ','SI-ET0 ',
5342  & 'SI0PI- ','SI-0 ','BLANC ','BLANC ','BLANC ',
5343  & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
5344  & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
5345  & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
5346  & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
5347  & 'EPI+- ','EPI00 ','GAPI+- ','GAGA* ','K+- ',
5348  & 'KLKS ','PI+-0 ','EGA ','LPI0 ','LPI ' /
5349  DATA (zkname(k),k=341,425) /
5350  & 'APPI0 ','ANPI- ','ALAGA ','ANPI ','ALPI0 ',
5351  & 'ALPI+ ','LAPI+ ','SI+PI0 ','SI0PI+ ','LAPI0 ',
5352  & 'SI+PI- ','SI-PI+ ','LAPI- ','SI-PI0 ','SI0PI- ',
5353  & 'TE0PI0 ','TE-PI+ ','TE0PI- ','TE-PI0 ','TE0PI ',
5354  & 'TE-PI ','LAK- ','ALPI- ','AS-PI0 ','AS0PI- ',
5355  & 'ALPI0 ','AS+PI- ','AS-PI+ ','ALPI+ ','AS+PI0 ',
5356  & 'AS0PI+ ','AT0PI0 ','AT+PI- ','AT0PI+ ','AT+PI0 ',
5357  & 'AT0PI ','AT+PI ','ALK+ ','K-PI+ ','K-PI+0 ',
5358  & 'K0PI+- ','K0PI0 ','K-PI++ ','AK0PI+ ','K+PI-- ',
5359  & 'K0PI- ','K+PI- ','K+PI-0 ','AKPI-+ ','AK0PI0 ',
5360  & 'ETAPIF ','K++- ','K+AK0 ','ETAPI- ','K--+ ',
5361  & 'K-K0 ','PI00 ','PI+- ','GAGA ','D0PI0 ',
5362  & 'D0GA ','D0PI+ ','D+PI0 ','DFGA ','AD0PI- ',
5363  & 'D-PI0 ','D-GA ','AD0PI0 ','AD0GA ','F+GA ',
5364  & 'F+GA ','F-GA ','F-GA ','PSPI+- ','PSPI00 ',
5365  & 'PSETA ','E+E- ','MUE+- ','PI+-0 ','M+NN ',
5366  & 'E+NN ','RHO+NT ','PI+ANT ','K*+ANT ','M-NN ' /
5367  DATA (zkname(k),k=426,510) /
5368  & 'E-NN ','RHO-NT ','PI-NT ','K*-NT ','NUET ',
5369  & 'ANUET ','NUEM ','ANUEM ','SI+ETA ','SI+ET* ',
5370  & 'PAK0 ','TET0K+ ','SI*+ET ','N*+AK0 ','N*++K- ',
5371  & 'LAMRO+ ','SI0RO+ ','SI+RO0 ','SI+OME ','PAK*0 ',
5372  & 'N*+AK* ','N*++K* ','SI+AK0 ','TET0PI ','SI+AK* ',
5373  & 'TET0RO ','SI0AK* ','SI+K*- ','TET0OM ','TET-RO ',
5374  & 'SI*0AK ','C0+PI+ ','C0+PI0 ','C0+PI- ','A+GAM ',
5375  & 'A0GAM ','TET0AK ','TET0K* ','OM-RO+ ','OM-PI+ ',
5376  & 'C1++AK ','A+PI+ ','C0+AK0 ','A0PI+ ','A+AK0 ',
5377  & 'T0PI+ ','ASI-ET ','ASI-E* ','APK0 ','ATET0K ',
5378  & 'ASI*-E ','AN*-K0 ','AN*--K ','ALAMRO ','ASI0RO ',
5379  & 'ASI-RO ','ASI-OM ','APK*0 ','AN*-K* ','AN*--K ',
5380  & 'ASI-K0 ','ATETPI ','ASI-K* ','ATETRO ','ASI0K* ',
5381  & 'ASI-K* ','ATE0OM ','ATE+RO ','ASI*0K ','AC-PI- ',
5382  & 'AC-PI0 ','AC-PI+ ','AA-GAM ','AA0GAM ','ATET0K ',
5383  & 'ATE0K* ','AOM+RO ','AOM+PI ','AC1--K ','AA-PI- ',
5384  & 'AC0-K0 ','AA0PI- ','AA-K0 ','AT0PI- ','C1++GA ' /
5385  DATA (zkname(k),k=511,540) /
5386  & 'C1++GA ','C10GAM ','S+GAM ','S0GAM ','T0GAM ',
5387  & 'XU++GA ','XD+GAM ','XS+GAM ','A+AKPI ','T02PI+ ',
5388  & 'C1++2K ','AC1--G ','AC1-GA ','AC10GA ','AS-GAM ',
5389  & 'AS0GAM ','AT0GAM ','AXU--G ','AXD-GA ','AXS-GA ',
5390  & 'AA-KPI ','AT02PI ','AC1--K ','RH-PI+ ','RH+PI- ',
5391  & 'RH3PI0 ','RH0PI+ ','RH+PI0 ','RH0PI- ','RH-PI0 ' /
5392  DATA (zkname(i),i=541,602)/
5393  & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHO0','ANRHO-','ANETA ',
5394  & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0','RH0PI+','RH+PI0',
5395  & '3PI+00','3PI-++','F0PI+ ','RH+PI-','RH0PI0','3PI000','3PI0+-',
5396  & 'F0PI0 ','RH0PI-','RH-PI0','3PI-00','3PI--+','F0PI- ','PI0PI0',
5397  & 'PI+PI-','K+K- ','K0AK0 ','L01600','AL0160','K*+146','K*-146',
5398  & 'K*0146','AK0146','S+1660','S01660','S-1660','AS-166','AS0166',
5399  & 'AS+166','X01690','X-1690','AX0169','AX+169','OM-225','AOM+22',
5400  & 'N*PPI0','N*NPI+','N*P2P0','N*PP+-','N*D+P0','N*D0P+','N*NPI0',
5401  & 'N*PPI-','N*N2P0','N*NP+-','N*D+P-','N*D0P0','BLANK '/
5402 * *
5403 * Weight of decay channel *
5404 * *
5405  DATA (wt(k),k= 1, 85) /
5406  & .1000d+01, .1000d+01, .1000d+01, .1000d+01, .1000d+01,
5407  & .1000d+01, .1000d+01, .1000d+01, .1000d+01, .1000d+01,
5408  & .1000d+01, .2100d+00, .1200d+00, .2700d+00, .4000d+00,
5409  & .1000d+01, .1000d+01, .6400d+00, .2100d+00, .6000d-01,
5410  & .2000d-01, .3000d-01, .4000d-01, .6400d+00, .2100d+00,
5411  & .6000d-01, .2000d-01, .3000d-01, .4000d-01, .6400d+00,
5412  & .3600d+00, .0000d+00, .0000d+00, .6400d+00, .3600d+00,
5413  & .0000d+00, .0000d+00, .6900d+00, .3100d+00, .1000d+01,
5414  & .5200d+00, .4800d+00, .1000d+01, .9900d+00, .1000d-01,
5415  & .3800d+00, .3000d-01, .3000d+00, .2400d+00, .5000d-01,
5416  & .1000d+01, .1000d+01, .0000d+00, .1000d+01, .9000d+00,
5417  & .1000d-01, .9000d-01, .3300d+00, .6700d+00, .3300d+00,
5418  & .6700d+00, .3300d+00, .6700d+00, .3300d+00, .6700d+00,
5419  & .3300d+00, .6700d+00, .3300d+00, .6700d+00, .3300d+00,
5420  & .6700d+00, .3300d+00, .6700d+00, .1900d+00, .3800d+00,
5421  & .9000d-01, .2000d+00, .3000d-01, .4000d-01, .5000d-01,
5422  & .2000d-01, .1900d+00, .3800d+00, .9000d-01, .2000d+00 /
5423  DATA (wt(k),k= 86,170) /
5424  & .3000d-01, .4000d-01, .5000d-01, .2000d-01, .1900d+00,
5425  & .3800d+00, .9000d-01, .2000d+00, .3000d-01, .4000d-01,
5426  & .5000d-01, .2000d-01, .1900d+00, .3800d+00, .9000d-01,
5427  & .2000d+00, .3000d-01, .4000d-01, .5000d-01, .2000d-01,
5428  & .8800d+00, .6000d-01, .6000d-01, .8800d+00, .6000d-01,
5429  & .6000d-01, .8800d+00, .1200d+00, .1900d+00, .1900d+00,
5430  & .1600d+00, .1600d+00, .1700d+00, .3000d-01, .3000d-01,
5431  & .3000d-01, .4000d-01, .1000d+00, .1000d+00, .2000d+00,
5432  & .1200d+00, .1000d+00, .4000d-01, .4000d-01, .5000d-01,
5433  & .7500d-01, .7500d-01, .3000d-01, .3000d-01, .4000d-01,
5434  & .5000d+00, .5000d+00, .5000d+00, .5000d+00, .1000d+01,
5435  & .6700d+00, .3300d+00, .3300d+00, .6700d+00, .1000d+01,
5436  & .2500d+00, .2700d+00, .1800d+00, .3000d+00, .1700d+00,
5437  & .8000d-01, .1800d+00, .3000d-01, .2400d+00, .2000d+00,
5438  & .1000d+00, .8000d-01, .1700d+00, .2400d+00, .3000d-01,
5439  & .1800d+00, .1000d+00, .2000d+00, .2500d+00, .1800d+00,
5440  & .2700d+00, .3000d+00, .5000d+00, .3000d+00, .1250d+00 /
5441 C & .2700D+00, .3000D+00, .4000D+00, .2000D+00, .1250D+00 /
5442 C & .7500D-01, .7500D-01, .1250D+00, .4000D+00, .7500D-01,
5443 C & .1250D+00, .2000D+00, .1250D+00, .7500D-01, .1800D+00,
5444  DATA (wt(k),k=171,255) /
5445  & .7500d-01, .0000d+00, .0000d+00, .5000d+00, .7500d-01,
5446  & .1250d+00, .3000d+00, .0000d+00, .0000d+00, .1800d+00,
5447  & .3700d+00, .1300d+00, .8000d-01, .4000d-01, .7000d-01,
5448  & .1300d+00, .3700d+00, .1800d+00, .4000d-01, .8000d-01,
5449  & .1300d+00, .1300d+00, .7000d-01, .7000d-01, .1300d+00,
5450  & .2300d+00, .4700d+00, .5000d-01, .2000d-01, .1000d-01,
5451  & .2000d-01, .1300d+00, .7000d-01, .4700d+00, .2300d+00,
5452  & .5000d-01, .1000d-01, .2000d-01, .2000d-01, .1000d+01,
5453  & .6700d+00, .3300d+00, .3300d+00, .6700d+00, .1000d+01,
5454  & .2500d+00, .2700d+00, .1800d+00, .3000d+00, .1700d+00,
5455  & .8000d-01, .1800d+00, .3000d-01, .2400d+00, .2000d+00,
5456  & .1000d+00, .8000d-01, .1700d+00, .2400d+00, .3000d-01,
5457  & .1800d+00, .1000d+00, .2000d+00, .2500d+00, .1800d+00,
5458  & .2700d+00, .3000d+00, .1800d+00, .3700d+00, .1300d+00,
5459  & .8000d-01, .4000d-01, .7000d-01, .1300d+00, .3700d+00,
5460  & .1800d+00, .4000d-01, .8000d-01, .1300d+00, .1300d+00,
5461  & .7000d-01, .5000d+00, .5000d+00, .1000d+01, .1000d+01 /
5462  DATA (wt(k),k=256,340) /
5463  & .1000d+01, .8000d+00, .2000d+00, .6000d+00, .3000d+00,
5464  & .1000d+00, .6000d+00, .3000d+00, .1000d+00, .8000d+00,
5465  & .2000d+00, .3300d+00, .6700d+00, .6600d+00, .1700d+00,
5466  & .1700d+00, .3200d+00, .1700d+00, .3200d+00, .1900d+00,
5467  & .3300d+00, .3300d+00, .3400d+00, .3000d+00, .5000d-01,
5468  & .6500d+00, .3800d+00, .1200d+00, .3800d+00, .1200d+00,
5469  & .3800d+00, .1200d+00, .3800d+00, .1200d+00, .3000d+00,
5470  & .5000d-01, .6500d+00, .3800d+00, .2500d+00, .2500d+00,
5471  & .2000d-01, .5000d-01, .5000d-01, .2000d+00, .2000d+00,
5472  & .1200d+00, .1000d+00, .7000d-01, .7000d-01, .1400d+00,
5473  & .5000d-01, .5000d-01, .1000d+01, .1000d+01, .1000d+01,
5474  & .1000d+01, .1000d+01, .1000d+01, .1000d+01, .1000d+01,
5475  & .1000d+01, .1000d+01, .1000d+01, .1000d+01, .1000d+01,
5476  & .1000d+01, .1000d+01, .1000d+01, .1000d+01, .1000d+01,
5477  & .1000d+01, .1000d+01, .1000d+01, .1000d+01, .1000d+01,
5478  & .4800d+00, .2400d+00, .2600d+00, .2000d-01, .4700d+00,
5479  & .3500d+00, .1500d+00, .3000d-01, .1000d+01, .1000d+01 /
5480  DATA (wt(k),k=341,425) /
5481  & .5200d+00, .4800d+00, .1000d+01, .1000d+01, .1000d+01,
5482  & .1000d+01, .9000d+00, .5000d-01, .5000d-01, .9000d+00,
5483  & .5000d-01, .5000d-01, .9000d+00, .5000d-01, .5000d-01,
5484  & .3300d+00, .6700d+00, .6700d+00, .3300d+00, .2500d+00,
5485  & .2500d+00, .5000d+00, .9000d+00, .5000d-01, .5000d-01,
5486  & .9000d+00, .5000d-01, .5000d-01, .9000d+00, .5000d-01,
5487  & .5000d-01, .3300d+00, .6700d+00, .6700d+00, .3300d+00,
5488  & .2500d+00, .2500d+00, .5000d+00, .1000d+00, .5000d+00,
5489  & .1600d+00, .2400d+00, .7000d+00, .3000d+00, .7000d+00,
5490  & .3000d+00, .1000d+00, .5000d+00, .1600d+00, .2400d+00,
5491  & .3000d+00, .4000d+00, .3000d+00, .3000d+00, .4000d+00,
5492  & .3000d+00, .4900d+00, .4900d+00, .2000d-01, .5500d+00,
5493  & .4500d+00, .6800d+00, .3000d+00, .2000d-01, .6800d+00,
5494  & .3000d+00, .2000d-01, .5500d+00, .4500d+00, .9000d+00,
5495  & .1000d+00, .9000d+00, .1000d+00, .6000d+00, .3000d+00,
5496  & .1000d+00, .1000d+00, .1000d+00, .8000d+00, .2800d+00,
5497  & .2800d+00, .3500d+00, .7000d-01, .2000d-01, .2800d+00 /
5498  DATA (wt(k),k=426,510) /
5499  & .2800d+00, .3500d+00, .7000d-01, .2000d-01, .1000d+01,
5500  & .1000d+01, .1000d+01, .1000d+01, .2000d-01, .3000d-01,
5501  & .7000d-01, .2000d-01, .2000d-01, .4000d-01, .1300d+00,
5502  & .7000d-01, .6000d-01, .6000d-01, .2000d+00, .1400d+00,
5503  & .4000d-01, .1000d+00, .2500d+00, .3000d-01, .3000d+00,
5504  & .4200d+00, .2200d+00, .3500d+00, .1900d+00, .1600d+00,
5505  & .8000d-01, .1000d+01, .1000d+01, .1000d+01, .1000d+01,
5506  & .1000d+01, .3700d+00, .2000d+00, .3600d+00, .7000d-01,
5507  & .5000d+00, .5000d+00, .5000d+00, .5000d+00, .5000d+00,
5508  & .5000d+00, .2000d-01, .3000d-01, .7000d-01, .2000d-01,
5509  & .2000d-01, .4000d-01, .1300d+00, .7000d-01, .6000d-01,
5510  & .6000d-01, .2000d+00, .1400d+00, .4000d-01, .1000d+00,
5511  & .2500d+00, .3000d-01, .3000d+00, .4200d+00, .2200d+00,
5512  & .3500d+00, .1900d+00, .1600d+00, .8000d-01, .1000d+01,
5513  & .1000d+01, .1000d+01, .1000d+01, .1000d+01, .3700d+00,
5514  & .2000d+00, .3600d+00, .7000d-01, .5000d+00, .5000d+00,
5515  & .5000d+00, .5000d+00, .5000d+00, .5000d+00, .1000d+01 /
5516  DATA (wt(k),k=511,540) /
5517  & .1000d+01, .1000d+01, .1000d+01, .1000d+01, .1000d+01,
5518  & .1000d+01, .1000d+01, .1000d+01, .3000d+00, .3000d+00,
5519  & .4000d+00, .1000d+01, .1000d+01, .1000d+01, .1000d+01,
5520  & .1000d+01, .1000d+01, .1000d+01, .1000d+01, .1000d+01,
5521  & .3000d+00, .3000d+00, .4000d+00, .3300d+00, .3300d+00,
5522  & .3400d+00, .5000d+00, .5000d+00, .5000d+00, .5000d+00 /
5523 C
5524  DATA (wt(i),i=541,602) / .0d+00, .3334d+00, .2083d+00, 2*.125d+00,
5525  & .2083d+00, .0d+00, .125d+00, .2083d+00, .3334d+00, .2083d+00,
5526  & .125d+00, 0.2d+00, 0.2d+00, 0.3d+00, 0.3d+00, 0.0d+00, 0.2d+00,
5527  & 0.2d+00, 0.3d+00, 0.3d+00, 0.0d+00, 0.2d+00, 0.2d+00, 0.3d+00,
5528  & 0.3d+00, 0.0d+00, 0.31d+00, 0.62d+00, 0.035d+00, 0.035d+00,
5529  & 18*1.d+00, 0.5d+00, 0.16d+00, 2*0.12d+00, 2*0.05d+00, 0.5d+00,
5530  & 0.16d+00, 2*0.12d+00, 2*0.05d+00, 1.d+00 /
5531 *
5532 * Particle numbers in decay channel *
5533 * *
5534  DATA (nzk(k,1),k= 1,170) /
5535  & 1, 2, 3, 4, 5, 6, 7, 1, 2, 4,
5536  & 3, 23, 13, 13, 13, 10, 11, 10, 13, 13,
5537  & 13, 10, 4, 11, 14, 14, 14, 11, 3, 1,
5538  & 8, 1, 1, 2, 9, 2, 2, 13, 23, 8,
5539  & 1, 8, 17, 7, 7, 7, 23, 23, 13, 13,
5540  & 13, 13, 23, 14, 13, 13, 23, 15, 24, 24,
5541  & 15, 16, 25, 25, 16, 15, 24, 24, 15, 16,
5542  & 24, 25, 16, 15, 24, 36, 37, 15, 24, 15,
5543  & 15, 24, 15, 37, 36, 24, 15, 24, 24, 16,
5544  & 24, 38, 39, 16, 25, 16, 16, 25, 16, 39,
5545  & 38, 25, 16, 25, 25, 17, 22, 21, 17, 21,
5546  & 20, 17, 22, 8, 1, 21, 22, 20, 17, 48,
5547  & 50, 49, 8, 1, 17, 17, 17, 21, 20, 22,
5548  & 17, 22, 21, 20, 22, 19, 12, 19, 12, 1,
5549  & 1, 8, 1, 8, 8, 1, 53, 54, 1, 1,
5550  & 8, 53, 54, 55, 1, 8, 1, 8, 54, 55,
5551  & 56, 1, 8, 8, 55, 56, 8, 1, 53, 54 /
5552  DATA (nzk(k,1),k=171,340) /
5553  & 55, 1, 8, 8, 54, 55, 56, 1, 8, 1,
5554  & 8, 53, 54, 55, 1, 8, 1, 8, 54, 55,
5555  & 56, 1, 8, 1, 8, 1, 8, 17, 21, 22,
5556  & 1, 1, 8, 1, 8, 17, 22, 20, 8, 2,
5557  & 2, 9, 2, 9, 9, 2, 67, 68, 2, 2,
5558  & 9, 67, 68, 69, 2, 9, 2, 9, 68, 69,
5559  & 70, 2, 9, 9, 69, 70, 9, 2, 9, 67,
5560  & 68, 69, 2, 9, 2, 9, 68, 69, 70, 2,
5561  & 9, 1, 8, 13, 13, 14, 1, 8, 1, 1,
5562  & 8, 8, 8, 1, 8, 1, 1, 1, 1, 1,
5563  & 8, 2, 2, 9, 9, 2, 2, 9, 15, 15,
5564  & 24, 16, 16, 25, 25, 15, 15, 24, 24, 16,
5565  & 16, 25, 1, 21, 22, 21, 48, 49, 8, 17,
5566  & 20, 17, 22, 20, 20, 22, 20, 0, 0, 0,
5567  & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
5568  & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
5569  & 31, 31, 13, 7, 15, 12, 13, 31, 17, 17 /
5570  DATA (nzk(k,1),k=341,510) /
5571  & 2, 9, 18, 9, 18, 18, 17, 21, 22, 17,
5572  & 21, 20, 17, 20, 22, 97, 98, 97, 98, 97,
5573  & 98, 17, 18, 99, 100, 18, 101, 99, 18, 101,
5574  & 100, 102, 103, 102, 103, 102, 103, 18, 16, 16,
5575  & 24, 24, 16, 25, 15, 24, 15, 15, 25, 25,
5576  & 31, 15, 15, 31, 16, 16, 23, 13, 7, 116,
5577  & 116, 116, 117, 117, 119, 118, 118, 119, 119, 120,
5578  & 120, 121, 121, 130, 130, 130, 4, 10, 13, 10,
5579  & 4, 32, 13, 36, 11, 3, 34, 14, 38, 133,
5580  & 134, 135, 136, 21, 21, 1, 97, 104, 54, 53,
5581  & 17, 22, 21, 21, 1, 54, 53, 21, 97, 21,
5582  & 97, 22, 21, 97, 98, 105, 137, 137, 137, 138,
5583  & 139, 97, 97, 109, 109, 140, 138, 137, 139, 138,
5584  & 145, 99, 99, 2, 102, 110, 68, 67, 18, 100,
5585  & 99, 99, 2, 68, 67, 99, 102, 99, 102, 100,
5586  & 99, 102, 103, 111, 149, 149, 149, 150, 151, 113,
5587  & 113, 115, 115, 152, 150, 149, 151, 150, 157, 140 /
5588  DATA (nzk(k,1),k=511,540) /
5589  & 141, 142, 143, 144, 145, 146, 147, 148, 138, 145,
5590  & 140, 152, 153, 154, 155, 156, 157, 158, 159, 160,
5591  & 150, 157, 152, 34, 32, 33, 33, 32, 33, 34 /
5592  DATA (nzk(i,1),i=541,602) / 2, 67, 68, 69, 2, 9, 9, 68, 69,
5593  & 70, 2, 9, 33, 32, 13, 14, 189, 32, 34, 23, 23, 189, 33, 34, 14,
5594  & 14, 189, 23, 13, 15, 24, 36, 38, 37, 39, 194, 195, 196, 197,
5595  & 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 1, 8, 1, 1, 54,
5596  & 55, 8, 1, 8, 8, 54, 55, 210/
5597  DATA (nzk(k,2),k= 1,170) /
5598  & 0, 0, 0, 0, 0, 0, 0, 3, 4, 6,
5599  & 5, 23, 14, 11, 3, 5, 5, 5, 23, 13,
5600  & 23, 23, 23, 5, 23, 13, 23, 23, 23, 14,
5601  & 23, 3, 11, 13, 23, 4, 10, 14, 23, 14,
5602  & 23, 13, 7, 7, 4, 7, 7, 23, 14, 14,
5603  & 23, 14, 23, 23, 14, 14, 7, 23, 13, 23,
5604  & 14, 23, 14, 23, 13, 23, 13, 23, 14, 23,
5605  & 14, 23, 13, 23, 13, 23, 13, 33, 32, 35,
5606  & 31, 23, 14, 23, 14, 33, 34, 35, 31, 23,
5607  & 14, 23, 14, 33, 34, 35, 31, 23, 13, 23,
5608  & 13, 33, 32, 35, 31, 13, 13, 23, 23, 14,
5609  & 13, 14, 14, 25, 16, 14, 23, 13, 31, 14,
5610  & 13, 23, 25, 16, 23, 35, 33, 34, 32, 33,
5611  & 31, 31, 14, 13, 23, 0, 0, 0, 0, 13,
5612  & 23, 13, 14, 23, 14, 13, 23, 13, 78, 23,
5613  & 13, 14, 23, 13, 79, 78, 14, 23, 14, 23,
5614  & 13, 80, 79, 14, 14, 23, 80, 31, 14, 23 /
5615  DATA (nzk(k,2),k=171,340) /
5616  & 13, 79, 78, 31, 14, 23, 13, 80, 79, 23,
5617  & 13, 14, 23, 13, 79, 78, 14, 23, 14, 23,
5618  & 13, 80, 79, 23, 13, 33, 32, 15, 24, 15,
5619  & 31, 14, 23, 34, 33, 24, 24, 15, 31, 14,
5620  & 23, 14, 13, 23, 13, 14, 23, 14, 80, 23,
5621  & 14, 13, 23, 14, 79, 80, 13, 23, 13, 23,
5622  & 14, 78, 79, 13, 13, 23, 78, 23, 14, 13,
5623  & 23, 14, 79, 80, 13, 23, 13, 23, 14, 78,
5624  & 79, 62, 61, 23, 14, 23, 13, 13, 13, 23,
5625  & 13, 13, 23, 14, 14, 14, 1, 8, 8, 1,
5626  & 8, 1, 8, 8, 1, 8, 1, 8, 1, 8,
5627  & 1, 1, 8, 1, 8, 8, 1, 1, 8, 8,
5628  & 1, 8, 25, 23, 13, 31, 23, 13, 16, 14,
5629  & 35, 34, 34, 33, 31, 14, 23, 0, 0, 0,
5630  & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
5631  & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
5632  & 13, 23, 14, 7, 16, 19, 14, 7, 23, 14 /
5633  DATA (nzk(k,2),k=341,510) /
5634  & 23, 14, 7, 13, 23, 13, 13, 23, 13, 23,
5635  & 14, 13, 14, 23, 14, 23, 13, 14, 23, 14,
5636  & 23, 16, 14, 23, 14, 23, 14, 13, 13, 23,
5637  & 13, 23, 14, 13, 23, 13, 23, 15, 13, 13,
5638  & 13, 23, 13, 13, 14, 14, 14, 14, 14, 23,
5639  & 13, 16, 25, 14, 15, 24, 23, 14, 7, 23,
5640  & 7, 13, 23, 7, 14, 23, 7, 23, 7, 7,
5641  & 7, 7, 7, 13, 23, 31, 3, 11, 14, 135,
5642  & 5, 134, 134, 134, 136, 6, 133, 133, 133, 0,
5643  & 0, 0, 0, 31, 95, 25, 15, 31, 95, 16,
5644  & 32, 32, 33, 35, 39, 39, 38, 25, 13, 39,
5645  & 32, 39, 38, 35, 32, 39, 13, 23, 14, 7,
5646  & 7, 25, 37, 32, 13, 25, 13, 25, 13, 25,
5647  & 13, 31, 95, 24, 16, 31, 24, 15, 34, 34,
5648  & 33, 35, 37, 37, 36, 24, 14, 37, 34, 37,
5649  & 36, 35, 34, 37, 14, 23, 13, 7, 7, 24,
5650  & 39, 34, 14, 24, 14, 24, 14, 24, 14, 7 /
5651  DATA (nzk(k,2),k=511,540) /
5652  & 7, 7, 7, 7, 7, 7, 7, 7, 25, 13,
5653  & 25, 7, 7, 7, 7, 7, 7, 7, 7, 7,
5654  & 24, 14, 24, 13, 14, 23, 13, 23, 14, 23 /
5655  DATA (nzk(i,2),i=541,602) / 31, 13, 23, 14, 79, 80, 31, 13, 23,
5656  & 14, 78, 79, 13, 23, 23, 13, 13, 14, 13, 23, 13, 23, 14, 23, 23,
5657  & 14, 14, 23, 14, 16, 25,
5658  & 4*23, 14*0, 23, 13, 23, 13, 23, 13, 23, 14,
5659  & 23, 13, 14, 23, 0 /
5660  DATA (nzk(k,3),k= 1,170) /
5661  & 0, 0, 0, 0, 0, 0, 0, 5, 6, 5,
5662  & 6, 23, 23, 5, 5, 0, 0, 0, 0, 14,
5663  & 23, 5, 5, 0, 0, 14, 23, 5, 5, 0,
5664  & 0, 5, 5, 0, 0, 5, 5, 0, 0, 0,
5665  & 0, 0, 0, 0, 3, 0, 7, 23, 23, 7,
5666  & 0, 0, 0, 0, 23, 0, 0, 0, 0, 0,
5667  & 110*0 /
5668  DATA (nzk(k,3),k=171,340) /
5669  & 80*0,
5670  & 0, 0, 0, 0, 0, 0, 23, 13, 14, 23,
5671  & 23, 14, 23, 23, 23, 14, 23, 13, 23, 14,
5672  & 13, 23, 13, 23, 14, 23, 14, 14, 23, 13,
5673  & 13, 23, 13, 14, 23, 23, 14, 23, 13, 23,
5674  & 14, 14, 0, 0, 0, 0, 0, 0, 0, 0,
5675  & 30*0,
5676  & 14, 23, 7, 0, 0, 0, 23, 0, 0, 0 /
5677  DATA (nzk(k,3),k=341,510) /
5678  & 30*0,
5679  & 0, 0, 0, 0, 0, 0, 0, 0, 0, 23,
5680  & 14, 0, 13, 0, 14, 0, 0, 23, 13, 0,
5681  & 0, 15, 0, 0, 16, 0, 0, 0, 0, 0,
5682  & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
5683  & 0, 0, 0, 14, 23, 0, 0, 0, 23, 134,
5684  & 134, 0, 0, 0, 133, 133, 0, 0, 0, 0,
5685  & 80*0 /
5686  DATA (nzk(k,3),k=511,540) /
5687  & 0, 0, 0, 0, 0, 0, 0, 0, 13, 13,
5688  & 25, 0, 0, 0, 0, 0, 0, 0, 0, 0,
5689  & 14, 14, 24, 0, 0, 0, 0, 0, 0, 0 /
5690  DATA (nzk(i,3),i=541,602) / 12*0, 2*0, 23, 13, 0, 2*0, 23, 14, 0,
5691  & 2*0, 23, 13, 0, 4*0, 18*0, 2*0, 23, 14, 2*0, 2*0, 23, 14, 2*0, 0/
5692 *= end.block.blkdt7 *
5693 * *
5694  END
5695 
5696 *
5697 *===xsglau=============================================================*
5698 *
5699  SUBROUTINE xsglau(NA,NB,IJPROJ,NTARG)
5700 
5701 ************************************************************************
5702 * Total, elastic, quasi-elastic, inelastic cross sections according to *
5703 * Glauber's approach. *
5704 * NA / NB mass numbers of proj./target nuclei *
5705 * IJPROJ bamjet-index of projectile (=1 in case of proj.nucleus) *
5706 * ECMI kinematical variables E_cm *
5707 * IE indices of energy
5708 * NTARG index of target nucleus set o NTARG=1 here *
5709 * This version dated 17.3.98 is written by S. Roesler mod by J.R. *
5710 ************************************************************************
5711 
5712  IMPLICIT DOUBLE PRECISION (a-h,o-z)
5713  SAVE
5714  parameter(lout=6,llook=9)
5715 
5716  COMPLEX*16 czero,cone,ctwo
5717  parameter(zero=0.0d0,one=1.0d0,two=2.0d0,three=3.0d0,
5718  & onethi=one/three,tiny25=1.0d-25)
5719  parameter(twopi = 6.283185307179586454d+00,
5720  & pi = twopi/two,
5721  & gev2mb = 0.38938d0,
5722  & gev2fm = 0.1972d0,
5723  & alphem = one/137.0d0,
5724 * proton mass
5725  & amp = 0.938d0,
5726  & amp2 = amp**2,
5727 * approx. nucleon radius
5728  & rnucle = 1.12d0,
5729 * number of bins in b-space
5730  & ksiteb = 200 )
5731 
5732  CHARACTER*8 aname
5733  COMMON /dpar/ aname(210),aam(210),gam(210),tau(210),iich(210),
5734  & iibar(210),ka1(210),ka2(210)
5735 
5736  parameter(ncompx=1,neb=50)
5737  COMMON /dshmm/ rash,rbsh(ncompx),bmax(ncompx),bstep(ncompx),
5738  & sigsh,rosh,gsh,bsite(0:neb,ncompx,ksiteb),
5739  & nstatb,nsiteb
5740  COMMON /glaber/ ecmnn(neb),ecmnow,
5741  & xstot(neb),xsela(neb),
5742  & xsqep(neb),xsqet(neb),
5743  & xsqe2(neb),xspro(neb),
5744  & xetot(neb),xeela(neb),
5745  & xeqep(neb),xeqet(neb),
5746  & xeqe2(neb),xepro(neb),
5747  & bslope,elabb(neb)
5748 
5749  COMMON /vdmpar/ rl2,epspol,intrge(2),idpdf,modega,ishad(3)
5750  COMMON /glapar/ jstatb
5751 
5752  COMPLEX*16 c,ca,ci
5753  COMMON /damp/ ca,ci,ga
5754  COMMON /xsecnu/ecmuu,ecmoo,ngritt,nevtt
5755  COMMON /kglaub/jglaub
5756 
5757  parameter(maxncl = 210)
5758  COMPLEX*16 pp11,pp12,pp21,pp22,
5759  & ompp11,ompp12,ompp21,ompp22
5760  dimension coop1(3,maxncl),coot1(3,maxncl),
5761  & coop2(3,maxncl),coot2(3,maxncl),
5762  & bprod(ksiteb),sigshh(neb),
5763  & sigto(neb),sigel(neb),sigin(neb),sigsd(neb),sigdif(neb)
5764 
5765  jglaub=1
5766  Write(6,*)' XSGLAU(NA,NB,IJPROJ,NTARG)',
5767  &na,nb,ijproj,ntarg
5768  WRITE(6,*)'/XSECNU/ECMUU,ECMOO,NGRITT,NEVTT',
5769  &ecmuu,ecmoo,ngritt,nevtt
5770 
5771  czero = dcmplx(zero,zero)
5772  cone = dcmplx(one,zero)
5773  ctwo = dcmplx(two,zero)
5774 
5775 * re-define kinematics
5776  ec000=ecmuu
5777  dellog=(log10(ecmoo)-log10(ecmuu))/(ngritt-1)
5778  deldel=10.d0**dellog
5779  ec111=ecmuu/deldel
5780  DO 1123 ieee=1,ngritt
5781  ie=ieee
5782  ec111=deldel*ec111
5783  s=ec111**2
5784  ecmnn(ie) = ec111
5785  WRITE(6,*)'IE,EC111,S',ie,ec111,s
5786 
5787 * parameters determining statistics in evaluating Glauber-xsection
5788  jstatb=nevtt
5789  nstatb = jstatb
5790  nsiteb = ksiteb
5791 
5792 * set up interaction geometry (common /DSHM/)
5793 * projectile/target radii
5794  rash = rnucle*dble(na)**onethi
5795  rbsh(ntarg) = rnucle*dble(nb)**onethi
5796  IF(jglaub.EQ.1)THEN
5797  IF(na.EQ.9)rash=2.52d0
5798  IF(na.EQ.10)rash=2.45d0
5799  IF(na.EQ.11)rash=2.37d0
5800  IF(na.EQ.12)rash=2.45d0
5801  IF(na.EQ.13)rash=2.44d0
5802  IF(na.EQ.14)rash=2.55d0
5803  IF(na.EQ.15)rash=2.58d0
5804  IF(na.EQ.16)rash=2.71d0
5805  IF(na.EQ.17)rash=2.66d0
5806  IF(na.EQ.18)rash=2.71d0
5807  IF(nb.EQ.9)rbsh(ntarg)=2.52d0
5808  IF(nb.EQ.10)rbsh(ntarg)=2.45d0
5809  IF(nb.EQ.11)rbsh(ntarg)=2.37d0
5810  IF(nb.EQ.12)rbsh(ntarg)=2.45d0
5811  IF(nb.EQ.13)rbsh(ntarg)=2.44d0
5812  IF(nb.EQ.14)rbsh(ntarg)=2.55d0
5813  IF(nb.EQ.15)rbsh(ntarg)=2.58d0
5814  IF(nb.EQ.16)rbsh(ntarg)=2.71d0
5815  IF(nb.EQ.17)rbsh(ntarg)=2.66d0
5816  IF(nb.EQ.18)rbsh(ntarg)=2.71d0
5817  ENDIF
5818 * maximum impact-parameter
5819  bmax(ntarg) = 4.0d0*(rash+rbsh(ntarg))
5820  bstep(ntarg)= bmax(ntarg)/dble(nsiteb-1)
5821 
5822 * slope, rho ( Re(f(0))/Im(f(0)) )
5823  IF (ijproj.LE.12) THEN
5824  bslope = 8.5d0*(1.0d0+0.065d0*log(s))
5825  IF (ecmnn(ie).LE.3.0d0) THEN
5826  rosh = -0.43d0
5827  ELSEIF ((ecmnn(ie).GT.3.0d0).AND.(ecmnn(ie).LE.50.d0)) THEN
5828  rosh = -0.63d0+0.175d0*log(ecmnn(ie))
5829  ELSEIF (ecmnn(ie).GT.50.0d0) THEN
5830  rosh = 0.1d0
5831  ENDIF
5832  ELSE
5833  bslope = 6.0d0*(1.0d0+0.065d0*log(s))
5834  rosh = 0.01d0
5835  ENDIF
5836 
5837 * projectile-nucleon xsection (in fm)
5838  elab = (s-aam(ijproj)**2-amp2)/(two*amp)
5839  elabb(ie)=elab/1000.
5840  plab = sqrt( (elab-aam(ijproj))*(elab+aam(ijproj)) )
5841 C SIGSH = SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
5842  sigsh = dshpto(ijproj,plab)/10.d0
5843  sigshh(ie)=sigsh*10.d0
5844  WRITE(6,*)' NSTATB,NSITEB,RASH,RBSH(NTARG),BMAX(NTARG),
5845  &BSLOPE,ROSH,SIGSH,ECM ELAB',
5846  & nstatb,nsiteb,rash,rbsh(ntarg),bmax(ntarg),
5847  &bslope,rosh,sigsh,ec111,elab
5848 * initializations
5849  DO 10 i=1,nsiteb
5850  bsite( 0,ntarg,i) = zero
5851  bsite(ie,ntarg,i) = zero
5852  bprod(i) = zero
5853  10 CONTINUE
5854  stot = zero
5855  stot2 = zero
5856  sela = zero
5857  sela2 = zero
5858  sqep = zero
5859  sqep2 = zero
5860  sqet = zero
5861  sqet2 = zero
5862  sqe2 = zero
5863  sqe22 = zero
5864  spro = zero
5865  spro2 = zero
5866  facn = one/dble(nstatb)
5867 
5868  ipnt = 0
5869  rpnt = zero
5870 
5871 C------------------------------------------------------
5872 
5873 * cross sections averaged over NSTATB nucleon configurations
5874  DO 11 is=1,nstatb
5875  stotn = zero
5876  selan = zero
5877  sqepn = zero
5878  sqetn = zero
5879  sqe2n = zero
5880  spron = zero
5881  CALL conuclx(coop1,na,rash,0)
5882  CALL conuclx(coot1,nb,rbsh(ntarg),1)
5883  CALL conuclx(coop2,na,rash,0)
5884  CALL conuclx(coot2,nb,rbsh(ntarg),1)
5885 
5886 * integration over impact parameter B
5887  DO 12 ib=1,nsiteb-1
5888  stotb = zero
5889  selab = zero
5890  sqepb = zero
5891  sqetb = zero
5892  sqe2b = zero
5893  sprob = zero
5894  sdir = zero
5895  b = dble(ib)*bstep(ntarg)
5896  facb = 10.0d0*twopi*b*bstep(ntarg)
5897 
5898 * integration over M_V^2 for photon-proj.
5899 C DO 14 IM=1,JPOINT
5900  pp11 = cone
5901  pp12 = cone
5902  pp21 = cone
5903  pp22 = cone
5904  shi = zero
5905  facm = one
5906  dcoh = 1.0d10
5907 
5908 C------------------------------------------------------------
5909 
5910  gsh = 10.0d0/(two*bslope*gev2mb)
5911 * common /DAMP/
5912  ga = gsh
5913  rca = ga*sigsh/twopi
5914  fca = -rosh*rca
5915  ca = dcmplx(rca,fca)
5916  ci = cone
5917 
5918  DO 15 ina=1,na
5919  kk1 = 1
5920  kk2 = 1
5921  DO 16 inb=1,nb
5922 
5923  x11 = b+coot1(1,inb)-coop1(1,ina)
5924  y11 = coot1(2,inb)-coop1(2,ina)
5925  xy11 = ga*(x11*x11+y11*y11)
5926  x12 = b+coot2(1,inb)-coop1(1,ina)
5927  y12 = coot2(2,inb)-coop1(2,ina)
5928  xy12 = ga*(x12*x12+y12*y12)
5929  x21 = b+coot1(1,inb)-coop2(1,ina)
5930  y21 = coot1(2,inb)-coop2(2,ina)
5931  xy21 = ga*(x21*x21+y21*y21)
5932  x22 = b+coot2(1,inb)-coop2(1,ina)
5933  y22 = coot2(2,inb)-coop2(2,ina)
5934  xy22 = ga*(x22*x22+y22*y22)
5935  IF (xy11.LE.15.0d0) THEN
5936  c = cone-ca*exp(-xy11)
5937  ar = dble(pp11)
5938  ai = dimag(pp11)
5939  IF (abs(ar).LT.tiny25) ar = zero
5940  IF (abs(ai).LT.tiny25) ai = zero
5941  pp11 = dcmplx(ar,ai)
5942  pp11 = pp11*c
5943  ar = dble(c)
5944  ai = dimag(c)
5945  shi = shi+log(ar*ar+ai*ai)
5946  ENDIF
5947  IF (xy12.LE.15.0d0) THEN
5948  c = cone-ca*exp(-xy12)
5949  ar = dble(pp12)
5950  ai = dimag(pp12)
5951  IF (abs(ar).LT.tiny25) ar = zero
5952  IF (abs(ai).LT.tiny25) ai = zero
5953  pp12 = dcmplx(ar,ai)
5954  pp12 = pp12*c
5955  ENDIF
5956  IF (xy21.LE.15.0d0) THEN
5957  c = cone-ca*exp(-xy21)
5958  ar = dble(pp21)
5959  ai = dimag(pp21)
5960  IF (abs(ar).LT.tiny25) ar = zero
5961  IF (abs(ai).LT.tiny25) ai = zero
5962  pp21 = dcmplx(ar,ai)
5963  pp21 = pp21*c
5964  ENDIF
5965  IF (xy22.LE.15.0d0) THEN
5966  c = cone-ca*exp(-xy22)
5967  ar = dble(pp22)
5968  ai = dimag(pp22)
5969  IF (abs(ar).LT.tiny25) ar = zero
5970  IF (abs(ai).LT.tiny25) ai = zero
5971  pp22 = dcmplx(ar,ai)
5972  pp22 = pp22*c
5973  ENDIF
5974  16 CONTINUE
5975  15 CONTINUE
5976 
5977  ompp11 = czero
5978  ompp21 = czero
5979  ompp11 = ompp11+(cone-pp11)
5980  ompp21 = ompp21+(cone-pp21)
5981  ompp12 = czero
5982  ompp22 = czero
5983  ompp12 = ompp12+(cone-pp12)
5984  ompp22 = ompp22+(cone-pp22)
5985 
5986  stotm = dble(ompp11+ompp22)
5987  selam = dble(ompp11*dconjg(ompp22))
5988  sprom = one-exp(shi)
5989  sqepm = dble(ompp11*dconjg(ompp21))-selam
5990  sqetm = dble(ompp11*dconjg(ompp12))-selam
5991  sqe2m = dble(ompp11*dconjg(ompp11))-selam-sqepm-sqetm
5992 
5993  stotb = stotb+facm*stotm
5994  selab = selab+facm*selam
5995  IF (nb.GT.1) sqepb = sqepb+facm*sqepm
5996  IF (na.GT.1) sqetb = sqetb+facm*sqetm
5997  IF ((na.GT.1).AND.(nb.GT.1)) sqe2b = sqe2b+facm*sqe2m
5998  sprob = sprob+facm*sprom
5999 
6000 C 14 CONTINUE
6001 
6002  stotn = stotn+facb*stotb
6003  selan = selan+facb*selab
6004  sqepn = sqepn+facb*sqepb
6005  sqetn = sqetn+facb*sqetb
6006  sqe2n = sqe2n+facb*sqe2b
6007  spron = spron+facb*sprob
6008  bprod(ib+1)= bprod(ib+1)+facn*facb*sprob
6009 
6010  12 CONTINUE
6011 
6012  stot = stot +facn*stotn
6013  stot2 = stot2+facn*stotn**2
6014  sela = sela +facn*selan
6015  sela2 = sela2+facn*selan**2
6016  sqep = sqep +facn*sqepn
6017  sqep2 = sqep2+facn*sqepn**2
6018  sqet = sqet +facn*sqetn
6019  sqet2 = sqet2+facn*sqetn**2
6020  sqe2 = sqe2 +facn*sqe2n
6021  sqe22 = sqe22+facn*sqe2n**2
6022  spro = spro +facn*spron
6023  spro2 = spro2+facn*spron**2
6024 
6025  11 CONTINUE
6026 
6027 * final cross sections
6028 * 1) total
6029  xstot(ie) = stot
6030 * 2) elastic
6031  xsela(ie) = sela
6032 * 3) quasi-el.: A+B-->A+X (excluding 2)
6033  xsqep(ie) = sqep
6034 * 4) quasi-el.: A+B-->X+B (excluding 2)
6035  xsqet(ie) = sqet
6036 * 5) quasi-el.: A+B-->X (excluding 2-4)
6037  xsqe2(ie) = sqe2
6038 * 6) production (= STOT-SELA-SQEP-SQET-SQE2!)
6039  xspro(ie) = spro
6040  WRITE(6,*)' STOT,SELA ,SQEP,SQET,SQE2,SPRO ',
6041  & stot,sela ,sqep,sqet,sqe2,spro
6042 * stat. errors
6043  xetot(ie) = sqrt(abs(stot2-stot**2)/dble(nstatb-1))
6044  xeela(ie) = sqrt(abs(sela2-sela**2)/dble(nstatb-1))
6045  xeqep(ie) = sqrt(abs(sqep2-sqep**2)/dble(nstatb-1))
6046  xeqet(ie) = sqrt(abs(sqet2-sqet**2)/dble(nstatb-1))
6047  xeqe2(ie) = sqrt(abs(sqe22-sqe2**2)/dble(nstatb-1))
6048  xepro(ie) = sqrt(abs(spro2-spro**2)/dble(nstatb-1))
6049  WRITE(6,*)' XETOT,XEELA,XEQEP,XEQET,XEQE2,XEPRO ',
6050  & xetot(ie),xeela(ie),xeqep(ie),
6051  &xeqet(ie),xeqe2(ie),xepro(ie)
6052 1123 CONTINUE
6053  DO 19 i=2,nsiteb
6054  bsite(ie,ntarg,i) = bprod(i)/spro+bsite(ie,ntarg,i-1)
6055  IF (ie.EQ.1)
6056  & bsite(0,ntarg,i) = bprod(i)/spro+bsite(0,ntarg,i-1)
6057  19 CONTINUE
6058  WRITE (6,*)' ECMNN,ELABB,SIGSHH,SIGTO,SIGEL,SIGIN,SIGSD'
6059 C & SIGTO(NEB),SIGEL(NEB),SIGIN(NEB),SIGSD(NEB),SIGDIF(NEB)
6060  DO 129 i=1,ngritt
6061  sigto(i)=dshnto(1,1,ecmnn(i))
6062  sigel(i)=dshnel(1,1,ecmnn(i))
6063  sigin(i)=siinel(1,1,ecmnn(i))
6064  sigsd(i)=sippsd(ecmnn(i))
6065  CALL sihndi(ecmnn(i),1,1,sigdif(i),sigdih)
6066  WRITE (6,'(2F18.4,6F11.3)')ecmnn(i),elabb(i),sigshh(i),
6067  & sigto(i),sigel(i),sigin(i),sigsd(i),sigdif(i)
6068  129 CONTINUE
6069  WRITE (6,*)' ECMNN,ELABB,XSQEP,XEQEP,XSQET,XEQET,XSQE2,XEQE2'
6070  DO 139 i=1,ngritt
6071  WRITE (6,'(2F18.4,6F11.3)')ecmnn(i),elabb(i),xsqep(i),xeqep(i),
6072  * xsqet(i),xeqet(i),xsqe2(i),xeqe2(i)
6073  139 CONTINUE
6074  WRITE (6,*)' ECMNN,ELABB,XSTOT,XETOT,XSELA,XEELA,XSPRO,XEPRO'
6075  DO 119 i=1,ngritt
6076  WRITE (6,'(2F18.4,6F11.3)')ecmnn(i),elabb(i),xstot(i),xetot(i),
6077  * xsela(i),xeela(i),xspro(i),xepro(i)
6078  119 CONTINUE
6079 
6080  RETURN
6081  END
6082 
6083 
6084  SUBROUTINE conuclx(COOP1,NA,RASH,I)
6085  IMPLICIT DOUBLE PRECISION (a-h,o-z)
6086  SAVE
6087  parameter(maxncl = 210)
6088  dimension coop1(3,maxncl)
6089  CALL conucl(coop1,na,rash)
6090  RETURN
6091  END
6092 *-- Author :
6093 C
6094 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6095 C
6096  SUBROUTINE dbklas(I,J,K,I8,I10)
6097  IMPLICIT DOUBLE PRECISION (a-h,o-z)
6098  SAVE
6099 C*** I,J,K QUARK FLAVOURS U,D,S,C=1,2,3,4
6100 C*** AQ = -Q
6101 C*** I8,I10 BARYON INDICES
6102 *KEEP,DINPDA.
6103  COMMON /dinpda/ imps(6,6),imve(6,6),ib08(6,21),ib10(6,21), ia08
6104  +(6,21),ia10(6,21), a1,b1,b2,b3,lt,le,bet,as,b8,ame,diq,isu
6105 *KEND.
6106  IF (i) 20,20,10
6107 C*** BARYON
6108  10 CONTINUE
6109  CALL indexd(j,k,ind)
6110  i8=ib08(i,ind)
6111  i10=ib10(i,ind)
6112  IF (i8.LE.0) i8=i10
6113  RETURN
6114  20 CONTINUE
6115 C*** ANTIBARYONS
6116  ii=iabs(i)
6117  jj=iabs(j)
6118  kk=iabs(k)
6119  CALL indexd(jj,kk,ind)
6120  i8=ia08(ii,ind)
6121  i10=ia10(ii,ind)
6122  IF (i8.LE.0) i8=i10
6123  RETURN
6124  END
6125 C-----------------------------------------------------------
6126 
6127  DOUBLE PRECISION FUNCTION sippsd(ECM)
6128  IMPLICIT DOUBLE PRECISION (a-h,o-z)
6129 C Single Diffraction cross section in p-p collision
6130 C Tables calculated with DPMJET-II.4.2
6131  dimension ec(30),sd(30)
6132  DATA ec /0.d0, 5.d0, 20.d0, 50.d0, 100.d0,
6133  * 200.d0, 500.d0, 1000.d0, 1500.d0, 2000.d0,
6134  * 3000.d0, 4000.d0, 6000.d0, 8000.d0, 10000.d0,
6135  * 15000.d0, 20000.d0, 30000.d0, 40000.d0, 60000.d0,
6136  * 80000.d0, 100000.d0, 150000.d0, 200000.d0, 300000.d0,
6137  * 400000.d0, 600000.d0, 800000.d0, 1000000.d0, 2000000.d0/
6138  DATA sd /0.d0, 0.d0, 5.00d0, 6.14d0, 6.93d0,
6139  * 7.64d0, 8.43d0, 8.87d0, 9.07d0, 9.17d0,
6140  * 9.33d0, 9.40d0, 9.49d0, 9.56d0, 9.58d0,
6141  * 9.69d0, 9.72d0, 9.82d0, 9.85d0, 9.97d0,
6142  * 10.02d0, 10.03d0, 10.13d0, 10.16d0, 10.25d0,
6143  * 10.28d0, 10.39d0, 10.42d0, 10.43d0, 10.53d0/
6144  ii=1
6145  DO 1 i=1,30
6146  IF((ecm.GE.ec(i)).AND.(ecm.LT.ec(i+1)))THEN
6147  ii=i
6148  del=(ecm-ec(i))*(sd(i+1)-sd(i))/(ec(i+1)-ec(i))
6149  sippsd=sd(i)+del
6150  RETURN
6151  ENDIF
6152  1 CONTINUE
6153  sippsd=0.d0
6154  RETURN
6155  END
6156  DOUBLE PRECISION FUNCTION siinel(KPROJ,KTARG,UMO)
6157  IMPLICIT DOUBLE PRECISION (a-h,o-z)
6158 C Inelastic cross section
6159  siinel=dshnto(kproj,ktarg,umo)-dshnel(kproj,ktarg,umo)
6160  RETURN
6161  END
6162 C---------------------------------------------------------------
6163 C was dpmsicha.f
6164 C---------------------------------------------------------------
6165 *$ CREATE PHNSCH.FOR
6166 *COPY PHNSCH
6167 *
6168 *=== phnsch ===========================================================*
6169 *
6170  DOUBLE PRECISION FUNCTION phnsch ( KP, KTARG, PLAB )
6171 
6172 C INCLUDE '(DBLPRC)'
6173 C INCLUDE '(DIMPAR)'
6174 C INCLUDE '(IOUNIT)'
6175 *
6176 *----------------------------------------------------------------------*
6177 * *
6178 * Probability for Hadron Nucleon Single CHain interactions: *
6179 * *
6180 * Created on 30 december 1993 by Alfredo Ferrari & Paola Sala *
6181 * Infn - Milan *
6182 * *
6183 * Last change on 04-jan-94 by Alfredo Ferrari *
6184 * *
6185 * modified by J.R.for use in DTUNUC 6.1.94 *
6186 * *
6187 * Input variables: *
6188 * Kp = hadron projectile index (Part numbering *
6189 * scheme) *
6190 * Ktarg = target nucleon index (1=proton, 8=neutron) *
6191 * Plab = projectile laboratory momentum (GeV/c) *
6192 * Output variable: *
6193 * Phnsch = probability per single chain (particle *
6194 * exchange) interactions *
6195 * *
6196 *----------------------------------------------------------------------*
6197 *
6198 C INCLUDE '(PAPROP)'
6199 C INCLUDE '(PART2)'
6200 C INCLUDE '(QQUARK)'
6201 
6202 *$ CREATE DBLPRC.ADD
6203 *COPY DBLPRC
6204 * *
6205 *=== dblprc ==========================================================*
6206 * *
6207 *---------------------------------------------------------------------*
6208 * *
6209 * Dblprc: included in any routine *
6210 * *
6211 * !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
6212 * !!!! O N M A C H I N E S W H E R E T H E D O U B L E !!!! *
6213 * !!!! P R E C I S I O N I S N O T R E Q U I R E D R E -!!!! *
6214 * !!!! M O V E T H E D O U B L E P R E C I S I O N !!!! *
6215 * !!!! S T A T E M E N T, S E T K A L G N M = 1 A N D !!!! *
6216 * !!!! C H A N G E A L L N U M E R I C A L C O N S - !!!! *
6217 * !!!! T A N T S T O S I N G L E P R E C I S I O N !!!! *
6218 * !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
6219 * *
6220 * Kalgnm = real address alignment, 2 for double precision, *
6221 * 1 for single precision *
6222 * Anglgb = this parameter should be set equal to the machine *
6223 * "zero" with respect to unit *
6224 * Anglsq = this parameter should be set equal to the square *
6225 * of Anglgb *
6226 * Axcssv = this parameter should be set equal to the number *
6227 * for which unity is negligible for the machine *
6228 * accuracy *
6229 * Andrfl = "underflow" of the machine for floating point *
6230 * operation *
6231 * Avrflw = "overflow" of the machine for floating point *
6232 * operation *
6233 * Ainfnt = code "infinite" *
6234 * Azrzrz = code "zero" *
6235 * Einfnt = natural logarithm of the code "infinite" *
6236 * Ezrzrz = natural logarithm of the code "zero" *
6237 * Onemns = 1- of the machine, it is 1 - 2 x Anglgb *
6238 * Onepls = 1+ of the machine, it is 1 + 2 x Anglgb *
6239 * Csnnrm = maximum tolerable error on cosine normalization, *
6240 * u**2+v**2+w**2: assuming a typical anglgb relative *
6241 * error on each component we would get 2xanglgb: use *
6242 * 4xanglgb to avoid too many normalizations *
6243 * Dmxtrn = "infinite" distance for transport (cm) *
6244 * *
6245 *---------------------------------------------------------------------*
6246 * *
6247  IMPLICIT DOUBLE PRECISION (a-h,o-z)
6248  parameter( kalgnm = 2 )
6249  parameter( anglgb = 5.0d-16 )
6250  parameter( anglsq = 2.5d-31 )
6251  parameter( axcssv = 0.2d+16 )
6252  parameter( andrfl = 1.0d-38 )
6253  parameter( avrflw = 1.0d+38 )
6254  parameter( ainfnt = 1.0d+30 )
6255  parameter( azrzrz = 1.0d-30 )
6256  parameter( einfnt = +69.07755278982137 d+00 )
6257  parameter( ezrzrz = -69.07755278982137 d+00 )
6258  parameter( onemns = 0.999999999999999 d+00 )
6259  parameter( onepls = 1.000000000000001 d+00 )
6260  parameter( csnnrm = 2.0d-15 )
6261  parameter( dmxtrn = 1.0d+08 )
6262 *
6263 *======================================================================*
6264 *======================================================================*
6265 *========= ==========*
6266 *========= M A T H E M A T I C A L C O N S T A N T S ==========*
6267 *========= ==========*
6268 *======================================================================*
6269 *======================================================================*
6270 * *
6271 * Numerical constants: *
6272 * *
6273 * Zerzer = 0 *
6274 * Oneone = 1 *
6275 * Twotwo = 2 *
6276 * Thrthr = 3 *
6277 * Foufou = 4 *
6278 * Fivfiv = 5 *
6279 * Sixsix = 6 *
6280 * Sevsev = 7 *
6281 * Eigeig = 8 *
6282 * Aninen = 9 *
6283 * Tenten = 10 *
6284 * Hlfhlf = 1/2 *
6285 * Onethi = 1/3 *
6286 * Twothi = 2/3 *
6287 * Pipipi = Circumference / diameter *
6288 * Eneper = "e", base of natural logarithm *
6289 * Sqrent = square root of "e" *
6290 * *
6291 *----------------------------------------------------------------------*
6292 *
6293  parameter( zerzer = 0.d+00 )
6294  parameter( oneone = 1.d+00 )
6295  parameter( twotwo = 2.d+00 )
6296  parameter( thrthr = 3.d+00 )
6297  parameter( foufou = 4.d+00 )
6298  parameter( fivfiv = 5.d+00 )
6299  parameter( sixsix = 6.d+00 )
6300  parameter( sevsev = 7.d+00 )
6301  parameter( eigeig = 8.d+00 )
6302  parameter( aninen = 9.d+00 )
6303  parameter( tenten = 10.d+00 )
6304  parameter( hlfhlf = 0.5d+00 )
6305  parameter( onethi = oneone / thrthr )
6306  parameter( twothi = twotwo / thrthr )
6307  parameter( pipipi = 3.1415926535897932270 d+00 )
6308  parameter( eneper = 2.7182818284590452354 d+00 )
6309  parameter( sqrent = 1.6487212707001281468 d+00 )
6310 *
6311 *======================================================================*
6312 *======================================================================*
6313 *========= ==========*
6314 *========= P H Y S I C A L C O N S T A N T S ==========*
6315 *========= ==========*
6316 *======================================================================*
6317 *======================================================================*
6318 * *
6319 * Primary constants: *
6320 * *
6321 * Clight = speed of light in cm s-1 *
6322 * Avogad = Avogadro number *
6323 * Amelgr = electron mass (g) *
6324 * Plckbr = reduced Planck constant (erg s) *
6325 * Elccgs = elementary charge (CGS unit) *
6326 * Elcmks = elementary charge (MKS unit) *
6327 * Amugrm = Atomic mass unit (g) *
6328 * Ammumu = Muon mass (amu) *
6329 * *
6330 * Derived constants: *
6331 * *
6332 * Alpfsc = Fine structure constant = e^2/(hbar c) *
6333 * Amelct = Electron mass (GeV) = 10^-16Amelgr Clight^2 / Elcmks*
6334 * Amugev = Atomic mass unit (GeV) = 10^-16Amelgr Clight^2 *
6335 * / Elcmks *
6336 * Ammuon = Muon mass (GeV) = Ammumu * Amugev *
6337 * Fscto2 = (Fine structure constant)^2 *
6338 * Fscto3 = (Fine structure constant)^3 *
6339 * Fscto4 = (Fine structure constant)^4 *
6340 * Plabrc = Reduced Planck constant times the light velocity *
6341 * expressed in GeV fm *
6342 * Rclsel = Classical electron radius (cm) = e^2 / (m_e c^2) *
6343 * Conversion constants: *
6344 * GeVMeV = from GeV to MeV *
6345 * eMVGeV = from MeV to GeV *
6346 * Raddeg = from radians to degrees *
6347 * Degrad = from degrees to radians *
6348 * *
6349 *----------------------------------------------------------------------*
6350 *
6351  parameter( clight = 2.99792458 d+10 )
6352  parameter( avogad = 6.0221367 d+23 )
6353  parameter( amelgr = 9.1093897 d-28 )
6354  parameter( plckbr = 1.05457266 d-27 )
6355  parameter( elccgs = 4.8032068 d-10 )
6356  parameter( elcmks = 1.60217733 d-19 )
6357  parameter( amugrm = 1.6605402 d-24 )
6358  parameter( ammumu = 0.113428913 d+00 )
6359 * PARAMETER ( ALPFSC = 1.D+00 / 137.035989561D+00 )
6360 * PARAMETER ( FSCTO2 = ALPFSC * ALPFSC )
6361 * PARAMETER ( FSCTO3 = FSCTO2 * ALPFSC )
6362 * PARAMETER ( FSCTO4 = FSCTO3 * ALPFSC )
6363 * It is important to set the electron mass exactly with the same
6364 * rounding as in the mass tables, so use the explicit expression
6365 * PARAMETER ( AMELCT = 1.D-16 * AMELGR * CLIGHT * CLIGHT / ELCMKS )
6366 * It is important to set the amu mass exactly with the same
6367 * rounding as in the mass tables, so use the explicit expression
6368 * PARAMETER ( AMUGEV = 1.D-16 * AMUGRM * CLIGHT * CLIGHT / ELCMKS )
6369 * It is important to set the muon mass exactly with the same
6370 * rounding as in the mass tables, so use the explicit expression
6371 * PARAMETER ( AMMUON = AMMUMU * AMUGEV ELCMKS )
6372 * PARAMETER ( RCLSEL = ELCCGS * ELCCGS / CLIGHT / CLIGHT / AMELGR )
6373  parameter( alpfsc = 7.2973530791728595 d-03 )
6374  parameter( fscto2 = 5.3251361962113614 d-05 )
6375  parameter( fscto3 = 3.8859399018437826 d-07 )
6376  parameter( fscto4 = 2.8357075508200407 d-09 )
6377  parameter( plabrc = 0.197327053 d+00 )
6378  parameter( amelct = 0.51099906 d-03 )
6379  parameter( amugev = 0.93149432 d+00 )
6380  parameter( ammuon = 0.105658389 d+00 )
6381  parameter( rclsel = 2.8179409183694872 d-13 )
6382  parameter( gevmev = 1.0 d+03 )
6383  parameter( emvgev = 1.0 d-03 )
6384  parameter( raddeg = 180.d+00 / pipipi )
6385  parameter( degrad = pipipi / 180.d+00 )
6386 
6387 
6388 *$ CREATE DIMPAR.ADD
6389 *COPY DIMPAR
6390 * *
6391 *=== dimpar ==========================================================*
6392 * *
6393 *---------------------------------------------------------------------*
6394 * *
6395 * DIMPAR: included in any routine *
6396 * *
6397 * Mxxrgn = maximum number of regions *
6398 * Mxxmdf = maximum number of media in Fluka *
6399 * Mxxmde = maximum number of media in Emf *
6400 * Mfstck = stack dimension in Fluka *
6401 * Mestck = stack dimension in Emf *
6402 * Nallwp = number of allowed particles *
6403 * Mpdpdx = number of particle types for which EM dE/dx pro- *
6404 * cesses (ion,pair,bremss) have to be computed *
6405 * Icomax = maximum number of materials for compounds (equal *
6406 * to the sum of the number of materials for every *
6407 * compound ) *
6408 * Nstbis = number of stable isotopes recorded in common iso- *
6409 * top *
6410 * Idmaxp = number of particles/resonances defined in common *
6411 * part *
6412 * *
6413 *---------------------------------------------------------------------*
6414 * *
6415  parameter( mxxrgn = 500 )
6416  parameter( mxxmdf = 56 )
6417  parameter( mxxmde = 50 )
6418  parameter( mfstck = 1000 )
6419  parameter( mestck = 100 )
6420  parameter( nallwp = 39 )
6421  parameter( mpdpdx = 8 )
6422  parameter( icomax = 180 )
6423  parameter( nstbis = 304 )
6424  parameter( idmaxp = 210 )
6425 
6426 
6427 
6428 *$ CREATE IOUNIT.ADD
6429 *COPY IOUNIT
6430 * *
6431 *=== iounit ==========================================================*
6432 * *
6433 *---------------------------------------------------------------------*
6434 * *
6435 * Iounit: included in any routine *
6436 * *
6437 * lunin = standard input unit *
6438 * lunout = standard output unit *
6439 * lunerr = standard error unit *
6440 * lunber = input file for bertini nuclear data *
6441 * lunech = echo file for pegs dat *
6442 * lunflu = input file for photoelectric edges and X-ray fluo- *
6443 * rescence data *
6444 * lungeo = scratch file for combinatorial geometry *
6445 * lunpgs = input file for pegs material data *
6446 * lunran = output file for the final random number seed *
6447 * lunxsc = input file for low energy neutron cross sections *
6448 * lunrdb = unit number for reading (extra) auxiliary external *
6449 * files to be closed just after reading *
6450 * *
6451 *---------------------------------------------------------------------*
6452 * *
6453  parameter( lunin = 5 )
6454  parameter( lunout = 6 )
6455  parameter( lunerr = 66 )
6456  parameter( lunber = 14 )
6457  parameter( lunech = 8 )
6458  parameter( lunflu = 86 )
6459  parameter( lungeo = 16 )
6460  parameter( lunpgs = 12 )
6461  parameter( lunran = 2 )
6462  parameter( lunxsc = 81 )
6463  parameter( lunrdb = 1 )
6464 
6465 
6466 *$ CREATE PAPROP.ADD
6467 *COPY PAPROP
6468 *
6469 *=== paprop ===========================================================*
6470 *
6471 *----------------------------------------------------------------------*
6472 * include file: paprop copy created 26/11/86 by p*
6473 * changes: on 16 december 1992 by Alfredo Ferrari *
6474 * included in the following subroutines or functions: not updated *
6475 * *
6476 * description of the common block(s) and variable(s) *
6477 * *
6478 * /paprop/ contains particle properties *
6479 * btype = literal name of the particle *
6480 * am = particle mass in gev *
6481 * ichrge = electric charge of the particle *
6482 * iscore = explanations for the scored distribution *
6483 * genpar = names of the generalized particles *
6484 * ijdisc = list of the particle types to be discarded *
6485 * thalf = half life of the particle in sec *
6486 * biasdc = decay biasing factors *
6487 * biasin = inelastic interaction biasing factors *
6488 * lhadro = flag for hadrons *
6489 * jspinp = particle spin (in units of 1/2) *
6490 * lbsdcy = logical flag for biased decay: if .true. the biasing *
6491 * factor is used as an upper limit to the decay length *
6492 * lprbsd = logical flag for biased decay: if .true. the biasing *
6493 * factor is applied only to primaries *
6494 * lprbsi = logical flag for inelastic interaction biasing: if *
6495 * .true. the biasing factor is applied only to prima- *
6496 * ries *
6497 * *
6498 *----------------------------------------------------------------------*
6499 *
6500 C LOGICAL LHADRO, LBSDCY, LPRBSD, LPRBSI
6501 C CHARACTER*8 BTYPE,GENPAR
6502 C COMMON / PAPROP / AM (NALLWP), AMDISC (NALLWP), THALF (NALLWP),
6503 C & BIASDC (NALLWP), BIASIN (NALLWP), ICHRGE (NALLWP),
6504 C & ISCORE (10), IJDISC (NALLWP), LHADRO (NALLWP),
6505 C & JSPINP (NALLWP), LBSDCY (NALLWP), LPRBSD, LPRBSI
6506 C COMMON / CHPPRP / BTYPE (NALLWP), GENPAR (30)
6507 
6508  dimension ichrge(39),am(39)
6509 
6510 *$ CREATE PART2.ADD
6511 *COPY PART2
6512 *
6513 *=== part2 ============================================================*
6514 *
6515 *----------------------------------------------------------------------*
6516 * Include file: part2 copy Revised on 20-7-90 by A. Ferrari *
6517 * Note: see also part copy and part3 copy *
6518 * Changes: none *
6519 * Included in the following subroutines or functions: not updated *
6520 * *
6521 * Description of the common block(s) and variable(s) *
6522 * *
6523 * Kptoip = conversion from part to paprop numbering *
6524 * Iptokp = conversion from paprop to part numbering *
6525 * *
6526 *----------------------------------------------------------------------*
6527 *
6528 C CHARACTER*8 ANAME
6529 C COMMON / PART / AAM (IDMAXP), GA (IDMAXP), TAU (IDMAXP),
6530 C & AAMDSC (IDMAXP), ZMNABS (IDMAXP), ATNMNA (IDMAXP),
6531 C & IICH (IDMAXP), IIBAR (IDMAXP), K1 (IDMAXP),
6532 C & K2 (IDMAXP), KPTOIP (IDMAXP), IPTOKP (NALLWP)
6533 C COMMON / CHPART / ANAME (IDMAXP)
6534 
6535 *KEEP,DPAR.
6536 C /DPAR/ CONTAINS PARTICLE PROPERTIES
6537 C ANAME = LITERAL NAME OF THE PARTICLE
6538 C AAM = PARTICLE MASS IN GEV
6539 C GA = DECAY WIDTH
6540 C TAU = LIFE TIME OF INSTABLE PARTICLES
6541 C IICH = ELECTRIC CHARGE OF THE PARTICLE
6542 C IIBAR = BARYON NUMBER
6543 C K1,K1 = BIGIN AND END OF DECAY CHANNELS OF PARTICLE
6544 C
6545  CHARACTER*8 aname
6546  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),
6547  + iich(210),iibar(210),k1(210),k2(210)
6548  dimension kptoip(210),iptokp(39)
6549 C DATA KPTOIP/1, 2, 3, 4, 5, 6, 7, 8, 9, 10,
6550 C + 11,12,13,14,15,16,17,18,19,20,
6551 C + 21,22,23,24,25, 0, 0, 0, 0, 0,
6552 C + 60*0,
6553 C + 0, 0, 0, 0, 0, 0,34,36,31,32,
6554 C + 33,35,37, 0, 0, 0, 0, 0,38, 0,
6555 C + 0, 0, 0, 0,39, 0, 0, 0, 0, 0,
6556 C + 90*0/
6557 C DATA IPTOKP/1, 2, 3, 4, 5, 6, 7, 8, 9, 10,
6558 C + 11,12,13,14,15,16,17,18,19,20,
6559 C + 21,22,23,24,25, 0, 0, 0, 0, 0,
6560 C + 99,100,101,97,102,98,103,109,115/
6561 * *
6562 * Conversion from part to paprop numbering *
6563 * *
6564  DATA kptoip / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
6565  & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 66*0,
6566  & 34, 36, 31, 32, 33, 35, 37, 5*0, 38, 5*0, 39, 19*0, 27, 28, 74*0/
6567 * *
6568 * Conversion from paprop to part numbering *
6569 * *
6570  DATA iptokp / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
6571  & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 99,
6572  & 100, 101, 97, 102, 98, 103, 109, 115 /
6573 
6574 
6575 *$ CREATE QQUARK.ADD
6576 *COPY QQUARK
6577 *
6578 *=== qquark ===========================================================*
6579 *
6580 *----------------------------------------------------------------------*
6581 * *
6582 * Created on 6 february 1991 by Alfredo Ferrari *
6583 * INFN - Milan *
6584 * *
6585 * Last change on 6 february 1991 by Alfredo Ferrari *
6586 * *
6587 * Included in the following routines : *
6588 * *
6589 * COREVT *
6590 * CORRIN *
6591 * HADEVV *
6592 * HADEVT *
6593 * NUCEVV *
6594 * NUCEVT *
6595 * *
6596 * Quark content of particles: *
6597 * index quark el. charge bar. charge isospin isospin3 *
6598 * 1 = u 2/3 1/3 1/2 1/2 *
6599 * -1 = ubar -2/3 -1/3 1/2 -1/2 *
6600 * 2 = d -1/3 1/3 1/2 -1/2 *
6601 * -2 = dbar 1/3 -1/3 1/2 1/2 *
6602 * 3 = s -1/3 1/3 0 0 *
6603 * -3 = sbar 1/3 -1/3 0 0 *
6604 * 4 = c 2/3 1/3 0 0 *
6605 * -4 = cbar -2/3 -1/3 0 0 *
6606 * 5 = b -1/3 1/3 0 0 *
6607 * -5 = bbar 1/3 -1/3 0 0 *
6608 * 6 = t 2/3 1/3 0 0 *
6609 * -6 = tbar -2/3 -1/3 0 0 *
6610 * *
6611 * Mquark = particle quark composition (Paprop numbering) *
6612 * Iqechr = electric charge ( in 1/3 unit ) *
6613 * Iqbchr = baryonic charge ( in 1/3 unit ) *
6614 * Iqichr = isospin ( in 1/2 unit ), z component *
6615 * Iqschr = strangeness *
6616 * Iqcchr = charm *
6617 * Iquchr = beauty *
6618 * Iqtchr = ...... *
6619 * *
6620 *----------------------------------------------------------------------*
6621 *
6622  COMMON / qquark / iqechr(-6:6), iqbchr(-6:6), iqichr(-6:6),
6623  & iqschr(-6:6), iqcchr(-6:6), iquchr(-6:6),
6624  & iqtchr(-6:6), mquark(3,39)
6625 C
6626  dimension sieapp(11), sitapp(16), plaetb(16)
6627  dimension sgtcoe(5,33), plalim(2,33), ihlp(nallwp)
6628  dimension sgtco1(5,10),sgtco2(5,8),sgtco3(5,15)
6629  SAVE plaetb, sieapp, sitapp, sgtcoe, plalim, ihlp
6630  SAVE iqfsc1, iqfsc2, iqbsc1, iqbsc2
6631  equivalence(sgtco1(1,1),sgtcoe(1,1))
6632  equivalence(sgtco2(1,1),sgtcoe(1,11))
6633  equivalence(sgtco3(1,1),sgtcoe(1,19))
6634 * 1=baryon, 2=pion, 3=kaon, 4=antibaryon:
6635  DATA ihlp/1,4,5*0,1,4,2*0,3,2*2,2*3,1,4,3,3*1,2,
6636  & 2*3, 2, 4*0, 3*4, 1, 4, 1, 4, 1, 4 /
6637 C DATA ( ( SGTCOE (J,I), J=1,5 ), I=1,10 ) /
6638  DATA sgtco1 /
6639 * 1st reaction: gamma p total
6640  &0.147 d+00, zerzer , zerzer , 0.0022d+00, -0.0170d+00,
6641 * 2nd reaction: gamma d total
6642  &0.300 d+00, zerzer , zerzer , 0.0095d+00, -0.057 d+00,
6643 * 3rd reaction: pi+ p total
6644  &16.4 d+00, 19.3d+00, -0.42d+00, 0.19 d+00, zerzer ,
6645 * 4th reaction: pi- p total
6646  &33.0 d+00, 14.0d+00, -1.36d+00, 0.456 d+00, -4.03 d+00,
6647 * 5th reaction: pi+/- d total
6648  &56.8 d+00, 42.2d+00, -1.45d+00, 0.65 d+00, -5.39 d+00,
6649 * 6th reaction: K+ p total
6650  &18.1 d+00, zerzer , zerzer , 0.26 d+00, -1.0 d+00,
6651 * 7th reaction: K+ n total
6652  &18.7 d+00, zerzer , zerzer , 0.21 d+00, -0.89 d+00,
6653 * 8th reaction: K+ d total
6654  &34.2 d+00, 7.9 d+00, -2.1 d+00, 0.346 d+00, -0.99 d+00,
6655 * 9th reaction: K- p total
6656  &32.1 d+00, zerzer , zerzer , 0.66 d+00, -5.6 d+00,
6657 * 10th reaction: K- n total
6658  &25.2 d+00, zerzer , zerzer , 0.38 d+00, -2.9 d+00/
6659 C DATA ( ( SGTCOE (J,I), J=1,5 ), I=11,18 ) /
6660  DATA sgtco2 /
6661 * 11th reaction: K- d total
6662  &57.6 d+00, zerzer , zerzer , 1.17 d+00, -9.5 d+00,
6663 * 12th reaction: p p total
6664  &48.0 d+00, zerzer , zerzer , 0.522 d+00, -4.51 d+00,
6665 * 13th reaction: p n total
6666  &47.30 d+00, zerzer , zerzer , 0.513 d+00, -4.27 d+00,
6667 * 14th reaction: p d total
6668  &91.3 d+00, zerzer , zerzer , 1.05 d+00, -8.8 d+00,
6669 * 15th reaction: pbar p total
6670  &38.4 d+00, 77.6d+00, -0.64d+00, 0.26 d+00, -1.2 d+00,
6671 * 16th reaction: pbar n total
6672  &zerzer ,133.6d+00, -0.70d+00, -1.22 d+00, 13.7 d+00,
6673 * 17th reaction: pbar d total
6674  &112. d+00, 125.d+00, -1.08d+00, 1.14 d+00, -12.4 d+00,
6675 * 18th reaction: Lamda p total
6676  &30.4 d+00, zerzer , zerzer , zerzer , 1.6 d+00/
6677 C DATA ( ( SGTCOE (J,I), J=1,5 ), I=19,33 ) /
6678  DATA sgtco3 /
6679 * 19th reaction: pi+ p elastic
6680  &zerzer , 11.4d+00, -0.4 d+00, 0.079 d+00, zerzer ,
6681 * 20th reaction: pi- p elastic
6682  &1.76 d+00, 11.2d+00, -0.64d+00, 0.043 d+00, zerzer ,
6683 * 21st reaction: K+ p elastic
6684  &5.0 d+00, 8.1 d+00, -1.8 d+00, 0.16 d+00, -1.3 d+00,
6685 * 22nd reaction: K- p elastic
6686  &7.3 d+00, zerzer , zerzer , 0.29 d+00, -2.40 d+00,
6687 * 23rd reaction: p p elastic
6688  &11.9 d+00, 26.9d+00, -1.21d+00, 0.169 d+00, -1.85 d+00,
6689 * 24th reaction: p d elastic
6690  &16.1 d+00, zerzer , zerzer , 0.32 d+00, -3.4 d+00,
6691 * 25th reaction: pbar p elastic
6692  &10.2 d+00, 52.7d+00, -1.16d+00, 0.125 d+00, -1.28 d+00,
6693 * 26th reaction: pbar p elastic bis
6694  &10.6 d+00, 53.1d+00, -1.19d+00, 0.136 d+00, -1.41 d+00,
6695 * 27th reaction: pbar n elastic
6696  &36.5 d+00, zerzer , zerzer , zerzer , -11.9 d+00,
6697 * 28th reaction: Lamda p elastic
6698  &12.3 d+00, zerzer , zerzer , zerzer , -2.4 d+00,
6699 * 29th reaction: K- p ela bis
6700  &7.24 d+00, 46.0d+00, -4.71d+00, 0.279 d+00, -2.35 d+00,
6701 * 30th reaction: pi- p cx
6702  &zerzer ,0.912d+00, -1.22d+00, zerzer , zerzer ,
6703 * 31st reaction: K- p cx
6704  &zerzer , 3.39d+00, -1.75d+00, zerzer , zerzer ,
6705 * 32nd reaction: K+ n cx
6706  &zerzer , 7.18d+00, -2.01d+00, zerzer , zerzer ,
6707 * 33rd reaction: pbar p cx
6708  &zerzer , 18.8d+00, -2.01d+00, zerzer , zerzer /
6709 *
6710  DATA plalim /
6711 * gamma p tot , gamma d tot , pi+ p tot ,
6712  & 3.0d+00, 183.d+00, 2.0d+00, 17.8d+00, 4.0d+00, 340.d+00,
6713 * pi- p tot , pi+/- d tot , K+ p tot ,
6714  & 2.5d+00, 370.d+00, 2.5d+00, 370.d+00, 2.0d+00, 310.d+00,
6715 * K+ n tot , K+ d tot , K- p tot ,
6716  & 2.0d+00, 310.d+00, 2.0d+00, 310.d+00, 3.0d+00, 310.d+00,
6717 * K- n tot , K- d tot , p p tot ,
6718  & 1.8d+00, 310.d+00, 3.0d+00, 310.d+00, 3.0d+00, 2100.d+00,
6719 * p n tot , p d tot , pbar p tot ,
6720  & 3.0d+00, 370.d+00, 3.0d+00, 370.d+00, 5.0d+00, 1.73d+06,
6721 * pbar n tot , pbar d tot , Lamda p tot ,
6722  & 1.1d+00, 280.d+00, 2.0d+00, 280.d+00, 0.6d+00, 21.d+00,
6723 * pi+ p ela , pi- p ela , K+ p ela ,
6724  & 2.0d+00, 200.d+00, 2.0d+00, 360.d+00, 2.0d+00, 175.d+00,
6725 * K- p ela , p p ela , p d ela ,
6726  & 3.0d+00, 175.d+00, 3.0d+00, 2100.d+00, 2.0d+00, 384.d+00,
6727 * pbar p ela , pbar p ela bis , pbar n ela ,
6728  & 5.0d+00, 1.73d+06, 2.0d+00, 1.59d+05, 1.1d+00, 5.55d+00,
6729 * Lamda p ela , K- p ela bis , pi- p cx ,
6730  & 0.6d+00, 24.d+00, 2.0d+00, 175.d+00, 3.5d+00, 200.d+00,
6731 * K- p cx , K+ n cx , pbar p cx /
6732  & 2.0d+00, 40.d+00, 2.0d+00, 12.8d+00, 3.0d+00, 350.d+00/
6733 * Momenta for which tabulated data exist for elastic/total pbar p
6734  DATA plaetb / 0.1d+00, 0.2d+00,
6735  & 0.3d+00, 0.4d+00, 0.5d+00, 0.6d+00, 0.8d+00, 1.d+00,
6736  & 1.2d+00, 1.5d+00, 2. d+00, 2.5d+00, 3. d+00, 4.d+00,
6737  & 4.5d+00, 5. d+00 /
6738 * Tabulated data for pbar p elastic:
6739 * The two lowest energy points are educated guesses:
6740  DATA sieapp / 142.d+00, 95.1d+00,
6741  & 75.0d+00, 70.0d+00, 62.0d+00, 57.0d+00, 48.0d+00,
6742  & 44.5d+00, 43.5d+00, 38.0d+00, 33.0d+00 /
6743 * Tabulated data for pbar p total cross section:
6744  DATA sitapp /1129.d+00, 424.d+00,
6745  & 239.d+00, 195.d+00, 172.d+00, 150.d+00, 124.d+00,
6746  & 117.d+00, 109.d+00, 100.d+00, 90.2d+00, 81.5d+00,
6747  & 78.0d+00, 72.0d+00, 67.0d+00, 64.8d+00 /
6748 *
6749 * +-------------------------------------------------------------------*
6750  ichrge(ktarg)=iich(ktarg)
6751  am(ktarg)=aam(ktarg)
6752 * | Check for pi0 (d-dbar)
6753  IF ( kp .NE. 26 ) THEN
6754  ip = kptoip(kp)
6755  IF(ip.EQ.0)ip=1
6756  ichrge(ip)=iich(kp)
6757  am(ip)=aam(kp)
6758 * |
6759 * +-------------------------------------------------------------------*
6760 * |
6761  ELSE
6762  ip = 23
6763  ichrge(ip)=0
6764  END IF
6765 * |
6766 * +-------------------------------------------------------------------*
6767 * +-------------------------------------------------------------------*
6768 * | No such interactions for baryon-baryon
6769  IF ( iibar(kp) .GT. 0 ) THEN
6770  phnsch = zerzer
6771  RETURN
6772 * |
6773 * +-------------------------------------------------------------------*
6774 * | No "annihilation" diagram possible for K+ p/n
6775  ELSE IF ( ip .EQ. 15 ) THEN
6776  phnsch = zerzer
6777  RETURN
6778 * |
6779 * +-------------------------------------------------------------------*
6780 * | No "annihilation" diagram possible for K0 p/n
6781  ELSE IF ( ip .EQ. 24 ) THEN
6782  phnsch = zerzer
6783  RETURN
6784 * |
6785 * +-------------------------------------------------------------------*
6786 * | No "annihilation" diagram possible for Omebar p/n
6787  ELSE IF ( ip .GE. 38 ) THEN
6788  phnsch = zerzer
6789  RETURN
6790  END IF
6791 * |
6792 * +-------------------------------------------------------------------*
6793 * +-------------------------------------------------------------------*
6794 * | If the momentum is larger than 50 GeV/c, compute the single
6795 * | chain probability at 50 GeV/c and extrapolate to the present
6796 * | momentum according to 1/sqrt(s)
6797 * | sigma = sigma_sch (50) * sqrt (s(50)/s) + sigma_dch
6798 * | P_sch (50) = sigma_sch (50) / ( sigma_dch + sigma_sch (50) )
6799 * | sigma_dch / sigma_sch (50) = 1 / P_sch (50) - 1
6800 * | sigma_dch / sigma_sch = 1 / P_sch - 1 = ( 1 / P_sch (50) - 1 )
6801 * | x sqrt(s/s(50))
6802 * | P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
6803  IF ( plab .GT. 50.d+00 ) THEN
6804  pla = 50.d+00
6805  ampsq = am(ip)**2
6806  amtsq = am(ktarg)**2
6807  eproj = sqrt( plab**2 + ampsq )
6808  umosq = ampsq + amtsq + twotwo * am(ktarg) * eproj
6809  eproj = sqrt( pla**2 + ampsq )
6810  umo50 = ampsq + amtsq + twotwo * am(ktarg) * eproj
6811  umorat = sqrt( umosq / umo50 )
6812 * |
6813 * +-------------------------------------------------------------------*
6814 * | P < 3 GeV/c
6815  ELSE IF ( plab .LT. 3.d+00 ) THEN
6816  pla = 3.d+00
6817  ampsq = am(ip)**2
6818  amtsq = am(ktarg)**2
6819  eproj = sqrt( plab**2 + ampsq )
6820  umosq = ampsq + amtsq + twotwo * am(ktarg) * eproj
6821  eproj = sqrt( pla**2 + ampsq )
6822  umo50 = ampsq + amtsq + twotwo * am(ktarg) * eproj
6823  umorat = sqrt( umosq / umo50 )
6824 * |
6825 * +-------------------------------------------------------------------*
6826 * | P < 50 GeV/c
6827  ELSE
6828  pla = plab
6829  umorat = oneone
6830  END IF
6831 * |
6832 * +-------------------------------------------------------------------*
6833  algpla = log(pla)
6834 * +-------------------------------------------------------------------*
6835 * | Pions:
6836  IF ( ihlp(ip) .EQ. 2 ) THEN
6837  acof = sgtcoe(1,3)
6838  bcof = sgtcoe(2,3)
6839  enne = sgtcoe(3,3)
6840  ccof = sgtcoe(4,3)
6841  dcof = sgtcoe(5,3)
6842 * | Compute the pi+ p total cross section:
6843  sppptt = acof + bcof * pla**enne + ccof * algpla**2
6844  & + dcof * algpla
6845  acof = sgtcoe(1,19)
6846  bcof = sgtcoe(2,19)
6847  enne = sgtcoe(3,19)
6848  ccof = sgtcoe(4,19)
6849  dcof = sgtcoe(5,19)
6850 * | Compute the pi+ p elastic cross section:
6851  spppel = acof + bcof * pla**enne + ccof * algpla**2
6852  & + dcof * algpla
6853 * | Compute the pi+ p inelastic cross section:
6854  spppin = sppptt - spppel
6855  acof = sgtcoe(1,4)
6856  bcof = sgtcoe(2,4)
6857  enne = sgtcoe(3,4)
6858  ccof = sgtcoe(4,4)
6859  dcof = sgtcoe(5,4)
6860 * | Compute the pi- p total cross section:
6861  spmptt = acof + bcof * pla**enne + ccof * algpla**2
6862  & + dcof * algpla
6863  acof = sgtcoe(1,20)
6864  bcof = sgtcoe(2,20)
6865  enne = sgtcoe(3,20)
6866  ccof = sgtcoe(4,20)
6867  dcof = sgtcoe(5,20)
6868 * | Compute the pi- p elastic cross section:
6869  spmpel = acof + bcof * pla**enne + ccof * algpla**2
6870  & + dcof * algpla
6871 * | Compute the pi- p inelastic cross section:
6872  spmpin = spmptt - spmpel
6873  sigdia = spmpin - spppin
6874 * | +----------------------------------------------------------------*
6875 * | | Charged pions: besides isospin consideration it is supposed
6876 * | | that (pi+ n)el is almost equal to (pi- p)el
6877 * | | and (pi+ p)el " " " " (pi- n)el
6878 * | | and all are almost equal among each others
6879 * | | (reasonable above 5 GeV/c)
6880  IF ( ichrge(ip) .NE. 0 ) THEN
6881  khelp = ktarg / 8
6882  jreac = 3 + ip - 13 + ichrge(ip) * khelp
6883  acof = sgtcoe(1,jreac)
6884  bcof = sgtcoe(2,jreac)
6885  enne = sgtcoe(3,jreac)
6886  ccof = sgtcoe(4,jreac)
6887  dcof = sgtcoe(5,jreac)
6888 * | | Compute the total cross section:
6889  shnctt = acof + bcof * pla**enne + ccof * algpla**2
6890  & + dcof * algpla
6891  jreac = 19 + ip - 13 + ichrge(ip) * khelp
6892  acof = sgtcoe(1,jreac)
6893  bcof = sgtcoe(2,jreac)
6894  enne = sgtcoe(3,jreac)
6895  ccof = sgtcoe(4,jreac)
6896  dcof = sgtcoe(5,jreac)
6897 * | | Compute the elastic cross section:
6898  shncel = acof + bcof * pla**enne + ccof * algpla**2
6899  & + dcof * algpla
6900 * | | Compute the inelastic cross section:
6901  shncin = shnctt - shncel
6902 * | | Number of diagrams:
6903  ndiagr = 1 + ip - 13 + ichrge(ip) * khelp
6904 * | | Now compute the chain end (anti)quark-(anti)diquark
6905  iqfsc1 = 1 + ip - 13
6906  iqfsc2 = 0
6907  iqbsc1 = 1 + khelp
6908  iqbsc2 = 1 + ip - 13
6909 * | |
6910 * | +----------------------------------------------------------------*
6911 * | | pi0: besides isospin consideration it is supposed that the
6912 * | | elastic cross section is not very different from
6913 * | | pi+ p and/or pi- p (reasonable above 5 GeV/c)
6914  ELSE
6915  khelp = ktarg / 8
6916  k2hlp = ( kp - 23 ) / 3
6917 * | | Number of diagrams:
6918 * | | For u ubar (k2hlp=0):
6919 * NDIAGR = 2 - KHELP
6920 * | | For d dbar (k2hlp=1):
6921 * NDIAGR = 2 + KHELP - K2HLP
6922  ndiagr = 2 + khelp * ( 2 * k2hlp - 1 ) - k2hlp
6923  shncin = hlfhlf * ( spppin + spmpin )
6924 * | | Now compute the chain end (anti)quark-(anti)diquark
6925  iqfsc1 = 1 + k2hlp
6926  iqfsc2 = 0
6927  iqbsc1 = 1 + khelp
6928  iqbsc2 = 2 - k2hlp
6929  END IF
6930 * | |
6931 * | +----------------------------------------------------------------*
6932 * | end pi's
6933 * +-------------------------------------------------------------------*
6934 * | Kaons:
6935  ELSE IF ( ihlp(ip) .EQ. 3 ) THEN
6936  acof = sgtcoe(1,6)
6937  bcof = sgtcoe(2,6)
6938  enne = sgtcoe(3,6)
6939  ccof = sgtcoe(4,6)
6940  dcof = sgtcoe(5,6)
6941 * | Compute the K+ p total cross section:
6942  skpptt = acof + bcof * pla**enne + ccof * algpla**2
6943  & + dcof * algpla
6944  acof = sgtcoe(1,21)
6945  bcof = sgtcoe(2,21)
6946  enne = sgtcoe(3,21)
6947  ccof = sgtcoe(4,21)
6948  dcof = sgtcoe(5,21)
6949 * | Compute the K+ p elastic cross section:
6950  skppel = acof + bcof * pla**enne + ccof * algpla**2
6951  & + dcof * algpla
6952 * | Compute the K+ p inelastic cross section:
6953  skppin = skpptt - skppel
6954  acof = sgtcoe(1,9)
6955  bcof = sgtcoe(2,9)
6956  enne = sgtcoe(3,9)
6957  ccof = sgtcoe(4,9)
6958  dcof = sgtcoe(5,9)
6959 * | Compute the K- p total cross section:
6960  skmptt = acof + bcof * pla**enne + ccof * algpla**2
6961  & + dcof * algpla
6962  acof = sgtcoe(1,22)
6963  bcof = sgtcoe(2,22)
6964  enne = sgtcoe(3,22)
6965  ccof = sgtcoe(4,22)
6966  dcof = sgtcoe(5,22)
6967 * | Compute the K- p elastic cross section:
6968  skmpel = acof + bcof * pla**enne + ccof * algpla**2
6969  & + dcof * algpla
6970 * | Compute the K- p inelastic cross section:
6971  skmpin = skmptt - skmpel
6972  sigdia = hlfhlf * ( skmpin - skppin )
6973 * | +----------------------------------------------------------------*
6974 * | | Charged Kaons: actually only K-
6975  IF ( ichrge(ip) .NE. 0 ) THEN
6976  khelp = ktarg / 8
6977 * | | +-------------------------------------------------------------*
6978 * | | | Proton target:
6979  IF ( khelp .EQ. 0 ) THEN
6980  shncin = skmpin
6981 * | | | Number of diagrams:
6982  ndiagr = 2
6983 * | | |
6984 * | | +-------------------------------------------------------------*
6985 * | | | Neutron target: besides isospin consideration it is supposed
6986 * | | | that (K- n)el is almost equal to (K- p)el
6987 * | | | (reasonable above 5 GeV/c)
6988  ELSE
6989  acof = sgtcoe(1,10)
6990  bcof = sgtcoe(2,10)
6991  enne = sgtcoe(3,10)
6992  ccof = sgtcoe(4,10)
6993  dcof = sgtcoe(5,10)
6994 * | | | Compute the total cross section:
6995  shnctt = acof + bcof * pla**enne + ccof * algpla**2
6996  & + dcof * algpla
6997 * | | | Compute the elastic cross section:
6998  shncel = skmpel
6999 * | | | Compute the inelastic cross section:
7000  shncin = shnctt - shncel
7001 * | | | Number of diagrams:
7002  ndiagr = 1
7003  END IF
7004 * | | |
7005 * | | +-------------------------------------------------------------*
7006 * | | Now compute the chain end (anti)quark-(anti)diquark
7007  iqfsc1 = 3
7008  iqfsc2 = 0
7009  iqbsc1 = 1 + khelp
7010  iqbsc2 = 2
7011 * | |
7012 * | +----------------------------------------------------------------*
7013 * | | K0's: (actually only K0bar)
7014  ELSE
7015  khelp = ktarg / 8
7016 * | | +-------------------------------------------------------------*
7017 * | | | Proton target: (K0bar p)in supposed to be given by
7018 * | | | (K- p)in - Sig_diagr
7019  IF ( khelp .EQ. 0 ) THEN
7020  shncin = skmpin - sigdia
7021 * | | | Number of diagrams:
7022  ndiagr = 1
7023 * | | |
7024 * | | +-------------------------------------------------------------*
7025 * | | | Neutron target: (K0bar n)in supposed to be given by
7026 * | | | (K- n)in + Sig_diagr
7027 * | | | besides isospin consideration it is supposed
7028 * | | | that (K- n)el is almost equal to (K- p)el
7029 * | | | (reasonable above 5 GeV/c)
7030  ELSE
7031  acof = sgtcoe(1,10)
7032  bcof = sgtcoe(2,10)
7033  enne = sgtcoe(3,10)
7034  ccof = sgtcoe(4,10)
7035  dcof = sgtcoe(5,10)
7036 * | | | Compute the total cross section:
7037  shnctt = acof + bcof * pla**enne + ccof * algpla**2
7038  & + dcof * algpla
7039 * | | | Compute the elastic cross section:
7040  shncel = skmpel
7041 * | | | Compute the inelastic cross section:
7042  shncin = shnctt - shncel + sigdia
7043 * | | | Number of diagrams:
7044  ndiagr = 2
7045  END IF
7046 * | | |
7047 * | | +-------------------------------------------------------------*
7048 * | | Now compute the chain end (anti)quark-(anti)diquark
7049  iqfsc1 = 3
7050  iqfsc2 = 0
7051  iqbsc1 = 1
7052  iqbsc2 = 1 + khelp
7053  END IF
7054 * | |
7055 * | +----------------------------------------------------------------*
7056 * | end Kaon's
7057 * +-------------------------------------------------------------------*
7058 * | Antinucleons:
7059  ELSE IF ( ihlp(ip) .EQ. 4 .AND. ip .LE. 9 ) THEN
7060 * | For momenta between 3 and 5 GeV/c the use of tabulated data
7061 * | should be implemented!
7062  acof = sgtcoe(1,15)
7063  bcof = sgtcoe(2,15)
7064  enne = sgtcoe(3,15)
7065  ccof = sgtcoe(4,15)
7066  dcof = sgtcoe(5,15)
7067 * | Compute the pbar p total cross section:
7068  sapptt = acof + bcof * pla**enne + ccof * algpla**2
7069  & + dcof * algpla
7070  IF ( pla .LT. fivfiv ) THEN
7071  jreac = 26
7072  ELSE
7073  jreac = 25
7074  END IF
7075  acof = sgtcoe(1,jreac)
7076  bcof = sgtcoe(2,jreac)
7077  enne = sgtcoe(3,jreac)
7078  ccof = sgtcoe(4,jreac)
7079  dcof = sgtcoe(5,jreac)
7080 * | Compute the pbar p elastic cross section:
7081  sappel = acof + bcof * pla**enne + ccof * algpla**2
7082  & + dcof * algpla
7083 * | Compute the pbar p inelastic cross section:
7084  sappin = sapptt - sappel
7085  acof = sgtcoe(1,12)
7086  bcof = sgtcoe(2,12)
7087  enne = sgtcoe(3,12)
7088  ccof = sgtcoe(4,12)
7089  dcof = sgtcoe(5,12)
7090 * | Compute the p p total cross section:
7091  spptot = acof + bcof * pla**enne + ccof * algpla**2
7092  & + dcof * algpla
7093  acof = sgtcoe(1,23)
7094  bcof = sgtcoe(2,23)
7095  enne = sgtcoe(3,23)
7096  ccof = sgtcoe(4,23)
7097  dcof = sgtcoe(5,23)
7098 * | Compute the p p elastic cross section:
7099  sppela = acof + bcof * pla**enne + ccof * algpla**2
7100  & + dcof * algpla
7101 * | Compute the K- p inelastic cross section:
7102  sppine = spptot - sppela
7103  sigdia = ( sappin - sppine ) / fivfiv
7104  khelp = ktarg / 8
7105 * | +----------------------------------------------------------------*
7106 * | | Pbar:
7107  IF ( ichrge(ip) .NE. 0 ) THEN
7108  ndiagr = 5 - khelp
7109 * | | +-------------------------------------------------------------*
7110 * | | | Proton target:
7111  IF ( khelp .EQ. 0 ) THEN
7112 * | | | Number of diagrams:
7113  shncin = sappin
7114  puubar = 0.8d+00
7115 * | | |
7116 * | | +-------------------------------------------------------------*
7117 * | | | Neutron target: it is supposed that (ap n)el is almost equal
7118 * | | | to (ap p)el (reasonable above 5 GeV/c)
7119  ELSE
7120  acof = sgtcoe(1,16)
7121  bcof = sgtcoe(2,16)
7122  enne = sgtcoe(3,16)
7123  ccof = sgtcoe(4,16)
7124  dcof = sgtcoe(5,16)
7125 * | | | Compute the total cross section:
7126  shnctt = acof + bcof * pla**enne + ccof * algpla**2
7127  & + dcof * algpla
7128 * | | | Compute the elastic cross section:
7129  shncel = sappel
7130 * | | | Compute the inelastic cross section:
7131  shncin = shnctt - shncel
7132  puubar = hlfhlf
7133  END IF
7134 * | | |
7135 * | | +-------------------------------------------------------------*
7136 * | | Now compute the chain end (anti)quark-(anti)diquark
7137 * | | there are different possibilities, make a random choiche:
7138  iqfsc1 = -1
7139  rnchen = rndm(rnchen)
7140  IF ( rnchen .LT. puubar ) THEN
7141  iqfsc2 = -2
7142  ELSE
7143  iqfsc2 = -1
7144  END IF
7145  iqbsc1 = -iqfsc1 + khelp
7146  iqbsc2 = -iqfsc2
7147 * | |
7148 * | +----------------------------------------------------------------*
7149 * | | nbar:
7150  ELSE
7151  ndiagr = 4 + khelp
7152 * | | +-------------------------------------------------------------*
7153 * | | | Proton target: (nbar p)in supposed to be given by
7154 * | | | (pbar p)in - Sig_diagr
7155  IF ( khelp .EQ. 0 ) THEN
7156  shncin = sappin - sigdia
7157  pddbar = hlfhlf
7158 * | | |
7159 * | | +-------------------------------------------------------------*
7160 * | | | Neutron target: (nbar n)el is supposed to be equal to
7161 * | | | (pbar p)el (reasonable above 5 GeV/c)
7162  ELSE
7163 * | | | Compute the total cross section:
7164  shnctt = sapptt
7165 * | | | Compute the elastic cross section:
7166  shncel = sappel
7167 * | | | Compute the inelastic cross section:
7168  shncin = shnctt - shncel
7169  pddbar = 0.8d+00
7170  END IF
7171 * | | |
7172 * | | +-------------------------------------------------------------*
7173 * | | Now compute the chain end (anti)quark-(anti)diquark
7174 * | | there are different possibilities, make a random choiche:
7175  iqfsc1 = -2
7176  rnchen = rndm(rnchen)
7177  IF ( rnchen .LT. pddbar ) THEN
7178  iqfsc2 = -1
7179  ELSE
7180  iqfsc2 = -2
7181  END IF
7182  iqbsc1 = -iqfsc1 + khelp - 1
7183  iqbsc2 = -iqfsc2
7184  END IF
7185 * | |
7186 * | +----------------------------------------------------------------*
7187 * |
7188 * +-------------------------------------------------------------------*
7189 * | Others: not yet implemented
7190  ELSE
7191  sigdia = zerzer
7192  shncin = oneone
7193  ndiagr = 0
7194  phnsch = zerzer
7195  RETURN
7196  END IF
7197 * | end others
7198 * +-------------------------------------------------------------------*
7199  phnsch = ndiagr * sigdia / shncin
7200  iqechc = iqechr(iqfsc1) + iqechr(iqfsc2) + iqechr(iqbsc1)
7201  & + iqechr(iqbsc2)
7202  iqbchc = iqbchr(iqfsc1) + iqbchr(iqfsc2) + iqbchr(iqbsc1)
7203  & + iqbchr(iqbsc2)
7204  iqechc = iqechc / 3
7205  iqbchc = iqbchc / 3
7206  iqschc = iqschr(iqfsc1) + iqschr(iqfsc2) + iqschr(iqbsc1)
7207  & + iqschr(iqbsc2)
7208  iqspro = iqschr(mquark(1,ip)) + iqschr(mquark(2,ip))
7209  & + iqschr(mquark(3,ip))
7210 * +-------------------------------------------------------------------*
7211 * | Consistency check:
7212  IF ( phnsch .LE. zerzer .OR. phnsch .GT. oneone ) THEN
7213  WRITE (lunout,*)' *** Phnsch,kp,ktarg,pla',
7214  & phnsch,kp,ktarg,pla,' ****'
7215  WRITE (lunerr,*)' *** Phnsch,kp,ktarg,pla',
7216  & phnsch,kp,ktarg,pla,' ****'
7217  phnsch = max( phnsch, zerzer )
7218  phnsch = min( phnsch, oneone )
7219  END IF
7220 * |
7221 * +-------------------------------------------------------------------*
7222 * +-------------------------------------------------------------------*
7223 * | Consistency check:
7224  IF ( iqspro .NE. iqschc .OR. ichrge(ip) + ichrge(ktarg)
7225  & .NE. iqechc .OR. iibar(kp) + iibar(ktarg) .NE. iqbchc) THEN
7226  WRITE (lunout,*)
7227  &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
7228  & iqspro,iqschc,ichrge(ip),iqechc,iibar(kp),iqbchc,ktarg
7229  WRITE (lunerr,*)
7230  &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
7231  & iqspro,iqschc,ichrge(ip),iqechc,iibar(kp),iqbchc,ktarg
7232  END IF
7233 * |
7234 * +-------------------------------------------------------------------*
7235 * P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
7236  IF ( umorat .GT. onepls ) phnsch = oneone / ( ( oneone / phnsch
7237  & - oneone ) * umorat + oneone )
7238  RETURN
7239 *
7240  entry schqua( jqfsc1, jqfsc2, jqbsc1, jqbsc2 )
7241  schqua = oneone
7242  jqfsc1 = iqfsc1
7243  jqfsc2 = iqfsc2
7244  jqbsc1 = iqbsc1
7245  jqbsc2 = iqbsc2
7246 *=== End of function Phnsch ===========================================*
7247  RETURN
7248  END
7249 *
7250 *=== qprop ============================================================*
7251 *
7252  BLOCK DATA qprop
7253 *----------------------------------------------------------------------*
7254 * *
7255 * Created on 6 february 1991 by Alfredo Ferrari *
7256 * INFN - Milan *
7257 * *
7258 * Last change on 6 february 1991 by Alfredo Ferrari *
7259 * *
7260 * Included in the following routines : *
7261 * *
7262 * COREVT *
7263 * CORRIN *
7264 * HADEVV *
7265 * HADEVT *
7266 * NUCEVV *
7267 * NUCEVT *
7268 * *
7269 * Quark content of particles: *
7270 * index quark el. charge bar. charge isospin isospin3 *
7271 * 1 = u 2/3 1/3 1/2 1/2 *
7272 * -1 = ubar -2/3 -1/3 1/2 -1/2 *
7273 * 2 = d -1/3 1/3 1/2 -1/2 *
7274 * -2 = dbar 1/3 -1/3 1/2 1/2 *
7275 * 3 = s -1/3 1/3 0 0 *
7276 * -3 = sbar 1/3 -1/3 0 0 *
7277 * 4 = c 2/3 1/3 0 0 *
7278 * -4 = cbar -2/3 -1/3 0 0 *
7279 * 5 = b -1/3 1/3 0 0 *
7280 * -5 = bbar 1/3 -1/3 0 0 *
7281 * 6 = t 2/3 1/3 0 0 *
7282 * -6 = tbar -2/3 -1/3 0 0 *
7283 * *
7284 * Mquark = particle quark composition (Paprop numbering) *
7285 * Iqechr = electric charge ( in 1/3 unit ) *
7286 * Iqbchr = baryonic charge ( in 1/3 unit ) *
7287 * Iqichr = isospin ( in 1/2 unit ), z component *
7288 * Iqschr = strangeness *
7289 * Iqcchr = charm *
7290 * Iquchr = beauty *
7291 * Iqtchr = ...... *
7292 * *
7293 *----------------------------------------------------------------------*
7294 *
7295  IMPLICIT DOUBLE PRECISION (a-h,o-z)
7296 
7297  COMMON / qquark / iqechr(-6:6), iqbchr(-6:6), iqichr(-6:6),
7298  & iqschr(-6:6), iqcchr(-6:6), iquchr(-6:6),
7299  & iqtchr(-6:6), mquark(3,39)
7300 
7301 *
7302 * / Qquark /
7303  DATA iqechr / -2, 1, -2, 1, 1, -2, 0, 2, -1, -1, 2, -1, 2 /
7304  DATA iqbchr / 6*-1, 0, 6*1 /
7305  DATA iqichr / 4*0, 1, -1, 0, 1, -1, 4*0 /
7306  DATA iqschr / 3*0, 1, 5*0, -1, 3*0 /
7307  DATA iqcchr / 2*0, -1, 7*0, 1, 2*0 /
7308  DATA iquchr / 0, 1, 9*0, -1, 0 /
7309  DATA iqtchr / -1, 11*0, 1 /
7310  DATA mquark / 1,1,2, -1,-1,-2,
7311  * 0,0,0, 0,0,0, 0,0,0, 0,0,0, 0,0,0,
7312  * 1,2,2, -1,-2,-2, 0,0,0, 0,0,0, 0,0,0,
7313  * 1,-2,0, 2,-1,0, 1,-3,0, 3,-1,0,
7314  * 1,2,3, -1,-2,-3, 0,0,0,
7315  * 2,2,3, 1,1,3, 1,2,3, 1,-1,0,
7316  * 2,-3,0, 3,-2,0, 2,-2,0, 0,0,0,
7317  * 0,0,0, 0,0,0, 0,0,0,
7318  * -1,-1,-3, -1,-2,-3, -2,-2,-3,
7319  * 1,3,3, -1,-3,-3, 2,3,3, -2,-3,-3,
7320  * 3,3,3, -3,-3,-3 /
7321 
7322  END
7323 C******************************************************************
7324  SUBROUTINE selpts( PTXSQ1,PTYSQ1,
7325  +plq1,eq1,ptxsa2,
7326  +ptysa2,plaq2,eaq2, amch1,irej,ikvala,pttq1)
7327  IMPLICIT DOUBLE PRECISION (a-h,o-z)
7328 C SELECT PT VALUES FOR A SINGLE CHAIN SYSTEM
7329 C SELECT SEA QUARK AND ANTIQUARK PT-VALUES
7330 *KEEP,DPRIN.
7331  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
7332 *KEEP,DROPPT.
7333  LOGICAL intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada, ipadis,
7334  +ishmal,lpauli
7335  COMMON /droppt/ intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada,
7336  +ipadis,ishmal,lpauli
7337 *KEND.
7338  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
7339 C--------------------------------
7340 C change j.r.6.5.93
7341  qtxsq1=ptxsq1
7342  qtxsa2=ptxsa2
7343  qtysq1=ptysq1
7344  qtysa2=ptysa2
7345  qlq1=plq1
7346  qlaq2=plaq2
7347  qeq1=eq1
7348  qeaq2=eaq2
7349 C ----------------
7350  ianfa=0
7351  itagpt=0
7352 C changed from 3. j.r.21.8.93
7353  b33=3.00
7354  IF (ikvala.EQ.1)b33=6.0
7355  icount=0
7356  irej=0
7357  10 CONTINUE
7358  icount=icount+1
7359  IF (icount.EQ.10)THEN
7360  irej=1
7361 C REJECT EVENT
7362  RETURN
7363  ENDIF
7364  IF (icount.GE.1)THEN
7365  hps=hps*0.9
7366  ptxsq1=qtxsq1+hps*cfe
7367  ptysq1=qtysq1+hps*sfe
7368  ptxsa2=qtxsa2-hps*cfe
7369  ptysa2=qtysa2-hps*sfe
7370  go to 111
7371  ENDIF
7372  b33=2.*b33
7373 C
7374  es=-2./(b33**2)*log(abs(rndm(v)*rndm(u))+0.00000001)
7375  hps=sqrt(es*es+2.*es*0.94)
7376 C............................................................
7377  110 CONTINUE
7378  IF (.NOT.intpt) hps=0.0000001
7379 C.............................................................
7380  CALL dsfecf(sfe,cfe)
7381 C change j.r.6.5.93
7382  ptxsq1=qtxsq1+hps*cfe
7383  ptysq1=qtysq1+hps*sfe
7384  ptxsa2=qtxsa2-hps*cfe
7385  ptysa2=qtysa2-hps*sfe
7386  111 CONTINUE
7387 C -----------------
7388 C
7389  IF (ipev.GE.6)WRITE(6,1000)ptxsq1,ptysq1,
7390  +ptxsa2,ptysa2
7391  1000 FORMAT (' PT S ',8f12.6)
7392 C KINEMATICS OF THE TWO CHAINS Q1-AQ2,AQ1-Q2
7393  pttq1=ptxsq1**2+ptysq1**2
7394  IF((eq1**2.LE.pttq1)) go to 10
7395 C
7396  ianfa2=0
7397  itagp2=0
7398  b33=3.00
7399  IF (ikvala.EQ.1)b33=6.0
7400  icoun2=0
7401  irej=0
7402  12 CONTINUE
7403  icoun2=icoun2+1
7404  IF (icoun2.EQ.12)THEN
7405  irej=1
7406 C REJECT EVENT
7407  RETURN
7408  ENDIF
7409 C -----------------
7410 C
7411  IF (ipev.GE.6)WRITE(6,1000)ptxsq1,ptysq1,
7412  +ptxsa2,ptysa2
7413 C KINEMATICS OF THE TWO CHAINS Q1-AQ2,AQ1-Q2
7414  ptta2=ptxsa2**2+ptysa2**2
7415  IF((eaq2**2.LE.ptta2)) go to 12
7416 
7417 C
7418  IF(ip.GE.1)go to 1779
7419  plq1=sqrt(eq1**2-pttq1)
7420  plaq2=-sqrt(eaq2**2-ptta2)
7421  1779 CONTINUE
7422 C-----------
7423 C-----------
7424 C CHAIN 1: Q1-AQ2 CHAIN2: AQ1-Q2
7425  amch1q=(eq1+eaq2)**2-(ptxsq1+ptxsa2)** 2-(ptysq1+ptysa2)**2-(plq1
7426  ++plaq2)**2
7427  IF (amch1q.LE.0.d0)THEN
7428  WRITE(6,301)amch1q
7429  301 FORMAT(' inconsistent Kinematics in SELPT AMCH1Q=',e12.3)
7430  WRITE(6,305) qtxsq1,qtysq1,
7431  +qlq1,qeq1,qtxsa1,qtysa1,qlaq1,qeaq1, qtxsq2,qtysq2,qlq2,qeq2,
7432  +qtxsa2,
7433  +qtysa2,qlaq2,qeaq2, amch1,amch2
7434  305 FORMAT( 'PTXSQ1,PTYSQ1,
7435  +PLQ1,EQ1,PTXSA1,PTYSA1,PLAQ1,EAQ1, PTXSQ2,PTYSQ2,PLQ2,EQ2,PTXSA2,
7436  +PTYSA2,PLAQ2,EAQ2, AMCH1,AMCH2',5(4e15.5/))
7437  irej=1
7438  RETURN
7439  ENDIF
7440  amch1=sqrt(amch1q)
7441 C
7442  RETURN
7443  END
Generated on Sat May 25 2013 14:32:36 for Geant4 by   doxygen 1.8.4