path: root/Donjon/src/SCR.f

*DECK SCR
      SUBROUTINE SCR(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY)
*
*-----------------------------------------------------------------------
*
*Purpose:
* Recover and interpolate Microlib or Macrolib information from one or
* many Saphyb database objects.
*
*Copyright:
* Copyright (C) 2012 Ecole Polytechnique de Montreal
*
*Author(s): 
* A. Hebert
*
*Parameters: input
* NENTRY  number of data structures transfered to this module.
* HENTRY  name of the data structures.
* IENTRY  data structure type where:
*         IENTRY=1 for LCM memory object;
*         IENTRY=2 for XSM file;
*         IENTRY=3 for sequential binary file;
*         IENTRY=4 for sequential ASCII file.
* JENTRY  access permission for the data structure where:
*         JENTRY=0 for a data structure in creation mode;
*         JENTRY=1 for a data structure in modifications mode;
*         JENTRY=2 for a data structure in read-only mode.
* KENTRY  data structure pointer.
*
*Comments:
* The SCR: calling specifications are:
* MLIB := SCR: [ { MLIB | MLIB2 } ] SAPNAM1 [[ SAPNAM2 ]] [ MAPFL ] 
*   :: (scr\_data) ; \\
* where
*   MLIB : name of a \emph{microlib} (type L\_LIBRARY) or \emph{macrolib} 
*     (type L\_MACROLIB) containing the interpolated data. If this object also 
*     appears on the RHS of structure (SCR:, it is open in modification mode 
*     and updated.
*   MLIB2 : name of an optional \emph{microlib} object whose content is copied 
*     on MLIB.
*   SAPNAM1 : name of the \emph{saphyb} data structure (L\_SAPHYB signature).
*   SAPNAM2 : name of an additional \emph{saphyb} data structure (L\_SAPHYB 
*     signature). This object is optional.
*   MAPFL : name of the \emph{map} object containing fuel regions description, 
*     global parameter information (burnup, fuel/coolant temperatures, coolant 
*     density, etc). Keyword TABLE is expected in (scr\_data).
*   scr\_data : input data structure containing interpolation information.
*
*-----------------------------------------------------------------------
*
      USE GANLIB
      IMPLICIT NONE
*----
*  SUBROUTINE ARGUMENTS
*----
      INTEGER      NENTRY,IENTRY(NENTRY),JENTRY(NENTRY)
      TYPE(C_PTR)  KENTRY(NENTRY)
      CHARACTER    HENTRY(NENTRY)*12
*----
*  LOCAL VARIABLES
*----
      INTEGER, PARAMETER::IOUT=6
      INTEGER, PARAMETER::MAXR=12
      INTEGER, PARAMETER::NSTATE=40
      REAL B2, FLOTT
      INTEGER ITYLCM, MAXISO, MAXNIS, MD1, MD2, MY1, MY2, NB, NCAL,
     & NCH, NCOMB, NDEPL, NDFI, NDFP, NFUEL, NGRP, NHEAVY, NBISO, NISY,
     & NITMA, NLIGHT, NMAC, NMIL, NMIX, NOTHER, NPARM, NPAR, NREAC,
     & NSTABL, NSURFD, NVTOT, NBESP, ILUPS
      INTEGER  IMPX, ILONG, IMPY, INDIC, ITER, ITEXT4
      INTEGER  I, IACCS, ITH, J
      CHARACTER TEXT4*4,TEXT12*12,HSMG*131,HSIGN*12,HEQUI*4,
     1 HMASL*4,NMDEPL(MAXR)*8
      LOGICAL LMACRO,LCUBIC,LRES,LPURE
      DOUBLE PRECISION DFLOTT
      INTEGER ISTATE(NSTATE),DIMSAP(50)
      TYPE(C_PTR) IPMAP,IPSAP,IPLIB,IPLIB2,IPMEM
*----
*  ALLOCATABLE ARRAYS
*----
      INTEGER, ALLOCATABLE, DIMENSION(:) :: MIXC,NISO,LISO,HISO,IADRY,
     1 ITNAM,ITZEA,MATNO,KPAX,INAM,IZAE,HREAC,IDR,KPAR,ITODO
      REAL, ALLOCATABLE, DIMENSION(:) :: CONC,BPAX,RER,RRD,BPAR,YIELD
      REAL, ALLOCATABLE, DIMENSION(:,:) :: TERP
      DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: VTOT
      DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: YLDS,DECAY
      CHARACTER(LEN=8), ALLOCATABLE, DIMENSION(:) :: NOMIS
*
      SAVE      NMDEPL
      DATA      NMDEPL/'DECAY   ','NFTOT   ','NG      ','N2N     ',
     >                 'N3N     ','N4N     ','NA      ','NP      ',
     >                 'N2A     ','NNP     ','ND      ','NT      '/
*----
*  PARAMETER VALIDATION
*----
      IF(NENTRY.LE.1) CALL XABORT('SCR: MINIMUM OF 2 OBJECTS EXPECTED.')
      IF((IENTRY(1).NE.1).AND.(IENTRY(1).NE.2)) CALL XABORT('SCR: MACRO'
     1 //'LIB LCM OBJECT EXPECTED AT LHS.')
      IF((JENTRY(1).NE.0).AND.(JENTRY(1).NE.1)) CALL XABORT('SCR: MACRO'
     1 //'LIB IN CREATE OR MODIFICATION MODE EXPECTED.')
      IACCS=JENTRY(1)
      IPLIB=KENTRY(1)
      IPLIB2=C_NULL_PTR
      IPMAP=C_NULL_PTR
      NGRP=0
      NMIX=0
      IF(IACCS.EQ.1) THEN
        CALL LCMGTC(IPLIB,'SIGNATURE',12,HSIGN)
        IF(HSIGN.EQ.'L_LIBRARY') THEN
          CALL LCMGET(IPLIB,'STATE-VECTOR',ISTATE)
          NGRP=ISTATE(3)
          NMIX=ISTATE(1)
        ELSE IF(HSIGN.EQ.'L_MACROLIB') THEN
          CALL LCMGET(IPLIB,'STATE-VECTOR',ISTATE)
          NGRP=ISTATE(1)
          NMIX=ISTATE(2)
        ELSE
          TEXT12=HENTRY(1)
          CALL XABORT('SCR: SIGNATURE OF '//TEXT12//' IS '//HSIGN//
     1    '. L_LIBRARY OR L_MACROLIB EXPECTED.')
        ENDIF
      ENDIF
      DO 10 I=2,NENTRY
        IF((IENTRY(I).NE.1).AND.(IENTRY(I).NE.2)) CALL XABORT('SCR: '
     1 //'LCM OBJECTS EXPECTED AT RHS.')
        IF(JENTRY(I).NE.2) CALL XABORT('SCR: LCM OBJECTS IN READ-ONLY '
     1 //'MODE EXPECTED AT RHS.')
        CALL LCMGTC(KENTRY(I),'SIGNATURE',12,HSIGN)
        IF(HSIGN.EQ.'L_LIBRARY') THEN
          IF(C_ASSOCIATED(IPLIB2)) CALL XABORT('SCR: ONLY ONE MICROLIB'
     1   //' EXPECTED AT RHS.')
          IPLIB2=KENTRY(I)
          GO TO 10
        ELSE IF(HSIGN.EQ.'L_MACROLIB') THEN
          CALL XABORT('SCR: ANOTHER MACROLIB NOT EXPECTED AT RHS.')
        ELSE IF(HSIGN.EQ.'L_MAP') THEN
          IF(I.NE.NENTRY)CALL XABORT('SCR: FUEL-MAP EXPECTED TO BE THE '
     1    //'LAST OBJECT.')
          IF(NENTRY.LT.3)CALL XABORT('SCR: MISSING SAPHYB OBJECT.')
          IPMAP=KENTRY(NENTRY)
          CALL LCMGET(IPMAP,'STATE-VECTOR',ISTATE)
          NMIX=ISTATE(9)
        ELSE IF(HSIGN.NE.'L_SAPHYB') THEN
          TEXT12=HENTRY(I)
          CALL XABORT('SCR: SIGNATURE OF '//TEXT12//' IS '//HSIGN//
     1   '. L_SAPHYB EXPECTED.')
        ENDIF
   10 CONTINUE
*----
*  READ THE INPUT DATA
*----
      NVTOT=0
      LMACRO=.TRUE.
      LCUBIC=.FALSE.
      LRES=.FALSE.
      LPURE=.FALSE.
      B2=0.0
      ITER=-1
      IPSAP=C_NULL_PTR
      HEQUI=' '
      HMASL=' '
      ILUPS=0
      IMPX=1
   20 CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT)
      IF(INDIC.NE.3) CALL XABORT('SCR: CHARACTER DATA EXPECTED(1).')
   30 IF(TEXT12.EQ.'EDIT') THEN
*       READ THE PRINT INDEX.
        CALL REDGET(INDIC,IMPX,FLOTT,TEXT12,DFLOTT)
        IF(INDIC.NE.1) CALL XABORT('SCR: INTEGER DATA EXPECTED(1).')
      ELSE IF(TEXT12.EQ.'NMIX') THEN
*       READ THE MAXIMUM NUMBER OF MATERIAL MIXTURES.
        CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT)
        IF(INDIC.NE.1) CALL XABORT('SCR: INTEGER DATA EXPECTED(2).')
        IF(NITMA.LT.NMIX) THEN
           WRITE(HSMG,'(20HSCR: NMIX MUST BE >=,I8)') NMIX
           CALL XABORT(HSMG)
        ENDIF
        NMIX=NITMA
      ELSE IF(TEXT12.EQ.'MACRO') THEN
        LMACRO=.TRUE.
      ELSE IF(TEXT12.EQ.'MICRO') THEN
        LMACRO=.FALSE.
      ELSE IF(TEXT12.EQ.'LINEAR') THEN
        LCUBIC=.FALSE.
      ELSE IF(TEXT12.EQ.'CUBIC') THEN
        LCUBIC=.TRUE.
      ELSE IF(TEXT12.EQ.'RES') THEN
        IF((IACCS.EQ.0).AND.(.NOT.C_ASSOCIATED(IPLIB2))) THEN
          CALL XABORT('SCR: RHS MICROLIB EXPECTED WITH RES OPTION.')
        ENDIF
        LRES=.TRUE.
      ELSE IF(TEXT12.EQ.'PURE') THEN
        LPURE=.TRUE.
      ELSE IF(TEXT12.EQ.'UPS') THEN
        ILUPS=1
      ELSE IF(TEXT12.EQ.'SAPHYB') THEN
        IF(NMIX.EQ.0) CALL XABORT('SCR: ZERO NUMBER OF MIXTURES.')
        IF(C_ASSOCIATED(IPMAP)) THEN
          WRITE(IOUT,'(/43H SCR: ***WARNING*** A FUEL MAP IS SET AT RH,
     1    26HS; KEYWORD TABLE EXPECTED.)')
        ENDIF
        IF((IACCS.EQ.0).AND.(C_ASSOCIATED(IPLIB2))) THEN
          CALL LCMEQU(IPLIB2,IPLIB)
          IACCS=1
        ENDIF
        CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT)
        IF(INDIC.NE.3) CALL XABORT('SCR: CHARACTER DATA EXPECTED(2).')
        ITH=0
        DO 50 I=2,NENTRY
          IF(C_ASSOCIATED(KENTRY(I),IPLIB2)) GO TO 50
          IF(TEXT12.EQ.HENTRY(I)) THEN
            CALL LCMGTC(KENTRY(I),'SIGNATURE',12,TEXT12)
            IF(TEXT12.EQ.'L_SAPHYB') THEN
              IPSAP=KENTRY(I)
            ELSE
              CALL XABORT('SCR: WRONG SIGNATURE ('//TEXT12//').')
            ENDIF
            ITH=I
            GO TO 60
          ENDIF
   50   CONTINUE
        CALL XABORT('SCR: SAPHYB '//TEXT12//' NOT FOUND.')
   60   IF(IMPX.GT.0) THEN
          WRITE(IOUT,320) HENTRY(ITH)
          CALL SCRTOC(IPSAP)
        ENDIF
        CALL LCMGET(IPSAP,'DIMSAP',DIMSAP)
        IF(NGRP.EQ.0) THEN
          NGRP=DIMSAP(20)
        ELSE IF(NGRP.NE.DIMSAP(20)) THEN
          WRITE(HSMG,'(9H SCR: THE,I4,27H-TH SAPHYB HAS AN INVALID N,
     1    24HUMBER OF ENERGY GROUPS (,I4,3H VS,I5,1H.)') ITH,NGRP,
     2    DIMSAP(20)
          CALL XABORT(HSMG)
        ENDIF
        NMIL=DIMSAP(7)
        NCAL=DIMSAP(19)
        MY1=DIMSAP(6)+DIMSAP(14)
        MY2=DIMSAP(15)
        MD1=DIMSAP(3)
        MD2=DIMSAP(5)+DIMSAP(6)
        ALLOCATE(MIXC(NMIX),NISO(NMIX),LISO(NMIX),HISO(2*NMIX*MD2),
     1  ITODO(NMIX*MD2))
        ALLOCATE(TERP(NCAL,NMIX),CONC(NMIX*MD2))
*
        CALL SCRDRV(IPSAP,LCUBIC,NMIX,IMPX,NMIL,NCAL,MD2,ITER,MAXNIS,
     1  MIXC,TERP,NISO,LISO,HISO,CONC,ITODO)
        GO TO 130
      ELSE IF(TEXT12.EQ.'TABLE') THEN
        IF(.NOT.C_ASSOCIATED(IPMAP)) CALL XABORT('SCR: MISSING FUEL-MA'
     1  //'P OBJECT.')
        ISTATE(:NSTATE)=0
        CALL LCMGET(IPMAP,'STATE-VECTOR',ISTATE)
        NB=ISTATE(1)
        NCH=ISTATE(2)
        NCOMB=ISTATE(3)
        NGRP=ISTATE(4)
        NFUEL=ISTATE(7)
        NPARM=ISTATE(8)
        IF(NCOMB.EQ.0) CALL XABORT('SCR: NUMBER OF COMBUSTION ZONES NO'
     1   //'T YET DEFINED IN THE FUEL MAP NCOMB=0.')
        IF((IACCS.EQ.0).AND.(C_ASSOCIATED(IPLIB2))) THEN
          CALL LCMEQU(IPLIB2,IPLIB)
          IACCS=1
        ENDIF
        CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT)
        IF(INDIC.NE.3) CALL XABORT('SCR: CHARACTER DATA EXPECTED(2).')
        ITH=0
        DO 80 I=2,NENTRY
          IF((C_ASSOCIATED(KENTRY(I),IPLIB2)).OR.
     1       (C_ASSOCIATED(KENTRY(I),IPMAP))) GO TO 80
          IF(TEXT12.EQ.HENTRY(I)) THEN
            CALL LCMGTC(KENTRY(I),'SIGNATURE',12,TEXT12)
            IF(TEXT12.EQ.'L_SAPHYB') THEN
              IPSAP=KENTRY(I)
            ELSE
              CALL XABORT('SCR: WRONG SIGNATURE ('//TEXT12//').')
            ENDIF
            ITH=I
            GO TO 90
          ENDIF
   80   CONTINUE
        CALL XABORT('SCR: SAPHYB '//TEXT12//' NOT FOUND.')
   90   IF(IMPX.GT.0) THEN
          WRITE(IOUT,320) HENTRY(ITH)
          CALL SCRTOC(IPSAP)
        ENDIF
        CALL LCMGET(IPSAP,'DIMSAP',DIMSAP)
        IF(NGRP.NE.DIMSAP(20)) THEN
          WRITE(HSMG,'(9H SCR: THE,I4,27H-TH SAPHYB HAS AN INVALID N,
     1    24HUMBER OF ENERGY GROUPS (,I4,3H VS,I5,2H).)') ITH,NGRP,
     2    DIMSAP(20)
          CALL XABORT(HSMG)
        ENDIF
        NMIL=DIMSAP(7)
        NCAL=DIMSAP(19)
        MY1=DIMSAP(6)+DIMSAP(14)
        MY2=DIMSAP(15)
        MD1=DIMSAP(3)
        MD2=DIMSAP(5)+DIMSAP(6)
        ALLOCATE(MIXC(NMIX),NISO(NMIX),LISO(NMIX),HISO(2*NMIX*MD2),
     1  ITODO(NMIX*MD2))
        ALLOCATE(TERP(NCAL,NMIX),CONC(NMIX*MD2))
*
        CALL SCRRGR(IPSAP,IPMAP,LCUBIC,NMIX,IMPX,NMIL,NCAL,MD2,NCH,NB,
     1  NFUEL,NPARM,ITER,MAXNIS,MIXC,TERP,NISO,LISO,HISO,CONC,ITODO)
        GO TO 130
      ELSE IF(TEXT12.EQ.'EQUI') THEN
         CALL REDGET(INDIC,NITMA,FLOTT,HEQUI,DFLOTT)
         IF(INDIC.NE.3) CALL XABORT('SCR: CHARACTER DATA EXPECTED')
      ELSE IF(TEXT12.EQ.'MASL') THEN
         CALL REDGET(INDIC,NITMA,FLOTT,HMASL,DFLOTT)
         IF(INDIC.NE.3) CALL XABORT('SCR: CHARACTER DATA EXPECTED')
      ELSE IF(TEXT12.EQ.'LEAK') THEN
        CALL REDGET(INDIC,NITMA,B2,TEXT12,DFLOTT)
        IF(INDIC.NE.2) CALL XABORT('SCR: REAL DATA EXPECTED.')
      ELSE IF(TEXT12.EQ.'CHAIN') THEN
        IF(LMACRO) CALL XABORT('SCR: MICRO KEYWORD EXPECTED.')
        CALL LCMGET(IPSAP,'DIMSAP',DIMSAP)
        NBISO=DIMSAP(5)  ! number of particularized isotopes
        NMAC=DIMSAP(6)   ! number of macroscopic sets
        IF(NBISO.EQ.0) CALL XABORT('SCR: NO PARTICULARIZED ISOTOPES.')
        IF(NMAC.EQ.0) CALL XABORT('SCR: NO MACROSCOPIC SETS.')
        MY1=DIMSAP(6)+DIMSAP(14)
        MY2=DIMSAP(15)
        MD1=DIMSAP(3)
        MD2=DIMSAP(5)+DIMSAP(6)
        CALL LCMLEN(IPLIB,'VTOT_',ILONG,ITYLCM)
        IF(ILONG.NE.NVTOT) CALL XABORT('SCR: INVALID LENGTH: VTOT(1).')
        CALL LCMLEN(IPLIB,'YLDS_',ILONG,ITYLCM)
        IF(ILONG.NE.MY1*MY2*NVTOT) CALL XABORT('SCR: INVALID LENGTH: Y'
     1  //'LDS(1).')
        CALL LCMLEN(IPLIB,'DECAYC_',ILONG,ITYLCM)
        IF(ILONG.NE.MD1*MD2*NVTOT) CALL XABORT('SCR: INVALID LENGTH: D'
     1  //'ECAYC(1)')
        ALLOCATE(VTOT(NVTOT),YLDS(MY1,MY2,NVTOT),DECAY(MD1,MD2,NVTOT),
     1  NOMIS(NBISO+NMAC))
        CALL LCMGET(IPLIB,'VTOT_',VTOT)
        CALL LCMGET(IPLIB,'YLDS_',YLDS)
        CALL LCMGET(IPLIB,'DECAYC_',DECAY)
        CALL LCMSIX(IPSAP,'contenu',1)
          CALL LCMGTC(IPSAP,'NOMISO',8,NBISO,NOMIS)
          CALL LCMGTC(IPSAP,'NOMMAC',8,NMAC,NOMIS(NBISO+1:NBISO+NMAC))
        CALL LCMSIX(IPSAP,' ',2)
        WRITE(TEXT12,'(4Hcalc,I8)') 1
        CALL LCMSIX(IPSAP,TEXT12,1) ! step up to calc
        CALL LCMSIX(IPSAP,'info',1)
        CALL LCMGET(IPSAP,'NISY',NISY)
        ALLOCATE(IADRY(NISY))
        CALL LCMGET(IPSAP,'ADRY',IADRY)
        CALL LCMSIX(IPSAP,' ',2)
        CALL LCMSIX(IPSAP,' ',2)
*
        NBESP=1
        ALLOCATE(ITNAM(3*MD2),ITZEA(MD2),MATNO(MD2),
     1  KPAX((MD2+MAXR)*MD2),BPAX((MD2+MAXR)*MD2*NBESP))
        TEXT4='    '
        READ(TEXT4,'(A4)') ITEXT4
        ITNAM(:3*MD2)=ITEXT4
        ITZEA(:MD2)=0
        MATNO(:MD2)=0
        KPAX(:(MD2+MAXR)*MD2)=0
        BPAX(:(MD2+MAXR)*MD2*NBESP)=0.0
        CALL SCREIR(NMDEPL,MY1,MY2,MD1,MD2,NOMIS,IADRY,NVTOT,VTOT,
     1              YLDS,DECAY,ITNAM,ITZEA,KPAX,BPAX)
        DEALLOCATE(IADRY,NOMIS,DECAY,YLDS,VTOT)
        CALL LIBWET(MAXR,MD2,NBESP,NSTATE,NMDEPL,ITNAM,ISTATE,MATNO,
     1  KPAX,BPAX)
        NDEPL=ISTATE(1)
        NDFI=ISTATE(2)
        NDFP=ISTATE(3)
        NHEAVY=ISTATE(4)
        NLIGHT=ISTATE(5)
        NOTHER=ISTATE(6)
        NSTABL=ISTATE(7)
        NREAC=ISTATE(8)
        NPAR=ISTATE(9)
        NBESP=MAX(1,ISTATE(10))
*----
*  ALLOCATE DECAY CHAIN
*----
        NDEPL=MAX(NDEPL,1)
        NDFI=MAX(NDFI,1)
        NDFP=MAX(NDFP,1)
        ALLOCATE(INAM(3*NDEPL),IZAE(NDEPL),IDR(NREAC*NDEPL),
     1  RER(NREAC*NDEPL),RRD(NDEPL),KPAR(NPAR*NDEPL),BPAR(NPAR*NDEPL),
     2  YIELD(NDFI*NDFP*NBESP))
*----
*  SET DECAY CHAIN
*----
        CALL LIBWED(MAXR,MD2,NBESP,NDEPL,NDFI,NDFP,NHEAVY,NLIGHT,NOTHER,
     >              NREAC,NPAR,ITNAM,ITZEA,MATNO,KPAX,BPAX,INAM,IZAE,
     >              IDR,RER,RRD,KPAR,BPAR,YIELD)
*----
*  RELEASE WORK VECTORS FOR WIMS-AECL, WIMS-NEA, DRAGLIB
*  AND INPUT FILE
*----
        DEALLOCATE(BPAX,KPAX,MATNO,ITZEA,ITNAM)
*----
*  SELECT USED DEPLETION REACTION NAMES
*----
        ALLOCATE(HREAC(2*NREAC))
        DO 100 I=1,NREAC
          READ(NMDEPL(I),'(2A4)') (HREAC(2*(I-1)+J),J=1,2)
  100   CONTINUE
*----
*  PRINT DECAY CHAIN IF REQUIRED
*----
        IMPY=IMPX+2
        CALL LIBEPR(IMPY,NBESP,NDEPL,NSTABL,NDFI,NDFP,NREAC,NPAR,INAM,
     >              HREAC,IDR,RER,RRD,KPAR,BPAR,YIELD,IZAE)
*----
*  SAVE CHAIN
*----
        CALL LCMSIX(IPLIB,'DEPL-CHAIN',1)
        CALL LCMPUT(IPLIB,'STATE-VECTOR',NSTATE,1,ISTATE)
        NDEPL=ISTATE(1)
        CALL LCMPUT(IPLIB,'ISOTOPESDEPL',3*NDEPL,3,INAM)
        CALL LCMPUT(IPLIB,'CHARGEWEIGHT',NDEPL,1,IZAE)
        CALL LCMPUT(IPLIB,'DEPLETE-IDEN',2*NREAC,3,HREAC)
        CALL LCMPUT(IPLIB,'DEPLETE-REAC',NREAC*NDEPL,1,IDR)
        CALL LCMPUT(IPLIB,'DEPLETE-ENER',NREAC*NDEPL,2,RER)
        CALL LCMPUT(IPLIB,'DEPLETE-DECA',NDEPL,2,RRD)
        CALL LCMPUT(IPLIB,'PRODUCE-REAC',NPAR*NDEPL,1,KPAR)
        CALL LCMPUT(IPLIB,'PRODUCE-RATE',NPAR*NDEPL,2,BPAR)
        IF(NDFP.GT.0) CALL LCMPUT(IPLIB,'FISSIONYIELD',NDFI*NDFP*NBESP,
     >  2,YIELD)
        CALL LCMSIX(IPLIB,' ',2)
        CALL LCMGET(IPLIB,'STATE-VECTOR',ISTATE)
        ISTATE(11)=NDEPL
        CALL LCMPUT(IPLIB,'STATE-VECTOR',NSTATE,1,ISTATE)
*----
*  DEALLOCATE DECAY CHAIN ARRAYS
*----
        DEALLOCATE(YIELD,BPAR,KPAR,RRD,RER,IDR,IZAE,INAM)
      ELSE IF(TEXT12.EQ.';') THEN
        GO TO 200
      ELSE
        CALL XABORT('SCR: '//TEXT12//' IS AN INVALID KEYWORD.')
      ENDIF
      GO TO 20
*----
*  COPY THE SAPHYB INTO MEMORY IN ORDER TO SAVE INTERPOLATION TIME
*----
  130 CALL SCRMEM(IPSAP,IPMEM,NCAL,NMIL,NMIX,TERP,MIXC)
      CALL LCMGET(IPSAP,'DIMSAP',DIMSAP)
      MD2=DIMSAP(5)+DIMSAP(6)
*----
*  FIND THE NUMBER OF DISCONTINUITY FACTORS
*----
      NSURFD=0
      CALL LCMSIX(IPSAP,'geom',1)
      CALL LCMLEN(IPSAP,'outgeom',ILONG,ITYLCM)
      IF(ILONG.NE.0) THEN
        CALL LCMSIX(IPSAP,'outgeom',1)
        CALL LCMLEN(IPSAP,'SURF',NSURFD,ITYLCM)
        CALL LCMSIX(IPSAP,' ',2)
      ENDIF
      CALL LCMSIX(IPSAP,' ',2)
*----
*  BUILD THE INTERPOLATED MACROLIB
*----
      IF(LMACRO.AND.(MAXNIS.EQ.0)) THEN
*       build a macrolib
        CALL SCRSAP(IPLIB,IPMEM,IACCS,NMIL,NMIX,NGRP,IMPX,HEQUI,HMASL,
     1  NCAL,NSURFD,ILUPS,MIXC,TERP,LPURE,B2)
      ELSE
*       build a microlib
        IF(LMACRO)THEN
          CALL LCMOP(IPLIB,'*TEMPORARY*',0,1,0)
          IACCS=0
        ENDIF
        IF(IACCS.EQ.0)THEN
          MAXISO=MD2*NMIX
        ELSE
          CALL LCMGET(IPLIB,'STATE-VECTOR',ISTATE)
          MAXISO=MAX(MD2*NMIX,ISTATE(2))
        ENDIF
        NVTOT=NVTOT+1
        ALLOCATE(VTOT(NVTOT),YLDS(MY1,MY2,NVTOT),DECAY(MD1,MD2,NVTOT))
        IF(NVTOT.GT.1) THEN
          CALL LCMLEN(IPLIB,'VTOT_',ILONG,ITYLCM)
          IF(ILONG.NE.NVTOT-1) CALL XABORT('SCR: INVALID LENGTH: VTOT('
     1    //'2).')
          CALL LCMLEN(IPLIB,'YLDS_',ILONG,ITYLCM)
          IF(ILONG.NE.MY1*MY2*(NVTOT-1)) CALL XABORT('SCR: INVALID LEN'
     1    //'GTH: YLDS(2).')
          CALL LCMGET(IPLIB,'VTOT_',VTOT)
          IF(MY1*MY2.GT.0) CALL LCMGET(IPLIB,'YLDS_',YLDS)
          IF(MD1*MD2.GT.0) CALL LCMGET(IPLIB,'DECAYC_',DECAY)
        ENDIF
        CALL SCRLIB(MAXNIS,MAXISO,IPLIB,IPMEM,IACCS,NMIX,NGRP,IMPX,
     1  HEQUI,HMASL,NCAL,ITER,MY1,MY2,MD1,MD2,TERP,NISO,LISO,HISO,
     2  CONC,ITODO,MIXC,LRES,LPURE,ILUPS,B2,VTOT(NVTOT),YLDS(1,1,NVTOT),
     3  DECAY(1,1,NVTOT))
        CALL LCMPUT(IPLIB,'VTOT_',NVTOT,4,VTOT)
        IF(MY1*MY2.GT.0) THEN
          CALL LCMPUT(IPLIB,'YLDS_',MY1*MY2*NVTOT,4,YLDS)
        ENDIF
        IF(MD1*MD2.GT.0) THEN
          CALL LCMPUT(IPLIB,'DECAYC_',MD1*MD2*NVTOT,4,DECAY)
        ENDIF
        DEALLOCATE(VTOT,DECAY,YLDS)
        IF(LMACRO) THEN
          CALL LCMVAL(IPLIB,' ')
          CALL LCMSIX(IPLIB,'MACROLIB',1)
          CALL LCMEQU(IPLIB,KENTRY(1))
          CALL LCMSIX(IPLIB,' ',2)
          CALL LCMCL(IPLIB,2)
        ENDIF
      ENDIF
      CALL LCMCL(IPMEM,2)
      DEALLOCATE(LISO,NISO,HISO,ITODO,CONC,TERP,MIXC)
*----
*  PRINT THE STATE VECTOR
*----
      IF(IMPX.GT.0) THEN
        IF(LMACRO) THEN
          CALL LCMGET(KENTRY(1),'STATE-VECTOR',ISTATE)
          WRITE(IOUT,290) IMPX,(ISTATE(I),I=1,7),ISTATE(9),ISTATE(12)
          IF(IMPX.GT.3) CALL LCMLIB(KENTRY(1))
        ELSE
          CALL LCMGET(IPLIB,'STATE-VECTOR',ISTATE)
          WRITE(IOUT,300) IMPX,(ISTATE(I),I=1,12)
          WRITE(IOUT,310) (ISTATE(I),I=13,15),(ISTATE(I),I=17,24)
          IF(IMPX.GT.3) CALL LCMLIB(IPLIB)
        ENDIF
      ENDIF
*----
*  CONTINUE DATA PROCESSING
*----
      IF(ITER.EQ.0) THEN
        GO TO 200
      ELSE IF(ITER.EQ.1) THEN
        TEXT12='SAPHYB'
        GO TO 30
      ELSE IF(ITER.EQ.2) THEN
        TEXT12='TABLE'
        GO TO 30
      ELSE IF(ITER.EQ.3) THEN
        TEXT12='CHAIN'
        GO TO 30
      ENDIF
*----
*  LEAVE SCR:
*----
  200 RETURN
*
  290 FORMAT(/8H OPTIONS/8H -------/
     1 7H IMPX  ,I6,30H   (0=NO PRINT/1=SHORT/2=MORE)/
     2 7H NGROUP,I6,28H   (NUMBER OF ENERGY GROUPS)/
     3 7H NBMIX ,I6,39H   (NUMBER OF MIXTURES IN THE MACROLIB)/
     4 7H NANISO,I6,34H   (MAXIMUM SCATTERING ANISOTROPY)/
     5 7H NIFISS,I6,45H   (MAXIMUM NUMBER OF FISSILE ISOTOPES IN A M,
     6 7HIXTURE)/
     7 7H NEDMAC,I6,34H   (NUMBER OF CROSS SECTION EDITS)/
     8 7H ITRANC,I6,45H   (0=NO TRANSPORT CORRECTION/1=APOLLO TYPE/2,
     9 43H=RECOVER FROM LIBRARY/4=LEAKAGE CORRECTION)/
     1 7H NLG   ,I6,39H   (NUMBER OF DELAYED PRECURSOR GROUPS)/
     2 7H ILEAK ,I6,40H   (1=DIFF AVAILABLE; 2=DIFFX AVAILABLE)/
     3 7H IDF   ,I6,34H   (0=NO ADF INFO/2=FLUX GAP INFO))
  300 FORMAT(/8H OPTIONS/8H -------/
     1 7H IMPX  ,I6,30H   (0=NO PRINT/1=SHORT/2=MORE)/
     2 7H MAXMIX,I6,31H   (MAXIMUM NUMBER OF MIXTURES)/
     3 7H NBISO ,I6,36H   (NUMBER OF ISOTOPES OR MATERIALS)/
     4 7H NGRP  ,I6,28H   (NUMBER OF ENERGY GROUPS)/
     5 7H NL    ,I6,30H   (NUMBER OF LEGENDRE ORDERS)/
     6 7H ITRANC,I6,45H   (0=NO TRANSPORT CORRECTION/1=APOLLO TYPE/2,
     7 57H=RECOVER FROM LIBRARY/3=WIMS-D TYPE/4=LEAKAGE CORRECTION)/
     8 7H IPROB ,I6,23H   (0=DIRECT/1=ADJOINT)/
     9 7H ITIME ,I6,28H   (1=STEADY-STATE/2=PROMPT)/
     1 7H NLIB  ,I6,32H   (NUMBER OF SETS OF LIBRARIES)/
     2 7H NGF   ,I6,48H   (NUMBER OF FAST GROUP WITHOUT SELF-SHIELDING)/
     3 7H IGRMAX,I6,41H   (LAST GROUP INDEX WITH SELF-SHIELDING)/
     4 7H NDEPL ,I6,33H   (NUMBER OF DEPLETING ISOTOPES)/
     5 7H NCOMB ,I6,33H   (NUMBER OF DEPLETING MIXTURES))
  310 FORMAT(7H NEDMAC,I6,34H   (NUMBER OF CROSS SECTION EDITS)/
     1 7H NBMIX ,I6,23H   (NUMBER OF MIXTURES)/
     2 7H NRES  ,I6,40H   (NUMBER OF SETS OF RESONANT MIXTURES)/
     3 7H IPROC ,I6,48H   (-1=SKIP LIBRARY PROCESSING/0=DILUTION INTERP,
     4 48HOLATION/1=USE PHYSICAL TABLES/2=BUILD A DRAGLIB/,
     5 55H3=COMPUTE CALENDF TABLES/4=COMPUTE SLOWING-DOWN TABLES)/
     6 7H IMAC  ,I6,45H   (0=DO NOT/1=DO BUILD AN EMBEDDED MACROLIB)/
     7 7H NDEL  ,I6,31H   (NUMBER OF PRECURSOR GROUPS)/
     8 7H NFISS ,I6,31H   (NUMBER OF FISSILE ISOTOPES)/
     9 7H ISOADD,I6,37H   (0=COMPLETE BURNUP CHAIN/1=DO NOT)/
     1 7H MAXISM,I6,40H   (MAX. NUMBER OF ISOTOPES PER MIXTURE)/
     2 7H IPRECI,I6,34H   (CALENDF ACCURACY FLAG:1/2/3/4)/
     3 7H IDF   ,I6,47H   (0=NO INFO/1=ALBS INFO/2=FLUX GAP INFO/3=ADF,
     4 10H GAP INFO))
  320 FORMAT(/28H SCR: INTERPOLATING SAPHYB ',A12,2H'.)
      END