*DECK MCRMAC SUBROUTINE MCRMAC(IPMAC,IPMPO,IACCS,NMIL,NMIX,NGRP,LADFM,IMPX, 1 HEQUI,HMASL,NCAL,HEDIT,NSURFD,NALBP,ILUPS,MIXC,TERP,LPURE,B2) * *----------------------------------------------------------------------- * *Purpose: * Build the Macrolib by scanning the NCAL elementary calculations of * a HDF5 file and weighting them with TERP factors. * *Copyright: * Copyright (C) 2022 Ecole Polytechnique de Montreal * *Author(s): * A. Hebert * *Parameters: input * IPMAC address of the output Macrolib LCM object. * IPMPO pointer to the MPO file. * IACCS =0 macrolib is created; =1 ... is updated. * NMIL number of material mixtures in the MPO file. * NMIX maximum number of material mixtures in the Macrolib. * NGRP number of energy groups. * LADFM type of discontinuity factors (.true.: diagonal; .false.: GxG). * IMPX print parameter (equal to zero for no print). * HEQUI keyword of SPH-factor set to be recovered. * HMASL keyword of MASL data set to be recovered. * NCAL number of elementary calculations in the MPO file. * HEDIT name of output group for a (multigroup mesh, output geometry) * couple (generally equal to 'output_0'). * NSURFD number of discontinuity factors. * NALBP number of physical albedos per energy group. * ILUPS up-scattering removing flag (=1 to remove up-scattering from * output cross-sections). * MIXC mixture index in the MPO file corresponding to each Microlib. * mixture. Equal to zero if a Microlib mixture is not updated. * TERP interpolation factors. * LPURE =.true. if the interpolation is a pure linear interpolation * with TERP factors. * B2 buckling. * *----------------------------------------------------------------------- * USE GANLIB USE hdf5_wrap IMPLICIT NONE *---- * SUBROUTINE ARGUMENTS *---- TYPE(C_PTR) IPMAC,IPMPO INTEGER IACCS,NMIL,NMIX,NGRP,IMPX,NCAL,NSURFD,NALBP,ILUPS, 1 MIXC(NMIX) REAL TERP(NCAL,NMIX),B2 LOGICAL LADFM,LPURE CHARACTER(LEN=80) HEQUI,HMASL CHARACTER(LEN=12) HEDIT *---- * LOCAL VARIABLES *---- INTEGER, PARAMETER::IOUT=6 INTEGER, PARAMETER::MAX1D=40 INTEGER, PARAMETER::MAX2D=20 INTEGER, PARAMETER::MAXED=30 INTEGER, PARAMETER::MAXNFI=1 INTEGER, PARAMETER::MAXNL=6 INTEGER, PARAMETER::NSTATE=40 INTEGER, PARAMETER::MAXRES=MAX1D-8 INTEGER I, J, I1D, I2D, IBM, IBMOLD, ICAL, IDEL, IDF, IED, IGMAX, & IGMIN, IGR, JGR, IL, ILONG, IOF, IPOSDE, ITRANC, ITYLCM, LENGTH, & N1D, N2D, NDEL, NED, NEDTMP, NF, NFTMP, NL, NLTMP, IMC, ID, ID_E, & ID_G, NENERG, NGEOME, IACCOLD, NALBP2, RANK, NBYTE, TYPE, & DIMSR(5) REAL FLOTVA, WEIGHT, B2R TYPE(C_PTR) JPMAC,KPMAC,IPTMP,JPTMP,KPTMP INTEGER ISTATE(NSTATE) LOGICAL LMAKE1(MAX1D),LMAKE2(MAX2D),LWD,LALBG CHARACTER TEXT8*8,TEXT12*12,CM*2,HMAK1(MAX1D)*12,HMAK2(MAX2D)*12, 1 HVECT(MAXED)*8,RECNAM*80 *---- * ALLOCATABLE ARRAYS *---- INTEGER, ALLOCATABLE, DIMENSION(:) :: IJJ,NJJ,IPOS,IJJB,NJJB,IPOSB INTEGER, ALLOCATABLE, DIMENSION(:,:) :: OUPUTID REAL, ALLOCATABLE, DIMENSION(:) :: GAR4,GAR4B,WORK1,WORK2,VOLMI2, 1 ENERG,VOSAP,WDLA REAL, ALLOCATABLE, DIMENSION(:,:) :: SPH REAL, ALLOCATABLE, DIMENSION(:,:,:) :: GAR1 REAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: GAR2,GAR3 REAL, POINTER, DIMENSION(:) :: FLOT TYPE(C_PTR) FLOT_PTR *---- * DATA STATEMENTS *---- DATA HMAK1 / 'FLUX-INTG','NTOT0','OVERV','DIFF','FLUX-INTG-P1', 1 'NTOT1','H-FACTOR','TRANC',MAXRES*' '/ *---- * SCRATCH STORAGE ALLOCATION *---- ALLOCATE(IJJ(NMIX),NJJ(NMIX),IPOS(NMIX),IJJB(NMIL),NJJB(NMIL), 1 IPOSB(NMIL)) ALLOCATE(GAR1(NMIX,NGRP,MAX1D),GAR2(NMIX,MAXNFI,NGRP,MAX2D), 1 GAR3(NMIX,NGRP,NGRP,MAXNL),GAR4(NMIX*NGRP),GAR4B(NMIL*NGRP), 2 VOLMI2(NMIX)) IACCOLD=IACCS ! for ADF *---- * MACROLIB INITIALIZATION *---- LMAKE1(:MAX1D)=.FALSE. LMAKE2(:MAX2D)=.FALSE. GAR1(:NMIX,:NGRP,:MAX1D)=0.0 GAR2(:NMIX,:MAXNFI,:NGRP,:MAX2D)=0.0 GAR3(:NMIX,:NGRP,:NGRP,:MAXNL)=0.0 VOLMI2(:NMIX)=0.0 IBMOLD=0 N1D=0 N2D=0 NDEL=0 NL=0 NF=0 NED=0 ITRANC=0 IDF=0 N1D=0 N2D=0 *---- * READ EXISTING MACROLIB INFORMATION *---- IF(IACCS.EQ.0) THEN TEXT12='L_MACROLIB' CALL LCMPTC(IPMAC,'SIGNATURE',12,TEXT12) ELSE CALL LCMGTC(IPMAC,'SIGNATURE',12,TEXT12) IF(TEXT12.NE.'L_MACROLIB') THEN CALL XABORT('MCRMAC: SIGNATURE OF INPUT MACROLIB IS '//TEXT12 1 //'. L_MACROLIB EXPECTED.') ENDIF CALL LCMGET(IPMAC,'STATE-VECTOR',ISTATE) IF(ISTATE(1).NE.NGRP) THEN CALL XABORT('MCRMAC: INVALID NUMBER OF ENERGY GROUPS(2).') ELSE IF(ISTATE(2).NE.NMIX) THEN CALL XABORT('MCRMAC: INVALID NUMBER OF MIXTURES(2).') ENDIF NL=ISTATE(3) NF=ISTATE(4) IF(NF.GT.MAXNFI) CALL XABORT('MCRMAC: MAXNFI OVERFLOW(1).') NED=ISTATE(5) ITRANC=ISTATE(6) NDEL=ISTATE(7) IDF=ISTATE(12) IF(NED.GT.MAXED) CALL XABORT('MCRMAC: MAXED OVERFLOW(1).') CALL LCMGTC(IPMAC,'ADDXSNAME-P0',8,NED,HVECT) N1D=8+NED+NL N2D=2*(NDEL+1) IF(NL.GT.MAXNL) CALL XABORT('MCRMAC: MAXNL OVERFLOW(1).') IF(N1D.GT.MAX1D) CALL XABORT('MCRMAC: MAX1D OVERFLOW(1).') IF(N2D.GT.MAX2D) CALL XABORT('MCRMAC: MAX2D OVERFLOW(1).') DO 10 IED=1,NED HMAK1(8+IED)=HVECT(IED) 10 CONTINUE DO 20 IL=1,NL WRITE(CM,'(I2.2)') IL-1 HMAK1(8+NED+IL)='SIGS'//CM 20 CONTINUE HMAK2(1)='NUSIGF' HMAK2(2)='CHI' DO 30 IDEL=1,NDEL WRITE(TEXT8,'(6HNUSIGF,I2.2)') IDEL HMAK2(2+2*(IDEL-1)+1)=TEXT8 WRITE(TEXT8,'(3HCHI,I2.2)') IDEL HMAK2(2+2*(IDEL-1)+2)=TEXT8 30 CONTINUE CALL LCMGET(IPMAC,'STATE-VECTOR',ISTATE) JPMAC=LCMGID(IPMAC,'GROUP') DO 150 IGR=1,NGRP KPMAC=LCMGIL(JPMAC,IGR) DO 60 I1D=1,N1D CALL LCMLEN(KPMAC,HMAK1(I1D),ILONG,ITYLCM) IF(ILONG.NE.0) THEN CALL LCMGET(KPMAC,HMAK1(I1D),GAR1(1,IGR,I1D)) DO 50 IBM=1,NMIX DO 40 IBMOLD=1,NMIL IF(MIXC(IBM).EQ.IBMOLD) GAR1(IBM,IGR,I1D)=0.0 40 CONTINUE 50 CONTINUE ENDIF 60 CONTINUE DO 100 I2D=1,N2D CALL LCMLEN(KPMAC,HMAK2(I2D),ILONG,ITYLCM) IF(ILONG.NE.0) THEN CALL LCMGET(KPMAC,HMAK2(I2D),GAR2(1,1,IGR,I2D)) DO 90 I=1,NF DO 80 IBM=1,NMIX DO 70 IBMOLD=1,NMIL IF(MIXC(IBM).EQ.IBMOLD) GAR2(IBM,I,IGR,I2D)=0.0 70 CONTINUE 80 CONTINUE 90 CONTINUE ENDIF 100 CONTINUE DO 140 IL=1,NL WRITE(CM,'(I2.2)') IL-1 ILONG=1 IF(IL.GT.1) CALL LCMLEN(KPMAC,'SCAT'//CM,ILONG,ITYLCM) IF(ILONG.NE.0) THEN CALL LCMGET(KPMAC,'SCAT'//CM,GAR4) CALL LCMGET(KPMAC,'NJJS'//CM,NJJ) CALL LCMGET(KPMAC,'IJJS'//CM,IJJ) CALL LCMGET(KPMAC,'IPOS'//CM,IPOS) DO 130 IBM=1,NMIX IPOSDE=IPOS(IBM) DO 120 JGR=IJJ(IBM),IJJ(IBM)-NJJ(IBM)+1,-1 GAR3(IBM,JGR,IGR,IL)=GAR4(IPOSDE) DO 110 IBMOLD=1,NMIL IF(MIXC(IBM).EQ.IBMOLD) GAR3(IBM,JGR,IGR,IL)=0.0 110 CONTINUE IPOSDE=IPOSDE+1 120 CONTINUE 130 CONTINUE ENDIF 140 CONTINUE 150 CONTINUE ENDIF *---- * SET ENERGY MESH AND ZONE VOLUMES *---- CALL hdf5_read_data(IPMPO,"/energymesh/NENERGYMESH",NENERG) CALL hdf5_read_data(IPMPO,"/geometry/NGEOMETRY",NGEOME) CALL hdf5_read_data(IPMPO,"/output/OUPUTID",OUPUTID) READ(HEDIT,'(7X,I2)') ID ID_G=0 ID_E=0 DO I=1,NGEOME DO J=1,NENERG IF(OUPUTID(J,I).EQ.ID) THEN ID_G=I-1 ID_E=J-1 GO TO 160 ENDIF ENDDO ENDDO CALL XABORT('MCRMAC: no ID found in /output/OUPUTID.') 160 WRITE(RECNAM,'(23H/energymesh/energymesh_,I0)') ID_E CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"/ENERGY",ENERG) IF(SIZE(ENERG,1)-1.NE.NGRP) CALL XABORT('MCRMAC: INVALID NGRP VA' 1 //'LUE.') DO IGR=1,NGRP+1 ENERG(IGR)=ENERG(IGR)/1.0E-6 ENDDO WRITE(RECNAM,'(19H/geometry/geometry_,I0,1H/)') ID_G CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"ZONEVOLUME",VOSAP) *---- * OVERALL ELEMENTARY CALCULATION LOOP *---- DO 300 ICAL=1,NCAL DO 170 IBM=1,NMIX ! mixtures in Macrolib WEIGHT=TERP(ICAL,IBM) IF(WEIGHT.NE.0.0) GO TO 180 170 CONTINUE GO TO 300 *---- * PRODUCE AN ELEMENTARY MACROLIB *---- 180 CALL LCMOP(IPTMP,'*ELEMENTARY*',0,1,0) ALLOCATE(SPH(NMIL+NALBP,NGRP)) CALL LCMPUT(IPTMP,'ENERGY',NGRP+1,2,ENERG) B2R=B2 CALL SPHMPO(IPMPO,IPTMP,ICAL,IMPX,HEQUI,HMASL,NMIL,NALBP,NGRP, 1 HEDIT,VOSAP,ILUPS,SPH,B2R) *---- * RECOVER MACROLIB PARAMETERS *---- CALL LCMGET(IPTMP,'STATE-VECTOR',ISTATE) NLTMP=ISTATE(3) NFTMP=ISTATE(4) NEDTMP=ISTATE(5) IF(NLTMP.GT.MAXNL) CALL XABORT('MCRMAC: MAXNL OVERFLOW(2).') IF(NFTMP.GT.MAXNFI) CALL XABORT('MCRMAC: MAXNFI OVERFLOW(2).') IF(NEDTMP.GT.MAXED) CALL XABORT('MCRMAC: MAXED OVERFLOW(2).') IF(IACCS.EQ.0) THEN IF(ISTATE(1).NE.NGRP) THEN CALL XABORT('MCRMAC: INVALID NUMBER OF ENERGY GROUPS(3).') ELSE IF(ISTATE(2).NE.NMIL) THEN CALL XABORT('MCRMAC: INVALID NUMBER OF MIXTURES(3).') ENDIF NL=NLTMP NF=NFTMP NED=NEDTMP ITRANC=ISTATE(6) NDEL=ISTATE(7) IDF=ISTATE(12) CALL LCMGTC(IPTMP,'ADDXSNAME-P0',8,NED,HVECT) N1D=8+NED+NL N2D=2*(NDEL+1) IF(N1D.GT.MAX1D) CALL XABORT('MCRMAC: MAX1D OVERFLOW(2).') IF(N2D.GT.MAX2D) CALL XABORT('MCRMAC: MAX2D OVERFLOW(2).') DO 190 IED=1,NED HMAK1(8+IED)=HVECT(IED) 190 CONTINUE DO 200 IL=1,NL WRITE(CM,'(I2.2)') IL-1 HMAK1(8+NED+IL)='SIGS'//CM 200 CONTINUE HMAK2(1)='NUSIGF' HMAK2(2)='CHI' DO 210 IDEL=1,NDEL WRITE(TEXT8,'(6HNUSIGF,I2.2)') IDEL HMAK2(2+2*(IDEL-1)+1)=TEXT8 WRITE(TEXT8,'(3HCHI,I2.2)') IDEL HMAK2(2+2*(IDEL-1)+2)=TEXT8 210 CONTINUE ELSE IF(NLTMP.GT.NL) CALL XABORT('MCRMAC: NL OVERFLOW.') ITRANC=MAX(ITRANC,ISTATE(6)) IF(ISTATE(1).NE.NGRP) THEN CALL XABORT('MCRMAC: INVALID NUMBER OF ENERGY GROUPS(3).') ELSE IF(ISTATE(2).NE.NMIL)THEN CALL XABORT('MCRMAC: INVALID NUMBER OF MIXTURES(3).') ELSE IF((NFTMP.NE.0).AND.(NFTMP.NE.NF)) THEN CALL XABORT('MCRMAC: INVALID NUMBER OF FISSILE ISOTOPES(3).') ELSE IF(ISTATE(7).NE.NDEL) THEN CALL XABORT('MCRMAC: INVALID NUMBER OF PRECURSOR GROUPS(3).') ELSE IF(LADFM.AND.(ISTATE(12).NE.IDF)) THEN CALL XABORT('MCRMAC: INVALID TYPE OF ADF DIRECTORY.') ENDIF ENDIF *---- * SPH CORRECTION OF MACROLIB INFORMATION *---- IMC=1 ! SPH correction for SPN macro-calculation CALL SPHCMA(IPTMP,IMPX,IMC,NMIL,NGRP,NFTMP,NEDTMP,NALBP,SPH) DEALLOCATE(SPH) *---- * RECOVER VOLUMES, ENERGY GROUPS, EDIT NAMES, AND LAMBDA-D. *---- CALL LCMLEN(IPTMP,'VOLUME',ILONG,ITYLCM) IF(ILONG.EQ.NMIL) THEN DO 220 IBM=1,NMIX ! mixtures in Macrolib IBMOLD=MIXC(IBM) ! mixture in MPO file IF(IBMOLD.NE.0) VOLMI2(IBM)=VOSAP(IBMOLD) 220 CONTINUE ENDIF CALL LCMLEN(IPTMP,'ENERGY',ILONG,ITYLCM) IF(ILONG.EQ.NGRP+1) CALL LCMGET(IPTMP,'ENERGY',ENERG) CALL LCMLEN(IPTMP,'LAMBDA-D',LENGTH,ITYLCM) LWD=(LENGTH.EQ.NDEL).AND.(NDEL.GT.0) IF(LWD) THEN ALLOCATE(WDLA(NDEL)) CALL LCMGET(IPTMP,'LAMBDA-D',WDLA) CALL LCMPUT(IPMAC,'LAMBDA-D',NDEL,2,WDLA) DEALLOCATE(WDLA) ENDIF *---- * PERFORM INTERPOLATION *---- JPTMP=LCMGID(IPTMP,'GROUP') DO 290 IBM=1,NMIX ! mixtures in Macrolib WEIGHT=TERP(ICAL,IBM) IF(WEIGHT.EQ.0.0) GO TO 290 IBMOLD=MIXC(IBM) ! mixture in MPO file IF(IBMOLD.EQ.0) GO TO 290 * DO 280 IGR=1,NGRP KPTMP=LCMGIL(JPTMP,IGR) DO 230 I1D=1,N1D CALL LCMLEN(KPTMP,HMAK1(I1D),ILONG,ITYLCM) IF(ILONG.NE.0) THEN CALL LCMGPD(KPTMP,HMAK1(I1D),FLOT_PTR) CALL C_F_POINTER(FLOT_PTR,FLOT,(/ ILONG /)) FLOTVA=FLOT(IBMOLD) IF(FLOTVA.NE.0.0) LMAKE1(I1D)=.TRUE. IF((.NOT.LPURE).AND.(I1D.EQ.4)) FLOTVA=1.0/FLOTVA GAR1(IBM,IGR,I1D)=GAR1(IBM,IGR,I1D)+WEIGHT*FLOTVA ENDIF 230 CONTINUE IF(ISTATE(4).GT.0) THEN DO 250 I2D=1,N2D CALL LCMLEN(KPTMP,HMAK2(I2D),ILONG,ITYLCM) IF(ILONG.NE.0) THEN CALL LCMGPD(KPTMP,HMAK2(I2D),FLOT_PTR) CALL C_F_POINTER(FLOT_PTR,FLOT,(/ ILONG /)) DO 240 I=1,NF IOF=(IBMOLD-1)*NF+I IF(FLOT(IOF).NE.0.0) LMAKE2(I2D)=.TRUE. GAR2(IBM,I,IGR,I2D)=GAR2(IBM,I,IGR,I2D)+WEIGHT*FLOT(IOF) 240 CONTINUE ENDIF 250 CONTINUE ENDIF DO 270 IL=1,NLTMP WRITE(CM,'(I2.2)') IL-1 CALL LCMLEN(KPTMP,'SCAT'//CM,ILONG,ITYLCM) IF(ILONG.NE.0) THEN CALL LCMGET(KPTMP,'SCAT'//CM,GAR4B) CALL LCMGET(KPTMP,'NJJS'//CM,NJJB) CALL LCMGET(KPTMP,'IJJS'//CM,IJJB) CALL LCMGET(KPTMP,'IPOS'//CM,IPOSB) IPOSDE=IPOSB(IBMOLD) DO 260 JGR=IJJB(IBMOLD),IJJB(IBMOLD)-NJJB(IBMOLD)+1,-1 GAR3(IBM,JGR,IGR,IL)=GAR3(IBM,JGR,IGR,IL)+WEIGHT*GAR4B(IPOSDE) IPOSDE=IPOSDE+1 260 CONTINUE ENDIF 270 CONTINUE 280 CONTINUE 290 CONTINUE CALL LCMCL(IPTMP,2) 300 CONTINUE *---- * WRITE INTERPOLATED MACROLIB INFORMATION *---- CALL LCMPUT(IPMAC,'VOLUME',NMIX,2,VOLMI2) CALL LCMPUT(IPMAC,'ENERGY',NGRP+1,2,ENERG) IF(NED.GT.0) CALL LCMPTC(IPMAC,'ADDXSNAME-P0',8,NED,HVECT) JPMAC=LCMLID(IPMAC,'GROUP',NGRP) DO 410 IGR=1,NGRP KPMAC=LCMDIL(JPMAC,IGR) DO 350 I1D=1,N1D IF(LMAKE1(I1D)) THEN IF((.NOT.LPURE).AND.(I1D.EQ.4)) THEN DO 320 IBM=1,NMIX DO 310 IBMOLD=1,NMIL IF(MIXC(IBM).EQ.IBMOLD) GAR1(IBM,IGR,I1D)=1./GAR1(IBM,IGR,I1D) 310 CONTINUE 320 CONTINUE ELSE IF(I1D.EQ.7) THEN DO 340 IBM=1,NMIX DO 330 IBMOLD=1,NMIL IF(MIXC(IBM).EQ.IBMOLD) GAR1(IBM,IGR,I1D)=GAR1(IBM,IGR,I1D)* 1 1.0E6 ! convert MeV to eV 330 CONTINUE 340 CONTINUE ENDIF CALL LCMPUT(KPMAC,HMAK1(I1D),NMIX,2,GAR1(1,IGR,I1D)) ENDIF 350 CONTINUE DO 360 I2D=1,N2D IF(LMAKE2(I2D).AND.(NF.GT.0)) THEN CALL LCMPUT(KPMAC,HMAK2(I2D),NMIX*NF,2,GAR2(1,1,IGR,I2D)) ENDIF 360 CONTINUE DO 400 IL=1,NL WRITE(CM,'(I2.2)') IL-1 IPOSDE=0 DO 390 IBM=1,NMIX IPOS(IBM)=IPOSDE+1 IGMIN=IGR IGMAX=IGR DO 370 JGR=1,NGRP IF(GAR3(IBM,JGR,IGR,IL).NE.0.0) THEN IGMIN=MIN(IGMIN,JGR) IGMAX=MAX(IGMAX,JGR) ENDIF 370 CONTINUE IJJ(IBM)=IGMAX NJJ(IBM)=IGMAX-IGMIN+1 DO 380 JGR=IGMAX,IGMIN,-1 IPOSDE=IPOSDE+1 GAR4(IPOSDE)=GAR3(IBM,JGR,IGR,IL) 380 CONTINUE 390 CONTINUE IF(IPOSDE.GT.0) THEN CALL LCMPUT(KPMAC,'SCAT'//CM,IPOSDE,2,GAR4) CALL LCMPUT(KPMAC,'NJJS'//CM,NMIX,1,NJJ) CALL LCMPUT(KPMAC,'IJJS'//CM,NMIX,1,IJJ) CALL LCMPUT(KPMAC,'IPOS'//CM,NMIX,1,IPOS) CALL LCMPUT(KPMAC,'SIGW'//CM,NMIX,2,GAR3(1,IGR,IGR,IL)) ENDIF 400 CONTINUE 410 CONTINUE IACCS=1 *---- * UPDATE STATE-VECTOR *---- ISTATE(2)=NMIX ISTATE(3)=NL ISTATE(4)=NF ISTATE(5)=NED ISTATE(6)=ITRANC IF(LMAKE1(6)) ISTATE(10)=1 CALL LCMPUT(IPMAC,'STATE-VECTOR',NSTATE,1,ISTATE) *---- * INCLUDE LEAKAGE IN THE MACROLIB (USED ONLY FOR NON-REGRESSION TESTS) *---- IF(B2.NE.0.0) THEN IF(IMPX.GT.0) WRITE(IOUT,'(/31H MCRMAC: INCLUDE LEAKAGE IN THE, 1 14H MACROLIB (B2=,1P,E12.5,2H).)') B2 JPMAC=LCMGID(IPMAC,'GROUP') ALLOCATE(WORK1(NMIX),WORK2(NMIX)) DO 430 IGR=1,NGRP KPMAC=LCMGIL(JPMAC,IGR) CALL LCMGET(KPMAC,'NTOT0',WORK1) CALL LCMGET(KPMAC,'DIFF',WORK2) DO 420 IBM=1,NMIX IF(MIXC(IBM).NE.0) WORK1(IBM)=WORK1(IBM)+B2*WORK2(IBM) 420 CONTINUE CALL LCMPUT(KPMAC,'NTOT0',NMIX,2,WORK1) 430 CONTINUE DEALLOCATE(WORK2,WORK1) ENDIF *---- * PROCESS ADF and physical albedos (if required) *---- LALBG=.TRUE. IF(NALBP.GT.0) THEN WRITE(RECNAM,'(8H/output/,A,16H/statept_0/flux/)') TRIM(HEDIT) CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"NALBP",NALBP2) IF(NALBP2.NE.NALBP) CALL XABORT('MCRMAC: INVALID NALBP.') CALL hdf5_info(IPMPO,TRIM(RECNAM)//"ALBEDOGxG",RANK,TYPE,NBYTE, & DIMSR) IF(TYPE.NE.99) LALBG=.FALSE. ENDIF CALL MCRAGF(IPMAC,IPMPO,IACCOLD,NMIL,NMIX,NGRP,NALBP,LALBG,LADFM, 1 IMPX,NCAL,TERP,MIXC,NSURFD,HEDIT,VOSAP,VOLMI2,IDF) IF(NSURFD.GT.0) THEN CALL LCMGET(IPMAC,'STATE-VECTOR',ISTATE) ISTATE(12)=IDF ! ADF information CALL LCMPUT(IPMAC,'STATE-VECTOR',NSTATE,1,ISTATE) ENDIF *---- * SCRATCH STORAGE DEALLOCATION *---- DEALLOCATE(VOSAP,ENERG) DEALLOCATE(VOLMI2,GAR4B,GAR4,GAR3,GAR2,GAR1) DEALLOCATE(IPOSB,NJJB,IJJB,IPOS,NJJ,IJJ) RETURN END