GEANT321/miface/gmorin.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.3  1996/09/30 14:26:05  ravndal
   6 * Windows NT related modifications
   7 *
   8 * Revision 1.2  1996/04/26 12:21:12  ravndal
   9 * NAP character*20 declaration included
  10 *
  11 * Revision 1.1.1.1  1995/10/24 10:21:52  cernlib
  12 * Geant
  13 *
  14 *
  15 #include "geant321/pilot.h"
  16 *CMZ :  3.21/04 23/02/95  14.53.54  by  S.Giani
  17 *-- Author :    Christian Zeitnitz   21/07/92
  18       SUBROUTINE GMORIN
  19 C**************************************************************
  20 C                  Initialize MICAP
  21 C                  ================
  22 C Called by : CALINI
  23 C
  24 C Purpose : setup cross-section tables and initialize pointer
  25 C           print flags etc.
  26 C
  27 C Author : C.Zeitnitz
  28 C
  29 C last modification: Changed in order to read new x-section file
  30 C
  31 C
  32 C for details see MICAP manual ORNL/TM-10340
  33 C*************************************************************
  34 C MICAP commons
  35 #include "geant321/mmicap.inc"
  36 #include "geant321/mpoint.inc"
  37 #include "geant321/minput.inc"
  38 #include "geant321/mmass.inc"
  39 #include "geant321/mconst.inc"
  40 #include "geant321/cmagic.inc"
  41 #include "geant321/cerrcm.inc"
  42 #include "geant321/camass.inc"
  43 C GEANT common
  44 #include "geant321/gccuts.inc"
  45 #include "geant321/gcflag.inc"
  46 #include "geant321/gcunit.inc"
  47 C pointer to material/mixture bank (NMATE,JMATE)
  48 #include "geant321/gcnum.inc"
  49 C
  50       COMMON / QUEST / IQUEST(100)
  51 C
  52 C  Avogadro number multiplied by 1.E-24
  53       PARAMETER(XNAVO = 0.60221367)
  54 C
  55       DIMENSION A(100),AGEA(100),Z(100),DEN(100),MID(100,2),IDI(20,2)
  56       DIMENSION IPID(0:11)
  57       CHARACTER*100 XSFILE
  58       CHARACTER*4   CNAME
  59       CHARACTER*20  NAP
  60       CHARACTER*70 CCOMM
  61 #if defined(CERNLIB_UNIX)||defined(CERNLIB_CRAY)||defined(CERNLIB_VAX)
  62       CHARACTER*100 CHROOT
  63 #endif
  64       LOGICAL OPENED,EXISTS,FMIST,FSINGL,FMIFL
  65 C GEANT Particle IDs used to extract masses from GEANT
  66       DATA IPID /14 , 13 , 8 , 7 , 9 , 5 , 6 , 45 , 46 , 49 , 47 , 1/
  67 C
  68 C   Initialization flag of GEANT
  69 C   Loop for XMASS extracted from GCALOR routine CALINI  K.L-P
  70 C
  71       IFINIT(7) = 1
  72       DO 5 I=0,11
  73          CALL GFPART(IPID(I),NAP,ITR,AM,CH,TL,UB,NW)
  74          XMASS(I)=AM
  75     5 CONTINUE
  76 C
  77 C  neutron energy cut (eV)
  78       ECUT = CUTNEU * 1.E9
  79 C get time cut off from GEANT
  80       TCUT = TOFMAX
  81 C temperature for thermal neutron xsection (Kelvin)
  82 C only temporary constant !!!
  83       TEMP = 300.0
  84 C xsection file unit
  85       MICROS = 31
  86       IOUT = LOUT
  87       INN  = LIN
  88 C open MICAP I/O units
  89       INQUIRE(UNIT=MICROS,OPENED=OPENED)
  90       IF(OPENED) THEN
  91          REWIND MICROS
  92       ELSE
  93 #if defined(CERNLIB_VAX)
  94          XSFILE='xsneut95.dat'
  95          INQUIRE(FILE=XSFILE,EXIST=EXISTS)
  96          IF(.NOT.EXISTS) THEN
  97             ISTAT = LIB$SYS_TRNLOG('CERN_ROOT',NALL,CHROOT,,,%VAL(0))
  98             IF(ISTAT.EQ.1) XSFILE = 'CERN_ROOT:[LIB]xsneut95.dat'
  99          ENDIF
 100          INQUIRE(FILE=XSFILE,EXIST=EXISTS)
 101          IF(.NOT.EXISTS) THEN
 102            PRINT*,'**********************************'
 103            PRINT*,'*        G C A L O R             *'
 104            PRINT*,'*        -----------             *'
 105            PRINT*,'*  File XSNEUT95.DAT not found   *'
 106            PRINT*,'*         Program STOP           *'
 107            PRINT*,'*   Check CERN_ROOT environment  *'
 108            PRINT*,'*           variable             *'
 109            PRINT*,'**********************************'
 110            STOP
 111          ENDIF
 112          OPEN(UNIT=MICROS,FILE=XSFILE, STATUS='OLD',READONLY)
 113 #endif
 114 #if defined(CERNLIB_UNIX)||defined(CERNLIB_CRAY)
 115          XSFILE = 'xsneut95.dat'
 116          INQUIRE(FILE=XSFILE,EXIST=EXISTS)
 117          IF(.NOT.EXISTS) THEN
 118             CHROOT=' '
 119             CALL GETENV('CERN_ROOT',CHROOT)
 120             LNROOT = LNBLNK(CHROOT)
 121             IF(LNROOT.GT.0)
 122      +      XSFILE = CHROOT(1:LNROOT)//'/lib/xsneut95.dat'
 123          ENDIF
 124          INQUIRE(FILE=XSFILE,EXIST=EXISTS)
 125          IF(.NOT.EXISTS) THEN
 126            PRINT*,'**********************************'
 127            PRINT*,'*        G C A L O R             *'
 128            PRINT*,'*        -----------             *'
 129            PRINT*,'*  File XSNEUT95.DAT not found   *'
 130            PRINT*,'*         Program STOP           *'
 131            PRINT*,'*   Check CERN_ROOT environment  *'
 132            PRINT*,'*           variable             *'
 133            PRINT*,'**********************************'
 134            STOP
 135          ENDIF
 136          OPEN(UNIT=MICROS,FILE=XSFILE,STATUS='OLD')
 137 #endif
 138 #if defined(CERNLIB_MSDOS)||defined(CERNLIB_WINNT)
 139          CHROOT=' '
 140          CALL GETENVF('CERN_ROOT',CHROOT)
 141          LNROOT = LNBLNK(CHROOT)
 142          IF(LNROOT.LE.0) THEN
 143             XSFILE = 'xsneut95.dat'
 144          ELSE
 145             XSFILE = CHROOT(1:LNROOT)//'\\lib\\xsneut95.dat'
 146             INQUIRE(FILE=XSFILE,EXIST=EXISTS)
 147             IF(.NOT.EXISTS) XSFILE='xsneut95.dat'
 148          ENDIF
 149          OPEN(UNIT=MICROS,FILE=XSFILE)
 150 #endif
 151 #if defined(CERNLIB_IBMVM)
 152          XSFILE = '\XSNEUT95 DAT *'
 153          OPEN(UNIT=MICROS,FILE=XSFILE,STATUS='OLD')
 154 #endif
 155       ENDIF
 156 C setup the link areas needed for x-section banks
 157       CALL MZLINK(IXCONS,'MICTMP',LTEMP,LTEMP,LTEMP)
 158       CALL MZLINK(IXCONS,'MMICAP',LMAG2,LMOX4,LMAG2)
 159       CALL MZLINK(IXCONS,'MPOINT',LMAG1,LFP210,LMAG1)
 160 C
 161       LSUP = 0
 162       LCSUP = 0
 163       NUNIT = MICROS
 164 C pointers into TEMP bank
 165       NTUNIT = 1
 166       NTNAME = NTUNIT + 1
 167       NTMPNI = NTNAME + 1 + 80/4
 168       NTCOMM = NTMPNI + 1
 169       NTDATS = NTCOMM + 1 + 80/4
 170       NTLIST = NTDATS + 1 + 24/4
 171    10 CONTINUE
 172 C read comment and date of xsection file
 173         READ(NUNIT,'(A80,/,A24)') COMMEN,DATSTR
 174 C read in material definition array
 175         READ(NUNIT,'(I10)') NISO
 176         NWW = NISO * 3 + 12 + NTLIST
 177 C get temporary buffer
 178         CALL CHKZEB(NWW,IXCONS)
 179         IF(LSUP.EQ.0) Then
 180 C create a top level bank for the list of isotopes
 181           CALL MZBOOK(IXCONS,LTEMP,LSUP,1,'TEMP',3,0,NWW,0,-1)
 182           LT = LTEMP
 183         ELSE
 184 C create an additional bank in the linear structure TEMP
 185           CALL MZBOOK(IXCONS,LT,LSUP,0,'TEMP',3,0,NWW,0,-1)
 186           LSUP = LT
 187         ENDIF
 188         NREC = NISO * 3 / 12
 189         NN = 0
 190 C store the unit number of the file in bank TEMP
 191         IQ(LT + NTUNIT) = NUNIT
 192 C store the file name in bank TEMP
 193         CALL UCTOH(XSFILE,IQ(LT+NTNAME+1),4,LNBLNK(XSFILE))
 194         IQ(LT + NTNAME) = LNBLNK(XSFILE)
 195 C store the comment and date string in bank TEMP
 196         IQ(LT + NTCOMM) = LNBLNK(COMMEN)
 197         CALL UCTOH(COMMEN,IQ(LT+NTCOMM+1),4,LNBLNK(COMMEN))
 198         IQ(LT + NTDATS) = LNBLNK(DATSTR)
 199         CALL UCTOH(DATSTR,IQ(LT+NTDATS+1),4,LNBLNK(DATSTR))
 200         DO 20 I=1,NREC
 201            LL = (I-1)*12 + LT + NTLIST
 202            READ(NUNIT,'(12I6)') (IQ(L),L=LL,LL+11)
 203    20   CONTINUE
 204 C
 205 C get number of comment lines for different isotopes
 206         READ(NUNIT,'(I10)') NCOM
 207         NWW = NCOM * 80 + 2
 208 C get CISO bank
 209         CALL CHKZEB(NWW,IXCONS)
 210         IF(LCSUP.EQ.0) Then
 211 C create a top level bank for the isotope comments
 212           CALL MZBOOK(IXCONS,LCISO,LCSUP,1,'CISO',3,0,NWW,0,-1)
 213           LC = LCISO
 214         ELSE
 215 C create an additional bank in the linear structure CISO
 216           CALL MZBOOK(IXCONS,LC,LCSUP,0,'CISO',3,0,NWW,0,-1)
 217           LCSUP = LC
 218         ENDIF
 219         IQ(LC+1) = NCOM
 220         DO 30 I=1,NCOM
 221            J = (I-1)*81 + 2
 222            READ(NUNIT,'(I4,I4,A70)') IQ(LC+J),IQ(LC+J+1),
 223      +                CCOMM
 224            CALL UCTOH(CCOMM,IQ(LC+J+2),4,70)
 225    30   CONTINUE
 226 C
 227 C---------------------------------------------------------------------
 228 C check the existence of secondary x-section files stored in bank MIFL
 229 C real messy code !!! But its fortran after all !!! CZ Jan 95
 230         XSFILE = ' '
 231         IF(NUNIT.EQ.MICROS) THEN
 232           FMIFL = .FALSE.
 233           CALL MZINQD(IXCONS)
 234           IF(LMIFIL.GE.IQUEST(3) .AND. LMIFIL.LE.IQUEST(4)) THEN
 235              CALL UHTOC(IQ(LMIFIL-4),4,CNAME,4)
 236              IF(CNAME.EQ.'MIFL') FMIFL = .TRUE.
 237           ENDIF
 238           IXSF=LMIFIL
 239         ENDIF
 240         IF(FMIFL) THEN
 241    40     CONTINUE
 242 C get the file name
 243           CALL UHTOC(IQ(IXSF+2),4,XSFILE,IQ(IXSF+1))
 244 C
 245           INQUIRE(FILE=XSFILE,EXIST=EXISTS)
 246           IF(.NOT.EXISTS) THEN
 247              PRINT '(70(''*''))'
 248              PRINT*,' * MICAP : x-section file not found : ',XSFILE
 249              PRINT '(70(''*''))'
 250           ELSE
 251             IXSF = IXSF + 101
 252 C last name in the list ?
 253             IF(IXSF-LMIFIL .GE. IQ(LMIFIL-1) ) FMIFL = .FALSE.
 254 C find a free unit number (greater 31), and use it
 255             DO 50 I=NUNIT+1,99
 256               INQUIRE(UNIT=I,OPENED=OPENED)
 257               IF(.NOT.OPENED) THEN
 258                  NUNIT = I
 259 #if defined(CERNLIB_UNIX)||defined(CERNLIB_CRAY)||defined(CERNLIB_IBMVM)
 260                  OPEN(UNIT=I,FILE=XSFILE,STATUS='OLD')
 261 #endif
 262 #if defined(CERNLIB_VAX)
 263                  OPEN(UNIT=I,FILE=XSFILE,STATUS='OLD',READONLY)
 264 #endif
 265                  GOTO 10
 266               ENDIF
 267    50       CONTINUE
 268             PRINT '(70(''*''))'
 269             PRINT *,'* MICAP : No more free units available !'
 270             PRINT '(70(''*''))'
 271           ENDIF
 272         ENDIF
 273 C---------------------------------------------------------------------
 274       CALL VZERO(MATIDS,4000)
 275       LT = LTEMP
 276    60 CONTINUE
 277         NUNIT = IQ(LT + NTUNIT)
 278         KK = LT + NTLIST
 279         DO 90 I=1,100
 280            NIS = IQ(KK)
 281            KK = KK + 1
 282            IF(NIS.EQ.0) GOTO 100
 283            IF(MATIDS(I,1,1).EQ.0) THEN
 284               MATIDS(I,1,1) = NIS
 285               MATIDS(I,1,2) = NUNIT
 286 C is the Z of the element correct?
 287            ELSE IF(IQ(KK)/1000.EQ.I) THEN
 288 C overwrite existing element with the one stored in new file
 289               DO 70 J=2,MATIDS(I,1,1)+1
 290                 MATIDS(I,J,1) = 0
 291                 MATIDS(I,J,2) = 0
 292    70         CONTINUE
 293               MATIDS(I,1,1) = NIS
 294               MATIDS(I,1,2) = NUNIT
 295            ELSE
 296 C no action
 297               KK = KK + 2 * NIS
 298               GOTO 90
 299            ENDIF
 300 C maximal 20 isotopes per element
 301            NIS = MIN(NIS,20)
 302            DO 80 J=2,NIS+1
 303               MATIDS(I,J,1) = IQ(KK)
 304               MATIDS(I,J,2) = IQ(KK+1)
 305               KK = KK + 2
 306    80      CONTINUE
 307    90   CONTINUE
 308   100   CONTINUE
 309         LT = LQ(LT)
 310       IF(LT.GT.0) GOTO 60
 311 C
 312 C       DEFINE CROSS SECTION DIMENSIONING VARIABLES
 313 C         NNR EQUALS THE NUMBER OF NEUTRON RECORDS
 314 C         NQ EQUALS THE NUMBER OF Q VALUES
 315 C         NGR EQUALS THE NUMBER OF GAMMA RECORDS
 316 C       SET THE DEFAULT VALUES FOR THE CURRENT CROSS SECTION DATA
 317       NNR=134
 318       NQ=66
 319       NGR=60
 320 C
 321 C       SET THE DEFAULT VALUES FOR THE NEUTRON, PROTON, DEUTERON,
 322 C       TRITON, HELIUM-3, AND ALPHA PARTICLE MASSES (IN EV)
 323       ZN=XMASS(1)*1.E9
 324       ZP=XMASS(0)*1.E9
 325       ZD=XMASS(7)*1.E9
 326       ZT=XMASS(8)*1.E9
 327       ZHE3=XMASS(9)*1.E9
 328       ZA=XMASS(10)*1.E9
 329 C       SET THE DEFAULT VALUES FOR THE NEUTRON, PROTON, DEUTERON,
 330 C       TRITON, HELIUM-3, AND ALPHA PARTICLE MASSES (IN AMU)
 331       XAMU=0.93149432*1.E9
 332       AN=ZN/XAMU
 333       AP=ZP/XAMU
 334       AD=ZD/XAMU
 335       AT=ZT/XAMU
 336       AHE3=ZHE3/XAMU
 337       AA=ZA/XAMU
 338 C now preprocess all materials xs
 339       MEDIA = 0
 340       NMIX = 0
 341       NMAT = 0
 342 #if defined(CERNLIB_MDEBUG)
 343       PRINT *,' MICAP-INI : setup materials '
 344       PRINT '('' NMATE='',I20,'' JMATE='',I20)',NMATE,JMATE
 345       PRINT '('' NTMED='',I20,'' JTMED='',I20)',NTMED,JTMED
 346 #endif
 347 C Check if material option bank MIST exists
 348       FMIST = .FALSE.
 349       CALL MZINQD(IXCONS)
 350       IF(LMIST.GE.IQUEST(3) .AND. LMIST.LE.IQUEST(4)) THEN
 351          CALL UHTOC(IQ(LMIST-4),4,CNAME,4)
 352          IF(CNAME.EQ.'MIST') FMIST = .TRUE.
 353       ENDIF
 354 C 1. loop over tracking media -> get NMIX,MEDIA
 355       DO 140 I=1,NTMED
 356          JTM = LQ(JTMED - I)
 357          IF(JTM.LE.0) GOTO 140
 358 C valid tracking medium found get material number
 359 C and get corresponding material parameters from JMATE structure
 360          IMA = INT(Q(JTM+6))
 361          IF(IMA.LE.0 .OR. IMA.GT.NMATE) GOTO 140
 362 C count number of elements and number of mixing operations
 363          JMA = LQ(JMATE-IMA)
 364          IF(JMA.LE.0) GOTO 140
 365          IF(Q(JMA+6) .LE. 1.0 .OR. Q(JMA+6) .GE. 240.) GOTO 140
 366 C Check if for material IMA single isotopes are selected
 367          FSINGL = .FALSE.
 368          IF(FMIST) THEN
 369            DO 110 KIM=1,IQ(LMIST-1),2
 370               IF(IMA.EQ.IQ(LMIST+KIM).AND.IQ(LMIST+KIM+1).EQ.0) THEN
 371                  FSINGL = .TRUE.
 372                  GOTO 120
 373               ENDIF
 374   110      CONTINUE
 375   120      CONTINUE
 376          ENDIF
 377 C get number of elements in material max = 100
 378          KK = MIN(ABS(Q(JMA+11)),100.)
 379 C relation between MICAP and GEANT material number
 380          MEDIA = MEDIA + 1
 381 C mixture ?
 382          KK1 = KK
 383          IF(KK.GT.1) THEN
 384             JMIXT = LQ(JMA - 5)
 385 C
 386 C check if more than one isotope has to taken into account for all
 387 C elements in the mixture
 388             DO 130 K=1,KK
 389                IA = NINT(Q(JMIXT+K))
 390                IZ = NINT(Q(JMIXT+K+KK))
 391                CALL MATISO(IZ,IA,NNI,IDI,FSINGL,NUNIT)
 392                KK1 = KK1 + NNI - 1
 393   130       CONTINUE
 394          ELSE
 395             IA  = NINT(Q(JMA+6))
 396             IZ  = NINT(Q(JMA+7))
 397             CALL MATISO(IZ,IA,NNI,IDI,FSINGL,NUNIT)
 398             KK1 = KK1 + NNI - 1
 399          ENDIF
 400          NMIX = NMIX + KK1
 401   140 CONTINUE
 402 C allocate ZEBRA bank for material information
 403       NW = 9 * NMIX + MEDIA + 10
 404 C define link area for MICAP banks in GCBANK
 405       CALL CHKZEB(NW,IXCONS)
 406       CALL MZBOOK(IXCONS,LMOMA,0,2,'MOME',0,0,NW,0,-1)
 407       LMAG1 = LMOMA + 1
 408       IQ(LMAG1) = NMAGIC
 409       LGE2MO = LMAG1  + 1
 410       LFP10  = LGE2MO + MEDIA + 1
 411       LFP11  = LFP10  + NMIX
 412       LFP12  = LFP11  + NMIX
 413       LFP13  = LFP12  + NMIX
 414       LFP14  = LFP13  + NMIX
 415       LFP140 = LFP14  + NMIX
 416       LFP16  = LFP140 + NMIX
 417       LFP17  = LFP16  + NMIX
 418 C 2. loop over tracking media
 419       MEDIA1 = 0
 420       NMIX1 = 0
 421       DO 230 I=1,NTMED
 422          JTM = LQ(JTMED - I)
 423          IF(JTM.LE.0) GOTO 230
 424 C valid tracking medium found get material number
 425 C and get corresponding material parameters from JMATE structure
 426          IMA = INT(Q(JTM+6))
 427 #if defined(CERNLIB_MDEBUG)
 428          PRINT '('' IMATE ='',I10)',IMA
 429 #endif
 430          IF(IMA.LE.0 .OR. IMA.GT.NMATE) GOTO 230
 431 C count number of elements and number of mixing operations
 432          JMA = LQ(JMATE-IMA)
 433          IF(JMA.LE.0) GOTO 230
 434          IF(Q(JMA+6) .LE. 1.0 .OR. Q(JMA+6) .GE. 240.) GOTO 230
 435 C Check if for material IMA single isotopes are selected
 436          FSINGL = .FALSE.
 437          IF(FMIST) THEN
 438            DO 150 KIM=1,IQ(LMIST-1),2
 439               IF(IMA.EQ.IQ(LMIST+KIM).AND.IQ(LMIST+KIM+1).EQ.0) THEN
 440                  FSINGL = .TRUE.
 441                  GOTO 160
 442               ENDIF
 443   150      CONTINUE
 444   160      CONTINUE
 445          ENDIF
 446          NMAT = NMAT + 1
 447 C get number of elements in material max = 100
 448          RHO1 = Q(JMA+8)
 449          KK = MIN1(ABS(Q(JMA+11)),100.)
 450 C relation between MICAP and GEANT material number
 451 C check if medium IMA already stored (multiple tracking media)
 452          CALL VZERO(AGEA,100)
 453          DO 180 KMI=1,MEDIA1
 454             IF(IQ(LGE2MO+KMI).EQ.IMA) THEN
 455                IF(KK.EQ.1) THEN
 456                   IA  = NINT(Q(JMA+6))
 457                   IZ  = NINT(Q(JMA+7))
 458                   CALL MATISO(IZ,IA,NNI,IDI,FSINGL,NUNIT)
 459                   NMIX = NMIX - NNI
 460                ELSE
 461                   JMIXT = LQ(JMA - 5)
 462                   DO 170 K=1,KK
 463                      IA = NINT(Q(JMIXT+K))
 464                      IZ = NINT(Q(JMIXT+K+KK))
 465                      CALL MATISO(IZ,IA,NNI,IDI,FSINGL,NUNIT)
 466                      NMIX  = NMIX - NNI
 467   170             CONTINUE
 468                ENDIF
 469                MEDIA = MEDIA - 1
 470                GOTO 230
 471             ENDIF
 472   180    CONTINUE
 473          MEDIA1 = MEDIA1 + 1
 474          IQ(LGE2MO+MEDIA1) = IMA
 475 C mixture ?
 476          KK2 = KK
 477          IF(KK.GT.1) THEN
 478             JMIXT = LQ(JMA - 5)
 479             KPOS = 1
 480             DO 200 K=1,KK
 481                AMOL = Q(LQ(JMIXT-1) + 2)
 482                XMOLCM = RHO1/AMOL*XNAVO
 483                IA = NINT(Q(JMIXT+K))
 484                IZ = NINT(Q(JMIXT+K+KK))
 485                CALL MATISO(IZ,IA,NNI,IDI,FSINGL,NUNIT)
 486                KK2 = KK2 + NNI - 1
 487                DO 190 KJ=1,NNI
 488                   KKPOS = KPOS + KJ - 1
 489                   IF(KJ.EQ.1) THEN
 490                      AGEA(KKPOS) = Q(JMIXT+K)
 491                   ELSE
 492                      AGEA(KKPOS) = 0.
 493                   ENDIF
 494                   MID(KKPOS,1) = IDI(KJ,1)
 495                   MID(KKPOS,2) = NUNIT
 496                   IIZ = IDI(KJ,1)/1000
 497                   IIA = IDI(KJ,1) - IIZ * 1000
 498                   IF(IIA.NE.0 .AND. NNI.GT.1.) THEN
 499                     A(KKPOS) = FLOAT(IIA)
 500                   ELSE
 501                     A(KKPOS) = Q(JMIXT+K)
 502                   ENDIF
 503                   Z(KKPOS) =  Q(JMIXT+K+KK)
 504                   WISO = FLOAT(IDI(KJ,2))/100.
 505                   WI = Q(JMIXT+K+2*KK)*AMOL/A(KKPOS)*WISO
 506                   DEN(KKPOS) = XMOLCM * WI
 507 #if defined(CERNLIB_MDEBUG)
 508                   PRINT '('' MIXT: El #'',I3,'' A,Z :'',2F10.2,
 509      +                    '' Rho='',F10.2,'' Den ='',F10.5)',
 510      +                       KJ,A(KJ),Z(KJ),RHO1,DEN(KJ)
 511 #endif
 512   190          CONTINUE
 513                KPOS = KPOS + NNI
 514   200       CONTINUE
 515 C element or compound
 516          ELSE
 517             IA  = NINT(Q(JMA+6))
 518             IZ  = NINT(Q(JMA+7))
 519             CALL MATISO(IZ,IA,NNI,IDI,FSINGL,NUNIT)
 520             KK2 = KK2 + NNI - 1
 521             DO 210 KJ=1,NNI
 522                IF(KJ.EQ.1) THEN
 523                   AGEA(KJ) = Q(JMA+6)
 524                ELSE
 525                   AGEA(KJ) = 0.
 526                ENDIF
 527                MID(KJ,1) = IDI(KJ,1)
 528                MID(KJ,2) = NUNIT
 529                IIZ = IDI(KJ,1)/1000
 530                IIA = IDI(KJ,1) - IIZ * 1000
 531                IF(IIA.NE.0 .AND. NNI.GT.1.) THEN
 532                   A(KJ) = FLOAT(IIA)
 533                ELSE
 534                   A(KJ) = Q(JMA+6)
 535                ENDIF
 536                Z(KJ) =  Q(JMA+7)
 537                WISO = FLOAT(IDI(KJ,2))/100.
 538                DEN(KJ) = RHO1/A(KJ) * WISO *XNAVO
 539 #if defined(CERNLIB_MDEBUG)
 540                PRINT '('' ELEM: Iso #'',I3,'' A,Z :'',2F10.2,
 541      +                 '' Rho='',F10.2,'' Den ='',F10.5)',
 542      +                  KJ,A(KJ),Z(KJ),RHO1,DEN(KJ)
 543 #endif
 544   210       CONTINUE
 545          ENDIF
 546 C
 547 C fill MICAP material arrays
 548 C actual number of isotopes given by KK2
 549 C
 550          DO 220 J = NMIX1 + 1, NMIX1 + KK2
 551             IQ(LFP10+J-1) = MEDIA1
 552             IQ(LFP11+J-1) = MID(J-NMIX1,1)
 553 C check if bound hydrogen has been selected
 554             IF(NINT(Z(J-NMIX1)).EQ.1.AND.KK.GT.1) IQ(LFP11+J-1) = 1000
 555             Q(LFP12+J-1) = DEN(J-NMIX1)
 556             IQ(LFP13+J-1) = NINT(Z(J-NMIX1))
 557             Q(LFP14+J-1) = A(J-NMIX1)
 558             Q(LFP140+J-1) = AGEA(J-NMIX1)
 559   220    CONTINUE
 560          NMIX1 = NMIX1 + KK2
 561   230 CONTINUE
 562       IF(NMIX.LE.0) THEN
 563          PRINT *,' GCALOR: NO tracking media found ===> STOP '
 564          STOP
 565       ENDIF
 566 C read cross-sections and perform mixing and thinning
 567       CALL MOXSEC
 568 C close MICAP cross-section file(s)
 569       LT = LTEMP
 570   240 CONTINUE
 571         CLOSE(UNIT=IQ(LT+NTUNIT))
 572         LT = LQ(LT)
 573       IF(LT.GT.0) GOTO 240
 574 C Drop temporary linear structures
 575       CALL MZDROP(IXCONS,LTEMP,'L')
 576       CALL MZDROP(IXCONS,LCISO,'L')
 577       RETURN
 578       END