GEANT321/fluka/incini.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.1.1.1  1995/10/24 10:19:57  cernlib
   6 * Geant
   7 *
   8 *
   9 #include "geant321/pilot.h"
  10 *CMZ :  3.21/02 29/03/94  15.41.43  by  S.Giani
  11 *-- Author :
  12 *=== incini ===========================================================*
  13 *                                                                      *
  14       SUBROUTINE INCINI
  15
  16 #include "geant321/dblprc.inc"
  17 #include "geant321/dimpar.inc"
  18 #include "geant321/iounit.inc"
  19 *
  20 *----------------------------------------------------------------------*
  21 *                                                                      *
  22 *     Created on  10  june  1990   by    Alfredo Ferrari & Paola Sala  *
  23 *                                                   Infn - Milan       *
  24 *                                                                      *
  25 *     Last change on 14-apr-93     by    Alfredo Ferrari               *
  26 *                                                                      *
  27 *                                                                      *
  28 *----------------------------------------------------------------------*
  29 *
  30       PARAMETER ( PI = PIPIPI )
  31 #include "geant321/fheavy.inc"
  32 #include "geant321/inpdat2.inc"
  33 #include "geant321/inpflg.inc"
  34 #include "geant321/nucdat.inc"
  35 #include "geant321/parevt.inc"
  36       COMMON / FKNUCO / HELP (2), HHLP (2), FTVTH (2), FINCX (2),
  37      &                  EKPOLD (2), BBOLD, ZZOLD, SQROLD, ASEASQ,
  38      &                  FSPRED, FEX0RD
  39       BBOLD  = - 1.D+10
  40       ZZOLD  = - 1.D+10
  41       SQROLD = - 1.D+10
  42       APFRMX = PLABRC * ( 9.D+00 * PI / 8.D+00 )**0.3333333333333333D+00
  43      &       / R0NUCL
  44       AMNUCL (1) = AMPROT
  45       AMNUCL (2) = AMNEUT
  46       AMNUSQ (1) = AMPROT * AMPROT
  47       AMNUSQ (2) = AMNEUT * AMNEUT
  48       AMNHLP = 0.5D+00 * ( AMNUCL (1) + AMNUCL (2) )
  49       ASQHLP = AMNHLP**2
  50 *     ASQHLP = 0.5D+00 * ( AMNUSQ (1) + AMNUSQ (2) )
  51       AEFRMX = SQRT ( ASQHLP + APFRMX**2 ) - AMNHLP
  52       AEFRMA = 0.3D+00 * APFRMX**2 / AMNHLP * ( 1.D+00 - APFRMX**2 /
  53      &         ( 5.6D+00 * ASQHLP ) )
  54       AV0WEL = AEFRMX + EBNDAV
  55       EBNDNG (1) = EBNDAV
  56       EBNDNG (2) = EBNDAV
  57       AEXC12 = 0.001D+00 * FKENER ( ONEONE*12, SIXSIX )
  58       CEXC12 = 0.001D+00 * ENRG   ( ONEONE*12, SIXSIX )
  59       AMMC12 = 12.D+00 * AMUAMU + AEXC12
  60       AMNC12 = AMMC12 - 6.D+00 * AMELEC +
  61      &         FERTHO * 6.D+00**EXPEBN
  62       AEXO16 = 0.001D+00 * FKENER ( ONEONE*16, EIGEIG )
  63       CEXO16 = 0.001D+00 * ENRG   ( ONEONE*16, EIGEIG )
  64       AMMO16 = 16.D+00 * AMUAMU + AEXO16
  65       AMNO16 = AMMO16 - 8.D+00 * AMELEC +
  66      &         FERTHO * 8.D+00**EXPEBN
  67       AEXS28 = 0.001D+00 * FKENER ( ONEONE*28, ONEONE*14 )
  68       CEXS28 = 0.001D+00 * ENRG   ( ONEONE*28, ONEONE*14 )
  69       AMMS28 = 28.D+00 * AMUAMU + AEXS28
  70       AMNS28 = AMMS28 - 14.D+00 * AMELEC +
  71      &         FERTHO * 14.D+00**EXPEBN
  72       AEXC40 = 0.001D+00 * FKENER ( ONEONE*40, ONEONE*20 )
  73       CEXC40 = 0.001D+00 * ENRG   ( ONEONE*40, ONEONE*20 )
  74       AMMC40 = 40.D+00 * AMUAMU + AEXC40
  75       AMNC40 = AMMC40 - 20.D+00 * AMELEC +
  76      &         FERTHO * 20.D+00**EXPEBN
  77       AEXF56 = 0.001D+00 * FKENER ( ONEONE*56, ONEONE*26 )
  78       CEXF56 = 0.001D+00 * ENRG   ( ONEONE*56, ONEONE*26 )
  79       AMMF56 = 56.D+00 * AMUAMU + AEXF56
  80       AMNF56 = AMMF56 - 26.D+00 * AMELEC +
  81      &         FERTHO * 26.D+00**EXPEBN
  82       AEX107 = 0.001D+00 * FKENER ( ONEONE*107, ONEONE*47 )
  83       CEX107 = 0.001D+00 * ENRG   ( ONEONE*107, ONEONE*47 )
  84       AMM107 = 107.D+00 * AMUAMU + AEX107
  85       AMN107 = AMM107 - 47.D+00 * AMELEC +
  86      &         FERTHO * 47.D+00**EXPEBN
  87       AEX132 = 0.001D+00 * FKENER ( ONEONE*132, ONEONE*54 )
  88       CEX132 = 0.001D+00 * ENRG   ( ONEONE*132, ONEONE*54 )
  89       AMM132 = 132.D+00 * AMUAMU + AEX132
  90       AMN132 = AMM132 - 54.D+00 * AMELEC +
  91      &         FERTHO * 54.D+00**EXPEBN
  92       AEX181 = 0.001D+00 * FKENER ( ONEONE*181, ONEONE*73 )
  93       CEX181 = 0.001D+00 * ENRG   ( ONEONE*181, ONEONE*73 )
  94       AMM181 = 181.D+00 * AMUAMU + AEX181
  95       AMN181 = AMM181 - 73.D+00 * AMELEC +
  96      &         FERTHO * 73.D+00**EXPEBN
  97       AEX208 = 0.001D+00 * FKENER ( ONEONE*208, ONEONE*82 )
  98       CEX208 = 0.001D+00 * ENRG   ( ONEONE*208, ONEONE*82 )
  99       AMM208 = 208.D+00 * AMUAMU + AEX208
 100       AMN208 = AMM208 - 82.D+00 * AMELEC +
 101      &         FERTHO * 82.D+00**EXPEBN
 102       AEX238 = 0.001D+00 * FKENER ( ONEONE*238, ONEONE*92 )
 103       CEX238 = 0.001D+00 * ENRG   ( ONEONE*238, ONEONE*92 )
 104       AMM238 = 238.D+00 * AMUAMU + AEX238
 105       AMN238 = AMM238 - 92.D+00 * AMELEC +
 106      &         FERTHO * 92.D+00**EXPEBN
 107 #if defined(CERNLIB_FDEBUG)
 108       WRITE ( LUNOUT,* )
 109       WRITE ( LUNOUT,* )
 110       WRITE ( LUNOUT,* )' **** Maximum Fermi momentum  : ',REAL(APFRMX),
 111      &                  ' GeV/c ****'
 112       WRITE ( LUNOUT,* )
 113       WRITE ( LUNOUT,* )' **** Maximum Fermi energy    : ',REAL(AEFRMX),
 114      &                  ' GeV   ****'
 115       WRITE ( LUNOUT,* )
 116       WRITE ( LUNOUT,* )' **** Average Fermi energy    : ',REAL(AEFRMA),
 117      &                  ' GeV   ****'
 118       WRITE ( LUNOUT,* )
 119       WRITE ( LUNOUT,* )' **** Average binding energy  : ',REAL(EBNDAV),
 120      &                  ' GeV   ****'
 121       WRITE ( LUNOUT,* )
 122       WRITE ( LUNOUT,* )' **** Nuclear well depth      : ',REAL(AV0WEL),
 123      &                  ' GeV   ****'
 124       WRITE ( LUNOUT,* )
 125       WRITE ( LUNOUT,* )' **** Excess  mass  for 12-C  : ',REAL(AEXC12),
 126      &                  ' GeV   ****'
 127       WRITE ( LUNOUT,* )
 128       WRITE ( LUNOUT,* )' **** Cameron E. m. for 12-C  : ',REAL(CEXC12),
 129      &                  ' GeV   ****'
 130       WRITE ( LUNOUT,* )
 131       WRITE ( LUNOUT,* )' **** Atomic  mass  for 12-C  : ',REAL(AMMC12),
 132      &                  ' GeV   ****'
 133       WRITE ( LUNOUT,* )
 134       WRITE ( LUNOUT,* )' **** Nuclear mass  for 12-C  : ',REAL(AMNC12),
 135      &                  ' GeV   ****'
 136       WRITE ( LUNOUT,* )
 137       WRITE ( LUNOUT,* )' **** Excess  mass  for 16-O  : ',REAL(AEXO16),
 138      &                  ' GeV   ****'
 139       WRITE ( LUNOUT,* )
 140       WRITE ( LUNOUT,* )' **** Cameron E. m. for 16-O  : ',REAL(CEXO16),
 141      &                  ' GeV   ****'
 142       WRITE ( LUNOUT,* )
 143       WRITE ( LUNOUT,* )' **** Atomic  mass  for 16-O  : ',REAL(AMMO16),
 144      &                  ' GeV   ****'
 145       WRITE ( LUNOUT,* )
 146       WRITE ( LUNOUT,* )' **** Nuclear mass  for 16-O  : ',REAL(AMNO16),
 147      &                  ' GeV   ****'
 148       WRITE ( LUNOUT,* )
 149       WRITE ( LUNOUT,* )' **** Excess  mass  for 40-Ca : ',REAL(AEXC40),
 150      &                  ' GeV   ****'
 151       WRITE ( LUNOUT,* )
 152       WRITE ( LUNOUT,* )' **** Cameron E. m. for 40-Ca : ',REAL(CEXC40),
 153      &                  ' GeV   ****'
 154       WRITE ( LUNOUT,* )
 155       WRITE ( LUNOUT,* )' **** Atomic  mass  for 40-Ca : ',REAL(AMMC40),
 156      &                  ' GeV   ****'
 157       WRITE ( LUNOUT,* )
 158       WRITE ( LUNOUT,* )' **** Nuclear mass  for 40-Ca : ',REAL(AMNC40),
 159      &                  ' GeV   ****'
 160       WRITE ( LUNOUT,* )
 161       WRITE ( LUNOUT,* )' **** Excess  mass  for 56-Fe : ',REAL(AEXF56),
 162      &                  ' GeV   ****'
 163       WRITE ( LUNOUT,* )
 164       WRITE ( LUNOUT,* )' **** Cameron E. m. for 56-Fe : ',REAL(CEXF56),
 165      &                  ' GeV   ****'
 166       WRITE ( LUNOUT,* )
 167       WRITE ( LUNOUT,* )' **** Atomic  mass  for 56-Fe : ',REAL(AMMF56),
 168      &                  ' GeV   ****'
 169       WRITE ( LUNOUT,* )
 170       WRITE ( LUNOUT,* )' **** Nuclear mass  for 56-Fe : ',REAL(AMNF56),
 171      &                  ' GeV   ****'
 172       WRITE ( LUNOUT,* )
 173       WRITE ( LUNOUT,* )' **** Excess  mass  for 107-Ag: ',REAL(AEX107),
 174      &                  ' GeV   ****'
 175       WRITE ( LUNOUT,* )
 176       WRITE ( LUNOUT,* )' **** Cameron E. m. for 107-Ag: ',REAL(CEX107),
 177      &                  ' GeV   ****'
 178       WRITE ( LUNOUT,* )
 179       WRITE ( LUNOUT,* )' **** Atomic  mass  for 107-Ag: ',REAL(AMM107),
 180      &                  ' GeV   ****'
 181       WRITE ( LUNOUT,* )
 182       WRITE ( LUNOUT,* )' **** Nuclear mass  for 107-Ag: ',REAL(AMN107),
 183      &                  ' GeV   ****'
 184       WRITE ( LUNOUT,* )
 185       WRITE ( LUNOUT,* )' **** Excess  mass  for 132-Xe: ',REAL(AEX132),
 186      &                  ' GeV   ****'
 187       WRITE ( LUNOUT,* )
 188       WRITE ( LUNOUT,* )' **** Cameron E. m. for 132-Xe: ',REAL(CEX132),
 189      &                  ' GeV   ****'
 190       WRITE ( LUNOUT,* )
 191       WRITE ( LUNOUT,* )' **** Atomic  mass  for 132-Xe: ',REAL(AMM132),
 192      &                  ' GeV   ****'
 193       WRITE ( LUNOUT,* )
 194       WRITE ( LUNOUT,* )' **** Nuclear mass  for 132-Xe: ',REAL(AMN132),
 195      &                  ' GeV   ****'
 196       WRITE ( LUNOUT,* )
 197       WRITE ( LUNOUT,* )' **** Excess  mass  for 181-Ta: ',REAL(AEX181),
 198      &                  ' GeV   ****'
 199       WRITE ( LUNOUT,* )
 200       WRITE ( LUNOUT,* )' **** Cameron E. m. for 181-Ta: ',REAL(CEX181),
 201      &                  ' GeV   ****'
 202       WRITE ( LUNOUT,* )
 203       WRITE ( LUNOUT,* )' **** Atomic  mass  for 181-Ta: ',REAL(AMM181),
 204      &                  ' GeV   ****'
 205       WRITE ( LUNOUT,* )
 206       WRITE ( LUNOUT,* )' **** Nuclear mass  for 181-Ta: ',REAL(AMN181),
 207      &                  ' GeV   ****'
 208       WRITE ( LUNOUT,* )
 209       WRITE ( LUNOUT,* )' **** Excess  mass  for 208-Pb: ',REAL(AEX208),
 210      &                  ' GeV   ****'
 211       WRITE ( LUNOUT,* )
 212       WRITE ( LUNOUT,* )' **** Cameron E. m. for 208-Pb: ',REAL(CEX208),
 213      &                  ' GeV   ****'
 214       WRITE ( LUNOUT,* )
 215       WRITE ( LUNOUT,* )' **** Atomic  mass  for 208-Pb: ',REAL(AMM208),
 216      &                  ' GeV   ****'
 217       WRITE ( LUNOUT,* )
 218       WRITE ( LUNOUT,* )' **** Nuclear mass  for 208-Pb: ',REAL(AMN208),
 219      &                  ' GeV   ****'
 220       WRITE ( LUNOUT,* )
 221       WRITE ( LUNOUT,* )' **** Excess  mass  for 238-U : ',REAL(AEX238),
 222      &                  ' GeV   ****'
 223       WRITE ( LUNOUT,* )
 224       WRITE ( LUNOUT,* )' **** Cameron E. m. for 238-U : ',REAL(CEX238),
 225      &                  ' GeV   ****'
 226       WRITE ( LUNOUT,* )
 227       WRITE ( LUNOUT,* )' **** Atomic  mass  for 238-U : ',REAL(AMM238),
 228      &                  ' GeV   ****'
 229       WRITE ( LUNOUT,* )
 230       WRITE ( LUNOUT,* )' **** Nuclear mass  for 238-U : ',REAL(AMN238),
 231      &                  ' GeV   ****'
 232       WRITE ( LUNOUT,* )
 233 #endif
 234       AMHEAV (1) = AMUAMU + 1.D-03 * FKENER ( ONEONE, ZERZER )
 235       AMHEAV (2) = AMUAMU + 1.D-03 * FKENER ( ONEONE, ONEONE )
 236       AMHEAV (3) = 2.D+00 * AMUAMU + 1.D-03 * FKENER ( TWOTWO, ONEONE )
 237       AMHEAV (4) = 3.D+00 * AMUAMU + 1.D-03 * FKENER ( THRTHR, ONEONE )
 238       AMHEAV (5) = 3.D+00 * AMUAMU + 1.D-03 * FKENER ( THRTHR, TWOTWO )
 239       AMHEAV (6) = 4.D+00 * AMUAMU + 1.D-03 * FKENER ( FOUFOU, TWOTWO )
 240       ELBNDE (0) = 0.D+00
 241       DO 2000 IZ = 1, 100
 242          ELBNDE ( IZ ) = FERTHO *  IZ **EXPEBN
 243 2000  CONTINUE
 244       IF ( LEVPRT ) THEN
 245 #if defined(CERNLIB_FDEBUG)
 246          WRITE ( LUNOUT, * )' **** Evaporation from residual nucleus',
 247      &                      ' activated **** '
 248          IF ( LDEEXG ) WRITE ( LUNOUT, * )' **** Deexcitation gamma',
 249      &                      ' production activated **** '
 250          IF ( LHEAVY ) WRITE ( LUNOUT, * )' **** Evaporated "heavies"',
 251      &                      ' transport activated **** '
 252          IF ( IFISS .GT. 0 )
 253      &                 WRITE ( LUNOUT, * )' **** High Energy fission ',
 254      &                      ' requested & activated **** '
 255 #endif
 256       ELSE
 257          LDEEXG = .FALSE.
 258          LHEAVY = .FALSE.
 259          IFISS  = 0
 260       END IF
 261       RETURN
 262 *=== End of subroutine incini =========================================*
 263       END