summaryrefslogtreecommitdiff
path: root/Donjon/src/NCRRGR.f
diff options
context:
space:
mode:
Diffstat (limited to 'Donjon/src/NCRRGR.f')
-rw-r--r--Donjon/src/NCRRGR.f1027
1 files changed, 1027 insertions, 0 deletions
diff --git a/Donjon/src/NCRRGR.f b/Donjon/src/NCRRGR.f
new file mode 100644
index 0000000..cea9f45
--- /dev/null
+++ b/Donjon/src/NCRRGR.f
@@ -0,0 +1,1027 @@
+*DECK NCRRGR
+ SUBROUTINE NCRRGR(IPCPO,IPMAP,LCUBIC,NMIX,IMPX,NMIL,NCAL,NCH,NB,
+ 1 NFUEL,NPARM,ITER,MAXNIS,MIXC,TERP,NISO,LISO,HISO,CONC)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Compute TERP factors for multicompo interpolation. Use global and
+* local parameters from a fuel-map object and optional user-defined
+* values.
+*
+*Copyright:
+* Copyright (C) 2007 Ecole Polytechnique de Montreal
+*
+*Author(s):
+* A. Hebert, D. Sekki, R. Chambon
+*
+*Parameters: input
+* IPCPO address of the multicompo object.
+* IPMAP address of the fuel-map object.
+* LCUBIC =.TRUE.: cubic Ceschino interpolation; =.FALSE: linear
+* Lagrange interpolation.
+* NMIX number of material mixtures in the fuel-map macrolib.
+* IMPX printing index (=0 for no print).
+* NMIL number of material mixtures in the multicompo.
+* NCAL number of elementary calculations in the multicompo.
+* NCH number of reactor channels.
+* NB number of fuel bundles per channel.
+* NFUEL number of fuel types.
+* NPARM number of additional parameters (other than burnup) defined
+* in FMAP object
+*
+*Parameters: output
+* ITER completion flag (=0: all over; =1: use another multicompo;
+* =2 use another L_MAP + multicompo).
+* MAXNIS maximum value of NISO(I) in user data.
+* MIXC mixture index in the multicompo corresponding to each microlib
+* mixture.
+* 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.
+*
+*-----------------------------------------------------------------------
+*
+ USE GANLIB
+ IMPLICIT NONE
+*----
+* SUBROUTINE ARGUMENTS
+*----
+ INTEGER, PARAMETER::MAXISD=200
+ TYPE(C_PTR) IPCPO,IPMAP
+ INTEGER NMIX,IMPX,NMIL,NCAL,NFUEL,NCH,NB,ITER,MAXNIS,
+ 1 MIXC(NMIX),NPARM,HISO(2,NMIX,MAXISD),NISO(NMIX)
+ REAL TERP(NCAL,NMIX),CONC(NMIX,MAXISD)
+ LOGICAL LCUBIC,LISO(NMIX)
+*----
+* LOCAL VARIABLES
+*----
+ INTEGER, PARAMETER::IOUT=6
+ INTEGER, PARAMETER::MAXADD=10
+ INTEGER, PARAMETER::MAXLIN=50
+ INTEGER, PARAMETER::MAXPAR=50
+ INTEGER, PARAMETER::MAXVAL=200
+ INTEGER, PARAMETER::NSTATE=40
+ REAL, PARAMETER::REPS=1.0E-4
+ REAL BURN0, BURN1, FLOTT, SUM, VALR1, VALR2, VARVAL
+ INTEGER I0, IBMB, IBME, IBMOLD, IBM, IBTYP, IB, ICAL, ICH, IFUEL,
+ & ILONG, IMIX, IMPY, INDIC, IPARTM, IPAR, ISO, ITYLCM, ITYPE, ITYP,
+ & IVARTY, I, JBM, JB, JCAL, JPARM, JPAR, J, LENGTH, NCOMLI, NISOMI,
+ & NITMA, NLOC, NMIXA, NPARMP, NPAR, NTOT, N
+ CHARACTER TEXT12*12,PARKEY(MAXPAR)*12,PARFMT(MAXPAR)*8,
+ 1 PARKEL(MAXPAR)*12,HSMG*131,COMMEN(MAXLIN)*80,VALH(MAXPAR)*12,
+ 2 RECNAM*12,VCHAR(MAXVAL)*12,PARNAM*12,HCUBIC*12,HNAVAL*12
+ INTEGER ISTATE(NSTATE),VALI(MAXPAR),NVALUE(MAXPAR),VINTE(MAXVAL),
+ 1 MUPLET(2*MAXPAR),MUTYPE(2*MAXPAR),MAPLET(2*MAXPAR,MAXADD),
+ 2 MATYPE(2*MAXPAR,MAXADD),IDLTA(2*MAXPAR,MAXADD),NDLTA(2*MAXPAR),
+ 3 IDLTA1,MUPLT2(2*MAXPAR),MUTYP2(2*MAXPAR),HISOMI(2,MAXISD)
+ DOUBLE PRECISION DFLOTT
+ REAL VALR(2*MAXPAR,2),VREAL(MAXVAL),VALRA(2*MAXPAR,2,MAXADD),
+ 1 CONCMI(MAXISD)
+ LOGICAL LDELT(2*MAXPAR),LDELT1,LSET(2*MAXPAR),LADD(2*MAXPAR),
+ 1 LSET1,LADD1,LDMAP(2*MAXPAR,2),LAMAP(2*MAXPAR,2,MAXADD),
+ 2 LCUB2(2*MAXPAR),LTST,LISOMI,LASBLY
+ TYPE(C_PTR) JPMAP,KPMAP,JPCPO,KPCPO,LPCPO
+ INTEGER, ALLOCATABLE, DIMENSION(:) :: FMIX,ZONEC,MIXA
+ INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ZONEDP
+ REAL, ALLOCATABLE, DIMENSION(:) :: BRN0,BRN1,VARC,TERPA
+ REAL, ALLOCATABLE, DIMENSION(:,:) :: WPAR
+ LOGICAL, ALLOCATABLE, DIMENSION(:) :: LPARM,LDELTA
+ CHARACTER(LEN=12), ALLOCATABLE, DIMENSION(:) :: HPAR
+*----
+* SCRATCH STORAGE ALLOCATION
+* FMIX fuel mixture indices per fuel bundle.
+* BRN0 contains either low burnup integration limits or
+* instantaneous burnups per fuel bundle.
+* BRN1 upper burnup integration limits per fuel bundle.
+* WPAR other parameter distributions.
+* HPAR 'PARKEY' name of the other parameters.
+*----
+ ALLOCATE(LPARM(NPARM+1),FMIX(NCH*NB),ZONEDP(NCH,NB),ZONEC(NCH),
+ 1 BRN0(NCH*NB),BRN1(NCH*NB),WPAR(NCH*NB,NPARM),LDELTA(NMIX),
+ 2 HPAR(NPARM+1))
+*----
+* RECOVER TABLE-OF-CONTENT INFORMATION FOR THE MULTICOMPO.
+*----
+ CALL LCMGET(IPCPO,'STATE-VECTOR',ISTATE)
+ NPAR=ISTATE(5)
+ NLOC=ISTATE(6)
+ NCOMLI=ISTATE(10)
+* ASBLY :
+ LASBLY=.FALSE.
+ CALL LCMGTC(IPCPO,'COMMENT',80,NCOMLI,COMMEN)
+ IF(NPAR.GT.0)THEN
+ CALL LCMSIX(IPCPO,'GLOBAL',1)
+ CALL LCMGTC(IPCPO,'PARKEY',12,NPAR,PARKEY)
+ CALL LCMGTC(IPCPO,'PARFMT',8,NPAR,PARFMT)
+ CALL LCMGET(IPCPO,'NVALUE',NVALUE)
+ IF(IMPX.GT.0)THEN
+ DO IPAR=1,NPAR
+ WRITE(RECNAM,'(''pval'',I8.8)') IPAR
+ IF(PARFMT(IPAR).EQ.'INTEGER') THEN
+ CALL LCMGET(IPCPO,RECNAM,VINTE)
+ WRITE(IOUT,'(13H NCRRGR: KEY=,A,18H TABULATED POINTS=,
+ 1 1P,6I12/(43X,6I12))') PARKEY(IPAR),(VINTE(I),I=1,
+ 2 NVALUE(IPAR))
+ ELSE IF(PARFMT(IPAR).EQ.'REAL') THEN
+ CALL LCMGET(IPCPO,RECNAM,VREAL)
+ WRITE(IOUT,'(13H NCRRGR: KEY=,A,18H TABULATED POINTS=,
+ 1 1P,6E12.4/(43X,6E12.4))') PARKEY(IPAR),(VREAL(I),I=1,
+ 2 NVALUE(IPAR))
+ ELSE IF(PARFMT(IPAR).EQ.'STRING') THEN
+ CALL LCMGTC(IPCPO,RECNAM,12,NVALUE(IPAR),VCHAR)
+ WRITE(IOUT,'(13H NCRRGR: KEY=,A,18H TABULATED POINTS=,
+ 1 1P,6A12/(43X,6A12))') PARKEY(IPAR),(VCHAR(I),I=1,
+ 2 NVALUE(IPAR))
+ ENDIF
+ ENDDO
+ ENDIF
+ CALL LCMSIX(IPCPO,' ',2)
+ ENDIF
+ IF(NLOC.GT.0)THEN
+ CALL LCMSIX(IPCPO,'LOCAL',1)
+ CALL LCMGTC(IPCPO,'PARKEY',12,NLOC,PARKEL)
+ CALL LCMSIX(IPCPO,' ',2)
+ JPCPO=LCMGID(IPCPO,'MIXTURES')
+ DO IBMOLD=1,NMIL
+ KPCPO=LCMGIL(JPCPO,IBMOLD)
+ LPCPO=LCMGID(KPCPO,'TREE')
+ CALL LCMGET(LPCPO,'NVALUE',NVALUE)
+ IF(IMPX.GT.0)THEN
+ WRITE(IOUT,'(17H NCRRGR: MIXTURE=,I6)') IBMOLD
+ DO IPAR=1,NLOC
+ WRITE(RECNAM,'(''pval'',I8.8)') IPAR
+ CALL LCMGET(LPCPO,RECNAM,VREAL)
+ WRITE(IOUT,'(13H NCRRGR: KEY=,A,18H TABULATED POINTS=,
+ 1 1P,6E12.4/(43X,6E12.4))') PARKEL(IPAR),(VREAL(I),I=1,
+ 2 NVALUE(IPAR))
+ ENDDO
+ ENDIF
+ ENDDO
+ ENDIF
+ IF(IMPX.GT.0) THEN
+ WRITE(IOUT,'(43H NCRRGR: NUMBER OF CALCULATIONS IN MULTICOM,
+ 1 3HPO=,I5)') NCAL
+ WRITE(IOUT,'(43H NCRRGR: NUMBER OF MATERIAL MIXTURES IN MUL,
+ 1 8HTICOMPO=,I5)') NMIL
+ WRITE(IOUT,'(43H NCRRGR: NUMBER OF MATERIAL MIXTURES IN FUE,
+ 1 6HL MAP=,I6)') NMIX
+ WRITE(IOUT,'(1X,A)') (COMMEN(I),I=1,NCOMLI)
+ ENDIF
+ TERP(:NCAL,:NMIX)=0.0
+ MIXC(:NMIX)=0
+*----
+* READ (INTERP_DATA) AND SET VALI, VALR AND VALH PARAMETERS
+* CORRESPONDING TO THE INTERPOLATION POINT. FILL MUPLET FOR
+* PARAMETERS SET WITHOUT INTERPOLATION.
+*----
+ IBM=0
+ IBMB=0
+ IBME=0
+ MAXNIS=0
+ NISOMI=0
+ LISOMI=.TRUE.
+ LDELT1=.FALSE.
+ LADD1=.FALSE.
+ NISO(:NMIX)=0
+ LISO(:NMIX)=.TRUE.
+ LDELTA(:NMIX)=.FALSE.
+ IDLTA1=0
+ DO I=1,2*MAXPAR
+ LSET(I)=.FALSE.
+ LDELT(I)=.FALSE.
+ LADD(I)=.FALSE.
+ LDMAP(I,:2)=.FALSE.
+ LAMAP(I,:2,:MAXADD)=.FALSE.
+ NDLTA(I)=0
+ ENDDO
+*----
+* READ THE PARKEY NAME OF THE BURNUP FOR THIS MULTICOMPO.
+*----
+ CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT)
+ IF(INDIC.NE.3)CALL XABORT('NCRRGR: CHARACTER DATA EXPECTED(1).')
+ IF((TEXT12.EQ.'MIX').OR.(TEXT12.EQ.';')) THEN
+ NPARMP=NPARM
+ GO TO 30
+ ELSE
+* add burnup to parameters
+ NPARMP=NPARM+1
+ HPAR(NPARMP)=TEXT12
+ CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT)
+ IF(INDIC.NE.3)CALL XABORT('MCRRGR: CHARACTER DATA EXPECTED(2).')
+ IF((TEXT12.EQ.'MIX').OR.(TEXT12.EQ.';')) GO TO 30
+ HNAVAL=TEXT12
+ ENDIF
+*----
+* MAIN LOOP OF THE SUBROUTINE (UNTIL THE END)
+*----
+ 20 CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT)
+ IF(INDIC.NE.3)CALL XABORT('NCRRGR: CHARACTER DATA EXPECTED(2).')
+ 30 IF(TEXT12.EQ.'MIX')THEN
+ NISOMI=0
+ LISOMI=.TRUE.
+ IVARTY=0
+ IBTYP=0
+ HNAVAL=' '
+ MUPLET(:NPAR+NLOC)=0
+ MUTYPE(:NPAR+NLOC)=0
+ VALI(:NPAR)=0
+ VALR(:NPAR+NLOC,1)=0.0
+ VALR(:NPAR+NLOC,2)=0.0
+ DO 35 I=1,MAXADD
+ MAPLET(:NPAR+NLOC,I)=0
+ MATYPE(:NPAR+NLOC,I)=0
+ VALRA(:NPAR+NLOC,1,I)=0.0
+ VALRA(:NPAR+NLOC,2,I)=0.0
+ 35 CONTINUE
+ DO I=1,2*MAXPAR
+ LSET(I)=.FALSE.
+ LDELT(I)=.FALSE.
+ LADD(I)=.FALSE.
+ LDMAP(I,:2)=.FALSE.
+ LAMAP(I,:2,:MAXADD)=.FALSE.
+ ENDDO
+ DO 40 I=1,NPAR
+ VALH(I)=' '
+ 40 CONTINUE
+ LCUB2(:NPAR+NLOC)=LCUBIC
+ CALL REDGET(INDIC,IBM,FLOTT,TEXT12,DFLOTT)
+ IF(INDIC.NE.1)CALL XABORT('NCRRGR: INTEGER DATA EXPECTED.')
+* CHECK FUEL MIXTURE
+ JPMAP=LCMGID(IPMAP,'FUEL')
+ DO IFUEL=1,NFUEL
+ KPMAP=LCMGIL(JPMAP,IFUEL)
+ CALL LCMGET(KPMAP,'MIX',IMIX)
+ IF(IMIX.EQ.IBM)GOTO 50
+ ENDDO
+ WRITE(IOUT,*)'NCRRGR: UNABLE TO FIND FUEL MIXTURE ',IBM
+ CALL XABORT('NCRRGR: WRONG MIXTURE NUMBER.')
+ 50 IBMOLD=1
+ CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT)
+ IF(INDIC.NE.3)CALL XABORT('NCRRGR: CHARACTER DATA EXPECTED(3).')
+ IF(TEXT12.EQ.'FROM')THEN
+ CALL REDGET(INDIC,IBMOLD,FLOTT,TEXT12,DFLOTT)
+ IF(INDIC.NE.1)CALL XABORT('NCRRGR: INTEGER DATA EXPECTED.')
+ CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT)
+ IF(INDIC.NE.3)CALL XABORT('NCRRGR: CHARACTER DATA EXPECTE'
+ 1 //'D.')
+ ELSE IF(TEXT12.EQ.'USE') THEN
+ IBMOLD=IBM
+ CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT)
+ IF(INDIC.NE.3)CALL XABORT('NCRRGR: CHARACTER DATA EXPECTE'
+ 1 //'D.')
+* ASBLY: automatically assembly-wise unfolded geometry
+ ELSE IF(TEXT12.EQ.'ASBLY') THEN
+ IF(LASBLY) DEALLOCATE(MIXA)
+ IBMOLD=1
+ LASBLY=.TRUE.
+ JPMAP=LCMGID(IPMAP,'GEOMAP')
+ CALL LCMGET(JPMAP,'STATE-VECTOR',ISTATE)
+ CALL LCMLEN(JPMAP,'MIX-ASBLY',NITMA,INDIC)
+ IF(NITMA.EQ.0)CALL XABORT('NCRRGR: No assembly defined')
+ NMIXA=NITMA/2
+* NMIXA=ISTATE(39)
+ ALLOCATE(MIXA(2*NMIXA))
+ CALL LCMGET(JPMAP,'MIX-ASBLY',MIXA)
+ DO I=1,NMIXA
+ IF(IBM.EQ.MIXA(I)) THEN
+ IBMB=MIXA(I+NMIXA)
+ IBME=IBMB+NMIL-1
+ CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT)
+ IF(INDIC.NE.3)CALL XABORT('NCRRGR: CHARACTER DATA EXPECTE'
+ 1 //'D.')
+ GOTO 30
+ ENDIF
+ ENDDO
+ CALL XABORT('NCRRGR: WRONG ASSEMBLY MIXTURE.')
+ ENDIF
+* ASBLY: automatically assembly-wise unfolded geometry
+ IBMB=IBM
+ IBME=IBM
+ GOTO 30
+ ELSEIF(TEXT12.EQ.'MICRO')THEN
+ IF(IBM.EQ.0) CALL XABORT('NCRRGR: MIX NOT SET (1).')
+ CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT)
+ IF(INDIC.NE.3)CALL XABORT('NCRRGR: CHARACTER DATA EXPECTED(4).')
+ IF(TEXT12.EQ.'ALL')THEN
+ LISOMI=.TRUE.
+ ELSEIF(TEXT12.EQ.'ONLY')THEN
+ LISOMI=.FALSE.
+ ENDIF
+ CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT)
+ IF(INDIC.NE.3)CALL XABORT('NCRRGR: CHARACTER DATA EXPECTED(5).')
+ 60 IF(TEXT12.EQ.'ENDMIX')THEN
+ GOTO 30
+ ELSE
+ NISOMI=NISOMI+1
+ IF(NISOMI.GT.MAXISD) CALL XABORT('NCRRGR: MAXISD OVERFLOW.')
+ MAXNIS=MAX(MAXNIS,NISOMI)
+ READ(TEXT12,'(2A4)') (HISOMI(I0,NISOMI),I0=1,2)
+ CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT)
+ IF(INDIC.EQ.2)THEN
+ CONCMI(NISOMI)=FLOTT
+ ELSEIF((INDIC.EQ.3).AND.(TEXT12.EQ.'*'))THEN
+ CONCMI(NISOMI)=-99.99
+ ELSE
+ CALL XABORT('NCRRGR: INVALID HISO DATA.')
+ ENDIF
+ CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT)
+ IF(INDIC.NE.3)CALL XABORT('NCRRGR: CHARACTER DATA EXPECTED.')
+ GOTO 60
+ ENDIF
+ ELSEIF((TEXT12.EQ.'SET').OR.(TEXT12.EQ.'DELTA').OR.
+ 1 (TEXT12.EQ.'ADD'))THEN
+ IF(IBM.EQ.0) CALL XABORT('NCRRGR: MIX NOT SET (2).')
+ ITYPE=0
+ LSET1=.FALSE.
+ LDELT1=.FALSE.
+ LADD1=.FALSE.
+ IF(TEXT12.EQ.'SET')THEN
+ ITYPE=1
+ LSET1=.TRUE.
+ ELSEIF(TEXT12.EQ.'DELTA')THEN
+ ITYPE=2
+ LDELT1=.TRUE.
+ ELSEIF(TEXT12.EQ.'ADD')THEN
+ ITYPE=2
+ LADD1=.TRUE.
+ IDLTA1=IDLTA1+1
+ DO 65 JPAR=1,NPAR+NLOC
+ MAPLET(JPAR,IDLTA1)=MUPLET(JPAR)
+ MATYPE(JPAR,IDLTA1)=MUTYPE(JPAR)
+ 65 CONTINUE
+ ENDIF
+ CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT)
+ IF(INDIC.NE.3)CALL XABORT('NCRRGR: CHARACTER DATA EXPECTED(7).')
+ IF((TEXT12.EQ.'LINEAR').OR.(TEXT12.EQ.'CUBIC')) THEN
+ HCUBIC=TEXT12
+ CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT)
+ ELSE
+ HCUBIC=' '
+ ENDIF
+ IF(INDIC.NE.3)CALL XABORT('NCRRGR: CHARACTER DATA EXPECTED(8).')
+* check if parameter is global
+ IPAR=-99
+ DO I=1,NPAR
+ IF(TEXT12.EQ.PARKEY(I))THEN
+ IPAR=I
+ LPCPO=LCMGID(IPCPO,'GLOBAL')
+ IPARTM=IPAR
+ PARNAM=TEXT12
+ GOTO 70
+ ENDIF
+ ENDDO
+* check if parameter is local
+ DO I=1,NLOC
+ IF(TEXT12.EQ.PARKEL(I))THEN
+ IPAR=NPAR+I
+ JPCPO=LCMGID(IPCPO,'MIXTURES')
+ KPCPO=LCMGIL(JPCPO,IBMOLD)
+ LPCPO=LCMGID(KPCPO,'TREE')
+ IPARTM=IPAR-NPAR
+ PARNAM=TEXT12
+ GOTO 70
+ ENDIF
+ ENDDO
+ WRITE(HSMG,'(18HNCRRGR: PARAMETER ,A,14H NOT FOUND(1).)') TEXT12
+ CALL XABORT(HSMG)
+*
+ 70 IF(HCUBIC.EQ.'LINEAR') THEN
+ LCUB2(IPAR)=.FALSE.
+ ELSE IF(HCUBIC.EQ.'CUBIC') THEN
+ LCUB2(IPAR)=.TRUE.
+ ENDIF
+ WRITE(RECNAM,'(''pval'',I8.8)') IPARTM
+ CALL LCMGET(LPCPO,'NVALUE',NVALUE)
+ IF(NVALUE(IPARTM).GT.MAXVAL)CALL XABORT('NCRRGR: MAXVAL OVERFL'
+ 1 //'OW.')
+ CALL LCMLEN(LPCPO,RECNAM,LENGTH,ITYLCM)
+ IF(LENGTH.EQ.0)THEN
+ WRITE(HSMG,'(25HNCRRGR: GLOBAL PARAMETER ,A,9H NOT SET.)')
+ 1 PARNAM
+ CALL XABORT(HSMG)
+ ENDIF
+ IF((IPAR.GT.NPAR).OR.
+ 1 ((IPAR.LE.NPAR).AND.(PARFMT(IPAR).EQ.'REAL')))THEN
+ VALR1=VREAL(1)
+ VALR2=VREAL(NVALUE(IPAR))
+ CALL LCMGET(LPCPO,RECNAM,VREAL)
+ CALL REDGET(INDIC,NITMA,VALR1,TEXT12,DFLOTT)
+ IF(INDIC.EQ.2)THEN
+ VALR2=VALR1
+ IF(LSET1) THEN
+ LSET(IPAR)=.TRUE.
+ VALR(IPAR,1)=VALR1
+ VALR(IPAR,2)=VALR1
+ ENDIF
+ IF(LDELT1) THEN
+ LDELT(IPAR)=.TRUE.
+ VALR(IPAR,1)=VALR1
+ VALR(IPAR,2)=VALR1
+ ELSEIF(LADD1) THEN
+ LADD(IPAR)=.TRUE.
+ VALRA(IPAR,1,IDLTA1)=VALR1
+ VALRA(IPAR,2,IDLTA1)=VALR1
+ NDLTA(IPAR)=NDLTA(IPAR)+1
+ IF(NDLTA(IPAR).GT.MAXADD) CALL XABORT('NCRRGR: MAXADD OV'
+ 1 //'ERFLOW.')
+ IDLTA(IPAR,NDLTA(IPAR))=IDLTA1
+ ENDIF
+ ELSEIF(TEXT12.EQ.'MAP')THEN
+ IF(LDELT1)THEN
+ LDELT(IPAR)=.TRUE.
+ LDMAP(IPAR,1)=.TRUE.
+ ELSEIF(LADD1)THEN
+ LADD(IPAR)=.TRUE.
+ NDLTA(IPAR)=NDLTA(IPAR)+1
+ IF(NDLTA(IPAR).GT.MAXADD) CALL XABORT('NCRRGR: MAXADD OV'
+ 1 //'ERFLOW.')
+ LAMAP(IPAR,1,NDLTA(IPAR))=.TRUE.
+ IDLTA(IPAR,NDLTA(IPAR))=IDLTA1
+ ENDIF
+ IF(LSET1.AND.(.NOT.LSET(IPAR))) GO TO 20
+ ELSE
+ CALL XABORT('NCRRGR: real value or "MAP" expected(1).')
+ ENDIF
+ CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT)
+ IF(ITYPE.GE.2)THEN
+ IF(INDIC.EQ.2)THEN
+ VALR2=FLOTT
+ IF(LDELT1)THEN
+ VALR(IPAR,2)=VALR2
+ ELSEIF(LADD1)THEN
+ VALRA(IPAR,2,IDLTA1)=VALR2
+ ENDIF
+ ELSEIF(TEXT12.EQ.'MAP')THEN
+ IF(LDELT1)THEN
+ LDMAP(IPAR,2)=.TRUE.
+ ELSEIF(LADD1)THEN
+ LAMAP(IPAR,2,IDLTA1)=.TRUE.
+ ENDIF
+ ELSE
+ CALL XABORT('NCRRGR: real value or "MAP" expected(2).')
+ ENDIF
+ CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT)
+ ENDIF
+ LTST=.FALSE.
+ IF(.NOT.LADD1)THEN
+ IF(VALR(IPAR,1).EQ.VALR(IPAR,2)) LTST=.TRUE.
+ MUPLET(IPAR)=-1
+ MUTYPE(IPAR)=ITYPE
+ ELSE
+ MAPLET(IPAR,IDLTA1)=-1
+ MATYPE(IPAR,IDLTA1)=2
+ ENDIF
+ IF((LTST).AND.(ITYPE.EQ.1))THEN
+ DO J=1,NVALUE(IPARTM)
+ IF(ABS(VALR(IPAR,1)-VREAL(J)).LE.REPS*ABS(VREAL(J)))THEN
+ MUPLET(IPAR)=J
+ GOTO 30
+ ENDIF
+ ENDDO
+ ENDIF
+*----
+* ERRORS HANDLING
+*----
+ IF(VALR1.LT.VREAL(1))THEN
+* OUTSIDE OF THE DOMAIN (1)
+ WRITE(HSMG,'(23HNCRRGR: REAL PARAMETER ,A,10H WITH VALU,
+ 1 1HE,1P,E12.4,26H IS OUTSIDE THE DOMAIN.(1))') PARNAM,VALR1
+ WRITE(6,*)'Domain:',VREAL(1),' <-> ',VREAL(NVALUE(IPAR))
+ CALL XABORT(HSMG)
+ ELSEIF(VALR2.GT.VREAL(NVALUE(IPARTM)))THEN
+* OUTSIDE OF THE DOMAIN (2)
+ WRITE(HSMG,'(23HNCRRGR: REAL PARAMETER ,A,10H WITH VALU,
+ 1 1HE,1P,E12.4,26H IS OUTSIDE THE DOMAIN.(2))') PARNAM,VALR2
+ WRITE(6,*)'Domain:',VREAL(1),' <-> ',VREAL(NVALUE(IPAR))
+ CALL XABORT(HSMG)
+ ELSEIF((VALR1.GT.VALR2).AND.(ITYPE.EQ.1))THEN
+* ITYPE=1 correspond to an integral between VALR1 and VALR2
+* otherwise it is a simple difference
+ WRITE(HSMG,'(23HNCRRGR: REAL PARAMETER ,A,9H IS DEFIN,
+ 1 7HED WITH,1P,E12.4,2H >,E12.4,4H.(1))') PARNAM,
+ 2 VALR1,VALR2
+ CALL XABORT(HSMG)
+ ENDIF
+ IF((LADD1).AND.(TEXT12.EQ.'REF'))THEN
+ 120 IPAR=-99
+ CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT)
+ IF(TEXT12.EQ.'ENDREF') GOTO 140
+ DO I=1,NPAR
+ IF(TEXT12.EQ.PARKEY(I))THEN
+ IPAR=I
+ GOTO 130
+ ENDIF
+ ENDDO
+ DO I=1,NLOC
+ IF(TEXT12.EQ.PARKEL(I))THEN
+ IPAR=NPAR+I
+ GOTO 130
+ ENDIF
+ ENDDO
+ CALL XABORT('NCRRGR: PARAMETER '//TEXT12//' NOT FOUND(2).')
+ 130 CONTINUE
+ CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT)
+ IF(INDIC.EQ.2)THEN
+ VALRA(IPAR,1,IDLTA1)=FLOTT
+ VALRA(IPAR,2,IDLTA1)=FLOTT
+ IF(IPAR.LE.NPAR)THEN
+ LPCPO=LCMGID(IPCPO,'GLOBAL')
+ IPARTM=IPAR
+ ELSE
+ JPCPO=LCMGID(IPCPO,'MIXTURES')
+ KPCPO=LCMGIL(JPCPO,IBMOLD)
+ LPCPO=LCMGID(KPCPO,'TREE')
+ IPARTM=IPAR-NPAR
+ ENDIF
+ WRITE(RECNAM,'(''pval'',I8.8)') IPARTM
+ CALL LCMGET(LPCPO,RECNAM,VREAL)
+ CALL LCMGET(LPCPO,'NVALUE',NVALUE)
+ MAPLET(IPAR,IDLTA1)=-1
+ MATYPE(IPAR,IDLTA1)=1
+ DO J=1,NVALUE(IPARTM)
+ IF(ABS(VALRA(IPAR,1,IDLTA1)-VREAL(J)).LE.
+ 1 REPS*ABS(VREAL(J)))THEN
+ MAPLET(IPAR,IDLTA1)=J
+ GOTO 120
+ ENDIF
+ ENDDO
+ ELSEIF(TEXT12.EQ.'SAMEASREF')THEN
+ MAPLET(IPAR,IDLTA1)=-1
+ MATYPE(IPAR,IDLTA1)=-1
+ ELSE
+ CALL XABORT('NCRRGR: REAL or "SAMEASREF" expected')
+ ENDIF
+ GOTO 120
+ 140 CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT)
+ ELSE IF((LDELT1).AND.(TEXT12.EQ.'REF'))THEN
+ 150 IPAR=-99
+ CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT)
+ IF(TEXT12.EQ.'ENDREF') GOTO 170
+ DO I=1,NPAR
+ IF(TEXT12.EQ.PARKEY(I))THEN
+ IPAR=I
+ GOTO 160
+ ENDIF
+ ENDDO
+ DO I=1,NLOC
+ IF(TEXT12.EQ.PARKEL(I))THEN
+ IPAR=NPAR+I
+ GOTO 160
+ ENDIF
+ ENDDO
+ CALL XABORT('NCRRGR: PARAMETER '//TEXT12//' NOT FOUND(3).')
+ 160 CONTINUE
+ CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT)
+ IF(INDIC.EQ.2)THEN
+ VALR(IPAR,1)=FLOTT
+ VALR(IPAR,2)=FLOTT
+ IF(IPAR.LE.NPAR)THEN
+ LPCPO=LCMGID(IPCPO,'GLOBAL')
+ IPARTM=IPAR
+ ELSE
+ JPCPO=LCMGID(IPCPO,'MIXTURES')
+ KPCPO=LCMGIL(JPCPO,IBMOLD)
+ LPCPO=LCMGID(KPCPO,'TREE')
+ IPARTM=IPAR-NPAR
+ ENDIF
+ WRITE(RECNAM,'(''pval'',I8.8)') IPARTM
+ CALL LCMGET(LPCPO,RECNAM,VREAL)
+ CALL LCMGET(LPCPO,'NVALUE',NVALUE)
+ MUPLET(IPAR)=-1
+ MUTYPE(IPAR)=1
+ DO J=1,NVALUE(IPARTM)
+ IF(ABS(VALR(IPAR,1)-VREAL(J)).LE.REPS*ABS(VREAL(J)))THEN
+ MUPLET(IPAR)=J
+ GOTO 150
+ ENDIF
+ ENDDO
+ ELSEIF(TEXT12.EQ.'SAMEASREF')THEN
+ MUPLET(IPAR)=-1
+ MUTYPE(IPAR)=-1
+ ELSE
+ CALL XABORT('NCRRGR: REAL or "SAMEASREF" expected')
+ ENDIF
+ GOTO 150
+ 170 CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT)
+ ENDIF
+ GOTO 30
+ ELSEIF(PARFMT(IPAR).EQ.'INTEGER')THEN
+ IF(ITYPE.NE.1)CALL XABORT('NCRRGR: SET MANDATORY WITH INT'
+ 1 //'EGER PARAMETERS.')
+ CALL REDGET(INDIC,VALI(IPAR),FLOTT,TEXT12,DFLOTT)
+ IF(INDIC.NE.1)CALL XABORT('NCRRGR: INTEGER DATA EXPECTED.')
+ CALL LCMGET(LPCPO,RECNAM,VINTE)
+ DO 175 J=1,NVALUE(IPAR)
+ IF(VALI(IPAR).EQ.VINTE(J))THEN
+ MUPLET(IPAR)=J
+ MUTYPE(IPAR)=ITYPE
+ GOTO 20
+ ENDIF
+ 175 CONTINUE
+ WRITE(HSMG,'(26HNCRRGR: INTEGER PARAMETER ,A,9H WITH VAL,
+ 1 2HUE,I5,34H NOT FOUND IN MULTICOMPO DATABASE.)')
+ 2 PARKEY(IPAR), VALI(IPAR)
+ CALL XABORT(HSMG)
+ ELSEIF(PARFMT(IPAR).EQ.'STRING')THEN
+ IF(ITYPE.NE.1)CALL XABORT('NCRRGR: SET MANDATORY WITH STR'
+ 1 //'ING PARAMETERS.')
+ CALL REDGET(INDIC,NITMA,FLOTT,VALH(IPAR),DFLOTT)
+ IF(INDIC.NE.3)CALL XABORT('NCRRGR: STRING DATA EXPECTED.')
+ CALL LCMGTC(LPCPO,RECNAM,12,NVALUE(IPAR),VCHAR)
+ DO 180 J=1,NVALUE(IPAR)
+ IF(VALH(IPAR).EQ.VCHAR(J))THEN
+ MUPLET(IPAR)=J
+ MUTYPE(IPAR)=ITYPE
+ GOTO 20
+ ENDIF
+ 180 CONTINUE
+ WRITE(HSMG,'(25HNCRRGR: STRING PARAMETER ,A,10H WITH VALU,
+ 1 1HE,A12,34H NOT FOUND IN MULTICOMPO DATABASE.)')
+ 2 PARKEY(IPAR), VALH(IPAR)
+ CALL XABORT(HSMG)
+ ENDIF
+ ELSEIF(TEXT12.EQ.'TIMAV-BURN')THEN
+ IF(IBM.EQ.0) CALL XABORT('NCRRGR: MIX NOT SET (3).')
+ IBTYP=1
+ ELSEIF(TEXT12.EQ.'INST-BURN')THEN
+ IF(IBM.EQ.0) CALL XABORT('NCRRGR: MIX NOT SET (4).')
+ IBTYP=2
+ ELSEIF(TEXT12.EQ.'AVG-EX-BURN')THEN
+ IF(IBM.EQ.0) CALL XABORT('NCRRGR: MIX NOT SET (5).')
+ IBTYP=3
+ CALL REDGET(INDIC,IVARTY,FLOTT,TEXT12,DFLOTT)
+ IF(INDIC.NE.1)CALL XABORT('NCRRGR: INTEGER DATA EXPECTED.')
+ ELSEIF(TEXT12.EQ.'ENDMIX')THEN
+*----
+* RECOVER FUEL-MAP INFORMATION.
+*----
+ IF(IMPX.GT.0) THEN
+ DO IPAR=1,NPAR
+ IF(PARFMT(IPAR).EQ.'REAL')THEN
+ IF(LCUB2(IPAR)) THEN
+ WRITE(IOUT,'(26H NCRRGR: GLOBAL PARAMETER:,A12,5H ->CU,
+ 1 18HBIC INTERPOLATION.)') PARKEY(IPAR)
+ ELSE
+ WRITE(IOUT,'(26H NCRRGR: GLOBAL PARAMETER:,A12,5H ->LI,
+ 1 19HNEAR INTERPOLATION.)') PARKEY(IPAR)
+ ENDIF
+ ENDIF
+ ENDDO
+ DO IPAR=1,NLOC
+ IF(LCUB2(NPAR+IPAR)) THEN
+ WRITE(IOUT,'(25H NCRRGR: LOCAL PARAMETER:,A12,8H ->CUBIC,
+ 1 14HINTERPOLATION.)') PARKEL(IPAR)
+ ELSE
+ WRITE(IOUT,'(25H NCRRGR: LOCAL PARAMETER:,A12,8H ->LINEA,
+ 1 16HR INTERPOLATION.)') PARKEL(IPAR)
+ ENDIF
+ ENDDO
+ ENDIF
+ FMIX(:NCH*NB)=0
+ CALL LCMGET(IPMAP,'FLMIX',FMIX)
+ CALL NCRMAP(IPMAP,NPARM,HPAR,NCH,NB,IBTYP,HNAVAL,IMPX,BRN0,BRN1,
+ 1 WPAR,LPARM)
+ IF(IBTYP.EQ.3) THEN
+ IF(IVARTY.EQ.0) CALL XABORT('NCRRGR: IVARTY NOT SET.')
+ CALL LCMGET(IPMAP,'B-ZONE',ZONEC)
+ DO ICH=1,NCH
+ DO J=1,NB
+ IF(ZONEC(ICH).EQ.IVARTY) THEN
+ ZONEDP(ICH,J)=1
+ ELSE
+ ZONEDP(ICH,J)=0
+ ENDIF
+ ENDDO
+ ENDDO
+ CALL LCMLEN(IPMAP,'B-VALUE',ILONG,ITYP)
+ IF (ILONG.EQ.0) CALL XABORT('NCRRGR: NO SAVED VALUES FOR '
+ 1 //'THIS TYPE OF VARIABLE IN L_MAP')
+ ALLOCATE(VARC(ILONG))
+ CALL LCMGET(IPMAP,'B-VALUE',VARC)
+ VARVAL=VARC(IVARTY)
+ DEALLOCATE(VARC)
+ ENDIF
+*----
+* PERFORM INTERPOLATION OVER THE FUEL MAP.
+*----
+ DO 185 JPARM=1,NPARMP
+ IPAR=-99
+ DO I=1,NPAR
+ IF(HPAR(JPARM).EQ.PARKEY(I))THEN
+ IPAR=I
+ IF(LSET(IPAR)) THEN
+ IF(IMPX.GT.0) WRITE(6,*) 'L_MAP values overwritten by '
+ 1 // 'the SET option for parameter '//HPAR(JPARM)
+ IF(.NOT.LADD(IPAR)) LPARM(JPARM)=.FALSE.
+ ENDIF
+ GOTO 185
+ ENDIF
+ ENDDO
+ DO I=1,NLOC
+ IF(HPAR(JPARM).EQ.PARKEL(I))THEN
+ IPAR=NPAR+I
+ IF(LSET(IPAR)) THEN
+ IF(IMPX.GT.0) WRITE(6,*) 'L_MAP values overwritten by '
+ 1 // 'the SET option for parameter '//HPAR(JPARM)
+ IF(.NOT.LADD(IPAR)) LPARM(JPARM)=.FALSE.
+ ENDIF
+ GOTO 185
+ ENDIF
+ ENDDO
+ LPARM(JPARM)=.FALSE.
+ 185 CONTINUE
+*----
+* COMPUTE ALL THE MUPLETS FOR EACH BUNDLE
+*----
+ IMPY=MAX(0,IMPX-1)
+ NTOT=0
+ DO 281 JB=1,NB
+ DO 280 ICH=1,NCH
+ IB=(JB-1)*NCH+ICH
+ IF(FMIX(IB).EQ.0) GO TO 280
+ NTOT=NTOT+1
+* ASBLY: loop on multicompo mixtures
+ DO 285 IBM=IBMB,IBME
+ IF(LASBLY) IBMOLD=IBM-IBMB+1
+* ASBLY: end
+ IPAR=-99
+ IF(FMIX(IB).EQ.IBM)THEN
+ IF(NTOT.GT.NMIX) CALL XABORT('NCRRGR: NMIX OVERFLOW.')
+ DO 260 JPARM=1,NPARMP
+ IF(.NOT.LPARM(JPARM))GOTO 260
+* check if parameter is global
+ DO I=1,NPAR
+ IF(HPAR(JPARM).EQ.PARKEY(I))THEN
+ IPAR=I
+ LPCPO=LCMGID(IPCPO,'GLOBAL')
+ IPARTM=IPAR
+ PARNAM=HPAR(JPARM)
+ GOTO 190
+ ENDIF
+ ENDDO
+* check if parameter is local
+ DO I=1,NLOC
+ IF(HPAR(JPARM).EQ.PARKEL(I))THEN
+ IPAR=NPAR+I
+ JPCPO=LCMGID(IPCPO,'MIXTURES')
+ KPCPO=LCMGIL(JPCPO,IBMOLD)
+ LPCPO=LCMGID(KPCPO,'TREE')
+ IPARTM=IPAR-NPAR
+ PARNAM=HPAR(JPARM)
+ GOTO 190
+ ENDIF
+ ENDDO
+ WRITE(HSMG,'(18HNCRRGR: PARAMETER ,A,14H NOT FOUND(4).)')
+ 1 HPAR(JPARM)
+ CALL XABORT(HSMG)
+ 190 CONTINUE
+ WRITE(RECNAM,'(''pval'',I8.8)') IPARTM
+ CALL LCMGET(LPCPO,'NVALUE',NVALUE)
+ IF(NVALUE(IPARTM).GT.MAXVAL)CALL XABORT('NCRRGR: MAXVAL OVERFL'
+ 1 //'OW.')
+ CALL LCMLEN(LPCPO,RECNAM,LENGTH,ITYLCM)
+ IF(LENGTH.EQ.0)THEN
+ WRITE(HSMG,'(25HNCRRGR: GLOBAL PARAMETER ,A,9H NOT SET.)')
+ 1 PARNAM
+ CALL XABORT(HSMG)
+ ENDIF
+ ITYPE=0
+ IF((JPARM.EQ.NPARMP).AND.(NPARMP.EQ.NPARM+1))THEN
+* parameter JPARAM is burnup
+ IF(.NOT.LSET(IPAR))THEN
+ MUTYPE(IPAR)=1
+ MUPLET(IPAR)=-1
+ BURN0=0.0
+ BURN1=0.0
+ IF(IBTYP.EQ.1)THEN
+* TIME-AVERAGE
+ BURN0=BRN0(IB)
+ BURN1=BRN1(IB)
+ ELSEIF(IBTYP.EQ.2)THEN
+* INSTANTANEOUS
+ BURN0=BRN0(IB)
+ BURN1=BURN0
+ ELSEIF(IBTYP.EQ.3)THEN
+* DIFFERENCIATION RELATIVE TO EXIT BURNUP
+ ITYPE=3
+ BURN0=BRN0(IB)
+ BURN1=BRN1(IB)
+ ENDIF
+ VALR(IPAR,1)=BURN0
+ VALR(IPAR,2)=BURN1
+ VALR1=VALR(IPAR,1)
+ VALR2=VALR(IPAR,2)
+ ITYPE=1
+ ENDIF
+ ELSE
+ IF(.NOT.LSET(IPAR))THEN
+ VALR(IPAR,1)=WPAR(IB,JPARM)
+ VALR(IPAR,2)=WPAR(IB,JPARM)
+ MUPLET(IPAR)=-1
+ MUTYPE(IPAR)=1
+ VALR1=VALR(IPAR,1)
+ VALR2=VALR(IPAR,2)
+ ITYPE=1
+ ENDIF
+ IF(LDMAP(IPAR,1).OR.LDMAP(IPAR,2))THEN
+ IF(LDMAP(IPAR,1)) VALR(IPAR,1)=WPAR(IB,JPARM)
+ IF(LDMAP(IPAR,2)) VALR(IPAR,2)=WPAR(IB,JPARM)
+ MUPLET(IPAR)=-1
+ MUTYPE(IPAR)=2
+ VALR1=VALR(IPAR,1)
+ VALR2=VALR(IPAR,2)
+ ITYPE=2
+ ELSE IF(LADD(IPAR))THEN
+ DO N=1,NDLTA(IPAR)
+ IDLTA1=IDLTA(IPAR,N)
+ IF(LAMAP(IPAR,1,IDLTA1)) THEN
+ VALRA(IPAR,1,IDLTA1)=WPAR(IB,JPARM)
+ MAPLET(IPAR,IDLTA1)=-1
+ MATYPE(IPAR,IDLTA1)=2
+ ENDIF
+ IF(LAMAP(IPAR,2,IDLTA1)) THEN
+ VALRA(IPAR,2,IDLTA1)=WPAR(IB,JPARM)
+ MAPLET(IPAR,IDLTA1)=-1
+ MATYPE(IPAR,IDLTA1)=2
+ ENDIF
+ ENDDO
+ VALR1=VALRA(IPAR,1,IDLTA(IPAR,1))
+ VALR2=VALRA(IPAR,2,IDLTA(IPAR,1))
+ ITYPE=2
+ ENDIF
+ ENDIF
+ LPCPO=LCMGID(IPCPO,'GLOBAL')
+ CALL LCMGET(LPCPO,'NVALUE',NVALUE)
+ IF(NVALUE(IPARTM).GT.MAXVAL) CALL XABORT('NCRRGR: MAXVAL OVE'
+ 1 //'RFLOW.')
+ WRITE(RECNAM,'(''pval'',I8.8)') IPARTM
+ CALL LCMLEN(LPCPO,RECNAM,LENGTH,ITYLCM)
+ IF(LENGTH.EQ.0)THEN
+ WRITE(HSMG,'(25HNCRRGR: GLOBAL PARAMETER ,A,9H NOT SET.)')
+ 1 PARNAM
+ CALL XABORT(HSMG)
+ ENDIF
+ IF(LENGTH.GT.MAXVAL) CALL XABORT('NCRRGR: MAXVAL OVERFLOW.')
+ CALL LCMGET(LPCPO,RECNAM,VREAL)
+ IF(ITYPE.EQ.1)THEN
+ IF(VALR1.EQ.VALR2)THEN
+ DO J=1,NVALUE(IPARTM)
+ IF(ABS(VALR1-VREAL(J)).LE.REPS*ABS(VREAL(J)))THEN
+ MUPLET(IPAR)=J
+ MUTYPE(IPAR)=ITYPE
+ GOTO 260
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+*----
+* ERRORS HANDLING
+*----
+ IF(VALR1.LT.VREAL(1))THEN
+* OUTSIDE OF THE DOMAIN (1)
+ WRITE(HSMG,'(23HNCRRGR: REAL PARAMETER ,A,10H WITH VALU,
+ 1 1HE,1P,E12.4,26H IS OUTSIDE THE DOMAIN(3).)') PARNAM,VALR1
+ WRITE(6,*)'Domain:',VREAL(1),' <-> ',VREAL(NVALUE(IPAR))
+ CALL XABORT(HSMG)
+ ELSEIF(VALR2.GT.VREAL(NVALUE(IPAR)))THEN
+* OUTSIDE OF THE DOMAIN (2)
+ WRITE(HSMG,'(23HNCRRGR: REAL PARAMETER ,A,10H WITH VALU,
+ 1 1HE,1P,E12.4,26H IS OUTSIDE THE DOMAIN(4).)') PARNAM,VALR2
+ WRITE(6,*)'Domain:',VREAL(1),' <-> ',VREAL(NVALUE(IPAR))
+ CALL XABORT(HSMG)
+ ELSEIF((ITYPE.EQ.1).AND.(VALR1.GT.VALR2))THEN
+* VALR1 > VALR2
+ WRITE(HSMG,'(23HNCRRGR: REAL PARAMETER ,A,9H IS DEFIN,
+ 1 7HED WITH,1P,E12.4,2H >,E12.4,4H.(2))') PARNAM,
+ 2 VALR1,VALR2
+ CALL XABORT(HSMG)
+ ENDIF
+*----
+* COMPUTE THE TERP FACTORS USING TABLE-OF-CONTENT INFORMATION.
+*----
+ 260 CONTINUE
+ MIXC(NTOT)=IBMOLD
+ IF(IBMOLD.GT.NMIL)
+ 1 CALL XABORT('NCRRGR: MIX OVERFLOW (COMPO).')
+ IF(IMPY.GT.2) WRITE(6,'(32H NCRRGR: COMPUTE TERP FACTORS IN,
+ 1 12H NEW MIXTURE,I5,1H.)') NTOT
+ NISO(NTOT)=NISOMI
+ LISO(NTOT)=LISOMI
+ LDELTA(NTOT)=LDELT1
+ DO ISO=1,NISOMI
+ HISO(1,NTOT,ISO)=HISOMI(1,ISO)
+ HISO(2,NTOT,ISO)=HISOMI(2,ISO)
+ CONC(NTOT,ISO)=CONCMI(ISO)
+ ENDDO
+ DO JPAR=1,NPAR+NLOC
+ MUPLT2(JPAR)=MUPLET(JPAR)
+ ENDDO
+ IF(IBTYP.EQ.3)THEN
+ IF(ZONEDP(ICH,JB).NE.0) THEN
+ CALL NCRTRP(IPCPO,LCUB2,IMPY,IBMOLD,NPAR,NLOC,NCAL,
+ 1 MUPLT2,MUTYPE,VALR(1,1),VARVAL,TERP(1,NTOT))
+ ELSE
+ TERP(:NCAL,NTOT)=0.0
+ ENDIF
+ ELSE
+ CALL NCRTRP(IPCPO,LCUB2,IMPY,IBMOLD,NPAR,NLOC,NCAL,
+ 1 MUPLT2,MUTYPE,VALR(1,1),VARVAL,TERP(1,NTOT))
+ ENDIF
+* DELTA-ADD
+ DO 270 IPAR=1,NPAR+NLOC
+ IF(LADD(IPAR))THEN
+ DO N=1,NDLTA(IPAR)
+ IDLTA1=IDLTA(IPAR,N)
+ DO JPAR=1,NPAR+NLOC
+ MUPLT2(JPAR)=MAPLET(JPAR,IDLTA1)
+ MUTYP2(JPAR)=MATYPE(JPAR,IDLTA1)
+ ENDDO
+ DO JPAR=1,NPAR+NLOC
+ IF(MUTYP2(JPAR).LT.0)THEN
+ MUPLT2(JPAR)=MUPLET(JPAR)
+ MUTYP2(JPAR)=MUTYPE(JPAR)
+ VALRA(JPAR,1,IDLTA1)=VALR(JPAR,1)
+ VALRA(JPAR,2,IDLTA1)=VALR(JPAR,2)
+ ENDIF
+ ENDDO
+ ALLOCATE(TERPA(NCAL))
+ CALL NCRTRP(IPCPO,LCUB2,IMPY,IBMOLD,NPAR,NLOC,NCAL,
+ 1 MUPLT2,MUTYP2,VALRA(1,1,IDLTA1),VARVAL,TERPA(1))
+ DO 275 JCAL=1,NCAL
+ TERP(JCAL,NTOT)=TERP(JCAL,NTOT)+TERPA(JCAL)
+ 275 CONTINUE
+ DEALLOCATE(TERPA)
+ ENDDO
+ ENDIF
+ 270 CONTINUE
+ ENDIF
+* ASBLY: next mixture
+ 285 CONTINUE
+* ASBLY: end
+ 280 CONTINUE
+ 281 CONTINUE
+ IF(NTOT.GT.NMIX) CALL XABORT('NCRRGR: ALGORITHM FAILURE.')
+ IBM=0
+ IBMB=0
+ IBME=0
+ ELSEIF((TEXT12.EQ.'COMPO').OR.(TEXT12.EQ.'TABLE').OR.
+ 1 (TEXT12.EQ.';')) THEN
+*----
+* CHECK TERP FACTORS AND RETURN
+*----
+ IF(TEXT12.EQ.';') ITER=0
+ IF(TEXT12.EQ.'COMPO') ITER=1
+ IF(TEXT12.EQ.'TABLE') ITER=2
+ DO 300 IBM=1,NMIX
+ IBMOLD=MIXC(IBM)
+ IF(IBMOLD.EQ.0) GO TO 300
+ IF(NISO(IBM).GT.MAXNIS) CALL XABORT('NCRRGR: MAXNIS OVERFLOW.')
+ IF(LDELTA(IBM)) THEN
+ SUM=0.0
+ ELSE
+ SUM=1.0
+ ENDIF
+ DO 290 ICAL=1,NCAL
+ SUM=SUM-TERP(ICAL,IBM)
+ 290 CONTINUE
+ IF(ABS(SUM).GT.1.0E-4) THEN
+ WRITE(HSMG,'(43HNCRRGR: INVALID INTERPOLATION FACTORS IN MI,
+ 1 5HXTURE,I4,1H.)') IBM
+ CALL XABORT(HSMG)
+ ENDIF
+ 300 CONTINUE
+*----
+* EXIT MAIN LOOP OF THE SUBROUTINE
+*----
+ GO TO 310
+ ELSE
+ CALL XABORT('NCRRGR: '//TEXT12//' IS AN INVALID KEYWORD.')
+ ENDIF
+ GOTO 20
+*----
+* PRINT INTERPOLATION (TERP) FACTORS
+*----
+ 310 IF(IMPX.GT.2) THEN
+ WRITE(IOUT,'(/30H NCRRGR: INTERPOLATION FACTORS)')
+ DO ICAL=1,NCAL
+ DO IBM=1,NMIX
+ IF(TERP(ICAL,IBM).NE.0.0) THEN
+ WRITE(IOUT,320) ICAL,(TERP(ICAL,JBM),JBM=1,NMIX)
+ EXIT
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDIF
+*----
+* SCRATCH STORAGE DEALLOCATION
+*----
+ DEALLOCATE(HPAR,LDELTA,WPAR,BRN1,BRN0,ZONEC,ZONEDP,FMIX,LPARM)
+ IF(LASBLY) DEALLOCATE(MIXA)
+ RETURN
+ 320 FORMAT(6H CALC=,I8,6H TERP=,1P,8E13.5/(20X,8E13.5))
+ END
generated by cgit v1.2.3 (git 2.46.0) at 2026-02-16 13:03:00 +0000