Initial commit from Polytechnique Montreal

1 files changed, 167 insertions, 0 deletions

diff --git a/Donjon/src/SCRTOC.f b/Donjon/src/SCRTOC.f
new file mode 100644
index 0000000..f1cca53
--- /dev/null
+++ b/Donjon/src/SCRTOC.f
@@ -0,0 +1,167 @@
+*DECK SCRTOC
+      SUBROUTINE SCRTOC(IPSAP)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Print the table of content of a Saphyb.
+*
+*Copyright:
+* Copyright (C) 2012 Ecole Polytechnique de Montreal
+*
+*Author(s): 
+* A. Hebert
+*
+*Parameters: input
+* IPSAP   address of the multidimensional Saphyb object.
+*
+*-----------------------------------------------------------------------
+*
+      USE GANLIB
+      IMPLICIT NONE
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      TYPE(C_PTR) IPSAP
+*----
+*  LOCAL VARIABLES
+*----
+      INTEGER, PARAMETER::IOUT=6
+      INTEGER, PARAMETER::MAXLAM=20
+      INTEGER, PARAMETER::MAXPAR=50
+      INTEGER, PARAMETER::MAXVAL=200
+      INTEGER I, ILENG,ILONG, IPAR, ITYLCM, 
+     & NADRX, NCALS, NGROUP, NISO, NISOTS, NLAM, NMAC, NMIL, NPAR, 
+     & NPARL, NPRC, NREA, NSURFD
+      INTEGER DIMSAP(50),NVALUE(MAXPAR),VINTE(MAXVAL)
+      REAL VREAL(MAXVAL)
+      CHARACTER PARKEY(MAXPAR)*4,PARTYP(MAXPAR)*4,PARFMT(MAXPAR)*8,
+     1 VCHAR(MAXVAL)*12,RECNAM*12,NAMLAM(MAXLAM)*8
+      CHARACTER(LEN=8), ALLOCATABLE, DIMENSION(:) :: TEXT8
+      CHARACTER(LEN=12), ALLOCATABLE, DIMENSION(:) :: TEXT12
+*----
+*  DIMSAP INFORMATION
+*----
+      CALL LCMLEN(IPSAP,'DIMSAP',ILENG,ITYLCM)
+      IF(ILENG.EQ.0) CALL XABORT('SCRTOC: INVALID SAPHYB.')
+      CALL LCMGET(IPSAP,'DIMSAP',DIMSAP)
+      NLAM=DIMSAP(3)   ! number of radioactive decay reactions
+      NREA=DIMSAP(4)   ! number of neutron-induced reactions
+      NISO=DIMSAP(5)   ! number of particularized isotopes
+      NMAC=DIMSAP(6)   ! number of macroscopic sets
+      NMIL=DIMSAP(7)   ! number of mixtures
+      NPAR=DIMSAP(8)   ! number of global parameters
+      NPARL=DIMSAP(11) ! number of local variables
+      NADRX=DIMSAP(18) ! number of address sets
+      NCALS=DIMSAP(19) ! number of elementary calculations in the Saphyb
+      NGROUP=DIMSAP(20) ! number of energy groups
+      NPRC=DIMSAP(31)   ! number of delayed neutron precursor groups
+      NISOTS=DIMSAP(32) ! maximum number of isotopes in output tables
+      WRITE(IOUT,'(/38H SCRTOC: table of content information:)')
+      WRITE(IOUT,'(42H   number of radioactive decay reactions =,I3)')
+     1 NLAM
+      WRITE(IOUT,'(40H   number of neutron-induced reactions =,I3)')
+     1 NREA
+      WRITE(IOUT,'(38H   number of particularized isotopes =,I4)') NISO
+      WRITE(IOUT,'(31H   number of macroscopic sets =,I2)') NMAC
+      WRITE(IOUT,'(23H   number of mixtures =,I5)') NMIL
+      WRITE(IOUT,'(32H   number of global parameters =,I4)') NPAR
+      WRITE(IOUT,'(30H   number of local variables =,I4)') NPARL
+      WRITE(IOUT,'(27H   number of address sets =,I4)') NADRX
+      WRITE(IOUT,'(27H   number of calculations =,I7)') NCALS
+      WRITE(IOUT,'(28H   number of energy groups =,I4)') NGROUP
+      WRITE(IOUT,'(31H   number of precursor groups =,I4)') NPRC
+      WRITE(IOUT,'(48H   maximum number of isotopes in output tables =,
+     1 I4/)') NISOTS
+      IF(NLAM.GT.0) THEN
+        CALL LCMSIX(IPSAP,'constphysiq',1)
+          IF(NLAM.GT.MAXLAM) CALL XABORT('SCRTOC: MAXLAM OVERFLOW')
+          CALL LCMGTC(IPSAP,'NOMLAM',8,NLAM,NAMLAM)
+          WRITE(IOUT,'(40H   names of radioactive decay reactions:/
+     1    (5X,5A10))') (NAMLAM(I),I=1,NLAM)
+        CALL LCMSIX(IPSAP,' ',2)
+      ENDIF
+      CALL LCMSIX(IPSAP,'contenu',1)
+        IF(NREA.GT.0) THEN
+          ALLOCATE(TEXT12(NREA))
+          CALL LCMGTC(IPSAP,'NOMREA',12,NREA,TEXT12)
+          WRITE(IOUT,'(38H   names of neutron-induced reactions:/
+     1    (5X,A12,2X,A12,2X,A12,2X,A12,2X,A12))') (TEXT12(I),I=1,NREA)
+          DEALLOCATE(TEXT12)
+        ENDIF
+        IF(NISO.GT.0) THEN
+          ALLOCATE(TEXT8(NISO))
+          CALL LCMGTC(IPSAP,'NOMISO',8,NISO,TEXT8)
+          WRITE(IOUT,'(36H   names of particularized isotopes:/
+     1    (5X,A8,2X,A8,2X,A8,2X,A8,2X,A8))') (TEXT8(I),I=1,NISO)
+          DEALLOCATE(TEXT8)
+        ENDIF
+        IF(NMAC.GT.0) THEN
+          ALLOCATE(TEXT8(NMAC))
+          CALL LCMGTC(IPSAP,'NOMMAC',8,NMAC,TEXT8)
+          WRITE(IOUT,'(29H   names of macroscopic sets:/
+     1    (5X,A8,2X,A8,2X,A8,2X,A8,2X,A8))') (TEXT8(I),I=1,NMAC)
+          DEALLOCATE(TEXT8)
+        ENDIF
+      CALL LCMSIX(IPSAP,' ',2)
+      CALL LCMSIX(IPSAP,'geom',1)
+      CALL LCMLEN(IPSAP,'outgeom',ILONG,ITYLCM)
+      IF(ILONG.NE.0) THEN
+        CALL LCMSIX(IPSAP,'outgeom',1)
+        CALL LCMLEN(IPSAP,'SURF',NSURFD,ITYLCM)
+        WRITE(IOUT,'(36H   number of discontinuity factors =,I4/)')
+     1  NSURFD
+        CALL LCMSIX(IPSAP,' ',2)
+      ENDIF
+      CALL LCMSIX(IPSAP,' ',2)
+*----
+*  GLOBAL PARAMETERS INFORMATION
+*----
+      IF(NPAR.GT.MAXPAR) CALL XABORT('SCRTOC: MAXPAR OVERFLOW')
+      CALL LCMSIX(IPSAP,'paramdescrip',1)
+        CALL LCMGET(IPSAP,'NVALUE',NVALUE)
+        CALL LCMGTC(IPSAP,'PARKEY',4,NPAR,PARKEY)
+        CALL LCMGTC(IPSAP,'PARTYP',4,NPAR,PARTYP)
+        CALL LCMGTC(IPSAP,'PARFMT',8,NPAR,PARFMT)
+      CALL LCMSIX(IPSAP,' ',2)
+      CALL LCMSIX(IPSAP,'paramvaleurs',1)
+        DO IPAR=1,NPAR
+          WRITE(IOUT,'(25H SCRTOC: global parameter,A5,8H of type,A5,
+     1    1H:)') PARKEY(IPAR),PARTYP(IPAR)
+          IF(NVALUE(IPAR).GT.MAXVAL) CALL XABORT('SCRTOC: MAXVAL OVERF'
+     1    //'LOW')
+          WRITE(RECNAM,'(''pval'',I8)') IPAR
+          IF(PARFMT(IPAR).EQ.'ENTIER') THEN
+            CALL LCMGET(IPSAP,RECNAM,VINTE)
+            WRITE(IOUT,'(20H   TABULATED POINTS=,1P,6I12/(20X,6I12))')
+     1      (VINTE(I),I=1,NVALUE(IPAR))
+          ELSE IF(PARFMT(IPAR).EQ.'FLOTTANT') THEN
+            CALL LCMGET(IPSAP,RECNAM,VREAL)
+            WRITE(IOUT,'(20H   TABULATED POINTS=,1P,6E12.4/(20X,
+     1      6E12.4))') (VREAL(I),I=1,NVALUE(IPAR))
+          ELSE IF(PARFMT(IPAR).EQ.'CHAINE') THEN
+            CALL LCMGTC(IPSAP,RECNAM,12,NVALUE(IPAR),VCHAR)
+            WRITE(IOUT,'(20H   TABULATED POINTS=,2X,6A12/(22X,6A12))')
+     1      (VCHAR(I),I=1,NVALUE(IPAR))
+          ENDIF
+        ENDDO
+      CALL LCMSIX(IPSAP,' ',2)
+*----
+*  LOCAL VARIABLES INFORMATION
+*----
+      IF(NPARL.GT.0) THEN
+        IF(NPARL.GT.MAXPAR) CALL XABORT('SCRTOC: MAXPAR OVERFLOW')
+        CALL LCMSIX(IPSAP,'varlocdescri',1)
+          CALL LCMGTC(IPSAP,'PARKEY',4,NPARL,PARKEY)
+          CALL LCMGTC(IPSAP,'PARTYP',4,NPARL,PARTYP)
+          CALL LCMGTC(IPSAP,'PARFMT',8,NPARL,PARFMT)
+          DO IPAR=1,NPARL
+            WRITE(IOUT,'(23H SCRTOC: local variable,A5,8H of type,A5,
+     1      11H and format,A9,1H:)') PARKEY(IPAR),PARTYP(IPAR),
+     2      PARFMT(IPAR)
+          ENDDO
+        CALL LCMSIX(IPSAP,' ',2)
+      ENDIF
+      WRITE(IOUT,'(/)')
+      RETURN
+      END