*DECK AFMDRV SUBROUTINE AFMDRV (KENTRY,NENTRY,NPARM,ITYPE,NBURN,NGRP,NISO,ISC, 1 MNPS,NL,ILEAK,NTYP,NBCH,NCCO,NCZO,NUT,CTITRE,LMCR,IXYZ,MMIX,MSFT, 2 NISM) * *----------------------------------------------------------------------- * *Purpose: * Driver to generate a macrolib using fbm * *Copyright: * Copyright (C) 2002 Ecole Polytechnique de Montreal * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2.1 of the License, or (at your option) any later version * *Author(s): * M.T. Sissaoui * *Update(s): * E. Varin 28/03/00, B. Dionne 26/02/01, * A. Lagarrigue 30/07/05 * A. Hebert 11/11/11 (remove table support) * *Parameters: input * KENTRY address of the LCM objects * NENTRY number of LCM objects * NPARM number of parameters in L_MAP object * ITYPE creation/modification flag for output macrolib * NBURN number of burnup steps * NGRP 1+number of energy groups * NISO number of extracted isotopes * ISC type of cross-section calculation (=1: time average; * =2: instantaneous; =3: homogeneous) * MNPS number of shifts + 2 * NL number of legendre orders (=1 for isotropic scattering) * ILEAK type of leakage * NTYP * NBCH number of bundles per channel * NCCO number of channels in the core * NCZO number of combustion zones * NUT number of fuel types * CTITRE character*72 title * LMCR if true, create a macrolib containing only one non-zero * mixture * IXYZ type of diffusion coefficient (=0: isotropic; =1: directional) * MMIX number of mixtures in the output macrolib * MSFT second dimension of BSFT and PSFT * NISM * *----------------------------------------------------------------------- * USE GANLIB *---- * SUBROUTINE ARGUMENTS *---- TYPE(C_PTR) KENTRY(NENTRY) INTEGER NPARM,ITYPE,NBURN,NGRP,NISO,ISC,MNPS,NL,ILEAK,NTYP,NBCH, 1 NCCO,NCZO,NUT,IXYZ,MMIX,MSFT,NISM CHARACTER*72 CTITRE LOGICAL LMCR *---- * LOCAL VARIABLES *---- CHARACTER TEXTR*12,CM*2,TEXT4*5,HMICRO*12,TEXTB*12,TEXTD*12 TYPE(C_PTR) IPMACX,JPMAC,KPMAC,IPFBM,IPMAP,JPMAP,KPMAP DOUBLE PRECISION DFLOTT,XCOF(3) REAL STORE,RLOC(7) LOGICAL LNOMP,LTAV,LXENON,LSAM,LNEP,LXEREF,LNEREF,LTFUEL,LDRAH, 1 LTCOOL,LDCOOL,LPWF,LINI CHARACTER PNAME*12,PARKEY*12 INTEGER, DIMENSION(:), ALLOCATABLE :: IPOS,IJ,IZONE,IWORK,NJ, 1 HISO,JTAB,INDEX,KTYP,ISFT,ITEXTR INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: IJJ,NJJ REAL, DIMENSION(:), ALLOCATABLE :: VOL,ENER,WORK,BURBG,BURED, 1 POWER,PW,BRH,XSIGF,XSIGX,XFLUN,PDCOOL,PTCOOL,PTFUEL,SSCAT REAL, DIMENSION(:,:), ALLOCATABLE :: XBURN,OVERV,SIGS,FLUX,CHI, 1 DIFFX,DIFFY,DIFFZ,FLUAV,BFLUX,BSFT,PSFT REAL, DIMENSION(:,:,:), ALLOCATABLE :: SIGMA,SIGAV,DENSITB,HXEN1, 1 HXEN2,HSAM1,HSAM2,HNEP1,HNEP2,CPW1B,CPW2B,FLUXB,CHIB,OVERVB REAL, DIMENSION(:,:,:,:), ALLOCATABLE :: SCAT,SCATAV REAL, DIMENSION(:,:,:,:,:), ALLOCATABLE :: SMACB,XBORB,XXENB, 1 XT1FB,XT2FB,XT1CB,XT2CB,XT1MB,XT2MB,XD1CB,XD2CB,XD1MB,XD2MB, 2 XSMB,XNP9B,XMFDB,XMMDB,XPF1B,XPF2B,XPF1LB,XPF2LB,XPURB DOUBLE PRECISION XDRCST,EVJ *---- * SCRATCH STORAGE ALLOCATION *---- ALLOCATE(SIGMA(MMIX,NGRP,NTYP),IJJ(MMIX,NL,NGRP),VOL(MMIX), 1 NJJ(MMIX,NL,NGRP),XBURN(NBURN,NUT),OVERV(MMIX,NGRP), 2 SIGS(MMIX,NGRP),FLUX(MMIX,NGRP),CHI(MMIX,NGRP),ENER(NGRP+1), 3 IPOS(MMIX),SCAT(MMIX,NL,NGRP,NGRP),DIFFX(MMIX,NGRP), 4 DIFFY(MMIX,NGRP),DIFFZ(MMIX,NGRP),IJ(NGRP),WORK(MMIX*NGRP*NBURN), 5 IZONE(NCCO),BURBG(MMIX),BURED(MMIX),POWER(MMIX), 6 FLUAV(NBURN,NGRP),SIGAV(NBURN,NGRP,NTYP),IWORK(MMIX*NGRP), 7 SCATAV(NBURN,NL,NGRP,NGRP),PW(MNPS),BRH(MNPS),NJ(NGRP), 8 BFLUX(NGRP,MMIX),DENSITB(NISO,NBURN,NUT),HISO(3*NISM), 9 HXEN1(2,NBURN,NUT),HXEN2(2,NBURN,NUT),HSAM1(2,NBURN,NUT), 1 HSAM2(2,NBURN,NUT),HNEP1(2,NBURN,NUT),HNEP2(2,NBURN,NUT), 2 CPW1B(2,NBURN,NUT),CPW2B(2,NBURN,NUT),FLUXB(NGRP,NBURN,NUT), 3 JTAB(NISO),CHIB(NGRP,NBURN,NUT),OVERVB(NGRP,NBURN,NUT), 4 INDEX(MMIX),KTYP(NUT),XSIGF(NGRP),XSIGX(NGRP),XFLUN(NGRP), 5 BSFT(MMIX,MSFT),PSFT(MMIX,MSFT),ISFT(MMIX),PDCOOL(MMIX), 6 PTCOOL(MMIX),PTFUEL(MMIX),ITEXTR(3*NUT)) ALLOCATE(SMACB(NGRP*NGRP,NTYP,NISO,NBURN,NUT), 1 XBORB(NGRP*NGRP,NTYP,NISO,NBURN,NUT), 2 XXENB(NGRP*NGRP,NTYP,NISO,NBURN,NUT), 3 XT1FB(NGRP*NGRP,NTYP,NISO,NBURN,NUT), 4 XT2FB(NGRP*NGRP,NTYP,NISO,NBURN,NUT), 5 XT1CB(NGRP*NGRP,NTYP,NISO,NBURN,NUT), 6 XT2CB(NGRP*NGRP,NTYP,NISO,NBURN,NUT), 7 XT1MB(NGRP*NGRP,NTYP,NISO,NBURN,NUT), 8 XT2MB(NGRP*NGRP,NTYP,NISO,NBURN,NUT), 9 XD1CB(NGRP*NGRP,NTYP,NISO,NBURN,NUT), 1 XD2CB(NGRP*NGRP,NTYP,NISO,NBURN,NUT), 2 XD1MB(NGRP*NGRP,NTYP,NISO,NBURN,NUT), 3 XD2MB(NGRP*NGRP,NTYP,NISO,NBURN,NUT), 4 XSMB(NGRP*NGRP,NTYP,NISO,NBURN,NUT), 5 XNP9B(NGRP*NGRP,NTYP,NISO,NBURN,NUT), 6 XMFDB(NGRP*NGRP,NTYP,NISO,NBURN,NUT), 7 XMMDB(NGRP*NGRP,NTYP,NISO,NBURN,NUT), 8 XPF1B(NGRP*NGRP,NTYP,NISO,NBURN,NUT), 9 XPF2B(NGRP*NGRP,NTYP,NISO,NBURN,NUT), 1 XPF1LB(NGRP*NGRP,NTYP,NISO,NBURN,NUT), 2 XPF2LB(NGRP*NGRP,NTYP,NISO,NBURN,NUT), 3 XPURB(NGRP*NGRP,NTYP,NISO,NBURN,NUT)) * EVJ=XDRCST('eV','J') IPMACX=KENTRY(1) IPFBM=KENTRY(2) IF( .NOT.LMCR )IPMAP=KENTRY(3) CALL LCMLIB(IPMAP) *---------------------------------------------------------------* * SET THE DEFAULT OPTIONS LNOMP=.FALSE. LTAV=.FALSE. LXENON=.FALSE. LSAM=.FALSE. LNEP=.FALSE. LXEREF=.FALSE. LNEREF=.FALSE. LTFUEL=.FALSE. LDRAH =.FALSE. LTCOOL=.FALSE. LDCOOL=.FALSE. LPWF=.TRUE. ILBFLU=0 IMPX=0 IXENO=0 ISAMA=0 INEPT=0 IPROF2=0 LINI=.FALSE. ILEAK=0 PWREF=0.0 DMR=0.0 DCR=0.0 NTM=0 * Set burnup interpolation method * (default 0 for lagrangian interpolation) * (1 for linear) ILIN=0 * SET HERMITE INTERPOLATION FOR TIME-AVERAGE CALCULATION ITM=3 *---------------------------------------------------------------* * MX IS THE MAXIMUN MIXTURE NUMBER MX=NBCH*NCCO *---------------------------------------------------------------* * CHECK THE PARAMETERS IF(MX.EQ.0) CALL XABORT('AFMDRV: ZERO NUMBER OF MIXTURES.') IF(NGRP.EQ.0) CALL XABORT('AFMDRV: ZERO NUMBER OF GROUPS.') IF(NBURN.EQ.0) CALL XABORT('AFMDRV: ZERO NUMBER OF BURNUPS.') *---------------------------------------------------------------* * INITIALISATION OF THE MATRICES NG2=NGRP*NGRP DO 50 IGR=1,NG2 DO 40 IN=1,NUT DO 30 I=1,NBURN DO 20 ITY=1,NTYP DO 10 ISO=1,NISO XBORB(IGR,ITY,ISO,I,IN)=0.0 XPURB(IGR,ITY,ISO,I,IN)=0.0 XXENB(IGR,ITY,ISO,I,IN)=0.0 XT1FB(IGR,ITY,ISO,I,IN)=0.0 XT2FB(IGR,ITY,ISO,I,IN)=0.0 XT1CB(IGR,ITY,ISO,I,IN)=0.0 XT2CB(IGR,ITY,ISO,I,IN)=0.0 XT1MB(IGR,ITY,ISO,I,IN)=0.0 XT2MB(IGR,ITY,ISO,I,IN)=0.0 XD1CB(IGR,ITY,ISO,I,IN)=0.0 XD2CB(IGR,ITY,ISO,I,IN)=0.0 XD1MB(IGR,ITY,ISO,I,IN)=0.0 XD2MB(IGR,ITY,ISO,I,IN)=0.0 XSMB(IGR,ITY,ISO,I,IN)=0.0 XNP9B(IGR,ITY,ISO,I,IN)=0.0 XMFDB(IGR,ITY,ISO,I,IN)=0.0 XMMDB(IGR,ITY,ISO,I,IN)=0.0 XPF1B(IGR,ITY,ISO,I,IN)=0.0 XPF2B(IGR,ITY,ISO,I,IN)=0.0 XPF1LB(IGR,ITY,ISO,I,IN)=0.0 XPF2LB(IGR,ITY,ISO,I,IN)=0.0 SMACB(IGR,ITY,ISO,I,IN)=0.0 10 CONTINUE 20 CONTINUE 30 CONTINUE 40 CONTINUE 50 CONTINUE * DO 100 IGR=1,NGRP DO 90 IMX=1,MX DIFFX(IMX,IGR)=0.0 DIFFY(IMX,IGR)=0.0 DIFFZ(IMX,IGR)=0.0 FLUX(IMX,IGR)=0.0 OVERV(IMX,IGR)=0.0 CHI(IMX,IGR)=0.0 DO 70 IL=1,NL DO 60 JGR=1,NGRP SCAT(IMX,IL,IGR,JGR)=0.0 60 CONTINUE IJJ(IMX,IL,IGR)=IGR NJJ(IMX,IL,IGR)=1 70 CONTINUE DO 80 ITYP=1,NTYP SIGMA(IMX,IGR,ITYP)=0.0 80 CONTINUE 90 CONTINUE 100 CONTINUE C DO 150 IBR=1,NBURN DO 140 IGR=1,NGRP FLUAV(IBR,IGR)=0.0 DO 110 ITYP=1,NTYP SIGAV(IBR,IGR,ITYP)=0.0 110 CONTINUE DO 130 JGR=1,NGRP DO 120 IL=1,NL SCATAV(IBR,IL,IGR,JGR)=0.0 120 CONTINUE 130 CONTINUE 140 CONTINUE 150 CONTINUE * INITIALISATION OF THE HISTORY COEFFICIENT DO 180 IBR=1,NBURN DO 170 IN=1,NUT DO 160 I=1,2 CPW1B(I,IBR,IN)=0.0 CPW2B(I,IBR,IN)=0.0 HXEN1(I,IBR,IN)=0.0 HXEN2(I,IBR,IN)=0.0 HSAM1(I,IBR,IN)=0.0 HSAM2(I,IBR,IN)=0.0 HNEP1(I,IBR,IN)=0.0 HNEP2(I,IBR,IN)=0.0 160 CONTINUE 170 CONTINUE 180 CONTINUE *---------------------------------------------------------------* * READ AN OPTION KEY WORD 185 CALL REDGET (INDIC,NITMA,FLOTT,TEXT4,DFLOTT) IF(INDIC.NE.3) CALL XABORT('AFMDRV: CHARACTER DATA EXPECTED.') IF(TEXT4.EQ.'EDIT') THEN * READ THE PRINT INDEX. CALL REDGET(INDIC,IMPX,FLOTT,TEXT4,DFLOTT) IF(INDIC.NE.1) CALL XABORT('AFMDRV: INTEGER DATA EXPECTED.') ELSE IF(TEXT4.EQ.'REFT') THEN DO 190 IN=1,NUT CALL REDGET(INDIC,KTYP(IN),FLOTT,TEXT4,DFLOTT) IF(INDIC.NE.1) CALL XABORT('AFMDRV: INTEGER DATA EXPECTED.') CALL REDGET (INDIC,NITMA,FLOTT,TEXTR,DFLOTT) IF(INDIC.NE.3) 1 CALL XABORT('AFMDRV: CHARACTER DATA EXPECTED.') READ(TEXTR,'(3A4)') (ITEXTR((IN-1)*3+I),I=1,3) 190 CONTINUE IF(LMCR .AND. KTYP(1).GT.MX) + CALL XABORT('AFMDRV: INVALID INDEX NUMBER.') C * CHECK THE NAME OF THE DIRECTORY WRITE(TEXTR,'(3A4)') (ITEXTR(I1),I1=1,3) CALL LCMLEN(IPFBM,TEXTR,ILENGT,ITYLCM) IF(ILENGT.EQ.0) THEN CALL XABORT('AFMDRV: UNABLE TO FIND '//TEXTR//' .') ENDIF * RECOVER THE REFERENCE LOCAL PARAMETERS VALUES CALL LCMSIX(IPFBM,TEXTR,1) CALL LCMSIX(IPFBM,'INFO-NOMINA',1) CALL LCMLEN(IPFBM,'NOMINALP',ILP,ITYLCM) IF(ILP.GT.0) THEN CALL LCMGET(IPFBM,'NOMINALP',RLOC) CALL LCMGET(IPFBM,'NOMINALN',HISO) DO 200 I=1,ILP WRITE(HMICRO,'(3A4)') (HISO((I-1)*3+IH),IH=1,3) IF(HMICRO.EQ.'PW') PWREF=RLOC(I) IF(HMICRO.EQ.'TCOOL') TCR=RLOC(I) IF(HMICRO.EQ.'TMOD') TMR=RLOC(I) IF(HMICRO.EQ.'TFUEL') TFR=RLOC(I) IF(HMICRO.EQ.'RHOC') DCR=RLOC(I) IF(HMICRO.EQ.'RHOM') DMR=RLOC(I) IF(HMICRO.EQ.'PUR') XIR=RLOC(I) 200 CONTINUE ENDIF CALL LCMSIX(IPFBM,' ',2) CALL LCMSIX(IPFBM,' ',2) * REFERENCE PARAMETER VALUES PFIX=PWREF AW=15.9994 +2*(1-XIR)*1.0079 +2*XIR*2.014101 PH=2*1.0079/AW PD=2*2.014101/AW * INITIALISATION OF PERTURBED PARAMETER TF=TFR TC=TCR TM=TMR DC=1.0 DM=1.0 XI=XIR BOR=0.0 SM=0.0 RNP9=0.0 XEN=0.0 * DO 210 IMX=1,MX POWER(IMX)=PWREF ISFT(IMX)=0 BURBG(IMX)=0.0 BURED(IMX)=0.0 VOL(IMX)=0.0 PDCOOL(IMX)=DCR PTCOOL(IMX)=TCR PTFUEL(IMX)=TFR 210 CONTINUE * RECOVER THE TEMERATURE AND DENSITY PROFILES IF( (.NOT.LMCR).AND.(NPARM.GT.0) ) THEN JPMAP=LCMGID(IPMAP,'PARAM') DO 220 IPARM=1,NPARM KPMAP=LCMGIL(JPMAP,IPARM) CALL LCMGTC(KPMAP,'P-NAME',12,PNAME) CALL LCMGTC(KPMAP,'PARKEY',12,PARKEY) CALL LCMGET(KPMAP,'P-TYPE',IPTYPE) IF(IPTYPE.EQ.1) THEN CALL LCMGET(KPMAP,'P-VALUE',FLOTT) ELSE IF(IPTYPE.EQ.2) THEN CALL LCMLEN(KPMAP,'P-VALUE',NITMA,ITYLCM) IF(NITMA.NE.MX) CALL XABORT('@AFMDRV: INVALID LENGTH FO' 1 //'R P-VALUE.') ENDIF IF(PNAME.EQ.'T-COOL') THEN WRITE(6,716) PNAME,PARKEY IF(IPTYPE.EQ.1) THEN PTCOOL(:MX)=FLOTT ELSE IF(IPTYPE.EQ.2) THEN CALL LCMGET(KPMAP,'P-VALUE',PTCOOL) ENDIF ELSE IF(PNAME.EQ.'D-COOL') THEN WRITE(6,716) PNAME,PARKEY IF(IPTYPE.EQ.1) THEN PDCOOL(:MX)=FLOTT ELSE IF(IPTYPE.EQ.2) THEN CALL LCMGET(KPMAP,'P-VALUE',PDCOOL) ENDIF ELSE IF(PNAME.EQ.'T-FUEL') THEN WRITE(6,716) PNAME,PARKEY IF(IPTYPE.EQ.1) THEN PTFUEL(:MX)=FLOTT ELSE IF(IPTYPE.EQ.2) THEN CALL LCMGET(KPMAP,'P-VALUE',PTFUEL) ENDIF ENDIF 220 CONTINUE ENDIF * PW(:MNPS)=PWREF BRH(:MNPS)=0.0 POWER(:MX)=PWREF * ELSE IF(TEXT4.EQ.'TFUEL') THEN CALL REDGET (INDIC,NITMA,TFU,TEXT4,DFLOTT) LTFUEL = .TRUE. IF(INDIC.NE.2) CALL XABORT('AFMDRV: REAL DATA EXPECTED.') * ELSE IF(TEXT4.EQ.'TCOOL') THEN CALL REDGET (INDIC,NITMA,TCU,TEXT4,DFLOTT) IF(INDIC.NE.2) CALL XABORT('AFMDRV: REAL DATA EXPECTED.') LTCOOL = .TRUE. PTCOOL(:MX)=TCU * ELSE IF(TEXT4.EQ.'TMOD') THEN CALL REDGET (INDIC,NITMA,TM,TEXT4,DFLOTT) IF(INDIC.NE.2) CALL XABORT('AFMDRV: REAL DATA EXPECTED.') * ELSE IF(TEXT4.EQ.'RDCL') THEN CALL REDGET (INDIC,NITMA,DCU,TEXT4,DFLOTT) IF(INDIC.NE.2) CALL XABORT('AFMDRV: REAL DATA EXPECTED.') LDCOOL = .TRUE. PDCOOL(:MX)=DCU * ELSE IF(TEXT4.EQ.'RDMD') THEN CALL REDGET (INDIC,NITMA,DM,TEXT4,DFLOTT) IF(INDIC.NE.2) CALL XABORT('AFMDRV: REAL DATA EXPECTED.') DM=DM/DMR * ELSE IF(TEXT4.EQ.'BORON') THEN CALL REDGET (INDIC,NITMA,BOR,TEXT4,DFLOTT) IF(INDIC.NE.2) CALL XABORT('AFMDRV: REAL DATA EXPECTED.') * * ppm eq 10**-6, NO CONSISTENCY WITH CFC CONCENTRATIONS * NEED TO ADD A COEFFICIENT TO FIT THE DATA (BREF should be 0.0ppm) * BOR=BOR*1.E-6 * ELSE IF(TEXT4.EQ.'PUR') THEN CALL REDGET (INDIC,NITMA,XI,TEXT4,DFLOTT) IF(INDIC.NE.2) CALL XABORT('AFMDRV: REAL DATA EXPECTED.') XI=XI*1.0E-02 * ELSE IF(TEXT4.EQ.'FIXP') THEN CALL REDGET (INDIC,NITMA,PFIX,TEXT4,DFLOTT) IF(INDIC.EQ.2) THEN LNOMP=.TRUE. ELSE IF(TEXT4.EQ.'INIT') THEN LINI=.TRUE. ELSE CALL XABORT('AFMDRV: "INIT" or REAL DATA EXPECTED.') ENDIF * ELSE IF(TEXT4.EQ.'IMET') THEN CALL REDGET(INDIC,ITM,FLOTT,TEXT4,DFLOTT) IF(INDIC.NE.1) CALL XABORT('AFMDRV: INTEGER DATA EXPECTED.') * ELSE IF(TEXT4.EQ.'XENON') THEN LXENON=.TRUE. CALL REDGET (INDIC,NITMA,FXEN,TEXT4,DFLOTT) IF(INDIC.NE.2) CALL XABORT('AFMDRV: REAL DATA EXPECTED.') * ELSE IF(TEXT4.EQ.'XEREF') THEN LXEREF=.TRUE. * ELSE IF(TEXT4.EQ.'DRAH') THEN LDRAH=.TRUE. * ELSE IF(TEXT4.EQ.'SAM') THEN LSAM=.TRUE. CALL REDGET (INDIC,NITMA,FSAM,TEXT4,DFLOTT) IF(INDIC.NE.2) CALL XABORT('AFMDRV: REAL DATA EXPECTED.') * ELSE IF(TEXT4.EQ.'NEP') THEN LNEP=.TRUE. CALL REDGET (INDIC,NITMA,FNEP,TEXT4,DFLOTT) IF(INDIC.NE.2) CALL XABORT('AFMDRV: REAL DATA EXPECTED.') * ELSE IF(TEXT4.EQ.'NREF') THEN LNEREF=.TRUE. * ELSE IF(TEXT4.EQ.'BURN') THEN IF(LMCR) THEN CALL REDGET (INDIC,NITMA,FBUR,TEXT4,DFLOTT) IF(INDIC.NE.2) CALL XABORT('AFMDRV: REAL DATA EXPECTED.') ELSE CALL XABORT('AFMDRV: INVALID KEYWORD BURN.') ENDIF * ELSE IF(TEXT4.EQ.'NPWF') THEN LPWF=.FALSE. ELSE IF(TEXT4.EQ.'PWF') THEN LPWF=.TRUE. ELSE IF(TEXT4.EQ.'BLIN') THEN ILIN=1 ELSE IF(TEXT4.EQ.';') THEN GO TO 230 ELSE CALL XABORT('AFMDRV: '//TEXT4//' IS AN INVALID KEY-WORD.') ENDIF GO TO 185 * EQUIVALENT MODERATOR DENSITY FOR THE REFERENCE PURITY 230 DXI = XI - XIR * pas de modification de densite selon la purete D2O * DM=DM/(1.0+DXI*(PD-PH)) *---------------------------------------------------------------* * RECOVER NEUTRONICS PARAMETRES WRITE(TEXTR,'(3A4)') (ITEXTR(I1),I1=1,3) CALL LCMSIX(IPFBM,TEXTR,1) CALL LCMGET(IPFBM,'VOLUME',VOL(1)) CALL LCMGET(IPFBM,'ENERGY',ENER) CALL LCMGET(IPFBM,'HITAB',HISO) CALL LCMGET(IPFBM,'JTAB',JTAB) CALL LCMSIX(IPFBM,' ',2) DO 280 IN=1,NUT WRITE(TEXTR,'(3A4)') (ITEXTR((IN-1)*3+I1),I1=1,3) CALL LCMSIX(IPFBM,TEXTR,1) CALL LCMGET(IPFBM,'BURNUP',XBURN(1,IN)) * RECOVER THE EXISTING DATABASE. * RECOVER THE HISTORY COEFFICIENTS DO 270 I = 1,NBURN WRITE(TEXTB,'(4HBURN,4X,I4)') I CALL LCMSIX(IPFBM,TEXTB,1) * IF(JTAB(1).EQ.1) THEN CALL LCMSIX(IPFBM,'HISTORY',1) CALL LCMGET(IPFBM,'PHIL1',CPW1B(1,I,IN)) CALL LCMGET(IPFBM,'PHIS1',CPW1B(2,I,IN)) CALL LCMGET(IPFBM,'PHIL2',CPW2B(1,I,IN)) CALL LCMGET(IPFBM,'PHIS2',CPW2B(2,I,IN)) CALL LCMLEN(IPFBM,'PHISX1',IHISTO,ITYLCM) IF(IHISTO.GT.0) THEN CALL LCMGET(IPFBM,'PHILX1',HXEN1(1,I,IN)) CALL LCMGET(IPFBM,'PHISX1',HXEN1(2,I,IN)) CALL LCMGET(IPFBM,'PHILX2',HXEN2(1,I,IN)) CALL LCMGET(IPFBM,'PHISX2',HXEN2(2,I,IN)) C CALL LCMGET(IPFBM,'PHILS1',HSAM1(1,I,IN)) CALL LCMGET(IPFBM,'PHISS1',HSAM1(2,I,IN)) CALL LCMGET(IPFBM,'PHILS2',HSAM2(1,I,IN)) CALL LCMGET(IPFBM,'PHISS2',HSAM2(2,I,IN)) C CALL LCMGET(IPFBM,'PHILN1',HNEP1(1,I,IN)) CALL LCMGET(IPFBM,'PHISN1',HNEP1(2,I,IN)) CALL LCMGET(IPFBM,'PHILN2',HNEP2(1,I,IN)) CALL LCMGET(IPFBM,'PHISN2',HNEP2(2,I,IN)) ENDIF CALL LCMSIX(IPFBM,' ',2) ENDIF * CALL LCMGET(IPFBM,'FLUX-INTG',FLUXB(1,I,IN)) CALL LCMGET(IPFBM,'OVERV',OVERVB(1,I,IN)) CALL LCMGET(IPFBM,'ISOTOPESDENS',DENSITB(1,I,IN)) * COMPUTE DELTA-CONCENTRATION DO 250 ISO=1,NISO WRITE(HMICRO,'(3A4)') (HISO((ISO-1)*3+IH),IH=1,3) CALL LCMSIX(IPFBM,HMICRO,1) IF(JTAB(1).EQ.1) THEN IF((HMICRO.EQ.'XE135').OR.(HMICRO.EQ.'Xe135')) IXENO=ISO IF((HMICRO.EQ.'SM149').OR.(HMICRO.EQ.'Sm149')) ISAMA=ISO IF((HMICRO.EQ.'NP239').OR.(HMICRO.EQ.'Np239')) INEPT=ISO IF(HMICRO.EQ.'MACR ') 1 CALL LCMGET(IPFBM,'CHI',CHIB(1,I,IN)) ENDIF * RECOVER MACROSCOPIC X-SECTIONS NTM=4+2*IXYZ DO 240 ITY=1,NTM IF(ITY.EQ.1) THEN IF(IXYZ.EQ.0) THEN TEXTD = 'STRD' ELSE IF(IXYZ.EQ.1) THEN TEXTD = 'STRD X' ENDIF ENDIF IF(ITY.EQ.2) TEXTD = 'ABS' IF(ITY.EQ.3) TEXTD = 'NUSIGF' IF(ITY.EQ.4) TEXTD = 'H-FACTORS' IF(ITY.EQ.5) TEXTD = 'STRD Y' IF(ITY.EQ.6) TEXTD = 'STRD Z' CALL LCMLEN(IPFBM,TEXTD,ILENG,ITYXSM) * IF(ILENG.NE.0) THEN CALL LCMSIX(IPFBM,TEXTD,1) CALL LCMGET(IPFBM,'REF',SMACB(1,ITY,ISO,I,IN)) CALL LCMGET(IPFBM,'BOR',XBORB(1,ITY,ISO,I,IN)) CALL LCMGET(IPFBM,'PUR',XPURB(1,ITY,ISO,I,IN)) CALL LCMGET(IPFBM,'T1M',XT1MB(1,ITY,ISO,I,IN)) CALL LCMGET(IPFBM,'T2M',XT2MB(1,ITY,ISO,I,IN)) CALL LCMGET(IPFBM,'D1M',XD1MB(1,ITY,ISO,I,IN)) CALL LCMGET(IPFBM,'D2M',XD2MB(1,ITY,ISO,I,IN)) IF(JTAB(1).EQ.1) THEN CALL LCMLEN(IPFBM,'XEN',ILENGX,ITYXSM) IF(ILENGX.GT.0) + CALL LCMGET(IPFBM,'XEN',XXENB(1,ITY,ISO,I,IN)) CALL LCMGET(IPFBM,'T1F',XT1FB(1,ITY,ISO,I,IN)) CALL LCMGET(IPFBM,'T2F',XT2FB(1,ITY,ISO,I,IN)) CALL LCMGET(IPFBM,'T1C',XT1CB(1,ITY,ISO,I,IN)) CALL LCMGET(IPFBM,'T2C',XT2CB(1,ITY,ISO,I,IN)) CALL LCMGET(IPFBM,'D1C',XD1CB(1,ITY,ISO,I,IN)) CALL LCMGET(IPFBM,'D2C',XD2CB(1,ITY,ISO,I,IN)) CALL LCMGET(IPFBM,'SM149',XSMB(1,ITY,ISO,I,IN)) CALL LCMGET(IPFBM,'NP239',XNP9B(1,ITY,ISO,I,IN)) CALL LCMGET(IPFBM,'MIXFD',XMFDB(1,ITY,ISO,I,IN)) CALL LCMGET(IPFBM,'MIXMD',XMMDB(1,ITY,ISO,I,IN)) CALL LCMGET(IPFBM,'FPCH1',XPF1B(1,ITY,ISO,I,IN)) CALL LCMGET(IPFBM,'FPCL1',XPF1LB(1,ITY,ISO,I,IN)) CALL LCMGET(IPFBM,'FPCH2',XPF2B(1,ITY,ISO,I,IN)) CALL LCMGET(IPFBM,'FPCL2',XPF2LB(1,ITY,ISO,I,IN)) ENDIF * CALL LCMSIX(IPFBM,' ',2) ENDIF 240 CONTINUE * CALL LCMLEN(IPFBM,'NFTOT',ILNF,ITYXSM) IF(ILNF.NE.0) THEN CALL LCMGET(IPFBM,'NFTOT',SMACB(1,NTM+1,ISO,I,IN)) ENDIF CALL LCMSIX(IPFBM,' ',2) 250 CONTINUE * SCATTERING CROSS-SECTIONS DO 260 ISO=1,NISO WRITE(HMICRO,'(3A4)') (HISO((ISO-1)*3+IH),IH=1,3) CALL LCMLEN(IPFBM,HMICRO,ILENG,ITYLCM) IF(ILENG.EQ.0) GO TO 230 CALL LCMSIX(IPFBM,HMICRO,1) C DO 150 IL=1,NL IL=1 ITY=NTM+1+IL LTST=0 WRITE (CM,'(I2.2)') IL-1 CALL LCMLEN(IPFBM,'SCAT'//CM,ILENG,ITYXSM) IF(ILENG.NE.0) THEN LTST=1 ELSE WRITE (CM,'(I2)') IL-1 CALL LCMLEN(IPFBM,'SCAT'//CM,ILENG,ITYXSM) IF(ILENG.NE.0) THEN LTST=2 ENDIF ENDIF IF (LTST.GE.1) THEN CALL LCMSIX(IPFBM,'SCAT'//CM,1) IF(HMICRO.EQ.'MACR') THEN IF (LTST.EQ.1) THEN CALL LCMGET(IPFBM,'NJJS',NJ) CALL LCMGET(IPFBM,'IJJS',IJ) ELSE CALL LCMGET(IPFBM,'NJJ',NJ) CALL LCMGET(IPFBM,'IJJ',IJ) ENDIF ENDIF CALL LCMGET(IPFBM,'REF',SMACB(1,ITY,ISO,I,IN)) CALL LCMGET(IPFBM,'BOR',XBORB(1,ITY,ISO,I,IN)) CALL LCMGET(IPFBM,'PUR',XPURB(1,ITY,ISO,I,IN)) CALL LCMGET(IPFBM,'T1M',XT1MB(1,ITY,ISO,I,IN)) CALL LCMGET(IPFBM,'T2M',XT2MB(1,ITY,ISO,I,IN)) CALL LCMGET(IPFBM,'D1M',XD1MB(1,ITY,ISO,I,IN)) CALL LCMGET(IPFBM,'D2M',XD2MB(1,ITY,ISO,I,IN)) IF(JTAB(1).EQ.1) THEN CALL LCMLEN(IPFBM,'XEN',ILENG,ITYXSM) IF(ILENG.GT.0) THEN CALL LCMGET(IPFBM,'XEN',XXENB(1,ITY,ISO,I,IN)) ENDIF CALL LCMGET(IPFBM,'T1F',XT1FB(1,ITY,ISO,I,IN)) CALL LCMGET(IPFBM,'T2F',XT2FB(1,ITY,ISO,I,IN)) CALL LCMGET(IPFBM,'T1C',XT1CB(1,ITY,ISO,I,IN)) CALL LCMGET(IPFBM,'T2C',XT2CB(1,ITY,ISO,I,IN)) CALL LCMGET(IPFBM,'D1C',XD1CB(1,ITY,ISO,I,IN)) CALL LCMGET(IPFBM,'D2C',XD2CB(1,ITY,ISO,I,IN)) * CALL LCMGET(IPFBM,'SM149',XSMB(1,ITY,ISO,I,IN)) CALL LCMGET(IPFBM,'NP239',XNP9B(1,ITY,ISO,I,IN)) CALL LCMGET(IPFBM,'MIXFD',XMFDB(1,ITY,ISO,I,IN)) CALL LCMGET(IPFBM,'MIXMD',XMMDB(1,ITY,ISO,I,IN)) CALL LCMGET(IPFBM,'FPCH1',XPF1B(1,ITY,ISO,I,IN)) CALL LCMGET(IPFBM,'FPCL1',XPF1LB(1,ITY,ISO,I,IN)) CALL LCMGET(IPFBM,'FPCH2',XPF2B(1,ITY,ISO,I,IN)) CALL LCMGET(IPFBM,'FPCL2',XPF2LB(1,ITY,ISO,I,IN)) ENDIF * CALL LCMSIX(IPFBM,' ',2) ENDIF CALL LCMSIX(IPFBM,' ',2) 260 CONTINUE C CALL LCMSIX(IPFBM,' ',2) 270 CONTINUE CALL LCMSIX(IPFBM,' ',2) 280 CONTINUE IF(JTAB(1).EQ.1) THEN IF(IXENO.EQ.0) CALL XABORT('NO XE135 FOUND ') IF(ISAMA.EQ.0) CALL XABORT('NO SM149 FOUND ') IF(INEPT.EQ.0) CALL XABORT('NO NP239 FOUND ') ENDIF * END OF THE RECOVERING PROCESS *---------------------------------------------------------------* * ISC INDICATE THE TYPE OF CROSS-SECTION CALCULATION * ISC=1 ; TIME AVERAGE CALCULATION * ISC=2 ; INSTANTANEOUS CALCULATION * ISC=3 ; HOMOGENEOUS CALCULATION *---------------------------------------------------------------* * IF(ISC.EQ.0) THEN CALL XABORT('AFMDRV: TIMAV/INSTANT BURNUP TREATMENT NOT SET') ELSE IF(ISC.EQ.1) THEN * Time-averaged calculation WRITE(6,699) MMIX=NBCH*NCCO LTAV=.TRUE. CALL LCMGET(IPMAP,'FLMIX',INDEX) CALL LCMGET(IPMAP,'BURN-BEG',BURBG) CALL LCMGET(IPMAP,'BURN-END',BURED) CALL LCMLEN(IPMAP,'BUND-PW',ILPW,ITYLCM) IF((ILPW.NE.0).AND.LPWF) THEN IF(IMPX.GE.1) WRITE(6,702) IF(.NOT.LINI) THEN CALL LCMGET(IPMAP,'BUND-PW',POWER) ELSE CALL LCMLEN(IPMAP,'BUND-PW-INI',ILPW,ITYLCM) IF(ILPW.NE.0) THEN CALL LCMGET(IPMAP,'BUND-PW-INI',POWER) ELSE CALL XABORT('AFMDRV: NO INITIAL POWER IN L_MAP') ENDIF ENDIF ELSE POWER(:MMIX)=PWREF ENDIF CALL LCMLEN(IPMAP,'FLUX-AV',ILBFLU,ITYLCM) IF(ILBFLU.NE.0) THEN IF(IMPX.GE.1) WRITE(6,703) CALL LCMGET(IPMAP,'FLUX-AV',WORK) DO 300 IGR=1,NGRP DO 290 IBF=1,MMIX IIBF=MMIX*(IGR-1)+IBF BFLUX(IGR,IBF)=WORK(IIBF) 290 CONTINUE 300 CONTINUE ENDIF ELSE IF(ISC.EQ.2) THEN * Instantaneous calculation IF(LMCR) THEN MMIX=NBCH*NCCO POWER(:MMIX)=PWREF ELSE WRITE(6,701) MMIX=NBCH*NCCO CALL LCMGET(IPMAP,'FLMIX',INDEX) CALL LCMGET(IPMAP,'BURN-INST',BURBG) CALL LCMLEN(IPMAP,'BUND-PW',ILPW,ITYLCM) IF((ILPW.NE.0).AND.LPWF) THEN IF(IMPX.GE.1) WRITE(6,702) IF(.NOT.LINI) THEN CALL LCMGET(IPMAP,'BUND-PW',POWER) ELSE CALL LCMLEN(IPMAP,'BUND-PW-INI',ILPW,ITYLCM) IF(ILPW.NE.0) THEN CALL LCMGET(IPMAP,'BUND-PW-INI',POWER) ELSE CALL XABORT('AFMDRV: NO INITIAL POWER IN L_MAP') ENDIF ENDIF ELSE POWER(:MMIX)=PWREF ENDIF CALL LCMLEN(IPMAP,'FLUX-AV',ILBFLU,ITYLCM) IF(ILBFLU.NE.0) THEN IF(IMPX.GE.1) WRITE(6,703) CALL LCMGET(IPMAP,'FLUX-AV',WORK) DO 320 IGR=1,NGRP DO 310 IBF=1,MMIX IIBF=MMIX*(IGR-1)+IBF BFLUX(IGR,IBF)=WORK(IIBF) 310 CONTINUE 320 CONTINUE ENDIF * RECOVER THE SHIFT INFORMATION IF(MNPS.GT.2) THEN IF(IMPX.GE.1) WRITE(6,704) CALL LCMGET(IPMAP,'ISHIFT',ISFT) DO 330 IS=1,MNPS-2 WRITE (CM,'(I2)') IS CALL LCMGET(IPMAP,'BSHIFT'//CM,BSFT(1,IS)) CALL LCMGET(IPMAP,'PSHIFT'//CM,PSFT(1,IS)) 330 CONTINUE ENDIF ENDIF ELSE IF(ISC.EQ.3) THEN * Homogeneous calculation MMIX=NCZO LTAV=.TRUE. CALL LCMGET(IPMAP,'B-ZONE',IZONE) CALL LCMGET(IPMAP,'FLMIX',INDEX) CALL LCMGET(IPMAP,'BURN-AVG',BURED) ENDIF *---------------------------------------------------------------* IF(IMPX.GE.1) THEN IF(LNOMP) WRITE(6,705) PFIX IF(LXENON) WRITE(6,706) FXEN IF(LSAM) WRITE(6,719) FSAM IF(LNEP) WRITE(6,711) FNEP IF(LXEREF) WRITE(6,712) IF(LNEREF) WRITE(6,713) IF(LTFUEL) WRITE(6,714) TFU IF(IHISTO.GT.0.AND.LDRAH) WRITE(6,715) IF(LTCOOL) WRITE(6,717) TCU IF(LDCOOL) WRITE(6,718) DCU ENDIF *---------------------------------------------------------------* * MIXTURE SHIFT IF(LMCR) THEN MXSH=MMIX VOL(:MMIX)=VOL(1) ELSE MXSH=1 ENDIF *---------------------------------------------------------------* * LOOP OVER THE MIXTURES DO 540 NMIX=MXSH,MMIX TC=PTCOOL(NMIX) DC=PDCOOL(NMIX)/DCR IF(LMCR) THEN NPS=2 IDF=1 ELSE VOL(NMIX)=VOL(1) NPS=ISFT(NMIX)+2 KDF=0 DO 340 IN=1,NUT IF(INDEX(NMIX).EQ.KTYP(IN)) THEN IDF=IN KDF=1 ENDIF 340 CONTINUE IF(KDF.EQ.0) CALL XABORT('AFMDRV: WRONG NUMBER OF INDEX') ENDIF * IF TIME AVERAGE CALCULATION: * EVALUATION OF THE BURNUPS STEPS EMBEDED IN THE INTEGRATION IF(LTAV) THEN XBMIN=BURBG(NMIX) XBMAX=BURED(NMIX) * TIME AVERAGE BURNUP LOCALISATION CALL AFMLOC(NBURN,NTP,XBMAX,XBMIN,XBURN(1,IDF), 1 IMAX,IMIN,XCOF,ILIN) * LAGRANGE METHOD (TIME-AVERAGE) IMINR=IMIN IMAXR=ABS(IMAX) * SPLINE OR HERMITE METHOD (TIME-AVERAGE) IF(ITM.EQ.2.OR.ITM.EQ.3) THEN IMINR=1 IMAXR=NBURN ENDIF * ELSE IMINR=1 IMAXR=1 ENDIF C DO 450 JR=IMINR,IMAXR IF(LTAV) THEN IRAV=JR NPS=2 ELSE IF(NPS.GT.2) THEN DO 350 K=2,NPS-1 IS=K-1 BRH(K)=BSFT(NMIX,IS) 350 CONTINUE ENDIF IF(LMCR) THEN BRH(NPS)=FBUR IF(JTAB(1).EQ.0) BRH(NPS)=0.0 ELSE BRH(NPS)=BURBG(NMIX) ENDIF ENDIF * IF(LNOMP) THEN DO 360 K=2,NPS PW(K)=PFIX 360 CONTINUE ELSE IF(NPS.GT.2) THEN DO 370 K=2,NPS-1 IS=K-1 PW(K)=PSFT(NMIX,IS) 370 CONTINUE ENDIF PW(NPS)=POWER(NMIX) ENDIF * D. Rozon 'Introduction a la Cinetique des Reacteur Nucleaires' * Edition E.P., 1992. (p.217) or 1998 (p.185) * PW is assumed to be in kW. IF(IPROF2.GT.0) THEN TF = PTFUEL(NMIX) ELSE TF= TC + 0.476*PW(NPS) + 2.267*PW(NPS)*PW(NPS)*1.0E-04 ENDIF C INITIAL CONCENTRATIONS ZXREF=0.0 SM=0.0 ZRNP9=0.0 * IF FUEL IF(JTAB(1).EQ.1) THEN * BURNUP LOCALISATION FOR XENON AND FISSION X-SECTION INTERPOLATION IF(LTAV) THEN XIFL=XBURN(IRAV,IDF) IMAXX=IRAV IMINX=IRAV XCOF(1)=1.0D0 XCOF(2)=0.0D0 XCOF(3)=0.0D0 ELSE XIFL=BRH(NPS) CALL AFMLOC(NBURN,NTP,BRH(NPS),BRH(NPS),XBURN(1,IDF), 1 IMAXX,IMINX,XCOF,ILIN) ENDIF * DO 380 IGR = 1,NGRP XSIGX(IGR)=0.0 XFLUN(IGR)=0.0 XSIGF(IGR)=0.0 380 CONTINUE * INTERPOLATION OF THE CONCENTRATION * IIX=0 DO 395 I = IMINX,IMAXX IIX=IIX+1 RXCOF=REAL(XCOF(IIX)) ZXREF=DENSITB(IXENO,I,IDF)*RXCOF +ZXREF XEN=ZXREF SM=DENSITB(ISAMA,I,IDF)*RXCOF +SM ZRNP9=DENSITB(INEPT,I,IDF)*RXCOF +ZRNP9 RNP9=ZRNP9 * DO 390 IGR=1,NGRP XSIGX(IGR)=SMACB(IGR,2,IXENO,I,IDF)*RXCOF 1 + XSIGX(IGR) XFLUN(IGR)=FLUXB(IGR,I,IDF)*RXCOF + XFLUN(IGR) XSIGF(IGR)=SMACB(IGR,5,1,I,IDF)*RXCOF + XSIGF(IGR) 390 CONTINUE 395 CONTINUE IF(LDRAH.AND.IHISTO.GT.0) THEN IF(PW(NPS).GT.PWREF) THEN XPW=ALOG(PW(NPS)/PW(1)) XPWM=1.0/PW(NPS)-1.0/PW(1) IFH=1 ELSE XPW=PW(NPS)-PW(1) XPWM=(PW(NPS)-PW(1))**2 IFH=2 ENDIF C XEN =ZXREF RNP9 =ZRNP9 IIX=0 DO 400 I = IMINX,IMAXX IIX=IIX+1 RXCOF=REAL(XCOF(IIX)) * COMPUTE XENON-SAMRIUM-NEPTUNIUM CONCENTRATION USING DRAGON XEN =XEN +HXEN1(IFH,I,IDF)*XPW*RXCOF+ 1 HXEN2(IFH,I,IDF)*XPWM*RXCOF SM =SM +HSAM1(IFH,I,IDF)*XPW*RXCOF+ 1 HSAM2(IFH,I,IDF)*XPWM*RXCOF RNP9 =RNP9 +HNEP1(IFH,I,IDF)*XPW*RXCOF+ 1 HNEP2(IFH,I,IDF)*XPWM*RXCOF 400 CONTINUE ELSE IF(ILBFLU.NE.0.AND.XIFL.NE.0.0) THEN * COMPUTE THE XENON AND NEPTUNIUM CONCENTRATIONS CALL AFMXNC(NGRP,XSIGX,XSIGF,BFLUX(1,NMIX), 1 XEN,RNP9,XFLUN) ENDIF * COMPUTE THE XENON AND NEPTUNIUM CONCENTRATIONS IF(LXENON) XEN=FXEN IF(LSAM) SM=FSAM IF(LNEP) RNP9=FNEP IF(LXEREF) XEN=ZXREF IF(LNEREF) RNP9=ZRNP9 IF(LTFUEL) THEN ! fuel temperature as input TF=TFU ! reference fuel temperature ELSEIF(LMCR) THEN TF=TFR ENDIF ENDIF *---------------------------------------------------------------* * XSECTION CALCULATION *---------------------------------------------------------------* CALL AFMCPT(KENTRY,NBURN,NGRP,NISO, 1 NL,IMPX,SMACB,XBORB,XPURB,XXENB,XT1FB,XT2FB,XT1CB, 1 XT2CB,XT1MB,XT2MB,XD1CB,XD2CB,XD1MB,XD2MB, 1 XSMB,XNP9B,XMFDB,XMMDB,XPF1B,XPF2B,XPF1LB,XPF2LB, 1 DENSITB,CPW1B,CPW2B,FLUXB,OVERVB,CHIB, 1 IJ,NJ,HISO,CTITRE, 1 NMIX,SIGMA,NTYP,TF,TC,TM,DC,DM,BOR,XEN,SM,RNP9,XI, 1 TFR,TCR,TMR,XIR,OVERV,FLUX,CHI,SCAT,MX,NPS,PW,BRH, 1 XBURN,LTAV,IRAV,IDF,JTAB,IXYZ,ILIN) *---------------------------------------------------------------* * DO 420 IGR=1,NGRP FLUAV(JR,IGR)=FLUX(NMIX,IGR) DO 410 ITY=1,NTM+1 SIGAV(JR,IGR,ITY)=SIGMA(NMIX,IGR,ITY) 410 CONTINUE 420 CONTINUE IL =1 DO 440 IGR=1,NGRP DO 430 JGR=1,NGRP SCATAV(JR,IL,JGR,IGR)=SCAT(NMIX,IL,JGR,IGR) 430 CONTINUE 440 CONTINUE 450 CONTINUE IF(LTAV) THEN * COMPUTE TIME AVERAGED X-SECTIONS DO 470 IGR=1,NGRP CALL AFMTAV(NBURN,ITM,XBMAX,XBMIN,FLUAV(1,IGR),IMIN,IMAX, 1 XBURN,FLUX(NMIX,IGR)) DO 460 ITY=1,NTM+1 CALL AFMTAV(NBURN,ITM,XBMAX,XBMIN,SIGAV(1,IGR,ITY),IMIN, 1 IMAX,XBURN,SIGMA(NMIX,IGR,ITY)) 460 CONTINUE 470 CONTINUE * DO 490 IGR=1,NGRP DO 480 JGR=1,NGRP IL=1 CALL AFMTAV(NBURN,ITM,XBMAX,XBMIN,SCATAV(1,IL,IGR,JGR), 1 IMIN,IMAX,XBURN,SCAT(NMIX,IL,IGR,JGR)) 480 CONTINUE 490 CONTINUE * ENDIF * COMPUTE DIRECTIONAL DIFFUSION COEFFICIENTS FROM STRD * X-SECTIONS. IF(IXYZ.EQ.0) THEN DO 500 IGR=1,NGRP DIFFX(NMIX,IGR)=1.0/(3.0*SIGMA(NMIX,IGR,1)) 500 CONTINUE ILEAK=1 ELSE IF(IXYZ.EQ.1) THEN DO 510 IGR=1,NGRP DIFFX(NMIX,IGR)=1.0/(3.0*SIGMA(NMIX,IGR,1)) DIFFY(NMIX,IGR)=1.0/(3.0*SIGMA(NMIX,IGR,5)) DIFFZ(NMIX,IGR)=1.0/(3.0*SIGMA(NMIX,IGR,6)) ILEAK=2 510 CONTINUE ENDIF * IL=1 DO 530 IGR=1,NGRP NJJ(NMIX,IL,IGR)=NJ(IGR) IJJ(NMIX,IL,IGR)=IJ(IGR) IF(LMCR) THEN DO 520 NI=1,MMIX NJJ(NI,IL,IGR)=NJ(IGR) IJJ(NI,IL,IGR)=IJ(IGR) 520 CONTINUE ENDIF 530 CONTINUE * MIX LOOP 540 CONTINUE * IF(LTAV) THEN IF(IMPX.GE.1.AND.ITM.EQ.1) WRITE(6,707) IF(IMPX.GE.1.AND.ITM.EQ.2) WRITE(6,708) IF(IMPX.GE.1.AND.ITM.EQ.3) WRITE(6,709) ENDIF *---------------------------------------------------------------* * DECOMPRESS BURN ZONE FOR ALL THE BUNDLES IF(ISC.EQ.3) THEN MMIX=NBCH*NCCO DO 870 IGR=1,NGRP DO 550 IZ=1,NCZO WORK(IZ)=DIFFX(IZ,IGR) 550 CONTINUE DO 570 IC=1,NCCO DO 560 IB=1,NBCH ICB=NBCH*(IC-1)+IB DIFFX(ICB,IGR)=WORK(IZONE(IC)) 560 CONTINUE 570 CONTINUE * IF(ILEAK.EQ.2) THEN DO 580 IZ=1,NCZO WORK(IZ)=DIFFY(IZ,IGR) 580 CONTINUE DO 600 IC=1,NCCO DO 590 IB=1,NBCH ICB=NBCH*(IC-1)+IB DIFFY(ICB,IGR)=WORK(IZONE(IC)) 590 CONTINUE 600 CONTINUE * DO 610 IZ=1,NCZO WORK(IZ)=DIFFZ(IZ,IGR) 610 CONTINUE DO 630 IC=1,NCCO DO 620 IB=1,NBCH ICB=NBCH*(IC-1)+IB DIFFZ(ICB,IGR)=WORK(IZONE(IC)) 620 CONTINUE 630 CONTINUE ENDIF * DO 670 ITY=2,NTM+1 DO 640 IZ=1,NCZO WORK(IZ)=SIGMA(IZ,IGR,ITY) 640 CONTINUE DO 660 IC=1,NCCO DO 650 IB=1,NBCH ICB=NBCH*(IC-1)+IB SIGMA(ICB,IGR,ITY)=WORK(IZONE(IC)) 650 CONTINUE 660 CONTINUE 670 CONTINUE * DO 680 IZ=1,NCZO WORK(IZ)=FLUX(IZ,IGR) 680 CONTINUE DO 700 IC=1,NCCO DO 690 IB=1,NBCH ICB=NBCH*(IC-1)+IB FLUX(ICB,IGR)=WORK(IZONE(IC)) 690 CONTINUE 700 CONTINUE * DO 710 IZ=1,NCZO WORK(IZ)=OVERV(IZ,IGR) 710 CONTINUE DO 730 IC=1,NCCO DO 720 IB=1,NBCH ICB=NBCH*(IC-1)+IB OVERV(ICB,IGR)=WORK(IZONE(IC)) 720 CONTINUE 730 CONTINUE * DO 740 IZ=1,NCZO WORK(IZ)=CHI(IZ,IGR) 740 CONTINUE DO 760 IC=1,NCCO DO 750 IB=1,NBCH ICB=NBCH*(IC-1)+IB CHI(ICB,IGR)=WORK(IZONE(IC)) 750 CONTINUE 760 CONTINUE * IL=1 DO 800 JGR=1,NGRP DO 770 IZ=1,NCZO WORK(IZ)=SCAT(IZ,IL,IGR,JGR) 770 CONTINUE DO 790 IC=1,NCCO DO 780 IB=1,NBCH ICB=NBCH*(IC-1)+IB SCAT(ICB,IL,IGR,JGR)=WORK(IZONE(IC)) 780 CONTINUE 790 CONTINUE 800 CONTINUE * DO 810 IZ=1,NCZO IWORK(IZ)=NJJ(IZ,IL,IGR) 810 CONTINUE DO 830 IC=1,NCCO DO 820 IB=1,NBCH ICB=NBCH*(IC-1)+IB NJJ(ICB,IL,IGR)=IWORK(IZONE(IC)) 820 CONTINUE 830 CONTINUE * DO 840 IZ=1,NCZO IWORK(IZ)=IJJ(IZ,IL,IGR) 840 CONTINUE DO 860 IC=1,NCCO DO 850 IB=1,NBCH ICB=NBCH*(IC-1)+IB IJJ(ICB,IL,IGR)=IWORK(IZONE(IC)) 850 CONTINUE 860 CONTINUE * 870 CONTINUE * DO 880 IZ=1,NCZO WORK(IZ)=VOL(IZ) 880 CONTINUE DO 900 IC=1,NCCO DO 890 IB=1,NBCH ICB=NBCH*(IC-1)+IB VOL(ICB)=WORK(IZONE(IC)) 890 CONTINUE 900 CONTINUE * ENDIF *--- * STORE MACROLIB INFORMATIONS *--- IF(ITYPE.EQ.0)THEN CALL LCMPUT(IPMACX,'VOLUME',MMIX,2,VOL) CALL LCMPUT(IPMACX,'ENERGY',NGRP+1,2,ENER) ENDIF * IF(LMCR) THEN STORE=VOL(MMIX) VOL(MMIX)= 0.0 * MACROLIB EN MODIFICATION IF(ITYPE.NE.0) THEN CALL LCMGET(IPMACX,'VOLUME',VOL) ENDIF VOL(KTYP(1)) = STORE CALL LCMPUT(IPMACX,'VOLUME',MMIX,2,VOL) JPMAC=LCMLID(IPMACX,'GROUP',NGRP) DO 950 JGR=1,NGRP KPMAC=LCMDIL(JPMAC,JGR) STORE=SIGMA(MMIX,JGR,2) SIGMA(MMIX,JGR,2) = 0.0 * MACROLIB EN MODIFICATION IF(ITYPE.NE.0) THEN CALL LCMGET(KPMAC,'NTOT0',SIGMA(1,JGR,2)) ENDIF SIGMA(KTYP(1),JGR,2) = STORE * STORE=OVERV(MMIX,JGR) OVERV(MMIX,JGR) = 0.0 * MACROLIB EN MODIFICATION IF(ITYPE.NE.0) THEN CALL LCMGET(KPMAC,'OVERV',OVERV(1,JGR)) ENDIF OVERV(KTYP(1),JGR) = STORE * STORE=DIFFX(MMIX,JGR) DIFFX(MMIX,JGR) = 0.0 * MACROLIB EN MODIFICATION IF(ITYPE.NE.0) THEN CALL LCMGET(KPMAC,'DIFFX',DIFFX(1,JGR)) ENDIF DIFFX(KTYP(1),JGR) = STORE * IF(ILEAK.EQ.2) THEN STORE=DIFFY(MMIX,JGR) DIFFY(MMIX,JGR) = 0.0 IF(ITYPE.NE.0) THEN CALL LCMGET(KPMAC,'DIFFY',DIFFY(1,JGR)) ENDIF DIFFY(KTYP(1),JGR) = STORE * STORE=DIFFZ(MMIX,JGR) DIFFZ(MMIX,JGR) = 0.0 IF(ITYPE.NE.0) THEN CALL LCMGET(KPMAC,'DIFFZ',DIFFZ(1,JGR)) ENDIF DIFFZ(KTYP(1),JGR) = STORE ENDIF * STORE = FLUX(MMIX,JGR) FLUX(MMIX,JGR) = 0.0 IF(ITYPE.NE.0) THEN CALL LCMGET(KPMAC,'FLUX-INTG',FLUX(1,JGR)) ENDIF FLUX(KTYP(1),JGR) = STORE * IF(JTAB(1).EQ.1 .OR. ITYPE.NE.0) THEN STORE = CHI(MMIX,JGR) CHI(MMIX,JGR) = 0.0 IF(ITYPE.NE.0) THEN CALL LCMGET(KPMAC,'CHI',CHI(1,JGR)) ENDIF CHI(KTYP(1),JGR) = STORE * STORE=SIGMA(MMIX,JGR,3) SIGMA(MMIX,JGR,3) = 0.0 IF(ITYPE.NE.0) THEN CALL LCMGET(KPMAC,'NUSIGF',SIGMA(1,JGR,3)) ENDIF SIGMA(KTYP(1),JGR,3) = STORE * STORE=SIGMA(MMIX,JGR,5) SIGMA(MMIX,JGR,5) = 0.0 IF(ITYPE.NE.0) THEN CALL LCMGET(KPMAC,'NFTOT',SIGMA(1,JGR,5)) ENDIF SIGMA(KTYP(1),JGR,5) = STORE * STORE=SIGMA(MMIX,JGR,4) SIGMA(MMIX,JGR,4) = 0.0 IF(ITYPE.NE.0) THEN CALL LCMGET(KPMAC,'H-FACTOR',SIGMA(1,JGR,4)) ENDIF SIGMA(KTYP(1),JGR,4) = STORE * ENDIF * IL=1 ALLOCATE(SSCAT(NGRP)) DO 910 IGR=1,NGRP SSCAT(IGR)= SCAT(MMIX,IL,IGR,JGR) SCAT(MMIX,IL,IGR,JGR) = 0.0 910 CONTINUE IF(ITYPE.NE.0) THEN !! ATTENTION isotropy is supposed !! IL=1 WRITE (CM,'(I2.2)') IL-1 CALL LCMGET(KPMAC,'SCAT'//CM,WORK) CALL LCMGET(KPMAC,'NJJS'//CM,NJJ(1,IL,JGR)) CALL LCMGET(KPMAC,'IJJS'//CM,IJJ(1,IL,JGR)) CALL LCMGET(KPMAC,'IPOS'//CM,IPOS) DO 930 IBM=1,MMIX IJJ0=IJJ(IBM,IL,JGR) IPOSDE = IPOS(IBM) DO 920 IGR=IJJ0,IJJ0-NJJ(IBM,IL,JGR)+1,-1 SCAT(IBM,IL,IGR,JGR)=WORK(IPOSDE) IPOSDE=IPOSDE+1 920 CONTINUE 930 CONTINUE ENDIF * DO 940 IGR=1,NGRP SCAT(KTYP(1),IL,IGR,JGR) = SSCAT(IGR) 940 CONTINUE DEALLOCATE(SSCAT) 950 CONTINUE ENDIF * DO 990 IX=1,MMIX DO 980 JGR=1,NGRP DO 970 IL=1,NL IGMIN=JGR IGMAX=JGR DO 960 IGR=NGRP,1,-1 IF (SCAT(IX,IL,IGR,JGR).NE.0.0) THEN IGMIN=MIN(IGMIN,IGR) IGMAX=MAX(IGMAX,IGR) ENDIF 960 CONTINUE IJJ(IX,IL,JGR)=IGMAX NJJ(IX,IL,JGR)=IGMAX-IGMIN+1 970 CONTINUE 980 CONTINUE 990 CONTINUE * SIGS(:MMIX,:NGRP)=0.0 JPMAC=LCMLID(IPMACX,'GROUP',NGRP) DO 1002 JGR=1,NGRP KPMAC=LCMDIL(JPMAC,JGR) CALL LCMPUT(KPMAC,'NTOT0',MMIX,2,SIGMA(1,JGR,2)) CALL LCMPUT(KPMAC,'OVERV',MMIX,2,OVERV(1,JGR)) IF(ILEAK.EQ.1) THEN CALL LCMPUT(KPMAC,'DIFF',MMIX,2,DIFFX(1,JGR)) ELSE IF(ILEAK.EQ.2) THEN CALL LCMPUT(KPMAC,'DIFFX',MMIX,2,DIFFX(1,JGR)) CALL LCMPUT(KPMAC,'DIFFY',MMIX,2,DIFFY(1,JGR)) CALL LCMPUT(KPMAC,'DIFFZ',MMIX,2,DIFFZ(1,JGR)) ENDIF CALL LCMPUT(KPMAC,'FLUX-INTG',MMIX,2,FLUX(1,JGR)) IF(JTAB(1).EQ.1 .OR. ITYPE.NE.0) THEN CALL LCMPUT(KPMAC,'CHI ',MMIX,2,CHI(1,JGR)) CALL LCMPUT(KPMAC,'NUSIGF ',MMIX,2,SIGMA(1,JGR,3)) ! Caution: H-FACTORS are J-barn. Convert them to eV-barn SIGMA(:MMIX,JGR,4)=SIGMA(:MMIX,JGR,4)/REAL(EVJ) CALL LCMPUT(KPMAC,'H-FACTOR',MMIX,2,SIGMA(1,JGR,4)) CALL LCMPUT(KPMAC,'NFTOT',MMIX,2,SIGMA(1,JGR,5)) ENDIF * IL=1 WRITE (CM,'(I2.2)') IL-1 IPOSDE=0 DO 1001 IX=1,MMIX IPOS(IX)=IPOSDE+1 DO 1000 IGR=IJJ(IX,IL,JGR),IJJ(IX,IL,JGR)-NJJ(IX,IL,JGR)+1,-1 IPOSDE=IPOSDE+1 WORK(IPOSDE)=SCAT(IX,IL,IGR,JGR) SIGS(IX,IGR)=SIGS(IX,IGR)+ SCAT(IX,IL,IGR,JGR) 1000 CONTINUE 1001 CONTINUE * CALL LCMPUT(KPMAC,'SCAT'//CM,IPOSDE,2,WORK) CALL LCMPUT(KPMAC,'IPOS'//CM,MMIX,1,IPOS) CALL LCMPUT(KPMAC,'NJJS'//CM,MMIX,1,NJJ(1,IL,JGR)) CALL LCMPUT(KPMAC,'IJJS'//CM,MMIX,1,IJJ(1,IL,JGR)) CALL LCMPUT(KPMAC,'SIGW'//CM,MMIX,2,SCAT(1,IL,JGR,JGR)) 1002 CONTINUE DO 1003 JGR=1,NGRP KPMAC=LCMDIL(JPMAC,JGR) IL=1 WRITE (CM,'(I2.2)') IL-1 CALL LCMPUT(KPMAC,'SIGS'//CM,MMIX,2,SIGS(1,JGR)) 1003 CONTINUE *---- * SCRATCH STORAGE DEALLOCATION *---- DEALLOCATE(XPURB,XPF2LB,XPF1LB,XPF2B,XPF1B,XMMDB,XMFDB,XNP9B, 1 XSMB,XD2MB,XD1MB,XD2CB,XD1CB,XT2MB,XT1MB,XT2CB,XT1CB,XT2FB,XT1FB, 2 XXENB,XBORB,SMACB) DEALLOCATE(ITEXTR,PTFUEL,PTCOOL,PDCOOL,ISFT,PSFT,BSFT,XFLUN,XSIGX, 1 XSIGF,KTYP,INDEX,OVERVB,CHIB,JTAB,FLUXB,CPW2B,CPW1B,HNEP2,HNEP1, 2 HSAM2,HSAM1,HXEN2,HXEN1,HISO,DENSITB,BFLUX,NJ,BRH,PW,SCATAV, 3 IWORK,SIGAV,FLUAV,POWER,BURED,BURBG,IZONE,WORK,IJ,DIFFZ,DIFFY, 4 DIFFX,SCAT,IPOS,ENER,CHI,FLUX,SIGS,OVERV,XBURN,NJJ,VOL,IJJ,SIGMA) RETURN * 699 FORMAT(/' AFMDRV: THE CROSS SECTIONS ARE GENERATED FOR A', 1 ' TIME AVERAGE CALCULATION.') 701 FORMAT(/' AFMDRV: THE CROSS SECTIONS ARE GENERATED FOR A', 1 ' SNAPSHOT CALCULATION.') 702 FORMAT(/' AFMDRV: POWER ARE RECOVERED FROM L_MAP.') 703 FORMAT(/' AFMDRV: FLUX ARE RECOVERED FROM L_MAP.') 704 FORMAT(/' AFMDRV: BUNDLES POWER SHIFT ARE CORRECTED.') 705 FORMAT(/' AFMDRV: BUNDLES POWER = ',F12.2,1X,'KW IS FIXED', 1 ' BY THE USER.') 706 FORMAT(/' AFMDRV: BUNDLES XENON = ',E15.8,1X,'IS FIXED', 1 ' BY THE USER.') 707 FORMAT(/' AFMDRV: LAGRANGE INTERPOLATION IS USED TO COMPUTE', 1 ' TIME AVERAGED CROSS SECTIONS.') 708 FORMAT(/' AFMDRV: SPLINE 3 INTERPOLATION IS USED TO COMPUTE', 1 ' TIME AVERAGED CROSS SECTIONS.') 709 FORMAT(/' AFMDRV: HERMITE 3 INTERPOLATION IS USED TO COMPUT', 1 'E TIME AVERAGED CROSS SECTIONS.') 711 FORMAT(/' AFMDRV: BUNDLES NEPTUNIUM = ',E15.8,1X,'IS FIXED', 1 ' BY THE USER.') 712 FORMAT(/' AFMDRV: NOMINAL XENON IS USED.') 713 FORMAT(/' AFMDRV: NOMINAL NEPTUNIUM IS USED.') 714 FORMAT(/' AFMDRV: BUNDLES TFUEL = ',F12.2,1X,'K IS FIXED', 1 ' BY THE USER.') 715 FORMAT(/' AFMDRV: DRAGON CONCENTRATIONS ARE USED (XE135' 1 //' NP239, SM149).') 716 FORMAT(/' AFMDRV: ',A12,' PROFILES ARE RECOVERED FROM L_MAP.', 1 ' PARKEY=',A12) 717 FORMAT(/' AFMDRV: BUNDLES COOL. TEMP. TCOOL = ',F12.2,1X, 1 'K IS FIXED BY THE USER.') 718 FORMAT(/' AFMDRV: BUNDLES COOL. DENSITY RDCL = ',F12.9,1X, 1 'K IS FIXED BY THE USER.') 719 FORMAT(/' AFMDRV: BUNDLES SAMARIUM = ',E15.8,1X,'IS FIXED', 1 ' BY THE USER.') END