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