Initial commit from Polytechnique Montreal

1 files changed, 216 insertions, 0 deletions

diff --git a/Trivac/src/MACD.f b/Trivac/src/MACD.f
new file mode 100755
index 0000000..b9ce53b
--- /dev/null
+++ b/Trivac/src/MACD.f
@@ -0,0 +1,216 @@
+*DECK MACD
+      SUBROUTINE MACD(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Macroscopic cross sections and diffusion coefficients input module.
+*
+*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 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
+*----
+      PARAMETER (NSTATE=40)
+      CHARACTER TEXT4*4,TEXT12*12,HSMG*131,HSIGN*12
+      DOUBLE PRECISION DFLOTT
+      INTEGER IPAR(NSTATE)
+      TYPE(C_PTR) IPLIST
+      REAL, DIMENSION(:,:), ALLOCATABLE :: ALBP
+*----
+*  PARAMETER VALIDATION.
+*----
+      IF(NENTRY.EQ.0) CALL XABORT('MACD: PARAMETER EXPECTED.')
+      IF((IENTRY(1).NE.1).AND.(IENTRY(1).NE.2)) CALL XABORT('MACD: LCM'
+     1 //' OBJECT EXPECTED AT LHS.')
+      IF((JENTRY(1).NE.0).AND.(JENTRY(1).NE.1)) CALL XABORT('MACD: ENT'
+     1 //'RY IN CREATE OR MODIFICATION MODE EXPECTED.')
+      ITYPE=JENTRY(1)
+      IPLIST=KENTRY(1)
+*----
+*  READ THE INPUT DATA.
+*----
+*     DEFAULT OPTIONS:
+      IND=1
+      IMPX=1
+      ISTEP=0
+      IF(ITYPE.EQ.0) THEN
+         NL=1
+         NGRP=0
+         NMIXT=0
+         NIFISS=1
+         NDG=0
+         NALBP=0
+         NSTEP=0
+         IF(NENTRY.EQ.2) THEN
+            IF((IENTRY(2).NE.1).AND.(IENTRY(2).NE.2)) CALL XABORT('MACD'
+     1      //': LCM OBJECT EXPECTED AT RHS.')
+            IF(JENTRY(2).NE.2) CALL XABORT('MACD: RHS ENTRY IN READ-ONL'
+     1      //'Y MODE EXPECTED.')
+            CALL LCMEQU(KENTRY(2),IPLIST)
+            IND=2
+         ENDIF
+      ELSE IF(ITYPE.EQ.1) THEN
+         IND=2
+      ENDIF
+      IF(IND.EQ.2) THEN
+         CALL LCMGTC(IPLIST,'SIGNATURE',12,HSIGN)
+         IF(HSIGN.NE.'L_MACROLIB') THEN
+            TEXT12=HENTRY(1)
+            CALL XABORT('MACD: SIGNATURE OF '//TEXT12//' IS '//HSIGN//
+     1      '. L_MACROLIB EXPECTED.')
+         ENDIF
+         IND=2
+         CALL LCMGET(IPLIST,'STATE-VECTOR',IPAR)
+         NGRP=IPAR(1)
+         NMIXT=IPAR(2)
+         NL=IPAR(3)
+         NIFISS=IPAR(4)
+         NDG=IPAR(7)
+         NALBP=IPAR(8)
+         NSTEP=IPAR(11)
+      ENDIF
+*----
+*  READ THE MAC: MODULE OPTIONS.
+*----
+   10 CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT)
+      IF(INDIC.NE.3) CALL XABORT('MACD: CHARACTER DATA EXPECTED(1).')
+   20 IF(TEXT4.EQ.'EDIT') THEN
+*        READ THE PRINT INDEX.
+         CALL REDGET(INDIC,IMPX,FLOTT,TEXT4,DFLOTT)
+         IF(INDIC.NE.1) CALL XABORT('MACD: INTEGER DATA EXPECTED(1).')
+      ELSE IF(TEXT4.EQ.'NGRO') THEN
+*        READ THE NUMBER OF ENERGY GROUPS.
+         IF(IND.EQ.2) CALL XABORT('MACD: NGRO IS ALREADY DEFINED.')
+         CALL REDGET(INDIC,NGRP,FLOTT,TEXT4,DFLOTT)
+         IF(INDIC.NE.1) CALL XABORT('MACD: INTEGER DATA EXPECTED(2).')
+      ELSE IF(TEXT4.EQ.'NMIX') THEN
+*        READ THE MAXIMUM NUMBER OF MATERIAL MIXTURES.
+         IF(IND.EQ.2) CALL XABORT('MACD: NMIX IS ALREADY DEFINED.')
+         CALL REDGET(INDIC,NMIXT,FLOTT,TEXT4,DFLOTT)
+         IF(INDIC.NE.1) CALL XABORT('MACD: INTEGER DATA EXPECTED(3).')
+      ELSE IF(TEXT4.EQ.'DELP') THEN
+*        READ THE MAXIMUM NUMBER OF PRECURSORS.
+         IF(IND.EQ.2) CALL XABORT('MACD: DELP IS ALREADY DEFINED.')
+         CALL REDGET(INDIC,NDG,FLOTT,TEXT4,DFLOTT)
+         IF(INDIC.NE.1) CALL XABORT('MACD: INTEGER DATA EXPECTED(3).')
+      ELSE IF(TEXT4.EQ.'ANIS') THEN
+*        READ THE SCATTERING ANISOTROPY FOR TRANSPORT THEORY CASES.
+         IF(IND.EQ.2) CALL XABORT('MACD: NMIX IS ALREADY DEFINED.')
+         CALL REDGET(INDIC,NL,FLOTT,TEXT4,DFLOTT)
+         IF(INDIC.NE.1) CALL XABORT('MACD: INTEGER DATA EXPECTED(4).')
+      ELSE IF(TEXT4.EQ.'NIFI') THEN
+*        READ THE NUMBER OF FISSILE ISOTOPES
+         IF(IND.EQ.2) CALL XABORT('MACD: NIFISS IS ALREADY DEFINED.')
+         CALL REDGET(INDIC,NIFISS,FLOTT,TEXT4,DFLOTT)
+         IF(INDIC.NE.1) CALL XABORT('MACD: INTEGER DATA EXPECTED(5).')
+      ELSE IF(TEXT4.EQ.'ALBP') THEN
+*        READ GROUP-INDEPENDENT PHYSICAL ALBEDOS
+         CALL REDGET(INDIC,NALBP,FLOTT,TEXT4,DFLOTT)
+         IF(INDIC.NE.1) CALL XABORT('MACD: INTEGER DATA EXPECTED(6).')
+         IF(NALBP.GT.0) THEN
+           ALLOCATE(ALBP(NALBP,NGRP))
+           DO IAL=1,NALBP
+             DO IGR=1,NGRP
+               CALL REDGET(INDIC,NITMA,ALBP(IAL,IGR),TEXT4,DFLOTT)
+               IF(INDIC.NE.2) CALL XABORT('MACD: REAL DATA EXPECTED.')
+             ENDDO
+           ENDDO
+           CALL LCMPUT(IPLIST,'ALBEDO',NALBP*NGRP,2,ALBP)
+           DEALLOCATE(ALBP)
+         ELSE
+           CALL XABORT('MACD: INVALID NUMBER OF ALBEDOS.')
+         ENDIF
+         IF(ITYPE.EQ.1) THEN
+           CALL LCMGET(IPLIST,'STATE-VECTOR',IPAR)
+           IPAR(8)=NALBP
+           CALL LCMPUT(IPLIST,'STATE-VECTOR',NSTATE,1,IPAR)
+         ENDIF
+      ELSE IF(TEXT4.EQ.'STEP') THEN
+*        STEP TO A SON DIRECTORY AND WRITE PERTURBATION VALUES.
+         CALL REDGET(INDIC,ISTEP,FLOTT,TEXT4,DFLOTT)
+         IF(INDIC.NE.1) CALL XABORT('MACD: INTEGER DATA EXPECTED(7).')
+         WRITE(TEXT12,'(4HSTEP,I8)') ISTEP
+         IF(IND.EQ.1) THEN
+            CALL LCMLEN(IPLIST,TEXT12,ILENG,ITYLCM)
+            IF(ILENG.GT.0) THEN
+               WRITE(HSMG,'(30HMACD: PERTURBATION DIRECTORY '',A12,
+     1         21H'' ALREADY EXISTS IN '',A12,2H''.)') TEXT12,HENTRY(1)
+               CALL XABORT(HSMG)
+            ENDIF
+         ENDIF
+         NSTEP=MAX(NSTEP,ISTEP)
+         CALL LCMSIX(IPLIST,TEXT12,1)
+         IF(IMPX.GT.0) WRITE(6,'(/34H MACD: WRITE PERTURBATION VALUES O,
+     1   13HN DIRECTORY '',A12,6H'' OF '',A12,2H''.)') TEXT12,HENTRY(1)
+      ELSE IF(TEXT4.EQ.'READ') THEN
+*        INPUT NON-PERTURBED OR PERTURBED DIFFUSION COEFFICIENTS AND
+*        CROSS SECTIONS PER MIXTURE.
+         CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT)
+         IF((INDIC.NE.3).OR.(TEXT4.NE.'INPU')) CALL XABORT('MACD: INPU'
+     1   //'T KEYWORD EXPECTED.')
+         CALL MACXSI(IPLIST,IND,NMIXT,NGRP,NDG,NL,IMPX,NBMIX,JND)
+         IF(ISTEP.GT.0) THEN
+            IF(IMPX.GT.1) CALL LCMLIB(IPLIST)
+            CALL LCMSIX(IPLIST,' ',2)
+         ENDIF
+         IF(JND.EQ.1) THEN
+            GO TO 40
+         ELSE IF(JND.EQ.2) THEN
+            TEXT4='STEP'
+            GO TO 20
+         ENDIF
+      ELSE IF(TEXT4.EQ.';') THEN
+         GO TO 40
+      ELSE
+         CALL XABORT('MACD: '//TEXT4//' IS AN INVALID KEY-WORD.')
+      ENDIF
+      GO TO 10
+*
+   40 IF(ITYPE.EQ.0) THEN
+         HSIGN='L_MACROLIB'
+         CALL LCMPTC(IPLIST,'SIGNATURE',12,HSIGN)
+         IPAR(:NSTATE)=0
+         IPAR(1)=NGRP
+         IPAR(2)=NMIXT
+         IPAR(3)=NL
+         IPAR(4)=NIFISS
+         IPAR(5)=0
+         IPAR(6)=0
+         IPAR(7)=NDG
+         IPAR(8)=NALBP
+         IPAR(11)=NSTEP
+         CALL LCMPUT(IPLIST,'STATE-VECTOR',NSTATE,1,IPAR)
+      ENDIF
+      IF(IMPX.GT.1) CALL LCMLIB(IPLIST)
+      RETURN
+      END