Initial commit from Polytechnique Montreal

1 files changed, 215 insertions, 0 deletions

diff --git a/Dragon/src/MPOTOC.f b/Dragon/src/MPOTOC.f
new file mode 100644
index 0000000..be1067e
--- /dev/null
+++ b/Dragon/src/MPOTOC.f
@@ -0,0 +1,215 @@
+*DECK MPOTOC
+      SUBROUTINE MPOTOC(IPMPO,HEDIT,IMPX,NREA,NBISO,NMIL,NPAR,NLOC,
+     1 NISOF,NISOP,NISOS,NCAL,NGRP,NSURFD,NALBP,NPRC)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Recover the table of content of an MPO file.
+*
+*Copyright:
+* Copyright (C) 2022 Ecole Polytechnique de Montreal
+*
+*Author(s): 
+* A. Hebert
+*
+*Parameters: input
+* IPMPO   address of the MPO file.
+* HEDIT   name of output group for a (multigroup mesh, output geometry)
+*         couple (generally equal to 'output_0').
+* IMPX    print parameter (equal to zero for no print).
+*
+*Parameters: output
+* NREA    number of neutron-induced reaction
+* NBISO   number of particularized isotopes
+* NMIL    number of mixtures in the MPO file
+* NPAR    number of global parameters
+* NLOC    number of local parameters
+* NISOF   number of particularized fissile isotopes
+* NISOP   number of particularized fission products
+* NISOS   number of particularized stable isotopes
+* NCAL    number of elementary calculations
+* NGRP    number of energy groups
+* NSURFD  number of discontinuity factors values in the MPO file
+* NALBP   number of physical albedos per energy group
+* NPRC    number of precursors
+*
+*-----------------------------------------------------------------------
+*
+      USE GANLIB
+      USE hdf5_wrap
+      IMPLICIT NONE
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      TYPE(C_PTR) IPMPO
+      INTEGER IMPX,NREA,NBISO,NMIL,NPAR,NLOC,NISOF,NISOP,NISOS,NCAL,
+     1 NGRP,NSURFD,NALBP,NPRC
+      CHARACTER(LEN=12) HEDIT
+*----
+*  LOCAL VARIABLES
+*----
+      INTEGER, PARAMETER::IOUT=6
+      INTEGER I,J,NENERG,NGEOME,ID_G,ID_E,ID,IBM,NGRP2,RANK,TYPE,NBYTE,
+     1 DIMSR(5)
+      CHARACTER HSMG*131,RECNAM*80,HFORMAT*132
+      LOGICAL LNEW
+      CHARACTER(LEN=100), ALLOCATABLE, DIMENSION(:) :: LIST
+      INTEGER, ALLOCATABLE, DIMENSION(:) :: DIMS_MPO,ADDRISO
+      INTEGER, ALLOCATABLE, DIMENSION(:,:) :: OUPUTID
+*----
+*  LIST GROUPS AND DATASETS ON THE ROOT FILE
+*----
+      IF(IMPX.GT.0) THEN
+        CALL hdf5_list_groups(IPMPO, '/', LIST)
+        WRITE(*,*)
+        WRITE(*,*) 'MPOTOC: GROUP TABLE OF CONTENTS'
+        DO I=1,SIZE(LIST)
+          WRITE(*,*) TRIM(LIST(I))
+        ENDDO
+        DEALLOCATE(LIST)
+      ENDIF
+*----
+*  RECOVER MPO PARAMETERS
+*----
+      ID_G=-1
+      ID_E=-1
+      CALL hdf5_read_data(IPMPO,"/parameters/tree/NSTATEPOINT",NCAL)
+      CALL hdf5_read_data(IPMPO,"/energymesh/NENERGYMESH",NENERG)
+      CALL hdf5_read_data(IPMPO,"/geometry/NGEOMETRY",NGEOME)
+      IF((NENERG.GT.0).AND.(NGEOME.GT.0)) THEN
+        CALL hdf5_read_data(IPMPO,"/output/OUPUTID",OUPUTID)
+        READ(HEDIT,'(7X,I2)') ID
+        DO I=1,NGEOME
+          DO J=1,NENERG
+            IF(OUPUTID(J,I).EQ.ID) THEN
+              ID_G=I-1
+              ID_E=J-1
+              GO TO 10
+            ENDIF
+          ENDDO
+        ENDDO
+        CALL XABORT('MPOTOC: no ID found in /output/OUPUTID.')
+   10   WRITE(RECNAM,'(23H/energymesh/energymesh_,I0,1H/)') ID_E
+        IF(IMPX.GT.1) THEN
+          HFORMAT='(/42H MPOTOC: Process MPO multiparameter file o,'//
+     >    '9Hn output=,A)'
+          WRITE(IOUT,HFORMAT) TRIM(HEDIT)
+          WRITE(IOUT,'(24H MPOTOC:   energy group=,A)') TRIM(RECNAM)
+        ENDIF
+        CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"NG",NGRP2)
+        IF(NGRP.EQ.0) THEN
+          NGRP=NGRP2
+        ELSE IF(NGRP2.NE.NGRP) THEN
+          WRITE(HSMG,'(44H MPOTOC: THE MPO FILE HAS AN INVALID NUMBER ,
+     1    18HOF ENERGY GROUPS (,I4,3H VS,I5,2H).)') NGRP2,NGRP
+          CALL XABORT(HSMG)
+        ENDIF
+        DEALLOCATE(OUPUTID)
+        WRITE(RECNAM,'(19H/geometry/geometry_,I0,1H/)') ID_G
+        IF(IMPX.GT.1) THEN
+          WRITE(IOUT,'(24H MPOTOC: geometry group=,A)') TRIM(RECNAM)
+        ENDIF
+        CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"NZONE",NMIL)
+      ENDIF
+      WRITE(RECNAM,'(8H/output/,A,6H/info/)') TRIM(HEDIT)
+      CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"NREA",NREA)
+      CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"ADDRISO",ADDRISO)
+      NBISO=ADDRISO(SIZE(ADDRISO,1))
+*----
+*  SET NPAR
+*----
+      NPAR=0
+      CALL hdf5_info(IPMPO,"/parameters/info/NVALUE",RANK,TYPE,NBYTE,
+     1 DIMSR)
+      IF(RANK.GT.0) NPAR=DIMSR(1)
+*----
+*  SET NLOC
+*----
+      IF(hdf5_group_exists(IPMPO,"/local_values")) THEN
+        CALL hdf5_get_shape(IPMPO,"/local_values/LOCVALNAME",DIMS_MPO)
+        NLOC=DIMS_MPO(1)
+        DEALLOCATE(DIMS_MPO)
+      ELSE
+        NLOC=0
+      ENDIF
+*----
+*  SET NISOF AND NISOP
+*----
+      NISOF=0
+      NISOP=0
+      IF(NBISO.GT.0) THEN
+        DO IBM=1,NMIL
+          WRITE(RECNAM,'(8H/output/,A,9H/statept_,I0,6H/zone_,I0,1H/)')
+     1    TRIM(HEDIT),0,IBM-1
+          IF(hdf5_group_exists(IPMPO,TRIM(RECNAM)//"yields")) THEN
+            CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"yields/NISF",NISOF)
+            CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"yields/NISP",NISOP)
+            EXIT
+          ENDIF
+        ENDDO
+      ENDIF
+      NISOS=NBISO-(NISOF+NISOP)
+      DEALLOCATE(ADDRISO)
+*----
+*  SET NSURFD
+*----
+      NSURFD=0
+      WRITE(RECNAM,'(8H/output/,A,32H/statept_0/zone_0/discontinuity/)')
+     & TRIM(HEDIT)
+      LNEW=hdf5_group_exists(IPMPO,TRIM(RECNAM))
+      IF(LNEW) THEN
+*       new specification
+        CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"NSURF",NSURFD)
+      ELSE
+*       old specification
+        WRITE(RECNAM,'(8H/output/,A,22H/statept_0/flux/NSURF/)')
+     &  TRIM(HEDIT)
+        CALL hdf5_info(IPMPO,TRIM(RECNAM),RANK,TYPE,NBYTE,DIMSR)
+        IF(TYPE.NE.99) CALL hdf5_read_data(IPMPO,TRIM(RECNAM),NSURFD)
+      ENDIF
+*----
+*  SET NALBP
+*----
+      WRITE(RECNAM,'(8H/output/,A,16H/statept_0/flux/)') TRIM(HEDIT)
+      NALBP=0
+      CALL hdf5_info(IPMPO,TRIM(RECNAM)//"NALBP",RANK,TYPE,NBYTE,DIMSR)
+      IF(TYPE.NE.99) CALL hdf5_read_data(IPMPO,TRIM(RECNAM)//"NALBP",
+     1 NALBP)
+*----
+*  SET NPRC
+*----
+      NPRC=0
+      WRITE(RECNAM,'(8H/output/,A,27H/statept_0/zone_0/kinetics/)')
+     1 TRIM(HEDIT)
+      IF(hdf5_group_exists(IPMPO,RECNAM)) THEN
+        CALL hdf5_get_shape(IPMPO,TRIM(RECNAM)//"LAMBDAD",DIMS_MPO)
+        NPRC=DIMS_MPO(1)
+        DEALLOCATE(DIMS_MPO)
+      ENDIF
+*----
+*  PRINT MPO PARAMETERS
+*----
+      IF(IMPX.GT.0) THEN
+        WRITE(IOUT,'(/38H MPOTOC: table of content information:)')
+        WRITE(IOUT,'(36H   nb of neutron-induced reactions =,I3)') NREA
+        WRITE(IOUT,'(34H   nb of particularized isotopes =,I4)') NBISO
+        WRITE(IOUT,'(19H   nb of mixtures =,I5)') NMIL
+        WRITE(IOUT,'(28H   nb of global parameters =,I4)') NPAR
+        WRITE(IOUT,'(27H   nb of local parameters =,I4)') NLOC
+        WRITE(IOUT,'(42H   nb of particularized fissile isotopes =,I4)')
+     1  NISOF
+        WRITE(IOUT,'(42H   nb of particularized fission products =,I4)')
+     1  NISOP
+        WRITE(IOUT,'(41H   nb of particularized stable isotopes =,I4)')
+     1  NISOS
+        WRITE(IOUT,'(23H   nb of calculations =,I9)') NCAL
+        WRITE(IOUT,'(24H   nb of energy groups =,I4)') NGRP
+        WRITE(IOUT,'(38H   nb of discontinuity factor values =,I4)')
+     1  NSURFD
+        WRITE(IOUT,'(44H   nb of physical albedos per energy group =,
+     1  I4)') NALBP
+        WRITE(IOUT,'(21H   nb of precursors =,I4/)') NPRC
+      ENDIF
+      RETURN
+      END