Initial commit from Polytechnique Montreal

1 files changed, 210 insertions, 0 deletions

diff --git a/Trivac/src/KINRD2.f b/Trivac/src/KINRD2.f
new file mode 100755
index 0000000..bff9fe0
--- /dev/null
+++ b/Trivac/src/KINRD2.f
@@ -0,0 +1,210 @@
+*DECK KINRD2
+      SUBROUTINE KINRD2(NEN,KEN,CMODUL)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Read and validate the module options from the input file.
+*
+*Copyright:
+* Copyright (C) 2008 Ecole Polytechnique de Montreal.
+*
+*Author(s): D. Sekki
+*
+*Parameters: input/output
+* NEN     number of LCM objects used in the module.
+* KEN     addresses of LCM objects: (1) L_KINET; (2) L_MACROLIB;
+*         (3) L_TRACK; (4) L_SYSTEM; (5) L_MACROLIB.
+* CMODUL  name of the assembly door ('BIVAC' or 'TRIVAC').
+*
+*-----------------------------------------------------------------------
+*
+      USE GANLIB
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      INTEGER NEN
+      TYPE(C_PTR) KEN(NEN)
+      CHARACTER CMODUL*12
+*----
+*  LOCAL VARIABLES
+*----
+      PARAMETER(NSTATE=40,IOS=6)
+      INTEGER ISTATE(NSTATE)
+      REAL EPSCON(5),POWTOT
+      CHARACTER TEXT*12,FNAM*40,PNAM*40
+      DOUBLE PRECISION DFLOT
+      LOGICAL ADJ
+*----
+*  READ THE INPUT DATA
+*----
+      CALL LCMGET(KEN(1),'STATE-VECTOR',ISTATE)
+      ITR=ISTATE(1)
+      IMPX=1
+      IMPH=0
+      DELT=0.0
+      IPICK=0
+      IEXP=0
+      ADJ=.FALSE.
+      IF(ITR.EQ.0) THEN
+        ICL1=3
+        ICL2=3
+        MAXINR=0
+        MAXOUT=200
+        NADI=2
+        IFL=0
+        IPR=0
+        EPSINR=1.0E-2
+        EPSOUT=1.0E-4
+        TTF=9999.0
+        TTP=9999.0
+        IF(CMODUL.EQ.'TRIVAC') THEN
+          CALL LCMGET(KEN(3),'STATE-VECTOR',ISTATE)
+          NADI=ISTATE(33)
+        ELSE
+          NADI=2
+        ENDIF
+      ELSE
+        ICL1=ISTATE(11)
+        ICL2=ISTATE(12)
+        MAXINR=ISTATE(14)
+        MAXOUT=ISTATE(15)
+        NADI=ISTATE(16)
+        IFL=ISTATE(17)
+        IPR=ISTATE(18)
+        IEXP=ISTATE(19)
+        ADJ=ISTATE(20).EQ.1
+        CALL LCMGET(KEN(1),'EPS-CONVERGE',EPSCON)
+        EPSINR=EPSCON(1)
+        EPSOUT=EPSCON(2)
+        TTF=EPSCON(3)
+        TTP=EPSCON(4)
+      ENDIF
+   40 CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT)
+   50 IF(ITYP.NE.3)CALL XABORT('@KINRD2: CHARACTER DATA EXPECTED(1).')
+      IF(TEXT.EQ.';')THEN
+        GOTO 80
+      ELSE IF(TEXT.EQ.'PICK') THEN
+        IPICK=1
+        GOTO 80
+      ELSEIF(TEXT.EQ.'EDIT') THEN
+        CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT)
+        IF(ITYP.NE.1)CALL XABORT('@KINRD2: INTEGER FOR EDIT EXPECTED.')
+        IMPX=MAX(0,NITMA)
+        IF(IMPX.GT.4) WRITE(IOS,1001)
+      ELSEIF(TEXT.EQ.'DELTA') THEN
+        CALL REDGET(ITYP,NITMA,DELT,TEXT,DFLOT)
+        IF(ITYP.NE.2)CALL XABORT('@KINRD2: REAL FOR DELTA EXPECTED.')
+        IF(DELT.LT.0.)CALL XABORT('@KINRD2: INVALID VALUE FOR DELTA.')
+      ELSEIF(TEXT.EQ.'SCHEME') THEN
+        CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT)
+        IF(ITYP.NE.3)CALL XABORT('@KINRD2: CHARACTER DATA EXPECTED(2).')
+        IF(TEXT.NE.'FLUX')CALL XABORT('@KINRD2: READ KEYWORD '//TEXT//
+     1  '. KEYWORD FLUX EXPECTED.')
+   55   CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT)
+        IF(ITYP.NE.3)CALL XABORT('@KINRD2: CHARACTER DATA EXPECTED(3).')
+        IF(TEXT.EQ.'IMPLIC')THEN
+          FNAM='IMPLICIT EULER METHOD'
+          IFL=1
+        ELSEIF(TEXT.EQ.'CRANK')THEN
+          FNAM='CRANK-NICHOLSON METHOD'
+          IFL=2
+        ELSEIF(TEXT.EQ.'THETA')THEN
+          CALL REDGET(ITYP,NITMA,TTF,TEXT,DFLOT)
+          IF(ITYP.NE.2)CALL XABORT('@KINRD2: REAL THETA EXPECTED(1).')
+          IF(TTF.LE.0.5)CALL XABORT('@KINRD2: INVALID THETA VALUE(1).')
+          IF(TTF.GE.1.0)CALL XABORT('@KINRD2: INVALID THETA VALUE(2).')
+          FNAM='GENERAL THETA METHOD'
+          IFL=3
+        ELSEIF(TEXT.EQ.'TEXP')THEN
+          IEXP=1
+          GO TO 55
+        ELSE
+          CALL XABORT('@KINRD2: INVALID KEYWORD '//TEXT)
+        ENDIF
+      ELSEIF(TEXT.EQ.'PREC') THEN
+        CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT)
+        IF(ITYP.NE.3)CALL XABORT('@KINRD2: CHARACTER DATA EXPECTED(4).')
+        IF(TEXT.EQ.'IMPLIC')THEN
+          PNAM='IMPLICIT EULER METHOD'
+          IPR=1
+        ELSEIF(TEXT.EQ.'CRANK')THEN
+          PNAM='CRANK-NICHOLSON METHOD'
+          IPR=2
+        ELSEIF(TEXT.EQ.'THETA')THEN
+          CALL REDGET(ITYP,NITMA,TTP,TEXT,DFLOT)
+          IF(ITYP.NE.2)CALL XABORT('@KINRD2: REAL THETA EXPECTED(2).')
+          IF(TTP.LE.0.5)CALL XABORT('@KINRD2: INVALID THETA VALUE(3).')
+          IF(TTP.GE.1.0)CALL XABORT('@KINRD2: INVALID THETA VALUE(4).')
+          PNAM='GENERAL THETA METHOD'
+          IPR=3
+        ELSEIF(TEXT.EQ.'EXPON')THEN
+          PNAM='ANALYTICAL INTEGRATION METHOD'
+          IPR=4
+        ELSE
+          CALL XABORT('@KINRD2: INVALID KEYWORD '//TEXT)
+        ENDIF
+      ELSEIF((TEXT.EQ.'VAR1').OR.(TEXT.EQ.'ACCE')) THEN
+        CALL REDGET(ITYP,ICL1,FLOT,TEXT,DFLOT)
+        IF(ITYP.NE.1)
+     1    CALL XABORT('@KINRD2: INTEGER DATA EXPECTED FOR ICL1.')
+        CALL REDGET(ITYP,ICL2,FLOT,TEXT,DFLOT)
+        IF(ITYP.NE.1)
+     1    CALL XABORT('@KINRD2: INTEGER DATA EXPECTED FOR ICL2.')
+      ELSEIF(TEXT.EQ.'ADI') THEN
+        CALL REDGET(ITYP,NADI,FLOTT,TEXT,DFLOT)
+        IF(ITYP.NE.1) CALL XABORT('@KINRD2: INTEGER DATA EXPECTED(1).')
+        GO TO 40
+      ELSE IF(TEXT.EQ.'ADJ') THEN
+        ADJ=.TRUE.
+      ELSEIF(TEXT.EQ.'EXTE') THEN
+   60   CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT)
+        IF(ITYP.EQ.1) THEN
+          MAXOUT=NITMA
+        ELSE IF(ITYP.EQ.2) THEN
+          EPSOUT=FLOT
+        ELSE
+          GO TO 50
+        ENDIF
+        GO TO 60
+      ELSEIF(TEXT.EQ.'THER') THEN
+   70   CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT)
+        IF(ITYP.EQ.1) THEN
+          MAXINR=NITMA
+        ELSE IF(ITYP.EQ.2) THEN
+          EPSINR=FLOT
+        ELSE
+          GO TO 50
+        ENDIF
+        GO TO 70
+      ELSEIF(TEXT.EQ.'HIST') THEN
+        CALL REDGET(ITYP,IMPH,FLOT,TEXT,DFLOT)
+        IF(ITYP.NE.1) CALL XABORT('@KINRD2: INTEGER DATA EXPECTED(2).')
+      ELSE
+        CALL XABORT('@KINRD2: INVALID KEYWORD '//TEXT)
+      ENDIF
+      GOTO 40
+   80 IF(IFL.EQ.0) CALL XABORT('@KINRD2: SCHEME DATA MISSING.')
+      IF(IPR.EQ.0) CALL XABORT('@KINRD2: PREC DATA MISSING.')
+      IF(IMPX.GT.0) WRITE(IOS,1002) ITR+1
+      CALL KINST2(NEN,KEN,CMODUL,TTF,TTP,IFL,IPR,IEXP,DELT,IMPH,ICL1,
+     1 ICL2,NADI,ADJ,MAXOUT,EPSOUT,MAXINR,EPSINR,FNAM,PNAM,IMPX,POWTOT)
+*----
+*  RECOVER THE FINAL POWER AND SAVE IT IN A CLE-2000 VARIABLE
+*----
+      IF(IPICK.EQ.1) THEN
+         CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT)
+         IF(ITYP.NE.-2) CALL XABORT('KINRD2: OUTPUT REAL EXPECTED.')
+         ITYP=2
+         FLOT=POWTOT
+         CALL REDPUT(ITYP,NITMA,FLOT,TEXT,DFLOT)
+         CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT)
+         IF((ITYP.NE.3).OR.(TEXT.NE.';')) THEN
+           CALL XABORT('KINRD2: ; CHARACTER EXPECTED.')
+         ENDIF      
+      ENDIF      
+      RETURN
+*
+ 1001 FORMAT(/1X,'KINRD2: READING DATA FROM INPUT FILE'/)
+ 1002 FORMAT(1X,'KINRD2: THE INPUT DATA HAVE BEEN READ AT STEP',I5,'.')
+      END