Initial commit from Polytechnique Montreal

1 files changed, 281 insertions, 0 deletions

diff --git a/Dragon/src/MAC.f b/Dragon/src/MAC.f
new file mode 100644
index 0000000..c4f0cde
--- /dev/null
+++ b/Dragon/src/MAC.f
@@ -0,0 +1,281 @@
+*DECK MAC
+      SUBROUTINE MAC(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Macroscopic cross sections and diffusion coefficients input module.
+*
+*Copyright:
+* Copyright (C) 2002 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 and G. Marleau
+*
+*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 type(L_MACROLIB);
+*         HENTRY(2) optional read-only type(L_MACROLIB) or
+*                     type(L_OPTIMIZE).
+* 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) IPMACR,JPLIST,KPLIST
+      PARAMETER(NSTATE=40,IOUT=6)
+      CHARACTER TEXT12*12,HSIGN*12,CARLIR*12
+      INTEGER ISTATE(NSTATE)
+      INTEGER NALBP
+      DOUBLE PRECISION DBLLIR
+*----
+*  PARAMETER VALIDATION
+*----
+      IF(NENTRY.EQ.0) CALL XABORT('MAC: PARAMETER EXPECTED.')
+      IF((IENTRY(1).NE.1).AND.(IENTRY(1).NE.2)) CALL XABORT('MAC: LCM '
+     1 //'OBJECT EXPECTED AT LHS.')
+      IF((JENTRY(1).NE.0).AND.(JENTRY(1).NE.1)) CALL XABORT('MAC: ENTR'
+     1 //'Y IN CREATE OR MODIFICATION MODE EXPECTED.')
+      ITYPE=JENTRY(1)
+      IPMACR=KENTRY(1)
+      NGO=0
+*----
+*  LOOK FOR OTHER MACROLIB IN SET OF DATA STRUCTURES
+*----
+      NMACSR=1
+      NOLDMX=0
+      NGO=0
+      NLO=0
+      NFO=0
+      NEO=0
+      ITO=0
+      IPMAC2=0
+      IF(NENTRY.GT.2) CALL XABORT('MAC: ONLY TWO OBJECTS PERMITTED.')
+      IF(NENTRY.EQ.2) THEN
+        IPMAC2=NENTRY
+        IF((IENTRY(IPMAC2).NE.1).AND.(IENTRY(IPMAC2).NE.2)) THEN
+           CALL XABORT('MAC: INVALID STRUCTURE TYPE FOR SECOND OBJECT.')
+        ELSE IF(JENTRY(IPMAC2).NE.2) THEN
+           CALL XABORT('MAC: DATA STRUCTURE '//HENTRY(IPMAC2)//' NOT '
+     1     //'IN READ-ONLY MODE')
+        ENDIF
+        CALL LCMGTC(KENTRY(IPMAC2),'SIGNATURE',12,HSIGN)
+        IF(HSIGN.EQ.'L_MACROLIB') THEN
+           NMACSR=2
+           ISTATE(:NSTATE)=0
+           CALL LCMGET(KENTRY(IPMAC2),'STATE-VECTOR',ISTATE)
+           IF(ISTATE(2).GT.0) THEN
+              NOLDMX=ISTATE(2)
+              NGO=ISTATE(1)
+              NLO=ISTATE(3)
+              NFO=ISTATE(4)
+              NEO=ISTATE(5)
+              ITO=ISTATE(6)
+           ELSE
+              NMACSR=1
+           ENDIF
+        ELSE IF(HSIGN.EQ.'L_LIBRARY') THEN
+           NMACSR=-2
+           CALL LCMSIX(KENTRY(IPMAC2),'MACROLIB',1)
+           ISTATE(:NSTATE)=0
+           CALL LCMGET(KENTRY(IPMAC2),'STATE-VECTOR',ISTATE)
+           IF(ISTATE(2).GT.0) THEN
+              NOLDMX=ISTATE(2)
+              NGO=ISTATE(1)
+              NLO=ISTATE(3)
+              NFO=ISTATE(4)
+              NEO=ISTATE(5)
+              ITO=ISTATE(6)
+           ELSE
+              CALL LCMSIX(KENTRY(IPMAC2),' ',2)
+              NMACSR=1
+           ENDIF
+        ELSE IF(HSIGN.EQ.'L_OPTIMIZE') THEN
+           CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR)
+           IF(ITYPLU.NE.10) CALL XABORT('MAC: NO INPUT DATA EXPECTED.')
+           CALL MACOPT(IPMACR,KENTRY(IPMAC2))
+           RETURN
+        ELSE
+           CALL XABORT('MAC: SECOND DATA STRUCTURE HAS INVALID SIGNATU'
+     1     //'RE SET TO '//HSIGN//'.')
+        ENDIF
+      ENDIF
+*----
+*  READ THE INPUT DATA
+*----
+*     DEFAULT OPTIONS:
+      IPRINT=1
+      IF(ITYPE.EQ.0) THEN
+         INDREC=1
+         NANISO=1
+         NGROUP=0
+         NBMIX=0
+         NIFISS=0
+         NEDMAC=0
+         ITRANC=0
+         NDELG=0
+         NALBP=0
+         NSTEP=0
+         IDF=0
+         NPART0=0
+      ELSE
+         INDREC=2
+         CALL LCMGTC(IPMACR,'SIGNATURE',12,HSIGN)
+         IF(HSIGN.EQ.'L_LIBRARY') THEN
+            CALL LCMSIX(IPMACR,'MACROLIB',1)
+         ELSE IF(HSIGN.NE.'L_MACROLIB') THEN
+            TEXT12=HENTRY(1)
+            CALL XABORT('MAC: SIGNATURE OF '//TEXT12//' IS '//HSIGN//
+     1      '. L_MACROLIB OR L_LIBRARY EXPECTED.')
+         ENDIF
+         ISTATE(:NSTATE)=0
+         CALL LCMGET(IPMACR,'STATE-VECTOR',ISTATE)
+         NGROUP=ISTATE(1)
+         NBMIX=ISTATE(2)
+         NANISO=ISTATE(3)
+         NIFISS=ISTATE(4)
+         NEDMAC=ISTATE(5)
+         ITRANC=ISTATE(6)
+         NDELG=ISTATE(7)
+         NALBP =ISTATE(8)
+         NSTEP=ISTATE(11)
+         IDF=ISTATE(12)
+         NPART0=ISTATE(17)
+      ENDIF
+*----
+*  PROCESS THE MAC: INPUT DATA
+*----
+      IF(NMACSR.EQ.1) THEN
+         CALL MACDRV(IPMACR,INDREC,IPRINT,IDF,NBMIX,NGROUP,NANISO,
+     1   NIFISS,NEDMAC,ITRANC,NDELG,NSTEP,NALBP)
+      ELSE
+         NNEWMX=0
+         NANISO=MAX(NLO,NANISO)
+         NIFISS=NFO+NIFISS
+         NEDMAC=MAX(NEDMAC,NEO)
+         ITRANC=MAX(ITRANC,ITO)
+*----
+*  TAKE MACROSCOPIC XS FROM OLD MACROLIB
+*  READ MAIN INPUT PARAMETERS UNTIL KEYWORD MIX FOUND
+*----
+ 1000    CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR)
+         IF(ITYPLU.NE.3) CALL XABORT('MAC: CHARACTER KEYWORD EXPECTED.')
+         IF(CARLIR.EQ.'EDIT') THEN
+            CALL REDGET(ITYPLU,IPRINT,REALIR,CARLIR,DBLLIR)
+            IF(ITYPLU.NE.1) CALL XABORT('MAC: EDIT LEVEL SHOULD BE AN '
+     1      //'INTEGER.')
+         ELSE IF(CARLIR.EQ.'NMIX') THEN
+            CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR)
+            IF(ITYPLU.NE.1) CALL XABORT('MAC: READ ERROR - NUMBER OF M'
+     1      //'IXTURES EXPECTED.')
+            NNEWMX=MAX(INTLIR,NNEWMX)
+         ELSE IF(CARLIR.EQ.'ANIS') THEN
+            CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR)
+            IF(ITYPLU.NE.1) CALL XABORT('MAC: READ ERROR - ANIS LEVEL '
+     1      //'EXPECTED.')
+            NANISO=MAX(NANISO,INTLIR)
+         ELSE IF(CARLIR.EQ.'NIFI') THEN
+            CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR)
+            IF(ITYPLU.NE.1) CALL XABORT('MAC: READ ERROR - NUMBER FISS'
+     1      //'ILE ISOTOPES EXPECTED.')
+            NIFISS=MAX(INTLIR,NIFISS)
+         ELSE IF(CARLIR(1:4).EQ.'CTRA') THEN
+            CALL REDGET(ITYPLU,INTLIR,REALIR,CARLIR,DBLLIR)
+            IF(ITYPLU.NE.3) CALL XABORT('MAC: CTRA MUST BE FOLLOWED BY'
+     1      //' CHARACTER.')
+            IF(CARLIR.EQ.'OFF') THEN
+               ITRANC=0
+            ELSE IF(CARLIR.EQ.'ON') THEN
+               ITRANC=2
+            ELSE
+               CALL XABORT('MAC: INVALID CTRA OPTION.')
+            ENDIF
+         ELSE IF(CARLIR(1:3).EQ.'MIX') THEN
+            GO TO 1005
+         ELSE
+            CALL XABORT('MAC: KEYWORD '//CARLIR//' NOT PERMITTED.')
+         ENDIF
+         GO TO 1000
+ 1005    CONTINUE
+         NTOTMX=NOLDMX+NBMIX+NNEWMX
+         IF(NGROUP.EQ.0) THEN
+            IF(NGO.EQ.0) CALL XABORT('MAC: MACROLIBS HAVE 0 GROUP.')
+            NGROUP=NGO
+         ELSE IF(NGROUP.NE.NGO) THEN
+            CALL XABORT('MAC: MACROLIBS HAVE DIFFERENT GROUP STRUCTURE'
+     1      //'S.')
+         ENDIF
+         CALL MACUPD(NENTRY,KENTRY,IPRINT,NTOTMX,NBMIX,NGROUP,
+     1               NANISO,NIFISS,NEDMAC,ITRANC)
+         IF(NMACSR.EQ.-2) CALL LCMSIX(KENTRY(IPMAC2),' ',2)
+      ENDIF
+*
+      IF(ITYPE.EQ.0) THEN
+         HSIGN='L_MACROLIB'
+         CALL LCMPTC(IPMACR,'SIGNATURE',12,HSIGN)
+      ENDIF
+      IF(ITYPE.NE.2) THEN
+         ISTATE(:NSTATE)=0
+         ISTATE(1)=NGROUP
+         ISTATE(2)=NBMIX
+         ISTATE(3)=NANISO
+         ISTATE(4)=NIFISS
+         ISTATE(5)=NEDMAC
+         ISTATE(6)=ITRANC
+         ISTATE(7)=NDELG
+         ISTATE(8)=NALBP
+         ISTATE(11)=NSTEP
+         ISTATE(12)=IDF
+         ISTATE(17)=NPART0
+         IF(ITRANC.NE.0) ISTATE(6)=2
+         JPLIST=LCMGID(IPMACR,'GROUP')
+         KPLIST=LCMGIL(JPLIST,1)
+         CALL LCMLEN(KPLIST,'DIFF',ILONG,ITYLCM)
+         IF(ILONG.GT.0) ISTATE(9)=1
+         CALL LCMLEN(KPLIST,'DIFFX',ILONG,ITYLCM)
+         IF(ILONG.GT.0) ISTATE(9)=2
+         CALL LCMPUT(IPMACR,'STATE-VECTOR',NSTATE,1,ISTATE)
+      ENDIF
+      IF(IPRINT.GT.1) CALL LCMLIB(IPMACR)
+      IF(IPRINT.GT.0) WRITE(IOUT,100) IPRINT,(ISTATE(I),I=1,9),
+     1 ISTATE(11),ISTATE(12),ISTATE(17)
+      CALL LCMSIX(IPMACR,' ',0)
+      RETURN
+*
+  100 FORMAT(/8H OPTIONS/8H -------/
+     1 7H IPRINT,I6,30H   (0=NO PRINT/1=SHORT/2=MORE)/
+     2 7H NGROUP,I6,28H   (NUMBER OF ENERGY GROUPS)/
+     3 7H NBMIX ,I6,39H   (NUMBER OF MIXTURES IN THE MACROLIB)/
+     4 7H NANISO,I6,34H   (MAXIMUM SCATTERING ANISOTROPY)/
+     5 7H NIFISS,I6,45H   (MAXIMUM NUMBER OF FISSILE ISOTOPES IN A M,
+     6 7HIXTURE)/
+     7 7H NEDMAC,I6,34H   (NUMBER OF CROSS SECTION EDITS)/
+     8 7H ITRANC,I6,45H   (0=NO TRANSPORT CORRECTION/1=APOLLO TYPE/2,
+     9 43H=RECOVER FROM LIBRARY/4=LEAKAGE CORRECTION)/
+     1 7H NLG   ,I6,39H   (NUMBER OF DELAYED PRECURSOR GROUPS)/
+     2 7H NALB  ,I6,31H   (NUMBER OF PHYSICAL ALBEDOS)/
+     3 7H ILEAK ,I6,40H   (1=DIFF AVAILABLE; 2=DIFFX AVAILABLE)/
+     4 7H NSTEP ,I6,39H   (NUMBER OF PERTURBATION DIRECTORIES)/
+     5 7H IDF   ,I6,48H   (=0/2 BOUNDARY FLUXES FOR ADF ABSENT/PRESENT)/
+     6 7H NPART0,I6,34H   (NUMBER OF COMPANION PARTICLES))
+      END