C *********************************************************************
C **********                  NXTTKN                         **********
C *********************************************************************
C ***   NXTTKN  6 JUN 78  (PRY)
C ***   NXTTKN CLASSIFIES AND RETURNS THE NEXT TOKEN FROM THE INPUT
C ***   FILE.  UPON RETURNING, THE CURRENT CHARACTER IS THE
C ***   CHARACTER IMMEDIATELY FOLLOWING THE IDENTIFIED TOKEN
C ***   EXCEPT FOR THE END-OF-FILE TOKEN WHICH DOES NOT CHANGE
C ***   THE CURRENT CHARACTER (LEFT AT END OF FILE) AND
C ***   THE END-OF-RECORD TOKEN FOR WHICH A FLAG (EORFLG) IS SET
C ***   TO INDICATE THAT THE NEXT RECORD MUST BE READ.  THIS INSURES
C ***   THAT A RECORD REMAINS PRESENT WHILE ANY END-OF-RECORD
C ***   PROCESSING MUST BE PERFORMED.
C
      SUBROUTINE NXTTKN
C
      INCLUDE AEXTGLBLS
C
      LOGICAL ALPHA, DIGIT, SPLCHR
      INTEGER ITMKEY
C
C ***   ALPHA - .TRUE. IF ARGUMENT CHAR IS ALPHABETIC
C ***   DIGIT - .TRUE. IF ARGUMENT CHAR IS NUMERIC
C ***   SPLCHR - .TRUE. IF ARGUMENT CHAR IS $, _, #, OR @
C ***   ITMKEY - FUNCTION TO RETURN ID OF KEYWORD OR 0
C
      GLOBAL SPLHIT
      INTEGER SPLHIT
C
C ***   SPLHIT - INCREMENTED FOR EACH SPECIAL ONE ENCOUNTERED.
C
C ********************
C ***   IF WE WERE IN A COMMENT, CONTINUE IT.
C
C ***   GET NEXT RECORD IF LAST TOKEN WAS END-OF-RECORD.
10010 IF (EORFLG) CALL NXTCHR
      SPLHIT = 0
C
C ***   IGNORE LEADING BLANKS.
C
10015 IF (RECCHR.NE.1R ) GOTO 10020
C        CALL NXTCHR
C        GOTO 10015
C ***   IN-LINE 'NXTCHR' TO SPEED THINGS UP.
10016    IF (RECPOS.LT.RECLEN) GOTO 10019
            CALL NXTCHR
10019    RECPOS = RECPOS + 1
         IF (RECORD(RECPOS).EQ.1R ) GOTO 10016
         RECCHR = RECORD(RECPOS)
C
C ***   INITIALIZE FOR NEXT TOKEN.
C
10020 TITEM(0) = 0
C ***   SAVE POSITIONAL INFORMATION.
      TRCPOS = RECPOS
      TRCNBR = RECNBR
      TRCKEY = RECKEY
C
C **********
C ***   HANDLE ALPHA STRING (NAME).
C
11010 IF ( (RECCHR.LE.1RZ) .AND. (RECCHR.GE.1RA) ) GOTO 11015
      IF (SPLCHR(RECCHR)) GOTO 11015
      GOTO 12010
11015    TOKEN = TNAME
C11020   CALL STRCHR
C ***   IN-LINE 'STRCHR' TO SPEED THINGS UP.
11020    TITEM(0) = TITEM(0) + 1
         TITEM(TITEM(0)) = RECCHR
         IF (RECPOS.LT.RECLEN) GOTO 11024
            CALL NXTCHR
            GOTO 11027
11024    RECPOS = RECPOS + 1
         RECCHR = RECORD(RECPOS)
C     ***   KEEP ADDING CHARS TO NAME WHILE VALID NAME CHARS.
11025    IF (RECCHR.LT.1RA) GOTO 11026
         IF (RECCHR.LE.1RZ) GOTO 11020
         GOTO 11028
C     ***   CHANCES ARE THAT IT'S A BLANK.
11026    IF (RECCHR.EQ.1R ) GOTO 11027
11028    IF (RECCHR.EQ.1R_) GOTO 11020
         IF (RECCHR.EQ.1R$) GOTO 11020
         IF ( (RECCHR.GE.1Ra) .AND. (RECCHR.LE.1Rz) ) GOTO 11020
         IF (DIGIT(RECCHR)) GOTO 11020
         IF (SPLCHR(RECCHR)) GOTO 11020
11027    TPL6ID = ITMKEY()
         RETURN
C
C **********
C ***   HANDLE DIGIT STRING (INTEGER).
C
12010 IF ( (RECCHR.LT.1R0) .OR. (RECCHR.GT.1R9) ) GOTO 13010
         TOKEN = TDIGIT
         TPL6ID = 0
12020    TPL6ID = TPL6ID * 10 + RECCHR - 1R0
         CALL STRCHR
C     ***   KEEP PROCESSING DIGITS 'TIL DIGIT STRING END.
C     ***   IF ALPHA, THIS DIGIT STRING IS REALLY A NAME.
         IF (ALPHA(RECCHR)) GOTO 11015
         RETURN
C
C **********
C ***   HANDLE 'STRINGS', "STRINGS", 'STRINGS'O, 'STRINGS'B.
C
13010 QUOTE = 1R'
      IF (RECCHR.EQ.QUOTE) GOTO 13020
         QUOTE = 1R"
         IF (RECCHR.NE.QUOTE) GOTO 14010
C     ***   SAVE NEXT CHAR AND GET NEXT.
13020    CALL STRCHR
C     ***   END-OF-RECORD OR END-OF-FILE ENDS STRING.
         IF (RECCHR.LT.0) GOTO 13070
C     ***   CHECK FOR CLOSING QUOTE.
13060    IF (RECCHR.NE.QUOTE) GOTO 13020
         CALL STRCHR
C     ***   CHECK FOR TWO ADJACENT QUOTES.
         IF (RECCHR.EQ.QUOTE) GOTO 13020
C
C ***   END OF STRING.   CHECK WHICH TYPE.
C
13070    TOKEN = TDQSTR
         IF (QUOTE.EQ.1R") RETURN
         TOKEN = TSQSTR
C     ***   FOR STRING ENDING WITH ', CHECK IF O OR B FOLLOWS.
         IF ( (RECCHR.NE.1RO) .AND. (RECCHR.NE.1RB) ) RETURN
         TOKEN = TBTSTR
         CALL STRCHR
         RETURN
*
C **********
C ***   CHECK FOR SINGLE CHAR TYPE TOKENS.
C
C ***   FOR END-OF-FILE AND END-OF-RECORD DON'T GET THE NEXT CHAR YET.
14010 IF (RECCHR.GE.0) GOTO 14015
14012 TITEM(0) = 0
      TOKEN = TEOF
      IF (RECCHR.EQ.-1) RETURN
C ***   MUST BE SPECIAL END-OF-RECORD CODE.
         TOKEN = TEOR
         EORFLG = .TRUE.
         RETURN
C
C ***   CHECK WHICH CHAR WE GOT.
C
14015 CALL STRCHR
      IF (TITEM(1).NE.1R;) GOTO 14016
         TOKEN = TSMICL
         RETURN
14016 IF (TITEM(1).NE.1R=) GOTO 14017
         TOKEN = TEQUAL
         RETURN
         TOKEN = TPEROD
         RETURN
14018 TOKEN = TARMOP
      IF (TITEM(1).EQ.1R-) GOTO 14040
      IF (TITEM(1).EQ.1R+) RETURN
      IF (TITEM(1).EQ.1R/) GOTO 14050
      TOKEN = TRELOP
      IF (TITEM(1).EQ.1R<) GOTO 14030
      IF (TITEM(1).EQ.1R>) GOTO 14030
      TOKEN = TLPAR
      IF (TITEM(1).EQ.1R() RETURN
      TOKEN = TRPAR
      IF (TITEM(1).EQ.1R)) RETURN
      TOKEN = TCOMMA
      IF (TITEM(1).EQ.1R,) RETURN
      TOKEN = TCOLON
      IF (TITEM(1).EQ.1R:) RETURN
      TOKEN = TPRCNT
      IF (TITEM(1).EQ.1R%) RETURN
      TOKEN = TNOT
      IF (TITEM(1).EQ.1R~) GOTO 14030
      TOKEN = TARMOP
      IF (TITEM(1).EQ.1R*) GOTO 14060
      IF (TITEM(1).EQ.1R&) RETURN
      IF (TITEM(1).EQ.1R|) RETURN
      TOKEN = TRPAR
      IF (TITEM(1).EQ.1R]) RETURN
      IF (TITEM(1).EQ.1R}) RETURN
      TOKEN = TLPAR
      IF (TITEM(1).EQ.1R[) RETURN
      IF (TITEM(1).EQ.1R{) RETURN
C
C ***   CHAR COULDN'T BE IDENTIFIED.  IGNORE IF IN COMMENT
C ***   OTHERWISE REPORT ERROR AND IGNORE.
C
      IF (INCMNT) GOTO 10015
      WRITE(ERUNIT,14020) RECNBR, ABS(RECKEY), TITEM(1)
14020 FORMAT( ' *** ILLEGAL CHAR IN REC # ', I5, '(', F8.3, ')',
     &      ' HAS DECIMAL CODE ', I5 )
      GOTO 10015
C
C *****
C ***   CHECK IF = FOLLOWS ~, <, OR > FOR RELOP.
C
14030 IF (RECCHR.NE.1R=) RETURN
      TOKEN = TRELOP
14035 CALL STRCHR
      RETURN
C
C *****
C ***   CHECK IF > FOLLOWS - FOR -> (ARITH OP).
C
14040 IF (RECCHR.EQ.1R>) GOTO 14035
      RETURN
C
C *****
C ***   CHECK IF * FOLLOWS / FOR COMMENT BEGINNING.
C
14050 IF (RECCHR.NE.1R*) RETURN
C ***   DON'T FIND COMMENT BEGINNINGS WITHIN COMMENT.
      IF (.NOT.INCMNT) TOKEN = TCMBGN
      INCMNT = .TRUE.
      GOTO 14035
C
C *****
C ***   CHECK IF / FOLLOWS * FOR COMMENT END.
C
14060 IF (RECCHR.NE.1R/) RETURN
      TOKEN = TCMEND
      INCMNT = .FALSE.
      GOTO 14035
      END
C *********************************************************************
C **********               IDITM                             **********
C *********************************************************************
C ***   IDITM   16 FEB 78   (PRY)   RETURNS AN IDENTIFICATION
C ***   NUMBER FOR THE CURRENT ITEM.
C
      INTEGER FUNCTION IDITM( )
C
      INTEGER LOOKUP, ADDTBL
C
C ********************
C ***   LOOKUP NAME IN NAME TABLE.   IF NOT IN, ADD IT.
C
10010 IDITM = LOOKUP( )
      IF (IDITM.EQ.0) IDITM = ADDTBL( )
      RETURN
      END
C *********************************************************************
C **********               LOOKUP                            **********
C *********************************************************************
C ***   LOOKUP   16 FEB 78   (PRY)   LOOKS UP THE CURRENT ITEM IN
C ***   THE NAME TABLE AND RETURNS 0 IF NOT FOUND OR ITS
C ***   IDENTIFICATION NUMBER (RELATIVE POSITION IN TABLE).
C ***   THE NAME TABLE CONTAINS ADJACENT TEXTC NAMES.
C
      INTEGER FUNCTION LOOKUP( )
C
      INCLUDE AEXTGLBLS
C
      INTEGER SRCHX, SRCHID
C
C ********************
C ***   INITIALIZE SEARCH PARAMETERS.  ASSUME NAME WILL NOT BE FOUND.
C
10010 LOOKUP = 0
      SRCHX  = 1
      SRCHID = 1
C
C ***   IF THE SEARCH INDEX IS BEYOND THE END OF THE TABLE, THE NAME
C ***   WAS NOT FOUND.  OTHERWISE CHECK IF CURRENT ITEM IS A CURRENT
C ***   TABLE POSITION.
C
10020 IF (SRCHX.GE.NAMFIX) RETURN
C ***   NAMES MUST BE OF SAME LENGTH.
      IF (NAMTBL(SRCHX).NE.TITEM(0)) GOTO 10040
C
C     ***   COMPARE CORRESPONDING NAME CHARS.
C
         DO 10030 I=1,TITEM(0)
            IF (NAMTBL(SRCHX+I).NE.TITEM(I)) GOTO 10040
10030       CONTINUE
         LOOKUP = SRCHID
         RETURN
C
C ***   TRY NEXT NAME IN TABLE.
C
10040 SRCHX = SRCHX + NAMTBL(SRCHX) + 1
      SRCHID = SRCHID + 1
      GOTO 10020
      END
C *********************************************************************
C **********                  ADDTBL                         **********
C *********************************************************************
C ***   ADDTBL   16 FEB 78   (PRY)   ADD THE CURRENT ITEM TO THE NAME
C ***   TABLE AND RETURN ITS IDENTIFICATION NUMBER.
C
      INTEGER FUNCTION ADDTBL( )
C
      INCLUDE AEXTGLBLS
C
C ********************
C ***   IF NAME CAN NOT FIT IN TABLE, ERROR MESSAGE AND RETURN.
C
10010 IF (NAMFIX+TITEM(0).LE.TBLMAX) GOTO 10030
         WRITE(108,10029) RECNBR, RECKEY, TITEM(0),
     &         (TITEM(I),I=1,TITEM(0))
10029    FORMAT( ' *** NAME AT REC # ', I5, '(', F8.3, ')',
     &         ' NOT ADDED TO FULL SYMBOL TABLE: ', NR1 )
         ADDTBL = 0
         RETURN
C
C ***   ENOUGH ROOM IN TABLE.   APPEND THE CURRENT ITEM ONTO
C ***   THE END.
C
10030 DO 10040 I=0,TITEM(0)
         NAMTBL(NAMFIX+I) = TITEM(I)
10040    CONTINUE
C
C
      NAMFIX = NAMFIX + TITEM(0) + 1
C ***   INCREASE NAME ID FOR CURRENT NAME'S ID.
      NAMNID = NAMNID + 1
      ADDTBL = NAMNID
      RETURN
      END
C *********************************************************************
C **********               RSTTBL                            **********
C *********************************************************************
C ***   RSTTBL  6 JUN 78  (PRY)
C ***   RSTTBL RESETS THE NAME TABLE TO NO ENTRIES.
C
      SUBROUTINE RSTTBL
C
      INCLUDE AEXTGLBLS
C
C ********************
C ***   RESET NAME TABLE INDICES.
C
C ***   NO NAMES.
10010 NAMNID = 0
C ***   NEXT FREE NAME TABLE IX IS FIRST.
      NAMFIX = 1
      RETURN
      END
C *********************************************************************
C **********            RDCLNM                               **********
C *********************************************************************
C ***   RDCLNM  6 JUN 78  (PRY)
C ***   RDCLNM RESETS THE LAST FULLY QUALIFIED DATA ITEM NAME.
C
      SUBROUTINE RDCLNM
C
      INCLUDE AEXTGLBLS
C
C ********************
C ***   NO LEVELS MEANS NO NAMES.
C
10010 LSTEND = 0
      LSTNPS(0) = -1
      RETURN
      END
C *********************************************************************
C **********               ADCLNM                            **********
C *********************************************************************
C ***   ADCLNM  6 JUN 78  (PRY)
C ***   ADCLNM ADDS A NAME TO THE CURRENT FULLY QUALIFIED DATA ITEM
C ***   NAME AT THE SPECIFIED LOGICAL LEVEL.
C
C
      INTEGER LEVEL
C
C ***   LEVEL - LOGICAL LEVEL WHERE NAME SHOULD GO
C
      INCLUDE AEXTGLBLS
C
      INTEGER LEV
C
C ***   LEV - PHYSICAL LEVEL CORRESPONDING TO LOGICAL LEVEL
C
C ********************
C ***   CONVERT LOGICAL LEVEL TO PHYSICAL LEVEL.
C
C ***   IF THIS IS FIRST NAME, NO SEARCH.
10010 IF (LSTEND.EQ.0) GOTO 10040
C ***   SEARCH FOR PROPER LEVEL.
      DO 10030 LEV=1,LSTEND
10030    IF (LSTLEV(LEV).GE.LEVEL) GOTO 10050
C
C ***   ADD NAME AT NEXT LEVEL.
C
10040 LEV = LSTEND + 1
10050 LSTLEV(LEV) = LEVEL
      LSTEND = LEV
C
C ***   ADD THE NAME.
C
C ***   GET NAME IX OF WHERE TO PUT PERIOD SEPARATING NAMES.
      J = LSTNPS(LEV-1) + 1
C     ***   ENSURE THAT ENOUGH SPACE REMAINS.
      IF (J+1+TITEM(0).LE.140) GOTO 20010
         WRITE(ERUNIT,10099) TITEM(0),(TITEM(I),I=1,TITEM(0)),LEVEL,
     &         LSTNAM(0),(LSTNAM(I),I=1,LSTNAM(0)),RECNBR,RECKEY
10099    FORMAT( ' *** NAME ', NR1, ' AT LEVEL ', I3, ' NOT ADDED',
     &         ' TO ', /, X, NR1, /, ' AT REC # ', I5,
     &         '(', F8.3, ') DUE TO 140 CHAR LIMITATION' )
         LSTEND = LEV - 1
         RETURN
C
C **********
C ***   NAME FITS...APPEND IT TO THE OTHERS.
C
20010 IF (LEV.GT.1) LSTNAM(J) = 1R.
      DO 20020 I=1,TITEM(0)
20020    LSTNAM(J+I) = TITEM(I)
C ***   INDICATE NAME APPENDED.
      LSTNPS(LEV) = J + TITEM(0)
      LSTNAM(0) = LSTNPS(LEV)
      RETURN
      END
C *********************************************************************
C **********               SAVNAM                            **********
C ***   SAVNAM  6 JUN 78  (PRY)
C ***   SAVNAM SAVES THE CURRENT NAME (ITEM) AS AN ARGUMENT
C ***   VALUE.
C
      SUBROUTINE SAVNAM( NAMNBR )
C
      INTEGER NAMNBR
C
C ***   NAMNBR - NUMBER TO ASSOCIATE WITH NAME
C
      INCLUDE AEXTGLBLS
C
C ********************
C ***   MOVE THE CURRENT ITEM TO THE SPECIFIED NAME.
C
10010 I = NAMNBR
      DO 10020 J=0,TITEM(0)
10020    NAMES(I,J) = TITEM(J)
      RETURN
      END
C *********************************************************************
C **********               ADDNAM                            **********
C *********************************************************************
C ***   ADDNAM  8 JUN 78  (PRY)
C ***   ADDNAM ADDS THE CURRENT ITEM TO THE SPECIFIED NAME.
C
      SUBROUTINE ADDNAM( NAMNBR )
C
      INTEGER NAMNBR
C
C ***   NAMNBR - NAME WHICH TO ADD CURRENT ITEM TO
C
      INCLUDE AEXTGLBLS
C
C **********
C ***   IF NAME FITS, ADD IT.
C
10010 I = NAMNBR
C ***   TOTAL STRING LENGTHS.
      J = TITEM(0) + NAMES(I,0)
C     ***   ENSURE THAT ENOUGH SPACE REMAINS.
      IF (J.LE.140) GOTO 20010
         WRITE(10029) RECNBR, RECKEY, TITEM(0),
     &         (TITEM(I),I=1,TITEM(0))
10029    FORMAT( ' *** ITEM AT REC # ', I5, '(', F8.3, ')',
     &         ' NOT ADDED DUE TO 140 CHAR LIMIT: ', NR1 )
         RETURN
C
C **********
C ***   ADD NAME.
C
20010 N = NAMES(I,0)
      DO 20020 K=1,TITEM(0)
20020    NAMES(I,N+K) = TITEM(K)
      NAMES(I,0) = J
      RETURN
      END
C **********                  FLINIT                         **********
C *********************************************************************
C ***   FLINIT  6 JUN 78  (PRY)
C ***   FLINIT FULLY INITIALIZES DATA AREAS.
C
      SUBROUTINE FLINIT
C
      INCLUDE AEXTGLBLS
C
      GLOBAL SPLONE
      INTEGER SPLONE
C
C ***   SPLONE - SPECIAL CHAR TO USE AS VALID ID CHAR.
C
C
C **********************
C ***   INITIALIZE DATA BY CALLING INITIALIZATION ROUTINES
C ***   AND MANUALLY INITIALIZING OTHER DATA.
C
C ***   GET READY TO READ INPUT FILE.
10010 CALL IOINIT
C ***   NO DATA NAMES YET.
      CALL RDCLNM
C ***   NO NAME TABLE YET.
      CALL RSTTBL
      DO 10020 I=1,20
10020    NAMES(I,0) = 0
C ***   NO DATA NAMES YET.
      LSTNAM(0) = 0
C ***   DON'T ALLOW ANY SPECIAL NAME CHARS.
      SPLONE = -9999
      RETURN
      END
C *********************************************************************
C **********                  NXTPL6                         **********
C *********************************************************************
C ***   NXTPL6  7 JUN 78  (PRY)
C ***   NXTPL6 RETURNS THE NEXT VALID PL6 TOKEN OR END-OF-FILE
C ***   FOR BMAP AND FORTRAN PROGRAMS.
C
      SUBROUTINE  NXTPL6
C
      INCLUDE AEXTGLBLS
C
C ********************
C ***   PROCESS SOURCE ACCORDING TO TYPE.
C
C ***   IF PL-6, SPECIAL FREE FORMAT HANDLING.
10010 IF (SRCTYP.EQ.1) GOTO 20010
C
C ***   BMAP AND FORTRAN: IGNORE ALL CODE LINES; ONLY PASS VALID
C ***   EXTRACT COMMENT LINES TO GETCMT.
C
10020 IF (RECCHR.NE.-1) GOTO 10030
10025    TOKEN = TEOF
         RETURN
C
C ***   IF NOT A COMMENT LINE, FORCE READ OF NEXT LINE.
C
10030 IF (BRKFLG.GT.0) GOTO 10025
      IF (INCMNT) GOTO 10050
10040    RECPOS = RECLEN + 1
         CALL NXTCHR
         GOTO 10020
C
C ***   COMMENT LINE: IF NOT AN EXTRACT COMMENT IGNORE IT.
C
C ***   FORTRAN COMMENT IS C*X*, BMAP IS *X*.
10050 J = 3
      IF ( (SRCTYP.EQ.3) .AND. (RECORD(1).EQ.1RC) ) J = 4
C ***   MUST HAVE SUFFICIENT LENGTH TO BE EXTRACT COMMENT.
      IF (RECLEN.LT.J) GOTO 10040
C ***   COMMENT TYPE MUST BE SURROUNDED BY ASTERISKS.
      IF ( (RECORD(J).NE.1R*) .OR. (RECORD(J-2).NE.1R*) ) GOTO 10040
C
C ***   EXTRACT COMMENT: PASS TO GETCMT.
C
C ***   SET RECORD POSITION TO COMMENT TYPE.
      RECPOS = J - 1
      RECCHR = RECORD(RECPOS)
      CALL GETCMT
      GOTO 10020
C
C ********************
C ***   PL6 SOURCE: RETURN TOKEN 'TIL A COMMENT IS FOUND.
C
20010 IF (BRKFLG.GT.0) RETURN
      CALL NXTTKN
C ***   COUNT PARENTHESES.
      IF (TOKEN.EQ.TLPAR) PRNLEV = PRNLEV + 1
      IF (TOKEN.EQ.TRPAR) PRNLEV = PRNLEV - 1
C ***   IGNORE RECORD ENDS.
      IF (TOKEN.EQ.TEOR) GOTO 20010
C ***   RETURN ALL NON-COMMENTARY.
      IF (TOKEN.NE.TCMBGN) RETURN
C
C ***   FOUND COMMENT BEGINNING.
C
C ***   MUST HAVE SUFFICIENT LENGTH TO BE EXTRACT COMMENT.
      IF (RECPOS+1.LE.RECLEN) GOTO 20100
C     ***   NOT AN EXTRACT TYPE COMMENT, IGNORE IT.
         GOTO 20020
20015    IF (RECPOS.LT.RECLEN) GOTO 20016
            RECPOS = RECLEN + 1
            CALL NXTCHR
20016    RECPOS = RECPOS + 1
         IF (RECORD(RECPOS).NE.1R*) GOTO 20015
         RECCHR = RECORD(RECPOS)
         GOTO 20021
20020    IF (RECCHR.EQ.-1) GOTO 10025
C     ***   LOOK FOR */.
         IF (RECCHR.NE.1R*) GOTO 20015
20021    CALL NXTCHR
         IF (RECCHR.NE.1R/) GOTO 20020
C     ***   CONTINUE TOKEN SEARCH.
         INCMNT = .FALSE.
         CALL NXTCHR
         GOTO 20010
C
C **********
C ***   MAKE SURE /*X* FOR EXTRACT TYPE COMMENT.
C
20100 IF (RECORD(RECPOS+1).NE.1R*) GOTO 20020
C ***   EXTRACT TYPE COMMENT: PASS IT TO GETCMT.
      CALL GETCMT
      GOTO 20010
      END
C *********************************************************************
C **********               GETCMT                            **********
C *********************************************************************
C ***   GETCMT  7 JUN 78  (PRY)
C ***   GETCMT PROCESS EXTRACT TYPE COMMENTARY FROM THE SOURCE FILE.
C
      SUBROUTINE GETCMT
C
      LOGICAL NONBLK
C
C ***   NONBLK - SET .TRUE. IF NON-BLANK ENCOUNTERED
C
      GLOBAL SPLONE
      INTEGER SPLONE, ADDCMT
C
C ***   SPLONE - SPECIAL CHAR TO USE AS VALID ID CHAR.
C ***   ADDCMT - SETS UP COMMENT DATA FOR ADDITION TO DATA BASE
C
      INCLUDE AEXTGLBLS
C
      INTEGER LBLK, CMTNMX
C
C ***   LBLK - LAST BLOCK NUMBER OF DATA BASE
C ***   CMTNMX - INDEX OF NAME ASSOCIATED WITH COMMENT
C
C ********************
C ***   PROCESS EXTRACT TYPE COMMENT ACCORDING TO SOURCE TYPE.
C
      RECCHR = RECORD(RECPOS)
10010 CMTREC = RECNBR
      NONBLK = .FALSE.
C
C
      IF (RECCHR.NE.1R,) CMTTYP = RECCHR
C
C     ***   NEW COMMENT BEGINS.   FIND ACTUAL START OF COMMENT BY
C     ***   IGNORING BLANKS.
C
         CMTBGN = RECPOS + 1
10013    CMTBGN = CMTBGN + 1
         IF (CMTBGN.GE.RECLEN) GOTO 10017
            IF (RECORD(CMTBGN).EQ.1R ) GOTO 10013
C
C ***   SKIP PAST * /*X*.
C
10017 CMTSTR = CMTBGN
      RECPOS = RECPOS + 2
      RECCHR = RECORD(RECPOS)
C
C ***   IF COMMENT CONTINUES PREVIOUS (TYPE = ,), SKIP INITIAL
C ***   COMMENT PROCESSING.
C
      IF (RECORD(RECPOS-2).EQ.1R,) GOTO 10160
C ***   DON'T  CHECK COMMENT END IF NOT PL-6.
      IF (SRCTYP.NE.1) GOTO 10020
C
C ***   CHECK IF COMMENT IMMEDIATELY ENDS (I.E. /*X*/).
C
      IF (RECCHR.NE.1R/) GOTO 10020
C     ***   SKIP TO NEXT CHAR.
         CALL NXTCHR
C     ***   NULL COMMENT.
         INCMNT = .FALSE.
         TOKEN = TCMEND
         RETURN
C
C ***   GET COMMENT ID.
C
10020 DO 10021 CMTID=1,13
10021    IF (CMTIDS(CMTID).EQ.CMTTYP) GOTO 10030
      CMTID = 0
C ***   UNKNOWN COMMENT TYPE.
      GOTO 10062
C
C ***   GET FIRST TOKEN--WE HOPE IT'S A NAME--OF COMMENT.
C
C ***   ALLOW . IN DATA NAME IF K OR B COMMENT.
10030 IF ( (CMTTYP.EQ.1RK) .OR. (CMTTYP.EQ.1RB) ) SPLONE = 1R.
      CALL NXTTKN
      SPLONE = -9999
C ***   SET FLAG IF ANYTHING IS IN RECORD.
      IF (TOKEN.NE.TEOR) NONBLK = .TRUE.
C ***   CHECK IF WE GOT EXPECTED NAME.
      IF (TOKEN.EQ.TNAME) GOTO 10040
C     ***   IF PL-6 SOURCE AND COMMENT END, RETURN.
         IF ( (SRCTYP.EQ.1) .AND. (TOKEN.EQ.TCMEND) ) RETURN
         IF ( (SRCTYP.EQ.1).AND.(TITEM(0).EQ.1).AND.(TITEM(1).EQ.1R*)
     &         .AND.(TOKEN.EQ.TARMOP) ) GOTO 10030
C     ***   IF NOT PL-6 OR NOT END-OF-RECORD, WE GOT SOME
C     ***   ILLEGAL JUNK.  GIVE ERROR MESSAGE.
         IF (TOKEN.NE.TEOR) GOTO 10031
         IF (SRCTYP.NE.1) GOTO 10034
            CMTSTR = 1
            GOTO 10030
C     ***   IF WE HAVE A NAME ALREADY, USE IT.
10031    CMTSTR = TRCPOS
         CMTBGN = CMTSTR
         CMTNMX = CMTID + 4
         IF (NAMES(CMTNMX,0).GT.0) GOTO 10110
C     ***   WE DON'T HAVE A NAME.
10034    WRITE(ERUNIT,10035) RECNBR, RECKEY, RECLEN,
     &         (RECORD(I),I=1,RECLEN)
10035    FORMAT( ' *** EXPECTED KEYWORD OR NAME MISSING AT REC # ',
     &         I5, '(', F8.3, '):', /, X, NR1 )
         GOTO 10064
C
C ***   DETERMINE IF EXPECTED NAME WAS FOUND.
C
C ***   SAVE START OF COMMENT.
10040 CMTBGN = TRCPOS
      CMTSTR = CMTBGN
C
C ***   LOOK FOR NEXT KEYWORD DEPENDING ON COMMENT TYPE.
C
      GOTO (10090,10090,10050,10050,10050,10050,10090,
     &      10051,10052,10090,10090,10053,10054),CMTID
C
C ***   NAME FOR I, P, F, D.
C
10050    IF (TPL6ID.EQ.101) GOTO 10070
         GOTO 10060
C
C ***   ERROR FOR E.
C
10051    IF (TPL6ID.EQ.102) GOTO 10070
         GOTO 10060
C
C ***   SCREECH_CODE FOR S.
C
10052    IF (TPL6ID.EQ.103) GOTO 10070
         GOTO 10060
C
C ***   MESSAGE FOR O.
C
10053    IF (TPL6ID.EQ.104) GOTO 10070
         GOTO 10060
C
C ***   VERSION FOR C.
C
10054    IF (TPL6ID.EQ.105) GOTO 10070
C
C **********
C ***   ERROR:
C
10060 CMTNMX = CMTID + 4
      IF (NAMES(CMTNMX,0).GT.0) GOTO 10110
      WRITE(ERUNIT,10061) RECNBR, RECKEY, RECLEN,
     &      (RECORD(I),I=1,RECLEN)
10061 FORMAT( ' *** EXPECTED KEYWORD MISSING AT REC # ', I5, '(',
     &      F8.3, '):', /, X, NR1 )
      GOTO 10064
C
C **********
C ***   JUST IGNORE X AND * COMMENTS.
C
10062 IF (CMTTYP.EQ.1R*) GOTO 10064
      IF (CMTTYP.EQ.1R ) GOTO 10064
      IF (CMTTYP.EQ.1RX) GOTO 10064
      WRITE(ERUNIT,10063) RECNBR, RECKEY, RECLEN,
     &      (RECORD(I),I=1,RECLEN)
10063 FORMAT( ' *** COMMENT TYPE UNKNOWN AT REC # ',
     &      I5, '(', F8.3, '):', /, X, NR1 )
C
C ***   IGNORE UNKNOWN COMMENT.
C
10064 IF (SRCTYP.EQ.1) GOTO 10066
      RECPOS = RECLEN + 1
      CALL NXTCHR
      RETURN
C
C ***   IGNORE BAD PL-6 COMMENT TO */.
C
10065 IF (RECPOS.LT.RECLEN) GOTO 19065
         RECPOS = RECLEN + 1
         CALL NXTCHR
         GOTO 10066
19065 RECPOS = RECPOS + 1
      IF (RECORD(RECPOS).NE.1R*) GOTO 10065
      RECCHR = RECORD(RECPOS)
      GOTO 10067
10066 IF (RECCHR.EQ.-1) RETURN
      IF (RECCHR.NE.1R*) GOTO 10065
10067 CALL NXTCHR
      IF (RECCHR.NE.1R/) GOTO 10066
      CALL NXTCHR
      TOKEN = TCMEND
      INCMNT = .FALSE.
      RETURN
C
C ***   EXPECTED KEYWORD WAS PRESENT.  GET COLON.
C
10070 IF ( (CMTTYP.EQ.1RE).OR.(CMTTYP.EQ.1RS) ) SPLONE = 1R-
      CALL NXTTKN
      SPLONE = -9999
      IF (TOKEN.EQ.TCOLON) GOTO 10080
C     ***   COLON DIDN'T FOLLOW.
         IF (TOKEN.EQ.TNAME) GOTO 10090
         GOTO 10095
C
C ***   GET NAME.
C
C ***   FOR E COMMENT TYPE, - CAN APPEAR IN NAME.
10080 IF ( (CMTTYP.EQ.1RE).OR.(CMTTYP.EQ.1RS) ) SPLONE = 1R-
      CALL NXTTKN
      SPLONE = -9999
C
C ***   USE NAME AS IS.
C
10090 NONBLK = .TRUE.
      IF (TOKEN.EQ.TEOF) RETURN
C ***   GIVE ERROR MESSAGE IF NOT USING NAME.
      IF (TOKEN.EQ.TNAME) GOTO 10100
10095    WRITE(ERUNIT,10099) RECNBR, RECKEY, RECLEN,
     &      (RECORD(I),I=1,RECLEN)
10099    FORMAT( ' *** EXPECTED NAME MISSING AT REC # ', I5, '(', F8.3,
     &      '):', /, X, NR1 )
         GOTO 10064
C
C ***   SAVE THE NAME.
C
10100 CMTNMX = CMTID + 4
      IF ( (CMTTYP.EQ.1RK).OR.(CMTTYP.EQ.1RB) ) GOTO 10105
10102    CALL SAVNAM(CMTNMX)
         GOTO 10110
C ***   USE F NAME AS PART OF K,B.
10105 IF (NAMES(4+4,0).EQ.0) GOTO 10102
      DO 10106 I=0,NAMES(4+4,0)
10106    NAMES(CMTNMX,I) = NAMES(4+4,I)
      NAMES(CMTNMX,0) = NAMES(CMTNMX,0) + 1
      NAMES(CMTNMX,NAMES(CMTNMX,0)) = 1R
      CALL ADDNAM(CMTNMX)
C
C ***   PROCESS TEXT OF CURRENT COMMENT.
C
C ***   INDICATE END OF PREVIOUS COMMENT BLOCK.
10110 IF (HAVCMT) CALL ADDLIN( 0, -1 )
C
C ***   ADD CURRENT COMMENT TO LISTS.
C
      LBLK = BK(0)
      I = ADDCMT( )
      DO 10130 J=0,ITMMAX
10130    CALL ADDREC( J )
C ***   COUNT NEW COMMENT IN DATA BASE.
      NUMRCS = NUMRCS + 1
C ***   MOVE POINTER TO NEXT RECORD.
      BT(0) = BT(0) + I
C
C ***   IF A NEW BLOCK WAS NECESSARY, BALANCE THE DATA BASE.
C
      IF (BK(0).EQ.LBLK) GOTO 10140
         IF (LBLK.EQ.(LBLK/2)*2) GOTO 10140
         CALL STPDB
         CALL BALANC
C
C ***   FOR K AND B TYPE COMMENTS PRINT THE CURRENT DATA NAME.
C
10140 IF ( (CMTTYP.NE.1RK) .AND. (CMTTYP.NE.1RB) ) GOTO 10160
C     ***   ONLY PRINT NAME IF WE HAVE ONE.
         IF (LSTNAM(0).LE.0) GOTO 10160
C           WRITE(RPTUNT,10159) LSTNAM(0),(LSTNAM(I),I=1,LSTNAM(0)),
C    &            ITMDIM(0), ITMSIZ(0), ITMTYP(0), ITMALN(0)
10159       FORMAT( X, 'DATA NAME: ', NR1, X, I3, X, I3, X, I3, X, I3 )
C
C ********************
C ***   WRITE COMMENT LINES 'TIL COMMENT EXHAUSTED.
C
C ***  ONLY PL-6 GETS FREE FORMAT PROCESSING.
10160 IF (SRCTYP.NE.1) GOTO 20100
C **********
C ***  RETURN IF END-OF-FILE.
C
10170 IF (RECCHR.EQ.-1) RETURN
      IF (RECCHR.NE.-2) GOTO 10210
C     ***   ONLY PRINT RECORD IF NON-BLANKS HAVE BEEN FOUND.
         IF (.NOT.NONBLK) GOTO 10190
C
C        ***   ASSUME ALL RECORDS ARE ALIGNED AT COMMENT BEGINNING
C        ***   BUT DON'T PERMIT NON-BLANKS TO GO UNPRINTED.
C
10180       K = MIN(CMTSTR,CMTBGN)
            J = RECLEN - K + 1
            IF (J.LE.0) J = 1
            K = RECLEN - J + 1
            CALL ADDLIN( K, RECLEN )
C
C     ***   ASSUME NEXT COMMENT LINE STARTS IN COL 1.
C
10190    CMTSTR = 1
         NONBLK = .FALSE.
C
C ***   LOOK FOR COMMENT END (*/) WHILE LISTING COMMENT LINES.
C
C10200 CALL NXTCHR
C ***   IN-LINE NXTCHR TO SPEED THINGS UP.
10200 IF (RECPOS.LT.RECLEN) GOTO 10209
         CALL NXTCHR
         GOTO 10210
10209 RECPOS = RECPOS + 1
      RECCHR = RECORD(RECPOS)
      IF (RECCHR.NE.1R*) GOTO 10212
      GOTO 10220
C ***   IF END OF LINE, LIST COMMENT LINE.
      IF (RECCHR.EQ.-2) GOTO 10180
      IF (RECCHR.EQ.-1) RETURN
10211 IF (RECCHR.EQ.1R*) GOTO 10220
C        ***   IGNORE BLANKS WITHIN COMMENT.
10212    IF (RECCHR.EQ.1R ) GOTO 10200
C  ***   SAVE POSITION OF FIRST NON-BLANK OF COMMENT LINE.
10215    IF (NONBLK) GOTO 10200
C     ***   FOUND A NON-BLANK.
         CMTSTR = RECPOS
         NONBLK = .TRUE.
         GOTO 10200
10220 CALL NXTCHR
      IF (RECCHR.NE.1R/) GOTO 10210
C
C ***   END OF COMMENT.
C
10230 IF (.NOT.NONBLK) GOTO 10310
C
C     ***   PRINT FOR LAST LINE OF COMMENT.
C
         K = MIN(CMTSTR,CMTBGN)
         J = RECPOS - K - 1
         IF (J.LE.0) J = 1
         K = RECPOS - J - 1
         CALL ADDLIN( K, RECPOS-2 )
C
C ***   RESUME PL-6 SCAN AT NEXT CHAR AFTER */.
C
10310 CALL NXTCHR
      INCMNT = .FALSE.
      TOKEN = TCMEND
      RETURN
C
C ********************
C ***   FORTRAN AND BMAP COMMENTS.
C
C ***   CALC LENGTH AND PRINT RECORD.
20100 J = RECLEN - CMTSTR + 1
      CALL ADDLIN( CMTSTR, RECLEN )
C ***   FORCE READ OF NEXT RECORD.
      RECPOS = RECLEN + 1
      CALL NXTCHR
C ***   RETURN IF END OF FILE.
      IF (RECCHR.EQ.-1) RETURN
C ***   RETURN IF END OF CURRENT COMMENT.
      IF (.NOT.INCMNT) RETURN
C ***   CHECK IF RECORD IS ANOTHER COMMENT.
      J = 3
      IF (SRCTYP.EQ.3) J = 4
C ***   RECORD MUST CONTAIN [C]*X*.
      IF (RECLEN.LT.J) RETURN
      IF ( (RECORD(J).NE.1R*) .OR. (RECORD(J-2).NE.1R*) ) RETURN
C
C ***   IGNORE LEADING BLANKS.
C
      CMTSTR = J
20150 CMTSTR = CMTSTR + 1
         IF (RECORD(CMTSTR).EQ.1R ) GOTO 20150
C ***   CHECK IF THIS COMMENT LINE CONTINUES PREVIOUS.
20160 IF ( (RECORD(J-1).EQ.1R,) .OR. (RECORD(J-1).EQ.CMTTYP) )
     &      GOTO 20100
C
C ***   PROCESS NEW COMMENT.
C
      RECPOS = J - 1
      CMTTYP = RECORD(RECPOS)
      RECCHR = CMTTYP
      GOTO 10010
      END
C *********************************************************************
C **********                  STPDB                          **********
C *********************************************************************
C ***   STPDB   23 JUN 78   (PRY)
C ***   STPDB WRITES OUT ANY DATA BLOCKS STILL AT LARGE IN CORE.
C ***   ALL DATA IS LEFT INTACT.
C
      SUBROUTINE STPDB
C
      INCLUDE AEXTGLBLS
C
      INTEGER GETBLK
C
C ***   GETBLK - GET SPECIFIED PHYSICAL BLOCK
C
C ********************
C  ***   WRITE OUT LAST COMMENT/DATA BLOCK IF ANY.
C
C ***   IF FIRST TEXT BLOCK, WRITE IT OUT.
      IF (TBKNBR.EQ.0) GOTO 10015
C ***   IF ANYWHERE IN THIS BLOCK, WRITE IT OUT.
      IF (TBTNBR.LE.0) GOTO 10020
10015    CALL DIWRIT(TXTUNT,TBKCHR,BLKSIZ,TBKNBR)
         CALL UNPACK(TBKCHR,BLKSIZ)
C
C  ***   GET BLOCK 0 FOR UPDATE.
C
10020 J = GETBLK( 0 )
      BA(J) = 0
C  ***   UPDATE BLOCK 0 WITH FIRST-OF-LIST POINTERS.
10035 DO 10037 I=0,ITMMAX
         DO 10037 K=0,INDMAX
10037       CALL T12T38( FSTBLK(I,K),FSTBYT(I,K),J,(I+(ITMMAX+1)*K)*3 )
C  ***   SAVE NEXT FREE DATA BYTE INFO.
      CALL T12T38( BK(0), BT(0), J, ((ITMMAX+1)*(INDMAX+1))*3 )
C  ***   SAVE NEXT FREE TEXT BYTE INFO.
      CALL T12T38( TBKNBR, TBTNBR, J, ((ITMMAX+1)*(INDMAX+1))*3+3 )
      DO 10038 I=0,ITMMAX
10038   CALL T12T38( FSTEND(I),0,J,(ITMMAX+1)*(INDMAX+1)*3+3+3+3+I*3 )
C ***   SAVE THE NUMBER OF RECORDS IN THE DATA BASE
      N1 = NUMRCS / 4096
      N2 = NUMRCS - N1 * 4096
      CALL T12T38( N1, N2, J, ((ITMMAX+1)*(INDMAX+1))*3+3+3 )
C  ***   SET BLOCK J MODIFIED AND WRITE OUT ALL MODIFIED BLOCKS.
      BM(J) = .TRUE.
      DO 10039 I=0,BLKMAX
         IF (.NOT.BM(I)) GOTO 10039
            CALL DIWRIT(DATUNT,BLK(0,I),BLKSIZ,BK(I))
            CALL UNPACK(BLK(0,I),BLKSIZ)
         BM(I) = .FALSE.
10039 CONTINUE
      RETURN
      END
C *********************************************************************
C **********               EXTRACT                           **********
C *********************************************************************
C ***   EXTRACT   JUN 78   (PRY)
C ***   EXTRACT IS THE EXTRACTER.
C
      SUBROUTINE EXTRACT
C
      INCLUDE AEXTGLBLS
C
      INTEGER IDITM, PRMID, LOWLEV, DCLLEV, LOOKUP
C
C ***   IDITM - FUNCTION WHICH RETURNS NAME ID
C ***   PRMID - ID NUMBER OF LAST PARAMETER
C ***   LOWLEV - LOWEST DECLARATION LEVEL
C ***   DCLLEV - LEVEL OF CURRENT DCL ITEM
C ***   LOOKUP - LOOKS UP CURRENT NAME IN SYMBOL TABLE
C
C ********************
C ***   INITIALIZE.
C
10010 SIUNIT = 101
      HAVCMT = .FALSE.
      CALL FLINIT
      IF (FILNLN.LT.1) GOTO 10020
      WRITE(ERUNIT,10019) FILNAM(1:FILNLN)
10019 FORMAT( ' ... ', A )
C
C ********************
C ***   LOOK FOR DCL OR PROC.
C
10020 CALL NXTPL6
C ***   IF END-OF-FILE, WE'RE DONE.
         IF (BRKFLG.GT.0) WRITE(ERUNIT,10034) FILNAM(1:FILNLN),
     &         RECNBR
10034    FORMAT( ' !!! BREAK AT ', A, ' RECORD # ', I5 )
         IF (HAVCMT) CALL ADDLIN(0,-1)
         RETURN
C
C ***   IF NOT A NAME, IGNORE IT.
C
10040 IF (TOKEN.NE.TNAME) GOTO 10020
C ***   PROC?
      IF (TPL6ID.EQ.88) GOTO 20010
C ***   DCL?
      IF (TPL6ID.EQ.86) GOTO 30010
C ***   IGNORE ANY OTHER NAME.
      GOTO 10020
C
C ********************
C ***   HANDLE PROC STATEMENT.
C
C ***   RESET THE NAME TABLE.
20010 CALL RSTTBL
C ***   GET THE NEXT TOKEN.
      CALL NXTPL6
C ***   IF NOT BEGINNING OF ARGUMENT LIST, RETURN TO MAIN SCANNER.
      IF (TOKEN.NE.TLPAR) GOTO 10030
C
C ***   GET ARGUMENTS AND STORE IN ARG TABLE.
C
20020 CALL NXTPL6
      IF (TOKEN.NE.TNAME) GOTO 10030
      PRMID = IDITM( )
      CALL NXTPL6
C ***   IF COMMA, ANOTHER ARG FOLLOWS.
      IF (TOKEN.EQ.TCOMMA) GOTO 20020
C ***   END OF ARG LIST.
      GOTO 10030
C
C ********************
C ***   PROCESS DCL.
C
30010 ITMID = 0
C ***   RESET SIZE OF DIMENSION NAME (IF ANY).
      NAMES(3,0) = 0
C ***   RESET SIZE OF SIZE NAME (IF ANY).
      NAMES(4,0) = 0
C ***   RESET FULLY QUALIFIED NAME.
      CALL RDCLNM
C
C ***   IF NAME FOLLOWS, ASSUME DCL LEVEL IS 0.
C
      CALL NXTPL6
      IF (TOKEN.NE.TDIGIT) TPL6ID = 0
      LOWLEV = TPL6ID
C ***   GET DCL NAME.
      IF (TOKEN.EQ.TDIGIT) CALL NXTPL6
C ***   IGNORE DCL IF NOT NAME.
      IF (TOKEN.NE.TNAME) GOTO 31010
C ***   BEGIN FULLY QUALIFIED NAME.
C ***   IDENTIFY NAME.
      ITMID = LOOKUP( )
C ***   IF NOT PARAMETER, MAKE ITEM 0.
      IF (ITMID.GT.PRMID) ITMID = 0
C
C ***   RESET ITEM INFORMATION.
C
30015 ITMDIM(ITMID) = 0
      ITMSIZ(ITMID) = 0
      ITMTYP(ITMID) = 0
      ITMALN(ITMID) = 0
C
C ***   PROCESS DIMENSION IF ANY.
C
      CALL NXTPL6
      IF (TOKEN.NE.TLPAR) GOTO 30070
C
C ***   DIMENSION BEGINS.
C
      CALL NXTPL6
C ***   IF ANY ERRORS, IGNORE DCL.
      IF (TOKEN.NE.TDIGIT) GOTO 31010
      CALL NXTPL6
      IF (TOKEN.NE.TCOLON) GOTO 31010
      CALL NXTPL6
C ***   IF INTEGER DIM, SAVE IT.
      IF (TOKEN.EQ.TDIGIT) ITMDIM(ITMID) = TPL6ID + 1
      IF (TOKEN.EQ.TDIGIT) GOTO 30040
C
C ***   NOT INTEGER DIM--FLAG AND GET DIM.
C
      ITMDIM(ITMID) = -3
30020 IF (TOKEN.EQ.TRPAR) GOTO 30060
         CALL ADDNAM( 3 )
         CALL NXTPL6
         IF (TOKEN.NE.TEOF) GOTO 30020
      GOTO 30050
C
C ***   IGNORE EXPECTED RIGHT PAREN.
C
30040 CALL NXTPL6
30050 IF (TOKEN.NE.TRPAR) GOTO 31010
C
C ***************
C ***   PROCESS OTHER ATTRIBUTES.
C
C ***   ZERO PAREN COUNT.
30060 PRNLEV = 0
      CALL NXTPL6
C ***   GET NEXT TOKEN.
C ***   CHECK FOR DCL END.
30070 IF (TOKEN.EQ.TSMICL) GOTO 10020
C ***   CHECK FOR DCL CONTINUATION.
      IF (TOKEN.EQ.TCOMMA) GOTO 30600
C ***   CHECK FOR FRACTIONAL JUNK WHICH MIGHT OCCUR DUE TO MACROS.
      IF (TOKEN.EQ.TRPAR) GOTO 30060
      IF (TOKEN.EQ.TLPAR) GOTO 30510
      IF (TOKEN.NE.TNAME) GOTO 31010
      IF (TPL6ID.LE.0) GOTO 30060
      IF (TPL6ID.EQ.60) GOTO 30500
C
C ***   PROCESS ALIGNMENT.
C
      IF ( (TPL6ID.LT.11) .OR. (TPL6ID.GT.13) ) GOTO 30100
      ITMALN(ITMID) = TPL6ID - 10
      GOTO 30060
C
C ***    PROCESS ITEM TYPE.
C
30100 IF ( (TPL6ID.LT.51) .OR. (TPL6ID.GT.58) ) GOTO 30060
      ITMTYP(ITMID) = TPL6ID - 50
      GOTO (30110,30120,30130,30140,30150,30160,30170,30180),
     &      ITMTYP(ITMID)
C ***   BIT.
30110 ITMSIZ(ITMID) = 1
      GOTO 30200
C ***   CHAR.
30120 ITMSIZ(ITMID) = 9
      GOTO 30200
C ***   DCB.
30130 ITMSIZ(ITMID) = 0
      GOTO 30200
C ***   EPTR.
30140 ITMSIZ(ITMID) = 36
      GOTO 30200
C ***   LABEL.
30150 ITMSIZ(ITMID) = 36
      GOTO 30200
C ***   PTR.
30160 ITMSIZ(ITMID) = 36
      GOTO 30200
C ***   SBIN.
30170 ITMSIZ(ITMID) = 36
      GOTO 30200
C ***   UBIN.
30180 ITMSIZ(ITMID) = 36
      GOTO 30200
C
C *****   PROCESS SIZE.
C
30200 CALL NXTPL6
      IF (TOKEN.EQ.TLPAR) GOTO 30400
C ***   USE DEFAULT SIZE IF NOT NAME.
      IF (TOKEN.NE.TNAME) GOTO 30070
      IF (TPL6ID.NE.59) GOTO 30070
C
C ***   PROCESS WORD, HALF OR BYTE.
C
      I = TITEM(1)
      IF (I.EQ.1RW) ITMSIZ(ITMID) = 36
      IF (I.EQ.1RH) ITMSIZ(ITMID) = 18
      IF (I.EQ.1RB) ITMSIZ(ITMID) = 9
      GOTO 30060
C
C **********
C ***   PROCESS SIZE SPEC.
C
30400 PRNLEV = 1
      CALL NXTPL6
      IF (TOKEN.EQ.TDIGIT) ITMSIZ(ITMID) = TPL6ID
      IF (TOKEN.EQ.TDIGIT) GOTO 30040
C ***   IGNORE REST IF NOT NAME.
      IF (TOKEN.NE.TNAME) GOTO 31010
30420 CALL ADDNAM( 4 )
      CALL NXTPL6
      IF (TOKEN.EQ.TEOF) GOTO 31010
      IF (PRNLEV.GT.0) GOTO 30420
C ***   GET NEXT TOKEN.
      GOTO 30060
C
C ********
C ***   PROCESS INIT.
C
30500 PRNLEV = 0
30510 CALL NXTPL6
      IF (TOKEN.EQ.TEOF) GOTO 31010
      IF (PRNLEV.GT.0) GOTO 30510
      IF (TOKEN.EQ.TRPAR) GOTO 30060
      GOTO 30070
C
C ********
C ***   PROCESS END OF DCL LINE.
C
30600 IF (TOKEN.EQ.TSMICL) GOTO 10020
      IF (TOKEN.NE.TCOMMA) GOTO 31010
C ***   BEGIN NEXT LEVEL.
      CALL NXTPL6
      IF (TOKEN.NE.TDIGIT) GOTO 31010
C ***   SAVE DCL LEVEL.
      DCLLEV = TPL6ID
      CALL NXTPL6
C ***   FILLER OR NAME LEGAL AFTER LEVEL.
      IF ( (TITEM(0).EQ.1) .AND. (TITEM(1).EQ.1R*) ) GOTO 30620
      IF (TOKEN.NE.TNAME) GOTO 31010
30620 CALL ADCLNM( DCLLEV )
C ***   LOWER LEVEL ITEMS CAN'T BE PARAMETERS.
      ITMID = 0
      GOTO 30015
C
C **********
C ***   ILLEGAL DECLARATION LINE.
C
31010 WRITE(ERUNIT,31019) RECNBR,RECKEY, RECLEN, (RECORD(I),I=1,RECLEN)
31019 FORMAT( ' *** CAN''T UNDERSTAND DCL AT REC # ', I5, '(', F8.3,
     &      ')', /, X, NR1 )
      CALL RDCLNM
      GOTO 10030
      END
C *********************************************************************
C **********                  DIREAD                         **********
C *********************************************************************
C ***   DIREAD   20 JUN 78   (PRY)
C ***   DIREAD READ THE SPECIFIED DATA BLOCK FROM THE SPECIFIED I/O
C ***   UNIT INTO THE SPECIFIED BUFFER AND UNPACKS IT.
C
      SUBROUTINE DIREAD(IOUNIT,BUFFER,NUMBTS,DATBLK)
C
      INTEGER IOUNIT,BUFFER,NUMBTS,DATBLK
C
C ***   IOUNIT - SPECIFIED I/O UNIT
C ***   BUFFER - SPECIFIED BUFFER
C ***   NUMBTS - NUMBER OF BYTES TO READ
C ***   DATBLK - SPECIFIED DATA BLOCK
C
C ********************
C ***   READ THE BLOCK.
C
10010 N = (NUMBTS+3)/4
      CALL DIRECT READ(IOUNIT,BUFFER,N,DATBLK)
      CALL UNPACK(BUFFER,NUMBTS)
      RETURN
      END
C *********************************************************************
C **********               DIWRIT                            **********
C *********************************************************************
C ***   DIWRIT   20 JUN 78   (PRY)
C ***   DIWRIT WRITE THE SPECIFIED NUMBER OF UNPACKED BYTES FROM
C ***   THE SPECIFIED DATA BLOCK TO THE SPECIFIED PHYSICAL BLOCK.
C
      SUBROUTINE DIWRIT(IOUNIT,BUFFER,NUMBTS,DATBLK)
C
      INTEGER IOUNIT,BUFFER,NUMBTS,DATBLK
C
C ***   IOUNIT - SPECIFIED I/O UNIT
C ***   BUFFER - SPECIFIED BUFFER
C ***   NUMBTS - NUMBER OF BYTES TO READ
C ***   DATBLK - SPECIFIED DATA BLOCK
C
C ********************
C ***   PACK THE DATA.
C
10010 N = (NUMBTS+3)/4
      CALL PACK(BUFFER,NUMBTS)
      CALL DIRECT WRITE(IOUNIT,BUFFER,N,DATBLK)
      RETURN
      END
C *********************************************************************
C **********            BALANC                               **********
C *********************************************************************
C ***   BALANC   23 JUN 78   (PRY)
C ***   BALANC BALANCES THE INDEX INTO THE DATA BASE.
C
      SUBROUTINE BALANC
C
      INCLUDE AEXTGLBLS
C
      INTEGER N16, PSTRCS, NXTSTP, INDNBR, LSTNBR
C
C ***   N16   - NUMBER OF ITEMS WHICH SHOULD BE IN EACH LIST SECTION
C ***   PSTRCS - NUMBER OF RECORDS WE'VE PASSED
C ***   NXTSTP - NUMBER OF NEXT RECORD WE SHOULD STOP ON
C ***   INDNBR - INDEX NUMBER
C ***   LSTNBR - NUMBER OF LIST TO BALANCE
C
      INTEGER SAVBT0
C
C ********************
C ***   READY THE DATA BASE
C
10010 CALL RDYDB
      WRITE(ERUNIT,10019) BK(0), NUMRCS
10019 FORMAT( ' ... BALANCING AT BLOCK ', I5, ', RECORD ', I5 )
      SAVBT0 = BT(0)
C
C ***   DO FOR ALL LISTS.
C
10020 DO 20130 LSTNBR=0,ITMMAX
C
C ***   INITIALIZE LIST DIVISION.
C
         N16 = MAX( NUMRCS/INDMAX, 1 )
         NXTSTP = N16
         PSTRCS = 0
         INDNBR = 1
C
C ***   START SEARCH AT LIST BEGINNING.
C
         PBK = NULMRK
         PBT = NULMRK
         NBK = NULMRK
         NBT = NULMRK
C
C ***   PASS BY RECORDS 'TIL WE GET TO THE DESIRED ONE.
C
10100    IF (PSTRCS.GT.NXTSTP) GOTO 10300
            CALL NXTREC( LSTNBR )
C        ***   STOP ON LIST END.
            IF (NBK.EQ.NULMRK) GOTO 20100
            PSTRCS = PSTRCS + 1
            GOTO 10100
C
C ***   FIND NEXT RECORD WHICH IS NOT SAME AS PREVIOUS.
C
10300    BT(PBK) = PBT
         CALL CMPBLK( PBK, LSTNBR, .FALSE. )
         IF (.NOT.BEQUAL) GOTO 10500
C     ***   GO ON.
            CALL NXTREC( LSTNBR )
            IF (NBK.EQ.NULMRK) GOTO 20100
            PSTRCS = PSTRCS + 1
            GOTO 10300
C
C ***   FOUND BEGINNING OF NEXT LIST SECTION.
C
10500    FSTBLK(LSTNBR,INDNBR) = BK(NBK)
         FSTBYT(LSTNBR,INDNBR) = NBT
         INDNBR = INDNBR + 1
C     ***   IF LAST INDEX OF THIS LIST, START NEXT LIST.
         IF (INDNBR.GT.INDMAX) GOTO 20130
            NXTSTP = NXTSTP + N16
            CALL NXTREC( LSTNBR )
            PSTRCS = PSTRCS + 1
            IF (NBK.NE.NULMRK) GOTO 10100
C
C ***   END OF LIST DIVISION.
C
C
C ***   NUL UNUSED INDICES.
C
20100    DO 20120 I=INDNBR,INDMAX
            FSTBLK(LSTNBR,I) = NULMRK
20120       FSTBYT(LSTNBR,I) = 0
C
C ***   DO ALL LISTS.
C
20130    FSTEND(LSTNBR) = INDNBR - 1
C
C ***   RESTORE CHANGED DATA.
C
      BT(0) = SAVBT0
      CALL STPDB
      RETURN
      END
C *********************************************************************
C **********                     ALPHA                       **********
C *********************************************************************
C ***   ALPHA  20 JAN 78 (PRY)
C ***   ALPHA IS .TRUE. IF THE ARGUMENT INTEGER CONTAINS AN
C ***   ALPHABETIC CHARACTER CODE AND .FALSE. OTHERWISE.
C
      LOGICAL FUNCTION ALPHA( CRNTCR )
C
      INTEGER CRNTCR
C
C ********************
C ***   ASSUME CODE IS THAT OF AN ALPHABETIC CHAR.
C
10010 ALPHA = .TRUE.
      IF ( (CRNTCR.GE.1RA) .AND. (CRNTCR.LE.1RZ) ) RETURN
      IF ( (CRNTCR.GE.1Ra) .AND. (CRNTCR.LE.1Rz) ) RETURN
      ALPHA = .FALSE.
      RETURN
      END
C *********************************************************************
C **********                     DIGIT                       **********
C *********************************************************************
C ***   DIGIT  20 JAN 78 (PRY)
C ***   NUMERIC CHARACTER CODE AND .FALSE. OTHERWISE.
C
      LOGICAL FUNCTION DIGIT( CRNTCR )
C
      INTEGER CRNTCR
C
C ********************
C ***   ASSUME CODE IS NOT THAT OF A NUMERIC CHAR.
C
10010 DIGIT = .FALSE.
      IF ( (CRNTCR.GE.1R0) .AND. (CRNTCR.LE.1R9) ) DIGIT = .TRUE.
      RETURN
      END
C *********************************************************************
C **********                     SPLCHR                      **********
C *********************************************************************
C ***   SPLCHR 20 JAN 78 (PRY)
C ***   SPLCHR IS .TRUE. IF THE ARGUMENT INTEGER CONTAINS A
C ***   SPECIAL NAME CHARACTER CODE AND .FALSE. OTHERWISE.
C ***
      LOGICAL FUNCTION SPLCHR( CRNTCR )
C
      INTEGER CRNTCR
      GLOBAL   SPLONE, SPLHIT
      INTEGER SPLONE, SPLHIT
C
C ***   SPLONE - SPECIAL CHAR WHICH MAY BE SET EXTERNALLY.
C
C ********************
C ***   ASSUME CODE IS THAT OF A SPECIAL NAME CHAR.
C
10010 SPLCHR = .TRUE.
      N = CRNTCR
      IF (N.EQ.1R_) RETURN
      IF (N.EQ.1R$) RETURN
      IF (N.EQ.1R#) RETURN
      IF (N.EQ.1R@) RETURN
      IF (N.NE.SPLONE) GOTO 10020
         SPLHIT = SPLHIT + 1
         RETURN
10020 SPLCHR = .FALSE.
      RETURN
      END
C *********************************************************************
C **********                    NXTCHR                       **********
C *********************************************************************
C ***   NXTCHR  5 JUN 78 (PRY)
C ***   NXTCHR RETURNS THE NEXT CHARACTER OF THE CURRENT INPUT FILE
C ***   END-OF-RECORD.   INITIALLY RECNBR SHOULD BE ZERO,
C ***   RECSCN SHOULD BE .FALSE., AND RECPOS SHOULD BE GREATER
C ***   THAN RECLEN TO FORCE A READ OF THE FIRST RECORD.
C
      SUBROUTINE NXTCHR()
C
      INCLUDE AEXTGLBLS
C
C ********************
C ***   WE NEED TO GET THE NEXT CHAR.   IF THE LAST CHAR OF THE
C ***   RECORD HAS ALREADY BEEN RETURNED, GET THE NEXT RECORD AND
C ***   DETERMINE ITS LENGTH.
C
20010 IF (RECPOS.GE.RECLEN) GOTO 20015
         RECPOS = RECPOS + 1
         RECCHR = RECORD(RECPOS)
         EORFLG = .FALSE.
         RETURN
20015 IF (RECPOS.GT.RECLEN) GOTO 20020
C     ***   RETURN END OF RECORD CODE.
         RECPOS = RECPOS + 1
         RECCHR = -2
         RETURN
C
C     ***   ASSUME RECORD IS NOT COMMENT IF NOT PL-6 SOURCE.
20020    IF (SRCTYP.NE.1) INCMNT = .FALSE.
C     ***   GET THE NEXT RECORD.
         CALL READR1(SIUNIT,RECORD,140,30010S,30050S)
C        READ(SIUNIT,20029,END=30010,ERR=30050)
C    &         (RECORD(I),I=1,140)
20029    FORMAT( 140R1 )
C
C     ***   COUNT NEW RECORD, NEW RECORD BEGINS.
C
         RECNBR = RECNBR + 1
         RECBGN = .TRUE.
         RECPOS = 0
         RECLEN = 140
C
C     ***   DETERMINE KEY.
C
         INQUIRE(UNIT=SIUNIT,NEXTREC=I)
         IF (I.GT.0) RECKEY = FLOAT(I-1) * 0.001
         IF (I.LE.0) RECKEY = - FLOAT(RECNBR) * 0.001
C
C     ***   DETERMINE IF THIS RECORD IS A COMMENT.
C
         IF (SRCTYP.EQ.1) GOTO 20030
         IF ( ( (SRCTYP.EQ.2).AND.(RECORD(1).EQ.1R*) )
     &    .OR.  ( (SRCTYP.EQ.3).AND.( (RECORD(1).EQ.1RC)
     &         INCMNT = .TRUE.
C
C     ***   IGNORE TRAILING JUNK.
C
20030    IF (RECLEN.LE.0) GOTO 20035
            IF (RECORD(RECLEN).GT.1R ) GOTO 20040
               RECORD(RECLEN) = 1R
               RECLEN = RECLEN - 1
               GOTO 20030
20035 RECLEN = 1
C
C ********************
C ***   THIS IS THE FIRST RECORD OF THE INPUT FILE,
C ***   DETERMINE ITS TYPE.   BMAP STARTS WITH *, FORTRAN WITH C,
C ***   PL-6 IS ANYTHING ELSE.
C
20040 RECPOS = RECPOS + 1
      RECCHR = RECORD(RECPOS)
      EORFLG = .FALSE.
      IF (RECNBR.GT.1) RETURN
C
C **********
C ***   FIRST RECORD OF CURRENT FILE.   GET FILE'S NAME AND ACCOUNT.
C
      INQUIRE(UNIT=SIUNIT,NAME=FILNAM,ACCOUNT=FILACT)
C
C ***   DETERMINE LENGTH OF FILE NAME.
C
      FILNLN = 0
20042 FILNLN = FILNLN + 1
      IF (FILNLN.GT.31) GOTO 20046
         IF (FILNAM(FILNLN:FILNLN).GT.' ') GOTO 20042
20046 FILNLN = FILNLN - 1
      READ(FILNAM,20047) FILNLN,(FILNMR(I),I=1,FILNLN)
20047 FORMAT( NR1 )
C
C ***   DETERMINE SOURCE TYPE.
C
20050 SRCTYP = 1
C
C ***   IF RECORD BEGINS WITH * - BMAP
C ***                         C - FORTRAN
C ***   IF RECORD CONTAINS / OR ; - PL6
C ***   ELSE ASSUME BMAP
C
      INCMNT = .TRUE.
      IF (RECORD(1).EQ.1R*) SRCTYP = 2
      IF (RECORD(1).EQ.1RC) SRCTYP = 3
      IF (SRCTYP.NE.1) RETURN
      INCMNT = .FALSE.
      DO 20051 I=1,RECLEN
         IF (RECORD(I).EQ.1R/) RETURN
         IF (RECORD(I).EQ.1R;) RETURN
20051 CONTINUE
      SRCTYP = 2
      RETURN
C
C ********************
C ***   END OF FILE.
C
30010 RECCHR = -1
      RETURN
C
C ********************
C ***   ERROR READING INPUT FILE.
C
30050 WRITE(ERUNIT,30059) RECNBR, ABS(RECKEY)
30059 FORMAT( ' *** ERROR READING REC # ', I5, '(', F8.3, ')' )
      STOP 'ABORT'
      END
C *********************************************************************
C **********                  IOINIT                         **********
C *********************************************************************
C ***   IOINIT  5 JUN 78  (PRY)
C ***   IOINIT INITIALIZES GLOBAL DATA FOR NXTCHR.
C
      SUBROUTINE IOINIT
C
      INCLUDE AEXTGLBLS
C
C ********************
C ***   RESET RECORD COUNT.  SET RECPOS > RECLEN.
C
10010 RECNBR = 0
      RECPOS = RECLEN + 1
C ***   FORCE READ OF FIRST RECORD.
      INCMNT = .FALSE.
C ***   ASSUME PL-6 SOURCE.
      SRCTYP = 1
      EORFLG = .FALSE.
C ***   READ FIRST RECORD.
      CALL NXTCHR
      RETURN
      END
C *********************************************************************
C **********               STRCHR                            **********
C *********************************************************************
C ***   STRCHR  5 JUN 78   (PRY)
C ***   STRCHR APPENDS THE CURRENT CHARACTER TO THE CURRENT ITEM AND
C ***   GETS THE NEXT CHARACTER.
C
      SUBROUTINE STRCHR
C
      INCLUDE AEXTGLBLS
C
C ********************
C ***   INCREMENT THE CHARACTER INDEX.  IF NO MORE ROOM, RETURN.
C ***   OTHERWISE APPEND THE CHARACTER.
C
10010 TITEM(0) = TITEM(0) + 1
      IF (TITEM(0).GT.140) GOTO 20010
      TITEM(TITEM(0)) = RECCHR
      RETURN
C
C ********************
C ***   ITEM BECAME TOO LONG.
C
20010 WRITE(ERUNIT,20019) RECNBR, ABS(EDTKEY),
     &      (TITEM(I),I=1,TITEM(0))
20019 FORMAT( ' *** ITEM TOO LONG AT REC # ', I5, '(',
     &      F8.3, ') :', /, X, NR1 )
      RETURN
      END
C *********************************************************************
C **********                   ITMKEY                        **********
C *********************************************************************
C ***   ITMKEY   25 JAN 78   (PRY)
C ***   ITMKEY DETERMINES IF THE CURRENT ITEM IS A
C ***   KEYWORD AND RETURNS ITS CODE (TAKEN FROM A KEYWORD TABLE)
C ***   IF SO OR 0 INDICATING IT ISN'T.
C ***   THE KEYWORD TABLE IS ORDERED BY KEYWORD LENGTH.  KEYLEN
C ***   CONTAINS THE INDEX INTO THE KEYWORD TABLE KEYWRD OF
C ***   ALL KEYWORD OF A GIVEN LENGTH.  THUS THE SEARCH BOUNDS
C ***   ARE KEYLEN(N) TO (NOT INCLUDING) KEYLEN(N+1).  FOLLOWING
C ***   EACH KEYWORD IN THE KEYWORD TABLE IS ITS CODE.
C ***
C
      INTEGER FUNCTION ITMKEY( )
C
      INCLUDE AEXTGLBLS
C
C ***   GET THE KEYWORD TABLE.
      INCLUDE AEXTPL6T
C
      INTEGER SRCHX, ENDX
C
C ********************
C ***   ASSUME ITEM NOT IN TABLE.  CHECK IF IT'S POSSIBLE THAT
C ***   ITEM IS IN THE TABLE BY CHECKING ITS LENGTH.
C
10010 ITMKEY = 0
      IF (KEYLEN(0).LT.TITEM(0)) RETURN
C
C ***   GET SEARCH LIMITS.
C
      SRCHX = KEYLEN(TITEM(0))
      ENDX  = KEYLEN(TITEM(0)+1)
C
C ********************
C ***   IF SEARCH INDEX IS AT OR PAST END INDEX, ITEM WAS NOT FOUND.
C
20010 IF (SRCHX.GE.ENDX) RETURN
C
C
      DO 20030 I=1,TITEM(0)
           IF (KEYWRD(SRCHX+I).EQ.TITEM(I)) GOTO 20030
C          ***   KEYWORD DIDN'T MATCH.  TRY NEXT KEYWORD.
                SRCHX = SRCHX + TITEM(0) + 1
                GOTO 20010
20030      CONTINUE
C
C **********
C ***   ITEM MATCHES KEYWORD.  RETURN KEYWORD CODE.
C
      ITMKEY = KEYWRD(SRCHX+TITEM(0)+1)
      RETURN
      END
C *********************************************************************
C **********                     ADDCMT                      **********
C *********************************************************************
C ***   ADDCMT   14 JUN 78   (PRY)
C ***   ADDCMT SETS UP COMMENT DATA FOR ADDITION TO DATA BASE.
C ***   THE LENGTH OF THE COMMENT DATA IS RETURNED.
C
      INTEGER FUNCTION ADDCMT( )
C
      INCLUDE AEXTGLBLS
C
C
      INTEGER DRCLEN, CNAMIX
C
C ***   DRCLEN - DATA RECORD LENGTH
C ***   CNAMIX - INDEX OF NAME TABLE NAME TO USE FOR COMMENT
C
C ********************
C ***   MAKE SURE THAT THIS COMMENT WILL FIT INTO THE CURRENT (END)
C ***   BLOCK OF THE DATA BASE.
C
C ***   2 BYTES/ITEM, 3 BYTES/PREV PTR/ITEM, 3 BYTES/NEXT PTR/ITEM,
C ***   3 BYTES/RECORD TEXT PTR, VARIABLE SIZE INFO
C ***   IF NULL BLOCK, USE NAME 4.
10010 IF (BK(0).EQ.NULMRK) CNAMIX = 4
      IF (BK(0).NE.NULMRK) CNAMIX = CMTID+4
      DRCLEN = (ITMMAX+1)*(2+3)+3+(1+3)+(1+FILNLN)
     &      +(1+NAMES(CNAMIX,0))
      IF (DRCLEN+BT(0).LE.BLKSIZ) GOTO 10020
C     ***   DOESN'T FIT.  WRITE OUT CURRENT AND PREPARE NEXT.
         CALL DIWRIT(DATUNT,BLK(0,0),BLKSIZ,BK(0))
         BK(0)=BK(0)+1
         BT(0)=0
C
C ***   SET UP NEXT RECORD WITH ITEM INFORMATION.
C
C
C ***   FIRST ITEM IS COMMENT IDENTITY.  ONE BYTE.
C
10020 BLK(BT(0),0) = 1
      BLK(BT(0)+1,0) = CMTID
C
C ***   UPDATE RECORD WITH POINTER TO TEXT DATA.
C
C ***   CALC IX OF FIRST VARIABLE ENTRY BYTE.
      J = BT(0) + (ITMMAX+1)*(2+3)
C ***   BREAK APART TWO 12 BIT FIELDS INTO THREE 8 BIT FIELDS.
      CALL T12T38( TBKNBR, TBTNBR, 0, J )
C
C ***   SECOND ITEM IS SOURCE LINE NUMBER.
C
      J = J + 3
      BLK(BT(0)+2,0) = 0
      BLK(BT(0)+3,0) = J-BT(0)
C ***   MAKE 24 BIT LINE NUMBER INTO 3 8 BIT FIELDS.
      BLK(J,0) = 3
      N1 = CMTREC / 4096
      N2 = CMTREC - N1*4096
      CALL T12T38( N1, N2, 0, J+1 )
C
C ***   THIRD ITEM IS ITEM NAME.
C
      J = J + 4
      BLK(BT(0)+4,0) = 0
      BLK(BT(0)+5,0) = J-BT(0)
C ***   MOVE NAME INTO POSITION.
      DO 10070 I=0,NAMES(CNAMIX,0)
10070    BLK(J+I,0) = NAMES(CNAMIX,I)
C
C ***   FOURTH ITEM IS FILE ID.
C
      J = J + NAMES(CNAMIX,0) + 1
      BLK(BT(0)+6,0) = 0
      BLK(BT(0)+7,0) = J-BT(0)
      BLK(J,0) = FILNLN
      DO 10079 I=1,FILNLN
10079    BLK(J+I,0) = FILNMR(I)
C
C
      BM(0) = .TRUE.
      ADDCMT = DRCLEN
      RETURN
      END
C *********************************************************************
C **********               T12T38                            **********
C *********************************************************************
C ***   T12T38   14 JUN 78   (PRY)
C ***   T12T38 CONVERTS TWO TWELVE BIT INTEGERS INTO THREE
C ***   SUCCESSIVE 8 BIT INTEGERS.
C
C
      INTEGER WD1, WD2, BLOCK, DISP
C
C ***   WD1    - FIRST 12 BIT INTEGER
C ***   WD2    - SECOND 12 BIT INTEGER
C ***   BLOCK  - BLOCK INTO WHICH 8 BIT INTEGERS ARE TO GO
C ***   DISP   - DISPLACEMENT INTO BLOCK WHERE FIRST ONE SHOULD GO
C
      INCLUDE AEXTGLBLS
C
C ********************
C ***   LOCALIZE DATA.
C
10010 N1 = WD1 / 16
      N2 = WD2 / 256
      I = DISP
      K = BLOCK
      BLK(I,K) = N1
      BLK(I+1,K) = (WD1 - N1*16)*16 + N2
      BLK(I+2,K) = WD2 - N2*256
      RETURN
      END
C *********************************************************************
C **********               T38T12                            **********
C *********************************************************************
C ***   T38T12  15 JUN 78   (PRY)
C ***   T38T12 CONVERTS 3 SUCCESSIVE 8 BIT INTEGERS INTO TWO
C ***   12 BIT INTEGERS.
C
      SUBROUTINE T38T12( BLOCK, DISP, WD1, WD2 )
C
      INTEGER BLOCK, DISP, WD1, WD2
C
C ***   BLOCK  - BLOCK IN WHICH 8 BIT INTEGERS ARE TO BE FOUND
C ***   DISP   - DISPLACEMENT INTO BLOCK OF FIRST INTEGER
C ***   WD1    - FIRST 12 BIT INTEGER
C ***   WD2    - SECOND 12 BIT INTEGER
C
      INCLUDE AEXTGLBLS
C
C ********************
C ***   LOCALIZE DATA.
C
10010 I = DISP
      K = BLOCK
      N = BLK(I+1,K)
      N1 = N / 16
      WD1 = BLK(I,K)*16 + N1
      WD2 = (N - N1*16)*256 + BLK(I+2,K)
      RETURN
      END
C *********************************************************************
C **********               ADDLIN                            **********
C ***   ADDLIN  13 JUN 78  (PRY)
C ***   ADDLIN ADDS THE CURRENT LINE TO THE OUTPUT BLOCK.
C
      SUBROUTINE ADDLIN( FRSTCR, LASTCR )
C
      INTEGER FRSTCR, LASTCR
C
C ***   FRSTCR - INDEX OF FIRST CHARACTER OF STRING
C ***   LASTCR - INDEX OF LAST CHARACTER OF STRING
C
      INCLUDE AEXTGLBLS
C
      INTEGER LINLEN
C
C ***   LINLEN - NUMBER OF CHARACTERS IN CURRENT LINE
C
C ********************
C ***   CALC LENGTH OF STRING.
C
10010 LINLEN = LASTCR - FRSTCR + 1
      K = FRSTCR
      HAVCMT = .TRUE.
C
C ***   ENTIRE LINE MUST FIT.
C
      IF (TBTNBR+LINLEN.LE.BLKSZX) GOTO 10020
C     ***   READY NEW BLOCK.
         TBKCHR(TBTNBR) = LINLEN
         CALL DIWRIT(TXTUNT,TBKCHR,BLKSIZ,TBKNBR)
         TBKNBR = TBKNBR + 1
         TBTNBR = 0
C
C ***   PUT TEXTC STRING LENGTH IN BLOCK.
C
10020 TBKCHR(TBTNBR) = LINLEN
      TBTNBR = TBTNBR + 1
C ***   INIT STRING INDEX.
C
C **********
C ***   ADD STRING TO OUTPUT BLOCK.
C
10400 IF (LINLEN.LE.0) GOTO 10460
      DO 10450 I=0,LINLEN-1
10450    TBKCHR(TBTNBR+I) = RECORD(K+I)
C
C ***   CALC LOC OF NEXT FREE BYTE.
C
      TBTNBR = TBTNBR + LINLEN
C
C ***   MAKE SURE NEXT BYTE IS FREE.
C
10460 IF (TBTNBR.LE.BLKSZX) RETURN
      CALL DIWRIT(TXTUNT,TBKCHR,BLKSIZ,TBKNBR)
      TBKNBR = TBKNBR + 1
      TBTNBR = 0
      RETURN
      END
C *********************************************************************
C **********                  GETLNS                         **********
C ***   GETLNS  13 JUN 78  (PRY)
C ***   GETLNS PRINTS A GROUP OF TEXT LINES GIVEN THE BLOCK NUMBER
C ***   AND STARTING BYTE INDEX.
C
      SUBROUTINE GETLNS( BLKNBR, BYTNBR )
C
      INTEGER BLKNBR, BYTNBR
C
C ***   BLKNBR - NUMBER OF BLOCK TEXT STARTS IN
C ***   BYTNBR - INDEX INTO BLOCK OF START OF TEXT
C
      INCLUDE AEXTGLBLS
C
C
C ********************
C ***   READ DESIRED BLOCK AND SET CURRENT POSITION.
C
10010 TBKNBR = BLKNBR
      CALL DIREAD(TXTUNT,TBKCHR,BLKSIZ,TBKNBR)
C
C ***   PRINT LINES FROM CURRENT WHILE 1) LINES EXIST AND 2)
C ***   LINE FITS INTO BLOCK.
C
10050 J = BYTNBR
C ***   RETURN IF END OF TEXT MARKER.
10060 IF (TBKCHR(J).EQ.0) RETURN
      IF (BRKFLG.GT.0) RETURN
C ***   IF LINE DOESN'T FIT INTO BLOCK, IT'S IN THE NEXT ONE.
      IF (J+TBKCHR(J).LE.BLKSZX) GOTO 10070
10065    TBKNBR = TBKNBR + 1
         CALL DIREAD(TXTUNT,TBKCHR,BLKSIZ,TBKNBR)
         J = 0
         GOTO 10060
C
C ***   PRINT NEXT LINE.
C
10070 WRITE(RPTUNT,10079) TBKCHR(J),(TBKCHR(I),I=J+1,J+TBKCHR(J))
10079 FORMAT( X, NR1 )
C ***   POSITION INDEX TO START OF NEXT LINE.
      J = J + TBKCHR(J) + 1
      IF (J.GT.BLKSZX) GOTO 10065
      GOTO 10060
      END
C *********************************************************************
C **********                  ADDREC                         **********
C *********************************************************************
C ***   ADDREC  14 JUN 78  (PRY)
C ***   ADDREC INSERTS THE CURRENT RECORD INTO THE SPECIFIED LIST
C ***   IN ASCENDING ORDER.
C
C
      INTEGER LSTNBR
C
C ***   LSTNBR - NUMBER OF LIST TO INSERT CURRENT RECORD INTO
C
      INCLUDE AEXTGLBLS
C
      INTEGER NLST
C
C ***   NLST - DISPLACEMENT INTO RECORD WHERE NEXT INFO BEGINS
C
C ********************
C ***   ATTEMPT TO FIND RECORD THEN USE CURRENT POSITION INFORMATION
C ***   TO INSERT RECORD.
C
C ***   CALCULATE DISPLACEMENTS.
10010 NLST = (ITMMAX+1)*2 + LSTNBR*3
C
C ***   ATTEMPT TO FIND RECORD.
C
10020 CALL FNDREC( LSTNBR, .FALSE. )
C ***   IF AT BEGINNING OF INDEX LIST, INSERT BEFORE NEXT.
      IF (BEQUAL.AND.(PBK.EQ.NULMRK)) CALL NXTREC( LSTNBR )
C
C **********
C ***   INSERT RECORD BETWEEN PREVIOUS AND NEXT RECORDS.
C
C ***   CHECK IF NO PREVIOUS RECORD.
20010 IF (PBK.NE.NULMRK) GOTO 20020
C
C     ***   NO PREVIOUS RECORD.  LINK CURRENT RECORD TO FRONT OF LIST.
C
C     ***   CURRENT IS FIRST RECORD OF LIST.
         FSTBLK(LSTNBR,0) = BK(0)
         FSTBYT(LSTNBR,0) = BT(0)
         GOTO 20030
C
C ***   LINK CURRENT RECORD AFTER PREVIOUS.
C
C ***   PREVIOUS'S NEXT POINT TO CURRENT.
20020 CALL T12T38( BK(0), BT(0), PBK, PBT+NLST )
      BM(PBK) = .TRUE.
C
C **********
C ***   INSERT CURRENT BEFORE NEXT.
C
C ***   CHECK IF NEXT EXISTS.
20030 IF (NBK.NE.NULMRK) GOTO 20040
C     ***   CURRENT'S NEXT DOES NOT EXIST.
         CALL T12T38( NULMRK, NULMRK, 0, BT(0)+NLST )
         GOTO 20050
C
C ***   NEXT RECORD EXISTS.  LINK CURRENT BEFORE IT.
C
C ***   CURRENT'S NEXT IS NEXT.
20040 CALL T12T38( BK(NBK), NBT, 0, BT(0)+NLST )
C
20050 BM(0) = .TRUE.
      RETURN
      END
C *********************************************************************
C **********                  FNDREC                         **********
C *********************************************************************
C ***   FNDREC   14 JUN 78   (PRY)
C ***   FNDREC RUNS THROUGH THE ARGUMENT LIST STARTING AT THE FIRST
C ***   RECORD OF THE LIST TO FIND WHERE A RECORD SHOULD BE INSERTED.
C
      SUBROUTINE FNDREC( LSTNBR, WLDFND )
C
      INTEGER LSTNBR, INDIX, GETBLK, LOWIX, HIGHIX
      LOGICAL WLDFND
C
C ***   LSTNBR - NUMBER OF LIST RECORD IS TO BE INSERTED IN
C ***   WLDFND - SET .TRUE. IF TO FIND WILD MATCH
C ***   INDIX  - INDEX OF CURRENT INDEX BLOCK
C ***   GETBLK - FUNCTION TO GET SPECIFIED PHYSICAL BLOCK
C ***   LOWIX  - INDEX OF LOWEST COMPARED BLOCK
C ***   HIGHIX - INDEX OF GREATEST COMPARED BLOCK
C
      INCLUDE AEXTGLBLS
C
C *********************
C ***   SEARCH INDEX LIST FOR RECORD.
C
10010 IF (WLDFND) GOTO 10500
      HIGHIX = FSTEND(LSTNBR)
      IF (HIGHIX.LE.0) GOTO 10500
      PBK = NULMRK
      PBT = NULMRK
      LOWIX = 0
C
C ***   CALC INDEX OF NEXT MIDPOINT.
C
10040 INDIX = (LOWIX+HIGHIX+1) / 2
C
C ***   GET THE NEXT BLOCK FOR COMPARISON.
C
      NBT = FSTBYT(LSTNBR,INDIX)
      NBK = GETBLK( FSTBLK(LSTNBR,INDIX) )
10050 CALL CMPBLK( 0, LSTNBR, .FALSE. )
      IF (BLESS) GOTO 10070
      IF (BEQUAL) RETURN
C
C ***   RECORD SHOULD FOLLOW INDEXED RECORD.
C
      LOWIX = INDIX
      IF (INDIX.GE.HIGHIX) GOTO 20020
      GOTO 10040
10070 HIGHIX = INDIX - 1
      IF (HIGHIX.GT.LOWIX) GOTO 10040
      NBK = GETBLK( FSTBLK(LSTNBR,LOWIX) )
      GOTO 20030
C
C **********
C ***   INITIALIZE FOR START OF LIST.
C
10500 NBK = NULMRK
      NBT = NULMRK
      PBK = NULMRK
      PBT = NULMRK
C
C **********
C ***   GET THE NEXT RECORD.
C
20020 CALL NXTREC( LSTNBR )
C ***   CHECK FOR LIST END.
      IF (NBK.EQ.NULMRK) RETURN
C ***   COMPARE NEXT WITH CURRENT.
20030 CALL CMPBLK( 0, LSTNBR, WLDFND )
C ***   IF NOT LESS THAN OR EQUAL TO, KEEP LOOKING.
      IF (BGRATR) GOTO 20020
      RETURN
      END
C *********************************************************************
C **********                  NXTREC                         **********
C *********************************************************************
C ***   NXTREC   16 JUN 78   (PRY)
C ***   NXTREC GETS THE NEXT RECORD IN THE SPECIFIED LIST.
C
      SUBROUTINE NXTREC( LSTNBR )
C
      INTEGER LSTNBR
C
C ***   LSTNBR - LIST TO GET NEXT RECORD FROM
C
      INCLUDE AEXTGLBLS
C
      INTEGER GETBLK
C
C ***   RETURNS LOGICAL BLOCK NUMBER GIVEN PHYSICAL BLOCK NUMBER
C
C ********************
C ***   IF NOT ANYWHERE IN LIST, GET FIRST RECORD.
C
10010 IF (NBK.NE.NULMRK) GOTO 10500
         NBK = FSTBLK(LSTNBR,0)
         NBT = FSTBYT(LSTNBR,0)
C     ***   IF NO LIST START, RETURN WITH NULL.
         IF (NBK.EQ.NULMRK) RETURN
C     ***   NO PREVIOUS
         PBK = NULMRK
         PBT = NULMRK
C     ***   GET FIRST RECORD.
         NBK = GETBLK( NBK )
         RETURN
C
C **********
C ***   IN LIST.  GET NEXT RECORD.
C
10500 PBK = NBK
      PBT = NBT
C ***   GET POINTER TO NEXT RECORD.
      CALL T38T12( PBK, PBT+(ITMMAX+1)*(2)+LSTNBR*3, NBK, NBT )
C ***   IF END OF LIST, RETURN.
      IF (NBK.EQ.NULMRK) RETURN
C ***   GET THE RECORD BLOCK.
      NBK = GETBLK( NBK )
      RETURN
      END
C *********************************************************************
C **********                  GETBLK                         **********
C *********************************************************************
C ***   GETBLK   14 JUN 78   (PRY)
C ***   GET BLOCK GETS THE ARGUMENT PHYSICAL BLOCK INTO CORE
C ***   AS THE RETURNED LOGICAL BLOCK NUMBER.
C
      INTEGER FUNCTION GETBLK( PHYBLK )
C
      INTEGER PHYBLK
C
C ***   PHYBLK - NUMBER OF PHYSICAL BLOCK TO GET
C
      INCLUDE AEXTGLBLS
C
      INTEGER RPLBLK
C
C ***   RPLBLK - FUNCTION TELLS WHICH BLOCK TO REPLACE
C
C ********************
C ***   IF BLOCK IS ALREADY IN CORE, RETURN ITS LOGICAL NUMBER.
C
10010 BTIC = BTIC + 1
      DO 10020 GETBLK=0,BMAXIX
10020    IF (BK(GETBLK).EQ.PHYBLK) GOTO 20020
C
C ***   SELECT FIRST UNUSED BLOCK.
C
      IF (BMAXIX.GE.BLKMAX) GOTO 10028
         BMAXIX = BMAXIX + 1
         GETBLK = BMAXIX
         GOTO 20010
C
C ***   SELECT OLDEST BLOCK IF UNMODIFIED.
C
10028 GETBLK = RPLBLK( )
      IF (.NOT.BM(GETBLK)) GOTO 20010
      K = GETBLK
C
C ***   SELECT FIRST UNMODIFIED BLOCK.
C
      DO 10030 GETBLK=1,BLKMAX
C     ***   DON'T THROW OUT PREVIOUS BLOCK.
         IF (GETBLK.EQ.PBK) GOTO 10030
         IF (.NOT.BM(GETBLK)) GOTO 20010
10030 CONTINUE
C
C ***   ALL IN-CORE BLOCKS ARE IN-USE AND MODIFIED.  SELECT
C ***   BLOCK FOR REPLACEMENT.
C
      GETBLK = K
C  ***   WRITE OUT BLOCK.
      CALL DIWRIT(DATUNT,BLK(0,GETBLK),BLKSIZ,BK(GETBLK))
C
C ***************
C ***   READ IN NEW BLOCK.
C
20010 CALL DIREAD(DATUNT,BLK(0,GETBLK),BLKSIZ,PHYBLK)
C ***   SET UP BLOCK DATA.
      BK(GETBLK) = PHYBLK
      BM(GETBLK) = .FALSE.
C
C ***   TIC BLOCK.
C
20020 BA(GETBLK) = BTIC
      RETURN
      END
C *********************************************************************
C **********               RPLBLK                            **********
C *********************************************************************
C ***   RPLBLK   14 JUN 78   (PRY)
C ***   RPLBLK DECIDES WHICH LOGICAL BLOCK TO REPLACE AND RETURNS
C ***   ITS NUMBER.
C
      INTEGER FUNCTION RPLBLK( )
C
      INCLUDE AEXTGLBLS
C
C ********************
C ***   RETURN THE NUMBER OF THE BLOCK WHICH HASN'T BEEN ACCESSED
C ***   FOR THE GREATEST AMOUNT OF TIME.
C
10010 K = 2**30-1
      DO 10020 I=1,BLKMAX
         IF (I.EQ.PBK) GOTO 10020
         IF (K.LE.BA(I)) GOTO 10020
            K = BA(I)
            RPLBLK = I
10020 CONTINUE
C
C ***   UN-TIC BLOCKS.
C
10030 DO 10040 I=0,BLKMAX
10040    BA(I) = BA(I) - K
      BTIC = BTIC - K
      RETURN
      END
C *********************************************************************
C **********                  CMPBLK                         **********
C *********************************************************************
C ***   CMPBLK  14 JUN 78  (PRY)
C ***   OF THE ARGUMENT BLOCK NUMBER
C
      SUBROUTINE CMPBLK( BLOCK, LSTNBR, WLDCMP )
C
      INTEGER BLOCK, LSTNBR, RECID, BLOCKL
      LOGICAL WLDCMP
C
C ***   BLOCK  - BLOCK TO COMPARE
C ***   LSTNBR - NUMBER OF LIST ITEM TO COMPARE
C ***   WLDCMP - FLAG INDICATING IF WILD COMPARE IS TO BE USED
C ***   BLOCKL - LOCAL BLOCK NUMBER
C
      INCLUDE AEXTGLBLS
C
      INTEGER CBT1, CBT2, K1, K2, C1, C2
C
C ***   CBT1 - DISPLACEMENT INTO LOGICAL RECORD 0 OF ITEM TO COMPARE
C ***   CBT2 - DISPLACEMENT INTO LGL REC BLKNBR OF ITEM TO COMPARE
C ***   K1   - LENGTH OF ITEM 1
C ***   K2   - LENGTH OF ITEM 2
C ***   C1   - BYTE FROM ITEM 1
C ***   C2   - BYTE FROM ITEM 2
C
      INTEGER XSX, X1, X2, X1S(40), X2S(40)
C
C ***   XSX - STACK INDEX
C ***   X1 - INDEX OF FIRST STRING
C ***   X2 - INDEX OF SECOND STRING
C ***   X1S - STACK FOR FIRST INDEX
C ***   X2S - STACK FOR SECOND INDEX
C
C ********************
C ***   GET ITEM STARTING BYTE INFORMATION.
C
10010 I = LSTNBR * 2
      BLOCKL = BLOCK
      CBT1 = BT(BLOCKL) + I
C     ***   NON-ZERO MEANS TEXTC ITEM STARTS HERE.
      IF (BLK(CBT1,BLOCKL).NE.0) GOTO 10014
C ***   NEED TO GET DISPLACEMENT TO ITEM.
      CBT1 = BLK(CBT1+1,BLOCKL) + BT(BLOCKL)
C
10014 CBT2 = NBT + I
      IF (BLK(CBT2,NBK).NE.0) GOTO 10018
      CBT2 = BLK(CBT2+1,NBK) + NBT
C
C ***   INITIALIZE FLAGS.
C
10018 BEQUAL = .FALSE.
      BGRATR = .FALSE.
      BLESS = .FALSE.
C ***   GET LENGTH OF RESPECTIVE ITEMS.
      K1 = BLK(CBT1,BLOCKL)
      K2 = BLK(CBT2,NBK)
      K = MIN( K1, K2 )
99991 IF (K.LE.0) GOTO 10040
C
C ***   COMPARE SUCCESSIVE BYTES 'TIL UNEQUAL OR OUT OF BYTES.
C
      DO 10030 I=1,K
C     ***   GET RESPECTIVE BYTES.
         C1 = BLK(CBT1+I,BLOCKL)
         C2 = BLK(CBT2+I,NBK)
C     ***  IF EQUAL, MORE TO COMPARE.  ELSE DONE AND SET FLAGS.
         IF (C1.EQ.C2) GOTO 10030
            IF (C1.LT.C2) GOTO 10025
               BGRATR = .TRUE.
               GOTO 10050
10025       BLESS = .TRUE.
            GOTO 10050
10030 CONTINUE
C
C ***   IF LENGTHS ARE EQUAL, ITEMS ARE EQUAL.  ELSE LONGER ITEM
C ***   IS GREATER.
C
10040 IF (K1.EQ.K2) BEQUAL = .TRUE.
      IF (K1.GT.K2) BGRATR = .TRUE.
      IF (K1.LT.K2) BLESS = .TRUE.
10050 IF (.NOT.WLDCMP) RETURN
      IF (LSTNBR.LT.2) RETURN
C
C ***   TRY WILD CARD TYPE COMPARISON.
C
C ***   INIT STACK AND STRING INDICES.
      XSX = 1
      X1S(1) = 1
      X2S(1) = 1
C
C ***   IF ANYTHING LEFT ON STACK, MORE TO COMPARE.
C
20030 IF (XSX.LE.0) RETURN
      X1 = X1S(XSX)
      X2 = X2S(XSX)
      XSX = XSX - 1
      BEQUAL = .FALSE.
      BGRATR = .FALSE.
      BLESS = .FALSE.
C
C ***   IF NOTHING LEFT TO COMPARE, STRINGS ARE EQUAL.
C
20040 IF (X1.LE.K1) GOTO 20050
         IF (X2.LE.K2) BLESS = .TRUE.
         IF (BLESS) GOTO 20030
         BEQUAL = .TRUE.
         RETURN
C
C ***   IF NOTHING TO COMPARE OF SECOND STRING, GREATER.
C
20050 IF (X2.LE.K2) GOTO 20060
         IF (BLK(CBT1+X1,BLOCKL).NE.1R?) GOTO 20056
            X1 = X1 + 1
            GOTO 20040
         GOTO 20030
C
C ***   PART OF STRINGS REMAIN...COMPARE NEXT CHARS.
C
20060 C1 = BLK(CBT1+X1,BLOCKL)
      C2 = BLK(CBT2+X2,NBK)
C
C ***   IF CHARS ARE EQUAL, COMPARE NEXT CHARS.
C
      IF (C1.NE.C2) GOTO 20070
         X1 = X1 + 1
         X2 = X2 + 1
         GOTO 20040
C
C ***   CHARS WERE NOT EQUAL.  CHECK FOR WILD CARD CHAR.
C
20070 IF (C1.EQ.1R?) GOTO 20080
         IF (C1.GT.C2) BGRATR = .TRUE.
         IF (C1.LT.C2) BLESS = .TRUE.
         GOTO 20030
C
C ***  IGNORE DUPLICATE WILD CARD CHARS.
C
20080 IF (X1+1.GT.K1) GOTO 20086
         IF (BLK(CBT1+X1+1,BLOCKL).NE.1R?) GOTO 20086
         X1 = X1 + 1
         GOTO 20080
C
C ***   FOUND A WILD CARD CHAR...IF ENOUGH ROOM ON STACK,
C ***   COMPARE MORE OF STRING.  OTHERWISE ASSUME FIRST IF LESS
C ***   THAN SECOND.
C
20086 IF (XSX.LE.38) GOTO 20090
         BLESS = .TRUE.
         RETURN
C
C ***   PUSH COMPARISONS ON STACK.
C
20090 XSX = XSX + 1
C ***   IGNORE CHAR OF SECOND STRING DUE TO WILD CARD.
      X1S(XSX) = X1
      X2S(XSX) = X2+1
      XSX = XSX + 1
C ***   IGNORE WILD CARD CHAR.
      X1S(XSX) = X1 + 1
      X2S(XSX) = X2
C
C ***   ASSUME WILD CARD CHAR MATCHES ONE CHAR AND CONTINUE COMPARISON.
C
      X1 = X1 + 1
      X2 = X2 + 1
      GOTO 20040
      GOTO 99991
      END
C *********************************************************************
C **********               MAIN                              **********
C *********************************************************************
C ***   MAIN     16 JUN 78   (PRY)
C
      PROGRAM MAIN
C
      INCLUDE AEXTGLBLS
C
      GLOBAL OLDFIL, FOUND, HLPFLG, RPTSET, SRTFLG, SRTYET, DELFLG
      INTEGER FOUND
      LOGICAL GETFID, OLDFIL, HLPFLG, RPTSET, SRTFLG, SRTYET, DELFLG
      LOGICAL EXTLST
      DATA OLDFIL/.FALSE./, RPTSET/.FALSE./, SRTYET/.FALSE./
      DATA EXTLST/.FALSE./
C
C ***   GETFID - FUNCTION TO RETURN FID
C ***   OLDFIL - SET .TRUE. IF EXTRACT DATA BASE EXISTS
C ***   HLPFLG - SET .TRUE. IF IN HELP MODE
C ***   FOUND  - INCREMENTED FOR EACH RECORD FOUND
C ***   RPTSET - SET .TRUE. IF LAST COMMAND WAS SUCCESSFUL REPORT
C ***   SRTFLG - SET .TRUE. FOR SORT COMMAND
C ***   SRTYET - SET .TRUE. ONCE SORT FILE HAS BEEN OPENED
C ***   DELFLG - SET IF FOUND RECORDS ARE TO BE DELETED
C ***   EXTLST - SET .TRUE. IF EXTRACT WAS LAST COMMAND EXECUTED
C
      GLOBAL LSTRIX, LSTWLD, LSTRDR, PID, RNG, CMTIDL, CMTRCL
      INTEGER LSTRIX, LSTRDR(0:ITMMAX), PID, RNG, CMTIDL(0:1)
      LOGICAL LSTWLD(0:ITMMAX)
      INTEGER CMTRCL(0:1), SFILSZ, SRECSZ
      INTEGER KEYIX, GETBLK
      DATA KEYIX/ 1 /
      INTEGER LSTMLN(0:ITMMAX)
      DATA LSTMLN/ 1, 3, 20, 12 /
C
C***    LSTRIX - INDEX OF LAST ENTRY IN LIST ORDER TABLE
C ***   LSTWLD - FLAG SET IF ITEM CONTAINS WILD CARD CHAR
C ***   LSTRDR - LIST ORDER TABLE, HOW TO SORT OR LIST DATA
C ***   PID    - PARAMETER ID
C ***   RNG    - RANGE ELEMENT 0-FIRST, 1-LAST
C ***   CMTIDL - FIRST AND LAST COMMEND IDS
C ***   CMTRCL - FIRST AND LAST RECORD NUMBERS
C ***   SFILSZ - SORT FILE SIZE
C ***   KEYIX  - INDEX OF FIRST KEY OF SORT RECORD
C ***   GETBLK - ROUTINE TO GET SPECIFIED PHYSICAL BLOCK
C ***   LSTMLN - MAXIMUM LENGTHS OF ITEMS
C
      GLOBAL DBSTAT, SPLONE, SPLHIT
      CHARACTER DBSTAT*6
      INTEGER SPLONE, SPLHIT
C
C ***   DBSTAT - DATA BASE STATUS
C ***   SPLONE - SPECIAL CHAR TO ACCEPT IN NAME
C ***   SPLHIT - COUNT OF SPECIAL CHARS ENCOUNTERED
C
C ********************
C ***   INITIALIZE FOR COMMAND INPUT.
C
10010 SIUNIT = 102
C ***   INITIALIZE.
      CALL EXTINT
      WRITE(ERUNIT,10019)
10019 FORMAT( ' CP-6 EXTRACT ' )
      CALL IOINIT
C ***   DATA BASE IS NOT OPEN.
      BASOPN = .FALSE.
      HAVDAT = .FALSE.
C
C **********
C ***   GET NEXT COMMAND.
C
10020 CALL NXTTKN
      BRKFLG = 0
C
C ***   STOP IF END OF FILE OR 'END'.
C
      IF ( (TOKEN.NE.TEOF).AND..NOT.( (TOKEN.EQ.TNAME).AND.
     &      (TPL6ID.EQ.85) ) ) GOTO 10025
C     ***   CLOSE THE DATA BASE.
         IF (.NOT.BASOPN) STOP 'BYE'
C     ***   IF EXTRACT WAS LAST COMMAND EXECUTED, WRITE OUT DATA
         IF (EXTLST) CALL STPDB
         DBSTAT = 'DELETE'
         IF (OLDFIL) DBSTAT = 'KEEP'
         CLOSE(UNIT=DATUNT,STATUS=DBSTAT)
         CLOSE(UNIT=TXTUNT,STATUS=DBSTAT)
C     ***   DELETE SORT FILES IF USED.
         IF (SRTYET) CLOSE(SRIUNT,STATUS='DELETE')
         IF (SRTYET) CLOSE(SROUNT,STATUS='DELETE')
         IF (.NOT.OLDFIL) WRITE(ERUNIT,10022)
10022    FORMAT( ' *** NOTHING EXTRACTED FOR THIS DATA BASE--DELETED' )
         IF ((HAVDAT.OR.RPTSET).AND.OLDFIL) WRITE(ERUNIT,10023) NUMRCS
10023    FORMAT( ' ', I5, ' RECORDS IN DATA BASE' )
         STOP 'ADIOS'
C
C ***   IGNORE RECORD ENDS.
C
10025 IF (TOKEN.EQ.TEOR) GOTO 10020
      IF ( (TOKEN.EQ.TNAME) .AND. ( (TPL6ID.GE.115)
     &      .AND. (TPL6ID.LE.122) ) ) GOTO 10050
         WRITE(ERUNIT,10039) TITEM(0),(TITEM(I),I=1,TITEM(0))
10039    FORMAT( ' *** ', NR1, ' IS NOT A COMMAND' )
C     ***   FORCE NEXT RECORD TO BE READ.
10040    RECPOS = RECLEN + 1
         EORFLG = .TRUE.
         INCMNT = .FALSE.
         SRCTYP = 1
C     ***   MAKE ESC-D WORK.
         CALL PACK(RECORD,RECLEN)
         GOTO 10020
C
C ***************
C ***   HAVE VALID COMMAND.  GOTO PROCESSING ROUTINE.
C
C ***   WRITE OUT DATA BASE INFO IF EXTRACT WAS LAST COMMAND AND
C ***   IS NOT THE CURRENT COMMAND.
10050 IF (EXTLST.AND.(TPL6ID.NE.115)) CALL STPDB
      EXTLST = .FALSE.
      DELFLG = .FALSE.
      HLPFLG = .FALSE.
      SRTFLG = .FALSE.
C ***       EXTRA REPOR DATA_ WHAT  SORT  BALAN OUTPU DELET
      GOTO (10100,10200,10300,10800,10900,11000,11100,11200),TPL6ID-114
C
C ********************
C ***   PROCESS DATA BASE COMMAND.
C
10300 IF (.NOT.BASOPN) GOTO 10320
C     ***   CLOSE OPEN DATA BASE--SAVE ONLY IF IT CONTAINS SOMETHING.
         DBSTAT = 'DELETE'
         IF (OLDFIL) DBSTAT = 'KEEP'
         CLOSE(UNIT=DATUNT,STATUS=DBSTAT)
         CLOSE(UNIT=TXTUNT,STATUS=DBSTAT)
         IF (.NOT.OLDFIL) WRITE(ERUNIT,10022)
         RPTSET = .FALSE.
         BASOPN = .FALSE.
         HAVDAT = .FALSE.
C
C ***   GET FID.
C
10320 IF (.NOT.GETFID()) GOTO 10040
      FNAME(FNLN+1:) = '$DAT'
C ***   OPEN DATA AND TEXT FILES.
      INQUIRE(FILE=FNAME,ACCOUNT=FACCT,EXIST=OLDFIL)
      OPEN(DATUNT,NAME=FNAME,KEYM=3,ERR=10390,
     &      ACCESS='DIRECT')
      FNAME(FNLN+1:) = '$TXT'
      OPEN(TXTUNT,NAME=FNAME,KEYM=3,ERR=10385,
     &      ACCOUNT=FACCT,RECL=16384,STATUS='UNKNOWN',
     &      ACCESS='DIRECT')
      IF (.NOT.OLDFIL) WRITE(ERUNIT,10329)
10329 FORMAT( ' ... NEW DATA BASE' )
      BASOPN = .TRUE.
      RPTSET = .FALSE.
      HAVDAT = .FALSE.
      GOTO 10040
C
C ***   DATA BASE CAN NOT BE OPENED.
C
10385 CLOSE(UNIT=DATUNT,STATUS='KEEP')
10390 WRITE(ERUNIT,10399) FNAME(1:FNLN)
10399 FORMAT( ' *** DATA BASE ', A, ' CAN NOT BE OPENED' )
      RPTSET = .FALSE.
      BASOPN = .FALSE.
      HAVDAT = .FALSE.
      GOTO 10040
C
C ********************
C ***   PROCESS EXTRACT COMMAND.
C
10100 IF (BASOPN) GOTO 10130
10120    WRITE(ERUNIT,10129)
10129    FORMAT( ' *** NO DATA_BASE HAS BEEN SPECIFIED' )
         GOTO 10040
C
C ***   GET EXTRACT SOURCE NAME.
C
10130 IF (.NOT.GETFID()) GOTO 10040
      RPTSET = .FALSE.
      SIUNIT = 101
      OPEN(SIUNIT,NAME=FNAME,ERR=10190,ACCOUNT=FACCT,
     &      USAGE='INPUT',ACCESS='SEQUENTIAL',STATUS='OLD')
      IF (.NOT.HAVDAT) CALL RDYDB
10180 OLDFIL = .TRUE.
      CALL EXTRACT
C ***   NOW WE HAVE SOMETHING IN DATA BASE.
C ***   SET EXTRACT WAS LAST COMMAND FLAG.
      EXTLST = .TRUE.
      CLOSE(UNIT=SIUNIT,STATUS='KEEP')
      SIUNIT=102
      GOTO 10040
C
C ***   ERROR OPENING EXTRACT SOURCE.
C
10190 WRITE(ERUNIT,10199)
10199 FORMAT( ' *** EXTRACT SOURCE FILE CAN NOT BE OPENED' )
      SIUNIT = 102
      GOTO 10040
C
C ***************
C ***   PROCESS 'REPORT' COMMAND.
C
C ***   NOT IN HELP MODE.
10200 HLPFLG = .FALSE.
C
C ***   SET UP INITIAL DATA FOR REPORT OF ALL COMMENTARY.
C
10210 IF (.NOT.BASOPN) GOTO 10120
C ***   IF DATA BASE IS A NEW FILE, NOTHING TO REPORT FROM.
      IF (OLDFIL) GOTO 10215
10211    WRITE(ERUNIT,10214)
10214    FORMAT(' *** NOTHING EXTRACTED FOR THIS DATA BASE YET' )
         GOTO 10040
C
C ***   NO ORDER LIST YET.
C
10215 LSTRIX = -1
      DO 10216 I=0,ITMMAX
10216    LSTWLD(I) = .FALSE.
C ***   MAKE SURE BLOCK 0 CAN'T BE REPLACED DURING REPORT.  ALSO,
C ***   INDICATE THAT NAME 4 IS THE CURRENT NAME.
      BK(0) = NULMRK
C ***   INITIAL COMMENT ID RANGE 0-MAX
      CMTIDL(0) = 0
      CMTIDL(1) = 255
      NAMES(8,0) = 0
      NAMES(9,0) = 0
C ***   INITIAL LINE COUNT RANGE 0-MAX
      CMTRCL(0) = 0
      CMTRCL(1) = 16777215
C ***   INITIAL NAMES RANGE FIRST POSSIBLE-LAST POSSIBLE
      NAMES(4,0) = 0
      NAMES(4,1) = 0
      NAMES(5,0) = 1
      NAMES(5,1) = 255
C ***   INITIAL MODULES RANGE.
      NAMES(6,0) = 0
      NAMES(6,1) = 0
      NAMES(7,0) = 1
      NAMES(7,1) = 255
C
C **********
C ***   GET PARAMETER NAME
C
10220 CALL NXTTKN
C ***   IF END OF COMMAND, READY TO REPORT.
      IF (TOKEN.EQ.TEOR) GOTO 10640
C ***   ERROR IF NOT VALID PARAMETER NAME.
10225 IF (TOKEN.NE.TNAME) GOTO 10230
         IF (TPL6ID.EQ.101) TPL6ID = 112
         IF ( (TPL6ID.LE.114).AND.(TPL6ID.GE.111) ) GOTO 10240
10230    WRITE(ERUNIT,10239) TITEM(0),(TITEM(I),I=1,TITEM(0))
10239    FORMAT( ' *** ', NR1, ' IS NOT A PARAMETER NAME' )
         GOTO 10040
C
C ***   SET PARAMETER ID = LIST INDEX VALUE.
C
10240 GOTO (10241,10242,10243,10244),TPL6ID-110
C ***   MODULES.
10241 PID = 3
      GOTO 10250
C ***   NAMES.
10242 PID = 2
      GOTO 10250
C ***   CODES
10243 PID = 0
      GOTO 10250
C ***   LINES.
10244 PID = 1
C
C ***   MAKE SURE ENOUGH ROOM IN THE LIST ORDER TABLE.
C
10250 IF (LSTRIX.LT.ITMMAX) GOTO 10270
         WRITE(ERUNIT,10269)
10269    FORMAT( ' *** A MAXIMUM OF FOUR PARAMETERS MAY BE SPECIFIED' )
         GOTO 10040
C
C ***   MAKE SURE PARAMETER HAS NOT ALREADY BEEN SPECIFIED.
C
10270 IF (LSTRIX.LE.-1) GOTO 10290
      DO 10280 J=0,LSTRIX
         IF (LSTRDR(J).NE.PID) GOTO 10280
            WRITE(ERUNIT,10279) TITEM(0),(TITEM(I),I=1,TITEM(0))
10279       FORMAT( ' *** ', NR1, ' HAS ALREADY BEEN SPECIFIED ONCE' )
            GOTO 10040
10280 CONTINUE
C
C ***   ADD ITEM TO THE ORDER LIST.
C
10290 LSTRIX = LSTRIX + 1
      LSTRDR(LSTRIX) = PID
C ***   INIT RANGE ITEM INDEX
      RNG = 0
C
C ***   GET THE FIRST RANGE ARGUMENT.
C
      SPLONE = 1R?
      CALL NXTTKN
      SPLONE = -9999
C
C ***   IF A -, BEGINNING OF RANGE IS DEFAULT.
C
      IF ( (TITEM(0).EQ.1).AND.(TITEM(1).EQ.1R-) ) GOTO 10530
C
C ***   IF A COMMA, RANGE IS DEFAULT RANGE.
C
10294 IF (TOKEN.EQ.TEOR) GOTO 10640
      IF (TOKEN.NE.TCOMMA) GOTO 10400
C     ***   IF COMMA IS LAST ON LINE, ASSUME MORE ON NEXT LINE.
10295    CALL NXTTKN
         IF (TOKEN.EQ.TEOR) GOTO 10220
C     ***   ALREADY HAVE NEXT PARAMETER NAME.
         GOTO 10225
C
C ***   PATHS FOR DIFFERENT PARAMETER NAMES DIVERGE FOR A WHILE
C ***   NOW TO CHECK FOR SPECIFIC RESTRICTIONS ON PARAMETER ARGS.
C
10400 IF (PID.NE.1) GOTO 10540
C
C ***   PROCESS LINES OPTION.
C
C ***   ARGUMENT MUST BE A DIGIT STRING.
10410    IF (TOKEN.EQ.TDIGIT) GOTO 10420
C     ***   ILLEGAL PARAMETER ARGUMENT.
            WRITE(ERUNIT,10419) TITEM(0),(TITEM(I),I=1,TITEM(0))
10419       FORMAT( ' *** ', NR1, ' IS NOT AN INTEGER VALUE' )
            GOTO 10040
C
C ***   SAVE LINE NUMBER.
C
10420 CMTRCL(RNG) = TPL6ID
C ***   MAKE SURE RANGE OK.
      IF (CMTRCL(0).LE.CMTRCL(1)) GOTO 10430
         WRITE(ERUNIT,10429)
10429    FORMAT( ' *** END OF LINES RANGE IS LESS THAN BEGINNING' )
         GOTO 10040
C
C ***   PARAMETER ARGUMENT PROCESSING PATHS CONVERGE HERE TO
C ***   CHECK FOR RANGE END OR CONTINUATION.
C
10430 CALL NXTTKN
C ***   PARAMETER ARGUMENTS END WITH , OR END OF RECORD.
      IF ( (TOKEN.NE.TEOR).AND.(TOKEN.NE.TCOMMA) ) GOTO 10490
C
C     ***   RANGE END.  IF THERE WAS NO SECOND PARAMETER, RANGE
C     ***   IS N-N.
C
         IF (RNG.LT.1) GOTO 10435
C        ***   GOT A SECOND PARAMETER.
C        ***   IF COMMA, CHECK IF CONTINUATION ON NEXT LINE.
            IF (TOKEN.EQ.TCOMMA) GOTO 10295
C        ***   IF END OF RECORD, BEGIN COMMAND PROCESSING.
            GOTO 10640
C
C ***   NO SECOND PARAMETER ARGUMENT WAS SPECIFIED.  USE FIRST
C ***   AS LAST.
C
10435 GOTO (10440,10450,10460,10470),PID+1
C ***   COMMENT ID.
10440 CMTIDL(1) = CMTIDL(0)
      GOTO 10480
C ***   LINE NUMBER.
10450 CMTRCL(1) = CMTRCL(0)
      GOTO 10480
C ***   NAME.
10460 DO 10465 I=0,NAMES(4,0)
10465    NAMES(5,I) = NAMES(4,I)
C ***   MODULE NAME.
10470 DO 10475 I=0,NAMES(6,0)
10475    NAMES(7,I) = NAMES(6,I)
C
C ***   IF PARAMETER ARGUMENTS ENDED ON ,, CHECK IF MORE ON NEXT LINE.
C
10480 IF (TOKEN.EQ.TCOMMA) GOTO 10295
C ***   END OF RECORD, BEGIN COMMAND PROCESSING.
      GOTO 10640
C
C *****
C ***   IF DASH FOLLOWS, WE CAN'T HAVE ALREADY PROCESSED A SECOND ITEM.
C
10490 IF ( (TITEM(0).EQ.1).AND.(TITEM(1).EQ.1R-) ) GOTO 10510
         WRITE(ERUNIT,10509) TITEM(0),(TITEM(I),I=1,TITEM(0))
10509    FORMAT( ' *** ', NR1, ' NOT EXPECTED--ILLEGAL SYNTAX' )
         GOTO 10040
C
C ***
C
10510 IF (RNG.LT.1) GOTO 10530
C     ***   ALREADY PROCESSED SECOND ITEM OF RANGE.
      WRITE(ERUNIT,10529)
10529 FORMAT( ' *** ILLEGAL ITEM RANGE SPECIFICATION' )
         GOTO 10040
C
C ***   BEGIN PROCESSING SECOND ITEM OF RANGE.
C
10530 RNG = 1
C ***   EXPECT TO GET ITEM, COMMA OR RECORD END.
      SPLONE = 1R?
      CALL NXTTKN
      SPLONE = -9999
      IF (TOKEN.EQ.TCOMMA) GOTO 10295
      IF (TOKEN.EQ.TEOR) GOTO 10640
C
C ***   ITEM PROCESSING DIVERGES HERE.
C
      IF (PID.EQ.1) GOTO 10410
C
C ***   CONVERT STRING ARGUMENT TO NAME.
C
10540 SPLONE = 1R?
      CALL CVRTKN
      SPLONE = -9999
C ***   MAKE SURE WE GOT A NAME.
      IF (TOKEN.EQ.TNAME) GOTO 10560
         WRITE(ERUNIT,10539) TITEM(0),(TITEM(I),I=1,TITEM(0))
10539    FORMAT( ' *** ', NR1, ' IS NOT WHAT''S EXPECTED HERE' )
         GOTO 10040
C
10560 GOTO (10590,10590,10620,10610),PID+1
C
C ***   PROCESS COMMENT TYPE.
C
C ***   MAKE SURE COMMENT TYPE IS REAL.
      N = 9999
      DO 10597 K=1,TITEM(0)
         DO 10595 I=1,13
10595       IF (CMTIDS(I).EQ.TITEM(K)) GOTO 10596
10580    WRITE(ERUNIT,10589) TITEM(0),(TITEM(I),I=1,TITEM(0))
10589    FORMAT( ' *** ', NR1, ' IS NOT A VALID COMMENT TYPE' )
         GOTO 10040
10596 IF (I.GT.J) J = I
      IF (I.LT.N) N = I
10597 TITEM(K) = I
C ***   GOOD COMMENT TYPE.
10600 CMTID = N
      IF ((TITEM(0).GT.1).AND.(RNG.GT.0)) GOTO 10605
      CMTIDL(RNG) = CMTID
      CALL SAVNAM(8+RNG)
      IF (TITEM(0).GT.1) RNG = 1
      IF (TITEM(0).GT.1) CMTIDL(RNG) = J
C ***   MAKE SURE RANGE OK.
      IF (CMTIDL(0).LE.CMTIDL(1)) GOTO 10430
         WRITE(ERUNIT,10609)
10609    FORMAT( ' *** END OF CODES RANGE IS LESS THAN BEGINNING' )
         GOTO 10040
10605 WRITE(ERUNIT,10606)
10606 FORMAT( ' *** ONLY ONE CODE CAN BE SPECIFIED FOR A RANGE END' )
      GOTO 10040
C
C ***   PROCESS MODULE NAME.
C
C ***   MOVE MODULE NAME TO PROPER SAVE NAME.
10610 CALL SAVNAM(6+RNG)
C ***   MAKE SURE RANGE OK.
      IF (SPLHIT.GT.0) LSTWLD(LSTRIX) = .TRUE.
      J = MIN( NAMES(6,0),NAMES(7,0) )
99999 IF (J.LE.0) GOTO 10430
      DO 10615 I=1,J
         IF (NAMES(7,I).GT.NAMES(6,I)) GOTO 10430
10615    IF (NAMES(7,I).LT.NAMES(6,I)) GOTO 10618
      IF (NAMES(7,0).GE.NAMES(6,0)) GOTO 10430
C ***   SECOND IN RANGE IS LESS THAN FIRST.
10618 WRITE(ERUNIT,10619)
10619 FORMAT( ' *** END OF MODULES RANGE IS LESS THAN BEGINNING' )
      GOTO 10040
C
C ***   ITEM NAME.
C
C ***   MOVE ITEM NAME TO PROPER SAVE NAME.
10620 CALL SAVNAM(4+RNG)
C ***   MAKE SURE RANGE OK.
      IF (SPLHIT.GT.0) LSTWLD(LSTRIX) = .TRUE.
99998 IF (J.LE.0) GOTO 10430
      DO 10625 I=1,J
         IF (NAMES(5,I).GT.NAMES(4,I)) GOTO 10430
10625    IF (NAMES(5,I).LT.NAMES(4,I)) GOTO 10628
      IF (NAMES(5,0).GE.NAMES(4,0)) GOTO 10430
C ***   SECOND IN RANGE IS LESS THAN FIRST.
10628 WRITE(ERUNIT,10629)
10629 FORMAT( ' *** END OF NAMES RANGE IS LESS THAN BEGINNING' )
      GOTO 10040
C
C ****************
C ***   READY TO EXECUTE REPORT COMMAND.
C
C ***   GET DATA BASE READY.
10640 IF (.NOT.RPTSET.AND..NOT.HAVDAT) CALL RDYDB
C ***   ZERO SORT FILE SIZE.
      SFILSZ = 0
C ***   DATA BASE SET UP FOR REPORT.
      RPTSET = .TRUE.
C ***   DATA WILL NOT BE SET UP FOR EXTRACT AFTER REPORT.
      HAVDAT = .FALSE.
      BK(0) = NULMRK
C ***   SET UP COMPARE RECORDS.
      CMTID = CMTIDL(0)
      CMTREC = CMTRCL(0)
      FILNLN = NAMES(6,0)
      DO 10649 I=1,FILNLN
10649    FILNMR(I)=NAMES(6,I)
      BT(0) = 0
      CALL ADDCMT
C
      CMTID = CMTIDL(1)
      CMTREC = CMTRCL(1)
      DO 10650 I=0,NAMES(5,0)
10650    NAMES(4,I) = NAMES(5,I)
      FILNLN = NAMES(7,0)
      DO 10651 I=1,FILNLN
10651    FILNMR(I)=NAMES(7,I)
      BT(0) = 200
      CALL ADDCMT
C ***   NOTHING FOUND YET.
      FOUND = 0
C
C ***   IF NO PARAMETERS SPECIFIED, LIST BY NAME AND MODULE.
C
10820 IF (LSTRIX.GT.-1) GOTO 10830
         LSTRIX = 1
         LSTRDR(0) = 2
         LSTRDR(1) = 3
C
C ***   FIND FIRST RECORD > FIRST OF MAIN RANGE.
C
10830 BT(0) = 0
      CALL FNDREC( LSTRDR(0), LSTWLD(0) )
C ***   NONE IN LIST CHECK.
10835    WRITE(ERUNIT,10839)
10839    FORMAT( ' *** CAN''T FIND ANYTHING LIKE THAT' )
         GOTO 10040
C
C ***   FOUND NAME.
C
10840 IF (BRKFLG.GT.0) GOTO 10040
      DO 10845 I=0,LSTRIX
C     ***   LAST IN RANGE MUST BE GREATER OR EQUAL TO ITEM.
         BT(0) = 200
         CALL CMPBLK( 0, LSTRDR(I), LSTWLD(I) )
         IF ( (I.EQ.0).AND.BLESS ) GOTO 10890
         IF (BLESS) GOTO 10885
C     ***   FIRST IN RANGE MUST BE LESS THAN OR EQUAL TO ITEM.
         BT(0) = 0
         CALL CMPBLK( 0, LSTRDR(I), LSTWLD(I) )
         IF (LSTRDR(I).NE.0) GOTO 10845
         IF (NAMES(8,0).LE.1) GOTO 10845
         IF (BGRATR) GOTO 10845
         CMTID = BLK(NBT+1,NBK)
         DO 10841 K=1,NAMES(8,0)
10841       IF (CMTID.EQ.NAMES(8,K)) GOTO 10845
         GOTO 10885
10845    IF (BGRATR) GOTO 10885
C
C ***   WE FOUND A COMMENT.
C
10850 CALL GTXCMT
C
C ***   IF THIS COMMENT HAS BEEN "DELETED", SKIP IT.
C
      IF (TXKNBR.EQ.NULMRK) GOTO 10885
C ***   FOUND A RECORD.
      IF ( (FOUND.LE.0) .AND..NOT.SRTFLG) WRITE(RPTUNT,10859)
10859 FORMAT( '      ', T7, ' MODULES', T19, ' LINES', T25, ' T',
     &      T27, ' NAMES' )
      FOUND = FOUND + 1
C
C ***   DELETE COMMENT IF DELETE FLAG SET.
C
      IF (.NOT.DELFLG) GOTO 10860
         CALL LSTCMT
         CALL T12T38( NULMRK, NULMRK, NBK, NBT+(ITMMAX+1)*(2+3) )
         BM(NBK) = .TRUE.
         GOTO 10885
10860 IF (.NOT.SRTFLG) CALL LSTCMT
C
C ***   BUILD SORT RECORD.
C
      TITEM(0) = 0
      IF (.NOT.SRTFLG) GOTO 10880
      DO 10878 I=0,LSTRIX
C     ***   GET MAX ITEM LENGTHS.
         M = LSTMLN(LSTRDR(I))
         GOTO (10871,10872,10873,10874),LSTRDR(I)+1
C     ***   COMMENT TYPE MAX 1 CHAR.
10871    K = CIDX
         GOTO 10875
C     ***   LINE NUMBER MAX 3 CHARS.
10872    K = CRCX
         GOTO 10875
C     *** NAME MAX LENGTH IS 20.
10873    K = CNMX
         GOTO 10875
C     ***   MODULE NAME MAX IS 12.
10874    K = CMDX
C     ***   APPEND ITEM TO SORT RECORD.
10875    N = MIN( M,BLK(K,NBK) )
         DO 10876 J=1,N
10876       TITEM(TITEM(0)+J) = BLK(K+J,NBK)
C
C     ***   BLANK FILL IF NECESSARY.
C
10877    IF (N.GE.M) GOTO 10878
            N = N + 1
            TITEM(TITEM(0)+N) = 1R
            GOTO 10877
C     ***   COMPUTE CURRENT LENGTH OF SORT RECORD.
10878    TITEM(0) = TITEM(0) + M
C
C **********
C ***   INCLUDE DATA RECORD LOCATION IN SORT RECORD.
C
      N1 = BK(NBK)
      N2 = N1 / 16
      N3 = NBT / 256
      TITEM(TITEM(0)+1) = N2
      TITEM(TITEM(0)+2) = (N1 - N2*16)*16 + N3
      TITEM(TITEM(0)+3) = NBT - N3*256
      TITEM(0) = TITEM(0) + 3
C ***   REPORT LINES IF NOT IN HELP MODE.
C
10880 IF (.NOT.HLPFLG.AND..NOT.SRTFLG) CALL GETLNS( TXKNBR, TXTNBR )
C
C ***   IF SORT NECESSARY, OPEN SORT FILE AND WRITE RECORDS.
C
      IF (.NOT.SRTFLG) GOTO 10885
         IF ( (SFILSZ.GT.0).OR.(SRTYET) ) GOTO 10881
            OPEN(SRIUNT,
     &         RECL=TITEM(0),USAGE='OUTPUT',ACCESS='SEQUENTIAL',
     &         STATUS='UNKNOWN',NAME='$$EXT$$SRI$')
            OPEN(SROUNT,
     &         RECL=TITEM(0),USAGE='OUTPUT',ACCESS='SEQUENTIAL',
     &         STATUS='UNKNOWN',NAME='$$EXT$$SRO$')
C        ***   SET SORT FILES OPEN FLAG.
            SRTYET = .TRUE.
10881    SFILSZ = SFILSZ + 1
         WRITE(SRIUNT,10882) TITEM(0),(TITEM(I),I=1,TITEM(0))
10882    FORMAT( NR1 )
10885 CALL NXTREC( LSTRDR(0) )
      IF (NBK.NE.NULMRK) GOTO 10840
C
C ***   END OF LIST, SORT WILL CLOSE FILE IF OPEN.
C
10890 IF (SFILSZ.LE.0) GOTO 10899
C
C ***   HAVE SOMETHING TO SORT AND REPORT.
         IF (BRKFLG.GT.0) GOTO 10040
         SRECSZ = TITEM(0)
         CALL SORT(SRIUNT,SROUNT,SFILSZ,SRECSZ,KEYIX,
     &         SRECSZ-KEYIX-2)
C     ***   REPORT SORTED.
C10891   READ(SROUNT,10882,END=10899) SRECSZ,(BLK(I,0),I=1,SRECSZ)
10891    IF (BRKFLG.GT.0) GOTO 10040
         CALL READR1(SROUNT,BLK(1,0),SRECSZ,10899S)
         CALL T38T12( 0, SRECSZ-2,   NBK, NBT )
         NBK = GETBLK( NBK )
         CALL GTXCMT
         CALL LSTCMT
         CALL GETLNS( TXKNBR, TXTNBR )
         WRITE(RPTUNT,10892)
10892    FORMAT( '  ' )
         GOTO 10891
C
C ***   END OF LIST, ERROR MESSAGE IF NOTHING FOUND.
C
10899 IF (FOUND.LE.0) GOTO 10835
      IF (.NOT.DELFLG) GOTO 10040
C
C ***   WRITE OUT ALL MODIFIED BLOCKS.
C
      DO 10895 I=0,BLKMAX
         IF (.NOT.BM(I)) GOTO 10895
            CALL DIWRIT(DATUNT,BLK(0,I),BLKSIZ,BK(I))
            CALL UNPACK(BLK(0,I),BLKSIZ)
            BM(I) = .FALSE.
10895 CONTINUE
      WRITE(ERUNIT,10896) FOUND
10896 FORMAT( X, '...', I5, ' RECORDS LOST'    )
      GOTO 10040
C
C ********************
C ***   HELP COMMAND.
C
10800 HLPFLG = .TRUE.
      GOTO 10210
C ********************
C ***   DELETE COMMAND.
C
11200 DELFLG = .TRUE.
      GOTO 10210
C
C ********************
C ***   SORT COMMAND.
C
10900 SRTFLG = .TRUE.
      HLPFLG = .TRUE.
      GOTO 10210
      GOTO 99999
      GOTO 99998
C
C ********************
C ***   BALANCE COMMAND.
C
11000 IF (.NOT.BASOPN) GOTO 10120
      IF (.NOT.OLDFIL) GOTO 10211
      CALL NXTTKN
      IF (TOKEN.EQ.TEOR) GOTO 11030
         WRITE(ERUNIT,11029)
11029    FORMAT( ' *** THIS COMMAND TAKES NO ARGUMENTS' )
         GOTO 10040
11030 CALL BALANC
      GOTO 10040
C
C ********************
C ***   OUTPUT COMMAND.
C
11100 IF (.NOT.GETFID()) GOTO 10040
      CLOSE(UNIT=RPTUNT,STATUS='KEEP',ERR=11120)
11120 OPEN(RPTUNT,NAME=FNAME,ERR=11160,ACCOUNT=FACCT,
     &      USAGE='CREATE',ACCESS='SEQUENTIAL',STATUS='UNKNOWN',
     &      FORM='FORMATTED')
      GOTO 10040
C
C ***   ERROR OPENING OUTPUT FILE
C
11160 WRITE(ERUNIT,11169) FNAME(1:FNLN), FACCT
11169 FORMAT( ' *** ERROR OPENING REPORT FILE ', A, '.', A )
      OPEN(RPTUNT,NAME='(SI)',USAGE='OUTPUT',ACCESS='SEQUENTIAL',
     &      STATUS='UNKNOWN',FORM='FORMATTED')
      GOTO 10040
      END
C *********************************************************************
C **********            GTXCMT                               **********
C *********************************************************************
C ***   GTXCMT   JUN 78   (PRY)
C ***   GTXCMT SETS UP INDICES INTO COMMENT INFO.
C
      SUBROUTINE GTXCMT
C
      INCLUDE AEXTGLBLS
C
C ********************
C ***   GET INDICES FROM DATA RECORD.
C
      CIDX = NBT
      CMTID = CMTIDS(BLK(CIDX+1,NBK))
C ***   GET LINE NUMBER.
      CRCX = BLK(NBT+3,NBK)+NBT
      CMTREC=(BLK(CRCX+1,NBK)*256+BLK(CRCX+2,NBK))*256+BLK(CRCX+3,NBK)
C ***   GET NAME.
      CNMX = BLK(NBT+5,NBK)+NBT
C ***   GET MODULE NAME.
      CMDX = BLK(NBT+7,NBK)+NBT
C ***   GET POINTER TO TEXT RECORD.
      CALL T38T12( NBK, NBT+(ITMMAX+1)*(2+3), TXKNBR, TXTNBR )
      RETURN
      END
C *********************************************************************
C **********                  LSTCMT                         **********
C *********************************************************************
C ***   LSTCMT   JUN 78   (PRY)
C ***   LSTCMT LISTS THE CURRENT COMMENT DATA.
C
      SUBROUTINE LSTCMT
C
      INCLUDE AEXTGLBLS
C
C ********************
C ***   LIST DATA FROM THE CURRENT RECORD.
C
      WRITE(RPTUNT,10861)
     &      BLK(CMDX,NBK),(BLK(CMDX+J,NBK),J=1,BLK(CMDX,NBK)),
     &      CMTREC, CMTID,
     &      BLK(CNMX,NBK),(BLK(CNMX+J,NBK),J=1,BLK(CNMX,NBK))
10861 FORMAT( ' ***** ', NR1, T19, ' ', I5, T25, ' ', R1, T27, ' ',
     &      NR1 )
      RETURN
      END
C *********************************************************************
C **********                  CVRTKN                         **********
C *********************************************************************
C ***   CVRTKN   19 JUN 78   (PRY)
C ***   CVRTKN CONVERTS A QUOTED STRING TO A NAME.
C
      SUBROUTINE CVRTKN
C
      INCLUDE AEXTGLBLS
C
      INTEGER ITMKEY
C
C ***   ITMKEY - FUNCTION TO RETURN ID OF KEYWORD OR 0
C
      GLOBAL SPLONE, SPLHIT
      INTEGER SPLONE, SPLHIT
C
C ***   SPLONE - SPECIAL CHAR TO CHECK FOR IN NAMES
C
C
C ********************
C ***   IF NOT QUOTED STRING, RETURN.
C
10010 IF (TOKEN.NE.TSQSTR) RETURN
C
C ***   CONVERT QUOTED STRING TO NAME (GET RID OF QUOTES)
C
10020 I = 1
      J = 2
10030 IF (J.GE.TITEM(0)) GOTO 10080
         IF (TITEM(J).EQ.1R') J = J + 1
         TITEM(I) = TITEM(J)
         IF (TITEM(I).EQ.SPLONE) SPLHIT = SPLHIT + 1
         I = I + 1
         J = J + 1
         GOTO 10030
C
C ***   SET LENGTH AND RETURN.
C
10080 TITEM(0) = I - 1
      TOKEN = TNAME
      TPL6ID = ITMKEY( )
      RETURN
      END
C *********************************************************************
C **********               RDYDB                             **********
C *********************************************************************
C ***   RDYDB   18 JUN 78   (PRY)
C ***   RDYDB GETS THE DATA BASE READY FOR EXTRACTING OR REPORTING.
C
      SUBROUTINE RDYDB
C
      INCLUDE AEXTGLBLS
C
      GLOBAL OLDFIL
      LOGICAL OLDFIL
C
C ***   OLDFIL - SET .TRUE. IF DATA BASE ALREADY EXISTS.
C
C
C ********************
C ***   BOTH DATA FILES ARE OPENED...IF DATA BASE DOES NOT EXIST,
C ***   SET UP DATA FOR NEW DATA BASE.
C
10010 IF (.NOT.OLDFIL) GOTO 10070
C
C ***   SET UP FOR OLD DATA BASE.
C
      CALL DIREAD(DATUNT,BLK(0,1),BLKSIZ,0)
C ***   CONVERT NEXT FREE DATA BASE BYTE INFO.
      CALL T38T12( 1, (ITMMAX+1)*(INDMAX+1)*3, BK(0), BT(0) )
C *** CONVERT NEXT FREE TEXT BASE BYTE INFO.
      CALL T38T12( 1, (ITMMAX+1)*(INDMAX+1)*3+3, TBKNBR, TBTNBR )
      CALL DIREAD(TXTUNT,TBKCHR,BLKSIZ,TBKNBR)
C ***   CONVERT NUMBER OF RECORDS IN DATA BASE.
      CALL T38T12( 1, (ITMMAX+1)*(INDMAX+1)*3+3+3, N1, N2 )
      NUMRCS = N1*4096 + N2
C ***   CONVERT END OF INDICES.
      DO 10030 I=0,ITMMAX
10030    CALL T38T12( 1, (ITMMAX+1)*(INDMAX+1)*3+3+3+3+I*3,
     &         FSTEND(I), N2 )
C ***   CONVERT BEGINNING OF LIST POINTERS.
      DO 10040 J=0,ITMMAX
         DO 10040 K=0,INDMAX
10040       CALL T38T12( 1,(J+(ITMMAX+1)*K)*3,FSTBLK(J,K),FSTBYT(J,K) )
C ***   SET UP DATA FOR EXTRACTING.
      CALL DIREAD( DATUNT, BLK(0,0), BLKSIZ, BK(0) )
      DO 10050 J=1,BLKMAX
         BK(J) = NULMRK
         BT(J) = NULMRK
         BA(J) = 0
10050    BM(J) = .FALSE.
      BMAXIX = 0
      BM(0) = .FALSE.
C ***   HAVE DATA BASE DATA.
      HAVDAT = .TRUE.
      BTIC = 0
      RETURN
C
C **********
C ***   EXTRACT DATA BASE DID NOT EXIST.  SET UP FOR NEW ONE.
C ***   INITIALIZE CURRENT RECORD POINTER.
C
10070 BK(0) = 1
C ***   SKIP OVER FIRST IN LIST PTRS, NEXT DATA BYTE, NEXT TEXT BYTE.
      BT(0) = 0
      BM(0) = .TRUE.
C ***   MARK LIST BEGINNINGS AS NULL.
      DO 10076 I=0,ITMMAX
         DO 10075 K=0,INDMAX
            FSTBYT(I,K)=0
10075       FSTBLK(I,K)=NULMRK
10076    FSTEND(I) = 0
C ***   MARK NO BLOCKS IN CORE.
      DO 10077 I=1,BLKMAX
         BK(I) = NULMRK
         BT(I) = 0
         BA(I) = 0
10077    BM(I) = .FALSE.
      BMAXIX = 0
C ***   WRITE OUT BOGUS RECORD 0.
      CALL DIWRIT(DATUNT,BLK(0,0),BLKSIZ,0)
C *** SET UP NEXT FREE TEXT BYTE INFO.
      TBKNBR = 0
      TBTNBR = 0
      NUMRCS = 0
      HAVDAT = .TRUE.
      BTIC = 0
      RETURN
      END
C *********************************************************************
C **********                  GETFID                         **********
C *********************************************************************
C ***   GETFID   16 JUN 78   (PRY)
C ***   GETFID GETS A FILE NAME FROM THE CURRENT RECORD.
C
      LOGICAL FUNCTION GETFID( )
C
      INCLUDE AEXTGLBLS
C
      GLOBAL SPLONE
      INTEGER SPLONE
C
C ***   SPLONE - SPECIAL CHAR ALLOWED IN NAME
C
C ********************
C ***   GET THE FILE NAME.
C
10010 GETFID = .FALSE.
      SPLONE = 1R:
      CALL NXTTKN
      SPLONE = -9999
      CALL CVRTKN
      IF (TOKEN.EQ.TNAME) GOTO 10030
         WRITE(ERUNIT,10029)
10029    FORMAT( ' *** EXPECTED FILE NAME MISSING' )
         RETURN
C
C ***   MAKE SURE FILE NAME IS NOT TOO LONG.
C
10030 IF (TITEM(0).LE.27) GOTO 10050
         WRITE(ERUNIT,10049)
10049    FORMAT( ' *** FILE NAME IS GREATER THAN 27 CHARS' )
         RETURN
C
C ***   MAKE FILE NAME INTO CHARACTER STRING.
C
10050 FNLN = TITEM(0)
      WRITE(FNAME,10069) FNLN,(TITEM(I),I=1,FNLN)
10069 FORMAT( NR1 )
C
C ***   FILE NAME ENDS IF END OF RECORD.
C
      FACCT = '        '
      GETFID = .TRUE.
      CALL NXTTKN
      IF (TOKEN.EQ.TEOR) RETURN
C
C ***   FOLLOWING TOKEN SHOULD BE PERIOD
C
      GETFID = .FALSE.
      IF (TOKEN.EQ.TPEROD) GOTO 10080
         WRITE(ERUNIT,10079)
10079    FORMAT( ' *** ILLEGAL CHARACTERS FOLLOW FILE NAME' )
         RETURN
C
C
10080 SPLONE = 1R:
      CALL NXTTKN
      CALL CVRTKN
      SPLONE = -9999
      GETFID = .TRUE.
      IF (TOKEN.EQ.TEOR) RETURN
      GETFID = .FALSE.
      IF (TOKEN.EQ.TNAME) GOTO 10100
         WRITE(ERUNIT,10099)
10099    FORMAT( ' *** ILLEGAL ACCOUNT' )
         RETURN
C
C ***   CHECK ACCOUNT LENGTH.
C
10100 IF (TITEM(0).LE.8) GOTO 10120
         WRITE(ERUNIT,10119)
10119    FORMAT( ' *** ACCOUNT CAN NOT EXCEED 8 CHARS' )
         RETURN
C
C ***   FILL OUT ACCOUNT WITH BLANKS.
C
10120 IF (TITEM(0).EQ.8) GOTO 10140
      DO 10130 I=TITEM(0)+1,8
10130    TITEM(I) = 1R
10140 TITEM(0) = 8
C
C ***   CONVERT ACCOUNT TO STRING.
C
      WRITE(FACCT,10159) (TITEM(I),I=1,8)
10159 FORMAT( 8R1 )
C
C ***   NOTHING SHOULD FOLLOW ACCOUNT.
C
      CALL NXTTKN
      GETFID = .TRUE.
      IF (TOKEN.EQ.TEOR) RETURN
      GETFID = .FALSE.
      WRITE(ERUNIT,10169)
10169 FORMAT( ' *** ILLEGAL CHARACTERS FOLLOW ACCOUNT' )
      RETURN
      END
