summaryrefslogtreecommitdiff
path: root/Donjon/src/NCRAGF.f
diff options
context:
space:
mode:
Diffstat (limited to 'Donjon/src/NCRAGF.f')
-rw-r--r--Donjon/src/NCRAGF.f532
1 files changed, 532 insertions, 0 deletions
diff --git a/Donjon/src/NCRAGF.f b/Donjon/src/NCRAGF.f
new file mode 100644
index 0000000..b21f935
--- /dev/null
+++ b/Donjon/src/NCRAGF.f
@@ -0,0 +1,532 @@
+*DECK NCRAGF
+ SUBROUTINE NCRAGF(IPMAC,IPCPO,IACCS,NMIL,NMIX,NGRP,NGFF,NALBP,
+ 1 IMPX,NCAL,TERP,MIXC,IDF,NTYPE,NFINF)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Build the macrolib by scanning the NCAL elementary calculations and
+* weighting them with TERP factors. ADF, GFF and physical albedos part.
+*
+*Copyright:
+* Copyright (C) 2015 Ecole Polytechnique de Montreal
+*
+*Author(s):
+* R. Chambon, A. Hebert
+*
+*Parameters: input
+* 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.
+* IMPX print parameter (equal to zero for no print).
+* NCAL number of elementary calculations in the multicompo.
+* TERP interpolation factors.
+* MIXC mixture index in the multicompo corresponding to each macrolib
+* mixture. Equal to zero if a macrolib mixture is not updated.
+* IDF ADF type, 0 = none, 1 = Albedo, 2 = FD_B/FD_C/..., 3 = ADF.
+* NTYPE number of ADF.
+* NFINF number of 'enriched' flux (for pin power reconstruction in
+* NAP:).
+*
+*-----------------------------------------------------------------------
+*
+ USE GANLIB
+ IMPLICIT NONE
+*----
+* SUBROUTINE ARGUMENTS
+*----
+ TYPE(C_PTR) IPMAC,IPCPO
+ INTEGER IACCS,NMIL,NMIX,NGRP,NGFF,NALBP,IMPX,NCAL,MIXC(NMIX),IDF,
+ 1 NTYPE,NFINF
+ REAL TERP(NCAL,NMIX)
+*----
+* LOCAL VARIABLES
+*----
+ INTEGER, PARAMETER::IOUT=6
+ INTEGER, PARAMETER::MAXIFX=5
+ INTEGER, PARAMETER::NSTATE=40
+ INTEGER FINF(MAXIFX),NITMA
+ REAL WEIGHT,FACTOR,ZZZ
+ CHARACTER FINFN*8,HSMG*131
+ TYPE(C_PTR) JPCPO,KPCPO,LPCPO,MPCPO
+ INTEGER IKEFF,IKINF,I,IBM,IBMOLD,ICAL,IGR,JGR,IGFF,ILONG,ITYLCM,
+ 1 ITYPE,ITYP2,JTYPE,IAL,NTYPE2
+ INTEGER ISTATE(NSTATE)
+ DOUBLE PRECISION GAR1,GAR2
+*----
+* ALLOCATABLE ARRAYS
+*----
+ REAL, ALLOCATABLE, DIMENSION(:) :: GAR4,VOL,ZKINF,ZKEFF
+ REAL, ALLOCATABLE, DIMENSION(:,:) :: GAR6,ALBP
+ REAL, ALLOCATABLE, DIMENSION(:,:,:) :: GAR5,ADF2,ALBP2
+ REAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: GFF,ADF2M
+ CHARACTER(LEN=8), ALLOCATABLE, DIMENSION(:) :: HADF,HADF2
+*----
+* SCRATCH STORAGE ALLOCATION
+*----
+ ALLOCATE(GAR4(NGRP*NGRP),GAR6(NGRP,2),GFF(NMIX,NGFF,NGRP,2+NFINF),
+ 1 GAR5(NGFF,NGRP,2+MAXIFX),ALBP(NALBP,NGRP),ALBP2(NMIX,NALBP,NGRP),
+ 2 ZKINF(NMIX),ZKEFF(NMIX),HADF(NTYPE),ADF2(NMIX,NGRP,NTYPE),
+ 3 ADF2M(NMIX,NGRP,NGRP,NTYPE))
+*----
+* OVERALL MULTICOMPO MIXTURE LOOP
+*----
+ IKINF=0
+ IKEFF=0
+ JPCPO=LCMGID(IPCPO,'MIXTURES')
+ IF(NALBP.NE.0) ALBP2(:NMIX,:NALBP,:NGRP)=0.0
+ ZKINF(:NMIX)=0.0
+ ZKEFF(:NMIX)=0.0
+ DO 500 IBMOLD=1,NMIL
+ IF(IMPX.GT.0) WRITE(IOUT,'(/33H NCRAGF: PROCESS MULTICOMPO MIXTU,
+ 1 2HRE,I5)') IBMOLD
+ KPCPO=LCMGIL(JPCPO,IBMOLD)
+ LPCPO=LCMGID(KPCPO,'CALCULATIONS')
+*----
+* READ EXISTING MACROLIB INFORMATION
+*----
+ MPCPO=LCMGIL(LPCPO,1)
+ CALL LCMGET(MPCPO,'STATE-VECTOR',ISTATE)
+ IF(ISTATE(1).NE.1) CALL XABORT('NCRAGF: THE NUMBER OF MIXTURE SH'
+ 1 //'OULD ALWAYS BE EQUAL TO 1 IN A MULTICOMPO MICROLIB BRANCH.')
+ IF(IACCS.EQ.0) THEN !IACCS
+ IF((IDF.NE.0).OR.(NGFF.NE.0)) CALL LCMSIX(MPCPO,'MACROLIB',1)
+ IF(IDF.NE.0) THEN
+ !copy ADF names from multicompo
+ CALL LCMSIX(IPMAC,'ADF',1)
+ CALL LCMLEN(MPCPO,'ADF',ILONG,ITYLCM)
+ IF(ILONG.EQ.0) CALL XABORT('NCRAGF: MISSING ADF DIRECTORY I'
+ 1 //'N MULTICOMPO OBJECT.')
+ CALL LCMSIX(MPCPO,'ADF',1)
+ CALL LCMEQU(MPCPO,IPMAC)
+ IF(IDF.EQ.1) THEN
+ CALL LCMLEN(IPMAC,'ALBS00',ILONG,ITYLCM)
+ IF(ILONG.GT.0) CALL LCMDEL(IPMAC,'ALBS00')
+ ADF2(:NMIX,:NGRP,:NTYPE)=0.0
+ ELSE IF((IDF.EQ.2).OR.(IDF.EQ.3)) THEN
+ CALL LCMGET(MPCPO,'NTYPE',NITMA)
+ IF(NITMA.NE.NTYPE) CALL XABORT('NCRAGF: INVALID NTYPE(1).')
+ IF(NTYPE.GT.0) THEN
+ CALL LCMGTC(MPCPO,'HADF',8,NTYPE,HADF)
+ DO ITYPE=1,NTYPE
+ CALL LCMLEN(IPMAC,HADF(ITYPE),ILONG,ITYLCM)
+ IF(ILONG.GT.0) CALL LCMDEL(IPMAC,HADF(ITYPE))
+ ENDDO
+ ENDIF
+ ADF2(:NMIX,:NGRP,:NTYPE)=0.0
+ ELSE IF(IDF.EQ.4) THEN
+ CALL LCMGET(MPCPO,'NTYPE',NITMA)
+ IF(NITMA.NE.NTYPE) CALL XABORT('NCRAGF: INVALID NTYPE(2).')
+ IF(NTYPE.GT.0) THEN
+ CALL LCMGTC(MPCPO,'HADF',8,NTYPE,HADF)
+ DO ITYPE=1,NTYPE
+ CALL LCMLEN(IPMAC,HADF(ITYPE),ILONG,ITYLCM)
+ IF(ILONG.GT.0) CALL LCMDEL(IPMAC,HADF(ITYPE))
+ ENDDO
+ ENDIF
+ ADF2M(:NMIX,:NGRP,:NGRP,:NTYPE)=0.0
+ ENDIF
+ CALL LCMSIX(MPCPO,' ',2)
+ CALL LCMSIX(IPMAC,' ',2)
+ ENDIF
+ IF(NGFF.NE.0) THEN
+ !copy GFF geom and FINF names from multicompo
+ CALL LCMSIX(IPMAC,'GFF',1)
+ CALL LCMLEN(MPCPO,'GFF',ILONG,ITYLCM)
+ IF(ILONG.EQ.0) CALL XABORT('NCRAGF: MISSING GFF DIRECTORY I'
+ 1 //'N MULTICOMPO OBJECT.')
+ CALL LCMSIX(MPCPO,'GFF',1)
+ CALL LCMEQU(MPCPO,IPMAC)
+ IF(NFINF.GT.0) THEN
+ CALL LCMGET(IPMAC,'FINF_NUMBER ',FINF)
+ DO I=1,NFINF
+ WRITE(FINFN,'(5HFINF_,I3.3)') FINF(I)
+ CALL LCMLEN(IPMAC,FINFN,ILONG,ITYLCM)
+ IF(ILONG.GT.0) CALL LCMDEL(IPMAC,FINFN)
+ ENDDO
+ ENDIF
+ CALL LCMSIX(MPCPO,' ',2)
+ CALL LCMSIX(IPMAC,' ',2)
+ GFF(:NMIX,:NGFF,:NGRP,:2+NFINF)=0.0
+ ENDIF
+ IF((IDF.NE.0).OR.(NGFF.NE.0)) CALL LCMSIX(MPCPO,' ',2)
+ CALL LCMGET(IPMAC,'STATE-VECTOR',ISTATE)
+ ISTATE(8)=NALBP
+ ISTATE(12)=IDF
+ ISTATE(16)=NGFF
+ CALL LCMPUT(IPMAC,'STATE-VECTOR',NSTATE,1,ISTATE)
+ IACCS=1
+ ELSE !IACCS
+* Recover ADF, GFF and physical albedos previously computed
+ IF(NGFF.NE.0) THEN
+ CALL LCMSIX(IPMAC,'GFF',1)
+ CALL LCMGET(IPMAC,'NWT0',GFF(1,1,1,1))
+ CALL LCMGET(IPMAC,'H-FACTOR',GFF(1,1,1,2))
+ IF(NFINF.GT.0) THEN
+ CALL LCMGET(IPMAC,'FINF_NUMBER ',FINF)
+ DO I=1,NFINF
+ WRITE(FINFN,'(5HFINF_,I3.3)') FINF(I)
+ CALL LCMGET(IPMAC,FINFN,GFF(1,1,1,2+I))
+ ENDDO
+ ENDIF
+ DO IBM=1,NMIX
+ IF(MIXC(IBM).EQ.IBMOLD) GFF(IBM,:NGFF,:NGRP,:NFINF+2)=0.0
+ ENDDO
+ CALL LCMSIX(IPMAC,' ',2)
+ ENDIF
+ IF(IDF.NE.0) THEN
+ CALL LCMSIX(IPMAC,'ADF',1)
+ IF(IDF.EQ.1) THEN
+ DO IBM=1,NMIX
+ IF(MIXC(IBM).EQ.IBMOLD) ADF2(IBM,:NGRP,1)=0.0
+ ENDDO
+ ELSE IF((IDF.EQ.2).OR.(IDF.EQ.3)) THEN
+ CALL LCMGTC(IPMAC,'HADF',8,NTYPE,HADF)
+ DO ITYPE=1,NTYPE
+ CALL LCMGET(IPMAC,HADF(ITYPE),ADF2(1,1,ITYPE))
+ DO IBM=1,NMIX
+ IF(MIXC(IBM).EQ.IBMOLD) ADF2(IBM,:NGRP,ITYPE)=0.0
+ ENDDO
+ ENDDO
+ ELSE IF(IDF.EQ.4) THEN
+ CALL LCMGTC(IPMAC,'HADF',8,NTYPE,HADF)
+ DO ITYPE=1,NTYPE
+ CALL LCMGET(IPMAC,HADF(ITYPE),ADF2M(1,1,1,ITYPE))
+ DO IBM=1,NMIX
+ IF(MIXC(IBM).EQ.IBMOLD) ADF2M(IBM,:NGRP,:NGRP,ITYPE)=0.0
+ ENDDO
+ ENDDO
+ ENDIF
+ CALL LCMSIX(IPMAC,' ',2)
+ ENDIF
+ DO IBM=1,NMIX
+ IF(MIXC(IBM).EQ.IBMOLD) THEN
+ IF(NALBP.NE.0) ALBP2(IBM,:NALBP,:NGRP)=0.0
+ ZKINF(IBM)=0.0
+ ZKEFF(IBM)=0.0
+ ENDIF
+ ENDDO
+ CALL LCMGET(IPMAC,'STATE-VECTOR',ISTATE)
+ ISTATE(8)=NALBP
+ ISTATE(12)=IDF
+ ISTATE(16)=NGFF
+ CALL LCMPUT(IPMAC,'STATE-VECTOR',NSTATE,1,ISTATE)
+*
+ ENDIF !IACCS
+*----
+* OVERALL ELEMENTARY CALCULATION LOOP
+*----
+ DO 210 ICAL=1,NCAL
+ MPCPO=LCMGIL(LPCPO,ICAL)
+ DO 200 IBM=1,NMIX
+ WEIGHT=TERP(ICAL,IBM)
+ IF((MIXC(IBM).NE.IBMOLD).OR.(WEIGHT.EQ.0.0)) GO TO 200
+*----
+* PERFORM INTERPOLATION
+*----
+*----
+* PROCESS GROUP FORM FACTOR (GFF) INFORMATION
+*----
+ IF(NGFF.NE.0) THEN
+ CALL LCMSIX(MPCPO,'MACROLIB',1)
+ CALL LCMLEN(MPCPO,'GFF',ILONG,ITYLCM)
+ IF(ILONG.NE.0) THEN
+ CALL LCMSIX(MPCPO,'GFF',1)
+ CALL LCMLEN(MPCPO,'NWT0',ILONG,ITYLCM)
+ IF(ILONG.GT.NGFF*NGRP*(2+MAXIFX)) THEN
+ CALL LCMLIB(MPCPO)
+ WRITE(6,'(6H NGFF=,I6,6H NGRP=,I6,11H LEN(NWT0)=,I6)')
+ > NGFF,NGRP,ILONG
+ CALL XABORT('NCRAGF: MAXIFX OVERFLOW.')
+ ENDIF
+ CALL LCMGET(MPCPO,'NWT0',GAR5(1,1,1))
+ CALL LCMGET(MPCPO,'H-FACTOR',GAR5(1,1,2))
+ CALL LCMLEN(MPCPO,'FINF_NUMBER ',NFINF,ITYLCM)
+ IF(NFINF.GT.0) THEN
+ CALL LCMGET(MPCPO,'FINF_NUMBER ',FINF)
+ DO I=1,NFINF
+ WRITE(FINFN,'(5HFINF_,I3.3)') FINF(I)
+ CALL LCMGET(MPCPO,FINFN,GAR5(1,1,2+I))
+ ENDDO
+ ENDIF
+ DO IGFF=1,NGFF
+ DO IGR=1,NGRP
+ GFF(IBM,IGFF,IGR,1)=GFF(IBM,IGFF,IGR,1)
+ 1 +WEIGHT*GAR5(IGFF,IGR,1)
+ GFF(IBM,IGFF,IGR,2)=GFF(IBM,IGFF,IGR,2)
+ 1 +WEIGHT*GAR5(IGFF,IGR,2)
+ DO I=1,NFINF
+ GFF(IBM,IGFF,IGR,2+I)=GFF(IBM,IGFF,IGR,2+I)
+ 1 +WEIGHT*GAR5(IGFF,IGR,2+I)
+ ENDDO
+ ENDDO
+ ENDDO
+ CALL LCMSIX(MPCPO,' ',2)
+ ENDIF
+ CALL LCMSIX(MPCPO,' ',2)
+ ENDIF
+*----
+* PROCESS ADF INFORMATION
+*----
+ IF(IDF.NE.0) THEN
+ CALL LCMSIX(MPCPO,'MACROLIB',1)
+ CALL LCMLEN(MPCPO,'ADF',ILONG,ITYLCM)
+ IF(ILONG.NE.0) THEN
+ CALL LCMSIX(MPCPO,'ADF',1)
+ IF(IDF.EQ.1) THEN
+ GAR6(:NGRP,:2)=0.0
+ CALL LCMGET(MPCPO,'ALBS00',GAR6)
+ DO IGR=1,NGRP
+ ADF2(IBM,IGR,:2)=ADF2(IBM,IGR,:2)+WEIGHT*GAR6(IGR,:2)
+ ENDDO
+ ELSE IF((IDF.EQ.2).OR.(IDF.EQ.3)) THEN
+ CALL LCMGET(MPCPO,'NTYPE',NTYPE2)
+ ALLOCATE(HADF2(NTYPE2))
+ CALL LCMGTC(MPCPO,'HADF',8,NTYPE2,HADF2)
+ IF(NTYPE2.EQ.1) THEN
+* assign the same ADF to all sides.
+ CALL LCMLEN(MPCPO,HADF2(1),ILONG,ITYLCM)
+ IF(ILONG.NE.NGRP) CALL XABORT('NCRAGF: INVALID ADF LENGT'
+ 1 //'H(1).')
+ CALL LCMGET(MPCPO,HADF2(1),GAR4)
+ DO ITYPE=1,NTYPE
+ DO IGR=1,NGRP
+ ADF2(IBM,IGR,ITYPE)=ADF2(IBM,IGR,ITYPE)+WEIGHT*
+ 1 GAR4(IGR)
+ ENDDO
+ ENDDO
+ ELSE
+ IF(NTYPE2.GT.NTYPE) CALL XABORT('NCRAGF: NTYPE OVERFLOW.')
+ DO ITYP2=1,NTYPE2
+ ITYPE=0
+ DO JTYPE=1,NTYPE
+ IF(HADF2(ITYP2).EQ.HADF(JTYPE)) THEN
+ ITYPE=JTYPE
+ GO TO 180
+ ENDIF
+ ENDDO
+ WRITE(HSMG,'(18HNCRAGF: ADF NAMED ,A,11H NOT FOUND.)')
+ 1 TRIM(HADF2(ITYP2))
+ CALL XABORT(HSMG)
+ 180 CALL LCMLEN(MPCPO,HADF2(ITYP2),ILONG,ITYLCM)
+ IF(ILONG.NE.NGRP) CALL XABORT('NCRAGF: INVALID ADF LEN'
+ 1 //'GTH(2).')
+ CALL LCMGET(MPCPO,HADF2(ITYP2),GAR4)
+ DO IGR=1,NGRP
+ ADF2(IBM,IGR,ITYPE)=ADF2(IBM,IGR,ITYPE)+WEIGHT*
+ 1 GAR4(IGR)
+ ENDDO
+ ENDDO
+ ENDIF
+ DEALLOCATE(HADF2)
+ ELSE IF(IDF.EQ.4) THEN
+ CALL LCMGET(MPCPO,'NTYPE',NTYPE2)
+ ALLOCATE(HADF2(NTYPE2))
+ CALL LCMGTC(MPCPO,'HADF',8,NTYPE2,HADF2)
+ IF(NTYPE2.EQ.1) THEN
+* assign the same MADF to all sides.
+ CALL LCMLEN(MPCPO,HADF2(1),ILONG,ITYLCM)
+ IF(ILONG.NE.NGRP*NGRP) CALL XABORT('NCRAGF: INVALID ADFM'
+ 1 //'LENGTH(1).')
+ CALL LCMGET(MPCPO,HADF2(1),GAR4)
+ DO ITYPE=1,NTYPE
+ DO JGR=1,NGRP
+ DO IGR=1,NGRP
+ ADF2M(IBM,IGR,JGR,ITYPE)=ADF2M(IBM,IGR,JGR,ITYPE)+
+ 1 WEIGHT*GAR4((JGR-1)*NGRP+IGR)
+ ENDDO
+ ENDDO
+ ENDDO
+ ELSE
+ IF(NTYPE2.GT.NTYPE) CALL XABORT('NCRAGF: NTYPE OVERFLOW.')
+ DO ITYP2=1,NTYPE2
+ ITYPE=0
+ DO JTYPE=1,NTYPE
+ IF(HADF2(ITYP2).EQ.HADF(JTYPE)) THEN
+ ITYPE=JTYPE
+ GO TO 190
+ ENDIF
+ ENDDO
+ WRITE(HSMG,'(19HNCRAGF: ADFM NAMED ,A,11H NOT FOUND.)')
+ 1 TRIM(HADF2(ITYP2))
+ CALL XABORT(HSMG)
+ CALL LCMLEN(MPCPO,HADF2(ITYP2),ILONG,ITYLCM)
+ 190 IF(ILONG.NE.NGRP*NGRP) CALL XABORT('NCRAGF: INVALID AD'
+ 1 //'FM LENGTH(2).')
+ CALL LCMGET(MPCPO,HADF2(ITYP2),GAR4)
+ DO JGR=1,NGRP
+ DO IGR=1,NGRP
+ ADF2M(IBM,IGR,JGR,ITYPE)=ADF2M(IBM,IGR,JGR,ITYPE)+
+ 1 WEIGHT*GAR4((JGR-1)*NGRP+IGR)
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDIF
+ DEALLOCATE(HADF2)
+ ENDIF
+ CALL LCMSIX(MPCPO,' ',2)
+ ENDIF
+ CALL LCMSIX(MPCPO,' ',2)
+ ENDIF
+*----
+* PROCESS PHYSICAL ALBEDO INFORMATION
+*----
+ IF(NALBP.NE.0) THEN
+ CALL LCMSIX(MPCPO,'MACROLIB',1)
+ CALL LCMGET(MPCPO,'ALBEDO',ALBP)
+ DO IGR=1,NGRP
+ DO IAL=1,NALBP
+ FACTOR=(1.0-ALBP(IAL,IGR))/(1.0+ALBP(IAL,IGR))
+ ALBP2(IBM,IAL,IGR)=ALBP2(IBM,IAL,IGR)+WEIGHT*FACTOR
+ ENDDO
+ ENDDO
+ CALL LCMSIX(MPCPO,' ',2)
+ ENDIF
+*----
+* PROCESS KINF
+*----
+ CALL LCMLEN(MPCPO,'K-INFINITY',IKINF,ITYLCM)
+ IF(IKINF.EQ.1) THEN
+ CALL LCMGET(MPCPO,'K-INFINITY',ZZZ)
+ ZKINF(IBM)=ZKINF(IBM)+WEIGHT*ZZZ
+ ENDIF
+*----
+* PROCESS KEFF
+*----
+ CALL LCMLEN(MPCPO,'K-EFFECTIVE',IKEFF,ITYLCM)
+ IF(IKEFF.EQ.1) THEN
+ CALL LCMGET(MPCPO,'K-EFFECTIVE',ZZZ)
+ ZKEFF(IBM)=ZKEFF(IBM)+WEIGHT*ZZZ
+ ENDIF
+ 200 CONTINUE
+ 210 CONTINUE
+*----
+* WRITE INTERPOLATED MACROLIB INFORMATION
+*----
+ IF(IDF.EQ.1) THEN
+ CALL LCMSIX(IPMAC,'ADF',1)
+ CALL LCMPUT(IPMAC,'ALBS00',NMIX*NGRP*2,2,ADF2(1,1,1))
+ CALL LCMSIX(IPMAC,' ',2)
+ ELSE IF((IDF.EQ.2).OR.(IDF.EQ.3)) THEN
+ CALL LCMSIX(IPMAC,'ADF',1)
+ CALL LCMGTC(IPMAC,'HADF',8,NTYPE,HADF)
+ DO ITYPE=1,NTYPE
+ CALL LCMPUT(IPMAC,HADF(ITYPE),NMIX*NGRP,2,
+ 1 ADF2(1,1,ITYPE))
+ ENDDO
+ CALL LCMSIX(IPMAC,' ',2)
+ IF(IMPX.GT.1) THEN
+ DO IBM=1,NMIX
+ IF(MIXC(IBM).EQ.0) CYCLE
+ WRITE(6,'(/40H NCRAGF: DISCONTINUITY FACTORS - MIXTURE,I5)')
+ 1 IBM
+ DO ITYPE=1,NTYPE
+ WRITE(6,'(1X,A,1H:,1P,(5X,10E12.4))') TRIM(HADF(ITYPE)),
+ 1 (ADF2(IBM,IGR,ITYPE),IGR=1,NGRP)
+ ENDDO
+ ENDDO
+ ENDIF
+ ELSE IF(IDF.EQ.4) THEN
+ CALL LCMSIX(IPMAC,'ADF',1)
+ CALL LCMGTC(IPMAC,'HADF',8,NTYPE,HADF)
+ DO ITYPE=1,NTYPE
+ CALL LCMPUT(IPMAC,HADF(ITYPE),NMIX*NGRP*NGRP,2,
+ 1 ADF2M(1,1,1,ITYPE))
+ ENDDO
+ CALL LCMSIX(IPMAC,' ',2)
+ IF(IMPX.GT.1) THEN
+ DO IBM=1,NMIX
+ IF(MIXC(IBM).EQ.0) CYCLE
+ WRITE(6,'(/40H NCRAGF: DISCONTINUITY FACTORS - MIXTURE,I5)')
+ 1 IBM
+ DO ITYPE=1,NTYPE
+ WRITE(6,'(1X,A,1H:,1P,(5X,10E12.4))') TRIM(HADF(ITYPE)),
+ 1 ((ADF2M(IBM,IGR,JGR,ITYPE),IGR=1,NGRP),JGR=1,NGRP)
+ ENDDO
+ ENDDO
+ ENDIF
+ ENDIF
+ IF(NGFF.NE.0) THEN
+ CALL LCMSIX(IPMAC,'GFF',1)
+ CALL LCMPUT(IPMAC,'NWT0',NMIX*NGFF*NGRP,2,GFF(1,1,1,1))
+ CALL LCMPUT(IPMAC,'H-FACTOR',NMIX*NGFF*NGRP,2,GFF(1,1,1,2))
+ IF(NFINF.GT.0) THEN
+ CALL LCMGET(IPMAC,'FINF_NUMBER ',FINF)
+ DO I=1,NFINF
+ WRITE(FINFN,'(5HFINF_,I3.3)') FINF(I)
+ CALL LCMPUT(IPMAC,FINFN,NMIX*NGFF*NGRP,2,GFF(1,1,1,2+I))
+ ENDDO
+ ENDIF
+ CALL LCMSIX(IPMAC,' ',2)
+ ENDIF
+ IACCS=1
+*----
+* END OF OVERALL MULTICOMPO MIXTURE LOOP
+*----
+ IF(IMPX.GT.0) WRITE(IOUT,'(/33H NCRAGF: PROCESS MULTICOMPO MIXTU,
+ 1 6HRE-OUT,I5)') IBMOLD
+ 500 CONTINUE
+*----
+* AVERAGE PHYSICAL ALBEDO INFORMATION
+*----
+ IF(NALBP.NE.0) THEN
+ ALLOCATE(VOL(NMIX))
+ CALL LCMGET(IPMAC,'VOLUME',VOL)
+ DO IGR=1,NGRP
+ DO IAL=1,NALBP
+ GAR1=0.0D0
+ GAR2=0.0D0
+ DO IBM=1,NMIX
+ GAR1=GAR1+ALBP2(IBM,IAL,IGR)*VOL(IBM)
+ GAR2=GAR2+VOL(IBM)
+ ENDDO
+ ALBP(IAL,IGR)=REAL((1.0D0-GAR1/GAR2)/(1.0D0+GAR1/GAR2))
+ ENDDO
+ ENDDO
+ DEALLOCATE(VOL)
+ CALL LCMPUT(IPMAC,'ALBEDO',NALBP*NGRP,2,ALBP(1,1))
+ ENDIF
+*----
+* AVERAGE KINF
+*----
+ IF(IKINF.EQ.1) THEN
+ ALLOCATE(VOL(NMIX))
+ CALL LCMGET(IPMAC,'VOLUME',VOL)
+ GAR1=0.0D0
+ GAR2=0.0D0
+ DO IBM=1,NMIX
+ GAR1=GAR1+ZKINF(IBM)*VOL(IBM)
+ GAR2=GAR2+VOL(IBM)
+ ENDDO
+ ZZZ=REAL(GAR1/GAR2)
+ DEALLOCATE(VOL)
+ CALL LCMPUT(IPMAC,'K-INFINITY',1,2,ZZZ)
+ ENDIF
+*----
+* AVERAGE KEFF
+*----
+ IF(IKEFF.EQ.1) THEN
+ ALLOCATE(VOL(NMIX))
+ CALL LCMGET(IPMAC,'VOLUME',VOL)
+ GAR1=0.0D0
+ GAR2=0.0D0
+ DO IBM=1,NMIX
+ GAR1=GAR1+ZKEFF(IBM)*VOL(IBM)
+ GAR2=GAR2+VOL(IBM)
+ ENDDO
+ ZZZ=REAL(GAR1/GAR2)
+ DEALLOCATE(VOL)
+ CALL LCMPUT(IPMAC,'K-EFFECTIVE',1,2,ZZZ)
+ ENDIF
+*----
+* SCRATCH STORAGE DEALLOCATION
+*----
+ DEALLOCATE(ADF2M,ADF2,HADF,ZKEFF,ZKINF,ALBP2,ALBP,GAR5,GFF,GAR6,
+ 1 GAR4)
+ RETURN
+ END
generated by cgit v1.2.3 (git 2.46.0) at 2026-02-16 12:59:44 +0000