From 7dfcc480ba1e19bd3232349fc733caef94034292 Mon Sep 17 00:00:00 2001 From: stainer_t Date: Mon, 8 Sep 2025 13:48:49 +0200 Subject: Initial commit from Polytechnique Montreal --- Donjon/src/NCRRGR.f | 1027 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 1027 insertions(+) create mode 100644 Donjon/src/NCRRGR.f (limited to 'Donjon/src/NCRRGR.f') 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 -- cgit v1.2.3