diff options
Diffstat (limited to 'Donjon/src/NCRMAC.f')
| -rw-r--r-- | Donjon/src/NCRMAC.f | 618 |
1 files changed, 618 insertions, 0 deletions
diff --git a/Donjon/src/NCRMAC.f b/Donjon/src/NCRMAC.f new file mode 100644 index 0000000..6a7aa21 --- /dev/null +++ b/Donjon/src/NCRMAC.f @@ -0,0 +1,618 @@ +*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 |