This commit was generated by cvs2svn to compensate for changes in r2,
[u/mrichter/AliRoot.git] / 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