Initial commit from Polytechnique Montreal

1 files changed, 622 insertions, 0 deletions

diff --git a/Donjon/src/HST.f b/Donjon/src/HST.f
new file mode 100644
index 0000000..16ba333
--- /dev/null
+++ b/Donjon/src/HST.f
@@ -0,0 +1,622 @@
+*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