*     COPYRIGHT, (C) HONEYWELL INFORMATION SYSTEMS INC., 1979, 1980
*
      BLOCK DATA COPYRIT6
      INTEGER COPYRITE(16)
     1   /'COPYRIGHT, (C) HONEYWELL INFORMATION SYSTEMS INC., 1979,'
     2  , ' 1980.  '/
      GLOBAL COPYRITE
      END
************************************************************************
*                                                                      *
*            DATABASE REPAIR UTILITY                 1979 03 15        *
*            =======================                                   *
*                                                                      *
*            THIS PROGRAM ALLOWS A USER TO AFFECT REPAIRS ON AN EDMS   *
*     DATABASE.  THERE ARE TWO APPROACHES TO THE REPAIR PROCESS,       *
*     THE FIRST IS TO RECALCULATE THE CHECKSUMS ON EACH DATABASE       *
*     PAGE, AND THE SECOND IS TO PATCH SPECIFIC SET CHAIN POINTERS     *
*     TO CORRECT BROKEN CHAIN TROUBLES.                                *
*            THE CHECKSUM PROCESS INVOLVES STEPPING THROUGH EACH       *
*     PAGE IN THE DATABASE, CALCULATING THE CHECKSUM IF IT             *
*     EXISTS, AND RESETTING THE MUST WRITE FLAG.                       *
*            THE POINTER PATCHING PROCESS  REQUIRES INTERACTION        *
*     WITH THE USER, PROMPTING HIM FOR THE INFORMATION NECESSARY       *
*     TO MAKE THE PATCH, AND CHECKING THAT THE PATCH IS VALID          *
*     ACCORDING TO THE SCHEMA OF THE DATABASE.  THIS UTILITY IS        *
*     INTENDED TO BE USED TO CORRECT ERRORS IN THE POINTER             *
*     RELATIONSHIPS, AS DETECTED BY THE VALIDATION SOFTWARE.           *
*                                                                      *
************************************************************************
      COMMON /USERIO/UERROR,TRMIN,TRMOUT
      INTEGER ERROR,REPCOD
      WRITE (TRMOUT,40)
40    FORMAT (' REPAIR A00 HERE')
*
*  BUILD THE SCHEMA TABLES
*
      CALL SCHINI
      CALL BLSCHM(ERROR)
      IF(ERROR.NE.0)STOP'TABLE CONSTRUCTION BLEW IT.'
*
*  FIND OUT WHAT TYPE OF REPAIRS THE USER WANTS
*
      CALL REPTYP(REPCOD)
      GOTO(10,20)REPCOD
      GOTO 30
*
*  WE'RE GOING TO PATCH POINTERS
*
10    CONTINUE
      CALL REPAIR
      GOTO 30
*
*  WE'RE GOING TO RE-CALCULATE CHECKSUMS
*
20    CONTINUE
      CALL CHECKS
30    CONTINUE
      STOP 'FINISHED REPAIRS'
      END
      SUBROUTINE REPTYP($TYPE)
************************************************************************
*                                                                      *
*        SUBROUTINE TO PROMPT THE USER AND DETERMINE WHAT              *
*        TYPE OF REPAIR OPERATION HE WISHES TO PERFORM                 *
*        (POINTER PATCHING OR RE-CHECKSUMMING AND UNLOCKING)           *
*                                                                      *
************************************************************************
      IMPLICIT LOGICAL(A-Z,$)
      LOGICAL TSTEND
      INTEGER $TYPE,$REPLY(80),$TYPTB(8,3)/
     @'P','O','I','N','T','E','R','S',
     @'P','A','T','C','H',' ',' ',' ',
     @'C','H','E','C','K','S','U','M'/
      INTEGER START,END
      INTEGER UERROR,TRMIN,TRMOUT
      COMMON /USERIO/UERROR,TRMIN,TRMOUT
*
*  ASK USER WHAT HE WANTS
*
10    CONTINUE
      WRITE(TRMOUT,1000)
     .,'BASE   ')
      READ(TRMIN,2000,END=20,ERR=20)$REPLY
2000  FORMAT(80A1)
*
*  CHECK TO SEE IF HE'S TRYING TO RUN AWAY
*
      START=1
      IF(TSTEND($REPLY,START))GOTO 20
*
*  SEE IF HE ANSWERS US WITH SOMETHING WE KNOW
*  POINTER OR PATCH MEANS POINTER REPAIR,
*  CHECKSUM MEANS RECALCULATE AND UNLOCK
*
      END=80
      CALL MATCH($REPLY,START,END,$TYPTB,3,8,$TYPE)
      IF($TYPE.EQ.0)GOTO 10
      IF($TYPE.GT.1)$TYPE=$TYPE-1
      RETURN
*
*  USER WANTS OUT
*
20    CONTINUE
      $TYPE=0
      RETURN
      END
      SUBROUTINE CHECKS
************************************************************************
*                                                                      *
*        THIS SUBROUTINE PROCESSES THE USERS DATABASE, RE-CHECKSUMMING *
*        THE AREAS WHICH HAVE CHECKSUMS, AND RESETTING THE DATABASE    *
*        LOCKS ON THE WAY BY.                                          *
*                                                                      *
************************************************************************
      INCLUDE EVAL_IN01
      INTEGER $BUFFR(512),INDEX0,INDEX1,BITS
      DO 10 INDEX0=1,ARACNT
         DO 20 INDEX1=1,ARASIZ(INDEX0)
            READ DISK 10+INDEX0,(INDEX1-1)*512,$BUFFR
            CALL WRITLN($BUFFR,INDEX0,INDEX1)
20       CONTINUE
10    CONTINUE
      RETURN
      END
      SUBROUTINE REPAIR
************************************************************************
*                                                                      *
*            SUBROUTINE REPAIR                                         *
*     THIS IS THE MAIN DRIVING ROUTINE FOR THE POINTER PATCHING        *
*     OPERATION.  IT DOESN'T DO MUCH EXCEPT CHECK THAT THE USER        *
*     DOESN'T DO SILLY THINGS TO HIS DATABASE.  IT ALSO HAS THE        *
*     CAPABILITY OF COPING WITH SMART, DUMB, OR UNDECIDED USERS.       *
*     THE USER IS PROMPTED FOR THE INITIAL REFCODE, AND FOR ANY        *
*     ADDITIONAL INFORMATION NOT ALLREADY PROVIDED IN THE INPUT        *
*     STREAM.  AT ANY POINT, AN END COMMAND MAY BE ENTERED TO          *
*     EXIT THE ROUTINE.  AT THE COMPLETION OF EACH PATCH, THE          *
*     USER MAY EXERCISE THE OPTION TO HAVE THE PATCH UNDONE.           *
*     AN INVALID ELEMENT IN THE INPUT STREAM CAUSES REPROMPTING        *
*     FOR THAT PARTICULAR ELEMENT.  THE USER IS REPROMPTED UNTIL       *
*     A VALID RESPONSE OR A BLANK LINE IS RECIEVED. A VALID            *
*     RESPONSE CAUSES THE PATCH PROCEDURE TO PROCEED, WHILE THE        *
*     NULL OR BLANK RESPONSE WILL CAUSE A PATCH ABORT, AND THEN        *
*     A RETURN TO THE ORIGINAL PROMPT FOR INITIAL REFCODE.             *
*                                                                      *
************************************************************************
      IMPLICIT LOGICAL(A-Z)
      INTEGER TRMBUF(80),BOLN,EOLN,I,PTRSIZ,PTRDSP,SETIND,DEFPTR
      INTEGER RECGRP,RECGPI,PTRGRP,PTRGPI,NEWPTR,TEMPTR,OLDPTR
      INTEGER PATCH(512),LINPTR,TPAGE(512),TLINE
      INTEGER REFARY(3),RECARA,RECPGE,RECLIN
      INTEGER PTRARY(3),PTRARA,PTRPGE,PTRLIN
      INTEGER UNCODE,UNDO(4),PTRTBL(5,3),PTRTYP,PSET(32),OLDBUF(16)
      INTEGER BITS,COMREF,FNDGRP,DELIND,PULFLD
      LOGICAL ENDRUN,ERROR,TOOFAR
      EQUIVALENCE (REFARY(1),RECARA),(PTRARY(1),PTRARA),
     @            (REFARY(3),RECLIN),(PTRARY(3),PTRLIN)
      DATA UNDO/'U','N','D','O'/,PTRTBL/
     @'N','E','X','T',' ',
     @'P','R','I','O','R',
     @'O','W','N','E','R'/
*
*     LOCAL VARIABLES:
*            NAME     TYPE        DESCRIPTION
*            ----     ----        ----------
*            TRMBUF   INTEGER     USER'S LAST TERMINAL BUFFER
*            BOLN     INTEGER     SCAN POINTER TO BEGINNING OF
*                                 INPUT STREAM
*            EOLN     INTEGER     POINTER AT LAST NON-BLANK
*                                 CHARACTER IN TRMBUF
*            I        INTEGER     AN OUTPUT LOOP SCRATCH VARIABLE
*            PTRSIZ   INTEGER     THE SIZE OF POINTERS IN THIS
*                                 DATABASE
*            PTRDSP   INTEGER     THE DISPLACMENT OF A POINTER
*                                 FROM THE BEGINNING OF A
*                                 RECORD.
*            SETIND   INTEGER     THE INDEX OF THE NAMED SET
*            DEFPTR   INTEGER     A POINTER INTO THE SET POINTER
*                                 TABLES.
*            DELIND   INTEGER     DELETE INDICATOR FOR A RECORD
*
      INTEGER UERROR,TRMIN,TRMOUT
      COMMON /USERIO/UERROR,TRMIN,TRMOUT
      INCLUDE EVAL_IN01
*
*  DETERMINE THE POINTER SIZE, SET THE TOOFAR
*  FLAG TO DISALLOW AN UNDO
*
      PTRSIZ=4
      IF(ARACNT.EQ.1)PTRSIZ=3
      TOOFAR=.TRUE.
*
*  START BY GETTING THE REFCODE
*
10    CONTINUE
      WRITE(TRMOUT,'($ REFCODE OF RECORD TO BE PATCHED   $)')
      CALL RDTERM(TRMBUF,EOLN,ENDRUN)
      IF(ENDRUN)GOTO 20
      BOLN=1
*
*  DOES THE USER WANT TO UNDO THE LAST OPERATION?
*  (YES, YOU CAN UNDO AN UNDO)
*
      CALL MATCH(TRMBUF,BOLN,EOLN,UNDO,1,4,UNCODE)
      IF(UNCODE.EQ.1)GOTO 30
      TOOFAR=.TRUE.
*
*  MAKE SURE WE GOT A REFCODE
*
      CALL MAKREF(TRMBUF,BOLN,EOLN,REFARY,ERROR)
      IF(ERROR)GOTO 10
*
*  MAKE SURE THE REFCODE ISN'T SILLY
*
      CALL TSTREF(REFARY,ERROR)
      IF(ERROR)GOTO 10
*
*  TRY TO GET THE RECORD THE USER WANTS
*
      CALL READLN(PATCH,LINPTR,RECGRP,RECARA,RECPGE,RECLIN,ERROR)
      IF(ERROR)WRITE(TRMOUT,'($ THAT RECORD DOES NOT EXIST$)');GOTO 10
      RECGPI=FNDGRP(RECGRP,RECARA)
*
*  PULL THE DELETE FLAG, IF IT'S SET, RING BELLS.
*
      DELIND=PULFLD(18,1,PATCH(LINPTR))
      IF(DELIND.EQ.1)WRITE(TRMOUT,'($ *** PATCH RECORD IS $,
     @$LOGICALLY DELETED.$)')
C     USED TO BE IF LOGICALLY DELETED GO TO 10
      IF(BOLN.LE.EOLN)GOTO 40
*
*  FIND OUT WHICH SET THE USER WANTS
*
50    CONTINUE
      WRITE(TRMOUT,'($    WHICH SET  $)')
      CALL RDTERM(TRMBUF,EOLN,ENDRUN)
*
*  THE TEST FOR ENDRUN IS DEFERRED UNTIL WE ARE SURE THERE IS
*  NO SET CALLED "END" OR "EXIT" OR WHATEVER.
*
      IF(EOLN.EQ.0)WRITE(TRMOUT,'($ **** PATCH ABORTED ****$)');GOTO 10
      BOLN=1
*
*  TRY TO FIND THE SET NAME THE USER GAVE
*
40    CONTINUE
      CALL FINSET(TRMBUF,BOLN,EOLN,PSET,SETIND)
      IF(SETIND.NE.0)GOTO 110
      IF(ENDRUN)GOTO 20
      WRITE(TRMOUT,'($ THIS SCHEMA HAS NO SET NAMED $,32A1)')PSET
      GOTO 50
*
*  THE SET EXISTS, CHECK IF IT HAS THIS GROUP AS A MEMBER
*
110   CONTINUE
      DEFPTR=TPYLNK(SETIND,RECGPI)
      IF(DEFPTR.EQ.0)WRITE(TRMOUT,2000)RECGRP,PSET;GOTO 50
2000  FORMAT(' THIS RECORD, IN GROUP #',I,'IS NOT A MEMBER OF ',32A1)
      IF(BOLN.LE.EOLN)GOTO 60
*
*  GET THE POINTER TYPE
*
70    CONTINUE
      WRITE(TRMOUT,'($    WHICH POINTER  $)')
      CALL RDTERM(TRMBUF,EOLN,ENDRUN)
      IF(EOLN.EQ.0)WRITE(TRMOUT,'($ **** PATCH ABORTED ****$)');GOTO 10
      BOLN=1
*
*  MAKE SURE THE POINTER TYPE IS VALID
*
60    CONTINUE
      CALL MATCH(TRMBUF,BOLN,EOLN,PTRTBL,3,5,PTRTYP)
      IF(PTRTYP.NE.0)GOTO 130
      IF(ENDRUN)GOTO 20
      WRITE(TRMOUT,1000)
1000  FORMAT(' POINTER TYPES ARE: NEXT, PRIOR, OR OWNER')
      GOTO 70
*
*  SEE IF THIS RECORD HAS THAT KIND OF POINTER
*
130   CONTINUE
      PTRDSP=SETPTR(DEFPTR,PTRTYP)
      IF(PTRDSP.NE.0)GOTO 120
      WRITE(TRMOUT,4000)RECGRP,(PTRTBL(I,PTRTYP),I=1,5),PSET
4000  FORMAT(' GROUP #',I,' HAS NO ',5A1,' POINTER IN ',32A1)
      GOTO 70
*
*  PULL OUT THE CURRENT POINTER AND TELL USER WHAT IT IS
*
120   CONTINUE
      CALL LOAD(PATCH(LINPTR),PTRDSP,PTRSIZ,OLDPTR)
      IF(ARACNT.EQ.1)CALL PUTFLD(OLDPTR,0,8,AREA(1))
      CALL REFFMT(OLDPTR,OLDBUF)
      WRITE(TRMOUT,3000)(OLDBUF(I),I=1,OLDBUF(1)+1)
3000  FORMAT('             OLD POINTER IS ',NA1)
      IF(BOLN.LE.EOLN)GOTO 80
*
*  GET THE NEW POINTER VALUE
*
90    CONTINUE
      WRITE(TRMOUT,'($    NEW VALUE OF POINTER  $)')
      CALL RDTERM(TRMBUF,EOLN,ENDRUN)
      IF(ENDRUN)GOTO 20
      IF(EOLN.EQ.0)WRITE(TRMOUT,'($ **** PATCH ABORTED ****$)');GOTO 10
      BOLN=1
*
*
80    CONTINUE
      CALL MAKREF(TRMBUF,BOLN,EOLN,PTRARY,ERROR)
      IF(ERROR)GOTO 90
*
*  MAKE SURE THE POINTER ISN'T SILLY
*
      CALL TSTREF(PTRARY,ERROR)
      IF(ERROR)GOTO 90
*
*  MAKE SURE HE IS POINTING AT A RECORD THAT'S THERE
*
      CALL READLN(TPAGE,TLINE,PTRGRP,PTRARA,PTRPGE,PTRLIN,ERROR)
      IF(ERROR)WRITE(TRMOUT,'($ THAT RECORD DOES NOT EXIST$)');GOTO 90
*
*  THE RECORD EXISTS, LETS MAKE SURE IT'S IN THE SPECIFIED SET
*
      PTRGPI=FNDGRP(PTRGRP,PTRARA)
      IF(TPYLNK(SETIND,PTRGPI).EQ.0)WRITE(TRMOUT,2000)PTRGRP,PSET;GOTO90
      NEWPTR=COMREF(PTRARA,PTRPGE,PTRLIN)
*
*  PULL THE DELETE FLAG, IF IT'S SET, TELL USER AND TRY AGAIN
*
      DELIND=PULFLD(18,1,TPAGE(TLINE))
      IF(DELIND.EQ.1)WRITE(TRMOUT,'($ *** NEW POINTER POINTS AT A$,
     @$ LOGICALLY DELETED RECORD.$)')
C     USED TO BE IF LOGICALLY DELETED GO TO 90
      GOTO 100
*
*  THE USER WANTS TO BE UNDONE.  MAKE SURE THE INFORMATION
*  IS STILL AROUND, THEN TELL HIM WHAT WE'RE GOING TO DO,
*  IN THE PAST TENSE.
*
30    CONTINUE
      IF(TOOFAR)WRITE(TRMOUT,'($   UNABLE TO UNDO.$)');GOTO 10
      WRITE(TRMOUT,'($   $,NA1,$ RESTORED$)')(OLDBUF(I),I=1,OLDBUF(1)+1)
      TEMPTR=NEWPTR
      NEWPTR=OLDPTR
      OLDPTR=TEMPTR
      CALL REFFMT(OLDPTR,OLDBUF)
      WRITE(TRMOUT,'($   $,NA1,$ REMOVED$)')(OLDBUF(I),I=1,OLDBUF(1)+1)
*
*  STORE THE NEW POINTER IN
*  WRITE THE RECORD/PAGE BACK INTO THE DATABASE, AND ALLOW AN UNDO
*
100   CONTINUE
      CALL STORE(PATCH(LINPTR),PTRDSP,PTRSIZ,NEWPTR)
      CALL WRITLN(PATCH,RECARA,RECPGE)
      TOOFAR=.FALSE.
      GOTO 10
*
*  HAVING TIED HIS DATABASE IN KNOTS, THE USER TRIES TO ESCAPE.....
*
20    CONTINUE
      RETURN
      END
      INTEGER FUNCTION BITS($WORD,$LEFT,$RIGHT)
************************************************************************
*                                                                      *
*       FUNCTION BITS RETURNS A SPECIFIED BIT FIELD, RIGHT JUSTIFIED,  *
*        OUT OF THE FIRST PARAMETER, THE SECOND PARAMETER BEING THE    *
*        LEFTMOST BIT OF THE FIELD,AND THE THIRD PARAMTER BEING        *
*        THE RIGHTMOST.                                                *
*                                                                      *
************************************************************************
      INTEGER $LEFT,$RIGHT,$WORD
      BITS=ISL(ISL($WORD,$LEFT),($RIGHT-$LEFT+1)-32)
      RETURN
      END
      INTEGER FUNCTION COMREF($AREA,$PAGE,$LINE)
************************************************************************
*                                                                      *
*        FUNCTION COMREF TAKES AS ARGUMENTS THREE INTEGERS REPRESENTING*
*        THE AREA,PAGE, AND LINE NUMBERS OF AN EDMS REF-CODE, AND      *
*        COMBINES THEM INTO A SINGLE WORD, IN EDMS COMPATABLE FORMAT.  *
*                                                                      *
************************************************************************
      INTEGER $AREA,$PAGE,$LINE,FNDARA
      INCLUDE EVAL_IN01
      COMREF=IOR(IOR(ISL($AREA,24),ISL($PAGE,ARALSZ(FNDARA($AREA))))
     .,$LINE)
      RETURN
      END
      SUBROUTINE FINSET(TRMBUF,BOLN,EOLN,PSET,SETIND)
************************************************************************
*            SUBROUTINE FINSET                        1979 03 15       *
*                                                                      *
*     THIS ROUTINE FINDS A NAME IN TRMBUF, COPIES IT INTO PSET,        *
*     TRIES TO FIND A SET NAME TO MATCH IT IN THE SET TABLES,          *
*     AND RETURNS THE SET INDEX IF FOUND, ZERO IF NOT FOUND.           *
*                                                                      *
************************************************************************
      IMPLICIT LOGICAL(A-Z)
      INTEGER TRMBUF(80),BOLN,EOLN,PSET(32),SETIND,INDEX0,INDEX1,BASE
      INTEGER SETNSZ,BLANK/' '/,TOP8/8ZFF000000/
************************************************************************
*                                                                      *
*     LOCAL VARIABLES:                                                 *
*            NAME     TYPE        DESCRIPTION                          *
*            ----     ----        -----------                          *
*            TRMBUF   INTEGER     USER'S LAST TERMINAL BUFFER          *
*            BOLN     INTEGER     NEXT CHAR IN TRMBUF                  *
*            EOLN     INTEGER     LAST NON-BLANK CHAR IN TRMBUF        *
*            PSET     INTEGER     FIRST NAME IN TRMBUF AFTER BOLN      *
*            SETIND   INTEGER     INDEX OF NAMED SET, IF ANY.          *
*                                 ZERO IF NO SUCH SET                  *
*            INDEX0   INTEGER     A SCRATCH VARIABLE                   *
*            INDEX1   INTEGER     A NUTHER SCRATCH                     *
*            BASE     INTEGER     STILL YET ANOTHER SCRATCH VARIABLE   *
*            SETNSZ   INTEGER     SIZE OF NAMED SET                    *
*            BLANK    INTEGER     A BLANK.                             *
*            TOP8     INTEGER     MASK GIVING THE FIRST CHAR IN        *
*                                 A WORD, FOLLOWED BY NULLS            *
*                                                                      *
************************************************************************
      INCLUDE EVAL_IN01
*
*  CLEAR THE NAME BUFFER, PSET
*
      DO 30 INDEX1=1,32
      PSET(INDEX1)=BLANK
30    CONTINUE
*
*  SKIP PAST LEADING BLANKS
*
      DO 10 BASE=BOLN,EOLN
      IF(TRMBUF(BASE).NE.BLANK)GOTO 20
10    CONTINUE
      GOTO 50
*
*  COPY THE NAME WE FOUND INTO PSET
*
20    CONTINUE
      BASE=BASE-1
      DO 40 SETNSZ=1,32
      IF(BASE+SETNSZ.GT.EOLN)GOTO 60
      IF(TRMBUF(BASE+SETNSZ).EQ.BLANK)GOTO 60
      PSET(SETNSZ)=TRMBUF(BASE+SETNSZ)
40    CONTINUE
      SETNSZ=33
      IF(BASE+33.GT.EOLN)GOTO 60
      IF(TRMBUF(BASE+33).NE.BLANK)GOTO 50
60    CONTINUE
      BASE=BASE+SETNSZ
      SETNSZ=SETNSZ-1
*
*  SEARCH FOR THIS NAME IN THE SET TABLES
*  ONLY LOOK AT NAMES OF THE SAME LENGTH
*
      DO 70 INDEX0=1,SETCNT
      IF(SETNSZ.NE.SETNAM(INDEX0,1))GOTO 70
      DO 80 INDEX1=1,SETNSZ
*
*  LOOK ONLY AT THE FIRST BYTE OF THE NAMES.  SOME HAVE
*  TRAILING BLANKS, OTHERS HAVE NULLS
*
      IF(IAND(TOP8,PSET(INDEX1)).NE.
     @   IAND(TOP8,SETNAM(INDEX0,INDEX1+1)))GOTO 70
80    CONTINUE
      SETIND=INDEX0
      BOLN=BASE
      RETURN
70    CONTINUE
*
*  COULDNT FIND A NAME, RETURN 0
*
50    CONTINUE
      SETIND=0
      RETURN
      END
************************************************************************
*                                                                      *
*            SUBROUTINE MAKREF                        1979 03 15       *
*                                                                      *
*     THIS ROUTINE USES THE INFORMATION IN TRMBUF TO FORM AN           *
*     AREA, PAGE, AND LINE NUMBER REPRESENTING A REFCODE.              *
*     EITHER SPACES OR DASHES MAY SEPERATE COMPONENTS OF THE           *
*     REFCODE.  IF THERE IS NO ACCEPTABLE REFCODE,                     *
*     THEN ERRFLG IS RETURNED TRUE, AND THE RESULT, IN REFARY          *
*     IS RETURNED AS 0-0-0.                                            *
*                                                                      *
************************************************************************
      IMPLICIT LOGICAL(A-Z)
      LOGICAL ERRFLG
      INTEGER TRMBUF(80),START,END,REFARY(3),INDEX0,INDEX1,BLANK,
     @ DASH,BASE,TEMP,NUMER
      DATA DASH/'-'/,BLANK/' '/
************************************************************************
*                                                                      *
*     LOCAL VARIABLES:                                                 *
*            NAME     TYPE        DESCRIPTION                          *
*            ----     ----        -----------                          *
*            ERRFLG   LOGICAL     TRUE IF INVALID REFCODE              *
*            TRMBUF   INTEGER     USER'S LAST TERMINAL BUFFER          *
*            START    INTEGER     SCAN POINTER INTO TRMBUF             *
*            END      INTEGER     LAST NON-BLANK CHAR IN TERMBUF       *
*            REFARY   INTEGER     RESULTANT REFCODE ARRAY              *
*            INDEX1   INTEGER     A SCRATCH VARIABLE                   *
*            BLANK    CONSTANT    A BLANK                              *
*            DASH     CONSTANT    A DASH; A MINUS; A HYPHEN, ETC.      *
*            BASE     INTEGER     SCRATCH SCAN POINTER                 *
*            TEMP     INTEGER     A SCRATCH/TEMP VARIABLE              *
*            NUMER    FUNCTION    RETURNS INTEGER VALUE OF A           *
*                                 NUMERIC CHAR, AND -1 IF CHAR         *
*                                 IS NON-NUMERIC.                      *
*                                                                      *
************************************************************************
      INTEGER UERROR,TRMIN,TRMOUT
      COMMON /USERIO/UERROR,TRMIN,TRMOUT
*
*  SET BASE TO THE LINE POINTER
*
      BASE=START
*
*  PICK UP THREE NUMBERS (WE HOPE)
*
      DO 10 INDEX0=1,3
*
*  IF THERE IS NOTHING LEFT, ERROR.
*
      IF(BASE.GT.END)GOTO 60
*
*  CLEAR THIS SEGMENT OF THE REFCODE
*
      REFARY(INDEX0)=0
*
*  SKIP BY BLANKS OR DASHES, AND LOOK FOR A NUMBER
*
      DO 20 INDEX1=BASE,END
      IF(TRMBUF(INDEX1).EQ.BLANK.OR.TRMBUF(INDEX1).EQ.DASH)GOTO 20
      IF(NUMER(TRMBUF(INDEX1)).GE.0)GOTO 30
      GOTO 60
20    CONTINUE
      GOTO 60
*
*  WE FOUND A NUMBER, LETS TURN IT FROM CHAR TO INTEGER
*
30    CONTINUE
      BASE=INDEX1
      DO 40 INDEX1=BASE,END
      TEMP=NUMER(TRMBUF(INDEX1))
*
*  ANY MORE NUMBER LEFT?
*
      IF(TEMP.LT.0)GOTO 50
      REFARY(INDEX0)=REFARY(INDEX0)*10+TEMP
40    CONTINUE
*
*  MOVE THE BASE POINTER UP, AND GOT GET THE NEXT SEGMENT,
*  IF THERE IS ONE
*
50    CONTINUE
      BASE=INDEX1
10    CONTINUE
*
*  GIVE THE USER A HERO BISCUT, HE KNOWS WHAT A REFCODE LOOKS
*  LIKE.  MOVE HIS POINTER UP TO THE CHAR AFTER THE REFCODE.
*
      START=BASE+1
      ERRFLG=.FALSE.
      RETURN
*
*  THE NURD SEEMS TO BE HAVING CEREBRAL DIFFICULTIES, GIVE
*  HIM A SUBTLE HINT, AND ERROR.
*
60    CONTINUE
      ERRFLG=.TRUE.
      WRITE(TRMOUT,1000)
1000  FORMAT(' REFCODES HAVE THE FORMAT AREA-PAGE-LINE')
      RETURN
      END
      SUBROUTINE MATCH(BUFFER,START,END,TABLE,WORDS,SIZE,WORD)
************************************************************************
*                                                                      *
*            SUBROUTINE MATCH                         1979 03 15       *
*                                                                      *
*     THIS IS A GENERAL TABLE-MATCHING ROUTINE.  THE INPUT BUFFER      *
*     IS SEARCHED FOR NON-BLANK CHARACTERS, THEN THE CHARACTERS        *
*     ARE COMPARED WITH ENTRIES IN TABLE. IF THE BUFFER CONTAINS A     *
*     SYMBOL (A NON-BLANK STRING, ENDED BY A BLANK) WHICH MATCHES      *
*     AN ENTRY IN THE TABLE, IN WHOLE OR IN PART, THEN THE INDEX       *
*     OF THE WORD WHICH MATCHED IS RETURNED IN THE VARIABLE "WORD".    *
*     IF NO MATCH OCCURS, WORD IS ZERO.                                *
*            NOTE THAT THE TABLE IS SEARCHED CONSECUTIVLEY, FROM       *
*     FRONT TO BACK, AND THEREFORE, IF THE BUFFER CONTAINS A WORD      *
*     WHICH MATCHES TWO ENTRIES IN THE TABLE, THEN THE RESULT WILL     *
*     BE THE INDEX OF THE FIRST WORD FOUND.                            *
*            NOTE ALSO, THAT THE TABLE IS DIMENSIONED AS               *
*     TABLE(SIZE,WORDS). THIS IS BECAUSE FORTRAN ORDERS ITS SUBSCRIPTS *
*     ASS-BACKWARDS.  THIS ORDERING ALLOWS WORD-BY-WORD ENTRIES        *
*     TO BE MADE TO THE TABLE FROM A DATA STATEMENT.                   *
*                                                                      *
************************************************************************
      IMPLICIT LOGICAL(A-Z)
      INTEGER START,END,WORDS,SIZE,WORD,BASE,BLANK/' '/
      INTEGER BUFFER(END),TABLE(SIZE,WORDS),INDEX0,INDEX1
************************************************************************
*                                                                      *
*     LOCAL VARIABLES:                                                 *
*            NAME     TYPE        DESCRIPTION                          *
*            ----     ----        -----------                          *
*            START    INTEGER     THE START OF THE BUFFER, AS FAR      *
*                                 AS WE ARE CONCERNED.                 *
*            END      INTEGER     THE END OF THE BUFFER, AS FAR        *
*                                 AS WE ARE CONCERNED.                 *
*            WORDS    INTEGER     THE NUMBER OF WORDS IN TABLE         *
*            SIZE     INTEGER     THE SIZE OF A WORD IN TABLE          *
*            BASE     INTEGER     A SCRATCH VARIABLE                   *
*            BLANK    INTEGER     IF YOU REALLY EXPECT SOMETHING       *
*                                 MEANINGFUL HERE, YOU MIGHT AS WELL   *
*                                 QUIT READING;  TRY TAKING UP ZEN...  *
*            BUFFER   INTEGER     THE BUFFER WHICH MAY CONTAIN A WORD  *
*            TABLE    INTEGER     THE USER'S SYMBOL TABLE, WHICH       *
*                                 WORD.                                *
*            INDEX0   INTEGER     A SCRATCH VARIABLE                   *
*            INDEX1   INTEGER     MUCH THE SAME AS INDEX0              *
*                                                                      *
************************************************************************
*
*  BE PESSIMISTIC, ASSUME WE WONT FIND ANYTHING
*
      WORD=0
*
*  SKIP LEADING BLANKS
*
      DO 10 BASE=START,END
      IF(BUFFER(BASE).NE.BLANK)GOTO 20
10    CONTINUE
*
*  BUFFER WAS EMPTY
*
      RETURN
*
*  WELL, WE FOUND SOMETHING.
*  LETS GO THROUGH THE TABLE AND SEE IF IT FITS
*
20    CONTINUE
      BASE=BASE-1
      DO 40 INDEX0=1,WORDS
      DO 50 INDEX1=1,SIZE
*
*  IF WE HIT THE END OF A TABLE WORD, THEN MAKE
*  SURE THE BUFFER SYMBOL DID TOO
*
      IF(TABLE(INDEX1,INDEX0).EQ.BLANK)GOTO 70
*
*  IF WE HIT THE END OF A BUFFER SYMBOL, THEN WE HAVE A MATCH.
*  THE END OF THE BUFFER IS TREATED AS THOUGH A BLANK
*  WERE CATENATED TO IT.
*
      IF(BASE+INDEX1.GT.END)GOTO 60
      IF(BUFFER(BASE+INDEX1).EQ.BLANK)GOTO 60
*
*  IF WE HAVE A MISMATCH, THEN TRY THE NEXT TABLE WORD
*
      IF(TABLE(INDEX1,INDEX0).NE.BUFFER(BASE+INDEX1))GOTO 40
50    CONTINUE
      INDEX1=SIZE+1
70    CONTINUE
*
*  THE TABLE WORD ENDED, LETS MAKE SURE THE BUFFER SYMBOL DID TOO.
*
      IF(BASE+INDEX1.GT.END)GOTO 60
      IF(BUFFER(BASE+INDEX1).EQ.BLANK)GOTO 60
40    CONTINUE
*
*  NO MATCH, WORD WAS SET TO ZERO WAY BACK WHEN WE
*
      RETURN
*
*  LOOKS LIKE WE FOUND A MATCH.  SET THE BEGINNING OF BUFFER
*  POINTER TO THE FIRST CHAR AFTER THE SYMBOL, SET THE
*  WORD NUMBER, AND PACK IT IN.
*
60    CONTINUE
      START=BASE+INDEX1+1
      WORD=INDEX0
      RETURN
      END
      INTEGER FUNCTION NUMER($CHAR)
************************************************************************
*                                                                      *
*        THIS FUNCTION RETURNS THE VALUE TRUE IF THE ARGUMENT          *
*        TO IT HAS A NUMERIC CHARACTER IN THE TOP 8 BITS.              *
*                                                                      *
************************************************************************
      INTEGER $CHAR,ORD
      INTEGER NTABLE(256)
      DATA NTABLE /
     .0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
     .0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
     .0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
     .0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
     .0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
     .0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
     .0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
     .0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
     .0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
     .0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
     .0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
     .0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
     .0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
     .0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
     .0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
     .1,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0 /
      ORD=ISL($CHAR,-24)
      IF(NTABLE(ORD+1).EQ.0)NUMER=-1;RETURN
      NUMER=ORD-240
      RETURN
      END
      SUBROUTINE RDTERM(TRMBUF,EOLN,ENDFLG)
*                                                                      *
*            SUBROUTINE RDTERM                        1979 03 15       *
*                                                                      *
*     THIS ROUTINE READS IN AN 80-CHARACTER BUFFER FROM THE USER,      *
*     TRAPPING AN END-OF-FILE.  IF THE USER TYPED AN EOF, THEN         *
*     ENDFLG IS RETURNED TRUE.  IF THE BUFFER CONTAINS AN              *
*     END WORD, ENDFLG IS TRUE. OTHERWISE, THE BUFFER IS SCANNED       *
*     FROM THE END FOR THE LAST NON-BLANK CHARACTER.  THIS             *
*     CHARACTER IS MARKED BY THE VARIABLE "EOLN".                      *
*                                                                      *
************************************************************************
      IMPLICIT LOGICAL(A-Z)
      LOGICAL ENDFLG,TSTEND
      INTEGER TRMBUF(80),EOLN,BLANK/' '/,START
************************************************************************
*                                                                      *
*     LOCAL VARIABLES:                                                 *
*            NAME     TYPE        DESCRIPTION                          *
*            ----     ----        -----------                          *
*            ENDFLG   LOGICAL     TRUE IF END-OF-FILE ENCOUNTERED      *
*            TSTEND   FUNCTION    RETURNS TRUE IF BUFFER CONTAINS AN   *
*                                 END-WORD.                            *
*            TRMBUF   INTEGER     BUFFER FROM THE TERMINAL             *
*            EOLN     INTEGER     POINTER TO MARK THE LAST NON-BLANK   *
*                                 CHARACTER IN THE BUFFER              *
*            BLANK    CONSTANT    A BLANK                              *
*                                                                      *
************************************************************************
      INTEGER UERROR,TRMIN,TRMOUT
      COMMON /USERIO/UERROR,TRMIN,TRMOUT
*
*  GET THE BUFFER
*
      READ(TRMIN,1000,END=10)TRMBUF
1000  FORMAT(80A1)
*
*  LOOK FOR AN END WORD
*
      START=1
      ENDFLG=TSTEND(TRMBUF,START)
      IF(ENDFLG)RETURN
*
*  LOOK FOR THE LAST CHAR
*
      DO 20 EOLN=80,1,-1
      IF(TRMBUF(EOLN).NE.BLANK)RETURN
20    CONTINUE
*
*  USER ENTERED BLANK LINE
*
      EOLN=0
      RETURN
*
*  USER DEFINITLEY DOES NOT WANT TO TYPE IN ANYTHING ELSE
*
10    CONTINUE
      ENDFLG=.TRUE.
      RETURN
      END
      SUBROUTINE READLN(BUFFR,LNPTR,GRPNUM,ARANUM,PAGE,LINE,ERROR)
************************************************************************
*                                                                      *
*        SUBROUTINE READLN WILL READ IN THE SPECIFIED PAGE FROM        *
*        THE SPECIFIED AREA,   AND FIND THE SPECIFIED LINE, SETTING    *
*        ERROR TO FALSE AND LNPTR  TO POINT TO THE FIRST WORD OF       *
*        THE LINE IN THE BUFFER IF THE LINE WAS FOUND, OR SETTING      *
*        ERROR TO TRUE IF THE LINE WAS NOT FOUND.                      *
*                                                                      *
************************************************************************
      INTEGER BUFFR(512),LNPTR,GRPNUM,ARANUM,LINE,PAGE,LSTWD
      INTEGER FNDARA,BITS
      LOGICAL ERROR
      READ DISK FNDARA(ARANUM)+10,(PAGE-1)*512,BUFFR
      IF(LINE.EQ.0)LNPTR=1;GRPNUM=131072;RETURN
      LNPTR=3
10    CONTINUE
      IF(LNPTR.GT.LSTWD)ERROR=.TRUE.;GOTO 20
      IF(LINE.EQ.BITS(BUFFR(LNPTR),0,7))ERROR=.FALSE.;GOTO 20
      LNPTR=LNPTR+BITS(BUFFR(LNPTR),23,31)
      GOTO 10
20    CONTINUE
      GRPNUM=BITS(BUFFR(LNPTR),8,17)
      RETURN
      END
      LOGICAL FUNCTION TSTEND(INBUF,START)
************************************************************************
*                                                                      *
*            FUNCTION TSTEND                                           *
*                                                                      *
*     THIS FUNCTION LOOKS FOR AN END WORD IN INBUF. ANY SUBSET OF      *
*     THE WORDS IN THE TABLE "ENDWDS" IS CONSIDERED AN END WORD.       *
*                                                                      *
************************************************************************
      IMPLICIT LOGICAL(A-Z)
      INTEGER INBUF(80),START,END,MINDEX,
     @ENDWDS(4,6)/
     @'E','N','D',' ',
     @'Q','U','I','T',
     @'X',' ',' ',' ',
     @'E','X','I','T',
     @'S','T','O','P',
     @'O','U','T',' '/
      END=80
      CALL MATCH(INBUF,START,END,ENDWDS,6,4,MINDEX)
      TSTEND=MINDEX.NE.0
      RETURN
      END
      SUBROUTINE TSTREF(REFARY,ERRFLG)
************************************************************************
*                                                                      *
*            SUBROUTINE TSTREF                                         *
*                                                                      *
*     THIS ROUTINE CHECKS THE AREA-PAGE-LINE NUMBERS IN REFARY         *
*     ALLOWABLE IN THIS DATABASE.  ANY COMPONENT FAILING A TEST        *
*     CAUSES INFORMATION AS TO THE  ALLOWABLE VALUES TO BE PRINTED.    *
*                                                                      *
************************************************************************
      IMPLICIT LOGICAL(A-Z)
      LOGICAL ERRFLG
      INTEGER REFARY(3),I,ARANUM,FNDARA
      INTEGER UERROR,TRMIN,TRMOUT
      COMMON /USERIO/UERROR,TRMIN,TRMOUT
      INCLUDE EVAL_IN01
*
*  CHECK THE AREA NUMBER
*
      ARANUM=FNDARA(REFARY(1))
      IF(ARANUM.NE.0)GOTO 10
*
*  AREA CHECK FAILED, WRITE OUT THE VALID AREA(S)
*
      IF(ARACNT.EQ.1)WRITE(TRMOUT,1000)AREA(1);GOTO 20
1000  FORMAT(' THE VALID AREA NUMBER IS: ',I)
      WRITE(TRMOUT,2000)ARACNT-1,(AREA(I),I=1,ARACNT)
2000  FORMAT(' THE VALID AREA NUMBERS ARE: ',NI,'AND ',I)
      GOTO 20
*
*  CHECK THE PAGE NUMBER
*
10    CONTINUE
      IF(REFARY(2).GT.0.AND.REFARY(2).LE.ARASIZ(ARANUM))GOTO 30
*
*  PAGE CHECK FAILED, TELL THE USER HOW MANY PAGES THERE ARE
*
      WRITE(TRMOUT,3000)REFARY(1),ARASIZ(ARANUM)
3000  FORMAT(' AREA #',I,'ONLY HAS ',I,'PAGES')
      GOTO 20
*
*     CHECK THE LINE NUMBER
*
30    CONTINUE
      IF(REFARY(3).LT.0.OR.REFARY(3).GT.255)WRITE(TRMOUT,4000);GOTO 20
*
*  THE LINE NUMBER WAS SILLY
*
4000  FORMAT(' LINE NUMBERS MUST BE IN THE RANGE 0 TO 255')
      ERRFLG=.FALSE.
      RETURN
20    CONTINUE
      ERRFLG=.TRUE.
      RETURN
      END
      SUBROUTINE WRITLN($BUFFR,$AREA,$PAGE)
*                                                                      *
*        SUBROUTINE TO WRITE OUT A SPECIFIED PAGE OF THE               *
*        USERS DATABASE, RESETTING THE MUST-WRITE FLAG AND             *
*        RECHECKSUMMING THE PAGE, IF THE PAGE IS CHECKSUMMED.          *
*                                                                      *
************************************************************************
      IMPLICIT LOGICAL(A-Z,$)
      INTEGER $AREA,$PAGE,FNDARA
      INCLUDE EVAL_IN01
      INTEGER $BUFFR(512),$LNPTR,$CHKWD
*
*  CLEAR THE MUST WRITE FLAG
*
      INTEGER $MWF,CHKSUM,BITS
      DATA $MWF/ZFFFFFDFF/
      $BUFFR(1)=IAND($BUFFR(1),$MWF)
      IF(.NOT.ARACHK(FNDARA($AREA)))GOTO 10
*
*  RECALCULATE THE CHECKSUM
*
      $CHKWD=512-BITS($BUFFR(1),23,31)
      $BUFFR($CHKWD)=CHKSUM($BUFFR,$CHKWD-1)
10    CONTINUE
      WRITE DISK FNDARA($AREA)+10,($PAGE-1)*512,$BUFFR
      RETURN
      END
