GEANT321/gcons/gprmat.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.1.1.1  1995/10/24 10:20:16  cernlib
   6 * Geant
   7 *
   8 *
   9 #include "geant321/pilot.h"
  10 *CMZ :  3.21/04 13/12/94  17.08.38  by  S.Giani
  11 *-- Author :
  12       SUBROUTINE GPRMAT(IMATE,IPART,MECAN,KDIN,TKIN)
  13 C.
  14 C.    ******************************************************************
  15 C.    *                                                                *
  16 C.    *       INTERPOLATE and PRINT the DE/DX ,stopping range and      *
  17 C.    *       Cross sections tabulated in JMATE banks corresponding to *
  18 C.    *       material IMATE, particle IPART, mecanism name MECAN ,    *
  19 C.    *       kinetic energies TKIN.                                   *
  20 C.    *                                                                *
  21 C.    *      The MECAnism name can be :                                *
  22 C.    *      'HADF'   'INEF'   'ELAF'   'FISF'   'CAPF'                *
  23 C.    *      'HADG'   'INEG'   'ELAG'   'FISG'   'CAPG'                *
  24 C.    *      'LOSS'   'PHOT'   'ANNI'   'COMP'   'BREM'                *
  25 C.    *      'PAIR'   'DRAY'   'PFIS'   'RAYL'   'HADG'                *
  26 C.    *      'MUNU'   'RANG'   'STEP'                                  *
  27 C.    *                                                                *
  28 C.    *       For Hadronic particles it also computes the              *
  29 C.    *       hadronic cross section from FLUKA ( '***F' ) or          *
  30 C.    *       GHEISHA ( '***G' ) programs:                             *
  31 C.    *       HADF or HADG -- total                                    *
  32 C.    *       INEF or INEG -- inelastic                                *
  33 C.    *       ELAF or ELAG -- elastic                                  *
  34 C.    *       FISF or FISG -- fission (0.0 for FLUKA)                  *
  35 C.    *       CAPF or CAPG -- neutron capture (0.0 for FLUKA)          *
  36 C.    *                                                                *
  37 C.    *             Input parameters                                   *
  38 C.    *  IMATE   Geant material number                                 *
  39 C.    *  IPART   Geant particle number                                 *
  40 C.    *  MECAN   mechanism name of the bank to be fetched              *
  41 C.    *  KDIM   dimension of the arrays TKIN , VALUE                   *
  42 C.    *  TKIN   array of kinetic energy of incident particle (in Gev)  *
  43 C.    *                                                                *
  44 C.    *    ==>Called by : <USER>                                       *
  45 C.    *       Authors    R.Brun, M.Maire    *********                  *
  46 C.    *                                                                *
  47 C.    ******************************************************************
  48 C.
  49 #include "geant321/gcbank.inc"
  50 #include "geant321/gcnum.inc"
  51 #include "geant321/gcunit.inc"
  52       PARAMETER (MMX=100)
  53       CHARACTER*(*) MECAN
  54       CHARACTER*4  MECA
  55       CHARACTER*4  KU1 , KU2 , KU3 , KU(5)
  56       DIMENSION   TKIN(KDIN),VALUE(MMX),SIGT(MMX),PCUT(5),CU(5)
  57 *
  58 #include "geant321/gcnmec.inc"
  59 *
  60 *     ------------------------------------------------------------------
  61 *
  62       KDIM = MIN(KDIN,MMX)
  63       IF (KDIM.LE.0) GO TO 999
  64 *
  65       IF (JMATE.LE.0) GO TO 999
  66       IF (IMATE.LE.0) GO TO 999
  67       IF (IMATE.GT.NMATE) GO TO 90
  68       JMA = LQ(JMATE-IMATE)
  69       IF (JMA.LE.0) GO TO 90
  70 *
  71       IF (JPART.LE.0) GO TO 999
  72       IF (IPART.LE.0) GO TO 999
  73       IF (IPART.GT.NPART) GO TO 90
  74       JPA = LQ(JPART-IPART)
  75       IF (JPA.LE.0) GO TO 90
  76 *
  77       DO 10 JSIG=1,MMX
  78          SIGT(JSIG)=0.
  79    10 CONTINUE
  80       IF(MECAN.EQ.'ALL') THEN
  81          N1 = 1
  82          N2 = NMECA
  83       ELSE
  84          N1 = 0
  85          DO 20  IMECA=1,NMECA
  86             IF(MECAN.EQ.CHNMEC(IMECA)) THEN
  87                N1 = IMECA
  88             ENDIF
  89    20    CONTINUE
  90          IF(N1.EQ.0) THEN
  91             WRITE(CHMAIL,'('' *** GPRMAT: Mechanism '',A,
  92      +      '' not implemented'')') MECAN
  93             CALL GMAIL(0,0)
  94             GOTO 999
  95          ENDIF
  96          N2 = N1
  97       ENDIF
  98       DO 60  IMEC = N1,N2
  99          IF(CHNMEC(IMEC).NE.'NULL') THEN
 100             MECA = CHNMEC(IMEC)
 101             CALL GFTMAT(IMATE,IPART,MECA,KDIM,TKIN,VALUE,PCUT,IXST)
 102             IF(IXST.EQ.0) GO TO 60
 103             CHMAIL='1'
 104             CALL GMAIL(0,0)
 105             WRITE(CHMAIL,10100)(IQ(JMA+I),I=1,5),MECA,(IQ(JPA+J),J=1,5)
 106             CALL GMAIL(0,0)
 107             CHMAIL(31:)='-----------------------------------------'
 108             CALL GMAIL(0,1)
 109             CHMAIL=' '
 110             DO 30  K=1,5
 111    30       CALL GEVKEV(PCUT(K),CU(K),KU(K))
 112             WRITE(CHMAIL,10200) (CU(K),KU(K),K=1,5)
 113             CALL GMAIL(0,1)
 114 *
 115             IF (MECA.EQ.'LOSS'.OR.MECA.EQ.'RANG'.OR.MECA.EQ.'STEP')
 116      +      THEN
 117                IF (MECA.EQ.'LOSS') WRITE(CHMAIL,10300)
 118                IF (MECA.EQ.'RANG') WRITE(CHMAIL,10400)
 119                IF (MECA.EQ.'STEP') WRITE(CHMAIL,10500)
 120                CALL GMAIL(0,1)
 121                NROW = (KDIM-1)/3 + 1
 122                DO 40  IKB=1,NROW
 123                   IK = IKB
 124                   DE1 = VALUE(IK)
 125                   CALL GEVKEV(TKIN(IK),EK1,KU1)
 126 *
 127                   IK = IKB + NROW
 128                   IF (IK.GT.KDIM) IK=KDIM
 129                   DE2 = VALUE(IK)
 130                   CALL GEVKEV(TKIN(IK),EK2,KU2)
 131 *
 132                   IK = IKB + 2*NROW
 133                   IF (IK.GT.KDIM) IK=KDIM
 134                   DE3 = VALUE(IK)
 135                   CALL GEVKEV(TKIN(IK),EK3,KU3)
 136 *
 137                   WRITE(CHMAIL,10600) EK1,KU1,DE1,EK2,KU2,DE2,EK3,KU3,
 138      +            DE3
 139                   CALL GMAIL(0,0)
 140    40          CONTINUE
 141             ELSE
 142                WRITE(CHMAIL,10700)
 143                CALL GMAIL(0,1)
 144                NROW = (KDIM-1)/2 + 1
 145                DO 50  IKB=1,NROW
 146                   IK = IKB
 147                   SIG1 = VALUE(IK)
 148                   AL1=0.
 149                   IF(SIG1.NE.0.)AL1 = 1./SIG1
 150                   SIGT(IK) = SIGT(IK) + SIG1
 151                   CALL GEVKEV(TKIN(IK),EK1,KU1)
 152 *
 153                   IK = IKB + NROW
 154                   IF (IK.GT.KDIM) IK=KDIM
 155                   SIG2 = VALUE(IK)
 156                   AL2=0.
 157                   IF(SIG2.NE.0.)AL2 = 1./SIG2
 158                   SIGT(IK) = SIGT(IK) + SIG2
 159                   CALL GEVKEV(TKIN(IK),EK2,KU2)
 160 *
 161                   WRITE(CHMAIL,10900) EK1,KU1,SIG1,AL1,EK2,KU2,SIG2,AL2
 162                   CALL GMAIL(0,0)
 163    50          CONTINUE
 164             ENDIF
 165          ENDIF
 166    60 CONTINUE
 167 *
 168 * *** print total cross section
 169       IF (MECAN.EQ.'ALL') THEN
 170          MECA = 'SIGT'
 171          CHMAIL='1'
 172          CALL GMAIL(0,0)
 173          WRITE(CHMAIL,10100)(IQ(JMA+I),I=1,5),MECA,(IQ(JPA+J),J=1,5)
 174          CALL GMAIL(0,0)
 175          CHMAIL(31:)='-----------------------------------------'
 176          CALL GMAIL(0,1)
 177          CHMAIL=' '
 178          DO 70  K=1,5
 179    70    CALL GEVKEV(PCUT(K),CU(K),KU(K))
 180          WRITE(CHMAIL,10200) (CU(K),KU(K),K=1,5)
 181          CALL GMAIL(0,1)
 182          WRITE(CHMAIL,10800)
 183          CALL GMAIL(0,1)
 184          NROW = (KDIM-1)/2 + 1
 185          DO 80  IKB=1,NROW
 186             IK = IKB
 187             SIG1 = SIGT(IK)
 188             AL1=0.
 189             IF(SIG1.NE.0.)AL1 = 1./SIG1
 190             CALL GEVKEV(TKIN(IK),EK1,KU1)
 191 *
 192             IK = IKB + NROW
 193             IF (IK.GT.KDIM) IK=KDIM
 194             SIG2 = SIGT(IK)
 195             AL2=0.
 196             IF(SIG2.NE.0.)AL2 = 1./SIG2
 197             CALL GEVKEV(TKIN(IK),EK2,KU2)
 198 *
 199             WRITE(CHMAIL,10900) EK1,KU1,SIG1,AL1,EK2,KU2,SIG2,AL2
 200             CALL GMAIL(0,0)
 201    80    CONTINUE
 202       ENDIF
 203 *
 204       GO TO 999
 205 *
 206    90 WRITE(CHMAIL,10000) IMATE ,IPART
 207       CALL GMAIL(0,0)
 208 *
 209 10000 FORMAT(' ***** GPRMAT error : material',I4,
 210      +       '  or particle',I4,' not defined'   )
 211 10100 FORMAT(30X,5A4,A4, ' for  ',5A4)
 212 10200 FORMAT(  6X,'BCUTE =',F6.2,A4,3X,'BCUTM =',F6.2,A4,3X,
 213      +             'DCUTE =',F6.2,A4,3X,'DCUTM =',F6.2,A4,3X,
 214      +            'PPCUTM =',F6.2,A4 )
 215 10300 FORMAT(  6X,'kinetic energy   DE/DX(mev/cm)',
 216      +         6X,'kinetic energy   DE/DX(mev/cm)',
 217      +         6X,'kinetic energy   DE/DX(mev/cm)')
 218 10400 FORMAT(  6X,'kinetic energy   Stop range cm',
 219      +         6X,'kinetic energy   Stop ramge cm',
 220      +         6X,'kinetic energy   Stop range cm')
 221 10500 FORMAT(  6X,'kinetic energy   Mulof step cm',
 222      +         6X,'kinetic energy   Mulof step cm',
 223      +         6X,'kinetic energy   Mulof step cm')
 224 10600 FORMAT( 3(F16.2,A4,E15.4))
 225 10700 FORMAT(  6X,'kinetic energy   Sigma (1/cm)    Lambda (cm)',
 226      +         6X,'kinetic energy   Sigma (1/cm)    Lambda (cm)')
 227 10800 FORMAT(  6X,'kinetic energy   Sigto (1/cm)    Lambda (cm)',
 228      +         6X,'kinetic energy   Sigto (1/cm)    Lambda (cm)')
 229 10900 FORMAT( 2(F16.2,A4,2(E15.4)))
 230   999 END