C 25 OCT 01 - MWS - DECODN: INITIALIZE -LAST- TO KOLSV ON ENTRY
C 26 OCT 00 - MWS - USE VARIABLES IN ALL BCAST CALLS, EXPLICIT SAVES
C  6 MAY 98 - MWS - CHANGE -UPCASE- TO -UPRCAS-
C 28 SEP 97 - MWS - CONVERT PARALLEL CALLS FROM TCGMSG TO DDI
C 10 NOV 94 - MWS - REMOVE SOME FTNCHEK WARNINGS
C 20 FEB 92 - TLW - PARALLELIZED AND ADDED PROCEDURE FNDGRP
C 11 JAN 92 - TLW - RDCARD: MAKE READ PARALLEL
C  4 JAN 92 - TLW - MAKE WRITES PARALLEL, ADD COMMON PAR
C  8 AUG 91 - MK  - RDCARD: INITIALIZE MORE
C 25 FEB 91 - MWS - FIX RETURN CODE IN IFIND
C 25 OCT 90 - STE - PORTABLE UPRCAS
C 25 SEP 90 - MWS - DECODN: STRING D123 SHOULD NOT BE A NUMBER 0D123
C 15 SEP 90 - MWS - BRING UPRCAS BACK INTO THIS FILE
C  5 APR 90 - JHJ - INTRODUCE FRFMT MODULE INTO GAMESS.
C  3 MAR 90 - MWS - ADD SAVE STATEMENTS
C 13 JUL 87 - MWS - FIX DIAGNOSTIC OUTPUT
C 24 MAR 87 - MWS - ALTER ALIS ROUTINES FOR FORTRAN-77
C
C*MODULE FRFMT   *DECK DECODN
C
C              FREE FORMAT I/O ROUTINES.
C     THESE ROUTINES WERE TAKEN FROM THE PROGRAM SYSTEM 'ALIS',
C     AND WERE MODIFIED TO REMOVE MACHINE DEPENDENCIES, AND TO
C     MAKE BETTER USE OF FORTRAN-77 CHARACTER TYPES.
C     N.B. - ARGUMENTS TO RDCARD,RFIND,IFIND,GSTRNG ARE CHANGED,
C            ROUTINES REREAD AND UPPER CASE CONVERSION IS ADDED.
C
C     BRIEF OVERVIEW, SEE EACH ROUTINE FOR CALLING ARGUMENTS.
C        OPNCRD - OPENS FREE FORMAT LIBRARY, CALL ONCE
C        RDCARD - READ IN FRESH CURRENT CARD, OR REREAD PREVIOUS
C        RFIND  - SCAN FLOATING POINT NUMBER FROM CURRENT CARD
C        IFIND  - SCAN INTEGER NUMBER FROM CURRENT CARD
C        GSTRNG - SCAN CHARACTER STRING FROM CURRENT CARD
C        REREAD - BACK UP, SO PREVIOUS DATA ITEM CAN BE RESCANNED
C     UTILITY ROUTINE, NOT NORMALLY CALLED DIRECTLY
C        DECODN - THE ROUTINE THAT SCANS NUMBERS OFF
C
      SUBROUTINE DECODN(VARABL,VALUE,ISIGN,FIXPNT,FRACT,IEXPFR,ISIGNE
     *                 ,IEXP)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      LOGICAL FIRST,GOPARR,DSKWRK,MASWRK
      CHARACTER*8 VARABL
      CHARACTER*1 BLANK,PLUS,DECPT,SLASH,COMMA,EQUALS,RPAREN,TAB,
     *            MINUS,LPAREN,LETE,LETD,LETS,LETQ,LETR,LETT,
     *            NUM(10),LETTER
      CHARACTER*1 LCONT,LEOD,LEOC
      CHARACTER*80 CARD
      COMMON /FREFM1/ NCOL,LSTCOL,MAXCOL,KEOF,KERR,LUIN,LUOUT,
     *                LUERR,KOLSV
      COMMON /FREFM2/ CARD,LCONT,LEOD,LEOC
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00, TEN=10.0D+00)
      DATA FIRST/.TRUE./
      SAVE FIRST,TAB,NUM,BLANK,PLUS,MINUS,DECPT,SLASH,COMMA,EQUALS,
     *     LPAREN,RPAREN,LETE,LETD,LETS,LETQ,LETR,LETT
C
C                 DECODE NUMERIC STRING ON INPUT CARD
C
C-----------------------------------------------------------------------
C
C        VARABL - ALPHAMERIC NAME OF VARIABLE BEING DECODED      (INPUT)
C      -- THE FOLLOWING PARAMETERS ARE ALL OUTPUT AND REFER TO
C              THE CURRENT PORTION OF THE STRING BEING DECODED --
C        VALUE  - REAL VALUE OF DIGIT STRING
C        ISIGN  - SIGN OF STRING (+1 OR -1)
C        FIXPNT - VALUE OF STRING TO LEFT OF DECIMAL POINT
C        FRACT  - VALUE OF STRING TO RIGHT OF DECIMAL POINT
C        IEXPFR - NO. OF DIGITS IN FRACTION STRING EXPRESSED AS A
C                 NEGATIVE NUMBER
C        ISIGNE - SIGN OF EXPONENT (+1 OR -1)
C        IEXP   - VALUE OF EXPONENT STRING
C
C-----------------------------------------------------------------------
C
C     CARD - CHARACTER ARRAY CONTAINING UNDECODED CARD IMAGE
C     NCOL   - LOCATION IN CARD TO BEGIN STRING SEARCH
C     LSTCOL - LOCATION IN CARD WHERE SEARCH WILL BE TERMINATED
C     MAXCOL - LAST LOCATION IN CARD THAT MAY CONTAIN USEFUL INFO.
C     KERR    - INTEGER WHICH SUPPLIES THE CALLING PROGRAM A FLAG TO
C               CHECK FOR READ ERRORS
C                    KERR = 0  -  NO ERROR   KERR = 1  -  READ ERROR,
C                    INFORMATION RETURNED IS NOT USEFUL
C               IF KERR = 30 AT ENTRY, NO ERROR MESSAGE IS PRINTED
C
C     LEND   = 1 IF A NON-BLANK CHARACTER HAS BEEN FOUND
C     LFIRST = LOCATION IN CARD OF FIRST CHARACTER OF DIGIT STRING
C     LAST   = LOCATION IN CARD OF LAST CHARACTER OF DIGIT STRING
C     KINDST = 1 FOR INTEGER DIGIT STRING
C     KINDST = 2 FOR DECIMAL FRACTION DIGIT STRING
C     KINDST = 3 FOR EXPONENT DIGIT STRING
C
C
C                         INITIALIZE VARIABLES
      IF(FIRST) THEN
         TAB = CHAR(9)
         NUM(1) = '0'
         NUM(2) = '1'
         NUM(3) = '2'
         NUM(4) = '3'
         NUM(5) = '4'
         NUM(6) = '5'
         NUM(7) = '6'
         NUM(8) = '7'
         NUM(9) = '8'
         NUM(10)= '9'
         BLANK = ' '
         PLUS =  '+'
         MINUS = '-'
         DECPT = '.'
         SLASH = '/'
         COMMA = ','
         EQUALS= '='
         LPAREN= '('
         RPAREN= ')'
         LETE =  'E'
         LETD  = 'D'
         LETS  = 'S'
         LETQ  = 'Q'
         LETR  = 'R'
         LETT  = 'T'
         FIRST = .FALSE.
      END IF
      TNUM=ZERO
      ISQRT=0
  110 LSIGN=1
      ICOMMA=0
      NEWCRD=0
      X=ZERO
      LSTERR=KERR
      KERR = 0
      NDECPT=0
      KINDST=1
      ISIGN=1
      ISIGNE=1
      VALUE=ZERO
      FIXPNT=ZERO
      FRACT=ZERO
      IEXPFR=0
      IEXP=0
      LEND=0
      LAST=KOLSV
C                   BEGIN LOOP TO DECODE CARD CHARACTERS
  120 LFIRST=0
  130 IF (NCOL.GT.LSTCOL) GO TO 240
      LETTER=CARD(NCOL:NCOL)
      CALL UPRCAS(LETTER,1)
      IF(LETTER.EQ.PLUS  ) GO TO 170
      IF(LETTER.EQ.MINUS ) GO TO 190
      IF((LFIRST.EQ.0  .AND.  LAST.LE.KOLSV)  .AND.
     *   (LETTER.EQ.LETD  .OR.  LETTER.EQ.LETE)) GO TO 290
      IF(LETTER.EQ.LETE  ) GO TO 200
      IF(LETTER.EQ.LETD  ) GO TO 200
      IF(LETTER.EQ.LCONT ) GO TO 208
      IF(LETTER.EQ.COMMA ) GO TO 210
      IF(LETTER.EQ.LPAREN) GO TO 210
      IF(LETTER.EQ.RPAREN) GO TO 210
      IF(LETTER.EQ.DECPT ) GO TO 220
      IF(LETTER.EQ.SLASH ) GO TO 230
      IF(LETTER.EQ.BLANK ) GO TO 250
      IF(LETTER.EQ.TAB  ) GO TO 250
      IF(LETTER.EQ.EQUALS) GO TO 250
      DO 140 J=1,10
      IF(LETTER.EQ.NUM(J)) GO TO 150
  140 CONTINUE
      LAST=NCOL
      IF(LETTER.NE.LETS) GO TO 290
      LAST=LAST+1
      IF(CARD(LAST:LAST).NE.LETQ) GO TO 290
      LAST=LAST+1
      IF(CARD(LAST:LAST).NE.LETR) GO TO 290
      LAST=LAST+1
      IF(CARD(LAST:LAST).NE.LETT) GO TO 290
      LAST=LAST+1
      IF(CARD(LAST:LAST).NE.LPAREN) GO TO 290
      NCOL=LAST+1
      ISQRT=1
      GO TO 130
C
  150 IF (LFIRST.EQ.0) LFIRST=NCOL
      IF(NCOL.EQ.MAXCOL) NEWCRD=1
  160 LEND=1
  170 NCOL=NCOL+1
      GO TO 130
C
  180 IF (LEND.GT.0) GO TO 350
      GO TO 170
C
  190 LSIGN=-1
      GO TO 170
C
  200 IF (LFIRST.NE.0) GO TO 260
      IF (LEND.EQ.0) FIXPNT=ONE
      IF (CARD(NCOL+1:NCOL+1).EQ.BLANK) NCOL=NCOL+1
      LSIGN=1
      KINDST=3
      GO TO 160
C
  208 NEWCRD=1
      IF(LFIRST.NE.0) GO TO 260
      IF(LEND.GT.0) GO TO 350
      CALL RDCARD('   *    ',KEOF)
      NEWCRD=0
      GO TO 130
C
  210 ICOMMA=1
      IF(LFIRST.NE.0) GO TO 260
      GO TO 350
C
  220 CONTINUE
      IF(NDECPT.GT.1) GO TO 290
      NDECPT=NDECPT+1
      IF (LFIRST.NE.0) GO TO 260
      ISIGN=LSIGN
      KINDST=2
      GO TO 160
C
  230 IF(LFIRST.NE.0) GO TO 260
      TNUM=(FIXPNT+FRACT*(TEN**IEXPFR))*(TEN**(ISIGNE*IEXP))
      IF(ISIGN.LT.0) TNUM=-TNUM
      NCOL=NCOL+1
      GO TO 110
C
  240 IF (LEND.EQ.0) NCOL=LSTCOL+1
      LEND=1
  250 IF (LFIRST.EQ.0) GO TO 180
C                  DECODE DIGIT STRING AND STORE IN X
  260 LAST=NCOL-1
      X=ZERO
      FAC=ONE
  270 CONTINUE
      DO 280 J=1,10
         IF (CARD(LAST:LAST).EQ.NUM(J)) GO TO 300
  280 CONTINUE
C
  290 CONTINUE
      IF(LSTERR.NE.30 .AND. LUOUT.GT.0 .AND. MASWRK) THEN
            WRITE(LUOUT,900) VARABL,LAST
            WRITE(LUOUT,910) CARD,(I,I=1,8)
      END IF
      IF(LSTERR.NE.30 .AND. LUERR.GT.0 .AND. LUOUT.LT.0
     *   .AND. MASWRK) THEN
            WRITE(LUERR,900) VARABL,LAST
            WRITE(LUERR,910) CARD,(I,I=1,8)
      END IF
      KERR = 1
      RETURN
C
  300 X=X+FAC*(J-1)
      IF (LAST.EQ.LFIRST) GO TO 310
      LAST=LAST-1
      FAC = TEN * FAC
      GO TO 270
C
C                STORE X,SIGN AND GO ON TO THE NEXT DIGIT STRING
C
  310 CONTINUE
      IF(KINDST.EQ.3) GO TO 340
         IF(KINDST.EQ.2) GO TO 330
            FIXPNT=X
            ISIGN=LSIGN
            GO TO 120
C
  330    FRACT=X
         IEXPFR=LFIRST-NCOL
         GO TO 120
C
  340 IEXP=INT(X)
      ISIGNE=LSIGN
      GO TO 120
C
C             COMBINE DECODED DIGIT STRINGS TO FORM CONSTANT
C
  350 CONTINUE
      VALUE=(FIXPNT+FRACT*(TEN**IEXPFR))*(TEN**(ISIGNE*IEXP))
      IF(TNUM.NE.ZERO) VALUE=TNUM/VALUE
      IF(ISQRT.EQ.1) VALUE=SQRT(VALUE)
      IF(ISIGN.LT.0) VALUE=-VALUE
      NCOL=NCOL+ICOMMA
      IF(NEWCRD.EQ.1) CALL RDCARD('   *    ',KEOF)
      RETURN
C
  900 FORMAT(1X,'**** ERROR READING VARIABLE ',A8,
     *      ' CHECK COLUMN',I3)
  910 FORMAT(1X,A80/1X,8('....V....',I1))
      END
C*MODULE FRFMT   *DECK FNDGRP
      SUBROUTINE FNDGRP(IR,GRPNAM,IEOF)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      CHARACTER*8 WORD,GRPNAM
C
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      IF (MASWRK) THEN
         IEOF = 0
  100    CONTINUE
            READ (IR,9000,END=200) WORD
            CALL UPRCAS(WORD,8)
            IF (WORD.EQ.GRPNAM) GO TO 300
         GOTO 100
C
  200    CONTINUE
         IEOF = 1
      ENDIF
C
  300 CONTINUE
      IF (GOPARR) CALL DDI_BCAST(275,'I',IEOF,1,MASTER)
      RETURN
C
 9000 FORMAT(A8)
      END
C*MODULE FRFMT   *DECK GSTRNG
      SUBROUTINE GSTRNG(STRING,LENGTH)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      LOGICAL FIRST
      CHARACTER*(*) STRING
      CHARACTER*1 BLANK,TAB,QUOTE,EQUAL,COMMA,LPAREN
      CHARACTER*1 LCONT,LEOD,LEOC
      CHARACTER*80 CARD
      COMMON /FREFM1/ NCOL,LSTCOL,MAXCOL,KEOF,KERR,LUIN,LUOUT,
     *                LUERR,KOLSV
      COMMON /FREFM2/ CARD,LCONT,LEOD,LEOC
      DATA FIRST/.TRUE./
      SAVE FIRST,BLANK,QUOTE,EQUAL,COMMA,LPAREN,TAB
C
C           TRANSFER LENGTH CHARACTERS FROM INPUT CARD TO STRING
C
C           STRING WILL BE PADDED WITH BLANKS ON THE RIGHT IF NECESSARY
C           THERE ARE THREE OPTIONS:
C           LENGTH > 0 - THE NEXT LENGTH CHARACTERS STARTING AT CURRENT
C                        POSITION OF COLUMN POINTER (NCOL) ARE COPIED
C           LENGTH = 0 - THE NEXT STRING ENCLOSED IN SINGLE QUOTES (')
C                        WILL BE COPIED.  THE NUMBER OF CHARACTERS IN
C                        THE STRING IS RETURNED IN LENGTH.  IF THE NEXT
C                        STRING DOES NOT START WITH A QUOTE, STRING
C                        WILL BE BLANKED.
C           LENGTH < 0 - UP TO IABS(LENGTH) CHARACTERS WILL BE COPIED
C                        FROM THE NEXT STRING.  THE REMAINDER OF STRING
C                        WILL BE BLANKED AS SOON AS A BLANK, EQUAL SIGN,
C                        OR COMMA IS ENCOUNTERED.
C           IF THE FIRST NON-BLANK CHARACTER ENCOUNTERED IS >, A NEW
C           CARD WILL BE READ BEFORE TRANSFERRING THE STRING.
C
      KOLSV = NCOL
      IF(FIRST) THEN
         BLANK = ' '
         QUOTE = ''''
         EQUAL = '='
         COMMA = ','
         LPAREN = '('
         TAB= CHAR(9)
         FIRST=.FALSE.
      END IF
C
  100 CONTINUE
      NOCHAR=MAX(IABS(LENGTH),4)
      NCC=0
      NBC=NOCHAR
      IF(NCOL.GT.LSTCOL) GO TO 320
C                    IF ALREADY AT END OF CARD, RETURN A BLANK STRING
      LSTART=NCOL-1
      LSTOP=LSTART+NOCHAR
C
C                 LOCATE FIRST NON-BLANK CHARACTER
C
      DO 110 N=NCOL,LSTCOL
         IF(CARD(N:N).EQ.TAB) GO TO 110
         IF(CARD(N:N).NE.BLANK) GO TO 120
  110 CONTINUE
      NCOL=LSTCOL+1
      GO TO 300
C
  120 CONTINUE
      IF(CARD(N:N).NE.LCONT) GO TO 130
C
C              AVOID RECURSIVE CALLS TO RDCARD
C
         IF(STRING(1:4).EQ.'   *') RETURN
            CALL RDCARD('   *    ',KEOF)
            GO TO 100
C
C                    FIRST CHARACTER IS > SO GET NEW CARD AND START OVER
C
  130 CONTINUE
      NCOL=LSTOP+1
      IF(LENGTH.LT.0) GO TO 200
      IF(LENGTH.GT.0) GO TO 300
C
      NCOL=N
      IF(CARD(N:N).NE.QUOTE) GO TO 300
C
C                  FIRST CHARACTER IS A SINGLE QUOTE (')
C
      LSTART=NCOL-1
  140 CONTINUE
      NCOL=NCOL+1
C
C                   SHIFT COLUMNS LEFT TO ERASE '
C
      DO 150 N=NCOL,LSTCOL
         CARD(N-1:N-1)=CARD(N:N)
  150 CONTINUE
      CARD(LSTCOL:LSTCOL)=BLANK
C
C                  FIND NEXT QUOTE
C
      DO 160 N=NCOL,LSTCOL
         IF(CARD(N:N).EQ.QUOTE) GO TO 170
  160 CONTINUE
      N=LSTCOL
  170 CONTINUE
      NCOL=N+1
C
C                  CHECK FOR ADJACENT QUOTES (KEEP ONE IN STRING)
C
      IF(NCOL.LT.LSTCOL .AND. CARD(NCOL:NCOL).EQ.QUOTE) GO TO 140
      LSTOP=N-1
      LENGTH=LSTOP-LSTART
      NOCHAR=MAX(LENGTH,4)
      GO TO 300
C
C           COPY UP TO -LENGTH ADJACENT NON-BLANK CHARACTERS STARTING
C              WITH THE NEXT NON-BLANK CHARACTER
C
  200 CONTINUE
      NCOL=N
      LSTART=NCOL-1
C
C                 CHECK FOR TERMINATION OF STRING
C
      DO 210 N=NCOL,LSTCOL
         IF(CARD(N:N).EQ.BLANK) GO TO 220
         IF(CARD(N:N).EQ.EQUAL) GO TO 220
         IF(CARD(N:N).EQ.COMMA) GO TO 220
         IF(CARD(N:N).EQ.LPAREN) GO TO 220
  210 CONTINUE
      N=LSTCOL+1
  220 CONTINUE
      NCOL=N+1
      LSTOP=MIN(LSTART+NOCHAR,N-1)
C
C              TRANSFER CHARACTERS TO STRING
C
  300 CONTINUE
      NCC=MIN(LSTOP,LSTCOL) - LSTART
      NBC=NOCHAR - NCC
      IF(NCC.LE.0) GO TO 320
         DO 310 N=1,NCC
            STRING(N:N)=CARD(LSTART+N:LSTART+N)
  310    CONTINUE
  320 CONTINUE
      IF(NBC.EQ.0) GO TO 340
C
C                  PAD WITH NBC BLANKS
C
         DO 330 N=1,NBC
            STRING(NCC+N:NCC+N)=BLANK
  330    CONTINUE
  340 CONTINUE
C
C        CONVERT KEYWORD TO UPPER CASE
C
      IF(LENGTH.LT.0) CALL UPRCAS(STRING,IABS(LENGTH))
      RETURN
      END
C*MODULE FRFMT   *DECK IFIND
      FUNCTION IFIND(VARABL,IERR)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      CHARACTER*8 VARABL
      COMMON /FREFM1/ NCOL,LSTCOL,MAXCOL,KEOF,KERR,LUIN,LUOUT,
     *                LUERR,KOLSV
C
C       DECODE NEXT STRING ON CURRENT INPUT CARD AS AN INTEGER VARIABLE
C           VARABL - ALPHAMERIC NAME OF VARIABLE BEING DECODED
C                    GIVE A DESCRIPTIVE NAME, THIS WILL BE PRINTED
C                    IF AN ERROR IS ENCOUNTERED WHEN SCANNING
C           IERR   - CAN BE USED TO SUPPRESS ERRORS, OR TO LEARN
C                    IF AN ERROR OCCURRED.  SEE KERR DESCRIPTION.
C
      KOLSV = NCOL
      KERR = IERR
      CALL DECODN(VARABL,VALUE,ISIGN,FIXPNT,FRACT,IEXPFR,ISIGNE,IEXP)
C
C           VALUE=ISIGN*(FIXPNT+FRACT*(10**IEXPFR))*(10**(ISIGNE*IEXP))
C           UNLESS THE STRING WAS REPRESENTED AS A FRACTION
C
C                            MAKE UP INTEGER CONSTANT
      IFRACT=INT(FRACT)
      INTT=INT(FIXPNT)
      I1=10**IEXP
      I2=IEXPFR+ISIGNE*IEXP
      I3=10**IABS(I2)
      IF (ISIGNE.LT.0) GO TO 130
C
      IF (I2.LT.0) THEN
         I5=IFRACT/I3
      ELSE
         I5=IFRACT*I3
      END IF
C
      IFIND=ISIGN*(INTT*I1+I5)
      IERR = KERR
      RETURN
C
  130 IFIND=ISIGN*INTT/I1
      IERR = KERR
      RETURN
      END
C*MODULE FRFMT   *DECK OPNCRD
      SUBROUTINE OPNCRD(IR,IW)
      CHARACTER*1 LCONT,LEOD,LEOC
      CHARACTER*80 CARD
      COMMON /FREFM1/ NCOL,LSTCOL,MAXCOL,KEOF,KERR,LUIN,LUOUT,
     *                LUERR,KOLSV
      COMMON /FREFM2/ CARD,LCONT,LEOD,LEOC
C
C     OPEN FREE FORMAT ROUTINES.  CARDS WILL BE READ FROM UNIT
C     -IR-, WITH OUTPUT TO -IW-, WITH THESE SIDE CONDITIONS:
C        IW>0 - ECHO INPUT CARDS ON THE OUTPUT.
C        IW=0 - NO PRINTOUT, EVER.
C        IW<0 - DO NOT ECHO INPUT, BUT DO WRITE ANY POSSIBLE
C               ERROR MESSAGES TO IABS(IW).
C
C     CONTENTS OF COMMON BLOCKS /FREFM1/ AND /FREFM2/ ARE
C           NCOL   - CURRENT COLUMN POINTER
C           KOLSV  - COLUMN OF PREVIOUS DATA FIELD (FOR REREADING)
C           LSTCOL - LAST COLUMN OF LOGICAL CARD TO BE INTERPRETED
C           MAXCOL - LAST COLUMN OF REAL CARD TO BE INTERPRETED
C           KEOF   - CARD STATUS FLAG
C                    -1 - CARD IS TO BE RESCANNED
C                     0 - READY FOR NEW LOGICAL CARD
C                     1 - END OF CARD INPUT FILE HAS BEEN ENCOUNTERED
C           KERR   - READ ERROR FLAG
C           LUIN   - LOGICAL FILE NUMBER FOR CARD INPUT
C           LUOUT  - LOGICAL FILE NUMBER FOR PRINTED OUTPUT
C           LUERR  - LOGICAL FILE NUMBER FOR ERROR MESSAGES
C           CARD   - ARRAY WITH ONE ELEMENT FOR EACH COLUMN OF A CARD
C           LCONT  - CONTINUE LOGICAL CARD TO NEXT PHYSICAL CARD
C           LEOD   - END OF DATA CHARACTER
C           LEOC   - END OF LOGICAL CARD CHARACTER
C
      MAXCOL= 80
      KEOF  = 0
      KERR  = 0
      LUIN  = IR
      LUOUT = IW
      LUERR = IABS(IW)
      LCONT = '>'
      LEOD  = '!'
      LEOC  = ';'
      RETURN
      END
C*MODULE FRFMT   *DECK RDCARD
      SUBROUTINE RDCARD(ROUTIN,IEOF)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      LOGICAL FIRST,GOPARR,DSKWRK,MASWRK
      CHARACTER*8 ROUTIN,ROUTNE,STAR,STARS
      CHARACTER*4 KEYWRD,KCOL,KSET,KEOD,KEOC
      CHARACTER*1 LCONT,LEOD,LEOC
      CHARACTER*80 CARD
      INTEGER CMSG(80)
      COMMON /FREFM1/ NCOL,LSTCOL,MAXCOL,KEOF,KERR,LUIN,LUOUT,
     *                LUERR,KOLSV
      COMMON /FREFM2/ CARD,LCONT,LEOD,LEOC
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      DATA FIRST/.TRUE./
      SAVE FIRST,MORE,STAR,STARS,KCOL,KSET,KEOD,KEOC,LASTC
C
C        READ NEW CURRENT CARD IN
C
C-----------------------------------------------------------------------
C
C           ROUTIN - 8 CHARACTER NAME OF CALLING ROUTINE'S READ SITE.
C                    NORMALLY THE 6 LETTER ROUTINE NAME, FOLLOWED
C                    BY THE NUMBER OF THE CALL WITHIN THE ROUTINE,
C                    E.G. 'ABCDEF 3', INDICATING THE 3RD TYPE OF
C                    CARD THE ROUTINE ABCDEF EXPECTS TO READ.
C           IEOF   - INPUT AS -1 TO REREAD THE PREVIOUS CARD,
C                              0 TO READ NEXT CARD (MOST CALLS)
C                    RETURNS AS 1 IF END OF FILE IS HIT.
C
C-----------------------------------------------------------------------
C
      IZERO = 0
      IONE = 1
      KEOF = IEOF
      IF(FIRST) THEN
         MORE=0
         STAR='   *    '
         STARS='   **   '
         KCOL='COL '
         KSET='SET '
         KEOD='EOD '
         KEOC='EOC '
         FIRST=.FALSE.
      END IF
C
      IF(MAXCOL.LE.0 .OR. MAXCOL.GT.80) CALL OPNCRD(5,6)
      IF(LUIN.LE.0 .OR. LUIN.GT.99) CALL OPNCRD(5,6)
      IF(KEOF.EQ.1) GO TO 170
         ROUTNE=ROUTIN
         KPRNT=1
         IF(KEOF.EQ.(-1)) GO TO 160
            KPRNT=2
            IF(MORE.EQ.1) GO TO 120
  105          KPRNT=0
               NSTART=MAXCOL+1
               LSTCOL=MAXCOL
               KEOF=1
               IF (MASWRK) THEN
                  READ(LUIN,900,END=180) CARD
                  IF (GOPARR) THEN
                     CALL DDI_BCAST(300,'I',IZERO,1,MASTER)
                     DO 106 I=1,80
                        CMSG(I) = ICHAR(CARD(I:I))
  106                CONTINUE
                  END IF
               ELSE
                  IF (GOPARR)
     *               CALL DDI_BCAST(300,'I',IEND,1,MASTER)
                  IF (IEND.EQ.IONE) GO TO 180
               ENDIF
               IF (GOPARR) CALL DDI_BCAST(301,'I',CMSG,80,MASTER)
               IF (.NOT.MASWRK) THEN
                  DO 107 I=1,80
                     CARD(I:I) = CHAR(CMSG(I))
  107             CONTINUE
               END IF
               IF(LUOUT.GT.0 .AND. MASWRK) WRITE(LUOUT,901) ROUTNE,CARD
               IF(ROUTNE.EQ.STAR) GO TO 118
C
C                   RECURSIVE CALLS TO GSTRNG AND DECODN WILL BE AVOIDED
C
                  NSET=0
                  NCOL=1
  112             CONTINUE
                  KEYWRD='   *'
                  LGSTR=-4
                  CALL GSTRNG(KEYWRD,LGSTR)
                  IF(KEYWRD.NE.KSET) GO TO 117
                     LGSTR=-4
                     CALL GSTRNG(KEYWRD,LGSTR)
                     IF(KEYWRD.NE.KCOL) GO TO 113
                        IERR=0
                        MAXCOL=IFIND('MAXCOL  ',IERR)
                        NSET=NSET+1
                        GO TO 112
C
  113                IF(KEYWRD.NE.KEOD) GO TO 114
                        LGSTR=-4
                        CALL GSTRNG(LEOD,LGSTR)
                        NSET=NSET+1
                        GO TO 112
C
  114                IF(KEYWRD.NE.KEOC) GO TO 115
                        LGSTR=-4
                        CALL GSTRNG(LEOC,LGSTR)
                        NSET=NSET+1
                        GO TO 112
C
  115                IF(KEYWRD.NE.LCONT) GO TO 117
                        LGSTR=-4
                        CALL GSTRNG(LCONT,LGSTR)
                        NSET=NSET+1
                        GO TO 112
C
  117             IF(NSET.EQ.0) GO TO 118
                     IF(LUOUT.GT.0 .AND. MASWRK) WRITE(LUOUT,904)
     *                  NSET,MAXCOL,LEOD,LEOC,LCONT
                     ROUTNE=STARS
                     GO TO 105
C
  118          CONTINUE
               LASTC=0
  120       CONTINUE
C
C              CHECK FOR DATA FIELD TERMINATION
C
            MORE=1
            NSTART=LASTC+1
            LASTC=MAXCOL+1
            DO 130 N=NSTART,MAXCOL
               IF(CARD(N:N).EQ.LEOD) LASTC=N
               IF(CARD(N:N).EQ.LEOC) GO TO 150
  130       CONTINUE
            N=LASTC
            MORE=0
  150       LSTCOL=MIN(LASTC,N)-1
            LASTC=N
  160    CONTINUE
         IF(KPRNT.EQ.1 .AND. LUOUT.GT.0 .AND. MASWRK)
     *      WRITE(LUOUT,902) ROUTNE
         IF(KPRNT.EQ.2 .AND. LUOUT.GT.0 .AND. MASWRK)
     *      WRITE(LUOUT,903) NSTART,LSTCOL,ROUTNE
         KEOF=0
  170 CONTINUE
      NCOL=NSTART
      KOLSV=NCOL
      IEOF = KEOF
      RETURN
  180 CONTINUE
      IF (MASWRK.AND.GOPARR) CALL DDI_BCAST(300,'I',IONE,1,MASTER)
      NCOL=NSTART
      KOLSV=NCOL
      IEOF = KEOF
      RETURN
C
  900 FORMAT(A80)
  901 FORMAT(1X,A8,'>',A80)
  902 FORMAT(10X,10HREREAD AT ,A8)
  903 FORMAT(10X,8HCOLUMNS ,I2,3H - ,I2,1X,8HREAD AT ,A8)
  904 FORMAT(/6X,I2,' CARD PARAMETERS HAVE BEEN RESET --'/1X,
     *       7H  COL =,I3,3X,7H EOD = ,A4,7H EOC = ,A4,8H CONT = ,A4/)
      END
C*MODULE FRFMT   *DECK REREAD
      SUBROUTINE REREAD
      COMMON /FREFM1/ NCOL,LSTCOL,MAXCOL,KEOF,KERR,LUIN,LUOUT,
     *                LUERR,KOLSV
      NCOL=KOLSV
      RETURN
      END
C*MODULE FRFMT   *DECK RFIND
      FUNCTION RFIND(VARABL,IERR)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      CHARACTER*8 VARABL
      COMMON /FREFM1/ NCOL,LSTCOL,MAXCOL,KEOF,KERR,LUIN,LUOUT,
     *                LUERR,KOLSV
C
C       DECODE NEXT STRING ON CURRENT INPUT CARD AS AN REAL VARIABLE
C           VARABL - ALPHAMERIC NAME OF VARIABLE BEING DECODED
C                    GIVE A DESCRIPTIVE NAME, THIS WILL BE PRINTED
C                    IF AN ERROR IS ENCOUNTERED WHEN SCANNING
C           IERR   - CAN BE USED TO SUPPRESS ERRORS, OR TO LEARN
C                    IF AN ERROR OCCURRED.  SEE KERR DESCRIPTION.
C
      KOLSV = NCOL
      KERR = IERR
      CALL DECODN(VARABL,VALUE,ISIGN,FIXPNT,FRACT,IEXPFR,ISIGNE,IEXP)
C
C           VALUE=ISIGN*(FIXPNT+FRACT*(10**IEXPFR))*(10**(ISIGNE*IEXP))
C           UNLESS THE STRING WAS REPRESENTED AS A FRACTION
C
      RFIND=VALUE
      IERR = KERR
      RETURN
      END
C*MODULE FRFMT   *DECK UPRCAS
      SUBROUTINE UPRCAS(STRING,LENSTR)
C
      CHARACTER*(*) STRING
      CHARACTER*26 UCASE,LCASE
C
      DATA UCASE /'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
      DATA LCASE /'abcdefghijklmnopqrstuvwxyz'/
C
C        CONVERTS LOWER CASE TO UPPER CASE IN THE GIVEN STRING.
C
      DO 100 I=1,LENSTR
         IC = INDEX(LCASE,STRING(I:I))
         IF (IC.GT.0) STRING(I:I) = UCASE(IC:IC)
  100 CONTINUE
      RETURN
      END
