Initial commit from Polytechnique Montreal

1 files changed, 191 insertions, 0 deletions

diff --git a/Dragon/src/S2M.f b/Dragon/src/S2M.f
new file mode 100644
index 0000000..61b927e
--- /dev/null
+++ b/Dragon/src/S2M.f
@@ -0,0 +1,191 @@
+*DECK S2M
+      SUBROUTINE S2M(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+*  To recover information from a SERPENT output file and translate the
+*  requested data towards a macrolib.
+*
+*Copyright:
+* Copyright (C) 2014 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/output
+* NENTRY  number of LCM objects or files used by the operator.
+* HENTRY  name of each LCM object or file:
+*         HENTRY(1) create or modification ascii file containing
+*         Apotrim data;
+*         HENTRY(2) read-only type(L_MACROLIB).
+* IENTRY  type of each LCM object or file:
+*         =1 LCM memory object; =2 XSM file; =3 sequential binary file;
+*         =4 sequential ascii file.
+* JENTRY  access of each LCM object or file:
+*         =0 the LCM object or file is created;
+*         =1 the LCM object or file is open for modifications;
+*         =2 the LCM object or file is open in read-only mode.
+* KENTRY  LCM object address or file unit number.
+*
+*-----------------------------------------------------------------------
+*
+      USE GANLIB
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      INTEGER      NENTRY,IENTRY(NENTRY),JENTRY(NENTRY)
+      TYPE(C_PTR)  KENTRY(NENTRY)
+      CHARACTER    HENTRY(NENTRY)*12
+*----
+*  LOCAL VARIABLES
+*----
+      TYPE(C_PTR) IPMAC,JPMAC,KPMAC
+      PARAMETER (NSTATE=40,IOUT=6)
+      CHARACTER TEXT12*12,HSIGN*12,HLINE*512,CM*2
+      LOGICAL LB1,LFIS
+      DOUBLE PRECISION DFLOTT
+      INTEGER ISTATE(NSTATE)
+      PARAMETER(CM='00')
+*----
+*  ALLOCATABLE ARRAYS
+*----
+      REAL, ALLOCATABLE, DIMENSION(:) :: XS,FLUX,FISS,CHI,DIFF,GAR3
+      REAL, ALLOCATABLE, DIMENSION(:,:) :: SCAT
+*
+      IF(NENTRY.LE.1) CALL XABORT('S2M: MINIMUM OF 2 OBJECTS EXPECTED.')
+      TEXT12=HENTRY(1)
+      IF((IENTRY(1).NE.1).AND.(IENTRY(1).NE.4)) CALL XABORT('S2M: LCM '
+     1 //'OBJECT EXPECTED AT LHS.')
+      IF(JENTRY(1).EQ.2) CALL XABORT('S2M: LCM OBJECT IN CREATE OR MOD'
+     1 //'IFICATION MODE EXPECTED AT LHS.')
+      IPMAC=KENTRY(1)
+      IF(IENTRY(2).NE.4) CALL XABORT('S2M: ASCII FILE NAMED '//TEXT12
+     1 //' EXPECTED AT RHS.')
+      IF(JENTRY(2).NE.2) CALL XABORT('S2M: ASCII FILE IN READ-ONLY MOD'
+     1 //'E EXPECTED AT RHS.')
+      IFIN=FILUNIT(KENTRY(2))
+      HSIGN='L_MACROLIB'
+      CALL LCMPTC(IPMAC,'SIGNATURE',12,HSIGN)
+*----
+*  READ THE INPUT DATA
+*----
+      IMPX=1
+      IDX=1
+      NGRP=0
+      LB1=.FALSE.
+   20 CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT)
+      IF(INDIC.NE.3) CALL XABORT('S2M: CHARACTER DATA EXPECTED(1).')
+      IF(TEXT12.EQ.'EDIT') THEN
+*        READ THE PRINT INDEX.
+         CALL REDGET(INDIC,IMPX,FLOTT,TEXT12,DFLOTT)
+         IF(INDIC.NE.1) CALL XABORT('S2M: INTEGER DATA EXPECTED(1).')
+      ELSE IF(TEXT12.EQ.'IDX') THEN
+*        READ THE INSTANCE INDEX.
+         CALL REDGET(INDIC,IDX,FLOTT,TEXT12,DFLOTT)
+         IF(INDIC.NE.1) CALL XABORT('S2M: INTEGER DATA EXPECTED(2).')
+         IF(IDX.LE.0) CALL XABORT('S2M: INVALID VALUE OF IDX.')
+      ELSE IF(TEXT12.EQ.'B1') THEN
+         LB1=.TRUE.
+      ELSE IF(TEXT12.EQ.';') THEN
+         GO TO 30
+      ELSE
+         CALL XABORT('S2M: '//TEXT12//' IS AN INVALID KEYWORD.')
+      ENDIF
+      GO TO 20
+*----
+*  FIND THE NUMBER OF ENERGY GROUPS
+*----
+   30 DO
+        READ(IFIN,'(A)',END=40) HLINE
+        IND1=INDEX(HLINE,'GC_NE                     (idx, 1)')
+        IF(IND1.GT.0) THEN
+           IND2=INDEX(HLINE,';')
+           READ(HLINE(45:IND2-1),'(I5)') NGRP
+           GO TO 50
+        ENDIF
+      ENDDO
+   40 CALL XABORT('S2M: UNABLE TO FING NUMBER OF ENERGY GROUPS.')
+   50 IF(IMPX.GT.0) WRITE(IOUT,100) NGRP
+*----
+*  DETERMINE IF THE ISOTOPE IS FISSILE
+*----
+      LFIS=.FALSE.
+      DO
+        READ(IFIN,'(A)',END=40) HLINE
+        IND1=INDEX(HLINE,'CHI')
+        IF(IND1.GT.0) THEN
+           LFIS=.TRUE.
+           GO TO 60
+        ENDIF
+      ENDDO
+   60 IF(IMPX.GT.0) WRITE(IOUT,110) LFIS
+*----
+*  RECOVER CROSS SECTIONS
+*----
+      ALLOCATE(XS(NGRP+1),FLUX(NGRP+1),CHI(NGRP),FISS(NGRP+1),
+     > SCAT(NGRP,NGRP),DIFF(NGRP),GAR3(NGRP*NGRP))
+      CALL S2MGET(IFIN,'GC_BOUNDS',IDX,.FALSE.,NGRP+1,XS(1))
+      DO IGRP=1,NGRP+1
+        XS(IGRP)=XS(IGRP)*1.0E6
+      ENDDO
+      CALL LCMPUT(IPMAC,'ENERGY',NGRP+1,2,XS)
+      CALL S2MGET(IFIN,'TOTXS',IDX,.TRUE.,NGRP+1,XS(1))
+      CALL S2MGET(IFIN,'FLUX',IDX,.TRUE.,NGRP+1,FLUX(1))
+      CALL S2MGET(IFIN,'GTRANSFXS',IDX,.TRUE.,NGRP*NGRP,SCAT(1,1)) ! I -> J
+      IF(LFIS) THEN
+        CALL S2MGET(IFIN,'CHI  ',IDX,.TRUE.,NGRP,CHI(1))
+        CALL S2MGET(IFIN,'NSF  ',IDX,.TRUE.,NGRP+1,FISS(1))
+      ENDIF
+      IF(LB1) THEN
+        CALL S2MGET(IFIN,'B1_DIFFCOEF',IDX,.TRUE.,NGRP,DIFF(1))
+      ENDIF
+      JPMAC=LCMLID(IPMAC,'GROUP',NGRP)
+      DO IGRP=1,NGRP
+        KPMAC=LCMDIL(JPMAC,IGRP)
+        CALL LCMPUT(KPMAC,'NTOT0',1,2,XS(IGRP+1))
+        CALL LCMPUT(KPMAC,'NWT0',1,2,FLUX(IGRP+1))
+        IF(LFIS) THEN
+          CALL LCMPUT(KPMAC,'CHI',1,2,CHI(IGRP))
+          CALL LCMPUT(KPMAC,'NUSIGF',1,2,FISS(IGRP+1))
+        ENDIF
+        IF(LB1) THEN
+          CALL LCMPUT(KPMAC,'DIFF',1,2,DIFF(IGRP))
+        ENDIF
+        IPOSDE=0
+        IPOS=1
+        IGMIN=IGRP
+        IGMAX=IGRP
+        DO JGRP=1,NGRP
+          IF(SCAT(JGRP,IGRP).NE.0.0) THEN
+            IGMIN=MIN(IGMIN,JGRP)
+            IGMAX=MAX(IGMAX,JGRP)
+          ENDIF
+        ENDDO
+        IJJ=IGMAX
+        NJJ=IGMAX-IGMIN+1
+        DO JGRP=IGMAX,IGMIN,-1
+          IPOSDE=IPOSDE+1
+          GAR3(IPOSDE)=SCAT(JGRP,IGRP)
+        ENDDO
+        CALL LCMPUT(KPMAC,'SCAT'//CM,IPOSDE,2,GAR3)
+        CALL LCMPUT(KPMAC,'SIGW'//CM,1,2,SCAT(IGRP,IGRP))
+        CALL LCMPUT(KPMAC,'NJJS'//CM,1,1,NJJ)
+        CALL LCMPUT(KPMAC,'IJJS'//CM,1,1,IJJ)
+        CALL LCMPUT(KPMAC,'IPOS'//CM,1,1,IPOS)
+      ENDDO
+      ISTATE(:NSTATE)=0
+      ISTATE(1)=NGRP
+      ISTATE(2)=1
+      ISTATE(3)=1
+      IF(LFIS) ISTATE(4)=1
+      CALL LCMPUT(IPMAC,'STATE-VECTOR',NSTATE,1,ISTATE)
+      DEALLOCATE(GAR3,DIFF,SCAT,FISS,CHI,FLUX,XS)
+      RETURN
+*
+  100 FORMAT(/30H S2M: NUMBER OF ENERGY GROUPS=,I5)
+  110 FORMAT(/19H S2M: FISSILE FLAG=,L1)
+      END