This commit was generated by cvs2svn to compensate for changes in r2,
[u/mrichter/AliRoot.git] / GEANT321 / peanut / pioabs.F
1 *
2 * $Id$
3 *
4 * $Log$
5 * Revision 1.1.1.1  1995/10/24 10:22:02  cernlib
6 * Geant
7 *
8 *
9 #include "geant321/pilot.h"
10 *CMZ :  3.21/02 29/03/94  15.41.46  by  S.Giani
11 *-- Author :
12 *$ CREATE PIOABS.FOR
13 *COPY PIOABS
14 *
15 *=== pioabs ===========================================================*
16 *
17       SUBROUTINE PIOABS ( IKPMX , KRFLIN, WEE   , ERECMN, LBIMPC,
18      &                    LBCHCK, ICYCL , NHOLE , NPROT , NNEUT ,
19      &                    LEXIT , LNWINT )
20  
21 #include "geant321/dblprc.inc"
22 #include "geant321/dimpar.inc"
23 #include "geant321/iounit.inc"
24 *
25 *----------------------------------------------------------------------*
26 *----------------------------------------------------------------------*
27 *
28 #include "geant321/balanc.inc"
29 #include "geant321/finuc.inc"
30 #include "geant321/nucdat.inc"
31 #include "geant321/nucgeo.inc"
32 #include "geant321/parevt.inc"
33 #include "geant321/parnuc.inc"
34 #include "geant321/part.inc"
35 #include "geant321/resnuc.inc"
36 *
37       COMMON / FKPLOC / IABCOU
38       REAL RNDM(1)
39       LOGICAL LBCHCK, LBIMPC, LTROUB, LEXIT, LNWINT
40 *
41       NPNCLD = NPNUC
42  1000 CONTINUE
43       IF ( LABRST .OR. LABSRP ) THEN
44          LNWINT = .FALSE.
45       ELSE
46          LEXIT  = .FALSE.
47          LNWINT = .TRUE.
48          RETURN
49       END IF
50       NHOLE  = NHOLE + NTARGT
51       NTARLD = NTARGT
52       ICYCL  = ICYCL + 1
53       IF ( NTARGT .EQ. 1 ) THEN
54          IF ( .NOT. LABRST )  STOP '???_rad_flight_abs'
55          LABRST = .FALSE.
56          LABSRP = .FALSE.
57          PFROUT = PFRIMP / PFRCEN (1) * PFRCEN (2)
58          EKFOUT = SQRT ( AMNUSQ (2) + PFROUT**2 ) - AMNUCL (2)
59          POTINC = EKEWLL - EKECON + EKFERM
60          POTOUT = EKFERM + EKFOUT + BNENRG (2) - EKFIMP - BNENRG (1)
61          ERES   = EKEWLL + AM (KPRIN) + EKFERM + AM (KNUCIM)
62      &          + POTOUT - POTINC
63          AMNREC = AMNTAR - AMUC12
64          ERECMN = 0.5D+00 * PTRES2 / AMNREC
65          ERECMN = 0.D+00
66          UMO2   = ERES*ERES - PTRES2
67          UMO    = SQRT (UMO2)
68          GAMCM = ERES  / UMO
69          ETAX  = PXRES / UMO
70          ETAY  = PYRES / UMO
71          ETAZ  = PZRES / UMO
72          ECMSNU = 0.5D+00 * ( UMO2 + AMNUSQ (2) ) / UMO
73          PCMS   = UMO - ECMSNU
74          CALL RACO ( PCMSX, PCMSY, PCMSZ )
75          PCMSX = PCMS * PCMSX
76          PCMSY = PCMS * PCMSY
77          PCMSZ = PCMS * PCMSZ
78          NPNUC = NPNUC + 1
79          KPNUCL (NPNUC) = 7
80          KRFNUC (NPNUC) = KRFLIN + 1
81          ETAPCM = ETAX * PCMSX + ETAY * PCMSY + ETAZ * PCMSZ
82          PHELP  = PCMS + ETAPCM / ( GAMCM + 1.D+00 )
83          ENNUC  (NPNUC) = GAMCM * PCMS + ETAPCM
84          PXHELP = PCMSX + ETAX * PHELP
85          PYHELP = PCMSY + ETAY * PHELP
86          PZHELP = PCMSZ + ETAZ * PHELP
87          PXRES = PXRES - PXHELP
88          PYRES = PYRES - PYHELP
89          PZRES = PZRES - PZHELP
90          ERES  = ERES  - ENNUC (NPNUC)
91          PTRES2= PXRES**2 + PYRES**2 + PZRES**2
92          PXHLP = PXTTOT - PXHELP
93          PYHLP = PYTTOT - PYHELP
94          PZHLP = PZTTOT - PZHELP
95          UMO2  = ( ETTOT - ENNUC (NPNUC) )**2 - PXHLP**2 - PYHLP**2
96      &         - PZHLP**2
97          EEXMNM = 0.D+00
98          DELTU2 = UMO2 - ( AMNRES + EEXMNM )**2
99          IF ( DELTU2 .LT. 0.D+00 ) THEN
100             NPNUC  = NPNUC - 1
101             LBCHCK = .FALSE.
102             IF ( LBIMPC ) THEN
103                CALL BIMNXT ( LBCHCK )
104                RHOMEM = 0.5D+00 * ( RHOIMP + RHOIMT )
105                EKFMEM = 0.5D+00 * ( EKFIMP + EKFPRO )
106             ELSE
107                CALL NWINXT ( LBCHCK )
108                IF ( BIMPCT .GT. RADTOT ) THEN
109                   NHOLE = NHOLE - NTARLD
110                   ICYCL = ICYCL - 1
111                   CALL PHDSET ( IKPMX )
112                   IBRES = IBRES - IBAR (KPRIN)
113                   ICRES = ICRES - ICH  (KPRIN)
114                   BBRES = IBRES
115                   ZZRES = ICRES
116                   AMMRES = BBRES * AMUAMU + 0.001D+00 * FKENER
117      &                   ( BBRES, ZZRES)
118                   AMNRES = AMMRES - ZZRES * AMELEC + ELBNDE ( ICRES )
119                   LTROUB = .FALSE.
120                   CALL UMOFIN ( IKPMX, BBRES, ZZRES, LTROUB )
121                   IF ( LTROUB ) THEN
122                      KPNUCL (IKPMX) = 0
123                      UMO2  = ERES**2 - PTRES2
124                      UMO = SQRT (UMO2)
125                      WRITE ( LUNOUT,* )' PIO0_P:UMO,AMNRES',UMO,AMNRES
126                      LEXIT = .TRUE.
127                      RETURN
128                   END IF
129                   NP = NP + 1
130                   TKI   (NP) = ENNUC  (IKPMX) - AM (KPRIN)
131                   KPART (NP) = KPRIN
132                   PLR   (NP) = PNUCL  (IKPMX)
133                   CXR   (NP) = PXNUCL (IKPMX) / PLR (NP)
134                   CYR   (NP) = PYNUCL (IKPMX) / PLR (NP)
135                   CZR   (NP) = PZNUCL (IKPMX) / PLR (NP)
136                   WEI   (NP) = WEE
137                   KPNUCL (IKPMX) = 0
138                   IOTHER = IOTHER + 1
139                   PXNUCR = PXNUCR + PXNUCL (IKPMX)
140                   PYNUCR = PYNUCR + PYNUCL (IKPMX)
141                   PZNUCR = PZNUCR + PZNUCL (IKPMX)
142                   ENUCR  = ENUCR  + ENNUC  (IKPMX)
143                   IBNUCR = IBNUCR + IBAR   (KPART(NP))
144                   ICNUCR = ICNUCR + ICH    (KPART(NP))
145                   LEXIT  = .TRUE.
146                   RETURN
147                END IF
148                XSTNUC (IKPMX) = XIMPTR
149                YSTNUC (IKPMX) = YIMPTR
150                ZSTNUC (IKPMX) = ZIMPTR
151                RSTNUC (IKPMX) = ABS (RIMPTR)
152             END IF
153             NHOLE = NHOLE - NTARLD
154             ICYCL = ICYCL - 1
155             GO TO 1000
156          END IF
157          EKFNUC (NPNUC) = - AINFNT
158          PXNUCL (NPNUC) = PXHELP
159          PYNUCL (NPNUC) = PYHELP
160          PZNUCL (NPNUC) = PZHELP
161          PNUCL  (NPNUC) = ENNUC (NPNUC)
162          XSTNUC (NPNUC) = XIMPTR
163          YSTNUC (NPNUC) = YIMPTR
164          ZSTNUC (NPNUC) = ZIMPTR
165          RSTNUC (NPNUC) = ABS (RIMPTR)
166          NPNUC = NPNUC + 1
167          KPNUCL (NPNUC) = 8
168          KRFNUC (NPNUC) = KRFLIN + 1
169          ETAPCM = - ETAPCM
170          PHELP  = ECMSNU + ETAPCM / ( GAMCM + 1.D+00 )
171          ENNUC  (NPNUC) = GAMCM * ECMSNU + ETAPCM
172          DEFRNU = DEFNEU
173          IF ( ENNUC (NPNUC) - AM (8) .LE. EKFOUT + DEFRNU ) THEN
174             NPNUC  = NPNUC - 2
175             LBCHCK = .FALSE.
176             IF ( LBIMPC ) THEN
177                CALL BIMNXT ( LBCHCK )
178                RHOMEM = 0.5D+00 * ( RHOIMP + RHOIMT )
179                EKFMEM = 0.5D+00 * ( EKFIMP + EKFPRO )
180             ELSE
181                CALL NWINXT ( LBCHCK )
182                IF ( BIMPCT .GT. RADTOT ) THEN
183                   NHOLE = NHOLE - NTARLD
184                   ICYCL = ICYCL - 1
185                   CALL PHDSET ( IKPMX )
186                   IBRES = IBRES - IBAR (KPRIN)
187                   ICRES = ICRES - ICH  (KPRIN)
188                   BBRES = IBRES
189                   ZZRES = ICRES
190                   AMMRES = BBRES * AMUAMU + 0.001D+00 * FKENER
191      &                   ( BBRES, ZZRES)
192                   AMNRES = AMMRES - ZZRES * AMELEC + ELBNDE ( ICRES )
193                   LTROUB = .FALSE.
194                   CALL UMOFIN ( IKPMX, BBRES, ZZRES, LTROUB )
195                   IF ( LTROUB ) THEN
196                      KPNUCL (IKPMX) = 0
197                      UMO2  = ERES**2 - PTRES2
198                      UMO = SQRT (UMO2)
199                      WRITE ( LUNOUT,* )' PIO0_T:UMO,AMNRES',UMO,AMNRES
200                      LEXIT = .TRUE.
201                      RETURN
202                   END IF
203                   NP = NP + 1
204                   TKI   (NP) = ENNUC  (IKPMX) - AM (KPRIN)
205                   KPART (NP) = KPRIN
206                   PLR   (NP) = PNUCL  (IKPMX)
207                   CXR   (NP) = PXNUCL (IKPMX) / PLR (NP)
208                   CYR   (NP) = PYNUCL (IKPMX) / PLR (NP)
209                   CZR   (NP) = PZNUCL (IKPMX) / PLR (NP)
210                   WEI   (NP) = WEE
211                   KPNUCL (IKPMX) = 0
212                   IOTHER = IOTHER + 1
213                   PXNUCR = PXNUCR + PXNUCL (IKPMX)
214                   PYNUCR = PYNUCR + PYNUCL (IKPMX)
215                   PZNUCR = PZNUCR + PZNUCL (IKPMX)
216                   ENUCR  = ENUCR  + ENNUC  (IKPMX)
217                   IBNUCR = IBNUCR + IBAR   (KPART(NP))
218                   ICNUCR = ICNUCR + ICH    (KPART(NP))
219                   LEXIT  = .TRUE.
220                   RETURN
221                END IF
222                XSTNUC (IKPMX) = XIMPTR
223                YSTNUC (IKPMX) = YIMPTR
224                ZSTNUC (IKPMX) = ZIMPTR
225                RSTNUC (IKPMX) = ABS (RIMPTR)
226             END IF
227             NHOLE = NHOLE - NTARLD
228             ICYCL = ICYCL - 1
229             GO TO 1000
230          END IF
231          EKFNUC (NPNUC) = EKFOUT
232          PXNUCL (NPNUC) = -PCMSX + ETAX * PHELP
233          PYNUCL (NPNUC) = -PCMSY + ETAY * PHELP
234          PZNUCL (NPNUC) = -PCMSZ + ETAZ * PHELP
235          PNUCL  (NPNUC) = SQRT ( PXNUCL (NPNUC)**2 + PYNUCL (NPNUC)**2
236      &                         + PZNUCL (NPNUC)**2 )
237          XSTNUC (NPNUC) = XIMPCT
238          YSTNUC (NPNUC) = YIMPCT
239          ZSTNUC (NPNUC) = ZIMPCT
240          RSTNUC (NPNUC) = ABS (RIMPCT)
241          LBIMPC = .FALSE.
242          LEXIT  = .FALSE.
243          NUSCIN = NUSCIN + 1
244          ISCTYP (NUSCIN) = - ( KPRIN * 100 + KNUCIM )
245          IF ( NUSCIN .EQ. 1 ) IPRTYP = ISCTYP (1)
246          NHLEXP = NHLEXP + 1
247          HOLEXP (NHLEXP) = EKFIMP - EKFERM
248          RHOACT = 0.5D+00 * ( RHOIMP + RHOIMT )
249          RHOEXP = RHOEXP + RHOACT
250          EKFEXP = EKFEXP + 0.5D+00 * ( EKFIMP + EKFPRO )
251          CALL NCLVFX
252       ELSE
253          LABRST = .FALSE.
254          LABSRP = .FALSE.
255          ITFRMI = 1 + KNUCIM / 8
256          ITFRM2 = 1 + KNUCI2 / 8
257          IF ( ICH (KPRIN) .GT. 0 ) THEN
258             IOFRMI = 1
259             IOFRM2 = ITFRM2
260             DEFRPR = DEFPRO
261             IF ( IOFRMI .EQ. ITFRM2 ) THEN
262                EKFOUT = EKFIM2
263                DEFRNU = DEFPRO
264             ELSE
265                PFROUT = PFRIMP / PFRCEN (1) * PFRCEN (2)
266                EKFOUT = SQRT ( AMNUSQ (1) + PFROUT**2 ) - AMNUCL (1)
267                DEFRNU = DEFNEU
268             END IF
269          ELSE IF ( ICH (KPRIN) .LT. 0 ) THEN
270             IOFRMI = 2
271             IOFRM2 = ITFRM2
272             DEFRPR = DEFNEU
273             IF ( IOFRMI .EQ. ITFRM2 ) THEN
274                EKFOUT = EKFIM2
275                DEFRNU = DEFNEU
276             ELSE
277                PFROUT = PFRIMP / PFRCEN (2) * PFRCEN (1)
278                EKFOUT = SQRT ( AMNUSQ (2) + PFROUT**2 ) - AMNUCL (2)
279                DEFRNU = DEFPRO
280             END IF
281          ELSE
282             IOFRMI = ITFRMI
283             IOFRM2 = ITFRM2
284             EKFOUT = EKFIMP
285             IF ( ITFRMI .EQ. 1 ) THEN
286                DEFRPR = DEFPRO
287             ELSE
288                DEFRPR = DEFNEU
289             END IF
290             IF ( ITFRM2 .EQ. 1 ) THEN
291                DEFRNU = DEFPRO
292             ELSE
293                DEFRNU = DEFNEU
294             END IF
295          END IF
296          POTINC = EKEWLL - EKECON + EKFERM + EKFER2
297          POTOUT = EKFERM + EKFER2 + EKFOUT + BNENRG (IOFRMI) - EKFIMP
298      &          - BNENRG (ITFRMI)
299          ERES   = EKEWLL + AM (KPRIN) + EKFERM + AM (KNUCIM)
300      &          + EKFER2 + AM (KNUCI2) + POTOUT - POTINC
301          AMNREC = AMNTAR - 2.D+00 * AMUC12
302          PHLPSQ = ( PXRES - CXIMPC * PNUCCO )**2
303      &          + ( PYRES - CYIMPC * PNUCCO )**2
304      &          + ( PZRES - CZIMPC * PNUCCO )**2
305          ERECMN = 0.5D+00 * PHLPSQ / AMNREC**2
306          ERECMN = AMNREC * ERECMN * ( 1.D+00 - 0.25D+00 * ERECMN )
307          ERECMN = 0.D+00
308          UMO2   = ERES*ERES - PTRES2
309          UMO    = SQRT (UMO2)
310          GAMCM = ERES  / UMO
311          ETAX  = PXRES / UMO
312          ETAY  = PYRES / UMO
313          ETAZ  = PZRES / UMO
314          ECMSPR = 0.5D+00 * ( UMO2 + AMNUSQ (IOFRMI) - AMNUSQ (IOFRM2) )
315      &          / UMO
316          ECMSNU = UMO - ECMSPR
317          PCMS   = SQRT ( ( ECMSPR - AMNUCL (IOFRMI) ) * ( ECMSPR
318      &          + AMNUCL (IOFRMI) ) )
319          CALL RACO ( PCMSX, PCMSY, PCMSZ )
320          PCMSX = PCMS * PCMSX
321          PCMSY = PCMS * PCMSY
322          PCMSZ = PCMS * PCMSZ
323          NPNUC = NPNUC + 1
324          KPNUCL (NPNUC) = 1 + 7 * ( IOFRMI - 1 )
325          KRFNUC (NPNUC) = KRFLIN + 1
326          ETAPCM = ETAX * PCMSX + ETAY * PCMSY + ETAZ * PCMSZ
327          PHELP  = ECMSPR + ETAPCM / ( GAMCM + 1.D+00 )
328          ENNUC  (NPNUC) = GAMCM * ECMSPR + ETAPCM
329          IF ( ENNUC (NPNUC) - AMNUCL (IOFRMI) .LE. EKFOUT + DEFRPR )THEN
330             NPNUC  = NPNUC - 1
331             LBCHCK = .FALSE.
332             IF ( LBIMPC ) THEN
333                CALL BIMNXT ( LBCHCK )
334                RHOMEM = 0.5D+00 * ( RHOIMP + RHOIMT )
335                EKFMEM = 0.5D+00 * ( EKFIMP + EKFPRO )
336             ELSE
337                CALL NWINXT ( LBCHCK )
338                IF ( BIMPCT .GT. RADTOT ) THEN
339                   NHOLE = NHOLE - NTARLD
340                   ICYCL = ICYCL - 1
341                   CALL PHDSET ( IKPMX )
342                   IBRES = IBRES - IBAR (KPRIN)
343                   ICRES = ICRES - ICH  (KPRIN)
344                   BBRES = IBRES
345                   ZZRES = ICRES
346                   AMMRES = BBRES * AMUAMU + 0.001D+00 * FKENER
347      &                   ( BBRES, ZZRES)
348                   AMNRES = AMMRES - ZZRES * AMELEC + ELBNDE ( ICRES )
349                   LTROUB = .FALSE.
350                   CALL UMOFIN ( IKPMX, BBRES, ZZRES, LTROUB )
351                   IF ( LTROUB ) THEN
352                      KPNUCL (IKPMX) = 0
353                      UMO2  = ERES**2 - PTRES2
354                      UMO = SQRT (UMO2)
355                      WRITE ( LUNOUT,* )' PIO0_P:UMO,AMNRES',UMO,AMNRES
356                      LEXIT = .TRUE.
357                      RETURN
358                   END IF
359                   NP = NP + 1
360                   TKI   (NP) = ENNUC  (IKPMX) - AM (KPRIN)
361                   KPART (NP) = KPRIN
362                   PLR   (NP) = PNUCL  (IKPMX)
363                   CXR   (NP) = PXNUCL (IKPMX) / PLR (NP)
364                   CYR   (NP) = PYNUCL (IKPMX) / PLR (NP)
365                   CZR   (NP) = PZNUCL (IKPMX) / PLR (NP)
366                   WEI   (NP) = WEE
367                   KPNUCL (IKPMX) = 0
368                   IOTHER = IOTHER + 1
369                   PXNUCR = PXNUCR + PXNUCL (IKPMX)
370                   PYNUCR = PYNUCR + PYNUCL (IKPMX)
371                   PZNUCR = PZNUCR + PZNUCL (IKPMX)
372                   ENUCR  = ENUCR  + ENNUC  (IKPMX)
373                   IBNUCR = IBNUCR + IBAR   (KPART(NP))
374                   ICNUCR = ICNUCR + ICH    (KPART(NP))
375                   LEXIT  = .TRUE.
376                   RETURN
377                END IF
378                XSTNUC (IKPMX) = XIMPTR
379                YSTNUC (IKPMX) = YIMPTR
380                ZSTNUC (IKPMX) = ZIMPTR
381                RSTNUC (IKPMX) = ABS (RIMPTR)
382             END IF
383             NHOLE = NHOLE - NTARLD
384             ICYCL = ICYCL - 1
385             GO TO 1000
386          END IF
387          EKFNUC (NPNUC) = EKFOUT
388          PXNUCL (NPNUC) = PCMSX + ETAX * PHELP
389          PYNUCL (NPNUC) = PCMSY + ETAY * PHELP
390          PZNUCL (NPNUC) = PCMSZ + ETAZ * PHELP
391          PNUCL  (NPNUC) = SQRT ( PXNUCL (NPNUC)**2 + PYNUCL (NPNUC)**2
392      &                         + PZNUCL (NPNUC)**2 )
393          XSTNUC (NPNUC) = XIMPTR
394          YSTNUC (NPNUC) = YIMPTR
395          ZSTNUC (NPNUC) = ZIMPTR
396          RSTNUC (NPNUC) = ABS (RIMPTR)
397          NPNUC = NPNUC + 1
398          KPNUCL (NPNUC) = 1 + 7 * ( IOFRM2 - 1 )
399          KRFNUC (NPNUC) = KRFLIN + 1
400          ETAPCM = - ETAPCM
401          PHELP  = ECMSNU + ETAPCM / ( GAMCM + 1.D+00 )
402          ENNUC  (NPNUC) = GAMCM * ECMSNU + ETAPCM
403          IF ( ENNUC (NPNUC) - AMNUCL (IOFRM2) .LE. EKFIM2 + DEFRNU )THEN
404             NPNUC  = NPNUC - 2
405             LBCHCK = .FALSE.
406             IF ( LBIMPC ) THEN
407                CALL BIMNXT ( LBCHCK )
408                RHOMEM = 0.5D+00 * ( RHOIMP + RHOIMT )
409                EKFMEM = 0.5D+00 * ( EKFIMP + EKFPRO )
410             ELSE
411                CALL NWINXT ( LBCHCK )
412                IF ( BIMPCT .GT. RADTOT ) THEN
413                   NHOLE = NHOLE - NTARLD
414                   ICYCL = ICYCL - 1
415                   CALL PHDSET ( IKPMX )
416                   IBRES = IBRES - IBAR (KPRIN)
417                   ICRES = ICRES - ICH  (KPRIN)
418                   BBRES = IBRES
419                   ZZRES = ICRES
420                   AMMRES = BBRES * AMUAMU + 0.001D+00 * FKENER
421      &                   ( BBRES, ZZRES)
422                   AMNRES = AMMRES - ZZRES * AMELEC + ELBNDE ( ICRES )
423                   LTROUB = .FALSE.
424                   CALL UMOFIN ( IKPMX, BBRES, ZZRES, LTROUB )
425                   IF ( LTROUB ) THEN
426                      KPNUCL (IKPMX) = 0
427                      UMO2  = ERES**2 - PTRES2
428                      UMO = SQRT (UMO2)
429                      WRITE ( LUNOUT,* )' PIO0_T:UMO,AMNRES',UMO,AMNRES
430                      LEXIT = .TRUE.
431                      RETURN
432                   END IF
433                   NP = NP + 1
434                   TKI   (NP) = ENNUC  (IKPMX) - AM (KPRIN)
435                   KPART (NP) = KPRIN
436                   PLR   (NP) = PNUCL  (IKPMX)
437                   CXR   (NP) = PXNUCL (IKPMX) / PLR (NP)
438                   CYR   (NP) = PYNUCL (IKPMX) / PLR (NP)
439                   CZR   (NP) = PZNUCL (IKPMX) / PLR (NP)
440                   WEI   (NP) = WEE
441                   KPNUCL (IKPMX) = 0
442                   IOTHER = IOTHER + 1
443                   PXNUCR = PXNUCR + PXNUCL (IKPMX)
444                   PYNUCR = PYNUCR + PYNUCL (IKPMX)
445                   PZNUCR = PZNUCR + PZNUCL (IKPMX)
446                   ENUCR  = ENUCR  + ENNUC  (IKPMX)
447                   IBNUCR = IBNUCR + IBAR   (KPART(NP))
448                   ICNUCR = ICNUCR + ICH    (KPART(NP))
449                   LEXIT  = .TRUE.
450                   RETURN
451                END IF
452                XSTNUC (IKPMX) = XIMPTR
453                YSTNUC (IKPMX) = YIMPTR
454                ZSTNUC (IKPMX) = ZIMPTR
455                RSTNUC (IKPMX) = ABS (RIMPTR)
456             END IF
457             NHOLE = NHOLE - NTARLD
458             ICYCL = ICYCL - 1
459             GO TO 1000
460          END IF
461          EKFNUC (NPNUC) = EKFIM2
462          PXNUCL (NPNUC) = -PCMSX + ETAX * PHELP
463          PYNUCL (NPNUC) = -PCMSY + ETAY * PHELP
464          PZNUCL (NPNUC) = -PCMSZ + ETAZ * PHELP
465          PNUCL  (NPNUC) = SQRT ( PXNUCL (NPNUC)**2 + PYNUCL (NPNUC)**2
466      &                         + PZNUCL (NPNUC)**2 )
467          XSTNUC (NPNUC) = XIMPCT
468          YSTNUC (NPNUC) = YIMPCT
469          ZSTNUC (NPNUC) = ZIMPCT
470          RSTNUC (NPNUC) = ABS (RIMPCT)
471          LBIMPC = .FALSE.
472          LEXIT  = .FALSE.
473          NUSCIN = NUSCIN + 1
474          ISCTYP (NUSCIN) = - ( KPRIN * 100 + KNUCIM * 10 + KNUCI2 )
475          IF ( NUSCIN .EQ. 1 ) IPRTYP = ISCTYP (1)
476          IABCOU = IABCOU + 1
477          NHLEXP = NHLEXP + 2
478          HOLEXP (NHLEXP-1) = EKFIMP - EKFERM
479          HOLEXP (NHLEXP)   = EKFIM2 - EKFER2
480          RHOACT = 0.6666666666666666D+00 * RHOIMP
481      &          + 0.3333333333333333D+00 * RHOIMT
482          RHOEXP = RHOEXP + 2.D+00 * RHOACT
483          EKFEXP = EKFEXP + 0.6666666666666666D+00 * ( EKFIMP + EKFIM2
484      &          + EKFPRO )
485          CALL NCLVFX
486       END IF
487       DO 3000 KP = NPNCLD+1, NPNUC
488          KPNUC = KPNUCL (KP)
489          IF ( AM (KPNUC) .LE. 0.D+00 ) THEN
490             TAUTAU = RZNUCL / PNUCL (KP)
491          ELSE
492             TAUEFF = 0.5D+00 * TAUFOR * AM (13) / AM (KPNUC)
493             CALL GRNDM(RNDM,1)
494             TAUTAU = - TAUEFF / AM (KPNUC) * LOG ( 1.D+00 - RNDM
495      &             (1) )
496             TAUTAU = MAX ( TAUTAU, RZNUCL / PNUCL (KP) )
497          END IF
498          XSTNUC (KP) = XSTNUC (KP) + PXNUCL (KP) * TAUTAU
499          YSTNUC (KP) = YSTNUC (KP) + PYNUCL (KP) * TAUTAU
500          ZSTNUC (KP) = ZSTNUC (KP) + PZNUCL (KP) * TAUTAU
501          RSTNUC (KP) = SQRT ( XSTNUC (KP)**2 + YSTNUC (KP)**2
502      &               + ZSTNUC (KP)**2 )
503          RHNUCL (KP) = RHOACT
504  3000 CONTINUE
505       RETURN
506 *=== End of subroutine pioabs =========================================*
507       END