summaryrefslogtreecommitdiff
path: root/Dragon/src/LIBDRA.f
blob: e846822e56e2a048b6879334892eaa298c288415 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
*DECK LIBDRA
      SUBROUTINE LIBDRA (IPLIB,IPDRL,NAMFIL,NGRO,NBISO,NL,ISONAM,
     1 ISONRF,IPISO,TN,SN,SB,MASKI,NED,HVECT,IMPX,NGF,NGFR,NDEL,NBESP)
*
*-----------------------------------------------------------------------
*
*Purpose:
* Transcription of the useful interpolated microscopic cross section
* data from a microscopic x-section library (draglib format) to LCM
* data structures.
*
*Copyright:
* Copyright (C) 2002 Ecole Polytechnique de Montreal
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
* License as published by the Free Software Foundation; either
* version 2.1 of the License, or (at your option) any later version
*
*Author(s): A. Hebert
*
*Parameters: input
* IPLIB   pointer to the lattice microscopic cross section library
*         (L_LIBRARY signature).
* IPDRL   pointer to the draglib (L_DRAGLIB signature).
* NAMFIL  name of the Dragon library file.
* NGRO    number of energy groups.
* NBISO   number of isotopes present in the calculation domain.
* NL      number of Legendre orders required in the calculation
*         NL=1 or higher.
* ISONAM  alias name of isotopes.
* ISONRF  library name of isotopes.
* IPISO   pointer array towards microlib isotopes.
* TN      temperature of each isotope.
* SN      dilution cross section in each energy group of each
*         isotope. a value of 1.0e10 is used for infinite dilution.
* SB      dilution cross section as used in livolant and jeanpierre
*         normalization.
* MASKI   isotopic mask. Isotope with index I is processed if
*         MASKI(I)=.true.
* NED     number of extra vector edits.
* HVECT   names of the extra vector edits.
* IMPX    print flag.
*
*Parameters: output
* NGF     number of fast groups without self-shielding.
* NGFR    number of fast and resonance groups.
* NDEL    number of precursor groups for delayed neutrons.
* NBESP   number of energy-dependent fission spectra.
*
*-----------------------------------------------------------------------
*
      USE GANLIB
*----
*  SUBROUTINE ARGUMENTS
*----
      PARAMETER(MAXDEL=10,MAXESP=4)
      CHARACTER*(*) HVECT(NED),NAMFIL
      TYPE(C_PTR) IPLIB,IPDRL,IPISO(NBISO)
      INTEGER NGRO,NBISO,NL,ISONAM(3,NBISO),ISONRF(3,NBISO),NED,IMPX,
     1 NGF,NGFR,NDEL,NBESP
      REAL TN(NBISO),SN(NGRO,NBISO),SB(NGRO,NBISO)
      LOGICAL MASKI(NBISO)
*----
*  LOCAL VARIABLES
*----
      CHARACTER CD*4,HSMG*131,HVERS*12,HNISOR*12,HNAMIS*12,HNUSIG*12,
     1 HCHI*12
      PARAMETER (IOUT=6,MAXTMP=50,NOTX=3)
      TYPE(C_PTR) KPLIB
      LOGICAL LSIGF,LGOLD,LOGT,LNZERO
      INTEGER IESP(MAXESP+1)
      DOUBLE PRECISION FACTOR,TERP(MAXTMP),DDELI
      REAL TEMP(MAXTMP),ZLAMB(MAXDEL),EESP(MAXESP+1)
*----
*  ALLOCATABLE ARRAYS
*----
      INTEGER, ALLOCATABLE, DIMENSION(:) :: NFS,ITYPRO
      REAL, ALLOCATABLE, DIMENSION(:) :: AWR,DELTA,TOTAL,GOLD,ZNPHI,
     1 ENER,BIN,EBIN,SIGS2,SCAT2,TOTAL2,SIGF2,CHI2,SADD2,GOLD2,BIN2,
     2 ZNPHI2,CHI4G2
      REAL, ALLOCATABLE, DIMENSION(:,:) :: SIGS,SIGF,CHI,SADD,CHI4G
      REAL, ALLOCATABLE, DIMENSION(:,:,:) :: SCAT
      LOGICAL, ALLOCATABLE, DIMENSION(:) :: LSCAT,LADD
      CHARACTER(LEN=80), ALLOCATABLE, DIMENSION(:) :: HTITLE
*----
*  SCRATCH STORAGE ALLOCATION
*----
      ALLOCATE(NFS(NGRO),ITYPRO(NL))
      ALLOCATE(AWR(NBISO),DELTA(NGRO),SIGS(NGRO,NL),SCAT(NGRO,NGRO,NL),
     1 TOTAL(NGRO),SIGF(NGRO,0:MAXDEL),CHI(NGRO,0:MAXDEL),
     2 SADD(NGRO,NED),ENER(NGRO+1),GOLD(NGRO),ZNPHI(NGRO))
      ALLOCATE(LSCAT(NL),LADD(NED))
*----
*  RECOVER THE GROUP STRUCTURE.
*----
      NGF=NGRO+1
      NGFR=0
      NDEL=0
      HVERS='**UNKNOWN**'
      CALL LCMLEN(IPDRL,'VERSION',LENGT,ITYLCM)
      IF(LENGT.NE.0) CALL LCMGTC(IPDRL,'VERSION',12,HVERS)
      IF(IMPX.GT.0) WRITE (IOUT,900) TRIM(NAMFIL),TRIM(HVERS)
      IF(HVERS.EQ.'RELEASE_2003') THEN
        WRITE(IOUT,'(46H LIBDRA: ***WARNING*** RELEASE_2003 DRAGLIBS A,
     1  15HRE DEPRECIATED.)')
      ENDIF
      CALL LCMLEN(IPDRL,'README',LENGT,ITYLCM)
      IF((IMPX.GT.0).AND.(LENGT.GT.0)) THEN
         LENGT=(LENGT-1)/20+1
         ALLOCATE(HTITLE(LENGT))
         CALL LCMGTC(IPDRL,'README',80,LENGT,HTITLE)
         WRITE (IOUT,940)
         DO 10 J=1,LENGT
         WRITE (IOUT,'(1X,A80)') HTITLE(J)
   10    CONTINUE
         DEALLOCATE(HTITLE)
         WRITE (IOUT,'(40H LIBDRA: NUMBER OF ISOTOPES IN MICROLIB=,I6)')
     1   NBISO
      ENDIF
      CALL LCMLEN(IPDRL,'ENERGY',LENGT,ITYLCM)
      LENGT=LENGT-1
      IF(LENGT.NE.NGRO) CALL XABORT('LIBDRA: INVALID GROUP STRUCTURE.')
      CALL LCMGET(IPDRL,'ENERGY',ENER)
      CALL LCMLEN(IPDRL,'DELTAU',LENGT,ITYLCM)
      IF(LENGT.EQ.NGRO) THEN
         CALL LCMGET(IPDRL,'DELTAU',DELTA)
      ELSE IF(LENGT.EQ.0) THEN
         IF(ENER(NGRO+1).EQ.0.0) ENER(NGRO+1)=1.0E-5
         DO 15 J=1,NGRO
         DELTA(J)=LOG(ENER(J)/ENER(J+1))
   15    CONTINUE
      ENDIF
      CALL LCMPUT(IPLIB,'ENERGY',NGRO+1,2,ENER)
      CALL LCMPUT(IPLIB,'DELTAU',NGRO,2,DELTA)
      CALL LCMLEN(IPDRL,'CHI-LIMITS',NBESP,ITYLCM)
      IF(NBESP.GT.0) THEN
         NBESP=NBESP-1
         IF(NBESP.GT.MAXESP) CALL XABORT('LIBDRA: MAXESP OVERFLOW.')
         CALL LCMGET(IPDRL,'CHI-LIMITS',IESP)
         CALL LCMPUT(IPLIB,'CHI-LIMITS',NBESP+1,1,IESP)
         CALL LCMGET(IPDRL,'CHI-ENERGY',EESP)
         CALL LCMPUT(IPLIB,'CHI-ENERGY',NBESP+1,2,EESP)
      ENDIF
      ALLOCATE(CHI4G(NGRO,NBESP))
*----
*  READ THROUGH DRAGON FILE AND ACCUMULATE CROSS SECTIONS FOR THIS RANGE
*  OF MATS, LEGENDRE ORDERS, AND GROUPS.
*----
      DO 400 IMX=1,NBISO
      IF(MASKI(IMX)) THEN
         WRITE(HNAMIS,'(3A4)') (ISONAM(I0,IMX),I0=1,3)
         WRITE(HNISOR,'(3A4)') (ISONRF(I0,IMX),I0=1,3)
         CALL LCMLEN(IPDRL,HNISOR,LENGT,ITYLCM)
         IF(LENGT.EQ.0) THEN
            CALL LCMLIB(IPDRL)
            WRITE (HSMG,910) HNAMIS,HNISOR,NAMFIL,IMX
            CALL XABORT(HSMG)
         ENDIF
         IF(IMPX.GT.0) WRITE (IOUT,920) HNAMIS,HNISOR
         CALL LCMSIX(IPDRL,HNISOR,1)
*
         CALL LCMGET(IPDRL,'AWR',AWR(IMX))
         CALL LCMLEN(IPDRL,'README',LTITLE,ITYLCM)
         IF(LTITLE.GT.0) THEN
           LTITLE=(LTITLE-1)/20+1
           ALLOCATE(HTITLE(LTITLE))
           CALL LCMGTC(IPDRL,'README',80,LTITLE,HTITLE)
           IF(IMPX.GT.0) THEN
             WRITE (IOUT,930)
             DO 20 J=1,LTITLE
             WRITE (IOUT,'(1X,A80)') HTITLE(J)
   20        CONTINUE
           ENDIF
         ENDIF
*----
*  RECOVER BIN TYPE INFORMATION (IF AVAILABLE).
*----
         LBIN=0
         CALL LCMLEN (IPDRL,'BIN-NFS',LENGT,ITYXSM)
         IF(LENGT.GT.0) THEN
            CALL LCMGET (IPDRL,'BIN-NFS',NFS)
            DO 30 I=1,NGRO
            LBIN=LBIN+NFS(I)
   30       CONTINUE
            ALLOCATE(BIN(3*LBIN),EBIN(LBIN+1))
            CALL LCMGET (IPDRL,'BIN-ENERGY',EBIN)
            CALL LCMLEN(IPDRL,'BIN-DELI',LENDEL,ITYLCM)
            IF((LENDEL.EQ.1).AND.(ITYLCM.EQ.2)) THEN
              CALL LCMGET (IPDRL,'BIN-DELI',RDELI)
            ELSE IF((LENDEL.EQ.1).AND.(ITYLCM.EQ.4)) THEN
              CALL LCMGET (IPDRL,'BIN-DELI',DDELI)
              RDELI=REAL(DDELI)
            ENDIF
         ENDIF
*----
*  RECOVER ECCOLIB INFORMATION (IF AVAILABLE).
*----
         DELECC=0.0
         IGECCO=0
         CALL LCMLEN(IPDRL,'ONFLIGHTDEL',LENGT,ITYLCM)
         IF(LENGT.GT.0) THEN
            CALL LCMGET(IPDRL,'ONFLIGHTDEL',DELECC)
            CALL LCMGET(IPDRL,'ONFLIGHTIGR',IGECCO)
         ENDIF
*
         CALL LCMLEN (IPDRL,'TEMPERATURE',NTMP,ITYLCM)
         IF(NTMP.GT.MAXTMP) CALL XABORT('LIBDRA: MAXTMP OVERFLOW.')
         IF(NTMP.EQ.0) THEN
            CALL LCMLEN (IPDRL,'LAMBDA-D',NDEL0,ITYLCM)
            NDEL=MAX(NDEL,NDEL0)
            IF(NDEL0.GT.MAXDEL) CALL XABORT('LIBDRA: MAXDEL OVERFLOW.')
            IF(NDEL0.GT.0) CALL LCMGET (IPDRL,'LAMBDA-D',ZLAMB)
            CALL LIBDRB (IPDRL,NGRO,NL,NDEL0,NBESP,ENER,SN(1,IMX),
     1      SB(1,IMX),NED,HVECT,DELTA,LBIN,NFS,EBIN,AWR(IMX),DELECC,
     2      IGECCO,IMPX,NGF,NGFR,LSCAT,LSIGF,LADD,LGOLD,SIGS(1,1),
     3      SCAT(1,1,1),TOTAL,ZNPHI,SIGF(1,1),CHI(1,1),CHI4G(1,1),
     4      SADD(1,1),GOLD(1),BIN(1))
         ELSE
*----
*  PERFORM TEMPERATURE LAGRANGIAN INTERPOLATION (ORDER ABS(NOTX)).
*----
            CALL LCMSIX (IPDRL,'SUBTMP0001',1)
            CALL LCMLEN (IPDRL,'LAMBDA-D',NDEL0,ITYLCM)
            NDEL=MAX(NDEL,NDEL0)
            IF(NDEL0.GT.MAXDEL) CALL XABORT('LIBDRA: MAXDEL OVERFLOW.')
            IF(NDEL0.GT.0) CALL LCMGET (IPDRL,'LAMBDA-D',ZLAMB)
            CALL LCMSIX (IPDRL,' ',2)
            CALL LCMGET (IPDRL,'TEMPERATURE',TEMP)
            CALL LIBLEX(NTMP,TN(IMX),TEMP,NOTX,TERP)
            DO 121 IG1=1,NGRO
            TOTAL(IG1)=0.0
            ZNPHI(IG1)=0.0
            DO 100 IDEL=0,NDEL0
            SIGF(IG1,IDEL)=0.0
            CHI(IG1,IDEL)=0.0
  100       CONTINUE
            DO 105 ISP=1,NBESP
            CHI4G(IG1,ISP)=0.0
  105       CONTINUE
            GOLD(IG1)=0.0
            DO 115 IL=1,NL
            SIGS(IG1,IL)=0.0
            DO 110 IG2=1,NGRO
            SCAT(IG1,IG2,IL)=0.0
  110       CONTINUE
  115       CONTINUE
            DO 120 IED=1,NED
            SADD(IG1,IED)=0.0
  120       CONTINUE
  121       CONTINUE
            DO 125 IG=1,3*LBIN
            BIN(IG)=0.0
  125       CONTINUE
            ALLOCATE(SIGS2(NGRO*NL),SCAT2(NGRO*NGRO*NL),TOTAL2(NGRO),
     1      SIGF2(NGRO*(NDEL0+1)),CHI2(NGRO*(NDEL0+1)),SADD2(NGRO*NED),
     2      GOLD2(NGRO),BIN2(3*LBIN),ZNPHI2(NGRO),CHI4G2(NGRO*NBESP))
            FACTOR=1.0D0
            DO 210 ITM=1,NTMP
            TERPM=REAL(TERP(ITM))
            FACTOR=FACTOR-TERP(ITM)
            IF(TERPM.EQ.0.0) GO TO 210
            IF(IMPX.GT.4) WRITE(6,'(/30H DRAGLIB ACCESS AT TEMPERATURE,
     >      1P,E12.4,18H KELVIN. FACTOR = ,E12.4)') TEMP(ITM),TERPM
            WRITE (CD,'(I4.4)') ITM
            CALL LCMSIX (IPDRL,'SUBTMP'//CD,1)
            CALL LIBDRB (IPDRL,NGRO,NL,NDEL0,NBESP,ENER,SN(1,IMX),
     1      SB(1,IMX),NED,HVECT,DELTA,LBIN,NFS,EBIN,AWR(IMX),DELECC,
     2      IGECCO,IMPX,NGF,NGFR,LSCAT,LSIGF,LADD,LGOLD,SIGS2(1),
     3      SCAT2(1),TOTAL2,ZNPHI2,SIGF2(1),CHI2(1),CHI4G2(1),SADD2(1),
     4      GOLD2(1),BIN2(1))
            CALL LCMSIX (IPDRL,' ',2)
            DO 130 IG=1,NGRO
              TOTAL(IG)=TOTAL(IG)+TERPM*TOTAL2(IG)
              ZNPHI(IG)=ZNPHI(IG)+TERPM*ZNPHI2(IG)
  130       CONTINUE
            IF(LSIGF) THEN
              DO 141 IDEL=0,NDEL0
              DO 140 IG=1,NGRO
                IOFSET=IDEL*NGRO+IG-1
                SIGF(IG,IDEL)=SIGF(IG,IDEL)+TERPM*SIGF2(IOFSET+1)
                CHI(IG,IDEL)=CHI(IG,IDEL)+TERPM*CHI2(IOFSET+1)
  140         CONTINUE
  141         CONTINUE
              DO 146 ISP=1,NBESP
              DO 145 IG=1,NGRO
                IOFSET=(ISP-1)*NGRO+IG-1
                CHI4G(IG,ISP)=CHI4G(IG,ISP)+TERPM*CHI4G2(IOFSET+1)
  145         CONTINUE
  146         CONTINUE
            ENDIF
            DO 160 IL=1,NL
              IF(LSCAT(IL)) THEN
                DO 150 IG2=1,NGRO
                  SIGS(IG2,IL)=SIGS(IG2,IL)+TERPM*SIGS2((IL-1)*NGRO+IG2)
                  IOF=(IL-1)*NGRO*NGRO+(IG2-1)*NGRO
                  DO 151 IG1=1,NGRO
                    SCAT(IG1,IG2,IL)=SCAT(IG1,IG2,IL)+TERPM*
     >              SCAT2(IOF+IG1)
  151             CONTINUE
  150           CONTINUE
              ENDIF
  160       CONTINUE
            DO 180 IED=1,NED
            IF(LADD(IED)) THEN
               DO 170 IG=1,NGRO
                 SADD(IG,IED)=SADD(IG,IED)+TERPM*SADD2((IED-1)*NGRO+IG)
  170          CONTINUE
            ENDIF
  180       CONTINUE
            IF(LGOLD) THEN
               DO 190 IG=1,NGRO
               GOLD(IG)=GOLD(IG)+TERPM*GOLD2(IG)
  190          CONTINUE
            ENDIF
            DO 200 IG=1,3*LBIN
            BIN(IG)=BIN(IG)+TERPM*BIN2(IG)
  200       CONTINUE
  210       CONTINUE
            DEALLOCATE(CHI4G2,ZNPHI2,BIN2,GOLD2,SADD2,CHI2,SIGF2,TOTAL2,
     >      SCAT2,SIGS2)
            IF(ABS(FACTOR).GT.1.0D-4) CALL XABORT('LIBDRA: TERP ERROR')
         ENDIF
         CALL LCMSIX(IPDRL,' ',2)
*----
*        SAVE CROSS SECTION DATA ON LCM.
*----
         KPLIB=IPISO(IMX) ! set IMX-th isotope
         CALL LCMPTC(KPLIB,'ALIAS',12,HNAMIS)
         CALL LCMPUT(KPLIB,'AWR',1,2,AWR(IMX))
         IF(LTITLE.GT.0) THEN
            CALL LCMPTC(KPLIB,'README',80,LTITLE,HTITLE)
            DEALLOCATE(HTITLE)
         ENDIF
         DO 220 IG=1,NGRO
         IF(TOTAL(IG).LT.0.0) THEN
            WRITE(HSMG,'(42HLIBDRA: NEGATIVE TOTAL CROSS SECTION IN GR,
     1      3HOUP,I4,14H FOR ISOTOPE '',A12,2H''.)') IG,HNAMIS
            CALL XABORT(HSMG)
         ELSE IF(ZNPHI(IG).LT.0.0) THEN
            WRITE(HSMG,'(41HLIBDRA: NEGATIVE INTEGRATED FLUX IN GROUP,
     1      I4,14H FOR ISOTOPE '',A12,2H''.)') IG,HNAMIS
            CALL XABORT(HSMG)
         ENDIF
  220    CONTINUE
         CALL LCMPUT(KPLIB,'NTOT0',NGRO,2,TOTAL)
         CALL LCMPUT(KPLIB,'NWT0',NGRO,2,ZNPHI)
         IF(NDEL0.GT.0) CALL LCMPUT (KPLIB,'LAMBDA-D',NDEL0,2,ZLAMB)
         IF(LSIGF) THEN
            DO 250 IDEL=0,NDEL0
            IF(IDEL.EQ.0) THEN
               HNUSIG='NUSIGF'
            ELSE
               WRITE(HNUSIG,'(6HNUSIGF,I2.2)') IDEL
            ENDIF
            CALL LCMPUT(KPLIB,HNUSIG,NGRO,2,SIGF(1,IDEL))
            IF(IDEL.EQ.0) THEN
               IF(NBESP.GT.0) GO TO 250
               HCHI='CHI'
            ELSE
               WRITE(HCHI,'(3HCHI,I2.2)') IDEL
            ENDIF
            CALL LCMPUT(KPLIB,HCHI,NGRO,2,CHI(1,IDEL))
  250       CONTINUE
            DO 260 ISP=1,NBESP
               LNZERO=.FALSE.
               DO 255 IG=1,NGRO
               LNZERO=LNZERO.OR.(CHI4G(IG,ISP).NE.0.0)
  255          CONTINUE
               IF(LNZERO) THEN
                 WRITE(HCHI,'(5HCHI--,I2.2)') ISP
                 CALL LCMPUT(KPLIB,HCHI,NGRO,2,CHI4G(1,ISP))
               ENDIF
  260       CONTINUE
         ENDIF
         CALL XDRLGS(KPLIB,1,0,0,NL-1,1,NGRO,SIGS,SCAT,ITYPRO)
         CALL LCMLEN(KPLIB,'H-FACTOR',LENGT,ITYLCM)
         IF(LENGT.NE.0) CALL LCMDEL(KPLIB,'H-FACTOR')
         DO 340 IED=1,NED
         IF(LADD(IED).AND.(HVECT(IED)(:3).NE.'CHI')
     1               .AND.(HVECT(IED)(:2).NE.'NU')
     2               .AND.(HVECT(IED).NE.'NTOT0')
     3               .AND.(HVECT(IED)(:3).NE.'NWT')) THEN
            CALL LCMPUT(KPLIB,HVECT(IED),NGRO,2,SADD(1,IED))
         ENDIF
  340    CONTINUE
         IF(LGOLD) CALL LCMPUT(KPLIB,'NGOLD',NGRO,2,GOLD)
         IF(LBIN.GT.0) THEN
            CALL LCMPUT(KPLIB,'BIN-NFS',NGRO,1,NFS)
            CALL LCMPUT(KPLIB,'BIN-ENERGY',LBIN+1,2,EBIN)
            CALL LCMPUT(KPLIB,'BIN-NTOT0',LBIN,2,BIN)
            CALL LCMPUT(KPLIB,'BIN-SIGS00',LBIN,2,BIN(LBIN+1))
            LOGT=.FALSE.
            DO 350 I=1,LBIN
            LOGT=LOGT.OR.(BIN(2*LBIN+I).NE.0.0)
  350       CONTINUE
            IF(LOGT) THEN
               CALL LCMPUT(KPLIB,'BIN-NUSIGF',LBIN,2,BIN(2*LBIN+1))
            ENDIF
            DEALLOCATE(EBIN,BIN)
            IF(LENDEL.EQ.1) CALL LCMPUT(KPLIB,'BIN-DELI',1,2,RDELI)
         ENDIF
         IF(IMPX.GT.9) CALL LCMLIB(KPLIB)
      ENDIF
  400 CONTINUE
*----
*  SCRATCH STORAGE DEALLOCATION
*----
      DEALLOCATE(LADD,LSCAT)
      DEALLOCATE(CHI4G,ZNPHI,GOLD,ENER,SADD,CHI,SIGF,TOTAL,SCAT,SIGS,
     1 DELTA,AWR)
      DEALLOCATE(ITYPRO,NFS)
      RETURN
*
  900 FORMAT(/33H PROCESSING DRAGON LIBRARY NAMED ,A,9H VERSION ,A,1H.)
  910 FORMAT(26HLIBDRA: MATERIAL/ISOTOPE ',A12,5H' = ',A12,9H' IS MISS,
     1 25HING ON DRAGON FILE NAMED ,A12,10H (ISOTOPE=,I10,2H).)
  920 FORMAT(/30H PROCESSING ISOTOPE/MATERIAL ',A12,11H' (HNISOR=',A12,
     1 3H').)
  930 FORMAT(/23H ISOTOPE/MATERIAL INFO:)
  940 FORMAT(/24H X-SECTION LIBRARY INFO:)
      END