*DECK ACRLIB SUBROUTINE ACRLIB(MAXNIS,MAXISO,IPLIB,IPAPX,IACCS,NMIX,NGRP,IMPX, 1 HEQUI,NCAL,ITER,MY1,MY2,MD1,MD2,TERP,NISO,LISO,HISO,CONC,ITODO, 2 MIXC,LRES,LPURE,LTOTAL,ILUPS,B2,LFROM,VTOT,YLDS,DECAYC) * *----------------------------------------------------------------------- * *Purpose: * Build the Microlib by scanning the NCAL elementary calculations in * a Apex file and weighting them with TERP factors. * *Copyright: * Copyright (C) 2021 Ecole Polytechnique de Montreal * *Author(s): * A. Hebert * *Parameters: input * MAXNIS maximum value of NISO(I) in user data. * MAXISO maximum allocated space for output Microlib TOC information. * IPLIB address of the output Microlib LCM object. * IPAPX pointer to the Apex file. * IACCS =0 Microlib is created; =1 ... is updated. * NMIX maximum number of material mixtures in the Microlib. * NGRP number of energy groups. * IMPX print parameter (equal to zero for no print). * HEQUI keyword of SPH-factor set to be recovered. * NCAL number of elementary calculations in the Apex file. * ITER completion flag (=0: compute the macrolib). * MY1 number of fissile isotopes including macroscopic sets. * MY2 number of fission fragment. * MD1 number of types of radioactive decay reactions. * MD2 number of particularized isotopes including macro. * TERP interpolation factors. * NISO number of user-selected isotopes. * LISO type of treatment (=.true.: ALL; =.false.: ONLY). * HISO name of the user-selected isotopes. * CONC user-defined number density of the user-selected isotopes. A * value of -99.99 is set to indicate that the Apex file value is * used. * ITODO non-depletion mask (=1 to force a user-selected isotope to be * non-depleting) * MIXC mixture index in the Apex file corresponding to each Microlib * mixture. Equal to zero if a Microlib mixture is not updated. * LRES =.true. if the interpolation is done without updating isotopic * densities * LPURE =.true. if the interpolation is a pure linear interpolation * with TERP factors. * LTOTAL =.true. to use the mac/TOTAL macroscopic set. * ILUPS up-scattering removing flag (=1 to remove up-scattering from * output cross-sections). * B2 buckling * LFROM macroregion flag (=.true. if 'xs n' groups are set). * VTOT volume of updated core. * YLDS fission yields. * DECAYC radioactive decay constants. * *----------------------------------------------------------------------- * USE GANLIB USE hdf5_wrap IMPLICIT NONE *---- * SUBROUTINE ARGUMENTS *---- TYPE(C_PTR) IPLIB,IPAPX INTEGER MAXNIS,MAXISO,IACCS,NMIX,NGRP,IMPX,NCAL,ITER,MY1,MY2,MD1, 1 MD2,NISO(NMIX),ITODO(NMIX,MAXNIS),MIXC(NMIX),ILUPS REAL TERP(NCAL,NMIX),CONC(NMIX,MAXNIS),B2 DOUBLE PRECISION VTOT,YLDS(MY1,MY2),DECAYC(MD1,MD2) LOGICAL LISO(NMIX),LRES,LPURE,LTOTAL,LFROM CHARACTER(LEN=80) HEQUI CHARACTER(LEN=8) HISO(NMIX,MD2) *---- * LOCAL VARIABLES *---- INTEGER, PARAMETER::IOUT=6 INTEGER, PARAMETER::MAXMAC=2 INTEGER, PARAMETER::MAXREA=50 INTEGER, PARAMETER::NSTATE=40 INTEGER, PARAMETER::MAXFRD=4 TYPE(C_PTR) JPLIB,KPLIB REAL B2APEX, FACT0, WEIGHT INTEGER I, I0, K, IBM, IBMOLD, ICAL, ID1, IED2, IFISS, IGR, & ILONG, IMAC, IOF, IPRC, IREA, IREAF, IRES, ISO, ITRANC, ITSTMP, & ITYLCM, IY1, IY2, JSO, KSO, KSO1, LMY1, LSO, MAXMIX, NBISO, & NBISO1, NBISO2, NBISO2I, NBS1, NCALS, NED2, NL, NLAM, NBMAC, & NMIL, NPAR, NPRC, NREA, NSURFD, NISOF, NISOP, NISOS, NISOTS, & NVP, RANK, NBYTE, TYPE, ISURF, DIMSR(5) CHARACTER RECNAM*80,TEXT8*8, TEXT12*12,HSMG*131,HVECT2(MAXREA)*8, 1 HRESID*8,HHAD(MAXFRD)*16 INTEGER ISTATE(NSTATE),INAME(2),IHRES(2) REAL TMPDAY(3) LOGICAL LUSER,LSTRD *---- * ALLOCATABLE ARRAYS *---- INTEGER, ALLOCATABLE, DIMENSION(:) :: IMIX2,ITOTM,IRESM,ISONA, 1 ISOMI,ITOD2,ISTY1,ISTY2,IPIFI,IMICR,ITOD1,JJSO,IPYMIX,DIMS_APX INTEGER, ALLOCATABLE, DIMENSION(:,:) :: HUSE2,HNAM2 REAL, ALLOCATABLE, DIMENSION(:) :: DENS2,DENS3,VOL2,VOLMI2,SPH, 1 ENER,XVOLM,CONCE,TAUXFI,NWT0,FLUXS,DENIS,GAR1,GAR2,LAMB,BETAR, 2 INVELS,BETARB,INVELSB REAL, ALLOCATABLE, DIMENSION(:,:) :: ADF,DENS1,FACT,DECAY2, 1 CHIRS,CHIRSB REAL, ALLOCATABLE, DIMENSION(:,:,:) :: XS,SIGS,DENS0,FLUX,ADF2, 1 YLDS2 REAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: SS2D DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: YLDSM LOGICAL, ALLOCATABLE, DIMENSION(:) :: LXS,MASK,MASKL CHARACTER(LEN=8), ALLOCATABLE, DIMENSION(:) :: HADF,HNOMIS,NOMISO, 1 NOMMAC,HPYNAM CHARACTER(LEN=12), ALLOCATABLE, DIMENSION(:) :: NOMREA *---- * RECOVER APEX FILE CHARACTERISTICS *---- I=0 CALL APXTOC(IPAPX,0,NLAM,NREA,NBISO,NBMAC,NMIL,NPAR,NVP,NISOF, 1 NISOP,NISOS,NCALS,I,NISOTS,NSURFD,NPRC) IF(NGRP.NE.I) CALL XABORT('ACRLIB: INVALID VALUE OF NGRP.') IF(NREA.GT.MAXREA) CALL XABORT('ACRLIB: MAXREA OVERFLOW') IF(NBMAC.GT.MAXMAC) CALL XABORT('ACRLIB: MAXMAC OVERFLOW') *---- * SCRATCH STORAGE ALLOCATION *---- ALLOCATE(IMIX2(MAXISO),ITOD2(MAXISO),ISTY1(MAXISO),ISTY2(MAXISO), 1 HUSE2(3,MAXISO),HNAM2(3,MAXISO)) ALLOCATE(DENS2(MAXISO),DENS3(MAXISO),VOL2(MAXISO),VOLMI2(NMIX), 1 FLUX(NMIX,NGRP,2),SPH(NGRP)) ALLOCATE(HADF(NSURFD),ADF2(NMIX,NGRP,NSURFD)) *---- * MICROLIB INITIALIZATION *---- VOLMI2(:NMIX)=0.0 DENS2(:MAXISO)=0.0 VOL2(:MAXISO)=0.0 IMIX2(:MAXISO)=0 ITOD2(:MAXISO)=0 ISTY2(:MAXISO)=0 IF(NSURFD.GT.0) ADF2(:NMIX,:NGRP,:NSURFD)=0.0 IF(IACCS.EQ.0) THEN IF(LRES) CALL XABORT('ACRLIB: RES OPTION IS INVALID.') NBISO2=0 NED2=0 TEXT12='L_LIBRARY' CALL LCMPTC(IPLIB,'SIGNATURE',12,TEXT12) ELSE CALL LCMGET(IPLIB,'STATE-VECTOR',ISTATE) IF(ISTATE(1).NE.NMIX) CALL XABORT('ACRLIB: INVALID NUMBER OF ' 1 //'MATERIAL MIXTURES IN THE MICROLIB.') IF(ISTATE(3).NE.NGRP) CALL XABORT('ACRLIB: INVALID NUMBER OF ' 1 //'ENERGY GROUPS IN THE MICROLIB.') NBISO2=ISTATE(2) IF(NBISO2.GT.MAXISO) CALL XABORT('ACRLIB: MAXISO OVERFLOW(1).') NED2=ISTATE(13) IF(NED2.GT.MAXREA) CALL XABORT('ACRLIB: MAXREA OVERFLOW.') CALL LCMLEN(IPLIB,'MIXTURESVOL',ILONG,ITYLCM) IF(ILONG.GT.0) THEN CALL LCMGET(IPLIB,'MIXTURESVOL',VOLMI2) ELSE VOLMI2(:NMIX)=0.0 ENDIF CALL LCMGET(IPLIB,'ISOTOPESUSED',HUSE2) CALL LCMGET(IPLIB,'ISOTOPERNAME',HNAM2) CALL LCMGET(IPLIB,'ISOTOPESDENS',DENS2) CALL LCMGET(IPLIB,'ISOTOPESVOL',VOL2) CALL LCMGET(IPLIB,'ISOTOPESMIX',IMIX2) CALL LCMGET(IPLIB,'ISOTOPESTODO',ITOD2) CALL LCMGET(IPLIB,'ISOTOPESTYPE',ISTY2) IF(NED2.GT.0) CALL LCMGTC(IPLIB,'ADDXSNAME-P0',8,NED2,HVECT2) IF(NSURFD.GT.0) THEN CALL LCMSIX(IPLIB,'MACROLIB',1) CALL LCMLEN(IPLIB,'ADF',ILONG,ITYLCM) IF(ILONG.EQ.0) THEN CALL LCMLIB(IPLIB) CALL XABORT('ACRLIB: UNABLE TO FIND DIRECTORY ADF.') ENDIF CALL LCMSIX(IPLIB,'ADF',1) CALL LCMGTC(IPLIB,'HADF',8,NSURFD,HADF) DO I=1,NSURFD CALL LCMGET(IPLIB,HADF(I),ADF2(1,1,I)) ENDDO CALL LCMSIX(IPLIB,' ',2) CALL LCMSIX(IPLIB,' ',2) ENDIF ENDIF *---- * RECOVER INFORMATION FROM physconst GROUP. *---- IF(hdf5_group_exists(IPAPX,"/physconst/")) THEN CALL hdf5_read_data(IPAPX,"/physconst/ENRGS",ENER) ELSE IF(hdf5_group_exists(IPAPX,"/physco001/")) THEN CALL hdf5_read_data(IPAPX,"/physco001/ENRGS",ENER) ELSE CALL XABORT('ACRLIB: GROUP physconst NOT FOUND IN HDF5 FILE.') ENDIF DO IGR=1,NGRP+1 ENER(IGR)=ENER(IGR)/1.0E-6 ENDDO CALL LCMPUT(IPLIB,'ENERGY',NGRP+1,2,ENER) DO IGR=1,NGRP ENER(IGR)=LOG(ENER(IGR)/ENER(IGR+1)) ENDDO CALL LCMPUT(IPLIB,'DELTAU',NGRP,2,ENER) DEALLOCATE(ENER) *---- * RECOVER INFORMATION FROM explicit GROUP. *---- ALLOCATE(ITOTM(NMIL),IRESM(NMIL)) ITOTM(:)=0 IRESM(:)=0 IREAF=0 IF(NREA.GT.0) THEN IF(hdf5_group_exists(IPAPX,"/explicit/")) THEN CALL hdf5_read_data(IPAPX,"/explicit/REANAME",NOMREA) ELSE IF(hdf5_group_exists(IPAPX,"/expli001/")) THEN CALL hdf5_read_data(IPAPX,"/expli001/REANAME",NOMREA) ELSE CALL XABORT('ACRLIB: GROUP explicit NOT FOUND IN HDF5 FILE.') ENDIF IF(IMPX.GT.1) THEN WRITE(IOUT,'(29H ACRLIB: Available reactions:/(1X,10A13))') 1 (NOMREA(I),I=1,NREA) ENDIF DO IREA=1,NREA IF(NOMREA(IREA).EQ.'NUFI') THEN IREAF=IREA EXIT ENDIF ENDDO ENDIF IF(NBISO.GT.0) THEN IF(hdf5_group_exists(IPAPX,"/explicit/")) THEN CALL hdf5_read_data(IPAPX,"/explicit/ISONAME",NOMISO) ELSE IF(hdf5_group_exists(IPAPX,"/expli001/")) THEN CALL hdf5_read_data(IPAPX,"/expli001/ISONAME",NOMISO) ELSE CALL XABORT('ACRLIB: GROUP explicit NOT FOUND IN HDF5 FILE.') ENDIF ENDIF IF(LTOTAL.AND.(NBMAC.EQ.0)) CALL XABORT('ACRLIB: NBMAC=0.') IF(NBMAC.GT.0) THEN IF(hdf5_group_exists(IPAPX,"/explicit/")) THEN CALL hdf5_read_data(IPAPX,"/explicit/MACNAME",NOMMAC) ELSE IF(hdf5_group_exists(IPAPX,"/expli001/")) THEN CALL hdf5_read_data(IPAPX,"/expli001/MACNAME",NOMMAC) ELSE CALL XABORT('ACRLIB: GROUP explicit NOT FOUND IN HDF5 FILE.') ENDIF DO I=1,NBMAC IF(NOMMAC(I).EQ.'TOTAL') ITOTM(:)=I IF(NOMMAC(I).EQ.'RESIDUAL') IRESM(:)=I ENDDO NBISO1=NBISO+NBMAC ALLOCATE(HNOMIS(NBISO1)) IF(NBISO.GT.0) HNOMIS(:NBISO)=NOMISO(:NBISO) IF(LTOTAL) THEN ! use the mac/TOTAL macroscopic set HNOMIS(:NBISO)=' ' DO I=1,NBMAC IF(NOMMAC(I).EQ.'TOTAL') THEN HNOMIS(NBISO+I)='*MAC*RES' ELSE IF(NOMMAC(I).EQ.'RESIDUAL') THEN HNOMIS(NBISO+I)=' ' ENDIF ENDDO ELSE ! use the mac/RESIDUAL macroscopic set DO I=1,NBMAC IF(NOMMAC(I).EQ.'TOTAL') THEN HNOMIS(NBISO+I)=' ' ELSE IF(NOMMAC(I).EQ.'RESIDUAL') THEN HNOMIS(NBISO+I)='*MAC*RES' ENDIF ENDDO ENDIF ELSE NBISO1=NBISO ALLOCATE(HNOMIS(NBISO1)) IF(NBISO.GT.0) HNOMIS(:NBISO)=NOMISO(:NBISO) ENDIF *---- * RECOVER VOLUMES. *---- ALLOCATE(XVOLM(NMIL)) RECNAM='calc 1/xs/' DO IBMOLD=1,NMIL IF(LFROM) WRITE(RECNAM,'(4Hcalc,I8,3H/xs,I8,1H/)') ICAL,IBMOLD CALL hdf5_info(IPAPX,TRIM(RECNAM)//"MEDIA_VOLUME",RANK, 1 TYPE,NBYTE,DIMSR) IF(TYPE.EQ.99) THEN XVOLM(IBMOLD)=1.0 WRITE(IOUT,'(44H ACRLIB: WARNING -- Record MEDIA_VOLUME is m, 1 42Hissing in the Apex file. Volume set to 1.0)') ELSE CALL hdf5_read_data(IPAPX,TRIM(RECNAM)//"MEDIA_VOLUME", 1 XVOLM(IBMOLD)) ENDIF ENDDO *---- * FIND SCATTERING ANISOTROPY. *---- CALL hdf5_info(IPAPX,TRIM(RECNAM)//"mac/TOTAL/DIFF",RANK, 1 TYPE,NBYTE,DIMSR) IF(TYPE.EQ.99) CALL XABORT('ACRLIB: MISSING SCATTERING INFO.') NL=DIMSR(2) IF(IMPX.GT.1) THEN WRITE(IOUT,'(36H ACRLIB: number of Legendre orders =,I4)') NL ENDIF *---- * LOOP OVER APEX MIXTURES TO COMPUTE DENS0(NMIL,NCAL,NBISO1) *---- ALLOCATE(DENS0(NMIL,NCAL,NBISO1)) DENS0(:NMIL,:NCAL,:NBISO1)=0.0 DO 30 IBMOLD=1,NMIL DO ICAL=1,NCAL DO IBM=1,NMIX IF((TERP(ICAL,IBM).NE.0.0).AND.(MIXC(IBM).EQ.IBMOLD)) GO TO 10 ENDDO CYCLE 10 WRITE(RECNAM,'(4Hcalc,I8,4H/xs/)') ICAL IF(LFROM) WRITE(RECNAM,'(4Hcalc,I8,3H/xs,I8,1H/)') ICAL,IBMOLD IF(NBISO.GT.0) THEN CALL hdf5_read_data(IPAPX,TRIM(RECNAM)//"mic/CONC",CONCE) DO 20 ISO=1,NBISO DENS0(IBMOLD,ICAL,ISO)=CONCE(ISO) 20 CONTINUE ENDIF ENDDO 30 CONTINUE IF(NBISO.GT.0) DEALLOCATE(CONCE) *---- * LOOP OVER MICROLIB MIXTURES *---- YLDS(:MY1,:MY2)=0.0D0 DECAYC(:MD1,:MD2)=0.0D0 VTOT=0.0D0 DO 40 IBM=1,NMIX IBMOLD=MIXC(IBM) IF(IBMOLD.NE.0) VTOT=VTOT+XVOLM(IBMOLD) 40 CONTINUE ALLOCATE(JJSO(NBISO+NBMAC),YLDSM(MY1,MY2),ITOD1(NBISO1)) ALLOCATE(TAUXFI(NBISO+NBMAC),NWT0(NGRP), 1 SIGS(NGRP,NL,NBISO+NBMAC),SS2D(NGRP,NGRP,NL,NBISO+NBMAC), 2 XS(NGRP,NREA,NBISO+NBMAC)) ALLOCATE(LXS(NREA)) ALLOCATE(CHIRS(NGRP,NPRC),BETAR(NPRC),INVELS(NGRP)) CHIRS(:NGRP,:NPRC)=0.0 BETAR(:NPRC)=0.0 INVELS(:NGRP)=0.0 ALLOCATE(BETARB(NPRC),INVELSB(NGRP)) ALLOCATE(DENS1(NBISO1,NCAL),FACT(NBISO1,NCAL)) JPLIB=LCMLID(IPLIB,'ISOTOPESLIST',(NBISO+NBMAC)*NMIX) * DO 180 IBM=1,NMIX IBMOLD=MIXC(IBM) IF(IBMOLD.EQ.0) GO TO 180 IF(NISO(IBM).GT.MAXNIS) CALL XABORT('ACRLIB: MAXNIS OVERFLOW.') VOLMI2(IBM)=XVOLM(IBMOLD) IMAC=ITOTM(IBMOLD) IRES=IRESM(IBMOLD) *---- * RECOVER ITOD1(NBISO1) INDICES. *---- ITOD1(:NBISO1)=0 DO 50 ISO=1,NBISO1 ! Apex file isotope DO KSO=1,NISO(IBM) ! user-selected isotope IF(NOMISO(ISO).EQ.HISO(IBM,KSO)) THEN ITOD1(ISO)=ITODO(IBM,KSO) GO TO 50 ENDIF ENDDO 50 CONTINUE *---- * COMPUTE THE NUMBER DENSITIES OF EACH ELEMENTARY CALCULATION. *---- DENS1(:NBISO1,:NCAL)=0.0 DENS3(:NBISO1)=0.0 DO ICAL=1,NCAL WEIGHT=TERP(ICAL,IBM) IF(WEIGHT.EQ.0.0) CYCLE DO ISO=1,NBISO LUSER=.FALSE. KSO1=0 DO KSO=1,NISO(IBM) ! user-selected isotope IF(NOMISO(ISO).EQ.HISO(IBM,KSO)) THEN KSO1=KSO LUSER=(CONC(IBM,KSO1).NE.-99.99) GO TO 60 ENDIF ENDDO 60 IF(LUSER) THEN DENS1(ISO,ICAL)=CONC(IBM,KSO1) CYCLE ENDIF IF(.NOT.LISO(IBM)) CYCLE DENS1(ISO,ICAL)=DENS0(IBMOLD,ICAL,ISO) ENDDO IF((NBISO.NE.0).AND.(.NOT.LTOTAL)) THEN DENS1(NBISO+IRES,ICAL)=1.0 ELSE IF(IMAC.NE.0) THEN DENS1(NBISO+IMAC,ICAL)=1.0 ENDIF DO ISO=1,NBISO1 DENS3(ISO)=DENS3(ISO)+WEIGHT*DENS1(ISO,ICAL) ENDDO ENDDO FACT(:NBISO1,:NCAL)=1.0 IF(.NOT.LPURE) THEN DO ICAL=1,NCAL IF(TERP(ICAL,IBM).EQ.0.0) CYCLE DO ISO=1,NBISO1 IF(DENS3(ISO).GT.DENS1(ISO,ICAL)*1.0E-9) THEN FACT(ISO,ICAL)=DENS1(ISO,ICAL)/DENS3(ISO) ENDIF ENDDO ENDDO ENDIF *---- * INITIALIZE WORKING ARRAYS. *---- TAUXFI(:NBISO1)=0.0 NWT0(:NGRP)=0.0 SIGS(:NGRP,:NL,:NBISO1)=0.0 SS2D(:NGRP,:NGRP,:NL,:NBISO1)=0.0 XS(:NGRP,:NREA,:NBISO1)=0.0 LXS(:NREA)=.FALSE. YLDSM(:MY1,:MY2)=0.0D0 *---- * MAIN LOOP OVER ELEMENTARY CALCULATIONS *---- TEXT12='*MAC*RES' READ(TEXT12,'(2A4)') IHRES(1),IHRES(2) LSTRD=.FALSE. B2APEX=B2 DO 80 ICAL=1,NCAL WEIGHT=TERP(ICAL,IBM) IF(WEIGHT.EQ.0.0) GO TO 80 *---- * RECOVER INFORMATION FROM caldir GROUP. *---- WRITE(RECNAM,'(4Hcalc,I8,10H/kinetics/)') ICAL CALL hdf5_info(IPAPX,TRIM(RECNAM)//"LAMBDA",RANK,TYPE,NBYTE,DIMSR) NPRC=0 IF(TYPE.NE.99) THEN NPRC=DIMSR(1) CALL hdf5_read_data(IPAPX,TRIM(RECNAM)//"LAMBDA",LAMB) CALL hdf5_read_data(IPAPX,TRIM(RECNAM)//"CHIDA",CHIRSB) CALL hdf5_read_data(IPAPX,TRIM(RECNAM)//"BETADA",BETARB) CALL hdf5_read_data(IPAPX,TRIM(RECNAM)//"INVELA",INVELSB) ENDIF *---- * SELECT APEX MIXTURE IBMOLD. *---- WRITE(RECNAM,'(4Hcalc,I8,4H/xs/)') ICAL IF(LFROM) WRITE(RECNAM,'(4Hcalc,I8,3H/xs,I8,1H/)') ICAL,IBMOLD IF(HEQUI.NE.' ') THEN CALL hdf5_read_data(IPAPX,TRIM(RECNAM)//"MEDIA_SPH/"//HEQUI,SPH) ELSE SPH(:NGRP)=1.0 ENDIF CALL hdf5_read_data(IPAPX,TRIM(RECNAM)//"FLUX",FLUXS) DO I=1,NGRP FLUXS(I)=FLUXS(I)/XVOLM(IBMOLD) NWT0(I)=NWT0(I)+WEIGHT*FLUXS(I)/SPH(I) ENDDO IF((NBISO.NE.0).AND.(.NOT.LTOTAL)) THEN DO ISO=1,NBISO FACT0=FACT(ISO,ICAL) CALL ACRSX2(IPAPX,RECNAM,NREA,NGRP,NISOF,NISOP,NL,ISO, 1 NOMREA,B2APEX,FACT0,WEIGHT,SPH,FLUXS,IREAF,LPURE,LXS, 2 XS(1,1,ISO),SIGS(1,1,ISO),SS2D(1,1,1,ISO),TAUXFI(ISO)) ENDDO IF(IRES.NE.0) THEN FACT0=1.0 CALL ACRSX2(IPAPX,RECNAM,NREA,NGRP,NISOF,NISOP,NL,-2,NOMREA, 1 B2APEX,FACT0,WEIGHT,SPH,FLUXS,IREAF,LPURE,LXS,XS(1,1,NBISO+1), 2 SIGS(1,1,NBISO+1),SS2D(1,1,1,NBISO+1),TAUXFI(NBISO+IRES)) ENDIF ELSE IF(IMAC.NE.0) THEN FACT0=1.0 CALL ACRSX2(IPAPX,RECNAM,NREA,NGRP,NISOF,NISOP,NL,-1,NOMREA, 1 B2APEX,FACT0,WEIGHT,SPH,FLUXS,IREAF,LPURE,LXS,XS(1,1,NBISO+1), 2 SIGS(1,1,NBISO+1),SS2D(1,1,1,NBISO+1),TAUXFI(NBISO+IMAC)) ELSE CALL XABORT('ACRLIB: NO MACROSCOPIC SET.') ENDIF DEALLOCATE(FLUXS) * IF(NPRC.GT.0) THEN DO IGR=1,NGRP INVELS(IGR)=INVELS(IGR)+SPH(IGR)*WEIGHT*INVELSB(IGR) DO IPRC=1,NPRC CHIRS(IGR,IPRC)=CHIRS(IGR,IPRC)+WEIGHT*CHIRSB(IGR,IPRC) ENDDO ENDDO DO IPRC=1,NPRC BETAR(IPRC)=BETAR(IPRC)+WEIGHT*BETARB(IPRC) ENDDO ENDIF *---- * COMPUTE DEPLETION CHAIN DATA *---- IF(NISOF*NISOP.GT.0) THEN IF(hdf5_group_exists(IPAPX,"/physconst/")) THEN CALL hdf5_read_data(IPAPX,"/physconst/FYIELDS",YLDS2) ELSE IF(hdf5_group_exists(IPAPX,"/physco001/")) THEN CALL hdf5_read_data(IPAPX,"/physco001/FYIELDS",YLDS2) ELSE CALL XABORT('ACRLIB: GROUP physconst NOT FOUND IN HDF5 FILE.') ENDIF DO IY2=1,NISOP DO IY1=1,NISOF YLDSM(IY1,IY2)=YLDSM(IY1,IY2)+WEIGHT*YLDS2(IY1,IY2,1) YLDS(IY1,IY2)=YLDS(IY1,IY2)+WEIGHT*YLDS2(IY1,IY2,1)* > VOLMI2(IBM)/VTOT ENDDO ENDDO DEALLOCATE(YLDS2) ENDIF IF((MD1*MD2.GT.0).AND.(NBISO.GT.0)) THEN IF(hdf5_group_exists(IPAPX,"/physconst/")) THEN CALL hdf5_read_data(IPAPX,"/physconst/DECAYC",DECAY2) ELSE IF(hdf5_group_exists(IPAPX,"/physco001/")) THEN CALL hdf5_read_data(IPAPX,"/physco001/DECAYC",DECAY2) ELSE CALL XABORT('ACRLIB: GROUP physconst NOT FOUND IN HDF5 FILE.') ENDIF DO ISO=1,NBISO DO ID1=1,NLAM DECAYC(ID1,ISO)=DECAYC(ID1,ISO)+WEIGHT*DECAY2(ID1,ISO)* > VOLMI2(IBM)/VTOT ENDDO ENDDO DEALLOCATE(DECAY2) ENDIF 80 CONTINUE ! end of loop over elementary calculations. *---- * IDENTIFY SPECIAL FLUX EDITS *---- DO IREA=1,NREA IF(NOMREA(IREA).EQ.'ABSO') THEN DO 90 IED2=1,NED2 IF(HVECT2(IED2).EQ.'ABSO') GO TO 100 90 CONTINUE NED2=NED2+1 IF(NED2.GT.MAXREA) CALL XABORT('ACRLIB: MAXREA OVERFLOW(1).') HVECT2(NED2)='ABSO' ELSE IF(NOMREA(IREA).EQ.'FISS') THEN DO 95 IED2=1,NED2 IF(HVECT2(IED2).EQ.'NFTOT') GO TO 100 95 CONTINUE NED2=NED2+1 IF(NED2.GT.MAXREA) CALL XABORT('ACRLIB: MAXREA OVERFLOW(2).') HVECT2(NED2)='NFTOT' ENDIF 100 CONTINUE ENDDO *---- * SET FLAG LSTRD *---- LSTRD=.TRUE. DO IREA=1,NREA IF(NOMREA(IREA).EQ.'LEAK') THEN IF(LXS(IREA).AND.(B2APEX.NE.0.0)) LSTRD=.FALSE. EXIT ENDIF ENDDO *---- * SAVE CROSS SECTIONS IN MICROLIB FOR MIXTURE IBM *---- ISTY1(:NBISO1)=0 JJSO(:NBISO1)=0 NBISO2I=NBISO2 IF((NBISO.NE.0).AND.(.NOT.LTOTAL)) THEN HRESID=' ' DO ISO=1,NBISO READ(HNOMIS(ISO),'(2A4)') INAME(:2) CALL SCRFND(MAXISO,NBISO2I,NBISO2,INAME,IBM,HRESID,HUSE2, 1 HNAM2,IMIX2,JJSO(ISO)) KPLIB=LCMDIL(JPLIB,JJSO(ISO)) ! step up isot JJSO(ISO) CALL ACRISO(KPLIB,NREA,NGRP,NL,NPRC,NOMREA,NWT0,XS(1,1,ISO), 1 SIGS(1,1,ISO),SS2D(1,1,1,ISO),TAUXFI(ISO),LXS,LAMB,CHIRS, 2 BETAR,INVELS,INAME,LSTRD,LPURE,ILUPS,ITRANC,IFISS) IF(MY1*MY2.GT.0) CALL ACRNDF(IMPX,NBISO+NBMAC,ISO,IBM,HNOMIS, 1 IPAPX,KPLIB,MY1,MY2,YLDSM,ISTY1(ISO)) ENDDO IF(IRES.NE.0) THEN HRESID=NOMMAC(IRES) CALL SCRFND(MAXISO,NBISO2I,NBISO2,IHRES,IBM,HRESID,HUSE2, 1 HNAM2,IMIX2,JJSO(NBISO+IRES)) KPLIB=LCMDIL(JPLIB,JJSO(NBISO+IRES)) ! step up isot JJSO(NBISO+IRES) CALL ACRISO(KPLIB,NREA,NGRP,NL,NPRC,NOMREA,NWT0, 1 XS(1,1,NBISO+1),SIGS(1,1,NBISO+1),SS2D(1,1,1,NBISO+1), 2 TAUXFI(NBISO+IRES),LXS,LAMB,CHIRS,BETAR,INVELS,IHRES, 3 LSTRD,LPURE,ILUPS,ITRANC,IFISS) IF(MY1*MY2.GT.0) CALL ACRNDF(IMPX,NBISO+NBMAC,NBISO+IRES, 1 IBM,HNOMIS,IPAPX,KPLIB,MY1,MY2,YLDSM,ISTY1(NBISO+IRES)) ENDIF DEALLOCATE(NOMMAC) ELSE IF(IMAC.NE.0) THEN HRESID=NOMMAC(IMAC) CALL SCRFND(MAXISO,NBISO2I,NBISO2,IHRES,IBM,HRESID,HUSE2,HNAM2, 1 IMIX2,JJSO(NBISO+IMAC)) KPLIB=LCMDIL(JPLIB,JJSO(NBISO+IMAC)) ! step up isot JJSO(NBISO+IMAC) CALL ACRISO(KPLIB,NREA,NGRP,NL,NPRC,NOMREA,NWT0,XS(1,1,NBISO+1), 1 SIGS(1,1,NBISO+1),SS2D(1,1,1,NBISO+1),TAUXFI(NBISO+IMAC),LXS, 2 LAMB,CHIRS,BETAR,INVELS,IHRES,LSTRD,LPURE,ILUPS,ITRANC,IFISS) DEALLOCATE(NOMMAC) ENDIF *---- * SET NUMBER DENSITIES AND VOLUMES IN OUTPUT MICROLIB *---- IF(LRES) THEN * -- Number densities are left unchanged except if they are * -- listed in HISO array. DO 110 KSO=1,NISO(IBM) ! user-selected isotope DO JSO=1,NBISO2 ! microlib isotope IF(IMIX2(JSO).NE.IBM) CYCLE WRITE(TEXT8,'(2A4)') HUSE2(1,JSO),HUSE2(2,JSO) IF(HISO(IBM,KSO).EQ.TEXT8) THEN ITOD2(JSO)=ITODO(IBM,KSO) IF(CONC(IBM,KSO).EQ.-99.99) THEN * -- Only number densities of isotopes set with "MICR" and * -- "*" keywords are interpolated DENS2(JSO)=0.0 DO ISO=1,NBISO1 ! Apex file isotope IF(JJSO(ISO).EQ.JSO) DENS2(JSO)=DENS2(JSO)+DENS3(ISO) ENDDO ELSE IF(CONC(IBM,KSO).NE.-99.99) THEN * -- Number densities of isotopes set with "MICR" and * -- fixed value are forced to this value DENS2(JSO)=CONC(IBM,KSO) ENDIF GO TO 110 ENDIF ENDDO WRITE(HSMG,'(31HACRLIB: UNABLE TO FIND ISOTOPE ,A8,6H IN MI, 1 5HXTURE,I8,1H.)') HISO(IBM,KSO),IBM CALL XABORT(HSMG) 110 CONTINUE ELSE * -- Number densities are interpolated or not according to * -- ALL/ONLY option DO JSO=1,NBISO2 ! microlib isotope WRITE(TEXT8,'(2A4)') HUSE2(1,JSO),HUSE2(2,JSO) IF(IBM.EQ.IMIX2(JSO)) THEN DO ISO=1,NBISO1 ! Apex file isotope IF(HNOMIS(ISO).EQ.TEXT8) THEN DENS2(JSO)=0.0 VOL2(JSO)=0.0 CYCLE ENDIF ENDDO ENDIF ENDDO DO 130 ISO=1,NBISO1 ! Apex file isotope IF(.NOT.LISO(IBM)) THEN * --ONLY option DO KSO=1,NISO(IBM) ! user-selected isotope IF(HNOMIS(ISO).EQ.HISO(IBM,KSO)) GO TO 120 ENDDO GO TO 130 ENDIF 120 JSO=JJSO(ISO) IF(JSO.GT.0) THEN ITOD2(JSO)=ITOD1(ISO) ISTY2(JSO)=ISTY1(ISO) DENS2(JSO)=DENS2(JSO)+DENS3(ISO) VOL2(JSO)=VOL2(JSO)+XVOLM(IBMOLD) ENDIF 130 CONTINUE ENDIF *---- * SET PIFI INFORMATION *---- ALLOCATE(IMICR(NBISO1)) IMICR(:NBISO1)=0 NBS1=0 DO 140 JSO=1,NBISO2 ! microlib isotope IF(IMIX2(JSO).EQ.IBM) THEN NBS1=NBS1+1 IF(NBS1.GT.NBISO1) CALL XABORT('ACRLIB: NBISO1 OVERFLOW.') IMICR(NBS1)=JSO ENDIF 140 CONTINUE DO 170 ISO=1,NBS1 ! Apex file isotope JSO=IMICR(ISO) KPLIB=LCMDIL(JPLIB,JSO) ! step up isot JSO CALL LCMLEN(KPLIB,'PYIELD',LMY1,ITYLCM) IF(LMY1.GT.0) THEN ALLOCATE(HPYNAM(LMY1),IPYMIX(LMY1),IPIFI(LMY1)) IPIFI(:LMY1)=0 CALL LCMGTC(KPLIB,'PYNAM',8,LMY1,HPYNAM) CALL LCMGET(KPLIB,'PYMIX',IPYMIX) DO 160 IY1=1,LMY1 IF(HPYNAM(IY1).NE.' ') THEN DO 150 KSO=1,NBS1 LSO=IMICR(KSO) WRITE(TEXT8,'(2A4)') HUSE2(:2,LSO) IF((HPYNAM(IY1).EQ.TEXT8).AND.(IPYMIX(IY1).EQ.IMIX2(LSO))) 1 THEN IPIFI(IY1)=LSO GO TO 160 ENDIF 150 CONTINUE IF(IPIFI(IY1).EQ.0) THEN WRITE(HSMG,'(40HACRLIB: FAILURE TO FIND FISSILE ISOTOPE , 1 A12,25H AMONG MICROLIB ISOTOPES.)') HPYNAM(IY1) CALL XABORT(HSMG) ENDIF ENDIF 160 CONTINUE CALL LCMPUT(KPLIB,'PIFI',LMY1,1,IPIFI) DEALLOCATE(IPIFI,IPYMIX,HPYNAM) ENDIF 170 CONTINUE DEALLOCATE(IMICR) 180 CONTINUE ! end of loop over microlib mixtures. *---- * RELEASE MEMORY *---- DEALLOCATE(FACT,DENS1) IF(NPRC.GT.0) DEALLOCATE(INVELSB,BETARB,CHIRSB,INVELS,BETAR, 1 CHIRS,LAMB) DEALLOCATE(LXS,XS,SS2D,SIGS,NWT0,TAUXFI) DEALLOCATE(ITOD1,YLDSM) IF(NBISO.GT.0) DEALLOCATE(NOMISO) DEALLOCATE(JJSO,DENS0,XVOLM,HNOMIS,IRESM,ITOTM) *---- * MICROLIB FINALIZATION *---- IF(.NOT.LRES) THEN ISTATE(:NSTATE)=0 ISTATE(1)=NMIX ISTATE(2)=NBISO2 ISTATE(3)=NGRP ISTATE(4)=NL ISTATE(5)=ITRANC ISTATE(7)=1 IF(ITER.EQ.3) ISTATE(12)=NMIX ISTATE(13)=NED2 ISTATE(14)=NMIX ISTATE(18)=1 ISTATE(19)=NPRC ISTATE(20)=MY1 ISTATE(22)=MAXISO/NMIX IF(NSURFD.GT.0) ISTATE(24)=3 ! ADF/CPDF information IF(NBISO2.EQ.0) CALL XABORT('ACRLIB: NBISO2=0.') CALL LCMPUT(IPLIB,'STATE-VECTOR',NSTATE,1,ISTATE) CALL LCMPUT(IPLIB,'MIXTURESVOL',NMIX,2,VOLMI2) CALL LCMPUT(IPLIB,'ISOTOPESUSED',3*NBISO2,3,HUSE2) CALL LCMPUT(IPLIB,'ISOTOPERNAME',3*NBISO2,3,HNAM2) CALL LCMPUT(IPLIB,'ISOTOPESDENS',NBISO2,2,DENS2) CALL LCMPUT(IPLIB,'ISOTOPESMIX',NBISO2,1,IMIX2) CALL LCMPUT(IPLIB,'ISOTOPESVOL',NBISO2,2,VOL2) IF(NED2.GT.0) CALL LCMPTC(IPLIB,'ADDXSNAME-P0',8,NED2,HVECT2) CALL LCMPUT(IPLIB,'ISOTOPESTODO',NBISO2,1,ITOD2) CALL LCMPUT(IPLIB,'ISOTOPESTYPE',NBISO2,1,ISTY2) ELSE IF(LRES.AND.(NBISO.GT.0)) THEN CALL LCMPUT(IPLIB,'ISOTOPESDENS',NBISO2,2,DENS2) CALL LCMPUT(IPLIB,'ISOTOPESVOL',NBISO2,2,VOL2) ENDIF IF(IMPX.GT.5) CALL LCMLIB(IPLIB) IACCS=1 *---- * COMPUTE THE MACROSCOPIC X-SECTIONS *---- IF((ITER.NE.0).AND.(ITER.NE.3)) GO TO 280 CALL LCMGET(IPLIB,'STATE-VECTOR',ISTATE) MAXMIX=ISTATE(1) IF(MAXMIX.NE.NMIX) CALL XABORT('ACRLIB: INVALID NMIX.') NBISO=ISTATE(2) ALLOCATE(MASK(MAXMIX),MASKL(NGRP)) ALLOCATE(ISONA(3*NBISO),ISOMI(NBISO),DENIS(NBISO)) CALL LCMGET(IPLIB,'ISOTOPESUSED',ISONA) CALL LCMGET(IPLIB,'ISOTOPESMIX',ISOMI) CALL LCMGET(IPLIB,'ISOTOPESDENS',DENIS) MASK(:MAXMIX)=.TRUE. MASKL(:NGRP)=.TRUE. ITSTMP=0 TMPDAY(1)=0.0 TMPDAY(2)=0.0 TMPDAY(3)=0.0 CALL LCMLEN(IPLIB,'MACROLIB',ILONG,ITYLCM) IF(ILONG.NE.0) CALL LCMDEL(IPLIB,'MACROLIB') CALL LIBMIX(IPLIB,MAXMIX,NGRP,NBISO,ISONA,ISOMI,DENIS,MASK,MASKL, 1 ITSTMP,TMPDAY) DEALLOCATE(MASKL,MASK) DEALLOCATE(DENIS,ISOMI,ISONA) IF(NSURFD.GT.0) THEN CALL LCMSIX(IPLIB,'MACROLIB',1) CALL LCMGET(IPLIB,'STATE-VECTOR',ISTATE) ISTATE(12)=3 ! ADF information CALL LCMPUT(IPLIB,'STATE-VECTOR',NSTATE,1,ISTATE) CALL LCMSIX(IPLIB,' ',2) ENDIF *---- * INCLUDE LEAKAGE IN THE MACROLIB (USED ONLY FOR NON-REGRESSION TESTS) *---- IF(B2.NE.0.0) THEN IF(IMPX.GT.0) WRITE(IOUT,'(/31H ACRLIB: INCLUDE LEAKAGE IN THE, 1 14H MACROLIB (B2=,1P,E12.5,2H).)') B2 CALL LCMSIX(IPLIB,'MACROLIB',1) JPLIB=LCMGID(IPLIB,'GROUP') ALLOCATE(GAR1(NMIX),GAR2(NMIX)) DO 270 IGR=1,NGRP KPLIB=LCMGIL(JPLIB,IGR) CALL LCMGET(KPLIB,'NTOT0',GAR1) CALL LCMGET(KPLIB,'DIFF',GAR2) DO 260 IBM=1,NMIX IF(MIXC(IBM).NE.0) GAR1(IBM)=GAR1(IBM)+B2*GAR2(IBM) 260 CONTINUE CALL LCMPUT(KPLIB,'NTOT0',NMIX,2,GAR1) 270 CONTINUE DEALLOCATE(GAR2,GAR1) CALL LCMSIX(IPLIB,' ',2) ENDIF *---- * PROCESS ADF INFORMATION *---- 280 IF(NSURFD.GT.0) THEN DO 285 IBM=1,NMIX ! mixtures in Macrolib IF(MIXC(IBM).NE.0) ADF2(IBM,:NGRP,:NSURFD)=0.0 285 CONTINUE DO 300 ICAL=1,NCAL DO 290 IBM=1,NMIX ! mixtures in Macrolib IBMOLD=MIXC(IBM) IF(IBMOLD.EQ.0) GO TO 290 WEIGHT=TERP(ICAL,IBM) IF(WEIGHT.EQ.0.0) GO TO 290 WRITE(RECNAM,'(4Hcalc,I8,15H/miscellaneous/)') ICAL K=0 CALL hdf5_info(IPAPX,TRIM(RECNAM)//"ADF",RANK,TYPE,NBYTE,DIMSR) IF(TYPE.NE.99) THEN HHAD(K+1)='ADF' K=K+1 ENDIF CALL hdf5_info(IPAPX,TRIM(RECNAM)//"CPDF",RANK,TYPE,NBYTE,DIMSR) IF(TYPE.NE.99) THEN HHAD(K+1)='CPDF' K=K+1 ENDIF CALL hdf5_info(IPAPX,TRIM(RECNAM)//"INTERNAL_ADF",RANK,TYPE, 1 NBYTE,DIMSR) IF(TYPE.NE.99) THEN HHAD(K+1)='INTERNAL_ADF' K=K+1 ENDIF CALL hdf5_info(IPAPX,TRIM(RECNAM)//"INTERNAL_CPDF",RANK,TYPE, 1 NBYTE,DIMSR) IF(TYPE.NE.99) THEN HHAD(K+1)='INTERNAL_CPDF' K=K+1 ENDIF IF(4*K.NE.NSURFD) CALL XABORT('ACRLIB: INVALID ADF COUNT.') DO I=1,K CALL hdf5_get_shape(IPAPX,TRIM(RECNAM)//HHAD(I),DIMS_APX) ISURF=DIMS_APX(1) DEALLOCATE(DIMS_APX) CALL hdf5_read_data(IPAPX,TRIM(RECNAM)//HHAD(I),ADF) DO I0=1,ISURF IF(HHAD(I).EQ.'ADF') THEN WRITE(TEXT8,'(3HADF,I1)') I0 ELSE IF(HHAD(I).EQ.'CPDF') THEN WRITE(TEXT8,'(4HCPDF,I1)') I0 ELSE IF(HHAD(I).EQ.'INTERNAL_ADF') THEN WRITE(TEXT8,'(6HIN_ADF,I1)') I0 ELSE IF(HHAD(I).EQ.'INTERNAL_CPDF') THEN WRITE(TEXT8,'(7HIN_CPDF,I1)') I0 ENDIF IOF=(I-1)*ISURF+I0 HADF(IOF)=TEXT8 DO IGR=1,NGRP ADF2(IBM,IGR,IOF)=ADF2(IBM,IGR,IOF)+WEIGHT*ADF(I0,IGR) ENDDO ENDDO DEALLOCATE(ADF) ENDDO 290 CONTINUE 300 CONTINUE CALL LCMSIX(IPLIB,'MACROLIB',1) CALL LCMSIX(IPLIB,'ADF',1) CALL LCMPUT(IPLIB,'NTYPE',1,1,NSURFD) CALL LCMPTC(IPLIB,'HADF',8,NSURFD,HADF) DO I=1,NSURFD CALL LCMPUT(IPLIB,HADF(I),NMIX*NGRP,2,ADF2(1,1,I)) ENDDO CALL LCMSIX(IPLIB,' ',2) CALL LCMSIX(IPLIB,' ',2) ENDIF *---- * SCRATCH STORAGE DEALLOCATION *---- DEALLOCATE(ADF2,HADF) DEALLOCATE(SPH,FLUX,VOLMI2,VOL2,DENS3,DENS2) DEALLOCATE(HNAM2,HUSE2,ISTY2,ISTY1,ITOD2,IMIX2) RETURN END