1 files changed, 119 insertions, 0 deletions
diff --git a/Dragon/src/SPHSTM.f b/Dragon/src/SPHSTM.f
new file mode 100644
index 0000000..c1b98cb
--- /dev/null
+++ b/Dragon/src/SPHSTM.f
@@ -0,0 +1,119 @@
+*DECK SPHSTM
+      SUBROUTINE SPHSTM(IPAPX,ICAL,IMPX,LNEW,HEQUI,HEDIT,NMIL,NGROUP,
+     1 SPH)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Store a new set of SPH factors for an elementary calculation in a
+* MPO file.
+*
+*Copyright:
+* Copyright (C) 2022 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): A. Hebert
+*
+*Parameters: input
+* IPAPX   pointer to the MPO file.
+* ICAL    index of the elementary calculation being considered.
+* IMPX    print parameter (equal to zero for no print).
+* LNEW    flag set to .TRUE. to allow the overwriting of the existing
+*         set of SPH factors named HEQUI.
+* HEQUI   LOCKEY name of SPH-factor set to be stored.
+* HEDIT   name of output group for a (multigroup mesh, output geometry)
+*         couple (generally equal to 'output_0').
+* NMIL    number of mixtures in the elementary calculation.
+* NGROUP  number of energy groups in the elementary calculation.
+* SPH     SPH-factor set to be stored the MPO file.
+*
+*-----------------------------------------------------------------------
+*
+      USE GANLIB
+      USE hdf5_wrap
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      TYPE(C_PTR) IPAPX
+      INTEGER ICAL,IMPX,NMIL,NGROUP
+      REAL SPH(NMIL,NGROUP)
+      LOGICAL LNEW
+      CHARACTER(LEN=80) HEQUI
+      CHARACTER(LEN=12) HEDIT
+*----
+*  LOCAL VARIABLES
+*----
+      CHARACTER RECNAM*80
+*----
+*  SLLOCATABLE ARRAYS
+*----
+      INTEGER, ALLOCATABLE, DIMENSION(:) :: LOCAD,LOCA_OLD
+      REAL, ALLOCATABLE, DIMENSION(:) :: RVALO,RVALO_OLD
+      CHARACTER(LEN=80), ALLOCATABLE, DIMENSION(:) :: LOCTYP,LOCKEY,
+     & LOCTYP_OLD,LOCKEY_OLD
+*----
+*  RECOVER MPO FILE CHARACTERISTICS
+*----
+      NLOC_OLD=0
+      IF(hdf5_group_exists(IPAPX,"/local_values/")) THEN
+        CALL hdf5_read_data(IPAPX,"local_values/LOCVALTYPE",LOCTYP_OLD)
+        CALL hdf5_read_data(IPAPX,"local_values/LOCVALNAME",LOCKEY_OLD)
+        NLOC_OLD=SIZE(LOCTYP_OLD,1)
+        NLOC=NLOC_OLD
+        DO ILOC=1,NLOC_OLD
+          IF((LOCTYP_OLD(ILOC).EQ.'EQUI').AND.
+     &                  (LOCKEY_OLD(ILOC).EQ.HEQUI)) THEN
+*           SET HEQUI EXISTS.
+            IF(LNEW) THEN
+              IF(IMPX.GT.0) WRITE(6,'(28H SPHSTM: OVERWRITE SPH-FACTO,
+     &        12HR SET NAMED ,A)') HEQUI
+              JLOC=ILOC
+              GO TO 10
+            ELSE
+              CALL XABORT('SPHSTM: THIS SPH FACTOR SET EXISTS: '//HEQUI)
+            ENDIF
+          ENDIF
+        ENDDO
+      ENDIF
+      NLOC=NLOC_OLD+1
+      JLOC=NLOC
+   10 ALLOCATE(LOCTYP(NLOC),LOCKEY(NLOC))
+      IF(NLOC_OLD.GT.0) THEN
+        LOCTYP(:NLOC_OLD)=LOCTYP_OLD(:NLOC_OLD)
+        LOCKEY(:NLOC_OLD)=LOCKEY_OLD(:NLOC_OLD)
+        DEALLOCATE(LOCKEY_OLD,LOCTYP_OLD)
+      ENDIF
+      LOCTYP(JLOC)='EQUI'
+      LOCKEY(JLOC)=HEQUI
+      CALL hdf5_delete(IPAPX,"local_values/LOCVALTYPE")
+      CALL hdf5_delete(IPAPX,"local_values/LOCVALNAME")
+      CALL hdf5_write_data(IPAPX,"local_values/LOCVALTYPE",LOCTYP)
+      CALL hdf5_write_data(IPAPX,"local_values/LOCVALNAME",LOCKEY)
+*----
+*  LOOP OVER MIXTURES.
+*----
+      DO IBM=1,NMIL
+        WRITE(RECNAM,'(8H/output/,A,9H/statept_,I0,6H/zone_,I0,1H/)')
+     &  TRIM(HEDIT),ICAL-1,IBM-1
+        CALL hdf5_read_data(IPAPX,TRIM(RECNAM)//"LOCVALADDR",LOCA_OLD)
+        CALL hdf5_read_data(IPAPX,TRIM(RECNAM)//"LOCALVALUE",RVALO_OLD)
+        ALLOCATE(LOCAD(NLOC+1))
+        LOCAD(:NLOC_OLD+1)=LOCA_OLD(:NLOC_OLD+1)
+        LOCAD(JLOC+1)=LOCAD(JLOC)+NGROUP
+        ALLOCATE(RVALO(LOCAD(NLOC+1)))
+        RVALO(:LOCA_OLD(NLOC_OLD+1))=RVALO_OLD(:LOCA_OLD(NLOC_OLD+1))
+        DEALLOCATE(LOCA_OLD,RVALO_OLD)
+        DO IGR=1,NGROUP
+          RVALO(LOCAD(JLOC)+IGR)=SPH(IBM,IGR)
+        ENDDO
+        CALL hdf5_delete(IPAPX,TRIM(RECNAM)//"LOCVALADDR")
+        CALL hdf5_delete(IPAPX,TRIM(RECNAM)//"LOCALVALUE")
+        CALL hdf5_write_data(IPAPX,TRIM(RECNAM)//"LOCVALADDR",LOCAD)
+        CALL hdf5_write_data(IPAPX,TRIM(RECNAM)//"LOCALVALUE",RVALO)
+        DEALLOCATE(RVALO,LOCAD)
+      ENDDO
+      RETURN
+      END