*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,HTITLE*80,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,ITITLE 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 *---- * 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),GOLD(NGRO),ZNPHI(NGRO)) ALLOCATE(LSCAT(NL),LADD(NED)) *---- * RECOVER THE GROUP STRUCTURE. *---- NGF=NGRO+1 NGFR=0 NDEL=0 IF(IMPX.GT.0) WRITE (IOUT,900) NAMFIL CALL LCMLEN(IPDRL,'README',LENGT,ITYLCM) IF((IMPX.GT.0).AND.(LENGT.GT.0)) THEN ALLOCATE(ITITLE(LENGT)) CALL LCMGET(IPDRL,'README',ITITLE) WRITE (IOUT,940) I2=0 DO 10 J=0,LENGT/20 I1=I2+1 I2=MIN(I1+19,LENGT) WRITE (HTITLE,'(20A4)') (ITITLE(I),I=I1,I2) WRITE (IOUT,'(1X,A80)') HTITLE 10 CONTINUE DEALLOCATE(ITITLE) WRITE (IOUT,'(40H LIBDRA: NUMBER OF ISOTOPES IN MICROLIB=,I6)') 1 NBISO ENDIF ALLOCATE(ENER(NGRO+1)) 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) DEALLOCATE(ENER) 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 ALLOCATE(ITITLE(LTITLE)) CALL LCMGET(IPDRL,'README',ITITLE) IF(IMPX.GT.0) THEN WRITE (IOUT,930) I2=0 DO 20 J=0,LTITLE/20 I1=I2+1 I2=MIN(I1+19,LTITLE) WRITE (HTITLE,'(20A4)') (ITITLE(I),I=I1,I2) WRITE (IOUT,'(1X,A80)') HTITLE 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,SN(1,IMX),SB(1,IMX), 1 NED,HVECT,DELTA,LBIN,NFS,EBIN,AWR(IMX),DELECC,IGECCO,IMPX, 2 NGF,NGFR,LSCAT,LSIGF,LADD,LGOLD,SIGS(1,1),SCAT(1,1,1),TOTAL, 3 ZNPHI,SIGF(1,1),CHI(1,1),CHI4G(1,1),SADD(1,1),GOLD(1), 4 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,SN(1,IMX),SB(1,IMX), 1 NED,HVECT,DELTA,LBIN,NFS,EBIN,AWR(IMX),DELECC,IGECCO,IMPX, 2 NGF,NGFR,LSCAT,LSIGF,LADD,LGOLD,SIGS2(1),SCAT2(1),TOTAL2, 3 ZNPHI2,SIGF2(1),CHI2(1),CHI4G2(1),SADD2(1),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 LCMPUT(KPLIB,'README',LTITLE,3,ITITLE) DEALLOCATE(ITITLE) 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) 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,SADD,CHI,SIGF,TOTAL,SCAT,SIGS,DELTA, 1 AWR) DEALLOCATE(ITYPRO,NFS) RETURN * 900 FORMAT(/33H PROCESSING DRAGON LIBRARY NAMED ,A12,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