Initial commit from Polytechnique Montreal

1 files changed, 156 insertions, 0 deletions

diff --git a/Dragon/src/M2T.f b/Dragon/src/M2T.f
new file mode 100644
index 0000000..427c21c
--- /dev/null
+++ b/Dragon/src/M2T.f
@@ -0,0 +1,156 @@
+*DECK M2T
+      SUBROUTINE M2T(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+*  Recover information from a macrolib and translate the requested data
+*  towards an Apotrim interface file.
+*
+*Copyright:
+* Copyright (C) 2007 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
+      PARAMETER (NSTATE=40,IOUT=6)
+      CHARACTER TEXT12*12,TEXT20*20,HSIGN*12
+      DOUBLE PRECISION DFLOTT
+      INTEGER ISTATE(NSTATE)
+*----
+*  ALLOCATABLE ARRAYS
+*----
+      INTEGER, ALLOCATABLE, DIMENSION(:) :: NBM,HBM
+      REAL, ALLOCATABLE, DIMENSION(:) :: BUP,TEMP
+*----
+*  PARAMETER VALIDATION
+*----
+      IF(NENTRY.LE.1) CALL XABORT('M2T: MINIMUM OF 2 OBJECTS EXPECTED.')
+      TEXT12=HENTRY(1)
+      IF(IENTRY(1).NE.4) CALL XABORT('M2T: ASCII FILE NAMED '//TEXT12
+     1 //' EXPECTED AT LHS.')
+      IF(JENTRY(1).EQ.2) CALL XABORT('M2T: ASCII FILE IN CREATE OR MOD'
+     1 //'IFICATION MODE EXPECTED.')
+      LOUT=FILUNIT(KENTRY(1))
+      IF((IENTRY(2).NE.1).AND.(IENTRY(2).NE.2)) CALL XABORT('M2T: LCM '
+     1 //'OBJECT EXPECTED AT RHS.')
+      IF(JENTRY(2).NE.2) CALL XABORT('M2T: LCM OBJECTS IN READ-ONLY MO'
+     1 //'DE EXPECTED AT RHS.')
+      CALL LCMGTC(KENTRY(2),'SIGNATURE',12,HSIGN)
+      IF(HSIGN.NE.'L_MACROLIB') CALL XABORT('M2T: MACROLIB OBJECT EXPE'
+     1 //'CTED AT RHS.')
+      IPMAC=KENTRY(2)
+      CALL LCMGET(IPMAC,'STATE-VECTOR',ISTATE)
+      NGRP=ISTATE(1)
+      MAXMIX=ISTATE(2)
+      MAXNL=ISTATE(3)
+      NBFIS=ISTATE(4)
+      IF(NBFIS.GT.1) CALL XABORT('M2T: THE CAPABILITY TO MERGE MANY FI'
+     1 //'SSION SPECTRA IS NOT IMPLEMENTED.')
+*----
+*  ALLOCATE MEMORY
+*----
+      ALLOCATE(NBM(MAXMIX),HBM(5*MAXMIX),BUP(MAXMIX),TEMP(MAXMIX))
+      NBM(:MAXMIX)=1
+      BUP(:MAXMIX)=0.0
+      TEMP(:MAXMIX)=0.0
+*----
+*  READ THE INPUT DATA
+*----
+      NL=1
+      NBMIX=0
+      ICTR=0
+      IGMAIL=0
+      IMPX=1
+   20 CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT)
+      IF(INDIC.NE.3) CALL XABORT('M2T: 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('M2T: INTEGER DATA EXPECTED(1).')
+      ELSE IF(TEXT12.EQ.'MIX') THEN
+*        READ A MATERIAL MIXTURE.
+         TEXT20=' '
+         CALL REDGET(INDIC,NITMA,FLOTT,TEXT20,DFLOTT)
+         IF(INDIC.NE.3) CALL XABORT('M2T: CHARACTER DATA EXPECTED(2).')
+         NBMIX=NBMIX+1
+         IF(NBMIX.GT.MAXMIX) CALL XABORT('M2T: MAXMIX OVERFLOW.')
+         READ(TEXT20,'(5A4)') (HBM(5*(NBMIX-1)+I0),I0=1,5)
+   30    CALL REDGET(INDIC,NITMA,FLOTT,TEXT12,DFLOTT)
+         IF(INDIC.NE.3) CALL XABORT('M2T: CHARACTER DATA EXPECTED(3).')
+         IF(TEXT12.EQ.'FROM') THEN
+            CALL REDGET(INDIC,NBM(NBMIX),FLOTT,TEXT12,DFLOTT)
+            IF(INDIC.NE.1) CALL XABORT('M2T: INTEGER DATA EXPECTED(2).')
+            GO TO 30
+         ELSE IF(TEXT12.EQ.'BURN') THEN
+*           READ A BURNUP.
+            CALL REDGET(INDIC,NITMA,BUP(NBMIX),TEXT12,DFLOTT)
+            IF(INDIC.NE.2) CALL XABORT('M2T: REAL DATA EXPECTED(1).')
+            GO TO 30
+         ELSE IF(TEXT12.EQ.'TEMP') THEN
+*           READ A TEMPERATURE.
+            CALL REDGET(INDIC,NITMA,TEMP(NBMIX),TEXT12,DFLOTT)
+            IF(INDIC.NE.2) CALL XABORT('M2T: REAL DATA EXPECTED(2).')
+            GO TO 30
+         ELSE IF(TEXT12.NE.'ENDMIX') THEN
+            CALL XABORT('M2T: FROM, BURN, TEMP OR ENDMIX EXPECTED.')
+         ENDIF
+      ELSE IF(TEXT12.EQ.'PN') THEN
+*        READ THE ANISOTROPY ORDER
+         CALL REDGET(INDIC,NITMA,FLOTT,TEXT20,DFLOTT)
+         IF(INDIC.NE.1) CALL XABORT('M2T: INTEGER DATA EXPECTED(3).')
+         NL=MIN(NITMA+1,MAXNL)
+      ELSE IF(TEXT12.EQ.'TRAN') THEN
+*        PERFORM TRANSPORT CORRECTION
+         ICTR=1
+      ELSE IF(TEXT12.EQ.'NOMA') THEN
+*        DO NOT WRITE ENERGY MESH ON APOTRIM FILE
+         IGMAIL=1
+      ELSE IF(TEXT12.EQ.';') THEN
+         GO TO 40
+      ELSE
+         CALL XABORT('M2T: '//TEXT12//' IS AN INVALID KEYWORD.')
+      ENDIF
+      GO TO 20
+*----
+*  RECOVER INFORMATION
+*----
+   40 CALL M2TDRV(IMPX,LOUT,IPMAC,NGRP,NBMIX,MAXMIX,NL,NBFIS,ICTR,
+     1 IGMAIL,BUP,TEMP,HBM,NBM)
+*----
+*  RELEASE MEMORY
+*----
+      DEALLOCATE(TEMP,BUP,HBM,NBM)
+      RETURN
+      END