*
* $Id$
*
* $Log$
* Revision 1.1  1995/10/24 10:20:58  cernlib
* Initial revision
*
*
#include "geant321/pilot.h"
*CMZ :  3.21/02 29/03/94  15.41.38  by  S.Giani
*-- Author :
      SUBROUTINE PIMABS(NOPT)
C
C *** CHARGED PION ABSORPTION BY A NUCLEUS ***
C *** NVE 04-MAR-1988 CERN GENEVA ***
C
C ORIGIN : H.FESEFELDT (09-JULY-1987)
C
C PANOFSKY RATIO (PI- P --> N PI0/PI- P --> N GAMMA) = 3/2
C FOR CAPTURE ON PROTON (HYDROGEN),
C STAR PRODUCTION FOR HEAVIER ELEMENTS
C
#include "geant321/s_defcom.inc"
      DIMENSION RNDM(4)
      SAVE NT
C
      CALL COMPO
      PV(1,1)=0.
      PV(2,1)=0.
      PV(3,1)=0.
      PV(4,1)=RMASS(9)
      PV(5,1)=RMASS(9)
      PV(6,1)=-1.
      PV(7,1)=TOF
      PV(8,1)=IPART
      PV(9,1)=0.
      PV(10,1)=USERW
      IER(87)=IER(87)+1
      IF(ATNO2.GT.1.5) GOTO 30
      CALL GRNDM(RNDM,2)
      RAN=RNDM(1)
      ISW=1
      IF(RAN.LT.0.33) ISW=2
      NOPT=ISW
      RAN=RNDM(2)
      TOF1=-25.*LOG(RAN)
      TOF1=20.*TOF1
      IF(ISW.EQ.1) GOTO 20
      PCM=0.02
      CALL GRNDM(RNDM,2)
      PHI=2.*PI*RNDM(1)
      COST=-1.+2.*RNDM(2)
      SINT=SQRT(ABS(1.-COST*COST))
      PV(1,2)=PCM*SINT*COS(PHI)
      PV(2,2)=PCM*SINT*SIN(PHI)
      PV(3,2)=PCM*COST
      PV(4,2)=PCM
      PV(5,2)=0.
      PV(7,2)=TOF+TOF1
      PV(9,2)=0.
      PV(10,2)=0.
      PV(6,2)=0.
      PV(8,2)=1.
      GOTO 21
   20 PV(1,2)=PV(1,1)
      PV(2,2)=PV(2,1)
      PV(3,2)=PV(3,1)
      PV(4,2)=PV(4,1)
      PV(5,2)=PV(5,1)
      PV(6,2)=0.
      PV(7,2)=TOF+TOF1
      PV(8,2)=8.
      PV(9,2)=0.
      PV(10,2)=0.
   21 INTCT=INTCT+1.
      CALL SETCUR(2)
      NTK=NTK+1
      IF(NPRT(3))
     *WRITE(NEWBCD,1002) XEND,YEND,ZEND,P,NCH
1002  FORMAT(1H0,'PION ABSORBTION   POSITION',3(2X,F8.2),2X,
     * 'PI0/GAMMA MOMENTUM,CHARGE',2X,F8.4,2X,F4.1)
      GO TO 9999
C**
C** STAR PRODUCTION FOR PION ABSORPTION IN HEAVY ELEMENTS
C**
   30 ENP(1)=0.0135
      ENP(3)=0.0058
      NT=1
      TEX=ENP(1)
      BLACK=0.5*LOG(ATNO2)
      CALL POISSO(BLACK,NBL)
      IF(NBL.LE.0) NBL=1
      IF(NPRT(3))
     *WRITE(NEWBCD,3003) NBL,TEX
      IF(NT+NBL.GT.MXGKPV-2) NBL=MXGKPV-2-NT
      EKIN=TEX/NBL
      EKIN2=0.
      DO 31 I=1,NBL
      IF(NT.EQ.MXGKPV-2) GOTO 31
      CALL GRNDM(RNDM,4)
      RAN2=RNDM(1)
      EKIN1=-EKIN*LOG(RAN2)
      EKIN2=EKIN2+EKIN1
      IPA1=16
      PNRAT=1.-ZNO2/ATNO2
      IF(RNDM(2).GT.PNRAT) IPA1=14
      NT=NT+1
      COST=-1.+RNDM(3)*2.
      SINT=SQRT(ABS(1.-COST*COST))
      PHI=TWPI*RNDM(4)
      IPA(NT)=-IPA1
      PV(5,NT)=ABS(RMASS(IPA1))
      PV(6,NT)=RCHARG(IPA1)
      PV(7,NT)=2.
      PV(4,NT)=EKIN1+PV(5,NT)
      PP=SQRT(ABS(PV(4,NT)**2-PV(5,NT)**2))
      PV(1,NT)=PP*SINT*SIN(PHI)
      PV(2,NT)=PP*SINT*COS(PHI)
      PV(3,NT)=PP*COST
      IF(EKIN2.GT.TEX) GOTO 33
   31 CONTINUE
   33 TEX=ENP(3)
      BLACK=0.50*LOG(ATNO2)
      CALL POISSO(BLACK,NBL)
      IF(NT+NBL.GT.MXGKPV-2) NBL=MXGKPV-2-NT
      IF(NBL.LE.0) NBL=1
      EKIN=TEX/NBL
      EKIN2=0.
      IF(NPRT(3))
     *WRITE(NEWBCD,3004) NBL,TEX
      DO 32 I=1,NBL
      IF(NT.EQ.MXGKPV-2) GOTO 32
      CALL GRNDM(RNDM,4)
      RAN2=RNDM(1)
      EKIN1=-EKIN*LOG(RAN2)
      EKIN2=EKIN2+EKIN1
      NT=NT+1
      COST=-1.+RNDM(2)*2.
      SINT=SQRT(ABS(1.-COST*COST))
      PHI=TWPI*RNDM(3)
      RAN=RNDM(4)
      IPA(NT)=-30
      IF(RAN.GT.0.60) IPA(NT)=-31
      IF(RAN.GT.0.90) IPA(NT)=-32
      INVE=ABS(IPA(NT))
      PV(5,NT)=RMASS(INVE)
      PV(6,NT)=RCHARG(INVE)
      PV(7,NT)=2.
      PV(4,NT)=PV(5,NT)+EKIN1
      PP=SQRT(ABS(PV(4,NT)**2-PV(5,NT)**2))
      PV(1,NT)=PP*SINT*SIN(PHI)
      PV(2,NT)=PP*SINT*COS(PHI)
      PV(3,NT)=PP*COST
      IF(EKIN2.GT.TEX) GOTO 40
   32 CONTINUE
C**
C** STORE ON EVENT COMMON
C**
   40 CALL GRNDM(RNDM,1)
      RAN=RNDM(1)
      TOF1=-25.*LOG(RAN)
      TOF1=20.*TOF1
      DO 41 I=2,NT
      IF(PV(7,I).LT.0.) PV(5,I)=-PV(5,I)
      PV(7,I)=TOF+TOF1
      PV(8,I)=ABS(IPA(I))
      PV(9,I)=0.
   41 PV(10,I)=0.
      INTCT=INTCT+1.
      CALL SETCUR(2)
      NTK=NTK+1
      IF(NT.EQ.2) GO TO 9999
      DO 50 I=3,NT
      IF(NTOT.LT.NSIZE/12) GOTO 43
      GO TO 9999
   43 CALL SETTRK(I)
   50 CONTINUE
C
 3003 FORMAT(1H ,I3,' BLACK TRACK PARTICLES PRODUCED WITH TOTAL KINETIC
     * ENERGY OF ',F8.3,' GEV')
 3004 FORMAT(1H ,I5,' HEAVY FRAGMENTS WITH TOTAL ENERGY OF',F8.4,' GEV')
C
 9999 CONTINUE
      END
