GEANT321/miface/gfmfin.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.1.1.1  1995/10/24 10:21:53  cernlib
   6 * Geant
   7 *
   8 *
   9 #include "geant321/pilot.h"
  10 *CMZ :  3.21/02 29/03/94  15.41.47  by  S.Giani
  11 *-- Author :
  12       SUBROUTINE GFMFIN
  13 #include "geant321/gcbank.inc"
  14 #include "geant321/gccuts.inc"
  15 #include "geant321/gcjloc.inc"
  16 #include "geant321/gcflag.inc"
  17 #include "geant321/gckine.inc"
  18 #include "geant321/gcking.inc"
  19 #include "geant321/gcmate.inc"
  20 #include "geant321/gcphys.inc"
  21 #include "geant321/gctrak.inc"
  22 #include "geant321/gsecti.inc"
  23 #include "geant321/gctmed.inc"
  24 #include "geant321/gcunit.inc"
  25 #include "geant321/dimpar.inc"
  26
  27 #if !defined(CERNLIB_SINGLE)
  28 #include "geant321/finuct.inc"
  29 #endif
  30 #include "geant321/finuc.inc"
  31       REAL RNDM(1)
  32 #if !defined(CERNLIB_SINGLE)
  33       DOUBLE PRECISION AOCMBM, AMSS , ZTAR, RHO , ZLIN, ZLEL, ZLRAD,
  34      +ZUL
  35 #endif
  36       COMMON / FKMAPA / AOCMBM (MXXMDF), AMSS (MXXMDF), ZTAR   (MXXMDF),
  37      +                  RHO    (MXXMDF), ZLIN (MXXMDF), ZLEL   (MXXMDF),
  38      +                  ZLRAD  (MXXMDF), ZUL  (MXXMDF), MEDIUM (MXXRGN),
  39      +                  MULFLG (MXXMDF),IFCOMP(MXXMDF), MSSNUM (MXXMDF),
  40      +                  NREGS, NMATF, MTBSNM
  41 #if !defined(CERNLIB_SINGLE)
  42 #include "geant321/part2t.inc"
  43 #endif
  44 #include "geant321/part2.inc"
  45 #if !defined(CERNLIB_SINGLE)
  46 #include "geant321/comcont.inc"
  47 #endif
  48 #include "geant321/comcon.inc"
  49 #if !defined(CERNLIB_SINGLE)
  50 #include "geant321/fheavyt.inc"
  51 #endif
  52 #include "geant321/fheavy.inc"
  53 #include "geant321/paprop.inc"
  54 #if !defined(CERNLIB_SINGLE)
  55 #include "geant321/papropt.inc"
  56 #endif
  57 #include "geant321/gfkdis.inc"
  58 #if !defined(CERNLIB_SINGLE)
  59       DOUBLE PRECISION POO,EKE,TXI,TYI,TZI,AMM,WE,ONE,PGEANT,DMOD
  60 #endif
  61       PARAMETER (ONE=1)
  62       DIMENSION IGTOFL(49),IFLTOG(39),IHVTOG(6),ZSAMP(50)
  63       DATA IGTOFL / 0, 0, 0, 0, 0, 0,23,13,14,12, 15,16, 8, 1, 2,19, 0,
  64      +17,21,22, 20, 34, 36, 38, 9,18, 31, 32, 33, 35, 37, 39, 17*0/
  65
  66       DATA IFLTOG /14,15, 3, 2, 4, 4, 1,13,25, 5, 6,10, 8, 9,11,12,18,
  67      +26,16,21, 19,20, 7, 7*0, 27, 28, 29, 22, 30, 23, 31, 24, 32/
  68       DATA IHVTOG /13,14,45,46,49,47/
  69 *
  70       NP = 0
  71       NPHEAV = 0
  72 *
  73 *    Stopped particles:
  74 *    o Neutral particles are sent to GHSTOP
  75 *    o pi+ and K+/K- are forced to decay
  76 *    o pi-, antiprotons and antineutrons are sent to FLUKA
  77 *      for annihilation (not here but later in this routine)
  78       IF (IGF.EQ.2.OR.(GEKIN.EQ.0.0.AND.IPART.EQ.13)) THEN
  79          IF (GEKIN.LT.CUTNEU) THEN
  80             GEKIN = MAX(GEKIN,1E-14)
  81 * should kinetic energy be deposited?
  82             ISTOP = 2
  83             IGF = 0
  84             GOTO 110
  85          ENDIF
  86          CALL GMICAP
  87          IGF = 0
  88          GOTO 110
  89       ELSE IF (GEKIN.EQ.0..AND.
  90      +        (IPART.EQ.8.OR.IPART.EQ.12.OR.IPART.EQ.11)) THEN
  91          CALL GDECAY
  92          NMEC=NMEC+1
  93          LMEC(NMEC)=5
  94          ISTOP=1
  95          GOTO 999
  96       ENDIF
  97 *
  98       IF (IFINIT(5) .EQ. 0) CALL FLINIT
  99       INT=0
 100       IJ=IGTOFL(IPART)
 101       IF(IJ.EQ.0) GOTO 110
 102       NMEC = NMEC + 1
 103       EKE = GEKIN
 104       TXI = VECT(4)
 105       TYI = VECT(5)
 106       TZI = VECT(6)
 107       DMOD = ONE/SQRT(TXI**2+TYI**2+TZI**2)
 108       TXI = TXI*DMOD
 109       TYI = TYI*DMOD
 110       TZI = TZI*DMOD
 111       WE  = 1.
 112       JMA = LQ(JMATE-NMAT)
 113       NCOMP = ABS (Q(JMA+11))
 114       AMM = Q(JMA+6)
 115       JMIXT = LQ(JMA-5)
 116
 117 *    Antiprotons, antineutrons and pi- are sent to
 118 *    eventv for annihilation
 119       IF (GEKIN.EQ.0..AND.
 120      +         (IPART.EQ.15.OR.IPART.EQ.9.OR.IPART.EQ.25)) THEN
 121          IF(NCOMP.LE.1) THEN
 122             AMSS(1) = Q(JMA+6)
 123             ZTAR(1) = Q(JMA+7)
 124             MSSNUM(1) = 0
 125             RHO(1) = Q(JMA+8)
 126          ELSE
 127             ZSAMP(1) = 0.
 128             DO 10 I=1,NCOMP
 129                ZSAMP(I+1) = ZSAMP(I) + Q(JMIXT+NCOMP+I)
 130    10       CONTINUE
 131             CALL GRNDM(RNDM,1)
 132             ZCONT=ZSAMP(NCOMP+1)*RNDM(1)
 133             DO 20 I=1,NCOMP
 134                IF(ZCONT.LE.ZSAMP(I+1)) GO TO 30
 135    20       CONTINUE
 136             I = NCOMP
 137    30       CONTINUE
 138             AMSS(1)   = Q(JMIXT+I)
 139             MSSNUM(1) = 0
 140             ZTAR(1)   = Q(JMIXT+NCOMP+I)
 141             RHO(1)    = Q(JMIXT+2*NCOMP+I)*DENS
 142          END IF
 143          EKE = 1E-9
 144          POO=SQRT(EKE*(EKE+2*AM(IJ)))
 145          CALL EVENTV(IJ,POO,EKE,TXI,TYI,TZI,WE,1)
 146          GOTO 80
 147       ELSE IF (GEKIN.LE.CUTHAD .AND. ITRTYP.EQ.4) THEN
 148          DESTEP = DESTEP + GEKIN
 149          GEKIN  = 0.
 150          GETOT  = AMASS
 151          VECT(7) = 0.
 152          ISTOP = 1
 153          GO TO 110
 154       ENDIF
 155 *
 156       CALL GRNDM(RNDM,1)
 157       RNDEVT=RNDM(1)
 158       IF ( RNDEVT .GE. SINE/FSIG) THEN
 159
 160          IF (GEKIN .GT. 0.02) THEN
 161             POO=SQRT(EKE*(EKE+2*AM(IJ)))
 162          ELSE
 163             GO TO 110
 164          END IF
 165          INT=1
 166          LMEC(NMEC)=13
 167          IF(NCOMP.LE.1) THEN
 168             CALL NUCREL(IJ,POO,EKE,TXI,TYI,TZI,AMM,WE)
 169          ELSE
 170             CALL GRNDM(RNDM,1)
 171             RCONT=ELXNOR*RNDM(1)
 172             DO 40  I=1,NCOMP
 173                IF(RCONT.LE.CABELX(I)) GO TO 50
 174    40       CONTINUE
 175             I=NCOMP
 176    50       CONTINUE
 177             CALL NUCREL(IJ,POO,EKE,TXI,TYI,TZI,ONE*Q(JMIXT+I),WE)
 178          END IF
 179       ELSE
 180          LMEC(NMEC)=20
 181          IF (IHADR.EQ.2) THEN
 182             ISTOP = 2
 183             DESTEP = DESTEP + GETOT
 184             GO TO 110
 185          ENDIF
 186          IF (GEKIN .GT. 0.02) THEN
 187             POO=SQRT(EKE*(EKE+2*AM(IJ)))
 188          ELSE
 189             IF ((IJ.EQ.2 .OR. IJ.EQ.9 .OR. IJ.EQ.14 .OR. IJ.EQ.16)
 190      +            .AND. GEKIN .GT. 0.0) THEN
 191                POO=SQRT(EKE*(EKE+2*AM(IJ)))
 192             ELSE
 193                NMEC=NMEC-1
 194                GO TO 110
 195             END IF
 196          END IF
 197          INT=2
 198          IF(NCOMP.LE.1) THEN
 199             AMSS(1) = Q(JMA+6)
 200             ZTAR(1) = Q(JMA+7)
 201             MSSNUM(1) = 0
 202             RHO(1) = Q(JMA+8)
 203          ELSE
 204             CALL GRNDM(RNDM,1)
 205             RCONT=ANXNOR*RNDM(1)
 206             DO 60  I=1,NCOMP
 207                IF(RCONT.LE.CABINX(I)) GO TO 70
 208    60       CONTINUE
 209             I=NCOMP
 210    70       CONTINUE
 211             AMSS(1)   = Q(JMIXT+I)
 212             MSSNUM(1) = 0
 213             ZTAR(1)   = Q(JMIXT+NCOMP+I)
 214             RHO(1)    = Q(JMIXT+2*NCOMP+I)*DENS
 215          END IF
 216          CALL EVENTV(IJ,POO,EKE,TXI,TYI,TZI,WE,1)
 217       END IF
 218 *
 219    80 IF(NP.EQ.1.AND.NPHEAV.EQ.0.AND.KPART(1).EQ.IJ) THEN
 220          VECT(4)=CXR(1)
 221          VECT(5)=CYR(1)
 222          VECT(6)=CZR(1)
 223          VECT(7)=SQRT(TKI(1)*(TKI(1)+2*AMASS))
 224          GETOT=TKI(1)+AMASS
 225          GEKIN=TKI(1)
 226       ELSE
 227          ISTOP=1
 228          NSTAK1 = MIN(NP,MXGKIN-NGKINE)
 229          IF(NP.GT.NSTAK1) THEN
 230             WRITE(CHMAIL,10000) NP-NSTAK1
 231             CALL GMAIL(0,0)
 232          ENDIF
 233          DO 90  K=1,NSTAK1
 234             NGKINE = NGKINE + 1
 235             IF (KPART(K) .EQ. 24 .OR. KPART(K) .EQ. 25) THEN
 236                KPART(K) = 19
 237                CALL GRNDM(RNDM,1)
 238                IF (RNDM(1) .GT. 0.5) KPART(K) = 12
 239             END IF
 240             IGEPAR = IFLTOG(KPART(K))
 241             JPA = LQ(JPART-IGEPAR)
 242             AGEMAS = Q(JPA+7)
 243             PGEANT = SQRT(TKI(K)*(TKI(K)+2*AGEMAS))
 244             GKIN(1,NGKINE)=CXR(K)*PGEANT
 245             GKIN(2,NGKINE)=CYR(K)*PGEANT
 246             GKIN(3,NGKINE)=CZR(K)*PGEANT
 247             GKIN(4,NGKINE)=TKI(K)+AGEMAS
 248             GKIN(5,NGKINE)=IGEPAR
 249             TOFD(NGKINE)=0.0
 250             GPOS(1,NGKINE) = VECT(1)
 251             GPOS(2,NGKINE) = VECT(2)
 252             GPOS(3,NGKINE) = VECT(3)
 253    90    CONTINUE
 254 *
 255          NSTAK2 = MIN(NPHEAV,MXGKIN-NGKINE)
 256          IF(NPHEAV.GT.NSTAK2) THEN
 257             WRITE(CHMAIL,10100) NPHEAV-NSTAK2
 258             CALL GMAIL(0,0)
 259          ENDIF
 260          DO 100 K=1,NSTAK2
 261             NGKINE = NGKINE + 1
 262             IGEPAR = IHVTOG(KHEAVY(K))
 263             JPA = LQ(JPART-IGEPAR)
 264             AGEMAS = Q(JPA+7)
 265             PGEANT = SQRT(TKHEAV(K)*(TKHEAV(K)+2*AGEMAS))
 266             GKIN(1,NGKINE)=CXHEAV(K)*PGEANT
 267             GKIN(2,NGKINE)=CYHEAV(K)*PGEANT
 268             GKIN(3,NGKINE)=CZHEAV(K)*PGEANT
 269             GKIN(4,NGKINE)=TKHEAV(K)+AGEMAS
 270             GKIN(5,NGKINE)=IGEPAR
 271             TOFD(NGKINE)=0.0
 272             GPOS(1,NGKINE) = VECT(1)
 273             GPOS(2,NGKINE) = VECT(2)
 274             GPOS(3,NGKINE) = VECT(3)
 275   100    CONTINUE
 276 *
 277          KCASE=NAMEC(12)
 278       END IF
 279   110 CONTINUE
 280       ZINTHA = GARNDM(DUMMY)
 281       SLHADR = SLENG
 282       STEPHA = 1.0E10
 283 10000 FORMAT(' **** FLUFIN: Stack overflow, ',I6,' particles lost')
 284 10100 FORMAT(' **** FLUFIN: Stack overflow, ',I6,
 285      +' heavy particles lost')
 286   999 END