         SYSTEM   BPM
         SYSTEM   SIG7FDP
         SYSTEM   TP:TPO
         SYSTEM   LP:TPOQ
         GENTABS
GOD      EQU      1
         REF      ABTCMD
         REF      QRECBUF
         REF      OPOUTX
         REF      TEMPID
         REF      F:QDCB
         REF      BUF
         REF      ERR
         REF      ABN
         REF      MASTER,SLAVE
         REF      LOCKFPT
         REF      DRX
         REF      OPOUTFPT
         DEF      QCK
DBGKEY   EQU      0
ALLRECKEY EQU     0
         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
INXCONTROLBLK  RES     512
INDEXBLK      RES      512
DATABLK  RES      512
NOIPM    TEXTC    'NO IN PROGRESS ENTRIES IN QUEUE - OK TO RESTART TP'
GOTO6    TEXTC    'DATABASE RECOVERY NEEDED * OK TO RUN PREPLOAD'
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
         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     16                CONTHTID
         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
         STW,8    TTP+14            TID
         BAL,15   SLAVE
         DO       GOD
         CAL1,7   LOCKFPT
         FIN
*  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,R4  CONTINDEXES,*R2 INIT INDEX BLOCK COUNTDOWN
         STW,R8   INDEX:CD
         GET,R8,R4 CONTENTRIES,*R2  INIT # ENTRIES QUEUED COUNTDOWN
         STW,R8   ENTRY:CD
         GET,R8,R4 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,R4   CONTNAVGRANS,*R2    INIT MAX BLOCK SIZE
         STW,R8   BLOCKMAX
         GET,R8,R4 CONTHTID,*R2     FIND OUT IF CONTROL BLK WAS SAVED
*                                   OK BY RECOVERY
         BEZ      GET200            NO
         GET,R13,R4  CONTINXCONT,*R2  YES
         LI,R6    1
         LI,R14   2                 INDEX CONTROL BLOCK TYPE
         CALL     READBLOCK
         T,R0,R4  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,R4 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,R4  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    10                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 DATA    X'00001000'
ALLT:MASK DATA    X'00002000'
ANAV:MASK DATA    X'00000FFF'
*
IKEY#    DATA     0                 INDEX KEY POSITION NUMBER
A:BLKCNT  DATA    0                 BLOCK COUNTER FOR ALLOC MAP
I:HDCNT  EQU      10                10 WORDS IN HEADER FOR INDEX BLK
IKEY:HDCNT  EQU   3                 3 WORDS IN HEADER FOR INDEX KEY
A:HW:HDCNT  EQU   10                10 HW'S IN ALLOC BLK HEADER
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
A:HDCNT  EQU      5                 # OF WORDS IN ALLOC BLK HEADER
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
         AND,R8   ALLA:MASK         IS ALLA SET ?
         BGZ      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    A:HW:HDCNT        #  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      %
         LH,R8    0,R2              RELOAD ALLMAP
         AND,R8   ALLT:MASK         IS ALLT SET (ALLT=1 FOR DATABLOCK)
         BGZ      IBLK20            YES - CONTINUE SEARCH FOR INDEX BLK
         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
         LH,R8    0,R2              RELOAD ALLMAP
         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    I:HDCNT           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,R4  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,R4 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    ERROR20           UNABLE TO FIND EXPECTED ACTIVE ENTTRY IN INDEX BLK
         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,R4 DATAFLINKR,*R6   IS THERE ANOTHER ENTRY ?
         BEZ      DKEY10            NO
         LI,R1    DATABLK
         C,R2,R4   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,R4  DATABLOCK,*R1
         C,R2,R4   INDEXHTXT,*R7    NEED TO INPUT NEW DATA BLOCK ?
         BNE      NEXTDBLK          YES
         B        DKEY40            NO
*
NEXTDBLK EQU      %
         GET,R13,R4  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    ERROR1F           SEARCHING EMPTY DATABLK
         CALL     ADVISE
DKEY40   EQU      %
         LI,R6    WA(DATABLK)+D:HDCNT DATA HDR = 2 WORDS
DKEY50   EQU      %
         GET,R2,R4  DATAENTRY#R,*R6  GET INDEX KEY POSITION
         CW,R2    IKEY#              IS IT EQUAL TO CALCULATED VALUE?
         BNE      DKEY100           NO
         GET,R2,R4  DATAINDEXR,*R6   GET INDEX BLOCK #
         LI,R3    INDEXBLK
         C,R2,R4  INDEXBLOCK,*R3     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    ERROR15           ERROR 15: 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                  TRANSFER DIVIDEND TO ODD
         XW,R2    R3
         LI,R4    4
         DW,R2    R4                DIVIDE BYTE CNT BY 4
         AW,R6    R3                ADD QUOTIENT TO INDEX
         CI,R2    0                 ANY REMAINDER ?
         BLE      DKEY102           NO
         AI,R6    1                 FORCE WORD BOUNDARY ON REMAINDER
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
         SLS,R6   -1
*                                   CK TO SEE IF BEYOND END OF BLOCK
         LW,R4    R6
         AI,R4    -DA(DATABLK)      GET # OF DW'S USED
         CW,R4    DATA:DW           GET # AVAIL DW'S FROM ALLOCATN MAP
         BLE      DKEY110           COMPARE OK
         LI,R1    ERROR16
*                                   ERROR 16: # AVAIL DW'S IN ALLOCATION
*                                   MAP DOESN'T COMPARE W/ DATABLOCK
         CALL     ADVISE
DKEY110  EQU      %                 R6 BACK TO WORD BOUNDARY
         SLS,R6   1
         B        DKEY50
*
D:HDCNT  EQU      2
         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 ENTRY
         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    A:HW:HDCNT        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
         CW,R13   BLOCKMAX
         BG       RBLK70
         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     WA(INXCONTROLBLK)
         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    'THE TOTAL # OF INDEX BLKS EXPECTED IS LESS ';
                  ,'THAN THE TOTAL NUMBER FOUND. INVALID CONTROL BLK'
ERROR13  TEXTC    '# OF ACTIVE INDEX KEYS IN INDEX BLK IS NOT';
                  ,' EQUAL TO EXPECTED # IN ALLOCATION MAP';
                  ,'INVALID ALLOCATION MAP'
ERROR14  TEXTC    'NOT ALL EXPECTED DATA ENTRIES WERE FOUND FOR';
                  ,' CURRENT INDEX KEY. INVALID INDEX BLOCK'
ERROR15  TEXTC    'MORE THEN EXPECTED # OF DATA ENTRIES WERE';
                  ,' FOUND FOR CURRENT INDEX KEY. INVALID INDEX BLOCK'
ERROR16  TEXTC    '# AVAIL. DWS FOR DATA BLOCK IN ALLOCATION';
                  ,' MAP DOES NOT EQUAL CALCULATED #.';
                  ,' INVALID ALLOCATION BLOCK'
ERROR17  TEXTC    'TOTAL # OF DATA ENTRIES FOUND EXCEEDS #';
                  ,' ANTICIPATED. INVALID CONTROL BLOCK'
ERROR18  TEXTC    ' NOT ALL ANTICIPATED DATA ENTRIES WERE FOUND.';
                  ,' INVALID CONTROL BLOCK'
ERROR19  TEXTC    'ABN ENCOUNTERED ON REAAING QUEUE'
ERROR1A  TEXTC    'ERROR ENCOUNTERED ON READING QUEUE'
ERROR1B  TEXTC    'NOT ALL INDEX BLOCKS WERE FOUND.';
                  ,'INVALID CONTROL BLOCK.'
ERROR1C  TEXTC    'ERROR WHILE TRYING TO OPEN QUEUE'
ERROR1D  TEXTC    'ABNORMAL WHILE TRYING TO OPEN QUEUE'
ERROR1E  TEXTC    'BLOCK NUMBER OUT OF RANGE OF FILE IN READBLOCK'
ERROR1F  TEXTC    'SEARCHING EMPTY DATA BLOCK FOR ENTRY - ';
                  ,'INVALID ALLOCATION BLOCK'
ERROR20  TEXTC    'UNABLE TO FIND EXPECTED ACTIVE ENTRY IN INDEX BLOCK';
                  ,' INVALID ALLOCATION BLOCK'
ERROR21  TEXTC    'UNKNOWN CODE SENT TO IPLISTWRT IN R5'
ERROR22  TEXTC    'WRITE ERROR ON F:IPLIST'
ERROR23  TEXTC    'READ ERROR ON TPFILES * RESTRORE TPFILES BEFOORE';
                  ,' RERUNNING JOB'
ERROR24  TEXTC    'TPFILES MISSING * PLEASE RESTORE THIS FILE'
ERROR25  TEXTC    'UNEXPECTED ABNORMAL ON TPFILES'
ERROR26  TEXTC    'UNEXPECTED ABNORMAL ON F:IPLIST'
ERROR27  TEXTC    'ABORTED BY OPERATOR'
PATCH    RES      20
         END

