1 files changed, 95 insertions, 0 deletions
diff --git a/Donjon/src/HSTUMH.f b/Donjon/src/HSTUMH.f
new file mode 100644
index 0000000..e290034
--- /dev/null
+++ b/Donjon/src/HSTUMH.f
@@ -0,0 +1,95 @@
+*DECK HSTUMH                                 
+      SUBROUTINE HSTUMH(IPMAP, IPHST,  IPRINT, NCHA,   NBUN,   IDCELL,
+     >                  BURNUP )
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* To update the MAP data structure using the information
+* provided on the HISTORY data structure.
+*
+*Copyright:
+* Copyright (C) 2004 Ecole Polytechnique de Montreal.
+*
+*Author(s): 
+* E. Varin
+*
+*Parameters: input
+* IPMAP   address of the \dds{map} data structure.
+* IPHST   address of the \dds{history} data structure.
+* IPRINT  print level.
+* NCHA    number of fuel channels.                   
+* NBUN    number of bundles per channel.
+* IDCELL  cell identifier for each fuel bundle in each channel.
+*
+*Parameters: work        
+* BURNUP   burnup for each fuel bundle in each channel.
+*
+*-----------------------------------------------------------------------
+*
+      USE GANLIB
+      IMPLICIT         NONE
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      TYPE(C_PTR)      IPHST,IPMAP
+      INTEGER          IPRINT
+      INTEGER          NCHA,NBUN
+      INTEGER          IDCELL(NBUN,NCHA)
+      REAL             BURNUP(NCHA,NBUN)
+*----
+*  LOCAL PARAMETERS
+*----
+      INTEGER          IOUT
+      INTEGER          ILCMUP,ILCMDN
+      CHARACTER        NAMSBR*6
+      PARAMETER       (IOUT=6,ILCMUP=1,ILCMDN=2,NAMSBR='HSTUMH')
+*----
+*  LOCAL VARIABLES
+*---- 
+      CHARACTER        NAMP*12 
+      INTEGER          ILCMLN,ILCMTY 
+      INTEGER          IBT,ICT,ICCT
+      REAL             BITH(3)
+*----
+*  Read isotope densities on CELL TYPE
+*  if available
+*----
+      IF(IPRINT .GE. 100) THEN
+        WRITE(IOUT,6000) NAMSBR
+      ENDIF
+      CALL LCMGET(IPMAP,'BURN-DEB',BURNUP)
+      DO 10 ICT=1,NCHA
+       DO 20 IBT=1,NBUN
+        ICCT=IDCELL(IBT,ICT)
+        WRITE(NAMP,'(A4,I8.8)') 'CELL',ICCT
+        CALL LCMLEN(IPHST,NAMP,ILCMLN,ILCMTY)
+        IF(ILCMLN .EQ. 0) THEN
+          CALL XABORT(' HSTUMH: BAD CELL TYPE')
+        ELSE
+          CALL LCMSIX(IPHST,NAMP,ILCMUP)
+          CALL LCMGET(IPHST,'DEPL-PARAM  ',BITH)
+          CALL LCMSIX(IPHST,NAMP,ILCMDN)
+        ENDIF
+        IF(IPRINT .GE. 100) THEN
+          WRITE(IOUT,6001) 'CELL TYPE',ICCT
+          WRITE(IOUT,'(A6,1X,F8.3,2X,F8.3)') 'BURNUP',
+     >       BITH(2),BURNUP(ICT,IBT)
+        ENDIF 
+        BURNUP(ICT,IBT) = BITH(2)
+ 20   CONTINUE
+ 10   CONTINUE
+*----
+* Store burnup record in MAP data structure
+*----
+      CALL LCMPUT(IPMAP,'BURN-DEB',NBUN*NCHA,2,BURNUP)
+*----
+*  Return
+*----
+      RETURN
+*----
+*  FORMAT
+*----
+ 6000 FORMAT(' ****** OUTPUT FROM ',A6)
+ 6001 FORMAT(' Contents of ',A9,1X,I8) 
+      END