path: root/Donjon/src/HST.f

*DECK HST
      SUBROUTINE HST(NENTRY, HENTRY, IENTRY, JENTRY, KENTRY)
*
*-----------------------------------------------------------------------
*
*Purpose:
* To extract from or save to a \dds{history} data structure 
* the information related to various cells in a reactor.
*
*Copyright:
* Copyright (C) 2003 Ecole Polytechnique de Montreal.
*
*Author(s): 
* G. Marleau, E. Varin
*
*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:
* For HST:, the possible calling specifications  are:
* Option 1: Updating an \emph{history} structure using a \emph{map} structure
* history := HST: [ history ]  map [ :: [ (hstdim) ]  [ GET (hstpar) ] ] ;
* Option 2: Updating an \emph{history} structure using a \emph{burnup} structure
* history := HST: [ history ]  [ burnup ] [ :: [ (hstdim) ]
*   [ GET (hstpar) ] [ CELLID icha ibun [ idfuel ] [ GET (hstpar) ] ] ] ; 
* Option 3: Updating a \emph{burnup} structure using an \emph{history} structure
* burnup := HST: history [ :: [ (hstdim ] 
*    [ PUT (hstpar) ]
*    CELLID icha ibun
*    [ PUT { BREFL  (hstbrn) (hstpar) AREFL (hstbrn) (hstpar) 
*            | [ AREFL ] (hstbrn) (hstpar) } ] ] ;
* Option 4: Updating a \emph{map} data structure from the information available 
*   on an \emph{history} data structure:
* map := HST:  map  history ;
* where
*   history : name of an \emph{history} data structure. 
*   burnup  : name of a \emph{burnup} data structure. 
*   map     : name of a \emph{map} data structure. 
*   (hstdim) : structure containing the dimensions for the \emph{history} 
*     data structure.
*   CELLID  : keyword to identify the cell for which history information is 
*     to be processed.
*   icha    : channel number for which history information is to be processed. 
*   ibun    : bundle number for which history information is to be processed. 
*   idfuel  : fuel type number associated with this cell. One can associate to 
*     each fuel cell a different fuel type. By default a single fuel type is
*     defined and it fills every fuel cell. Only the initial properties of each
*     fuel type are saved. These properties are used for refueling. 
*   GET     : keyword to specify that the values of the parameters selected in 
*     (brnpar will be read from the input stream or CLE-2000 local variables
*     and stored on the \emph{history data structure.
*   PUT     : keyword to specify that the values of the parameters selected in
*     (brnpar will be read from the \emph{history data structure and
*      transferred to local CLE-2000 variables.
*   BREFL   : to specify that the information to extract from the \emph{history}
*     data structure is related to the properties of the cell before refueling 
*     takes place.
*   AREFL   : to specify that the information to extract from the \emph{history}
*     data base is related to the properties of the cell after refueling took
*     place.
*   (hstbrn) : structure containing the burnup options.
*   (hstpar) : structure containing the local parameters options.
*
*-----------------------------------------------------------------------
*
      USE GANLIB
      IMPLICIT NONE
*----
*  SUBROUTINE ARGUMENTS
*----
      INTEGER      NENTRY,IENTRY(NENTRY),JENTRY(NENTRY)
      TYPE(C_PTR)  KENTRY(NENTRY)
      CHARACTER    HENTRY(NENTRY)*12
*----
*  LOCAL PARAMETERS
*----
      INTEGER          IOUT,ILCMUP,ILCMDN,NSTATE,NTC,MAXENT
      CHARACTER        NAMSBR*6,TEXT12*12
      PARAMETER       (IOUT=6,ILCMUP=1,ILCMDN=2,NSTATE=40,
     >                 NTC=3,MAXENT=2,NAMSBR='HST   ')
      INTEGER          NSTOLD
      PARAMETER       (NSTOLD=20)
*----
*  Debug print flag
*  IDEB = 0  -> no print debug
*       > 0  -> print debug
*----
      INTEGER          IDEB 
      PARAMETER       (IDEB=0) 
*----
*  LOCAL VARIABLES
*----
      CHARACTER        CBLANK*4,SIGENT(MAXENT)*12
      INTEGER          IBLANK,NAMTMP(NTC)
      INTEGER          ISTATB(NSTATE),ISTATH(NSTATE),ISTATM(NSTATE)
      INTEGER          ILCMLN,ILCMTY 
      INTEGER          IEN,ITC,ITYPRO
      INTEGER          IKHST,IKEVO,IKMAP
      INTEGER          NCELL,IUPDC,IUPDB
      TYPE(C_PTR)      IPHST,IPEVO,IPMAP
*----
*  HISTORY Parameters
*----
      INTEGER          MAXG,MAXL,NBUNH,NCHAH,
     >                 ITSOLH,ITBURH,MAXIH,NREGH
      REAL             BUNLEN 
*----
*  BURNUP Parameters
*----
      INTEGER          ITSOLB,ITBURB,NBBTS,MAXIB
      REAL             REVOL(5)
*----
*  MAP Parameters
*----
      INTEGER          NBUNM,NCHAM,NBFUEL 
*----
*  Variables from HSTGDM
*----
      INTEGER          IPRINT,NGLO,NLOC,NBUN,NCHA,ITYRED
      CHARACTER*12     CARRED
      INTEGER          II
*----
*  MEMORY ALLOCATION
*----
      INTEGER, ALLOCATABLE, DIMENSION(:) :: NAMG,NAML,IDCELL,IDFUEL,
     > IREFUS
      REAL, ALLOCATABLE, DIMENSION(:) :: PARAG,PARAL,REFUT,DENI,POWR,
     > BURN
*----
*  initialize blank signatures
*----
      DO 100 IEN=1,MAXENT
        SIGENT(IEN)='            '
 100  CONTINUE
      CBLANK='    '
      READ(CBLANK,'(A4)') IBLANK
      ISTATB(:NSTATE)=0
      ISTATH(:NSTATE)=0
      ISTATM(:NSTATE)=0
*----
*  PARAMETER VALIDATION.
*  1 or 2 data structures permitted
*  If one data structure it must be an 
*  HISTORY structure, 
*  If two data structure, one of them must be and history
*  while the second one can be a BURNUP or MAP structure
*  Options:
*  2)   [History] := HST: [History] [Burnup] :: ... ;
*  3)    History  := HST: [History] Map      :: ... ;
*  3)    Burnup   := HST: History            :: ... ;
*---- 
      IF(NENTRY .EQ. 0) THEN
        CALL XABORT(NAMSBR//
     >': At least one data structure expected.')
      ELSE IF(NENTRY .GT. MAXENT) THEN
        CALL XABORT(NAMSBR//
     >': Maximum number of structures exceeded.')
      ENDIF
      DO 110 IEN=1,NENTRY
        TEXT12=HENTRY(IEN)
        IF(IENTRY(IEN) .NE. 1 .AND. IENTRY(IEN) .NE. 2)
     >  CALL XABORT(NAMSBR//
     >': Data structure '//TEXT12//' must be of type LCM or XSM.')
 110  CONTINUE
      IEN = 1 
      IF(JENTRY(IEN) .EQ. 2 ) THEN
        IF(NENTRY .EQ. 2) CALL XABORT(NAMSBR//
     >    ': First data structure must be in create or update mode.')
        CALL LCMLEN(KENTRY(IEN),'SIGNATURE',ILCMLN,ILCMTY)
        IF(ILCMLN .GT. 0) THEN
          CALL LCMGET(KENTRY(IEN),'SIGNATURE',NAMTMP)
          WRITE(SIGENT(IEN),'(3A4)') (NAMTMP(ITC),ITC=1,NTC)
        ENDIF
      ELSE IF(JENTRY(IEN) .EQ. 1 ) THEN
        CALL LCMLEN(KENTRY(IEN),'SIGNATURE',ILCMLN,ILCMTY)
        IF(ILCMLN .GT. 0) THEN
          CALL LCMGET(KENTRY(IEN),'SIGNATURE',NAMTMP)
          WRITE(SIGENT(IEN),'(3A4)') (NAMTMP(ITC),ITC=1,NTC)
        ENDIF
      ENDIF
      IF(NENTRY .EQ. 2) THEN 
        IEN = 2 
        IF(JENTRY(IEN) .NE. 2 ) CALL XABORT(NAMSBR//
     >    ': Second data structure must be in read-only mode.')
        CALL LCMLEN(KENTRY(IEN),'SIGNATURE',ILCMLN,ILCMTY)
        IF(ILCMLN .LE. 0) CALL XABORT(NAMSBR//
     >': No signature found on second data structure')
        CALL LCMGET(KENTRY(IEN),'SIGNATURE',NAMTMP) 
        WRITE(SIGENT(IEN),'(3A4)') (NAMTMP(ITC),ITC=1,NTC)
      ENDIF
      IKHST=0
      IKEVO=0
      IKMAP=0
      DO 111 IEN=1,NENTRY
        IF     (SIGENT(IEN) .EQ. 'L_HISTORY   ') THEN
          IF(IKHST .NE. 0) CALL XABORT(NAMSBR//
     >      ': Two history structure forbidden.')
          IKHST=IEN
        ELSE IF(SIGENT(IEN) .EQ. 'L_BURNUP    ') THEN 
          IF(IKEVO .NE. 0) CALL XABORT(NAMSBR//
     >      ': Two burnup structure forbidden.')
          IKEVO=IEN
        ELSE IF(SIGENT(IEN) .EQ. 'L_MAP       ') THEN 
          IF(IKMAP .NE. 0) CALL XABORT(NAMSBR//
     >      ': Two map structure forbidden.')
          IKMAP=IEN
        ELSE IF(SIGENT(IEN) .NE. '            ') THEN
          CALL XABORT(NAMSBR//
     >    ': At least on structure type is invalid.')
        ENDIF
 111  CONTINUE
      BUNLEN=1.0
*----
*  For structures with SIGNATURE read STATE-VECTOR
*----
      IF(IKHST .GT. 0) THEN
        CALL LCMGET(KENTRY(IKHST),'STATE-VECTOR',ISTATH)
        CALL LCMGET(KENTRY(IKHST),'BUNDLELENGTH',BUNLEN)
      ENDIF 
      IF(IKEVO .GT. 0) THEN
        CALL LCMGET(KENTRY(IKEVO),'STATE-VECTOR',ISTATB)
        CALL LCMGET(KENTRY(IKEVO),'EVOLUTION-R ',REVOL)
      ENDIF 
      IF(IKMAP .GT. 0) THEN
        CALL LCMGET(KENTRY(IKMAP),'STATE-VECTOR',ISTATM)
      ENDIF 
*----
*  Select type of processing depending
*  on order of structures
*  ITYPRO =  1 : History := HST:                  ::
*  ITYPRO =  2 : History := HST: History          ::
*  ITYPRO =  3 : History := HST: Burnup           ::
*  ITYPRO =  4 : History := HST: History Burnup   ::
*  ITYPRO =  5 : History := HST: Map              ::
*  ITYPRO =  6 : History := HST: History Map      ::
*  ITYPRO = -1 :         := HST: History          ::
*  ITYPRO = -3 : Burnup  := HST: History          ::
*  ITYPRO = -4 : Burnup  := HST: Burnup History   ::
*  ITYPRO = -5 : Map     := HST: Map  History     ::
*----
      IF(NENTRY .EQ. 1) THEN
        IF(IKEVO .NE. 0 .OR. IKMAP .NE. 0) CALL XABORT(NAMSBR//
     >  ': A single burnup or map structure forbidden.')
        IF(IKHST .EQ. 1) THEN
          ITYPRO=2
          IF(JENTRY(1) .EQ. 2) THEN
            ITYPRO=-1
          ENDIF
        ELSE
          IKHST=1
          ITYPRO=1
          SIGENT(IKHST)='L_HISTORY   '
          READ(SIGENT(IKHST),'(3A4)') (NAMTMP(ITC),ITC=1,NTC)
          CALL LCMPUT(KENTRY(IKHST),'SIGNATURE',NTC,3,NAMTMP)
        ENDIF
      ELSE
        IF(IKHST .EQ. 2) THEN
          IF(IKMAP .EQ. 1) THEN
            ITYPRO = -5
          ELSE IF(IKEVO .EQ. 1) THEN
            ITYPRO=-4
          ELSE 
            ITYPRO=-3
            IKEVO=1 
            SIGENT(IKEVO)='L_BURNUP    '
            READ(SIGENT(IKEVO),'(3A4)') (NAMTMP(ITC),ITC=1,NTC)
            CALL LCMPUT(KENTRY(IKEVO),'SIGNATURE',NTC,3,NAMTMP)
          ENDIF
        ELSE IF(IKEVO.EQ.2) THEN
          IF(IKHST .EQ. 1) THEN
            ITYPRO=4
          ELSE
            ITYPRO=3
            IKHST=1 
            SIGENT(IKHST)='L_HISTORY   '
            READ(SIGENT(IKHST),'(3A4)') (NAMTMP(ITC),ITC=1,NTC)
            CALL LCMPUT(KENTRY(IKHST),'SIGNATURE',NTC,3,NAMTMP)
          ENDIF
        ELSE IF(IKMAP.EQ.2) THEN
          IF(IKHST .EQ. 1) THEN
            ITYPRO=6
          ELSE
            ITYPRO=5
            IKHST=1 
            SIGENT(IKHST)='L_HISTORY   '
            READ(SIGENT(IKHST),'(3A4)') (NAMTMP(ITC),ITC=1,NTC)
            CALL LCMPUT(KENTRY(IKHST),'SIGNATURE',NTC,3,NAMTMP)
          ENDIF
        ELSE
          CALL XABORT(NAMSBR//
     >    ': A read-only burnup or map structure required.')
        ENDIF
      ENDIF
      IF(IKHST .NE. 0) IPHST=KENTRY(IKHST)
      IF(IKEVO .NE. 0) IPEVO=KENTRY(IKEVO)
      IF(IKMAP .NE. 0) IPMAP=KENTRY(IKMAP)
*----
*  Get elements of HISTORY STATE-VECTOR
*----
      MAXG  =ISTATH( 1)
      MAXL  =ISTATH( 2)
      NBUNH =ISTATH( 3)
      NCHAH =ISTATH( 4)
      ITSOLH=ISTATH( 6)
      ITBURH=ISTATH( 7)
      MAXIH =ISTATH( 8)
      NREGH =ISTATH(10)
      IF(IDEB .EQ. 1) THEN
        WRITE(IOUT,7000) (ISTATH(II),II=1,8),ISTATH(10)
      ENDIF
*----
*  Get elements of BURNUP STATE-VECTOR
*----
      ITSOLB=ISTATB(1)
      ITBURB=ISTATB(2)
      NBBTS =ISTATB(3)
      MAXIB =ISTATB(4)
      IF(IDEB .EQ. 1) THEN
        WRITE(IOUT,7001) (ISTATB(II),II=1,6)
      ENDIF
      IF(ITYPRO .EQ. 3 .OR. ITYPRO .EQ. 4) THEN
        ITSOLH=ITSOLB
        ITBURH=ITBURB
        IF(MAXIH .NE. 0 .AND. MAXIH .NE. MAXIB) CALL XABORT(NAMSBR//
     >  ': Different number of isotopes in history and burnup')
        MAXIH=MAXIB
      ELSE IF(ITYPRO .EQ. -3 .OR. ITYPRO .EQ. -4) THEN
        ITSOLB=ITSOLH
        ITBURB=ITBURH
        IF(MAXIB .NE. 0 .AND. MAXIB .NE. MAXIH) CALL XABORT(NAMSBR//
     >  ': Different number of isotopes in history and burnup')
        MAXIB=MAXIH
      ENDIF 
*----
*  Get elements of MAP STATE-VECTOR
*  and verify consistency with history information
*----
      NBUNM =ISTATM(1)
      NCHAM =ISTATM(2)
      IF(NBUNM .NE. 0) THEN
        IF(NBUNH .EQ. 0) THEN
          NBUNH=NBUNM
        ELSE IF(NBUNH .NE. NBUNM) THEN 
          CALL XABORT(NAMSBR//': Different number of bundles in'//
     >                        ' MAP and HISTORY structures')
        ENDIF
      ENDIF
      IF(NCHAM .NE. 0) THEN
        IF(NCHAH .EQ. 0) THEN
          NCHAH=NCHAM
        ELSE IF(NCHAH .NE. NCHAM) THEN 
          CALL XABORT(NAMSBR//': Different number of channels in'//
     >                        ' MAP and HISTORY structures')
        ENDIF
      ENDIF
*----
*  Test compatibility of HISTORY, BURNUP and MAP data structures.
*---- 
      IF(ITYPRO .EQ.  4 .OR. ITYPRO .EQ. -4) THEN
        IF(ITSOLB .NE. ITSOLH .OR. 
     >     ITBURB .NE. ITBURH .OR.
     >     MAXIB  .NE. MAXIH  ) CALL XABORT(NAMSBR//
     >    ': HISTORY and BURNUP parameters incompatible')
      ELSE IF(ITYPRO .EQ.  6) THEN
        IF(NBUNM  .NE. NBUNH .OR. 
     >     NCHAM  .NE. NCHAH      ) CALL XABORT(NAMSBR//
     >    ': HISTORY and MAP parameters incompatible')
      ENDIF
*----
*  Get EDIT level and dimensioning parameters for history structure
*  and test their validity
*----
      IPRINT=1
      NGLO  =MAXG
      NLOC  =MAXL
      NBUN  =NBUNH
      NCHA  =NCHAH
      CALL HSTGDM(IPRINT,NGLO  ,NLOC  ,NCHA  ,NBUN  ,
     >            BUNLEN,ITYRED,CARRED)
*----
*  Test dimensioning parameters for coherence
*  with already defined parameters
*----
      MAXG=MAX(MAXG,NGLO)
      MAXL=MAX(MAXL,NLOC)
      IF(NBUN .LE. 0 ) CALL XABORT(NAMSBR// 
     >': Number of bundles must be larger than 0')
      IF(NCHA .LE. 0 ) CALL XABORT(NAMSBR// 
     >': Number of channels must be larger than 0')
      IF(NBUNH .GT. 0 .AND. NBUN .NE. NBUNH) CALL XABORT(NAMSBR// 
     >': Number of bundles on input'//
     >' different from HISTORY, MAP or BURNUP structures')
      NBUNH=MAX(NBUN,NBUNH)
      IF(NCHAH .GT. 0 .AND. NCHA .NE. NCHAH) CALL XABORT(NAMSBR// 
     >': Number of channels on input'//
     >' different from HISTORY, MAP or BURNUP structures')
      NCHAH=MAX(NCHA,NCHAH)
      IF(IPRINT .GE. 10) THEN
        WRITE(IOUT,6010) NGLO,NLOC,NCHA,NBUN
      ENDIF
*----
* Allocate memory for global and local parameters
*---- 
      ALLOCATE(NAMG(3*(MAXG+1)),PARAG(MAXG+1),NAML(3*(MAXL+1)),
     > PARAL((MAXL+1)*2))
      NAMG(:3*(MAXG+1))=IBLANK
      PARAG(:MAXG+1)=0.0
      NAML(:3*(MAXL+1))=IBLANK
      IF(ISTATH(1) .GT. 0) THEN
        CALL LCMGET(IPHST,'NAMEGLOBAL  ',NAMG(4))
        CALL LCMGET(IPHST,'PARAMGLOBAL ',PARAG(2))
        IF(IDEB .GE. 1) THEN 
          WRITE(IOUT,'(A18,2I10)') 'Initial NAMEGLOBAL',MAXG,ISTATH(1) 
          WRITE(IOUT,'(6(3A4,2X))') (NAMG(3+II),II=1,3*MAXG) 
        ENDIF
      ENDIF
      IF(ISTATH(2) .GT. 0) THEN
        CALL LCMGET(IPHST,'NAMELOCAL   ',NAML(4))
        IF(IDEB .GE. 1) THEN 
          WRITE(IOUT,'(A18,2I10)') 'Initial NAMELOCAL ',MAXL,ISTATH(2) 
          WRITE(IOUT,'(6(3A4,2X))') (NAML(3+II),II=1,3*MAXL) 
        ENDIF
      ENDIF
      IF(NCHAH .LT. 1 .OR. NBUNH .LT. 1 ) CALL XABORT(NAMSBR//
     >': Both the number of channels and bundles must be > 0')
*----
*  Allocate memory for core description
*----
      NCELL=NCHAH*NBUNH
      IF(IPRINT .GE. 10) THEN
        WRITE(IOUT,6011) NCELL,NCHAH,MAXIH
      ENDIF
      ALLOCATE(IDCELL(NCELL),IDFUEL(NCELL),IREFUS(NCHAH),REFUT(NCHAH))
      IDCELL(:NCELL)=0
      IDFUEL(:NCELL)=0
      IF(ISTATH( 3)*ISTATH( 4) .GT. 0) THEN
        CALL LCMGET(IPHST,'CELLID      ',IDCELL)
        CALL LCMGET(IPHST,'FUELID      ',IDFUEL)
      ENDIF
      IREFUS(:NCHAH)=0
      REFUT(:NCHAH)=0.0
      ALLOCATE(DENI(MAXIH+1))
      NBFUEL=0
*----
*  Allocate memory for MAP power
*----
      ALLOCATE(POWR(NCELL),BURN(NCELL))
      POWR(:NCELL)=0.0
      BURN(:NCELL)=0.0
      IF(ITYPRO .EQ. 5 .OR. ITYPRO .EQ. 6) THEN
*----
*  Read information from MAP data structure
*  and update history using this information
*---- 
        CALL HSTUHM(IPHST, IPMAP, IPRINT, MAXL, NCHAH ,NBUNH, MAXIH,
     >              POWR,BURN,IREFUS,
     >              REFUT,BUNLEN,IDCELL,IDFUEL,PARAL,DENI)        
*----
* Update Map with History
*---- 
      ELSE IF(ITYPRO .EQ. -5) THEN
        CALL HSTUMH(IPMAP, IPHST, IPRINT,NCHAH ,NBUNH, IDCELL, BURN)
      ENDIF
*----
*  Release memory for MAP power
*----
      DEALLOCATE(BURN,POWR)
*----
*  Read or write remaining information on input
*  Also extract information from history if required
*----
      CALL HSTGET(IPHST ,IPRINT,MAXG  ,MAXL  ,NCHAH ,NBUNH ,
     >            ITYPRO,ITYRED,CARRED,IUPDC ,IUPDB ,
     >            NAMG ,PARAG,NAML ,
     >            PARAL,IDCELL,IDFUEL)
      IF(ITYPRO .GT. 0) THEN
        IF(MAXG .GT. 0) THEN
          CALL LCMPUT(IPHST,'NAMEGLOBAL  ',3*MAXG,3,NAMG(4))
          CALL LCMPUT(IPHST,'PARAMGLOBAL ',  MAXG,2,PARAG(2))
          IF(IDEB .GE. 1) THEN 
            WRITE(IOUT,'(A18,2I10)') 'Final NAMEGLOBAL  ',MAXG,ISTATH(1)
            WRITE(IOUT,'(6(3A4,2X))') (NAMG(3+II),II=1,3*MAXG) 
          ENDIF
        ENDIF
        IF(MAXL .GT. 0) THEN
          CALL LCMPUT(IPHST,'NAMELOCAL   ',3*MAXL,3,NAML(4))
          IF(IDEB .GE. 1) THEN 
            WRITE(IOUT,'(A18,2I10)') 'Final NAMELOCAL   ',MAXL,ISTATH(2)
            WRITE(IOUT,'(6(3A4,2X))') (NAML(3+II),II=1,3*MAXL) 
          ENDIF
        ENDIF
        IF(NCELL .GT. 0) THEN
          CALL LCMPUT(IPHST,'CELLID      ',NCELL,1,IDCELL)
          CALL LCMPUT(IPHST,'FUELID      ',NCELL,1,IDFUEL)
        ENDIF
      ENDIF
*----
*  If channel and bundle specified
*  Update information on HISTORY or BURNUP structures
*----
      IF(IUPDC .GT. 0 .AND. IUPDB .GT. 0) THEN
*----
*  Allocate memory for isotopes and burnup
*----
        IF(IPRINT .GE. 10) THEN
          WRITE(IOUT,6000) NAMSBR,IUPDC,IUPDB 
        ENDIF
        IF(ITYPRO .EQ. 3 .OR. ITYPRO .EQ. 4) THEN
*----
*  Update HISTORY information from BURNUP data for 
*  channel IUPDC, bundle IUPDB.
*---- 
          IF(IPRINT .GE. 10) THEN
            WRITE(IOUT,6001) 
          ENDIF
          CALL HSTUHB(IPHST ,IPEVO ,IPRINT,MAXIH ,NBBTS ,
     >                NCHAH ,NBUNH ,IUPDC ,IUPDB ,
     >                IDCELL,IDFUEL,
     >                DENI ,MAXL, PARAL) 
        ELSE IF(ITYPRO .EQ. -3 .OR. ITYPRO .EQ. -4) THEN
*----
*  Update BURNUP information from HISTORY data for 
*  channel IUPDC, bundle IUPDB.
*---- 
          IF(IPRINT .GE. 10) THEN
            WRITE(IOUT,6002) 
          ENDIF
          CALL HSTUBH(IPEVO ,IPHST ,IPRINT,MAXIH ,NBBTS ,
     >                NCHAH ,NBUNH ,IUPDC ,IUPDB ,
     >                IDCELL,IDFUEL,DENI)
        ENDIF 
      ENDIF
      DEALLOCATE(DENI,REFUT,IREFUS,IDFUEL,IDCELL,PARAL,NAML,PARAG,NAMG)
      IF(ITYPRO .GT. 0) THEN
*----
*  Saving updated HISTORY state vector
*----
        CALL LCMPUT(IPHST,'BUNDLELENGTH',1,2,BUNLEN)
        ISTATH(:NSTATE)=0
        ISTATH( 1) = MAXG  
        ISTATH( 2) = MAXL  
        ISTATH( 3) = NBUNH 
        ISTATH( 4) = NCHAH 
        ISTATH( 5) = 0 
        ISTATH( 6) = ITSOLH
        ISTATH( 7) = ITBURH
        ISTATH( 8) = MAXIH 
        ISTATH(10) = NREGH
        IF(IPRINT .EQ. 10) THEN
          WRITE(IOUT,7010) (ISTATH(II),II=1,8),ISTATH(10)
        ENDIF
        CALL LCMPUT(IPHST,'STATE-VECTOR',NSTATE,1,ISTATH)
      ELSE IF(ITYPRO .EQ. -3 .OR. ITYPRO .EQ. -4 )  THEN
*----
*  Set burnup parameters to default values
*  See subroutine EVO.f
*----
        REVOL(1)=1.0E-5 
        REVOL(2)=1.0E-4 
        REVOL(3)=80.0   
        REVOL(4)=1.0E-4 
        REVOL(5)=0.0 
        CALL LCMPUT(IPEVO,'EVOLUTION-R ',5,2,REVOL)
*----
*  Saving updated BURNUP state vector
*----
        ISTATB(:NSTATE)=0
        ISTATB( 1) = ITSOLB 
        ISTATB( 2) = ITBURB 
        IF(ISTATB( 1) .EQ. 0) ISTATB( 1) = 2
        IF(ISTATB( 2) .EQ. 0) ISTATB( 2) = 2
        ISTATB( 3) = 1 
        ISTATB( 4) = MAXIH 
        ISTATB( 8) = NCHA*NBUN
        IF(IPRINT .GT. 1) THEN
          WRITE(IOUT,7011) (ISTATB(II),II=1,8)
        ENDIF
        CALL LCMPUT(IPEVO,'STATE-VECTOR',NSTOLD,1,ISTATB)
      ENDIF
*----
*  Module execution completed
*----
      RETURN
*----
*  FORMATS
*----
 6000 FORMAT(' ***** OUTPUT FROM ',A6/
     >' Processing: Channel ',I10,5X,'Bundle ',I10) 
 6001 FORMAT(' Updating HISTORY from BURNUP')
 6002 FORMAT(' Updating BURNUP from HISTORY')
 6010 FORMAT(' ***** General dimensioning '/
     >       10X,'NGLO  =',I10,5X,'NLOC   =',I5/
     >       10X,'NCHA  =',I10,5X,'NBUN   =',I5)
 6011 FORMAT(10X,'NCELL =',I10,5X,'NCHAH  =',I5/
     >       10X,'MAXIH =',I10)
 7000 FORMAT(' Initial contents of HISTORY state vector'/
     >5X,'MAXG  = ',I5,5X,'MAXL  = ',I5,5X,'NBUNH = ',I5,/
     >5X,'NCHAH = ',I5,5X,'      = ',I5,5X,'ITSOLH= ',I5,/
     >5X,'ITBURH= ',I5,5X,'MAXIH = ',I5,5X,'NREGH = ',I5) 
 7001 FORMAT(' Initial contents of BURNUP state vector'/
     >5X,'ITSOL = ',I5,5X,'ITBUR = ',I5,5X,'NBBTS = ',I5,/
     >5X,'MAXI  = ',I5,5X,'NGRP  = ',I5,5X,'NREG  = ',I5)
 7010 FORMAT(' Final contents of HISTORY state vector'/
     >5X,'MAXG  = ',I5,5X,'MAXL  = ',I5,5X,'NBUNH = ',I5,/
     >5X,'NCHAH = ',I5,5X,'      = ',I5,5X,'ITSOLH= ',I5,/
     >5X,'ITBURH= ',I5,5X,'MAXIH = ',I5,5X,'NREGH = ',I5) 
 7011 FORMAT(' Final contents of BURNUP state vector'/
     >5X,'ITSOL = ',I5,5X,'ITBUR = ',I5,5X,'NBBTS = ',I5,/
     >5X,'MAXI  = ',I5,5X,'      = ',I5,5X,'      = ',I5,/
     >5X,'      = ',I5,5X,'NBMIX = ',I5) 
      END