*DECK NCRMAC SUBROUTINE NCRMAC(MAXNIS,IPMAC,IPCPO,IACCS,NMIL,NMIX,NGRP,NGFF, 1 NALBP,IDF,IMPX,NCAL,TERP,NISO,LISO,HISO,CONC,MIXC,LRES,LPURE, 2 B2) * *----------------------------------------------------------------------- * *Purpose: * Build the macrolib by scanning the NCAL elementary calculations and * weighting them with TERP factors. * *Copyright: * Copyright (C) 2012 Ecole Polytechnique de Montreal * *Author(s): * A. Hebert * *Parameters: input * MAXNIS maximum value of NISO(I) in user data. * IPMAC address of the output macrolib LCM object. * IPCPO address of the multicompo object. * IACCS =0 macrolib is created; =1 ... is updated. * NMIL number of material mixtures in the multicompo. * NMIX maximum number of material mixtures in the macrolib. * NGRP number of energy groups. * NGFF number of group form factors per energy group. * NALBP number of physical albedos per energy group. * IDF ADF type, 0 = none, 1 = Albedo, 2 = FD_B/FD_C/..., 3 = ADF. * IMPX print parameter (equal to zero for no print). * NCAL number of elementary calculations in the multicompo. * 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 multicompo value * is used. * MIXC mixture index in the multicompo corresponding to each macrolib * mixture. Equal to zero if a macrolib 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. * B2 buckling * *----------------------------------------------------------------------- * USE GANLIB IMPLICIT NONE *---- * SUBROUTINE ARGUMENTS *---- TYPE(C_PTR) IPMAC,IPCPO INTEGER MAXNIS,IACCS,NMIL,NMIX,NGRP,NGFF,NALBP,IDF,IMPX,NCAL, 1 NISO(NMIX),HISO(2,NMIX,MAXNIS),MIXC(NMIX) REAL TERP(NCAL,NMIX),CONC(NMIX,MAXNIS),B2 LOGICAL LISO(NMIX),LRES,LPURE *---- * LOCAL VARIABLES *---- INTEGER, PARAMETER::IOUT=6 INTEGER, PARAMETER::MAXED=30 INTEGER, PARAMETER::MAX1D=40 INTEGER, PARAMETER::MAX2D=20 INTEGER, PARAMETER::MAXIFX=5 INTEGER, PARAMETER::MAXNFI=50 INTEGER, PARAMETER::MAXNL=6 INTEGER, PARAMETER::NSTATE=40 REAL FLOTVA, VOLMIX, WEIGHT INTEGER I0, I1D, I2D, IBMOLD, IBM, ICAL, IDEL, IED, IGMAX, IGMIN, & ILONG, IL, IPOSDE, ISOT, ISO, ITRAN, ITSTMP, ITYLCM, IGR, I, JGR, & KSO1, KSO, MAXMIX, N1D, N2D, NBISO, NDEL, NED, NF, NL, IW, NW, & NTYPE INTEGER ISTATE(NSTATE),NFINF,IACCOLD REAL TMPDAY(3) LOGICAL LUSER,LMAKE1(MAX1D),LMAKE2(MAX2D),LFAST CHARACTER TEXT8*8,TEXT12*12,HHISO*8,CM*2,HMAK1(MAX1D)*12, 1 HMAK2(MAX2D)*12,HVECT(MAXED)*8 TYPE(C_PTR) JPCPO,KPCPO,LPCPO,MPCPO,NPCPO,OPCPO,IPTMP,JPTMP,KPTMP, 1 JPMAC,KPMAC *---- * ALLOCATABLE ARRAYS *---- INTEGER, ALLOCATABLE, DIMENSION(:) :: IJJ,NJJ,IPOS,ISOMI REAL, ALLOCATABLE, DIMENSION(:) :: GAR4,XVOLM,WORK1,WORK2,ENERGY, 1 WDLA REAL, ALLOCATABLE, DIMENSION(:,:) :: FLUX REAL, ALLOCATABLE, DIMENSION(:,:,:) :: GAR1 REAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: GAR2,GAR3 LOGICAL, ALLOCATABLE, DIMENSION(:) :: MASKL,LWT CHARACTER(LEN=12), ALLOCATABLE, DIMENSION(:) :: HNAMIS INTEGER, POINTER, DIMENSION(:) :: ISONA REAL, POINTER, DIMENSION(:) :: DENIS,FLOT,NWT TYPE(C_PTR) ISONA_PTR,DENIS_PTR,FLOT_PTR,NWT_PTR *---- * SCRATCH STORAGE ALLOCATION *---- ALLOCATE(IJJ(NMIX),NJJ(NMIX),IPOS(NMIX)) ALLOCATE(GAR1(NMIX,NGRP,MAX1D),GAR2(NMIX,MAXNFI,NGRP,MAX2D), 1 GAR3(NMIX,NGRP,NGRP,MAXNL),GAR4(NMIX*NGRP)) IACCOLD=IACCS ! for ADF and GFF *---- * OVERALL MULTICOMPO MIXTURE LOOP *---- NTYPE=0 NFINF=0 JPCPO=LCMGID(IPCPO,'MIXTURES') DO 500 IBMOLD=1,NMIL IF(IMPX.GT.0) WRITE(IOUT,'(/33H NCRMAC: PROCESS MULTICOMPO MIXTU, 1 2HRE,I5)') IBMOLD KPCPO=LCMGIL(JPCPO,IBMOLD) LPCPO=LCMGID(KPCPO,'CALCULATIONS') *---- * MACROLIB INITIALIZATION *---- IF(IACCS.EQ.0) THEN MPCPO=LCMGIL(LPCPO,1) CALL LCMGET(MPCPO,'STATE-VECTOR',ISTATE) IF(ISTATE(1).NE.1) THEN CALL XABORT('NCRMAC: INVALID NUMBER OF MIXTURES(1).') ELSE IF(ISTATE(3).NE.NGRP) THEN CALL XABORT('NCRMAC: INVALID NUMBER OF ENERGY GROUPS(1).') ENDIF NBISO=ISTATE(2) NL=ISTATE(4) NF=0 ITRAN=ISTATE(5) NED=ISTATE(13) NDEL=ISTATE(19) IDF=ISTATE(24) NW=ISTATE(25) IF(NED.GT.MAXED) CALL XABORT('NCRMAC: MAXED OVERFLOW(1).') ALLOCATE(ENERGY(NGRP+1)) IF(NED.GT.0) CALL LCMGTC(MPCPO,'ADDXSNAME-P0',8,NED,HVECT) CALL LCMGET(MPCPO,'ENERGY',ENERGY) TEXT12='L_MACROLIB' CALL LCMPTC(IPMAC,'SIGNATURE',12,TEXT12) ISTATE(:NSTATE)=0 ISTATE(1)=NGRP ISTATE(2)=NMIX ISTATE(3)=NL ISTATE(5)=NED ISTATE(6)=ITRAN ISTATE(7)=NDEL ISTATE(8)=NALBP ISTATE(10)=NW ISTATE(12)=IDF ISTATE(16)=NGFF CALL LCMPUT(IPMAC,'STATE-VECTOR',NSTATE,1,ISTATE) CALL LCMPUT(IPMAC,'ENERGY',NGRP+1,2,ENERGY) IF(NED.GT.0) CALL LCMPTC(IPMAC,'ADDXSNAME-P0',8,NED,HVECT) DEALLOCATE(ENERGY) IF(NBISO.GT.0) THEN ALLOCATE(HNAMIS(NBISO)) CALL LCMGTC(MPCPO,'ISOTOPESUSED',12,NBISO,HNAMIS) NPCPO=LCMGID(MPCPO,'ISOTOPESLIST') DO ISO=1,NBISO OPCPO=LCMGIL(NPCPO,ISO) CALL LCMLEN(OPCPO,'LAMBDA-D',ILONG,ITYLCM) IF((ILONG.EQ.NDEL).AND.(NDEL.GT.0)) THEN ALLOCATE(WDLA(NDEL)) CALL LCMGET(OPCPO,'LAMBDA-D',WDLA) CALL LCMPUT(IPMAC,'LAMBDA-D',NDEL,2,WDLA) DEALLOCATE(WDLA) IF(HNAMIS(ISO).EQ.'U235') GO TO 10 IF(HNAMIS(ISO).EQ.'*MAC*RES') GO TO 10 ENDIF ENDDO 10 DEALLOCATE(HNAMIS) ENDIF IF(IDF.EQ.1) THEN NTYPE=2 ELSE IF(IDF.GE.2) THEN CALL LCMSIX(MPCPO,'MACROLIB',1) CALL LCMLEN(MPCPO,'ADF',ILONG,ITYLCM) IF(ILONG.EQ.0) CALL XABORT('NCRMAC: MISSING ADF DIRECTORY I' 1 //'N MULTICOMPO OBJECT.') CALL LCMSIX(MPCPO,'ADF',1) CALL LCMGET(MPCPO,'NTYPE',NTYPE) CALL LCMSIX(MPCPO,' ',2) CALL LCMSIX(MPCPO,' ',2) ENDIF IF(NGFF.NE.0) THEN CALL LCMSIX(MPCPO,'MACROLIB',1) CALL LCMLEN(MPCPO,'GFF',ILONG,ITYLCM) IF(ILONG.EQ.0) CALL XABORT('NCRMAC: MISSING GFF DIRECTORY I' 1 //'N MULTICOMPO OBJECT.') CALL LCMSIX(MPCPO,'GFF',1) CALL LCMLEN(MPCPO,'FINF_NUMBER ',NFINF,ITYLCM) CALL LCMSIX(MPCPO,' ',2) CALL LCMSIX(MPCPO,' ',2) ENDIF IF(NALBP.NE.0) THEN CALL LCMSIX(MPCPO,'MACROLIB',1) CALL LCMLEN(MPCPO,'ALBEDO',ILONG,ITYLCM) IF(ILONG.NE.NALBP*NGRP) CALL XABORT('NCRMAC: MISSING PHYSIC' 1 //'AL ALBEDO INFO IN MULTICOMPO OBJECT.') CALL LCMSIX(MPCPO,' ',2) ENDIF ELSE CALL LCMGTC(IPMAC,'SIGNATURE',12,TEXT12) IF(TEXT12.NE.'L_MACROLIB') THEN CALL XABORT('NCRMAC: SIGNATURE IS '//TEXT12//'. L_MACROLIB E' 1 //'XPECTED.') ENDIF CALL LCMGET(IPMAC,'STATE-VECTOR',ISTATE) IF(ISTATE(1).NE.NGRP) THEN CALL XABORT('NCRMAC: INVALID NUMBER OF ENERGY GROUPS(2).') ELSE IF(ISTATE(2).NE.NMIX) THEN CALL XABORT('NCRMAC: INVALID NUMBER OF MIXTURES(2).') ENDIF NL=ISTATE(3) NF=ISTATE(4) NED=ISTATE(5) NDEL=ISTATE(7) NALBP=ISTATE(8) NW=ISTATE(10) IDF=ISTATE(12) NGFF=ISTATE(16) IF(NED.GT.MAXED) CALL XABORT('NCRMAC: MAXED OVERFLOW(2).') IF(NED.GT.0) CALL LCMGTC(IPMAC,'ADDXSNAME-P0',8,NED,HVECT) IF(IDF.EQ.1) THEN NTYPE=2 ELSE IF((IDF.GE.2).AND.(IACCOLD.NE.0)) THEN CALL LCMSIX(IPMAC,'ADF',1) CALL LCMGET(IPMAC,'NTYPE',NTYPE) CALL LCMSIX(IPMAC,' ',2) ENDIF IF((NGFF.NE.0).AND.(IACCOLD.NE.0)) THEN CALL LCMSIX(IPMAC,'GFF',1) CALL LCMLEN(IPMAC,'FINF_NUMBER ',NFINF,ITYLCM) IF(NFINF.GT.MAXIFX) CALL XABORT('NCRMAC: MAXIFX OVERFLOW.') CALL LCMSIX(IPMAC,' ',2) ENDIF ENDIF N1D=8+2*NW+NED+NL N2D=2*(NDEL+1) IF(NL.GT.MAXNL) CALL XABORT('NCRMAC: MAXNL OVERFLOW.') IF(N1D.GT.MAX1D) CALL XABORT('NCRMAC: MAX1D OVERFLOW.') IF(N2D.GT.MAX2D) CALL XABORT('NCRMAC: MAX2D OVERFLOW.') LMAKE1(:N1D)=.FALSE. LMAKE2(:N2D)=.FALSE. GAR1(:NMIX,:NGRP,:N1D)=0.0 GAR2(:NMIX,:MAXNFI,:NGRP,:N2D)=0.0 GAR3(:NMIX,:NGRP,:NGRP,:NL)=0.0 *---- * SET HMAK1 AND HMAK2 *---- HMAK1(:N1D)=' ' DO 15 IW=1,MIN(NW+1,10) IF(IW.EQ.1) THEN TEXT12='FLUX-INTG' ELSE WRITE(TEXT12,'(11HFLUX-INTG-P,I1)') IW-1 ENDIF HMAK1(IW)=TEXT12 WRITE(TEXT12,'(4HNTOT,I1)') IW-1 HMAK1(1+NW+IW)=TEXT12 15 CONTINUE HMAK1(3+2*NW)='OVERV' HMAK1(4+2*NW)='DIFF' HMAK1(5+2*NW)='DIFFX' HMAK1(6+2*NW)='DIFFY' HMAK1(7+2*NW)='DIFFZ' HMAK1(8+2*NW)='H-FACTOR' DO 20 IED=1,NED HMAK1(8+2*NW+IED)=HVECT(IED) 20 CONTINUE DO 30 IL=1,NL WRITE(CM,'(I2.2)') IL-1 HMAK1(8+2*NW+NED+IL)='SIGS'//CM 30 CONTINUE HMAK2(1)='NUSIGF' HMAK2(2)='CHI' DO 40 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 40 CONTINUE *---- * READ EXISTING MACROLIB INFORMATION *---- ALLOCATE(XVOLM(NMIX)) XVOLM(:NMIX)=0.0 IF(IACCS.NE.0) THEN ! IACCS CALL LCMGET(IPMAC,'VOLUME',XVOLM) JPMAC=LCMGID(IPMAC,'GROUP') DO 81 IGR=1,NGRP KPMAC=LCMGIL(JPMAC,IGR) DO 60 I1D=1,N1D CALL LCMLEN(KPMAC,HMAK1(I1D),ILONG,ITYLCM) IF(ILONG.NE.0) THEN LMAKE1(I1D)=.TRUE. CALL LCMGET(KPMAC,HMAK1(I1D),GAR1(1,IGR,I1D)) DO 50 IBM=1,NMIX IF(MIXC(IBM).EQ.IBMOLD) GAR1(IBM,IGR,I1D)=0.0 50 CONTINUE ENDIF 60 CONTINUE DO 65 I2D=1,N2D CALL LCMLEN(KPMAC,HMAK2(I2D),ILONG,ITYLCM) IF(ILONG.NE.0) THEN LMAKE2(I2D)=.TRUE. CALL LCMGET(KPMAC,HMAK2(I2D),GAR2(1,1,IGR,I2D)) DO 64 I=1,NF DO 63 IBM=1,NMIX IF(MIXC(IBM).EQ.IBMOLD) GAR2(IBM,I,IGR,I2D)=0.0 63 CONTINUE 64 CONTINUE ENDIF 65 CONTINUE DO 80 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 75 IBM=1,NMIX IPOSDE=IPOS(IBM) DO 70 JGR=IJJ(IBM),IJJ(IBM)-NJJ(IBM)+1,-1 GAR3(IBM,JGR,IGR,IL)=GAR4(IPOSDE) IF(MIXC(IBM).EQ.IBMOLD) GAR3(IBM,JGR,IGR,IL)=0.0 IPOSDE=IPOSDE+1 70 CONTINUE 75 CONTINUE ENDIF 80 CONTINUE 81 CONTINUE ENDIF ! IACCS *---- * OVERALL ELEMENTARY CALCULATION LOOP *---- LFAST=.TRUE. DO 85 IBM=1,NMIX LFAST=LFAST.AND.((MIXC(IBM).NE.IBMOLD).OR.(NISO(IBM).EQ.0)) 85 CONTINUE DO 210 ICAL=1,NCAL MPCPO=LCMGIL(LPCPO,ICAL) IPTMP=C_NULL_PTR DO 200 IBM=1,NMIX WEIGHT=TERP(ICAL,IBM) IF((MIXC(IBM).NE.IBMOLD).OR.(WEIGHT.EQ.0.0)) GO TO 200 *---- * PRODUCE AN ELEMENTARY MACROLIB (IF IPTMP=C_NULL_PTR) *---- IF(.NOT.C_ASSOCIATED(IPTMP)) THEN ALLOCATE(FLUX(NGRP,NW+1),LWT(NW+1)) CALL LCMOP(IPTMP,'*ELEMENTARY*',0,1,0) CALL LCMEQU(MPCPO,IPTMP) IF(IMPX.GT.0) THEN WRITE(IOUT,'(38H NCRMAC: MULTICOMPO ACCESS FOR MIXTURE,I8, 1 5H AND ,11HCALCULATION,I8,9H. WEIGHT=,1P,E12.4)') IBM,ICAL, 2 WEIGHT IF(IMPX.GT.50) CALL LCMLIB(IPTMP) ENDIF CALL LCMLEN(IPTMP,'MACROLIB',ILONG,ITYLCM) IF(ILONG.NE.0) CALL LCMDEL(IPTMP,'MACROLIB') CALL LCMGET(IPTMP,'STATE-VECTOR',ISTATE) NBISO=ISTATE(2) IF(ISTATE(1).NE.1) CALL XABORT('NCRMAC: INVALID NUMBER OF MATE' 1 //'RIAL MIXTURES IN THE MULTICOMPO.') IF(ISTATE(3).NE.NGRP) CALL XABORT('NCRMAC: INVALID NUMBER OF E' 1 //'NERGY GROUPS IN THE MULTICOMPO.') ALLOCATE(MASKL(NGRP)) MASKL(:NGRP)=.TRUE. CALL LCMGPD(IPTMP,'ISOTOPESUSED',ISONA_PTR) CALL LCMGPD(IPTMP,'ISOTOPESDENS',DENIS_PTR) CALL C_F_POINTER(ISONA_PTR,ISONA,(/ NBISO /)) CALL C_F_POINTER(DENIS_PTR,DENIS,(/ NBISO /)) IF(.NOT.LRES) THEN DO 110 ISO=1,NBISO WRITE(TEXT8,'(2A4)') (ISONA(3*(ISO-1)+I0),I0=1,2) KSO1=0 DO 90 KSO=1,NISO(IBM) ! user-selected isotope WRITE(HHISO,'(2A4)') (HISO(I0,IBM,KSO),I0=1,2) IF(TEXT8.EQ.HHISO) THEN KSO1=KSO GO TO 100 ENDIF 90 CONTINUE IF(.NOT.LISO(IBM)) THEN DENIS(ISO)=0.0 GO TO 110 ENDIF 100 LUSER=.FALSE. IF(KSO1.GT.0) LUSER=(CONC(IBM,KSO1).NE.-99.99) IF(LUSER) DENIS(ISO)=CONC(IBM,KSO1) 110 CONTINUE ENDIF MAXMIX=1 ITSTMP=0 TMPDAY(1)=0.0 TMPDAY(2)=0.0 TMPDAY(3)=0.0 ALLOCATE(ISOMI(NBISO)) ISOMI(:NBISO)=1 CALL LIBMIX(IPTMP,MAXMIX,NGRP,NBISO,ISONA,ISOMI,DENIS, 1 .TRUE.,MASKL,ITSTMP,TMPDAY) CALL LCMPPD(IPTMP,'ISOTOPESDENS',NBISO,2,DENIS_PTR) DEALLOCATE(ISOMI,MASKL) *---- * RECOVER THE INTEGRATED FLUX *---- CALL LCMLEN(IPTMP,'MIXTURESVOL',ILONG,ITYLCM) IF(ILONG.EQ.0) GO TO 165 CALL LCMGET(IPTMP,'MIXTURESVOL',VOLMIX) XVOLM(IBM)=VOLMIX LWT(:NW+1)=.FALSE. FLUX(:NGRP,:(NW+1))=0.0 DO 150 ISOT=1,NBISO WRITE(TEXT12,'(3A4)') (ISONA(3*(ISOT-1)+I0),I0=1,3) CALL LCMLEN(IPTMP,TEXT12,ILONG,ITYLCM) IF(ILONG.NE.0) THEN CALL LCMSIX(IPTMP,TEXT12,1) DO 140 IW=1,MIN(NW+1,10) WRITE(TEXT12,'(3HNWT,I1)') IW-1 CALL LCMLEN(IPTMP,TEXT12,ILONG,ITYLCM) IF(ILONG.EQ.NGRP) THEN LWT(IW)=.TRUE. CALL LCMGPD(IPTMP,TEXT12,NWT_PTR) CALL C_F_POINTER(NWT_PTR,NWT,(/ NGRP /)) DO 130 IGR=1,NGRP FLUX(IGR,IW)=NWT(IGR)*VOLMIX 130 CONTINUE ENDIF 140 CONTINUE CALL LCMSIX(IPTMP,' ',2) ENDIF 150 CONTINUE CALL LCMSIX(IPTMP,'MACROLIB',1) JPTMP=LCMGID(IPTMP,'GROUP') DO 161 IGR=1,NGRP KPTMP=LCMGIL(JPTMP,IGR) DO 160 IW=1,MIN(NW+1,10) IF(LWT(IW)) THEN IF(IW.EQ.1) THEN TEXT12='FLUX-INTG' ELSE WRITE(TEXT12,'(11HFLUX-INTG-P,I1)') IW-1 ENDIF CALL LCMPUT(KPTMP,TEXT12,1,2,FLUX(IGR,IW)) ENDIF 160 CONTINUE 161 CONTINUE CALL LCMSIX(IPTMP,' ',2) DEALLOCATE(LWT,FLUX) ENDIF *---- * PERFORM INTERPOLATION *---- 165 CALL LCMSIX(IPTMP,'MACROLIB',1) CALL LCMGET(IPTMP,'STATE-VECTOR',ISTATE) IF(NF.EQ.0) NF=ISTATE(4) IF(NF.GT.MAXNFI) CALL XABORT('NCRMAC: MAXNFI OVERFLOW.') IF(ISTATE(1).NE.NGRP) THEN CALL XABORT('NCRMAC: INVALID NUMBER OF ENERGY GROUPS(3).') ELSE IF(ISTATE(2).NE.1)THEN CALL XABORT('NCRMAC: INVALID NUMBER OF MIXTURES(3).') ELSE IF(ISTATE(3).GT.NL) THEN CALL XABORT('NCRMAC: INVALID NUMBER OF LEGENDRE ORDERS(3).') ELSE IF((ISTATE(4).NE.0).AND.(ISTATE(4).NE.NF)) THEN CALL XABORT('NCRMAC: INVALID NUMBER OF FISSILE ISOTOPES(3).') ELSE IF((ISTATE(5).NE.NED).AND.(ISTATE(5).GT.0)) THEN CALL XABORT('NCRMAC: INVALID NUMBER OF EDIT REACTIONS(3).') ELSE IF((ISTATE(7).NE.NDEL).AND.(ISTATE(7).GT.0)) THEN CALL XABORT('NCRMAC: INVALID NUMBER OF PRECURSOR GROUPS(3).') ENDIF JPTMP=LCMGID(IPTMP,'GROUP') DO 195 IGR=1,NGRP KPTMP=LCMGIL(JPTMP,IGR) DO 170 I1D=1,N1D CALL LCMLEN(KPTMP,HMAK1(I1D),ILONG,ITYLCM) IF(ILONG.NE.0) THEN IF(ILONG.NE.1) CALL XABORT('NCRMAC: FLOTVA OVERFLOW.') LMAKE1(I1D)=.TRUE. CALL LCMGET(KPTMP,HMAK1(I1D),FLOTVA) IF((.NOT.LPURE).AND.(I1D.GE.4+2*NW).AND.(I1D.LE.7+2*NW)) THEN FLOTVA=1.0/FLOTVA ENDIF GAR1(IBM,IGR,I1D)=GAR1(IBM,IGR,I1D)+WEIGHT*FLOTVA ENDIF 170 CONTINUE IF(ISTATE(4).GT.0) THEN DO 175 I2D=1,N2D CALL LCMLEN(KPTMP,HMAK2(I2D),ILONG,ITYLCM) IF(ILONG.NE.0) THEN IF(ILONG.NE.NF) CALL XABORT('NCRMAC: FLOT OVERFLOW.') LMAKE2(I2D)=.TRUE. CALL LCMGPD(KPTMP,HMAK2(I2D),FLOT_PTR) CALL C_F_POINTER(FLOT_PTR,FLOT,(/ ILONG /)) DO 174 I=1,NF GAR2(IBM,I,IGR,I2D)=GAR2(IBM,I,IGR,I2D)+WEIGHT*FLOT(I) 174 CONTINUE ENDIF 175 CONTINUE ENDIF DO 190 IL=1,NL WRITE(CM,'(I2.2)') IL-1 ILONG=1 IF(IL.GT.1) CALL LCMLEN(KPTMP,'SCAT'//CM,ILONG,ITYLCM) IF(ILONG.NE.0) THEN CALL LCMGET(KPTMP,'SCAT'//CM,GAR4) CALL LCMGET(KPTMP,'NJJS'//CM,NJJ) CALL LCMGET(KPTMP,'IJJS'//CM,IJJ) CALL LCMGET(KPTMP,'IPOS'//CM,IPOS) IPOSDE=IPOS(1) DO 180 JGR=IJJ(1),IJJ(1)-NJJ(1)+1,-1 GAR3(IBM,JGR,IGR,IL)=GAR3(IBM,JGR,IGR,IL)+WEIGHT*GAR4(IPOSDE) IPOSDE=IPOSDE+1 180 CONTINUE ENDIF 190 CONTINUE 195 CONTINUE CALL LCMSIX(IPTMP,' ',2) IF(.NOT.LFAST) CALL LCMCL(IPTMP,2) 200 CONTINUE IF(C_ASSOCIATED(IPTMP)) CALL LCMCL(IPTMP,2) 210 CONTINUE *---- * WRITE INTERPOLATED MACROLIB INFORMATION *---- CALL LCMPUT(IPMAC,'VOLUME',NMIX,2,XVOLM) DEALLOCATE(XVOLM) JPMAC=LCMLID(IPMAC,'GROUP',NGRP) DO 365 IGR=1,NGRP KPMAC=LCMDIL(JPMAC,IGR) DO 320 I1D=1,N1D IF(LMAKE1(I1D)) THEN IF((.NOT.LPURE).AND.(I1D.GE.4+2*NW).AND.(I1D.LE.7+2*NW)) THEN DO 310 IBM=1,NMIX IF(MIXC(IBM).EQ.IBMOLD) GAR1(IBM,IGR,I1D)=1./GAR1(IBM,IGR,I1D) 310 CONTINUE ENDIF CALL LCMPUT(KPMAC,HMAK1(I1D),NMIX,2,GAR1(1,IGR,I1D)) ENDIF 320 CONTINUE DO 325 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 325 CONTINUE DO 360 IL=1,NL WRITE(CM,'(I2.2)') IL-1 IPOSDE=0 DO 350 IBM=1,NMIX IPOS(IBM)=IPOSDE+1 IGMIN=IGR IGMAX=IGR DO 330 JGR=1,NGRP IF(GAR3(IBM,JGR,IGR,IL).NE.0.0) THEN IGMIN=MIN(IGMIN,JGR) IGMAX=MAX(IGMAX,JGR) ENDIF 330 CONTINUE IJJ(IBM)=IGMAX NJJ(IBM)=IGMAX-IGMIN+1 DO 340 JGR=IGMAX,IGMIN,-1 IPOSDE=IPOSDE+1 GAR4(IPOSDE)=GAR3(IBM,JGR,IGR,IL) 340 CONTINUE 350 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 360 CONTINUE 365 CONTINUE IACCS=1 *---- * UPDATE STATE-VECTOR *---- CALL LCMGET(IPMAC,'STATE-VECTOR',ISTATE) ISTATE(4)=MAX(ISTATE(4),NF) IF(LMAKE1(4+2*NW)) ISTATE(9)=1 IF(LMAKE1(5+2*NW)) ISTATE(9)=2 CALL LCMPUT(IPMAC,'STATE-VECTOR',NSTATE,1,ISTATE) *---- * END OF OVERALL MULTICOMPO MIXTURE LOOP *---- 500 CONTINUE *---- * INCLUDE LEAKAGE IN THE MACROLIB (USED ONLY FOR NON-REGRESSION TESTS) *---- IF(B2.NE.0.0) THEN IF(IMPX.GT.0) WRITE(6,'(/34H NCRMAC: INCLUDE LEAKAGE IN THE MA, 1 11HCROLIB (B2=,1P,E12.5,2H).)') B2 JPMAC=LCMGID(IPMAC,'GROUP') ALLOCATE(WORK1(NMIX),WORK2(NMIX)) DO 520 IGR=1,NGRP KPMAC=LCMGIL(JPMAC,IGR) CALL LCMGET(KPMAC,'NTOT0',WORK1) CALL LCMGET(KPMAC,'DIFF',WORK2) DO 510 IBM=1,NMIX IF(MIXC(IBM).NE.0) WORK1(IBM)=WORK1(IBM)+B2*WORK2(IBM) 510 CONTINUE CALL LCMPUT(KPMAC,'NTOT0',NMIX,2,WORK1) 520 CONTINUE DEALLOCATE(WORK2,WORK1) ENDIF *---- * PROCESS ADF, GFF and physical albedos (if required) *---- CALL NCRAGF(IPMAC,IPCPO,IACCOLD,NMIL,NMIX,NGRP,NGFF,NALBP,IMPX, 1 NCAL,TERP,MIXC,IDF,NTYPE,NFINF) *---- * SCRATCH STORAGE DEALLOCATION *---- DEALLOCATE(GAR4,GAR3,GAR2,GAR1) DEALLOCATE(IPOS,NJJ,IJJ) RETURN END