***************************************************************
*M*      TPG1     TRANSACTION PROCESSING GHOST
***************************************************************
*F*
*F*      NAME:    TPG1, TRANSACTION PROCESSING GHOST
*F*
*F*      PURPOSE: THIS PART OF THE TPG IS CALLED WHENEVER
*F*               THERE IS AN EXISTING TPQUEUE FILE.  IT
*F*               SEARCHES ALL THE CURRENT TRANSACTIONS
*F*               LOOKING FOR A TRANSACTION MARKED IN-PROGRESS.
*F*               IF AN IN-PROGRESS TRANSACTION IS FOUND,
*F*               THEN THE RECOVERY ROUTINES MUST BE
*F*               INVOKED BEFORE THE QUEUE CAN BE REOPENED.
*F*               THIS INSURES THAT NO IN-PROGRESS TRANSACTION
*F*               WILL BE LOST ACROSS A SYSTEM CRASH.
*F*
*
         SYSTEM   BPM
         SYSTEM   SIG7FDP
         SYSTEM   TP:TPO
         SYSTEM   LP:TPOQ
         GENTABS
GOD      EQU      1
DBGKEY   EQU      0
ALLRECKEY EQU     0
         REF      ABTCMD            COMMAND ABORTED MESSAGE
         REF      QRECBUF           QUEUE BLOCK BUFFER
         REF      OPOUTX            ERROR CAL MESSAGE SET-UP
         REF      TEMPID            CURRENT HIGHEST TID (SAVE LOC)
         REF      F:QDCB            QUEUE FILE DCB
         REF      BUF               ADDRESS OF COMMON WORK PAGES
         REF      ERR               I/O ERROR ROUTINE
         REF      ABN               I/O ABNORMAL ROUTINE
         REF      MASTER,SLAVE      MASTER/SLAVE PSD ROUTINES
         REF      LOCKFPT           QUEUE LOCK FPT
         REF      DRX               OUTPUT MESSAGE ROUTINE
         REF      OPOUTFPT          ERROR MESSAGE FPT
         DEF      QCK               QUEUE CHECK SUBROUTINE
         DEF      PATCH             GENMD SYMBOL FOR PATCH AREA
         PAGE
PUSH     CNAME    X'0B'
PULL     CNAME    X'0A'
*
*                 FORMAT OF CALL:
*                    PULL     2,R7       PULLS R7,R8 FROM R:TSTACK
*                    PUSH   3,R0       PUSHES R0,R1,R2 INTO R:TSTACK
*                 NOTE THAT R:TSTACK MUST BE DECLARED AND
*                 INITIALIZED AS A STACK DOUBLEWORD POINTER
*
         PROC
LF       EQU      %
TMP      SET      -2
         DO       NUM(AF)>1
         DO       AF(1)<16
         LCI      AF(1)
         ELSE
         LCI      0
         FIN
TMP      SET      0
         FIN
         GEN,8,4,20  NAME+TMP,AF(NUM(AF)),R:TSTACK
         PEND
***********************************************************************
DEBUG    CNAME
         PROC
         LOCAL    %1,%2
         DO       DBGKEY=1
         B        %1
%2       TEXTC    AF
%1       EQU      %
         M:PRINT  (MESS,%2)
         FIN
         PEND
*
EXPLAIN  CNAME,0                    PRINTS OUT EXPLANATIONS
         PROC
         OPEN     X,I
X        SET      S:UFV(AF)         LIST OF MESSAGES
I        DO       NUM(X)
         ERROR,*  ;
         '                                                       ****';
                  ,X(I)
         FIN
         CLOSE    X,I
         PEND
******************************************************************
*
*        CALL, ENTRY, AND RETURN ARE FOR INTERNAL LINKING.
*                 THE LINK LABEL IS A 2-ITEM LIST:
*                 1.  ADDRESS  OF A ROUTINE
*                 2.  ADDRESS OF A TEMP FOR REMEMBERING CALLER'S
*                      ADDRESS
*                 ENTRY IS THE ENTRY POINT INTO THE CALLED ROUTINE.
*                 RETURN RETURNS CONTROL TO THE
*                 CALLING PROGRAM.
*
*                 THESE ROUTINES WERE DONATED BY TED MARTNER
*                 THEIR OPERATION IS IDENTICAL TO THEIR USE IN THE
*                 TRANSACTION PROCESSING CONTROLLER
*
******************************************************************
         OPEN     X
*
CALL     CNAME                      CALL CALLS A SUBROUTINE
         PROC
X        SET      S:UFV(AF)
         ERROR,7,NUM(X)<2     'BAD CALL'  COMPLAIN IF IT ISN'T A SUBR
LF       BAL,11   X(1)              CALL IT
         EXPLAIN  X(3)
         PEND
*
ENTRY    CNAME                      ENTRY STARTS A SUBROUTINE
         PROC
         LOCAL    X,Y
         USECT    @D                PRESERVE A WD IN DATA
X        EQU      %
         DATA     0                 FOR HOLDING RETURN ADDRESS
         USECT    @P
Y        EQU      %
LF       EQU      Y,X,(AF)
         STW,11   X                 REMEMBER CALLER'S ADDRESS
         PEND
*
*                 ENTRYR NOT IMPLEMENTED FOR THIS PROGRAM
*
RETURN   CNAME
         PROC
X        SET      S:UFV(AF)
         ERROR,7,NUM(X)<2   'BAD RETURN'
LF       B        *X(2)             RETURN TO CALLER
         PEND
         CLOSE    X
         PAGE
@P       CSECT    0
@D       CSECT    0
         USECT    @D
         BOUND    8
R:TSTK   DATA     WA(STKSTRT)
         GEN,16,16 64,0
R:TSTACK  DATA    WA(STKSTRT)
         GEN,16,16  64,0
STKSTRT  RES      64
INPROGMASK   DATA  X'10'
QERROR   DATA     0
SAVR15   DATA     0
         BOUND    8
CONTROLBLK    RES      512
INDEXBLK      RES      512
DATABLK  RES      512
DOP3REMAK TEXTC   'RUN PHASE 3 REMAKE - Q INFO NOT SAVED'
DOLISTQIP TEXTC   'RUN LISTQIP - FOUND IN PROGRESS ENTRY'
         PAGE
         USECT    @P
*
*        QCK   CHECKS THE Q AND EITHER
*        RETURNS TO CALLER (OPEN Q)  OR
*        PRINTS ERR MSG AND RETURNS TO ABORT THE CMD
*
QCK      EQU      %
         LCF      QRECBUF
         BCR,8    *15               FILE DIDN'T EXIST-DONT CHECK
         STW,15   SAVR15
*  DO UNLOCK & READ 1ST RECORD
         LI,5     X'80'
         STS,5    QRECBUF+7         SET RECOV MODE BIT
         LI,10    0
         DO1      GOD
         CAL1,7   QRECBUF+6
         LI,4     0
         STS,4    QRECBUF+7         RESET RECOV BIT
         CI,10    0
         BE       %+3               UNLOCK OK
         BAL,9    OPOUTX
         B        QCK7              UNLOCK ERROR
         STW,8    TEMPID            SAVE ID VALUE
         LI,9     0
         M:READ   F:QDCB,(BUF,*BUF),(SIZE,4*512),(ERR,ERR),;
                  (ABN,ABN),(WAIT),(BLOCK,0)
         LI,7     CONTHTID(I)       HIGHEST TRANSACTION ID
         LI,1     DOP3REMAK
         CW,9     *BUF,7            WAS QUEUE INFO SAVED BY RECOV
         BNEZ     %+2               YES
         CALL     ADVISE
         LI,6     0
QCK4     EQU      %
         CALL     GETNEXT
         CI,5     0
         BE       QCKDONE           DONE- OK TO RESTART OR START
         GET,R2,R4 DATASTATUSR,*R6
         AND,R2   INPROGMASK        WAS ENTRY IN PROG
         BEZ      QCK4              NO - GO ON TO NEXT
*  PRINT MESSAGE TO RUN LISTQIP
         LI,1     DOLISTQIP
ADVISE   ENTRY    'PRINT MESSAGE AND EXIT'
         LI,5     1
         LW,10    1
         CAL1,2   OPOUTFPT          ERR MESS IN 10
QCKDONE  EQU      %
         STW,5    QERROR
         LD,8     R:TSTK            CLEAN OUT STK
         STD,8    R:TSTACK
*  PUT ID IN MEMORY AND LOCK Q
         BAL,15   MASTER
         LW,8     TEMPID
         ST,8     Q:TID             STORE HIGHEST TID
         BAL,15   SLAVE
         DO1      GOD
         CAL1,7   LOCKFPT
*  RETURN IF NO ERR, OTHERWISE CLOSE Q AND ABORT CMD
         CI,5     0
         BE       *SAVR15
QCK7     EQU      %
         LI,9     0
         M:CLOSE  F:QDCB,(SAVE)
         LI,10    ABTCMD
         B        DRX               ABORT COMMAND
         PAGE
GETNEXT  ENTRY    'GET NEXT ENTRY OUT OF QUEUE'
         DEBUG    'ENTERING GETNEXT'
*
         PUSH     5,R0              PUSH R0 THRU R4
         PUSH     8,R8              PUSH R8 THRU R15
         CI,R6    0                 INITIALIZATION ?
         BE       GETNEXTINIT
         CALL     NEXTDKEY
ENDGETNEXT EQU    %
         PULL     8,R8
         PULL     5,R0
         DEBUG    ' EXITING GETNEXT'
         RETURN   GETNEXT
*
GETNEXTINIT EQU   %
         LI,R13   0                 INPUT TO READBLOCK (BLK #)
         LI,R14   1                 DITTO (BLK TYPE)
         CALL     READBLOCK
         LI,R2    CONTROLBLK        INIT INDEX REGISTER
         GET,R8   CONTINDEXES,R2    INIT INDEX BLOCK COUNTDOWN
         STW,R8   INDEX:CD
         GET,R8   CONTENTRIES,R2    INIT # ENTRIES QUEUED COUNTDOWN
         STW,R8   ENTRY:CD
         GET,R8   CONTFIRSTGDA,R2    INIT # OF BLOCK ALLOCATED IN
         STW,R8   A:BLKBIAS          FIRST ALLMAP
         STW,R8   A:BLKCNT          INIT BLOCK NUMBER COUNTER
         GET,R8,R4 CONTKEYM,R2
         AI,R8    3                 HDR SIZE IS 3 FOR INDEX BLOCK
         STW,R8   IKEYMAX           DIVIDE INTO 512 TO FIND SUPER MAX!!!
         LI,R8    0
         LI,R9    502
         DW,R8    IKEYMAX           HOW MANY KEYS IN INDEX BLK?
         STW,R9   ISUPERMAX         ISUPERMAX MANY, THAT'S HOW
         GET,R8   CONTNAVGRANS,R2        INIT MAX BLOCK SIZE
         STW,R8   BLOCKMAX
         GET,R8   CONTHTID,R2       FIND OUT IF CONTROL BLK WAS SAVED
*                                   OK BY RECOVERY
         BEZ      GET200            NO
         T,R0     CONTCON,R2        IS ALLOCATION MAP IN CONTROL BLK?
         BNEZ     GET65             YES IF CONTCON = 1
*                 RESERVE PAGE BUFFER FOR ALLOCATION BLOCK, READ IT IN
*                 AND SET UP ALLOCATION TABLES
         GET,R13  CONTMAP,R2        BLOCK # OF ALLOCATION MAP
         LI,R14   3                 INIT BLOCK TYPE
*
GET40    EQU      %
         LW,R2    ALLOX             PICK UP INDEX INTO ALLOC TABLES
         M:GP     1                 GET SPACE FOR ALLOCATION BLOCK
         STW,R9   ASTART,R2         SAVE ADR OF NEW PAGE
         SLS,R9   1                 CONVERT TO HW ADDR
         AI,R9    512*2-10+1
         STW,R9   ALASTHW,R2        SAVE ADR OF LAST HW
         CALL     READBLOCK
         LW,R3    ASTART,R2         GET START ADR OF BLK FOR INDEX REG
GET55    EQU      %
         GET,R13  ALLFLINK,R3       BLOCK # FORWARD LINK
         BEZ      GET70             NONE EXISTS
         MTW,1    ALLOX
         B        GET40             CONTINUE UNTIL ENTIRE MAP IS IN CORE
*
GET65    EQU      %                 FOR ALLOC MAP STARTING IN CONTROLBLK
         GET,R8,R4  CONTMAPBIAS,R2   BIAS IN CNTLBLK TO ALLOC MAP
         AW,R8    R2                CALCULATE START ADR OF ALLOC MAP
         STW,R8   ASTART
         LW,R2    R8                INDEX INTO INDEX REG
         GET,R8,R4  ALLBLOCKNAV,R2   # OF HW'S IN THIS SHORT BLOCK
         SLS,R2   1                 CONVERT TO HW
         AW,R2    R8                CALCULATE HW ADR OF LAST HW IN BLK
         AI,R2    1
         STW,R2   ALASTHW
         LW,R3    ASTART            SET UP REGS TO FIND NEXT ALLOC BLK
         LI,R14   3
         B        GET55             JOIN ROUTINE TO LOAD ENTIRE 'A' MAP
*
GET70    EQU      %
         LW,R2    ASTART            SET UP PTR TO GET FIRST INDEX BLOCK
         SLS,R2   1                 CONVERT TO HALFWORDS
         AI,R2    ALLMAP(I)         SKIP HDR INFO (5 WORDS)
         STW,R2   ALLOC:HW          SAVE VALUE
         CALL     NEXTIBLK
         CALL     NEXTIKEY
         LI,R6    0
         CALL     NEXTDKEY
         B        ENDGETNEXT        RETURN
*
GET200   EQU      %
         LW,R1    ENTRY:CD
         BEZ      GET202
         LI,R1    ERROR10           ERROR 10: CONTROL BLK NOT OK
         CALL     ADVISE
GET202   EQU      %
         LI,R1    ERROR11           ERROR 11: QUEUE IS EMPTY
         CALL     ADVISE
************************************************************
         PAGE
*                 GETNEXT DATA AREA
*
***************************************************************
         USECT    @D
INDEX:CD DATA     0                 # INDEX BLOCKS COUNTDOWN
ENTRY:CD DATA     0                 TOTAL # ENTRIES QUEUED COUNTDOWN
*
ALLOC:HW DATA     0                 HW POINTER TO ALLMAP'S IN ALLOCBLK
ALLOX    DATA     0                 INDEX OF CURRENT ALLOCATION BLOCK
*                                   BEING SEARCHED
ASIZE    EQU      10                SIZE OF PARALLEL ALLOCATION TABLES
*                                   (EXPECTED # OF ALLOCATION BLOCKS)
ASTART   DO1      ASIZE
         DATA     -1
*
ALASTHW  DO1      ASIZE
         DATA     X'FFFFFFF'
*
IKENT:CD DATA     0                 # ENTRIES QUEUED W/ THIS INDEX KEY
A:BLKBIAS DATA    0                 # OF BLOCK ALLOCATED IN FIRST ALLMAP
*
TEMP12   DATA     0                 TO SAVE EXIT ADDRESS **MAKE INTO STK
*
ALLA:MASK EQU     X'1000'
ALLT:MASK EQU     X'2000'
ANAV:MASK DATA    X'0FFF'
*
IKEY#    DATA     0                 INDEX KEY POSITION NUMBER
A:BLKCNT  DATA    0                 BLOCK COUNTER FOR ALLOC MAP
IACTKEYS DATA     0                 COUNT OF ACTIVE KEYS IN INDEX BLK
ISUPERMAX  DATA   0                 MAX POSSIBLE # OF KEYS IN INDEX BLK
IKEYMAX  DATA     0                 SIZE OF INDEX KEY INCL HEADER
DATA:DW  DATA     0                 # OF AVAIL. DW'S IN DATABLK
BLOCKMAX DATA     0
D:MINDW  EQU      1
         USECT    @P
         PAGE
************************************************************************
*
*        NEXTIBLK
*
*        INTERNAL ROUTINE TO FIND THE NEXT SUCCESSIVE INDEX BLOCK IN
*        THE ALLOCATION MAP, READ IT IN, AND SET UP R7 TO POINT TO
*        THE KEY BEFORE THE FIRST KEY (NEXTIKEY WILL INCREMENT IT).
*
*        INPUT: ALLOC:HW = CURRENT POSITION IN ALLOCATION MAP
*               ALLOCATION TABLES ASTART,ALASTHW
*        OUTPUT: R7 POINTS TO PREVIOUS ENTRY (IE, THE NON ENTRY BEFORE
*                THE FIRST ENTRY)
*        ROUTINES CALLED: READBLOCK, DUMPBLOCK
*        REGISTERS USED: R1-R3,R5-R8,R13-R15 ARE DESTROYED OR REINITIALIZED
*        CALLED BY: GETNEXTINIT, NEXTIKEY
*
************************************************************************
*
NEXTIBLK  ENTRY   ' INITIALIZE NEXT ALLOCATED INDEX BLOCK'
         DEBUG    'ENTERING NEXTIBLK'
         LI,R5    0                 REINIT ALL INPUT REGISTERS
         LI,R6    0
         LI,R7    0
         LW,R2    ALLOC:HW
         BLEZ     IBLK25            NO MORE INDEX BLOCKS SIGNAL
*
IBLK10   EQU      %
         LH,R8    0,R2              LOAD NEXT ALLMAP FROM ALLOC. MAP
         CI,R8    ALLA:MASK         IS ALLA SET ?
         BANZ     IBLK50            YES
IBLK20   EQU      %
         AI,R2    1                 INCR ALLOC MAP HW POINTER
         STW,R2   ALLOC:HW
         MTW,1    A:BLKCNT          INCR BLOCK # COUNTER
         LW,R3    ALLOX
         CW,R2    ALASTHW,R3        IS THIS THE END OF THIS ALLOC BLK?
         BG       IBLK23            YES
IBLK21   EQU      %
         CI,R7    0                 WAS NEXT INDEX BLOCK FOUND YET?
         BE       IBLK10            NO  - CONTINUE SEARCH
         DEBUG    'EXITING NEXTIBLK'
         RETURN   NEXTIBLK
IBLK23   EQU      %                 LOOK FOR NEXT ALLOCATION BLOCK
         MTW,1    ALLOX             INCR  INDEX INTO ALLOC TABLES
         AI,R3    1                 INCR REGISTER CONTAINING SAME
         LW,R2    ASTART,R3         PICK UP START OF NEXT ALLOC BLK
         BLEZ     IBLK27            IF NEG, THERE ARE NO MORE 'A' BLKS
         AW,R2    R2                CONVERT TO HALFWORDS
         AI,R2    ALLMAP(I)         #  HW'S IN ALLOC BLK HEADER
         STW,R2   ALLOC:HW
         B        IBLK21
*
IBLK25   EQU      %
         LI,R5    0                 SET NO MORE ENTRIES IN QUEUE FLAG
         DEBUG    'EXITING NEXTIBLK TO ENDGETNEXT'
         B        ENDGETNEXT        RETURN TO PRIMARY CALLER
IBLK27   EQU      %
         CI,R7    0                 WAS ANOTHER IBLK FOUND
         BE       IBLK25            NO
         STW,R2   ALLOC:HW          SET NO MORE IBLKS FLAG
         DEBUG    'EXITING NEXTIBLK'
         RETURN   NEXTIBLK
*
IBLK50   EQU      %
         CI,R8    ALLT:MASK         IS ALLT SET (ALLT=1 FOR DATABLOCK)
         BANZ     IBLK20            YES - CONTINUE SEARCH FOR INDEX BLK
         CI,R8    X'FFF'            IS THE BLOCK EMPTY
         BAZ      IBLK20            YES, IGNORE IT.
         LW,R13   A:BLKCNT          THIS BLOCK'S A WINNER
         LI,R14   4
         CALL     READBLOCK
         MTW,-1   INDEX:CD          COUNT DOWN TOTAL # INDEX BLOCKS
         BGEZ     IBLK55
         LI,R1    ERROR12           ERROR 12: CONTROL BLOCK INVALID
         CALL     ADVISE
IBLK55   EQU      %
*                 FIND ALLOC MAP VALUE FOR # OF INDEX KEYS IN USE
         AND,R8   ANAV:MASK         MASK OFF BIT FLAGS
         LI,R7    INDEXBLK          INIT INDEX REGISTER
         C,R8,R1  INDEXKEYS,R7      SHOULD BE THE SAME
         BE       IBLK60            OK
         LI,R1    ERROR13           ERROR 13: ALLOCATION BLOCK INVALID
         CALL     ADVISE
IBLK60   EQU      %
         AI,R7    INDEXSLOT(I)      MANIPULATE R7 TO POINT TO PHONY
         SW,R7    IKEYMAX           SUBTRACT KEY MAX
*            FIRST KEY HAS DATAENTRY# = 1, NOT 0
*                 BECAUSE NEXTIKEY WILL INCREMENT IKEY# WHEN IT FINDS
*                 THE FIRST KEY, INIT IKEY# TO 0
         LI,R3    0
         STW,R3   IKEY#
         STW,R3   IACTKEYS
         B        IBLK20            INCR ALLOC BLK PTRS AND EXIT
*
         PAGE
***********************************************************************
*
*        NEXTIKEY
*
*        INTERNAL ROUTINE TO FIND NEXT ACTIVE ENTRY IN INDEX BLK.
*
*        INPUT: R7 POINTS TO PREVIOUS ACTIVE KEY
*               INDEX BLOCK WHICH CONTAINS KEYS
*               R12 = RETURN ADDRESS
*        OUTPUT: R7 POINTS TO NEW KEY
*                R5 = 1 FOR TRANSACTION
*                   = 2 FOR REPORT
*                ENTRY NUMBER (IKEY#) IS INCREMENTED
*                # ENTRIES QUEUED THIS KEY (IKENT:CD) IS INITIALIZED
*        ROUTINES CALLED: NEXTIBLK
*        REGISTERS USED: R0-R4 ARE DESTROYED; R5 IS REINITIALIZED
*        CALLED BY: NEXTDKEY, GETNEXTINIT
************************************************************************
*
NEXTIKEY    ENTRY     'UPDATE R7 TO POINT TO NEXT ACTIVE INDEX KEY'
         DEBUG    'ENTERING NEXTIKEY'
*
*
*
         LI,R4    INDEXBLK
         GET,R2,R5  INDEXKEYS,R4    GET ACTIVE KEYS
         CW,R2    IACTKEYS          COMPARE W/ ACTIVE KEYS FOUND
         BLE      IKEY40            YES - GET NEW INDEX BLOCK
IKEY10   EQU      %
         AW,R7    IKEYMAX           INCREMENT TO NEXT KEY
         MTW,1    IKEY#             INCR KEY POSITION #
         LW,R2    IKEY#             HAS END OF BLOCK BEEN REACHED
         CW,R2    ISUPERMAX         KEYS FOUND :: KEYS POSSIBLE
         BG       IKEY50
         T,R0     INDEXFR,R7        IS KEY ACTIVE ?
         BEZ      IKEY10            NO
         MTW,1    IACTKEYS
*                 DETERMINE WHETHER KEY IS TRANSACTION OR REPORT
         GET,R4,R2  INDEXTYPER,R7   GET  TYPE BYTE
         CI,R4    C'?'               ? INDICATES A TRANSACTION
         BNE      IKEY20            ERGO, A REPORT
         LI,R5    1                 TRANS = 1
         B        IKEY30
IKEY20   EQU      %
         LI,R5    2                 REPORT OR WHATEVER = 2
IKEY30   EQU      %
         GET,R2   INDEXCOUNTR,R7    # ENTRIES QUEUED THIS NAME
         STW,R2   IKENT:CD          SAVE FOR COUNTDOWN
         DEBUG    'EXITING NEXTIKEY'
         RETURN   NEXTIKEY
IKEY40   EQU      %
         CALL     NEXTIBLK
         B        IKEY10            CONTINUE
IKEY50   EQU      %
         LI,R1    ERROR13           UNABLE TO FIND EXPECTED ACTIVE ENTRY
         CALL     ADVISE
         PAGE
************************************************************************
*
*        NEXTDKEY
*
*        INTERNAL ROUTINE TO FIND NEXT ACTIVE ENTRY IN DATA BLOCK
*
*        INPUT: R6=0 FOR INITIALIZATION
*                 = PREVIOUS ENTRY IN DATA BLOCK OTHERWISE
*               R7= CURRENT ENTRY IN INDEX BLOCK
*        OUTPUT: R6= ADR OF NEW ENTRY IN DATA BLOCK
*        ROUTINES CALLED: NEXTIKEY, READBLOCK, PRINTREC (IN DEBUG MODE),
*                 ADVISE, FINDMAP
*        REGISTERS: ALL EXCEPT R5 AND R7 ARE DESTROYED
*        CALLED BY: GETNEXT, GETNEXTINIT
*
************************************************************************
*
NEXTDKEY    ENTRY     'UPDATE R6 TO POINT TO NEXT DATA KEY'
         DEBUG    'ENTERING NEXTDKEY'
         CI,R6    0                 INITIALIZATION ?
         BE       NEXTDBLK          YES
         GET,R2   DATAFLINKR,R6     IS THERE ANOTHER ENTRY ?
         BEZ      DKEY10            NO
         LI,R1    DATABLK
         C,R2     DATABLOCK,R1      IS NEXT ENTRY IN THIS BLOCK ?
         BE       DKEY100           YES
         LW,R13   R2                SET UP R13 FOR READBLOCK CALL
         B        DKEY30            NO
DKEY10   EQU      %
         MTW,0    IKENT:CD          END OF ENTRIES QUEUED THIS INDEX KEY
         BEZ      DKEY15            YES - OK
         LI,R1    ERROR14           ERROR 14: NOT ALL EXPECTED DATA
*                                    ITEMS WERE FOUND - INDEX BLK BAD
         CALL     ADVISE
DKEY15   EQU      %
         CALL     NEXTIKEY
         LI,R1    DATABLK
         GET,R2   DATABLOCK,R1
         C,R2     INDEXHTXTR,R7     NEED TO INPUT NEW DATA BLOCK ?
         BE       DKEY40            NO
*
NEXTDBLK EQU      %
         GET,R13  INDEXHTXTR,R7       GET BLOCK # OF NEW DATA BLOCK
DKEY30   EQU      %
         LI,R14   5                 DATA BLOCK TYPE
         CALL     READBLOCK
         CALL     FINDMAP
*                 CHECK FOR 'EMPTY' DATA BLOCK
         LI,R4    D:MINDW           GET MINIMUM POSSIBLE DW'S USED
         CW,R4    DATA:DW           CHK WITH VALUE FROM ALLOC MAP
         BLE      DKEY40            OK
         LI,R1    ERROR16           SEARCHING EMPTY DATABLK
         CALL     ADVISE
DKEY40   EQU      %
         LI,R6    DATABLK+QDATAENTST   ADR OF FIRST DATA ENTRY
DKEY50   EQU      %
         GET,R2   DATAENTRY#R,R6     GET INDEX KEY POSITION
         CW,R2    IKEY#              IS IT EQUAL TO CALCULATED VALUE?
         BNE      DKEY100           NO
         GET,R2   DATAINDEXR,R6      GET INDEX BLOCK #
         LI,R4    INDEXBLK
         C,R2     INDEXBLOCK,R4      IS IT THE RIGHT BLOCK # ?
         BNE      DKEY100           NO
         DO       ALLRECKEY=1
         LI,R3    -1
         PUSH     1,R5
         CALL     PRINTREC
         PULL     1,R5
         FIN
         MTW,-1   IKENT:CD          COUNTDOWN # ENTRIES THIS KEY
         BGEZ     DKEY60
         LI,R1    ERROR14           ERROR 14: INDEX BLOCK INVALID - NOT
*                                   ENOUGH DATA ENTRIES INDICATED
         CALL     ADVISE
DKEY60   EQU      %
         MTW,-1   ENTRY:CD          COUNTDOWN TOTAL # OF ENTRIES
         BLZ      DKEY65
         DEBUG    'EXITING NEXTDKEY'
         RETURN   NEXTDKEY
DKEY65   EQU      %
         LI,R1    ERROR17           ERROR: # OF DATA ENTRIES FOUND
*                                   EXCEEDS NUMBER ANTICIPATED
*                                   CONTROL BLOCK INVALID
         CALL     ADVISE
DKEY100  EQU      %                 INCR R6 TO NEXT KEY
         LI,R0    0
         GET,R2,R4  DATANAMECNTR,R6  MUST USE EVEN REG FOR GET
         AI,R2    1                 ADD 1 FOR BYTE COUNT BYTE
*                 SKIP DATA NAME
DKEY101  EQU      %
         LI,R3    0                 ZERO FOR REMAINDER
         SLD,R2   -2                DIVIDE BYTE COUNT BY 4
         CI,R3    0                 ANY OVERFLOW
         BE       %+2               NO
         AI,R2    1                 INCREMENT TO NEXT WORD
         AW,R6    R2                NEW POSITION IN BLOCK
DKEY102  EQU      %
*                 SKIP DATA TEXT
         CI,R0    0                 2ND TIME THROUGH?
         BG       DKEY105           YES
         AI,R6    2                 ACCOUNT FOR ENTRY HDR
         LH,R2    *R6               GET BYTE COUNT OF TEXT
         AI,R2    2                 ACCOUNT FOR 2 BYTES IN HW COUNT
         LI,R0    1                 SET SENTINEL
         B        DKEY101
DKEY105  EQU      %                 FORCE DW BOUNDARY
         AI,R6    1
         AND,R6   NB31TO0+1         ROUND UP TO NEXT DW
         LW,R4    R6                CHECK FOR END OF BLOCK
         AI,R4    -DATABLK          NO. WORDS SO FAR
         SLS,R4   -1                DOUBLEWORDS USED
         CW,R4    DATA:DW           GET # AVAIL DW'S FROM ALLOCATN MAP
         BLE      DKEY50            COMPARE OK
         LI,R1    ERROR16
*                                   ERROR 16: # AVAIL DW'S IN ALLOCATION
*                                   MAP DOESN'T COMPARE W/ DATABLOCK
         CALL     ADVISE
*
         PAGE
**********************************************************************
*
*                 FINDMAP
*
*        FIND ALLOCATION MAP ENTRY ASSOCIATED WITH DATA BLOCK
*        INPUT: R13=RELATIVE BLOCK NUMBER OF DATA BLOCK
*        OUTPUT: DATA:DW=NUMBER OF DOUBLEWORDS IN USE IN A GIVEN DATA
*                 BLOCK (INCLUDING BOTH BLOCK HEADER AND ENTRIES).
*                 NOTE THAT INFORMATION IN A DATA BLOCK IS CLOSE-
*                 PACKED IN THE BLOCK>
*        REGISTERS: R1-R4,R13-R14 ARE DESTROYED
*        CALLED BY: NEXTDKEY
*
*********************************************************************
FINDMAP    ENTRY    'FIND ALLOCATION MAP ENTRY FOR DATABLOCK'
         DEBUG    'ENTERING FINDMAP'
         SW,R13   A:BLKBIAS         REMOVE BIAS OF FIRST ENTRY
         LW,R14   R13               SAVE BLOCK NUMBER
         LI,R4    0                 INDEX REG TO START OF ALLOC MAP
FINDMAP10  EQU    %
         LW,R3    ASTART,R4         PICK UP BEGINNING OF BLOCK
         GET,R2,R6   ALLBLOCKNAV,R3     # BLOCKS REPRESENTED BY THIS MAP
         SW,R13   R2                FIND OUT IF THIS BLK  HAS GIVEN BLK ALLOC EN
         BLEZ     FINDMAP20         YES
         LW,R14   R13               SAVE NEW DISPLACEMENT
         AI,R4    1                 INCR INDEX TO LOOK AT NEXT MAP
         B        FINDMAP10
FINDMAP20  EQU    %
         SLS,R3   1                 CONVERT TO HW
         AI,R3    ALLMAP(I)         HEADER FOR ALLOC BLOCK
         AW,R3    R14               DISPL INTO MAP
         LH,R2    0,R3              GET MAP ENTRY
         AND,R2   ANAV:MASK         GET RID OF ALLOCATION BITS
         STW,R2   DATA:DW           SAVE AVAIL # OF DW'S FOR LATER
         DEBUG    'EXITING FINDMAP'
         RETURN   FINDMAP
*****************************************************************
         PAGE
************************************************************************
*                                                                      *
*                 READBLOCK                                            *
*                                                                      *
*                 AN INTERNAL ROUTINE TO READ A SPECIFIED BLOCK OUT    *
*                 OF THE QUEUE FILE AND PUT IT IN THE APPROPRIATE      *
*                 BUFFER                                               *
*                                                                      *
*                 INPUT: R13 = RELATIVE BLOCK NUMBER
*                        R14 = BLOCK TYPE                              *
*                               1 FOR CONTROL                          *
*                               2 FOR INDEX CONTROL                    *
*                               3 FOR ALLOCATION                       *
*                               4 FOR INDEX                            *
*                               5 FOR DATA                             *
*                 OUTPUT: INPUT REGISTERS SAME                         *
*                        R15 = BUFFER ADDRESS                          *
*                 REGISTERS  USED: R1 IS DESTROYED                     *
*                 SUBROUTINES CALLED: ADVISE                           *
*                 CALLED BY: GETNEXTINIT, NEXTIBLK, NEXTDKEY           *
*                                                                      *
************************************************************************
*                                                                      *
READBLOCK   ENTRY    'READ SPECIFIED BLOCK INTO CORRECT BUFFER'
         DEBUG    'ENTERING READBLOCK'
*                 CHECK VALIDTY OF BLOCK NUMBER IN R13
         CI,R13   0
         BL       RBLK70
         BE       RBLK20            ZERO IS VALID
         CW,R13   BLOCKMAX
         BGE      RBLK70
RBLK20   EQU      %
         CI,R14   3                 ALLOCATION BLOCK TYPE
         BNE      RBLK40            NO
*
*                 ALLOCATION BLOCK
*                                   BUFFER ADDR IS IN ASTART(ALLOX)
         LW,R1    ALLOX
         LW,R15   ASTART,R1         INIT BUFFER ADDR
         B        RBLK60
RBLK40   EQU      %
         LW,R1    R14               INDEX TO INDEX REGISTER
         LW,R15   TYPE,R1           LOAD BUFFER ADDRESS
*
RBLK60   EQU      %
         M:READ   F:QDCB,(BUF,*R15),(BLOCK,*R13),(ERR,QERR),(ABN,QABN);
                  ,(SIZE,2048)
         DEBUG    'EXITING READBLOCK'
         RETURN   READBLOCK
*
*
QABN     EQU      %
         LI,R1    ERROR19           ERROR: ABN ENCOUNTERED ON READING QUEUE
         CALL     ADVISE
*
QERR     EQU      %
         LI,R1    ERROR1A           ERROR: ERR ON READING QUEUE
         CALL     ADVISE
RBLK70   EQU      %
         LI,R1    ERROR1E           ERROR: BLOCK # OUT OF RANGE OF FILE
         CALL     ADVISE
*
TYPE     EQU      %-1               NO TYPE(0)
         DATA     WA(CONTROLBLK)
         DATA     0                 DON'T NEED THE INDEX CONTROL BLK
         DATA     0                 NO ALLOCATION BLK ADDR VIA TYPE
         DATA     WA(INDEXBLK)
         DATA     WA(DATABLK)
*
*
         PAGE
*****************************************************************
*
*                 ERROR  TABLES
*
**************************************************************************
ERRMES   EQU      %
ERROR10  TEXTC    'CONTROL BLOCK NOT SAVED BY RECOVERY (NO TID)'
ERROR11  TEXTC    'THE QUEUE IS EMPTY'
ERROR12  TEXTC    'INVALID CONTROL BLOCK - # OF INDEX BLKS INCORRECT'
ERROR13  TEXTC    'INVALID ALLOCATION MAP - # OF INDEX KEYS INCORRECT'
ERROR14  TEXTC    'INVALID INDEX BLOCK - #DATA ENTRIES INCORRECT'
ERROR16  TEXTC    'INVALID ALLOCATION MAP - DATA SIZE INCORRECT'
ERROR17  TEXTC    'INVALID CONTROL BLOCK - # DATA ENTRIES INCORRECT'
ERROR19  TEXTC    'ABN ENCOUNTERED ON REAAING QUEUE'
ERROR1A  TEXTC    'ERROR ENCOUNTERED ON READING QUEUE'
ERROR1E  TEXTC    'BLOCK NUMBER OUT OF RANGE OF FILE IN READBLOCK'
PATCH    RES      50
         END

