        SUBROUTINE KEYIN (KEYS,VALUES,N,ENDMRK,MODE,IN,PR)
C-----------------------------------------------------------------------
C       Free-format keyed input
C
C       T.J.Pearson 1978 May 31    IBM 370
C       Modified 1979 Jun 25       VAX-11 Fortran 
C       Tidied up a bit 1980 Feb 12
C       Add SAVE command   1982 Mar 1
C       Use VMS help       1982 Dec 15
C       Add SHOW parameter 1983 May 9
C       Add DCL symbol substitution ({}) 1983 Dec 5
C       Remove necessity for quotation marks 1984 Mar 16
C
C       R.S.Simon 1985 Jul 22      Ridge 32C Fortran 77 (UNIX)
C               Most changes to bring to F77 standards.
C               Environment symbol substitution enabled.
C               Help only lists parameters
C
C       D. Mozurkewich 1986 Oct 29  Changed minimum value of PR
C               to 0, so prompts go to error file and are not piped.
C
C       R.S. Simon 1987 April 10 Many changes to remove system-dependent
C               junk.  Symbol subs. removed.  Optional common block with
C               program name.  Conversion between numeric and character
C               variables now with equivalence statements, a more common
C               extension to Fortran 77.
C
C       r. gaume  1988 may 04. modified for ndp fortran under dos
C
C       Arguments:
C        KEYS: array of parameter names
C        VALUES: array to receive values or defaults
C        N: number of parameters (dimension of keys and values)
C        ENDMRK: special keyword to indicate end of input
C        MODE: integer variable:
C              (input) 1 = turn on reflection, 0 = turn off
C                      2 = interactive mode (prompts for input,
C                          no reflection, no limit on errors)
C             (output) 1 = eof found, 0 = endmrk found
C        IN: input unit number
C        PR: printer unit number for reflection and messages
C       Common Block:
C        /PROGNM/ PROG
C        An optional common block containing the calling prognam's name
C        in the CHARACTER*12 variable PROG.
C-----------------------------------------------------------------------
C               Since IMPLICIT NONE is not available, try
        IMPLICIT UNDEFINED(A-Z)
        INTEGER    CHPWRD
        PARAMETER  (CHPWRD=8)   
C                               ! characters per REAL*8 word
C
        INTEGER*2  REC(120),FCH,DELIM(3),BLANK,EQUALS,COMMA,ARROW,BRA,
     1             KET,SQUOTE,DQUOTE,QUEST,TAB,EXCL,ATSIGN,NUMER(13),
     2             SLASH,I0,LB
        INTEGER*4  CTOI,COMPST,ERRCNT,IN,P,PR,
     2             INUNIT, N, MODE, I, LPROG, LABEL1, LABEL2, MAXREC,
     3             IER, IP, NEW, NK, NK2, LEN1, LUNSAV, II, NW, I1,
     4             NLETS, J
        REAL*8     KEYS(N),VALUES(N),ENDMRK,WORD,BLANK8,UNSET,CTOR,
     1             HELP,SHOW,SAVE,EOL,EXPRES,RESULT
        LOGICAL    REFLEC,DIALOG,SAVERF,SAVEDL,EQFOUND,exists
        CHARACTER*64 FILENAME
        CHARACTER*12 PROG
        CHARACTER*120 INREC, SBREC
C
C               Obtain name of calling program from the common block 
C               PROGNM (for HELP and SAVE).  If it is blank, use KEYIN.
C
        COMMON /PROGNM/ PROG
C
C               Initialize I*2 constants with equivalences and:
        DATA       BLANK8/' '/,UNSET/'***UNSET'/,REC/120*' '/,
     1             BLANK/' '/,EQUALS/'='/,COMMA/','/,
     2             ARROW/'>'/,BRA/'('/,KET/')'/,SQUOTE/''''/

        DATA       DQUOTE/'"'/,QUEST/'?'/,TAB/'	'/,EXCL/'!'/,
     1             SHOW/'SHOW'/,HELP/'HELP'/,ATSIGN/'@'/,
     2             EOL/'***EOL'/,SAVE/'SAVE'/,SLASH/'/'/,I0/0/

        DATA       NUMER/'-','+','.','0','1','2','3','4','5','6','7',
     6                   '8','9'/
        DATA       LB/0/
C
        IF (PROG.EQ.' ')  PROG = 'KEYIN'
        LPROG = LEN1(PROG)
C               Check i/o units
C
        P = PR
C                changed min unit number for print file to 0
C                so messages go to terminal even when output is piped.
        IF (P.LT.0 .OR.  P.GT.99) P = 6
        INUNIT = IN
        IF (IN.LT.0 .OR. IN.GT.99) GOTO 340     
C                                               ! treatsat as EOF
C
        REFLEC = MODE.EQ.1
        DIALOG = MODE.EQ.2
        FCH = BLANK
        ERRCNT = 0
        MODE = 0
C
        GOTO 102
C
C               Read next record
C               ('MAXREC' points to last non-blank character in record)
C
  100   IF(ENDMRK.EQ.EOL) GOTO 350
  102   ASSIGN 130 TO LABEL1
        GOTO 7000
C
C               Look for next input word: it is either a comment, an
C               @-command, or a keyword.
C
  130   CALL SKIPBL(REC,MAXREC,I)
        IF (I.GT.MAXREC) GOTO 100
C
C               Comment: skip rest of line.
C
        IF (REC(I).EQ.EXCL) GOTO 100
C
C               @-command: include file. If this facility
C               is not required, omit this IF clause. The file name is 
C               in the character variable FILENAME, and the unit is 91.
C
        IF (REC(I).EQ.ATSIGN) THEN
            IER = 6     
C                          ! signal file-name error
            FILENAME = ' '
            I = I+1
            CALL SKIPBL(REC,MAXREC,I)
            WRITE (FILENAME,400) (REC(IP),IP=I,MAXREC)
            IF (FILENAME.EQ.' ') FILENAME = PROG(1:LPROG)//'.PAR'
            NEW    = 51
C               Default file extension is .PAR
            IF (INDEX(FILENAME,'.').LE.0) 
     +        FILENAME = FILENAME(1:(LEN1(FILENAME)))//'.PAR'
            OPEN (UNIT=NEW, FILE=FILENAME, FORM='FORMATTED', 
     1            STATUS='OLD', ERR=330)
            INQUIRE (UNIT=NEW,NAME=FILENAME)
            WRITE (P,460) FILENAME(1:LEN1(FILENAME))
            INUNIT = NEW
            SAVEDL = DIALOG
            SAVERF = REFLEC
            REFLEC = REFLEC.OR.DIALOG
            DIALOG = .FALSE.
            FCH = ATSIGN
            GOTO 100
        END IF
C
C               Keyword: pack into WORD.
C
        ASSIGN 140 TO LABEL2
        GOTO 8000
  140   CONTINUE
C
C               Scan 'KEYS' for 'WORD'; error if not found
C               (check first that 'WORD' is not 'ENDMRK'
C                or a special command-word)
C
        IF (COMPST(WORD,ENDMRK,8,I0).EQ.0) THEN
            GOTO 350
        ELSE IF (COMPST(WORD,SHOW,8,I0).EQ.0) THEN
            CALL SKIPBL(REC,MAXREC,I)
            IF (I.GT.MAXREC) THEN
                CALL KEYOUT(KEYS,VALUES,N,P)
            ELSE
                ASSIGN 145 TO LABEL2
                GOTO 8000
  145           CONTINUE
                DO 150 NK=1,N
                    IF (COMPST(WORD,KEYS(NK),8,QUEST).EQ.0) THEN
                        NK2 = 1
  147                   IF (COMPST(WORD,KEYS(NK+NK2),8,QUEST).EQ.0
     1                     .OR. KEYS(NK+NK2).EQ.BLANK8) THEN
                            NK2 = NK2+1
                            GOTO 147
                        ENDIF
                        CALL KEYOUT(KEYS(NK),VALUES(NK),NK2,P)
                        GOTO 130
                    END IF
  150           CONTINUE
                IER = 4
                GOTO 330        
C                               ! error: unknown parameter
            END IF
            GOTO 130
        ELSE IF (COMPST(WORD,HELP,8,I0).EQ.0) THEN
            FILENAME = ' '
            I = I+1
            CALL SKIPBL(REC,MAXREC,I)
            WRITE (FILENAME,400) (REC(IP),IP=I,MAXREC)
            IF (FILENAME.EQ.' ') FILENAME = PROG
            CALL KEYHLP(KEYS,VALUES,N,P,FILENAME)
            GOTO 100
        ELSE IF (COMPST(WORD,SAVE,8,I0).EQ.0) THEN
            IER = 6     
C                        ! signal file-name error
            FILENAME = ' '
            I = I+1
            CALL SKIPBL(REC,MAXREC,I)
            WRITE (FILENAME,400) (REC(IP),IP=I,MAXREC)
            IF (FILENAME.EQ.' ') FILENAME = PROG(1:LPROG)//'.PAR'
            IF (INDEX(FILENAME,'.').LE.0) 
     +        FILENAME = FILENAME(1:(LEN1(FILENAME)))//'.PAR'
            LUNSAV = 52
C
C        test to see if file.par exists, if it does, then delete it
C        so we can write a new version
C
            inquire (file=FILENAME,exist=EXISTS)
            if (EXISTS) then
            open(unit=LUNSAV,file=FILENAME,status='OLD')
            close(LUNSAV,status='DELETE')
            endif
C
            OPEN (UNIT=LUNSAV, FILE=FILENAME, FORM='FORMATTED',
     2          STATUS='NEW', ERR=330)
            CALL KEYOUT(KEYS,VALUES,N,LUNSAV)
            INQUIRE (UNIT=LUNSAV,NAME=FILENAME)
            WRITE (P,450) FILENAME(1:LEN1(FILENAME))
            CLOSE (UNIT=LUNSAV)
            GOTO 100
        END IF
  156   DO 160 NK=1,N
        IF(COMPST(WORD,KEYS(NK),8,QUEST).EQ.0) GOTO 170
  160   CONTINUE
        IER=4
        GOTO 330                
C                               ! error: unknown parameter
C
C               Look for (subscript) to keyword
C
  170   EQFOUND = .FALSE.
        IF (REC(I).NE.BRA) GOTO 190
        I=I+1
        NK=NK-1+CTOI(REC,MAXREC,I)
        IER=1   
C               ! subscript error?
        IF(REC(I).NE.KET) GOTO 330
        I=I+1
  180   IF (NK.LT.1) GOTO 330
        IER = 2 
C               ! too many values?
        IF (NK.GT.N) GOTO 330
        IF (COMPST(WORD,KEYS(NK),8,QUEST).NE.0) GOTO 330
C
C               Look for value after optional '='. If no value
C               and no "=", assign value 0.
C
  190   CALL SKIPBL(REC,MAXREC,I)
        IF (I.GT.MAXREC) THEN
            VALUES(NK) = 0D0
            GOTO 100
        END IF
        IF (REC(I).EQ.EQUALS) THEN
            I=I+1
            EQFOUND = .TRUE.
            CALL SKIPBL(REC,MAXREC,I)
            IF (I.GT.MAXREC) THEN
                ASSIGN 195 TO LABEL1
                GOTO 7000
  195           CALL SKIPBL(REC,MAXREC,I)
            END IF
        END IF
C
C               If a bracket is found, read an expression.
C
        IF (REC(I).EQ.BRA) GOTO 205
C
C               If an explicit quotation mark is found, read
C               a quoted string.
C
        DELIM(1) = REC(I)
        DELIM(2) = REC(I)
        DELIM(3) = REC(I)
        IF (REC(I).EQ.SQUOTE .OR. REC(I).EQ.DQUOTE) GOTO 210
C
C               If the parameter requires a character value,
C               read an unquoted (blank-terminated) string.
C
        IF ((NK.LT.N).AND.(KEYS(NK+1).EQ.BLANK8)) GOTO 202
C
C               If '+', '-', '.', or a digit is found, read a
C               numerical value.
C
        DO 199 II=1,13
            IF (REC(I).EQ.NUMER(II)) GOTO 201
  199   CONTINUE
C
C               Otherwise, read a string terminated by blank
C               or comma, but only if an equals sign was found.
C
        IF (.NOT.EQFOUND) THEN
            VALUES(NK) = 0D0
            GOTO 260
        END IF
  202   I = I-1
        DELIM(1) = BLANK
        DELIM(2) = COMMA
        DELIM(3) = TAB
        GOTO 210
C
C               Numeric value.
C       
  201   RESULT=CTOR(REC,MAXREC,I)
        IF (REC(I).EQ.BLANK .OR. REC(I).EQ.COMMA .OR. REC(I).EQ.EXCL
     1      .OR. REC(I).EQ.TAB .OR. REC(I).EQ.SLASH) THEN
            VALUES(NK) = RESULT
            GOTO 260
        ELSE
            IER = 8             
C                               ! bad numeric value
            GOTO 330
        END IF
C
C               Arithmetic expression
C
  205   RESULT=EXPRES(REC,MAXREC,I,IER)
        IF(IER.NE.0) GOTO 330
        VALUES(NK) = RESULT
        GOTO 260
C
C               Textual value - 'NW' words of 'CHPWRD' characters
C
  210   NW=1
        VALUES(NK)=BLANK8
  220   IF(NK+NW.GT.N) GOTO 230
        IF(KEYS(NK+NW).NE.BLANK8) GOTO 230
            VALUES(NK+NW)=BLANK8
            NW=NW+1
            GOTO 220
  230   I1=I+1
        NLETS=0
  240   I=I+1
        IF(I.GT.MAXREC) GOTO 250
        IF(REC(I).EQ.DELIM(1).OR.REC(I).EQ.DELIM(2).OR.REC(I).EQ.
     1     DELIM(3)) GOTO 250
            NLETS=NLETS+1
            GOTO 240
  250   CALL PACK(REC(I1),VALUES(NK),MIN0(CHPWRD*NW,NLETS))
        IF (REC(I).NE.COMMA) I=I+1
        NK=NK+NW-1
C
C               Look for another value, if allowed
C
  260   CALL SKIPBL(REC,MAXREC,I)
        IF (I.GT.MAXREC) GOTO 100
        IF (REC(I).NE.COMMA) GOTO 130
        I = I+1
        CALL SKIPBL(REC,MAXREC,I)
        IF (I.GT.MAXREC) THEN
            ASSIGN 270 TO LABEL 1
            GOTO 7000
  270       CONTINUE
        END IF
        NK = NK+1
        GOTO 180
C
C----------------------------------------------------------------------
C               Error report
C----------------------------------------------------------------------
C
  330   IF(.NOT.(REFLEC.OR.DIALOG)) WRITE(P,410) FCH,(REC(J),J=1,MAXREC)
        WRITE(P,410) BLANK,(ARROW,J=1,I)
        IF(IER.EQ.1)  WRITE(P,440) 'in subscript of ',WORD
        IF(IER.EQ.2)  WRITE(P,440) 'Too many values for ',WORD
        IF(IER.EQ.4)  WRITE(P,440) 'Unknown parameter: ',WORD
        IF(IER.EQ.6)  WRITE(P,440) 'Bad file name: ',
     1                             FILENAME(1:LEN1(FILENAME))
        IF(IER.EQ.8)  WRITE(P,440) 'Not a valid number'
        IF(IER.EQ.11) WRITE(P,440) 'Too many parentheses'
        IF(IER.EQ.12) WRITE(P,440) 'Expecting ")"'
        IF(IER.EQ.13) WRITE(P,440) 'Value expected after operator'
        IF(IER.EQ.14) WRITE(P,440) 'Attempt to divide by zero'
        IF(DIALOG) GOTO 102
        ERRCNT=ERRCNT+1
        IF(ERRCNT.LT.10) GOTO 102
C
C----------------------------------------------------------------------
C               EOF or 'ENDMRK' found
C----------------------------------------------------------------------
C               If this is the end of a file included with an
C               @-command, revert to original file; otherwise
C               check that values have been assigned to all
C               compulsory parameters (default value '***UNSET')
C
  340   IF (INUNIT.NE.IN) THEN
            CLOSE (UNIT=INUNIT)
            INUNIT = IN
            REFLEC = SAVERF
            DIALOG = SAVEDL
            ERRCNT = 0
            FCH = BLANK
            GOTO 100
        END IF
        MODE = 1
  350   IF (ERRCNT.GT.0) CALL ERROR('in input parameters')
        DO 360 NK=1,N
            IF (VALUES(NK).EQ.UNSET) GOTO 380
  360   CONTINUE
        RETURN
  380   DO 390 NK=1,N
            IF (VALUES(NK).EQ.UNSET)
     1          WRITE (P,440) 'Value needed for ',KEYS(NK)
  390   CONTINUE
        IF (DIALOG.AND.MODE.NE.1) GOTO 102
        CALL ERROR('in input parameters.')
C
C----------------------------------------------------------------------
C               Internal routine to read a record and do
C               DCL symbol substitution.
C----------------------------------------------------------------------
 7000   IF (INUNIT.EQ.0) GOTO 340
        IF (DIALOG) WRITE (P,430)
        READ (INUNIT,'(A)',END=340) INREC
        MAXREC = LEN1(INREC)
        IF (REFLEC) WRITE(P,'(1X,A1,1X,A)') FCH,INREC(1:MAXREC)
        SBREC = INREC
        IF (MAXREC.LT.1) THEN
            MAXREC = 1
            REC(1) = BLANK
        ELSE
            DO 7050 I=1,MAXREC
                READ (SBREC(I:I),'(A1)') REC(I)
 7050       CONTINUE
        END IF
        REC(MAXREC+1) = BLANK
        I = 1
 7100   IF (MAXREC.LE.1 .OR. REC(MAXREC).NE.BLANK) GOTO 7200
            MAXREC=MAXREC-1
            GOTO 7100
 7200   CONTINUE
        GOTO LABEL1
C
C----------------------------------------------------------------------
C               Internal routine to find a keyword.
C----------------------------------------------------------------------
 8000   I1 = I
        NLETS = 1
 8100   I = I+1
        IF(REC(I).EQ.BLANK .OR. REC(I).EQ.EQUALS .OR. REC(I).EQ.EXCL
     1    .OR. REC(I).EQ.BRA .OR. REC(I).EQ.TAB) GOTO 8200
                NLETS = NLETS+1
                GOTO 8100
 8200   WORD = BLANK8
        CALL PACK(REC(I1),WORD,MIN0(CHPWRD,NLETS))
        GOTO LABEL2
C
C----------------------------------------------------------------------
C               Format statements.
C----------------------------------------------------------------------
  400   FORMAT (120A1)
  410   FORMAT (1X,A1,1X,120A1)
C       For VAX fortran, one could use:
  430   FORMAT (' * ',$)
  440   FORMAT (' +++ERROR+++ ',A,A)
  450   FORMAT ('   Saved: ',A)
  460   FORMAT (' Reading: ',A)
C
        END

        SUBROUTINE KEYHLP(KEYS,VALUES,N,P,PROG)
C-----------------------------------------------------------------------
C               HELP routine for KEYIN
C               - types contents of help file, if available;
C               else lists parameter names
C-----------------------------------------------------------------------
        INTEGER P
        REAL*8 KEYS(N),VALUES(N),BLANK8
        CHARACTER*8 CLANK8
        EQUIVALENCE (BLANK8,CLANK8)
        CHARACTER*12 PROG,WORD,DUMMYC
C       CHARACTER*128 LIB
C       EXTERNAL LIB$PUT_OUTPUT, LIB$GET_INPUT
        DATA CLANK8/'        '/, LB/0/
C
C               Try and read the help library.
C
C       IER = LIB$FIND_FILE('VLBHELP:VLBI.HLB', LIB, IC)
C       IF (IER) THEN
C           IER = LBR$OUTPUT_HELP(LIB$PUT_OUTPUT, , PROG, 
C
C           IF (IER) RETURN
C       END IF
C
C               If this fails, just list the parameters.
C
        CALL KEYPUT(PROG(1:LEN1(PROG))//' parameters: ',P,LB)
        CALL KEYPUT('***END',P,LB)
        I = 0
    5   IF (I.LT.N) THEN
            I = I+1
            IF (KEYS(I).NE.BLANK8) THEN
                J = 1
   10           IF (I.LT.N .AND. KEYS(I+1).EQ.KEYS(I)) THEN 
                    I = I+1
                    J = J+1
                    GO TO 10
                ENDIF
                WRITE (WORD,'(A8)') KEYS(I)
C
C               The following required by a bug in the Ridge 32 compiler
C
                DUMMYC = WORD
                IF (J.LE.1 .AND. WORD.NE.' ') THEN
                  WORD = DUMMYC(1:LEN1(DUMMYC))//','
                ELSEIF (J.LE.1) THEN
                  WORD = ','
                ENDIF
                CALL KEYPUT(' '//WORD(1:LEN1(WORD)),P,LB)
                IF (J.GT.1) THEN
                    WRITE (WORD,'(I3)') J
                    CALL KEYPUT(' ('//WORD(1:3)//' values),',P,LB)
                END IF
            END IF
            GOTO 5
        ENDIF
        CALL KEYPUT('***END',P,LB)
        RETURN
        END

        BLOCK DATA KEYIN
        CHARACTER*12 PROG
        COMMON /PROGNM/ PROG
        DATA PROG/' '/
        END

        SUBROUTINE KEYPUT(TEXT,P,LB)
C-----------------------------------------------------------------------
C               Write TEXT to unit P, filling lines if possible.
C-----------------------------------------------------------------------
        CHARACTER*(*) TEXT
        CHARACTER*78  BUFFER
        INTEGER       P
C
        IF (TEXT(1:6).EQ.'***END') THEN
            IF (LB.GT.0) WRITE (P,'(2X,A)') BUFFER(1:LB)
            LB = 0
            RETURN
        END IF
        IF (LB+LEN1(TEXT).GT.LEN(BUFFER)) THEN
            WRITE (P,'(2X,A)') BUFFER(1:LB)
            LB = 0
        END IF
        BUFFER(LB+1:) = TEXT
        LB = LB+LEN1(TEXT)
        RETURN
        END

        LOGICAL FUNCTION KEYCHK(RWORD,NC)
C-----------------------------------------------------------------------
C               Test whether value could be a character string
C               - It is considered to be character rather than
C               numeric unless one or more bytes are ASCII control
C               characters (0-31 decimal). Of course this doesn't
C               always work as any character string is also a
C               valid number.
C
C               Other invalid codes: 127 (DEL)
C               Character not allowed in 1st position: @
C-----------------------------------------------------------------------
        REAL*8 RWORD,TMPWRD
        CHARACTER*1 WORD(8)
        EQUIVALENCE (WORD(1),TMPWRD)
        TMPWRD=RWORD
C
        KEYCHK=.FALSE.
        IF (WORD(1).EQ.'@') RETURN
        DO 10 I=1,NC
          IF(ICHAR(WORD(I)).LT.32 .OR. ICHAR(WORD(I)).GE.127) RETURN
   10   CONTINUE
        KEYCHK=.TRUE.
        RETURN
        END

        FUNCTION EXPRES(S,IMAX,I,ERROR)
C-----------------------------------------------------------------------
C               Evaluate an arithmetic expression.  Input array S
C               is evaluated starting at S(I) and ending at S(IMAX)
C               or at a character which cannot be part of the
C               expression. The value of I returned points to the
C               invalid character or is IMAX+1. This is a pseudo-
C               recursive procedure: the "stack level" is LEVEL.
C               Dimensions are sufficient for 9 nested parentheses.
C
C               ERROR = 0  : success
C                       11 : too many parentheses
C                       12 : expecting ')'
C                       13 : missing value after operator
C                       14 : divide by zero
C-----------------------------------------------------------------------
        INTEGER*2 S,OP,PLUS,MINUS,STAR,SLASH,BRA,KET
        CHARACTER*2 CPLUS,CMINUS,CSTAR,CSLASH,CBRA,CKET
        EQUIVALENCE  (CPLUS,PLUS), (CMINUS,MINUS), (CSTAR,STAR), 
     +               (CSLASH,SLASH), (CBRA,BRA), (CKET,KET)
        INTEGER*4 SIGN,ERROR
        REAL*8 EXPRES,RESULT,TERM,FACTOR,CTOR
        DIMENSION S(IMAX)
        DIMENSION RESULT(10),TERM(10),FACTOR(10),OP(10),SIGN(10)
        DATA CPLUS/'+'/,CMINUS/'-'/,CSTAR/'*'/,CSLASH/'/'/,CBRA/'('/,
     +       CKET/')'/
C
        ERROR=0
        LEVEL=1
C
C               Evaluate 'expression'
  100   RESULT(LEVEL)=0.0
  110   SIGN(LEVEL)=+1
        IF(S(I).NE.PLUS) GOTO 120
            I=I+1
  120   IF(S(I).NE.MINUS) GOTO 130
            I=I+1
            SIGN(LEVEL)=-1
  130   CONTINUE
C
C               Evaluate 'term'
        TERM(LEVEL)=1.0
        OP(LEVEL)=STAR
  200   CONTINUE
C
C               Evaluate 'factor'
C               Parenthesized expression = 'expression' at next level
        IF(S(I).NE.BRA) GOTO 330
            I=I+1
            LEVEL=LEVEL+1
            IF(LEVEL.LE.10) GOTO 100
                ERROR=11
                RETURN
  310       FACTOR(LEVEL-1)=RESULT(LEVEL)
            LEVEL=LEVEL-1
            IF(S(I).EQ.KET) GOTO 320
                ERROR=12
                RETURN
  320       I=I+1
            GOTO 340
  330   IP=I
        FACTOR(LEVEL)=CTOR(S,IMAX,I)
        IF(I.NE.IP) GOTO 340
                ERROR=13
                RETURN
  340   CONTINUE
C               End 'factor'
C
        IF(OP(LEVEL).EQ.STAR) THEN
                TERM(LEVEL)=TERM(LEVEL)*FACTOR(LEVEL)
        ELSE IF(OP(LEVEL).EQ.SLASH) THEN
                IF(FACTOR(LEVEL).EQ.0.0) THEN
                        ERROR=14
                        RETURN
                ELSE
                        TERM(LEVEL)=TERM(LEVEL)/FACTOR(LEVEL)
                END IF
        END IF
        IF(S(I).NE.SLASH.AND.S(I).NE.STAR) GOTO 210
            OP(LEVEL)=S(I)
            I=I+1
            GOTO 200
  210   CONTINUE
C               End 'term'
C
        RESULT(LEVEL)=RESULT(LEVEL)+SIGN(LEVEL)*TERM(LEVEL)
        IF(S(I).EQ.PLUS.OR.S(I).EQ.MINUS) GOTO 110
C               End 'expression'
C
        IF(LEVEL.GT.1) GOTO 310
        EXPRES=RESULT(LEVEL)
        RETURN
        END

        SUBROUTINE KEYOUT(KEYS,VALUES,N,P)
C-----------------------------------------------------------------------
C               SAVE/SHOW routine for KEYIN
C               - list parameters and values to unit P
C-----------------------------------------------------------------------
        INTEGER P
        REAL*8 KEYS(N),VALUES(N),BLANK8
        CHARACTER*8 CLANK8
        EQUIVALENCE (BLANK8,CLANK8)
        LOGICAL KEYCHK
        CHARACTER*1 CONTIN
        CHARACTER*10 WORD
        CHARACTER*80 TEXT, DUMMYC
        DATA CLANK8/'        '/, LB/0/
C
        I = 1
        CONTIN = ' '
  100   IF (I.GT.N) RETURN
        WRITE (WORD,'(A8)') KEYS(I)
        IF (CONTIN.EQ.',') WORD = ' '
        J = 1
  110   IF (I+J.LE.N .AND. KEYS(I+J).EQ.BLANK8) THEN
            J = J+1
            GOTO 110
        ENDIF
        WRITE (TEXT,'(10A8)') (VALUES(K),K=I,I+MIN(J-1,9))
        CONTIN = ' '
        IF (I.LT.N .AND. KEYS(I).EQ.KEYS(I+J)) CONTIN = ','
        IF (WORD.NE.' ') CALL KEYPUT(WORD//' =',P,LB)
        IF (J.GT.1 .OR. KEYCHK(VALUES(I),8)) THEN
C               The following required by bug in the Ridge 32 compiler?
C
                IF (TEXT.NE.' ') THEN
                  DUMMYC = TEXT
                  TEXT = '"'//DUMMYC(1:LEN1(DUMMYC))//'"'
                ELSE
                  TEXT = '""'
                ENDIF
        ELSE IF (DABS(VALUES(I)).LT.1D7) THEN
                IF (DMOD(VALUES(I),1D0).EQ.0D0) THEN
                        IVAL = IDINT(VALUES(I))
                        WRITE (TEXT,620) IVAL
                ELSE
                        WRITE(TEXT,630) VALUES(I)
                END IF
        ELSE
                WRITE (TEXT,630) VALUES(I)
        END IF
  615   IF (TEXT(1:1).EQ.' ') THEN
            TEXT = TEXT(2:)
            GOTO 615
        ENDIF
C
C               The following required by bug in the Ridge 32 compiler?
C
        IF (TEXT.NE.' ') THEN
          DUMMYC = TEXT
          IF (CONTIN.EQ.',') TEXT = DUMMYC(1:LEN1(DUMMYC))//','
        ELSE
          IF (CONTIN.EQ.',') TEXT = ','
        ENDIF
        CALL KEYPUT(' '//TEXT(1:LEN1(TEXT)),P,LB)
        IF (CONTIN.NE.',') CALL KEYPUT('***END',P,LB)
        I = I+J
        GOTO 100
C
  620   FORMAT(I9)
  630   FORMAT(1PG25.16)
C
        END

        FUNCTION CTOI(S,N,I)
C
C               TJP 1977 DECEMBER 4  CIT 370/158
C               MODIFIED 1979 FEB 6  VAX/VMS FORTRAN 4
C
C               EVALUATE INTEGER AT S(I); INCREMENT I
C
        INTEGER   CTOI,N,I
        INTEGER*2 S(N),DIGITS(10)
        CHARACTER*2 CDIGIT(10)
        EQUIVALENCE (CDIGIT(1),DIGITS(1))
        DATA      CDIGIT/'0','1','2','3','4','5','6','7','8','9'/
C
        CTOI=0
   10   IF(I.GT.N) RETURN
        DO 20 K=1,10
        IF(S(I).EQ.DIGITS(K)) GOTO 30
   20   CONTINUE
        RETURN
   30   CTOI=CTOI*10+K-1
        I=I+1
        GOTO 10
        END
C=======================================================================
        FUNCTION CTOR(S,N,I)
C
C               T.J.PEARSON  1978 MAY 11
C               MODIFIED 1979 FEB 6  VAX/VMS FORTRAN 4
C
C               EVALUATE NUMBER AT S(I); INCREMENT I
C
        REAL*8    CTOR,CTOD,FRACTN
        INTEGER   CTOI,SIGN
        INTEGER   N,I
        INTEGER*2 S(N),COLON,PLUS,MINUS,POINT,E,ELC
        CHARACTER*2 CCOLON,CPLUS,CMINUS,CPOINT,CE,CELC
        EQUIVALENCE (CCOLON,COLON), (CPLUS,PLUS), (CMINUS,MINUS), 
     +              (CPOINT,POINT), (CE,E), (CELC,ELC)
        DATA      CCOLON/':'/,CPLUS/'+'/,CMINUS/'-'/,CPOINT/'.'/,
     1            CE/'E'/,CELC/'e'/
C
        CTOR=0D0
        IF(I.GT.N) RETURN
        SIGN=+1
        IF(S(I).NE.MINUS) GOTO 130
            I=I+1
            SIGN=-1
            CALL SKIPBL(S,N,I)
            GOTO 140
  130   IF(S(I).NE.PLUS) GOTO 140
            I=I+1
            CALL SKIPBL(S,N,I)
  140   ISTART=I
  150   CTOR=CTOD(S,N,I)*SIGN + CTOR*60D0
        IF(I.GT.N) RETURN
        IF(S(I).NE.COLON) GOTO 160
            I=I+1
            GOTO 150
C
C               LOOK FOR FRACTIONAL PART, IF ANY
C
  160   IF(S(I).NE.POINT) GOTO 170
        J=I+1
        FRACTN=CTOD(S,N,J)*SIGN
        CTOR=CTOR + FRACTN*10D0**(I-J+1)
        I=J
        IF(I.GT.N) RETURN
C
C               Look for exponent, if any; an exponent may not stand
C               alone
C
  170   IF(.NOT.(S(I).EQ.E.OR.S(I).EQ.ELC) .OR. I.EQ.ISTART) GOTO 270
        I=I+1
        IF(I.GT.N) RETURN
        SIGN=+1
        IF(S(I).NE.MINUS) GOTO 180
            I=I+1
            SIGN=-1
            GOTO 190
  180   IF(S(I).NE.PLUS) GOTO 190
            I=I+1
  190   CTOR=CTOR * 10D0**(SIGN*CTOI(S,N,I))
  270   RETURN
        END
C=======================================================================
        FUNCTION CTOD(S,N,I)
C
C               T.J. PEARSON 1979 JUN 4  VAX/VMS FORTRAN 4
C
C               EVALUATE INTEGER AT S(I); INCREMENT I
C               RETURN AS REAL*8
C
        INTEGER   N,I
        REAL*8    CTOD
        INTEGER*2 S(N),DIGITS(10)
        CHARACTER*2 CDIGIT(10)
        EQUIVALENCE (CDIGIT(1),DIGITS(1))
        DATA      CDIGIT/'0','1','2','3','4','5','6','7','8','9'/
C
        CTOD=0D0
   10   IF(I.GT.N) RETURN
        DO 20 K=1,10
        IF(S(I).EQ.DIGITS(K)) GOTO 30
   20   CONTINUE
        RETURN
   30   CTOD=CTOD*10D0 + (K-1)
        I=I+1
        GOTO 10
        END
C=======================================================================
        SUBROUTINE SKIPBL(S,N,I)
C
C               T.J.PEARSON  1978 MAY 11
C               MODIFIED 1979 FEB 6  (VAX/VMS FORTRAN 4)
C               MODIFIED 1987 APR 12 (RSS)
C
C               SKIP BLANKS FROM S(I); INCREMENT I
C
        INTEGER   N,I
        INTEGER*2 S(N),BLANK,TAB
        CHARACTER*2 CBLANK,CTAB
        EQUIVALENCE (CBLANK,BLANK), (CTAB,TAB)
        DATA      CBLANK/' '/,CTAB/'	'/
C
   10   IF(I.GT.N) RETURN
        IF(S(I).NE.BLANK.AND.S(I).NE.TAB) RETURN
        I=I+1
        GOTO 10
        END

        INTEGER FUNCTION COMPST(S1,S2,N,IWILD)
C
C               TJP 1977 DECEMBER 12  CIT 370/158
C               MODIFIED 1979 FEB 6   VAX/VMS FORTRAN 4+
C
C               MODIFIED 1987 APR 12 (RSS)
C               Modified 1985 Jul 17  Ridge 32 Fortran 77  R. S. Simon
C
C               Modified 1987 Apr 12  RM and VAX Fortran 77  R. S. Simon
C
C               Modified 1988 may 04  for lower case wildcard match
C
C               COMPARE CHARACTER STRINGS S1 AND S2 UP TO N PLACES;
C               RETURN POSITION OF FIRST MISMATCH, OR 0 IF
C               EQUAL. 'WILD' MATCHES ANY CHARACTER.
C               LOWER-CASE AND UPPER-CASE LETTERS DO MATCH EACH OTHER 
C
        REAL*8 S1,S2,TMPS1,TMPS2
        CHARACTER*(8) CS1,CS2
        INTEGER*2 IWILD,ITEMP
        CHARACTER*2   WILD
        EQUIVALENCE(WILD,ITEMP),(TMPS1,CS1),(TMPS2,CS2)
C
        TMPS1 = S1
        TMPS2 = S2
        ITEMP = IWILD
        IWI = ICHAR(WILD(1:1))
        IF (IWI.GT.64 .AND. IWI.LT.91) IWI = IWI+32
C
        DO 10 I=1,N
          IS1 = ICHAR(CS1(I:I))
          IS2 = ICHAR(CS2(I:I))
          IF (IS2.GT.96 .AND. IS2.LT.123 .AND. CS1(I:I).EQ.' ') GOTO 10
          IF (IS1.GT.64 .AND. IS1.LT.91) IS1 = IS1+32
          IF (IS2.GT.64 .AND. IS2.LT.91) IS2 = IS2+32
          IF (IS1.EQ.IS2 .OR. IS1.EQ.IWI .OR. IS2.EQ.IWI) GOTO 10
          COMPST=I
          RETURN
   10   CONTINUE
        COMPST=0
        RETURN
        END

        SUBROUTINE PACK(IFROM,RTO,NBYTES)
C
C               PACK ARRAY 'FROM', CONTAINING NBYTES CHARS IN A1 FORMAT
C               (NBYTES <=120)
C               IN WORDS OF LENGTH 2 BYTES, INTO ARRAY 'TO'
C
C               T.J.PEARSON 1978 APRIL 19 (IBM 370 FORTRAN)
C               MODIFIED 1979 FEB 6       (VAX/VMS FORTRAN 4)
C
C               Modified 1987 Apr 12  RM and VAX Fortran 77  R. S. Simon
C
        INTEGER*2 IFROM(1), TMPFRM
        REAL*8    RTO(1), TMPTO(15)
        INTEGER*4 NBYTES
        CHARACTER*2 FROM
        CHARACTER*120 TO
        EQUIVALENCE (FROM,TMPFRM), (TO,TMPTO(1))
C
        IF(NBYTES.LT.1) GOTO 20
        DO 5 I=1,120
    5     TO(I:I) = ' '
        DO 10 I=1,NBYTES
          TMPFRM = IFROM(I)
          TO(I:I) = FROM(1:1)
   10   CONTINUE
        DO 15 I=1,15
          IF (8*(I-1).GE.NBYTES) GO TO 20
          RTO(I) = TMPTO(I)
   15   CONTINUE
   20   RETURN
        END

