Geant4.10
 All Data Structures Namespaces Files Functions Variables Typedefs Enumerations Enumerator Friends Macros Groups Pages
dpm25nuc6.f
Go to the documentation of this file.
1 *
2 *===kkinc==============================================================*
3 *
4 **sr mod. for DPMJET: parameter list
5  SUBROUTINE kkinc(EPN,NTMASS,NTCHAR,NPMASS,NPCHAR,IDP,KKMAT,
6  *idt, nhkkh1,irej)
7 
8 ************************************************************************
9 * Treatment of complete nucleus-nucleus or hadron-nucleus scattering *
10 * This subroutine is an update of the previous version written *
11 * by J. Ranft/ H.-J. Moehring. *
12 * This version dated 19.11.95 is written by S. Roesler *
13 ************************************************************************
14 
15  IMPLICIT DOUBLE PRECISION (a-h,o-z)
16  SAVE
17  parameter(lout=6,llook=9)
18  parameter(zero=0.0d0,one=1.0d0,tiny5=1.0d-5,
19  & tiny2=1.0d-2,tiny3=1.0d-3)
20 
21  LOGICAL lfzc
22 
23  parameter(nmxhkk=89998)
24  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk),
25  & jmohkk(2,nmxhkk),jdahkk(2,nmxhkk),
26  & phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk(4,nmxhkk)
27  COMMON /extevt/ idres(nmxhkk),idxres(nmxhkk),nobam(nmxhkk),
28  & idbam(nmxhkk),idch(nmxhkk),npoint(10)
29  CHARACTER*8 aname
30  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),
31  & iich(210),iibar(210),k1(210),k2(210)
32 
33  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
34 **sr mod. for DPMJET: EPROJ needed
35  COMMON /nuccms/ gacms,bgcms,galab,bglab,blab,umo,pcm,eproj,pproj
36 **sr mod. for DPMJET: commons added
37  COMMON /final/ ifinal
38  COMMON /cmhico/ cmhis
39  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
40  COMMON /chabai/chargi,barnui
41  COMMON /nomije/ ptmije(10),nnmije(10)
42  COMMON /nncms/ gamcm,bgcm,umol,pcml,eprojl,pprojl
43  COMMON /edens/ieden
44  COMMON /xdidid/xdidi
45  COMMON /nstari/nstart
46  common/pyjets/nlu,npad,klu(4000,5),plu(4000,5),vlu(4000,5)
47  COMMON /felire/amrecd,kjpro
48  COMMON /neutyy/neutyp,neudec
49  COMMON /taufo/ taufor,ktauge,itauve,incmod
50 **
51 **sr mod. for DPMJET: set output flags
52  DATA kkcoun /0/
53  DATA chcoun /0/
54  DATA ficoun /0/
55  DATA taucou /0/
56  IF((taucou.EQ.0).AND.((it.EQ.1).AND.(ip.EQ.1)))THEN
57  taucou=taucou+1
58  ktauge=0
59  ENDIF
60  IF(ipev.GE.1)THEN
61  WRITE(6,*)'kkinc EPN,NTMASS,NTCHAR,NPMASS,NPCHAR,IDP,KKMAT',
62  *'IDT, NHKKH1,IREJ',
63  * epn,ntmass,ntchar,npmass,npchar,idp,kkmat,
64  *idt, nhkkh1,irej
65  ENDIF
66  ipri=0
67  irej=0
68 C--------------------------------------------------------------------
69  1889 CONTINUE
70  kkcoun=kkcoun+1
71  nevhkk=kkcoun
72 C DO 5371 IOK=1,200
73  IF(ipri.GE.1)WRITE(6,'(A,I10)') ' KKINC: KKCOUN=',kkcoun
74  IF(ipri.GE.1)WRITE(6,'(A,E20.8)') ' KKINC: EPN=',epn
75 C5371 CONTINUE
76 *---redefine characteristics of the actual interaction
77  IF(kkcoun.EQ.-721.OR.kkcoun.EQ.-821)THEN
78  iouxvo=iouxev
79  iouxev=6
80  ipevo=ipev
81  ipev=6
82  ippao=ippa
83  ippa=2
84  ipcoo=ipco
85  ipco=6
86  inito=init
87 C INIT=2
88  iprio=ipri
89  ipri=6
90  iphkko=iphkk
91 C IPHKK=6
92  ENDIF
93  IF(kkcoun.EQ.-39.OR.kkcoun.EQ.-822)THEN
94  iouxev=iouxvo
95  ipev=ipevo
96  ippa=ippao
97  ipco=ipcoo
98  init=inito
99  ipri=iprio
100  iphkk=iphkko
101  ENDIF
102 **
103 **sr mod. for DPMJET: minijet-statist. added
104 C NUMBER of JETS in event
105  DO iiii=1,10
106  nnmije(iiii)=0
107  ENDDO
108 **
109  iloop = 0
110  100 CONTINUE
111  irej=0
112  irej1=0
113  IF (iloop.EQ.40)THEN
114  WRITE(6,'(A)')' Rejection after 40 trials'
115  irej=1
116  RETURN
117  ENDIF
118  iloop = iloop+1
119 
120 * re-initialize /NUCC/
121  ip = npmass
122  ipz = npchar
123  it = ntmass
124  itz = ntchar
125  ijproj = idp
126  IF(neudec.GE.10)ijproj=5
127  IF(nstart.EQ.4.OR.nstart.EQ.2)ijproj=5
128  ijtarg = idt
129  ibproj = iibar(ijproj)
130  ibtarg = iibar(ijtarg)
131 
132 **sr mod. for DPMJET: quantum number check added
133 C Event Charge and Baryon number
134  chargi=itz
135  barnui=it
136  IF(ip.GT.1)THEN
137  chargi=chargi+ipz
138  barnui=barnui+ip
139  ELSE
140  chargi=chargi+iich(ijproj)
141  barnui=barnui+ibproj
142  ENDIF
143 **sr mod. for DPMJET: initialize /EXTEVT/ and /NUCCMS/
144  IF(ipev.GE.1)WRITE(6,*)' before EVTINI call'
145  CALL evtini(ijproj,ip,it,epn,ppn,ecm,nhkkh1,1)
146  IF(ipev.GE.1)WRITE(6,*)' after EVTINI call EPN',epn
147 **
148 
149 * calculate nuclear potentials (common /NUCLEA/)
150  IF(ipev.GE.1)WRITE(6,*)' before NCLPOT call'
151  IF(ip.GT.1.OR.it.GT.1)THEN
152  CALL nclpot(ipz,ip,itz,it,zero,zero,0)
153  ENDIF
154  IF(ipev.GE.1)WRITE(6,*)' after NCLPOT call'
155 
156 * initialize treatment for residual nuclei
157  IF(nstart.NE.2)THEN
158  IF(ipev.GE.1)WRITE(6,*)' before RESNCL call'
159  IF(ip.GT.1.OR.it.GT.1)THEN
160  CALL resncl(epn,1)
161  ENDIF
162  IF(ipev.GE.1)WRITE(6,*)' after RESNCL call EPN',epn
163  ENDIF
164 
165 * sample hadron/nucleus-nucleus interaction
166 **sr mod. for DPMJET: parameter list
167  IF(ipri.GE.1)WRITE(6,'(A,2E20.8,2I5)') ' KKINC call KKEVT: ',
168  * eproj,pproj,kkmat,irej1
169 C
170  IF(nstart.EQ.1)THEN
171 C h-h, h-A, A-A Collisions
172  CALL kkevt(nhkkh1,eproj,pproj,kkmat,irej1)
173  ELSEIF(nstart.EQ.2)THEN
174 C Neutrino-A Collisions (qeld code)
175  CALL kkevnu(nhkkh1,eproj,pproj,kkmat,irej1,ecm)
176  ELSEIF(nstart.EQ.3)THEN
177 C Diffr Interactions with nuclei
178  CALL kkevdi(nhkkh1,eproj,pproj,kkmat,irej1)
179  ELSEIF(nstart.EQ.4)THEN
180 C Neutrino-A Collisions (lepto code)
181  CALL kkevle(nhkkh1,eproj,pproj,kkmat,irej1)
182  ENDIF
183 C
184  IF(ipri.GE.1)WRITE(6,'(A,2E20.8,2I5)') ' KKINC after KKEVT: ',
185  * eproj,pproj,kkmat,irej1
186 C WRITE(6,'(A)')' KKEVT '
187  IF (irej1.GT.0)THEN
188  WRITE(6,'(A,I5)')' KKEVT Rejection KKCOUN ',kkcoun
189  RETURN
190  ENDIF
191 * initialize treatment for residual nuclei
192  IF(nstart.EQ.2)THEN
193  IF(ipev.GE.1)WRITE(6,*)' before RESNCL call'
194  IF(ip .GT.1.OR.it.GT.1)THEN
195  CALL resncl(epn,1)
196  ENDIF
197  IF(ipev.GE.1)WRITE(6,*)' after RESNCL call EPN',epn
198  ENDIF
199 
200 
201 **sr mod. for DPMJET: special ststistics
202 C IF(IPRI.GE.1)THEN
203 C DO 7735 IHKK=1,NHKK
204 C WRITE(6,1000) IHKK, ISTHKK(IHKK),IDHKK(IHKK),JMOHKK(1,IHKK),
205 C + JMOHKK(2,IHKK), JDAHKK(1,IHKK),JDAHKK(2,IHKK),(PHKK
206 C + (KHKK,IHKK),KHKK=1,5), (VHKK(KHKK,IHKK),KHKK=1,4)
207 C7735 CONTINUE
208 C ENDIF
209 C IREJ=0
210 C GOTO 100
211 C ENDIF
212 C IF (IPRI.GE.1.OR.IP.EQ.1)IREJ=0
213 C IF (IRESO.EQ.1) CALL DISRES(2,NHKKH1,PPN)
214  IF(ieden.EQ.0)CALL dechkk(nhkkh1)
215  IF(ipri.GE.7)THEN
216  WRITE(6,'(A)')' from KKINC after DECHKK'
217  DO 7835 ihkk=1,nhkk
218  WRITE(6,1000) ihkk, isthkk(ihkk),idhkk(ihkk),jmohkk(1,ihkk),
219  + jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),(phkk
220  + (khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
221  7835 CONTINUE
222  ENDIF
223 **
224 **sr mod. for DPMJET: get some information for fzc
225  IF(ipev.GE.1)WRITE(6,*)' before EVTINI call'
226  CALL evtini(ijproj,ip,it,epn,ppn,ecm,nhkkh1,2)
227  IF(ipev.GE.1)WRITE(6,*)' after EVTINI call'
228 **
229 * intranuclear cascade of final state particles for KTAUGE generations
230 * of secondaries
231  IF(ipev.GE.1)WRITE(6,*)' before FOZOCA call'
232  IF(ip .GT.1.OR.it.GT.1)THEN
233  CALL fozoca(lfzc,irej1)
234  ENDIF
235  IF(ipev.GE.1)WRITE(6,*)' after fozoca LFZC,IREJ1',lfzc,irej1
236  IF(ipev.GE.1)WRITE(6,*)' after FOZOCA call'
237  IF (irej1.GT.0)THEN
238  WRITE(6,'(A)')' FOZOCA Rejection'
239  RETURN
240  ENDIF
241 
242 * baryons unable to escape the nuclear potential are treated as
243 * excited nucleons (ISTHKK=15,16)
244  IF(ipev.GE.1)WRITE(6,*)' before SCN4BA call'
245  IF(ip .GT.1.OR.it.GT.1)THEN
246  CALL scn4ba
247  ENDIF
248  IF(ipev.GE.1)WRITE(6,*)' after SCN4BA call'
249 
250 * decay of resonances produced in intranuclear cascade processes
251 **sr 15-11-95 should be obsolete
252  IF (lfzc) CALL decay1
253 
254 * treatment of residual nuclei
255  IF(ipev.GE.1)WRITE(6,*)' before RESNCL call'
256  IF(ip .GT.1.OR.it.GT.1)THEN
257  CALL resncl(epn,2)
258  ENDIF
259  IF(ipev.GE.1)WRITE(6,*)' after RESNCL call'
260 
261 * evaporation / fission / fragmentation
262 * (if intranuclear cascade was sampled only)
263 **sr mod. for DPMJET: check for IFINAL-flag
264  IF ((lfzc).AND.(ifinal.EQ.0)) THEN
265  IF(ipri.GE.1)THEN
266  WRITE(6,'(A)')' from KKINC before FICONF'
267  DO 7935 ihkk=1,nhkk
268  WRITE(6,1005) ihkk, isthkk(ihkk),idhkk(ihkk),jmohkk(1,ihkk),
269  + jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),(phkk
270  + (khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
271  + ,idres(ihkk),idxres(ihkk),nobam(ihkk),
272  & idbam(ihkk),idch(ihkk)
273  1005 FORMAT (i6,i4,5i6,9(1pe10.2)/5i6)
274  7935 CONTINUE
275  ENDIF
276  IF(ipev.GE.1)WRITE(6,*)' before FICONF call'
277  IF(ip .GT.1.OR.it.GT.1)THEN
278  CALL ficonf(ijproj,ip,ipz,it,itz,irej1)
279  ENDIF
280  IF(ipev.GE.1)WRITE(6,*)' after FICONF call IREJ1',irej1
281 C-----------------------------------------------------------
282 C Write events to file qeld.evt
283 C-----------------------------------------------------------
284  IF (irej1.EQ.0.AND.nstart.EQ.2) THEN
285  iiii=0
286  iiimax = 5
287  IF(neudec.EQ.10.OR.neudec.EQ.11)THEN
288  iiimax = 7
289  ENDIF
290  IF(klu(1,2).EQ.16.OR.klu(1,2).EQ.-16)THEN
291  IF(neudec.EQ.1.OR.neudec.EQ.2)THEN
292  iiimax = 6
293  ENDIF
294  ENDIF
295  DO 266 iii=1,iiimax
296  IF(klu(iii,1).EQ.1.OR.iii.LE.2) THEN
297  iiii=iiii+1
298  WRITE(29,'(3I6,5F10.3)')iiii,klu(iii,1),klu(iii,2),
299  * (plu(iii,kk),kk=1,5)
300  ENDIF
301  266 CONTINUE
302  iiii=-1
303  WRITE(29,'(I6)')iiii
304  ENDIF
305 C-----------------------------------------------------------
306  IF (irej1.EQ.1) THEN
307  ficoun=ficoun+1
308  IF(ficoun.LE.20)WRITE(6,'(A)')' FICONF Rejection'
309 C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
310  IF(nstart.EQ.3)THEN
311  kform=2
312  IF(kform.EQ.1)THEN
313  aabbcc=0.
314  ELSEIF(kform.EQ.2)THEN
315 C the following 3 lines only for 6 (J/psi)
316  READ(29,'(1X,I5)')krepa
317  READ(29,'(1X,I5)')krepa
318  READ(29,'(1X,I5)')krepa
319 C
320  READ(29,'(1X,I5)')krepa
321  DO 1975 kre=1,krepa
322  READ(29,'(1X,A)')a109
323  1975 CONTINUE
324  ENDIF
325  ENDIF
326 C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
327 
328 C GOTO 100
329  ENDIF
330  ENDIF
331 
332 **sr mod. for DPMJET: checks, histograms, ...
333  iphihi=0
334  DO 7501 ihkk=1,nhkkh1
335  IF(idhkk(ihkk).EQ.88888)THEN
336 C PPTT=PHKK(1,IHKK)**2+PHKK(2,IHKK)**2
337 C IF(PPTT.LE.1.D-12)THEN
338 C IPHIHI=1
339 C WRITE(6,*)'pt=0 IHKK,IDHKK(IHKK),PHKK(1,IHKK),PHKK(2,IHKK) ',
340 C * IHKK,ISTHKK(IHKK),IDHKK(IHKK),PHKK(1,IHKK),PHKK(2,IHKK)
341 C ENDIF
342  IF(phkk(5,ihkk).LE.1.d-10)THEN
343  iphihi=1
344  WRITE(6,*)'M=0 IHKK,IDHKK(IHKK),PHKK(4,IHKK),PHKK(5,IHKK) ',
345  * ihkk,isthkk(ihkk),idhkk(ihkk),phkk(4,ihkk),phkk(5,ihkk)
346  ENDIF
347  IF(jmohkk(1,ihkk).GE.ihkk)THEN
348  iphihi=1
349  WRITE(6,*)'MO=0 IHKK,IDHKK(IHKK),PHKK(4,IHKK),PHKK(5,IHKK) ',
350  * ihkk,isthkk(ihkk),idhkk(ihkk),jmohkk(1,ihkk),
351  * phkk(4,ihkk),phkk(5,ihkk)
352  ENDIF
353  ENDIF
354  7501 CONTINUE
355  DO 501 ihkk=nhkkh1,nhkk
356  IF(isthkk(ihkk).EQ.1)THEN
357  pptt=phkk(1,ihkk)**2+phkk(2,ihkk)**2
358  IF(pptt.LE.1.d-18)THEN
359  iphihi=1
360  WRITE(6,*)' pt=0 IHKK,PHKK(1,IHKK),PHKK(2,IHKK) ',
361  * ihkk,phkk(1,ihkk),phkk(2,ihkk)
362  ENDIF
363  IF(jmohkk(1,ihkk).GT.ihkk)THEN
364  iphihi=1
365  WRITE(6,*)'MO=0 IHKK,IDHKK(IHKK),PHKK(4,IHKK),PHKK(5,IHKK) ',
366  * ihkk,isthkk(ihkk),idhkk(ihkk),jmohkk(1,ihkk),
367  * phkk(4,ihkk),phkk(5,ihkk)
368  ENDIF
369  IF(idhkk(ihkk).EQ.14.OR.idhkk(ihkk).EQ.-14)THEN
370 C IPHIHI=1
371  WRITE(6,*)'14-14IHKK,IDHKK(IHKK),PHKK(4,IHKK),PHKK(5,IHKK) ',
372  * ihkk,isthkk(ihkk),idhkk(ihkk),jmohkk(1,ihkk),
373  * phkk(4,ihkk),phkk(5,ihkk)
374  ENDIF
375  ENDIF
376  501 CONTINUE
377  IF (iphihi.GE.1) THEN
378  WRITE(6,'(/A/)') ' KKINC: One particle with pt=0. !!!!'
379  IF (iphkk.GE.-1) THEN
380  DO 502 ihkk=1,nhkk
381  WRITE(6,1000) ihkk,isthkk(ihkk),idhkk(ihkk),jmohkk(1,ihkk),
382  + jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),(phkk
383  + (khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
384  502 CONTINUE
385  ENDIF
386  ENDIF
387  IF (iphkk.GE.1) THEN
388  WRITE(6,'(/A/)') ' KKINC: FINAL LIST OF ENTRIES TO /HKKEVT/'
389  DO 50 ihkk=1,nhkk
390  WRITE(6,1000) ihkk,isthkk(ihkk),idhkk(ihkk),jmohkk(1,ihkk),
391  + jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),(phkk
392  + (khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
393  1000 FORMAT (i6,i4,5i6,9(1pe10.2))
394  50 CONTINUE
395  ENDIF
396 C
397 C fix KTAUAC later
398  ktauac=99
399 
400  IF(ipev.GE.1)THEN
401  WRITE(6,'(A,2F15.5)')' GACMS,BGCMS',gacms,bgcms
402  ENDIF
403 C------------------------------------------------------------------
404 C Up to here the events (PHKK(J,I)) are in cms
405 C transform back to lab for cmhis=0 (lab histograms)
406 C
407 C But VHKK(J,I) is in Lab frame
408 C transform into cms for CMHIS >= 1
409 C------------------------------------------------------------------
410  IF(kkcoun.LE.-50)THEN
411  WRITE(6,*)' Event from dpmjet (only final particles):'
412  WRITE(6,*)' before transf. into lab frame '
413  DO 7737 ihkk=1,nhkk
414  IF((isthkk(ihkk).EQ.-1).OR.
415  * (isthkk(ihkk).EQ.1).OR.
416  * (isthkk(ihkk).EQ.1001))THEN
417  WRITE(6,1055) ihkk, isthkk(ihkk),idhkk(ihkk),jmohkk(1,ihkk),
418  + jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),(phkk
419  + (khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
420  + , (whkk(khkk,ihkk),khkk=1,4)
421  + ,idres(ihkk),idxres(ihkk),nobam(ihkk),
422  & idbam(ihkk),idch(ihkk)
423  ENDIF
424  7737 CONTINUE
425  ENDIF
426  IF(ipev.GE.1)WRITE(6,*)' before transf. into lab frame '
427  DO 20 i=nhkkh1+1,nhkk
428  pznn=phkk(3,i)
429  enn =phkk(4,i)
430  zzzz=vhkk(3,i)
431  tttt=vhkk(4,i)
432  IF (cmhis.EQ.0.d0)THEN
433  IF(isthkk(i).NE.16.AND.isthkk(i).NE.15)THEN
434  phkk(3,i) = gacms*pznn + bgcms*enn
435  phkk(4,i) = gacms*enn + bgcms*pznn
436 C PHKK(3,I) = GAMCM*PZNN + BGCM*ENN
437 C PHKK(4,I) = GAMCM*ENN + BGCM*PZNN
438  ENDIF
439  ENDIF
440  IF(cmhis.GE.1.d0)THEN
441  vhkk(3,i) = gacms*zzzz - bgcms*tttt
442  vhkk(4,i) = gacms*tttt - bgcms*zzzz
443 C VHKK(3,I) = GAMCM*ZZZZ - BGCM*TTTT
444 C VHKK(4,I) = GAMCM*TTTT - BGCM*ZZZZ
445  ENDIF
446  ehecc=sqrt(phkk(1,i)** 2+ phkk(2,i)** 2+ phkk(3,i)** 2+ phkk
447  + (5,i)**2)
448  IF (abs(ehecc-phkk(4,i)).GT.0.001) THEN
449 C WRITE(6,'(2A/3I5,3E16.6)')
450 C & ' KKINC: CORRECT INCONSISTENT ENERGY ',
451 C * ' IEVCOU, I,IDHKK(I), PHKK(4,I),EHECC, PHKK(5,I)',
452 C * IEVCOU, I,IDHKK(I), PHKK(4,I),EHECC, PHKK(5,I)
453  phkk(4,i)=ehecc
454  ENDIF
455  20 CONTINUE
456  IF(ipev.GE.1)WRITE(6,*)' after transf. into lab frame '
457  IF(ipev.GE.1)THEN
458 C IF ((LFZC).AND.(IFINAL.EQ.0)) THEN
459  IF(ipev.GE.1) WRITE(6,'(A)')' before CHECKF'
460  DO 7135 ihkk=1,nhkk
461  WRITE(6,1055) ihkk, isthkk(ihkk),idhkk(ihkk),jmohkk(1,ihkk),
462  + jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),(phkk
463  + (khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
464  + , (whkk(khkk,ihkk),khkk=1,4)
465  + ,idres(ihkk),idxres(ihkk),nobam(ihkk),
466  & idbam(ihkk),idch(ihkk)
467  1055 FORMAT (i6,i4,5i6/7(1pe11.3)/6(1pe11.3)/5i6)
468  7135 CONTINUE
469 C ENDIF
470  ENDIF
471  IF(ip.LE.208.AND.nstart.EQ.1)THEN
472  IF ((lfzc).AND.(ifinal.EQ.0)) THEN
473  IF(ipev.GE.1) WRITE(6,'(A)')' before CHECKF'
474  IF ((cmhis.EQ.0.d0))
475  + CALL checkf(eproj,pproj,irej,1)
476  ELSE
477  IF ((cmhis.EQ.0.d0))
478  + CALL checko(eproj,pproj,irej,1)
479  ENDIF
480  ENDIF
481  IF(irej.EQ.1)THEN
482 C WRITE(6,'(A,I5)')' CHECKF/O IREJ ',IREJ
483 C DO 4135 IHKK=1,NHKK
484 C WRITE(6,1055) IHKK, ISTHKK(IHKK),IDHKK(IHKK),JMOHKK(1,IHKK),
485 C + JMOHKK(2,IHKK), JDAHKK(1,IHKK),JDAHKK(2,IHKK),(PHKK
486 C + (KHKK,IHKK),KHKK=1,5), (VHKK(KHKK,IHKK),KHKK=1,4)
487 C + ,IDRES(IHKK),IDXRES(IHKK),NOBAM(IHKK),
488 C & IDBAM(IHKK),IDCH(IHKK)
489 C4135 CONTINUE
490  IF(kkcoun.LE.1000)THEN
491  WRITE(6,7734)kkcoun
492  7734 FORMAT(' KKCOUN=',i10)
493  ENDIF
494  IF(ipev.GE.1) WRITE(6,'(A)')' after CHECKF'
495  IF(ipri.GE.1)THEN
496  DO 7735 ihkk=1,nhkk
497  WRITE(6,1055) ihkk, isthkk(ihkk),idhkk(ihkk),jmohkk(1,ihkk),
498  + jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),(phkk
499  + (khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
500  + , (whkk(khkk,ihkk),khkk=1,4)
501  + ,idres(ihkk),idxres(ihkk),nobam(ihkk),
502  & idbam(ihkk),idch(ihkk)
503  7735 CONTINUE
504  ENDIF
505  irej=0
506  IF(kkcoun.LE.500)THEN
507  IF ((lfzc).AND.(ifinal.EQ.0)) THEN
508  WRITE(6,'(A)')' CHECKF Rejection'
509  ELSE
510  WRITE(6,'(A)')' CHECKO Rejection'
511  ENDIF
512  ENDIF
513  goto 100
514  ENDIF
515  IF(nstart.EQ.4.OR.nstart.EQ.2)THEN
516  IF(ipev.GE.1) WRITE(6,'(A)')' before CHECKN'
517  IF ((cmhis.EQ.0.d0).AND.neudec.NE.20)
518  + CALL checkn(eproj,pproj,irej,1)
519  IF(kkcoun.LE.500)THEN
520  IF(irej.EQ.1)WRITE(6,'(A)')' CHECKN Rejection'
521 C IREJ=0
522  ENDIF
523  ENDIF
524 
525 C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
526 C& Writing file diffnuc2.evt for NSTART=3
527 C
528  IF(nstart.EQ.3.AND.irej.EQ.0)THEN
529  kform=2
530  IF(kform.EQ.1)THEN
531  aabbcc=0.
532  ELSEIF(kform.EQ.2.AND.irej.EQ.0)THEN
533  WRITE(33,'(I6,E12.4)')kjpro,amrecd
534 C The following only for 6 (J/psi)
535  READ(29,'(1X,I5,4E18.10)')imist,xxx1,xxx2,xxx3,xxx4
536  WRITE(33,'(1X,I5,4E18.10)')imist,xxx1,xxx2,xxx3,xxx4
537  READ(29,'(1X,I5,4E18.10)')imist,xxx1,xxx2,xxx3,xxx4
538  READ(29,'(1X,I5,4E18.10)')imist,xxx1,xxx2,xxx3,xxx4
539 C
540  READ(29,'(1X,I5)')krepa
541  WRITE(33,'(1X,I5)')krepa
542  DO 1977 kre=1,krepa
543  READ(29,'(1X,A)')a109
544  WRITE(33,'(1X,A)')a109
545  1977 CONTINUE
546  ENDIF
547  WRITE(33,*)' Event from dpmjet (only final particles):',
548  * 'in Nucleus rest frame'
549  DO 1976 ihkk=1,nhkk
550  IF((isthkk(ihkk).EQ.-1).OR.
551  * (isthkk(ihkk).EQ.1).OR.
552  * (isthkk(ihkk).EQ.1001))THEN
553  WRITE(33,'(2I6,5E18.10,2I6)') isthkk(ihkk),idhkk(ihkk),
554  + (phkk(khkk,ihkk),khkk=1,5)
555  + ,idres(ihkk),idxres(ihkk)
556  ENDIF
557  1976 CONTINUE
558  ENDIF
559 C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
560  IF(nstart.EQ.1)THEN
561  IF(ipev.GE.1) WRITE(6,'(A)')' before CHEBCH '
562  IF ((cmhis.EQ.0.d0))THEN
563  IF(ip.NE.it.AND.it.GT.1) CALL chebch(irej,nhkkh1)
564  IF((irej.EQ.1))THEN
565  chcoun=chcoun+1
566  IF(chcoun.LE.50)THEN
567  WRITE(6,'(A)')' CHEBCH Rejection'
568  WRITE(6,'(A,I10)') ' KKINC: KKCOUN=',kkcoun
569  ENDIF
570  goto 100
571  ENDIF
572  ENDIF
573  IF(ipev.GE.1)WRITE(6,'(A)')'after CHEBCH before histograms'
574  ENDIF
575  IF(neudec.EQ.20)CALL backdpm
576  supx=0.d0
577  supy=0.d0
578  supz=0.d0
579  IF(kkcoun.LE.50.AND.nstart.GE.2)THEN
580  WRITE(6,*)' Event from dpmjet (only final particles):'
581  DO 7736 ihkk=1,nhkk
582  IF((isthkk(ihkk).EQ.-1).OR.
583  * (isthkk(ihkk).EQ.1).OR.
584  * (isthkk(ihkk).EQ.1001))THEN
585  supx=supx+phkk(1,ihkk)
586  supy=supy+phkk(2,ihkk)
587  supz=supz+phkk(3,ihkk)
588  WRITE(6,1055) ihkk, isthkk(ihkk),idhkk(ihkk),jmohkk(1,ihkk),
589  + jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),(phkk
590  + (khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
591  + , (whkk(khkk,ihkk),khkk=1,4)
592  + ,idres(ihkk),idxres(ihkk),nobam(ihkk),
593  & idbam(ihkk),idch(ihkk)
594  ENDIF
595  7736 CONTINUE
596  WRITE(6,*)' SUPX,SUPY,SUPZ ',supx,supy,supz
597  ENDIF
598 CGB
599 CGB Output from G. Battistoni
600 CGB
601  IF(nhkk.LE.0) THEN
602  WRITE(6,*)' KKINC ', nhkk
603  DO jgb = 1,nhkk
604  IF(isthkk(jgb).EQ.1001)THEN
605  WRITE(6,*)jgb, isthkk(jgb),idhkk(jgb),
606  * jmohkk(1,jgb),jmohkk(2,jgb),jdahkk(1,jgb),jdahkk(2,jgb),
607  * phkk(1,jgb),phkk(2,jgb)
608  * ,phkk(3,jgb),phkk(4,jgb),phkk(5,jgb)
609  + ,idres(jgb),idxres(jgb),nobam(jgb),idbam(jgb),idch(jgb)
610  ENDIF
611  END DO
612  ENDIF
613 CGB
614 C
615  IF(nstart.EQ.1)THEN
616 C Random azimuthal rotation
617  CALL dsfecf(sfee,cfee)
618  DO jgb = 1,nhkk
619  xxee=phkk(1,jgb)
620  yyee=phkk(2,jgb)
621  phkk(1,jgb)=xxee*cfee-yyee*sfee
622  phkk(2,jgb)=xxee*sfee+yyee*cfee
623  END DO
624  ENDIF
625 C WRITE(6,'(A,I10)')' kkinc ',CMHIS
626 C IF(XDIDI.GT.0.1D0)THEN
627  IF (cmhis.EQ.0.d0) CALL distr(2,nhkkh1,ppn,ktauac)
628  IF (cmhis.EQ.1.d0) CALL distrc(2,nhkkh1,ppn,ktauac)
629  IF (cmhis.EQ.2.d0) CALL distco(2,nhkkh1,ppn,ktauac)
630 C IF (IPRI.GE.2) CALL CHECKE(EPN,PPN)
631 C ENDIF
632 C-----------
633 **
634  RETURN
635  END
636 
637 **sr mod. for DPMJET: short version of the original DTUNUC-routine
638 *
639 *===defaux=============================================================*
640 *
641  SUBROUTINE defaux(EPN,PPN)
642 
643 ************************************************************************
644 * Variables are set to default values. *
645 * This version dated 19.11.95 is written by S. Roesler. *
646 ************************************************************************
647 
648  IMPLICIT DOUBLE PRECISION (a-h,o-z)
649  SAVE
650  parameter(zero=0.0d0,one=1.0d0)
651 
652  COMMON /nuclea/ pfermp(2),pfermn(2),fermod,
653  & ebindp(2),ebindn(2),epot(2,210),
654  & etacou(2),icoul
655  LOGICAL lemcck,lhadro,lseadi
656  COMMON /flags/ ifrag(2),iresco,imshl,iresrj,
657  & lemcck,lhadro(0:9),lseadi
658 
659  DATA potmes /0.002d0/
660 
661 * common /NUCLEA/
662  DO 10 i=1,2
663  pfermp(i) = zero
664  pfermn(i) = zero
665  ebindp(i) = zero
666  ebindn(i) = zero
667  DO 11 j=1,210
668  epot(i,j) = zero
669  11 CONTINUE
670 * nucleus independent meson potential
671  epot(i,13) = potmes
672  epot(i,14) = potmes
673  epot(i,15) = potmes
674  epot(i,16) = potmes
675  epot(i,23) = potmes
676  epot(i,24) = potmes
677  epot(i,25) = potmes
678  10 CONTINUE
679  fermod = 0.95d0
680  etacou(1) = zero
681  etacou(2) = zero
682  icoul = 1
683 
684 * common /FLAGS/
685  ifrag(1) = 2
686  ifrag(2) = 1
687  iresco = 1
688  imshl = 1
689  iresrj = 0
690  lemcck = .true.
691  lhadro(0) = .false.
692  DO 13 i=1,9
693  lhadro(i) = .true.
694  13 CONTINUE
695  lseadi = .true.
696 
697  RETURN
698  END
699 *
700 *===nclpot=============================================================*
701 *
702  SUBROUTINE nclpot(IPZ,IP,ITZ,IT,AFERP,AFERT,MODE)
703 
704 ************************************************************************
705 * Calculation of Coulomb and nuclear potential for a given configurat. *
706 * IPZ, IP charge/mass number of proj. *
707 * ITZ, IT charge/mass number of targ. *
708 * AFERP,AFERT factors modifying proj./target pot. *
709 * if =0, FERMOD is used *
710 * MODE = 0 calculation of binding energy *
711 * = 1 pre-calculated binding energy is used *
712 * This version dated 16.11.95 is written by S. Roesler. *
713 ************************************************************************
714 
715  IMPLICIT DOUBLE PRECISION (a-h,o-z)
716  SAVE
717  parameter(lout=6,llook=9)
718  parameter(zero=0.0d0,one=1.0d0,tiny3=1.0d-3,tiny2=1.0d-2,
719  & tiny10=1.0d-10)
720 
721  LOGICAL lstart
722 
723  CHARACTER*8 aname
724  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),
725  & iich(210),iibar(210),k1(210),k2(210)
726 
727 **sr mod. for DPMJET: use the longer DPMJET one
728  LOGICAL intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada, ipadis,
729  & ishmal,lpauli
730  COMMON /droppt/ intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada,
731  & ipadis,ishmal,lpauli
732 **
733  COMMON /nuclea/ pfermp(2),pfermn(2),fermod,
734  & ebindp(2),ebindn(2),epot(2,210),
735  & etacou(2),icoul
736 **sr mod. for DPMJET: the corresponding common in DPMJET
737  COMMON /nucimp/ prmom(5,248),tamom(5,248), prmfep,prmfen,tamfep,
738  +tamfen, prefep,prefen,taefep,taefen, prepot(210),taepot(210),
739  +prebin,taebin,ferfac,ecou
740 **
741 
742  dimension idxpot(14)
743 * ap an lam alam sig- sig+ sig0 tet0 tet- asig-
744  DATA idxpot / 2, 9, 17, 18, 20, 21, 22, 97, 98, 99,
745 * asig0 asig+ atet0 atet+
746  & 100, 101, 102, 103/
747 
748  DATA an /0.4d0/
749  DATA lstart /.true./
750 
751  IF (mode.EQ.0) THEN
752  ebindp(1) = zero
753  ebindn(1) = zero
754  ebindp(2) = zero
755  ebindn(2) = zero
756  ENDIF
757  aip = dble(ip)
758  aipz = dble(ipz)
759  ait = dble(it)
760  aitz = dble(itz)
761 
762  fermip = aferp
763  IF (aferp.LE.zero) fermip = fermod
764  fermit = afert
765  IF (afert.LE.zero) fermit = fermod
766 
767 * Fermi momenta and binding energy for projectile
768  IF ((ip.GT.1).AND.(fermp)) THEN
769  IF (mode.EQ.0) THEN
770 C EBINDP(1) = EBIND(IP,IPZ)-EBIND(IP-1,IPZ-1)
771 C EBINDN(1) = EBIND(IP,IPZ)-EBIND(IP-1,IPZ)
772  bip = aip -one
773  bipz = aipz-one
774  ebindp(1) = 1.0d-3*abs(energy(aip,aipz)-energy(bip,bipz))
775  ebindn(1) = 1.0d-3*abs(energy(aip,aipz)-energy(bip,aipz))
776  ENDIF
777  pfermp(1) = fermip*an*(aipz/aip)**0.333333d0
778  pfermn(1) = fermip*an*((aip-aipz)/aip)**0.33333d0
779  ELSE
780  pfermp(1) = zero
781  pfermn(1) = zero
782  ENDIF
783 * effective nuclear potential for projectile
784 C EPOT(1,1) = PFERMP(1)**2/(2.0D0*AAM(1)) + EBINDP(1)
785 C EPOT(1,8) = PFERMN(1)**2/(2.0D0*AAM(8)) + EBINDN(1)
786  epot(1,1) = sqrt(pfermp(1)**2+aam(1)**2) -aam(1) + ebindp(1)
787  epot(1,8) = sqrt(pfermn(1)**2+aam(8)**2) -aam(8) + ebindn(1)
788 
789 * Fermi momenta and binding energy for target
790  IF ((it.GT.1).AND.(fermp)) THEN
791  IF (mode.EQ.0) THEN
792 C EBINDP(2) = EBIND(IT,ITZ)-EBIND(IT-1,ITZ-1)
793 C EBINDN(2) = EBIND(IT,ITZ)-EBIND(IT-1,ITZ)
794  bit = ait -one
795  bitz = aitz-one
796  ebindp(2) = 1.0d-3*abs(energy(ait,aitz)-energy(bit,bitz))
797  ebindn(2) = 1.0d-3*abs(energy(ait,aitz)-energy(bit,aitz))
798  ENDIF
799  pfermp(2) = fermit*an*(aitz/ait)**0.333333d0
800  pfermn(2) = fermit*an*((ait-aitz)/ait)**0.33333d0
801  ELSE
802  pfermp(2) = zero
803  pfermn(2) = zero
804  ENDIF
805 * effective nuclear potential for target
806 C EPOT(2,1) = PFERMP(2)**2/(2.0D0*AAM(1)) + EBINDP(2)
807 C EPOT(2,8) = PFERMN(2)**2/(2.0D0*AAM(8)) + EBINDN(2)
808  epot(2,1) = sqrt(pfermp(2)**2+aam(1)**2) -aam(1) + ebindp(2)
809  epot(2,8) = sqrt(pfermn(2)**2+aam(8)**2) -aam(8) + ebindn(2)
810 
811  DO 2 i=1,14
812  epot(1,idxpot(i)) = epot(1,8)
813  epot(2,idxpot(i)) = epot(2,8)
814  2 CONTINUE
815 
816 * Coulomb energy
817  etacou(1) = zero
818  etacou(2) = zero
819  IF (icoul.EQ.1) THEN
820  IF (ip.GT.1)
821  & etacou(1) = 0.001116d0*aipz/(1.0d0+aip**0.333d0)
822  IF (it.GT.1)
823  & etacou(2) = 0.001116d0*aitz/(1.0d0+ait**0.333d0)
824  ENDIF
825 
826  IF (lstart) THEN
827  WRITE(lout,1000) ip,ipz,it,itz,ebindp,ebindn,
828  & epot(1,1)-ebindp(1),epot(2,1)-ebindp(2),
829  & epot(1,8)-ebindn(1),epot(2,8)-ebindn(2),
830  & fermod,etacou
831  1000 FORMAT(/,/,1x,'NCLPOT: quantities for inclusion of nuclear'
832  & ,' effects',/,12x,'---------------------------',
833  & '----------------',/,/,38x,'projectile',
834  & ' target',/,/,1x,'Mass number / charge',
835  & 17x,i3,' /',i3,6x,i3,' /',i3,/,1x,'Binding energy -',
836  & ' proton (GeV) ',2e14.4,/,17x,'- neutron (GeV)'
837  & ,1x,2e14.4,/,1x,'Fermi-potential - proton (GeV)',
838  & 1x,2e14.4,/,17x,'- neutron (GeV) ',2e14.4,/,/,
839  & 1x,'Scale factor for Fermi-momentum ',f4.2,/,
840  & /,1x,'Coulomb-energy ',2(e14.4,' GeV '),/,/)
841  lstart = .false.
842  ENDIF
843 
844 **sr mod. for DPMJET: fill /NUCIMP/
845  prebnn = zero
846  prebpn = zero
847  prmfep = zero
848  prmfen = zero
849  IF ((ip.GT.1).AND.(fermp)) THEN
850  prebnn = ebindn(1)
851  prebpn = ebindp(1)
852  prmfep = pfermp(1)
853  prmfen = pfermn(1)
854  ENDIF
855  prefen = prmfen**2/(2.*aam(8))
856  prefep = prmfep**2/(2.*aam(1))
857  prepot(1) = prefep + prebpn
858  prepot(8) = prefen + prebnn
859  taebnn = zero
860  taebpn = zero
861  tamfep = zero
862  tamfen = zero
863  IF ((it.GT.1).AND.(fermp)) THEN
864  taebnn = ebindn(2)
865  taebpn = ebindp(2)
866  tamfep = pfermp(2)
867  tamfen = pfermn(2)
868  ENDIF
869  taefep = tamfep**2/(2.*aam(1))
870  taefen = tamfen**2/(2.*aam(8))
871  taepot(1) = taefep + taebpn
872  taepot(8) = taefen + taebnn
873  DO 3 i=1,14
874  taepot(idxpot(i)) = taepot(8)
875  3 CONTINUE
876  ecou = etacou(2)
877  ferfac = fermod
878 **
879 
880  RETURN
881  END
882 *
883 *===resncl=============================================================*
884 *
885  SUBROUTINE resncl(EPN,MODE)
886 
887 ************************************************************************
888 * Treatment of residual nuclei and nuclear effects. *
889 * MODE = 1 initializations *
890 * = 2 treatment of final state *
891 * This version dated 16.11.95 is written by S. Roesler. *
892 ************************************************************************
893 
894  IMPLICIT DOUBLE PRECISION (a-h,o-z)
895  SAVE
896  parameter(lout=6,llook=9)
897  parameter(zero=0.0d0,one=1.0d0,tiny3=1.0d-3,tiny2=1.0d-2,
898  & tiny1=1.0d-1,tiny4=1.0d-4,tiny10=1.0d-10)
899  parameter(amuamu=0.93149432d0)
900 
901 
902  parameter(nmxhkk=89998)
903  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk),
904  & jmohkk(2,nmxhkk),jdahkk(2,nmxhkk),
905  & phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk(4,nmxhkk)
906  COMMON /extevt/ idres(nmxhkk),idxres(nmxhkk),nobam(nmxhkk),
907  & idbam(nmxhkk),idch(nmxhkk),npoint(10)
908  CHARACTER*8 aname
909  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),
910  & iich(210),iibar(210),k1(210),k2(210)
911 
912  LOGICAL lemcck,lhadro,lseadi
913  COMMON /flags/ ifrag(2),iresco,imshl,iresrj,
914  & lemcck,lhadro(0:9),lseadi
915  COMMON /nuclea/ pfermp(2),pfermn(2),fermod,
916  & ebindp(2),ebindn(2),epot(2,210),
917  & etacou(2),icoul
918 **sr mod. for DPMJET: use the longer DPMJET one
919  LOGICAL intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada, ipadis,
920  & ishmal,lpauli
921  COMMON /droppt/ intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada,
922  & ipadis,ishmal,lpauli
923 **
924  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
925  COMMON /nuccms/ gacms,bgcms,galab,bglab,blab,umo,pcm,eproj,pproj
926  COMMON /wndncl/ npw,npw0,npcw,ntw,ntw0,ntcw
927  LOGICAL lrclpr,lrclta
928  COMMON /finsta/ pinipr(5),pinita(5),prclpr(5),prclta(5)
929  &, lrclpr,lrclta
930  COMMON /nstari/nstart
931  COMMON /neutyy/neutyp,neudec
932  dimension pfsp(4),psec(4),psec0(4)
933 
934  goto(1,2) mode
935 
936 *------- initializations
937  1 CONTINUE
938 
939 * initialize arrays for residual nuclei
940  DO 10 k=1,5
941  IF (k.LE.4) THEN
942  pfsp(k) = zero
943  ENDIF
944  pinipr(k) = zero
945  pinita(k) = zero
946  prclpr(k) = zero
947  prclta(k) = zero
948  10 CONTINUE
949 
950 * projectile in n-n cms
951  aip = dble(ip)
952  aipz = dble(ipz)
953  pinipr(4) = aip*umo/2.0d0
954  pinipr(5) = aip*amuamu+1.0d-3*energy(aip,aipz)
955  IF (ip.LE.1) pinipr(5) = aam(ijproj)
956  pinipr(3) = sqrt((pinipr(4)-pinipr(5))*(pinipr(4)+pinipr(5)))
957 C WRITE(6,*)PINIPR,'PINIPR,1'
958 * target in n-n cms
959  ait = dble(it)
960  aitz = dble(itz)
961  pinita(4) = ait*umo/2.0d0
962  pinita(5) = ait*amuamu+1.0d-3*energy(ait,aitz)
963 C WRITE(6,*)'UMO,PINITA(4),GACMS',UMO,PINITA(4),GACMS
964  IF(pinita(4).LE.pinita(5))THEN
965  pinita(4)=gacms*pinita(5)
966 C WRITE(6,*)'UMO,PINITA(4),GACMS',UMO,PINITA(4),GACMS
967  ENDIF
968  IF(nstart.EQ.2)THEN
969  pinita(4)=gacms*pinita(5)
970 C WRITE(6,*)'UMO,PINITA(4),GACMS',UMO,PINITA(4),GACMS
971  ENDIF
972  IF (it.LE.1) pinita(5) = aam(ijtarg)
973  pinita(3) = -sqrt((pinita(4)-pinita(5))*(pinita(4)+pinita(5)))
974 C WRITE(6,*)PINITA,'PINITA,1'
975 
976 * correction of projectile 4-momentum for effective target pot.
977 * and Coulomb-energy (in case of hadron-nucleus interaction only)
978  IF ((ip.EQ.1).AND.(it.GT.1).AND.(fermp)) THEN
979  epni = epn
980 * Coulomb-energy:
981 * positively charged hadron - check energy for Coloumb pot.
982  IF (iich(ijproj).EQ.1) THEN
983  thresh = etacou(2)+aam(ijproj)
984  IF (epni.LE.thresh) THEN
985  WRITE(lout,1000)
986  1000 FORMAT(/,1x,'KKINC: WARNING! projectile energy',
987  & ' below Coulomb threshold - event rejected',/)
988  isthkk(1) = 1
989  RETURN
990  ENDIF
991 * negatively charged hadron - increase energy by Coulomb energy
992  ELSEIF (iich(ijproj).EQ.-1) THEN
993  epni = epni+etacou(2)
994  ENDIF
995 * Effective target potential
996 C EPNI = EPNI+EPOT(2,IJPROJ)
997  ebipot = ebindp(2)
998  IF ((ijproj.NE.1).AND.(abs(epot(2,ijproj)).GT.5.0d-3))
999  & ebipot = ebindn(2)
1000  epni = epni+abs(ebipot)
1001 * re-initialization of NUCCMS
1002  dum1 = zero
1003  dum2 = zero
1004  IF(nstart.NE.2.AND.neudec.GE.20)
1005  & CALL ltini(ijproj,epni,dum1,dum2)
1006 C COMMON /NEUTYY/NEUTYP,NEUDEC
1007  ENDIF
1008 
1009  RETURN
1010 
1011 *------- treatment of final state
1012  2 CONTINUE
1013 
1014  jpw = npw
1015  jpcw = npcw
1016  jtw = ntw
1017  jtcw = ntcw
1018 
1019  DO 20 i=npoint(4),nhkk
1020 
1021  idsec = idbam(i)
1022 
1023 * reduction of particle momentum by corresponding nuclear potential
1024 * (this applies only if Fermi-momenta are requested)
1025 
1026  IF (isthkk(i).EQ.1) THEN
1027 
1028 C skip Photons
1029  IF(idsec.EQ.7) go to 23
1030 
1031  IF (fermp) THEN
1032 
1033 * select the nucleus which is most likely to be influenced by potential
1034 * corrections
1035  ipot = 0
1036  iother = 0
1037  IF (phkk(3,i).GE.zero) THEN
1038  ipot = 1
1039  IF ((ip.LE.1).OR.((ip-npw).LE.1)) THEN
1040  ipot = 2
1041  IF (ip.GT.1) iother = 1
1042  IF ((it.LE.1).OR.((it-ntw).LE.1)) goto 23
1043  ENDIF
1044  ELSE
1045  ipot = 2
1046  IF ((it.LE.1).OR.((it-ntw).LE.1)) THEN
1047  ipot = 1
1048  IF (it.GT.1) iother = 1
1049  IF ((ip.LE.1).OR.((ip-npw).LE.1)) goto 23
1050  ENDIF
1051  ENDIF
1052 
1053 * Lorentz-transformation into the rest system of the selected nucleus
1054  imode = -ipot-1
1055  CALL ltrans(phkk(1,i),phkk(2,i),phkk(3,i),phkk(4,i),
1056  & psec(1),psec(2),psec(3),psec(4),idsec,imode)
1057  pseco = sqrt(psec(1)**2+psec(2)**2+psec(3)**2)
1058  amsec = sqrt(abs((psec(4)-pseco)*(psec(4)+pseco)))
1059 
1060  chklev = tiny2
1061  IF ((eproj.GE.1.0d4).AND.(idsec.EQ.7)) chklev = tiny1
1062  IF (eproj.GE.2.0d6) chklev = 1.0d0
1063  IF (abs(amsec-aam(idsec)).GT.chklev) THEN
1064 C WRITE(LOUT,2000) I,NEVHKK,IDSEC,AMSEC,AAM(IDSEC)
1065  2000 FORMAT(1x,'RESNCL: inconsistent mass of particle',
1066  & ' at entry ',i5,' (evt.',i8,')',/,' IDSEC: ',
1067  & i4,' AMSEC: ',e12.3,' AAM(IDSEC): ',e12.3,/)
1068  ENDIF
1069 
1070  DO 21 k=1,4
1071  psec0(k) = psec(k)
1072  21 CONTINUE
1073 
1074 * the correction for nuclear potential effects is applied to as many
1075 * p/n as many nucleons were wounded; the momenta of other final state
1076 * particles are corrected only if they materialize inside the corresp.
1077 * nucleus (here: NOBAM = 1 part. outside proj., = 2 part. outside targ
1078 * = 3 part. outside proj. and targ., >=10 in overlapping region)
1079  IF ((idsec.EQ.1).OR.(idsec.EQ.8)) THEN
1080  IF (ipot.EQ.1) THEN
1081  IF ((jpw.GT.0).AND.(iother.EQ.0)) THEN
1082 * this is most likely a wounded nucleon
1083  psec(4) = psec(4)-epot(ipot,idsec)
1084  jpw = jpw-1
1085  ELSE
1086 * correct only if part. was materialized inside nucleus
1087 * and if it is ouside the overlapping region
1088  IF ((nobam(i).NE.1).AND.(nobam(i).LT.3))
1089  & psec(4) = psec(4)-epot(ipot,idsec)
1090  ENDIF
1091  ELSEIF (ipot.EQ.2) THEN
1092  IF ((jtw.GT.0).AND.(iother.EQ.0)) THEN
1093 * this is most likely a wounded nucleon
1094  psec(4) = psec(4)-epot(ipot,idsec)
1095  jtw = jtw-1
1096  ELSE
1097 * correct only if part. was materialized inside nucleus
1098  IF ((nobam(i).NE.2).AND.(nobam(i).LT.3))
1099  & psec(4) = psec(4)-epot(ipot,idsec)
1100  ENDIF
1101  ENDIF
1102  ELSE
1103  IF ((nobam(i).NE.ipot).AND.(nobam(i).LT.3))
1104  & psec(4) = psec(4)-epot(ipot,idsec)
1105  ENDIF
1106 
1107 * Coulomb energy correction:
1108 * the treatment of Coulomb potential correction is similar to the
1109 * one for nuclear potential
1110  IF (idsec.EQ.1) THEN
1111  IF ((ipot.EQ.1).AND.(jpcw.GT.0)) THEN
1112  jpcw = jpcw-1
1113  ELSEIF ((ipot.EQ.2).AND.(jtcw.GT.0)) THEN
1114  jtcw = jtcw-1
1115  ELSE
1116  IF ((nobam(i).EQ.ipot).OR.(nobam(i).EQ.3)) goto 25
1117  ENDIF
1118  ELSE
1119  IF ((nobam(i).EQ.ipot).OR.(nobam(i).EQ.3)) goto 25
1120  ENDIF
1121  IF (iich(idsec).EQ.1) THEN
1122 * pos. particles: check if they are able to escape Coulomb potential
1123  IF (psec(4).LT.amsec+etacou(ipot)) THEN
1124  isthkk(i) = 14+ipot
1125  IF (isthkk(i).EQ.15) THEN
1126  DO 26 k=1,4
1127  phkk(k,i) = psec0(k)
1128  prclpr(k) = prclpr(k)+psec0(k)
1129  26 CONTINUE
1130  IF ((idsec.EQ.1).OR.(idsec.EQ.8)) npw = npw-1
1131  IF (idsec.EQ.1) npcw = npcw-1
1132  ELSEIF (isthkk(i).EQ.16) THEN
1133  DO 27 k=1,4
1134  phkk(k,i) = psec0(k)
1135  prclta(k) = prclta(k)+psec0(k)
1136 C WRITE(6,*)I,K,PHKK(K,I),PRCLTA(K),'PRCLTA16+'
1137  27 CONTINUE
1138  IF ((idsec.EQ.1).OR.(idsec.EQ.8)) ntw = ntw-1
1139  IF (idsec.EQ.1) ntcw = ntcw-1
1140  ENDIF
1141  goto 20
1142  ENDIF
1143  ELSEIF (iich(idsec).EQ.-1) THEN
1144 * neg. particles: decrease energy by Coulomb-potential
1145  psec(4) = psec(4)-etacou(ipot)
1146  ENDIF
1147 
1148  25 CONTINUE
1149 
1150  IF (psec(4).LT.amsec) THEN
1151 C WRITE(LOUT,2001) I,IDSEC,PSEC(4),AMSEC
1152  2001 FORMAT(1x,'KKINC: particle at HKKEVT-pos. ',i5,
1153  & ' is not allowed to escape nucleus',/,
1154  & 8x,'id : ',i3,' reduced energy: ',e15.4,
1155  & ' mass: ',e12.3)
1156  isthkk(i) = 14+ipot
1157  IF (isthkk(i).EQ.15) THEN
1158  DO 28 k=1,4
1159  phkk(k,i) = psec0(k)
1160  prclpr(k) = prclpr(k)+psec0(k)
1161  28 CONTINUE
1162  IF ((idsec.EQ.1).OR.(idsec.EQ.8)) npw = npw-1
1163  IF (idsec.EQ.1) npcw = npcw-1
1164  ELSEIF (isthkk(i).EQ.16) THEN
1165  DO 29 k=1,4
1166  phkk(k,i) = psec0(k)
1167  prclta(k) = prclta(k)+psec0(k)
1168 C WRITE(6,*)I,K,PHKK(K,I),PRCLTA(K),'PRCLTA16+'
1169  29 CONTINUE
1170  IF ((idsec.EQ.1).OR.(idsec.EQ.8)) ntw = ntw-1
1171  IF (idsec.EQ.1) ntcw = ntcw-1
1172  ENDIF
1173  goto 20
1174  ENDIF
1175 
1176  psecn = sqrt( (psec(4)-amsec)*(psec(4)+amsec) )
1177 * 4-momentum after correction for nuclear potential
1178  DO 22 k=1,3
1179  psec(k) = psec(k)*psecn/pseco
1180  22 CONTINUE
1181 
1182 * store recoil momentum from particles escaping the nuclear potentials
1183  DO 30 k=1,4
1184  IF (ipot.EQ.1) THEN
1185  prclpr(k) = prclpr(k)+psec0(k)-psec(k)
1186  ELSEIF (ipot.EQ.2) THEN
1187  prclta(k) = prclta(k)+psec0(k)-psec(k)
1188 C WRITE(6,*)I,K,PHKK(K,I),PRCLTA(K),'PRCLTA000'
1189  ENDIF
1190  30 CONTINUE
1191 
1192 * transform momentum back into n-n cms
1193  imode = ipot+1
1194  CALL ltrans(psec(1),psec(2),psec(3),psec(4),
1195  & phkk(1,i),phkk(2,i),phkk(3,i),phkk(4,i),
1196  & idsec,imode)
1197 
1198  ENDIF
1199 
1200  23 CONTINUE
1201  DO 31 k=1,4
1202  pfsp(k) = pfsp(k)+phkk(k,i)
1203 C WRITE(6,*)I,K,PHKK(K,I),PFSP(K),'PFSP,2'
1204  31 CONTINUE
1205 
1206  ENDIF
1207  20 CONTINUE
1208 C j.r.4.2.97
1209 C IF ((IP.EQ.1).AND.(IT.GT.1).AND.(FERMP)) THEN
1210  IF ((ip.EQ.10001).AND.(it.GT.1).AND.(fermp)) THEN
1211 * hadron-nucleus interactions: get residual momentum from energy-
1212 * momentum conservation
1213  DO 32 k=1,4
1214  prclpr(k) = zero
1215  prclta(k) = pinipr(k)+pinita(k)-pfsp(k)
1216 C WRITE(6,*)I,K,PHKK(K,I),PRCLTA(K),'PRCLTA111'
1217 C WRITE(6,*)K,PINIPR(K),PINITA(K),PFSP(K),PRCLTA(K),'PRCLTA222'
1218  32 CONTINUE
1219  ELSE
1220 * nucleus-hadron, nucleus-nucleus: get residual momentum from
1221 * accumulated recoil momenta of particles leaving the spectators
1222 * transform accumulated recoil momenta of residual nuclei into
1223 * n-n cms
1224  pzi = prclpr(3)
1225  pei = prclpr(4)
1226  CALL ltnuc(pzi,pei,prclpr(3),prclpr(4),2)
1227  pzi = prclta(3)
1228  pei = prclta(4)
1229  CALL ltnuc(pzi,pei,prclta(3),prclta(4),3)
1230 C IF (IP.GT.1) THEN
1231  prclpr(3) = prclpr(3)+pinipr(3)
1232  prclpr(4) = prclpr(4)+pinipr(4)
1233 C ENDIF
1234  IF (it.GT.1) THEN
1235  kkk=3
1236 C WRITE(6,*)KKK,PINITA(3),PRCLTA(KKK),'PRCLTAkkk'
1237  kkk=4
1238 C WRITE(6,*)KKK,PINITA(4),PRCLTA(KKK),'PRCLTAkkk'
1239  prclta(3) = prclta(3)+pinita(3)
1240  kkk=3
1241 C WRITE(6,*)KKK,PINITA(3),PRCLTA(KKK),'PRCLTAkkk'
1242  prclta(4) = prclta(4)+pinita(4)
1243  kkk=4
1244 C WRITE(6,*)KKK,PINITA(4),PRCLTA(KKK),'PRCLTAkkk'
1245  ENDIF
1246  ENDIF
1247 
1248 * check momenta of residual nuclei
1249  IF (lemcck) THEN
1250  CALL evtemc(-pinipr(1),-pinipr(2),-pinipr(3),-pinipr(4),
1251  & 1,idum,idum)
1252  CALL evtemc(-pinita(1),-pinita(2),-pinita(3),-pinita(4),
1253  & 2,idum,idum)
1254  CALL evtemc(prclpr(1),prclpr(2),prclpr(3),prclpr(4),
1255  & 2,idum,idum)
1256  CALL evtemc(prclta(1),prclta(2),prclta(3),prclta(4),
1257  & 2,idum,idum)
1258  CALL evtemc(pfsp(1),pfsp(2),pfsp(3),pfsp(4),2,idum,idum)
1259  chklev = tiny3
1260  CALL evtemc(dum,dum,dum,chklev,-1,501,irej1)
1261  IF (irej1.GT.0) RETURN
1262  ENDIF
1263 
1264  RETURN
1265  END
1266 *
1267 *
1268 *===scn4ba=============================================================*
1269 *
1270  SUBROUTINE scn4ba
1271 
1272 ************************************************************************
1273 * SCan /HKKEVT/ 4 BAryons which are not able to escape nuclear pot. *
1274 * This version dated 12.12.95 is written by S. Roesler. *
1275 ************************************************************************
1276 
1277  IMPLICIT DOUBLE PRECISION (a-h,o-z)
1278  SAVE
1279  parameter(lout=6,llook=9)
1280  parameter(zero=0.0d0,one=1.0d0,tiny3=1.0d-3,tiny2=1.0d-2,
1281  & tiny10=1.0d-10)
1282 
1283  parameter(nmxhkk=89998)
1284  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk),
1285  & jmohkk(2,nmxhkk),jdahkk(2,nmxhkk),
1286  & phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk(4,nmxhkk)
1287  COMMON /extevt/ idres(nmxhkk),idxres(nmxhkk),nobam(nmxhkk),
1288  & idbam(nmxhkk),idch(nmxhkk),npoint(10)
1289  CHARACTER*8 aname
1290  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),
1291  & iich(210),iibar(210),k1(210),k2(210)
1292 
1293  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
1294  COMMON /nuclea/ pfermp(2),pfermn(2),fermod,
1295  & ebindp(2),ebindn(2),epot(2,210),
1296  & etacou(2),icoul
1297  COMMON /wndncl/ npw,npw0,npcw,ntw,ntw0,ntcw
1298  LOGICAL lrclpr,lrclta
1299  COMMON /finsta/ pinipr(5),pinita(5),prclpr(5),prclta(5),
1300  & lrclpr,lrclta
1301 
1302  dimension plab(2,5),pcms(4)
1303 
1304  irej = 0
1305 
1306 * get number of wounded nucleons
1307  npw = 0
1308  npw0 = 0
1309  npcw = 0
1310  npstck = 0
1311  ntw = 0
1312  ntw0 = 0
1313  ntcw = 0
1314  ntstck = 0
1315 
1316  isglpr = 0
1317  isglta = 0
1318  lrclpr = .false.
1319  lrclta = .false.
1320 
1321 C DO 2 I=1,NHKK
1322  DO 2 i=1,npoint(1)
1323 * projectile nucleons wounded in primary interaction and in fzc
1324  IF ((isthkk(i).EQ.11).OR.(isthkk(i).EQ.17)) THEN
1325  npw = npw+1
1326  npstck = npstck+1
1327  IF (idhkk(i).EQ.2212) npcw = npcw+1
1328  IF (isthkk(i).EQ.11) npw0 = npw0+1
1329 C IF (IP.GT.1) THEN
1330  DO 5 k=1,4
1331  prclpr(k) = prclpr(k)-phkk(k,i)
1332  5 CONTINUE
1333 C ENDIF
1334 * target nucleons wounded in primary interaction and in fzc
1335  ELSEIF ((isthkk(i).EQ.12).OR.(isthkk(i).EQ.18)) THEN
1336  ntw = ntw+1
1337  ntstck = ntstck+1
1338  IF (idhkk(i).EQ.2212) ntcw = ntcw+1
1339  IF (isthkk(i).EQ.12) ntw0 = ntw0+1
1340  IF (it.GT.1) THEN
1341  DO 6 k=1,4
1342  prclta(k) = prclta(k)-phkk(k,i)
1343 C WRITE(6,*)I,K,PHKK(K,I),PRCLTA(K),'PRCLTA12-'
1344  6 CONTINUE
1345  ENDIF
1346  ELSEIF (isthkk(i).EQ.13) THEN
1347  isglpr = i
1348  ELSEIF (isthkk(i).EQ.14) THEN
1349  isglta = i
1350  ENDIF
1351  2 CONTINUE
1352 
1353  DO 11 i=npoint(4),nhkk
1354 * baryons which are unable to escape the nuclear potential of proj.
1355  IF (isthkk(i).EQ.15) THEN
1356  isglpr = i
1357  npstck = npstck-1
1358  IF (iibar(idbam(i)).NE.0) THEN
1359  npw = npw-1
1360  IF (iich(idbam(i)).GT.0) npcw = npcw-1
1361  ENDIF
1362  DO 7 k=1,4
1363  prclpr(k) = prclpr(k)+phkk(k,i)
1364  7 CONTINUE
1365 * baryons which are unable to escape the nuclear potential of targ.
1366  ELSEIF (isthkk(i).EQ.16) THEN
1367  isglta = i
1368  ntstck = ntstck-1
1369  IF (iibar(idbam(i)).NE.0) THEN
1370  ntw = ntw-1
1371  IF (iich(idbam(i)).GT.0) ntcw = ntcw-1
1372  ENDIF
1373  DO 8 k=1,4
1374  prclta(k) = prclta(k)+phkk(k,i)
1375 C WRITE(6,*)I,K,PHKK(K,I),PRCLTA(K),'PRCLTA16+'
1376  8 CONTINUE
1377  ENDIF
1378  11 CONTINUE
1379 
1380 * residual nuclei so far
1381  iresp = ip-npstck
1382  irest = it-ntstck
1383 
1384 * ckeck for "residual nuclei" consisting of one nucleon only
1385 * treat it as final state particle
1386  IF (iresp.EQ.1) THEN
1387  id = idbam(isglpr)
1388  ist = isthkk(isglpr)
1389  CALL ltrans(phkk(1,isglpr),phkk(2,isglpr),
1390  & phkk(3,isglpr),phkk(4,isglpr),
1391  & pcms(1),pcms(2),pcms(3),pcms(4),id,2)
1392  IF (ist.EQ.13) THEN
1393  isthkk(isglpr) = 11
1394  ELSE
1395  isthkk(isglpr) = 2
1396  ENDIF
1397  CALL evtput(1,idhkk(isglpr),isglpr,0,
1398  & pcms(1),pcms(2),pcms(3),pcms(4),
1399  & idres(isglpr),idxres(isglpr),idch(isglpr))
1400  nobam(nhkk) = nobam(isglpr)
1401  jdahkk(1,isglpr) = nhkk
1402  DO 21 k=1,4
1403  prclpr(k) = prclpr(k)-phkk(k,isglpr)
1404  21 CONTINUE
1405  ENDIF
1406  IF (irest.EQ.1) THEN
1407  id = idbam(isglta)
1408  ist = isthkk(isglta)
1409  CALL ltrans(phkk(1,isglta),phkk(2,isglta),
1410  & phkk(3,isglta),phkk(4,isglta),
1411  & pcms(1),pcms(2),pcms(3),pcms(4),id,3)
1412  IF (ist.EQ.14) THEN
1413  isthkk(isglta) = 12
1414  ELSE
1415  isthkk(isglta) = 2
1416  ENDIF
1417  CALL evtput(1,idhkk(isglta),isglta,0,
1418  & pcms(1),pcms(2),pcms(3),pcms(4),
1419  & idres(isglta),idxres(isglta),idch(isglta))
1420  nobam(nhkk) = nobam(isglta)
1421  jdahkk(1,isglta) = nhkk
1422  DO 22 k=1,4
1423  prclta(k) = prclta(k)-phkk(k,isglta)
1424 C WRITE(6,*)ISGLTA,K,PHKK(K,ISGLTA),PRCLTA(K),'PRCLTA12-'
1425  22 CONTINUE
1426  ENDIF
1427 
1428 * get nuclear potential corresp. to the residual nucleus
1429  iprcl = ip -npw
1430  ipzrcl = ipz-npcw
1431  itrcl = it -ntw
1432  itzrcl = itz-ntcw
1433  CALL nclpot(ipzrcl,iprcl,itzrcl,itrcl,zero,zero,1)
1434 
1435 * baryons unable to escape the nuclear potential are treated as
1436 * excited nucleons (ISTHKK=15,16)
1437  DO 3 i=npoint(4),nhkk
1438  IF (isthkk(i).EQ.1) THEN
1439  id = idbam(i)
1440  IF ( ((id.EQ.1).OR.(id.EQ.8)).AND.(nobam(i).NE.3) ) THEN
1441 * final state n and p not being outside of both nuclei are considered
1442  npotp = 1
1443  npott = 1
1444  IF ( (ip.GT.1) .AND.(iresp.GT.1).AND.
1445  & (nobam(i).NE.1).AND.(npw.GT.0) ) THEN
1446 * Lorentz-trsf. into proj. rest sys. for those being inside proj.
1447  CALL ltrans(phkk(1,i),phkk(2,i),phkk(3,i),phkk(4,i),
1448  & plab(1,1),plab(1,2),plab(1,3),plab(1,4),
1449  & id,-2)
1450  plabt = sqrt(plab(1,1)**2+plab(1,2)**2+plab(1,3)**2)
1451  plab(1,5) = sqrt(abs( (plab(1,4)-plabt)*
1452  & (plab(1,4)+plabt) ))
1453  ekin = plab(1,4)-plab(1,5)
1454  IF (ekin.LE.epot(1,id)) npotp = 15
1455  IF ((id.EQ.1).AND.(npcw.LE.0)) npotp = 1
1456  ENDIF
1457  IF ( (it.GT.1) .AND.(irest.GT.1).AND.
1458  & (nobam(i).NE.2).AND.(ntw.GT.0) ) THEN
1459 * Lorentz-trsf. into targ. rest sys. for those being inside targ.
1460  CALL ltrans(phkk(1,i),phkk(2,i),phkk(3,i),phkk(4,i),
1461  & plab(2,1),plab(2,2),plab(2,3),plab(2,4),
1462  & id,-3)
1463  plabt = sqrt(plab(2,1)**2+plab(2,2)**2+plab(2,3)**2)
1464  plab(2,5) = sqrt(abs( (plab(2,4)-plabt)*
1465  & (plab(2,4)+plabt) ))
1466  ekin = plab(2,4)-plab(2,5)
1467  IF (ekin.LE.epot(2,id)) npott = 16
1468  IF ((id.EQ.1).AND.(ntcw.LE.0)) npott = 1
1469  ENDIF
1470  IF (phkk(3,i).GE.zero) THEN
1471  isthkk(i) = npott
1472  IF (npotp.NE.1) isthkk(i) = npotp
1473  ELSE
1474  isthkk(i) = npotp
1475  IF (npott.NE.1) isthkk(i) = npott
1476  ENDIF
1477  IF (isthkk(i).NE.1) THEN
1478  j = isthkk(i)-14
1479  DO 4 k=1,5
1480  phkk(k,i) = plab(j,k)
1481  4 CONTINUE
1482  IF (isthkk(i).EQ.15) THEN
1483  npw = npw-1
1484  IF (id.EQ.1) npcw = npcw-1
1485  DO 9 k=1,4
1486  prclpr(k) = prclpr(k)+phkk(k,i)
1487 C WRITE(6,*)I,K,PHKK(K,I),PRCLPR(K),'PRCLPR'
1488  9 CONTINUE
1489  ELSEIF (isthkk(i).EQ.16) THEN
1490  ntw = ntw-1
1491  IF (id.EQ.1) ntcw = ntcw-1
1492  DO 10 k=1,4
1493  prclta(k) = prclta(k)+phkk(k,i)
1494 C WRITE(6,*)I,K,PHKK(K,I),PRCLTA(K),'PRCLTA16+'
1495  10 CONTINUE
1496  ENDIF
1497  ENDIF
1498  ENDIF
1499  ENDIF
1500  3 CONTINUE
1501 
1502 * again: get nuclear potential corresp. to the residual nucleus
1503  iprcl = ip -npw
1504  ipzrcl = ipz-npcw
1505  itrcl = it -ntw
1506  itzrcl = itz-ntcw
1507  aferp = fermod+0.1d0
1508  afert = fermod+0.1d0
1509  CALL nclpot(ipzrcl,iprcl,itzrcl,itrcl,aferp,afert,1)
1510 
1511 
1512  RETURN
1513  END
1514 *
1515 *
1516 *===ficonf=============================================================*
1517 *
1518  SUBROUTINE ficonf(IJPROJ,IP,IPZ,IT,ITZ,IREJ)
1519 
1520 ************************************************************************
1521 * Treatment of FInal CONFiguration including evaporation, fission and *
1522 * Fermi-break-up (for light nuclei only). *
1523 * Adopted from the original routine FINALE and extended to residual *
1524 * projectile nuclei. *
1525 * This version dated 12.12.95 is written by S. Roesler. *
1526 ************************************************************************
1527 
1528  IMPLICIT DOUBLE PRECISION (a-h,o-z)
1529  SAVE
1530  parameter(lout=6,llook=9)
1531  parameter(zero=0.0d0,one=1.0d0,tiny3=1.0d-3,tiny10=1.0d-10)
1532 
1533  parameter(nmxhkk=89998)
1534  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk),
1535  & jmohkk(2,nmxhkk),jdahkk(2,nmxhkk),
1536  & phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk(4,nmxhkk)
1537  COMMON /extevt/ idres(nmxhkk),idxres(nmxhkk),nobam(nmxhkk),
1538  & idbam(nmxhkk),idch(nmxhkk),npoint(10)
1539  COMMON /rjcoun/ irpt,irhha,irres(2),lomres,lobres,
1540  & irchki(2),irfrag,ircron(3),irevt,
1541  & irexci(3),irdiff(2),irinc
1542  COMMON /zentra/ icentr
1543  COMMON /outlev/ioutpo,ioutpa,iouxev,ioucol
1544  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
1545  CHARACTER*8 aname
1546  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),
1547  & iich(210),iibar(210),k1(210),k2(210)
1548  LOGICAL lrclpr,lrclta
1549  COMMON /finsta/ pinipr(5),pinita(5),prclpr(5),prclta(5),
1550  & lrclpr,lrclta
1551  COMMON /excita/ amrcl0(2),eexc(2),eexcfi(2),
1552  & ntot(2),npro(2),nn(2),nh(2),nhpos(2),nq(2),
1553  & ntotfi(2),nprofi(2)
1554  COMMON /stfico/ excdpm(4),exceva(2),
1555  & nincge,nincco(2,3),ninchr(2,2),nincwo(2),
1556  & nincst(2,4),nincev(2),
1557  & nresto(2),nrespr(2),nresnu(2),nresba(2),
1558  & nrespb(2),nresch(2),nresev(4),
1559  & neva(2,6),nevaga(2),nevaht(2),nevahy(2,2,240),
1560  & nevafi(2,2)
1561 * evaporation interface
1562  parameter(anglgb=5.0d-16)
1563  parameter(amuamu=0.93149432d0,amelec=0.51099906d-3)
1564  parameter(mxp=999)
1565  COMMON /finuc/ cxr(mxp), cyr(mxp), czr(mxp), tki(mxp),
1566  & plr(mxp), wei(mxp), tv, tvcms, tvrecl, tvheav,
1567  & tvbind, np0, np, kpart(mxp)
1568  LOGICAL lrnfss, lfragm
1569  COMMON /resnuc/ amntar, ammtar, amnzm1, ammzm1, amnnm1, ammnm1,
1570  & anow, znow, ancoll, zncoll, ammlft, amnlft,
1571  & eres, ekres, amnres, ammres, ptres, pxres,
1572  & pyres, pzres, ptres2, ktarp, ktarn, igreyp,
1573  & igreyn, icres, ibres, istres, ievapl, ievaph,
1574  & ievneu, ievpro, ievdeu, ievtri, iev3he, iev4he,
1575  & ideexg, ibtar, ichtar, ibleft, icleft, iother,
1576  & lrnfss, lfragm
1577  COMMON /nucdat/ av0wel, apfrmx, aefrmx, aefrma,
1578  & rdsnuc, v0well(2), pfrmmx(2), efrmmx(2),
1579  & efrmav(2), amnucl(2), amnusq(2), ebndng(2),
1580  & veffnu(2), eslope(2), pkmnnu(2), ekmnnu(2),
1581  & pkmxnu(2), ekmxnu(2), ekmnav(2), ekinav(2),
1582  & exmnav(2), ekupnu(2), exmnnu(2), exupnu(2),
1583  & erclav(2), eswell(2), fincup(2), amrcav ,
1584  & amrcsq , ato1o3 , zto1o3 , elbnde(0:100)
1585  LOGICAL ldiffr, linctv, levprt, lheavy, ldeexg, lgdhpr, lpreex,
1586  & lhlfix, lprfix, lparwv, lpower, lsngch, llvmod, lschdf
1587  parameter( nallwp = 39 )
1588  COMMON / parevt / dpower, fsprd0, fshpfn, rn1gsc, rn2gsc,
1589  & ldiffr(nallwp),lpower, linctv, levprt, lheavy,
1590  & ldeexg, lgdhpr, lpreex, lhlfix, lprfix, lparwv,
1591  & ilvmod, jlvmod, llvmod, lsngch, lschdf
1592 
1593  dimension inuc(2),idxpar(2),idpar(2),aif(2),aizf(2),amrcl(2),
1594  & prcl(2,4),mo1(2),mo2(2),vrcl(2,4),wrcl(2,4),
1595  & p1in(4),p2in(4),p1out(4),p2out(4)
1596  common/rejfbk/irejfr
1597  COMMON /neutyy/neutyp,neudec
1598 
1599  dimension expnuc(2),exc(2,210),nexc(2,210)
1600  DATA exc,nexc /420*zero,420*0/
1601  DATA expnuc /4.0d-3,4.0d-3/
1602  DATA iniex/0/
1603  DATA iniwa/0/
1604 
1605  irej = 0
1606  lrclpr = .false.
1607  lrclta = .false.
1608 
1609 * skip residual nucleus treatment if not requested or in case
1610 * of central collisions
1611  IF(ipev.GE.1)WRITE(6,*)' FICONF: LEVPRT ICENTR',levprt,icentr
1612 C IF ((.NOT.LEVPRT).OR.(ICENTR.NE.0)) RETURN
1613 C jr.19.5.96 also for central coll.
1614  IF ((.NOT.levprt)) RETURN
1615 
1616  DO 1 k=1,2
1617  idpar(k) = 0
1618  idxpar(k)= 0
1619  ntot(k) = 0
1620  ntotfi(k)= 0
1621  npro(k) = 0
1622  nprofi(k)= 0
1623  nn(k) = 0
1624  nh(k) = 0
1625  nhpos(k) = 0
1626  nq(k) = 0
1627  eexc(k) = zero
1628  mo1(k) = 0
1629  mo2(k) = 0
1630  DO 2 i=1,4
1631  vrcl(k,i) = zero
1632  wrcl(k,i) = zero
1633  2 CONTINUE
1634  1 CONTINUE
1635  nfsp = 0
1636  inuc(1) = ip
1637  inuc(2) = it
1638 
1639  DO 3 i=1,nhkk
1640 
1641 * number of final state particles
1642  IF (abs(isthkk(i)).EQ.1) THEN
1643  nfsp = nfsp+1
1644  idfsp = idbam(i)
1645  ENDIF
1646 
1647 * properties of remaining nucleon configurations
1648  kf = 0
1649  IF ((isthkk(i).EQ.13).OR.(isthkk(i).EQ.15)) kf = 1
1650  IF ((isthkk(i).EQ.14).OR.(isthkk(i).EQ.16)) kf = 2
1651  IF (kf.GT.0) THEN
1652  IF (mo1(kf).EQ.0) mo1(kf) = i
1653  mo2(kf) = i
1654 * position of residual nucleus = average position of nucleons
1655  DO 4 k=1,4
1656  vrcl(kf,k) = vrcl(kf,k)+vhkk(k,i)
1657  wrcl(kf,k) = wrcl(kf,k)+whkk(k,i)
1658  4 CONTINUE
1659 * total number of particles contributing to each residual nucleus
1660  ntot(kf) = ntot(kf)+1
1661  idtmp = idbam(i)
1662  idxtmp = i
1663 * total charge of residual nuclei
1664  nq(kf) = nq(kf)+iich(idtmp)
1665 * number of protons
1666  IF (idhkk(i).EQ.2212) THEN
1667  npro(kf) = npro(kf)+1
1668 * number of neutrons
1669  ELSEIF (idhkk(i).EQ.2112) THEN
1670  nn(kf) = nn(kf)+1
1671  ELSE
1672 * number of baryons other than n, p
1673  IF (iibar(idtmp).EQ.1) THEN
1674  nh(kf) = nh(kf)+1
1675  IF (iich(idtmp).EQ.1) nhpos(kf) = nhpos(kf)+1
1676  ELSE
1677 * any other mesons (status set to 1)
1678  iniwa=iniwa+1
1679  IF(iniwa.LE.20)WRITE(lout,1002) kf,idtmp
1680  1002 FORMAT(1x,'FICONF: residual nucleus ',i2,
1681  & ' containing meson ',i4,', status set to 1')
1682  isthkk(i) = 1
1683  idtmp = idpar(kf)
1684  idxtmp = idxpar(kf)
1685  ntot(kf) = ntot(kf)-1
1686  ENDIF
1687  ENDIF
1688  idpar(kf) = idtmp
1689  idxpar(kf) = idxtmp
1690  ENDIF
1691  3 CONTINUE
1692 
1693 * reject elastic events (def: one final state particle = projectile)
1694  IF ((ip.EQ.1).AND.(nfsp.EQ.1).AND.(idfsp.EQ.ijproj)) THEN
1695  WRITE(lout,1009)
1696  1009 FORMAT(1x,'FICONF: ct elastic events ')
1697  irexci(3) = irexci(3)+1
1698  irej=1
1699  RETURN
1700  ENDIF
1701 
1702 * check if one nucleus disappeared..
1703 C IF ((IP.GT.1).AND.(NTOT(1).EQ.0).AND.(NTOT(2).NE.0)) THEN
1704 C DO 5 K=1,4
1705 C PRCLTA(K) = PRCLTA(K)+PRCLPR(K)
1706 C PRCLPR(K) = ZERO
1707 C 5 CONTINUE
1708 C ELSEIF ((IT.GT.1).AND.(NTOT(2).EQ.0).AND.(NTOT(1).NE.0)) THEN
1709 C DO 6 K=1,4
1710 C PRCLPR(K) = PRCLPR(K)+PRCLTA(K)
1711 C PRCLTA(K) = ZERO
1712 C 6 CONTINUE
1713 C ENDIF
1714 
1715  icor = 0
1716  inorcl = 0
1717  DO 7 i=1,2
1718  DO 8 k=1,4
1719 * get the average of the nucleon positions
1720  vrcl(i,k) = vrcl(i,k)/max(ntot(i),1)
1721  wrcl(i,k) = wrcl(i,k)/max(ntot(i),1)
1722  IF (i.EQ.1) prcl(1,k) = prclpr(k)
1723  IF (i.EQ.2) prcl(2,k) = prclta(k)
1724  8 CONTINUE
1725  IF(ipev.GE.1)WRITE(6,*)prcl,'PRCL(2,4)'
1726  IF(ipev.GE.1)WRITE(6,*)prclta,'PRCLTA'
1727 * mass number and charge of residual nuclei
1728  aif(i) = dble(ntot(i))
1729  aizf(i) = dble(npro(i)+nhpos(i))
1730  IF(ipev.GE.1)WRITE(6,*)'I,Ntot(i)',i,ntot(i),aif(i),aizf(i)
1731  IF (ntot(i).GT.1) THEN
1732 * masses of residual nuclei in ground state
1733  amrcl0(i) = aif(i)*amuamu+1.0d-3*energy(aif(i),aizf(i))
1734 * masses of residual nuclei
1735  ptorcl = sqrt(prcl(i,1)**2+prcl(i,2)**2+prcl(i,3)**2)
1736  amrcl(i) = (prcl(i,4)-ptorcl)*(prcl(i,4)+ptorcl)
1737  IF (amrcl(i).GT.zero) amrcl(i) = sqrt(amrcl(i))
1738  IF(ipev.GE.1) WRITE(6,*)amrcl(i),'AMRCL(',i,')'
1739 C Patch 5.2.98
1740  IF ((amrcl(i).LT.amrcl0(i)).AND.(neudec.EQ.20))
1741  & amrcl(i)=amrcl0(i)+0.025d0
1742  IF (amrcl(i).LE.zero) THEN
1743  iniex=iniex+1
1744  IF(iniex.LE.50)
1745  & WRITE(lout,1000) i,prcl(i,1),prcl(i,2),prcl(i,3),
1746  & prcl(i,4),amrcl(i),ntot
1747  1000 FORMAT(1x,'warning! negative excitation energy',/,
1748  & i4,5e15.4,2i4)
1749  amrcl(i) = zero
1750  eexc(i) = zero
1751  goto 9999
1752  ELSEIF ((amrcl(i).GT.zero).AND.(amrcl(i).LT.amrcl0(i)))
1753  & THEN
1754  eexc(i) = amrcl(i)-amrcl0(i)
1755 C WRITE(6,*)I,EEXC(I),AMRCL(I),AMRCL0(I),'EEXC(I)0'
1756 **sr 11.6.96
1757 C AMRCL(I) = AMRCL0(I)+EXPNUC(I)*DBLE(NTOT(I))
1758  m = min(ntot(i),210)
1759  IF (nexc(i,m).GT.0) THEN
1760  amrcl(i) = amrcl0(i)+exc(i,m)/dble(nexc(i,m))
1761  ELSE
1762  70 CONTINUE
1763  m = m+1
1764  IF (m.GE.inuc(i)) THEN
1765  amrcl(i) = amrcl0(i)+expnuc(i)*dble(ntot(i))
1766  ELSE
1767  IF (nexc(i,m).GT.0) THEN
1768  amrcl(i) = amrcl0(i)+exc(i,m)/dble(nexc(i,m))
1769  ELSE
1770  goto 70
1771  ENDIF
1772  ENDIF
1773  ENDIF
1774 **
1775  eexc(i) = amrcl(i)-amrcl0(i)
1776  IF(ipev.GE.1)THEN
1777  WRITE(6,*)i,eexc(i),amrcl(i),amrcl0(i),'EEXC(I)1'
1778  ENDIF
1779  IF ((amrcl(i).GT.zero).AND.(amrcl(i).LT.amrcl0(i)))
1780  & THEN
1781  icor = icor+i
1782  ENDIF
1783 C insert 4.2.98
1784  expnuc(i) = eexc(i)/max(1,inuc(i)-ntot(i))
1785 **sr 11.6.96
1786  m = min(ntot(i),210)
1787  exc(i,m) = exc(i,m)+eexc(i)
1788  nexc(i,m) = nexc(i,m)+1
1789 C insert 4.2.98
1790  ELSE
1791 * excitation energies of residual nuclei
1792  eexc(i) = amrcl(i)-amrcl0(i)
1793  IF(ipev.GE.1)THEN
1794  WRITE(6,*)i,eexc(i),amrcl(i),amrcl0(i),'EEXC(I)2'
1795  ENDIF
1796  expnuc(i) = eexc(i)/max(1,inuc(i)-ntot(i))
1797 **sr 11.6.96
1798  m = min(ntot(i),210)
1799  exc(i,m) = exc(i,m)+eexc(i)
1800  nexc(i,m) = nexc(i,m)+1
1801 **
1802  ENDIF
1803  ELSEIF (ntot(i).EQ.1) THEN
1804  WRITE(lout,1003) i
1805  1003 FORMAT(1x,'FICONF: warning! NTOT(I)=1? (I=',i3,')')
1806  goto 9999
1807  ELSE
1808  amrcl0(i) = zero
1809  amrcl(i) = zero
1810  eexc(i) = zero
1811  inorcl = inorcl+i
1812  IF(ipev.GE.1)WRITE(6,*)' INORCL,I',inorcl,i
1813  ENDIF
1814  IF(ipev.GE.1)THEN
1815  WRITE (6,'(A,I10,3F10.3)')' I,AIF,AIZF,EEXC:'
1816  *,i,aif(i),aizf(i),eexc(i)
1817  ENDIF
1818  7 CONTINUE
1819 
1820  prclpr(5) = amrcl(1)
1821  prclta(5) = amrcl(2)
1822  IF(ipev.GE.1)WRITE(6,*)' ICOR,INORCL ',icor,inorcl
1823  IF (icor.GT.0) THEN
1824  IF (inorcl.EQ.0) THEN
1825 * one or both residual nuclei consist of one nucleon only, transform
1826 * this nucleon on mass shell
1827  DO 9 k=1,4
1828  p1in(k) = prcl(1,k)
1829  p2in(k) = prcl(2,k)
1830  9 CONTINUE
1831  xm1 = amrcl(1)
1832  xm2 = amrcl(2)
1833  CALL mashel(p1in,p2in,xm1,xm2,p1out,p2out,irej1)
1834  IF (irej1.GT.0)THEN
1835  WRITE(6,'(A)')' FICONF MASHEL rejection'
1836  goto 9999
1837  ENDIF
1838  DO 10 k=1,4
1839  prcl(1,k) = p1out(k)
1840  prcl(2,k) = p2out(k)
1841  prclpr(k) = p1out(k)
1842  prclta(k) = p2out(k)
1843  10 CONTINUE
1844  prclpr(5) = amrcl(1)
1845  prclta(5) = amrcl(2)
1846  ELSE
1847 **sr mod. for DPMJET: IOULEV not available here
1848  IF(ipev.GE.1)THEN
1849  WRITE(6,'(A)')' from FICONF'
1850  DO 7935 ihkk=1,nhkk
1851  WRITE(6,1005) ihkk, isthkk(ihkk),idhkk(ihkk),jmohkk(1,ihkk),
1852  + jmohkk(2,ihkk), jdahkk(1,ihkk),jdahkk(2,ihkk),(phkk
1853  + (khkk,ihkk),khkk=1,5), (vhkk(khkk,ihkk),khkk=1,4)
1854  + ,idres(ihkk),idxres(ihkk),nobam(ihkk),
1855  & idbam(ihkk),idch(ihkk)
1856  1005 FORMAT (i6,i4,5i6,9(1pe10.2)/5i6)
1857  7935 CONTINUE
1858  ENDIF
1859  IF(ipev.GE.1)THEN
1860  WRITE(lout,1001) nevhkk,int(aif(1)),int(aizf(1)),
1861  & int(aif(2)),int(aizf(2)),amrcl0(1),
1862  & amrcl(1),amrcl(1)-amrcl0(1),amrcl0(2),
1863  & amrcl(2),amrcl(2)-amrcl0(2)
1864  1001 FORMAT(1x,'FICONF: warning! no residual nucleus for',
1865  & ' correction',/,11x,'at event',i6,
1866  & ', nucleon config. 1:',2i4,' 2:',2i4,
1867  & 2(/,11x,3e12.3))
1868  ENDIF
1869  goto 9998
1870  ENDIF
1871  ENDIF
1872 
1873 * update counter
1874  IF (nresev(1).NE.nevhkk) THEN
1875  nresev(1) = nevhkk
1876  nresev(2) = nresev(2)+1
1877  ENDIF
1878  DO 15 i=1,2
1879  excdpm(i) = excdpm(i)+eexc(i)
1880  excdpm(i+2) = excdpm(i+2)+(eexc(i)/max(ntot(i),1))
1881  nresto(i) = nresto(i)+ntot(i)
1882  nrespr(i) = nrespr(i)+npro(i)
1883  nresnu(i) = nresnu(i)+nn(i)
1884  nresba(i) = nresba(i)+nh(i)
1885  nrespb(i) = nrespb(i)+nhpos(i)
1886  nresch(i) = nresch(i)+nq(i)
1887  15 CONTINUE
1888 
1889 * evaporation
1890  IF (levprt) THEN
1891  DO 13 i=1,2
1892 * initialize evaporation counter
1893  np = 0
1894  eexcfi(i) = zero
1895  IF ((inuc(i).GT.1).AND.(aif(i).GT.one).AND.
1896  & (eexc(i).GT.zero)) THEN
1897 * put residual nuclei into HKKEVT
1898  idrcl = 80000
1899  jmass = int( aif(i))
1900  jchar = int(aizf(i))
1901  CALL evtput(1000,idrcl,mo1(i),mo2(i),prcl(i,1),
1902  & prcl(i,2),prcl(i,3),prcl(i,4),jmass,jchar,0)
1903  IF(ipev.GE.1)WRITE(6,*)prcl,'PRCL(2,4),EVTPUT'
1904  DO 14 j=1,4
1905  vhkk(j,nhkk) = vrcl(i,j)
1906  whkk(j,nhkk) = wrcl(i,j)
1907  14 CONTINUE
1908 * interface to evaporation module - fill final residual nucleus into
1909 * common RESNUC
1910  pxres = prcl(i,1)
1911  pyres = prcl(i,2)
1912  pzres = prcl(i,3)
1913 C j.r.4.2.97
1914  eres = prcl(i,4)
1915 C j.r.4.2.97
1916  ibres = npro(i)+nn(i)+nh(i)
1917  icres = npro(i)+nhpos(i)
1918  anow = dble(ibres)
1919  znow = dble(icres)
1920  ptres = sqrt(pxres**2+pyres**2+pzres**2)
1921  IF(ipev.GE.1)WRITE(6,*)pxres,pyres,pzres,eres,'FICONF1'
1922 * ground state mass of the residual nucleus (should be equal to AM0T)
1923  ammres = amrcl0(i)
1924  amnres = ammres-znow*amelec+elbnde(icres)
1925 * common FINUC
1926  tv = zero
1927 * kinetic energy of residual nucleus
1928  tvrecl = prcl(i,4)-amrcl(i)
1929 C WRITE(6,*)TVRECL, PRCL(I,4),AMRCL(I),'TVRECL'
1930 * excitation energy of residual nucleus
1931 C j.r.16.1.96
1932  dpmexm=0.5
1933 C TVCMS = EEXC(I)*DPMEXM
1934  tvcms = eexc(i)
1935 C WRITE(6,*)TVCMS,'TVCMS'
1936  ptold = ptres
1937 C 4.2.98
1938  ptres = sqrt(tvrecl*(tvrecl+2.0d0*(ammres+tvcms)))
1939  IF (ptold.LT.anglgb) THEN
1940  CALL raco(pxres,pyres,pzres)
1941  IF(ipev.GE.1)WRITE(6,*)pxres,pyres,pzres,eres,'FICONF2'
1942  ptold = one
1943  ENDIF
1944  pxres = pxres*ptres/ptold
1945  pyres = pyres*ptres/ptold
1946  pzres = pzres*ptres/ptold
1947  IF(ipev.GE.1)WRITE(6,*)ptres,ptold,'FICONF3'
1948  IF(ipev.GE.1)WRITE(6,*)pxres,pyres,pzres,eres,'FICONF3'
1949 * evaporation
1950  we = one
1951 C WRITE(6,'(A,2F10.2,2I5)')' FRMBRK bef. EVEVAP',
1952 C * ANOW,ZNOW,IBRES,ICRES
1953  anoww=anow
1954  znoww=znow
1955  ibress=ibres
1956  icress=icres
1957  irejfr=0
1958 C WRITE(6,*)' before EVEVAP, WE',WE
1959  CALL evevap(we)
1960 C WRITE(6,*)' after EVEVAP , WE',WE
1961  IF(irejfr.EQ.1)THEN
1962  WRITE(6,'(A,2F10.2,2I5)')' FRMBRK rej.',
1963  * anoww,znoww,ibress,icress
1964  go to 9998
1965  ENDIF
1966 * put evaporated particles and residual nuclei to HKKEVT
1967  mo = nhkk
1968  IF(ipev.GE.1)WRITE(6,*)excitf,'EXITF before EVA2HE'
1969  CALL eva2he(mo,excitf,i,irej1)
1970  IF(ipev.GE.1)WRITE(6,*)excitf,'EXITF after EVA2HE'
1971  IF(irej1.GE.1)WRITE(6,'(A)')' FICONF EVA2HE '
1972  eexcfi(i) = excitf
1973  exceva(i) = exceva(i)+excitf
1974  ENDIF
1975  13 CONTINUE
1976  ENDIF
1977  IF(ipev.GE.1)WRITE(6,'(A,I5)')' FICONF RETURN IREJ ',irej
1978 
1979  RETURN
1980 
1981  9998 irexci(1) = irexci(1)+1
1982  9999 CONTINUE
1983  lrclpr = .true.
1984  lrclta = .true.
1985  irej = irej+1
1986  IF(ipev.GE.1)WRITE(6,'(A,I5)')' FICONF rej. IREJ ',irej
1987  RETURN
1988  END
1989 *
1990 *====eva2he============================================================*
1991 * *
1992  SUBROUTINE eva2he(MO,EEXCF,IRCL,IREJ)
1993 
1994 ************************************************************************
1995 * Interface between common's of evaporation module (FINUC,FHEAVY) *
1996 * and HKKEVT. *
1997 * MO HKKEVT-index of "mother" (residual) nucleus before evap. *
1998 * EEXCF exitation energy of residual nucleus after evaporation *
1999 * IRCL = 1 projectile residual nucleus *
2000 * = 2 target residual nucleus *
2001 * This version dated 19.04.95 is written by S. Roesler. *
2002 ************************************************************************
2003 
2004  IMPLICIT DOUBLE PRECISION (a-h,o-z)
2005  SAVE
2006  parameter(lout=6,llook=9)
2007  parameter(tiny10=1.0d-10,tiny3=1.0d-3)
2008 
2009  parameter(nmxhkk=89998)
2010  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk),
2011  & jmohkk(2,nmxhkk),jdahkk(2,nmxhkk),
2012  & phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk(4,nmxhkk)
2013 * special use for heavy fragments !
2014 * IDRES(I) = mass number, IDXRES(I) = charge
2015  COMMON /extevt/ idres(nmxhkk),idxres(nmxhkk),nobam(nmxhkk),
2016  & idbam(nmxhkk),idch(nmxhkk),npoint(10)
2017  CHARACTER*8 aname
2018  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),
2019  & iich(210),iibar(210),k1(210),k2(210)
2020  LOGICAL lemcck,lhadro,lseadi
2021  COMMON /flags/ ifrag(2),iresco,imshl,iresrj,
2022  & lemcck,lhadro(0:9),lseadi
2023  COMMON /stfico/ excdpm(4),exceva(2),
2024  & nincge,nincco(2,3),ninchr(2,2),nincwo(2),
2025  & nincst(2,4),nincev(2),
2026  & nresto(2),nrespr(2),nresnu(2),nresba(2),
2027  & nrespb(2),nresch(2),nresev(4),
2028  & neva(2,6),nevaga(2),nevaht(2),nevahy(2,2,240),
2029  & nevafi(2,2)
2030  COMMON /excita/ amrcl0(2),eexc(2),eexcfi(2),
2031  & ntot(2),npro(2),nn(2),nh(2),nhpos(2),nq(2),
2032  & ntotfi(2),nprofi(2)
2033 
2034  parameter(mxp=999)
2035  COMMON / finuc / cxr(mxp), cyr(mxp), czr(mxp), tki(mxp),
2036  & plr(mxp), wei(mxp), tv, tvcms, tvrecl, tvheav,
2037  & tvbind, np0, np, kpart(mxp)
2038 
2039 * evaporation interface
2040  parameter( mxheav = 100 )
2041  CHARACTER*8 anheav
2042  COMMON / fheavy / cxheav(mxheav), cyheav(mxheav),
2043  & czheav(mxheav), tkheav(mxheav),
2044  & pheavy(mxheav), wheavy(mxheav),
2045  & amheav( 12 ) , amnhea( 12 ) ,
2046  & kheavy(mxheav), icheav( 12 ) ,
2047  & ibheav( 12 ) , npheav
2048  COMMON / fheavc / anheav( 12 )
2049  LOGICAL lrnfss, lfragm
2050  COMMON /resnuc/ amntar, ammtar, amnzm1, ammzm1, amnnm1, ammnm1,
2051  & anow, znow, ancoll, zncoll, ammlft, amnlft,
2052  & eres, ekres, amnres, ammres, ptres, pxres,
2053  & pyres, pzres, ptres2, ktarp, ktarn, igreyp,
2054  & igreyn, icres, ibres, istres, ievapl, ievaph,
2055  & ievneu, ievpro, ievdeu, ievtri, iev3he, iev4he,
2056  & ideexg, ibtar, ichtar, ibleft, icleft, iother,
2057  & lrnfss, lfragm
2058 
2059  dimension iptokp(39)
2060  DATA iptokp / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
2061  & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 99,
2062  & 100, 101, 97, 102, 98, 103, 109, 115 /
2063 
2064  irej = 0
2065 
2066 * update counter
2067  IF (nresev(3).NE.nevhkk) THEN
2068  nresev(3) = nevhkk
2069  nresev(4) = nresev(4)+1
2070  ENDIF
2071 
2072  IF (lemcck)
2073  & CALL evtemc(phkk(1,mo),phkk(2,mo),phkk(3,mo),phkk(4,mo),1,
2074  & idum,idum)
2075 * mass number/charge of residual nucleus before evaporation
2076  ibtot = idres(mo)
2077  iztot = idxres(mo)
2078  IF(ipri.GE.1)WRITE(6,*)' resnuc IBTOT,IZTOT ',ibtot,iztot
2079 * protons/neutrons/gammas
2080  DO 1 i=1,np
2081  px = cxr(i)*plr(i)
2082  py = cyr(i)*plr(i)
2083  pz = czr(i)*plr(i)
2084  id = iptokp(kpart(i))
2085  idpdg = ipdgha(id)
2086  am = ((plr(i)+tki(i))*(plr(i)-tki(i)))/
2087  & (2.0d0*max(tki(i),tiny10))
2088  IF (abs(am-aam(id)).GT.tiny3) THEN
2089  WRITE(lout,1000) id,am,aam(id)
2090  1000 FORMAT(1x,'EVA2HE: inconsistent mass of evap. ',
2091  & 'particle',i3,2e10.3)
2092  ENDIF
2093  pe = tki(i)+am
2094  CALL evtput(-1,idpdg,mo,0,px,py,pz,pe,0,0,0)
2095  nobam(nhkk) = ircl
2096  IF (lemcck) CALL evtemc(-px,-py,-pz,-pe,2,idum,idum)
2097  ibtot = ibtot-iibar(id)
2098  iztot = iztot-iich(id)
2099  1 CONTINUE
2100 
2101 * heavy fragments
2102  DO 2 i=1,npheav
2103  px = cxheav(i)*pheavy(i)
2104  py = cyheav(i)*pheavy(i)
2105  pz = czheav(i)*pheavy(i)
2106  idheav = 80000
2107  am = ((pheavy(i)+tkheav(i))*(pheavy(i)-tkheav(i)))/
2108  & (2.0d0*max(tkheav(i),tiny10))
2109  pe = tkheav(i)+am
2110  CALL evtput(-1,idheav,mo,0,px,py,pz,pe,
2111  & ibheav(kheavy(i)),icheav(kheavy(i)),0)
2112  nobam(nhkk) = ircl
2113  IF (lemcck) CALL evtemc(-px,-py,-pz,-pe,2,idum,idum)
2114  ibtot = ibtot-ibheav(kheavy(i))
2115  iztot = iztot-icheav(kheavy(i))
2116  2 CONTINUE
2117 
2118  IF (ibres.GT.0) THEN
2119 * residual nucleus after evaporation
2120  idnuc = 80000
2121  CALL evtput(1001,idnuc,mo,0,pxres,pyres,pzres,eres,
2122  & ibres,icres,0)
2123 C WRITE(6,*)PXRES,PYRES,PZRES,ERES,'EVTPUT1001'
2124  nobam(nhkk) = ircl
2125  ENDIF
2126  eexcf = tvcms
2127  ntotfi(ircl) = ibres
2128  nprofi(ircl) = icres
2129  IF (lemcck) CALL evtemc(-pxres,-pyres,-pzres,-eres,2,idum,idum)
2130  ibtot = ibtot-ibres
2131  iztot = iztot-icres
2132 
2133 * count events with fission
2134  nevafi(1,ircl) = nevafi(1,ircl)+1
2135  IF (lrnfss) nevafi(2,ircl) = nevafi(2,ircl)+1
2136 
2137 * energy-momentum conservation check
2138  IF (lemcck) CALL evtemc(dum,dum,dum,dum,4,40,irej)
2139 * baryon-number/charge conservation check
2140  IF (ibtot+iztot.NE.0) THEN
2141  WRITE(lout,1001) nevhkk,ibtot,iztot
2142  1001 FORMAT(1x,'EVA2HE: baryon-number/charge conservation ',
2143  & 'failure at event ',i6,' : IBTOT,IZTOT = ',2i3)
2144  ENDIF
2145 
2146  RETURN
2147  END
2148 *
2149 *===fozoca=============================================================*
2150 *
2151  SUBROUTINE fozoca(LFZC,IREJ)
2152 
2153 ************************************************************************
2154 * This subroutine treats the complete FOrmation ZOne supressed intra- *
2155 * nuclear CAscade. *
2156 * LFZC = .true. cascade has been treated *
2157 * = .false. cascade skipped *
2158 * This is a completely revised version of the original FOZOKL. *
2159 * This version dated 18.11.95 is written by S. Roesler *
2160 ************************************************************************
2161 
2162  IMPLICIT DOUBLE PRECISION (a-h,o-z)
2163  SAVE
2164  parameter(lout=6,llook=9)
2165  parameter(dlarge=1.0d10,ohalf=0.5d0,zero=0.0d0)
2166  parameter(fm2mm=1.0d-12,rnucle = 1.12d0)
2167 
2168  LOGICAL lstart,lcas,lfzc
2169 
2170  parameter(nmxhkk=89998)
2171  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk),
2172  & jmohkk(2,nmxhkk),jdahkk(2,nmxhkk),
2173  & phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk(4,nmxhkk)
2174  COMMON /extevt/ idres(nmxhkk),idxres(nmxhkk),nobam(nmxhkk),
2175  & idbam(nmxhkk),idch(nmxhkk),npoint(10)
2176  COMMON /rjcoun/ irpt,irhha,irres(2),lomres,lobres,
2177  & irchki(2),irfrag,ircron(3),irevt,
2178  & irexci(3),irdiff(2),irinc
2179 
2180  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
2181  COMMON /rptshm/ rproj,rtarg,bimpac
2182  COMMON /dprin/ ipri,ipev,ippa,ipco,init,iphkk,itopd,ipaupr
2183  LOGICAL lemcck,lhadro,lseadi
2184  COMMON /flags/ ifrag(2),iresco,imshl,iresrj,
2185  & lemcck,lhadro(0:9),lseadi
2186  COMMON /pauli/ ewound(2,300),nwound(2),idxinc(2000),noinc
2187 
2188  COMMON /taufo/ taufor,ktauge,itauve,incmod
2189 **sr mod. for DPMJET: use the longer DPMJET one
2190  LOGICAL intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada, ipadis,
2191  & ishmal,lpauli
2192  COMMON /droppt/ intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada,
2193  & ipadis,ishmal,lpauli
2194 **
2195 
2196  DATA lstart /.true./
2197 
2198  dimension ncwoun(2)
2199 
2200  lfzc = .true.
2201  irej = 0
2202 
2203 * skip cascade if hadron-hadron interaction or if supressed by user
2204  IF (((ip.EQ.1).AND.(it.EQ.1)).OR.(ktauge.LT.1)) goto 9999
2205 * skip cascade if not all possible chains systems are hadronized
2206  IF(ipev.GE.1)WRITE(6,*)lhadro
2207  DO 1 i=1,8
2208  IF (.NOT.(lhadro(i))) goto 9999
2209  1 CONTINUE
2210 
2211  IF (ipev.GE.1) THEN
2212  WRITE(6,1000) ktauge,taufor,incmod
2213  ENDIF
2214  IF (lstart) THEN
2215  WRITE(lout,1000) ktauge,taufor,incmod
2216  1000 FORMAT(/,1x,'FOZOCA: intranuclear cascade treated for a ',
2217  & 'maximum of',i4,' generations',/,10x,'formation time ',
2218  & 'parameter:',f5.1,' fm/c',9x,'modus:',i2)
2219  IF (itauve.EQ.1) WRITE(lout,1001)
2220  IF (itauve.EQ.2) WRITE(lout,1002)
2221  1001 FORMAT(10x,'p_t dependent formation zone',/)
2222  1002 FORMAT(10x,'constant formation zone',/)
2223  lstart = .false.
2224  ENDIF
2225 
2226 * in order to avoid wasting of cpu-time the HKKEVT-indices of nucleons
2227 * which may interact with final state particles are stored in a seperate
2228 * array - here all proj./target nucleon-indices (just for simplicity)
2229  noinc = 0
2230  DO 9 i=1,npoint(1)-1
2231  noinc = noinc+1
2232  idxinc(noinc) = i
2233  9 CONTINUE
2234 
2235 * initialize Pauli-principle treatment (find wounded nucleons)
2236  nwound(1) = 0
2237  nwound(2) = 0
2238  ncwoun(1) = 0
2239  ncwoun(2) = 0
2240  DO 2 j=1,npoint(1)
2241  DO 3 i=1,2
2242  IF (isthkk(j).EQ.10+i) THEN
2243  nwound(i) = nwound(i)+1
2244  ewound(i,nwound(i)) = phkk(4,j)
2245  IF (idhkk(j).EQ.2212) ncwoun(i) = ncwoun(i)+1
2246  ENDIF
2247  3 CONTINUE
2248  2 CONTINUE
2249 
2250 * modify nuclear potential for wounded nucleons
2251  iprcl = ip -nwound(1)
2252  ipzrcl = ipz-ncwoun(1)
2253  itrcl = it -nwound(2)
2254  itzrcl = itz-ncwoun(2)
2255  CALL nclpot(ipzrcl,iprcl,itzrcl,itrcl,zero,zero,1)
2256 
2257  nstart = npoint(4)
2258  nend = nhkk
2259 
2260  7 CONTINUE
2261  DO 8 i=nstart,nend
2262 
2263  IF ((abs(isthkk(i)).EQ.1).AND.(idch(i).LT.ktauge)) THEN
2264 
2265 * select nucleus the cascade starts first (proj. - 1, target - -1)
2266  ncas = 1
2267 * projectile/target with probab. 1/2
2268  IF ((incmod.EQ.1).OR.(idch(i).GT.0)) THEN
2269  IF (rndm(v).GT.ohalf) ncas = -ncas
2270 * in the nucleus with highest mass
2271  ELSEIF (incmod.EQ.2) THEN
2272  IF (ip.GT.it) THEN
2273  ncas = -ncas
2274  ELSEIF (ip.EQ.it) THEN
2275  IF (rndm(v).GT.ohalf) ncas = -ncas
2276  ENDIF
2277 * the nucleus the cascade starts first is requested to be the one
2278 * moving in the direction of the secondary
2279  ELSEIF (incmod.EQ.3) THEN
2280  ncas = int(sign(1.0d0,phkk(3,i)))
2281  ENDIF
2282 * check that the selected "nucleus" is not a hadron
2283  IF (((ncas.EQ. 1).AND.(ip.LE.1)).OR.
2284  & ((ncas.EQ.-1).AND.(it.LE.1))) ncas = -ncas
2285 
2286 * treat intranuclear cascade in the nucleus selected first
2287  lcas = .false.
2288  CALL inucas(it,ip,i,lcas,ncas,irej1)
2289  IF (irej1.NE.0)THEN
2290 C WRITE(6,'(A)')' INUCAS Rejection'
2291  goto 9998
2292  ENDIF
2293 * treat intranuclear cascade in the other nucleus if this isn't a had.
2294  ncas = -ncas
2295  IF (((ncas.EQ. 1).AND.(ip.GT.1)).OR.
2296  & ((ncas.EQ.-1).AND.(it.GT.1))) THEN
2297  IF (lcas) CALL inucas(it,ip,i,lcas,ncas,irej1)
2298  IF (irej1.NE.0)THEN
2299 C WRITE(6,'(A)')' INUCAS Rejection2'
2300  goto 9998
2301  ENDIF
2302  ENDIF
2303 
2304  ENDIF
2305 
2306  8 CONTINUE
2307  nstart = nend+1
2308  nend = nhkk
2309  IF (nstart.LE.nend) goto 7
2310 
2311  RETURN
2312 
2313  9998 CONTINUE
2314 * reject this event
2315  irinc = irinc+1
2316  irej = 1
2317 
2318  9999 CONTINUE
2319 * intranucl. cascade not treated because of interaction properties or
2320 * it is supressed by user or it was rejected or...
2321  lfzc = .false.
2322 * reset flag characterizing direction of motion in n-n-cms
2323 **sr14-11-95
2324 C DO 9990 I=NPOINT(5),NHKK
2325 C IF (ISTHKK(I).EQ.-1) ISTHKK(I)=1
2326 C9990 CONTINUE
2327 
2328  RETURN
2329  END
2330 *
2331 *
2332 *===inucas=============================================================*
2333 *
2334  SUBROUTINE inucas(IT,IP,IDXCAS,LCAS,NCAS,IREJ)
2335 
2336 ************************************************************************
2337 * Formation zone supressed IntraNUclear CAScade for one final state *
2338 * particle. *
2339 * IT, IP mass numbers of target, projectile nuclei *
2340 * IDXCAS index of final state particle in HKKEVT *
2341 * NCAS = 1 intranuclear cascade in projectile *
2342 * = -1 intranuclear cascade in target *
2343 * This version dated 11.06.96 is written by S. Roesler *
2344 ************************************************************************
2345 
2346  IMPLICIT DOUBLE PRECISION (a-h,o-z)
2347  SAVE
2348  parameter(lout=6,llook=9)
2349 
2350  parameter(tiny10=1.0d-10,tiny2=1.0d-2,zero=0.0d0,dlarge=1.0d10,
2351  & ohalf=0.5d0,one=1.0d0)
2352  parameter(fm2mm=1.0d-12,rnucle = 1.12d0)
2353  parameter(twopi=6.283185307179586454d+00)
2354  parameter(elowh=0.01d0,ehih=9.0d0)
2355 
2356  LOGICAL labsor,lcas
2357 
2358  parameter(nmxhkk=89998)
2359  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk),
2360  & jmohkk(2,nmxhkk),jdahkk(2,nmxhkk),
2361  & phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk(4,nmxhkk)
2362  COMMON /extevt/ idres(nmxhkk),idxres(nmxhkk),nobam(nmxhkk),
2363  & idbam(nmxhkk),idch(nmxhkk),npoint(10)
2364  parameter(maxfsp=10)
2365  COMMON /fistat/ pfsp(5,maxfsp),idfsp(maxfsp),nfsp
2366 
2367 **sr mod. for DPMJET: the old shorter version of /FLAGS/
2368  LOGICAL lemcck,lhadro,lseadi
2369  COMMON /flags/ ifrag(2),iresco,imshl,iresrj,
2370  & lemcck,lhadro(0:9),lseadi
2371  CHARACTER*8 aname
2372  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),
2373  & iich(210),iibar(210),k1(210),k2(210)
2374 
2375  COMMON /rptshm/ rproj,rtarg,bimpac
2376  COMMON /nuclea/ pfermp(2),pfermn(2),fermod,
2377  & ebindp(2),ebindn(2),epot(2,210),
2378  & etacou(2),icoul
2379  COMMON /taufo/ taufor,ktauge,itauve,incmod
2380  COMMON /pauli/ ewound(2,300),nwound(2),idxinc(2000),noinc
2381 **sr mod. for DPMJET: use the longer DPMJET one
2382  LOGICAL intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada, ipadis,
2383  & ishmal,lpauli
2384  COMMON /droppt/ intpt,fermp,ihadss,ihadsv,ihadvs,ihadvv,ihada,
2385  & ipadis,ishmal,lpauli
2386 
2387  COMMON /stfico/ excdpm(4),exceva(2),
2388  & nincge,nincco(2,3),ninchr(2,2),nincwo(2),
2389  & nincst(2,4),nincev(2),
2390  & nresto(2),nrespr(2),nresnu(2),nresba(2),
2391  & nrespb(2),nresch(2),nresev(4),
2392  & neva(2,6),nevaga(2),nevaht(2),nevahy(2,2,240),
2393  & nevafi(2,2)
2394 
2395  dimension pcas(2,5),ptocas(2),coscas(2,3),vtxcas(2,4),vtxca1(2,4),
2396  & pcas1(5),pnuc(5),bgta(4),
2397  & bgcas(2),gacas(2),becas(2),
2398  & rnuc(2),bimpc(2),vtxdst(3),idxspe(2),idspe(2),nwtmp(2)
2399 
2400  DATA pdif /0.545d0/
2401 
2402  irej = 0
2403 
2404 * update counter
2405  IF (nincev(1).NE.nevhkk) THEN
2406  nincev(1) = nevhkk
2407  nincev(2) = nincev(2)+1
2408  ENDIF
2409 
2410 * "BAMJET-index" of this hadron
2411  idcas = idbam(idxcas)
2412  IF (mchad(idcas).EQ.-1) RETURN
2413 
2414 * skip gammas, electrons, etc..
2415  IF (aam(idcas).LT.tiny2) RETURN
2416 
2417 * Lorentz-trsf. into projectile rest system
2418  IF (ip.GT.1) THEN
2419  CALL ltrans(phkk(1,idxcas),phkk(2,idxcas),phkk(3,idxcas),
2420  & phkk(4,idxcas),pcas(1,1),pcas(1,2),pcas(1,3),
2421  & pcas(1,4),idcas,-2)
2422  ptocas(1) = sqrt(pcas(1,1)**2+pcas(1,2)**2+pcas(1,3)**2)
2423  pcas(1,5) = (pcas(1,4)-ptocas(1))*(pcas(1,4)+ptocas(1))
2424  IF (pcas(1,5).GT.zero) THEN
2425  pcas(1,5) = sqrt(pcas(1,5))
2426  ELSE
2427  pcas(1,5) = aam(idcas)
2428  ENDIF
2429  DO 20 k=1,3
2430  coscas(1,k) = pcas(1,k)/max(ptocas(1),tiny10)
2431  20 CONTINUE
2432 * Lorentz-parameters
2433 * particle rest system --> projectile rest system
2434  bgcas(1) = ptocas(1)/max(pcas(1,5),tiny10)
2435  gacas(1) = pcas(1,4)/max(pcas(1,5),tiny10)
2436  becas(1) = bgcas(1)/gacas(1)
2437  ELSE
2438  DO 21 k=1,5
2439  pcas(1,k) = zero
2440  IF (k.LE.3) coscas(1,k) = zero
2441  21 CONTINUE
2442  ptocas(1) = zero
2443  bgcas(1) = zero
2444  gacas(1) = zero
2445  becas(1) = zero
2446  ENDIF
2447 * Lorentz-trsf. into target rest system
2448  IF (it.GT.1) THEN
2449  CALL ltrans(phkk(1,idxcas),phkk(2,idxcas),phkk(3,idxcas),
2450  & phkk(4,idxcas),pcas(2,1),pcas(2,2),pcas(2,3),
2451  & pcas(2,4),idcas,-3)
2452  ptocas(2) = sqrt(pcas(2,1)**2+pcas(2,2)**2+pcas(2,3)**2)
2453  pcas(2,5) = (pcas(2,4)-ptocas(2))*(pcas(2,4)+ptocas(2))
2454  IF (pcas(2,5).GT.zero) THEN
2455  pcas(2,5) = sqrt(pcas(2,5))
2456  ELSE
2457  pcas(2,5) = aam(idcas)
2458  ENDIF
2459  DO 22 k=1,3
2460  coscas(2,k) = pcas(2,k)/max(ptocas(2),tiny10)
2461  22 CONTINUE
2462 * Lorentz-parameters
2463 * particle rest system --> target rest system
2464  bgcas(2) = ptocas(2)/max(pcas(2,5),tiny10)
2465  gacas(2) = pcas(2,4)/max(pcas(2,5),tiny10)
2466  becas(2) = bgcas(2)/gacas(2)
2467  ELSE
2468  DO 23 k=1,5
2469  pcas(2,k) = zero
2470  IF (k.LE.3) coscas(2,k) = zero
2471  23 CONTINUE
2472  ptocas(2) = zero
2473  bgcas(2) = zero
2474  gacas(2) = zero
2475  becas(2) = zero
2476  ENDIF
2477 
2478 * radii of nuclei (mm) modified by the wall-depth of the Woods-Saxon-
2479 * potential (see CONUCL)
2480  rnuc(1) = (rproj+4.605d0*pdif)*fm2mm
2481  rnuc(2) = (rtarg+4.605d0*pdif)*fm2mm
2482 * impact parameter (the projectile moving along z)
2483  bimpc(1) = zero
2484  bimpc(2) = bimpac*fm2mm
2485 
2486 * get position of initial hadron in projectile/target rest-syst.
2487  DO 3 k=1,4
2488  vtxcas(1,k) = whkk(k,idxcas)
2489  vtxcas(2,k) = vhkk(k,idxcas)
2490  3 CONTINUE
2491 
2492  icas = 1
2493  i2 = 2
2494  IF (ncas.EQ.-1) THEN
2495  icas = 2
2496  i2 = 1
2497  ENDIF
2498 
2499  IF (ptocas(icas).LT.tiny10) THEN
2500  WRITE(lout,1000) ptocas
2501  1000 FORMAT(1x,'INUCAS: warning! zero momentum of initial',
2502  & ' hadron ',/,20x,2e12.4)
2503  goto 9999
2504  ENDIF
2505 
2506 * reset spectator flags
2507  nspe = 0
2508  idxspe(1) = 0
2509  idxspe(2) = 0
2510  idspe(1) = 0
2511  idspe(2) = 0
2512 
2513 * formation length (in fm)
2514 C IF (LCAS) THEN
2515 C DEL0 = ZERO
2516 C ELSE
2517  del0 = taufor*bgcas(icas)
2518  IF (itauve.EQ.1) THEN
2519  amt = pcas(icas,1)**2+pcas(icas,2)**2+pcas(icas,5)**2
2520  del0 = del0*pcas(icas,5)**2/amt
2521  ENDIF
2522 C ENDIF
2523 * sample from exp(-del/del0)
2524  del1 = -del0*log(max(rndm(v),tiny10))
2525 * save formation time
2526  tausa1 = del1/bgcas(icas)
2527  rel1 = tausa1*bgcas(i2)
2528 
2529  del = del1
2530  tausam = del/bgcas(icas)
2531  rel = tausam*bgcas(i2)
2532 
2533 * special treatment for negative particles unable to escape
2534 * nuclear potential (implemented for ap, pi-, K- only)
2535  labsor = .false.
2536  IF ((iich(idcas).EQ.-1).AND.(idcas.LT.20)) THEN
2537 * threshold energy = nuclear potential + Coulomb potential
2538 * (nuclear potential for hadron-nucleus interactions only)
2539  ethr = aam(idcas)+epot(icas,idcas)+etacou(icas)
2540  IF (pcas(icas,4).LT.ethr) THEN
2541  DO 4 k=1,5
2542  pcas1(k) = pcas(icas,k)
2543  4 CONTINUE
2544 * "absorb" negative particle in nucleus
2545  CALL absorp(idcas,pcas1,ncas,nspe,idspe,idxspe,0,irej1)
2546  IF (irej1.NE.0) goto 9999
2547  IF (nspe.GE.1) labsor = .true.
2548  ENDIF
2549  ENDIF
2550 
2551 * if the initial particle has not been absorbed proceed with
2552 * "normal" cascade
2553  IF (.NOT.labsor) THEN
2554 
2555 * calculate coordinates of hadron at the end of the formation zone
2556 * transport-time and -step in the rest system where this step is
2557 * treated
2558  dstep = del*fm2mm
2559  dtime = dstep/becas(icas)
2560  rstep = rel*fm2mm
2561  IF ((ip.GT.1).AND.(it.GT.1)) THEN
2562  rtime = rstep/becas(i2)
2563  ELSE
2564  rtime = zero
2565  ENDIF
2566 * save step whithout considering the overlapping region
2567  dstep1 = del1*fm2mm
2568  dtime1 = dstep1/becas(icas)
2569  rstep1 = rel1*fm2mm
2570  IF ((ip.GT.1).AND.(it.GT.1)) THEN
2571  rtime1 = rstep1/becas(i2)
2572  ELSE
2573  rtime1 = zero
2574  ENDIF
2575 * transport to the end of the formation zone in this system
2576  DO 5 k=1,3
2577  vtxca1(icas,k) = vtxcas(icas,k)+dstep1*coscas(icas,k)
2578  vtxca1(i2,k) = vtxcas(i2,k) +rstep1*coscas(i2,k)
2579  vtxcas(icas,k) = vtxcas(icas,k)+dstep*coscas(icas,k)
2580  vtxcas(i2,k) = vtxcas(i2,k) +rstep*coscas(i2,k)
2581  5 CONTINUE
2582  vtxca1(icas,4) = vtxcas(icas,4)+dtime1
2583  vtxca1(i2,4) = vtxcas(i2,4) +rtime1
2584  vtxcas(icas,4) = vtxcas(icas,4)+dtime
2585  vtxcas(i2,4) = vtxcas(i2,4) +rtime
2586 
2587  IF ((ip.GT.1).AND.(it.GT.1)) THEN
2588  xcas = vtxcas(icas,1)
2589  ycas = vtxcas(icas,2)
2590  xnclta = bimpac*fm2mm
2591  rnclpr = (rproj+rnucle)*fm2mm
2592  rnclta = (rtarg+rnucle)*fm2mm
2593  rcaspr = sqrt( xcas**2 +ycas**2)
2594  rcasta = sqrt((xcas-xnclta)**2+ycas**2)
2595  IF ((rcaspr.LT.rnclpr).AND.(rcasta.LT.rnclta)) THEN
2596  IF (idch(idxcas).EQ.0) nobam(idxcas) = 3
2597  ENDIF
2598  ENDIF
2599 
2600 * check if particle is already outside of the corresp. nucleus
2601  rdist = sqrt((vtxcas(icas,1)-bimpc(icas))**2+
2602  & vtxcas(icas,2)**2+vtxcas(icas,3)**2)
2603  IF (rdist.GE.rnuc(icas)) THEN
2604 * here: IDCH is the generation of the final state part. starting
2605 * with zero for hadronization products
2606 * flag particles of generation 0 being outside the nuclei after
2607 * formation time (to be used for excitation energy calculation)
2608  IF ((idch(idxcas).EQ.0).AND.(nobam(idxcas).LT.3))
2609  & nobam(idxcas) = nobam(idxcas)+icas
2610  goto 9997
2611  ENDIF
2612  dist = dlarge
2613  distp = dlarge
2614  distn = dlarge
2615  idxp = 0
2616  idxn = 0
2617 
2618 * already here: skip particles being outside HADRIN "energy-window"
2619 * to avoid wasting of time
2620  ninchr(icas,1) = ninchr(icas,1)+1
2621  IF ((ptocas(icas).LE.elowh).OR.(ptocas(icas).GE.ehih)) THEN
2622  ninchr(icas,2) = ninchr(icas,2)+1
2623 C WRITE(LOUT,1002) IDXCAS,IDCAS,ICAS,PTOCAS(ICAS),NEVHKK
2624 C1002 FORMAT(1X,'INUCAS: warning! momentum of particle with ',
2625 C & 'index ',I5,' (id: ',I3,') ',I3,/,11X,'p_tot = ',
2626 C & E12.4,', above or below HADRIN-thresholds',I6)
2627  nspe = 0
2628  goto 9997
2629  ENDIF
2630 
2631  DO 7 idxhkk=1,noinc
2632  i = idxinc(idxhkk)
2633 * scan HKKEVT for unwounded or excited nucleons
2634  IF ((isthkk(i).EQ.12+icas).OR.(isthkk(i).EQ.14+icas)) THEN
2635  DO 8 k=1,3
2636  IF (icas.EQ.1) THEN
2637  vtxdst(k) = whkk(k,i)-vtxcas(1,k)
2638  ELSEIF (icas.EQ.2) THEN
2639  vtxdst(k) = vhkk(k,i)-vtxcas(2,k)
2640  ENDIF
2641  8 CONTINUE
2642  posnuc = vtxdst(1)*coscas(icas,1)+
2643  & vtxdst(2)*coscas(icas,2)+
2644  & vtxdst(3)*coscas(icas,3)
2645 * check if nucleon is situated in forward direction
2646  IF (posnuc.GT.zero) THEN
2647 * distance between hadron and this nucleon
2648  distnu = sqrt(vtxdst(1)**2+vtxdst(2)**2+
2649  & vtxdst(3)**2)
2650 * impact parameter
2651  bimnu2 = distnu**2-posnuc**2
2652  IF (bimnu2.LT.zero) THEN
2653  WRITE(lout,1001) distnu,posnuc,bimnu2
2654  1001 FORMAT(1x,'INUCAS: warning! inconsistent impact',
2655  & ' parameter ',/,20x,3e12.4)
2656  goto 7
2657  ENDIF
2658  bimnu = sqrt(bimnu2)
2659 * maximum impact parameter to have interaction
2660  idnuc = icihad(idhkk(i))
2661  idnuc1 = mchad(idnuc)
2662  idcas1 = mchad(idcas)
2663  DO 19 k=1,5
2664  pcas1(k) = pcas(icas,k)
2665  pnuc(k) = phkk(k,i)
2666  19 CONTINUE
2667 * Lorentz-parameter for trafo into rest-system of target
2668  DO 18 k=1,4
2669  bgta(k) = pnuc(k)/max(pnuc(5),tiny10)
2670  18 CONTINUE
2671 * transformation of projectile into rest-system of target
2672  CALL daltra(bgta(4),-bgta(1),-bgta(2),-bgta(3),
2673  & pcas1(1),pcas1(2),pcas1(3),pcas1(4),
2674  & pptot,px,py,pz,pe)
2675  CALL sihnin(idcas1,idnuc1,pptot,sigin)
2676  CALL sihnel(idcas1,idnuc1,pptot,sigel)
2677  CALL sihnab(idcas1,idnuc1,pptot,sigab)
2678  sigtot = sigin+sigel+sigab
2679  bimmax = sqrt(sigtot/(5.0d0*twopi))*fm2mm
2680 * check if interaction is possible
2681  IF (bimnu.LE.bimmax) THEN
2682 * get nucleon with smallest distance and kind of interaction
2683 * (elastic/inelastic)
2684  IF (distnu.LT.dist) THEN
2685  dist = distnu
2686  bint = bimnu
2687  IF (idnuc.NE.idspe(1)) THEN
2688  idspe(2) = idspe(1)
2689  idxspe(2) = idxspe(1)
2690  idspe(1) = idnuc
2691  ENDIF
2692  idxspe(1) = i
2693  nspe = 1
2694 **sr
2695  sela = sigel
2696  sabs = sigab
2697  stot = sigtot
2698 C IF ((IDCAS.EQ.2).OR.(IDCAS.EQ.9)) THEN
2699 C SELA = SIGEL
2700 C STOT = SIGIN+SIGEL
2701 C ELSE
2702 C SELA = SIGEL+0.75D0*SIGIN
2703 C STOT = 0.25D0*SIGIN+SELA
2704 C ENDIF
2705 **
2706  ENDIF
2707  ENDIf
2708  ENDIF
2709  distnu = sqrt(vtxdst(1)**2+vtxdst(2)**2+
2710  & vtxdst(3)**2)
2711  idnuc = icihad(idhkk(i))
2712  IF (idnuc.EQ.1) THEN
2713  IF (distnu.LT.distp) THEN
2714  distp = distnu
2715  idxp = i
2716  posp = posnuc
2717  ENDIF
2718  ELSEIF (idnuc.EQ.8) THEN
2719  IF (distnu.LT.distn) THEN
2720  distn = distnu
2721  idxn = i
2722  posn = posnuc
2723  ENDIF
2724  ENDIF
2725  ENDIF
2726  7 CONTINUE
2727 
2728 * there is no nucleon for a secondary interaction
2729  IF (nspe.EQ.0) goto 9997
2730 
2731  IF (idxspe(2).EQ.0) THEN
2732  IF ((idspe(1).EQ.1).AND.(idxn.GT.0)) THEN
2733  idxspe(2) = idxn
2734  idspe(2) = 8
2735  ELSEIF ((idspe(1).EQ.8).AND.(idxp.GT.0)) THEN
2736  idxspe(2) = idxp
2737  idspe(2) = 1
2738  ELSE
2739  stot = stot-sabs
2740  sabs = zero
2741  ENDIF
2742  ENDIF
2743  rr = rndm(v)
2744  IF (rr.LT.sela/stot) THEN
2745  iproc = 2
2746  ELSEIF ((rr.GE.sela/stot).AND.(rr.LT.(sela+sabs)/stot)) THEN
2747  iproc = 3
2748  ELSE
2749  iproc = 1
2750  ENDIF
2751 
2752  DO 9 k=1,5
2753  pcas1(k) = pcas(icas,k)
2754  pnuc(k) = phkk(k,idxspe(1))
2755  9 CONTINUE
2756  IF (iproc.EQ.3) THEN
2757 * 2-nucleon absorption of pion
2758  nspe = 2
2759  CALL absorp(idcas,pcas1,ncas,nspe,idspe,idxspe,1,irej1)
2760  IF (irej1.NE.0) goto 9999
2761  IF (nspe.GE.1) labsor = .true.
2762  ELSE
2763 * sample secondary interaction
2764  idnuc = idbam(idxspe(1))
2765 **sr mod. for DPMJET: HADRIN-->HADRI1
2766  CALL hadri1(idcas,pcas1,idnuc,pnuc,iproc,irej1)
2767 **sr mod. for DPMJET: in case of rejections jump to 9998 rather than
2768 * reject cascade completely (??)
2769 C IF (IREJ1.EQ.1) GOTO 9999
2770  IF (irej1.GE.1)THEN
2771 C WRITE(6,'(A)')' HADRI1 Rejection'
2772  goto 9998
2773  ENDIF
2774  ENDIF
2775  ENDIF
2776 
2777 * update arrays to include Pauli-principle
2778  DO 10 i=1,nspe
2779  IF (nwound(icas).LE.299) THEN
2780  nwound(icas) = nwound(icas)+1
2781  ewound(icas,nwound(icas)) = phkk(4,idxspe(i))
2782  ENDIF
2783  10 CONTINUE
2784 
2785 * dump initial hadron for energy-momentum conservation check
2786  IF (lemcck)
2787  & CALL evtemc(pcas(icas,1),pcas(icas,2),pcas(icas,3),
2788  & pcas(icas,4),1,idum,idum)
2789 
2790 * dump final state particles into HKKEVT
2791 
2792 * check if Pauli-principle is fulfilled
2793  npauli = 0
2794  nwtmp(1) = nwound(1)
2795  nwtmp(2) = nwound(2)
2796  DO 111 i=1,nfsp
2797  npauli = 0
2798  j1 = 2
2799  IF (((ncas.EQ. 1).AND.(it.LE.1)).OR.
2800  & ((ncas.EQ.-1).AND.(ip.LE.1))) j1 = 1
2801  DO 117 j=1,j1
2802  IF ((npauli.NE.0).AND.(j.EQ.2)) goto 117
2803  IF (j.EQ.1) THEN
2804  idx = icas
2805  pe = pfsp(4,i)
2806  ELSE
2807  idx = i2
2808  mode = 1
2809  IF (idx.EQ.1) mode = -1
2810  CALL ltnuc(pfsp(3,i),pfsp(4,i),pz,pe,mode)
2811  ENDIF
2812 * first check if cascade step is forbidden due to Pauli-principle
2813 * (in case of absorpion this step is forced)
2814  IF ((.NOT.labsor).AND.lpauli.AND.((idfsp(i).EQ.1).OR.
2815  & (idfsp(i).EQ.8))) THEN
2816 * get nuclear potential barrier
2817  pot = epot(idx,idfsp(i))+aam(idfsp(i))
2818  IF (idfsp(i).EQ.1) THEN
2819  potlow = pot-ebindp(idx)
2820  ELSE
2821  potlow = pot-ebindn(idx)
2822  ENDIF
2823 * final state particle not able to escape nucleus
2824  IF (pe.LE.potlow) THEN
2825 * check if there are wounded nucleons
2826  IF ((nwound(idx).GE.1).AND.(pe.GE.
2827  & ewound(idx,nwound(idx)))) THEN
2828  npauli = npauli+1
2829  nwound(idx) = nwound(idx)-1
2830  ELSE
2831 * interaction prohibited by Pauli-principle
2832  nwound(1) = nwtmp(1)
2833  nwound(2) = nwtmp(2)
2834  goto 9997
2835  ENDIF
2836  ENDIF
2837  ENDIF
2838  117 CONTINUE
2839  111 CONTINUE
2840 
2841  npauli = 0
2842  nwound(1) = nwtmp(1)
2843  nwound(2) = nwtmp(2)
2844 
2845  DO 11 i=1,nfsp
2846 
2847  ist = isthkk(idxcas)
2848 
2849  npauli = 0
2850  j1 = 2
2851  IF (((ncas.EQ. 1).AND.(it.LE.1)).OR.
2852  & ((ncas.EQ.-1).AND.(ip.LE.1))) j1 = 1
2853  DO 17 j=1,j1
2854  IF ((npauli.NE.0).AND.(j.EQ.2)) goto 17
2855  idx = icas
2856  pe = pfsp(4,i)
2857  IF (j.EQ.2) THEN
2858  idx = i2
2859  CALL ltnuc(pfsp(3,i),pfsp(4,i),pz,pe,ncas)
2860  ENDIF
2861 * first check if cascade step is forbidden due to Pauli-principle
2862 * (in case of absorpion this step is forced)
2863  IF ((.NOT.labsor).AND.lpauli.AND.((idfsp(i).EQ.1).OR.
2864  & (idfsp(i).EQ.8))) THEN
2865 * get nuclear potential barrier
2866  pot = epot(idx,idfsp(i))+aam(idfsp(i))
2867  IF (idfsp(i).EQ.1) THEN
2868  potlow = pot-ebindp(idx)
2869  ELSE
2870  potlow = pot-ebindn(idx)
2871  ENDIF
2872 * final state particle not able to escape nucleus
2873  IF (pe.LE.potlow) THEN
2874 * check if there are wounded nucleons
2875  IF ((nwound(idx).GE.1).AND.(pe.GE.
2876  & ewound(idx,nwound(idx)))) THEN
2877  nwound(idx) = nwound(idx)-1
2878  npauli = npauli+1
2879  ist = 14+idx
2880  ELSE
2881 * interaction prohibited by Pauli-principle
2882  nwound(1) = nwtmp(1)
2883  nwound(2) = nwtmp(2)
2884  goto 9997
2885  ENDIF
2886 **sr
2887 c ELSEIF (PE.LE.POT) THEN
2888 cC ELSEIF ((PE.LE.POT).AND.(NWOUND(IDX).GE.1)) THEN
2889 cC NWOUND(IDX) = NWOUND(IDX)-1
2890 c**
2891 c NPAULI = NPAULI+1
2892 c IST = 14+IDX
2893  ENDIF
2894  ENDIF
2895  17 CONTINUE
2896 
2897 * dump final state particles for energy-momentum conservation check
2898  IF (lemcck) CALL evtemc(-pfsp(1,i),-pfsp(2,i),-pfsp(3,i),
2899  & -pfsp(4,i),2,idum,idum)
2900 
2901  px = pfsp(1,i)
2902  py = pfsp(2,i)
2903  pz = pfsp(3,i)
2904  pe = pfsp(4,i)
2905  IF (abs(ist).EQ.1) THEN
2906 * transform particles back into n-n cms
2907  imode = icas+1
2908  CALL ltrans(px,py,pz,pe,pfsp(1,i),pfsp(2,i),pfsp(3,i),
2909  & pfsp(4,i),idfsp(i),imode)
2910  ELSEIF ((icas.EQ.2).AND.(ist.EQ.15)) THEN
2911 * target cascade but fsp got stuck in proj. --> transform it into
2912 * proj. rest system
2913  CALL ltrans(px,py,pz,pe,pfsp(1,i),pfsp(2,i),pfsp(3,i),
2914  & pfsp(4,i),idfsp(i),-1)
2915  ELSEIF ((icas.EQ.1).AND.(ist.EQ.16)) THEN
2916 * proj. cascade but fsp got stuck in target --> transform it into
2917 * target rest system
2918  CALL ltrans(px,py,pz,pe,pfsp(1,i),pfsp(2,i),pfsp(3,i),
2919  & pfsp(4,i),idfsp(i),1)
2920  ENDIF
2921 
2922 * dump final state particles into HKKEVT
2923  igen = idch(idxcas)+1
2924  id = ipdgha(idfsp(i))
2925  ixr = 0
2926  IF (labsor) ixr = 99
2927  CALL evtput(ist,id,idxcas,idxspe(1),pfsp(1,i),
2928  & pfsp(2,i),pfsp(3,i),pfsp(4,i),0,ixr,igen)
2929 
2930 * update the counter for particles which got stuck inside the nucleus
2931  IF ((ist.EQ.15).OR.(ist.EQ.16)) THEN
2932  noinc = noinc+1
2933  idxinc(noinc) = nhkk
2934  ENDIF
2935  IF (labsor) THEN
2936 * in case of absorption the spatial treatment is an approximate
2937 * solution anyway (the positions of the nucleons which "absorb" the
2938 * cascade particle are not taken into consideration) therefore the
2939 * particles are produced at the position of the cascade particle
2940  DO 12 k=1,4
2941  whkk(k,nhkk) = whkk(k,idxcas)
2942  vhkk(k,nhkk) = vhkk(k,idxcas)
2943  12 CONTINUE
2944  ELSE
2945 * DDISTL - distance the cascade particle moves to the intera. point
2946 * (the position where impact-parameter = distance to the interacting
2947 * nucleon), DIST - distance to the interacting nucleon at the time of
2948 * formation of the cascade particle, BINT - impact-parameter of this
2949 * cascade-interaction
2950  ddistl = sqrt(dist**2-bint**2)
2951  dtime = ddistl/becas(icas)
2952  dtimel = ddistl/bgcas(icas)
2953  rdistl = dtimel*bgcas(i2)
2954  IF ((ip.GT.1).AND.(it.GT.1)) THEN
2955  rtime = rdistl/becas(i2)
2956  ELSE
2957  rtime = zero
2958  ENDIF
2959 * RDISTL, RTIME are this step and time in the rest system of the other
2960 * nucleus
2961  DO 13 k=1,3
2962  vtxca1(icas,k) = vtxcas(icas,k)+coscas(icas,k)*ddistl
2963  vtxca1(i2,k) = vtxcas(i2,k) +coscas(i2,k) *rdistl
2964  13 CONTINUE
2965  vtxca1(icas,4) = vtxcas(icas,4)+dtime
2966  vtxca1(i2,4) = vtxcas(i2,4) +rtime
2967 * position of particle production is half the impact-parameter to
2968 * the interacting nucleon
2969  DO 14 k=1,3
2970  whkk(k,nhkk) = ohalf*(vtxca1(1,k)+whkk(k,idxspe(1)))
2971  vhkk(k,nhkk) = ohalf*(vtxca1(2,k)+vhkk(k,idxspe(1)))
2972  14 CONTINUE
2973 * time of production of secondary = time of interaction
2974  whkk(4,nhkk) = vtxca1(1,4)
2975  vhkk(4,nhkk) = vtxca1(2,4)
2976  ENDIF
2977 
2978  11 CONTINUE
2979 
2980 * modify status and position of cascade particle (the latter for
2981 * statistics reasons only)
2982  isthkk(idxcas) = 2
2983  IF (labsor) isthkk(idxcas) = 19
2984  IF (.NOT.labsor) THEN
2985  DO 15 k=1,4
2986  whkk(k,idxcas) = vtxca1(1,k)
2987  vhkk(k,idxcas) = vtxca1(2,k)
2988  15 CONTINUE
2989  ENDIF
2990 
2991  DO 16 i=1,nspe
2992  is = idxspe(i)
2993 * dump interacting nucleons for energy-momentum conservation check
2994  IF (lemcck)
2995  & CALL evtemc(phkk(1,is),phkk(2,is),phkk(3,is),phkk(4,is),
2996  & 2,idum,idum)
2997 * modify entry for interacting nucleons
2998  IF (isthkk(is).EQ.12+icas) isthkk(is)=16+icas
2999  IF (isthkk(is).EQ.14+icas) isthkk(is)=2
3000  IF (i.GE.2) THEN
3001  jdahkk(1,is) = jdahkk(1,idxspe(1))
3002  jdahkk(2,is) = jdahkk(2,idxspe(1))
3003  ENDIF
3004  16 CONTINUE
3005 
3006 * check energy-momentum conservation
3007  IF (lemcck) THEN
3008  CALL evtemc(dum,dum,dum,dum,4,500,irej1)
3009  IF (irej1.NE.0) goto 9999
3010  ENDIF
3011 
3012 * update counter
3013  IF (labsor) THEN
3014  nincco(icas,1) = nincco(icas,1)+1
3015  ELSE
3016  IF (iproc.EQ.1) nincco(icas,2) = nincco(icas,2)+1
3017  IF (iproc.EQ.2) nincco(icas,3) = nincco(icas,3)+1
3018  ENDIF
3019 
3020  RETURN
3021 
3022  9997 CONTINUE
3023  9998 CONTINUE
3024 * transport-step but no cascade step due to configuration (i.e. there
3025 * is no nucleon for interaction etc.)
3026  IF (lcas) THEN
3027  DO 100 k=1,4
3028 C WHKK(K,IDXCAS) = VTXCAS(1,K)
3029 C VHKK(K,IDXCAS) = VTXCAS(2,K)
3030  whkk(k,idxcas) = vtxca1(1,k)
3031  vhkk(k,idxcas) = vtxca1(2,k)
3032  100 CONTINUE
3033  ENDIF
3034 
3035 C9998 CONTINUE
3036 * no cascade-step because of configuration
3037 * (i.e. hadron outside nucleus etc.)
3038  lcas = .true.
3039  RETURN
3040 
3041  9999 CONTINUE
3042 * rejection
3043  irej = 1
3044  RETURN
3045  END
3046 *
3047 *===absorp=============================================================*
3048 *
3049  SUBROUTINE absorp(IDCAS,PCAS,NCAS,NSPE,IDSPE,IDXSPE,MODE,IREJ)
3050 
3051 ************************************************************************
3052 * Two-nucleon absorption of antiprotons, pi-, and K-. *
3053 * Antiproton absorption is handled by HADRIN. *
3054 * The following channels for meson-absorption are considered: *
3055 * pi- + p + p ---> n + p *
3056 * pi- + p + n ---> n + n *
3057 * K- + p + p ---> sigma+ + n / Lam + p / sigma0 + p *
3058 * K- + p + n ---> sigma- + n / Lam + n / sigma0 + n *
3059 * K- + p + p ---> sigma- + n *
3060 * IDCAS, PCAS identity, momentum of particle to be absorbed *
3061 * NCAS = 1 intranuclear cascade in projectile *
3062 * = -1 intranuclear cascade in target *
3063 * NSPE number of spectator nucleons involved *
3064 * IDXSPE(2) HKKEVT-indices of spectator nucleons involved *
3065 * Revised version of the original STOPIK written by HJM and J. Ranft. *
3066 * This version dated 11.06.96 is written by S. Roesler *
3067 ************************************************************************
3068 
3069  IMPLICIT DOUBLE PRECISION (a-h,o-z)
3070  SAVE
3071  parameter(lout=6,llook=9)
3072  parameter(tiny10=1.0d-10,tiny5=1.0d-5,one=1.0d0,
3073  & onethi=0.3333d0,twothi=0.6666d0)
3074 
3075  parameter(nmxhkk=89998)
3076  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk),
3077  & jmohkk(2,nmxhkk),jdahkk(2,nmxhkk),
3078  & phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk(4,nmxhkk)
3079  COMMON /extevt/ idres(nmxhkk),idxres(nmxhkk),nobam(nmxhkk),
3080  & idbam(nmxhkk),idch(nmxhkk),npoint(10)
3081  LOGICAL lemcck,lhadro,lseadi
3082 C j.r.3.10.96
3083  COMMON /flags/ ifrag(2),iresco,imshl,iresrj,
3084  & lemcck,lhadro(0:9),lseadi
3085  parameter(maxfsp=10)
3086  COMMON /fistat/ pfsp(5,maxfsp),idfsp(maxfsp),nfsp
3087 
3088  CHARACTER*8 aname
3089  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),
3090  & iich(210),iibar(210),k1(210),k2(210)
3091 
3092  dimension pcas(5),idxspe(2),idspe(2),pspe(2,5),pspe1(5),
3093  & ptot3p(4),bg3p(4),
3094  & ecmf(2),pcmf(2),codf(2),coff(2),siff(2)
3095 
3096  irej = 0
3097  nfsp = 0
3098 
3099 * skip particles others than ap, pi-, K- for mode=0
3100  IF ((mode.EQ.0).AND.
3101  & (idcas.NE.2).AND.(idcas.NE.14).AND.(idcas.NE.16)) RETURN
3102 * skip particles others than pions for mode=1
3103  IF ((mode.EQ.1).AND.(idcas.NE.13).AND.
3104  &(idcas.NE.23).AND.(idcas.NE.14)) RETURN
3105 
3106  nucas = ncas
3107  IF (nucas.EQ.-1) nucas = 2
3108 
3109  IF (mode.EQ.0) THEN
3110 * scan spectator nucleons for nucleons being able to "absorb"
3111  nspe = 0
3112  idxspe(1) = 0
3113  idxspe(2) = 0
3114  DO 1 i=1,nhkk
3115  IF ((isthkk(i).EQ.12+nucas).OR.(isthkk(i).EQ.14+nucas)) THEN
3116  nspe = nspe+1
3117  idxspe(nspe) = i
3118  idspe(nspe) = idbam(i)
3119  IF ((nspe.EQ.1).AND.(idcas.EQ.2)) goto 2
3120  IF (nspe.EQ.2) THEN
3121  IF ((idcas.EQ.14).AND.(idspe(1).EQ.8).AND.
3122  & (idspe(2).EQ.8)) THEN
3123 * there is no pi-+n+n channel
3124  nspe = 1
3125  goto 1
3126  ELSE
3127  goto 2
3128  ENDIF
3129  ENDIF
3130  ENDIF
3131  1 CONTINUE
3132 
3133  2 CONTINUE
3134  ENDIF
3135 * transform excited projectile nucleons (status=15) into proj. rest s.
3136  DO 3 i=1,nspe
3137  DO 4 k=1,5
3138  pspe(i,k) = phkk(k,idxspe(i))
3139  4 CONTINUE
3140  3 CONTINUE
3141 
3142 * antiproton absorption
3143  IF ((idcas.EQ.2).AND.(nspe.GE.1)) THEN
3144  DO 5 k=1,5
3145  pspe1(k) = pspe(1,k)
3146  5 CONTINUE
3147 **sr mod. for DPMJET: HADRIN-->HADRI1
3148  CALL hadri1(idcas,pcas,idspe(1),pspe1,1,irej1)
3149  IF (irej1.NE.0) goto 9999
3150 
3151 * meson absorption
3152  ELSEIF (((idcas.EQ.13).OR.(idcas.EQ.14).OR.
3153  &(idcas.EQ.23).OR.(idcas.EQ.16))
3154  & .AND.(nspe.GE.2)) THEN
3155  IF (idcas.EQ.14) THEN
3156 * pi- absorption
3157  idfsp(1) = 8
3158  idfsp(2) = 8
3159  IF ((idspe(1).EQ.1).AND.(idspe(2).EQ.1)) idfsp(2) = 1
3160  ELSEIF (idcas.EQ.13) THEN
3161 * pi+ absorption
3162  idfsp(1) = 1
3163  idfsp(2) = 1
3164  IF ((idspe(1).EQ.8).AND.(idspe(2).EQ.8)) idfsp(2) = 8
3165  ELSEIF (idcas.EQ.23) THEN
3166 * pi-0 absorption
3167  idfsp(1) =idspe(1)
3168  idfsp(2) =idspe(2)
3169  ELSEIF (idcas.EQ.16) THEN
3170 * K- absorption
3171  r = rndm(v)
3172  IF ((idspe(1).EQ.1).AND.(idspe(2).EQ.1)) THEN
3173  IF (r.LT.onethi) THEN
3174  idfsp(1) = 21
3175  idfsp(2) = 8
3176  ELSEIF (r.LT.twothi) THEN
3177  idfsp(1) = 17
3178  idfsp(2) = 1
3179  ELSE
3180  idfsp(1) = 22
3181  idfsp(2) = 1
3182  ENDIF
3183  ELSEIF ((idspe(1).EQ.8).AND.(idspe(2).EQ.8)) THEN
3184  idfsp(1) = 20
3185  idfsp(2) = 8
3186  ELSE
3187  IF (r.LT.onethi) THEN
3188  idfsp(1) = 20
3189  idfsp(2) = 1
3190  ELSEIF (r.LT.twothi) THEN
3191  idfsp(1) = 17
3192  idfsp(2) = 8
3193  ELSE
3194  idfsp(1) = 22
3195  idfsp(2) = 8
3196  ENDIF
3197  ENDIF
3198  ENDIF
3199 * dump initial particles for energy-momentum cons. check
3200  IF (lemcck) THEN
3201  CALL evtemc(pcas(1),pcas(2),pcas(3),pcas(4),1,idum,idum)
3202  CALL evtemc(pspe(1,1),pspe(1,2),pspe(1,3),pspe(1,4),2,
3203  & idum,idum)
3204  CALL evtemc(pspe(2,1),pspe(2,2),pspe(2,3),pspe(2,4),2,
3205  & idum,idum)
3206  ENDIF
3207 * get Lorentz-parameter of 3 particle initial state
3208  DO 6 k=1,4
3209  ptot3p(k) = pcas(k)+pspe(1,k)+pspe(2,k)
3210  6 CONTINUE
3211  p3p = sqrt(ptot3p(1)**2+ptot3p(2)**2+ptot3p(3)**2)
3212  am3p = sqrt( (ptot3p(4)-p3p)*(ptot3p(4)+p3p) )
3213  DO 7 k=1,4
3214  bg3p(k) = ptot3p(k)/max(am3p,tiny10)
3215  7 CONTINUE
3216 * 2-particle decay of the 3-particle compound system
3217  CALL dtwopd(am3p,ecmf(1),ecmf(2),pcmf(1),pcmf(2),
3218  & codf(1),coff(1),siff(1),codf(2),coff(2),siff(2),
3219  & aam(idfsp(1)),aam(idfsp(2)))
3220  DO 8 i=1,2
3221  sdf = sqrt((one-codf(i))*(one+codf(i)))
3222  px = pcmf(i)*coff(i)*sdf
3223  py = pcmf(i)*siff(i)*sdf
3224  pz = pcmf(i)*codf(i)
3225  CALL daltra(bg3p(4),bg3p(1),bg3p(2),bg3p(3),px,py,pz,
3226  & ecmf(i),ptofsp,pfsp(1,i),pfsp(2,i),pfsp(3,i),
3227  & pfsp(4,i))
3228  pfsp(5,i) = sqrt( (pfsp(4,i)-ptofsp)*(pfsp(4,i)+ptofsp) )
3229 * check consistency of kinematics
3230  IF (abs(aam(idfsp(i))-pfsp(5,i)).GT.tiny5) THEN
3231  WRITE(lout,1001) idfsp(i),aam(idfsp(i)),pfsp(5,i)
3232  1001 FORMAT(1x,'ABSORP: warning! inconsistent',
3233  & ' tree-particle kinematics',/,20x,'id: ',i3,
3234  & ' AAM = ',e10.4,' MFSP = ',e10.4)
3235  ENDIF
3236 * dump final state particles for energy-momentum cons. check
3237  IF (lemcck) CALL evtemc(-pfsp(1,i),-pfsp(2,i),
3238  & -pfsp(3,i),-pfsp(4,i),2,idum,idum)
3239  8 CONTINUE
3240  nfsp = 2
3241  IF (lemcck) THEN
3242  CALL evtemc(dum,dum,dum,dum,3,100,irej1)
3243  IF (irej1.NE.0) THEN
3244  WRITE(lout,*)'ABSORB: EMC ',aam(idfsp(1)),aam(idfsp(2)),
3245  & am3p
3246  goto 9999
3247  ENDIF
3248  ENDIF
3249  ELSE
3250 C IF (IOULEV(3).GT.0) WRITE(LOUT,1000) IDCAS,NSPE
3251  1000 FORMAT(1x,'ABSORP: warning! absorption for particle ',i3,
3252  & ' impossible',/,20x,'too few spectators (',i2,')')
3253  nspe = 0
3254  ENDIF
3255 
3256  RETURN
3257 
3258  9999 CONTINUE
3259 C IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in ABSORP'
3260  irej = 1
3261  RETURN
3262  END
3263 *
3264 *===hadri1=============================================================*
3265 *
3266 **sr mod. for DPMJET: HADRIN-->HADRI1
3267  SUBROUTINE hadri1(IDPR,PPR,IDTA,PTA,MODE,IREJ)
3268 
3269 ************************************************************************
3270 * Interface to the HADRIN-routines for inelastic and elastic *
3271 * scattering. *
3272 * IDPR,PPR(5) identity, momentum of projectile *
3273 * IDTA,PTA(5) identity, momentum of target *
3274 * MODE = 1 inelastic interaction *
3275 * = 2 elastic interaction *
3276 * Revised version of the original FHAD. *
3277 * This version dated 27.10.95 is written by S. Roesler *
3278 ************************************************************************
3279 
3280  IMPLICIT DOUBLE PRECISION (a-h,o-z)
3281  SAVE
3282  parameter(lout=6,llook=9)
3283  parameter(zero=0.0d0,tiny10=1.0d-10,tiny5=1.0d-5,tiny3=1.0d-3,
3284  & tiny2=1.0d-2,tiny1=1.0d-1,one=1.0d0)
3285 
3286  LOGICAL lcorr,lmssg
3287  LOGICAL lemcck,lhadro,lseadi
3288  COMMON /flags/ ifrag(2),iresco,imshl,iresrj,
3289  & lemcck,lhadro(0:9),lseadi
3290  parameter(maxfsp=10)
3291  COMMON /fistat/ pfsp(5,maxfsp),idfsp(maxfsp),nfsp
3292 
3293  CHARACTER*8 aname
3294  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),
3295  & iich(210),iibar(210),k1(210),k2(210)
3296 
3297 * output-common for DHADRI/ELHAIN
3298  parameter(maxfin=10)
3299  COMMON /dfinls/ itrh(maxfin),cxrh(maxfin),cyrh(maxfin),
3300  & czrh(maxfin),elrh(maxfin),plrh(maxfin),irh
3301 
3302  dimension ppr(5),ppr1(5),pta(5),bgta(4),
3303  & p1in(4),p2in(4),p1out(4),p2out(4),imcorr(2)
3304 
3305  DATA lmssg /.true./
3306 
3307  irej = 0
3308  nfsp = 0
3309  kcorr = 0
3310  imcorr(1) = 0
3311  imcorr(2) = 0
3312  lcorr = .false.
3313 
3314 * dump initial particles for energy-momentum cons. check
3315  IF (lemcck) THEN
3316  CALL evtemc(ppr(1),ppr(2),ppr(3),ppr(4),1,idum,idum)
3317  CALL evtemc(pta(1),pta(2),pta(3),pta(4),2,idum,idum)
3318  ENDIF
3319 
3320  amp2 = ppr(4)**2-ppr(1)**2-ppr(2)**2-ppr(3)**2
3321  amt2 = pta(4)**2-pta(1)**2-pta(2)**2-pta(3)**2
3322  IF ((amp2.LT.zero).OR.(amt2.LT.zero).OR.
3323  & (abs(amp2-aam(idpr)**2).GT.tiny5).OR.
3324  & (abs(amt2-aam(idta)**2).GT.tiny5)) THEN
3325  IF (lmssg)
3326  & WRITE(lout,1000) amp2,aam(idpr)**2,amt2,aam(idta)**2
3327  1000 FORMAT(1x,'HADRIN: warning! inconsistent projectile/target',
3328  & ' mass',/,20x,'AMP2 = ',e15.7,', AAM(IDPR)**2 = ',
3329  & e15.7,/,20x,'AMT2 = ',e15.7,', AAM(IDTA)**2 = ',e15.7)
3330  lmssg = .false.
3331  lcorr = .true.
3332  ENDIF
3333 
3334 * convert initial state particles into particles which can be
3335 * handled by HADRIN
3336  idhpr = idpr
3337  idhta = idta
3338  IF ((idhpr.LE.0).OR.(idhpr.GE.111).OR.(lcorr)) THEN
3339  IF ((idhpr.LE.0).OR.(idhpr.GE.111)) idhpr = 1
3340  DO 1 k=1,4
3341  p1in(k) = ppr(k)
3342  p2in(k) = pta(k)
3343  1 CONTINUE
3344  xm1 = aam(idhpr)
3345  xm2 = aam(idhta)
3346  CALL mashel(p1in,p2in,xm1,xm2,p1out,p2out,irej1)
3347  IF (irej1.GT.0) THEN
3348 C WRITE(LOUT,'(1X,A)') 'HADRIN: inconsistent mass trsf.'
3349  goto 9999
3350  ENDIF
3351  DO 2 k=1,4
3352  ppr(k) = p1out(k)
3353  pta(k) = p2out(k)
3354  2 CONTINUE
3355  ppr(5) = sqrt(ppr(4)**2-ppr(1)**2-ppr(2)**2-ppr(3)**2)
3356  pta(5) = sqrt(pta(4)**2-pta(1)**2-pta(2)**2-pta(3)**2)
3357  ENDIF
3358 
3359 * Lorentz-parameter for trafo into rest-system of target
3360  DO 3 k=1,4
3361  bgta(k) = pta(k)/pta(5)
3362  3 CONTINUE
3363 * transformation of projectile into rest-system of target
3364  CALL daltra(bgta(4),-bgta(1),-bgta(2),-bgta(3),ppr(1),ppr(2),
3365  & ppr(3),ppr(4),pprto1,ppr1(1),ppr1(2),ppr1(3),
3366  & ppr1(4))
3367 
3368 * direction cosines of projectile in target rest system
3369  cx = ppr1(1)/pprto1
3370  cy = ppr1(2)/pprto1
3371  cz = ppr1(3)/pprto1
3372 
3373 * sample inelastic interaction
3374  IF (mode.EQ.1) THEN
3375  CALL dhadri(idhpr,pprto1,ppr1(4),cx,cy,cz,idhta)
3376  IF (irh.EQ.1)THEN
3377 C WRITE(6,'(A)')' DHADRI Rej'
3378  goto 9998
3379  ENDIF
3380 * sample elastic interaction
3381  ELSEIF (mode.EQ.2) THEN
3382  CALL elhain(idhpr,pprto1,ppr1(4),cx,cy,cz,idhta,irej1)
3383  IF (irej1.NE.0) THEN
3384 C WRITE(LOUT,*) 'rejected 1 in HADRIN'
3385  goto 9999
3386  ENDIF
3387  IF (irh.EQ.1) goto 9998
3388  ELSE
3389  WRITE(lout,1001) mode,inthad
3390  1001 FORMAT(1x,'HADRIN: warning! inconsistent interaction mode',
3391  & i4,' (INTHAD =',i4,')')
3392  goto 9999
3393  ENDIF
3394 
3395 * transform final state particles back into Lab.
3396  DO 4 i=1,irh
3397  nfsp = nfsp+1
3398  px = cxrh(i)*plrh(i)
3399  py = cyrh(i)*plrh(i)
3400  pz = czrh(i)*plrh(i)
3401  CALL daltra(bgta(4),bgta(1),bgta(2),bgta(3),px,py,pz,elrh(i),
3402  & ptofsp,pfsp(1,nfsp),pfsp(2,nfsp),pfsp(3,nfsp),
3403  & pfsp(4,nfsp))
3404  idfsp(nfsp) = itrh(i)
3405  amfsp2 = pfsp(4,nfsp)**2-pfsp(1,nfsp)**2-pfsp(2,nfsp)**2-
3406  & pfsp(3,nfsp)**2
3407  IF (amfsp2.LT.-tiny3) THEN
3408  WRITE(lout,1002) idfsp(nfsp),pfsp(1,nfsp),pfsp(2,nfsp),
3409  & pfsp(3,nfsp),pfsp(4,nfsp),amfsp2
3410  1002 FORMAT(1x,'HADRIN: warning! final state particle (id = ',
3411  & i2,') with negative mass^2',/,1x,5e12.4)
3412  goto 9999
3413  ELSE
3414  pfsp(5,nfsp) = sqrt(abs(amfsp2))
3415  IF (abs(pfsp(5,nfsp)-aam(idfsp(nfsp))).GT.tiny1) THEN
3416 C WRITE(LOUT,1003) IDFSP(NFSP),AAM(IDFSP(NFSP)),
3417 C & PFSP(5,NFSP)
3418  1003 FORMAT(1x,'HADRIN: warning! final state particle',
3419  & ' (id = ',i2,') with inconsistent mass',/,1x,
3420  & 2e12.4)
3421  kcorr = kcorr+1
3422  IF (kcorr.GT.2) goto 9999
3423  imcorr(kcorr) = nfsp
3424  ENDIF
3425  ENDIF
3426 * dump final state particles for energy-momentum cons. check
3427  IF (lemcck) CALL evtemc(-pfsp(1,i),-pfsp(2,i),
3428  & -pfsp(3,i),-pfsp(4,i),2,idum,idum)
3429  4 CONTINUE
3430 
3431 * transform momenta on mass shell in case of inconsistencies in
3432 * HADRIN
3433  IF (kcorr.GT.0) THEN
3434  IF (kcorr.EQ.2) THEN
3435  i1 = imcorr(1)
3436  i2 = imcorr(2)
3437  ELSE
3438  IF (imcorr(1).EQ.1) THEN
3439  i1 = 1
3440  i2 = 2
3441  ELSE
3442  i1 = 1
3443  i2 = imcorr(1)
3444  ENDIF
3445  ENDIF
3446  IF (lemcck) CALL evtemc(pfsp(1,i1),pfsp(2,i1),
3447  & pfsp(3,i1),pfsp(4,i1),2,idum,idum)
3448  IF (lemcck) CALL evtemc(pfsp(1,i2),pfsp(2,i2),
3449  & pfsp(3,i2),pfsp(4,i2),2,idum,idum)
3450  DO 5 k=1,4
3451  p1in(k) = pfsp(k,i1)
3452  p2in(k) = pfsp(k,i2)
3453  5 CONTINUE
3454  xm1 = aam(idfsp(i1))
3455  xm2 = aam(idfsp(i2))
3456  CALL mashel(p1in,p2in,xm1,xm2,p1out,p2out,irej1)
3457  IF (irej1.GT.0) THEN
3458 C WRITE(LOUT,'(1X,A)') 'HADRIN: inconsistent mass trsf.'
3459  goto 9999
3460  ENDIF
3461  DO 6 k=1,4
3462  pfsp(k,i1) = p1out(k)
3463  pfsp(k,i2) = p2out(k)
3464  6 CONTINUE
3465  pfsp(5,i1) = sqrt(pfsp(4,i1)**2-pfsp(1,i1)**2
3466  & -pfsp(2,i1)**2-pfsp(3,i1)**2)
3467  pfsp(5,i2) = sqrt(pfsp(4,i2)**2-pfsp(1,i2)**2
3468  & -pfsp(2,i2)**2-pfsp(3,i2)**2)
3469 * dump final state particles for energy-momentum cons. check
3470  IF (lemcck) CALL evtemc(-pfsp(1,i1),-pfsp(2,i1),
3471  & -pfsp(3,i1),-pfsp(4,i1),2,idum,idum)
3472  IF (lemcck) CALL evtemc(-pfsp(1,i2),-pfsp(2,i2),
3473  & -pfsp(3,i2),-pfsp(4,i2),2,idum,idum)
3474  ENDIF
3475 
3476 * check energy-momentum conservation
3477  IF (lemcck) THEN
3478  CALL evtemc(dum,dum,dum,dum,4,102,irej1)
3479  IF (irej1.NE.0)THEN
3480 C WRITE(6,'(A)')' EVTEMC-HADRIN Rej'
3481  goto 9999
3482  ENDIF
3483  ENDIF
3484 
3485  RETURN
3486 
3487  9998 CONTINUE
3488  irej = 2
3489  RETURN
3490 
3491  9999 CONTINUE
3492  irej = 1
3493  RETURN
3494  END
3495 *
3496 *===evtput=============================================================*
3497 *
3498  SUBROUTINE evtput(IST,ID,M1,M2,PX,PY,PZ,E,IDR,IDXR,IDC)
3499 
3500  IMPLICIT DOUBLE PRECISION (a-h,o-z)
3501  SAVE
3502  parameter(lout=6,llook=9)
3503  parameter(tiny10=1.0d-10,tiny4=1.0d-4,tiny3=1.0d-3,
3504  & tiny2=1.0d-2,sqtinf=1.0d+15,zero=0.d0)
3505 
3506  parameter(nmxhkk=89998)
3507  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk),
3508  & jmohkk(2,nmxhkk),jdahkk(2,nmxhkk),
3509  & phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk(4,nmxhkk)
3510  COMMON /extevt/ idres(nmxhkk),idxres(nmxhkk),nobam(nmxhkk),
3511  & idbam(nmxhkk),idch(nmxhkk),npoint(10)
3512 
3513  COMMON /nuccms/ gacms,bgcms,galab,bglab,blab,umo,pcm,eproj,pproj
3514  CHARACTER*8 aname
3515  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),
3516  & iich(210),iibar(210),k1(210),k2(210)
3517 C WRITE(6,'(A,4I5,4F10.3,3I5)')
3518 C &' EVTPUT, IST,ID,M1,M2,PX,PY,PZ,E,IDR,IDXR,IDC',
3519 C & IST,ID,M1,M2,PX,PY,PZ,E,IDR,IDXR,IDC
3520 
3521 C IF (MODE.GT.100) THEN
3522 C WRITE(LOUT,'(1X,A,I5,A,I5)')
3523 C & 'EVTPUT: reset NHKK = ',NHKK,' to NHKK =',NHKK-MODE+100
3524 C NHKK = NHKK-MODE+100
3525 C RETURN
3526 C ENDIF
3527  mo1 = m1
3528  mo2 = m2
3529  nhkk = nhkk+1
3530 
3531  IF (nhkk.GT.nmxhkk) THEN
3532  WRITE(lout,1000) nhkk
3533  1000 FORMAT(1x,'EVTPUT: NHKK exeeds NMXHKK = ',i7,
3534  & '! program execution stopped..')
3535  stop
3536  ENDIF
3537  IF (m1.LT.0) mo1 = nhkk+m1
3538  IF (m2.LT.0) mo2 = nhkk+m2
3539  isthkk(nhkk) = ist
3540  idhkk(nhkk) = id
3541  jmohkk(1,nhkk) = mo1
3542  jmohkk(2,nhkk) = mo2
3543  jdahkk(1,nhkk) = 0
3544  jdahkk(2,nhkk) = 0
3545  idres(nhkk) = idr
3546  idxres(nhkk) = idxr
3547  idch(nhkk) = idc
3548  IF (id.EQ.88888.OR.id.EQ.88887.OR.id.EQ.88889) THEN
3549  idmo1 = abs(idhkk(mo1))
3550  idmo2 = abs(idhkk(mo2))
3551  IF ((idmo1.LT.100).AND.(idmo2.LT.100)) nobam(nhkk) = 3
3552  IF ((idmo1.LT.100).AND.(idmo2.GT.100)) nobam(nhkk) = 4
3553  IF ((idmo1.GT.100).AND.(idmo2.GT.100)) nobam(nhkk) = 5
3554  IF ((idmo1.GT.100).AND.(idmo2.LT.100)) nobam(nhkk) = 6
3555  ELSE
3556  nobam(nhkk) = 0
3557  ENDIF
3558  idbam(nhkk) = icihad(id)
3559  IF (mo1.GT.0) THEN
3560  IF (jdahkk(1,mo1).NE.0) THEN
3561  jdahkk(2,mo1) = nhkk
3562  ELSE
3563  jdahkk(1,mo1) = nhkk
3564  ENDIF
3565  ENDIF
3566  IF (mo2.GT.0) THEN
3567  IF (jdahkk(1,mo2).NE.0) THEN
3568  jdahkk(2,mo2) = nhkk
3569  ELSE
3570  jdahkk(1,mo2) = nhkk
3571  ENDIF
3572  ENDIF
3573 C WRITE(6,'(A,2I10)')' EVTPUT:NHKK,IDBAM(NHKK)',NHKK,IDBAM(NHKK)
3574  IF(idbam(nhkk).EQ.410)idbam(nhkk)=210
3575  IF (idbam(nhkk).GT.0) THEN
3576  ptot = sqrt(px**2+py**2+pz**2)
3577  am0 = sqrt(abs( (e-ptot)*(e+ptot) ))
3578  amrq = aam(idbam(nhkk))
3579  amdif2 = (am0-amrq)*(am0+amrq)
3580  IF ((abs(amdif2).GT.tiny3).AND.(e.LT.sqtinf).AND.
3581  & (ptot.GT.zero)) THEN
3582  delta = -amdif2/(2.0d0*(e+ptot))
3583 C DELTA = (AMRQ2-AM2)/(2.0D0*(E+PTOT))
3584  e = e+delta
3585  ptot1 = ptot-delta
3586  px = px*ptot1/ptot
3587  py = py*ptot1/ptot
3588  pz = pz*ptot1/ptot
3589  ENDIF
3590  ENDIF
3591  phkk(1,nhkk) = px
3592  phkk(2,nhkk) = py
3593  phkk(3,nhkk) = pz
3594  phkk(4,nhkk) = e
3595  ptot = sqrt( px**2+py**2+pz**2 )
3596  phkk(5,nhkk) = (phkk(4,nhkk)-ptot)*(phkk(4,nhkk)+ptot)
3597 C IF ((PHKK(5,NHKK).LT.0.0D0).AND.(ABS(PHKK(5,NHKK)).GT.TINY4))
3598 C & WRITE(LOUT,'(1X,A,G10.3)')
3599 C & 'EVTPUT: negative mass**2 ',PHKK(5,NHKK)
3600  phkk(5,nhkk) = sqrt(abs(phkk(5,nhkk)))
3601 C IF (ID.EQ.88888) THEN
3602  IF (id.EQ.88888.OR.id.EQ.88887.OR.id.EQ.88889) THEN
3603 * special treatment for chains:
3604 * z coordinate of chain in Lab = pos. of target nucleon
3605 * time of chain-creation in Lab = time of passage of projectile
3606 * nucleus at pos. of taget nucleus
3607 C VHKK(1,NHKK) = 0.5D0*(VHKK(1,MO1)+VHKK(1,MO2))
3608 C VHKK(2,NHKK) = 0.5D0*(VHKK(2,MO1)+VHKK(2,MO2))
3609  vhkk(1,nhkk) = vhkk(1,mo2)
3610  vhkk(2,nhkk) = vhkk(2,mo2)
3611  vhkk(3,nhkk) = vhkk(3,mo2)
3612  vhkk(4,nhkk) = vhkk(3,mo2)/blab-vhkk(3,mo1)/bglab
3613 C WHKK(1,NHKK) = 0.5D0*(WHKK(1,MO1)+WHKK(1,MO2))
3614 C WHKK(2,NHKK) = 0.5D0*(WHKK(2,MO1)+WHKK(2,MO2))
3615  whkk(1,nhkk) = whkk(1,mo1)
3616  whkk(2,nhkk) = whkk(2,mo1)
3617  whkk(3,nhkk) = whkk(3,mo1)
3618  whkk(4,nhkk) = -whkk(3,mo1)/blab+whkk(3,mo2)/bglab
3619  ELSE
3620  DO 2 i=1,4
3621  vhkk(i,nhkk) = vhkk(i,mo1)
3622  whkk(i,nhkk) = whkk(i,mo1)
3623  2 CONTINUE
3624  ENDIF
3625 
3626  RETURN
3627  END
3628 *
3629 *===mashel=============================================================*
3630 *
3631  SUBROUTINE mashel(PA1,PA2,XM1,XM2,P1,P2,IREJ)
3632 
3633 ************************************************************************
3634 * *
3635 * rescaling of momenta of two partons to put both *
3636 * on mass shell *
3637 * *
3638 * input: PA1,PA2 input momentum vectors *
3639 * XM1,2 desired masses of particles afterwards *
3640 * P1,P2 changed momentum vectors *
3641 * *
3642 * The original version is written by R. Engel. *
3643 * This version dated 19.11.95 is modified by S. Roesler. *
3644 ************************************************************************
3645 
3646  IMPLICIT DOUBLE PRECISION (a-h,o-z)
3647  SAVE
3648  parameter(lout=6,llook=9)
3649  parameter(tiny10=1.0d-10,one=1.0d0,zero=0.0d0)
3650 
3651  dimension pa1(4),pa2(4),p1(4),p2(4)
3652 
3653  irej = 0
3654 
3655 * Lorentz transformation into system CMS
3656  px = pa1(1)+pa2(1)
3657  py = pa1(2)+pa2(2)
3658  pz = pa1(3)+pa2(3)
3659  ee = pa1(4)+pa2(4)
3660  xptot = sqrt(px**2+py**2+pz**2)
3661  xms = (ee-xptot)*(ee+xptot)
3662  IF(xms.LT.(xm1+xm2)**2) THEN
3663 C WRITE(LOUT,'(A,3E12.4)')' MASHEL Rej',XMS,XM1,XM2
3664  goto 9999
3665  ENDIF
3666  xms = sqrt(xms)
3667  bgx = px/xms
3668  bgy = py/xms
3669  bgz = pz/xms
3670  gam = ee/xms
3671  CALL daltra(gam,-bgx,-bgy,-bgz,pa1(1),pa1(2),pa1(3),
3672  & pa1(4),ptot1,p1(1),p1(2),p1(3),p1(4))
3673 * rotation angles
3674  cod = p1(3)/ptot1
3675  sid = sqrt((one-cod)*(one+cod))
3676  cof = one
3677  sif = zero
3678  IF(ptot1*sid.GT.tiny10) THEN
3679  cof = p1(1)/(sid*ptot1)
3680  sif = p1(2)/(sid*ptot1)
3681  anorf = sqrt(cof*cof+sif*sif)
3682  cof = cof/anorf
3683  sif = sif/anorf
3684  ENDIF
3685 * new CM momentum and energies (for masses XM1,XM2)
3686  xm12 = xm1**2
3687  xm22 = xm2**2
3688  ss = xms**2
3689  pcmp = ylamb(ss,xm12,xm22)/(2.d0*xms)
3690  ee1 = sqrt(xm12+pcmp**2)
3691  ee2 = xms-ee1
3692 * back rotation
3693  mode = 1
3694  CALL mytran(mode,zero,zero,pcmp,cod,sid,cof,sif,xx,yy,zz)
3695  CALL daltra(gam,bgx,bgy,bgz,xx,yy,zz,ee1,
3696  & ptot1,p1(1),p1(2),p1(3),p1(4))
3697  CALL daltra(gam,bgx,bgy,bgz,-xx,-yy,-zz,ee2,
3698  & ptot2,p2(1),p2(2),p2(3),p2(4))
3699 * check consistency
3700  del = xms*0.0001d0
3701  IF (abs(px-p1(1)-p2(1)).GT.del) THEN
3702  idev = 1
3703  ELSEIF (abs(py-p1(2)-p2(2)).GT.del) THEN
3704  idev = 2
3705  ELSEIF (abs(pz-p1(3)-p2(3)).GT.del) THEN
3706  idev = 3
3707  ELSEIF (abs(ee-p1(4)-p2(4)).GT.del) THEN
3708  idev = 4
3709  ELSE
3710  idev = 0
3711  ENDIF
3712  IF (idev.NE.0) THEN
3713  WRITE(lout,'(/1X,A,I3)')
3714  & 'MASHEL: inconsistent transformation',idev
3715  WRITE(lout,'(1X,A)') 'MASHEL: input momenta/masses:'
3716  WRITE(lout,'(1X,5E12.5)') (pa1(k),k=1,4),xm1
3717  WRITE(lout,'(1X,5E12.5)') (pa2(k),k=1,4),xm2
3718  WRITE(lout,'(1X,A)') 'MASHEL: output momenta:'
3719  WRITE(lout,'(5X,4E12.5)') (p1(k),k=1,4)
3720  WRITE(lout,'(5X,4E12.5)') (p2(k),k=1,4)
3721  ENDIF
3722  RETURN
3723 
3724  9999 CONTINUE
3725  irej = 1
3726  RETURN
3727  END
3728 *
3729 *===mytran=============================================================*
3730 *
3731  SUBROUTINE mytran(IMODE,XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
3732 
3733 ************************************************************************
3734 * This subroutine rotates the coordinate frame *
3735 * a) theta around y *
3736 * b) phi around z if IMODE = 1 *
3737 * *
3738 * x' cos(ph) -sin(ph) 0 cos(th) 0 sin(th) x *
3739 * y' = A B = sin(ph) cos(ph) 0 . 0 1 0 y *
3740 * z' 0 0 1 -sin(th) 0 cos(th) z *
3741 * *
3742 * and vice versa if IMODE = 0. *
3743 * This version dated 5.4.94 is based on the original version DTRAN *
3744 * by J. Ranft and is written by S. Roesler. *
3745 ************************************************************************
3746 
3747  IMPLICIT DOUBLE PRECISION (a-h,o-z)
3748  SAVE
3749  parameter(lout=6,llook=9)
3750 
3751  IF (imode.EQ.1) THEN
3752  x= cde*cfe*xo-sfe*yo+sde*cfe*zo
3753  y= cde*sfe*xo+cfe*yo+sde*sfe*zo
3754  z=-sde *xo +cde *zo
3755  ELSE
3756  x= cde*cfe*xo+cde*sfe*yo-sde*zo
3757  y= -sfe*xo+cfe*yo
3758  z= sde*cfe*xo+sde*sfe*yo+cde*zo
3759  ENDIF
3760  RETURN
3761  END
3762 *
3763 *===ylamb==============================================================*
3764 *
3765  DOUBLE PRECISION FUNCTION ylamb(X,Y,Z)
3766 
3767 ************************************************************************
3768 * *
3769 * auxiliary function for three particle decay mode *
3770 * (standard LAMBDA**(1/2) function) *
3771 * *
3772 * Adopted from an original version written by R. Engel. *
3773 * This version dated 12.12.94 is written by S. Roesler. *
3774 ************************************************************************
3775 
3776  IMPLICIT DOUBLE PRECISION (a-h,o-z)
3777  SAVE
3778 
3779  yz = y-z
3780  xlam = x*x-2.d0*x*(y+z)+yz*yz
3781  IF (xlam.LE.0.d0) xlam = abs(xlam)
3782  ylamb = sqrt(xlam)
3783 
3784  RETURN
3785  END
3786 *
3787 *===evtemc=============================================================*
3788 *
3789  SUBROUTINE evtemc(PXIO,PYIO,PZIO,EIO,IMODE,IPOS,IREJ)
3790 
3791 ************************************************************************
3792 * This version dated 19.11.94 is written by S. Roesler *
3793 ************************************************************************
3794 
3795  IMPLICIT DOUBLE PRECISION (a-h,o-z)
3796  SAVE
3797  parameter(lout=6,llook=9)
3798  parameter(tiny1=1.0d-1,tiny2=1.0d-2,tiny4=1.0d-4,tiny10=1.0d-10,
3799  & zero=0.0d0,tiny11=300.d0)
3800 
3801  parameter(nmxhkk=89998)
3802  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk),
3803  & jmohkk(2,nmxhkk),jdahkk(2,nmxhkk),
3804  & phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk(4,nmxhkk)
3805  LOGICAL lemcck,lhadro,lseadi
3806  COMMON /flags/ ifrag(2),iresco,imshl,iresrj,
3807  & lemcck,lhadro(0:9),lseadi
3808  COMMON /tmpemc/ px,py,pz,e
3809  COMMON /nucc/ it,itz,ip,ipz,ijproj,ibproj,ijtarg,ibtarg
3810  DATA inii/0/
3811 
3812  irej = 0
3813 
3814  mode = imode
3815  chklev = tiny10
3816  chklxv=tiny11
3817  IF (mode.EQ.4) THEN
3818  chklev = tiny2
3819  mode = 3
3820  ELSEIF (mode.EQ.5) THEN
3821  chklev = tiny1
3822  mode = 3
3823  ELSEIF (mode.EQ.-1) THEN
3824  chklev = eio
3825  mode = 3
3826 **sr mod. for DPMJET: set check-level to some fixed value
3827 * i.e. final state momentum is allowed to differ
3828 * from the inital one by 50GeV (!!!)
3829 C This was necessary to see wether the old
3830 C version would work at all at high energy
3831 C but it did not!
3832  chklxv = tiny11
3833  chklev = chklxv
3834 **
3835  ENDIF
3836 
3837  IF (abs(mode).EQ.3) THEN
3838  pxdev = px
3839  pydev = py
3840  pzdev = pz
3841  edev = e
3842  IF ((ifrag(1).EQ.2).AND.(chklev.LT.tiny4)) chklev = tiny4
3843 **sr mod. for DPMJET: use DPMJET check-level
3844  IF ( it.GE.200.AND.ip.GE.200)go to 9998
3845  IF ((abs(pxdev).GT.chklxv).OR.(abs(pydev).GT.chklxv).OR.
3846  & (abs(pzdev).GT.chklxv).OR.(abs(edev).GT.chklxv)) THEN
3847 **
3848  inii=inii+1
3849  IF(inii.LE.10)THEN
3850  WRITE(lout,'(1X,A,I4,A,I6,A,/,4G10.3)')
3851  & 'EVTEMC: energy-momentum cons. failure at pos. ',ipos,
3852  & ' event ',nevhkk,
3853  & ' ! ',pxdev,pydev,pzdev,edev
3854 **sr mod. for DPMJET: additional output
3855  WRITE(6,'(A/4E12.3,3I5)')
3856  * ' Input values (PXIO,PYIO,PZIO,EIO,IMODE,IPOS,IREJ)',
3857  * pxio,pyio,pzio,eio,imode,ipos,irej
3858  WRITE(6,'(A/4E12.3)')
3859  * ' Input values in /TMPEMC/ (PX,PY,PZ,E)',
3860  * px,py,pz,e
3861  ENDIF
3862 **
3863  px = 0.0d0
3864  py = 0.0d0
3865  pz = 0.0d0
3866  e = 0.0d0
3867  goto 9999
3868  ENDIF
3869  9998 CONTINUE
3870  px = 0.0d0
3871  py = 0.0d0
3872  pz = 0.0d0
3873  e = 0.0d0
3874  RETURN
3875  ENDIF
3876 
3877  IF (mode.EQ.1) THEN
3878  px = 0.0d0
3879  py = 0.0d0
3880  pz = 0.0d0
3881  e = 0.0d0
3882  ENDIF
3883 
3884  px = px+pxio
3885  py = py+pyio
3886  pz = pz+pzio
3887  e = e+eio
3888 
3889  RETURN
3890 
3891  9999 CONTINUE
3892  irej = 1
3893  RETURN
3894  END
3895 *
3896 *===ltrans=============================================================*
3897 *
3898  SUBROUTINE ltrans(PXI,PYI,PZI,PEI,PXO,PYO,PZO,PEO,ID,MODE)
3899 
3900 ************************************************************************
3901 * Special Lorentz-transformations. *
3902 * MODE = 1(-1) projectile rest syst. --> Lab (back) *
3903 * = 2(-2) projectile rest syst. --> nucl.-nucl.cms (back) *
3904 * = 3(-3) target rest syst. (=Lab)--> nucl.-nucl.cms (back) *
3905 * This version dated 01.11.95 is written by S. Roesler. *
3906 ************************************************************************
3907 
3908  IMPLICIT DOUBLE PRECISION (a-h,o-z)
3909  SAVE
3910  parameter(lout=6,llook=9)
3911  parameter(tiny3=1.0d-3,zero=0.0d0,two=2.0d0)
3912 
3913  parameter(sqtinf=1.0d+15)
3914 
3915  CHARACTER*8 aname
3916  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),
3917  & iich(210),iibar(210),k1(210),k2(210)
3918 
3919  pxo = pxi
3920  pyo = pyi
3921  CALL ltnuc(pzi,pei,pzo,peo,mode)
3922 
3923 * check particle mass for consistency (numerical rounding errors)
3924  po = sqrt(pxo**2+pyo**2+pzo**2)
3925  amo2 = (peo-po)*(peo+po)
3926  amorq2 = aam(id)**2
3927  amdif2 = abs(amo2-amorq2)
3928  IF ((amdif2.GT.tiny3).AND.(peo.LT.sqtinf).AND.(po.GT.zero)) THEN
3929  delta = (amorq2-amo2)/(two*(peo+po))
3930  peo = peo+delta
3931  po1 = po -delta
3932  pxo = pxo*po1/po
3933  pyo = pyo*po1/po
3934  pzo = pzo*po1/po
3935  ENDIF
3936 
3937  RETURN
3938  END
3939 *
3940 *===ltnuc==============================================================*
3941 *
3942  SUBROUTINE ltnuc(PIN,EIN,POUT,EOUT,MODE)
3943 
3944 ************************************************************************
3945 * Lorentz-transformations. *
3946 * PIN longitudnal momentum (input) *
3947 * EIN energy (input) *
3948 * POUT transformed long. momentum (output) *
3949 * EOUT transformed energy (output) *
3950 * MODE = 1(-1) projectile rest syst. --> Lab (back) *
3951 * = 2(-2) projectile rest syst. --> nucl.-nucl.cms (back) *
3952 * = 3(-3) target rest syst. (=Lab)--> nucl.-nucl.cms (back) *
3953 * This version dated 01.11.95 is written by S. Roesler. *
3954 ************************************************************************
3955 
3956  IMPLICIT DOUBLE PRECISION (a-h,o-z)
3957  SAVE
3958  parameter(lout=6,llook=9)
3959  parameter(zero=0.0d0)
3960 
3961  COMMON /nuccms/ gacms,bgcms,galab,bglab,blab,ecm,pcm,eproj,pproj
3962 
3963  IF (abs(mode).EQ.1) THEN
3964  bg = -sign(bglab,dble(mode))
3965  CALL daltra(galab,zero,zero,-bg,zero,zero,pin,ein,
3966  & dum,dum,dum,pout,eout)
3967  ELSEIF (abs(mode).EQ.2) THEN
3968  bg = sign(bgcms,dble(mode))
3969  CALL daltra(gacms,zero,zero,bg,zero,zero,pin,ein,
3970  & dum,dum,dum,pout,eout)
3971  ELSEIF (abs(mode).EQ.3) THEN
3972  bg = -sign(bgcms,dble(mode))
3973  CALL daltra(gacms,zero,zero,bg,zero,zero,pin,ein,
3974  & dum,dum,dum,pout,eout)
3975  ELSE
3976  WRITE(lout,1000) mode
3977  1000 FORMAT(1x,'LTNUC: not supported mode (MODE = ',i3,')')
3978  eout = ein
3979  pout = pin
3980  ENDIF
3981 
3982  RETURN
3983  END
3984 **sr mod. for DPMJET: short version of the original DTUNUC-routine
3985 *
3986 *===evtini=============================================================*
3987 *
3988  SUBROUTINE evtini(ID,IP,IT,EPN,PPN,ECM,NHKKH1,MODE)
3989 
3990 ************************************************************************
3991 * Initialization of HKKEVT. *
3992 * This version dated 19.11.95 is written by S. Roesler *
3993 ************************************************************************
3994 
3995  IMPLICIT DOUBLE PRECISION (a-h,o-z)
3996  SAVE
3997  parameter(lout=6,llook=9)
3998 
3999  parameter(nmxhkk=89998)
4000  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk),
4001  & jmohkk(2,nmxhkk),jdahkk(2,nmxhkk),
4002  & phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk(4,nmxhkk)
4003  COMMON /extevt/ idres(nmxhkk),idxres(nmxhkk),nobam(nmxhkk),
4004  & idbam(nmxhkk),idch(nmxhkk),npoint(10)
4005  COMMON /nstari/nstart
4006 
4007  goto(1,2) mode
4008 
4009  1 CONTINUE
4010 * initialization of EXTEVT
4011  DO 10 i=1,nhkk
4012  idres(i) = 0
4013  idxres(i) = 0
4014  nobam(i) = 0
4015  idch(i) = 0
4016  10 CONTINUE
4017  CALL ltini(id,epn,ppn,ecm)
4018 C IF(NSTART.NE.2.AND.NEUDEC.GE.20)
4019 C & CALL LTINI(IJPROJ,EPNI,DUM1,DUM2)
4020 
4021  RETURN
4022 
4023  2 CONTINUE
4024  DO 20 i=1,nhkk
4025 * get BAMJET-index of final state particle
4026  idbam(i) = mcihad(idhkk(i))
4027  20 CONTINUE
4028  npoint(1) = ip+it+1
4029  npoint(4) = nhkkh1+1
4030 
4031  RETURN
4032  END
4033 *
4034 *===ltini==============================================================*
4035 *
4036  SUBROUTINE ltini(IDP,EPN,PPN,ECM)
4037 
4038 ************************************************************************
4039 * Initializations of Lorentz-transformations, calculation of Lorentz- *
4040 * parameters. *
4041 * This version dated 13.11.95 is written by S. Roesler. *
4042 ************************************************************************
4043 
4044  IMPLICIT DOUBLE PRECISION (a-h,o-z)
4045  SAVE
4046  parameter(lout=6,llook=9)
4047  parameter(tiny3=1.0d-3,zero=0.0d0,one=1.0d0,two=2.0d0)
4048 
4049  COMMON /nuccms/ gacms,bgcms,galab,bglab,blab,umo,pcm,eproj,pproj
4050 **sr mod. for DPMJET: common added
4051  COMMON /trafop/ gamp,bgamp,betp
4052 **
4053  CHARACTER*8 aname
4054  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),
4055  & iich(210),iibar(210),k1(210),k2(210)
4056 
4057 **sr mod. for DPMJET: force calulation starting from EPN
4058  ecm = zero
4059  ppn = zero
4060 **
4061  IF (ecm.GT.zero) THEN
4062  epn = (ecm**2-aam(idp)**2-aam(1)**2)/(2.0d0*aam(1))
4063  ppn = sqrt((epn-aam(idp))*(epn+aam(idp)))
4064  ELSE
4065  IF ((epn.NE.zero).AND.(ppn.EQ.zero)) THEN
4066  IF (epn.LT.zero) epn = abs(epn)+aam(idp)
4067  ppn = sqrt((epn-aam(idp))*(epn+aam(idp)))
4068  ELSEIF ((ppn.GT.zero).AND.(epn.EQ.zero)) THEN
4069  epn = ppn*sqrt(one+(aam(idp)/ppn)**2)
4070  ENDIF
4071  ecm = sqrt(aam(idp)**2+aam(1)**2+2.0d0*aam(1)*epn)
4072  ENDIF
4073  umo = ecm
4074  eproj = epn
4075  pproj = ppn
4076 * Lorentz-parameter for transformation Lab. - projectile rest system
4077  IF(aam(idp).GT.0.d0)THEN
4078  galab = eproj/aam(idp)
4079  bglab = pproj/aam(idp)
4080  ELSE
4081  galab = eproj/(aam(idp)+0.0001d0)
4082  bglab = pproj/(aam(idp)+0.0001d0)
4083  ENDIF
4084  blab = bglab/galab
4085 * Lorentz-parameter for transformation Lab. - nucl.-nucl. cms.
4086  gacms = (eproj+aam(1))/umo
4087  bgcms = pproj/umo
4088  pcm = gacms*pproj-bgcms*eproj
4089 **sr mod. for DPMJET: initialize /TRAFOP/
4090  gamp = galab
4091  bgamp = bglab
4092  betp = bgamp/gamp
4093 **
4094 C WRITE(6,*)
4095 C &'IDP,EPN,PPN,ECM',IDP,EPN,PPN,ECM
4096 C WRITE(6,*)
4097 C &'GACMS,BGCMS,GALAB,BGLAB,BLAB,UMO,PCM,EPROJ,PPROJ',
4098 C &GACMS,BGCMS,GALAB,BGLAB,BLAB,UMO,PCM,EPROJ,PPROJ
4099 C WRITE(6,*)' GAMP,BGAMP,BETP',GAMP,BGAMP,BETP
4100 
4101  RETURN
4102  END
4103 * *
4104 *=== energy ===========================================================*
4105 * *
4106  DOUBLE PRECISION FUNCTION energy (A,Z)
4107 
4108 C INCLUDE '(DBLPRC)'
4109 *$ CREATE DBLPRC.ADD
4110  IMPLICIT DOUBLE PRECISION (a-h,o-z)
4111  SAVE
4112  parameter( kalgnm = 2 )
4113  parameter( anglgb = 5.0d-16 )
4114  parameter( anglsq = 2.5d-31 )
4115  parameter( axcssv = 0.2d+16 )
4116  parameter( andrfl = 1.0d-38 )
4117  parameter( avrflw = 1.0d+38 )
4118  parameter( ainfnt = 1.0d+30 )
4119  parameter( azrzrz = 1.0d-30 )
4120  parameter( einfnt = +69.07755278982137 d+00 )
4121  parameter( ezrzrz = -69.07755278982137 d+00 )
4122  parameter( onemns = 0.999999999999999 d+00 )
4123  parameter( onepls = 1.000000000000001 d+00 )
4124  parameter( csnnrm = 2.0d-15 )
4125  parameter( dmxtrn = 1.0d+08 )
4126  parameter( zerzer = 0.d+00 )
4127  parameter( oneone = 1.d+00 )
4128  parameter( twotwo = 2.d+00 )
4129  parameter( thrthr = 3.d+00 )
4130  parameter( foufou = 4.d+00 )
4131  parameter( fivfiv = 5.d+00 )
4132  parameter( sixsix = 6.d+00 )
4133  parameter( sevsev = 7.d+00 )
4134  parameter( eigeig = 8.d+00 )
4135  parameter( aninen = 9.d+00 )
4136  parameter( tenten = 10.d+00 )
4137  parameter( hlfhlf = 0.5d+00 )
4138  parameter( onethi = oneone / thrthr )
4139  parameter( twothi = twotwo / thrthr )
4140  parameter( onefou = oneone / foufou )
4141  parameter( thrtwo = thrthr / twotwo )
4142  parameter( pipipi = 3.141592653589793238462643383279d+00 )
4143  parameter( twopip = 6.283185307179586476925286766559d+00 )
4144  parameter( pip5o2 = 7.853981633974483096156608458199d+00 )
4145  parameter( pipisq = 9.869604401089358618834490999876d+00 )
4146  parameter( pihalf = 1.570796326794896619231321691640d+00 )
4147  parameter( erfa00 = 0.886226925452758013649083741671d+00 )
4148  parameter( eneper = 2.718281828459045235360287471353d+00 )
4149  parameter( sqrent = 1.648721270700128146848650787814d+00 )
4150  parameter( sqrsix = 2.449489742783178098197284074706d+00 )
4151  parameter( sqrsev = 2.645751311064590590501615753639d+00 )
4152  parameter( sqrt12 = 3.464101615137754587054892683012d+00 )
4153  parameter( clight = 2.99792458 d+10 )
4154  parameter( avogad = 6.0221367 d+23 )
4155  parameter( boltzm = 1.380658 d-23 )
4156  parameter( amelgr = 9.1093897 d-28 )
4157  parameter( plckbr = 1.05457266 d-27 )
4158  parameter( elccgs = 4.8032068 d-10 )
4159  parameter( elcmks = 1.60217733 d-19 )
4160  parameter( amugrm = 1.6605402 d-24 )
4161  parameter( ammumu = 0.113428913 d+00 )
4162  parameter( amprmu = 1.007276470 d+00 )
4163  parameter( amnemu = 1.008664904 d+00 )
4164  parameter( alpfsc = 7.2973530791728595 d-03 )
4165  parameter( fscto2 = 5.3251361962113614 d-05 )
4166  parameter( fscto3 = 3.8859399018437826 d-07 )
4167  parameter( fscto4 = 2.8357075508200407 d-09 )
4168  parameter( plabrc = 0.197327053 d+00 )
4169  parameter( amelct = 0.51099906 d-03 )
4170  parameter( amugev = 0.93149432 d+00 )
4171  parameter( ammuon = 0.105658389 d+00 )
4172  parameter( amprtn = 0.93827231 d+00 )
4173  parameter( amntrn = 0.93956563 d+00 )
4174  parameter( amdeut = 1.87561339 d+00 )
4175  parameter( cougfm = elccgs * elccgs / elcmks * 1.d-07 * 1.d+13
4176  & * 1.d-09 )
4177  parameter( rclsel = 2.8179409183694872 d-13 )
4178  parameter( bltzmn = 8.617385 d-14 )
4179  parameter( gevmev = 1.0 d+03 )
4180  parameter( emvgev = 1.0 d-03 )
4181  parameter( algvmv = 6.90775527898214 d+00 )
4182  parameter( raddeg = 180.d+00 / pipipi )
4183  parameter( degrad = pipipi / 180.d+00 )
4184  LOGICAL lgbias, lgbana
4185  COMMON / global / lgbias, lgbana
4186 C INCLUDE '(DIMPAR)'
4187 *$ CREATE DIMPAR.ADD
4188  parameter( mxxrgn = 5000 )
4189  parameter( mxxmdf = 56 )
4190  parameter( mxxmde = 50 )
4191  parameter( mfstck = 1000 )
4192  parameter( mestck = 100 )
4193  parameter( nallwp = 39 )
4194  parameter( mpdpdx = 8 )
4195  parameter( icomax = 180 )
4196  parameter( nstbis = 304 )
4197  parameter( idmaxp = 210 )
4198  parameter( idmxdc = 620 )
4199  parameter( mkbmx1 = 1 )
4200  parameter( mkbmx2 = 1 )
4201 C INCLUDE '(IOUNIT)'
4202 *$ CREATE IOUNIT.ADD
4203  parameter( lunin = 5 )
4204  parameter( lunout = 6 )
4205  parameter( lunerr = 15 )
4206  parameter( lunber = 14 )
4207  parameter( lunech = 8 )
4208  parameter( lunflu = 13 )
4209  parameter( lungeo = 16 )
4210  parameter( lunpgs = 12 )
4211  parameter( lunran = 2 )
4212  parameter( lunxsc = 9 )
4213  parameter( lundet = 17 )
4214  parameter( lunray = 10 )
4215  parameter( lunrdb = 1 )
4216 *
4217 *----------------------------------------------------------------------*
4218 * *
4219 * Revised version of the original routine from EVAP: *
4220 * *
4221 * Created on 15 may 1990 by Alfredo Ferrari & Paola Sala *
4222 * Infn - Milan *
4223 * *
4224 * Last change on 01-oct-94 by Alfredo Ferrari *
4225 * *
4226 * !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
4227 * !!! It is supposed to be used with the updated atomic !!! *
4228 * !!! mass data file !!! *
4229 * !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
4230 * *
4231 *----------------------------------------------------------------------*
4232 *
4233 * Mass number below which "unknown" isotopes out of the Z-interval
4234 * reported in the mass tabulations are completely unstable and made
4235 * up by Z proton masses + N neutron masses:
4236  parameter( kafree = 4 )
4237 * Mass number below which "unknown" isotopes out of the Z-interval
4238 * reported in the mass tabulations are supposed to be particle unstable
4239  parameter( kapuns = 12 )
4240 * Minimum energy required for partilce unstable isotopes
4241  parameter( depuns = 0.5d+00 )
4242 *
4243 C INCLUDE '(EVA0)'
4244 *$ CREATE EVA0.ADD
4245  COMMON / eva0 / y0, b0, p0(1001), p1(1001), p2(1001),
4246  * fla(6), flz(6), rho(6), omega(6), exmass(6),
4247  * cam2(130), cam3(200), cam4(130), cam5(200),
4248  * t(4,7), rmass(297), alph(297), bet(297),
4249  * aprime(250), ia(6), iz(6)
4250 C INCLUDE '(ISOTOP)'
4251 *$ CREATE ISOTOP.ADD
4252  parameter( namsmx = 270 )
4253  parameter( nzgvax = 15 )
4254  parameter( nismmx = 574 )
4255  COMMON / isotop / waps(namsmx,nzgvax), t12nuc(namsmx,nzgvax),
4256  & wapism(nismmx), t12ism(nismmx),
4257  & abuiso(nstbis), astlin(2,100), zstlin(2,260),
4258  & amssst(100) , isomnm(nstbis), isondx(2,100),
4259  & jspnuc(namsmx,nzgvax), jptnuc(namsmx,nzgvax),
4260  & inwaps(namsmx), jspism(nismmx),
4261  & jptism(nismmx), izwism(nismmx),
4262  & inwism(0:namsmx)
4263 *
4264  SAVE ka0, kz0, iz0
4265  DATA ka0, kz0, iz0 / -1, -1, -1 /
4266 *
4267  ka0 = nint( a )
4268  kz0 = nint( z )
4269  n = ka0 - kz0
4270 * +-------------------------------------------------------------------*
4271 * | Only protons:
4272  IF ( n .LE. 0 ) THEN
4273  IF ( ka0 .NE. 1 ) THEN
4274  IF ( n .LT. 0 ) THEN
4275  WRITE ( lunout, * )
4276  & ' FLUKA stopped in energy: mass number =< atomic number !!',
4277  & ka0, kz0
4278  WRITE ( lunout, * )
4279  & ' FLUKA stopped in energy: mass number =< atomic number !!',
4280  & ka0, kz0
4281  WRITE ( 77, * )
4282  & ' ^^^FLUKA stopped in energy: mass number =< atomic number !!',
4283  & ka0, kz0
4284  stop 'ENERGY:KA0-KZ0'
4285  END IF
4286  ELSE
4287  energy = waps( 1, 2 )
4288  iz0 = -1
4289  RETURN
4290  END IF
4291  END IF
4292 * |
4293 * +-------------------------------------------------------------------*
4294 * +-------------------------------------------------------------------*
4295 * |
4296 * |
4297 * +-------------------------------------------------------------------*
4298 * +-------------------------------------------------------------------*
4299 * | A larger than maximum allowed:
4300  IF ( ka0 .GT. namsmx ) THEN
4301  energy = enrg( a, z )
4302  iz0 = -1
4303  RETURN
4304  END IF
4305 * |
4306 * +-------------------------------------------------------------------*
4307  izz = inwaps( ka0 )
4308 * +-------------------------------------------------------------------*
4309 * | Too much neutron rich with respect to the stability line:
4310  IF ( kz0 .LT. izz ) THEN
4311 * | +----------------------------------------------------------------*
4312 * | | Up to A=Kafree all "bound" masses are known, set it unbound:
4313  IF ( ka0 .LE. kafree ) THEN
4314  energy = ( a - z ) * waps(1,1) + z * waps(1,2)
4315 * | |
4316 * | +----------------------------------------------------------------*
4317 * | | Up to Kapuns: be sure it is particle unstable
4318  ELSE IF ( ka0 .LE. kapuns ) THEN
4319  energy = enrg( a, z )
4320  jzz = inwaps( ka0 - 1 )
4321  lzz = inwaps( ka0 - 2 )
4322 * | | +-------------------------------------------------------------*
4323 * | | | Residual mass for n-decay known:
4324  IF ( kz0 .GE. jzz .AND. kz0 .LE. jzz + nzgvax - 1 ) THEN
4325  iz0 = kz0 - jzz + 1
4326  energy = max( energy, waps(ka0-1,iz0) + waps(1,1)
4327  & + depuns )
4328 * | | |
4329 * | | +-------------------------------------------------------------*
4330 * | | | Residual mass for 2n-decay known:
4331  ELSE IF ( kz0 .GE. lzz .AND. kz0 .LE. lzz + nzgvax - 1 )THEN
4332  iz0 = kz0 - lzz + 1
4333  energy = max( energy, waps(ka0-2,iz0) + twotwo *
4334  & ( waps(1,1) + depuns ) )
4335 * | | |
4336 * | | +-------------------------------------------------------------*
4337 * | | | Set it unbound:
4338  ELSE
4339  energy = ainfnt
4340  END IF
4341 * | | |
4342 * | | +-------------------------------------------------------------*
4343 * | | Be sure not to have a positive energy state:
4344  energy = min( energy, (a-z) * waps(1,1) + z * waps(1,2) )
4345 * | |
4346 * | +----------------------------------------------------------------*
4347 * | | Proceed as usual:
4348  ELSE
4349  energy = enrg(a,z)
4350  END IF
4351 * | |
4352 * | +----------------------------------------------------------------*
4353  iz0 = -1
4354  RETURN
4355 * |
4356 * +-------------------------------------------------------------------*
4357 * | Too much proton rich with respect to the stability line:
4358  ELSE IF ( kz0 .GT. izz + nzgvax - 1 ) THEN
4359 * | +----------------------------------------------------------------*
4360 * | | Up to A=Kafree all "bound" masses are known, set it unbound:
4361  IF ( ka0 .LE. kafree ) THEN
4362  energy = ( a - z ) * waps(1,1) + z * waps(1,2)
4363 * | |
4364 * | +----------------------------------------------------------------*
4365 * | | Up to Kapuns: be sure it is particle unstable
4366  ELSE IF ( ka0 .LE. kapuns ) THEN
4367  energy = enrg( a, z )
4368  jzz = inwaps( ka0 - 1 )
4369  lzz = inwaps( ka0 - 2 )
4370 * | | +-------------------------------------------------------------*
4371 * | | | Residual mass for p-decay known:
4372  IF ( kz0-1 .GE. jzz .AND. kz0-1 .LE. jzz + nzgvax - 1 ) THEN
4373  iz0 = kz0 - 1 - jzz + 1
4374  energy = max( energy, waps(ka0-1,iz0) + waps(1,2)
4375  & + depuns )
4376 * | | |
4377 * | | +-------------------------------------------------------------*
4378 * | | | Residual mass for 2p-decay known:
4379  ELSE IF ( kz0-2 .GE. lzz .AND. kz0-2 .LE. lzz + nzgvax - 1 )
4380  & THEN
4381  iz0 = kz0 - 2 - lzz + 1
4382  energy = max( energy, waps(ka0-2,iz0) + twotwo *
4383  & ( waps(1,2) + depuns ) )
4384 * | | |
4385 * | | +-------------------------------------------------------------*
4386 * | | | Set it unbound:
4387  ELSE
4388  energy = ainfnt
4389  END IF
4390 * | | |
4391 * | | +-------------------------------------------------------------*
4392 * | | Be sure not to have a positive energy state:
4393  energy = min( energy, (a-z) * waps(1,1) + z * waps(1,2) )
4394 * | |
4395 * | +----------------------------------------------------------------*
4396 * | | Proceed as usual:
4397  ELSE
4398  energy = enrg(a,z)
4399  END IF
4400 * | |
4401 * | +----------------------------------------------------------------*
4402  iz0 = -1
4403  RETURN
4404 * |
4405 * +-------------------------------------------------------------------*
4406 * | Known isotope or anyway isotope "inside" the stability zone
4407  ELSE
4408  iz0 = kz0 - izz + 1
4409  energy = waps( ka0, iz0 )
4410 * | +----------------------------------------------------------------*
4411 * | | Mass not known
4412  IF ( abs(energy) .LT. anglgb .AND. (ka0 .NE. 12 .OR. kz0
4413  & .NE. 6) ) THEN
4414  iz0 = -1
4415  energy = enrg( a, z )
4416  END IF
4417 * | |
4418 * | +----------------------------------------------------------------*
4419  RETURN
4420  END IF
4421 * |
4422 * +-------------------------------------------------------------------*
4423 *=== End of Function Energy ===========================================*
4424 * RETURN
4425  END
4426 *$ CREATE ENRG.FOR
4427 *COPY ENRG
4428 * *
4429 *=== enrg =============================================================*
4430 * *
4431  DOUBLE PRECISION FUNCTION enrg(A,Z)
4432 
4433 C INCLUDE '(DBLPRC)'
4434 *$ CREATE DBLPRC.ADD
4435  IMPLICIT DOUBLE PRECISION (a-h,o-z)
4436  SAVE
4437  parameter( kalgnm = 2 )
4438  parameter( anglgb = 5.0d-16 )
4439  parameter( anglsq = 2.5d-31 )
4440  parameter( axcssv = 0.2d+16 )
4441  parameter( andrfl = 1.0d-38 )
4442  parameter( avrflw = 1.0d+38 )
4443  parameter( ainfnt = 1.0d+30 )
4444  parameter( azrzrz = 1.0d-30 )
4445  parameter( einfnt = +69.07755278982137 d+00 )
4446  parameter( ezrzrz = -69.07755278982137 d+00 )
4447  parameter( onemns = 0.999999999999999 d+00 )
4448  parameter( onepls = 1.000000000000001 d+00 )
4449  parameter( csnnrm = 2.0d-15 )
4450  parameter( dmxtrn = 1.0d+08 )
4451  parameter( zerzer = 0.d+00 )
4452  parameter( oneone = 1.d+00 )
4453  parameter( twotwo = 2.d+00 )
4454  parameter( thrthr = 3.d+00 )
4455  parameter( foufou = 4.d+00 )
4456  parameter( fivfiv = 5.d+00 )
4457  parameter( sixsix = 6.d+00 )
4458  parameter( sevsev = 7.d+00 )
4459  parameter( eigeig = 8.d+00 )
4460  parameter( aninen = 9.d+00 )
4461  parameter( tenten = 10.d+00 )
4462  parameter( hlfhlf = 0.5d+00 )
4463  parameter( onethi = oneone / thrthr )
4464  parameter( twothi = twotwo / thrthr )
4465  parameter( onefou = oneone / foufou )
4466  parameter( thrtwo = thrthr / twotwo )
4467  parameter( pipipi = 3.141592653589793238462643383279d+00 )
4468  parameter( twopip = 6.283185307179586476925286766559d+00 )
4469  parameter( pip5o2 = 7.853981633974483096156608458199d+00 )
4470  parameter( pipisq = 9.869604401089358618834490999876d+00 )
4471  parameter( pihalf = 1.570796326794896619231321691640d+00 )
4472  parameter( erfa00 = 0.886226925452758013649083741671d+00 )
4473  parameter( eneper = 2.718281828459045235360287471353d+00 )
4474  parameter( sqrent = 1.648721270700128146848650787814d+00 )
4475  parameter( sqrsix = 2.449489742783178098197284074706d+00 )
4476  parameter( sqrsev = 2.645751311064590590501615753639d+00 )
4477  parameter( sqrt12 = 3.464101615137754587054892683012d+00 )
4478  parameter( clight = 2.99792458 d+10 )
4479  parameter( avogad = 6.0221367 d+23 )
4480  parameter( boltzm = 1.380658 d-23 )
4481  parameter( amelgr = 9.1093897 d-28 )
4482  parameter( plckbr = 1.05457266 d-27 )
4483  parameter( elccgs = 4.8032068 d-10 )
4484  parameter( elcmks = 1.60217733 d-19 )
4485  parameter( amugrm = 1.6605402 d-24 )
4486  parameter( ammumu = 0.113428913 d+00 )
4487  parameter( amprmu = 1.007276470 d+00 )
4488  parameter( amnemu = 1.008664904 d+00 )
4489  parameter( alpfsc = 7.2973530791728595 d-03 )
4490  parameter( fscto2 = 5.3251361962113614 d-05 )
4491  parameter( fscto3 = 3.8859399018437826 d-07 )
4492  parameter( fscto4 = 2.8357075508200407 d-09 )
4493  parameter( plabrc = 0.197327053 d+00 )
4494  parameter( amelct = 0.51099906 d-03 )
4495  parameter( amugev = 0.93149432 d+00 )
4496  parameter( ammuon = 0.105658389 d+00 )
4497  parameter( amprtn = 0.93827231 d+00 )
4498  parameter( amntrn = 0.93956563 d+00 )
4499  parameter( amdeut = 1.87561339 d+00 )
4500  parameter( cougfm = elccgs * elccgs / elcmks * 1.d-07 * 1.d+13
4501  & * 1.d-09 )
4502  parameter( rclsel = 2.8179409183694872 d-13 )
4503  parameter( bltzmn = 8.617385 d-14 )
4504  parameter( gevmev = 1.0 d+03 )
4505  parameter( emvgev = 1.0 d-03 )
4506  parameter( algvmv = 6.90775527898214 d+00 )
4507  parameter( raddeg = 180.d+00 / pipipi )
4508  parameter( degrad = pipipi / 180.d+00 )
4509  LOGICAL lgbias, lgbana
4510  COMMON / global / lgbias, lgbana
4511 C INCLUDE '(DIMPAR)'
4512 *$ CREATE DIMPAR.ADD
4513  parameter( mxxrgn = 5000 )
4514  parameter( mxxmdf = 56 )
4515  parameter( mxxmde = 50 )
4516  parameter( mfstck = 1000 )
4517  parameter( mestck = 100 )
4518  parameter( nallwp = 39 )
4519  parameter( mpdpdx = 8 )
4520  parameter( icomax = 180 )
4521  parameter( nstbis = 304 )
4522  parameter( idmaxp = 210 )
4523  parameter( idmxdc = 620 )
4524  parameter( mkbmx1 = 1 )
4525  parameter( mkbmx2 = 1 )
4526 C INCLUDE '(IOUNIT)'
4527 *$ CREATE IOUNIT.ADD
4528  parameter( lunin = 5 )
4529  parameter( lunout = 6 )
4530  parameter( lunerr = 15 )
4531  parameter( lunber = 14 )
4532  parameter( lunech = 8 )
4533  parameter( lunflu = 13 )
4534  parameter( lungeo = 16 )
4535  parameter( lunpgs = 12 )
4536  parameter( lunran = 2 )
4537  parameter( lunxsc = 9 )
4538  parameter( lundet = 17 )
4539  parameter( lunray = 10 )
4540  parameter( lunrdb = 1 )
4541 *
4542 *----------------------------------------------------------------------*
4543 * *
4544 * Revised version of the original routine from EVAP: *
4545 * *
4546 * Created on 15 may 1990 by Alfredo Ferrari & Paola Sala *
4547 * Infn - Milan *
4548 * *
4549 * Last change on 01-oct-94 by Alfredo Ferrari *
4550 * *
4551 * !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
4552 * !!! It is supposed to be used with the updated atomic !!! *
4553 * !!! mass data file !!! *
4554 * !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! *
4555 * *
4556 *----------------------------------------------------------------------*
4557 *
4558  parameter( o16old = 931.145 d+00 )
4559  parameter( o16new = 931.19826d+00 )
4560  parameter( o16rat = o16new / o16old )
4561  parameter( c12new = 931.49432d+00 )
4562  parameter( adjust = -8.322737768178909d-02 )
4563 C INCLUDE '(EVA0)'
4564 *$ CREATE EVA0.ADD
4565  COMMON / eva0 / y0, b0, p0(1001), p1(1001), p2(1001),
4566  * fla(6), flz(6), rho(6), omega(6), exmass(6),
4567  * cam2(130), cam3(200), cam4(130), cam5(200),
4568  * t(4,7), rmass(297), alph(297), bet(297),
4569  * aprime(250), ia(6), iz(6)
4570  LOGICAL lfirst
4571  SAVE lfirst, exhydr, exneut
4572  DATA lfirst / .true. /
4573  DATA nerg1/ 0/
4574 *
4575  IF ( lfirst ) THEN
4576  lfirst = .false.
4577  exhydr = energy( oneone, oneone )
4578  exneut = energy( oneone, zerzer )
4579  END IF
4580  iz0 = nint(z)
4581  IF ( iz0 .LE. 0 ) THEN
4582  enrg = a * exneut
4583  RETURN
4584  END IF
4585  IF (a .EQ. 0.d0)THEN
4586  WRITE (6,'(A)')' ENRG A=0.'
4587  enrg = 0
4588  RETURN
4589  ENDIF
4590  n = nint(a-z)
4591  IF ( n .LE. 0 ) THEN
4592  enrg = z * exhydr
4593  RETURN
4594  END IF
4595  am2zoa= (a-z-z)/a
4596  am2zoa=am2zoa*am2zoa
4597  a13 = rmass(nint(a))
4598 * A13 = A**.3333333333333333D+00
4599  IF(a13 .EQ. 0.d0) THEN
4600  nerg1=nerg1+1
4601  IF(nerg1.LE.50)WRITE (6,'(A)')' ENRG A13=0.'
4602  enrg = 0
4603  RETURN
4604  ENDIF
4605  am13 = 1.d+00/a13
4606  ev=-17.0354d+00*(1.d+00 -1.84619 d+00*am2zoa)*a
4607  es= 25.8357d+00*(1.d+00 -1.712185d+00*am2zoa)*
4608  & (1.d+00 -0.62025d+00*am13*am13)*
4609  & (a13*a13 -.62025d+00)
4610  ec= 0.799d+00*z*(z-1.d+00)*am13*(((1.5772d+00*am13 +1.2273d+00)*
4611  & am13-1.5849d+00)*
4612  & am13*am13 +1.d+00)
4613  eex= -0.4323d+00*am13*z**1.3333333d+00*
4614  & (((0.49597d+00*am13 -0.14518d+00)*am13 -0.57811d+00) * am13
4615  & + 1.d+00)
4616  enrg =8.367d+00*a -0.783d+00*z +ev +es +ec +eex+cam2(iz0)+cam3(n)
4617  enrg = ( enrg + a * o16old ) * o16rat - a * ( c12new - adjust )
4618  enrg = min( enrg, z * exhydr + ( a - z ) * exneut )
4619  RETURN
4620 *=== End of function Enrg =============================================*
4621  END
4622 *$ CREATE BERTTP.FOR
4623 *COPY BERTTP
4624 * *
4625 *=== berttp ===========================================================*
4626 * *
4627  SUBROUTINE berttp
4628 C INCLUDE '(DBLPRC)'
4629 *$ CREATE DBLPRC.ADD
4630  IMPLICIT DOUBLE PRECISION (a-h,o-z)
4631  SAVE
4632  parameter( kalgnm = 2 )
4633  parameter( anglgb = 5.0d-16 )
4634  parameter( anglsq = 2.5d-31 )
4635  parameter( axcssv = 0.2d+16 )
4636  parameter( andrfl = 1.0d-38 )
4637  parameter( avrflw = 1.0d+38 )
4638  parameter( ainfnt = 1.0d+30 )
4639  parameter( azrzrz = 1.0d-30 )
4640  parameter( einfnt = +69.07755278982137 d+00 )
4641  parameter( ezrzrz = -69.07755278982137 d+00 )
4642  parameter( onemns = 0.999999999999999 d+00 )
4643  parameter( onepls = 1.000000000000001 d+00 )
4644  parameter( csnnrm = 2.0d-15 )
4645  parameter( dmxtrn = 1.0d+08 )
4646  parameter( zerzer = 0.d+00 )
4647  parameter( oneone = 1.d+00 )
4648  parameter( twotwo = 2.d+00 )
4649  parameter( thrthr = 3.d+00 )
4650  parameter( foufou = 4.d+00 )
4651  parameter( fivfiv = 5.d+00 )
4652  parameter( sixsix = 6.d+00 )
4653  parameter( sevsev = 7.d+00 )
4654  parameter( eigeig = 8.d+00 )
4655  parameter( aninen = 9.d+00 )
4656  parameter( tenten = 10.d+00 )
4657  parameter( hlfhlf = 0.5d+00 )
4658  parameter( onethi = oneone / thrthr )
4659  parameter( twothi = twotwo / thrthr )
4660  parameter( onefou = oneone / foufou )
4661  parameter( thrtwo = thrthr / twotwo )
4662  parameter( pipipi = 3.141592653589793238462643383279d+00 )
4663  parameter( twopip = 6.283185307179586476925286766559d+00 )
4664  parameter( pip5o2 = 7.853981633974483096156608458199d+00 )
4665  parameter( pipisq = 9.869604401089358618834490999876d+00 )
4666  parameter( pihalf = 1.570796326794896619231321691640d+00 )
4667  parameter( erfa00 = 0.886226925452758013649083741671d+00 )
4668  parameter( eneper = 2.718281828459045235360287471353d+00 )
4669  parameter( sqrent = 1.648721270700128146848650787814d+00 )
4670  parameter( sqrsix = 2.449489742783178098197284074706d+00 )
4671  parameter( sqrsev = 2.645751311064590590501615753639d+00 )
4672  parameter( sqrt12 = 3.464101615137754587054892683012d+00 )
4673  parameter( clight = 2.99792458 d+10 )
4674  parameter( avogad = 6.0221367 d+23 )
4675  parameter( boltzm = 1.380658 d-23 )
4676  parameter( amelgr = 9.1093897 d-28 )
4677  parameter( plckbr = 1.05457266 d-27 )
4678  parameter( elccgs = 4.8032068 d-10 )
4679  parameter( elcmks = 1.60217733 d-19 )
4680  parameter( amugrm = 1.6605402 d-24 )
4681  parameter( ammumu = 0.113428913 d+00 )
4682  parameter( amprmu = 1.007276470 d+00 )
4683  parameter( amnemu = 1.008664904 d+00 )
4684  parameter( alpfsc = 7.2973530791728595 d-03 )
4685  parameter( fscto2 = 5.3251361962113614 d-05 )
4686  parameter( fscto3 = 3.8859399018437826 d-07 )
4687  parameter( fscto4 = 2.8357075508200407 d-09 )
4688  parameter( plabrc = 0.197327053 d+00 )
4689  parameter( amelct = 0.51099906 d-03 )
4690  parameter( amugev = 0.93149432 d+00 )
4691  parameter( ammuon = 0.105658389 d+00 )
4692  parameter( amprtn = 0.93827231 d+00 )
4693  parameter( amntrn = 0.93956563 d+00 )
4694  parameter( amdeut = 1.87561339 d+00 )
4695  parameter( cougfm = elccgs * elccgs / elcmks * 1.d-07 * 1.d+13
4696  & * 1.d-09 )
4697  parameter( rclsel = 2.8179409183694872 d-13 )
4698  parameter( bltzmn = 8.617385 d-14 )
4699  parameter( gevmev = 1.0 d+03 )
4700  parameter( emvgev = 1.0 d-03 )
4701  parameter( algvmv = 6.90775527898214 d+00 )
4702  parameter( raddeg = 180.d+00 / pipipi )
4703  parameter( degrad = pipipi / 180.d+00 )
4704  LOGICAL lgbias, lgbana
4705  COMMON / global / lgbias, lgbana
4706 C INCLUDE '(DIMPAR)'
4707 *$ CREATE DIMPAR.ADD
4708  parameter( mxxrgn = 5000 )
4709  parameter( mxxmdf = 56 )
4710  parameter( mxxmde = 50 )
4711  parameter( mfstck = 1000 )
4712  parameter( mestck = 100 )
4713  parameter( nallwp = 39 )
4714  parameter( mpdpdx = 8 )
4715  parameter( icomax = 180 )
4716  parameter( nstbis = 304 )
4717  parameter( idmaxp = 210 )
4718  parameter( idmxdc = 620 )
4719  parameter( mkbmx1 = 1 )
4720  parameter( mkbmx2 = 1 )
4721 C INCLUDE '(IOUNIT)'
4722 *$ CREATE IOUNIT.ADD
4723  parameter( lunin = 5 )
4724  parameter( lunout = 6 )
4725  parameter( lunerr = 15 )
4726  parameter( lunber = 14 )
4727  parameter( lunech = 8 )
4728  parameter( lunflu = 13 )
4729  parameter( lungeo = 16 )
4730  parameter( lunpgs = 12 )
4731  parameter( lunran = 2 )
4732  parameter( lunxsc = 9 )
4733  parameter( lundet = 17 )
4734  parameter( lunray = 10 )
4735  parameter( lunrdb = 1 )
4736 C---------------------------------------------------------------------
4737 C SUBNAME = BERTTP --- READ BERTINI DATA
4738 C---------------------------------------------------------------------
4739 C ---------------------------------- I-N-C DATA
4740 C COMMON R8(2127),R4(64),CRSC(600,4),R8B(336),CS(29849)
4741 C REAL*8 R8,R8B,CRSC,CS
4742 C REAL*4 R4
4743 C --------------------------------- EVAPORATION DATA
4744 C INCLUDE '(COOKCM)'
4745 *$ CREATE COOKCM.ADD
4746  parameter( asmtog = sixsix / pipipi**2 )
4747  LOGICAL ldefoz, ldefon
4748  parameter( incook = 150, izcook = 98 )
4749  COMMON / cookcm / alpign, betign, gamign, powign,
4750  & szcook(izcook), sncook(incook), pzcook(izcook),
4751  & pncook(incook), ldefoz(izcook), ldefon(incook)
4752 C INCLUDE '(EVA0)'
4753 *$ CREATE EVA0.ADD
4754  COMMON / eva0 / y0, b0, p0(1001), p1(1001), p2(1001),
4755  * fla(6), flz(6), rho(6), omega(6), exmass(6),
4756  * cam2(130), cam3(200), cam4(130), cam5(200),
4757  * t(4,7), rmass(297), alph(297), bet(297),
4758  * aprime(250), ia(6), iz(6)
4759 C INCLUDE '(FRBKCM)'
4760 *$ CREATE FRBKCM.ADD
4761  parameter( mxffbk = 6 )
4762  parameter( mxzfbk = 9 )
4763  parameter( mxnfbk = 10 )
4764  parameter( mxafbk = 16 )
4765  parameter( nxzfbk = mxzfbk + mxffbk / 3 )
4766  parameter( nxnfbk = mxnfbk + mxffbk / 3 )
4767  parameter( nxafbk = mxafbk + 1 )
4768  parameter( mxpsst = 300 )
4769  parameter( mxpsfb = 41000 )
4770  LOGICAL lfrmbk, lncmss
4771  COMMON / frbkcm / amufbk, eexfbk(mxpsst), amfrbk(mxpsst),
4772  & exfrbk(mxpsfb), sdmfbk(mxpsfb), coufbk(mxpsfb),
4773  & exmxfb, r0frbk, r0cfbk, c1cfbk, c2cfbk,
4774  & ifrbkn(mxpsst), ifrbkz(mxpsst),
4775  & ifbksp(mxpsst), ifbkpr(mxpsst), ifbkst(mxpsst),
4776  & ipsind(0:mxnfbk,0:mxzfbk,2), jpsind(0:mxafbk),
4777  & ifbind(0:nxnfbk,0:nxzfbk,2), jfbind(0:nxafbk),
4778  & ifbcha(5,mxpsfb), iposst, iposfb, ifbstf,
4779  & ifbfrb, nbufbk, lfrmbk, lncmss
4780 C INCLUDE '(HETTP)'
4781 *$ CREATE HETTP.ADD
4782  COMMON /hettp/ nhstp,nbertp,iosub,insrs
4783 C INCLUDE '(INPFLG)'
4784 *$ CREATE INPFLG.ADD
4785  COMMON /inpflg/ iang,ifiss,ib0,igeom,istrag,keydk
4786 C INCLUDE '(ISOTOP)'
4787 *$ CREATE ISOTOP.ADD
4788  parameter( namsmx = 270 )
4789  parameter( nzgvax = 15 )
4790  parameter( nismmx = 574 )
4791  COMMON / isotop / waps(namsmx,nzgvax), t12nuc(namsmx,nzgvax),
4792  & wapism(nismmx), t12ism(nismmx),
4793  & abuiso(nstbis), astlin(2,100), zstlin(2,260),
4794  & amssst(100) , isomnm(nstbis), isondx(2,100),
4795  & jspnuc(namsmx,nzgvax), jptnuc(namsmx,nzgvax),
4796  & inwaps(namsmx), jspism(nismmx),
4797  & jptism(nismmx), izwism(nismmx),
4798  & inwism(0:namsmx)
4799 C INCLUDE '(NUCGEO)'
4800 *$ CREATE NUCGEO.ADD
4801  parameter( pi = pipipi )
4802  parameter( pisq = pipisq )
4803  parameter( sktohl = 0.5456645846610345d+00 )
4804  parameter( rznucl = 1.12 d+00 )
4805  parameter( rmspro = 0.8 d+00 )
4806  parameter( r0prot = rmspro / sqrt12 )
4807  parameter( arhpro = 1.d+00 / 8.d+00 / pi / r0prot / r0prot
4808  & / r0prot )
4809  parameter( rlle04 = rznucl )
4810  parameter( rlle16 = rznucl )
4811  parameter( rlgt16 = rznucl )
4812  parameter( rcle04 = 0.75d+00 / pi / rlle04 / rlle04 / rlle04 )
4813  parameter( rcle16 = 0.75d+00 / pi / rlle16 / rlle16 / rlle16 )
4814  parameter( rcgt16 = 0.75d+00 / pi / rlgt16 / rlgt16 / rlgt16 )
4815  parameter( skle04 = 1.4d+00 )
4816  parameter( skle16 = 1.9d+00 )
4817  parameter( skgt16 = 2.4d+00 )
4818  parameter( hlle04 = sktohl * skle04 )
4819  parameter( hlle16 = sktohl * skle16 )
4820  parameter( hlgt16 = sktohl * skgt16 )
4821  parameter( alpha0 = 0.1d+00 )
4822  parameter( omalh0 = 1.d+00 - alpha0 )
4823  parameter( gamsk0 = 0.9d+00 )
4824  parameter( omgas0 = 1.d+00 - gamsk0 )
4825  parameter( potme0 = 0.6666666666666667d+00 )
4826  parameter( potba0 = 1.d+00 )
4827  parameter( pnfrat = 1.533d+00 )
4828  parameter( radpim = 0.035d+00 )
4829  parameter( rdpmhl = 14.d+00 )
4830  parameter( apmrst = 4.d+00 / 44.d+00 )
4831  parameter( apmpro = 1.d+00 / 6.d+00 )
4832  parameter( apppro = 5.d+00 / 6.d+00 )
4833  parameter( ap0pfs = 0.5d+00 )
4834  parameter( ap0pfp = 1.d+00 / 3.d+00 )
4835  parameter( ap0nfp = 2.d+00 / 3.d+00 )
4836  parameter( xpauco = 1.88495407241652 d+00 )
4837  parameter( mxscin = 50 )
4838  LOGICAL labrst, lelstc, linels, lchexc, labsrp, labsth, lpreeq,
4839  & lnphtc, lnwrad, lpnrho
4840  COMMON / nucgid / rhotab(2:260), rhatab(2:260), alptab(2:260),
4841  & radtab(2:260), skitab(2:260), haltab(2:260),
4842  & sk3tab(2:260), sk4tab(2:260), habtab(2:260),
4843  & cwstab(2:260), ekatab(2:260), pfatab(2:260),
4844  & pfrtab(2:260)
4845  COMMON / nucgeo / radtot, radiu1, radiu0, rad1o2, skindp, halodp,
4846  & alphal, omalhl, radskn, skneff, cparws, radpro,
4847  & radcor, radco2, radmax, bimptr, rimptr, ximptr,
4848  & yimptr, zimptr, rhoimt, ekfpro, pfrpro, rhocen,
4849  & rhocor, rhoskn, ekfcen(2), pfrcen(2), ekfbim,
4850  & pfrbim, rhoimp, ekfimp, pfrimp, rhoim2, ekfim2,
4851  & pfrim2, rhoim3, ekfim3, pfrim3, vprwll, rimpct,
4852  & bimpct, ximpct, yimpct, zimpct, rimpc2, ximpc2,
4853  & yimpc2, zimpc2, rimpc3, ximpc3, yimpc3, zimpc3,
4854  & xbimpc, ybimpc, zbimpc, cximpc, cyimpc, czimpc,
4855  & sqrimp, sigmap, sigman, sigmaa, rhored, r0traj,
4856  & r1traj, sbused, sbtot , sbres , rhoave, ekfave,
4857  & pfrave, avebin, acoll , zcoll , radsig, opacty,
4858  & ekecon, pnucco, ekewll, pprwll, pxproj, pyproj,
4859  & pzproj, ekferm, pnfrmi, pxferm, pyferm, pzferm,
4860  & ekfer2, pnfrm2, pxfer2, pyfer2, pzfer2, ekfer3,
4861  & pnfrm3, pxfer3, pyfer3, pzfer3, rhomem, ekfmem,
4862  & bimmem, wllred, vprbim, potinc, potout, eexmin
4863  COMMON / nucge2 / rdttnc(2), rhoncp(2), rhonc2(2), rhonc3(2),
4864  & rhonct(2), amothr, ekothr, amcrea, ekncln,
4865  & eexdel, eexany, clmbbr, rdclmb, bfclmb, bfceff,
4866  & bnproj, bndnuc, debrlm, sk4par, ubimpc, vbimpc,
4867  & wbimpc, bndpot, sigmat, sigabp, sigabn, wllres,
4868  & potbar, potmes, agepri, opnopa,
4869  & bnenrg(3), defnuc(2), sigmpr(4), sigmnu(4),
4870  & sigpab(3), signab(3), hhlp(2), fortot(2),
4871  & ipwell, itncmx, kprin , ntargt, knucim, knuci2,
4872  & knuci3, ievpre, isfcol, isftar, isfta2, isfta3,
4873  & npothr, icothr, ibothr, npumfn, istncl, itaucm,
4874  & iadflg, igsflg, ialflg, icbflg, lpreeq, lnphtc,
4875  & lpnrho, lnwrad
4876  COMMON / nucpwi / almbar, bimmax, siggeo, lllmax, lllact
4877  COMMON / nucgii / holexp(2*mxscin), xexpin(3,mxscin),
4878  & yexpin(3,mxscin), zexpin(3,mxscin),
4879  & agexin(mxscin), rhoexp(2), ekfexp, ehlfix,
4880  & nhlexp, nhlfix, iprtyp, nncexi(mxscin),
4881  & ncexpi(3,mxscin), isexin(3,mxscin),
4882  & isctyp(mxscin), nuscin, nexpem,
4883  & labrst, lelstc, linels, lchexc, labsrp, labsth
4884  dimension awstab(2:260), sigmab(3)
4885  equivalence( defpro, defnuc(1) )
4886  equivalence( defneu, defnuc(2) )
4887  equivalence( rhoipp, rhoncp(1) )
4888  equivalence( rhoinp, rhoncp(2) )
4889  equivalence( rhoip2, rhonc2(1) )
4890  equivalence( rhoin2, rhonc2(2) )
4891  equivalence( rhoip3, rhonc3(1) )
4892  equivalence( rhoin3, rhonc3(2) )
4893  equivalence( rhoipt, rhonct(1) )
4894  equivalence( rhoint, rhonct(2) )
4895  equivalence( omalhl, sk3par )
4896  equivalence( alphal, habpar )
4897  equivalence( alptab(2), awstab(2) )
4898  equivalence( sigmpe, sigmpr(1) )
4899  equivalence( sigmpc, sigmpr(2) )
4900  equivalence( sigmpi, sigmpr(3) )
4901  equivalence( sigmpa, sigmpr(4) )
4902  equivalence( sigmne, sigmnu(1) )
4903  equivalence( sigmnc, sigmnu(2) )
4904  equivalence( sigmni, sigmnu(3) )
4905  equivalence( sigmna, sigmnu(4) )
4906  equivalence( sigma2, sigpab(1) )
4907  equivalence( sigma3, sigpab(2) )
4908  equivalence( sigmas, sigpab(3) )
4909  equivalence( sigpab(1), sigmab(1) )
4910 C INCLUDE '(NUCLEV)'
4911 *$ CREATE NUCLEV.ADD
4912  LOGICAL lclvsl
4913  COMMON / nuclev / paenuc(200,2), shenuc(200,2), defrmi(2),
4914  & defmag(2), ennclv(160,2), ranclv(160,2),
4915  & cumrad(0:160,2), rusnuc(2),
4916  & enplvl(114), ennlvl(164), jusnuc(160,2),
4917  & ntanuc(2), navnuc(2), nlsnuc(2), nconuc(2),
4918  & nsknuc(2), nhanuc(2), nusnuc(2), jmxnuc(2),
4919  & iprnuc(3), jprnuc(3), magnum(8), magnuc(2),
4920  & mgsnuc(8,2), mgssnc(25,2), nsbshl(2),
4921  & nprnuc, inuclv, lclvsl
4922  dimension juspro(160), jusneu(160), mgspro(8), mgsneu(8),
4923  & mgsspr(19) , mgssne(25)
4924  equivalence( rusnuc(1), ruspro )
4925  equivalence( rusnuc(2), rusneu )
4926  equivalence( jusnuc(1,1), juspro(1) )
4927  equivalence( jusnuc(1,2), jusneu(1) )
4928  equivalence( mgsnuc(1,1), mgspro(1) )
4929  equivalence( mgsnuc(1,2), mgsneu(1) )
4930  equivalence( mgssnc(1,1), mgsspr(1) )
4931  equivalence( mgssnc(1,2), mgssne(1) )
4932  equivalence( ntanuc(1), ntapro )
4933  equivalence( ntanuc(2), ntaneu )
4934  equivalence( navnuc(1), navpro )
4935  equivalence( navnuc(2), navneu )
4936  equivalence( nlsnuc(1), nlspro )
4937  equivalence( nlsnuc(2), nlsneu )
4938  equivalence( nconuc(1), ncopro )
4939  equivalence( nconuc(2), nconeu )
4940  equivalence( nsknuc(1), nskpro )
4941  equivalence( nsknuc(2), nskneu )
4942  equivalence( nhanuc(1), nhapro )
4943  equivalence( nhanuc(2), nhaneu )
4944  equivalence( nusnuc(1), nuspro )
4945  equivalence( nusnuc(2), nusneu )
4946  equivalence( jmxnuc(1), jmxpro )
4947  equivalence( jmxnuc(2), jmxneu )
4948  equivalence( magnuc(1), magpro )
4949  equivalence( magnuc(2), magneu )
4950 C INCLUDE '(PAREVT)'
4951 *$ CREATE PAREVT.ADD
4952  parameter( frdiff = 0.2d+00 )
4953  parameter( ethsea = 1.0d+00 )
4954 
4955  LOGICAL ldiffr, linctv, levprt, lheavy, ldeexg, lgdhpr, lpreex,
4956  & lhlfix, lprfix, lparwv, lpower, lsngch, llvmod, lschdf
4957  COMMON / parevt / dpower, fsprd0, fshpfn, rn1gsc, rn2gsc,
4958  & ldiffr(nallwp),lpower, linctv, levprt, lheavy,
4959  & ldeexg, lgdhpr, lpreex, lhlfix, lprfix, lparwv,
4960  & ilvmod, jlvmod, llvmod, lsngch, lschdf
4961 C INCLUDE '(XSEPAR)'
4962 *$ CREATE XSEPAR.ADD
4963  COMMON / xsepar / aanxse(100), bbnxse(100), ccnxse(100),
4964  & ddnxse(100), eenxse(100), zznxse(100),
4965  & emnxse(100), xmnxse(100),
4966  & aapxse(100), bbpxse(100), ccpxse(100),
4967  & ddpxse(100), eepxse(100), ffpxse(100),
4968  & zzpxse(100), empxse(100), xmpxse(100)
4969 
4970 C---------------------------------------------------------------------
4971  nbertp=lunber
4972  WRITE( lunout,'(A,I2)')
4973  & ' *** Reading evaporation and nuclear data from unit: ', nbertp
4974  rewind nbertp
4975 C A. Ferrari: first of all read isotopic data
4976  READ (nbertp) isondx
4977  READ (nbertp) isomnm
4978  READ (nbertp) abuiso
4979  DO 1 i=1,4
4980 C READ (NBERTP) (CRSC(J,I),J=1,600)
4981 C A. Ferrari: commented also the dummy read to save disk space
4982 C READ (NBERTP)
4983  1 CONTINUE
4984 C READ (NBERTP) CS
4985 C A. Ferrari: commented also the dummy read to save disk space
4986 C READ (NBERTP)
4987 C---------------------------------------------------------------------
4988  READ (nbertp) (p0(i),p1(i),p2(i),i=1,1001)
4989  READ (nbertp) ia,iz
4990  DO 2 i=1,6
4991  fla(i)=ia(i)
4992  flz(i)=iz(i)
4993  2 CONTINUE
4994  READ (nbertp) rho,omega
4995  READ (nbertp) exmass
4996  READ (nbertp) cam2
4997  READ (nbertp) cam3
4998  READ (nbertp) cam4
4999  READ (nbertp) cam5
5000  READ (nbertp) ((t(i,j),j=1,7),i=1,3)
5001  DO 3 i=1,7
5002  t(4,i) = zerzer
5003  3 CONTINUE
5004  READ (nbertp) rmass
5005  READ (nbertp) alph
5006  READ (nbertp) bet
5007  READ (nbertp) inwaps
5008  READ (nbertp) waps
5009  READ (nbertp) t12nuc
5010  READ (nbertp) jspnuc
5011  READ (nbertp) jptnuc
5012  READ (nbertp) inwism
5013  READ (nbertp) izwism
5014  READ (nbertp) wapism
5015  READ (nbertp) t12ism
5016  READ (nbertp) jspism
5017  READ (nbertp) jptism
5018  READ (nbertp) aprime
5019  WRITE( lunout,'(A)' ) ' *** Evaporation: using 1977 Waps data ***'
5020  READ (nbertp) ahelp , bhelp , lrmsch, lrd1o2, ltrasp
5021  IF ( abs(ahelp-alpha0) .GT. csnnrm * alpha0 .OR.
5022  & abs(bhelp-gamsk0) .GT. csnnrm * gamsk0 ) THEN
5023  WRITE (lunout,*)
5024  & ' *** Inconsistent Nuclear Geometry data on file ***'
5025  stop
5026  END IF
5027  READ (nbertp) rhotab, rhatab, alptab, radtab, skitab, haltab,
5028  & ekatab, pfatab, pfrtab
5029  READ (nbertp) aanxse, bbnxse, ccnxse, ddnxse, eenxse, zznxse,
5030  & emnxse, xmnxse
5031  READ (nbertp) aapxse, bbpxse, ccpxse, ddpxse, eepxse, ffpxse,
5032  & zzpxse, empxse, xmpxse
5033 * Data about Fermi-breakup:
5034  READ (nbertp) iposst, mxpdum, mxadum, mxndum, mxzdum, ifbstf
5035  IF ( mxadum .NE. mxafbk .OR. mxndum .NE. mxnfbk .OR. mxzdum .NE.
5036  & mxzfbk .OR. mxpdum .NE. mxpsst ) THEN
5037  WRITE (lunout,*)' *** Inconsistent Fermi BreakUp data',
5038  & ' in the Nuclear Data file ***'
5039  stop 'STOP:BERTTP-INCONS-FERMI-BREAKUP-DATA'
5040  END IF
5041  READ (nbertp) ifrbkn
5042  READ (nbertp) ifrbkz
5043  READ (nbertp) ifbksp
5044  READ (nbertp) ifbkst
5045  READ (nbertp) eexfbk
5046  CLOSE (unit=nbertp)
5047  DO 100 jz = 1, 130
5048  shenuc( jz, 1 ) = emvgev * ( cam2(jz) + cam4(jz) )
5049  100 CONTINUE
5050  DO 200 ja = 1, 200
5051  shenuc( ja, 2 ) = emvgev * ( cam3(ja) + cam5(ja) )
5052  200 CONTINUE
5053  CALL stalin
5054  IF ( ilvmod .LE. 0 ) THEN
5055  ilvmod = ib0
5056  ELSE
5057  ib0 = ilvmod
5058  END IF
5059  IF ( llvmod ) THEN
5060  DO 300 jz = 1, izcook
5061  cam4(jz) = pzcook(jz)
5062  300 CONTINUE
5063  DO 400 jn = 1, incook
5064  cam5(jn) = pncook(jz)
5065  400 CONTINUE
5066  END IF
5067  WRITE (lunout,*)
5068  IF ( ilvmod .EQ. 1 ) THEN
5069  WRITE (lunout,*)
5070  &' **** Standard EVAP T=0 level density used ****'
5071  ELSE IF ( ilvmod .EQ. 2 ) THEN
5072  WRITE (lunout,*)
5073  &' **** Gilbert & Cameron T=0 N,Z-dep. level density used ****'
5074  ELSE IF ( ilvmod .EQ. 3 ) THEN
5075  WRITE (lunout,*)
5076  & ' **** Julich A-dependent level density used ****'
5077  ELSE IF ( ilvmod .EQ. 4 ) THEN
5078  WRITE (lunout,*)
5079  &' **** Brancazio & Cameron T=0 N,Z-dep. level density used ****'
5080  ELSE
5081  WRITE (lunout,*)
5082  &' **** Unknown T=0 level density option requested ****',ilvmod
5083  stop 'BERTTP-ILVMOD'
5084  END IF
5085  IF ( jlvmod .LE. 0 ) THEN
5086  gamign = zerzer
5087  WRITE (lunout,*)
5088  &' **** No Excitation en. dependence for level densities ****'
5089  ELSE IF ( jlvmod .EQ. 1 ) THEN
5090  WRITE (lunout,*)
5091  &' **** Ignyatuk (1975, 1st) level density en. dep. used ****'
5092  WRITE (lunout,*)
5093  &' **** with Ignyatuk (1975, 1st) set of parameters for T=oo ****'
5094  gamign = 0.054d+00
5095  betign = -6.3 d-05
5096  alpign = 0.154d+00
5097  powign = zerzer
5098  ELSE IF ( jlvmod .EQ. 2 ) THEN
5099  WRITE (lunout,*)
5100  &' **** Ignyatuk (1975, 1st) level density en. dep. used ****'
5101  WRITE (lunout,*)
5102  &' **** with UNKNOWN set of parameters for T=oo ****'
5103  stop 'BERTTP-JLVMOD'
5104  ELSE IF ( jlvmod .EQ. 3 ) THEN
5105  WRITE (lunout,*)
5106  &' **** Ignyatuk (1975, 1st) level density en. dep. used ****'
5107  WRITE (lunout,*)
5108  &' **** with UNKNOWN set of parameters for T=oo ****'
5109  stop 'BERTTP-JLVMOD'
5110  ELSE IF ( jlvmod .EQ. 4 ) THEN
5111  WRITE (lunout,*)
5112  &' **** Ignyatuk (1975, 2nd) level density en. dep. used ****'
5113  WRITE (lunout,*)
5114  &' **** with Ignyatuk (1975, 2nd) set of parameters for T=oo ****'
5115  gamign = 0.054d+00
5116  betign = 0.162d+00
5117  alpign = 0.114d+00
5118  powign = -onethi
5119  ELSE IF ( jlvmod .EQ. 5 ) THEN
5120  WRITE (lunout,*)
5121  &' **** Ignyatuk (1975, 2nd) level density en. dep. used ****'
5122  WRITE (lunout,*)
5123  &' **** with Iljinov & Mebel 1st set of parameters for T=oo ****'
5124  gamign = 0.051d+00
5125  betign = 0.098d+00
5126  alpign = 0.114d+00
5127  powign = -onethi
5128  ELSE IF ( jlvmod .EQ. 6 ) THEN
5129  WRITE (lunout,*)
5130  &' **** Ignyatuk (1975, 2nd) level density en. dep. used ****'
5131  WRITE (lunout,*)
5132  &' **** with Iljinov & Mebel 2nd set of parameters for T=oo ****'
5133  gamign = -0.46d+00
5134  betign = 0.107d+00
5135  alpign = 0.111d+00
5136  powign = -onethi
5137  ELSE IF ( jlvmod .EQ. 7 ) THEN
5138  WRITE (lunout,*)
5139  &' **** Ignyatuk (1975, 2nd) level density en. dep. used ****'
5140  WRITE (lunout,*)
5141  &' **** with Iljinov & Mebel 3rd set of parameters for T=oo ****'
5142  gamign = 0.059d+00
5143  betign = 0.257d+00
5144  alpign = 0.072d+00
5145  powign = -onethi
5146  ELSE IF ( jlvmod .EQ. 8 ) THEN
5147  WRITE (lunout,*)
5148  &' **** Ignyatuk (1975, 2nd) level density en. dep. used ****'
5149  WRITE (lunout,*)
5150  &' **** with Iljinov & Mebel 4th set of parameters for T=oo ****'
5151  gamign = -0.37d+00
5152  betign = 0.229d+00
5153  alpign = 0.077d+00
5154  powign = -onethi
5155  ELSE
5156  WRITE (lunout,*)
5157  &' **** Unknown T=oo level density option requested ****'
5158  stop 'BERTTP-JLVMOD'
5159  END IF
5160  IF ( llvmod ) THEN
5161  WRITE (lunout,*)
5162  & ' **** Cook''s modified pairing energy used ****'
5163  ELSE
5164  WRITE (lunout,*)
5165  & ' **** Original Gilbert/Cameron pairing energy used ****'
5166  END IF
5167  ilvmod = ib0
5168  DO 500 jz = 1, 130
5169  paenuc( jz, 1 ) = emvgev * cam4(jz)
5170  500 CONTINUE
5171  DO 600 ja = 1, 200
5172  paenuc( ja, 2 ) = emvgev * cam5(ja)
5173  600 CONTINUE
5174  RETURN
5175  END
5176 
5177 
5178 *$ CREATE INCINI.FOR
5179 *COPY INCINI
5180 * *
5181 *=== incini ===========================================================*
5182 * *
5183  SUBROUTINE incini
5184 
5185 C INCLUDE '(DBLPRC)'
5186 *$ CREATE DBLPRC.ADD
5187  IMPLICIT DOUBLE PRECISION (a-h,o-z)
5188  SAVE
5189  parameter( kalgnm = 2 )
5190  parameter( anglgb = 5.0d-16 )
5191  parameter( anglsq = 2.5d-31 )
5192  parameter( axcssv = 0.2d+16 )
5193  parameter( andrfl = 1.0d-38 )
5194  parameter( avrflw = 1.0d+38 )
5195  parameter( ainfnt = 1.0d+30 )
5196  parameter( azrzrz = 1.0d-30 )
5197  parameter( einfnt = +69.07755278982137 d+00 )
5198  parameter( ezrzrz = -69.07755278982137 d+00 )
5199  parameter( onemns = 0.999999999999999 d+00 )
5200  parameter( onepls = 1.000000000000001 d+00 )
5201  parameter( csnnrm = 2.0d-15 )
5202  parameter( dmxtrn = 1.0d+08 )
5203  parameter( zerzer = 0.d+00 )
5204  parameter( oneone = 1.d+00 )
5205  parameter( twotwo = 2.d+00 )
5206  parameter( thrthr = 3.d+00 )
5207  parameter( foufou = 4.d+00 )
5208  parameter( fivfiv = 5.d+00 )
5209  parameter( sixsix = 6.d+00 )
5210  parameter( sevsev = 7.d+00 )
5211  parameter( eigeig = 8.d+00 )
5212  parameter( aninen = 9.d+00 )
5213  parameter( tenten = 10.d+00 )
5214  parameter( hlfhlf = 0.5d+00 )
5215  parameter( onethi = oneone / thrthr )
5216  parameter( twothi = twotwo / thrthr )
5217  parameter( onefou = oneone / foufou )
5218  parameter( thrtwo = thrthr / twotwo )
5219  parameter( pipipi = 3.141592653589793238462643383279d+00 )
5220  parameter( twopip = 6.283185307179586476925286766559d+00 )
5221  parameter( pip5o2 = 7.853981633974483096156608458199d+00 )
5222  parameter( pipisq = 9.869604401089358618834490999876d+00 )
5223  parameter( pihalf = 1.570796326794896619231321691640d+00 )
5224  parameter( erfa00 = 0.886226925452758013649083741671d+00 )
5225  parameter( eneper = 2.718281828459045235360287471353d+00 )
5226  parameter( sqrent = 1.648721270700128146848650787814d+00 )
5227  parameter( sqrsix = 2.449489742783178098197284074706d+00 )
5228  parameter( sqrsev = 2.645751311064590590501615753639d+00 )
5229  parameter( sqrt12 = 3.464101615137754587054892683012d+00 )
5230  parameter( clight = 2.99792458 d+10 )
5231  parameter( avogad = 6.0221367 d+23 )
5232  parameter( boltzm = 1.380658 d-23 )
5233  parameter( amelgr = 9.1093897 d-28 )
5234  parameter( plckbr = 1.05457266 d-27 )
5235  parameter( elccgs = 4.8032068 d-10 )
5236  parameter( elcmks = 1.60217733 d-19 )
5237  parameter( amugrm = 1.6605402 d-24 )
5238  parameter( ammumu = 0.113428913 d+00 )
5239  parameter( amprmu = 1.007276470 d+00 )
5240  parameter( amnemu = 1.008664904 d+00 )
5241  parameter( alpfsc = 7.2973530791728595 d-03 )
5242  parameter( fscto2 = 5.3251361962113614 d-05 )
5243  parameter( fscto3 = 3.8859399018437826 d-07 )
5244  parameter( fscto4 = 2.8357075508200407 d-09 )
5245  parameter( plabrc = 0.197327053 d+00 )
5246  parameter( amelct = 0.51099906 d-03 )
5247  parameter( amugev = 0.93149432 d+00 )
5248  parameter( ammuon = 0.105658389 d+00 )
5249  parameter( amprtn = 0.93827231 d+00 )
5250  parameter( amntrn = 0.93956563 d+00 )
5251  parameter( amdeut = 1.87561339 d+00 )
5252  parameter( cougfm = elccgs * elccgs / elcmks * 1.d-07 * 1.d+13
5253  & * 1.d-09 )
5254  parameter( rclsel = 2.8179409183694872 d-13 )
5255  parameter( bltzmn = 8.617385 d-14 )
5256  parameter( gevmev = 1.0 d+03 )
5257  parameter( emvgev = 1.0 d-03 )
5258  parameter( algvmv = 6.90775527898214 d+00 )
5259  parameter( raddeg = 180.d+00 / pipipi )
5260  parameter( degrad = pipipi / 180.d+00 )
5261  LOGICAL lgbias, lgbana
5262  COMMON / global / lgbias, lgbana
5263 C INCLUDE '(DIMPAR)'
5264 *$ CREATE DIMPAR.ADD
5265  parameter( mxxrgn = 5000 )
5266  parameter( mxxmdf = 56 )
5267  parameter( mxxmde = 50 )
5268  parameter( mfstck = 1000 )
5269  parameter( mestck = 100 )
5270  parameter( nallwp = 39 )
5271  parameter( mpdpdx = 8 )
5272  parameter( icomax = 180 )
5273  parameter( nstbis = 304 )
5274  parameter( idmaxp = 210 )
5275  parameter( idmxdc = 620 )
5276  parameter( mkbmx1 = 1 )
5277  parameter( mkbmx2 = 1 )
5278 C INCLUDE '(IOUNIT)'
5279 *$ CREATE IOUNIT.ADD
5280  parameter( lunin = 5 )
5281  parameter( lunout = 6 )
5282  parameter( lunerr = 15 )
5283  parameter( lunber = 14 )
5284  parameter( lunech = 8 )
5285  parameter( lunflu = 13 )
5286  parameter( lungeo = 16 )
5287  parameter( lunpgs = 12 )
5288  parameter( lunran = 2 )
5289  parameter( lunxsc = 9 )
5290  parameter( lundet = 17 )
5291  parameter( lunray = 10 )
5292  parameter( lunrdb = 1 )
5293 *
5294 *----------------------------------------------------------------------*
5295 * *
5296 * Created on 10 june 1990 by Alfredo Ferrari & Paola Sala *
5297 * Infn - Milan *
5298 * *
5299 * Last change on 02-may-95 by Alfredo Ferrari *
5300 * *
5301 * *
5302 *----------------------------------------------------------------------*
5303 *
5304 C INCLUDE '(FHEAVY)'
5305 *$ CREATE FHEAVY.ADD
5306  parameter( mxheav = 100 )
5307  CHARACTER*8 anheav
5308  COMMON / fheavy / cxheav(mxheav), cyheav(mxheav),
5309  & czheav(mxheav), tkheav(mxheav),
5310  & pheavy(mxheav), wheavy(mxheav),
5311  & amheav( 12 ) , amnhea( 12 ) ,
5312  & kheavy(mxheav), icheav( 12 ) ,
5313  & ibheav( 12 ) , npheav
5314  COMMON / fheavc / anheav( 12 )
5315 C INCLUDE '(INPFLG)'
5316 *$ CREATE INPFLG.ADD
5317  COMMON /inpflg/ iang,ifiss,ib0,igeom,istrag,keydk
5318 C INCLUDE '(FRBKCM)'
5319 *$ CREATE FRBKCM.ADD
5320  parameter( mxffbk = 6 )
5321  parameter( mxzfbk = 9 )
5322  parameter( mxnfbk = 10 )
5323  parameter( mxafbk = 16 )
5324  parameter( nxzfbk = mxzfbk + mxffbk / 3 )
5325  parameter( nxnfbk = mxnfbk + mxffbk / 3 )
5326  parameter( nxafbk = mxafbk + 1 )
5327  parameter( mxpsst = 300 )
5328  parameter( mxpsfb = 41000 )
5329  LOGICAL lfrmbk, lncmss
5330  COMMON / frbkcm / amufbk, eexfbk(mxpsst), amfrbk(mxpsst),
5331  & exfrbk(mxpsfb), sdmfbk(mxpsfb), coufbk(mxpsfb),
5332  & exmxfb, r0frbk, r0cfbk, c1cfbk, c2cfbk,
5333  & ifrbkn(mxpsst), ifrbkz(mxpsst),
5334  & ifbksp(mxpsst), ifbkpr(mxpsst), ifbkst(mxpsst),
5335  & ipsind(0:mxnfbk,0:mxzfbk,2), jpsind(0:mxafbk),
5336  & ifbind(0:nxnfbk,0:nxzfbk,2), jfbind(0:nxafbk),
5337  & ifbcha(5,mxpsfb), iposst, iposfb, ifbstf,
5338  & ifbfrb, nbufbk, lfrmbk, lncmss
5339 C INCLUDE '(NUCDAT)'
5340 *$ CREATE NUCDAT.ADD
5341  parameter( amuamu = amugev )
5342  parameter( amprot = amprtn )
5343  parameter( amneut = amntrn )
5344  parameter( amelec = amelct )
5345  parameter( r0nucl = 1.12 d+00 )
5346  parameter( rccoul = 1.7 d+00 )
5347  parameter( coulpr = cougfm )
5348  parameter( fertho = 14.33 d-09 )
5349  parameter( expebn = 2.39 d+00 )
5350  parameter( bexc12 = fertho * 72.40715579499394d+00 )
5351  parameter( amuc12 = amugev - hlfhlf * amelct + bexc12 / 12.d+00 )
5352  parameter( amhydr = amprtn + amelct )
5353  parameter( amhton = amhydr - amntrn )
5354  parameter( amntou = amntrn - amuc12 )
5355  parameter( amucsq = amuc12 * amuc12 )
5356  parameter( ebndav = hlfhlf * (amprtn + amntrn) - amuc12 )
5357  parameter( gammin = 1.0d-06 )
5358  parameter( gamnsq = 2.0d+00 * gammin * gammin )
5359  parameter( tvepsi = gammin / 100.d+00 )
5360  COMMON /nucdat/ av0wel, apfrmx, aefrmx, aefrma,
5361  & rdsnuc, v0well(2), pfrmmx(2), efrmmx(2),
5362  & efrmav(2), amnucl(2), amnusq(2), ebndng(2),
5363  & veffnu(2), eslope(2), pkmnnu(2), ekmnnu(2),
5364  & pkmxnu(2), ekmxnu(2), ekmnav(2), ekinav(2),
5365  & exmnav(2), ekupnu(2), exmnnu(2), exupnu(2),
5366  & erclav(2), eswell(2), fincup(2), amrcav ,
5367  & amrcsq , ato1o3 , zto1o3 , elbnde(0:100)
5368 C INCLUDE '(PAREVT)'
5369 *$ CREATE PAREVT.ADD
5370  parameter( frdiff = 0.2d+00 )
5371  parameter( ethsea = 1.0d+00 )
5372 
5373  LOGICAL ldiffr, linctv, levprt, lheavy, ldeexg, lgdhpr, lpreex,
5374  & lhlfix, lprfix, lparwv, lpower, lsngch, llvmod, lschdf
5375  COMMON / parevt / dpower, fsprd0, fshpfn, rn1gsc, rn2gsc,
5376  & ldiffr(nallwp),lpower, linctv, levprt, lheavy,
5377  & ldeexg, lgdhpr, lpreex, lhlfix, lprfix, lparwv,
5378  & ilvmod, jlvmod, llvmod, lsngch, lschdf
5379  COMMON / nucold / help(2), hhlp(2), ftvth(2), fincx(2),
5380  & ekpold(2), bbold, zzold, sqrold, aseasq,
5381  & fspred, fex0rd
5382 *
5383  bbold = - 1.d+10
5384  zzold = - 1.d+10
5385  sqrold = - 1.d+10
5386  apfrmx = plabrc * ( aninen * pipipi / eigeig )**onethi / r0nucl
5387  amnucl(1) = amprot
5388  amnucl(2) = amneut
5389  amnusq(1) = amprot * amprot
5390  amnusq(2) = amneut * amneut
5391  amnhlp = hlfhlf * ( amnucl(1) + amnucl(2) )
5392  asqhlp = amnhlp**2
5393 * ASQHLP = HLFHLF * ( AMNUSQ (1) + AMNUSQ (2) )
5394  aefrmx = sqrt( asqhlp + apfrmx**2 ) - amnhlp
5395  aefrma = 0.3d+00 * apfrmx**2 / amnhlp * ( oneone - apfrmx**2 /
5396  & ( 5.6d+00 * asqhlp ) )
5397  av0wel = aefrmx + ebndav
5398  ebndng(1) = ebndav
5399  ebndng(2) = ebndav
5400  aexc12 = emvgev * energy( 12.d+00, 6.d+00 )
5401  cexc12 = emvgev * enrg( 12.d+00, 6.d+00 )
5402  ammc12 = 12.d+00 * amugev + aexc12
5403  amnc12 = ammc12 - 6.d+00 * amelct + fertho * 6.d+00**expebn
5404  aexo16 = emvgev * energy( 16.d+00, 8.d+00 )
5405  cexo16 = emvgev * enrg( 16.d+00, 8.d+00 )
5406  ammo16 = 16.d+00 * amugev + aexo16
5407  amno16 = ammo16 - 8.d+00 * amelct + fertho * 8.d+00**expebn
5408  aexs28 = emvgev * energy( 28.d+00, 14.d+00 )
5409  cexs28 = emvgev * enrg( 28.d+00, 14.d+00 )
5410  amms28 = 28.d+00 * amugev + aexs28
5411  amns28 = amms28 - 14.d+00 * amelct + fertho * 14.d+00**expebn
5412  aexc40 = emvgev * energy( 40.d+00, 20.d+00 )
5413  cexc40 = emvgev * enrg( 40.d+00, 20.d+00 )
5414  ammc40 = 40.d+00 * amugev + aexc40
5415  amnc40 = ammc40 - 20.d+00 * amelct + fertho * 20.d+00**expebn
5416  aexf56 = emvgev * energy( 56.d+00, 26.d+00 )
5417  cexf56 = emvgev * enrg( 56.d+00, 26.d+00 )
5418  ammf56 = 56.d+00 * amugev + aexf56
5419  amnf56 = ammf56 - 26.d+00 * amelct + fertho * 26.d+00**expebn
5420  aex107 = emvgev * energy( 107.d+00, 47.d+00 )
5421  cex107 = emvgev * enrg( 107.d+00, 47.d+00 )
5422  amm107 = 107.d+00 * amugev + aex107
5423  amn107 = amm107 - 47.d+00 * amelct + fertho * 47.d+00**expebn
5424  aex132 = emvgev * energy( 132.d+00, 54.d+00 )
5425  cex132 = emvgev * enrg( 132.d+00, 54.d+00 )
5426  amm132 = 132.d+00 * amugev + aex132
5427  amn132 = amm132 - 54.d+00 * amelct + fertho * 54.d+00**expebn
5428  aex181 = emvgev * energy( 181.d+00, 73.d+00 )
5429  cex181 = emvgev * enrg( 181.d+00, 73.d+00 )
5430  amm181 = 181.d+00 * amugev + aex181
5431  amn181 = amm181 - 73.d+00 * amelct + fertho * 73.d+00**expebn
5432  aex208 = emvgev * energy( 208.d+00, 82.d+00 )
5433  cex208 = emvgev * enrg( 208.d+00, 82.d+00 )
5434  amm208 = 208.d+00 * amugev + aex208
5435  amn208 = amm208 - 82.d+00 * amelct + fertho * 82.d+00**expebn
5436  aex238 = emvgev * energy( 238.d+00, 92.d+00 )
5437  cex238 = emvgev * enrg( 238.d+00, 92.d+00 )
5438  amm238 = 238.d+00 * amugev + aex238
5439  amn238 = amm238 - 92.d+00 * amelct + fertho * 92.d+00**expebn
5440  WRITE ( lunout,* )
5441  WRITE ( lunout,* )
5442  WRITE ( lunout,* )' **** Maximum Fermi momentum : ',sngl(apfrmx),
5443  & ' GeV/c ****'
5444  WRITE ( lunout,* )
5445  WRITE ( lunout,* )' **** Maximum Fermi energy : ',sngl(aefrmx),
5446  & ' GeV ****'
5447  WRITE ( lunout,* )
5448  WRITE ( lunout,* )' **** Average Fermi energy : ',sngl(aefrma),
5449  & ' GeV ****'
5450  WRITE ( lunout,* )
5451  WRITE ( lunout,* )' **** Average binding energy : ',sngl(ebndav),
5452  & ' GeV ****'
5453  WRITE ( lunout,* )
5454  WRITE ( lunout,* )' **** Nuclear well depth : ',sngl(av0wel),
5455  & ' GeV ****'
5456  WRITE ( lunout,* )
5457  WRITE ( lunout,* )' **** Excess mass for 12-C : ',sngl(aexc12),
5458  & ' GeV ****'
5459  WRITE ( lunout,* )
5460  WRITE ( lunout,* )' **** Cameron E. m. for 12-C : ',sngl(cexc12),
5461  & ' GeV ****'
5462  WRITE ( lunout,* )
5463  WRITE ( lunout,* )' **** Atomic mass for 12-C : ',sngl(ammc12),
5464  & ' GeV ****'
5465  WRITE ( lunout,* )
5466  WRITE ( lunout,* )' **** Nuclear mass for 12-C : ',sngl(amnc12),
5467  & ' GeV ****'
5468  WRITE ( lunout,* )
5469  WRITE ( lunout,* )' **** Excess mass for 16-O : ',sngl(aexo16),
5470  & ' GeV ****'
5471  WRITE ( lunout,* )
5472  WRITE ( lunout,* )' **** Cameron E. m. for 16-O : ',sngl(cexo16),
5473  & ' GeV ****'
5474  WRITE ( lunout,* )
5475  WRITE ( lunout,* )' **** Atomic mass for 16-O : ',sngl(ammo16),
5476  & ' GeV ****'
5477  WRITE ( lunout,* )
5478  WRITE ( lunout,* )' **** Nuclear mass for 16-O : ',sngl(amno16),
5479  & ' GeV ****'
5480  WRITE ( lunout,* )
5481  WRITE ( lunout,* )' **** Excess mass for 40-Ca : ',sngl(aexc40),
5482  & ' GeV ****'
5483  WRITE ( lunout,* )
5484  WRITE ( lunout,* )' **** Cameron E. m. for 40-Ca : ',sngl(cexc40),
5485  & ' GeV ****'
5486  WRITE ( lunout,* )
5487  WRITE ( lunout,* )' **** Atomic mass for 40-Ca : ',sngl(ammc40),
5488  & ' GeV ****'
5489  WRITE ( lunout,* )
5490  WRITE ( lunout,* )' **** Nuclear mass for 40-Ca : ',sngl(amnc40),
5491  & ' GeV ****'
5492  WRITE ( lunout,* )
5493  WRITE ( lunout,* )' **** Excess mass for 56-Fe : ',sngl(aexf56),
5494  & ' GeV ****'
5495  WRITE ( lunout,* )
5496  WRITE ( lunout,* )' **** Cameron E. m. for 56-Fe : ',sngl(cexf56),
5497  & ' GeV ****'
5498  WRITE ( lunout,* )
5499  WRITE ( lunout,* )' **** Atomic mass for 56-Fe : ',sngl(ammf56),
5500  & ' GeV ****'
5501  WRITE ( lunout,* )
5502  WRITE ( lunout,* )' **** Nuclear mass for 56-Fe : ',sngl(amnf56),
5503  & ' GeV ****'
5504  WRITE ( lunout,* )
5505  WRITE ( lunout,* )' **** Excess mass for 107-Ag: ',sngl(aex107),
5506  & ' GeV ****'
5507  WRITE ( lunout,* )
5508  WRITE ( lunout,* )' **** Cameron E. m. for 107-Ag: ',sngl(cex107),
5509  & ' GeV ****'
5510  WRITE ( lunout,* )
5511  WRITE ( lunout,* )' **** Atomic mass for 107-Ag: ',sngl(amm107),
5512  & ' GeV ****'
5513  WRITE ( lunout,* )
5514  WRITE ( lunout,* )' **** Nuclear mass for 107-Ag: ',sngl(amn107),
5515  & ' GeV ****'
5516  WRITE ( lunout,* )
5517  WRITE ( lunout,* )' **** Excess mass for 132-Xe: ',sngl(aex132),
5518  & ' GeV ****'
5519  WRITE ( lunout,* )
5520  WRITE ( lunout,* )' **** Cameron E. m. for 132-Xe: ',sngl(cex132),
5521  & ' GeV ****'
5522  WRITE ( lunout,* )
5523  WRITE ( lunout,* )' **** Atomic mass for 132-Xe: ',sngl(amm132),
5524  & ' GeV ****'
5525  WRITE ( lunout,* )
5526  WRITE ( lunout,* )' **** Nuclear mass for 132-Xe: ',sngl(amn132),
5527  & ' GeV ****'
5528  WRITE ( lunout,* )
5529  WRITE ( lunout,* )' **** Excess mass for 181-Ta: ',sngl(aex181),
5530  & ' GeV ****'
5531  WRITE ( lunout,* )
5532  WRITE ( lunout,* )' **** Cameron E. m. for 181-Ta: ',sngl(cex181),
5533  & ' GeV ****'
5534  WRITE ( lunout,* )
5535  WRITE ( lunout,* )' **** Atomic mass for 181-Ta: ',sngl(amm181),
5536  & ' GeV ****'
5537  WRITE ( lunout,* )
5538  WRITE ( lunout,* )' **** Nuclear mass for 181-Ta: ',sngl(amn181),
5539  & ' GeV ****'
5540  WRITE ( lunout,* )
5541  WRITE ( lunout,* )' **** Excess mass for 208-Pb: ',sngl(aex208),
5542  & ' GeV ****'
5543  WRITE ( lunout,* )
5544  WRITE ( lunout,* )' **** Cameron E. m. for 208-Pb: ',sngl(cex208),
5545  & ' GeV ****'
5546  WRITE ( lunout,* )
5547  WRITE ( lunout,* )' **** Atomic mass for 208-Pb: ',sngl(amm208),
5548  & ' GeV ****'
5549  WRITE ( lunout,* )
5550  WRITE ( lunout,* )' **** Nuclear mass for 208-Pb: ',sngl(amn208),
5551  & ' GeV ****'
5552  WRITE ( lunout,* )
5553  WRITE ( lunout,* )' **** Excess mass for 238-U : ',sngl(aex238),
5554  & ' GeV ****'
5555  WRITE ( lunout,* )
5556  WRITE ( lunout,* )' **** Cameron E. m. for 238-U : ',sngl(cex238),
5557  & ' GeV ****'
5558  WRITE ( lunout,* )
5559  WRITE ( lunout,* )' **** Atomic mass for 238-U : ',sngl(amm238),
5560  & ' GeV ****'
5561  WRITE ( lunout,* )
5562  WRITE ( lunout,* )' **** Nuclear mass for 238-U : ',sngl(amn238),
5563  & ' GeV ****'
5564  WRITE ( lunout,* )
5565  amheav(1) = amugev + emvgev * energy( oneone, zerzer )
5566  amheav(2) = amugev + emvgev * energy( oneone, oneone )
5567  amheav(3) = twotwo * amugev + emvgev * energy( twotwo, oneone )
5568  amheav(4) = thrthr * amugev + emvgev * energy( thrthr, oneone )
5569  amheav(5) = thrthr * amugev + emvgev * energy( thrthr, twotwo )
5570  amheav(6) = foufou * amugev + emvgev * energy( foufou, twotwo )
5571  elbnde(0) = zerzer
5572  elbnde(1) = 13.6d-09
5573  DO 2000 iz = 2, 100
5574  elbnde( iz ) = fertho * dble( iz )**expebn
5575 2000 CONTINUE
5576  amnhea(1) = amheav(1) + elbnde(0)
5577  amnhea(2) = amheav(2) - amelct + elbnde(1)
5578  amnhea(3) = amheav(3) - amelct + elbnde(1)
5579  amnhea(4) = amheav(4) - amelct + elbnde(1)
5580  amnhea(5) = amheav(5) - twotwo * amelct + elbnde(2)
5581  amnhea(6) = amheav(6) - twotwo * amelct + elbnde(2)
5582  IF ( levprt ) THEN
5583  WRITE ( lunout, * )' **** Evaporation from residual nucleus',
5584  & ' activated **** '
5585  IF ( ldeexg ) WRITE ( lunout, * )' **** Deexcitation gamma',
5586  & ' production activated **** '
5587  IF ( lheavy ) WRITE ( lunout, * )' **** Evaporated "heavies"',
5588  & ' transport activated **** '
5589  IF ( ifiss .GT. 0 )
5590  & WRITE ( lunout, * )' **** High Energy fission ',
5591  & ' requested & activated **** '
5592  IF ( lfrmbk )
5593  & WRITE ( lunout, * )' **** Fermi Break Up ',
5594  & ' requested & activated **** '
5595  IF ( lfrmbk ) CALL frbkin(.false.,.false.)
5596  ELSE
5597  ldeexg = .false.
5598  lheavy = .false.
5599  lfrmbk = .false.
5600  ifiss = 0
5601  END IF
5602  RETURN
5603 *=== End of subroutine incini =========================================*
5604  END
5605 *
5606 *===decay==============================================================*
5607 *
5608  SUBROUTINE decays(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
5609 
5610 ************************************************************************
5611 * Resonance-decay. *
5612 * This subroutine replaces DDECAY/DECHKK. *
5613 * PIN(4) 4-momentum of resonance (input) *
5614 * IDXIN BAMJET-index of resonance (input) *
5615 * POUT(20,4) 4-momenta of decay-products (output) *
5616 * IDXOUT(20) BAMJET-indices of decay-products (output) *
5617 * NSEC number of secondaries (output) *
5618 * Adopted from the original version DECHKK. *
5619 * This version dated 09.01.95 is written by S. Roesler *
5620 ************************************************************************
5621 
5622  IMPLICIT DOUBLE PRECISION (a-h,o-z)
5623  SAVE
5624  parameter(lout=6,llook=9)
5625  parameter(tiny17=1.0d-17)
5626 
5627  parameter(idmax9=602)
5628  CHARACTER*8 aname,zkname
5629  COMMON /ddecac/ zkname(idmax9),wt(idmax9),nzk(idmax9,3)
5630  COMMON /dpar/ aname(210),aam(210),ga(210),tau(210),
5631  & iich(210),iibar(210),k1(210),k2(210)
5632 
5633  LOGICAL lemcck,lhadro,lseadi
5634  COMMON /flags/ ifrag(2),iresco,imshl,iresrj,
5635  & lemcck,lhadro(0:9),lseadi
5636 
5637 * ISTAB = 1 strong and weak decays
5638 * = 2 strong decays only
5639 * = 3 strong decays, weak decays for charmed particles and tau
5640 * leptons only
5641  DATA istab /2/
5642 
5643  dimension pin(4),pi(20,4),pout(20,4),idxout(20),
5644  & ef(3),pf(3),pff(3),idxstk(20),idx(3),
5645  & codf(3),coff(3),siff(3),dcos(3),dcosf(3)
5646 
5647  irej = 0
5648  nsec = 0
5649 * put initial resonance to stack
5650  nstk = 1
5651  idxstk(nstk) = idxin
5652  DO 5 i=1,4
5653  pi(nstk,i) = pin(i)
5654  5 CONTINUE
5655 
5656 * store initial configuration for energy-momentum cons. check
5657  IF (lemcck) CALL evtemc(pi(nstk,1),pi(nstk,2),pi(nstk,3),
5658  & pi(nstk,4),1,idum,idum)
5659 
5660  100 CONTINUE
5661 * get particle from stack
5662  idxi = idxstk(nstk)
5663 * skip stable particles
5664  IF (istab.EQ.1) THEN
5665  IF ((idxi.EQ.135).OR. (idxi.EQ.136)) goto 10
5666  IF ((idxi.GE. 1).AND.(idxi.LE. 7)) goto 10
5667  ELSEIF (istab.EQ.2) THEN
5668  IF ((idxi.GE. 1).AND.(idxi.LE. 30)) goto 10
5669  IF ((idxi.GE. 97).AND.(idxi.LE.103)) goto 10
5670  IF ((idxi.GE.115).AND.(idxi.LE.122)) goto 10
5671  IF ((idxi.GE.131).AND.(idxi.LE.136)) goto 10
5672  IF ( idxi.EQ.109) goto 10
5673  IF ((idxi.GE.137).AND.(idxi.LE.160)) goto 10
5674  ELSEIF (istab.EQ.3) THEN
5675  IF ((idxi.GE. 1).AND.(idxi.LE. 23)) goto 10
5676  IF ((idxi.GE. 97).AND.(idxi.LE.103)) goto 10
5677  IF ((idxi.GE.109).AND.(idxi.LE.115)) goto 10
5678  IF ((idxi.GE.133).AND.(idxi.LE.136)) goto 10
5679  ENDIF
5680 
5681 * calculate direction cosines and Lorentz-parameter of decaying part.
5682  ptot = sqrt(pi(nstk,1)**2+pi(nstk,2)**2+pi(nstk,3)**2)
5683  ptot = max(ptot,tiny17)
5684  DO 1 i=1,3
5685  dcos(i) = pi(nstk,i)/ptot
5686  1 CONTINUE
5687  gam = pi(nstk,4)/aam(idxi)
5688  bgam = ptot/aam(idxi)
5689 
5690 * get decay-channel
5691  kchan = k1(idxi)-1
5692  2 CONTINUE
5693  kchan = kchan+1
5694  IF ((rndm(v)-tiny17).GT.wt(kchan)) goto 2
5695 
5696 * identities of secondaries
5697  idx(1) = nzk(kchan,1)
5698  idx(2) = nzk(kchan,2)
5699  IF (idx(2).LT.1) goto 9999
5700  idx(3) = nzk(kchan,3)
5701 
5702 * handle decay in rest system of decaying particle
5703  IF (idx(3).EQ.0) THEN
5704 * two-particle decay
5705  ndec = 2
5706  CALL dtwopd(aam(idxi),ef(1),ef(2),pf(1),pf(2),
5707  & codf(1),coff(1),siff(1),codf(2),coff(2),siff(2),
5708  & aam(idx(1)),aam(idx(2)))
5709  ELSE
5710 * three-particle decay
5711  ndec = 3
5712  CALL dthrep(aam(idxi),ef(1),ef(2),ef(3),pf(1),pf(2),pf(3),
5713  & codf(1),coff(1),siff(1),codf(2),coff(2),siff(2),
5714  & codf(3),coff(3),siff(3),
5715  & aam(idx(1)),aam(idx(2)),aam(idx(3)))
5716  ENDIF
5717  nstk = nstk-1
5718 
5719 * transform decay products back
5720  DO 3 i=1,ndec
5721  nstk = nstk+1
5722  CALL dtrafo(gam,bgam,dcos(1),dcos(2),dcos(3),
5723  & codf(i),coff(i),siff(i),pf(i),ef(i),
5724  & pff(i),dcosf(1),dcosf(2),dcosf(3),pi(nstk,4))
5725 * add particle to stack
5726  idxstk(nstk) = idx(i)
5727  DO 4 j=1,3
5728  pi(nstk,j) = dcosf(j)*pff(i)
5729  4 CONTINUE
5730  3 CONTINUE
5731  goto 100
5732 
5733  10 CONTINUE
5734 * stable particle, put to output-arrays
5735  nsec = nsec+1
5736  DO 6 i=1,4
5737  pout(nsec,i) = pi(nstk,i)
5738  6 CONTINUE
5739  idxout(nsec) = idxstk(nstk)
5740 * store secondaries for energy-momentum conservation check
5741  IF (lemcck)
5742  &CALL evtemc(-pout(nsec,1),-pout(nsec,2),-pout(nsec,3),
5743  & -pout(nsec,4),2,idum,idum)
5744  nstk = nstk-1
5745  IF (nstk.GT.0) goto 100
5746 
5747 * check energy-momentum conservation
5748  IF (lemcck) THEN
5749  CALL evtemc(dum,dum,dum,dum,3,5,irej1)
5750  IF (irej1.NE.0) goto 9999
5751  ENDIF
5752 
5753  RETURN
5754 
5755  9999 CONTINUE
5756  irej = 1
5757  RETURN
5758  END
5759 *
5760 *===decay1=============================================================*
5761 *
5762  SUBROUTINE decay1
5763 
5764 ************************************************************************
5765 * Decay of resonances stored in HKKEVT. *
5766 * This version dated 19.11.95 is written by S. Roesler *
5767 ************************************************************************
5768 
5769  IMPLICIT DOUBLE PRECISION (a-h,o-z)
5770  SAVE
5771  parameter(lout=6,llook=9)
5772 
5773  parameter(nmxhkk=89998)
5774  COMMON /hkkevt/ nhkk,nevhkk,isthkk(nmxhkk),idhkk(nmxhkk),
5775  & jmohkk(2,nmxhkk),jdahkk(2,nmxhkk),
5776  & phkk(5,nmxhkk),vhkk(4,nmxhkk),whkk(4,nmxhkk)
5777  COMMON /extevt/ idres(nmxhkk),idxres(nmxhkk),nobam(nmxhkk),
5778  & idbam(nmxhkk),idch(nmxhkk),npoint(10)
5779 
5780  dimension pin(4),pout(10,4),idxout(10)
5781 
5782  nend = nhkk
5783 C DO 1 I=NPOINT(5),NEND
5784 CCC DO 1 I=NPOINT(4),NEND
5785  n123=npoint(4)
5786  DO 1 i=n123,nend
5787 C write(67,*)i,n123,nend
5788  i123=isthkk(i)
5789  i124=abs(i123)
5790 C write(67,*)i,i123,i124,n123,nend
5791 
5792 CCC IF (ABS(ISTHKK(I)).EQ.1) THEN
5793  IF (i124.EQ.1) THEN
5794  DO 2 k=1,4
5795  pin(k) = phkk(k,i)
5796  2 CONTINUE
5797  idxin = idbam(i)
5798  CALL decays(pin,idxin,pout,idxout,nsec,irej)
5799  IF (nsec.GT.1) THEN
5800  DO 3 n=1,nsec
5801  idhad = ipdgha(idxout(n))
5802  CALL evtput(1,idhad,i,0,pout(n,1),pout(n,2),
5803  & pout(n,3),pout(n,4),0,0,0)
5804  3 CONTINUE
5805  ENDIF
5806  ENDIF
5807  1 CONTINUE
5808 
5809  RETURN
5810  END
5811  FUNCTION icihad(MCIND)
5812  icihad=mcihad(mcind)
5813  RETURN
5814  END
5815  FUNCTION ipdgha(MCIND)
5816  ipdgha=mpdgha(mcind)
5817  RETURN
5818  END
5819 *
5820 *===sihnab===============================================================*
5821 *
5822  SUBROUTINE sihnab(IDP,IDT,PLAB,SIGABS)
5823 
5824 **********************************************************************
5825 * Pion 2-nucleon absorption cross sections. *
5826 * (sigma_tot for pi+ d --> p p, pi- d --> n n *
5827 * taken from Ritchie PRC 28 (1983) 926 ) *
5828 * This version dated 18.05.96 is written by S. Roesler *
5829 **********************************************************************
5830 
5831  IMPLICIT DOUBLE PRECISION (a-h,o-z)
5832  SAVE
5833  parameter(zero=0.0d0,one=1.0d0,two=2.0d0,tiny3=1.0d-3)
5834  parameter(ampr = 938.0d0,
5835  & ampi = 140.0d0,
5836  & amde = two*ampr,
5837  & a = -1.2d0,
5838  & b = 3.5d0,
5839  & c = 7.4d0,
5840  & d = 5600.0d0,
5841  & er = 2136.0d0)
5842 
5843  sigabs = zero
5844  IF (((idp.NE.13).AND.(idp.NE.14).AND.(idp.NE.23))
5845  & .OR.((idt.NE.1).AND.(idt.NE.8)))
5846  & RETURN
5847  ptot = plab*1.0d3
5848  ekin = sqrt(ampi**2+ptot**2)-ampi
5849  IF ((ekin.LT.tiny3).OR.(ekin.GT.400.0d0)) RETURN
5850  ecm = sqrt( (ampi+amde)**2+two*ekin*amde )
5851  sigabs = a+b/sqrt(ekin)+c*1.0d4/((ecm-er)**2+d)
5852 * approximate 3N-abs., I=1-abs. etc.
5853  sigabs = sigabs/0.40d0
5854  IF(idp.EQ.23) sigabs = 0.5d0*sigabs
5855 
5856  RETURN
5857  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
frbkin
subroutine frbkin(L, LP)
Definition: dpm25eva.f:181
HepGeom::Transform3D::yy
double yy() const
Definition: Transform3D.h:264
checkn
subroutine checkn(EPN, PPN, IREJ, IORIG)
Definition: dpm25nuc1.f:4992
evtput
subroutine evtput(IST, ID, M1, M2, PX, PY, PZ, E, IDR, IDXR, IDC)
Definition: dpm25nuc6.f:3498
mcihad
function mcihad(MCIND)
Definition: dpm25nulib.f:364
decays
subroutine decays(PIN, IDXIN, POUT, IDXOUT, NSEC, IREJ)
Definition: dpm25nuc6.f:5608
dhadri
subroutine dhadri(N, PLAB, ELAB, CX, CY, CZ, ITTA)
Definition: dpm25hadri.f:2433
plu
function plu(I, J)
Definition: jetset74ku.f:6207
G4Abla::nint
G4int nint(G4double number)
Definition: G4Abla.cc:3631
decay1
subroutine decay1
Definition: dpm25nuc6.f:5762
mchad
function mchad(ITDTU)
Definition: dpm25nulib.f:488
G4StokesVector::p2
G4double p2() const
Definition: G4StokesVector.hh:75
sigmas
subroutine sigmas
Definition: dpm25pom.f:2176
int
typedef int(XMLCALL *XML_NotStandaloneHandler)(void *userData)
z
G4double z
Definition: TRTMaterials.hh:39
dtwopd
subroutine dtwopd(UMO, ECM1, ECM2, PCM1, PCM2, COD1, COF1, SIF1, COD2, COF2, SIF2, AM1, AM2)
Definition: dpm25nuc7.f:3326
hadri1
subroutine hadri1(IDPR, PPR, IDTA, PTA, MODE, IREJ)
Definition: dpm25nuc6.f:3267
mxzfbk
const int mxzfbk
Definition: G4DPMJET2_5Interface.hh:72
evevap
subroutine evevap(WEE)
Definition: dpm25eva.f:4
HepGeom::BasicVector3D::unit
BasicVector3D< T > unit() const
Definition: BasicVector3D.h:304
mxffbk
const int mxffbk
Definition: G4DPMJET2_5Interface.hh:70
dtrafo
subroutine dtrafo(GAM, BGAM, CX, CY, CZ, COD, COF, SIF, P, ECM, PL, CXL, CYL, CZL, EL)
Definition: dpm25nuc3.f:7346
stalin
subroutine stalin
Definition: dpm25eva.f:178
G4CascadeCheckBalance::ekin
G4double ekin(const G4LorentzVector &p) const
Definition: G4CascadeCheckBalance.hh:153
kkevnu
subroutine kkevnu(NHKKH1, EPN, PPN, KKMAT, IREJ, ECM)
Definition: dpm25nuc2.f:8539
ltrans
subroutine ltrans(PXI, PYI, PZI, PEI, PXO, PYO, PZO, PEO, ID, MODE)
Definition: dpm25nuc6.f:3898
absorp
subroutine absorp(IDCAS, PCAS, NCAS, NSPE, IDSPE, IDXSPE, MODE, IREJ)
Definition: dpm25nuc6.f:3049
inucas
subroutine inucas(IT, IP, IDXCAS, LCAS, NCAS, IREJ)
Definition: dpm25nuc6.f:2334
resncl
subroutine resncl(EPN, MODE)
Definition: dpm25nuc6.f:885
ltini
subroutine ltini(IDP, EPN, PPN, ECM)
Definition: dpm25nuc6.f:4036
a
G4double a
Definition: TRTMaterials.hh:39
ltnuc
subroutine ltnuc(PIN, EIN, POUT, EOUT, MODE)
Definition: dpm25nuc6.f:3942
fozoca
subroutine fozoca(LFZC, IREJ)
Definition: dpm25nuc6.f:2151
HepGeom::Transform3D::zz
double zz() const
Definition: Transform3D.h:276
HepGeom::Plane3D::d
T d() const
Definition: Plane3D.h:86
sihnin
subroutine sihnin(IPROJ, ITAR, PO, SIIN)
Definition: dpm25hadri.f:2176
nmxhkk
const int nmxhkk
Definition: G4DPMJET2_5Interface.hh:78
nclpot
subroutine nclpot(IPZ, IP, ITZ, IT, AFERP, AFERT, MODE)
Definition: dpm25nuc6.f:702
distrc
subroutine distrc(IOP, NHKKH1, PO, IGENER)
Definition: dpm25hist.f:525
c2_transformation::one
static float_type one(float_type)
utility function f(x)=1 useful in axis transforms
Definition: c2_function.hh:1201
nxafbk
const int nxafbk
Definition: G4DPMJET2_5Interface.hh:75
mytran
subroutine mytran(IMODE, XO, YO, ZO, CDE, SDE, CFE, SFE, X, Y, Z)
Definition: dpm25nuc6.f:3731
ficonf
subroutine ficonf(IJPROJ, IP, IPZ, IT, ITZ, IREJ)
Definition: dpm25nuc6.f:1518
sihnab
subroutine sihnab(IDP, IDT, PLAB, SIGABS)
Definition: dpm25nuc6.f:5822
berttp
subroutine berttp
Definition: dpm25nuc6.f:4627
icihad
function icihad(MCIND)
Definition: dpm25nuc6.f:5811
backdpm
subroutine backdpm
Definition: dpm25nuc2.f:10544
energy
double precision function energy(A, Z)
Definition: dpm25nuc6.f:4106
mxpsst
const int mxpsst
Definition: G4DPMJET2_5Interface.hh:73
nxzfbk
const int nxzfbk
Definition: G4DPMJET2_5Interface.hh:77
mxpsfb
const int mxpsfb
Definition: G4DPMJET2_5Interface.hh:74
CLHEP::HepLorentzVector::py
double py() const
iz
G4double iz
Definition: TRTMaterials.hh:39
checkf
subroutine checkf(EPN, PPN, IREJ, IORIG)
Definition: dpm25nuc1.f:4717
daltra
subroutine daltra(GA, BGX, BGY, BGZ, PCX, PCY, PCZ, EC, P, PX, PY, PZ, E)
Definition: dpm25nulib.f:542
CLHEP::HepLorentzVector::px
double px() const
kkevle
subroutine kkevle(NHKKH1, EPN, PPN, KKMAT, IREJ)
Definition: dpm25lepto.f:2
distco
subroutine distco(IOP, IJPROJ, PPN, IDUMMY)
Definition: dpm25hist.f:999
G4StokesVector::p1
G4double p1() const
Definition: G4StokesVector.hh:74
dechkk
subroutine dechkk(NHKKH1)
Definition: dpm25nuc3.f:6992
pyjets
#define pyjets
Definition: pythia6_common_address.c:39
mxafbk
const int mxafbk
Definition: G4DPMJET2_5Interface.hh:69
mxnfbk
const int mxnfbk
Definition: G4DPMJET2_5Interface.hh:71
n
const G4int n
Definition: G4UrQMD1_3Interface.hh:144
rndm
double precision function rndm(RDUMMY)
Definition: dpm25nulib.f:1460
elhain
subroutine elhain(IP, PLA, ELAB, CX, CY, CZ, IT, IREJ)
Definition: dpm25hadri.f:335
kkevt
subroutine kkevt(NHKKH1, EPN, PPN, KKMAT, IREJ)
Definition: dpm25nuc2.f:1405
kkinc
subroutine kkinc(EPN, NTMASS, NTCHAR, NPMASS, NPCHAR, IDP, KKMAT, IDT, NHKKH1, IREJ)
Definition: dpm25nuc6.f:5
HepGeom::Transform3D::yz
double yz() const
Definition: Transform3D.h:267
dsfecf
subroutine dsfecf(SFE, CFE)
Definition: dpm25nuc7.f:3354
kkevdi
subroutine kkevdi(NHKKH1, EPN, PPN, KKMAT, IREJ)
Definition: dpm25nuc2.f:9426
eva2he
subroutine eva2he(MO, EEXCF, IRCL, IREJ)
Definition: dpm25nuc6.f:1992
incini
subroutine incini
Definition: dpm25nuc6.f:5183
c2_factory::log
static c2_log_p< float_type > & log()
make a *new object
Definition: c2_factory.hh:138
checko
subroutine checko(EPN, PPN, IREJ, IORIG)
Definition: dpm25nuc1.f:5295
chebch
subroutine chebch(IREJ, NHKKH1)
Definition: dpm25nuc1.f:6270
G4Abla::tau
G4double tau(G4double bet, G4double homega, G4double ef, G4double t)
Definition: G4Abla.cc:2586
klu
function klu(I, J)
Definition: jetset74ku.f:6077
HepGeom::Transform3D::xx
double xx() const
Definition: Transform3D.h:252
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
mashel
subroutine mashel(PA1, PA2, XM1, XM2, P1, P2, IREJ)
Definition: dpm25nuc6.f:3631
CLHEP::HepAxisAngle::delta
double delta() const
distr
subroutine distr(IOP, NHKKH1, PO, IGENER)
Definition: dpm25hist.f:9
ylamb
double precision function ylamb(X, Y, Z)
Definition: dpm25nuc6.f:3765
ipdgha
function ipdgha(MCIND)
Definition: dpm25nuc6.f:5815
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
defaux
subroutine defaux(EPN, PPN)
Definition: dpm25nuc6.f:641
nxnfbk
const int nxnfbk
Definition: G4DPMJET2_5Interface.hh:76
scn4ba
subroutine scn4ba
Definition: dpm25nuc6.f:1270
evtemc
subroutine evtemc(PXIO, PYIO, PZIO, EIO, IMODE, IPOS, IREJ)
Definition: dpm25nuc6.f:3789
evtini
subroutine evtini(ID, IP, IT, EPN, PPN, ECM, NHKKH1, MODE)
Definition: dpm25nuc6.f:3988
enrg
double precision function enrg(A, Z)
Definition: dpm25nuc6.f:4431
raco
subroutine raco(WX, WY, WZ)
Definition: dpm25eva.f:37
sihnel
subroutine sihnel(IPROJ, ITAR, POO, SIEL)
Definition: dpm25hadri.f:448
Generated on Wed Apr 30 2014 15:54:31 for Geant4.10 by   doxygen 1.8.7