Geant4_10
dpm25nuc7g4.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 C I0=1
1910 C I2=N
1911 C 10 CONTINUE
1912 C I1=(I0+I2)/2
1913 C LEFT=((BSITE(1,I0)-Y)*(BSITE(1,I1)-Y)).LT.0.D0
1914 C IF(LEFT) GO TO 20
1915 C I0=I1
1916 C GO TO 30
1917 C 20 CONTINUE
1918 C I2=I1
1919 C 30 CONTINUE
1920 C IF(I2-I0-2)40,50,60
1921 C 40 CONTINUE
1922 C I1=I2+1
1923 C IF(I1.GT.N)I1=I0-1
1924 C GO TO 70
1925 C 50 CONTINUE
1926 C I1=I0+1
1927 C GO TO 70
1928 C 60 CONTINUE
1929 C GO TO 10
1930 C 70 CONTINUE
1931 C X0=(I0-1)*BSTEP
1932 C X1=(I1-1)*BSTEP
1933 C X2=(I2-1)*BSTEP
1934 C Y0=BSITE(1,I0)
1935 C Y1=BSITE(1,I1)
1936 C Y2=BSITE(1,I2)
1937 C 80 CONTINUE
1938 C B=X0*(Y-Y1)*(Y-Y2)/((Y0-Y1)*(Y0-Y2)+1.E-9)+ X1*(Y-Y0)*(Y-Y2)
1939 C +/((Y1-Y0)*(Y1-Y2)+1.E-9)+ X2*(Y-Y0)*(Y-Y1)/((Y2-Y0)*(Y2-Y1)+1.E-9)
1940 Cvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
1941  CALL g4dpmjet_modb(y,b)
1942 C^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
1943 **sr 14.4.98
1944  b = b+0.5d0*bstep
1945  IF (b.LT.0.0d0) b = x1
1946  IF (b.GT.bmax) b = bmax
1947 **
1948 
1949  RETURN
1950  END
1951 *-- Author :
1952 C
1953 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1954 C
1955  SUBROUTINE diagr(NA,NB,B,JS,JT,INT,INTA,INTB)
1956  IMPLICIT DOUBLE PRECISION (a-h,o-z)
1957  SAVE
1958 *---
1959 * -sample new impct parameter B
1960 * -sample nucleon configuration for projectile and target
1961 * -sample number of collisions INT, INTA, INTB
1962 *---
1963 *KEEP,INTMX.
1964  parameter(intmx=2488,intmd=252)
1965 *KEEP,SHMAKL.
1966 C INCLUDE (SHMAKL)
1967 * NOTE: INTMX set via INCLUDE(INTMX)
1968  common/shmakl/jssh(intmx),jtsh(intmx),inter1(intmx),inter2(intmx)
1969 *KEEP,DPRIN.
1970  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
1971 *KEEP,DSHM.
1972  COMMON /dshm/ rash,rbsh,bmax,bstep,sigsh,rosh,gsh,
1973  * bsite(0:1,200),nstatb,nsiteb
1974  COMMON /dshms/ sigshs
1975 *KEEP,NUCKOO.
1976  COMMON /nuckoo/ pkoo(3,intmx),tkoo(3,intmx),ppoo(3,intmx),
1977  +tpoo(3,intmx)
1978 *KEEP,DAMP.
1979 C COMPLEX*16 CA,CI
1980  DOUBLE COMPLEX ca,ci
1981  COMMON /damp/ ca,ci,ga
1982 *KEND.
1983  COMMON /kkmatu/kkmato,kkmata,ipoo,ipoa,ipzoo,ipzoa
1984  *,ibproo,ibproa,ireado
1985  COMMON /fluctu/ifluct
1986  COMMON /fluarr/flusi(1000),fluix(1000),fluixx(1000)
1987  parameter(namx=248)
1988  dimension js(namx),jt(namx)
1989 C COMPLEX*16 C
1990  DOUBLE COMPLEX c
1991  DATA icnt/0/
1992  DATA intco/0/
1993 C------------------------------
1994 **sr 14.4.98
1995  CALL modb(bsite,nsiteb,bstep,b)
1996  intco=0
1997 **
1998  DO 10 i=1,na
1999  10 js(i)=0
2000  DO 20 i=1,nb
2001  20 jt(i)=0
2002 C--------
2003  30 int=0
2004  inta=0
2005  intb=0
2006  intco=intco+1
2007  IF(intco.GE.500)THEN
2008  intco=0
2009  CALL modb(bsite,nsiteb,bstep,b)
2010  ENDIF
2011 C--------
2012 C IF (KKMATO.NE.KKMATA.AND.IPOO.NE.IPOA.AND.
2013 C * IBPROO.NE.IBPROA.AND.IPZOO.NE.IPZOA )THEN
2014  CALL conucl(pkoo,na,rash)
2015  CALL sortin(pkoo,na)
2016  CALL conucl(tkoo,nb,rbsh)
2017  CALL sort(tkoo,nb)
2018  kkmato=kkmata
2019  ipoo=ipoa
2020  ipzoo=ipzoa
2021  ibproo=ibproa
2022 C ELSEIF (KKMATO.EQ.KKMATA.AND.IPOO.EQ.IPOA.AND.
2023 C * IPZOO.EQ.IPZOA)THEN
2024 C IF(MOD(ICNT,5).EQ.0) THEN
2025 C CALL CONUCL(PKOO,NA,RASH)
2026 C CALL SORTIN(PKOO,NA)
2027 C CALL CONUCL(TKOO,NB,RBSH)
2028 C CALL SORT(TKOO,NB)
2029 C ENDIF
2030 C ICNT=ICNT+1
2031 C ENDIF
2032 C
2033  IF(ipev.GE.6) WRITE (6,1000)icnt,pkoo(1,1),tkoo(1,1)
2034  1000 FORMAT (' 111 FORM IN DIAGR ICNT,PKOO(1,1),TKOO(1,1) ',i6,2f10.3)
2035 C--------
2036  DO 40 i=1,na
2037  x1=b-pkoo(1,i)
2038  x2=-pkoo(2,i)
2039  IF(ifluct.EQ.0)THEN
2040  afluk=1.
2041  ELSEIF(ifluct.EQ.1)THEN
2042  ifuk=(rndm(v)+0.001)*1000.
2043  afluk=fluixx(ifuk)
2044  ENDIF
2045  DO 40 j=1,nb
2046  q1=x1+tkoo(1,j )
2047  q2=x2+tkoo(2,j )
2048  xy=ga*(q1*q1+q2*q2)
2049  IF(xy.GT.15.d0) go to 40
2050  e=exp(-xy)
2051  c=ci-ca*e*afluk
2052  ar=REAL(REAL(c))
2053  ai=imag(c)
2054  p=ar*ar+ai*ai
2055  IF(rndm(v).LT.p) go to 40
2056  int=int+1
2057  IF(int.GT.intmx) go to 40
2058  js(i)=js(i)+1
2059  jt(j)=jt(j)+1
2060  inter1(int)=i
2061  inter2(int)=j
2062  40 CONTINUE
2063  DO 50 i=1,na
2064  IF (js(i).NE.0) inta=inta+1
2065  50 CONTINUE
2066  DO 60 j=1,nb
2067  IF (jt(j).NE.0) intb=intb+1
2068  60 CONTINUE
2069  IF(ipev.GE.6) THEN
2070  WRITE(6,'(A)')
2071  + ' DIAGR - AFTER 30 CONTINUE: ICNT, INT, B, NA,RA, NB,RB'
2072  WRITE(6,'(I10,I5,1PE11.3,2(I5,1PE11.3))') icnt, int, b, na,rash,
2073  + nb,rbsh
2074  ENDIF
2075  IF(int.EQ.0) go to 30
2076  RETURN
2077  END
2078 C----------------------------------------------------------------
2079  SUBROUTINE fluini
2080  IMPLICIT DOUBLE PRECISION (a-h,o-z)
2081  SAVE
2082 C INITIALIZE THE ARRAY FOR CROSS SECTION FLUCTUATIONS
2083 C
2084  COMMON /fluarr/ flusi(1000),fluix(1000),fluixx(1000)
2085  dx=0.003d0
2086  b=0.893d0
2087  n=6
2088  a=0.1
2089  om=1.1
2090  flusu=0
2091  flusuu=0
2092  DO 1 i=1,1000
2093  x=i*dx
2094  fluix(i)=x
2095  flus=((x-b)/(om*b))**n
2096  IF(flus.LE.20.)THEN
2097  flusi(i)=(x/b)*exp(-((x-b)/(om*b))**n)/(x/b+a)
2098  ELSE
2099  flusi(i)=0.
2100  ENDIF
2101  flusu=flusu+flusi(i)
2102  1 CONTINUE
2103  DO 2 i=1,1000
2104  flusuu=flusuu+flusi(i)/flusu
2105  flusi(i)=flusuu
2106  2 CONTINUE
2107  WRITE(6,3)
2108  3 FORMAT(' FLUCTUATIONS')
2109  CALL plot(fluix,flusi,1000,1,1000,0.d0,0.06d0,0.d0,0.01d0)
2110  DO 5 i=1,1000
2111  af=i*0.001d0
2112  DO 6 j=1,1000
2113  IF(af.LE.flusi(j))THEN
2114  fluixx(i)=fluix(j)
2115  go to 7
2116  ENDIF
2117  6 CONTINUE
2118  7 CONTINUE
2119  5 CONTINUE
2120  fluixx(1)=fluix(1)
2121  fluixx(1000)=fluix(1000)
2122  RETURN
2123  END
2124 *-- Author :
2125 C
2126 C--------------------------------------------------------------------
2127 C
2128 C FILE TECALBAM
2129 C
2130 C
2131 C--------------------------------------------------------------------
2132 c SUBROUTINE TECALB
2133 C SUBROUTINE TECALBAM
2134 C
2135 C------------------------------------------------------------------
2136 C
2137 C DTNTCBI.FOR
2138 C
2139 C------------------------------------------------------------------
2140 C
2141  SUBROUTINE calbam(NNCH,I1,I2,IFB11,IFB22,IFB33,IFB44,
2142  * amch,nobam,ihad)
2143  IMPLICIT DOUBLE PRECISION (a-h,o-z)
2144  SAVE
2145 C
2146 C--------------------------------------------------------------------
2147 C SAMPLING OF Q-AQ, Q-QQ, QQ-AQQ CHAINS
2148 C USING BAMJET(IHAD,IFB1,IFB2,IFB3,IFB4,AMCH,NOBAM)-----FOR NNCH=0
2149 C OR PARJET(IHAD,ICH1=I1 OR I2)------FOR NNCH=-1 OR +1
2150 C-------------------------------------------------------------------
2151 C IHAD : NUMBER OF PRODUCED PARTICLES
2152 C NNCH : CALL BAMJET FOR NNCH=0
2153 C CALL PARJET FOR NNCH=+1 ICH1=I1
2154 C FOR NNCH=-1 ICH1=I2
2155 C jet not existing for NNCH=+/-99, i.e. IHAD=0
2156 C PRODUCED PARTICLES IN CHAIN REST FRAME ARE IN COMMON /FINPAR/
2157 C AMCH : INVARIANT MASS OF CHAIN (BAMJET)
2158 C
2159 C NOBAM : = 3 QUARK-ANTIQUARK JET QUARK FLAVORS : IFB1,IFB2
2160 C OR ANTIQUARK-QUARK JET IN ANY ORDER
2161 C
2162 C = 4 QUARK-DIQUARK JET, FLAVORS : QU : IFB1, DIQU :IFB2,IFB
2163 C OR ANTIQUARK-ANTIDIQUARK JET
2164 C
2165 C
2166 C = 5 DIQUARK-ANTIDIQUARK JET
2167 C OR ANTIDIQUARK-DIQUARK JET
2168 C FLAVORS : DIQU : IFB1,IFB2, ANTIDIQU : IFB3,IFB4
2169 C IN ANY ORDER
2170 C
2171 C = 6 DIQUARK-QUARK JET, FLAVORS : DIQU : IFB1,IFB2 QU: IFB
2172 C OR ANTIDIQUARK-ANTIQUARK JET
2173 C
2174 C = 10 q -- q -- q Jet Capella Kopeliovich
2175 C or aq -- aq -- aq flavors IFB11,IFB22,IFB33
2176 C
2177 C IFBI : FLAVORS : 1,2,3,4 = U,D,S,C 7,8,9,10 = AU,AD,AS,AC
2178 C
2179 C I1,I2 : NUMBER LABEL OF A HADRON CREATED BY PARJET
2180 C
2181 C NORMALLY IN BAMJET THE QUARKS MOVE FORWARD (POSITIVE Z-DIRECTION)
2182 C THE QUARK FLAVORS ARE FIRST GIVEN
2183 C CALBAM ALLOWS EITHER THE QUARK OR ANTIQUARK (DIQU) TO MOVE FORWARD
2184 C THE FORWARD GOING FLAVORS ARE GIVEN FIRST
2185 C
2186 C =====================================================================
2187 *KEEP,DFINPA.
2188  CHARACTER*8 anf
2189  parameter(nfimax=249)
2190  COMMON /dfinpa/ anf(nfimax),pxf(nfimax),pyf(nfimax),pzf(nfimax),
2191  +hef(nfimax),amf(nfimax), ichf(nfimax),ibarf(nfimax),nref(nfimax)
2192  COMMON /dfinpz/iormo(nfimax),idaug1(nfimax),idaug2(nfimax),
2193  * istath(nfimax)
2194 *KEEP,DPRIN.
2195  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
2196  DATA isymm/0/
2197 *KEND.
2198 C---------------------
2199 C IPCO=6
2200 C-------------------------------------------------------------------------------C
2201 C Symmetrize JETSET and BAMJET at small chain masses
2202 C for NOBAM=4 or 6
2203 C
2204 C-------------------------------------------------------------------------------
2205  IF(nobam.EQ.4.AND.isymm.EQ.1)THEN
2206  ifb4=ifb44
2207  IF (amch.LT.3.d0)THEN
2208  rr=rndm(v)
2209  IF (rr.LT.0.33333d0)THEN
2210  ifb1=ifb11
2211  ifb2=ifb22
2212  ifb3=ifb33
2213  ELSEIF (rr.GT.0.666666d0)THEN
2214  ifb1=ifb22
2215  ifb2=ifb11
2216  ifb3=ifb33
2217  ELSE
2218  ifb1=ifb33
2219  ifb2=ifb22
2220  ifb3=ifb11
2221  ENDIF
2222  ELSEIF(amch.GT.7.d0)THEN
2223  ifb1=ifb11
2224  ifb2=ifb22
2225  ifb3=ifb33
2226  ifb4=ifb44
2227  ELSE
2228  ssss=(7.d0-amch)/4.d0
2229  rrr=rndm(vv)
2230  IF(rrr.LT.1.d0-ssss)THEN
2231  ifb1=ifb11
2232  ifb2=ifb22
2233  ifb3=ifb33
2234  ELSE
2235  rr=rndm(v)
2236  IF (rr.LT.0.33333d0)THEN
2237  ifb1=ifb11
2238  ifb2=ifb22
2239  ifb3=ifb33
2240  ELSEIF (rr.GT.0.666666d0)THEN
2241  ifb1=ifb22
2242  ifb2=ifb11
2243  ifb3=ifb33
2244  ELSE
2245  ifb1=ifb33
2246  ifb2=ifb22
2247  ifb3=ifb11
2248  ENDIF
2249  ENDIF
2250  ENDIF
2251  ELSEIF(nobam.EQ.6.AND.isymm.EQ.1)THEN
2252  ifb4=ifb44
2253  IF (amch.LT.3.d0)THEN
2254  rr=rndm(v)
2255  IF (rr.LT.0.33333d0)THEN
2256  ifb1=ifb11
2257  ifb2=ifb22
2258  ifb3=ifb33
2259  ELSEIF (rr.GT.0.666666d0)THEN
2260  ifb3=ifb22
2261  ifb1=ifb11
2262  ifb2=ifb33
2263  ELSE
2264  ifb3=ifb11
2265  ifb2=ifb22
2266  ifb1=ifb33
2267  ENDIF
2268  ELSEIF(amch.GT.7.d0)THEN
2269  ifb1=ifb11
2270  ifb2=ifb22
2271  ifb3=ifb33
2272  ifb4=ifb44
2273  ELSE
2274  ssss=(7.d0-amch)/4.d0
2275  rrr=rndm(vv)
2276  IF(rrr.LT.1.d0-ssss)THEN
2277  ifb1=ifb11
2278  ifb2=ifb22
2279  ifb3=ifb33
2280  ELSE
2281  rr=rndm(v)
2282  IF (rr.LT.0.33333d0)THEN
2283  ifb1=ifb11
2284  ifb2=ifb22
2285  ifb3=ifb33
2286  ELSEIF (rr.GT.0.666666d0)THEN
2287  ifb3=ifb22
2288  ifb1=ifb11
2289  ifb2=ifb33
2290  ELSE
2291  ifb1=ifb33
2292  ifb2=ifb22
2293  ifb3=ifb11
2294  ENDIF
2295  ENDIF
2296  ENDIF
2297  ELSE
2298  ifb1=ifb11
2299  ifb2=ifb22
2300  ifb3=ifb33
2301  ifb4=ifb44
2302  ENDIF
2303 C------------------------------------------------------------------------------
2304  IF(ipco.GE.6)THEN
2305  WRITE (6,1000)nnch,i1,i2,ifb1,ifb2,ifb3,ifb4,amch,nobam,ihad
2306  1000 FORMAT(' CALBAM:NNCH,I1,I2,IFB1,IFB2,IFB3,IFB4,AMCH,NOBAM,IHAD' /7
2307  +i5,f10.3,2i5)
2308  ENDIF
2309  IF(nobam.EQ.10)THEN
2310  CALL dbamje(ihad,ifb1,ifb2,ifb3,ifb4,amch,nobam)
2311  ENDIF
2312  iturn=0
2313  IF (nnch) 10,30,20
2314  10 CONTINUE
2315  IF(nnch.EQ.-99) THEN
2316  ihad=0
2317  RETURN
2318  ENDIF
2319  ich1=i1
2320  go to 50
2321  20 CONTINUE
2322  IF(nnch.EQ.99) THEN
2323  ihad=0
2324  RETURN
2325  ENDIF
2326  ich1=i2
2327  go to 50
2328  30 CONTINUE
2329 C*** ITURN=0 HJM 24/01/91
2330  IF (ifb1.LE.6) go to 40
2331  iturn=1
2332  IF(nobam.EQ.3) CALL dbamje(ihad,ifb2,ifb1,ifb3,ifb4,amch,nobam)
2333  IF(nobam.EQ.4)THEN
2334  iturn=0
2335  CALL dbamje(ihad,ifb1,ifb2,ifb3,ifb4,amch,nobam)
2336  END IF
2337  IF(nobam.EQ.6) CALL dbamje(ihad,ifb3,ifb1,ifb2,ifb4,amch,4)
2338  IF(nobam.EQ.5)THEN
2339  CALL dbamje(ihad,ifb3,ifb4,ifb1,ifb2,amch,nobam)
2340  ENDIF
2341  go to 60
2342  40 CONTINUE
2343 
2344  IF (nobam.EQ.3.OR.nobam.EQ.4.OR.nobam.EQ.5) THEN
2345  CALL dbamje(ihad,ifb1,ifb2,ifb3,ifb4,amch,nobam)
2346  ELSEIF(nobam.EQ.6)THEN
2347  iturn=1
2348  CALL dbamje(ihad,ifb3,ifb1,ifb2,ifb4,amch,4)
2349  END IF
2350  go to 60
2351  50 CONTINUE
2352  CALL dparje(ihad,ich1)
2353  60 CONTINUE
2354 C CALL DECAY(IHAD,2)
2355  70 CONTINUE
2356 C*** TURN CHAINS AROUND IF NESSESARY
2357  IF (iturn.EQ.0) go to 100
2358 C*** TURN JET AROUND
2359  DO 80 i=1,ihad
2360  pzf(i)=-pzf(i)
2361  80 CONTINUE
2362  90 CONTINUE
2363  100 CONTINUE
2364  IF (ipco.GE.6)THEN
2365  DO 1244 i=1,ihad
2366  WRITE(6,1245)i,pzf(i),hef(i),anf(i)
2367  1245 FORMAT(i5,2f10.4,a8)
2368  1244 CONTINUE
2369  ENDIF
2370  RETURN
2371  END
2372 *-- Author :
2373 C
2374 C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2375 C
2376 C
2377  SUBROUTINE dbamje(IHAD,KFA1,KFA2,KFA3,KFA4,AE0,IOPT)
2378  IMPLICIT DOUBLE PRECISION (a-h,o-z)
2379  SAVE
2380 C*****IHAD=NUMBER OF FINAL HADRONS AND HADRON RESONANCES
2381 C*****AE0=INITIAL ENERGY IN GEV
2382 C*****KFA=INITIAL QUARK FLAVOUR
2383 C*****KFD1,KFD2=FLAVOUR CONTENTS OF A INITIAL DIQUARK
2384 C*****IOPT=1,2,3,4 MEANS: SINGLE QUARK JET,SINGLE DIQUARK JET,
2385 C*****COMPLETE QUARK ANTIQUARK TWOJET EVENT,COMPLETE QUARK-DIQUARK TWO
2386 C*****JET EVENT
2387 C*****IOPT=10 q -- q -- q Jet Capella Kopeliovich (only jetset defined)
2388 C*****COMMON/FINPAR/ CONTAINS THE MOMENTA,ENERGIES AND QUANTUM NUMBERS
2389 C*****OF THE CREATED HADRONS
2390 C*****IV IS THE ACTUAL VERTEX,IV=1,4,5,6,9,10 ARE MESON VERTIZES
2391 C*****IV=2,3,7,8 ARE BARYON VERTIZES
2392 C*****LA=1 MEANS CUT-OFF
2393 C*****LL=0,1 MEANS QUARK JET,ANTIQUARK JET(DIQUARK JET,ANTIDIQUARK JET)
2394 C*****COMMON/REMAIN/ CONTAINS REST JET ENERGY,MOMENTA AND QUANTUMNUMBERS
2395 C------------------
2396 *KEEP,DFINPA.
2397  CHARACTER*8 anf
2398  parameter(nfimax=249)
2399  COMMON /dfinpa/ anf(nfimax),pxf(nfimax),pyf(nfimax),pzf(nfimax),
2400  +hef(nfimax),amf(nfimax), ichf(nfimax),ibarf(nfimax),nref(nfimax)
2401  COMMON /dfinpz/iormo(nfimax),idaug1(nfimax),idaug2(nfimax),
2402  * istath(nfimax)
2403 *KEEP,DINPDA.
2404  COMMON /dinpda/ imps(6,6),imve(6,6),ib08(6,21),ib10(6,21), ia08
2405  +(6,21),ia10(6,21), a1,b1,b2,b3,lt,le,bet,as,b8,ame,diq,isu
2406 *KEND.
2407  CHARACTER*8 aname
2408  COMMON /dpar/ aname(210),am(210),ga(210),tau(210),ich(210), ibar
2409  +(210),k1(210),k2(210)
2410  common/dremai/ rpxr,rpyr,rpzr,rer,kr1r,kr2r
2411  COMMON /bamco/ nvdd
2412  common/ifragm/ifrag
2413  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
2414 *--------------------------- S.Roesler 5/27/93
2415  COMMON /diffra/ isingd,idiftp,ioudif,iflagd
2416 *
2417  dimension rpx(100),rpy(100),re(100)
2418  dimension kfr1(100),kfr2(100),iv(100)
2419  parameter(pimass=0.15d0)
2420 C
2421  IF(ipco.GE.6)lt=1
2422 C-------------------------------------------------------------------
2423  IF (lt.EQ.1)WRITE(6, 1000)ihad,kfa1,kfa2,kfa3,kfa4,ae0,iopt
2424  1000 FORMAT (5i5,e12.4,i5,
2425  + ' BAMJET,IHAD,KFA1,KFA2,KFA3,KFA4,AE0,IOPT')
2426 C------------------------------------------------------------------
2427 C
2428 C JETSET-7.3 FRAGMENTATION j.r.6/93
2429 C
2430  IF(iopt.EQ.10)THEN
2431  irej=0
2432  CALL bamlun(ihad,kfa1,kfa2,kfa3,kfa4,ae0,iopt,irej)
2433  IF(irej.EQ.1)THEN
2434  RETURN
2435  ENDIF
2436  RETURN
2437  ENDIF
2438  IF(ifrag.EQ.1.OR.ifrag.EQ.2.OR.ifrag.GE.10)THEN
2439  irej=0
2440  CALL bamlun(ihad,kfa1,kfa2,kfa3,kfa4,ae0,iopt,irej)
2441  IF(irej.EQ.1)THEN
2442  RETURN
2443  ENDIF
2444  RETURN
2445  ENDIF
2446 C_________________________________________________________________
2447  as=0.5
2448  b8=0.4
2449  a1=0.88
2450 *-------------------------- S.Roesler 5/26/93
2451  b1=3.
2452  b2=3.
2453 *
2454  b3=8.0
2455 C BET=9.5
2456  bet=12.0
2457  IF(nvdd.EQ.15) THEN
2458  a1=0.99
2459  b3=2.0
2460  bet=3.
2461  ENDIF
2462 *-------------------------- S.Roesler 5/26/93
2463 * diffractive chains
2464 *
2465  IF(iflagd.EQ.1)THEN
2466  a1=0.88
2467  b1=6.
2468  b2=9.
2469  b3=4.0
2470  ENDIF
2471 *
2472 C
2473  itry = 0
2474  10 CONTINUE
2475 C
2476 C avoid hang ups
2477  itry = itry+1
2478  IF(itry.GT.10000) THEN
2479  WRITE(6,'(/1X,A)') 'DBAMJE:ERROR: FRAGMENTATION IMPOSSIBLE'
2480  WRITE(6,'(1X,A,5I5,E12.3,I5)')
2481  & 'DBAMJE:IHAD,KFA1,KFA2,KFA3,KFA4,AE0,IOPT ',
2482  & ihad,kfa1,kfa2,kfa3,kfa4,ae0,iopt
2483  stop
2484  ENDIF
2485 C
2486  DO 20 i=1,100
2487  kfr1(i)=0
2488  kfr2(i)=0
2489  20 CONTINUE
2490  30 CONTINUE
2491  iyy=0
2492  ihad=0
2493  it=0
2494  e0=ae0/2.
2495 C low mass asymmetric fragmentation (r.e. 12/93)
2496  IF(itry.GT.100) THEN
2497  IF(iopt.EQ.3) THEN
2498  IF(kfa1.GT.(kfa2-6)) THEN
2499  e0=ae0-max(ae0*0.1,pimass)
2500  ELSE
2501  e0=max(ae0*0.1,pimass)
2502  ENDIF
2503  ENDIF
2504  ENDIF
2505 C
2506  IF(iopt.EQ.1.OR.iopt.EQ.2) e0=ae0
2507  ll=0
2508  pgx=0.
2509  IF(kfa1.GT.6.AND.iopt.EQ.1) ll=1
2510  IF(kfa1.LE.6.AND.iopt.EQ.2) ll=1
2511  IF(kfa1.GT.6.AND.iopt.EQ.4) ll=1
2512  pgy=0.
2513  pgz=0.
2514  rpx0=0.
2515  rpy0=0.
2516  DO 130 i=1,100
2517  la=0
2518  it=it+1
2519  j=it-1
2520  40 CONTINUE
2521 C*****CUT OFF TASK
2522 C CALL DABBRC(IT,LL,LA,LT,E0,PGX,PGY,PGZ,KFR1,KFR2,RE, KR1R,KR2R,
2523 C + KR1L,KR2L,RPX,RPY,RPZ,RPXR,RPYR,RPZR,RPXL,RPYL,RPZL, RER,REL,IV,
2524 C + B1,B2,KFA1,KFA2,KFA3,KFA4,IOPT,IYY)
2525  IF(la.EQ.0) goto60
2526  it=it-1
2527  IF(iopt.EQ.3.AND.ll.EQ.0) goto 50
2528  IF(iopt.EQ.4.AND.kfa1.LE.6.AND.ll.EQ.0) goto 50
2529  IF(iopt.EQ.4.AND.kfa1.GT.6.AND.ll.EQ.1) goto 50
2530  IF(iopt.EQ.5.AND.ll.EQ.0) goto 50
2531 C asymmetric fragmentation (r.e. 12/93)
2532  e0 = ae0/2.
2533  goto 140
2534  50 CONTINUE
2535 C asymmetric fragmentation (r.e. 12/93)
2536  e0 = ae0-e0
2537 C
2538  iyy=1
2539  ll=1
2540  IF(iopt.EQ.4.AND.kfa1.GT.6) ll=0
2541  iar=it
2542  goto120
2543  60 CONTINUE
2544 C*****CHOICE OF THE VERTEX
2545 C CALL DVERTE(IT,LT,LL,KFA1,E0,IV,AME,IOPT)
2546 C*****CHOICE OF THE FLAVOUR
2547 C CALL DFLAVO(IT,LT,LL,E0,IV,RE,KFR1,KFR2,ISU,BET,KFA1,KFA2,KFA3,
2548 C + KFA4,IOPT)
2549 C*****CLASSIFICATION OF THEPARTICLES
2550 C CALL DHKLAS(IT,LT,LA,LL,KFR1,KFR2,KR1R,KR2R,KR1L,KR2L,IV,IMPS,
2551 C + IMVE,IB08,IA08,IB10,IA10,AS,B8,KFA1,KFA2,KFA3,KFA4,IOPT)
2552  IF(it.EQ.1)rx=e0
2553  IF(it.GT.1)rx=re(j)
2554  IF(amf(it).GT.rx) goto 10
2555  IF(amf(it).LE.rx) goto 70
2556  la=1
2557  goto40
2558  70 CONTINUE
2559  ihad=ihad+1
2560  IF(lt.EQ.0) goto80
2561  WRITE(6, 1070)ihad
2562  80 CONTINUE
2563 C*****CHOICE OF THE ENERGY
2564 C CALL DENERG(IT,IV,RE,HMA,HE,E0,A1)
2565 C*****CHOICE OF THE MOMENTUM
2566 C CALL IMPULD(HE,HMA,HPS,HPX,HPY,HPZ,LT,LL,B3)
2567  IF(it.GT.1) goto90
2568  rpx(it)=rpx0-hpx
2569  rpy(it)=rpy0-hpy
2570  goto100
2571  90 rpx(it)=rpx(j)-hpx
2572  rpy(it)=rpy(j)-hpy
2573  100 CONTINUE
2574  IF (iopt.EQ.1.AND.ll.EQ.1)hpz=-hpz
2575  IF(iopt.EQ.2.AND.ll.EQ.1) hpz=-hpz
2576  IF(iopt.EQ.4.AND.kfa1.GT.6) hpz=-hpz
2577  IF(iopt.EQ.5) hpz=-hpz
2578  pgx=pgx+hpx
2579  pgy=pgy+hpy
2580  pgz=pgz+hpz
2581  pxf(it)=hpx
2582  pyf(it)=hpy
2583  pzf(it)=hpz
2584  IF(lt.EQ.0) goto110
2585  WRITE(6, 1010)pgx,pgy,pgz
2586  1010 FORMAT(1h0,12hpgx,pgy,pgz=,3f8.4)
2587  110 CONTINUE
2588  120 CONTINUE
2589  130 CONTINUE
2590  140 CONTINUE
2591  IF(iopt.EQ.1.OR.iopt.EQ.2) goto 150
2592 C*****PUT THE RIGHT AND LEFT JET TOGETHER
2593 C CALL DVEREI(IT,LA,LT,RER,REL,RPXR,RPYR,RPZR,RPXL,RPYL,RPZL,
2594 C *KR1R,KR2R,KR1L,KR2L,IHAD,LL,KFR1,KFR2,IMPS,IMVE,IB08,IA08,
2595 C *IB10,IA10,B3,AS,B8,IAR,KFA1,KFA2,KFA3,KFA4,IOPT)
2596  IF(la.EQ.3) goto 10
2597  IF(la.EQ.2) goto 10
2598  150 CONTINUE
2599  IF(iopt.EQ.3.OR.iopt.EQ.4.OR.iopt.EQ.5) goto 160
2600  IF(ll.EQ.0) goto 160
2601  rpxr=rpxl
2602  rpyr=rpyl
2603  rpzr=rpzl
2604  rer=rel
2605  kr1r=kr1l
2606  kr2r=kr2l
2607  160 CONTINUE
2608  IF(le.EQ.0) goto 180
2609  WRITE(6, 1030)
2610  do170 j=1,it
2611  WRITE(6, 1020)nref(j),anf(j),amf(j),ichf(j),
2612  + ibarf(j),pxf(j),pyf(j),
2613  + pzf(j),hef(j)
2614  1020 FORMAT(2x,i3,a6,f6.3,2i4,4f8.4)
2615  1030 FORMAT(2x,'NF,NAME,MASS,IQ,IB,PX,PY,PZ,E')
2616  170 CONTINUE
2617  180 CONTINUE
2618  1040 FORMAT(1h0,38hnumber of events with prest gt. erest=,i4, /,
2619  +21hnumber of all events=,i4)
2620  1050 FORMAT(1h0,'NUMBER OF EVENTS WITH ONLY ONE PARTICLE=',i4)
2621 C*****TEST OF THE CONSERVATION LAWS
2622 C CALL TERHAL(IT,LE,KFA1,KFA2,IOPT)
2623  IF(lt.EQ.0) goto190
2624  WRITE(6, 1060)ihad
2625  1060 FORMAT(1h0,' MULTIPLIZITAET=',i3)
2626  1070 FORMAT(1h0,13hhadronanzahl=,i3)
2627  190 CONTINUE
2628 C IF (IHAD.EQ.2)THEN
2629 C DO 200 I=1,IHAD
2630 C PZF(I)=-PZF(I)
2631 C 200 CONTINUE
2632 C ENDIF
2633 C
2634  RETURN
2635  END
2636 *-- Author :
2637 C
2638 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2639 C
2640  SUBROUTINE indexd(KA,KB,IND)
2641  IMPLICIT DOUBLE PRECISION (a-h,o-z)
2642  SAVE
2643  kp=ka*kb
2644  ks=ka+kb
2645  IF(kp.EQ.1)ind=1
2646  IF(kp.EQ.2)ind=2
2647  IF(kp.EQ.3)ind=3
2648  IF(kp.EQ.4.AND.ks.EQ.5)ind=4
2649  IF(kp.EQ.5)ind=5
2650  IF(kp.EQ.6.AND.ks.EQ.7)ind=6
2651  IF(kp.EQ.4.AND.ks.EQ.4)ind=7
2652  IF(kp.EQ.6.AND.ks.EQ.5)ind=8
2653  IF(kp.EQ.8)ind=9
2654  IF(kp.EQ.10)ind=10
2655  IF(kp.EQ.12.AND.ks.EQ.8)ind=11
2656  IF(kp.EQ.9)ind=12
2657  IF(kp.EQ.12.AND.ks.EQ.7)ind=13
2658  IF(kp.EQ.15)ind=14
2659  IF(kp.EQ.18)ind=15
2660  IF(kp.EQ.16)ind=16
2661  IF(kp.EQ.20)ind=17
2662  IF(kp.EQ.24)ind=18
2663  IF(kp.EQ.25)ind=19
2664  IF(kp.EQ.30)ind=20
2665  IF(kp.EQ.36)ind=21
2666  RETURN
2667  END
2668 *-- Author :
2669 C
2670 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2671 C
2672 C
2673 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2674 C
2675  DOUBLE PRECISION FUNCTION dbeta(X1,X2,BET)
2676  IMPLICIT DOUBLE PRECISION (a-h,o-z)
2677  SAVE
2678  ax=0.0
2679  betx1=bet*x1
2680  IF(betx1.LT.70.) ax=-1./bet**2*(betx1+1.)*exp(-betx1)
2681  ay=1./bet**2*(bet*x2+1.)*exp(-bet*x2)
2682  dbeta=ax+ay
2683  RETURN
2684  END
2685 *-- Author :
2686 C
2687 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2688 C
2689  SUBROUTINE ddrela(X,Y,Z,COTE,SITE,COPS,SIPS)
2690  IMPLICIT DOUBLE PRECISION (a-h,o-z)
2691  SAVE
2692  x1=cops*x-sips*cote*y+sips*site*z
2693  x2=sips*x+cops*cote*y-cops*site*z
2694  x3=site*y+cote*z
2695  x=x1
2696  y=x2
2697  z=x3
2698  RETURN
2699  END
2700 *-- Author :
2701 C
2702 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2703 C
2704 C SUBROUTINE DPOLI(CS,SI)
2705 C IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2706 C SAVE
2707 C U=RNDM(V)
2708 C CS=RNDM(VV)
2709 C IF (U.LT.0.5) CS=-CS
2710 C SI=SQRT(1.-CS*CS+1.E-10)
2711 C RETURN
2712 C END
2713 C SUBROUTINE ALTRAF(GA,BGA,CX,CY,CZ,COD,COF,SIF,PC,EC,P,PX,PY,PZ,E)
2714 C IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2715 C SAVE
2716 C BGX=BGA*CX
2717 C BGY=BGA*CY
2718 C BGZ=BGA*CZ
2719 C COD2=COD*COD
2720 C IF (COD2.GT.0.999999) COD2=0.999999
2721 C SID=SQRT(1.-COD2)*PC
2722 C PCX=SID*COF
2723 C PCY=SID*SIF
2724 C PCZ=COD*PC
2725 C EP=PCX*BGX+PCY*BGY+PCZ*BGZ
2726 C PE=EP/(GA+1.)+EC
2727 C PX=PCX+BGX*PE
2728 C PY=PCY+BGY*PE
2729 C PZ=PCZ+BGZ*PE
2730 C P=SQRT(PX*PX+PY*PY+PZ*PZ)
2731 C PM=1./P
2732 C PX=PX*PM
2733 C PY=PY*PM
2734 C PZ=PZ*PM
2735 C E=GA*EC+EP
2736 C RETURN
2737 C END
2738 C SUBROUTINE ROTAT(PX,PY,PZ,PXN,PYN,PZN,COTE,SITE,COPS,SIPS)
2739 C IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2740 C SAVE
2741 C PXN=-PX*SIPS-PY*COTE*COPS+PZ*SITE*COPS
2742 C PYN=PX*COPS-PY*COTE*SIPS+PZ*SITE*SIPS
2743 C PZN=PY*SITE+PZ*COTE
2744 C RETURN
2745 C END
2746 C
2747 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2748 
2749 *=== threpd ===========================================================*
2750 *
2751  SUBROUTINE dthrep(UMO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,
2752  &sif1,cod2,cof2,sif2,cod3,cof3,sif3,am1,am2,am3)
2753 
2754 *$ CREATE DBLPRC.ADD
2755 *COPY DBLPRC
2756 * *
2757 *=== dblprc ==========================================================*
2758 * *
2759 *---------------------------------------------------------------------*
2760 * *
2761 * Dblprc: included in any routine *
2762 * *
2763 * !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
2764 * !!!! O N M A C H I N E S W H E R E T H E D O U B L E !!!! *
2765 * !!!! P R E C I S I O N I S N O T R E Q U I R E D R E -!!!! *
2766 * !!!! M O V E T H E D O U B L E P R E C I S I O N !!!! *
2767 * !!!! S T A T E M E N T, S E T K A L G N M = 1 A N D !!!! *
2768 * !!!! C H A N G E A L L N U M E R I C A L C O N S - !!!! *
2769 * !!!! T A N T S T O S I N G L E P R E C I S I O N !!!! *
2770 * !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
2771 * *
2772 * Kalgnm = real address alignment, 2 for double precision, *
2773 * 1 for single precision *
2774 * Anglgb = this parameter should be set equal to the machine *
2775 * "zero" with respect to unit *
2776 * Anglsq = this parameter should be set equal to the square *
2777 * of Anglgb *
2778 * Axcssv = this parameter should be set equal to the number *
2779 * for which unity is negligible for the machine *
2780 * accuracy *
2781 * Andrfl = "underflow" of the machine for floating point *
2782 * operation *
2783 * Avrflw = "overflow" of the machine for floating point *
2784 * operation *
2785 * Ainfnt = code "infinite" *
2786 * Azrzrz = code "zero" *
2787 * Einfnt = natural logarithm of the code "infinite" *
2788 * Ezrzrz = natural logarithm of the code "zero" *
2789 * Onemns = 1- of the machine, it is 1 - 2 x Anglgb *
2790 * Onepls = 1+ of the machine, it is 1 + 2 x Anglgb *
2791 * Csnnrm = maximum tolerable error on cosine normalization, *
2792 * u**2+v**2+w**2: assuming a typical anglgb relative *
2793 * error on each component we would get 2xanglgb: use *
2794 * 4xanglgb to avoid too many normalizations *
2795 * Dmxtrn = "infinite" distance for transport (cm) *
2796 * *
2797 *---------------------------------------------------------------------*
2798 * *
2799  IMPLICIT DOUBLE PRECISION (a-h,o-z)
2800  SAVE
2801  parameter( kalgnm = 2 )
2802  parameter( anglgb = 5.0d-16 )
2803  parameter( anglsq = 2.5d-31 )
2804  parameter( axcssv = 0.2d+16 )
2805  parameter( andrfl = 1.0d-38 )
2806  parameter( avrflw = 1.0d+38 )
2807  parameter( ainfnt = 1.0d+30 )
2808  parameter( azrzrz = 1.0d-30 )
2809  parameter( einfnt = +69.07755278982137 d+00 )
2810  parameter( ezrzrz = -69.07755278982137 d+00 )
2811  parameter( onemns = 0.999999999999999 d+00 )
2812  parameter( onepls = 1.000000000000001 d+00 )
2813  parameter( csnnrm = 2.0d-15 )
2814  parameter( dmxtrn = 1.0d+08 )
2815 *
2816 *======================================================================*
2817 *======================================================================*
2818 *========= ==========*
2819 *========= M A T H E M A T I C A L C O N S T A N T S ==========*
2820 *========= ==========*
2821 *======================================================================*
2822 *======================================================================*
2823 * *
2824 * Numerical constants: *
2825 * *
2826 * Zerzer = 0 *
2827 * Oneone = 1 *
2828 * Twotwo = 2 *
2829 * Thrthr = 3 *
2830 * Foufou = 4 *
2831 * Fivfiv = 5 *
2832 * Sixsix = 6 *
2833 * Sevsev = 7 *
2834 * Eigeig = 8 *
2835 * Aninen = 9 *
2836 * Tenten = 10 *
2837 * Hlfhlf = 1/2 *
2838 * Onethi = 1/3 *
2839 * Twothi = 2/3 *
2840 * Pipipi = Circumference / diameter *
2841 * Eneper = "e", base of natural logarithm *
2842 * Sqrent = square root of "e" *
2843 * *
2844 *----------------------------------------------------------------------*
2845 *
2846  parameter( zerzer = 0.d+00 )
2847  parameter( oneone = 1.d+00 )
2848  parameter( twotwo = 2.d+00 )
2849  parameter( thrthr = 3.d+00 )
2850  parameter( foufou = 4.d+00 )
2851  parameter( fivfiv = 5.d+00 )
2852  parameter( sixsix = 6.d+00 )
2853  parameter( sevsev = 7.d+00 )
2854  parameter( eigeig = 8.d+00 )
2855  parameter( aninen = 9.d+00 )
2856  parameter( tenten = 10.d+00 )
2857  parameter( hlfhlf = 0.5d+00 )
2858  parameter( onethi = oneone / thrthr )
2859  parameter( twothi = twotwo / thrthr )
2860  parameter( pipipi = 3.1415926535897932270 d+00 )
2861  parameter( eneper = 2.7182818284590452354 d+00 )
2862  parameter( sqrent = 1.6487212707001281468 d+00 )
2863 *
2864 *======================================================================*
2865 *======================================================================*
2866 *========= ==========*
2867 *========= P H Y S I C A L C O N S T A N T S ==========*
2868 *========= ==========*
2869 *======================================================================*
2870 *======================================================================*
2871 * *
2872 * Primary constants: *
2873 * *
2874 * Clight = speed of light in cm s-1 *
2875 * Avogad = Avogadro number *
2876 * Amelgr = electron mass (g) *
2877 * Plckbr = reduced Planck constant (erg s) *
2878 * Elccgs = elementary charge (CGS unit) *
2879 * Elcmks = elementary charge (MKS unit) *
2880 * Amugrm = Atomic mass unit (g) *
2881 * Ammumu = Muon mass (amu) *
2882 * *
2883 * Derived constants: *
2884 * *
2885 * Alpfsc = Fine structure constant = e^2/(hbar c) *
2886 * Amelct = Electron mass (GeV) = 10^-16Amelgr Clight^2 / Elcmks*
2887 * Amugev = Atomic mass unit (GeV) = 10^-16Amelgr Clight^2 *
2888 * / Elcmks *
2889 * Ammuon = Muon mass (GeV) = Ammumu * Amugev *
2890 * Fscto2 = (Fine structure constant)^2 *
2891 * Fscto3 = (Fine structure constant)^3 *
2892 * Fscto4 = (Fine structure constant)^4 *
2893 * Plabrc = Reduced Planck constant times the light velocity *
2894 * expressed in GeV fm *
2895 * Rclsel = Classical electron radius (cm) = e^2 / (m_e c^2) *
2896 * Conversion constants: *
2897 * GeVMeV = from GeV to MeV *
2898 * eMVGeV = from MeV to GeV *
2899 * Raddeg = from radians to degrees *
2900 * Degrad = from degrees to radians *
2901 * *
2902 *----------------------------------------------------------------------*
2903 *
2904  parameter( clight = 2.99792458 d+10 )
2905  parameter( avogad = 6.0221367 d+23 )
2906  parameter( amelgr = 9.1093897 d-28 )
2907  parameter( plckbr = 1.05457266 d-27 )
2908  parameter( elccgs = 4.8032068 d-10 )
2909  parameter( elcmks = 1.60217733 d-19 )
2910  parameter( amugrm = 1.6605402 d-24 )
2911  parameter( ammumu = 0.113428913 d+00 )
2912 * PARAMETER ( ALPFSC = 1.D+00 / 137.035989561D+00 )
2913 * PARAMETER ( FSCTO2 = ALPFSC * ALPFSC )
2914 * PARAMETER ( FSCTO3 = FSCTO2 * ALPFSC )
2915 * PARAMETER ( FSCTO4 = FSCTO3 * ALPFSC )
2916 * It is important to set the electron mass exactly with the same
2917 * rounding as in the mass tables, so use the explicit expression
2918 * PARAMETER ( AMELCT = 1.D-16 * AMELGR * CLIGHT * CLIGHT / ELCMKS )
2919 * It is important to set the amu mass exactly with the same
2920 * rounding as in the mass tables, so use the explicit expression
2921 * PARAMETER ( AMUGEV = 1.D-16 * AMUGRM * CLIGHT * CLIGHT / ELCMKS )
2922 * It is important to set the muon mass exactly with the same
2923 * rounding as in the mass tables, so use the explicit expression
2924 * PARAMETER ( AMMUON = AMMUMU * AMUGEV ELCMKS )
2925 * PARAMETER ( RCLSEL = ELCCGS * ELCCGS / CLIGHT / CLIGHT / AMELGR )
2926  parameter( alpfsc = 7.2973530791728595 d-03 )
2927  parameter( fscto2 = 5.3251361962113614 d-05 )
2928  parameter( fscto3 = 3.8859399018437826 d-07 )
2929  parameter( fscto4 = 2.8357075508200407 d-09 )
2930  parameter( plabrc = 0.197327053 d+00 )
2931  parameter( amelct = 0.51099906 d-03 )
2932  parameter( amugev = 0.93149432 d+00 )
2933  parameter( ammuon = 0.105658389 d+00 )
2934  parameter( rclsel = 2.8179409183694872 d-13 )
2935  parameter( gevmev = 1.0 d+03 )
2936  parameter( emvgev = 1.0 d-03 )
2937  parameter( raddeg = 180.d+00 / pipipi )
2938  parameter( degrad = pipipi / 180.d+00 )
2939 
2940 *$ CREATE IOUNIT.ADD
2941 *COPY IOUNIT
2942 * *
2943 *=== iounit ==========================================================*
2944 * *
2945 *---------------------------------------------------------------------*
2946 * *
2947 * Iounit: included in any routine *
2948 * *
2949 * lunin = standard input unit *
2950 * lunout = standard output unit *
2951 * lunerr = standard error unit *
2952 * lunber = input file for bertini nuclear data *
2953 * lunech = echo file for pegs dat *
2954 * lunflu = input file for photoelectric edges and X-ray fluo- *
2955 * rescence data *
2956 * lungeo = scratch file for combinatorial geometry *
2957 * lunpgs = input file for pegs material data *
2958 * lunran = output file for the final random number seed *
2959 * lunxsc = input file for low energy neutron cross sections *
2960 * lunrdb = unit number for reading (extra) auxiliary external *
2961 * files to be closed just after reading *
2962 * *
2963 *---------------------------------------------------------------------*
2964 * *
2965  parameter( lunin = 5 )
2966  parameter( lunout = 6 )
2967  parameter( lunerr = 66 )
2968  parameter( lunber = 14 )
2969  parameter( lunech = 8 )
2970  parameter( lunflu = 86 )
2971  parameter( lungeo = 16 )
2972  parameter( lunpgs = 12 )
2973  parameter( lunran = 2 )
2974  parameter( lunxsc = 81 )
2975  parameter( lunrdb = 1 )
2976 
2977 *$ CREATE DIMPAR.ADD
2978 *COPY DIMPAR
2979 * *
2980 *=== dimpar ==========================================================*
2981 * *
2982 *---------------------------------------------------------------------*
2983 * *
2984 * DIMPAR: included in any routine *
2985 * *
2986 * Mxxrgn = maximum number of regions *
2987 * Mxxmdf = maximum number of media in Fluka *
2988 * Mxxmde = maximum number of media in Emf *
2989 * Mfstck = stack dimension in Fluka *
2990 * Mestck = stack dimension in Emf *
2991 * Nallwp = number of allowed particles *
2992 * Mpdpdx = number of particle types for which EM dE/dx pro- *
2993 * cesses (ion,pair,bremss) have to be computed *
2994 * Icomax = maximum number of materials for compounds (equal *
2995 * to the sum of the number of materials for every *
2996 * compound ) *
2997 * Nstbis = number of stable isotopes recorded in common iso- *
2998 * top *
2999 * Idmaxp = number of particles/resonances defined in common *
3000 * part *
3001 * *
3002 *---------------------------------------------------------------------*
3003 * *
3004  parameter( mxxrgn = 500 )
3005  parameter( mxxmdf = 56 )
3006  parameter( mxxmde = 50 )
3007  parameter( mfstck = 1000 )
3008  parameter( mestck = 100 )
3009  parameter( nallwp = 39 )
3010  parameter( mpdpdx = 8 )
3011  parameter( icomax = 180 )
3012  parameter( nstbis = 304 )
3013  parameter( idmaxp = 210 )
3014 *----------------------------------------------------------------------*
3015 * Threpd89: slight revision by A. Ferrari *
3016 * Last change on 11-oct-93 by Alfredo Ferrari, INFN - Milan *
3017 *----------------------------------------------------------------------*
3018 *
3019  dimension f(5),xx(5)
3020 C***THREE PARTICLE DECAY IN THE CM - SYSTEM
3021  COMMON /dgamre/ redu,amo,amm(15 )
3022  common/ddrei/uumo,aam1,aam2,aam3,s22,umo2,
3023  *am11,am22,am33,s2sup,s2sap(2)
3024 C COMMON/PRUNT/ISYS
3025  common/pritt/isys
3026  SAVE eps
3027  DATA eps/azrzrz/
3028 *
3029  umoo=umo+umo
3030 C***S1, S2, S3 ARE THE INVARIANT MASSES OF THE PARTICLES 1, 2, 3
3031 C***J. VON NEUMANN - RANDOM - SELECTION OF S2
3032 C***CALCULATION OF THE MAXIMUM OF THE S2 - DISTRIBUTION
3033  uumo=umo
3034  aam1=am1
3035  aam2=am2
3036  aam3=am3
3037  gu=(am2+am3)**2
3038  go=(umo-am1)**2
3039 * UFAK=1.0000000000001D0
3040 * IF (GU.GT.GO) UFAK=0.9999999999999D0
3041  IF (gu.GT.go) THEN
3042  ufak=onemns
3043  ELSE
3044  ufak=onepls
3045  END IF
3046  ofak=2.d0-ufak
3047  gu=gu*ufak
3048  go=go*ofak
3049  ds2=(go-gu)/99.d0
3050  am11=am1*am1
3051  am22=am2*am2
3052  am33=am3*am3
3053  umo2=umo*umo
3054  rho2=0.d0
3055  s22=gu
3056  DO 124 i=1,100
3057  s21=s22
3058  s22=gu+(i-1.d0)*ds2
3059  rho1=rho2
3060  rho2=dxlamb(s22,umo2,am11)*dxlamb(s22,am22,am33)/
3061  * (s22+eps)
3062  IF(rho2.LT.rho1) go to 125
3063  124 CONTINUE
3064  125 s2sup=(s22-s21)*.5d0+s21
3065  suprho=dxlamb(s2sup,umo2,am11)*dxlamb(s2sup,am22,am33)/
3066  * (s2sup+eps)
3067  suprho=suprho*1.05d0
3068  xo=s21-ds2
3069  IF (gu.LT.go.AND.xo.LT.gu) xo=gu
3070  IF (gu.GT.go.AND.xo.GT.gu) xo=gu
3071  xx(1)=xo
3072  xx(3)=s22
3073  x1=(xo+s22)*0.5d0
3074  xx(2)=x1
3075  f(3)=rho2
3076  f(1)=dxlamb(xo,umo2,am11)*dxlamb(xo,am22,am33)/(xo+eps)
3077  f(2)=dxlamb(x1,umo2,am11)*dxlamb(x1,am22,am33)/(x1+eps)
3078  DO 126 i=1,16
3079  x4=(xx(1)+xx(2))*0.5d0
3080  x5=(xx(2)+xx(3))*0.5d0
3081  f(4)=dxlamb(x4,umo2,am11)*dxlamb(x4,am22,am33)/
3082  * (x4+eps)
3083  f(5)=dxlamb(x5,umo2,am11)*dxlamb(x5,am22,am33)/
3084  * (x5+eps)
3085  xx(4)=x4
3086  xx(5)=x5
3087  DO 128 ii=1,5
3088  ia=ii
3089  DO 128 iii=ia,5
3090  IF (f(ii).GE.f(iii)) go to 128
3091  fh=f(ii)
3092  f(ii)=f(iii)
3093  f(iii)=fh
3094  fh=xx(ii)
3095  xx(ii)=xx(iii)
3096  xx(iii)=fh
3097 128 CONTINUE
3098  suprho=f(1)
3099  s2sup=xx(1)
3100  DO 129 ii=1,3
3101  ia=ii
3102  DO 129 iii=ia,3
3103  IF (xx(ii).GE.xx(iii)) go to 129
3104  fh=f(ii)
3105  f(ii)=f(iii)
3106  f(iii)=fh
3107  fh=xx(ii)
3108  xx(ii)=xx(iii)
3109  xx(iii)=fh
3110 129 CONTINUE
3111 126 CONTINUE
3112  am23=(am2+am3)**2
3113  ith=0
3114  redu=2.d0
3115  1 CONTINUE
3116  ith=ith+1
3117  IF (ith.GT.200) redu=-9.d0
3118  IF (ith.GT.200) go to 400
3119  c=rndm(c)
3120 * S2=AM23+C*((UMO-AM1)**2-AM23)
3121  s2=am23+c*(umo-am1-am2-am3)*(umo-am1+am2+am3)
3122  y=rndm(y)
3123  y=y*suprho
3124  rho=dxlamb(s2,umo2,am11)*dxlamb(s2,am22,am33)/s2
3125  IF(y.GT.rho) go to 1
3126 C***RANDOM SELECTION OF S3 AND CALCULATION OF S1
3127  s1=rndm(s1)
3128  s1=s1*rho+am11+am22-(s2-umo2+am11)*(s2+am22-am33)/(2.d0*s2)-
3129  &rho*.5d0
3130  s3=umo2+am11+am22+am33-s1-s2
3131  ecm1=(umo2+am11-s2)/umoo
3132  ecm2=(umo2+am22-s3)/umoo
3133  ecm3=(umo2+am33-s1)/umoo
3134  pcm1=sqrt((ecm1+am1)*(ecm1-am1))
3135  pcm2=sqrt((ecm2+am2)*(ecm2-am2))
3136  pcm3=sqrt((ecm3+am3)*(ecm3-am3))
3137  CALL dsfecf(sfe,cfe)
3138 C***TH IS THE ANGLE BETWEEN PARTICLES 1 AND 2
3139 C***TH1, TH2 ARE THE ANGLES BETWEEN PARTICLES 1, 2 AND THE DIRECTION OF
3140  pcm12 = pcm1 * pcm2
3141  IF ( pcm12 .LT. anglsq ) go to 200
3142  costh=(ecm1*ecm2+0.5d+00*(am11+am22-s1))/pcm12
3143  go to 300
3144  200 CONTINUE
3145  uw=rndm(uw)
3146  costh=(uw-0.5d+00)*2.d+00
3147  300 CONTINUE
3148 * IF(ABS(COSTH).GT.0.9999999999999999D0)
3149 * &COSTH=SIGN(0.9999999999999999D0,COSTH)
3150  IF(abs(costh).GT.oneone)
3151  &costh=sign(oneone,costh)
3152  IF (redu.LT.1.d+00) RETURN
3153  costh2=(pcm3*pcm3+pcm2*pcm2-pcm1*pcm1)/(2.d+00*pcm2*pcm3)
3154 * IF(ABS(COSTH2).GT.0.9999999999999999D0)
3155 * &COSTH2=SIGN(0.9999999999999999D0,COSTH2)
3156  IF(abs(costh2).GT.oneone)
3157  &costh2=sign(oneone,costh2)
3158  sinth2=sqrt((oneone-costh2)*(oneone+costh2))
3159  sinth =sqrt((oneone-costh)*(oneone+costh))
3160  sinth1=costh2*sinth-costh*sinth2
3161  costh1=costh*costh2+sinth2*sinth
3162 C***RANDOM SELECTION OF THE SPHERICAL COORDINATES OF THE DIRECTION OF PA
3163 C***CFE, SFE ARE COS AND SIN OF THE ROTATION ANGLE OF THE SYSTEM 1, 2 AR
3164 C***THE DIRECTION OF PARTICLE 3
3165 C***CALCULATION OF THE SPHERICAL COORDINATES OF PARTICLES 1, 2
3166  cx11=-costh1
3167  cy11=sinth1*cfe
3168  cz11=sinth1*sfe
3169  cx22=-costh2
3170  cy22=-sinth2*cfe
3171  cz22=-sinth2*sfe
3172  CALL dsfecf(sif3,cof3)
3173  cod3=twotwo*rndm(cod3)-oneone
3174  sid3=sqrt((1.d+00-cod3)*(1.d+00+cod3))
3175  2 FORMAT(5f20.15)
3176  cod1=cx11*cod3+cz11*sid3
3177  chlp=(oneone-cod1)*(oneone+cod1)
3178  IF(chlp.LT.1.d-14)WRITE(isys,2)cod1,cof3,sid3,
3179  &cx11,cz11
3180  sid1=sqrt(chlp)
3181  cof1=(cx11*sid3*cof3-cy11*sif3-cz11*cod3*cof3)/sid1
3182  sif1=(cx11*sid3*sif3+cy11*cof3-cz11*cod3*sif3)/sid1
3183  cod2=cx22*cod3+cz22*sid3
3184  sid2=sqrt((oneone-cod2)*(oneone+cod2))
3185  cof2=(cx22*sid3*cof3-cy22*sif3-cz22*cod3*cof3)/sid2
3186  sif2=(cx22*sid3*sif3+cy22*cof3-cz22*cod3*sif3)/sid2
3187  400 CONTINUE
3188 * === Energy conservation check: === *
3189  eochck = umo - ecm1 - ecm2 - ecm3
3190 * SID1 = SQRT ( ( ONEONE - COD1 ) * ( ONEONE + COD1 ) )
3191 * SID2 = SQRT ( ( ONEONE - COD2 ) * ( ONEONE + COD2 ) )
3192 * SID3 = SQRT ( ( ONEONE - COD3 ) * ( ONEONE + COD3 ) )
3193  pzchck = pcm1 * cod1 + pcm2 * cod2 + pcm3 * cod3
3194  pxchck = pcm1 * cof1 * sid1 + pcm2 * cof2 * sid2
3195  & + pcm3 * cof3 * sid3
3196  pychck = pcm1 * sif1 * sid1 + pcm2 * sif2 * sid2
3197  & + pcm3 * sif3 * sid3
3198  eocmpr = 1.d-12 * umo
3199  IF ( abs(eochck) + abs(pxchck) + abs(pychck) + abs(pzchck)
3200  & .GT. eocmpr ) THEN
3201  WRITE(lunerr,*)
3202  & ' *** Threpd: energy/momentum conservation failure! ***',
3203  & eochck,pxchck,pychck,pzchck
3204  WRITE(lunerr,*)' *** SID1,SID2,SID3',sid1,sid2,sid3
3205  END IF
3206  RETURN
3207  END
3208 *=== xlamb ============================================================*
3209 *
3210  DOUBLE PRECISION FUNCTION dxlamb(X,Y,Z)
3211  IMPLICIT DOUBLE PRECISION (a-h,o-z)
3212  SAVE
3213  DATA idgb/0/
3214  COMMON /dgamre/ redu,amo,amm(15 )
3215  common/ddrei/test(12)
3216  yz=y-z
3217  dxlamb=x*x-2.d0*x*(y+z)+yz*yz
3218  xlam =dxlamb
3219  IF (idgb.LE.0) go to 11
3220  IF(dxlamb.GT.1.d-12) goto 11
3221  WRITE(6,12)
3222  WRITE(6,10) xlam,x,y,z,test
3223  WRITE(6,13)
3224  12 FORMAT(/,10x,' DXLAMB PRINT')
3225  13 FORMAT(10x,60(1h*))
3226  10 FORMAT(4e20.8,'DXLAMB',/,12f10.5)
3227  11 CONTINUE
3228  IF(dxlamb.LE.0.d0)dxlamb=abs(dxlamb)
3229  dxlamb=sqrt(dxlamb)
3230  RETURN
3231  END
3232 
3233 *-- Author :
3234 C DOUBLE PRECISION FUNCTION DXLAMB(X,Y,Z)
3235 C IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3236 C SAVE
3237 C YZ=Y-Z
3238 C DXLAMB=X*X-2.*X*(Y+Z)+YZ*YZ
3239 C IF(DXLAMB.LE.0.)DXLAMB=ABS(DXLAMB)
3240 C DXLAMB=SQRT(DXLAMB)
3241 C RETURN
3242 C END
3243 *-- Author :
3244 C
3245 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3246 C
3247  SUBROUTINE strafo(GAM,BGAM,CX,CY,CZ,COD,COF,SIF,P,ECM,
3248  1pl,cxl,cyl,czl,el)
3249  IMPLICIT DOUBLE PRECISION (a-h,o-z)
3250  SAVE
3251 C LORENTZ TRANSFORMATION INTO THE LAB - SYSTEM
3252  sid=sqrt((1.-cod)*(1.+cod)+1.e-22)
3253  sif=sqrt((1.-cof)*(1.+cof)+1.e-22)
3254  plx=p*sid*cof
3255  ply=p*sid*sif
3256  pcmz=p*cod
3257  plz=gam*pcmz+bgam*ecm
3258  pl=sqrt(plx*plx+ply*ply+plz*plz)
3259  el=gam*ecm+bgam*pcmz
3260 C ROTATION INTO THE ORIGINAL DIRECTION
3261  coz=plz/pl
3262  IF(coz.GE.1.)coz=0.999999999999
3263  siz=sqrt((1.-coz)*(1.+coz))
3264  CALL drtran(cx,cy,cz,coz,siz,sif,cof,cxl,cyl,czl)
3265  RETURN
3266  END
3267 *-- Author :
3268  SUBROUTINE drtran(XO,YO,ZO,CDE,SDE,SFE,CFE,X,Y,Z)
3269  IMPLICIT DOUBLE PRECISION (a-h,o-z)
3270  SAVE
3271  IF (abs(xo)-0.0001) 10,10,30
3272  10 IF (abs(yo)-0.0001) 20,20,30
3273  20 CONTINUE
3274  x=sde*cfe
3275  y=sde*sfe
3276  z=cde*zo
3277  RETURN
3278  30 CONTINUE
3279  xi=sde*cfe
3280  yi=sde*sfe
3281  zi=cde
3282  a=sqrt(xo**2+yo**2)
3283  x=-yo*xi/a-zo*xo*yi/a+xo*zi
3284  y=xo*xi/a-zo*yo*yi/a+yo*zi
3285  z=a*yi+zo*zi
3286  RETURN
3287  END
3288 *-- Author :
3289 C
3290 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3291 C
3292  SUBROUTINE dchant
3293  IMPLICIT DOUBLE PRECISION (a-h,o-z)
3294  SAVE
3295  CHARACTER*8 zkname
3296 C COMMON/DDECAC/ ZKNAME(540),NZK(540,3),WT(540)
3297 
3298  parameter(idmax9=602)
3299 C CHARACTER*8 ZKNAME
3300  common/ddecac/ zkname(idmax9),wt(idmax9),nzk(idmax9,3)
3301 
3302 
3303  CHARACTER*8 aname
3304  common/dpar/aname(210),am(210),ga(210),tau(210),ich(210),ibar(210)
3305  *,k1(210),k2(210)
3306  dimension hwt(602)
3307 C CHANGE OF WEIGHTS WT FROM ABSOLUT VALUES INTO THE SUM OF WT OF A DEC.
3308  DO 10 j=1,602
3309  10 hwt(j)=0.
3310  DO 30 i=1,210
3311  ik1=k1(i)
3312  ik2=k2(i)
3313  hv=0.
3314  DO 20 j=ik1,ik2
3315  hv=hv+wt(j)
3316  hwt(j)=hv
3317 C IF(HWT(J).GT.1.) WRITE(6,1000) HWT(J),J,I,IK1
3318  20 CONTINUE
3319 C1000 FORMAT(2X,15H ERROR IN HWT =,1F10.5,8H J,I,K1=,3I5)
3320  30 CONTINUE
3321  DO 40 j=1,602
3322  40 wt(j)=hwt(j)
3323  RETURN
3324  END
3325 *-- Author :
3326 C
3327 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3328 C
3329  SUBROUTINE dtwopd(UMO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1, COD2,
3330  +cof2,sif2,am1,am2)
3331  IMPLICIT DOUBLE PRECISION (a-h,o-z)
3332  SAVE
3333 C*****TWO PARTICLE DECAY IN THE CM - SYSTEM
3334 C
3335  IF(umo.LT.(am1+am2)) THEN
3336  WRITE(6,'(/,A/A,3(1PE12.4))')
3337  + ' INCONSISTENT CALL OF TWOPAD / EXECUTION STOPPED',
3338  + ' UMO, AM1, AM2 :', umo, am1, am2
3339  stop
3340  ENDIF
3341 C
3342  ecm1=((umo-am2)*(umo+am2) + am1*am1)/(2.*umo)
3343  ecm2=umo-ecm1
3344  pcm1=sqrt((ecm1-am1)*(ecm1+am1))
3345  pcm2=pcm1
3346  CALL dsfecf(sif1,cof1)
3347  cod1=2.*rndm(x)-1.
3348  cod2=-cod1
3349  cof2=-cof1
3350  sif2=-sif1
3351  RETURN
3352  END
3353 *-- Author :
3354 C
3355 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3356 C
3357  SUBROUTINE dsfecf(SFE,CFE)
3358  IMPLICIT DOUBLE PRECISION (a-h,o-z)
3359  SAVE
3360  10 x=rndm(v)
3361  y=rndm(v)
3362  xx=x*x
3363  yy=y*y
3364  xy=xx+yy
3365  IF(xy.GT.1) goto10
3366  cfe=(xx-yy)/xy
3367  sfe=2.*x*y/xy
3368  IF(rndm(v).LT.0.5d0) goto20
3369  RETURN
3370  20 sfe=-sfe
3371  RETURN
3372  END
3373 *-- Author :
3374 C
3375 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3376 C
3377  SUBROUTINE ddates
3378  IMPLICIT DOUBLE PRECISION (a-h,o-z)
3379  SAVE
3380  CHARACTER*8 zkname,z
3381 C COMMON /DDECAC/ ZKNAME(540),NZK(540,3),WT(540)
3382 
3383  parameter(idmax9=602)
3384 C CHARACTER*8 ZKNAME
3385  common/ddecac/ zkname(idmax9),wt(idmax9),nzk(idmax9,3)
3386 
3387 
3388  CHARACTER*8 aname
3389  COMMON /dpar/ aname(210),am(210),ga(210),tau(210), ich(210),ibar
3390  +(210),k1(210),k2(210)
3391 C----------------------
3392  dimension ichar(210)
3393  equivalence(ich(1),ichar(1))
3394  dimension z(3)
3395 C---------------------------
3396  WRITE(6, 1000)
3397  1000 FORMAT(1h1,' ')
3398  WRITE(6, 1010)
3399  1010 FORMAT(///' TABLE OF USED PARTICLES AND RESONANCES (I)',//
3400  +' I = NUMBER OF PARTICLE OR RESONANCE',/
3401  +' IPDG = P D G NUMBER OF PARTICLE OR RESONANCE',/
3402  +' ANAME = NAME OF I'/, ' AM = MASS OF I (GEV)',/
3403  +' GA = WIDTH OF I (GEV)',/ ' TAU = LIFE TIME OF I (SEC.)',/
3404  +' ICH = ELECTRIC CHARGE OF I, IBAR = BARYONIC CHARGE OF I',/' ', '
3405  +K1 = FIRST DECAY CHANNEL NUMBER, K2 = LAST DECAY CHANNEL NUMBER OF
3406  +I')
3407 
3408 
3409  WRITE(6, 1020)
3410  1020 FORMAT(///
3411  +' I ANAME AM GA TAU ICH IBAR K1 K2'/)
3412  joo=210
3413  DO 10 i=1,joo
3414  ipdg=mpdgha(i)
3415  WRITE(6, 1030)i,ipdg,aname(i),am(i),
3416  + ga(i),tau(i),ich(i),ibar(i), k1
3417  + (i),k2(i)
3418  1030 FORMAT (1i4,i6,2x,1a8,3e11.4,4i4)
3419  IF(i.EQ.43) WRITE(6, 1000)
3420  IF(i.EQ.43) WRITE(6, 1020)
3421  IF(i.EQ.99) WRITE(6, 1000)
3422  IF(i.EQ.99) WRITE(6, 1020)
3423  IF(i.EQ.155) WRITE(6, 1000)
3424  IF(i.EQ.155) WRITE(6, 1020)
3425  10 CONTINUE
3426  WRITE(6, 1000)
3427  WRITE(6, 1040)
3428  1040 FORMAT(///' DECAY CHANNELS OF PARTICLES AND RESONANCES',//)
3429  WRITE(6, 1050)
3430  1050 FORMAT(' ANAME = PARTICLE AND RESONANCE NAME'/,
3431  +' DNAME = DECAY CHANNEL NAME'/, ' J = DECAY CHANNEL NUMBER'/,
3432  +' I = NUMBER OF DECAYING PARTICLE'/,
3433  +' WT = SUM OF DECAY CHANNEL WEIGHTS FROM K1(I) UP TO J'/,
3434  +' NZK = PROGRAM INTERNAL NUMBERS OF DECAY PRODUCTS')
3435 
3436  WRITE(6, 1060)
3437  1060 FORMAT(///' I J ANAME DNAME DECAY
3438  +PRODUCTS WT NZK'/)
3439  DO 60 i=1,joo
3440  ik1=k1(i)
3441  ik2=k2(i)
3442  IF (ik1.LE.0) go to 60
3443  DO 50 ik=ik1,ik2
3444  i1=nzk(ik,1)
3445  i2=nzk(ik,2)
3446  i3=nzk(ik,3)
3447  IF (i1.LE.0) i1=29
3448  IF (i2.LE.0) i2=29
3449  IF (i3.LE.0) i3=29
3450  j1=i1
3451  j2=i2
3452  j3=i3
3453  z(1)=aname(i1)
3454  z(2)=aname(i2)
3455  z(3)=aname(i3)
3456  WRITE(6, 1070)i,ik,aname(i),zkname(ik),(z(j),j=1,3),wt(ik),j1,j2,
3457  + j3
3458  1070 FORMAT(2i5,' DECAY OF ',1a8,' (CHANNEL: ',1a6,' ) TO ',3(1a6,2x),
3459  +1f8.4,3i5)
3460  amtest=am(i)-am(j1)-am(j2)-am(j3)
3461  ibtest=ibar(i)-ibar(j1)-ibar(j2)-ibar(j3)
3462  ictest=ichar(i)-ichar(j1)-ichar(j2)-ichar(j3)
3463  IF (amtest) 20,30,30
3464  20 mtest=1
3465  go to 40
3466  30 mtest=0
3467  40 CONTINUE
3468  IF (mtest+ibtest**2+ictest**2.NE.0) WRITE(6, 1080)amtest,
3469  + ibtest,
3470  + ictest
3471  1080 FORMAT (' ***** ERROR IN MASS, BAR.CH. OR E.CH. ',f10.5,2i6)
3472  IF(ik.EQ.27) WRITE(6, 1000)
3473  IF(ik.EQ.27) WRITE(6, 1060)
3474  IF(ik.EQ.62) WRITE(6, 1000)
3475  IF(ik.EQ.62) WRITE(6, 1060)
3476  IF(ik.EQ.101) WRITE(6, 1000)
3477  IF(ik.EQ.101) WRITE(6, 1060)
3478  IF(ik.EQ.144) WRITE(6, 1000)
3479  IF(ik.EQ.144) WRITE(6, 1060)
3480  IF(ik.EQ.183) WRITE(6, 1000)
3481  IF(ik.EQ.183) WRITE(6, 1060)
3482  IF(ik.EQ.222) WRITE(6, 1000)
3483  IF(ik.EQ.222) WRITE(6, 1060)
3484  IF(ik.EQ.261) WRITE(6, 1000)
3485  IF(ik.EQ.261) WRITE(6, 1060)
3486  IF(ik.EQ.300) WRITE(6, 1000)
3487  IF(ik.EQ.300) WRITE(6, 1060)
3488  IF(ik.EQ.362) WRITE(6, 1000)
3489  IF(ik.EQ.362) WRITE(6, 1060)
3490  IF(ik.EQ.401) WRITE(6, 1000)
3491  IF(ik.EQ.401) WRITE(6, 1060)
3492  IF(ik.EQ.440) WRITE(6, 1000)
3493  IF(ik.EQ.440) WRITE(6, 1060)
3494  IF(ik.EQ.479) WRITE(6, 1000)
3495  IF(ik.EQ.479) WRITE(6, 1060)
3496  IF(ik.EQ.518) WRITE(6, 1000)
3497  IF(ik.EQ.518) WRITE(6, 1060)
3498  50 CONTINUE
3499  60 CONTINUE
3500  RETURN
3501  END
3502 *-- Author :
3503 C
3504 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3505 C
3506  SUBROUTINE ddatar
3507  IMPLICIT DOUBLE PRECISION (a-h,o-z)
3508  SAVE
3509  common/dinpda/imps(6,6),imve(6,6),ib08(6,21),ib10(6,21),
3510  *ia08(6,21),ia10(6,21),a1,b1,b2,b3,lt,lb,bet,as,b8,ame,diq,isu
3511  dimension iv(36),ip(36),ib(126),ibb(126),ia(126),iaa(126)
3512 C DEFINE THE FIELDS FOR PARTICLE CLASSIFICATION
3513 C IMPS=PSEUDO SCALAR MESONS (SPIN=0)
3514 C IMVE=VECTOR MESONS (SPIN=1)
3515 C IB08(IA08)=BARYONS (ANTIBARYONS) (SPIN=1/2)
3516 C IB10(IA10)=BARYONS (ANTIBARYONS) (SPIN=3/2)
3517  DATA ip/
3518  *23,14,16,116,0,0,13,23,25,117,0,0,15,24,31,120,0,0,119,118,121,
3519  *122,14*0/
3520  l=0
3521  DO 20 i=1,6
3522  DO 10 j=1,6
3523  l=l+1
3524  imps(i,j)=ip(l)
3525  10 CONTINUE
3526  20 CONTINUE
3527  DATA iv/
3528  *33,34,38,123,0,0,32,33,39,124,0,0,36,37,96,127,0,0,126,125,128,
3529  *129,14*0/
3530  l=0
3531  DO 40 i=1,6
3532  DO 30 j=1,6
3533  l=l+1
3534  imve(i,j)=iv(l)
3535  30 CONTINUE
3536  40 CONTINUE
3537  DATA ib/
3538  *0,1,21,140,0,0,8,22,137,0,0,97,138,0,0,146,5*0,
3539  *1,8,22,137,0,0,0,20,142,0,0,98,139,0,0,147,5*0,
3540  *21,22,97,138,0,0,20,98,139,0,0,0,145,0,0,148,5*0,
3541  *140,137,138,146,0,0,142,139,147,0,0,145,148,50*0/
3542  l=0
3543  DO 60 i=1,6
3544  DO 50 j=1,21
3545  l=l+1
3546  ib08(i,j)=ib(l)
3547  50 CONTINUE
3548  60 CONTINUE
3549  DATA ibb/
3550  *53,54,104,161,0,0,55,105,162,0,0,107,164,0,0,167,5*0,
3551  *54,55,105,162,0,0,56,106,163,0,0,108,165,0,0,168,5*0,
3552  *104,105,107,164,0,0,106,108,165,0,0,109,166,0,0,169,5*0,
3553  *161,162,164,167,0,0,163,165,168,0,0,166,169,0,0,170,47*0/
3554  l=0
3555  DO 80 i=1,6
3556  DO 70 j=1,21
3557  l=l+1
3558  ib10(i,j)=ibb(l)
3559  70 CONTINUE
3560  80 CONTINUE
3561  DATA ia/
3562  *0,2,99,152,0,0,9,100,149,0,0,102,150,0,0,158,5*0,
3563  *2,9,100,149,0,0,0,101,154,0,0,103,151,0,0,159,5*0,
3564  *99,100,102,150,0,0,101,103,151,0,0,0,157,0,0,160,5*0,
3565  *152,149,150,158,0,0,154,151,159,0,0,157,160,50*0/
3566  l=0
3567  DO 100 i=1,6
3568  DO 90 j=1,21
3569  l=l+1
3570  ia08(i,j)=ia(l)
3571  90 CONTINUE
3572  100 CONTINUE
3573  DATA iaa/
3574  *67,68,110,171,0,0,69,111,172,0,0,113,174,0,0,177,5*0,
3575  *68,69,111,172,0,0,70,112,173,0,0,114,175,0,0,178,5*0,
3576  *110,111,113,174,0,0,112,114,175,0,0,115,176,0,0,179,5*0,
3577  *171,172,174,177,0,0,173,175,178,0,0,176,179,0,0,180,47*0/
3578  l=0
3579  DO 120 i=1,6
3580  DO 110 j=1,21
3581  l=l+1
3582  ia10(i,j)=iaa(l)
3583  110 CONTINUE
3584  120 CONTINUE
3585 C DEFINE THE FREE PARAMETERS FOR THE MONTE-CARLO PROGRAMMES BAMJET
3586 C AND PARJET
3587  a1=0.88
3588  b3=8.0
3589  b1=8.0
3590  b2=8.0
3591  isu=4
3592 c BET=8.0
3593  bet=9.5
3594  bet=12.
3595  as=0.50
3596  ame=0.95
3597  b8=0.40
3598  diq=0.375
3599  lt=0
3600  lb=0
3601 C THE FOLLOWING ARE THE PARAMETERS USED IN ABR8611
3602  a1=0.95
3603  a1=0.50
3604  a1=0.88
3605  b3=8.
3606  b1=6.
3607  b1=3.
3608  b2=6.
3609  b2=3.
3610  as=0.25
3611 * AME=0.95
3612  b8=0.33
3613 C WRITE (6,123)A1,B3,B1,B2,ISU,BET,AS,AME,LT,LB,B8,DIQ
3614 C 123 FORMAT (' DATAR3 INITIALIZATION:PARAMETERS SET LIKE IN ABR8611'/
3615 C *' A1 = ',F10.4/
3616 C *' B3 = ',F10.4/
3617 C *' B1 = ',F10.4/
3618 C *' B2 = ',F10.4/
3619 C *' ISU = ',I10/
3620 C *' BET = ',F10.4/
3621 C *' AS = ',F10.4/
3622 C *' AME = ',F10.4/
3623 C *' LT = ',I10/
3624 C *' LB = ',I10/
3625 C *' B8 = ',F10.4/
3626 C *' DIQ = ',F10.4)
3627  RETURN
3628  END
3629 *-- Author :
3630 C
3631 C
3632 C--------------------------------------------------------------------
3633 C
3634 C FILE TECALBAM
3635 C
3636 C
3637 C--------------------------------------------------------------------
3638  SUBROUTINE tecalb
3639  IMPLICIT DOUBLE PRECISION (a-h,o-z)
3640  SAVE
3641 C SUBROUTINE TECALBAM
3642 C
3643 C TWO CHAIN FRAGMENTATION MODEL FOR PARTICLE PRODUCTION
3644 C TEST OF CALBAM ROUTINE CALLING BAMJET
3645 C JUNE 1987, J.RANFT
3646 C********************************************************************
3647 C
3648 C OPTIONS
3649 C
3650 C JNI=7 BAMJET DISTRIBUTIONS ANALOG TO JNI=2
3651 C
3652 C IP=1=P, IP=2=AP, IP=8=N, IP=9=AN, IP=13=PI+, IP=14=PI-,
3653 C IP=15=K+, IP=16=K-,
3654 C
3655 C**********************************************************************
3656 C
3657 *KEEP,DFINPA.
3658  CHARACTER*8 anf
3659  parameter(nfimax=249)
3660  COMMON /dfinpa/ anf(nfimax),pxf(nfimax),pyf(nfimax),pzf(nfimax),
3661  +hef(nfimax),amf(nfimax), ichf(nfimax),ibarf(nfimax),nref(nfimax)
3662  COMMON /dfinpz/iormo(nfimax),idaug1(nfimax),idaug2(nfimax),
3663  * istath(nfimax)
3664 *KEEP,DINPDA.
3665  COMMON /dinpda/ imps(6,6),imve(6,6),ib08(6,21),ib10(6,21), ia08
3666  +(6,21),ia10(6,21), a1,b1,b2,b3,lt,le,bet,as,b8,ame,diq,isu
3667 *KEEP,DPRIN.
3668  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
3669 *KEND.
3670  common/jni/jni
3671  COMMON /diff/ idiff
3672  COMMON /dkpl/uplo,ipq
3673  COMMON /dinv/pnuc(3),inucvt
3674  common/capkop/xx1,xx3
3675 C----------------------------------------------------------------------
3676  WRITE (6,1000)
3677  1000 FORMAT (' ##############################################'/
3678  +' PROGRAM TECABAPT'/
3679  +' ######################################################')
3680 C CALL PRIBLO
3681 C CALL DATAR3
3682 C CALL CHANWT
3683  init=0
3684  lt=0
3685  it=1
3686  ip=1
3687  ipri=0
3688  10 CONTINUE
3689  READ(5,1010)jni,nevt,ip,ncases,poo,aoo,znuc
3690  1010 FORMAT(4i10,3f10.2)
3691  IF (it.EQ.0) it=1
3692  IF (jni.LE.0) go to 120
3693  WRITE(6, 1010)jni,nevt,ip,ncases,poo,aoo,znuc,it
3694  IF (jni.LT.0)stop
3695 C********** JNI SELECTS OPTION *************************************
3696  jni=7
3697  go to(20,30,40,50,60,70,80,100),jni
3698  20 CONTINUE
3699  30 CONTINUE
3700  40 CONTINUE
3701  50 CONTINUE
3702  60 CONTINUE
3703  70 CONTINUE
3704  go to 110
3705  80 CONTINUE
3706 C*** JNI=7 CALCUL. BAMJET EVENTS
3707 C*** WITH ENERGY POO (CMS ENERGY)
3708  ipri=0
3709  lt=0
3710  init=0
3711  ipq=1
3712  xx1=0.9
3713  xx3=1.
3714  uplo=poo
3715  iii=1
3716  CALL distcm(1,ipq,poo,ipq,ipq)
3717 C CALL DISRES(1,IPQ,POO,IPQ,IPQ)
3718  DO 90 l=1, nevt
3719  IF (ip.EQ.103)CALL calbam(0,1,1,1,7,1,1,poo,3,nhad)
3720  IF (ip.EQ.109)CALL calbam(0,1,1,7,1,1,1,poo,3,nhad)
3721  IF (ip.EQ.104)CALL calbam(0,1,1,1,2,2,1,poo,4,nhad)
3722  IF (ip.EQ.1010)CALL calbam(0,1,1,1,2,3,1,poo,4,nhad)
3723  IF (ip.EQ.105)CALL calbam(0,1,1,1,2,7,8,poo,5,nhad)
3724  IF (ip.EQ.1011)CALL calbam(0,1,1,7,7,1,1,poo,5,nhad)
3725  IF (ip.EQ.106)CALL calbam(0,1,1,1,1,1,1,poo,6,nhad)
3726  IF (ip.EQ.1012)CALL calbam(0,1,1,7,7,7,1,poo,6,nhad)
3727  IF (ip.EQ.1050)CALL calbam(0,1,1,1,1,2,1,poo,10,nhad)
3728 C
3729  CALL ddecay(nhad,2)
3730  CALL distcm(2,nhad,poo,ipq,ncases)
3731  90 CONTINUE
3732 C
3733  WRITE(6, 1020)poo,ip,ncases
3734  1020 FORMAT (' BAMJET (POO,IP,NCASES) = ',1f10.2,2i10)
3735  CALL distcm(3,nevt,poo,ipq,ncases)
3736 C CALL DISRES(3,III*NEVT,POO,IPQ,NCASES)
3737  go to 110
3738  100 CONTINUE
3739  110 CONTINUE
3740  go to 10
3741  120 CONTINUE
3742  RETURN
3743  END
3744 *-- Author :
3745 C
3746 C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3747 C
3748  SUBROUTINE distcm(IOP,NHAD,POLAB,KPROJ,KTARG)
3749  IMPLICIT DOUBLE PRECISION (a-h,o-z)
3750  SAVE
3751 C
3752 C*** 1=P, 2=N, 3=PI+, 4=PI-, 5=PIO, 6=GAM+HYP, 7=K, 8=ANUC, 9=CHARGED
3753 C*** 10=TOT, 11=TOTHAD
3754 C
3755  CHARACTER*8 anh
3756  parameter(nfimax=249)
3757  COMMON /dfinpa/ anh(nfimax),px(nfimax),py(nfimax),pz(nfimax),
3758  +he(nfimax),am(nfimax), ich(nfimax),ibar(nfimax),nr(nfimax)
3759  COMMON /dfinpz/iormo(nfimax),idaug1(nfimax),idaug2(nfimax),
3760  * istath(nfimax)
3761 C---------------------
3762  CHARACTER*8 aname
3763  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),iich(210),
3764  +iibar(210),k1(210),k2(210)
3765 C------------------
3766  COMMON /histo / xmult(100,10),ymult(100,10),xxfl(50,20), yxfl
3767  +(50,20),xyl(50,20),yyl(50,20), yylps(50,20),ptp(50,20),pty(50,20),
3768  +fill(6000)
3769  dimension avmult(12,30),ave(12,30),indx(25),mu(12,30), akno
3770  +(100,2),xkno(100,2),ake(12,30),aaso(12,30)
3771  COMMON /dkpl/uplo,kpl
3772  common/jni/jni
3773 C
3774  DATA ipriop/1/
3775  DATA indx/1,8,10,10,10,10,7,2,7,10,10,7,3,4,5,6,
3776  *11,12,7,13,14,15,16,17,18/
3777 C-----------------------------------------------------------------------
3778  go to(10,60,100),iop
3779  10 CONTINUE
3780  kpl=1
3781  avpt=0.
3782  navpt=0
3783  dxfl=0.04
3784  po=polab
3785 C EEO=SQRT(PO**2+AAM(NHAD)**2)
3786 C UMO=SQRT(AAM(KTARG)**2+AAM(KPROJ)**2+2.*AAM(KTARG)*EEO)
3787  IF(jni.EQ.7) umo=polab
3788  umo=polab
3789  eeo=umo
3790  po=eeo/2.d0
3791  WRITE(6, 1000)eeo,po,nhad
3792  1000 FORMAT (' EEO',f10.2,f10.2,i10)
3793  dy=0.2
3794  dpt=0.10
3795  DO 20 i=1,10
3796  avmult(kpl,i)=1.e-18
3797  ave(kpl,i)=0.
3798  DO 20 j=1,100
3799  xmult(j,i)=j-1
3800  ymult(j,i)=1.d-18
3801  akno(j,1)=1.d-18
3802  akno(j,2)=1.d-18
3803  20 CONTINUE
3804  WRITE(6, 1000)eeo,po,nhad
3805  DO 30 i=1,20
3806  DO 30 j=1,50
3807  xxfl(j,i)=j*dxfl -1.
3808  yxfl(j,i)=1.d-18
3809  xyl(j,i)=-5.0+j*dy
3810  yyl(j,i)=1.d-18
3811  yylps(j,i)=1.e-18
3812  ptp(j,i)=j*dpt
3813  pty(j,i)=1.d-18
3814  30 CONTINUE
3815  WRITE(6, 1000)eeo,po,nhad
3816  40 CONTINUE
3817  DO 50 i=1,30
3818  ave(kpl,i)=1.d-18
3819  avmult(kpl,i)=1.d-18
3820  mu(kpl,i)=0
3821  aaso(kpl,i)=uplo
3822  50 CONTINUE
3823  WRITE(6, 1000)eeo,po,nhad
3824  RETURN
3825 C
3826  60 CONTINUE
3827 C WRITE(6, 1000)EEO,PO,NHAD
3828  avmult(kpl,30)=avmult(kpl,30)+nhad
3829  nnhad=nhad+1
3830  IF (nnhad.GT.100) nnhad=100
3831  ymult(nnhad,10)=ymult(nnhad,10)+1.
3832  DO 70 i=1,30
3833  mu(kpl,i)=0
3834  70 CONTINUE
3835  eetot=0.d0
3836  DO 71 i=1,nhad
3837  IF(ibar(i).NE.500)THEN
3838 C WRITE(6,*)I,ANH(I),HE(I),AM(I),IBAR(I),NR(I)
3839  eetot=eetot+he(i)
3840  ENDIF
3841  71 CONTINUE
3842  IF(eetot.GT.polab+1.d-6)THEN
3843  WRITE(6,*).gt.' eetotpolab ',eetot,polab
3844  ENDIF
3845 C WRITE(6,*)' eetot ',EETOT
3846  DO 80 i=1,nhad
3847  IF(ibar(i).NE.500)THEN
3848  nre=nr(i)
3849  IF (nre.GT.25) nre=3
3850  IF (nre.LT. 1) nre=3
3851  ni=indx(nre)
3852  IF (nre.EQ.28)ni=8
3853  ave(kpl,nre)=ave(kpl,nre)+he(i)
3854  ave(kpl,30)=ave(kpl,30)+he(i)
3855  IF (ni.NE.6) ave(kpl,29)=ave(kpl,29)+he(i)
3856  avmult(kpl,nre)=avmult(kpl,nre)+1.
3857  IF (ni.NE.6) avmult(kpl,29)=avmult(kpl,29)+1.
3858  mu(kpl,ni)=mu(kpl,ni)+1
3859  IF (ich(i).NE.0)mu(kpl,9)=mu(kpl,9)+1
3860 C TOTAL=30 TOTAL-GAMMA=29 ANTIHYP=28
3861 C CHARGED=27
3862  IF (ich(i).NE.0)ave(kpl,27)=ave(kpl,27)+he(i)
3863  IF (ich(i).NE.0)avmult(kpl,27)=avmult(kpl,27)+1
3864 C XFL=PZ(I)/PO
3865  xfl=(pz(i)/abs(pz(i)))*he(i)/po
3866  ixfl=xfl/dxfl+26.
3867  IF (ixfl.LT. 1) ixfl=1
3868  IF (ixfl.GT.50) ixfl=50
3869 C XXXFL=SQRT(XFL**2+(AM(I)+0.3)**2/PO**2)
3870  xxxfl=abs(xfl)
3871  IF (ich(i).NE.0)yxfl(ixfl,9)=yxfl(ixfl,9)+xxxfl
3872  yxfl(ixfl,ni)=yxfl(ixfl,ni)+xxxfl
3873  yxfl(ixfl,10)=yxfl(ixfl,10)+xxxfl
3874  ptt=px(i)**2+py(i)**2
3875  yl=0.5*log(abs((he(i)+pz(i)+1.e-10)/(he(i)-pz(i)+1.e-10)))
3876  ylps=log(abs((pz(i)+sqrt(pz(i)**2+ptt))/sqrt(ptt)+1.e-18))
3877  iylps=(ylps+5.0)/dy
3878  IF (iylps.LT.1)iylps=1
3879  IF (iylps.GT.50)iylps=50
3880  yylps(iylps,ni)=yylps(iylps,ni)+1.
3881  yylps(iylps,10)=yylps(iylps,10)+1.
3882  IF (ich(i).NE.0)yylps(iylps,9)=yylps(iylps,9)+1.
3883  iyl=(yl+5.0)/dy
3884  IF (iyl.LT.1) iyl=1
3885  IF (iyl.GT.50) iyl=50
3886  IF (ich(i).NE.0)yyl(iyl,9)=yyl(iyl,9)+1.
3887  yyl(iyl,ni)=yyl(iyl,ni)+1.
3888  yyl(iyl,10)=yyl(iyl,10)+1.
3889  pt=sqrt(ptt)+0.001
3890  avpt=avpt+pt
3891  navpt=navpt+1
3892  ipt=pt/dpt+1.
3893  IF (ipt.LT.1)ipt=1
3894  IF (ipt.GT.50) ipt=50
3895  IF (ich(i).NE.0)pty(ipt,9)=pty(ipt,9)+1./pt
3896  pty(ipt,ni)=pty(ipt,ni)+1./pt
3897  pty(ipt,10)=pty(ipt,10)+1./pt
3898  ENDIF
3899  80 CONTINUE
3900  DO 90 i=1,9
3901  im=mu(kpl,i)+1
3902  IF (im.GT.100)im=100
3903  ymult(im,i)=ymult(im,i)+1.
3904  90 CONTINUE
3905  RETURN
3906 C------------------------------------------------
3907  100 CONTINUE
3908  WRITE(6, 1000)eeo,po,nhad
3909 C1020 FORMAT (' AVMULT=',11F10.5/,' AVE=',11F10.5)
3910  DO 110 i=1,30
3911  avmult(kpl,i)=avmult(kpl,i)/nhad
3912  ave(kpl,i)=ave(kpl,i)/nhad
3913  110 CONTINUE
3914  avpt=avpt/navpt
3915  WRITE (6,1030)avpt,navpt
3916  1030 FORMAT (' AVERAGE PT= ',f12.4,i10)
3917  WRITE(6, 1040)
3918  1040 FORMAT(' PARTICLE REF,CHAR,IBAR, MASS AVERAGE',
3919  +' ENERGY, MULTIPLICITY, INELASTICITY')
3920  DO 120 i=1,30
3921  ake(kpl,i)=ave(kpl,i)/eeo
3922  WRITE(6, 1050)aname(i),i,iich(i),iibar(i),
3923  + aam(i), ave(kpl,i),avmult
3924  + (kpl,i),ake(kpl,i)
3925  1050 FORMAT (' ',a8,3i5,f10.3,3f18.6)
3926  120 CONTINUE
3927  DO 130 i=1,10
3928  DO 130 j=1,100
3929  ymult(j,i)=ymult(j,i)/nhad
3930  130 CONTINUE
3931  DO 140 i=1,20
3932  DO 140 j=1,50
3933  yxfl(j,i)=yxfl(j,i)/(nhad*dxfl)
3934  yy l(j,i)=yy l(j,i)/(nhad*dy)
3935  yylps(j,i)=yylps(j,i)/(nhad*dy)
3936  pty(j,i)=pty(j,i)/(nhad*dpt)
3937  140 CONTINUE
3938  150 CONTINUE
3939  WRITE(6, 1060)
3940  1060 FORMAT('1 RAPIDITY DISTRIBUTION')
3941  DO 160 j=1,50
3942  WRITE(6, 1070)xyl(j,1),(yyl(j,i),i=1,10)
3943  1070 FORMAT (f10.2,10e11.3)
3944  160 CONTINUE
3945  DO 161 j=1,50
3946  WRITE(6, 1070)xyl(j,1),(yyl(j,i),i=11,20)
3947  161 CONTINUE
3948  WRITE(6, 1060)
3949  WRITE(6,*)' 1=*=p, 2=n, 3=pi+, 4=pi-, 5=K+, 6=K-,',
3950  &' 8=ap, 9=chargd., 10=Z=all, 11=+=Lamb, 12=A=aLam,',
3951  &' 13=O=sig-, 14=B=Sig+, 15=C=Sig0, 16=D=pi0'
3952  CALL plot(xyl,yyl,1000,20,50,-5.d0,dy,0.d0,0.1d0)
3953  WRITE(6,*)' 1=*=p, 2=n, 3=pi+, 4=pi-, 5=K+, 6=K-,',
3954  &' 8=ap, 9=chargd., 10=Z=all, 11=+=Lamb, 12=A=aLam,',
3955  &' 13=O=sig-, 14=B=Sig+, 15=C=Sig0, 16=D=pi0'
3956  CALL plot(xyl,yylps,1000,20,50,-5.d0,dy,0.d0,0.1d0)
3957 C IF (IPRIOP.EQ.1) GO TO 1423
3958  WRITE(6, 1080)
3959  1080 FORMAT ('1 LONG MOMENTUM (SCALED) DISTRIBUTION')
3960  DO 170 j=1,50
3961  WRITE(6, 1070)xxfl(j,1),(yxfl(j,i),i=1,10)
3962  170 CONTINUE
3963  DO 171 j=1,50
3964  WRITE(6, 1070)xxfl(j,1),(yxfl(j,i),i=11,20)
3965  171 CONTINUE
3966  180 CONTINUE
3967  WRITE(6, 1080)
3968  WRITE(6,*)' 1=*=p, 2=n, 3=pi+, 4=pi-, 5=K+, 6=K-,',
3969  &' 8=ap, 9=chargd., 10=Z=all, 11=+=Lamb, 12=A=aLam,',
3970  &' 13=O=sig-, 14=B=Sig+, 15=C=Sig0, 16=D=pi0'
3971  CALL plot(xxfl,yxfl,1000,20,50,-1.d0,dxfl,0.d0,0.05d0)
3972  WRITE(6, 1090)
3973  1090 FORMAT ('1 MULTIPLICITY DISTRIBUTIONS')
3974  simul=0.
3975  sumul=0.
3976  DO 190 j=1,100
3977  sumul=sumul+ymult(j,10)
3978  simul=simul+ymult(j,9)
3979  190 CONTINUE
3980  WRITE(6, 1100)(xmult(j,1),ymult(j,9),ymult(j,10),j=1,100)
3981  1100 FORMAT(f6.1,2e12.4,f6.1,2e12.4,f6.1,2e12.4,f6.1,2e12.4)
3982  WRITE(6, 1090)
3983  WRITE(6,*)' 1=*=p, 2=n, 3=pi+, 4=pi-, 5=K+, 6=K-,',
3984  &' 8=ap, 9=chargd., 10=Z=all, 11=+=Lamb, 12=A=aLam,',
3985  &' 13=O=sig-, 14=B=Sig+, 15=C=Sig0, 16=D=pi0'
3986  CALL plot(xmult,ymult,1000,10,100,0.d0,1.d0,0.d0,0.01d0)
3987  DO 200 i=1,100
3988  xkno(i,1)=i/avmult(kpl,30)
3989  xkno(i,2)=i/avmult(kpl,27)
3990  akno(i,1)=ymult(i,10)*avmult(kpl,30)/sumul
3991  akno(i,2)=ymult(i,9)*avmult(kpl,27)/simul
3992  akno(i,1)=log10(akno(i,1)+1.d-9)
3993  akno(i,2)=log10(akno(i,2)+1.d-9)
3994  200 CONTINUE
3995  WRITE(6, 1110)
3996  1110 FORMAT ('1 KNO MULTIPLICITY DISTRIBUTIONS')
3997  WRITE(6,*)' 1=*=p, 2=n, 3=pi+, 4=pi-, 5=K+, 6=K-,',
3998  &' 8=ap, 9=chargd., 10=Z=all, 11=+=Lamb, 12=A=aLam,',
3999  &' 13=O=sig-, 14=B=Sig+, 15=C=Sig0, 16=D=pi0'
4000  CALL plot(xkno,akno,200,2,100,0.d0,0.08d0,-4.d0,0.05d0)
4001  DO 210 i=1,10
4002  DO 210 j=1,100
4003  ymult(j,i)=log10(ymult(j,i))
4004  210 CONTINUE
4005  DO 220 i=1,20
4006  DO 220 j=1,50
4007  yxfl(j,i)=log10(abs(yxfl(j,i)+1.d-8))
4008  yyl(j,i)=log10(yyl(j,i)+1.d-8)
4009  pty(j,i)=log10(pty(j,i)+1.d-8)
4010  220 CONTINUE
4011  230 CONTINUE
4012  WRITE(6, 1060)
4013  WRITE(6,*)' 1=*=p, 2=n, 3=pi+, 4=pi-, 5=K+, 6=K-,',
4014  &' 8=ap, 9=chargd., 10=Z=all, 11=+=Lamb, 12=A=aLam,',
4015  &' 13=O=sig-, 14=B=Sig+, 15=C=Sig0, 16=D=pi0'
4016  CALL plot(xyl,yyl,1000,20,50,-5.d0,dy,-3.5d0,0.05d0)
4017  DO 240 j=1,50
4018  WRITE(6, 1070)xxfl(j,1),(yxfl(j,i),i=1,10)
4019  240 CONTINUE
4020  DO 241 j=1,50
4021  WRITE(6, 1070)xxfl(j,1),(yxfl(j,i),i=11,20)
4022  241 CONTINUE
4023  WRITE(6, 1080)
4024  WRITE(6,*)' 1=*=p, 2=n, 3=pi+, 4=pi-, 5=K+, 6=K-,',
4025  &' 8=ap, 9=chargd., 10=Z=all, 11=+=Lamb, 12=A=aLam,',
4026  &' 13=O=sig-, 14=B=Sig+, 15=C=Sig0, 16=D=pi0'
4027  CALL plot(xxfl,yxfl,1000,20,50,-1.d0,dxfl,-4.5d0,0.05d0)
4028  WRITE(6,1120)
4029  1120 FORMAT ('1 PT DISTRIBUTION DN/PTDPT')
4030  CALL plot(ptp,pty,1000,20,50,0.d0,dpt,-2.0d0,0.05d0)
4031  IF (ipriop.EQ.1) go to 250
4032  WRITE(6,1090)
4033  WRITE(6,*)' 1=*=p, 2=n, 3=pi+, 4=pi-, 5=K+, 6=K-,',
4034  &' 8=ap, 9=chargd., 10=Z=all, 11=+=Lamb, 12=A=aLam,',
4035  &' 13=O=sig-, 14=B=Sig+, 15=C=Sig0, 16=D=pi0'
4036  CALL plot(xmult,ymult,1000,10,100,0.d0,1.d0, -3.5d0,0.05d0)
4037  250 CONTINUE
4038  IF (kpl.NE.12) go to 270
4039  DO 260 i=1,12
4040  DO 260 j=1,30
4041  aaso(i,j)=log10(aaso(i,j)+1.d-18)
4042  avmult(i,j)=log10(avmult(i,j)+1.d-18)
4043  ake(i,j)=log10(ake(i,j)+1.d-18)
4044  260 CONTINUE
4045  WRITE(6,*)' 1=*=p, 2=n, 3=pi+, 4=pi-, 5=K+, 6=K-,',
4046  &' 8=ap, 9=chargd., 10=Z=all, 11=+=Lamb, 12=A=aLam,',
4047  &' 13=O=sig-, 14=B=Sig+, 15=C=Sig0, 16=D=pi0'
4048  CALL plot(aaso,avmult,360,30,12,0.d0,0.1d0,-3.d0,0.05d0)
4049  WRITE(6,*)' 1=*=p, 2=n, 3=pi+, 4=pi-, 5=K+, 6=K-,',
4050  &' 8=ap, 9=chargd., 10=Z=all, 11=+=Lamb, 12=A=aLam,',
4051  &' 13=O=sig-, 14=B=Sig+, 15=C=Sig0, 16=D=pi0'
4052  CALL plot(aaso,ake,360,30,12,0.d0,0.1d0,-5.d0,0.05d0)
4053  270 CONTINUE
4054  RETURN
4055  END
4056 *-- Author :
4057 C
4058 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4059 C
4060  SUBROUTINE ddecay(IHAD,ISTAB)
4061  IMPLICIT DOUBLE PRECISION (a-h,o-z)
4062  SAVE
4063 C------------------
4064 *KEEP,DFINPA.
4065  CHARACTER*8 anf
4066  parameter(nfimax=249)
4067  COMMON /dfinpa/ anf(nfimax),pxf(nfimax),pyf(nfimax),pzf(nfimax),
4068  +hef(nfimax),amf(nfimax), ichf(nfimax),ibarf(nfimax),nref(nfimax)
4069  COMMON /dfinpz/iormo(nfimax),idaug1(nfimax),idaug2(nfimax),
4070  * istath(nfimax)
4071 *KEND.
4072  CHARACTER*8 zkname
4073  CHARACTER*8 aname
4074 C COMMON/DDECAC/ ZKNAME(540),NZK(540,3),WT(540)
4075 
4076  parameter(idmax9=602)
4077 C CHARACTER*8 ZKNAME
4078  common/ddecac/ zkname(idmax9),wt(idmax9),nzk(idmax9,3)
4079 
4080 
4081  common/dpar/aname(210),am(210),ga(210),tau(210),ich(210),ibar(210)
4082  *,k1(210),k2(210)
4083  common/dmetls/ cxs(149),cys(149),czs(149),els(149),
4084  *pls(149),is,its(149)
4085  common/ddre/ test(12)
4086  common/pritt/isys
4087 C------------------
4088  isys=6
4089  DO 10 i=1,ihad
4090  its(i)=nref(i)
4091  pls(i)=sqrt(pxf(i)**2+pyf(i)**2+pzf(i)**2)
4092  IF(pls(i).NE.0.)cxs(i)=pxf(i)/pls(i)
4093  IF(pls(i).NE.0.)cys(i)=pyf(i)/pls(i)
4094  IF(pls(i).NE.0.)czs(i)=pzf(i)/pls(i)
4095  els(i)=hef(i)
4096  10 CONTINUE
4097  ist=ihad
4098  ir=0
4099  20 CONTINUE
4100 C*****TEST STABLE OR UNSTABLE
4101 C ISTAB=1/2/3 MEANS STRONG + WEAK DECAYS / ONLY STRONG DECAYS /
4102 C STRONG DECAYS + WEAK DECAYS FOR CHARMED PARTICLES AND TAU LEPTONS
4103  IF(istab.EQ.1) goto 30
4104  IF(istab.EQ.2) goto 50
4105  IF(istab.EQ.3) goto 40
4106  30 IF(its(ist).EQ.135.OR.its(ist).EQ.136) goto 60
4107  IF(its(ist).GE.1.AND.its(ist).LE.7) goto 60
4108  goto 70
4109  40 IF(its(ist).GE.1.AND.its(ist).LE.23) goto 60
4110  IF(its(ist).GE. 97.AND.its(ist).LE.103) goto 60
4111 C* IF(ITS(IST).EQ.109.AND.ITS(IST).EQ.115) GOTO 202
4112  IF(its(ist).EQ.109.OR.its(ist).EQ.115) goto 60
4113  IF(its(ist).GE.133.AND.its(ist).LE.136) goto 60
4114  goto 70
4115  50 IF(its(ist).GE. 1.AND.its(ist).LE. 30) goto 60
4116  IF(its(ist).GE. 97.AND.its(ist).LE.103) goto 60
4117  IF(its(ist).GE.115.AND.its(ist).LE.122) goto 60
4118  IF(its(ist).GE.131.AND.its(ist).LE.136) goto 60
4119  IF(its(ist).EQ.109) goto 60
4120  IF(its(ist).GE.137.AND.its(ist).LE.160) goto 60
4121  goto 70
4122  60 ir=ir+1
4123  IF (ir.GT.nfimax)THEN
4124  WRITE (6,1000)ir,nfimax
4125  1000 FORMAT(.GT.' DECAY IRNFIMAX RETURN ',2i10)
4126  RETURN
4127  ENDIF
4128  nref(ir)=its(ist)
4129  itt=its(ist)
4130  amf(ir)=am(itt)
4131  anf(ir)=aname(itt)
4132  ichf(ir)=ich(itt)
4133  ibarf(ir)=ibar(itt)
4134  hef(ir)=els(ist)
4135  pxf(ir)=cxs(ist)*pls(ist)
4136  pyf(ir)=cys(ist)*pls(ist)
4137  pzf(ir)=czs(ist)*pls(ist)
4138  ist=ist-1
4139  IF(ist.GE.1) goto 20
4140  goto140
4141  70 it=its(ist)
4142  gam=els(ist)/am(it)
4143  bgam=pls(ist)/am(it)
4144  eco=am(it)
4145  kz1=k1(it)
4146  80 CONTINUE
4147  vv=rndm(vw)-1.d-17
4148  iik=kz1-1
4149  90 iik=iik+1
4150  IF (vv.GT.wt(iik)) go to 90
4151 C IIK IS THE DECAY CHANNEL
4152  it1=nzk(iik,1)
4153  it2=nzk(iik,2)
4154  IF (it2-1.LT.0) go to 120
4155  it3=nzk(iik,3)
4156 C IT1,IT2, IT3 ARE THE PRODUCED PARTICLES FROM IT
4157  IF(it3.EQ.0) go to 100
4158  CALL dthrep(eco,ecm1,ecm2,ecm3,pcm1,pcm2,pcm3,cod1,cof1,sif1,
4159  *cod2,cof2,sif2,cod3,cof3,sif3,am(it1),am(it2),am(it3))
4160  go to 110
4161  100 CALL dtwopd(eco,ecm1,ecm2,pcm1,pcm2,cod1,cof1,sif1,cod2,cof2,sif2,
4162  +am(it1),am(it2))
4163  110 CONTINUE
4164  120 CONTINUE
4165  its(ist )=it1
4166  IF (it2-1.LT.0) go to 130
4167  its(ist+1) =it2
4168  its(ist+2)=it3
4169  rx=cxs(ist)
4170  ry=cys(ist)
4171  rz=czs(ist)
4172  CALL dtrafo(gam,bgam,rx,ry,rz,cod1,cof1,sif1,pcm1,ecm1,
4173  *pls(ist),cxs(ist),cys(ist),czs(ist),els(ist))
4174  ist=ist+1
4175  CALL dtrafo(gam,bgam,rx,ry,rz,cod2,cof2,sif2,pcm2,ecm2,
4176  *pls(ist),cxs(ist),cys(ist),czs(ist),els(ist))
4177  IF (it3.LE.0) go to 130
4178  ist=ist+1
4179  CALL dtrafo(gam,bgam,rx,ry,rz,cod3,cof3,sif3,pcm3,ecm3,
4180  *pls(ist),cxs(ist),cys(ist),czs(ist),els(ist))
4181  130 CONTINUE
4182  go to 20
4183  140 CONTINUE
4184  IF(ir.GT.7998) WRITE(isys,1010)
4185  1010 FORMAT(2x,' NUMBER OF STAB. FINAL PART. IS GREATER THAN 7998')
4186  ihad=ir
4187  RETURN
4188  END
4189 *-- Author :
4190 C--------------------------------------------------------------------
4191 C
4192 C FILE SHMAK
4193 C
4194 C--------------------------------------------------------------------
4195  SUBROUTINE shmak(ICASE,NN,NNA,NNB,NA,NB,UMO,BIMP)
4196  IMPLICIT DOUBLE PRECISION (a-h,o-z)
4197  SAVE
4198 * scoring of unbiased Glauber events sampled in KKEVT
4199 * (reduction of interactions possible in case event rejection because
4200 * of limitations from kinematics)
4201 *
4202 *KEEP,DPRIN.
4203  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
4204 *KEND.
4205  parameter(namx=248)
4206  dimension fnua(namx),fnub(namx),fnut(namx)
4207  dimension ann(namx)
4208  dimension xb(200),bimpp(200)
4209 C-------------------------------
4210 C---------------------------------------------------------------
4211 C
4212 C plot impact parameter distribution
4213 C
4214 C----------------------------------------------------------------
4215 C DO 7784 II=1,200
4216 C BIMPP(II)=0.D0
4217 CXB(II)=0.1D0*II
4218 C7784 CONTINUE
4219 C IP=207
4220 C IT=207
4221 C KKMAT=1
4222 C PPROJ=PPN
4223 C DO 7785 II=1,100000
4224 C CALL SHMAKO(IP,IT,BIMP,NN,NP,NT,JSSH,JTSH,PPROJ,KKMAT)
4225 C IF(II.LE.1000)WRITE(6,*)' IP,IT,BIMP,NN,NP,NT ',
4226 C * IP,IT,BIMP,NN,NP,NT
4227 C IB=BIMP/0.1D0+1.D0
4228 C IF(IB.GE.200)IB=200
4229 C BIMPP(IB)=BIMPP(IB)+1
4230 C7785 CONTINUE
4231 C WRITE(6,*)' Impact parameter distribution B,BIMPP'
4232 C DO 7786 II=1,200
4233 C WRITE(6,*)XB(II),BIMPP(II)
4234 C7786 CONTINUE
4235 C---------------------------------------------------------------
4236 C
4237 C plot impact parameter distribution
4238 C
4239 C---------------------------------------------------------------
4240  go to(10,30,40),icase
4241  10 CONTINUE
4242  DO 7784 ii=1,200
4243  bimpp(ii)=0.d0
4244  xb(ii)=0.1d0*ii
4245  7784 CONTINUE
4246  bnut=0.
4247  bnua=0.
4248  bnub=0.
4249  bnvv=0.
4250  bnsv=0.
4251  bnvs=0.
4252  bnss=0.
4253  DO 20 i=1,namx
4254  ann(i)=i
4255  fnu a(i)=0.
4256  fnu b(i)=0.
4257  fnu t(i)=0.
4258  20 CONTINUE
4259  anusd=0.d0
4260  RETURN
4261  30 CONTINUE
4262  ib=bimp/0.1d0+1.d0
4263  IF(ib.GE.200)ib=200
4264  bimpp(ib)=bimpp(ib)+1
4265 C Calculate fraction of diffractive events
4266  IF((nn.EQ.1).AND.(nna.EQ.1).AND.(nnb.EQ.1))THEN
4267  CALL sihndi(umo,1,1,singdif,sigdih)
4268  sigabs=siinel(1,1,umo)
4269  anusd=anusd + singdif/sigabs
4270  ENDIF
4271  intt=nn
4272  IF (intt.GT.namx)intt=namx
4273  nua=nna
4274  IF (nua.GT.namx) nua=namx
4275  nub=nnb
4276  IF (nub.GT.namx) nub=namx
4277  fnua(nua)=fnua(nua)+1.
4278  fnut(intt)=fnut(intt)+1.
4279  fnub(nub)=fnub(nub)+1.
4280  bnut=bnut+nn
4281  bnua=bnua+nna
4282  bnub=bnub+nnb
4283  IF(nnb.GE.nna) THEN
4284  nnvv=nna
4285  nnsv=nnb-nna
4286  nnvs=0
4287  nnss=nn-nnb
4288  ELSE
4289  nnvv=nnb
4290  nnsv=0
4291  nnvs=nna-nnb
4292  nnss=nn-nna
4293  ENDIF
4294  bnvv=bnvv + nnvv
4295  bnsv=bnsv + nnsv
4296  bnvs=bnvs + nnvs
4297  bnss=bnss + nnss
4298  RETURN
4299  40 CONTINUE
4300  IF(nn.EQ.0)THEN
4301  WRITE(6,*)' shmak(3,NN,... ) NN= ',nn
4302  RETURN
4303  ENDIF
4304 C WRITE(6,*)' Impact parameter distribution B,BIMPP'
4305 C WRITE(6,*)(XB(II),BIMPP(II),II=1,200)
4306 C WRITE(6,*)' Impact parameter distribution B,BIMPP'
4307 C CALL PLOT(XB,BIMPP,50,1,50,0.,0.4D0,0.,10.D0)
4308  anusd=anusd/nn
4309  bnut=bnut/nn
4310  bnua=bnua/nn
4311  bnub=bnub/nn
4312  bnvv=bnvv/nn
4313  bnsv=bnsv/nn
4314  bnvs=bnvs/nn
4315  bnss=bnss/nn
4316  WRITE(6,'(1H1,50(1H*))')
4317  WRITE(6,'(/10X,A/)') ' OUTPUT FROM SHMAK all events before',
4318  *' diffraction modification'
4319  WRITE(6,'(50(1H*))')
4320  WRITE(6,'(A,I10)') ' NUMBER OF TOTALLY SAMPLED GLAUBER EVENTS',nn
4321  WRITE(6, 1000) bnut,bnua,bnub
4322  WRITE(6,*)' Fraction of diffractive evnts: ',anusd
4323  1000 FORMAT(' AVERAGE NO OF COLLISIONS BNUT,BNUA,BNUB=',3f10.3)
4324  WRITE(6,'(/A)') ' AVERAGE NUMBERS OF DIFFERENT COLLISION TYPES'
4325  WRITE(6,'(4(5X,A,F8.2/))') ' VAL-VAL:',bnvv, ' SEA-VAL:',bnsv,
4326  +' VAL-SEA:',bnvs, ' SEA-SEA:',bnss
4327  IF(ipri.GE.1) THEN
4328  dnna=na/50+1
4329  dnnb=nb/50+1
4330  dnnt=2.*dnnb
4331  WRITE(6,1010)
4332  1010 FORMAT (' FNUA')
4333  WRITE(6,1040) fnua
4334  DO 323 i=1,namx
4335  fnu a(i)=log10(fnu a(i)+1.d-5)
4336  323 CONTINUE
4337  CALL plot(ann,fnu a,namx,1,namx,0.d0,dnna,0.d0,0.05d0)
4338  WRITE(6,1020 )
4339  WRITE(6,1040) fnub
4340  1020 FORMAT (' FNUB')
4341  DO 324 i=1,namx
4342  fnu b(i)=log10(fnu b(i)+1.d-5)
4343  324 CONTINUE
4344  CALL plot(ann,fnu b,namx,1,namx,0.d0,dnnb,0.d0,0.05d0)
4345  WRITE(6,1030 )
4346  WRITE(6,1040) fnut
4347  1030 FORMAT (' FNUT')
4348  DO 325 i=1,namx
4349  fnu t(i)=log10(fnu t(i)+1.e-5)
4350  325 CONTINUE
4351  CALL plot(ann,fnu t,namx,1,namx,0.d0,dnnt,0.d0,0.05d0)
4352  1040 FORMAT (10f12.2)
4353  ENDIF
4354  RETURN
4355  END
4356 C--------------------------------------------------------------------
4357 C
4358 C FILE SHMAK1
4359 C
4360 C--------------------------------------------------------------------
4361  SUBROUTINE shmak1(ICASE,NN,NNA,NNB,NA,NB,UMO,BIMP)
4362  IMPLICIT DOUBLE PRECISION (a-h,o-z)
4363  SAVE
4364 * scoring of unbiased Glauber events sampled in KKEVT
4365 * (reduction of interactions possible in case event rejection because
4366 * of limitations from kinematics)
4367 *
4368 *KEEP,DPRIN.
4369  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
4370 *KEND.
4371  parameter(namx=248)
4372  dimension fnua(namx),fnub(namx),fnut(namx)
4373  dimension ann(namx)
4374  dimension xb(200),bimpp(200)
4375 C-------------------------------
4376  go to(10,30,40),icase
4377  10 CONTINUE
4378  DO 7784 ii=1,200
4379  bimpp(ii)=0.d0
4380  xb(ii)=0.1d0*ii
4381  7784 CONTINUE
4382  bnut=0.
4383  bnua=0.
4384  bnub=0.
4385  anusd=0.d0
4386  DO 20 i=1,namx
4387  ann(i)=i
4388  fnu a(i)=0.
4389  fnu b(i)=0.
4390  fnu t(i)=0.
4391  20 CONTINUE
4392  RETURN
4393  30 CONTINUE
4394  ib=bimp/0.1d0+1.d0
4395  IF(ib.GE.200)ib=200
4396  bimpp(ib)=bimpp(ib)+1
4397 C Calculate fraction of diffractive events
4398  IF((nn.EQ.1).AND.(nna.EQ.1).AND.(nnb.EQ.1))THEN
4399  CALL sihndi(umo,1,1,singdif,sigdih)
4400  sigabs=siinel(1,1,umo)
4401  anusd=anusd + singdif/sigabs
4402  ENDIF
4403  intt=nn
4404  IF (intt.GT.namx)intt=namx
4405  nua=nna
4406  IF (nua.GT.namx) nua=namx
4407  nub=nnb
4408  IF (nub.GT.namx) nub=namx
4409  fnua(nua)=fnua(nua)+1.
4410  fnut(intt)=fnut(intt)+1.
4411  fnub(nub)=fnub(nub)+1.
4412  bnut=bnut+nn
4413  bnua=bnua+nna
4414  bnub=bnub+nnb
4415  RETURN
4416  40 CONTINUE
4417  IF(nn.EQ.0)THEN
4418  WRITE(6,*)' shmak1(3,NN,... ) NN= ',nn
4419  RETURN
4420  ENDIF
4421 C WRITE(6,*)' Impact parameter distribution B,BIMPP'
4422 C WRITE(6,*)(XB(II),BIMPP(II),II=1,200)
4423 C WRITE(6,*)' Impact parameter distribution B,BIMPP'
4424 C CALL PLOT(XB,BIMPP,50,1,50,0.D0,0.4D0,0.D0,10.D0)
4425  bnut=bnut/nn
4426  bnua=bnua/nn
4427  bnub=bnub/nn
4428  anusd=anusd/nn
4429  WRITE(6,'(1H1,50(1H*))')
4430  WRITE(6,'(/10X,A/)') ' OUTPUT FROM SHMAK1 after modification',
4431  *' of Glauber events for diffractive cross section'
4432  WRITE(6,'(50(1H*))')
4433  WRITE(6,'(A,I10)') ' NUMBER OF TOTALLY SAMPLED GLAUBER EVENTS',nn
4434  WRITE(6, 1000) bnut,bnua,bnub
4435  1000 FORMAT(' AVERAGE NO OF COLLISIONS BNUT,BNUA,BNUB=',3f10.3)
4436  WRITE(6,*)' Fraction of diffractive evnts: ',anusd
4437 C WRITE(6,'(/A)') ' AVERAGE NUMBERS OF DIFFERENT COLLISION TYPES'
4438 C WRITE(6,'(4(5X,A,F8.2/))') ' VAL-VAL:',BNVV, ' SEA-VAL:',BNSV,
4439 C +' VAL-SEA:',BNVS, ' SEA-SEA:',BNSS
4440  IF(ipri.GE.1) THEN
4441  dnna=na/50+1
4442  dnnb=nb/50+1
4443  dnnt=2.*dnnb
4444  WRITE(6,1010)
4445  1010 FORMAT (' FNUA')
4446  WRITE(6,1040) fnua
4447  DO 323 i=1,namx
4448  fnu a(i)=log10(fnu a(i)+1.d-5)
4449 323 CONTINUE
4450  CALL plot(ann,fnu a,namx,1,namx,0.d0,dnna,0.d0,0.05d0)
4451  WRITE(6,1020 )
4452  WRITE(6,1040) fnub
4453  1020 FORMAT (' FNUB')
4454  DO 324 i=1,namx
4455  fnu b(i)=log10(fnu b(i)+1.d-5)
4456 324 CONTINUE
4457  CALL plot(ann,fnu b,namx,1,namx,0.d0,dnnb,0.d0,0.05d0)
4458  WRITE(6,1030 )
4459  WRITE(6,1040) fnut
4460 1030 FORMAT (' FNUT')
4461  DO 325 i=1,namx
4462  fnu t(i)=log10(fnu t(i)+1.e-5)
4463 325 CONTINUE
4464  CALL plot(ann,fnu t,namx,1,namx,0.d0,dnnt,0.d0,0.05d0)
4465 1040 FORMAT (10f12.2)
4466  ENDIF
4467  RETURN
4468  END
4469 *-- Author :
4470 C
4471 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4472 C
4473  SUBROUTINE previo(RA,RB,NSTB,BMAX,BSTEP,SIG,RO,G)
4474  IMPLICIT DOUBLE PRECISION (a-h,o-z)
4475  SAVE
4476  COMPLEX*16 ca,ci
4477  common/damp/ca,ci,ga
4478 C WRITE(6,*)' PREVIO(RA,RB,NSTB,BMAX,BSTEP,SIG,RO,G)',
4479 C &RA,RB,NSTB,BMAX,BSTEP,SIG,RO,G
4480 C WRITE(6,*)' /CA,CI,GA/ ',CA,CI,GA
4481 C WRITE(6,*)' PREVIO: RA, RB = ',RA,RB
4482  bmax=4.*(ra+rb)
4483 C WRITE(6,*)' PREVIO(RA,RB,NSTB,BMAX,BSTEP,SIG,RO,G)',
4484 C &RA,RB,NSTB,BMAX,BSTEP,SIG,RO,G
4485 C WRITE(6,*)' /CA,CI,GA/ ',CA,CI,GA
4486 C WRITE(6,*)' PREVIO: RA, RB BMAX= ',RA,RB,BMAX
4487  bstep=bmax/(nstb-1)
4488 C WRITE(6,*)' PREVIO(RA,RB,NSTB,BMAX,BSTEP,SIG,RO,G)',
4489 C &RA,RB,NSTB,BMAX,BSTEP,SIG,RO,G
4490 C WRITE(6,*)' /CA,CI,GA/ ',CA,CI,GA
4491 C WRITE(6,*)' PREVIO: RA, RB ,BSTEP= ',RA,RB,BSTEP
4492  bstep=0.15d0
4493 C WRITE(6,*)' PREVIO(RA,RB,NSTB,BMAX,BSTEP,SIG,RO,G)',
4494 C &RA,RB,NSTB,BMAX,BSTEP,SIG,RO,G
4495 C WRITE(6,*)' /CA,CI,GA/ ',CA,CI,GA
4496 C WRITE(6,*)' PREVIO: RA, RB ,BSTEP= ',RA,RB,BSTEP
4497  ga=g
4498 C WRITE(6,*)' PREVIO(RA,RB,NSTB,BMAX,BSTEP,SIG,RO,G)',
4499 C &RA,RB,NSTB,BMAX,BSTEP,SIG,RO,G
4500 C WRITE(6,*)' /CA,CI,GA/ ',CA,CI,GA
4501 C WRITE(6,*)' PREVIO: RA, RB ,GA= ',RA,RB,GA
4502  rca=ga*sig/6.2831854
4503 C WRITE(6,*)' PREVIO(RA,RB,NSTB,BMAX,BSTEP,SIG,RO,G)',
4504 C &RA,RB,NSTB,BMAX,BSTEP,SIG,RO,G
4505 C WRITE(6,*)' /CA,CI,GA/ ',CA,CI,GA
4506 C WRITE(6,*)' PREVIO: RA, RB ,RCA= ',RA,RB,RCA
4507  fca=-ga*sig*ro/6.2831854
4508 C WRITE(6,*)' PREVIO(RA,RB,NSTB,BMAX,BSTEP,SIG,RO,G)',
4509 C &RA,RB,NSTB,BMAX,BSTEP,SIG,RO,G
4510 C WRITE(6,*)' /CA,CI,GA/ ',CA,CI,GA
4511 C WRITE(6,*)' PREVIO: RA, RB ,FCA= ',RA,RB,FCA
4512  ca=cmplx(rca,fca)
4513 C WRITE(6,*)' PREVIO(RA,RB,NSTB,BMAX,BSTEP,SIG,RO,G)',
4514 C &RA,RB,NSTB,BMAX,BSTEP,SIG,RO,G
4515 C WRITE(6,*)' /CA,CI,GA/ ',CA,CI,GA
4516 C WRITE(6,*)' PREVIO: RA, RB,CA = ',RA,RB,CA
4517  ci=(1.d0,0.d0)
4518  WRITE(6,*)' PREVIO(RA,RB,NSTB,BMAX,BSTEP,SIG,RO,G)',
4519  &ra,rb,nstb,bmax,bstep,sig,ro,g
4520  WRITE(6,*)' /CA,CI,GA/ ',ca,ci,ga
4521  WRITE(6,*)' PREVIO: RA, RB ,CI= ',ra,rb,ci
4522  RETURN
4523  END
4524 *-- Author :
4525 C
4526 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4527 C
4528  SUBROUTINE profb(BSTEP,NSTAT,NA,RA,NB,RB,BSITE,NSITEB)
4529  IMPLICIT DOUBLE PRECISION (a-h,o-z)
4530  SAVE
4531 C
4532 C THE PROGRAM CALCULATES THE PROFIL-FUNCTION AND FILLS
4533 C THE ARRAY BSITE TO APPROXIMATE THE B-DISTRIBUTION.
4534 C-------------------
4535  parameter(intmx=2488,intmd=252)
4536 *KEEP,DROPPT.
4537  LOGICAL intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada, ipadis,
4538  +ishmal,lpauli
4539  COMMON /droppt/ intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada,
4540  +ipadis,ishmal,lpauli
4541 *KEEP,NUCKOO.
4542  COMMON /nuckoo/ pkoo(3,intmx),tkoo(3,intmx),ppoo(3,intmx),
4543  +tpoo(3,intmx)
4544 *KEEP,DAMP.
4545 C COMPLEX*16 CA,CI
4546  DOUBLE COMPLEX ca,ci
4547  COMMON /damp/ ca,ci,ga
4548 *KEND.
4549  dimension bsite(0:1,nsiteb)
4550 C--------
4551  dimension helpp(200)
4552  dimension help(200)
4553  dimension bs(200)
4554  COMMON /sigla/siglau
4555 C COMPLEX*16 C
4556  DOUBLE COMPLEX c
4557  DATA irw /0/
4558 C--------
4559  WRITE(6,*)' PROFB: RA, RB = ',ra,rb
4560  WRITE(6, 1000)bstep,nstat,na,ra,nb,rb,irw,nsiteb
4561  1000 FORMAT (' PROFB',e15.5,2i10,f15.5,i10,e15.5,2i10)
4562  ns=nstat
4563  nsite=nsiteb-1
4564  bst=bstep
4565  DO 10 i=1,nsiteb
4566  bs(i)=0.
4567  10 CONTINUE
4568  DO 40 i=1,ns
4569  CALL conucl(tkoo,nb,rb)
4570 C CALL SORTIN(TKOO,NB)
4571  CALL conucl(pkoo,na,ra)
4572 C CALL SORT(PKOO,NA)
4573  DO 40 i3=1,nsite
4574  b=i3*bst
4575  pi=1.
4576  DO 30 i1=1,na
4577  x1=b-pkoo(1,i1)
4578  IF(pi.LT.1.d-100)go to 31
4579  x2=-pkoo(2,i1)
4580  DO 32 i2=1,nb
4581  q1=x1+tkoo(1,i2)
4582  q2=x2+tkoo(2,i2)
4583  xy=ga*(q1*q1+q2*q2)
4584 C
4585  IF(xy.GT.15.) go to 20
4586  e=exp(-xy)
4587  c=ci-ca*e
4588  ar=REAL(REAL(c))
4589  ai=imag(c)
4590  p=ar*ar+ai*ai
4591 C WRITE(6,'(A,5E13.3,3I6)')' PROFB:Pi,P,AR,AI,Ei,I3,I2,I1',
4592 C *PI,P,AR,AI,Ei,I3,I2,I1
4593  pi=pi*p
4594  20 CONTINUE
4595  32 CONTINUE
4596  31 CONTINUE
4597  30 CONTINUE
4598  bs(i3+1)=bs(i3+1)+1.-pi
4599  40 CONTINUE
4600  bs(1)=bs(2)
4601  sumb=0.
4602  DO 50 i=1,nsiteb
4603  helpp(i)=bs(i)/ns
4604  bs(i)=bs(i)*(i-1)*bst/ns
4605  sumb=sumb+bs(i)
4606  50 CONTINUE
4607  bsite(1,1)=0.
4608  DO 60 i=2,nsiteb
4609  bsite(1,i)=bs(i)/sumb+bsite(1,i-1)
4610  60 CONTINUE
4611  DO 70 i=1,nsiteb
4612  help(i)=i*bst
4613  70 CONTINUE
4614  sumb=sumb*bst*6.2831854
4615  siglau=sumb*10.
4616  WRITE(6,1020) sumb
4617  1020 FORMAT(/5x,7hsigma =,f7.3)
4618  IF(irw.GE.1) RETURN
4619  IF(ishmal) THEN
4620  DO 80 i=1,200
4621  WRITE (6,1030) help(i),helpp(i),bs(i),bsite(1,i)
4622  1030 FORMAT (f10.4,3e15.5)
4623  80 CONTINUE
4624  CALL plot(help,bsite,50,1,50,0.d0,0.5d0,0.d0,0.01d0)
4625  CALL plot(help,bs ,50,1,50,0.d0,0.5d0,0.d0,0.07d0)
4626  ENDIF
4627  RETURN
4628  END
4629 *-- Author :
4630 C
4631 C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4632 C
4633  SUBROUTINE dparje(IHAD,I)
4634  IMPLICIT DOUBLE PRECISION (a-h,o-z)
4635  SAVE
4636 *KEEP,DFINPA.
4637  CHARACTER*8 anf
4638  parameter(nfimax=249)
4639  COMMON /dfinpa/ anf(nfimax),pxf(nfimax),pyf(nfimax),pzf(nfimax),
4640  +hef(nfimax),amf(nfimax), ichf(nfimax),ibarf(nfimax),nref(nfimax)
4641  COMMON /dfinpz/iormo(nfimax),idaug1(nfimax),idaug2(nfimax),
4642  * istath(nfimax)
4643 *KEEP,DINPDA.
4644  COMMON /dinpda/ imps(6,6),imve(6,6),ib08(6,21),ib10(6,21), ia08
4645  +(6,21),ia10(6,21), a1,b1,b2,b3,lt,le,bet,as,b8,ame,diq,isu
4646 *KEEP,DPRIN.
4647  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
4648 *KEND.
4649  CHARACTER*8 aname
4650  COMMON /dpar/ aname(210),am(210),ga(210),tau(210), ich(210),ibar
4651  +(210),k1(210),k2(210)
4652  ihad=1
4653  nref(1)=i
4654  pxf(1)=0.
4655  pyf(1)=0.
4656  pzf(1)=0.
4657  hef(1)=am(i)
4658  amf(1)=am(i)
4659  ichf(1)=ich(i)
4660  ibarf(1)=ibar(i)
4661  anf(1)=aname(i)
4662  IF (ipco.GE.6)THEN
4663  WRITE(6,1000)ihad,i,pxf(1),pyf(1),pzf(1),hef(1),amf(1)
4664  1000 FORMAT(' PARJET: IHAD,I,PXF(1),PYF(1),PZF(1),HEP(1),AMF(1)'/ 2i5,5
4665  +f10.3)
4666  ENDIF
4667  RETURN
4668  END
4669 *-- Author :
4670 C
4671 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4672 C
4673  SUBROUTINE sort(A,N)
4674  IMPLICIT DOUBLE PRECISION (a-h,o-z)
4675  SAVE
4676  dimension a(3,n)
4677  m=n
4678  10 CONTINUE
4679  m=n-1
4680  IF(m.LE.0) RETURN
4681  l=0
4682  DO 20 i=1,m
4683  j=i+1
4684  IF (a(3,i).LE.a(3,j)) go to 20
4685  b=a(3,i)
4686  c=a(1,i)
4687  d=a(2,i)
4688  a(3,i)=a(3,j)
4689  a(2,i)=a(2,j)
4690  a(1,i)=a(1,j)
4691  a(3,j)=b
4692  a(1,j)=c
4693  a(2,j)=d
4694  l=1
4695  20 CONTINUE
4696  IF(l.EQ.1) go to 10
4697  RETURN
4698  END
4699 *-- Author :
4700 C
4701 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4702 C
4703  SUBROUTINE sortin(A,N)
4704  IMPLICIT DOUBLE PRECISION (a-h,o-z)
4705  SAVE
4706  dimension a(3,n)
4707  m=n
4708  10 CONTINUE
4709  m=n-1
4710  IF(m.LE.0) RETURN
4711  l=0
4712  DO 20 i=1,m
4713  j=i+1
4714  IF (a(3,i).GE.a(3,j)) go to 20
4715  b=a(3,i)
4716  c=a(1,i)
4717  d=a(2,i)
4718  a(3,i)=a(3,j)
4719  a(2,i)=a(2,j)
4720  a(1,i)=a(1,j)
4721  a(3,j)=b
4722  a(1,j)=c
4723  a(2,j)=d
4724  l=1
4725  20 CONTINUE
4726  IF(l.EQ.1) go to 10
4727  RETURN
4728  END
4729 *
4730 *=== blkdt6 ===========================================================*
4731 *== *
4732  BLOCK DATA blkd46
4733  IMPLICIT DOUBLE PRECISION (a-h,o-z)
4734  SAVE
4735 *$ CREATE DBLPRC.ADD
4736 *COPY DBLPRC
4737 * *
4738 *=== dblprc ==========================================================*
4739 * *
4740 *---------------------------------------------------------------------*
4741 * *
4742 * Dblprc: included in any routine *
4743 * *
4744 * !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
4745 * !!!! O N M A C H I N E S W H E R E T H E D O U B L E !!!! *
4746 * !!!! P R E C I S I O N I S N O T R E Q U I R E D R E -!!!! *
4747 * !!!! M O V E T H E D O U B L E P R E C I S I O N !!!! *
4748 * !!!! S T A T E M E N T, S E T K A L G N M = 1 A N D !!!! *
4749 * !!!! C H A N G E A L L N U M E R I C A L C O N S - !!!! *
4750 * !!!! T A N T S T O S I N G L E P R E C I S I O N !!!! *
4751 * !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
4752 * *
4753 * Kalgnm = real address alignment, 2 for double precision, *
4754 * 1 for single precision *
4755 * Anglgb = this parameter should be set equal to the machine *
4756 * "zero" with respect to unit *
4757 * Anglsq = this parameter should be set equal to the square *
4758 * of Anglgb *
4759 * Axcssv = this parameter should be set equal to the number *
4760 * for which unity is negligible for the machine *
4761 * accuracy *
4762 * Andrfl = "underflow" of the machine for floating point *
4763 * operation *
4764 * Avrflw = "overflow" of the machine for floating point *
4765 * operation *
4766 * Ainfnt = code "infinite" *
4767 * Azrzrz = code "zero" *
4768 * Einfnt = natural logarithm of the code "infinite" *
4769 * Ezrzrz = natural logarithm of the code "zero" *
4770 * Onemns = 1- of the machine, it is 1 - 2 x Anglgb *
4771 * Onepls = 1+ of the machine, it is 1 + 2 x Anglgb *
4772 * Csnnrm = maximum tolerable error on cosine normalization, *
4773 * u**2+v**2+w**2: assuming a typical anglgb relative *
4774 * error on each component we would get 2xanglgb: use *
4775 * 4xanglgb to avoid too many normalizations *
4776 * Dmxtrn = "infinite" distance for transport (cm) *
4777 * *
4778 *---------------------------------------------------------------------*
4779 * *
4780  parameter( kalgnm = 2 )
4781  parameter( anglgb = 5.0d-16 )
4782  parameter( anglsq = 2.5d-31 )
4783  parameter( axcssv = 0.2d+16 )
4784  parameter( andrfl = 1.0d-38 )
4785  parameter( avrflw = 1.0d+38 )
4786  parameter( ainfnt = 1.0d+30 )
4787  parameter( azrzrz = 1.0d-30 )
4788  parameter( einfnt = +69.07755278982137 d+00 )
4789  parameter( ezrzrz = -69.07755278982137 d+00 )
4790  parameter( onemns = 0.999999999999999 d+00 )
4791  parameter( onepls = 1.000000000000001 d+00 )
4792  parameter( csnnrm = 2.0d-15 )
4793  parameter( dmxtrn = 1.0d+08 )
4794 *
4795 *======================================================================*
4796 *======================================================================*
4797 *========= ==========*
4798 *========= M A T H E M A T I C A L C O N S T A N T S ==========*
4799 *========= ==========*
4800 *======================================================================*
4801 *======================================================================*
4802 * *
4803 * Numerical constants: *
4804 * *
4805 * Zerzer = 0 *
4806 * Oneone = 1 *
4807 * Twotwo = 2 *
4808 * Thrthr = 3 *
4809 * Foufou = 4 *
4810 * Fivfiv = 5 *
4811 * Sixsix = 6 *
4812 * Sevsev = 7 *
4813 * Eigeig = 8 *
4814 * Aninen = 9 *
4815 * Tenten = 10 *
4816 * Hlfhlf = 1/2 *
4817 * Onethi = 1/3 *
4818 * Twothi = 2/3 *
4819 * Pipipi = Circumference / diameter *
4820 * Eneper = "e", base of natural logarithm *
4821 * Sqrent = square root of "e" *
4822 * *
4823 *----------------------------------------------------------------------*
4824 *
4825  parameter( zerzer = 0.d+00 )
4826  parameter( oneone = 1.d+00 )
4827  parameter( twotwo = 2.d+00 )
4828  parameter( thrthr = 3.d+00 )
4829  parameter( foufou = 4.d+00 )
4830  parameter( fivfiv = 5.d+00 )
4831  parameter( sixsix = 6.d+00 )
4832  parameter( sevsev = 7.d+00 )
4833  parameter( eigeig = 8.d+00 )
4834  parameter( aninen = 9.d+00 )
4835  parameter( tenten = 10.d+00 )
4836  parameter( hlfhlf = 0.5d+00 )
4837  parameter( onethi = oneone / thrthr )
4838  parameter( twothi = twotwo / thrthr )
4839  parameter( pipipi = 3.1415926535897932270 d+00 )
4840  parameter( eneper = 2.7182818284590452354 d+00 )
4841  parameter( sqrent = 1.6487212707001281468 d+00 )
4842 *
4843 *======================================================================*
4844 *======================================================================*
4845 *========= ==========*
4846 *========= P H Y S I C A L C O N S T A N T S ==========*
4847 *========= ==========*
4848 *======================================================================*
4849 *======================================================================*
4850 * *
4851 * Primary constants: *
4852 * *
4853 * Clight = speed of light in cm s-1 *
4854 * Avogad = Avogadro number *
4855 * Amelgr = electron mass (g) *
4856 * Plckbr = reduced Planck constant (erg s) *
4857 * Elccgs = elementary charge (CGS unit) *
4858 * Elcmks = elementary charge (MKS unit) *
4859 * Amugrm = Atomic mass unit (g) *
4860 * Ammumu = Muon mass (amu) *
4861 * *
4862 * Derived constants: *
4863 * *
4864 * Alpfsc = Fine structure constant = e^2/(hbar c) *
4865 * Amelct = Electron mass (GeV) = 10^-16Amelgr Clight^2 / Elcmks*
4866 * Amugev = Atomic mass unit (GeV) = 10^-16Amelgr Clight^2 *
4867 * / Elcmks *
4868 * Ammuon = Muon mass (GeV) = Ammumu * Amugev *
4869 * Fscto2 = (Fine structure constant)^2 *
4870 * Fscto3 = (Fine structure constant)^3 *
4871 * Fscto4 = (Fine structure constant)^4 *
4872 * Plabrc = Reduced Planck constant times the light velocity *
4873 * expressed in GeV fm *
4874 * Rclsel = Classical electron radius (cm) = e^2 / (m_e c^2) *
4875 * Conversion constants: *
4876 * GeVMeV = from GeV to MeV *
4877 * eMVGeV = from MeV to GeV *
4878 * Raddeg = from radians to degrees *
4879 * Degrad = from degrees to radians *
4880 * *
4881 *----------------------------------------------------------------------*
4882 *
4883  parameter( clight = 2.99792458 d+10 )
4884  parameter( avogad = 6.0221367 d+23 )
4885  parameter( amelgr = 9.1093897 d-28 )
4886  parameter( plckbr = 1.05457266 d-27 )
4887  parameter( elccgs = 4.8032068 d-10 )
4888  parameter( elcmks = 1.60217733 d-19 )
4889  parameter( amugrm = 1.6605402 d-24 )
4890  parameter( ammumu = 0.113428913 d+00 )
4891 * PARAMETER ( ALPFSC = 1.D+00 / 137.035989561D+00 )
4892 * PARAMETER ( FSCTO2 = ALPFSC * ALPFSC )
4893 * PARAMETER ( FSCTO3 = FSCTO2 * ALPFSC )
4894 * PARAMETER ( FSCTO4 = FSCTO3 * ALPFSC )
4895 * It is important to set the electron mass exactly with the same
4896 * rounding as in the mass tables, so use the explicit expression
4897 * PARAMETER ( AMELCT = 1.D-16 * AMELGR * CLIGHT * CLIGHT / ELCMKS )
4898 * It is important to set the amu mass exactly with the same
4899 * rounding as in the mass tables, so use the explicit expression
4900 * PARAMETER ( AMUGEV = 1.D-16 * AMUGRM * CLIGHT * CLIGHT / ELCMKS )
4901 * It is important to set the muon mass exactly with the same
4902 * rounding as in the mass tables, so use the explicit expression
4903 * PARAMETER ( AMMUON = AMMUMU * AMUGEV ELCMKS )
4904 * PARAMETER ( RCLSEL = ELCCGS * ELCCGS / CLIGHT / CLIGHT / AMELGR )
4905  parameter( alpfsc = 7.2973530791728595 d-03 )
4906  parameter( fscto2 = 5.3251361962113614 d-05 )
4907  parameter( fscto3 = 3.8859399018437826 d-07 )
4908  parameter( fscto4 = 2.8357075508200407 d-09 )
4909  parameter( plabrc = 0.197327053 d+00 )
4910  parameter( amelct = 0.51099906 d-03 )
4911  parameter( amugev = 0.93149432 d+00 )
4912  parameter( ammuon = 0.105658389 d+00 )
4913  parameter( rclsel = 2.8179409183694872 d-13 )
4914  parameter( gevmev = 1.0 d+03 )
4915  parameter( emvgev = 1.0 d-03 )
4916  parameter( raddeg = 180.d+00 / pipipi )
4917  parameter( degrad = pipipi / 180.d+00 )
4918 
4919 *$ CREATE IOUNIT.ADD
4920 *COPY IOUNIT
4921 * *
4922 *=== iounit ==========================================================*
4923 * *
4924 *---------------------------------------------------------------------*
4925 * *
4926 * Iounit: included in any routine *
4927 * *
4928 * lunin = standard input unit *
4929 * lunout = standard output unit *
4930 * lunerr = standard error unit *
4931 * lunber = input file for bertini nuclear data *
4932 * lunech = echo file for pegs dat *
4933 * lunflu = input file for photoelectric edges and X-ray fluo- *
4934 * rescence data *
4935 * lungeo = scratch file for combinatorial geometry *
4936 * lunpgs = input file for pegs material data *
4937 * lunran = output file for the final random number seed *
4938 * lunxsc = input file for low energy neutron cross sections *
4939 * lunrdb = unit number for reading (extra) auxiliary external *
4940 * files to be closed just after reading *
4941 * *
4942 *---------------------------------------------------------------------*
4943 * *
4944  parameter( lunin = 5 )
4945  parameter( lunout = 6 )
4946  parameter( lunerr = 66 )
4947  parameter( lunber = 14 )
4948  parameter( lunech = 8 )
4949  parameter( lunflu = 86 )
4950  parameter( lungeo = 16 )
4951  parameter( lunpgs = 12 )
4952  parameter( lunran = 2 )
4953  parameter( lunxsc = 81 )
4954  parameter( lunrdb = 1 )
4955 
4956 *$ CREATE DIMPAR.ADD
4957 *COPY DIMPAR
4958 * *
4959 *=== dimpar ==========================================================*
4960 * *
4961 *---------------------------------------------------------------------*
4962 * *
4963 * DIMPAR: included in any routine *
4964 * *
4965 * Mxxrgn = maximum number of regions *
4966 * Mxxmdf = maximum number of media in Fluka *
4967 * Mxxmde = maximum number of media in Emf *
4968 * Mfstck = stack dimension in Fluka *
4969 * Mestck = stack dimension in Emf *
4970 * Nallwp = number of allowed particles *
4971 * Mpdpdx = number of particle types for which EM dE/dx pro- *
4972 * cesses (ion,pair,bremss) have to be computed *
4973 * Icomax = maximum number of materials for compounds (equal *
4974 * to the sum of the number of materials for every *
4975 * compound ) *
4976 * Nstbis = number of stable isotopes recorded in common iso- *
4977 * top *
4978 * Idmaxp = number of particles/resonances defined in common *
4979 * part *
4980 * *
4981 *---------------------------------------------------------------------*
4982 * *
4983  parameter( mxxrgn = 500 )
4984  parameter( mxxmdf = 56 )
4985  parameter( mxxmde = 50 )
4986  parameter( mfstck = 1000 )
4987  parameter( mestck = 100 )
4988  parameter( nallwp = 39 )
4989  parameter( mpdpdx = 8 )
4990  parameter( icomax = 180 )
4991  parameter( nstbis = 304 )
4992  parameter( idmaxp = 210 )
4993 
4994 
4995  CHARACTER*8 aname
4996  COMMON /dpar/ aname(210),am(210),ga(210),tau(210),
4997  + ich(210),ibar(210),k1(210),k2(210)
4998 * / Part /
4999 * datas datas datas datas datas *
5000 * --------------------------------------------- *
5001 *
5002 *
5003 * Particle masses Engel version JETSET compatible *
5004 * *
5005  DATA (am(k),k=1,85) /
5006  & .9383d+00, .9383d+00, amelct , amelct , .0000d+00,
5007  & .0000d+00, .0000d+00, .9396d+00, .9396d+00, ammuon ,
5008  & ammuon , .4977d+00, .1396d+00, .1396d+00, .4936d+00,
5009  & .4936d+00, .1116d+01, .1116d+01, .4977d+00, .1197d+01,
5010  & .1189d+01, .1193d+01, .1350d+00, .4977d+00, .4977d+00,
5011  & .0000d+00, .0000d+00, .0000d+00, .0000d+00, .0000d+00,
5012  & .5488d+00, .7669d+00, .7700d+00, .7669d+00, .7820d+00,
5013  & .8921d+00, .8962d+00, .8921d+00, .8962d+00, .1300d+01,
5014  & .1300d+01, .1300d+01, .1300d+01, .1421d+01, .1421d+01,
5015  & .1421d+01, .1421d+01, .1383d+01, .1384d+01, .1387d+01,
5016  & .1820d+01, .2030d+01, .1231d+01, .1232d+01, .1233d+01,
5017  & .1234d+01, .1675d+01, .1675d+01, .1675d+01, .1675d+01,
5018  & .1500d+01, .1500d+01, .1515d+01, .1515d+01, .1775d+01,
5019  & .1775d+01, .1231d+01, .1232d+01, .1233d+01, .1234d+01,
5020  & .1675d+01, .1675d+01, .1675d+01, .1675d+01, .1515d+01,
5021  & .1515d+01, .2500d+01, .4890d+00, .4890d+00, .4890d+00,
5022  & .1300d+01, .1300d+01, .1300d+01, .1300d+01, .2200d+01 /
5023  DATA (am(k),k=86,183) /
5024  & .2200d+01, .2200d+01, .2200d+01, .1700d+01, .1700d+01,
5025  & .1700d+01, .1700d+01, .1820d+01, .2030d+01, .9575d+00,
5026  & .1019d+01, .1315d+01, .1321d+01, .1189d+01, .1193d+01,
5027  & .1197d+01, .1315d+01, .1321d+01, .1383d+01, .1384d+01,
5028  & .1387d+01, .1532d+01, .1535d+01, .1672d+01, .1383d+01,
5029  & .1384d+01, .1387d+01, .1532d+01, .1535d+01, .1672d+01,
5030  & .1865d+01, .1869d+01, .1869d+01, .1865d+01, .1969d+01,
5031  & .1969d+01, .2980d+01, .2007d+01, .2010d+01, .2010d+01,
5032  & .2007d+01, .2113d+01, .2113d+01, .3686d+01, .3097d+01,
5033  & .1777d+01, .1777d+01, .0000d+00, .0000d+00, .0000d+00,
5034  & .0000d+00, .2285d+01, .2460d+01, .2460d+01, .2452d+01,
5035  & .2453d+01, .2454d+01, .2560d+01, .2560d+01, .2730d+01,
5036  & .3610d+01, .3610d+01, .3790d+01, .2285d+01, .2460d+01,
5037  & .2460d+01, .2452d+01, .2453d+01, .2454d+01, .2560d+01,
5038  & .2560d+01, .2730d+01, .3610d+01, .3610d+01, .3790d+01,
5039  & .2490d+01, .2490d+01, .2490d+01, .2610d+01, .2610d+01,
5040  & .2770d+01, .3670d+01, .3670d+01, .3850d+01, .4890d+01,
5041  & .2490d+01, .2490d+01, .2490d+01, .2610d+01, .2610d+01,
5042  & .2770d+01, .3670d+01, .3670d+01, .3850d+01, .4890d+01,
5043  & .1250d+01, .1250d+01, .1250d+01 /
5044  DATA ( am( i ), i = 184,210 ) /
5045  & 1.44000000000000d+00, 1.44000000000000d+00, 1.30000000000000d+00,
5046  & 1.30000000000000d+00, 1.30000000000000d+00, 1.40000000000000d+00,
5047  & 1.46000000000000d+00, 1.46000000000000d+00, 1.46000000000000d+00,
5048  & 1.46000000000000d+00, 1.60000000000000d+00, 1.60000000000000d+00,
5049  & 1.66000000000000d+00, 1.66000000000000d+00, 1.66000000000000d+00,
5050  & 1.66000000000000d+00, 1.66000000000000d+00, 1.66000000000000d+00,
5051  & 1.95000000000000d+00, 1.95000000000000d+00, 1.95000000000000d+00,
5052  & 1.95000000000000d+00, 2.25000000000000d+00, 2.25000000000000d+00,
5053  & 1.44000000000000d+00, 1.44000000000000d+00, 0.00000000000000d+00/
5054 * *
5055 * Particle mean lives *
5056 * *
5057  DATA (tau(k),k=1,183) /
5058  & .1000d+19, .1000d+19, .1000d+19, .1000d+19, .1000d+19,
5059  & .1000d+19, .1000d+19, .9180d+03, .9180d+03, .2200d-05,
5060  & .2200d-05, .5200d-07, .2600d-07, .2600d-07, .1200d-07,
5061  & .1200d-07, .2600d-09, .2600d-09, .9000d-10, .1500d-09,
5062  & .8000d-10, .5000d-14, .8000d-16, .0000d+00, .0000d+00,
5063  & 70*.0000d+00,
5064  & .0000d+00, .3000d-09, .1700d-09, .8000d-10, .1000d-13,
5065  & .1500d-09, .3000d-09, .1700d-09, .0000d+00, .0000d+00,
5066  & .0000d+00, .0000d+00, .0000d+00, .1000d-09, .0000d+00,
5067  & .0000d+00, .0000d+00, .0000d+00, .0000d+00, .1000d-09,
5068  & .0000d+00, .0000d+00, .0000d+00, .0000d+00, .0000d+00,
5069  & .0000d+00, .0000d+00, .0000d+00, .0000d+00, .0000d+00,
5070  & .0000d+00, .0000d+00, .0000d+00, .0000d+00, .0000d+00,
5071  & .9000d-11, .9000d-11, .9000d-11, .9000d-11, .1000d+19,
5072  & .1000d+19, .0000d+00, .0000d+00, .0000d+00, .0000d+00,
5073  & 40*.0000d+00,
5074  & .0000d+00, .0000d+00, .0000d+00 /
5075  DATA ( tau( i ), i = 184,210 ) /
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  & 0.00000000000000d+00, 0.00000000000000d+00, 0.00000000000000d+00,
5083  & 0.00000000000000d+00, 0.00000000000000d+00, 0.00000000000000d+00,
5084  & 0.00000000000000d+00, 0.00000000000000d+00, 0.00000000000000d+00/
5085 * *
5086 * Resonance width Gamma in GeV *
5087 * *
5088  DATA (ga(k),k= 1,85) /
5089  & 30*.0000d+00,
5090  & .8500d-06, .1520d+00, .1520d+00, .1520d+00, .1000d-01,
5091  & .7900d-01, .7900d-01, .7900d-01, .7900d-01, .4500d+00,
5092  & .4500d+00, .4500d+00, .4500d+00, .1080d+00, .1080d+00,
5093  & .1080d+00, .1080d+00, .5000d-01, .5000d-01, .5000d-01,
5094  & .8500d-01, .1800d+00, .1150d+00, .1150d+00, .1150d+00,
5095  & .1150d+00, .2000d+00, .2000d+00, .2000d+00, .2000d+00,
5096  & .2000d+00, .2000d+00, .1000d+00, .1000d+00, .2000d+00,
5097  & .2000d+00, .1150d+00, .1150d+00, .1150d+00, .1150d+00,
5098  & .2000d+00, .2000d+00, .2000d+00, .2000d+00, .1000d+00,
5099  & .1000d+00, .2000d+00, .1000d+00, .1000d+00, .1000d+00,
5100  & .1000d+00, .1000d+00, .1000d+00, .1000d+00, .2000d+00 /
5101  DATA (ga(k),k= 86,183) /
5102  & .2000d+00, .2000d+00, .2000d+00, .1500d+00, .1500d+00,
5103  & .1500d+00, .1500d+00, .8500d-01, .1800d+00, .2000d-02,
5104  & .4000d-02, .0000d+00, .0000d+00, .0000d+00, .0000d+00,
5105  & .0000d+00, .0000d+00, .0000d+00, .3400d-01, .3400d-01,
5106  & .3600d-01, .9000d-02, .9000d-02, .0000d+00, .3400d-01,
5107  & .3400d-01, .3600d-01, .9000d-02, .9000d-02, .0000d+00,
5108  & .0000d+00, .0000d+00, .0000d+00, .0000d+00, .0000d+00,
5109  & .0000d+00, .0000d+00, .5000d-02, .2000d-02, .2000d-02,
5110  & .5000d-02, .2000d-02, .2000d-02, .2000d-03, .7000d-03,
5111  & 50*.0000d+00,
5112  & .3000d+00, .3000d+00, .3000d+00 /
5113  DATA ( ga( i ), i = 184,210 ) /
5114  & 2.00000000000000d-01, 2.00000000000000d-01, 3.00000000000000d-01,
5115  & 3.00000000000000d-01, 3.00000000000000d-01, 2.70000000000000d-01,
5116  & 2.50000000000000d-01, 2.50000000000000d-01, 2.50000000000000d-01,
5117  & 2.50000000000000d-01, 1.50000000000000d-01, 1.50000000000000d-01,
5118  & 1.00000000000000d-01, 1.00000000000000d-01, 1.00000000000000d-01,
5119  & 1.00000000000000d-01, 1.00000000000000d-01, 1.00000000000000d-01,
5120  & 6.00000000000000d-02, 6.00000000000000d-02, 6.00000000000000d-02,
5121  & 6.00000000000000d-02, 5.50000000000000d-02, 5.50000000000000d-02,
5122  & 2.00000000000000d-01, 2.00000000000000d-01, 0.00000000000000d+00/
5123 * *
5124 * Particle names *
5125 * *
5126 * S+1385+Sigma+(1385) L02030+Lambda0(2030) *
5127 * Rho77=Rho(770) Om783=Omega(783) K*14=K*(1420) and so on *
5128 * designation N*@@ means N*@1(@2) *
5129 * *
5130 * *
5131  DATA (aname(k),k=1,85) /
5132  & 'P ','AP ','E- ','E+ ','NUE ',
5133  & 'ANUE ','GAM ','NEU ','ANEU ','MUE+ ',
5134  & 'MUE- ','K0L ','PI+ ','PI- ','K+ ',
5135  & 'K- ','LAM ','ALAM ','K0S ','SIGM- ',
5136  & 'SIGM+ ','SIGM0 ','PI0 ','K0 ','AK0 ',
5137  & 'BLANK ','BLANK ','BLANK ','BLANK ','BLANK ',
5138  & 'ETA550 ','RHO+77 ','RHO077 ','RHO-77 ','OM0783 ',
5139  & 'K*+892 ','K*0892 ','K*-892 ','AK*089 ','KA+125 ',
5140  & 'KA0125 ','KA-125 ','AKA012 ','K*+142 ','K*0142 ',
5141  & 'K*-142 ','AK*014 ','S+1385 ','S01385 ','S-1385 ',
5142  & 'L01820 ','L02030 ','N*++12 ','N*+ 12 ','N*012 ',
5143  & 'N*-12 ','N*++16 ','N*+16 ','N*016 ','N*-16 ',
5144  & 'N*+14 ','N*014 ','N*+15 ','N*015 ','N*+18 ',
5145  & 'N*018 ','AN--12 ','AN*-12 ','AN*012 ','AN*+12 ',
5146  & 'AN--16 ','AN*-16 ','AN*016 ','AN*+16 ','AN*-15 ',
5147  & 'AN*015 ','DE*=24 ','RPI+49 ','RPI049 ','RPI-49 ',
5148  & 'PIN++ ','PIN+0 ','PIN+- ','PIN-0 ','PPPI ' /
5149  DATA (aname(k),k=86,183) /
5150  & 'PNPI ','APPPI ','APNPI ','K+PPI ','K-PPI ',
5151  & 'K+NPI ','K-NPI ','S+1820 ','S-2030 ','ETA* ',
5152  & 'PHI ','TETA0 ','TETA- ','ASIG- ','ASIG0 ',
5153  & 'ASIG+ ','ATETA0 ','ATETA+ ','SIG*+ ','SIG*0 ',
5154  & 'SIG*- ','TETA*0 ','TETA* ','OMEGA- ','ASIG*- ',
5155  & 'ASIG*0 ','ASIG*+ ','ATET*0 ','ATET*+ ','OMEGA+ ',
5156  & 'D0 ','D+ ','D- ','AD0 ','DS+ ',
5157  & 'DS- ','ETAC ','D*0 ','D*+ ','D*- ',
5158  & 'AD*0 ','DS*+ ','DS*- ','CHI1C ','JPSI ',
5159  & 'TAU+ ','TAU- ','NUET ','ANUET ','NUEM ',
5160  & 'ANUEM ','LAMC+ ','XIC+ ','XIC0 ','SIGC++ ',
5161  & 'SIGC+ ','SIGC0 ','S+ ','S0 ','T0 ',
5162  & 'XU++ ','XD+ ','XS+ ','ALAMC- ','AXIC- ',
5163  & 'AXIC0 ','ASIGC-- ','ASIGC- ','ASIGC0 ','AS- ',
5164  & 'AS0 ','AT0 ','AXU-- ','AXD- ','AXS ',
5165  & 'C1*++ ','C1*+ ','C1*0 ','S*+ ','S*0 ',
5166  & 'T*0 ','XU*++ ','XD*+ ','XS*+ ','TETA++ ',
5167  & 'AC1*-- ','AC1*- ','AC1*0 ','AS*- ','AS*0 ',
5168  & 'AT*0 ','AXU*-- ','AXD*- ','AXS*- ','ATET-- ',
5169  & 'RO ','R+ ','R- ' /
5170  DATA ( aname( i ), i = 184,210 ) /
5171  &'AN*-14 ','AN*014 ','PI+130 ','PI0130 ','PI-130 ','F01400 ',
5172  &'K*+146 ','K*-146 ','K*0146 ','AK0146 ','L01600 ','AL0160 ',
5173  &'S+1660 ','S01660 ','S-1660 ','AS-166 ','AS0166 ','AS+166 ',
5174  &'X01950 ','X-1950 ','AX0195 ','AX+195 ','OM-225 ','AOM+22 ',
5175  &'N*+14 ','N*014 ','BLANK '/
5176 * *
5177 * Charge of particles and resonances *
5178 * *
5179  DATA ( ich( i ), i = 1,210 ) /
5180  & 1, -1, -1, 1, 0, 0, 0, 0, 0, 1, -1, 0, 1, -1, 1,
5181  & -1, 0, 0, 0, -1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
5182  & 0, 1, 0, -1, 0, 1, 0, -1, 0, 1, 0, -1, 0, 1, 0,
5183  & -1, 0, 1, 0, -1, 0, 0, 2, 1, 0, -1, 2, 1, 0, -1,
5184  & 1, 0, 1, 0, 1, 0, -2, -1, 0, 1, -2, -1, 0, 1, -1,
5185  & 0, 1, 1, 0, -1, 2, 1, 0, -1, 2, 1, 0, -1, 2, 0,
5186  & 1, -1, 1, -1, 0, 0, 0, -1, -1, 0, 1, 0, 1, 1, 0,
5187  & -1, 0, -1, -1, -1, 0, 1, 0, 1, 1, 0, 1, -1, 0, 1,
5188  & -1, 0, 0, 1, -1, 0, 1, -1, 0, 0, 1, -1, 0, 0, 0,
5189  & 0, 1, 1, 0, 2, 1, 0, 1, 0, 0, 2, 1, 1, -1, -1,
5190  & 0, -2, -1, 0, -1, 0, 0, -2, -1, -1, 2, 1, 0, 1, 0,
5191  & 0, 2, 1, 1, 2, -2, -1, 0, -1, 0, 0, -2, -1, -1, -2,
5192  & 0, 1, -1, -1, 0, 1, 0, -1, 0, 1, -1, 0, 0, 0, 0,
5193  & 1, 0, -1, -1, 0, 1, 0, -1, 0, 1, -1, 1, 1, 0, 0/
5194 * *
5195 * Particle baryonic charges *
5196 * *
5197  DATA ( ibar( i ), i = 1,210 ) /
5198  & 1, -1, 0, 0, 0, 0, 0, 1, -1, 0, 0, 0, 0, 0, 0,
5199  & 0, 1, -1, 0, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0,
5200  & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
5201  & 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
5202  & 1, 1, 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
5203  & -1, 2, 0, 0, 0, 1, 1, 1, 1, 2, 2, 0, 0, 1, 1,
5204  & 1, 1, 1, 1, 0, 0, 1, 1, -1, -1, -1, -1, -1, 1, 1,
5205  & 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, 0, 0, 0, 0, 0,
5206  & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
5207  & 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, -1, -1,
5208  & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 1, 1, 1, 1, 1,
5209  & 1, 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
5210  & 0, 0, 0, -1, -1, 0, 0, 0, 0, 0, 0, 0, 0, 1, -1,
5211  & 1, 1, 1, -1, -1, -1, 1, 1, -1, -1, 1, -1, 1, 1, 0/
5212 * *
5213 * First number of decay channels used for resonances *
5214 * and decaying particles *
5215 * *
5216  DATA k1/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 16, 17,
5217  & 18, 24, 30, 34, 38, 40, 41, 43, 44, 136, 138, 330, 327, 328,
5218  & 2*330, 46, 51, 52, 54, 55, 58,
5219  & 60, 62, 64, 66, 68, 70, 72, 74, 82, 90, 98, 106, 109, 112, 114,
5220  & 123, 140, 141, 143, 145, 146, 150, 157, 164, 168, 174, 180, 187,
5221  & 194, 202, 210, 211, 213, 215, 216, 220, 227, 234, 238, 245, 252,
5222  & 254, 255, 256, 257, 259, 262, 265, 267, 269, 272, 276, 279, 282,
5223  & 286, 290, 293, 299, 331, 335, 339, 340, 341, 343, 344, 345, 346,
5224  & 347, 350, 353, 356, 358, 360, 363, 366, 369, 372, 374, 376, 379,
5225  & 383, 385, 387, 391, 394, 397, 400, 402, 405, 408, 410, 412, 414,
5226  & 417, 420, 425, 430, 431, 432, 433, 434, 448, 452, 457, 458, 459,
5227  & 460, 461, 462, 466, 468, 470, 472, 486, 490, 495, 496, 497, 498,
5228  & 499, 500, 504, 506, 508, 510, 511, 512, 513, 514, 515, 516, 517,
5229  & 518, 519, 522, 523, 524, 525, 526, 527, 528, 529, 530, 531, 534,
5230  & 537, 539, 541, 547, 553, 558, 563, 568, 572, 573, 574, 575, 576,
5231  & 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588, 589,
5232  & 590, 596, 602 /
5233 * *
5234 * Last number of decay channels used for resonances *
5235 * and decaying particles *
5236 * *
5237  DATA k2/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 15, 16, 17,
5238  & 23, 29, 31, 35, 39, 40, 42, 43, 45, 137, 139, 330, 327, 328,
5239  & 2* 330, 50, 51, 53, 54, 57,
5240  & 59, 61, 63, 65, 67, 69, 71, 73, 81, 89, 97, 105, 108, 111, 113,
5241  & 122, 135, 140, 142, 144, 145, 149, 156, 163, 167, 173, 179, 186,
5242  & 193, 201, 209, 210, 212, 214, 215, 219, 226, 233, 237, 244, 251,
5243  & 253, 254, 255, 256, 258, 261, 264, 266, 268, 271, 275, 278, 281,
5244  & 285, 289, 292, 298, 307, 334, 338, 339, 340, 342, 343, 344, 345,
5245  & 346, 349, 352, 355, 357, 359, 362, 365, 368, 371, 373, 375, 378,
5246  & 382, 384, 386, 390, 393, 396, 399, 401, 404, 407, 409, 411, 413,
5247  & 416, 419, 424, 429, 430, 431, 432, 433, 447, 451, 456, 457, 458,
5248  & 459, 460, 461, 465, 467, 469, 471, 485, 489, 494, 495, 496, 497,
5249  & 498, 499, 503, 505, 507, 509, 510, 511, 512, 513, 514, 515, 516,
5250  & 517, 518, 521, 522, 523, 524, 525, 526, 527, 528, 529, 530, 533,
5251  & 536, 538, 540, 546, 552, 557, 562, 567, 571, 572, 573, 574, 575,
5252  & 576, 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588,
5253  & 589, 595, 601, 602 /
5254 * *
5255 *
5256  END
5257 *
5258 
5259 *=== blkdt7 ===========================================================*
5260 *== *
5261  BLOCK DATA blkd47
5262  IMPLICIT DOUBLE PRECISION (a-h,o-z)
5263  SAVE
5264 * * Block data 7 (ex 2) *
5265 C INCLUDE '(DECAYC)'
5266 C***********************************************************************
5267  parameter(idmax9=602)
5268  CHARACTER*8 zkname
5269  common/ddecac/ zkname(idmax9),wt(idmax9),nzk(idmax9,3)
5270 
5271 
5272 * *
5273 * Name of decay channel *
5274 * *
5275 * *
5276 * Designation N*@ means N*@1(1236) *
5277 * @1=# means ++, @1 = = means -- *
5278 * Designation P+/0/- means Pi+/Pi0/Pi- , respectively *
5279 * *
5280  DATA (zkname(k),k= 1, 85) /
5281  & 'P ','AP ','E- ','E+ ','NUE ',
5282  & 'ANUE ','GAM ','PE-NUE ','APEANU ','EANUNU ',
5283  & 'E-NUAN ','3PI0 ','PI+-0 ','PIMUNU ','PIE-NU ',
5284  & 'MU+NUE ','MU-NUE ','MU+NUE ','PI+PI0 ','PI++- ',
5285  & 'PI+00 ','M+P0NU ','E+P0NU ','MU-NU ','PI-0 ',
5286  & 'PI+-- ','PI-00 ','M-P0NU ','E-P0NU ','PPI- ',
5287  & 'NPI0 ','PD-NUE ','PM-NUE ','APPI+ ','ANPI0 ',
5288  & 'APE+NU ','APM+NU ','PI+PI- ','PI0PI0 ','NPI- ',
5289  & 'PPI0 ','NPI+ ','LAGA ','GAGA ','GAE+E- ',
5290  & 'GAGA ','GAGAP0 ','PI000 ','PI+-0 ','PI+-GA ',
5291  & 'PI+0 ','PI+- ','PI00 ','PI-0 ','PI+-0 ',
5292  & 'PI+- ','PI0GA ','K+PI0 ','K0PI+ ','KOPI0 ',
5293  & 'K+PI- ','K-PI0 ','AK0PI- ','AK0PI0 ','K-PI+ ',
5294  & 'K+PI0 ','K0PI+ ','K0PI0 ','K+PI- ','K-PI0 ',
5295  & 'K0PI- ','AK0PI0 ','K-PI+ ','K+PI0 ','K0PI+ ',
5296  & 'K+89P0 ','K08PI+ ','K+RO77 ','K0RO+7 ','K+OM07 ',
5297  & 'K+E055 ','K0PI0 ','K+PI+ ','K089P0 ','K+8PI- ' /
5298  DATA (zkname(k),k= 86,170) /
5299  & 'K0R077 ','K+R-77 ','K+R-77 ','K0OM07 ','K0E055 ',
5300  & 'K-PI0 ','K0PI- ','K-89P0 ','AK08P- ','K-R077 ',
5301  & 'AK0R-7 ','K-OM07 ','K-E055 ','AK0PI0 ','K-PI+ ',
5302  & 'AK08P0 ','K-8PI+ ','AK0R07 ','AK0OM7 ','AK0E05 ',
5303  & 'LA0PI+ ','SI0PI+ ','SI+PI0 ','LA0PI0 ','SI+PI- ',
5304  & 'SI-PI+ ','LA0PI- ','SI0PI- ','NEUAK0 ','PK- ',
5305  & 'SI+PI- ','SI0PI0 ','SI-PI+ ','LA0ET0 ','S+1PI- ',
5306  & 'S-1PI+ ','SO1PI0 ','NEUAK0 ','PK- ','LA0PI0 ',
5307  & 'LA0OM0 ','LA0RO0 ','SI+RO- ','SI-RO+ ','SI0RO0 ',
5308  & 'LA0ET0 ','SI0ET0 ','SI+PI- ','SI-PI+ ','SI0PI0 ',
5309  & 'K0S ','K0L ','K0S ','K0L ','P PI+ ',
5310  & 'P PI0 ','N PI+ ','P PI- ','N PI0 ','N PI- ',
5311  & 'P PI+ ','N*#PI0 ','N*+PI+ ','PRHO+ ','P PI0 ',
5312  & 'N PI+ ','N*#PI- ','N*+PI0 ','N*0PI+ ','PRHO0 ',
5313  & 'NRHO+ ','P PI- ','N PI0 ','N*+PI- ','N*0PI0 ',
5314  & 'N*-PI+ ','PRHO- ','NRHO0 ','N PI- ','N*0PI- ',
5315  & 'N*-PI0 ','NRHO- ','PETA0 ','N*#PI- ','N*+PI0 ' /
5316  DATA (zkname(k),k=171,255) /
5317  & 'N*0PI+ ','PRHO0 ','NRHO+ ','NETA0 ','N*+PI- ',
5318  & 'N*0PI0 ','N*-PI+ ','PRHO- ','NRHO0 ','P PI0 ',
5319  & 'N PI+ ','N*#PI- ','N*+PI0 ','N*0PI+ ','PRHO0 ',
5320  & 'NRHO+ ','P PI- ','N PI0 ','N*+PI- ','N*0PI0 ',
5321  & 'N*-PI+ ','PRHO- ','NRHO0 ','P PI0 ','N PI+ ',
5322  & 'PRHO0 ','NRHO+ ','LAMK+ ','S+ K0 ','S0 K+ ',
5323  & 'PETA0 ','P PI- ','N PI0 ','PRHO- ','NRHO0 ',
5324  & 'LAMK0 ','S0 K0 ','S- K+ ','NETA/ ','APPI- ',
5325  & 'APPI0 ','ANPI- ','APPI+ ','ANPI0 ','ANPI+ ',
5326  & 'APPI- ','AN*=P0 ','AN*-P- ','APRHO- ','APPI0 ',
5327  & 'ANPI- ','AN*=P+ ','AN*-P0 ','AN*0P- ','APRHO0 ',
5328  & 'ANRHO- ','APPI+ ','ANPI0 ','AN*-P+ ','AN*0P0 ',
5329  & 'AN*+P- ','APRHO+ ','ANRHO0 ','ANPI+ ','AN*0P+ ',
5330  & 'AN*+P0 ','ANRHO+ ','APPI0 ','ANPI- ','AN*=P+ ',
5331  & 'AN*-P0 ','AN*0P- ','APRHO0 ','ANRHO- ','APPI+, ',
5332  & 'ANPI0 ','AN*-P+ ','AN*0P0 ','AN*+P- ','APRHO+ ',
5333  & 'ANRHO0 ','PN*014 ','NN*=14 ','PI+0 ','PI+- ' /
5334  DATA (zkname(k),k=256,340) /
5335  & 'PI-0 ','P+0 ','N++ ','P+- ','P00 ',
5336  & 'N+0 ','N+- ','N00 ','P-0 ','N-0 ',
5337  & 'P-- ','PPPI0 ','PNPI+ ','PNPI0 ','PPPI- ',
5338  & 'NNPI+ ','APPPI0 ','APNPI+ ','ANNPI0 ','ANPPI- ',
5339  & 'APNPI0 ','APPPI- ','ANNPI- ','K+PPI0 ','K+NPI+ ',
5340  & 'K0PPI0 ','K-PPI0 ','K-NPI+ ','AKPPI- ','AKNPI0 ',
5341  & 'K+NPI0 ','K+PPI- ','K0PPI0 ','K0NPI+ ','K-NPI0 ',
5342  & 'K-PPI- ','AKNPI- ','PAK0 ','SI+PI0 ','SI0PI+ ',
5343  & 'SI+ETA ','S+1PI0 ','S01PI+ ','NEUK- ','LA0PI- ',
5344  & 'SI-OM0 ','LA0RO- ','SI0RO- ','SI-RO0 ','SI-ET0 ',
5345  & 'SI0PI- ','SI-0 ','BLANC ','BLANC ','BLANC ',
5346  & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
5347  & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
5348  & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
5349  & 'BLANC ','BLANC ','BLANC ','BLANC ','BLANC ',
5350  & 'EPI+- ','EPI00 ','GAPI+- ','GAGA* ','K+- ',
5351  & 'KLKS ','PI+-0 ','EGA ','LPI0 ','LPI ' /
5352  DATA (zkname(k),k=341,425) /
5353  & 'APPI0 ','ANPI- ','ALAGA ','ANPI ','ALPI0 ',
5354  & 'ALPI+ ','LAPI+ ','SI+PI0 ','SI0PI+ ','LAPI0 ',
5355  & 'SI+PI- ','SI-PI+ ','LAPI- ','SI-PI0 ','SI0PI- ',
5356  & 'TE0PI0 ','TE-PI+ ','TE0PI- ','TE-PI0 ','TE0PI ',
5357  & 'TE-PI ','LAK- ','ALPI- ','AS-PI0 ','AS0PI- ',
5358  & 'ALPI0 ','AS+PI- ','AS-PI+ ','ALPI+ ','AS+PI0 ',
5359  & 'AS0PI+ ','AT0PI0 ','AT+PI- ','AT0PI+ ','AT+PI0 ',
5360  & 'AT0PI ','AT+PI ','ALK+ ','K-PI+ ','K-PI+0 ',
5361  & 'K0PI+- ','K0PI0 ','K-PI++ ','AK0PI+ ','K+PI-- ',
5362  & 'K0PI- ','K+PI- ','K+PI-0 ','AKPI-+ ','AK0PI0 ',
5363  & 'ETAPIF ','K++- ','K+AK0 ','ETAPI- ','K--+ ',
5364  & 'K-K0 ','PI00 ','PI+- ','GAGA ','D0PI0 ',
5365  & 'D0GA ','D0PI+ ','D+PI0 ','DFGA ','AD0PI- ',
5366  & 'D-PI0 ','D-GA ','AD0PI0 ','AD0GA ','F+GA ',
5367  & 'F+GA ','F-GA ','F-GA ','PSPI+- ','PSPI00 ',
5368  & 'PSETA ','E+E- ','MUE+- ','PI+-0 ','M+NN ',
5369  & 'E+NN ','RHO+NT ','PI+ANT ','K*+ANT ','M-NN ' /
5370  DATA (zkname(k),k=426,510) /
5371  & 'E-NN ','RHO-NT ','PI-NT ','K*-NT ','NUET ',
5372  & 'ANUET ','NUEM ','ANUEM ','SI+ETA ','SI+ET* ',
5373  & 'PAK0 ','TET0K+ ','SI*+ET ','N*+AK0 ','N*++K- ',
5374  & 'LAMRO+ ','SI0RO+ ','SI+RO0 ','SI+OME ','PAK*0 ',
5375  & 'N*+AK* ','N*++K* ','SI+AK0 ','TET0PI ','SI+AK* ',
5376  & 'TET0RO ','SI0AK* ','SI+K*- ','TET0OM ','TET-RO ',
5377  & 'SI*0AK ','C0+PI+ ','C0+PI0 ','C0+PI- ','A+GAM ',
5378  & 'A0GAM ','TET0AK ','TET0K* ','OM-RO+ ','OM-PI+ ',
5379  & 'C1++AK ','A+PI+ ','C0+AK0 ','A0PI+ ','A+AK0 ',
5380  & 'T0PI+ ','ASI-ET ','ASI-E* ','APK0 ','ATET0K ',
5381  & 'ASI*-E ','AN*-K0 ','AN*--K ','ALAMRO ','ASI0RO ',
5382  & 'ASI-RO ','ASI-OM ','APK*0 ','AN*-K* ','AN*--K ',
5383  & 'ASI-K0 ','ATETPI ','ASI-K* ','ATETRO ','ASI0K* ',
5384  & 'ASI-K* ','ATE0OM ','ATE+RO ','ASI*0K ','AC-PI- ',
5385  & 'AC-PI0 ','AC-PI+ ','AA-GAM ','AA0GAM ','ATET0K ',
5386  & 'ATE0K* ','AOM+RO ','AOM+PI ','AC1--K ','AA-PI- ',
5387  & 'AC0-K0 ','AA0PI- ','AA-K0 ','AT0PI- ','C1++GA ' /
5388  DATA (zkname(k),k=511,540) /
5389  & 'C1++GA ','C10GAM ','S+GAM ','S0GAM ','T0GAM ',
5390  & 'XU++GA ','XD+GAM ','XS+GAM ','A+AKPI ','T02PI+ ',
5391  & 'C1++2K ','AC1--G ','AC1-GA ','AC10GA ','AS-GAM ',
5392  & 'AS0GAM ','AT0GAM ','AXU--G ','AXD-GA ','AXS-GA ',
5393  & 'AA-KPI ','AT02PI ','AC1--K ','RH-PI+ ','RH+PI- ',
5394  & 'RH3PI0 ','RH0PI+ ','RH+PI0 ','RH0PI- ','RH-PI0 ' /
5395  DATA (zkname(i),i=541,602)/
5396  & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHO0','ANRHO-','ANETA ',
5397  & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0','RH0PI+','RH+PI0',
5398  & '3PI+00','3PI-++','F0PI+ ','RH+PI-','RH0PI0','3PI000','3PI0+-',
5399  & 'F0PI0 ','RH0PI-','RH-PI0','3PI-00','3PI--+','F0PI- ','PI0PI0',
5400  & 'PI+PI-','K+K- ','K0AK0 ','L01600','AL0160','K*+146','K*-146',
5401  & 'K*0146','AK0146','S+1660','S01660','S-1660','AS-166','AS0166',
5402  & 'AS+166','X01690','X-1690','AX0169','AX+169','OM-225','AOM+22',
5403  & 'N*PPI0','N*NPI+','N*P2P0','N*PP+-','N*D+P0','N*D0P+','N*NPI0',
5404  & 'N*PPI-','N*N2P0','N*NP+-','N*D+P-','N*D0P0','BLANK '/
5405 * *
5406 * Weight of decay channel *
5407 * *
5408  DATA (wt(k),k= 1, 85) /
5409  & .1000d+01, .1000d+01, .1000d+01, .1000d+01, .1000d+01,
5410  & .1000d+01, .1000d+01, .1000d+01, .1000d+01, .1000d+01,
5411  & .1000d+01, .2100d+00, .1200d+00, .2700d+00, .4000d+00,
5412  & .1000d+01, .1000d+01, .6400d+00, .2100d+00, .6000d-01,
5413  & .2000d-01, .3000d-01, .4000d-01, .6400d+00, .2100d+00,
5414  & .6000d-01, .2000d-01, .3000d-01, .4000d-01, .6400d+00,
5415  & .3600d+00, .0000d+00, .0000d+00, .6400d+00, .3600d+00,
5416  & .0000d+00, .0000d+00, .6900d+00, .3100d+00, .1000d+01,
5417  & .5200d+00, .4800d+00, .1000d+01, .9900d+00, .1000d-01,
5418  & .3800d+00, .3000d-01, .3000d+00, .2400d+00, .5000d-01,
5419  & .1000d+01, .1000d+01, .0000d+00, .1000d+01, .9000d+00,
5420  & .1000d-01, .9000d-01, .3300d+00, .6700d+00, .3300d+00,
5421  & .6700d+00, .3300d+00, .6700d+00, .3300d+00, .6700d+00,
5422  & .3300d+00, .6700d+00, .3300d+00, .6700d+00, .3300d+00,
5423  & .6700d+00, .3300d+00, .6700d+00, .1900d+00, .3800d+00,
5424  & .9000d-01, .2000d+00, .3000d-01, .4000d-01, .5000d-01,
5425  & .2000d-01, .1900d+00, .3800d+00, .9000d-01, .2000d+00 /
5426  DATA (wt(k),k= 86,170) /
5427  & .3000d-01, .4000d-01, .5000d-01, .2000d-01, .1900d+00,
5428  & .3800d+00, .9000d-01, .2000d+00, .3000d-01, .4000d-01,
5429  & .5000d-01, .2000d-01, .1900d+00, .3800d+00, .9000d-01,
5430  & .2000d+00, .3000d-01, .4000d-01, .5000d-01, .2000d-01,
5431  & .8800d+00, .6000d-01, .6000d-01, .8800d+00, .6000d-01,
5432  & .6000d-01, .8800d+00, .1200d+00, .1900d+00, .1900d+00,
5433  & .1600d+00, .1600d+00, .1700d+00, .3000d-01, .3000d-01,
5434  & .3000d-01, .4000d-01, .1000d+00, .1000d+00, .2000d+00,
5435  & .1200d+00, .1000d+00, .4000d-01, .4000d-01, .5000d-01,
5436  & .7500d-01, .7500d-01, .3000d-01, .3000d-01, .4000d-01,
5437  & .5000d+00, .5000d+00, .5000d+00, .5000d+00, .1000d+01,
5438  & .6700d+00, .3300d+00, .3300d+00, .6700d+00, .1000d+01,
5439  & .2500d+00, .2700d+00, .1800d+00, .3000d+00, .1700d+00,
5440  & .8000d-01, .1800d+00, .3000d-01, .2400d+00, .2000d+00,
5441  & .1000d+00, .8000d-01, .1700d+00, .2400d+00, .3000d-01,
5442  & .1800d+00, .1000d+00, .2000d+00, .2500d+00, .1800d+00,
5443  & .2700d+00, .3000d+00, .5000d+00, .3000d+00, .1250d+00 /
5444 C & .2700D+00, .3000D+00, .4000D+00, .2000D+00, .1250D+00 /
5445 C & .7500D-01, .7500D-01, .1250D+00, .4000D+00, .7500D-01,
5446 C & .1250D+00, .2000D+00, .1250D+00, .7500D-01, .1800D+00,
5447  DATA (wt(k),k=171,255) /
5448  & .7500d-01, .0000d+00, .0000d+00, .5000d+00, .7500d-01,
5449  & .1250d+00, .3000d+00, .0000d+00, .0000d+00, .1800d+00,
5450  & .3700d+00, .1300d+00, .8000d-01, .4000d-01, .7000d-01,
5451  & .1300d+00, .3700d+00, .1800d+00, .4000d-01, .8000d-01,
5452  & .1300d+00, .1300d+00, .7000d-01, .7000d-01, .1300d+00,
5453  & .2300d+00, .4700d+00, .5000d-01, .2000d-01, .1000d-01,
5454  & .2000d-01, .1300d+00, .7000d-01, .4700d+00, .2300d+00,
5455  & .5000d-01, .1000d-01, .2000d-01, .2000d-01, .1000d+01,
5456  & .6700d+00, .3300d+00, .3300d+00, .6700d+00, .1000d+01,
5457  & .2500d+00, .2700d+00, .1800d+00, .3000d+00, .1700d+00,
5458  & .8000d-01, .1800d+00, .3000d-01, .2400d+00, .2000d+00,
5459  & .1000d+00, .8000d-01, .1700d+00, .2400d+00, .3000d-01,
5460  & .1800d+00, .1000d+00, .2000d+00, .2500d+00, .1800d+00,
5461  & .2700d+00, .3000d+00, .1800d+00, .3700d+00, .1300d+00,
5462  & .8000d-01, .4000d-01, .7000d-01, .1300d+00, .3700d+00,
5463  & .1800d+00, .4000d-01, .8000d-01, .1300d+00, .1300d+00,
5464  & .7000d-01, .5000d+00, .5000d+00, .1000d+01, .1000d+01 /
5465  DATA (wt(k),k=256,340) /
5466  & .1000d+01, .8000d+00, .2000d+00, .6000d+00, .3000d+00,
5467  & .1000d+00, .6000d+00, .3000d+00, .1000d+00, .8000d+00,
5468  & .2000d+00, .3300d+00, .6700d+00, .6600d+00, .1700d+00,
5469  & .1700d+00, .3200d+00, .1700d+00, .3200d+00, .1900d+00,
5470  & .3300d+00, .3300d+00, .3400d+00, .3000d+00, .5000d-01,
5471  & .6500d+00, .3800d+00, .1200d+00, .3800d+00, .1200d+00,
5472  & .3800d+00, .1200d+00, .3800d+00, .1200d+00, .3000d+00,
5473  & .5000d-01, .6500d+00, .3800d+00, .2500d+00, .2500d+00,
5474  & .2000d-01, .5000d-01, .5000d-01, .2000d+00, .2000d+00,
5475  & .1200d+00, .1000d+00, .7000d-01, .7000d-01, .1400d+00,
5476  & .5000d-01, .5000d-01, .1000d+01, .1000d+01, .1000d+01,
5477  & .1000d+01, .1000d+01, .1000d+01, .1000d+01, .1000d+01,
5478  & .1000d+01, .1000d+01, .1000d+01, .1000d+01, .1000d+01,
5479  & .1000d+01, .1000d+01, .1000d+01, .1000d+01, .1000d+01,
5480  & .1000d+01, .1000d+01, .1000d+01, .1000d+01, .1000d+01,
5481  & .4800d+00, .2400d+00, .2600d+00, .2000d-01, .4700d+00,
5482  & .3500d+00, .1500d+00, .3000d-01, .1000d+01, .1000d+01 /
5483  DATA (wt(k),k=341,425) /
5484  & .5200d+00, .4800d+00, .1000d+01, .1000d+01, .1000d+01,
5485  & .1000d+01, .9000d+00, .5000d-01, .5000d-01, .9000d+00,
5486  & .5000d-01, .5000d-01, .9000d+00, .5000d-01, .5000d-01,
5487  & .3300d+00, .6700d+00, .6700d+00, .3300d+00, .2500d+00,
5488  & .2500d+00, .5000d+00, .9000d+00, .5000d-01, .5000d-01,
5489  & .9000d+00, .5000d-01, .5000d-01, .9000d+00, .5000d-01,
5490  & .5000d-01, .3300d+00, .6700d+00, .6700d+00, .3300d+00,
5491  & .2500d+00, .2500d+00, .5000d+00, .1000d+00, .5000d+00,
5492  & .1600d+00, .2400d+00, .7000d+00, .3000d+00, .7000d+00,
5493  & .3000d+00, .1000d+00, .5000d+00, .1600d+00, .2400d+00,
5494  & .3000d+00, .4000d+00, .3000d+00, .3000d+00, .4000d+00,
5495  & .3000d+00, .4900d+00, .4900d+00, .2000d-01, .5500d+00,
5496  & .4500d+00, .6800d+00, .3000d+00, .2000d-01, .6800d+00,
5497  & .3000d+00, .2000d-01, .5500d+00, .4500d+00, .9000d+00,
5498  & .1000d+00, .9000d+00, .1000d+00, .6000d+00, .3000d+00,
5499  & .1000d+00, .1000d+00, .1000d+00, .8000d+00, .2800d+00,
5500  & .2800d+00, .3500d+00, .7000d-01, .2000d-01, .2800d+00 /
5501  DATA (wt(k),k=426,510) /
5502  & .2800d+00, .3500d+00, .7000d-01, .2000d-01, .1000d+01,
5503  & .1000d+01, .1000d+01, .1000d+01, .2000d-01, .3000d-01,
5504  & .7000d-01, .2000d-01, .2000d-01, .4000d-01, .1300d+00,
5505  & .7000d-01, .6000d-01, .6000d-01, .2000d+00, .1400d+00,
5506  & .4000d-01, .1000d+00, .2500d+00, .3000d-01, .3000d+00,
5507  & .4200d+00, .2200d+00, .3500d+00, .1900d+00, .1600d+00,
5508  & .8000d-01, .1000d+01, .1000d+01, .1000d+01, .1000d+01,
5509  & .1000d+01, .3700d+00, .2000d+00, .3600d+00, .7000d-01,
5510  & .5000d+00, .5000d+00, .5000d+00, .5000d+00, .5000d+00,
5511  & .5000d+00, .2000d-01, .3000d-01, .7000d-01, .2000d-01,
5512  & .2000d-01, .4000d-01, .1300d+00, .7000d-01, .6000d-01,
5513  & .6000d-01, .2000d+00, .1400d+00, .4000d-01, .1000d+00,
5514  & .2500d+00, .3000d-01, .3000d+00, .4200d+00, .2200d+00,
5515  & .3500d+00, .1900d+00, .1600d+00, .8000d-01, .1000d+01,
5516  & .1000d+01, .1000d+01, .1000d+01, .1000d+01, .3700d+00,
5517  & .2000d+00, .3600d+00, .7000d-01, .5000d+00, .5000d+00,
5518  & .5000d+00, .5000d+00, .5000d+00, .5000d+00, .1000d+01 /
5519  DATA (wt(k),k=511,540) /
5520  & .1000d+01, .1000d+01, .1000d+01, .1000d+01, .1000d+01,
5521  & .1000d+01, .1000d+01, .1000d+01, .3000d+00, .3000d+00,
5522  & .4000d+00, .1000d+01, .1000d+01, .1000d+01, .1000d+01,
5523  & .1000d+01, .1000d+01, .1000d+01, .1000d+01, .1000d+01,
5524  & .3000d+00, .3000d+00, .4000d+00, .3300d+00, .3300d+00,
5525  & .3400d+00, .5000d+00, .5000d+00, .5000d+00, .5000d+00 /
5526 C
5527  DATA (wt(i),i=541,602) / .0d+00, .3334d+00, .2083d+00, 2*.125d+00,
5528  & .2083d+00, .0d+00, .125d+00, .2083d+00, .3334d+00, .2083d+00,
5529  & .125d+00, 0.2d+00, 0.2d+00, 0.3d+00, 0.3d+00, 0.0d+00, 0.2d+00,
5530  & 0.2d+00, 0.3d+00, 0.3d+00, 0.0d+00, 0.2d+00, 0.2d+00, 0.3d+00,
5531  & 0.3d+00, 0.0d+00, 0.31d+00, 0.62d+00, 0.035d+00, 0.035d+00,
5532  & 18*1.d+00, 0.5d+00, 0.16d+00, 2*0.12d+00, 2*0.05d+00, 0.5d+00,
5533  & 0.16d+00, 2*0.12d+00, 2*0.05d+00, 1.d+00 /
5534 *
5535 * Particle numbers in decay channel *
5536 * *
5537  DATA (nzk(k,1),k= 1,170) /
5538  & 1, 2, 3, 4, 5, 6, 7, 1, 2, 4,
5539  & 3, 23, 13, 13, 13, 10, 11, 10, 13, 13,
5540  & 13, 10, 4, 11, 14, 14, 14, 11, 3, 1,
5541  & 8, 1, 1, 2, 9, 2, 2, 13, 23, 8,
5542  & 1, 8, 17, 7, 7, 7, 23, 23, 13, 13,
5543  & 13, 13, 23, 14, 13, 13, 23, 15, 24, 24,
5544  & 15, 16, 25, 25, 16, 15, 24, 24, 15, 16,
5545  & 24, 25, 16, 15, 24, 36, 37, 15, 24, 15,
5546  & 15, 24, 15, 37, 36, 24, 15, 24, 24, 16,
5547  & 24, 38, 39, 16, 25, 16, 16, 25, 16, 39,
5548  & 38, 25, 16, 25, 25, 17, 22, 21, 17, 21,
5549  & 20, 17, 22, 8, 1, 21, 22, 20, 17, 48,
5550  & 50, 49, 8, 1, 17, 17, 17, 21, 20, 22,
5551  & 17, 22, 21, 20, 22, 19, 12, 19, 12, 1,
5552  & 1, 8, 1, 8, 8, 1, 53, 54, 1, 1,
5553  & 8, 53, 54, 55, 1, 8, 1, 8, 54, 55,
5554  & 56, 1, 8, 8, 55, 56, 8, 1, 53, 54 /
5555  DATA (nzk(k,1),k=171,340) /
5556  & 55, 1, 8, 8, 54, 55, 56, 1, 8, 1,
5557  & 8, 53, 54, 55, 1, 8, 1, 8, 54, 55,
5558  & 56, 1, 8, 1, 8, 1, 8, 17, 21, 22,
5559  & 1, 1, 8, 1, 8, 17, 22, 20, 8, 2,
5560  & 2, 9, 2, 9, 9, 2, 67, 68, 2, 2,
5561  & 9, 67, 68, 69, 2, 9, 2, 9, 68, 69,
5562  & 70, 2, 9, 9, 69, 70, 9, 2, 9, 67,
5563  & 68, 69, 2, 9, 2, 9, 68, 69, 70, 2,
5564  & 9, 1, 8, 13, 13, 14, 1, 8, 1, 1,
5565  & 8, 8, 8, 1, 8, 1, 1, 1, 1, 1,
5566  & 8, 2, 2, 9, 9, 2, 2, 9, 15, 15,
5567  & 24, 16, 16, 25, 25, 15, 15, 24, 24, 16,
5568  & 16, 25, 1, 21, 22, 21, 48, 49, 8, 17,
5569  & 20, 17, 22, 20, 20, 22, 20, 0, 0, 0,
5570  & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
5571  & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
5572  & 31, 31, 13, 7, 15, 12, 13, 31, 17, 17 /
5573  DATA (nzk(k,1),k=341,510) /
5574  & 2, 9, 18, 9, 18, 18, 17, 21, 22, 17,
5575  & 21, 20, 17, 20, 22, 97, 98, 97, 98, 97,
5576  & 98, 17, 18, 99, 100, 18, 101, 99, 18, 101,
5577  & 100, 102, 103, 102, 103, 102, 103, 18, 16, 16,
5578  & 24, 24, 16, 25, 15, 24, 15, 15, 25, 25,
5579  & 31, 15, 15, 31, 16, 16, 23, 13, 7, 116,
5580  & 116, 116, 117, 117, 119, 118, 118, 119, 119, 120,
5581  & 120, 121, 121, 130, 130, 130, 4, 10, 13, 10,
5582  & 4, 32, 13, 36, 11, 3, 34, 14, 38, 133,
5583  & 134, 135, 136, 21, 21, 1, 97, 104, 54, 53,
5584  & 17, 22, 21, 21, 1, 54, 53, 21, 97, 21,
5585  & 97, 22, 21, 97, 98, 105, 137, 137, 137, 138,
5586  & 139, 97, 97, 109, 109, 140, 138, 137, 139, 138,
5587  & 145, 99, 99, 2, 102, 110, 68, 67, 18, 100,
5588  & 99, 99, 2, 68, 67, 99, 102, 99, 102, 100,
5589  & 99, 102, 103, 111, 149, 149, 149, 150, 151, 113,
5590  & 113, 115, 115, 152, 150, 149, 151, 150, 157, 140 /
5591  DATA (nzk(k,1),k=511,540) /
5592  & 141, 142, 143, 144, 145, 146, 147, 148, 138, 145,
5593  & 140, 152, 153, 154, 155, 156, 157, 158, 159, 160,
5594  & 150, 157, 152, 34, 32, 33, 33, 32, 33, 34 /
5595  DATA (nzk(i,1),i=541,602) / 2, 67, 68, 69, 2, 9, 9, 68, 69,
5596  & 70, 2, 9, 33, 32, 13, 14, 189, 32, 34, 23, 23, 189, 33, 34, 14,
5597  & 14, 189, 23, 13, 15, 24, 36, 38, 37, 39, 194, 195, 196, 197,
5598  & 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 1, 8, 1, 1, 54,
5599  & 55, 8, 1, 8, 8, 54, 55, 210/
5600  DATA (nzk(k,2),k= 1,170) /
5601  & 0, 0, 0, 0, 0, 0, 0, 3, 4, 6,
5602  & 5, 23, 14, 11, 3, 5, 5, 5, 23, 13,
5603  & 23, 23, 23, 5, 23, 13, 23, 23, 23, 14,
5604  & 23, 3, 11, 13, 23, 4, 10, 14, 23, 14,
5605  & 23, 13, 7, 7, 4, 7, 7, 23, 14, 14,
5606  & 23, 14, 23, 23, 14, 14, 7, 23, 13, 23,
5607  & 14, 23, 14, 23, 13, 23, 13, 23, 14, 23,
5608  & 14, 23, 13, 23, 13, 23, 13, 33, 32, 35,
5609  & 31, 23, 14, 23, 14, 33, 34, 35, 31, 23,
5610  & 14, 23, 14, 33, 34, 35, 31, 23, 13, 23,
5611  & 13, 33, 32, 35, 31, 13, 13, 23, 23, 14,
5612  & 13, 14, 14, 25, 16, 14, 23, 13, 31, 14,
5613  & 13, 23, 25, 16, 23, 35, 33, 34, 32, 33,
5614  & 31, 31, 14, 13, 23, 0, 0, 0, 0, 13,
5615  & 23, 13, 14, 23, 14, 13, 23, 13, 78, 23,
5616  & 13, 14, 23, 13, 79, 78, 14, 23, 14, 23,
5617  & 13, 80, 79, 14, 14, 23, 80, 31, 14, 23 /
5618  DATA (nzk(k,2),k=171,340) /
5619  & 13, 79, 78, 31, 14, 23, 13, 80, 79, 23,
5620  & 13, 14, 23, 13, 79, 78, 14, 23, 14, 23,
5621  & 13, 80, 79, 23, 13, 33, 32, 15, 24, 15,
5622  & 31, 14, 23, 34, 33, 24, 24, 15, 31, 14,
5623  & 23, 14, 13, 23, 13, 14, 23, 14, 80, 23,
5624  & 14, 13, 23, 14, 79, 80, 13, 23, 13, 23,
5625  & 14, 78, 79, 13, 13, 23, 78, 23, 14, 13,
5626  & 23, 14, 79, 80, 13, 23, 13, 23, 14, 78,
5627  & 79, 62, 61, 23, 14, 23, 13, 13, 13, 23,
5628  & 13, 13, 23, 14, 14, 14, 1, 8, 8, 1,
5629  & 8, 1, 8, 8, 1, 8, 1, 8, 1, 8,
5630  & 1, 1, 8, 1, 8, 8, 1, 1, 8, 8,
5631  & 1, 8, 25, 23, 13, 31, 23, 13, 16, 14,
5632  & 35, 34, 34, 33, 31, 14, 23, 0, 0, 0,
5633  & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
5634  & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
5635  & 13, 23, 14, 7, 16, 19, 14, 7, 23, 14 /
5636  DATA (nzk(k,2),k=341,510) /
5637  & 23, 14, 7, 13, 23, 13, 13, 23, 13, 23,
5638  & 14, 13, 14, 23, 14, 23, 13, 14, 23, 14,
5639  & 23, 16, 14, 23, 14, 23, 14, 13, 13, 23,
5640  & 13, 23, 14, 13, 23, 13, 23, 15, 13, 13,
5641  & 13, 23, 13, 13, 14, 14, 14, 14, 14, 23,
5642  & 13, 16, 25, 14, 15, 24, 23, 14, 7, 23,
5643  & 7, 13, 23, 7, 14, 23, 7, 23, 7, 7,
5644  & 7, 7, 7, 13, 23, 31, 3, 11, 14, 135,
5645  & 5, 134, 134, 134, 136, 6, 133, 133, 133, 0,
5646  & 0, 0, 0, 31, 95, 25, 15, 31, 95, 16,
5647  & 32, 32, 33, 35, 39, 39, 38, 25, 13, 39,
5648  & 32, 39, 38, 35, 32, 39, 13, 23, 14, 7,
5649  & 7, 25, 37, 32, 13, 25, 13, 25, 13, 25,
5650  & 13, 31, 95, 24, 16, 31, 24, 15, 34, 34,
5651  & 33, 35, 37, 37, 36, 24, 14, 37, 34, 37,
5652  & 36, 35, 34, 37, 14, 23, 13, 7, 7, 24,
5653  & 39, 34, 14, 24, 14, 24, 14, 24, 14, 7 /
5654  DATA (nzk(k,2),k=511,540) /
5655  & 7, 7, 7, 7, 7, 7, 7, 7, 25, 13,
5656  & 25, 7, 7, 7, 7, 7, 7, 7, 7, 7,
5657  & 24, 14, 24, 13, 14, 23, 13, 23, 14, 23 /
5658  DATA (nzk(i,2),i=541,602) / 31, 13, 23, 14, 79, 80, 31, 13, 23,
5659  & 14, 78, 79, 13, 23, 23, 13, 13, 14, 13, 23, 13, 23, 14, 23, 23,
5660  & 14, 14, 23, 14, 16, 25,
5661  & 4*23, 14*0, 23, 13, 23, 13, 23, 13, 23, 14,
5662  & 23, 13, 14, 23, 0 /
5663  DATA (nzk(k,3),k= 1,170) /
5664  & 0, 0, 0, 0, 0, 0, 0, 5, 6, 5,
5665  & 6, 23, 23, 5, 5, 0, 0, 0, 0, 14,
5666  & 23, 5, 5, 0, 0, 14, 23, 5, 5, 0,
5667  & 0, 5, 5, 0, 0, 5, 5, 0, 0, 0,
5668  & 0, 0, 0, 0, 3, 0, 7, 23, 23, 7,
5669  & 0, 0, 0, 0, 23, 0, 0, 0, 0, 0,
5670  & 110*0 /
5671  DATA (nzk(k,3),k=171,340) /
5672  & 80*0,
5673  & 0, 0, 0, 0, 0, 0, 23, 13, 14, 23,
5674  & 23, 14, 23, 23, 23, 14, 23, 13, 23, 14,
5675  & 13, 23, 13, 23, 14, 23, 14, 14, 23, 13,
5676  & 13, 23, 13, 14, 23, 23, 14, 23, 13, 23,
5677  & 14, 14, 0, 0, 0, 0, 0, 0, 0, 0,
5678  & 30*0,
5679  & 14, 23, 7, 0, 0, 0, 23, 0, 0, 0 /
5680  DATA (nzk(k,3),k=341,510) /
5681  & 30*0,
5682  & 0, 0, 0, 0, 0, 0, 0, 0, 0, 23,
5683  & 14, 0, 13, 0, 14, 0, 0, 23, 13, 0,
5684  & 0, 15, 0, 0, 16, 0, 0, 0, 0, 0,
5685  & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
5686  & 0, 0, 0, 14, 23, 0, 0, 0, 23, 134,
5687  & 134, 0, 0, 0, 133, 133, 0, 0, 0, 0,
5688  & 80*0 /
5689  DATA (nzk(k,3),k=511,540) /
5690  & 0, 0, 0, 0, 0, 0, 0, 0, 13, 13,
5691  & 25, 0, 0, 0, 0, 0, 0, 0, 0, 0,
5692  & 14, 14, 24, 0, 0, 0, 0, 0, 0, 0 /
5693  DATA (nzk(i,3),i=541,602) / 12*0, 2*0, 23, 13, 0, 2*0, 23, 14, 0,
5694  & 2*0, 23, 13, 0, 4*0, 18*0, 2*0, 23, 14, 2*0, 2*0, 23, 14, 2*0, 0/
5695 *= end.block.blkdt7 *
5696 * *
5697  END
5698 
5699 *
5700 *===xsglau=============================================================*
5701 *
5702  SUBROUTINE xsglau(NA,NB,IJPROJ,NTARG)
5703 
5704 ************************************************************************
5705 * Total, elastic, quasi-elastic, inelastic cross sections according to *
5706 * Glauber's approach. *
5707 * NA / NB mass numbers of proj./target nuclei *
5708 * IJPROJ bamjet-index of projectile (=1 in case of proj.nucleus) *
5709 * ECMI kinematical variables E_cm *
5710 * IE indices of energy
5711 * NTARG index of target nucleus set o NTARG=1 here *
5712 * This version dated 17.3.98 is written by S. Roesler mod by J.R. *
5713 ************************************************************************
5714 
5715  IMPLICIT DOUBLE PRECISION (a-h,o-z)
5716  SAVE
5717  parameter(lout=6,llook=9)
5718 
5719  COMPLEX*16 czero,cone,ctwo
5720  parameter(zero=0.0d0,one=1.0d0,two=2.0d0,three=3.0d0,
5721  & onethi=one/three,tiny25=1.0d-25)
5722  parameter(twopi = 6.283185307179586454d+00,
5723  & pi = twopi/two,
5724  & gev2mb = 0.38938d0,
5725  & gev2fm = 0.1972d0,
5726  & alphem = one/137.0d0,
5727 * proton mass
5728  & amp = 0.938d0,
5729  & amp2 = amp**2,
5730 * approx. nucleon radius
5731  & rnucle = 1.12d0,
5732 * number of bins in b-space
5733  & ksiteb = 200 )
5734 
5735  CHARACTER*8 aname
5736  COMMON /dpar/ aname(210),aam(210),gam(210),tau(210),iich(210),
5737  & iibar(210),ka1(210),ka2(210)
5738 
5739  parameter(ncompx=1,neb=50)
5740  COMMON /dshmm/ rash,rbsh(ncompx),bmax(ncompx),bstep(ncompx),
5741  & sigsh,rosh,gsh,bsite(0:neb,ncompx,ksiteb),
5742  & nstatb,nsiteb
5743  COMMON /glaber/ ecmnn(neb),ecmnow,
5744  & xstot(neb),xsela(neb),
5745  & xsqep(neb),xsqet(neb),
5746  & xsqe2(neb),xspro(neb),
5747  & xetot(neb),xeela(neb),
5748  & xeqep(neb),xeqet(neb),
5749  & xeqe2(neb),xepro(neb),
5750  & bslope,elabb(neb)
5751 
5752  COMMON /vdmpar/ rl2,epspol,intrge(2),idpdf,modega,ishad(3)
5753  COMMON /glapar/ jstatb
5754 
5755  COMPLEX*16 c,ca,ci
5756  COMMON /damp/ ca,ci,ga
5757  COMMON /xsecnu/ecmuu,ecmoo,ngritt,nevtt
5758  COMMON /kglaub/jglaub
5759 
5760  parameter(maxncl = 210)
5761  COMPLEX*16 pp11,pp12,pp21,pp22,
5762  & ompp11,ompp12,ompp21,ompp22
5763  dimension coop1(3,maxncl),coot1(3,maxncl),
5764  & coop2(3,maxncl),coot2(3,maxncl),
5765  & bprod(ksiteb),sigshh(neb),
5766  & sigto(neb),sigel(neb),sigin(neb),sigsd(neb),sigdif(neb)
5767 
5768  jglaub=1
5769  Write(6,*)' XSGLAU(NA,NB,IJPROJ,NTARG)',
5770  &na,nb,ijproj,ntarg
5771  WRITE(6,*)'/XSECNU/ECMUU,ECMOO,NGRITT,NEVTT',
5772  &ecmuu,ecmoo,ngritt,nevtt
5773 
5774  czero = dcmplx(zero,zero)
5775  cone = dcmplx(one,zero)
5776  ctwo = dcmplx(two,zero)
5777 
5778 * re-define kinematics
5779  ec000=ecmuu
5780  dellog=(log10(ecmoo)-log10(ecmuu))/(ngritt-1)
5781  deldel=10.d0**dellog
5782  ec111=ecmuu/deldel
5783  DO 1123 ieee=1,ngritt
5784  ie=ieee
5785  ec111=deldel*ec111
5786  s=ec111**2
5787  ecmnn(ie) = ec111
5788  WRITE(6,*)'IE,EC111,S',ie,ec111,s
5789 
5790 * parameters determining statistics in evaluating Glauber-xsection
5791  jstatb=nevtt
5792  nstatb = jstatb
5793  nsiteb = ksiteb
5794 
5795 * set up interaction geometry (common /DSHM/)
5796 * projectile/target radii
5797  rash = rnucle*dble(na)**onethi
5798  rbsh(ntarg) = rnucle*dble(nb)**onethi
5799  IF(jglaub.EQ.1)THEN
5800  IF(na.EQ.9)rash=2.52d0
5801  IF(na.EQ.10)rash=2.45d0
5802  IF(na.EQ.11)rash=2.37d0
5803  IF(na.EQ.12)rash=2.45d0
5804  IF(na.EQ.13)rash=2.44d0
5805  IF(na.EQ.14)rash=2.55d0
5806  IF(na.EQ.15)rash=2.58d0
5807  IF(na.EQ.16)rash=2.71d0
5808  IF(na.EQ.17)rash=2.66d0
5809  IF(na.EQ.18)rash=2.71d0
5810  IF(nb.EQ.9)rbsh(ntarg)=2.52d0
5811  IF(nb.EQ.10)rbsh(ntarg)=2.45d0
5812  IF(nb.EQ.11)rbsh(ntarg)=2.37d0
5813  IF(nb.EQ.12)rbsh(ntarg)=2.45d0
5814  IF(nb.EQ.13)rbsh(ntarg)=2.44d0
5815  IF(nb.EQ.14)rbsh(ntarg)=2.55d0
5816  IF(nb.EQ.15)rbsh(ntarg)=2.58d0
5817  IF(nb.EQ.16)rbsh(ntarg)=2.71d0
5818  IF(nb.EQ.17)rbsh(ntarg)=2.66d0
5819  IF(nb.EQ.18)rbsh(ntarg)=2.71d0
5820  ENDIF
5821 * maximum impact-parameter
5822  bmax(ntarg) = 4.0d0*(rash+rbsh(ntarg))
5823  bstep(ntarg)= bmax(ntarg)/dble(nsiteb-1)
5824 
5825 * slope, rho ( Re(f(0))/Im(f(0)) )
5826  IF (ijproj.LE.12) THEN
5827  bslope = 8.5d0*(1.0d0+0.065d0*log(s))
5828  IF (ecmnn(ie).LE.3.0d0) THEN
5829  rosh = -0.43d0
5830  ELSEIF ((ecmnn(ie).GT.3.0d0).AND.(ecmnn(ie).LE.50.d0)) THEN
5831  rosh = -0.63d0+0.175d0*log(ecmnn(ie))
5832  ELSEIF (ecmnn(ie).GT.50.0d0) THEN
5833  rosh = 0.1d0
5834  ENDIF
5835  ELSE
5836  bslope = 6.0d0*(1.0d0+0.065d0*log(s))
5837  rosh = 0.01d0
5838  ENDIF
5839 
5840 * projectile-nucleon xsection (in fm)
5841  elab = (s-aam(ijproj)**2-amp2)/(two*amp)
5842  elabb(ie)=elab/1000.
5843  plab = sqrt( (elab-aam(ijproj))*(elab+aam(ijproj)) )
5844 C SIGSH = SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
5845  sigsh = dshpto(ijproj,plab)/10.d0
5846  sigshh(ie)=sigsh*10.d0
5847  WRITE(6,*)' NSTATB,NSITEB,RASH,RBSH(NTARG),BMAX(NTARG),
5848  &BSLOPE,ROSH,SIGSH,ECM ELAB',
5849  & nstatb,nsiteb,rash,rbsh(ntarg),bmax(ntarg),
5850  &bslope,rosh,sigsh,ec111,elab
5851 * initializations
5852  DO 10 i=1,nsiteb
5853  bsite( 0,ntarg,i) = zero
5854  bsite(ie,ntarg,i) = zero
5855  bprod(i) = zero
5856  10 CONTINUE
5857  stot = zero
5858  stot2 = zero
5859  sela = zero
5860  sela2 = zero
5861  sqep = zero
5862  sqep2 = zero
5863  sqet = zero
5864  sqet2 = zero
5865  sqe2 = zero
5866  sqe22 = zero
5867  spro = zero
5868  spro2 = zero
5869  facn = one/dble(nstatb)
5870 
5871  ipnt = 0
5872  rpnt = zero
5873 
5874 C------------------------------------------------------
5875 
5876 * cross sections averaged over NSTATB nucleon configurations
5877  DO 11 is=1,nstatb
5878  stotn = zero
5879  selan = zero
5880  sqepn = zero
5881  sqetn = zero
5882  sqe2n = zero
5883  spron = zero
5884  CALL conuclx(coop1,na,rash,0)
5885  CALL conuclx(coot1,nb,rbsh(ntarg),1)
5886  CALL conuclx(coop2,na,rash,0)
5887  CALL conuclx(coot2,nb,rbsh(ntarg),1)
5888 
5889 * integration over impact parameter B
5890  DO 12 ib=1,nsiteb-1
5891  stotb = zero
5892  selab = zero
5893  sqepb = zero
5894  sqetb = zero
5895  sqe2b = zero
5896  sprob = zero
5897  sdir = zero
5898  b = dble(ib)*bstep(ntarg)
5899  facb = 10.0d0*twopi*b*bstep(ntarg)
5900 
5901 * integration over M_V^2 for photon-proj.
5902 C DO 14 IM=1,JPOINT
5903  pp11 = cone
5904  pp12 = cone
5905  pp21 = cone
5906  pp22 = cone
5907  shi = zero
5908  facm = one
5909  dcoh = 1.0d10
5910 
5911 C------------------------------------------------------------
5912 
5913  gsh = 10.0d0/(two*bslope*gev2mb)
5914 * common /DAMP/
5915  ga = gsh
5916  rca = ga*sigsh/twopi
5917  fca = -rosh*rca
5918  ca = dcmplx(rca,fca)
5919  ci = cone
5920 
5921  DO 15 ina=1,na
5922  kk1 = 1
5923  kk2 = 1
5924  DO 16 inb=1,nb
5925 
5926  x11 = b+coot1(1,inb)-coop1(1,ina)
5927  y11 = coot1(2,inb)-coop1(2,ina)
5928  xy11 = ga*(x11*x11+y11*y11)
5929  x12 = b+coot2(1,inb)-coop1(1,ina)
5930  y12 = coot2(2,inb)-coop1(2,ina)
5931  xy12 = ga*(x12*x12+y12*y12)
5932  x21 = b+coot1(1,inb)-coop2(1,ina)
5933  y21 = coot1(2,inb)-coop2(2,ina)
5934  xy21 = ga*(x21*x21+y21*y21)
5935  x22 = b+coot2(1,inb)-coop2(1,ina)
5936  y22 = coot2(2,inb)-coop2(2,ina)
5937  xy22 = ga*(x22*x22+y22*y22)
5938  IF (xy11.LE.15.0d0) THEN
5939  c = cone-ca*exp(-xy11)
5940  ar = dble(pp11)
5941  ai = dimag(pp11)
5942  IF (abs(ar).LT.tiny25) ar = zero
5943  IF (abs(ai).LT.tiny25) ai = zero
5944  pp11 = dcmplx(ar,ai)
5945  pp11 = pp11*c
5946  ar = dble(c)
5947  ai = dimag(c)
5948  shi = shi+log(ar*ar+ai*ai)
5949  ENDIF
5950  IF (xy12.LE.15.0d0) THEN
5951  c = cone-ca*exp(-xy12)
5952  ar = dble(pp12)
5953  ai = dimag(pp12)
5954  IF (abs(ar).LT.tiny25) ar = zero
5955  IF (abs(ai).LT.tiny25) ai = zero
5956  pp12 = dcmplx(ar,ai)
5957  pp12 = pp12*c
5958  ENDIF
5959  IF (xy21.LE.15.0d0) THEN
5960  c = cone-ca*exp(-xy21)
5961  ar = dble(pp21)
5962  ai = dimag(pp21)
5963  IF (abs(ar).LT.tiny25) ar = zero
5964  IF (abs(ai).LT.tiny25) ai = zero
5965  pp21 = dcmplx(ar,ai)
5966  pp21 = pp21*c
5967  ENDIF
5968  IF (xy22.LE.15.0d0) THEN
5969  c = cone-ca*exp(-xy22)
5970  ar = dble(pp22)
5971  ai = dimag(pp22)
5972  IF (abs(ar).LT.tiny25) ar = zero
5973  IF (abs(ai).LT.tiny25) ai = zero
5974  pp22 = dcmplx(ar,ai)
5975  pp22 = pp22*c
5976  ENDIF
5977  16 CONTINUE
5978  15 CONTINUE
5979 
5980  ompp11 = czero
5981  ompp21 = czero
5982  ompp11 = ompp11+(cone-pp11)
5983  ompp21 = ompp21+(cone-pp21)
5984  ompp12 = czero
5985  ompp22 = czero
5986  ompp12 = ompp12+(cone-pp12)
5987  ompp22 = ompp22+(cone-pp22)
5988 
5989  stotm = dble(ompp11+ompp22)
5990  selam = dble(ompp11*dconjg(ompp22))
5991  sprom = one-exp(shi)
5992  sqepm = dble(ompp11*dconjg(ompp21))-selam
5993  sqetm = dble(ompp11*dconjg(ompp12))-selam
5994  sqe2m = dble(ompp11*dconjg(ompp11))-selam-sqepm-sqetm
5995 
5996  stotb = stotb+facm*stotm
5997  selab = selab+facm*selam
5998  IF (nb.GT.1) sqepb = sqepb+facm*sqepm
5999  IF (na.GT.1) sqetb = sqetb+facm*sqetm
6000  IF ((na.GT.1).AND.(nb.GT.1)) sqe2b = sqe2b+facm*sqe2m
6001  sprob = sprob+facm*sprom
6002 
6003 C 14 CONTINUE
6004 
6005  stotn = stotn+facb*stotb
6006  selan = selan+facb*selab
6007  sqepn = sqepn+facb*sqepb
6008  sqetn = sqetn+facb*sqetb
6009  sqe2n = sqe2n+facb*sqe2b
6010  spron = spron+facb*sprob
6011  bprod(ib+1)= bprod(ib+1)+facn*facb*sprob
6012 
6013  12 CONTINUE
6014 
6015  stot = stot +facn*stotn
6016  stot2 = stot2+facn*stotn**2
6017  sela = sela +facn*selan
6018  sela2 = sela2+facn*selan**2
6019  sqep = sqep +facn*sqepn
6020  sqep2 = sqep2+facn*sqepn**2
6021  sqet = sqet +facn*sqetn
6022  sqet2 = sqet2+facn*sqetn**2
6023  sqe2 = sqe2 +facn*sqe2n
6024  sqe22 = sqe22+facn*sqe2n**2
6025  spro = spro +facn*spron
6026  spro2 = spro2+facn*spron**2
6027 
6028  11 CONTINUE
6029 
6030 * final cross sections
6031 * 1) total
6032  xstot(ie) = stot
6033 * 2) elastic
6034  xsela(ie) = sela
6035 * 3) quasi-el.: A+B-->A+X (excluding 2)
6036  xsqep(ie) = sqep
6037 * 4) quasi-el.: A+B-->X+B (excluding 2)
6038  xsqet(ie) = sqet
6039 * 5) quasi-el.: A+B-->X (excluding 2-4)
6040  xsqe2(ie) = sqe2
6041 * 6) production (= STOT-SELA-SQEP-SQET-SQE2!)
6042  xspro(ie) = spro
6043  WRITE(6,*)' STOT,SELA ,SQEP,SQET,SQE2,SPRO ',
6044  & stot,sela ,sqep,sqet,sqe2,spro
6045 * stat. errors
6046  xetot(ie) = sqrt(abs(stot2-stot**2)/dble(nstatb-1))
6047  xeela(ie) = sqrt(abs(sela2-sela**2)/dble(nstatb-1))
6048  xeqep(ie) = sqrt(abs(sqep2-sqep**2)/dble(nstatb-1))
6049  xeqet(ie) = sqrt(abs(sqet2-sqet**2)/dble(nstatb-1))
6050  xeqe2(ie) = sqrt(abs(sqe22-sqe2**2)/dble(nstatb-1))
6051  xepro(ie) = sqrt(abs(spro2-spro**2)/dble(nstatb-1))
6052  WRITE(6,*)' XETOT,XEELA,XEQEP,XEQET,XEQE2,XEPRO ',
6053  & xetot(ie),xeela(ie),xeqep(ie),
6054  &xeqet(ie),xeqe2(ie),xepro(ie)
6055 1123 CONTINUE
6056  DO 19 i=2,nsiteb
6057  bsite(ie,ntarg,i) = bprod(i)/spro+bsite(ie,ntarg,i-1)
6058  IF (ie.EQ.1)
6059  & bsite(0,ntarg,i) = bprod(i)/spro+bsite(0,ntarg,i-1)
6060  19 CONTINUE
6061  WRITE (6,*)' ECMNN,ELABB,SIGSHH,SIGTO,SIGEL,SIGIN,SIGSD'
6062 C & SIGTO(NEB),SIGEL(NEB),SIGIN(NEB),SIGSD(NEB),SIGDIF(NEB)
6063  DO 129 i=1,ngritt
6064  sigto(i)=dshnto(1,1,ecmnn(i))
6065  sigel(i)=dshnel(1,1,ecmnn(i))
6066  sigin(i)=siinel(1,1,ecmnn(i))
6067  sigsd(i)=sippsd(ecmnn(i))
6068  CALL sihndi(ecmnn(i),1,1,sigdif(i),sigdih)
6069  WRITE (6,'(2F18.4,6F11.3)')ecmnn(i),elabb(i),sigshh(i),
6070  & sigto(i),sigel(i),sigin(i),sigsd(i),sigdif(i)
6071  129 CONTINUE
6072  WRITE (6,*)' ECMNN,ELABB,XSQEP,XEQEP,XSQET,XEQET,XSQE2,XEQE2'
6073  DO 139 i=1,ngritt
6074  WRITE (6,'(2F18.4,6F11.3)')ecmnn(i),elabb(i),xsqep(i),xeqep(i),
6075  * xsqet(i),xeqet(i),xsqe2(i),xeqe2(i)
6076  139 CONTINUE
6077  WRITE (6,*)' ECMNN,ELABB,XSTOT,XETOT,XSELA,XEELA,XSPRO,XEPRO'
6078  DO 119 i=1,ngritt
6079  WRITE (6,'(2F18.4,6F11.3)')ecmnn(i),elabb(i),xstot(i),xetot(i),
6080  * xsela(i),xeela(i),xspro(i),xepro(i)
6081  119 CONTINUE
6082 
6083  RETURN
6084  END
6085 
6086 
6087  SUBROUTINE conuclx(COOP1,NA,RASH,I)
6088  IMPLICIT DOUBLE PRECISION (a-h,o-z)
6089  SAVE
6090  parameter(maxncl = 210)
6091  dimension coop1(3,maxncl)
6092  CALL conucl(coop1,na,rash)
6093  RETURN
6094  END
6095 *-- Author :
6096 C
6097 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6098 C
6099  SUBROUTINE dbklas(I,J,K,I8,I10)
6100  IMPLICIT DOUBLE PRECISION (a-h,o-z)
6101  SAVE
6102 C*** I,J,K QUARK FLAVOURS U,D,S,C=1,2,3,4
6103 C*** AQ = -Q
6104 C*** I8,I10 BARYON INDICES
6105 *KEEP,DINPDA.
6106  COMMON /dinpda/ imps(6,6),imve(6,6),ib08(6,21),ib10(6,21), ia08
6107  +(6,21),ia10(6,21), a1,b1,b2,b3,lt,le,bet,as,b8,ame,diq,isu
6108 *KEND.
6109  IF (i) 20,20,10
6110 C*** BARYON
6111  10 CONTINUE
6112  CALL indexd(j,k,ind)
6113  i8=ib08(i,ind)
6114  i10=ib10(i,ind)
6115  IF (i8.LE.0) i8=i10
6116  RETURN
6117  20 CONTINUE
6118 C*** ANTIBARYONS
6119  ii=iabs(i)
6120  jj=iabs(j)
6121  kk=iabs(k)
6122  CALL indexd(jj,kk,ind)
6123  i8=ia08(ii,ind)
6124  i10=ia10(ii,ind)
6125  IF (i8.LE.0) i8=i10
6126  RETURN
6127  END
6128 C-----------------------------------------------------------
6129 
6130  DOUBLE PRECISION FUNCTION sippsd(ECM)
6131  IMPLICIT DOUBLE PRECISION (a-h,o-z)
6132 C Single Diffraction cross section in p-p collision
6133 C Tables calculated with DPMJET-II.4.2
6134  dimension ec(30),sd(30)
6135  DATA ec /0.d0, 5.d0, 20.d0, 50.d0, 100.d0,
6136  * 200.d0, 500.d0, 1000.d0, 1500.d0, 2000.d0,
6137  * 3000.d0, 4000.d0, 6000.d0, 8000.d0, 10000.d0,
6138  * 15000.d0, 20000.d0, 30000.d0, 40000.d0, 60000.d0,
6139  * 80000.d0, 100000.d0, 150000.d0, 200000.d0, 300000.d0,
6140  * 400000.d0, 600000.d0, 800000.d0, 1000000.d0, 2000000.d0/
6141  DATA sd /0.d0, 0.d0, 5.00d0, 6.14d0, 6.93d0,
6142  * 7.64d0, 8.43d0, 8.87d0, 9.07d0, 9.17d0,
6143  * 9.33d0, 9.40d0, 9.49d0, 9.56d0, 9.58d0,
6144  * 9.69d0, 9.72d0, 9.82d0, 9.85d0, 9.97d0,
6145  * 10.02d0, 10.03d0, 10.13d0, 10.16d0, 10.25d0,
6146  * 10.28d0, 10.39d0, 10.42d0, 10.43d0, 10.53d0/
6147  ii=1
6148  DO 1 i=1,29
6149  IF((ecm.GE.ec(i)).AND.(ecm.LT.ec(i+1)))THEN
6150  ii=i
6151  del=(ecm-ec(i))*(sd(i+1)-sd(i))/(ec(i+1)-ec(i))
6152  sippsd=sd(i)+del
6153  RETURN
6154  ENDIF
6155  1 CONTINUE
6156  sippsd=0.d0
6157  RETURN
6158  END
6159  DOUBLE PRECISION FUNCTION siinel(KPROJ,KTARG,UMO)
6160  IMPLICIT DOUBLE PRECISION (a-h,o-z)
6161 C Inelastic cross section
6162  siinel=dshnto(kproj,ktarg,umo)-dshnel(kproj,ktarg,umo)
6163  RETURN
6164  END
6165 C---------------------------------------------------------------
6166 C was dpmsicha.f
6167 C---------------------------------------------------------------
6168 *$ CREATE PHNSCH.FOR
6169 *COPY PHNSCH
6170 *
6171 *=== phnsch ===========================================================*
6172 *
6173  DOUBLE PRECISION FUNCTION phnsch ( KP, KTARG, PLAB )
6174 
6175 C INCLUDE '(DBLPRC)'
6176 C INCLUDE '(DIMPAR)'
6177 C INCLUDE '(IOUNIT)'
6178 *
6179 *----------------------------------------------------------------------*
6180 * *
6181 * Probability for Hadron Nucleon Single CHain interactions: *
6182 * *
6183 * Created on 30 december 1993 by Alfredo Ferrari & Paola Sala *
6184 * Infn - Milan *
6185 * *
6186 * Last change on 04-jan-94 by Alfredo Ferrari *
6187 * *
6188 * modified by J.R.for use in DTUNUC 6.1.94 *
6189 * *
6190 * Input variables: *
6191 * Kp = hadron projectile index (Part numbering *
6192 * scheme) *
6193 * Ktarg = target nucleon index (1=proton, 8=neutron) *
6194 * Plab = projectile laboratory momentum (GeV/c) *
6195 * Output variable: *
6196 * Phnsch = probability per single chain (particle *
6197 * exchange) interactions *
6198 * *
6199 *----------------------------------------------------------------------*
6200 *
6201 C INCLUDE '(PAPROP)'
6202 C INCLUDE '(PART2)'
6203 C INCLUDE '(QQUARK)'
6204 
6205 *$ CREATE DBLPRC.ADD
6206 *COPY DBLPRC
6207 * *
6208 *=== dblprc ==========================================================*
6209 * *
6210 *---------------------------------------------------------------------*
6211 * *
6212 * Dblprc: included in any routine *
6213 * *
6214 * !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
6215 * !!!! O N M A C H I N E S W H E R E T H E D O U B L E !!!! *
6216 * !!!! P R E C I S I O N I S N O T R E Q U I R E D R E -!!!! *
6217 * !!!! M O V E T H E D O U B L E P R E C I S I O N !!!! *
6218 * !!!! S T A T E M E N T, S E T K A L G N M = 1 A N D !!!! *
6219 * !!!! C H A N G E A L L N U M E R I C A L C O N S - !!!! *
6220 * !!!! T A N T S T O S I N G L E P R E C I S I O N !!!! *
6221 * !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
6222 * *
6223 * Kalgnm = real address alignment, 2 for double precision, *
6224 * 1 for single precision *
6225 * Anglgb = this parameter should be set equal to the machine *
6226 * "zero" with respect to unit *
6227 * Anglsq = this parameter should be set equal to the square *
6228 * of Anglgb *
6229 * Axcssv = this parameter should be set equal to the number *
6230 * for which unity is negligible for the machine *
6231 * accuracy *
6232 * Andrfl = "underflow" of the machine for floating point *
6233 * operation *
6234 * Avrflw = "overflow" of the machine for floating point *
6235 * operation *
6236 * Ainfnt = code "infinite" *
6237 * Azrzrz = code "zero" *
6238 * Einfnt = natural logarithm of the code "infinite" *
6239 * Ezrzrz = natural logarithm of the code "zero" *
6240 * Onemns = 1- of the machine, it is 1 - 2 x Anglgb *
6241 * Onepls = 1+ of the machine, it is 1 + 2 x Anglgb *
6242 * Csnnrm = maximum tolerable error on cosine normalization, *
6243 * u**2+v**2+w**2: assuming a typical anglgb relative *
6244 * error on each component we would get 2xanglgb: use *
6245 * 4xanglgb to avoid too many normalizations *
6246 * Dmxtrn = "infinite" distance for transport (cm) *
6247 * *
6248 *---------------------------------------------------------------------*
6249 * *
6250  IMPLICIT DOUBLE PRECISION (a-h,o-z)
6251  parameter( kalgnm = 2 )
6252  parameter( anglgb = 5.0d-16 )
6253  parameter( anglsq = 2.5d-31 )
6254  parameter( axcssv = 0.2d+16 )
6255  parameter( andrfl = 1.0d-38 )
6256  parameter( avrflw = 1.0d+38 )
6257  parameter( ainfnt = 1.0d+30 )
6258  parameter( azrzrz = 1.0d-30 )
6259  parameter( einfnt = +69.07755278982137 d+00 )
6260  parameter( ezrzrz = -69.07755278982137 d+00 )
6261  parameter( onemns = 0.999999999999999 d+00 )
6262  parameter( onepls = 1.000000000000001 d+00 )
6263  parameter( csnnrm = 2.0d-15 )
6264  parameter( dmxtrn = 1.0d+08 )
6265 *
6266 *======================================================================*
6267 *======================================================================*
6268 *========= ==========*
6269 *========= M A T H E M A T I C A L C O N S T A N T S ==========*
6270 *========= ==========*
6271 *======================================================================*
6272 *======================================================================*
6273 * *
6274 * Numerical constants: *
6275 * *
6276 * Zerzer = 0 *
6277 * Oneone = 1 *
6278 * Twotwo = 2 *
6279 * Thrthr = 3 *
6280 * Foufou = 4 *
6281 * Fivfiv = 5 *
6282 * Sixsix = 6 *
6283 * Sevsev = 7 *
6284 * Eigeig = 8 *
6285 * Aninen = 9 *
6286 * Tenten = 10 *
6287 * Hlfhlf = 1/2 *
6288 * Onethi = 1/3 *
6289 * Twothi = 2/3 *
6290 * Pipipi = Circumference / diameter *
6291 * Eneper = "e", base of natural logarithm *
6292 * Sqrent = square root of "e" *
6293 * *
6294 *----------------------------------------------------------------------*
6295 *
6296  parameter( zerzer = 0.d+00 )
6297  parameter( oneone = 1.d+00 )
6298  parameter( twotwo = 2.d+00 )
6299  parameter( thrthr = 3.d+00 )
6300  parameter( foufou = 4.d+00 )
6301  parameter( fivfiv = 5.d+00 )
6302  parameter( sixsix = 6.d+00 )
6303  parameter( sevsev = 7.d+00 )
6304  parameter( eigeig = 8.d+00 )
6305  parameter( aninen = 9.d+00 )
6306  parameter( tenten = 10.d+00 )
6307  parameter( hlfhlf = 0.5d+00 )
6308  parameter( onethi = oneone / thrthr )
6309  parameter( twothi = twotwo / thrthr )
6310  parameter( pipipi = 3.1415926535897932270 d+00 )
6311  parameter( eneper = 2.7182818284590452354 d+00 )
6312  parameter( sqrent = 1.6487212707001281468 d+00 )
6313 *
6314 *======================================================================*
6315 *======================================================================*
6316 *========= ==========*
6317 *========= P H Y S I C A L C O N S T A N T S ==========*
6318 *========= ==========*
6319 *======================================================================*
6320 *======================================================================*
6321 * *
6322 * Primary constants: *
6323 * *
6324 * Clight = speed of light in cm s-1 *
6325 * Avogad = Avogadro number *
6326 * Amelgr = electron mass (g) *
6327 * Plckbr = reduced Planck constant (erg s) *
6328 * Elccgs = elementary charge (CGS unit) *
6329 * Elcmks = elementary charge (MKS unit) *
6330 * Amugrm = Atomic mass unit (g) *
6331 * Ammumu = Muon mass (amu) *
6332 * *
6333 * Derived constants: *
6334 * *
6335 * Alpfsc = Fine structure constant = e^2/(hbar c) *
6336 * Amelct = Electron mass (GeV) = 10^-16Amelgr Clight^2 / Elcmks*
6337 * Amugev = Atomic mass unit (GeV) = 10^-16Amelgr Clight^2 *
6338 * / Elcmks *
6339 * Ammuon = Muon mass (GeV) = Ammumu * Amugev *
6340 * Fscto2 = (Fine structure constant)^2 *
6341 * Fscto3 = (Fine structure constant)^3 *
6342 * Fscto4 = (Fine structure constant)^4 *
6343 * Plabrc = Reduced Planck constant times the light velocity *
6344 * expressed in GeV fm *
6345 * Rclsel = Classical electron radius (cm) = e^2 / (m_e c^2) *
6346 * Conversion constants: *
6347 * GeVMeV = from GeV to MeV *
6348 * eMVGeV = from MeV to GeV *
6349 * Raddeg = from radians to degrees *
6350 * Degrad = from degrees to radians *
6351 * *
6352 *----------------------------------------------------------------------*
6353 *
6354  parameter( clight = 2.99792458 d+10 )
6355  parameter( avogad = 6.0221367 d+23 )
6356  parameter( amelgr = 9.1093897 d-28 )
6357  parameter( plckbr = 1.05457266 d-27 )
6358  parameter( elccgs = 4.8032068 d-10 )
6359  parameter( elcmks = 1.60217733 d-19 )
6360  parameter( amugrm = 1.6605402 d-24 )
6361  parameter( ammumu = 0.113428913 d+00 )
6362 * PARAMETER ( ALPFSC = 1.D+00 / 137.035989561D+00 )
6363 * PARAMETER ( FSCTO2 = ALPFSC * ALPFSC )
6364 * PARAMETER ( FSCTO3 = FSCTO2 * ALPFSC )
6365 * PARAMETER ( FSCTO4 = FSCTO3 * ALPFSC )
6366 * It is important to set the electron mass exactly with the same
6367 * rounding as in the mass tables, so use the explicit expression
6368 * PARAMETER ( AMELCT = 1.D-16 * AMELGR * CLIGHT * CLIGHT / ELCMKS )
6369 * It is important to set the amu mass exactly with the same
6370 * rounding as in the mass tables, so use the explicit expression
6371 * PARAMETER ( AMUGEV = 1.D-16 * AMUGRM * CLIGHT * CLIGHT / ELCMKS )
6372 * It is important to set the muon mass exactly with the same
6373 * rounding as in the mass tables, so use the explicit expression
6374 * PARAMETER ( AMMUON = AMMUMU * AMUGEV ELCMKS )
6375 * PARAMETER ( RCLSEL = ELCCGS * ELCCGS / CLIGHT / CLIGHT / AMELGR )
6376  parameter( alpfsc = 7.2973530791728595 d-03 )
6377  parameter( fscto2 = 5.3251361962113614 d-05 )
6378  parameter( fscto3 = 3.8859399018437826 d-07 )
6379  parameter( fscto4 = 2.8357075508200407 d-09 )
6380  parameter( plabrc = 0.197327053 d+00 )
6381  parameter( amelct = 0.51099906 d-03 )
6382  parameter( amugev = 0.93149432 d+00 )
6383  parameter( ammuon = 0.105658389 d+00 )
6384  parameter( rclsel = 2.8179409183694872 d-13 )
6385  parameter( gevmev = 1.0 d+03 )
6386  parameter( emvgev = 1.0 d-03 )
6387  parameter( raddeg = 180.d+00 / pipipi )
6388  parameter( degrad = pipipi / 180.d+00 )
6389 
6390 
6391 *$ CREATE DIMPAR.ADD
6392 *COPY DIMPAR
6393 * *
6394 *=== dimpar ==========================================================*
6395 * *
6396 *---------------------------------------------------------------------*
6397 * *
6398 * DIMPAR: included in any routine *
6399 * *
6400 * Mxxrgn = maximum number of regions *
6401 * Mxxmdf = maximum number of media in Fluka *
6402 * Mxxmde = maximum number of media in Emf *
6403 * Mfstck = stack dimension in Fluka *
6404 * Mestck = stack dimension in Emf *
6405 * Nallwp = number of allowed particles *
6406 * Mpdpdx = number of particle types for which EM dE/dx pro- *
6407 * cesses (ion,pair,bremss) have to be computed *
6408 * Icomax = maximum number of materials for compounds (equal *
6409 * to the sum of the number of materials for every *
6410 * compound ) *
6411 * Nstbis = number of stable isotopes recorded in common iso- *
6412 * top *
6413 * Idmaxp = number of particles/resonances defined in common *
6414 * part *
6415 * *
6416 *---------------------------------------------------------------------*
6417 * *
6418  parameter( mxxrgn = 500 )
6419  parameter( mxxmdf = 56 )
6420  parameter( mxxmde = 50 )
6421  parameter( mfstck = 1000 )
6422  parameter( mestck = 100 )
6423  parameter( nallwp = 39 )
6424  parameter( mpdpdx = 8 )
6425  parameter( icomax = 180 )
6426  parameter( nstbis = 304 )
6427  parameter( idmaxp = 210 )
6428 
6429 
6430 
6431 *$ CREATE IOUNIT.ADD
6432 *COPY IOUNIT
6433 * *
6434 *=== iounit ==========================================================*
6435 * *
6436 *---------------------------------------------------------------------*
6437 * *
6438 * Iounit: included in any routine *
6439 * *
6440 * lunin = standard input unit *
6441 * lunout = standard output unit *
6442 * lunerr = standard error unit *
6443 * lunber = input file for bertini nuclear data *
6444 * lunech = echo file for pegs dat *
6445 * lunflu = input file for photoelectric edges and X-ray fluo- *
6446 * rescence data *
6447 * lungeo = scratch file for combinatorial geometry *
6448 * lunpgs = input file for pegs material data *
6449 * lunran = output file for the final random number seed *
6450 * lunxsc = input file for low energy neutron cross sections *
6451 * lunrdb = unit number for reading (extra) auxiliary external *
6452 * files to be closed just after reading *
6453 * *
6454 *---------------------------------------------------------------------*
6455 * *
6456  parameter( lunin = 5 )
6457  parameter( lunout = 6 )
6458  parameter( lunerr = 66 )
6459  parameter( lunber = 14 )
6460  parameter( lunech = 8 )
6461  parameter( lunflu = 86 )
6462  parameter( lungeo = 16 )
6463  parameter( lunpgs = 12 )
6464  parameter( lunran = 2 )
6465  parameter( lunxsc = 81 )
6466  parameter( lunrdb = 1 )
6467 
6468 
6469 *$ CREATE PAPROP.ADD
6470 *COPY PAPROP
6471 *
6472 *=== paprop ===========================================================*
6473 *
6474 *----------------------------------------------------------------------*
6475 * include file: paprop copy created 26/11/86 by p*
6476 * changes: on 16 december 1992 by Alfredo Ferrari *
6477 * included in the following subroutines or functions: not updated *
6478 * *
6479 * description of the common block(s) and variable(s) *
6480 * *
6481 * /paprop/ contains particle properties *
6482 * btype = literal name of the particle *
6483 * am = particle mass in gev *
6484 * ichrge = electric charge of the particle *
6485 * iscore = explanations for the scored distribution *
6486 * genpar = names of the generalized particles *
6487 * ijdisc = list of the particle types to be discarded *
6488 * thalf = half life of the particle in sec *
6489 * biasdc = decay biasing factors *
6490 * biasin = inelastic interaction biasing factors *
6491 * lhadro = flag for hadrons *
6492 * jspinp = particle spin (in units of 1/2) *
6493 * lbsdcy = logical flag for biased decay: if .true. the biasing *
6494 * factor is used as an upper limit to the decay length *
6495 * lprbsd = logical flag for biased decay: if .true. the biasing *
6496 * factor is applied only to primaries *
6497 * lprbsi = logical flag for inelastic interaction biasing: if *
6498 * .true. the biasing factor is applied only to prima- *
6499 * ries *
6500 * *
6501 *----------------------------------------------------------------------*
6502 *
6503 C LOGICAL LHADRO, LBSDCY, LPRBSD, LPRBSI
6504 C CHARACTER*8 BTYPE,GENPAR
6505 C COMMON / PAPROP / AM (NALLWP), AMDISC (NALLWP), THALF (NALLWP),
6506 C & BIASDC (NALLWP), BIASIN (NALLWP), ICHRGE (NALLWP),
6507 C & ISCORE (10), IJDISC (NALLWP), LHADRO (NALLWP),
6508 C & JSPINP (NALLWP), LBSDCY (NALLWP), LPRBSD, LPRBSI
6509 C COMMON / CHPPRP / BTYPE (NALLWP), GENPAR (30)
6510 
6511  dimension ichrge(39),am(39)
6512 
6513 *$ CREATE PART2.ADD
6514 *COPY PART2
6515 *
6516 *=== part2 ============================================================*
6517 *
6518 *----------------------------------------------------------------------*
6519 * Include file: part2 copy Revised on 20-7-90 by A. Ferrari *
6520 * Note: see also part copy and part3 copy *
6521 * Changes: none *
6522 * Included in the following subroutines or functions: not updated *
6523 * *
6524 * Description of the common block(s) and variable(s) *
6525 * *
6526 * Kptoip = conversion from part to paprop numbering *
6527 * Iptokp = conversion from paprop to part numbering *
6528 * *
6529 *----------------------------------------------------------------------*
6530 *
6531 C CHARACTER*8 ANAME
6532 C COMMON / PART / AAM (IDMAXP), GA (IDMAXP), TAU (IDMAXP),
6533 C & AAMDSC (IDMAXP), ZMNABS (IDMAXP), ATNMNA (IDMAXP),
6534 C & IICH (IDMAXP), IIBAR (IDMAXP), K1 (IDMAXP),
6535 C & K2 (IDMAXP), KPTOIP (IDMAXP), IPTOKP (NALLWP)
6536 C COMMON / CHPART / ANAME (IDMAXP)
6537 
6538 *KEEP,DPAR.
6539 C /DPAR/ CONTAINS PARTICLE PROPERTIES
6540 C ANAME = LITERAL NAME OF THE PARTICLE
6541 C AAM = PARTICLE MASS IN GEV
6542 C GA = DECAY WIDTH
6543 C TAU = LIFE TIME OF INSTABLE PARTICLES
6544 C IICH = ELECTRIC CHARGE OF THE PARTICLE
6545 C IIBAR = BARYON NUMBER
6546 C K1,K1 = BIGIN AND END OF DECAY CHANNELS OF PARTICLE
6547 C
6548  CHARACTER*8 aname
6549  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),
6550  + iich(210),iibar(210),k1(210),k2(210)
6551  dimension kptoip(210),iptokp(39)
6552 C DATA KPTOIP/1, 2, 3, 4, 5, 6, 7, 8, 9, 10,
6553 C + 11,12,13,14,15,16,17,18,19,20,
6554 C + 21,22,23,24,25, 0, 0, 0, 0, 0,
6555 C + 60*0,
6556 C + 0, 0, 0, 0, 0, 0,34,36,31,32,
6557 C + 33,35,37, 0, 0, 0, 0, 0,38, 0,
6558 C + 0, 0, 0, 0,39, 0, 0, 0, 0, 0,
6559 C + 90*0/
6560 C DATA IPTOKP/1, 2, 3, 4, 5, 6, 7, 8, 9, 10,
6561 C + 11,12,13,14,15,16,17,18,19,20,
6562 C + 21,22,23,24,25, 0, 0, 0, 0, 0,
6563 C + 99,100,101,97,102,98,103,109,115/
6564 * *
6565 * Conversion from part to paprop numbering *
6566 * *
6567  DATA kptoip / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
6568  & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 66*0,
6569  & 34, 36, 31, 32, 33, 35, 37, 5*0, 38, 5*0, 39, 19*0, 27, 28, 74*0/
6570 * *
6571 * Conversion from paprop to part numbering *
6572 * *
6573  DATA iptokp / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
6574  & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 99,
6575  & 100, 101, 97, 102, 98, 103, 109, 115 /
6576 
6577 
6578 *$ CREATE QQUARK.ADD
6579 *COPY QQUARK
6580 *
6581 *=== qquark ===========================================================*
6582 *
6583 *----------------------------------------------------------------------*
6584 * *
6585 * Created on 6 february 1991 by Alfredo Ferrari *
6586 * INFN - Milan *
6587 * *
6588 * Last change on 6 february 1991 by Alfredo Ferrari *
6589 * *
6590 * Included in the following routines : *
6591 * *
6592 * COREVT *
6593 * CORRIN *
6594 * HADEVV *
6595 * HADEVT *
6596 * NUCEVV *
6597 * NUCEVT *
6598 * *
6599 * Quark content of particles: *
6600 * index quark el. charge bar. charge isospin isospin3 *
6601 * 1 = u 2/3 1/3 1/2 1/2 *
6602 * -1 = ubar -2/3 -1/3 1/2 -1/2 *
6603 * 2 = d -1/3 1/3 1/2 -1/2 *
6604 * -2 = dbar 1/3 -1/3 1/2 1/2 *
6605 * 3 = s -1/3 1/3 0 0 *
6606 * -3 = sbar 1/3 -1/3 0 0 *
6607 * 4 = c 2/3 1/3 0 0 *
6608 * -4 = cbar -2/3 -1/3 0 0 *
6609 * 5 = b -1/3 1/3 0 0 *
6610 * -5 = bbar 1/3 -1/3 0 0 *
6611 * 6 = t 2/3 1/3 0 0 *
6612 * -6 = tbar -2/3 -1/3 0 0 *
6613 * *
6614 * Mquark = particle quark composition (Paprop numbering) *
6615 * Iqechr = electric charge ( in 1/3 unit ) *
6616 * Iqbchr = baryonic charge ( in 1/3 unit ) *
6617 * Iqichr = isospin ( in 1/2 unit ), z component *
6618 * Iqschr = strangeness *
6619 * Iqcchr = charm *
6620 * Iquchr = beauty *
6621 * Iqtchr = ...... *
6622 * *
6623 *----------------------------------------------------------------------*
6624 *
6625  COMMON / qquark / iqechr(-6:6), iqbchr(-6:6), iqichr(-6:6),
6626  & iqschr(-6:6), iqcchr(-6:6), iquchr(-6:6),
6627  & iqtchr(-6:6), mquark(3,39)
6628 C
6629  dimension sieapp(11), sitapp(16), plaetb(16)
6630  dimension sgtcoe(5,33), plalim(2,33), ihlp(nallwp)
6631  dimension sgtco1(5,10),sgtco2(5,8),sgtco3(5,15)
6632  SAVE plaetb, sieapp, sitapp, sgtcoe, plalim, ihlp
6633  SAVE iqfsc1, iqfsc2, iqbsc1, iqbsc2
6634  equivalence(sgtco1(1,1),sgtcoe(1,1))
6635  equivalence(sgtco2(1,1),sgtcoe(1,11))
6636  equivalence(sgtco3(1,1),sgtcoe(1,19))
6637 * 1=baryon, 2=pion, 3=kaon, 4=antibaryon:
6638  DATA ihlp/1,4,5*0,1,4,2*0,3,2*2,2*3,1,4,3,3*1,2,
6639  & 2*3, 2, 4*0, 3*4, 1, 4, 1, 4, 1, 4 /
6640 C DATA ( ( SGTCOE (J,I), J=1,5 ), I=1,10 ) /
6641  DATA sgtco1 /
6642 * 1st reaction: gamma p total
6643  &0.147 d+00, zerzer , zerzer , 0.0022d+00, -0.0170d+00,
6644 * 2nd reaction: gamma d total
6645  &0.300 d+00, zerzer , zerzer , 0.0095d+00, -0.057 d+00,
6646 * 3rd reaction: pi+ p total
6647  &16.4 d+00, 19.3d+00, -0.42d+00, 0.19 d+00, zerzer ,
6648 * 4th reaction: pi- p total
6649  &33.0 d+00, 14.0d+00, -1.36d+00, 0.456 d+00, -4.03 d+00,
6650 * 5th reaction: pi+/- d total
6651  &56.8 d+00, 42.2d+00, -1.45d+00, 0.65 d+00, -5.39 d+00,
6652 * 6th reaction: K+ p total
6653  &18.1 d+00, zerzer , zerzer , 0.26 d+00, -1.0 d+00,
6654 * 7th reaction: K+ n total
6655  &18.7 d+00, zerzer , zerzer , 0.21 d+00, -0.89 d+00,
6656 * 8th reaction: K+ d total
6657  &34.2 d+00, 7.9 d+00, -2.1 d+00, 0.346 d+00, -0.99 d+00,
6658 * 9th reaction: K- p total
6659  &32.1 d+00, zerzer , zerzer , 0.66 d+00, -5.6 d+00,
6660 * 10th reaction: K- n total
6661  &25.2 d+00, zerzer , zerzer , 0.38 d+00, -2.9 d+00/
6662 C DATA ( ( SGTCOE (J,I), J=1,5 ), I=11,18 ) /
6663  DATA sgtco2 /
6664 * 11th reaction: K- d total
6665  &57.6 d+00, zerzer , zerzer , 1.17 d+00, -9.5 d+00,
6666 * 12th reaction: p p total
6667  &48.0 d+00, zerzer , zerzer , 0.522 d+00, -4.51 d+00,
6668 * 13th reaction: p n total
6669  &47.30 d+00, zerzer , zerzer , 0.513 d+00, -4.27 d+00,
6670 * 14th reaction: p d total
6671  &91.3 d+00, zerzer , zerzer , 1.05 d+00, -8.8 d+00,
6672 * 15th reaction: pbar p total
6673  &38.4 d+00, 77.6d+00, -0.64d+00, 0.26 d+00, -1.2 d+00,
6674 * 16th reaction: pbar n total
6675  &zerzer ,133.6d+00, -0.70d+00, -1.22 d+00, 13.7 d+00,
6676 * 17th reaction: pbar d total
6677  &112. d+00, 125.d+00, -1.08d+00, 1.14 d+00, -12.4 d+00,
6678 * 18th reaction: Lamda p total
6679  &30.4 d+00, zerzer , zerzer , zerzer , 1.6 d+00/
6680 C DATA ( ( SGTCOE (J,I), J=1,5 ), I=19,33 ) /
6681  DATA sgtco3 /
6682 * 19th reaction: pi+ p elastic
6683  &zerzer , 11.4d+00, -0.4 d+00, 0.079 d+00, zerzer ,
6684 * 20th reaction: pi- p elastic
6685  &1.76 d+00, 11.2d+00, -0.64d+00, 0.043 d+00, zerzer ,
6686 * 21st reaction: K+ p elastic
6687  &5.0 d+00, 8.1 d+00, -1.8 d+00, 0.16 d+00, -1.3 d+00,
6688 * 22nd reaction: K- p elastic
6689  &7.3 d+00, zerzer , zerzer , 0.29 d+00, -2.40 d+00,
6690 * 23rd reaction: p p elastic
6691  &11.9 d+00, 26.9d+00, -1.21d+00, 0.169 d+00, -1.85 d+00,
6692 * 24th reaction: p d elastic
6693  &16.1 d+00, zerzer , zerzer , 0.32 d+00, -3.4 d+00,
6694 * 25th reaction: pbar p elastic
6695  &10.2 d+00, 52.7d+00, -1.16d+00, 0.125 d+00, -1.28 d+00,
6696 * 26th reaction: pbar p elastic bis
6697  &10.6 d+00, 53.1d+00, -1.19d+00, 0.136 d+00, -1.41 d+00,
6698 * 27th reaction: pbar n elastic
6699  &36.5 d+00, zerzer , zerzer , zerzer , -11.9 d+00,
6700 * 28th reaction: Lamda p elastic
6701  &12.3 d+00, zerzer , zerzer , zerzer , -2.4 d+00,
6702 * 29th reaction: K- p ela bis
6703  &7.24 d+00, 46.0d+00, -4.71d+00, 0.279 d+00, -2.35 d+00,
6704 * 30th reaction: pi- p cx
6705  &zerzer ,0.912d+00, -1.22d+00, zerzer , zerzer ,
6706 * 31st reaction: K- p cx
6707  &zerzer , 3.39d+00, -1.75d+00, zerzer , zerzer ,
6708 * 32nd reaction: K+ n cx
6709  &zerzer , 7.18d+00, -2.01d+00, zerzer , zerzer ,
6710 * 33rd reaction: pbar p cx
6711  &zerzer , 18.8d+00, -2.01d+00, zerzer , zerzer /
6712 *
6713  DATA plalim /
6714 * gamma p tot , gamma d tot , pi+ p tot ,
6715  & 3.0d+00, 183.d+00, 2.0d+00, 17.8d+00, 4.0d+00, 340.d+00,
6716 * pi- p tot , pi+/- d tot , K+ p tot ,
6717  & 2.5d+00, 370.d+00, 2.5d+00, 370.d+00, 2.0d+00, 310.d+00,
6718 * K+ n tot , K+ d tot , K- p tot ,
6719  & 2.0d+00, 310.d+00, 2.0d+00, 310.d+00, 3.0d+00, 310.d+00,
6720 * K- n tot , K- d tot , p p tot ,
6721  & 1.8d+00, 310.d+00, 3.0d+00, 310.d+00, 3.0d+00, 2100.d+00,
6722 * p n tot , p d tot , pbar p tot ,
6723  & 3.0d+00, 370.d+00, 3.0d+00, 370.d+00, 5.0d+00, 1.73d+06,
6724 * pbar n tot , pbar d tot , Lamda p tot ,
6725  & 1.1d+00, 280.d+00, 2.0d+00, 280.d+00, 0.6d+00, 21.d+00,
6726 * pi+ p ela , pi- p ela , K+ p ela ,
6727  & 2.0d+00, 200.d+00, 2.0d+00, 360.d+00, 2.0d+00, 175.d+00,
6728 * K- p ela , p p ela , p d ela ,
6729  & 3.0d+00, 175.d+00, 3.0d+00, 2100.d+00, 2.0d+00, 384.d+00,
6730 * pbar p ela , pbar p ela bis , pbar n ela ,
6731  & 5.0d+00, 1.73d+06, 2.0d+00, 1.59d+05, 1.1d+00, 5.55d+00,
6732 * Lamda p ela , K- p ela bis , pi- p cx ,
6733  & 0.6d+00, 24.d+00, 2.0d+00, 175.d+00, 3.5d+00, 200.d+00,
6734 * K- p cx , K+ n cx , pbar p cx /
6735  & 2.0d+00, 40.d+00, 2.0d+00, 12.8d+00, 3.0d+00, 350.d+00/
6736 * Momenta for which tabulated data exist for elastic/total pbar p
6737  DATA plaetb / 0.1d+00, 0.2d+00,
6738  & 0.3d+00, 0.4d+00, 0.5d+00, 0.6d+00, 0.8d+00, 1.d+00,
6739  & 1.2d+00, 1.5d+00, 2. d+00, 2.5d+00, 3. d+00, 4.d+00,
6740  & 4.5d+00, 5. d+00 /
6741 * Tabulated data for pbar p elastic:
6742 * The two lowest energy points are educated guesses:
6743  DATA sieapp / 142.d+00, 95.1d+00,
6744  & 75.0d+00, 70.0d+00, 62.0d+00, 57.0d+00, 48.0d+00,
6745  & 44.5d+00, 43.5d+00, 38.0d+00, 33.0d+00 /
6746 * Tabulated data for pbar p total cross section:
6747  DATA sitapp /1129.d+00, 424.d+00,
6748  & 239.d+00, 195.d+00, 172.d+00, 150.d+00, 124.d+00,
6749  & 117.d+00, 109.d+00, 100.d+00, 90.2d+00, 81.5d+00,
6750  & 78.0d+00, 72.0d+00, 67.0d+00, 64.8d+00 /
6751 *
6752 * +-------------------------------------------------------------------*
6753  ichrge(ktarg)=iich(ktarg)
6754  am(ktarg)=aam(ktarg)
6755 * | Check for pi0 (d-dbar)
6756  IF ( kp .NE. 26 ) THEN
6757  ip = kptoip(kp)
6758  IF(ip.EQ.0)ip=1
6759  ichrge(ip)=iich(kp)
6760  am(ip)=aam(kp)
6761 * |
6762 * +-------------------------------------------------------------------*
6763 * |
6764  ELSE
6765  ip = 23
6766  ichrge(ip)=0
6767  END IF
6768 * |
6769 * +-------------------------------------------------------------------*
6770 * +-------------------------------------------------------------------*
6771 * | No such interactions for baryon-baryon
6772  IF ( iibar(kp) .GT. 0 ) THEN
6773  phnsch = zerzer
6774  RETURN
6775 * |
6776 * +-------------------------------------------------------------------*
6777 * | No "annihilation" diagram possible for K+ p/n
6778  ELSE IF ( ip .EQ. 15 ) THEN
6779  phnsch = zerzer
6780  RETURN
6781 * |
6782 * +-------------------------------------------------------------------*
6783 * | No "annihilation" diagram possible for K0 p/n
6784  ELSE IF ( ip .EQ. 24 ) THEN
6785  phnsch = zerzer
6786  RETURN
6787 * |
6788 * +-------------------------------------------------------------------*
6789 * | No "annihilation" diagram possible for Omebar p/n
6790  ELSE IF ( ip .GE. 38 ) THEN
6791  phnsch = zerzer
6792  RETURN
6793  END IF
6794 * |
6795 * +-------------------------------------------------------------------*
6796 * +-------------------------------------------------------------------*
6797 * | If the momentum is larger than 50 GeV/c, compute the single
6798 * | chain probability at 50 GeV/c and extrapolate to the present
6799 * | momentum according to 1/sqrt(s)
6800 * | sigma = sigma_sch (50) * sqrt (s(50)/s) + sigma_dch
6801 * | P_sch (50) = sigma_sch (50) / ( sigma_dch + sigma_sch (50) )
6802 * | sigma_dch / sigma_sch (50) = 1 / P_sch (50) - 1
6803 * | sigma_dch / sigma_sch = 1 / P_sch - 1 = ( 1 / P_sch (50) - 1 )
6804 * | x sqrt(s/s(50))
6805 * | P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
6806  IF ( plab .GT. 50.d+00 ) THEN
6807  pla = 50.d+00
6808  ampsq = am(ip)**2
6809  amtsq = am(ktarg)**2
6810  eproj = sqrt( plab**2 + ampsq )
6811  umosq = ampsq + amtsq + twotwo * am(ktarg) * eproj
6812  eproj = sqrt( pla**2 + ampsq )
6813  umo50 = ampsq + amtsq + twotwo * am(ktarg) * eproj
6814  umorat = sqrt( umosq / umo50 )
6815 * |
6816 * +-------------------------------------------------------------------*
6817 * | P < 3 GeV/c
6818  ELSE IF ( plab .LT. 3.d+00 ) THEN
6819  pla = 3.d+00
6820  ampsq = am(ip)**2
6821  amtsq = am(ktarg)**2
6822  eproj = sqrt( plab**2 + ampsq )
6823  umosq = ampsq + amtsq + twotwo * am(ktarg) * eproj
6824  eproj = sqrt( pla**2 + ampsq )
6825  umo50 = ampsq + amtsq + twotwo * am(ktarg) * eproj
6826  umorat = sqrt( umosq / umo50 )
6827 * |
6828 * +-------------------------------------------------------------------*
6829 * | P < 50 GeV/c
6830  ELSE
6831  pla = plab
6832  umorat = oneone
6833  END IF
6834 * |
6835 * +-------------------------------------------------------------------*
6836  algpla = log(pla)
6837 * +-------------------------------------------------------------------*
6838 * | Pions:
6839  IF ( ihlp(ip) .EQ. 2 ) THEN
6840  acof = sgtcoe(1,3)
6841  bcof = sgtcoe(2,3)
6842  enne = sgtcoe(3,3)
6843  ccof = sgtcoe(4,3)
6844  dcof = sgtcoe(5,3)
6845 * | Compute the pi+ p total cross section:
6846  sppptt = acof + bcof * pla**enne + ccof * algpla**2
6847  & + dcof * algpla
6848  acof = sgtcoe(1,19)
6849  bcof = sgtcoe(2,19)
6850  enne = sgtcoe(3,19)
6851  ccof = sgtcoe(4,19)
6852  dcof = sgtcoe(5,19)
6853 * | Compute the pi+ p elastic cross section:
6854  spppel = acof + bcof * pla**enne + ccof * algpla**2
6855  & + dcof * algpla
6856 * | Compute the pi+ p inelastic cross section:
6857  spppin = sppptt - spppel
6858  acof = sgtcoe(1,4)
6859  bcof = sgtcoe(2,4)
6860  enne = sgtcoe(3,4)
6861  ccof = sgtcoe(4,4)
6862  dcof = sgtcoe(5,4)
6863 * | Compute the pi- p total cross section:
6864  spmptt = acof + bcof * pla**enne + ccof * algpla**2
6865  & + dcof * algpla
6866  acof = sgtcoe(1,20)
6867  bcof = sgtcoe(2,20)
6868  enne = sgtcoe(3,20)
6869  ccof = sgtcoe(4,20)
6870  dcof = sgtcoe(5,20)
6871 * | Compute the pi- p elastic cross section:
6872  spmpel = acof + bcof * pla**enne + ccof * algpla**2
6873  & + dcof * algpla
6874 * | Compute the pi- p inelastic cross section:
6875  spmpin = spmptt - spmpel
6876  sigdia = spmpin - spppin
6877 * | +----------------------------------------------------------------*
6878 * | | Charged pions: besides isospin consideration it is supposed
6879 * | | that (pi+ n)el is almost equal to (pi- p)el
6880 * | | and (pi+ p)el " " " " (pi- n)el
6881 * | | and all are almost equal among each others
6882 * | | (reasonable above 5 GeV/c)
6883  IF ( ichrge(ip) .NE. 0 ) THEN
6884  khelp = ktarg / 8
6885  jreac = 3 + ip - 13 + ichrge(ip) * khelp
6886  acof = sgtcoe(1,jreac)
6887  bcof = sgtcoe(2,jreac)
6888  enne = sgtcoe(3,jreac)
6889  ccof = sgtcoe(4,jreac)
6890  dcof = sgtcoe(5,jreac)
6891 * | | Compute the total cross section:
6892  shnctt = acof + bcof * pla**enne + ccof * algpla**2
6893  & + dcof * algpla
6894  jreac = 19 + ip - 13 + ichrge(ip) * khelp
6895  acof = sgtcoe(1,jreac)
6896  bcof = sgtcoe(2,jreac)
6897  enne = sgtcoe(3,jreac)
6898  ccof = sgtcoe(4,jreac)
6899  dcof = sgtcoe(5,jreac)
6900 * | | Compute the elastic cross section:
6901  shncel = acof + bcof * pla**enne + ccof * algpla**2
6902  & + dcof * algpla
6903 * | | Compute the inelastic cross section:
6904  shncin = shnctt - shncel
6905 * | | Number of diagrams:
6906  ndiagr = 1 + ip - 13 + ichrge(ip) * khelp
6907 * | | Now compute the chain end (anti)quark-(anti)diquark
6908  iqfsc1 = 1 + ip - 13
6909  iqfsc2 = 0
6910  iqbsc1 = 1 + khelp
6911  iqbsc2 = 1 + ip - 13
6912 * | |
6913 * | +----------------------------------------------------------------*
6914 * | | pi0: besides isospin consideration it is supposed that the
6915 * | | elastic cross section is not very different from
6916 * | | pi+ p and/or pi- p (reasonable above 5 GeV/c)
6917  ELSE
6918  khelp = ktarg / 8
6919  k2hlp = ( kp - 23 ) / 3
6920 * | | Number of diagrams:
6921 * | | For u ubar (k2hlp=0):
6922 * NDIAGR = 2 - KHELP
6923 * | | For d dbar (k2hlp=1):
6924 * NDIAGR = 2 + KHELP - K2HLP
6925  ndiagr = 2 + khelp * ( 2 * k2hlp - 1 ) - k2hlp
6926  shncin = hlfhlf * ( spppin + spmpin )
6927 * | | Now compute the chain end (anti)quark-(anti)diquark
6928  iqfsc1 = 1 + k2hlp
6929  iqfsc2 = 0
6930  iqbsc1 = 1 + khelp
6931  iqbsc2 = 2 - k2hlp
6932  END IF
6933 * | |
6934 * | +----------------------------------------------------------------*
6935 * | end pi's
6936 * +-------------------------------------------------------------------*
6937 * | Kaons:
6938  ELSE IF ( ihlp(ip) .EQ. 3 ) THEN
6939  acof = sgtcoe(1,6)
6940  bcof = sgtcoe(2,6)
6941  enne = sgtcoe(3,6)
6942  ccof = sgtcoe(4,6)
6943  dcof = sgtcoe(5,6)
6944 * | Compute the K+ p total cross section:
6945  skpptt = acof + bcof * pla**enne + ccof * algpla**2
6946  & + dcof * algpla
6947  acof = sgtcoe(1,21)
6948  bcof = sgtcoe(2,21)
6949  enne = sgtcoe(3,21)
6950  ccof = sgtcoe(4,21)
6951  dcof = sgtcoe(5,21)
6952 * | Compute the K+ p elastic cross section:
6953  skppel = acof + bcof * pla**enne + ccof * algpla**2
6954  & + dcof * algpla
6955 * | Compute the K+ p inelastic cross section:
6956  skppin = skpptt - skppel
6957  acof = sgtcoe(1,9)
6958  bcof = sgtcoe(2,9)
6959  enne = sgtcoe(3,9)
6960  ccof = sgtcoe(4,9)
6961  dcof = sgtcoe(5,9)
6962 * | Compute the K- p total cross section:
6963  skmptt = acof + bcof * pla**enne + ccof * algpla**2
6964  & + dcof * algpla
6965  acof = sgtcoe(1,22)
6966  bcof = sgtcoe(2,22)
6967  enne = sgtcoe(3,22)
6968  ccof = sgtcoe(4,22)
6969  dcof = sgtcoe(5,22)
6970 * | Compute the K- p elastic cross section:
6971  skmpel = acof + bcof * pla**enne + ccof * algpla**2
6972  & + dcof * algpla
6973 * | Compute the K- p inelastic cross section:
6974  skmpin = skmptt - skmpel
6975  sigdia = hlfhlf * ( skmpin - skppin )
6976 * | +----------------------------------------------------------------*
6977 * | | Charged Kaons: actually only K-
6978  IF ( ichrge(ip) .NE. 0 ) THEN
6979  khelp = ktarg / 8
6980 * | | +-------------------------------------------------------------*
6981 * | | | Proton target:
6982  IF ( khelp .EQ. 0 ) THEN
6983  shncin = skmpin
6984 * | | | Number of diagrams:
6985  ndiagr = 2
6986 * | | |
6987 * | | +-------------------------------------------------------------*
6988 * | | | Neutron target: besides isospin consideration it is supposed
6989 * | | | that (K- n)el is almost equal to (K- p)el
6990 * | | | (reasonable above 5 GeV/c)
6991  ELSE
6992  acof = sgtcoe(1,10)
6993  bcof = sgtcoe(2,10)
6994  enne = sgtcoe(3,10)
6995  ccof = sgtcoe(4,10)
6996  dcof = sgtcoe(5,10)
6997 * | | | Compute the total cross section:
6998  shnctt = acof + bcof * pla**enne + ccof * algpla**2
6999  & + dcof * algpla
7000 * | | | Compute the elastic cross section:
7001  shncel = skmpel
7002 * | | | Compute the inelastic cross section:
7003  shncin = shnctt - shncel
7004 * | | | Number of diagrams:
7005  ndiagr = 1
7006  END IF
7007 * | | |
7008 * | | +-------------------------------------------------------------*
7009 * | | Now compute the chain end (anti)quark-(anti)diquark
7010  iqfsc1 = 3
7011  iqfsc2 = 0
7012  iqbsc1 = 1 + khelp
7013  iqbsc2 = 2
7014 * | |
7015 * | +----------------------------------------------------------------*
7016 * | | K0's: (actually only K0bar)
7017  ELSE
7018  khelp = ktarg / 8
7019 * | | +-------------------------------------------------------------*
7020 * | | | Proton target: (K0bar p)in supposed to be given by
7021 * | | | (K- p)in - Sig_diagr
7022  IF ( khelp .EQ. 0 ) THEN
7023  shncin = skmpin - sigdia
7024 * | | | Number of diagrams:
7025  ndiagr = 1
7026 * | | |
7027 * | | +-------------------------------------------------------------*
7028 * | | | Neutron target: (K0bar n)in supposed to be given by
7029 * | | | (K- n)in + Sig_diagr
7030 * | | | besides isospin consideration it is supposed
7031 * | | | that (K- n)el is almost equal to (K- p)el
7032 * | | | (reasonable above 5 GeV/c)
7033  ELSE
7034  acof = sgtcoe(1,10)
7035  bcof = sgtcoe(2,10)
7036  enne = sgtcoe(3,10)
7037  ccof = sgtcoe(4,10)
7038  dcof = sgtcoe(5,10)
7039 * | | | Compute the total cross section:
7040  shnctt = acof + bcof * pla**enne + ccof * algpla**2
7041  & + dcof * algpla
7042 * | | | Compute the elastic cross section:
7043  shncel = skmpel
7044 * | | | Compute the inelastic cross section:
7045  shncin = shnctt - shncel + sigdia
7046 * | | | Number of diagrams:
7047  ndiagr = 2
7048  END IF
7049 * | | |
7050 * | | +-------------------------------------------------------------*
7051 * | | Now compute the chain end (anti)quark-(anti)diquark
7052  iqfsc1 = 3
7053  iqfsc2 = 0
7054  iqbsc1 = 1
7055  iqbsc2 = 1 + khelp
7056  END IF
7057 * | |
7058 * | +----------------------------------------------------------------*
7059 * | end Kaon's
7060 * +-------------------------------------------------------------------*
7061 * | Antinucleons:
7062  ELSE IF ( ihlp(ip) .EQ. 4 .AND. ip .LE. 9 ) THEN
7063 * | For momenta between 3 and 5 GeV/c the use of tabulated data
7064 * | should be implemented!
7065  acof = sgtcoe(1,15)
7066  bcof = sgtcoe(2,15)
7067  enne = sgtcoe(3,15)
7068  ccof = sgtcoe(4,15)
7069  dcof = sgtcoe(5,15)
7070 * | Compute the pbar p total cross section:
7071  sapptt = acof + bcof * pla**enne + ccof * algpla**2
7072  & + dcof * algpla
7073  IF ( pla .LT. fivfiv ) THEN
7074  jreac = 26
7075  ELSE
7076  jreac = 25
7077  END IF
7078  acof = sgtcoe(1,jreac)
7079  bcof = sgtcoe(2,jreac)
7080  enne = sgtcoe(3,jreac)
7081  ccof = sgtcoe(4,jreac)
7082  dcof = sgtcoe(5,jreac)
7083 * | Compute the pbar p elastic cross section:
7084  sappel = acof + bcof * pla**enne + ccof * algpla**2
7085  & + dcof * algpla
7086 * | Compute the pbar p inelastic cross section:
7087  sappin = sapptt - sappel
7088  acof = sgtcoe(1,12)
7089  bcof = sgtcoe(2,12)
7090  enne = sgtcoe(3,12)
7091  ccof = sgtcoe(4,12)
7092  dcof = sgtcoe(5,12)
7093 * | Compute the p p total cross section:
7094  spptot = acof + bcof * pla**enne + ccof * algpla**2
7095  & + dcof * algpla
7096  acof = sgtcoe(1,23)
7097  bcof = sgtcoe(2,23)
7098  enne = sgtcoe(3,23)
7099  ccof = sgtcoe(4,23)
7100  dcof = sgtcoe(5,23)
7101 * | Compute the p p elastic cross section:
7102  sppela = acof + bcof * pla**enne + ccof * algpla**2
7103  & + dcof * algpla
7104 * | Compute the K- p inelastic cross section:
7105  sppine = spptot - sppela
7106  sigdia = ( sappin - sppine ) / fivfiv
7107  khelp = ktarg / 8
7108 * | +----------------------------------------------------------------*
7109 * | | Pbar:
7110  IF ( ichrge(ip) .NE. 0 ) THEN
7111  ndiagr = 5 - khelp
7112 * | | +-------------------------------------------------------------*
7113 * | | | Proton target:
7114  IF ( khelp .EQ. 0 ) THEN
7115 * | | | Number of diagrams:
7116  shncin = sappin
7117  puubar = 0.8d+00
7118 * | | |
7119 * | | +-------------------------------------------------------------*
7120 * | | | Neutron target: it is supposed that (ap n)el is almost equal
7121 * | | | to (ap p)el (reasonable above 5 GeV/c)
7122  ELSE
7123  acof = sgtcoe(1,16)
7124  bcof = sgtcoe(2,16)
7125  enne = sgtcoe(3,16)
7126  ccof = sgtcoe(4,16)
7127  dcof = sgtcoe(5,16)
7128 * | | | Compute the total cross section:
7129  shnctt = acof + bcof * pla**enne + ccof * algpla**2
7130  & + dcof * algpla
7131 * | | | Compute the elastic cross section:
7132  shncel = sappel
7133 * | | | Compute the inelastic cross section:
7134  shncin = shnctt - shncel
7135  puubar = hlfhlf
7136  END IF
7137 * | | |
7138 * | | +-------------------------------------------------------------*
7139 * | | Now compute the chain end (anti)quark-(anti)diquark
7140 * | | there are different possibilities, make a random choiche:
7141  iqfsc1 = -1
7142  rnchen = rndm(rnchen)
7143  IF ( rnchen .LT. puubar ) THEN
7144  iqfsc2 = -2
7145  ELSE
7146  iqfsc2 = -1
7147  END IF
7148  iqbsc1 = -iqfsc1 + khelp
7149  iqbsc2 = -iqfsc2
7150 * | |
7151 * | +----------------------------------------------------------------*
7152 * | | nbar:
7153  ELSE
7154  ndiagr = 4 + khelp
7155 * | | +-------------------------------------------------------------*
7156 * | | | Proton target: (nbar p)in supposed to be given by
7157 * | | | (pbar p)in - Sig_diagr
7158  IF ( khelp .EQ. 0 ) THEN
7159  shncin = sappin - sigdia
7160  pddbar = hlfhlf
7161 * | | |
7162 * | | +-------------------------------------------------------------*
7163 * | | | Neutron target: (nbar n)el is supposed to be equal to
7164 * | | | (pbar p)el (reasonable above 5 GeV/c)
7165  ELSE
7166 * | | | Compute the total cross section:
7167  shnctt = sapptt
7168 * | | | Compute the elastic cross section:
7169  shncel = sappel
7170 * | | | Compute the inelastic cross section:
7171  shncin = shnctt - shncel
7172  pddbar = 0.8d+00
7173  END IF
7174 * | | |
7175 * | | +-------------------------------------------------------------*
7176 * | | Now compute the chain end (anti)quark-(anti)diquark
7177 * | | there are different possibilities, make a random choiche:
7178  iqfsc1 = -2
7179  rnchen = rndm(rnchen)
7180  IF ( rnchen .LT. pddbar ) THEN
7181  iqfsc2 = -1
7182  ELSE
7183  iqfsc2 = -2
7184  END IF
7185  iqbsc1 = -iqfsc1 + khelp - 1
7186  iqbsc2 = -iqfsc2
7187  END IF
7188 * | |
7189 * | +----------------------------------------------------------------*
7190 * |
7191 * +-------------------------------------------------------------------*
7192 * | Others: not yet implemented
7193  ELSE
7194  sigdia = zerzer
7195  shncin = oneone
7196  ndiagr = 0
7197  phnsch = zerzer
7198  RETURN
7199  END IF
7200 * | end others
7201 * +-------------------------------------------------------------------*
7202  phnsch = ndiagr * sigdia / shncin
7203  iqechc = iqechr(iqfsc1) + iqechr(iqfsc2) + iqechr(iqbsc1)
7204  & + iqechr(iqbsc2)
7205  iqbchc = iqbchr(iqfsc1) + iqbchr(iqfsc2) + iqbchr(iqbsc1)
7206  & + iqbchr(iqbsc2)
7207  iqechc = iqechc / 3
7208  iqbchc = iqbchc / 3
7209  iqschc = iqschr(iqfsc1) + iqschr(iqfsc2) + iqschr(iqbsc1)
7210  & + iqschr(iqbsc2)
7211  iqspro = iqschr(mquark(1,ip)) + iqschr(mquark(2,ip))
7212  & + iqschr(mquark(3,ip))
7213 * +-------------------------------------------------------------------*
7214 * | Consistency check:
7215  IF ( phnsch .LE. zerzer .OR. phnsch .GT. oneone ) THEN
7216  WRITE (lunout,*)' *** Phnsch,kp,ktarg,pla',
7217  & phnsch,kp,ktarg,pla,' ****'
7218  WRITE (lunerr,*)' *** Phnsch,kp,ktarg,pla',
7219  & phnsch,kp,ktarg,pla,' ****'
7220  phnsch = max( phnsch, zerzer )
7221  phnsch = min( phnsch, oneone )
7222  END IF
7223 * |
7224 * +-------------------------------------------------------------------*
7225 * +-------------------------------------------------------------------*
7226 * | Consistency check:
7227  IF ( iqspro .NE. iqschc .OR. ichrge(ip) + ichrge(ktarg)
7228  & .NE. iqechc .OR. iibar(kp) + iibar(ktarg) .NE. iqbchc) THEN
7229  WRITE (lunout,*)
7230  &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
7231  & iqspro,iqschc,ichrge(ip),iqechc,iibar(kp),iqbchc,ktarg
7232  WRITE (lunerr,*)
7233  &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
7234  & iqspro,iqschc,ichrge(ip),iqechc,iibar(kp),iqbchc,ktarg
7235  END IF
7236 * |
7237 * +-------------------------------------------------------------------*
7238 * P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
7239  IF ( umorat .GT. onepls ) phnsch = oneone / ( ( oneone / phnsch
7240  & - oneone ) * umorat + oneone )
7241  RETURN
7242 *
7243  entry schqua( jqfsc1, jqfsc2, jqbsc1, jqbsc2 )
7244  schqua = oneone
7245  jqfsc1 = iqfsc1
7246  jqfsc2 = iqfsc2
7247  jqbsc1 = iqbsc1
7248  jqbsc2 = iqbsc2
7249 *=== End of function Phnsch ===========================================*
7250  RETURN
7251  END
7252 *
7253 *=== qprop ============================================================*
7254 *
7255  BLOCK DATA qprop
7256 *----------------------------------------------------------------------*
7257 * *
7258 * Created on 6 february 1991 by Alfredo Ferrari *
7259 * INFN - Milan *
7260 * *
7261 * Last change on 6 february 1991 by Alfredo Ferrari *
7262 * *
7263 * Included in the following routines : *
7264 * *
7265 * COREVT *
7266 * CORRIN *
7267 * HADEVV *
7268 * HADEVT *
7269 * NUCEVV *
7270 * NUCEVT *
7271 * *
7272 * Quark content of particles: *
7273 * index quark el. charge bar. charge isospin isospin3 *
7274 * 1 = u 2/3 1/3 1/2 1/2 *
7275 * -1 = ubar -2/3 -1/3 1/2 -1/2 *
7276 * 2 = d -1/3 1/3 1/2 -1/2 *
7277 * -2 = dbar 1/3 -1/3 1/2 1/2 *
7278 * 3 = s -1/3 1/3 0 0 *
7279 * -3 = sbar 1/3 -1/3 0 0 *
7280 * 4 = c 2/3 1/3 0 0 *
7281 * -4 = cbar -2/3 -1/3 0 0 *
7282 * 5 = b -1/3 1/3 0 0 *
7283 * -5 = bbar 1/3 -1/3 0 0 *
7284 * 6 = t 2/3 1/3 0 0 *
7285 * -6 = tbar -2/3 -1/3 0 0 *
7286 * *
7287 * Mquark = particle quark composition (Paprop numbering) *
7288 * Iqechr = electric charge ( in 1/3 unit ) *
7289 * Iqbchr = baryonic charge ( in 1/3 unit ) *
7290 * Iqichr = isospin ( in 1/2 unit ), z component *
7291 * Iqschr = strangeness *
7292 * Iqcchr = charm *
7293 * Iquchr = beauty *
7294 * Iqtchr = ...... *
7295 * *
7296 *----------------------------------------------------------------------*
7297 *
7298  IMPLICIT DOUBLE PRECISION (a-h,o-z)
7299 
7300  COMMON / qquark / iqechr(-6:6), iqbchr(-6:6), iqichr(-6:6),
7301  & iqschr(-6:6), iqcchr(-6:6), iquchr(-6:6),
7302  & iqtchr(-6:6), mquark(3,39)
7303 
7304 *
7305 * / Qquark /
7306  DATA iqechr / -2, 1, -2, 1, 1, -2, 0, 2, -1, -1, 2, -1, 2 /
7307  DATA iqbchr / 6*-1, 0, 6*1 /
7308  DATA iqichr / 4*0, 1, -1, 0, 1, -1, 4*0 /
7309  DATA iqschr / 3*0, 1, 5*0, -1, 3*0 /
7310  DATA iqcchr / 2*0, -1, 7*0, 1, 2*0 /
7311  DATA iquchr / 0, 1, 9*0, -1, 0 /
7312  DATA iqtchr / -1, 11*0, 1 /
7313  DATA mquark / 1,1,2, -1,-1,-2,
7314  * 0,0,0, 0,0,0, 0,0,0, 0,0,0, 0,0,0,
7315  * 1,2,2, -1,-2,-2, 0,0,0, 0,0,0, 0,0,0,
7316  * 1,-2,0, 2,-1,0, 1,-3,0, 3,-1,0,
7317  * 1,2,3, -1,-2,-3, 0,0,0,
7318  * 2,2,3, 1,1,3, 1,2,3, 1,-1,0,
7319  * 2,-3,0, 3,-2,0, 2,-2,0, 0,0,0,
7320  * 0,0,0, 0,0,0, 0,0,0,
7321  * -1,-1,-3, -1,-2,-3, -2,-2,-3,
7322  * 1,3,3, -1,-3,-3, 2,3,3, -2,-3,-3,
7323  * 3,3,3, -3,-3,-3 /
7324 
7325  END
7326 C******************************************************************
7327  SUBROUTINE selpts( PTXSQ1,PTYSQ1,
7328  +plq1,eq1,ptxsa2,
7329  +ptysa2,plaq2,eaq2, amch1,irej,ikvala,pttq1)
7330  IMPLICIT DOUBLE PRECISION (a-h,o-z)
7331 C SELECT PT VALUES FOR A SINGLE CHAIN SYSTEM
7332 C SELECT SEA QUARK AND ANTIQUARK PT-VALUES
7333 *KEEP,DPRIN.
7334  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
7335 *KEEP,DROPPT.
7336  LOGICAL intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada, ipadis,
7337  +ishmal,lpauli
7338  COMMON /droppt/ intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada,
7339  +ipadis,ishmal,lpauli
7340 *KEND.
7341  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
7342 C--------------------------------
7343 C change j.r.6.5.93
7344  qtxsq1=ptxsq1
7345  qtxsa2=ptxsa2
7346  qtysq1=ptysq1
7347  qtysa2=ptysa2
7348  qlq1=plq1
7349  qlaq2=plaq2
7350  qeq1=eq1
7351  qeaq2=eaq2
7352 C ----------------
7353  ianfa=0
7354  itagpt=0
7355 C changed from 3. j.r.21.8.93
7356  b33=3.00
7357  IF (ikvala.EQ.1)b33=6.0
7358  icount=0
7359  irej=0
7360  10 CONTINUE
7361  icount=icount+1
7362  IF (icount.EQ.10)THEN
7363  irej=1
7364 C REJECT EVENT
7365  RETURN
7366  ENDIF
7367  IF (icount.GE.1)THEN
7368  hps=hps*0.9
7369  ptxsq1=qtxsq1+hps*cfe
7370  ptysq1=qtysq1+hps*sfe
7371  ptxsa2=qtxsa2-hps*cfe
7372  ptysa2=qtysa2-hps*sfe
7373  go to 111
7374  ENDIF
7375  b33=2.*b33
7376 C
7377  es=-2./(b33**2)*log(abs(rndm(v)*rndm(u))+0.00000001)
7378  hps=sqrt(es*es+2.*es*0.94)
7379 C............................................................
7380  110 CONTINUE
7381  IF (.NOT.intpt) hps=0.0000001
7382 C.............................................................
7383  CALL dsfecf(sfe,cfe)
7384 C change j.r.6.5.93
7385  ptxsq1=qtxsq1+hps*cfe
7386  ptysq1=qtysq1+hps*sfe
7387  ptxsa2=qtxsa2-hps*cfe
7388  ptysa2=qtysa2-hps*sfe
7389  111 CONTINUE
7390 C -----------------
7391 C
7392  IF (ipev.GE.6)WRITE(6,1000)ptxsq1,ptysq1,
7393  +ptxsa2,ptysa2
7394  1000 FORMAT (' PT S ',8f12.6)
7395 C KINEMATICS OF THE TWO CHAINS Q1-AQ2,AQ1-Q2
7396  pttq1=ptxsq1**2+ptysq1**2
7397  IF((eq1**2.LE.pttq1)) go to 10
7398 C
7399  ianfa2=0
7400  itagp2=0
7401  b33=3.00
7402  IF (ikvala.EQ.1)b33=6.0
7403  icoun2=0
7404  irej=0
7405  12 CONTINUE
7406  icoun2=icoun2+1
7407  IF (icoun2.EQ.12)THEN
7408  irej=1
7409 C REJECT EVENT
7410  RETURN
7411  ENDIF
7412 C -----------------
7413 C
7414  IF (ipev.GE.6)WRITE(6,1000)ptxsq1,ptysq1,
7415  +ptxsa2,ptysa2
7416 C KINEMATICS OF THE TWO CHAINS Q1-AQ2,AQ1-Q2
7417  ptta2=ptxsa2**2+ptysa2**2
7418  IF((eaq2**2.LE.ptta2)) go to 12
7419 
7420 C
7421  IF(ip.GE.1)go to 1779
7422  plq1=sqrt(eq1**2-pttq1)
7423  plaq2=-sqrt(eaq2**2-ptta2)
7424  1779 CONTINUE
7425 C-----------
7426 C-----------
7427 C CHAIN 1: Q1-AQ2 CHAIN2: AQ1-Q2
7428  amch1q=(eq1+eaq2)**2-(ptxsq1+ptxsa2)** 2-(ptysq1+ptysa2)**2-(plq1
7429  ++plaq2)**2
7430  IF (amch1q.LE.0.d0)THEN
7431  WRITE(6,301)amch1q
7432  301 FORMAT(' inconsistent Kinematics in SELPT AMCH1Q=',e12.3)
7433  WRITE(6,305) qtxsq1,qtysq1,
7434  +qlq1,qeq1,qtxsa1,qtysa1,qlaq1,qeaq1, qtxsq2,qtysq2,qlq2,qeq2,
7435  +qtxsa2,
7436  +qtysa2,qlaq2,qeaq2, amch1,amch2
7437  305 FORMAT( 'PTXSQ1,PTYSQ1,
7438  +PLQ1,EQ1,PTXSA1,PTYSA1,PLAQ1,EAQ1, PTXSQ2,PTYSQ2,PLQ2,EQ2,PTXSA2,
7439  +PTYSA2,PLAQ2,EAQ2, AMCH1,AMCH2',5(4e15.5/))
7440  irej=1
7441  RETURN
7442  ENDIF
7443  amch1=sqrt(amch1q)
7444 C
7445  RETURN
7446  END
mpdgha
function mpdgha(MCIND)
Definition: dpm25nulib.f:386
c2_transformation::zero
static float_type zero(float_type)
utility function f(x)=0 useful in axis transforms
Definition: c2_function.hh:1203
calbam
subroutine calbam(NNCH, I1, I2, IFB11, IFB22, IFB33, IFB44, AMCH, NOBAM, IHAD)
Definition: dpm25nuc7.f:2138
pycomp
#define pycomp
Definition: Pythia6.cc:98
intmx
const int intmx
Definition: G4DPMJET2_5Interface.hh:68
z
Double_t z
Definition: plot.C:279
yy
Double_t yy
Definition: macro.C:11
mcihad
function mcihad(MCIND)
Definition: dpm25nulib.f:364
tecalb
subroutine tecalb
Definition: dpm25nuc7.f:3635
shmak1
subroutine shmak1(ICASE, NN, NNA, NNB, NA, NB, UMO, BIMP)
Definition: dpm25nuc7.f:4358
x2
Double_t x2[nxs]
Definition: Style.C:19
pyexec
subroutine pyexec
Definition: pythia61.f:31539
sortin
subroutine sortin(A, N)
Definition: dpm25nuc7.f:4700
d
Float_t d
Definition: plot.C:237
ddatar
subroutine ddatar
Definition: dpm25nuc7.f:3503
distcm
subroutine distcm(IOP, NHAD, POLAB, KPROJ, KTARG)
Definition: dpm25nuc7.f:3745
bamlun
subroutine bamlun(IHAD, KFA1, KFA2, KFA3, KFA4, AEO, IOPT, IREJ)
Definition: dpm25nuc7.f:371
modb
subroutine modb(BSITE, N, BSTEP, B)
Definition: dpm25nuc7.f:1869
rndm
DOUBLE PRECISION function rndm(RDUMMY)
Definition: dpm25nulib.f:1460
h1
TH1F * h1
Definition: plot.C:43
ntarg
Int_t ntarg
Definition: Style.C:6
int
typedef int(XMLCALL *XML_NotStandaloneHandler)(void *userData)
s
const XML_Char * s
Definition: expat.h:262
dtwopd
subroutine dtwopd(UMO, ECM1, ECM2, PCM1, PCM2, COD1, COF1, SIF1, COD2, COF2, SIF2, AM1, AM2)
Definition: dpm25nuc7.f:3326
for
for(Int_t i=0;i< nentries;i++)
Definition: comparison.C:30
p
const char * p
Definition: xmltok.h:285
dshnto
DOUBLE PRECISION function dshnto(KPROJ, KTARG, UMO)
Definition: dpm25diff.f:3503
sampex
DOUBLE PRECISION function sampex(X1, X2)
Definition: dpm25nulib.f:1118
dtrafo
subroutine dtrafo(GAM, BGAM, CX, CY, CZ, COD, COF, SIF, P, ECM, PL, CXL, CYL, CZL, EL)
Definition: dpm25nuc3.f:7346
sihndi
subroutine sihndi(ECM, KPROJ, KTARG, SIGDIF, SIGDIH)
Definition: dpm25diff.f:3433
xx
Double_t xx
Definition: macro.C:10
indexd
subroutine indexd(KA, KB, IND)
Definition: dpm25nuc7.f:2637
ddecay
subroutine ddecay(IHAD, ISTAB)
Definition: dpm25nuc7.f:4057
fluini
subroutine fluini
Definition: dpm25nuc7.f:2076
G4StatDouble::fill
void fill(G4double x, G4double weight=1.)
Definition: G4StatDouble.cc:57
shmak
subroutine shmak(ICASE, NN, NNA, NNB, NA, NB, UMO, BIMP)
Definition: dpm25nuc7.f:4192
pydat3
#define pydat3
Definition: pythia6_common_address.c:41
pyp
function pyp(I, J)
Definition: pythia61.f:38097
HepGeom::Transform3D::dx
double dx() const
Definition: Transform3D.h:279
shmaki
subroutine shmaki(NA, NCA, NB, NCB, RPROJ, RTARG, PPN)
Definition: dpm25nuc7.f:1406
a
G4double a
Definition: TRTMaterials.hh:39
sort
subroutine sort(A, N)
Definition: dpm25nuc7.f:4670
sigsds
DOUBLE PRECISION function sigsds(S)
Definition: dpm25nuc7.f:1505
f
TFile f
Definition: plotHisto.C:6
c2_transformation::one
static float_type one(float_type)
utility function f(x)=1 useful in axis transforms
Definition: c2_function.hh:1201
conucl
subroutine conucl(X, N, R)
Definition: dpm25nuc7.f:1759
plot
subroutine plot(X, Y, N, M, MM, XO, DX, YO, DY)
Definition: dpm25nulib.f:176
py4ent
subroutine py4ent(IP, KF1, KF2, KF3, KF4, PECM, X1, X2, X4, X12, X14)
Definition: pythia61.f:30869
y
Double_t y
Definition: plot.C:279
intmd
const int intmd
Definition: G4DPMJET2_5Interface.hh:66
phnsch
DOUBLE PRECISION function phnsch(KP, KTARG, PLAB)
Definition: dpm25nuc7.f:6170
dxlamb
DOUBLE PRECISION function dxlamb(X, Y, Z)
Definition: dpm25nuc7.f:3207
n
Char_t n[5]
Definition: comparison_ascii.C:55
py2ent
subroutine py2ent(IP, KF1, KF2, PECM)
Definition: pythia61.f:30657
profb
subroutine profb(BSTEP, NSTAT, NA, RA, NB, RB, BSITE, NSITEB)
Definition: dpm25nuc7.f:4525
dshpto
DOUBLE PRECISION function dshpto(IT, PO)
Definition: dpm25hadri.f:1824
neb
const int neb
Definition: G4DPMJET2_5Interface.hh:79
testem0.App.init
def init
Definition: testem0.py:56
pydat1
#define pydat1
Definition: pythia6_common_address.c:40
previo
subroutine previo(RA, RB, NSTB, BMAX, BSTEP, SIG, RO, G)
Definition: dpm25nuc7.f:4470
CLHEP::HepLorentzVector::py
double py() const
dshnel
DOUBLE PRECISION function dshnel(KPROJ, KTARG, UMO)
Definition: dpm25diff.f:3902
ddates
subroutine ddates
Definition: dpm25nuc7.f:3374
x1
Double_t x1[nxs]
Definition: Style.C:18
CLHEP::HepLorentzVector::px
double px() const
pymass
function pymass(KF)
Definition: pythia61.f:36187
shmakf
subroutine shmakf(NA, NCA, NB, NCB)
Definition: dpm25nuc7.f:1515
strafo
subroutine strafo(GAM, BGAM, CX, CY, CZ, COD, COF, SIF, P, ECM, PL, CXL, CYL, CZL, EL)
Definition: dpm25nuc7.f:3244
pyjets
#define pyjets
Definition: pythia6_common_address.c:39
G4IT::diff
virtual G4bool diff(const G4IT &right) const =0
pyshow
subroutine pyshow(IP1, IP2, QMAX)
Definition: pythia61.f:34922
ddrela
subroutine ddrela(X, Y, Z, COTE, SITE, COPS, SIPS)
Definition: dpm25nuc7.f:2686
pyedit
subroutine pyedit(MEDIT)
Definition: pythia61.f:36852
HepGeom::Transform3D::xy
double xy() const
Definition: Transform3D.h:255
x
Double_t x
Definition: plot.C:279
HepGeom::Transform3D::dy
double dy() const
Definition: Transform3D.h:282
pt
TMarker * pt
Definition: egs.C:22
dparje
subroutine dparje(IHAD, I)
Definition: dpm25nuc7.f:4630
dbamje
subroutine dbamje(IHAD, KFA1, KFA2, KFA3, KFA4, AE0, IOPT)
Definition: dpm25nuc7.f:2374
r
jump r
Definition: plot.C:36
HepGeom::Transform3D::yz
double yz() const
Definition: Transform3D.h:267
dsfecf
subroutine dsfecf(SFE, CFE)
Definition: dpm25nuc7.f:3354
conuclx
subroutine conuclx(COOP1, NA, RASH, I)
Definition: dpm25nuc7.f:6084
xsglau
subroutine xsglau(NA, NB, IJPROJ, NTARG)
Definition: dpm25nuc7.f:5699
title
subroutine title(NA, NB, NCA, NCB)
Definition: dpm25nuc7.f:1744
c2_factory::log
static c2_log_p< float_type > & log()
make a *new object
Definition: c2_factory.hh:138
pylist
subroutine pylist(MLIST)
Definition: pythia61.f:37135
G4Abla::tau
G4double tau(G4double bet, G4double homega, G4double ef, G4double t)
Definition: G4Abla.cc:2586
pyjoin
subroutine pyjoin(NJOIN, IJOIN)
Definition: pythia61.f:31035
c2_factory::sqrt
static c2_sqrt_p< float_type > & sqrt()
make a *new object
Definition: c2_factory.hh:142
CLHEP::HepLorentzVector::pz
double pz() const
siinel
DOUBLE PRECISION function siinel(KPROJ, KTARG, UMO)
Definition: dpm25nuc7.f:6156
dchant
subroutine dchant
Definition: dpm25nuc7.f:3289
drtran
subroutine drtran(XO, YO, ZO, CDE, SDE, SFE, CFE, X, Y, Z)
Definition: dpm25nuc7.f:3265
sippsd
DOUBLE PRECISION function sippsd(ECM)
Definition: dpm25nuc7.f:6127
lundin
subroutine lundin
Definition: dpm25nuc7.f:62
c2_factory::cos
static c2_cos_p< float_type > & cos()
make a *new object
Definition: c2_factory.hh:134
dthrep
subroutine dthrep(UMO, ECM1, ECM2, ECM3, PCM1, PCM2, PCM3, COD1, COF1, SIF1, COD2, COF2, SIF2, COD3, COF3, SIF3, AM1, AM2, AM3)
Definition: dpm25nuc7.f:2748
test
program test
Definition: Main_HIJING.f:1
selpts
subroutine selpts(PTXSQ1, PTYSQ1, PLQ1, EQ1, PTXSA2, PTYSA2, PLAQ2, EAQ2, AMCH1, IREJ, IKVALA, PTTQ1)
Definition: dpm25nuc7.f:7324
xseapa
subroutine xseapa(ECM, XXXX, IPSQ1, IPSAQ1, XPSQ1, XPSAQ1, IREJ)
Definition: dpm25nuc7.f:1323
dbeta
DOUBLE PRECISION function dbeta(X1, X2, BET)
Definition: dpm25nuc7.f:2672
ns
#define ns
Definition: xmlparse.cc:597
dbklas
subroutine dbklas(I, J, K, I8, I10)
Definition: dpm25nuc7.f:6096
diagr
subroutine diagr(NA, NB, B, JS, JT, INT, INTA, INTB)
Definition: dpm25nuc7.f:1952
rannor
subroutine rannor(X, Y)
Definition: dpm25nulib.f:164
c2_factory::sin
static c2_sin_p< float_type > & sin()
make a *new object
Definition: c2_factory.hh:132
shmako
subroutine shmako(NA, NB, B, INTT, INTA, INTB, JS, JT, PPN, KKMAT)
Definition: dpm25nuc7.f:1606
left
Definition: F04UserTrackInformation.hh:37
c2_factory::exp
static c2_exp_p< float_type > & exp()
make a *new object
Definition: c2_factory.hh:140
Generated on Sat Dec 14 2013 14:33:24 for Geant4_10 by   doxygen 1.8.5