diff options
Diffstat (limited to 'Donjon/src/PCRMAC.f')
| -rw-r--r-- | Donjon/src/PCRMAC.f | 451 |
1 files changed, 451 insertions, 0 deletions
diff --git a/Donjon/src/PCRMAC.f b/Donjon/src/PCRMAC.f new file mode 100644 index 0000000..06cf5af --- /dev/null +++ b/Donjon/src/PCRMAC.f @@ -0,0 +1,451 @@ +*DECK PCRMAC + SUBROUTINE PCRMAC(MAXNIS,IPMAC,IACCS,NMIX,NGRP,NGFF,IMPX,NCAL, + 1 TERP,NISO,HISO,CONC,LMIXC,XS_CALC,B2) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Build the macrolib by scanning the NCAL elementary calculations and +* weighting them with TERP factors. +* +*Copyright: +* Copyright (C) 2019 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. +* IACCS =0 macrolib is created; =1 ... is updated. +* NMIX maximum number of material mixtures in the macrolib. +* NGRP number of energy groups. +* NGFF number of group form factors per energy group. +* IMPX print parameter (equal to zero for no print). +* NCAL number of elementary calculations in the PMAXS file. +* TERP interpolation factors. +* NISO number of user-selected isotopes. +* HISO name of the user-selected isotopes. +* CONC user-defined number density of the user-selected isotopes. +* LMIXC flag set to .true. for fuel-map mixtures to process. +* XS_CALC pointers towards PMAXS elementary calculations. +* B2 buckling +* +*----------------------------------------------------------------------- +* + USE GANLIB + USE PCRDATA + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPMAC + INTEGER MAXNIS,IACCS,NMIX,NGRP,NGFF,IMPX,NCAL,NISO(NMIX), + 1 HISO(2,NMIX,MAXNIS) + REAL TERP(NCAL,NMIX),CONC(NMIX,MAXNIS),B2 + LOGICAL LMIXC(NMIX) + TYPE(XSBLOCK_ITEM) XS_CALC(NCAL) +*---- +* 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::MAXRES=MAX1D-10 + INTEGER, PARAMETER::NSTATE=40 + REAL FLOTVA, WEIGHT + INTEGER I0, I1D, I2D, IBM, ICAL, IDEL, IDF, IED, IGMAX, IGMIN, + & IGR, ILONG, IL, IPOSDE, ISO, ITRAN, ITSTMP, ITYLCM, I, JGR, + & KSO1, KSO, MAXMIX, N1D, N2D, NBISO, NDEL, NED,NF, NL, NTYPE + INTEGER ISTATE(NSTATE),NFINF,IACCOLD + REAL TMPDAY(3) + LOGICAL 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) IPTMP,JPTMP,KPTMP,JPMAC,KPMAC +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IJJ,NJJ,IPOS,ISOMI + REAL, ALLOCATABLE, DIMENSION(:) :: GAR4,XVOLM,WORK1,WORK2 + REAL, ALLOCATABLE, DIMENSION(:,:) :: FLUX + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: GAR1 + REAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: GAR2,GAR3 + LOGICAL, ALLOCATABLE, DIMENSION(:) :: MASKL + INTEGER, POINTER, DIMENSION(:) :: ISONA + REAL, POINTER, DIMENSION(:) :: DENIS,FLOT + TYPE(C_PTR) ISONA_PTR,DENIS_PTR,FLOT_PTR + DATA HMAK1 / 'FLUX-INTG','NTOT0','OVERV','DIFF','DIFFX','DIFFY', + 1 'DIFFZ','FLUX-INTG-P1','NTOT1','H-FACTOR',MAXRES*' '/ +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IJJ(NMIX),NJJ(NMIX),IPOS(NMIX)) + ALLOCATE(FLUX(NGRP,2),GAR1(NMIX,NGRP,MAX1D), + 1 GAR2(NMIX,MAXNFI,NGRP,MAX2D),GAR3(NMIX,NGRP,NGRP,MAXNL), + 2 GAR4(NMIX*NGRP)) +* + IACCOLD=IACCS ! for ADF and GFF + NTYPE=0 + NFINF=0 +*---- +* MACROLIB INITIALIZATION +*---- + IF(IACCS.EQ.0) THEN +* PMAXS values: + NL=1 + NF=0 + ITRAN=0 + NDEL=NDLAY +* IDF=NTDF +* NGFF=NRODS + IDF=0 + NGFF=0 + NED=1 + HVECT(1)='H-FACTOR' + IF(NXST.GE.7) THEN + NED=2 + HVECT(2)='NFTOT' + ENDIF + IF(NXST.EQ.8) THEN + NED=3 + HVECT(3)='DETEC' + ENDIF + 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(12)=IDF + ISTATE(16)=NGFF + CALL LCMPUT(IPMAC,'STATE-VECTOR',NSTATE,1,ISTATE) + CALL LCMPTC(IPMAC,'ADDXSNAME-P0',8,NED,HVECT) + ELSE + CALL LCMGTC(IPMAC,'SIGNATURE',12,TEXT12) + IF(TEXT12.NE.'L_MACROLIB') THEN + CALL XABORT('PCRMAC: SIGNATURE IS '//TEXT12//'. L_MACROLIB E' + 1 //'XPECTED.') + ENDIF + CALL LCMGET(IPMAC,'STATE-VECTOR',ISTATE) + IF(ISTATE(1).NE.NGRP) THEN + CALL XABORT('PCRMAC: INVALID NUMBER OF ENERGY GROUPS(2).') + ELSE IF(ISTATE(2).NE.NMIX) THEN + CALL XABORT('PCRMAC: INVALID NUMBER OF MIXTURES(2).') + ENDIF + NL=ISTATE(3) + NF=ISTATE(4) + NED=ISTATE(5) + NDEL=ISTATE(7) + IDF=ISTATE(12) + NGFF=ISTATE(16) + IF(NED.GT.MAXED) CALL XABORT('PCRMAC: MAXED OVERFLOW(2).') + IF(NED.GT.0) CALL LCMGTC(IPMAC,'ADDXSNAME-P0',8,NED,HVECT) + IF(IDF.EQ.1) THEN + NTYPE=1 + ELSE IF((IDF.EQ.3).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('PCRMAC: MAXIFX OVERFLOW.') + CALL LCMSIX(IPMAC,' ',2) + ENDIF + ENDIF + N1D=10+NED+NL + N2D=2*(NDEL+1) + IF(NL.GT.MAXNL) CALL XABORT('PCRMAC: MAXNL OVERFLOW.') + IF(N1D.GT.MAX1D) CALL XABORT('PCRMAC: MAX1D OVERFLOW.') + IF(N2D.GT.MAX2D) CALL XABORT('PCRMAC: 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 + DO 20 IED=1,NED + HMAK1(10+IED)=HVECT(IED) + 20 CONTINUE + DO 30 IL=1,NL + WRITE(CM,'(I2.2)') IL-1 + HMAK1(10+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 80 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(LMIXC(IBM)) 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(LMIXC(IBM)) GAR2(IBM,I,IGR,I2D)=0.0 + 63 CONTINUE + 64 CONTINUE + ENDIF + 65 CONTINUE + DO 75 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 71 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(LMIXC(IBM)) GAR3(IBM,JGR,IGR,IL)=0.0 + IPOSDE=IPOSDE+1 + 70 CONTINUE + 71 CONTINUE + ENDIF + 75 CONTINUE + 80 CONTINUE + ENDIF ! IACCS +*---- +* OVERALL ELEMENTARY CALCULATION LOOP +*---- + LFAST=.TRUE. + DO 85 IBM=1,NMIX + LFAST=LFAST.AND.((.NOT.LMIXC(IBM)).OR.(NISO(IBM).EQ.0)) + 85 CONTINUE + DO 210 ICAL=1,NCAL + IPTMP=C_NULL_PTR + DO 200 IBM=1,NMIX + WEIGHT=TERP(ICAL,IBM) + IF((.NOT.LMIXC(IBM)).OR.(WEIGHT.EQ.0.0)) GO TO 200 +*---- +* PRODUCE AN ELEMENTARY MACROLIB (IF IPTMP=C_NULL_PTR) +*---- + IF(.NOT.C_ASSOCIATED(IPTMP)) THEN + CALL LCMOP(IPTMP,'*ELEMENTARY*',0,1,0) + CALL PCRONE(IMPX,ICAL,IPTMP,NCAL,NGRP,XS_CALC) + IF(IMPX.GT.0) THEN + WRITE(IOUT,'(33H PCRMAC: PMAXS ACCESS FOR MIXTURE,I8,5H AND , + 1 11HCALCULATION,I8,9H. WEIGHT=,1P,E12.4)') IBM,ICAL,WEIGHT + IF(IMPX.GT.50) CALL LCMLIB(IPTMP) + ENDIF + CALL LCMGET(IPTMP,'STATE-VECTOR',ISTATE) + NBISO=ISTATE(2) + IF(ISTATE(1).NE.1) CALL XABORT('PCRMAC: INVALID NUMBER OF MATE' + 1 //'RIAL MIXTURES IN THE PMAXS FILE.') + IF(ISTATE(3).NE.NGRP) CALL XABORT('PCRMAC: INVALID NUMBER OF E' + 1 //'NERGY GROUPS IN THE PMAXS FILE.') + 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 /)) + 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 + 100 IF(KSO1.GT.0) DENIS(ISO)=CONC(IBM,KSO1) + 110 CONTINUE + 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) + ENDIF +*---- +* PERFORM INTERPOLATION +*---- + CALL LCMSIX(IPTMP,'MACROLIB',1) + CALL LCMGET(IPTMP,'STATE-VECTOR',ISTATE) + IF(NF.EQ.0) NF=ISTATE(4) + IF(NF.GT.MAXNFI) CALL XABORT('PCRMAC: MAXNFI OVERFLOW.') + IF(ISTATE(1).NE.NGRP) THEN + CALL XABORT('PCRMAC: INVALID NUMBER OF ENERGY GROUPS(3).') + ELSE IF(ISTATE(2).NE.1)THEN + CALL XABORT('PCRMAC: INVALID NUMBER OF MIXTURES(3).') + ELSE IF(ISTATE(3).NE.NL) THEN + CALL XABORT('PCRMAC: INVALID NUMBER OF LEGENDRE ORDERS(3).') + ELSE IF((ISTATE(4).NE.0).AND.(ISTATE(4).NE.NF)) THEN + CALL XABORT('PCRMAC: INVALID NUMBER OF FISSILE ISOTOPES(3).') + ELSE IF((ISTATE(5).NE.NED).AND.(ISTATE(5).GT.0)) THEN + CALL XABORT('PCRMAC: INVALID NUMBER OF EDIT REACTIONS(3).') + ELSE IF((ISTATE(7).NE.NDEL).AND.(ISTATE(7).GT.0)) THEN + CALL XABORT('PCRMAC: 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('PCRMAC: FLOTVA OVERFLOW.') + LMAKE1(I1D)=.TRUE. + CALL LCMGET(KPTMP,HMAK1(I1D),FLOTVA) + 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('PCRMAC: 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 370 IGR=1,NGRP + KPMAC=LCMDIL(JPMAC,IGR) + DO 320 I1D=1,N1D + IF(LMAKE1(I1D)) THEN + 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 + 370 CONTINUE + IACCS=1 +*---- +* UPDATE STATE-VECTOR +*---- + CALL LCMGET(IPMAC,'STATE-VECTOR',ISTATE) + ISTATE(4)=MAX(ISTATE(4),NF) + IF(LMAKE1(4)) ISTATE(9)=1 + IF(LMAKE1(5)) ISTATE(9)=2 + 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(6,'(/34H PCRMAC: 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(LMIXC(IBM)) WORK1(IBM)=WORK1(IBM)+B2*WORK2(IBM) + 510 CONTINUE + CALL LCMPUT(KPMAC,'NTOT0',NMIX,2,WORK1) + 520 CONTINUE + DEALLOCATE(WORK2,WORK1) + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(GAR4,GAR3,GAR2,GAR1,FLUX) + DEALLOCATE(IPOS,NJJ,IJJ) + RETURN + END |