*M*      FIXSUB   SUBROUTINES FOR FIX PROCESSOR
         CSECT    1
         PCC      0
UTSPROC  SET      1
S69PROC  SET      1
MONPROC  SET      1
DISCBPROC SET     1
         SYSTEM   UTS
         SYSTEM   BPM
         M:PT     1                 FPTS IN PROTECTED MEMORY
         SPACE    2
FIXSUB:  RES      0
         SPACE    3
*P*      NAME:         FIXSUB
*P*
*P*      PURPOSE:      VARIOUS GENERAL SUBROUTINES NEEDED BY THE
*P*                    FIX PROCESSOR.
         SPACE    3
TXTSECT  CSECT    1
TBLSECT  CSECT    1
         USECT    FIXSUB:
         SPACE    2
         TITLE    '****  CONSTANTS  ****'
         SPACE    2
R0       EQU      0
R1       EQU      1
R2       EQU      2
R3       EQU      3
R4       EQU      4
R5       EQU      5
R6       EQU      6
R7       EQU      7
R8       EQU      8
R9       EQU      9
R10      EQU      10
R11      EQU      11
R12      EQU      12
R13      EQU      13
R14      EQU      14
R15      EQU      15
         SPACE    1
C        EQU      1
EOF      EQU      2
FAK      EQU      4
         SPACE    1
DFDA     EQU      8
DDA      EQU      X'1FD'
DBLINK   EQU      X'1FE'
DFLINK   EQU      X'1FF'
DEL      EQU      X'100'
TRUNC    EQU      X'200'
NORETRY  EQU      X'400'
BADA     EQU      X'800'
KEY      EQU      X'8000'
         SPACE    1
LDAFIT   EQU      6
         TITLE    '****  ASSEMBLY SWITCHES  ****'
         SPACE    2
DEBUG    SET      1                 1 = DEBUG
         SPACE    2
LPTYPE   SET      57                CHAR SET SIZE OF LP (57 OR 63)
         SPACE    2
*  COLUMN NUMBER OF START OF HEX AND EBCDIC TRANSLATIONS
DUMP:HEX SET       7                10 FOR LARGE PAPER
DUMP:EBC SET      79                84 FOR LARGE PAPER
         TITLE    '****  EXTERNAL DEFINITIONS  ****'
         SPACE    2
         DEF      FIXSUB:           MODULE NAME FOR PATCHING
         DEF      FIXSD:            SYMBOL FOR PATCHING DATA
         DEF      DISCRD            READ DISC INTO I/O BUFFER
         DEF      DISCWRT           WRITE DISC FROM I/O BUFFER
         DEF      IOQUEUE           QUEUE I/O
         DEF      DRDWAIT           READ DISC WITH WAIT
         DEF      DWRWAIT           WRITE DISC WITH WAIT
         DEF      IORETRY           RETRY AN I/O AFTER ERROR
         DEF      IOSPIN            WAIT FOR I/O TO COMPLETE
         DEF      CHKDA             VALIDATE DISC ADDRESS
         DEF      GETOCU            BECOME OPN/CLS USER
         DEF      GETBUF            GET AN I/O BUFFER
         DEF      RELBUF            RELEASE I/O BUFFER
         DEF      ALLOCBUF          ALLOCATE CORE FOR I/O BUFFERS
         DEF      FITCHK            VALIDATE FILE FIT
         DEF      CHKCON            VALIDATE CONSEC GRANULE
         DEF      LOCCODE           FIND SPECIFIC VLP
         DEF      LOCC2             FIND VLP IN DCB
         DEF      VALBUF            VALIDATE WORDS 0-2 OF BUFFER
         DEF      FNDKEY            LOCATE KEY IN MI OR DIRECTORY
         DEF      COMKEY            COMPARE TWO KEYS
         DEF      TRUNCATE          TRUNCATE FILE OR DIRECTORY
         DEF      DELKEY            DELETE KEY
         DEF      HEX2BIN           CONVERT EBCDIC HEX TO BINARY
         DEF      DEC2BIN           CONVERT EBCDIC DECIMAL TO BINARY
         DEF      BIN2HEX           CONVERT BINARY TO EBCDIC HEX
         DEF      BIN2DEC           CONVERT BINARY TO EBCDIC DECIMAL
         DEF      MOVTXTC           MOVE TEXTC TO PRBUF
         DEF      MOVTXT            MOVE TEXT TO PRBUF
         DEF      PUTMES            MOVE TEXT TO SPECIFIC COLUMN
         DEF      PUTMESC           MOVE TEXTC TO SPECIFIC COLUMN
         DEF      PUTDECR           RIGHT JUSTIFY DECIMAL IN GIVEN COL
         DEF      PUTHEXR           RIGHT JUSTIFY HEX IN GIVEN COLUMN
         DEF      MOVDEC            CONV BIN TO EBCDIC DEC, PUT IN PRBUF
         DEF      MOVHEX            CONV BIN TO EBC HEX, PUT IN PRBUF
         DEF      DUMPBUF           DUMP PRBUF TO LP
         DEF      INITBUF           INITIALIZE PRBUF TO EMPTY
         DEF      DMPFLG            DUMP TO LP OR USER
         DEF      DUMPB             DUMP PRBUF TO USER TERMINAL
         DEF      HEXDUMP           DUMP CORE IN HEX
         DEF      HEXDUMPB          DUMP CORE IN HEX
         DEF      DOPRINT           PRINT MESSAGE ON USER TERMINAL
         DEF      PRINT             PRINT MESSAGE ON LP
         DEF      GRANERR           RETRY I/O, PRINT ERROR MESSAGE
         DEF      ERRMSG            PRINT ERROR MESSAGE
         DEF      ERRMSG1           PRINT PARTIAL ERROR MESSAGE SEQUENCE
         DEF      SNAPGRAN          SNAP BUFFER
         DEF      PRKEY             MOVE KEY TO PRBUF
         DEF      PRFILE            PRINT FILE NAME/ACCOUNT
         DEF      TRUNC10           FDA BAD - DELETE NAME FROM DIR
         DEF      NOPAGES           INSUFFICIENT CORE
         DEF      RELOCU            GIVE UP OPN/CLS USER STATUS
         DEF      FITNAME           BYTE ADDRESS OF FIT NAME
         DEF      TBLXPSD           ENTRY TO BUILD OUTPUT MESSAGES
         DEF      FLAGSDSP          DISP TO FLAGS
         DEF      SNAPGRN           DUMP GRANULE ANYWAY
         DEF      ERR#10
         DEF      ERR#11
         DEF      ERR#12
         DEF      ERR#22
         DEF      ERR#99
         DEF      ERR#02
         DEF      ERR#07
         DEF      ERR#51
         DEF      ERR#52
         DEF      ERR#53
         DEF      ERR#54
         DEF      ERR#60
         TITLE    '****  EXTERNAL REFERENCES  ****'
         REF      ADINIT            SET POINTERS FOR ACCOUNT DIRECTORY
         REF      ALLOCG            ALLOCATE GRANULE IN BIT MAP
         REF      ALLOCKD           ALLOCATE KEYED DATA GRANULE
         REF      BADDA             BAD DISC ADDRESS
         REF      BOOTFLG           ZERO IF NOT PUBLIC HGP RECON
         REF      BT31TO0           TABLE OF BITS SET
         REF      BUFADR            I/O BUFFER ADDRESS
         REF      BUFCNT            # I/O BUFFERS ALLOCATED
         REF      BUFCODE           I/O BUFFER FUNCTION CODE
         REF      BUFDA             I/O BUFFER DISC ADDRESS
         REF      BUFDACHK          I/O BUFFER LINK CHECK DISC ADDR
         REF      BUFDUAL           I/O BUFFER DUAL DISC ADDRESS
         REF      BUFERR            NO BUFFERS LEFT
         REF      BUFINFO           I/O BUFFER ERROR CODE
         REF      BUFLINK           I/O BUFFER LINK TO NEXT BUFFER
         REF      BUFMAX            MAX # I/O BUFFERS TO GET
         REF      BUFMIN            MIN # I/O BUFFERS NEEDED
         REF      BUFNRT            # RETRIES FOR I/O BUFFER
         REF      BUFREE            I/O BUFFER FREE CHAIN
         REF      BUFTYPE           I/O BUFFER TYPE
         REF      CMDL              CURRENT DISPL INTO MI
         REF      CORESDCB          ZERO IF ECHODCB, M:LO NOT SAME DEV
         REF      CURACCT           CURRENT ACCOUNT
         REF      CURFILE           CURRENT FILE NAME
         REF      CURMES            CURRENT MESSAGE ADDRESS
         REF      DCTX              CONVERT VOL # TO DCT INDEX
         REF      DIRBUF            BUFFER CONTAINING DIRECTORY
         REF      DIRCMD            DISPL INTO DIRECTORY GRANULE
         REF      DISPFLG           SET IF USER PRESSED BREAK KEY
         REF      DUMPFLAG          SET IF DUMP COMMAND
         REF      E:CBK             EVENT:  COC BREAK
         REF      E:IC              EVENT:  INPUT COMPLETE
         REF      E:OCR             EVENT:  QUEUE FOR OPN/CLS USER
         REF      E:SL              EVENT:  SLEEP
         REF      EASPD             ADDR OF END-ACT STACK
         REF      ECHODCB           DCB FOR WRITING TO USER
         REF      ENVSIZE           SIZE OF ENVIRONMENT IN TCB
         REF      ERRCNT            # ERRORS ENCOUNTERED
         REF      ERRCODE           LAST ERROR # ENCOUNTERED
         REF      FDINIT            SET POINTERS FOR FILE DIRECTORY
         REF      FILCFU            CFU FOR READING FILE DIRECTORY
         REF      FITFLAG           SET IF ONLY FIT TO BE READ
         REF      FITVLPX           ADDR OF FIT VLPS
         REF      FIXFLAG           SET IF ERRORS TO BE FIXED
         REF      FL:DUAL           FLAG:  DUAL WAS READ
         REF      FL:EA             FLAG:  END-ACTION MUST BE DONE
         REF      FL:IOP            FLAG:  I/O IN PROGRESS
         REF      FL:SNAP           FLAG:  BUFFER HAS BEEN SNAPPED
         REF      FL:UPDT           FLAG:  BUFFER IS UPDATED
         REF      FLR:DUAL          MASK:  RESET FL:DUAL
         REF      FLR:EA            MASK:  RESET FL:EA
         REF      FLR:SNAP          MASK:  RESET FL:SNAP
         REF      FNDHGP1
         REF      HGP               CHECK DA FOR CYL DEVICE
         REF      GBG               GET GRANULE
         REF      GMB               GET MPOOL BUFFER
         REF      HGPRFLAG          SET IF DOING HGP RECON
         REF      INTADR2           SIMULATE BREAK INTERRUPT
         REF      IOCNT             # I/OS OUTSTANDING
         REF      J:JIT             JIT ADDRESS
         REF      J:TCB             TCB ADDRESS
         REF      KEYLEVEL          EXPECTED MI LEVEL
         REF      KEYSIZE           SIZE OF KEY
         REF      LINKFLAG          SET IF TO DO LINK CHECKING
         REF      LOCDA             DISC ADDRESS OF KEY FOUND
         REF      LOCDUAL           DUAL OF KEY FOUND
         REF      LPBUF             PRINTER I/O BUFFER
         REF      LPCNT             # PRINTER I/O'S OUTSTANDING
         REF      LPDCTX            DCT INDEX OF LINE PRINTER
         REF      LPFLAG            M:WRITE, DIRECT PRINTER I/O, NO I/O
         REF      LPIO              QUEUE AN LP I/O
         REF      LPNXT             NEXT PRINTER BUFFER TO USE
         REF      M:LO
         REF      MPOOLADR          I/O END-ACTION MPOOL ADDRESS
         REF      NEWQNWM           QUEUE I/O, NO WAIT
         REF      OPNCLSUS          CURRENT OPN/CLS USER
         REF      ORGL              ORGANIZATION OF CURRENT FILE
         REF      GAVALC            GRAN/CYL IN GAVAL DEVICE
         REF      GAVALL            CURRENT GAVAL/NGAVAL INFO
         REF      CCBDL             CURRENT MAX DISP INTO SRECLL
         REF      SRECL             SREC FROM FIT
         REF      EOFCMD            DISP OF LAST EOF FLAG
         REF      EOFDA             DISC ADDR OF LAST EOF BIT
         REF      PRBUF             BUFFER TO BUILD MESSAGES
         REF      PREVBUF           # OF BUFFER CONTAINING BLINK
         REF      PRPOS             CURRENT POSITION IN PRBUF
         REF      PVCHKDA           VALIDATE PRIVATE PACK DISC ADDR
         REF      QUEUE             QUEUE I/O VIA DCB
         SREF     RA:DA             READ-AHEAD TABLES, DISC ADDR
         SREF     RAB:BLINK         LINK OF ACTIVE READ-AHEAD ENTRIES
         REF      S:CUN             CURRENT USER #
         REF      SCRL              MAX KEY LENGTH
         REF      SIOMF             STATE:  MASTER FUNC TOO HIGH
         REF      SIOW              STATE:  WAIT FOR I/O COMPLETE
         REF      SN                SERIAL #
         REF      SNAPDAT           DUMP FIX DATA IN HEX
         REF      SPD               INTERNAL TSTACK ADDRESS
         REF      SPINCNT           # I/O WAIT EVENTS
         REF      SPINCNTT          # TIMES IOSPIN CALLED
         REF      SRCHKEY           KEY FOR FNDKEY TO FIND
         REF      SYNFLAG           SET IF CHECKING SYNON FILE
         SREF     T:RAREL           RELEASE READ-AHEAD ENTRY
         REF      T:REG             REPORT EVENT, GIVE UP CONTROL
         REF      T:RUE             REPORT USER EVENT
         REF      T:UBLKOCU         RELEASE OPN/CLS USER STATUS
         REF      TEMP              16 WORDS TEMP STORAGE
         REF      TSTACK            TEMP STACK IN JIT
         REF      TYPCUR            CURRENT # BUFFERS IN USE
         REF      TYPEFLAG          AD, FD OR FILE FLAG
         REF      TYPMAX            MAX # BUFFERS THAT MAY BE USED
         REF      U:MISC            MISC USER TABLE
         REF      UB:MF             I/O COUNT
         REF      UB:US             USER STATE
         REF      UH:DL             CHECK FOR IOINT WHILE IN IOQ
         REF      UH:FLG            USER FLAGS
         REF      VLP09             ADDR OF FIT X'09' VLP
         REF      VLP0C             ADDR OF FIT X'0C' VLP
         REF      VLP0D             ADDR OF FIT X'0D' VLP
         REF      #BUF              SIZE OF BUF TABLES
         REF      #EASTACK          SIZE OF END-ACTION STACK
         REF      #INTLOST          # INTERRUPTS LOST
         REF      #IO               # I/O'S QUEUED
         REF      #READS            # DISC READS
         REF      #RECS1            TEMP # RECORDS IN THIS GRANULE
         TITLE    '****  PROCS  ****'
         SPACE    2
         CLOSE    NXTF
         CLOSE    PUSH,PULL
PUSH     CNAME    X'09',X'0B'
PULL     CNAME    X'08',X'0A'
         PROC
LF       EQU      %
         DO1      NUM(AF)>1
         LCI      AF(1)&X'F'
         GEN,8,4,20  NAME(NUM(AF)),AF(NUM(AF)),SPD
         PEND
         SPACE    2
ERR      CNAME
         PROC
#ERR     SET      #ERR+1
LF       SET      AF(1)
         DISP     LF
         DO1      NUM(AF)=2
         GEN,8,5,19  AF(1)&X'FF',0,BA(AF(2))
         PEND
         SPACE    2
SNAP     CNAME    0
SNAPX    CNAME    1
         PROC
LF       PUSH     R4
         BAL,R4   SNAPDAT
         DO       TCOR(AF,S:C)=1
         TEXTC    AF
         ELSE
         DATA     AF
         FIN
         DO1      NAME=1
         M:XXX
         PEND
         SPACE    2
BUILD    CNAME
         PROC
         LOCAL    MAIN,TBL,TYPE,ADDR
LF(1)    SET      %
MAIN     SET      %
         DO       SCOR(CF(2),E)
TBL      SET      AF
         ELSE
         USECT    TBLSECT
TBL      SET      %
LF(2-SCOR(CF(2),L))  SET  %
*
I        DO       NUM(AF)           PROCESS ALL AF ENTRIES
TYPE     SET      SCOR(AF(I,1),TEXT,HEX,DEC,RHEX,RDEC,SPACE,;
                  TXT,FILL,DUMPBUF,DUMPB,DUMPECHO)
ADDR     SET      S:UFV(AF(I,2))
         DO       TYPE=1&TCOR(AF(I,2),S:C)=1
         USECT    TXTSECT
ADDR     SET      %
         TEXTC    AF(I,2)           GENERATE THE SPECIFIED TEXT
         USECT    TBLSECT
         FIN
         DO1      TYPE=8
ADDR     SET      AF(I,2)+(AF(I,4)-AF(I,3))**8
*
         GEN,1,7,4,1,19  AFA(I,2),AF(I,3),TYPE,I=NUM(AF),ADDR
*
         FIN
*
         USECT    MAIN
         FIN
         DO       SCOR(CF(2),L)=0
         XPSD,2   TBLXPSD
         DATA     TBL
         FIN
         PEND
         SPACE    2
         TITLE    '****  DISCRD, DISCWRT  ****'
         SPACE    2
*F*  NAME:         DISCRD
*F*  ENTRY:        DISCWRT
*F*
*F*  PURPOSE:      READ AND WRITE DISC NO-WAIT
*F*
*F*  DESCRIPTION:  THE I/O IS QUEUED VIA NEWQNWM WITH END-ACTION.  ALL
*F*                INFORMATION FOR THE I/O REQUEST IS CONTAINED IN THE
*F*                BUF TABLES.  AT I/O COMPLETE, ANY REQUESTED
*F*                OPERATIONS ARE PERFORMED AND THE BUF TABLE ENTRY
*F*                IS MARKED COMPLETED.
         SPACE    2
*D*  NAME:         DISCRD
*D*  ENTRY:        DISCWRT
*D*
*D*  REGISTERS:    ALL PRESERVED EXCEPT R2
*D*
*D*  CALL:         BAL,R11
*D*
*D*  INTERFACE:    PVCHKDA, T:RAREL, GMB, NEWQNWM
*D*
*D*  DATA:         THE BUF TABLES ARE USED TO PASS IN INFORMATION
*D*                ABOUT THE I/O TO BE QUEUED, AND ARE MODIFIED
*D*                AS APPROPRIATE.
*D*
*D*  INPUT:        R7 = BUF TABLE INDEX
*D*
*D*  DESCRIPTION:  R7 POINTS TO A BUF TABLE ENTRY WHICH CONTAINS:
*D*                  BUFDA - DISC ADDRESS TO QUEUE
*D*                  BUFDUAL - DUAL DISC ADDRESS
*D*                  BUFCODE - STORES IN HERE THE FUNCTION CODE
*D*                  BUFNRT - RETRY COUNT (SET TO 4 UPON ENTRY)
*D*                  BUFINFO - END-ACTION ERROR CODE (SET TO ZERO)
*D*                  BUFADR - VIRTUAL ADDRESS OF I/O BUFFER
*D*
*D*                ALL FLAGS IN BUFDA EXCEPT FL:DUAL ARE RESET.
*D*                THE DISC ADDRESS TO QUEUE IS OBTAINED FROM BUFDA,
*D*                OR FROM BUFDUAL IF FL:DUAL IS SET.  THE DISC
*D*                ADDRESS IS VALIDATED VIA PVCHKDA AFTER CONVERTING
*D*                THE PRIVATE VOL # TO DCT INDEX.  THE READ-AHEAD
*D*                TABLES ARE SEARCHED (IF PRESENT) TO DETERMINE IF
*D*                THIS DISC ADDRESS IS CONTAINED THEREIN.  IF SO,
*D*                THAT ENTRY IN THE TABLES IS RELEASED VIA T:RAREL.
*D*                IF AN MPOOL BUFFER HAS NOT ALREADY BEEN OBTAINED,
*D*                ONE IS GOTTEN VIA GMB AND THE END-ACTION ROUTINE
*D*                MOVED INTO IT AND RELOCATED (FIX HAS ONLY ONE
*D*                MPOOL BUFFER AT A TIME).  THE USER'S UB:MF
*D*                (COUNT OF # OF OUTSTANDING I/O'S) IS INCREMENTED
*D*                BY ONE.  THE I/O IS QUEUED VIA NEWQNWM, AND THE
*D*                ROUTINE EXITS NORMALLY.
*D*
*D*                THIS ROUTINE WILL ABORT FIX AND PRODUCE A DUMP
*D*                OF FIX'S DATA IF ANY OF THE FOLLOWING ERRORS OCCUR:
*D*                  1 - THE DISC ADDRESS IS INVALID
*D*                  2 - THE BUFFER ADDRESS IN BUFADR IS BELOW X'A000'
*D*                  3 - NEWQNWM RETURNS +1, INDICATING THE
*D*                      DEVICE IS DOWN
         SPACE    1
DISCRD   LI,R2    0                 READ FUNCTION CODE
         B        %+2
DISCWRT  LI,R2    1                 WRITE FUNCTION CODE
         STB,R2   BUFCODE,R7        SAVE FUNCTION CODE
DISCIOA  LI,R2    4
         STB,R2   BUFNRT,R7         SET # RETRIES
*
DISCIO   PUSH     15,R3
         AI,R7    0
         BLEZ     BADBUF            BAD BUF TABLE INDEX
         CW,R7    BUFMAX
         BG       BADBUF            BAD BUF TABLE INDEX
*
         LI,R12   0
         STW,R12  BUFINFO,R7        ZERO INFO WORD
         LW,R9    FL:DUAL           SAVE STATUS OF DUAL FLAG
         AND,R9   BUFDA,R7
         LW,R8    M24
         AND,R8   BUFDA,R7          DISC ADDRESS
         OR,R8    FL:IOP            SET I/O IN PROGRESS
         OR,R8    R9                SET FL:DUAL IF SET BEFORE
         STW,R8   BUFDA,R7          RESET ALL OTHER FLAGS
         CW,R8    FL:DUAL           SHOULD DUAL BE READ
         BAZ      %+2               NO
         LW,R8    BUFDUAL,R7        YES - GET DUAL DISC ADDRESS
         LDCTX,R2 R8
         LB,R4    DCTX,R2           CONVERT VOL # TO DCT INDEX
         LW,R12   R4
         STDCTX,R4  R8              CONVERT TO PUBLIC FORMAT
         BAL,R6   PVCHKDA
         BCS,15   DAOK
         SNAPX    'BAD DA'
*
DAOK     EQU      %
         LI,R5    T:RAREL
         BEZ      RA40              DON'T CHECK FOR READ-AHEAD
         LW,R9    M24
         PUSH     6,R7
RA10     LI,R7    0
         DISABLE                    **** DISABLE
RA20     LB,R7    RAB:BLINK,R7      GET NEXT ENTRY ON ACTIVE CHAIN
         BEZ      RA30              END OF CHAIN
         CS,R8    RA:DA,R7          IS IT FOR THE DISC ADDRESS
         BNE      RA20              NO
         BAL,R10  T:RAREL           YES - RELEASE READ-AHEAD ENTRY
         B        RA10              SEARCH CHAIN FROM BEGINNING
RA30     ENABLE                     ****  ENABLE
         PULL     6,R7
RA40     EQU      %
*
         LB,R2    BUFCODE,R7        FUNCTION CODE
         LW,R13   BUFADR,R7         BUFFER ADDRESS
         CI,R13   X'A000'
         BL       BADADR            BAD BUFFER ADDRESS
         SLS,R13  2                 BYTE ADDRESS
         LI,R14   2048              BYTE COUNT
         CI,R8    1
         BAZ      %+2               FULL GRANULE
         LI,R14   1024              HALF GRANULE
         LW,R15   R8                MOVE DISC ADDRESS
*
IOQ10    LW,R0    MPOOLADR          IS THERE AN MPOOL
         BNEZ     IOQ50             YES
         PUSH     5,R14
IOQ20    BAL,R11  GMB               GET AN MPOOL
         BNEZ     IOQ30             GOT ONE
         M:WAIT   1
         B        IOQ20             TRY AGAIN
*
IOQ30    STW,R14  MPOOLADR
         LW,R15   MPOOLADR          ADDRESS OF MPOOL
         LI,R14   UNMAPEA           ADDRESS OF END-ACTION ROUTINE
         SLD,R14  2
         LI,R2    #UNMAPEA*4        # BYTES TO MOVE
         STB,R2   R15
         MBS,R14  0                 MOVE ROUTINE TO MPOOL
         LW,R2    MPOOLADR
         AWM,R2   UNREL1,R2         RELOCATE SOME ADDRESSES
         AWM,R2   EASTACK,R2
         AI,R2    EASTACK
         STW,R2   EASPD             ADDRESS OF STACK IN MPOOL
         PULL     5,R14
         LW,R0    MPOOLADR
*
IOQ50    OR,R12   =X'200A00'        PRIO=20, NRT=A
         STB,R2   R12               FUNCTION CODE
         LW,R5    S:CUN
         MTB,1    UB:MF,R5          INCCR FUNCTION COUNT
         LW,R1    R7
         STB,R5   R1                END-ACTION INFO
         MTW,1    IOCNT             INCR # I/O OPERATIONS
         MTW,1    #IO               COUNT # I/O OPERATIONS QUEUED
         MTW,0    #IO
         BGEZ     %-1               TOO MANY - WAIT FOR ONE TO COMPLETE
         BAL,R11  NEWQNWM           QUEUE THE I/O
         B        DISCIO6           DEVICE DOWN
         DISABLE
         LW,R3    S:CUN             DID WE GET INTERRUPT
         LH,R3    UH:DL,R3          WHILE IN ROOT
         BEZ      %+2               NO, DONT GO DO IT
         BAL,R15  REL70
         ENABLE
         PULL     15,R3
         B        *R11
         SPACE    3
*D*  NAME:         IOQUEUE
*D*
*D*  REGISTERS:    ALL PRESERVED
*D*
*D*  CALL:         BAL,R11
*D*
*D*  INPUT:        R2 = FUNCTION CODE (FOR NEWQNWM)
*D*                R7 = BUF TABLE INDEX OR SPECIAL CODE
*D*                R12 = DCT INDEX
*D*                R13 = BA OF VIRTUAL BUFFER
*D*                R14 = BYTE COUNT
*D*                R15 = DISC ADDRESS
*D*
*D*  DESCRIPTION:  QUEUE I/O TO ANY DEVICE.  USES MOST OF THE
*D*                CODE IN DISCRD/DISCWRT, EXCEPT THE INPUT
*D*                ARGUMENTS ARE IN THE REGISTERS INSTEAD OF IN
*D*                THE BUF TABLES.  NOTE, HOWEVER, THAT R7 MUST HAVE
*D*                EITHER A BUF TABLE INDEX OR A SPECIAL CODE THAT
*D*                IS RECOGNIZED BY THE END-ACTION ROUTINE.
         SPACE    1
IOQUEUE  PUSH     15,R3
         B        IOQ10
         SPACE    3
*
DISCIO6  LW,R5    S:CUN             DEVICE DOWN
         MTB,-1   UB:MF,R5
         SNAPX    'DEV DOWN'
*
BADBUF   SNAPX    'BAD BUFFER INDEX'
BADADR   SNAPX    'BAD BUFFER ADDRESS'
         TITLE    '****  UNMAPPED END-ACTION  ****'
         SPACE    2
*D*  NAME:         UNMAPEA
*D*
*D*  REGISTERS:    ALL VOLATILE EXCEPT R11
*D*
*D*  CALL:         BAL,R11  (FROM IOQ)
*D*
*D*  INTERFACE:    T:RUE
*D*
*D*  ENVIRONMENT:  UNMAPPED MASTER
*D*
*D*  INPUT:        R14 = END-ACTION INFORMATION
*D*                      BYTE 0 = USER # OF FIX
*D*                      BYTE 3 = BUF TABLE INDEX
*D*
*D*  OUTPUT:       ONE WORD IS PUSHED INTO THE STACK IN THE MPOOL:
*D*                  BYTE 0 = TYC
*D*                  BYTE 1 = BUF TABLE INDEX
*D*                  HW 1 = REMAINING BYTE COUNT
*D*
*D*  DESCRIPTION:  THIS IS THE END-ACTION I/O ROUTINE FOR DISCRD/
*D*                DISCWRT.  IT RESIDES IN AN MPOOL BUFFER IN THE
*D*                MONITOR ROOT.  BESIDES CODE, THE MPOOL CONTAINS
*D*                A STACK INTO WHICH IS PUSHED ONE WORD PER I/O
*D*                COMPLETION.  THAT WORD IS LATER PULLED OUT BY
*D*                THE MAPPED END-ACTION ROUTINE.
*D*
*D*                THE ROUTINE FIRST REPORTS E:CBK (BREAK EVENT) FOR
*D*                FIX.  THE NEXT TIME FIX IS SCHEDULED, IT WILL
*D*                BE TRAPPED TO ITS M:INT ROUTINE (THE MAPPED
*D*                END-ACTION ROUTINE).  FIX'S STATE IS THEN CHECKED.
*D*                IF IT IS EITHER SIOMF (WAITING FOR UB:MF TO FALL
*D*                BELOW THE MAX THRESHOLD) OR SIOW (WAITING FOR AN
*D*                I/O TO COMPLETE), E:IC (I/O COMPLETE) IS REPORTED
*D*                TO CAUSE FIX TO BE SCHEDULED.  OTHERWISE, NOTHING
*D*                IS DONE AND THE ROUTINE EXITS BACK INTO IOQ.
         SPACE    1
         BOUND    8
UNMAPEA  PSW,R11  TSTACK
         LB,R5    R14               USER #
         STB,R5   *TSTACK           SAVE USER #
         LB,R2    R12               TYC
         STH,R14  R12               PUT IN EAI
         STB,R2   R12               RESTORE TYC
UNREL1   EQU      %-UNMAPEA
         PSW,R12  EASTACK           SAVE IN STACK
         LI,R6    E:CBK
         BAL,R11  T:RUE             REPORT BREAK EVENT
         PLW,R11  TSTACK            RETURN ADDRESS
         LB,R5    R11               RESTORE USER #
         LI,R6    E:IC              I/O COMPLETE EVENT
         LB,R14   UB:US,R5          USER'S CURRENT STATE
         CI,R14   SIOMF
         BE       T:RUE
         CI,R14   SIOW
         BE       T:RUE
         MTB,-1   UB:MF,R5          DECREMENT I/O COUNT
         B        *R11              DON'T REPORT ANYTHING
         BOUND    8
EASTACK  EQU      %-UNMAPEA
         DATA     EASTACK+1         SPD
         GEN,1,15,1,15  1,#EASTACK,1,0
#UNMAPEA EQU      %-UNMAPEA         # WORDS TO MOVE TO MPOOL
         TITLE    '****  DRDWAIT/DWRWAIT  ****'
         SPACE    2
*F*  NAME:         DRDWAIT
*F*  ENTRY:        DWRWAIT
*F*
*F*  PURPOSE:      READ AND WRITE DISC WITH WAIT
*F*
*F*  DESCRIPTION:  THE I/O IS QUEUED VIA QUEUE, AND THE ROUTINE
*F*                SPINS UNTIL DCB:FCN GOES TO ZERO (I/O COMPLETE).
*F*                THE CALLER IS INFORMED OF ANY ERRORS (BAD DISC
*F*                ADDRESS OR I/O ERROR).
         SPACE    2
*D*  NAME:         DRDWAIT
*D*  ENTRY:        DWRWAIT
*D*
*D*  REGISTERS:    ALL BUT R15 PRESERVED
*D*
*D*  CALL:         BAL,R11
*D*
*D*  INTERFACE:    QUEUE, PVCHKDA
*D*
*D*  INPUT:        R2 = # WORDS TO READ/WRITE
*D*                R7 = BUFFER VIRTUAL WORD ADDRESS
*D*                R8 = DISC ADDRESS
*D*
*D*  OUTPUT:       R15 = 0  NORMAL COMPLETION
*D*                    = 1  I/O ERROR
*D*                    = 2  BAD DISC ADDRESS
*D*                CONDITION CODES ARE SET TO INDICATE R15 STATUS.
*D*
*D*  DESCRIPTION:  THE WORD COUNT IS CHANGED TO BYTE COUNT AND PLACED
*D*                IN DCB:BLK.  THE BUFFER ADDRESS AND DISC
*D*                ADDRESS ARE PLACED IN DCB:QBUF AND DCB:CDA.
*D*                DCB:FCN (# I/O'S OUTSTANDING) IS INCREMENTED
*D*                AND QUEUE IS CALLED.  THE ROUTINE SPINS WAITING
*D*                FOR I/O COMPLETION BY CHECKING FOR DCB:FCN
*D*                TO GO TO ZERO.
         SPACE    1
DRDWAIT  PUSH     15,R0
         LI,R9    0                 READ FUNCTION CODE
         B        DIO10
DWRWAIT  PUSH     15,R0
         LI,R9    6                 WRITE FUNCTION CODE
*
DIO10    SLS,R2   2                 # BYTES TO READ
         LI,R3    X'7FFF'
         SLD,R2   17
         STS,R2   BLK+DISCDCB       BYTE COUNT
         STW,R7   QBUF+DISCDCB      BUFFER ADDRESS
         AI,R9    0
         BNE      DIO20             BR IF NOT READ
         LI,R11   X'40404'          PUT IDENTIFIABLE DATA IN BUFFER
         STW,R11  0,R7                IN CASE I/O FAILS
*
DIO20    LW,R2    Y0A               NRA=10, TYC=0
         STW,R2   NRA+DISCDCB
*
         LI,R15   2                 ERROR CODE FOR BAD DISC ADDRESS
         LDCTX,R4 R8
         BAL,R6   PVCHKDA           VALIDATE DISK ADDRESS
         BCR,15   DIO50             ERROR
         STW,R8   CDA+DISCDCB
         MTW,1    #READS
         LW,R11   Y01               INCR FUNCTION COUNT
         AWM,R11  FCN+DISCDCB
         LI,R8    DISCDCB           DCB ADDRESS
         STB,R9   R8                FUNCTION CODE
         BAL,R11  QUEUE             QUEUE THE I/O
         MTB,0    DISCDCB+FCN
         BNEZ     %-1               WAIT FOR I/O TO COMPLETE
*
         LI,R15   0                 ASSUME NORMAL COMPLETION
         LW,R8    TYC+DISCDCB
         SLS,R8   -17
         AND,R8   M7                ISOLATE TYC
         CI,R8    1
         BE       DIOXIT            NO ERRORS
         BAL,R1   IOERR             DUMP ERRLOG ON LP
         LI,R15   1                 I/O ERROR
DIO50    EQU      %
DIOXIT   PULL     15,R0
         AI,R15   0
         B        *R11
         TITLE    '****  IOERR  ****'
         SPACE    2
*D*  NAME:         IOERR
*D*
*D*  REGISTERS:    R7, R15 PRESERVED
*D*
*D*  CALL:         BAL,R1
*D*
*D*  DESCRIPTION:  IF PUBLIC HGP RECONSTRUCTION IS IN PROGRESS,
*D*                READ AND DUMP TO LP THE ERROR LOG.
         SPACE    1
IOERR    MTW,0    BOOTFLG
         BEZ      0,R1              NOT HGP RECON
         M:GP     1
         BCS,8    0,R1              CAN'T GET PAGE
         STW,R9   ELOGFPT
IOERR1   CAL1,6   ELOGFPT           READ NEXT ERRLOG BUFFER
         BCS,13   IOERRX            NO MORE
         LI,R5    3                 INDEX TO FIRST ENTRY
         B        IOERR5
*
IOERR2   LW,R13   *ELOGFPT,R5       GET NEXT CONTROL WORD
         LH,R13   R13
         AND,R13  M8                # WORDS IN ENTRY
         CI,R13   30
         BG       IOERR1            PROBABLY BAD - IGNORE BUFFER
         LI,R14   MERLOG
         BAL,R15  PRINT             HEADER MESSAGE
         LW,R12   ELOGFPT
         AW,R12   R5
         LI,R14   0
         BAL,R11  HEXDUMP
         AW,R5    R13               ADVANCE TO NEXT ENTRY
IOERR5   LW,R2    ELOGFPT
         CW,R5    2,R2
         BL       IOERR2            BUFFER NOT EMPTY
         B        IOERR1
IOERRX   M:FP     1
         B        0,R1
         TITLE    '****  IORETRY  ****'
         SPACE    2
*F*  NAME:         IORETRY
*F*
*F*  PURPOSE:      RETRY AN I/O IF MAX # RETRIES ARE NOT EXHAUSTED
*F*
*F*  DESCRIPTION:  ANY LINKED BUFFERS ARE RELEASED.  IF THE CURRENT
*F*                BUFFER IS UPDATED, NOTHING IS DONE.  IF MAX NUMBER
*F*                OF RETRIES HAVE NOT BEEN PERFORMED, AN
*F*                I/O IS QUEUED.
         SPACE    2
*D*  NAME:         IORETRY
*D*
*D*  REGISTERS:    ALL VOLATILE EXCEPT R7
*D*
*D*  CALL:         BAL,R10
*D*
*D*  INTERFACE:    DISCIO
*D*
*D*  INPUT:        R7 = BUF TABLE INDEX OF ENTRY TO RETRY
*D*
*D*  OUTPUT:       CC SET FOR BEZ IF RETRIES EXHAUSTED
*D*                CC SET FOR BNEZ IF RETRY I/O WAS QUEUED
*D*
*D*  DESCRIPTION:  ALL BUFFERS LINKED THRU BUFLINK ARE RELEASED.
*D*                EXIT IF NO RETRIES REMAIN (BUFNRT = 0).
*D*                DECREMENT BUFNRT.  IF BUFFER IS UPDATED, SET
*D*                BUFNRT TO ZERO AND EXIT.  QUEUE UP AN I/O VIA
*D*                DISCIO (ENTRY INTO DISCRD/DISCWRT WHICH TAKES
*D*                FUNCTION CODE FROM BUFCODE).
         SPACE    1
IORETRY  EQU      %
         LI,R8    0
         XW,R8    TYPMAX            SET MAX # BUFFERS TO ZERO
         PUSH     4,R7
         LI,R8    0
         LB,R6    BUFLINK,R7        NEXT BUFFER
         STB,R8   BUFLINK,R7        ZAP LINK
         LW,R7    R6                NO MORE LINKED BUFFERS
         BEZ      IORET8              DIRECTION
IORET4   BAL,R11  IOSPIN
         LB,R6    BUFLINK,R7        NEXT BUFFER
         BAL,R15  RELBUF            RELEASE CURRENT
         LW,R7    R6                NEXT BUFFER
         BNEZ     IORET4            THERE IS ONE
IORET8   PULL     4,R7
         STW,R8   TYPMAX            RESTORE MAX # BUFFERS
IORET9   MTB,0    BUFNRT,R7
         BEZ      *R10              NO MORE RETRIES
         MTB,-1   BUFNRT,R7         DECR # RETRIES REMAINING
         LW,R11   FL:UPDT
         CW,R11   BUFDA,R7
         BANZ     IORET9            DON'T READ IF UPDATED
         BAL,R11  DISCIO            RE-QUEUE THE I/O
         LCI      15
         B        *R10
         TITLE    '****  IOSPIN  ****'
         SPACE    2
*F*  NAME:         IOSPIN
*F*
*F*  PURPOSE:      WAIT FOR I/O QUEUED VIA DISCRD/DISCWRT/IOQUEUE
*F*                TO COMPLETE
*F*
*F*  DESCRIPTION:  IF THE I/O ON THE BUFFER HAS NOT ALREADY COMPLETED,
*F*                THE USER IS PUT TO SLEEP FOR ONE UNIT (1.2 SEC).
*F*                THE ABOVE PROCESS REPEATS UNTIL THE I/O COMPLETES.
         SPACE    1
*D*  NAME:         IOSPIN
*D*
*D*  REGISTERS:    R1 VOLATILE
*D*
*D*  CALL:         BAL,R11
*D*
*D*  INTERFACE:    T:REG
*D*
*D*  INPUT:        R7 = BUF TABLE INDEX
*D*
*D*  DESCRIPTION:  IF FL:IOP NOT SET IN BUFDA, RETURN.  OTHERWISE,
*D*                CALL T:REG TO SLEEP FOR 1.2 SECONDS.  EACH
*D*                TIME WAKE UP FROM T:REG CALL, CHECK IF ANYTHING
*D*                IN MPOOL BUFFER STACK.  IF SO, CALL REL70 TO
*D*                PERFORM END-ACTION PROCESSING.  FIX WILL NOT
*D*                BE SENT TO M:INT ADDRESS EXCEPT AT CAL
*D*                EXIT TIME, SO IF AN I/O COMPLETES WHILE IN IOSPIN
*D*                WILL NEVER MAKE IT TO M:INT ROUTINE TO PROCCESS IT.
         SPACE    1
IOSPIN   EQU      %
         MTW,1    SPINCNTT          INCR # CALLS TO IOSPIN
         LW,R1    FL:IOP
         PUSH     7,R5              SAVE REGS
         M:SYS                      RUU THRU SCHED FOR INT IN SIMULATOR
         DISABLE                    **** DISABLE
         CW,R1    BUFDA,R7
         BAZ      IOSPIN8           NO I/O IN PROGRESS
         MTW,1    SPINCNT           COUNT # IOSPINS
IOSPIN4  LW,R5    S:CUN
         LI,R6    1
         STW,R6   U:MISC,R5         SLEEP PERIOD = 1.2 SECONDS
         LI,R6    E:SL
         BAL,R11  T:REG             GO TO SLEEP
         CW,R1    BUFDA,R7          DID WE DO THE END-ACTION
         BANZ     IOSPIN4           NO - WAIT SOME MORE
*
IOSPIN8  PULL     7,R5
IOSPRET  ENABLE                     **** ENABLE
         B        *R11
         TITLE    '****  CHKDA  ****'
         SPACE    2
*F*  NAME:         CHKDA
*F*
*F*  PURPOSE:      VALIDATE A DISC ADDRESS
*F*
*F*  DESCRIPTION:  THE DISC ADDRESS IS VALIDATED - THE DCT INDEX MUST
*F*                BE FOR A DISC TYPE DEVICE, AND THE RELATIVE SECTOR
*F*                MUST BE WITHIN THE DEVICE SIZE.
         SPACE    2
*D*  NAME:         CHKDA
*D*
*D*  REGISTERS:    ALL PRESERVED
*D*
*D*  CALL:         BAL,R11
*D*
*D*  INTERFACE:    PVCHKDA
*D*
*D*  INPUT:        R8 = DISC ADDRESS (EITHER PUBLIC OR PRIVATE)
*D*
*D*  OUTPUT:       CC = 0 IF ERROR
*D*                CC NOT ZERO IF NO ERROR
*D*
*D*  DESCRIPTION:  THE DCTX/VOL # IS TRANSLATED TO A DCT INDEX BY
*D*                TABLE DCTX (FOR PUBLIC, THE TABLE IS SET UP 1 TO 1).
*D*                THE RESULTING DCTX AND RELATIVE SECTOR ARE CHECKED
*D*                BY PVCHKDA (IN IOQ).
         SPACE    1
CHKDA    PUSH     4,R4
         LDCTX,R4 R8
         LB,R4    DCTX,R4           CONVERT VOL # TO DCT INDEX
         DISABLE
         BAL,R6   PVCHKDA
         STCF     R11
         ENABLE                     DONT PERMIT IO INTERRUPTS WHILE IN ROOT
         PULL     4,R4
         LCF      R11
         B        *R11
         TITLE    '****  GETOCU  ****'
         SPACE    2
*D*  NAME:         GETOCU
*D*
*D*  REGISTERS:    ALL VOLATILE
*D*
*D*  CALL:         BAL,R15
*D*
*D*  INTERFACE:    T:REG
*D*
*D*  DESCRIPTION:  MAKE THE CURRENT USER THE OPEN/CLOSE USER.  IF
*D*                USER IS ALREADY OPEN/CLOSE USER, EXIT.  IF THERE
*D*                IS NO OPEN/CLOSE USER, STORE USER NUMBER IN
*D*                OPNCLSUS AND EXIT.  IF THERE IS CURRENTLY AN
*D*                OPEN/CLOSE USER, CALL T:REG WITH
*D*                THE EVENT E:OCR (TO PUT USER IN STATE SOCU,
*D*                WAITING FOR OPEN/CLOSE USER STATUS).  UPON
*D*                RETURN, REPEAT THE ENTIRE PROCESS.
         SPACE    1
GETOCU   EQU      %
         DISABLE                    **** DISABLE
         LW,R2    S:CUN
         CW,R2    OPNCLSUS
         BE       GETOCU2           ALREADY ARE OPEN/CLOSE USER
         LW,R11   OPNCLSUS
         BEZ      GETOCU2           NO ONE IS
         LI,R6    E:OCR
         BAL,R11  T:REG             WAIT FOR CURRENT USER TO FINISH
         B        GETOCU
*
GETOCU2  STW,R2   OPNCLSUS
         LH,R6    UH:FLG,R2
         OR,R6    BT31TO0+4         SET OPEN/CLOSE USER FLAG
         STH,R6   UH:FLG,R2
         ENABLE                     ****  ENABLE
         B        *R15
         TITLE    '****  RELOCU  ****'
         SPACE    2
*D*  NAME:         RELOCU
*D*
*D*  REGISTERS:    ALL VOLATILE
*D*
*D*  CALL:         BAL,R11
*D*
*D*  INTERFACE:    T:UBLKOCU
*D*
*D*  DESCRIPTION:  IF CURRENT USER IS NOT OPEN/CLOSE USER, EXIT.
*D*                OTHERWISE, CALL T:UBLKOCU (IN IORT).
         SPACE    1
RELOCU   LW,R0    S:CUN
         SW,R0    OPNCLSUS
         BNEZ     *R11              NOT OPEN/CLOSE USER
         STW,R0   FILCFU+ACNDISP    ZAP FILCFU IN CASE IT IS WRONG
         B        T:UBLKOCU
         TITLE    '****  GETBUF  ****'
         SPACE    2
*D*  NAME:         GETBUF
*D*
*D*  REGISTERS:    ALL VOLATILE
*D*
*D*  CALL:         BAL,R15
*D*
*D*  INPUT:        R2 = BUFFER TYPE
*D*
*D*  OUTPUT:       R7 = BUF TABLE INDEX
*D*
*D*  DESCRIPTION:  A BUF TABLE ENTRY THAT IS NOT CURRENTLY IN USE
*D*                IS OBTAINED FROM THE FREE POOL.  THE BUF TABLE
*D*                ENTRIES ARE ZEROED.
*D*
*D*                THE BUFFER TYPE REFERS TO THE TYPE OF OPERATION
*D*                THAT IS PERFORMED AT I/O END-ACTION BY THE
*D*                MAPPED END-ACTION ROUTINE:
*D*                  TYPE 0 - DO NOTHING
*D*                       1 - NOT IMPLEMENTED
*D*                       2,3 - OBTAIN ANOTHER BUFFER, LINK IT
*D*                             TO THE CURRENT BUFFER VIA BUFLINK, AND
*D*                               QUEUE A READ OF THE BLINK (TYPE 2) OR
*D*                               FLINK (TYPE 3) OF THE CURRENT BUFFER
*D*                             (SEE DESCRIPTION OF 'EA').
         SPACE    1
GETBUF   LB,R3    TYPCUR,R2         CUR # BUFFERS OF THIS TYPE
         CB,R3    TYPMAX,R2
         BGE      GETB4             TOO MANY ALREADY
         PLW,R7   BUFREE
         BNSU     GETB2             GOT ONE
         LI,R7    4
         MTB,0    TYPCUR,R7         ARE THERE ANY BEING RELEASED
         BEZ      GETB4             NO
         M:WAIT   1                 YES - WAIT
         B        GETBUF
*
GETB2    LI,R3    0
         STW,R3   BUFDA,R7          ZERO CELLS
         STW,R3   BUFDUAL,R7
         STW,R3   BUFINFO,R7
         STW,R3   BUFDACHK,R7
         STB,R3   BUFLINK,R7
         STB,R2   BUFTYPE,R7
         MTB,1    TYPCUR,R2         INCR # BUFFERS OF THIS TYPE
         B        *R15
*
GETB4    LI,R7    0                 NO BUFFERS AVAILABLE
         B        *R15
         TITLE    '****  RELBUF  ****'
         SPACE    2
*D*  NAME:         RELBUF
*D*
*D*  REGISTERS:    ALL VOLATILE
*D*
*D*  CALL:         BAL,R15
*D*
*D*  INTERFACE:    IOSPIN, DISCWRT, INTADR2
*D*
*D*  INPUT:        R7 = INDEX OF BUFFER TABLE ENTRY TO BE RELEASED
*D*                TO THE FREE POOL.
*D*
*D*  DESCRIPTION:  IOSPIN IS CALLED TO WAIT FOR I/O ON THE BUFFER
*D*                TO RELEASE.  IF BUFFER IS NOT UPDATED, ITS NUMBER
*D*                IS ADDED TO THE FREE POOL AND RELBUF EXITS.
*D*                IF UPDATED, THE BUFFER TYPE IS CHANGED TO 4 (SEE
*D*                DESCRIPTION OF 'EA'), AND DISCWRT IS CALLED TO
*D*                WRITE IT OUT.
*D*
*D*                RELBUF, BEFORE EXITING, CHECKS TO SEE IF ANY BUFFERS
*D*                NEED TO HAVE END-ACTION PERFORMED (FL:EA SET).
*D*                IF SO, A PSEUDO END-ACTION INFO WORD IS PUSHED
*D*                INTO THE STACK IN THE MPOOL BUFFER (SEE 'DISCRD'),
*D*                A PSEUDO INTERRUPT ENVIRONMENT PUSHED IN THE TCB
*D*                STACK, AND THE INTERRUPT CODE IS ENTERED AT INTADR2.
         SPACE    1
RELBUF   EQU      %
         DO       DEBUG=1
         AI,R7    0
         BLE      RELERR
         CW,R7    BUFMAX
         BG       RELERR
         DISABLE                    ****  DISABLE
         LW,R2    BUFREE
         CI,R2    BUFREE+1
         BLE      %+4
         CW,R7    0,R2
         BE       RELERR
         BDR,R2   %-4
         ENABLE                     **** ENABLE
         FIN
         BAL,R11  IOSPIN            WAIT FOR I/O TO COMPLETE
         LB,R2    BUFTYPE,R7
         MTB,-1   TYPCUR,R2         DECR # BUFFERS OF THIS TYPE
         LW,R2    BUFDA,R7          DISC ADDRESS - FLAGS
         AND,R2   FLR:EA            RESET 'PERFORM END-ACTION'
         STW,R2   BUFDA,R7            FLAG
         CW,R2    FL:UPDT
         BAZ      REL40             NOT UPDATED
         AND,R2   FLR:DUAL          RESET DUAL FLAG
         STW,R2   BUFDA,R7
         LI,R2    4
         STB,R2   BUFTYPE,R7        SET TYPE=4
         MTB,1    TYPCUR,R2         INCR # TYPE 4 BUFFERS
         BAL,R11  DISCWRT           WRITE IT
         B        *R15
*
*  CHECK FOR END-ACTION TO BE DONE
*
REL40    DISABLE                    **** DISABLE
         PSW,R7   BUFREE            ADD TO FREE POOL
         LW,R7    BUFMAX
         LW,R2    FL:EA
         CW,R2    BUFDA,R7
         BANZ     REL60             THIS ONE NEEDS END-ACTION
         BDR,R7   %-2
REL50    EQU      %
         ENABLE                     **** ENABLE
         B        *R15              NO END-ACTION TO DO
         SPACE    2
*
*  PREFORM PSEUDO END-ACTION
*
REL60    EQU      %
         SLS,R7   16
         MTB,1    R7                TYC = 1
         PSW,R7   *EASPD            PUT INTO END-ACTION STACK
         LW,R7    J:TCB
         INT,R8   1,R7              R9 = # WORDS IN TCB STACK
         CW,R9    ENVSIZE
         BG       REL50             ALREADY ARE IN BREAK ROUTINE
*
*  BUILD ENVIRIONMENT IN TCB STACK TO SIMULATE BREAK INTERRUPT
*
REL70    LW,R14   R15               RETURN ADDRESS
         OR,R14   Y004              SET MAPPED BIT
         LI,R15   0                 WORD 2 OF PSD
         LI,R13   1                 ASSUME NO SPACER WORD
         AND,R13  *J:TCB
         BEZ      %+3               NONE
         LI,R13   -1                MUST ADD SPACER WORD TO PUT
         PSW,R0   *J:TCB              PSD ON DW
*
         LCI      4                 PUSH 4 FIRST
         PSM,R13  *J:TCB            FLAG, PSD
*        LCI      0                 PSM LEAVES 0 COND CONDES
         PSM,R1   *J:TCB            PUSH REST OF REGS, CODE WORD
         LW,R1    *J:TCB            CALC ADDR OF PSD
         AI,R1    -18
         B        INTADR2
*
         DO       DEBUG=1
RELERR   SNAPX    'REL BUFFER ERROR'
         FIN
         TITLE    '****  ALLOCBUF  ****'
         SPACE    2
*D*  NAME:         ALLOCBUF
*D*
*D*  REGISTERS:    ALL VOLATILE
*D*
*D*  CALL:         BAL,R11
*D*
*D*  DESCRIPTION:  ALLOCATES CORE FOR THE I/O BUFFERS.  ATTEMPTS TO
*D*                GET VIA M:GP '#BUF' PAGES.  MUST BE ABLE TO
*D*                GET AT LEAST 'BUFMIN' PAGES (ABORTS FIX IF IT CAN'T).
*D*                INITIALIZES THE POOL OF FREE BUF TABLE ENTRIES,
*D*                SET UP BUFADR (BUFFER ADDRESS), AND ZEROS OTHER
*D*                BUF TABLE ENTRIES.
         SPACE    1
ALLOCBUF EQU      %
         M:GP     #BUF
         CI,R8    BUFMIN
         BL       *R11              DID NOT GET ENOUGH
         STW,R8   BUFMAX            # PAGES GOTTEN
         STW,R8   BUFCNT
         LI,R10   0
         LW,R7    R8                MOVE # PAGES GOTTEN
ALLOCB10 PSW,R7   BUFREE            ADD BUFFER INDEX TO FREE STACK
         STW,R9   BUFADR,R7         ADDRESS OF BUFFER
         STW,R10  BUFDA,R7          ZAP FLAGS
         AI,R9    512
         BDR,R7   ALLOCB10
         STW,R7   TYPMAX            ZAP MAX # BUFFERS ALLOWED
         STW,R7   TYPMAX+1
         STW,R7   TYPCUR            ZAP # BUFFERS CURRENTLY IN USE
         STW,R7   TYPCUR+1
         AI,R11   1
         B        *R11
*
NOPAGES  SNAPX    'NOT ENOUGH CORE'
         TITLE    '****  FITCHK  ****'
         SPACE    2
*F*  NAME:         FITCHK
*F*
*F*  PURPOSE:      VALIDATE A FILE'S FIT
*F*
*F*  DESCRIPTION:  VALIDATE THE VLPS IN A FIT FOR CONSISTENCY
         SPACE    2
*D*  NAME:         FITCHK
*D*
*D*  REGISTERS:    R7 PRESERVED
*D*
*D*  CALL:         BAL,R11
*D*
*D*  INTERFACE:    VALBUF, LOCCODE, CHKDA, GRANERR
*D*
*D*  INPUT:        R7 = BUF TABLE INDEX OF BUFFER CONTAINING FIT
*D*
*D*  OUTPUT:       R15 = ERROR CODE (ZERO IF NO ERROR).  CONDITION
*D*                CODES ARE SET TO INDICATE STATUS OF R15.
*D*
*D*  DESCRIPTION:  GRANULE HEADER IS VERIFIED VIA VALBUF.
*D*                WORD 2 IS CHECKED TO DETERMINE IF FILE IS
*D*                KEYED/RANDOM OR CONSEC, AND THE VLPS ARE LOCATED
*D*                THE FILE NAME IS CHECKED AGAINST THE DIRECTORY NAME
*D*                AND SYNFLAG SET IF NOT EQUAL (MAY BE A SYNONYMOUS FILE).
*D*                THE X'0D', X'0C', AND X'09' VLPS ARE LOCATED.  ALL
*D*                MUST BE PRESENT.  THE DISC ADDRESSES IN THE X'0C'
*D*                VLPS ARE VERIFIED.  ORG, KEYM AND # SYNON FILES
*D*                ARE OBTAINED FROM THE X'09' VLP.
         SPACE    1
FITCHK   PUSH     R11
*
FIT02    LI,R9    -1
         STW,R9   KEYSIZE           DON'T KNOW KEYSIZE
         STW,R9   SCRL              DON'T KNOW SCR
         STW,R9   LINKFLAG          NO LINK CHECK
*
         LI,R9    MFIT              CURRENT MESSAGE = 'FIT'
         STW,R9   CURMES
*
         LI,R9    1
         STW,R9   ORGL              ASSUME CONSEC FILE
         STW,R9   TYPEFLAG          TYPE = FILE
         STW,R9   FITFLAG           SET 'READING FIT' FOR VALBUF
         STW,R9   GAVALC            SET 1 GRAN/CYL
*
         LI,R9    0
         STW,R9   KEYLEVEL          KEYED FILE LEVEL = 0
         STW,R9   ERRCODE           NO ERROR
         STW,R9   VLP09             NO VLPS FOUND
         STW,R9   VLP0C
         STW,R9   VLP0D
         STW,R9   CCBDL
         STW,R9   GAVALL
         STW,R9   SRECL
         STW,R9   EOFDA+1           FILE'S ENTRY
*
         LW,R6    BUFADR,R7         BUFFER ADDRESS
         BAL,R10  VALBUF            VALIDATE FIRST 3 WORDS
         BNEZ     FITERR            ERROR
*
*  LOCATE FIT
*
         LH,R15   CURFILE           FIRST 2 BYTES OF FILE NAME
         CI,R15   X'0100'           IS IT THE FUNNY FILE
         BE       FITXIT            YES - GET OUT
         LI,R1    4                 WORD DISPL TO CONSEC FIT
         LW,R3    NAVX,R6
         CI,R3    X'8000'
         BANZ     FIT08             KEYED OR RANDOM
         CW,R3    Y3FFF
         BAZ      FIT10             CONSEC
FIT08    LI,R1    X'1B0'            KEYED/RANDOM FULL GRANULE
         CI,R3    X'4000'
         BANZ     FIT10
         LI,R1    X'B0'             HALF-GRANULE
*
FIT10    LI,R12   BA(CURFILE)
         LW,R13   R6
         AW,R13   R1
         SLS,R13  2                 BA OF NAME IN FIT
         STW,R13  FITNAME           SAVE BYTE ADDRESS OF FIT NAME
         LB,R8    CURFILE           # CHARS IN FILE NAME
         AI,R8    1                 INCLUDE TEXTC COUNT
         STB,R8   R13
         CBS,R12  0                 COMPARE
         BE       %+2
         MTW,1    SYNFLAG           NOT SAME - MUST BE SYNONYMOUS
*
*  VALIDATE VLPS
*
         AI,R1    9                 POINT TO FIRST VLP CONTROL WORD
         STW,R1   FITVLPX           SAVE IT
         LI,R15   ERR#32
FITVLP2  LI,R8    X'FF'
         AND,R8   *R6,R1            # WORDS RESERVED
         LI,R9    X'FF00'
         AND,R9   *R6,R1            # WORDS USED
         SLS,R9   -8
         INT,R12  *R6,R1            R12 = LAST ENTRY FLAG
         AW,R1    R8
         CI,R1    511               VLP MUST END IN GRANULE
         BG       FITERR
         CW,R9    R8
         BG       FITERR            # USED <= # RESERVED
         AI,R1    1
         CI,12    X'FF'
         BAZ      FITVLP2           NOT LAST ENTRY
*
*  FIND X'0D' ENTRY
*
         LI,R15   ERR#33
         LI,R12   X'0D'
         BAL,R4   LOCCODE           SEARCH FOR IT
         B        FITERR            DIDN'T FIND
         AND,R13  M8                # WORDS RESERVED
         CI,R13   1
         BL       FITERR
         AW,R1    R6
         STW,R1   VLP0D             ADDRESS OF X'0D' VLP
*
*  FIND X'09' ENTRY
*
         LI,R12   X'09'
         BAL,R4   LOCCODE
         B        FITERR            DIDN'T FIND
*
         STW,R6   VLP09
         AWM,R1   VLP09             ADDRESS OF X'09' VLP
         LI,R15   ERR#34
         AND,R13  M8                # WORDS RESERVED
         CI,R13   3
         BL       FITERR            MUST BE AT LEAST 3 WORDS LONG
         LW,R8    *R6,R1            GET FIRST WORD
         LB,R2    R8                ORG
         BNEZ     %+2
         LI,R2    1                 FORCE ORG=1 FOR CONSEC
         STW,R2   ORGL
         CI,R2    3
         BG       FITERR            ILLEGAL ORG
         LI,R9    0
         STW,R9   SCRL              ASSUME CONSEC
         CI,R2    2
         BNE      FIT30             NOT KEYED
         LH,R8    R8
         AND,R8   M8                KEYM
         AI,R8    1
         STW,R8   SCRL              SCR = KEYM+1
         AI,R8    4+4+5
         STW,R8   KEYSIZE           KEY ENTRY LENGTH
         AI,R8    -3                SET UP FLAGSDSP
         STW,R8   FLAGSDSP
*
FIT30    AI,R1    2                 POINT TO LAST WORD OF X'09'
         LW,R8    *R6,R1
         SLS,R8   -16               # SYNONYMOUS FILES
         AI,R8    0
         BNEZ     FIT50
         LI,R15   ERR#31            NONE - FIT AND DIRECTORY NAMES
         LW,R8    SYNFLAG             MUST MATCH
         BNEZ     FITERR            ERROR
*
*  FIND X'0C' VLP
*
FIT50    LI,R15   ERR#33
         LI,R12   X'0C'
         BAL,R4   LOCCODE
         B        FITERR            DIDN'T FIND
         STW,R6   VLP0C
         AWM,R1   VLP0C             ADDRESS OF X'0C'
         LI,R15   ERR#35
         AND,R13  M8                # WORDS RESERVED MUST BE 7
         CI,R13   7
         BL       FITERR
         BAL,R4   CHKVLD            FDA
         AI,R1    2
         BAL,R4   CHKVLD            GAVAL
         PUSH     7,R1              SET UP GAVALC/L
         LDCTX,R1 R8
         BEZ      FIT55             NOT THERE
         LB,R1    DCTX,R1
         LI,R7    HGP
         BAL,R5   FNDHGP1
         B        FIT55             BAD DCTX
         LI,R5    X'FF'
         AND,R5   1,R7              IS IT CYL
         BEZ      FIT55             NOPE, GET ERR AT FILEXIT
         STW,R5   GAVALC
         LSECTA,R3 R8
         SLS,R3   -1
         DW,R3    GAVALC
         LW,R9    XFF00FFFF
         LS,R8    R3
         STW,R8   GAVALL
FIT55    PULL     7,R1
         AI,R1    3
         BAL,R4   CHKVLD            SREC
         STW,R8   SRECL
         AI,R1    1
         BAL,R4   CHKVLD            LDA
         AI,R1    -6                POINT BACK TO FDA
*
         LW,R9    ORGL
         CI,R9    3
         BE       FIT60             FDA NOT = FIT DA FOR RANDOM
         LW,R9    M24
         LW,R8    *R6,R1            FDA
         LW,R4    BLINK,R6          IF FIT BLINK=0, FIT MUST BE FDA
         BNEZ     FIT60
         CS,R8    BUFDA,R7
         BNE      FITERR
*
*  NOW THAT SCRL AND KEYSIZE SET UP, CHECK BUFFER AGAIN
*
FIT60    LI,R15   0                 NO ERRORS
         LW,R10   ORGL              ORGANIZATION
         CI,R10   3
         BE       FITXIT            DON'T VALIDATE AGAIN IF RANDOM
         BAL,R10  VALBUF
         BEZ      FITXIT            NO ERRORS
*
FITERR   BAL,R11  GRANERR           RETRY
         BEZ      FIT02             RETRIES REMAIN
*
FITXIT   PULL     R11
         LI,R15   0
         STW,R15  FITFLAG           RESET FIT FLAG
         LW,R15   ERRCODE           ERROR CODE
         B        *R11
         SPACE    2
CHKVLD   LW,R8    *R6,R1            DISC ADDRESS
         AND,R8   M24
         BEZ      0,R4
         BAL,R11  CHKDA
         BCS,15   0,R4              GOOD
         B        FITERR            BAD
         TITLE    '****  CHKCON  ****'
         SPACE    2
*F*  NAME:         CHKCON
*F*
*F*  PURPOSE:      VALIDATE A CONSECUTIVE FILE GRANULE
*F*
*F*  DESCRIPTION:  THE RECORD SEGMENTS IN THE GRANULE ARE CHECKED
*F*                FOR LEGALITY AND CONSISTENCY.
         SPACE    2
*D*  NAME:         CHKCON
*D*
*D*  REGISTERS:    ALL VOLATILE
*D*
*D*  CALL:         BAL,R10
*D*
*D*  INTERFACE:    CHKDA, ALLOCG, GRANERR
*D*
*D*  INPUT:        R6 = BUFFER ADDRESS
*D*                R7 = BUFFER TABLE INDEX
*D*
*D*  DESCRIPTION:  CHAIN DOWN THRU THE GRANULE LOOKING AT EACH
*D*                RECORD CONTROL WORD, VALIDATING BACKSPACE
*D*                POINTERS, BYTE COUNTS, ETC.  FOR EACH UNBLOCKED
*D*                SEGMENT, ALLOCG IS CALLED TO ALLOCATE THE GRANULE.
*D*                IF AN ERROR IS DETECTED, AND THE 'FIX' FLAG IS
*D*                SET, THE GRANULE IS TRUNCATED AT EITHER THE BAD
*D*                CONTROL WORD OR AT THE BEGINNING OF THE GRANULE.
*D*                IN NO CASE IS THE FILE TRUNCATED.
         SPACE    1
CHKCON   PUSH     R10
CHKCON1  LI,R4    0                 LOCATION OF PREVIOUS CONTROL WORD
         STW,R4   #RECS1            # RECORDS IN THIS GRANULE
         LI,R5    1                 PREVIOUS SEG = BKSPC CNTRL
         LI,R3    3                 WORD INDEX OF NEXT CNTRL WORD
*
CHKC10   LW,R2    R3
         SLS,R2   2                 MAKE CMDL BYTE INDEX
         STW,R2   CMDL
         LI,R14   CHKER10           ERROR ROUTINE ADDRESS
         LI,R15   ERR#42
         INT,R12  *R6,R3            GET NEXT CONTROL WORD
         STCF     *SPD              SAVE FLAGS
         BCS,8    CONUBLK           UN-BLOCKED
         BCR,15   CONBKSPC          BACK-SPACE CONTROL WORD
*  BLOCKED SEGMENT
CHKC15   LI,R15   ERR#41
         CW,R13   R4                IS INDEX OF PREV CNTRL WORD OK
         BNE      CHKCERR           NO
         LI,R5    -1                PREVIOUS SEG = BLOCKED
         LW,R4    R3                INDEX OF PREVIOUS SEG
         AI,R12   3+4
         SLS,R12  -2                # WORDS TO NEXT CNTRL WORD
*
CHKC20   AW,R3    R12               POINT TO NEXT CNTRL WORD
         LC       *SPD              FLAGS FOR PREVIOUS CONTROL WORD
         BCR,4    %+2               NOT FAK (FIRST APPEARANCE OF KEY)
         MTW,1    #RECS1
         LI,R14   CHKER20           ERROR ROUTINE ADDRESS
         LI,R15   ERR#40
         LI,R2    NAVX
         INT,R12  *R6,R2            GET GRANULE CONTROL WORD
         CW,R3    R13
         BL       CHKC10            NOT AT END YET
         BG       CHKC30            PAST END
         INT,R12  *R6,R2
         BCR,4    CHKCXIT           OK
         CI,R3    512
         BGE      CHKCERR           ERROR - PAST END OF GRANULE
         B        CHKC10
*
CHKC30   INT,R12  *R6,R2            GRANULE CONTROL WORD
         BCR,4    CHKCERR           ERROR
         CW,R4    R13               R13 SHOULD BE LAST CNTRL WORD
         BNE      CHKCERR           NO - ERROR
*
CHKCXIT  LI,R15   0                 NO ERROR
         PULL     R10
         AI,R15   0
         B        *R10
*
*  UN-BLOCKED SEGMENT
*
CONUBLK  CI,R3    3
         BE       CONUB2            OK IF AT BEGINNING OF GRANULE
         AI,R5    0                 PREVIOUS SEG CNTRL WORD MUST
         BLZ      CHKCERR             NOT HAVE BEEN BLOCKED
         LW,R8    Y1
         AND,R8   *R6,R3
         SCS,R8   4                 R8 = 1 IF PREV SEG BKSPC CNTRL
         CW,R8    R5
         BNE      CHKCERR           ERROR
CONUB2   LI,R5    0                 PREV SEG = UN-BLOCKED
         LW,R4    R3                DISPL OF PREV SEG
         LI,R12   1                 INCREMENT TO NEXT SEG CNTRL WORD
         LW,R8    *R6,R3
         AND,R8   M24               DISC ADDRESS
         BAL,R11  CHKDA
         BCS,15   CONUB4            OK
         LI,R15   ERR#43
         LI,R14   CHKER10           ERROR ROUTINE ADDRESS
         B        CHKCERR           BAD DISC ADDRESS
*
CONUB4   BAL,R11  ALLOCG            ALLOCATE IT
         STCF     R11
         LW,R6    BUFADR,R7         RESTORE BUFFER ADDRESS
         LI,R14   CHKER10           ERROR ADDRESS
         LCF      R11
         BCR,11   CHKC20            ALL OK
         OR,R15   =KEY
         B        CHKCERR           ERROR
*
*  BACK-SPACE CONTROL WORD
*
CONBKSPC AI,R12   0
         BNEZ     CHKC15            DELETED BLOCKED SEGMENT
         AI,R5    0                 PREV SEG MUST HAVE BEEN
         BGEZ     CHKCERR             BLOCKED
         LI,R5    1                 PREV SEG = BKSPC CNTRL
         LI,R15   ERR#44
         CW,R13   R4                CHECK PREV SEG POINTER
         BNE      CHKCERR           ERROR
         LI,R12   1                 INCREMENT TO NEXT CNTRL WORD
         B        CHKC20
         SPACE    2
*
*  ERROR IN CONSECUTIVE FILE
*
CHKCERR  BAL,R11  GRANERR           RETRY
         BEZ      CHKCON1           RETRIES REMAIN
*  NO MORE RETRIES
         LW,R11   FIXFLAG
         BEZ      CHKCXIT           NOT 'FIX' - EXIT
         LW,R11   FL:UPDT
         STS,R11  BUFDA,R7          SET UPDATED FLAG
         B        *R14              GO TO ERROR ROUTINE
*
*  CHKER10 - SET NEXT AVAILABLE WORD AT 3.  ALL RECORD SEGMENTS IN
*        THIS GRANULE WILL BE DELETED.
*
*  CHKER20 - SET NEXT AVAILABLE WORD AT THE CURRENT SEGMENT CONTROL
*        WORD.  THE CURRENT SEGMENT AND ALL THAT FOLLOW IN THIS
*        GRANULE WILL BE DELETED.
*
CHKER20  LI,R3    3
CHKER10  LW,R2    R3
         LI,R3    X'FFFF'
         STS,R2   NAVX,R6           SET NEW NAV
*
         LI,R4    BA(MCONDEL)       'END OF GRANULE SET AT WORD '
         BAL,R10  MOVTXTC
         BAL,R10  MOVHEX
         BAL,R15  DUMPBUF           PRINT THE MESSAGE
         B        CHKCXIT
         TITLE    '****  LOCCODE  ****'
         SPACE    2
*D*  NAME:         LOCCODE
*D*
*D*  REGISTERS:    DESTROYS R1, R13
*D*
*D*  CALL:         BAL,R4
*D*
*D*  INPUT:        R6 = BUFFER ADDRESS OF FIT
*D*                R12 = VLP CODE TO FIND
*D*                FITVLPX = DISPL INTO BUFFER OF START OF VLPS
*D*
*D*  OUTPUT:       R1 = WORD INDEX OF FIRST DATA WORD OF VLP
*D*                R13 = VLP CONTROL WORD
*D*                RETURNS SKIPPING IF FOUND, NORMAL IF NOT FOUND
*D*
*D*  DESCRIPTION:  SEARCH FOR GIVEN VLP CODE, STOPPING EITHER WHEN
*D*                CODE IS FOUND OR END IS REACHED.
         SPACE    1
LOCCODE  LW,R1    FITVLPX
LOCC2    LW,R13   *R6,R1            NEXT CONTROL WORD
         AI,R1    1
         CB,R12   R13
         BE       1,R4              FOUND IT
         CW,R13   Y00FF
         BANZ     0,R4              NO MORE
         AND,R13  M8
         AW,R1    R13               ADD # WORDS RESERVED
         B        LOCC2
         TITLE    '****  VALBUF  ****'
         SPACE    2
*F*  NAME:         VALBUF
*F*
*F*  PURPOSE:      VALIDATE FIRST 3 WORDS OF DIRECTORY OR FILE GRANULE
*F*
*F*  DESCRIPTION:  FIRST 3 WORDS ARE CHECKED FOR LEGAL SCR, NAV, ETC.
         SPACE    2
*D*  NAME:         VALBUF
*D*
*D*  REGISTERS:    R7 PRESERVED
*D*
*D*  CALL:         BAL,R10
*D*
*D*  INPUT:        R6 = BUFFER ADDRESS
*D*                R7 = BUF TABLE INDEX
*D*                SCRL <0  GRANULE MAY BE KEYED OR CONSEC FORMAT
*D*                     =0  MUST BE CONSEC
*D*                     >0  MUST BE KEYED, SCRL MUST MATCH SCR IN BUFFER
*D*                         UNLESS SCRL = X'FF' (PRIV PACK AD)
*D*                KEYLEVEL >=0 IF KEYED, MUST HAVE THIS KEY LEVEL
*D*                         <0  DON'T CHECK KEY LEVEL
*D*
*D*  OUTPUT:       R15 = ERROR CODE (ZERO IF NO ERROR)
*D*
*D*  DESCRIPTION:  BLINK AND FLINK MUST BE ZERO OR LEGAL DISC ADDRESS.
*D*                IF LINKFLAG >= ZERO, CHECK DISC ADDRESS IN BUFDACHK
*D*                AGAINST BLINK OR FLINK.  IF NOT FIT, VALIDATE THAT
*D*                WORD 2 IS OF CORRECT TYPE.  IF KEYED OR
*D*                RANDOM, CHECK SCR, KEYLEVEL AND NAV.
         SPACE    1
VALBUF   EQU      %
         LI,R15   ERR#01            BLINK BAD
         LW,R8    BLINK,R6
         BEZ      %+3               ZERO - DON'T CHECK
         BAL,R11  CHKDA
         BCR,15   VALBXIT           ERROR
*
         LI,R15   ERR#02            FLINK BAD
         LW,R8    FLINK,R6
         BEZ      %+3
         BAL,R11  CHKDA
         BCR,15   VALBXIT           ERROR
*
         LI,R15   ERR#07            LINK CHECK FAILURE
         LW,R11   LINKFLAG
         BLZ      VALB04            NO CHECK
         LW,R9    M24
         LW,R8    BUFDACHK,R7
         LB,R11   R8                0 IF BLINK CHECK, 1 IF FLINK CHECK
         CS,R8    *R11,R6           CHECK BLINK OR FLINK
         BNE      VALBXIT           ERROR - NO MATCH
*
VALB04   LI,R15   ERR#03            GRANULE IS WRONG TYPE
         LI,R11   0
         XW,R11   FITFLAG
         BNEZ     VALBXIT1          EXIT IF THIS IS FIT
         LW,R11   NAVX,R6           GRANULE CONTROL INFO WORD
         LH,R9    R11
         CI,R11   X'8000'           CHECK FIT PRESENT BIT
         BAZ      VALCON            NOT SET - MAY BE CONSEC
*  KEYED
VALKEY   MTW,0    SCRL              SHOULD IT BE KEYED
         BEZ      VALBXIT           ERROR - SHOULD BE CONSEC
*
         LI,R15   ERR#04            KEYED NAV BAD
         CI,R9    MIDIS
         BL       VALBXIT           TOO SMALL
         CI,R9    X'800'
         BG       VALBXIT           TOO BIG
         AI,R9    -MIDIS
         LW,R8    KEYSIZE
         BLEZ     VALB10            DON'T KNOW KEY SIZE
         LW,R8    KEYLEVEL
         BNEZ     VALB10            DON'T CHECK NAV IF NOT LEVEL 0
         LI,R8    0                 MAKE SURE NAV IS
         DW,R8    KEYSIZE             MULTIPLE OF KEY SIZE
         AI,R8    0
         BNEZ     VALBXIT           REMAINDER NON-ZERO
*
VALB10   LI,R15   ERR#05            KEYED MI LEVEL WRONG
         LW,R8    KEYLEVEL
         BLZ      VALBK             KEYLEVEL NOT TO BE CHECKED
         LI,R8    X'1C00'
         AND,R8   NAVX,R6           LEVEL #
         SLS,R8   -10               RIGHT JUSTIFY
         CW,R8    KEYLEVEL
         BNE      VALBXIT           NOT RIGHT LEVEL
*
VALBK    LW,R15   SCRL
         BLZ      VALBXIT1          DON'T KNOW SCR - DON'T CHECK IT
*
         LI,R15   ERR#06            BAD SCR
         LI,R8    X'FF'
         AND,R8   NAVX,R6           GET SCR
         BNEZ     VALBK4
         LW,R8    SN                SCR MAY BE ZERO FOR PRIVATE PACKS
         BNEZ     VALBXIT1
VALBK4   CW,R8    SCRL
         BNE      VALBXIT           ERROR
*
VALBXIT1 LI,R15   0                 NO ERRORS
VALBXIT  AI,R15   0
         B        *R10
         SPACE    2
*  CONSEC
VALCON   CI,R9    X'3FFF'
         BANZ     VALKEY            MUST BE KEYED
         MTW,0    SCRL
         BGZ      VALBXIT           ERROR - WAS SUPPOSED TO BE KEYED
*
         LI,R15   ERR#09            CONSEC NAV BAD
         LI,R11   X'FFFF'
         AND,R11  NAVX,R6
         CI,R11   3
         BL       VALBXIT           TOO LOW
         CI,R11   512
         BG       VALBXIT           TOO HIGH
         B        VALBXIT1
         TITLE    '****  FNDKEY  ****'
         SPACE    2
*F*  NAME:         FNDKEY
*F*
*F*  PURPOSE:      VALIDATE AND FIND KEY IN DIRECTORY OR KEYED FILE
*F*
*F*  DESCRIPTION:  CHECK CONSISTENCY OF GRANULE AND EITHER STOP AT
*F*                NEXT KEY OR SEARCH FOR SPECIFIC KEY.
         SPACE    2
*D*  NAME:         FNDKEY
*D*
*D*  REGISTERS:    ALL VOLATILE
*D*
*D*  CALL:         BAL,R11
*D*
*D*  INTERFACE:    VALBUF, ALLOCG, ALLOCKD, COMKEY, DELKEY, GRANERR
*D*
*D*  INPUT:        R7 = BUF TABLE INDEX
*D*                CMDL = BYTE DISPL TO NEXT KEY TO LOOK AT.
*D*                SRCHKEY - CONTAINS KEY TO SEARCH FOR, OR
*D*                          ZERO - SEARCH ENTIRE FILE, OR
*D*                          NEGATIVE - STOP AT NEXT KEY
*D*
*D*  OUTPUT:       EXIT SKIPPING IF DIDN'T FIND DESIRED KEY, EXIT
*D*                  NORMAL IF FOUND.
*D*                CMDL = BYTE DISPL OF NEXT KEY TO LOOK AT
*D*                DABLK = MAIN DISC ADDRESS
*D*                DADUAL = DUAL DISC ADDRESS
*D*                BLKDISP = BYTE DISPL OF DATA RECORD
*D*                BLKSIZE = SIZE OF DATA RECORD
*D*                LOCDA = MAIN DISC ADDR FROM ENTRY FOUND
*D*                LOCDUAL = DUAL DISC ADDRESS FROM ENTRY FOUND
*D*
*D*  DESCRIPTION:  LOOK AT NEXT KEY.  PARSE OUT DISC ADDRESSES, COUNTS,
*D*                FLAGS, ETC.  IF ERROR, DELETE KEY IF IN FIX MODE.
*D*                IF NO ERROR AND FILE, ALLOCATE DATA GRANULE.
*D*                IF THIS IS DESIRED KEY OR SRCHKEY < 0, RETURN.
*D*                OTHERWISE, INCREMENT TO NEXT KEY AND START OVER.
         SPACE    1
FNDKEY   PUSH     R11
         LI,R3    0
         STW,R3   #RECS1            # RECORDS IN THIS GRANULE
FND10    EQU      %
         LW,R6    BUFADR,R7         BUFFER ADDRESS
         LI,R3    0
         STW,R3   ERRCODE           NO ERRORS
         LW,R3    CMDL              CURRENT BUFFER BYTE DISPL
         LI,R2    NAV
         CH,R3    *R6,R2
         BGE      FNDEOF3           AT END OF GRAN, CHECK END OF FILE
*
         LI,R15   ERR#20
         LB,R8    *R6,R3            BYTE COUNT OF KEY
         AND,R8   M7                SCRUB MI UPPER LEVEL FLAG
         CW,R8    SCRL
         BGE      FNDERR            KEY SIZE TOO LARGE
*
FND40    LI,R8    0
         STW,R8   DABLK             ZERO MAIN DISC ADDRESS
         LI,R8    -1                SET 'DON'T CHECK DUAL'
         STW,R8   DADUAL
         ANLZ,R4  IR6R3  LB,0 *R6,R3  BA OF CURRENT KEY
         AW,R4    SCRL              POINT PAST KEY
         LW,R5    TYPEFLAG
         BGZ      FNDMI             MASTER INDEX
         BEZ      FNDFD             FILE DIRECTORY
*
*  ACCOUNT DIRECTORY
*
         LW,R5    SN
         BNEZ     FNDFD             PRIV PACK AD SAME AS FD
         LI,R5    0
         STW,R5   DADUAL            ZAP DUAL DISC ADDRESS
         LW,R5    =X'03000001'+BA(DABLK)
         MBS,R4   0                 MOVE MAIN DISC ADDR TO DABLK
         LW,R5    =X'03000001'+BA(DADUAL)
         MBS,R4   0                 MOVE DUAL DISC ADDR TO DADUAL
*
FNDDA    LI,R15   ERR#26            FLAGS BAD
         LB,R8    0,R4              GET FLAGS
         STW,R8   FLAGS
         CI,R8    X'F8'
         BANZ     FNDERR            EXTRANEOUS BITS SET
         CI,R8    FAK
         BAZ      %+2               NOT FIRST APPEARANCE OF KEY
         MTW,1    #RECS1            COUNT A RECORD
*
         LI,R15   ERR#22
         LW,R8    DABLK             MAIN DISC ADDRESS
         STW,R8   BADDA             SAVE DISC ADDRESS IN CASE IT'S BAD
         BNEZ     FNDDA3            NON-ZERO DISC ADDRESS
         LW,R11   TYPEFLAG          ZERO DISC ADDRESS OK ONLY IF FILE
         BLEZ     FNDERR
         LW,R11   BLKSIZE           AND ORIGINAL SEGMENT SIZE = 0
         BNEZ     FNDERR
         B        FNDDA4            OK
FNDDA3   BAL,R11  CHKDA
         BCR,15   FNDERR            ERROR
*
FNDDA4   LI,R15   ERR#23
         LW,R8    DADUAL            DUAL DISC ADDRESS
         STW,R8   BADDA             SAVE DISC ADDRESS IN CASE IT'S BAD
         BLEZ     FNDDA5            DON'T CHECK DUAL
         BAL,R11  CHKDA
         BCR,15   FNDERR            ERROR
*
FNDDA5   LW,R11   TYPEFLAG
         BLEZ     FNDDA7            BR IF AD OR FD
         LW,R8    DABLK
         BEZ      FNDDA7            BR IF DISC ADDRESS IS ZERO
         LI,R11   FNDDA6            RETURN FROM ALLOCATION SUBROUTINE
         LW,R5    BLKDISP           INDEX INTO GRANULE OF DATA
         BEZ      ALLOCG            MASTER OF DATA GRANULE
         LI,R6    4                 FLAG FOR PFA
         LI,R15   X'100'            SPECIAL FLAG FOR NON-MASTER DATA
         B        ALLOCKD           ALLOCATE KEYED DATA
FNDDA6   BCS,11   FNDERR            ERROR - DELETE THE KEY
FNDDA7   LW,R6    BUFADR,R7
         LW,R5    TYPEFLAG          SET INDEX FOR EOFDA,EOFCMD
         BGEZ     %+3               NO EOFS IN ACCOUNT DIRECTORIES
         LW,R11   SN                EXCEPT PRIVATE ONES
         BEZ      FNDEOF2
         LB,R11   *R6,R3            CHECK FOR EOF FLAGS
         BEZ      FNDEOF2           DELETED KEY SHOULDNT HAVE ONE
         LW,R11   EOFDA,R5          ACTIVE SHOULDNT BE PAST
         BLZ      FNDEOFA           ONE.
FNDEOF1  STW,R3   EOFCMD,R5         AND IS CURRENT LAST KEY
         LW,R11   BUFDA,R7
         LW,R4    FLAGS
         SLS,R4   6                 PUT EOF BIT IN SIGN
         STB,R4   R11
         STW,R11  EOFDA,R5
         B        FNDEOF3
*
FNDEOF2  LW,R11   FLAGS
         CI,R11   EOF               IS EOF SET
         BAZ      FNDEOF3           NO,
         LI,R15   ERR#21            YES, REPRT ERROR
         BAL,R11  GRANERR
         MTW,-EOF FLAGS             FIX FLAGS
         MTW,0    FIXFLAG           ARE WE FIXING THINGS UP
         BEZ      FNDDA7            TRY AGAIN
         LW,R4    R3
         AW,R4    FLAGSDSP          GET TO FLAG BYTE
         MTB,-EOF *R6,R4
         LW,R11   FL:UPDT
         STS,R11  BUFDA,R7
         B        FNDDA7
*
FNDEOF3  RES
         LW,R5    TYPEFLAG
         BGEZ     %+3               NO EOFS IN ACCOUNT DIRECTORIES
         MTW,0    SN                EXCEPT PRIVATE ONES
         BEZ      FNDEOFX
         LW,R4    1,R6              IS THIS THE LAST KEY
         BNEZ     FNDEOFX           NO.
         LW,R4    2,R6              MEBBE, IS IT THE LAST IN THIS GRAN
         SLS,R4   -16
         SW,R4    KEYSIZE
         CW,R4    R3
         BGE      FNDEOFX           NOPE.
         LW,R11   EOFDA,R5          YES. DO WE HAVE AN EOF BIT
         BLEZ     FNDEOFX           YES.
*
FNDEOFA  RES                        TOGGLE THE EOFBIT AT EOFCMD IN EOFDA
         PUSH     5,R3              SAVE REGS
         LW,R3    EOFCMD,R5
         STW,R3   CMDL              SET CMD
FNDEOFB  BAL,R11  IOSPIN            WAIT FOR IO ON THIS BUFFER
         LW,R9    M24               TRY TO FIND EOFDA IN CORE
         LW,R8    EOFDA,R5
         DISABLE
         LW,R7    BUFMAX
FNDEOFD  CS,R8    BUFDA,R7
         BNE      FNDEOFH
         LW,R6    BUFREE            GOT ONE, IS IT ACTIVE
         AI,R6    -BUFREE
         CW,R7    BUFREE,R6
         BE       FNDEOFH           RELEASED
         BDR,R6   %-2
         LB,R6    BUFTYPE,R7        IS IT BEING RELEASED
         CI,R6    4
         BE       FNDEOFB           YES, WAIT FOR IT
         B        FNDEOFM
FNDEOFH  BDR,R7   FNDEOFD
         STW,R7   EOFCMD,R5         SET FLAG TO RELBUF
         LI,R2    0                 GET A BUFFER
         BAL,R15  GETBUF
         BEZ      BUFERR            NONE
         STS,R8   BUFDA,R7          SET DISC ADDR
         BAL,R11  DISCRD            READ THE THING
         BAL,R11  IOSPIN            COMPLETELY
         LW,R6    BUFADR,R7         SET DUAL ADDR IF THERE IS ONE
         MTW,0    SN                NO DUAL ON PRIVATE PACK
         BNEZ     FNDEOFM
         AI,R5    0                 OR IN A FILE
         BGZ      FNDEOFM
         LW,R8    509,R6
         STW,R8   BUFDUAL,R7
*
FNDEOFM  ENABLE
         LI,R15   ERR#21
         BAL,R11  GRANERR           REPORT ERROR
         MTW,0    FIXFLAG           NO FIX IF NO FIX
         BEZ      FNDEOFQ
         LW,R3    CMDL
         AW,R3    FLAGSDSP          GET TO BAD FLAGS
         LW,R6    BUFADR,R7
         LB,R11   *R6,R3
         EOR,R11  EOFBIT            TOGGLE THE BIT
         STB,R11  *R6,R3
         LW,R11   FL:UPDT
         STS,R11  BUFDA,R7
FNDEOFQ  MTW,0    EOFCMD,R5         RELBUF IF WE HAD TO GET ONE
         BNEZ     %+2
         BAL,R15  RELBUF
         LI,R3    0                 CLEAR ERROR FLAG
         STW,R3   ERRCODE
         PULL     5,R3
         STW,R3   CMDL              RESTORE CMD
         LW,R11   Y8                TOGGLE EOF BIT
         EOR,R11  EOFDA,R5
         STW,R11  EOFDA,R5
         BGZ      FNDDA7            IF WE TURNED ONE OFF, START OVER
FNDEOFX  RES
         LI,R2    NAV               IF PAST THE END
         CH,R3    *R6,R2            GET OUT
         BGE      FNDXIT
         LB,R11   *R6,R3
         BEZ      INCRKEY1          GET OUT IF DELETED KEY
         LI,R13   SRCHKEY           ADDRESS OF KEY
         LW,R11   SRCHKEY
         BEZ      INCRKEY           NOT LOOKING FOR SPECIFIC KEY
         BLZ      FNDDA8            STOP AT NEXT KEY
         BAL,R11  COMKEY            IS THIS THE KEY BEING SEARCHED FOR
         BNE      INCRKEY           NO
FNDDA8   LW,R8    DABLK
         BNEZ     %+2
         LI,R8    -1                FORCE NON-ZERO TO SHOW KEY FOUND
         LW,R9    DADUAL            YES - SAVE THE
         STW,R8   LOCDA               DISC ADDRESSES
         STW,R9   LOCDUAL
         LW,R3    CMDL              SAVE CMD
         STW,R3   DIRCMD
         PULL     R11
         B        *R11              EXIT - KEY FOUND
*
INCRKEY  LW,R3    FLAGS
         STW,R3   PREVFLAG          CURRENT FLAGS BECOME PREVIOUS
*
INCRKEY1 LW,R3    KEYSIZE
         AWM,R3   CMDL              POINT TO NEXT KEY
         B        FND10
*
FNDERR   OR,R15   =KEY
         BAL,R11  GRANERR
         BEZ      FND10             RETRIES REMAIN
         LW,R11   FIXFLAG
         BEZ      FNDDA7            DON'T FIX
         BAL,R11  DELKEY            DELETE THE KEY
         B        FND10
FNDXIT   PULL     R11
         AI,R11   1                 EXIT SKIPPING
         LW,R15   ERRCODE
         B        *R11
*
*  FILE DIRECTORY
*
FNDFD    LW,R5    =X'04000000'+BA(DABLK)
         MBS,R4   0                 MOVE FIT DISC ADDRESS
         AI,R4    2                 POINT TO FLAGS BYTE
         B        FNDDA
*
*  KEYED FILE MASTER INDEX
*
FNDMI    LW,R5    =X'04000000'+BA(DABLK)
         MBS,R4   0                 MOVE DATA DISC ADDRESS
         LW,R5    KEYLEVEL
         BNEZ     FNDDA             UPPER LEVEL - DONE
         LI,R15   ERR#24
         LH,R5    DABLK             BLDISP
         BLZ      FNDERR
         STW,R5   BLKDISP
         LI,R8    X'FFFF'
         AND,R8   DABLK             BLKSIZE
         STW,R8   BLKSIZE           SAVE ORIGINAL SEGMENT SIZE
         AW,R5    R8                SEGMENT MUST BE WHOLLY IN DATA
         CI,R5    X'800'              GRANULE
         BG       FNDERR            OUTSIDE
*
         LW,R5    =X'04000000'+BA(DABLK)
         MBS,R4   0                 GET THE REAL DISC ADDRESS
         LI,R15   ERR#25
         LI,R2    0
         LW,R5    =X'02000002'+R2*4
         MBS,R4   0                 MOVE BLK TO R2
         CW,R2    R8                CURRENT SEGMENT SIZE MUST BE
         BG       FNDERR              <= MAX SIZE
         AW,R8    BLKDISP           CHECK CCBD
         LW,R10   DABLK
         LW,R11   M24
         CS,R10   SRECL
         BNE      FNDDA
         CH,R8    CCBDL
         BLE      FNDDA
         STH,R8   CCBDL
         B        FNDDA
         TITLE    '****  COMKEY  ****'
         SPACE    2
*D*  NAME:         COMKEY
*D*
*D*  REGISTERS:    R0, R4, R5 VOLATILE
*D*
*D*  CALL:         BAL,R11
*D*
*D*  INPUT:        R3 = BYTE INDEX INTO BUFFER OF KEY B
*D*                R6 = WORD ADDRESS OF BUFFER CONTAINING KEY B
*D*                R13 = WORD ADDRESS OF KEY A
*D*
*D*  OUTPUT:       CONDITION CODES SET FOR BG, BE, BL (KEY A
*D*                COMPARED WITH KEY B)
*D*
*D*  DESCRIPTION:  COMPARE KEY A WITH KEY B.  WILL COMPARE EVEN IF
*D*                COUNT BYTE HAS BEEN ZEROED.
         SPACE    1
COMKEY   ANLZ,R5  IR6R3  LB,0 *R6,R3  BA OF KEY B
         ANLZ,R4  IR13   LB,0 *R13    BA OF KEY A
         LB,R0    0,R5              BYTE COUNT OF KEY B
         AI,R5    1
         CB,R0    0,R4              COMPARE BYTE COUNTS
         BE       COM10             SAME
         AND,R0   M7                SCRUB UPPER LEVEL FLAG
         BNEZ     COM20             NOT DELETED KEY
         LB,R0    0,R4              KEY B IS DELETED - USE KEY A SIZE
COM10    STB,R0   R5
         CBS,R4   1
         B        *R11
*
COM20    CB,R0    0,R4              TRY AGAIN
         BE       COM10             COUNTS ARE EQUAL
         BL       COM30             KEY B SMALLER THAN KEY A
         LB,R0    0,R4              USE SMALLEST COUNT
         OR,R0    Y3
COM30    EOR,R0   Y2
         STB,R0   R5
         CBS,R4   1
         BNE      *R11
         LC       R0
         B        *R11
         B        VALBXIT1
         TITLE    '****  TRUNCATE  ****'
*D*  NAME:         TRUNCATE
*D*
*D*  REGISTERS:    ALL VOLATILE
*D*
*D*  CALL:         BAL,R11
*D*
*D*  INPUT:        PREVBUF = BUF TABLE INDEX OF BUFFER CONTAINING
*D*                          BLINK OF CURRENT GRANULE
*D*                DIRBUF = BUF TABLE INDEX OF DIRECTORY GRANULE
*D*                         CONTAINING KEY THAT POINTS TO THIS LEVEL
*D*                DIRCMD = BYTE DISPL INTO DIRBUF BUFFER OF KEY
*D*               R7 = BUF TABLE INDEX OF BUFFER WITH BAD DATA
*D*
*D*  DESCRIPTION:  IF PREVBUF IS NON-ZERO, THAT BUFFER IS MARKED
*D*                UPDATED, AND FLINK AND DFLINK ARE SET TO ZERO.
*D*                IF BUFFER CONTAINS DIRECTORY OR KEYED MI, THE
*D*                EOF BIT IS SET ON THE LAST KEY.
*D*                IF PREVBUF IS NON-ZERO, THE KEY POINTED TO BY
*D*                DIRCMD IN DIRBUF IS DELETED VIA DELKEY.
         SPACE    1
TRUNCATE EQU      %
         LW,R7    PREVBUF           PREVIOUS (LAST GOOD) BUFFER
         BEZ      TRUNC10           NONE GOOD
         PUSH     R11
         LW,R15   FL:UPDT
         STS,R15  BUFDA,R7          SET BUFFER UPDATED
         LI,R14   MTRUNC1           'TRUNCATED AT PREVIOUS GRANULE'
         BAL,R15  PRINT
         LW,R6    BUFADR,R7         ADDRESS OF BUFFER
         LI,R8    0
         STW,R8   FLINK,R6          ZAP FLINK
         STW,R8   DFLINK,R6         ZAP DUAL FLINK
         LW,R8    TYPEFLAG
         BLEZ     TRUNC2            OK IF DIRECTORY
         LW,R8    ORGL              FILE - NO EOF BIT UNLESS KEYED
         CI,R8    2
         BNE      TRUNCXIT
TRUNC2   LI,R2    NAV
         LH,R3    *R6,R2            NAV
         SW,R3    KEYSIZE           GET TO LAST FLAG BYTE
         AW,R3    FLAGSDSP
         CI,R3    MIDIS             IS THERE A KEY HERE
         BL       TRUNCXIT          NO
         LB,R8    *R6,R3
         AND,R8   =X'4'             ZAP ALL BUT FAK
         AI,R8    2                 SET EOF
         STB,R8   *R6,R3
TRUNCXIT PULL     R11
         B        *R11
         SPACE    2
*
*  FIRST GRANULE OF DIRECTORY IS BAD - REMOVE KEY FROM DIRECTORY
*
TRUNC10  EQU      %
         PUSH     R11
         LW,R8    TYPEFLAG
         BAL,R11  ADINIT            ASSUME FD IS BAD
         AI,R8    0
         BLEZ     %+2               CORRECT
         BAL,R11  FDINIT            FILE BAD - DELETE FROM FD
         LW,R7    DIRBUF
         BEZ      TRUNCXIT          NO DIRECTORY TO DELETE KEY FROM
         LI,R14   MTRUNC2           'FDA BAD - KEY DELETED FROM DIRECTORY'
         BAL,R15  PRINT
         LW,R3    DIRCMD
         STW,R3   CMDL              MOVE CMD
         PULL     R11
         B        DELKEY            DELETE THE CURRENT KEY
         TITLE    '****  DELKEY  ****'
         SPACE    2
*D*  NAME:         DELKEY
*D*
*D*  REGISTERS:    R7 PRESERVED
*D*
*D*  CALL:         BAL,R11
*D*
*D*  INPUT:        R7 = BUF TABLE INDEX OF CURRENT BUFFER
*D*                CMDL = BYTE INDEX OF KEY TO BE DELETED
*D*
*D*  DESCRIPTION:  ALL KEYS FOLLOWING THE KEY TO BE DELETED ARE
*D*                MOVED UP OVER THE DELETED KEY.  NAV IS REDUCED
*D*                BY THE SIZE OF ONE KEY ENTRY.  IF THE KEY
*D*                DELETED WAS THE LAST IN THE FILE, EOF IS
*D*                SET ON THE LAST REMAINING KEY IN THE GRANULE.
         SPACE    1
DELKEY   EQU      %
         PUSH     R11
         LW,R6    BUFADR,R7         BUFFER ADDRESS
         LI,R2    NAV
         LW,R3    CMDL
         CH,R3    *R6,R2            IS KEY TO BE DELETED BEYOND BUFFER
         BGE      DELKEY80          YES
*
         LW,R9    BUFDA,R7
         OR,R9    FL:UPDT           SET UPDATED
         STW,R9   BUFDA,R7
*
         BUILD    (TEXT,MAST),(TEXT,*CURMES),(TEXT,MDELKEY)
         ANLZ,R4  IR6R3  LB,0 *R6,R3   BA OF KEY
         BAL,R11  PRKEY             PUT KEY IN BUFFER
         BAL,R15  DUMPBUF           PRINT LINE
*
         LW,R6    BUFADR,R7         BUFFER ADDRESS
         LI,R2    NAV
         LH,R8    *R6,R2            CURRENT NAV
         SW,R8    KEYSIZE
*
         LW,R3    CMDL
         CI,R3    MIDIS             IF DELETEING FIRST KEY OF MI
         BE       DELKEY90          JUST CLEAR COUNT AND UNUSED KEY BYTS
DELKEY05 STH,R8   *R6,R2            SET NEW NAV
         LW,R4    R3
         AW,R4    FLAGSDSP          GET FLAGS OF DELETEE
         LB,R11   *R6,R4
         SW,R8    R3                # BYTES TO MOVE
         BLEZ     DELKEY20          NONE
*
         LW,R4    R3
         AW,R4    KEYSIZE           TO NEXT ENTRY
DELKEY10 LB,R9    *R6,R4
         STB,R9   *R6,R3
         AI,R3    1
         AI,R4    1
         BDR,R8   DELKEY10
*
DELKEY20 CI,R11   EOF               MOVE EOF BIT IF REMOVED
         BAZ      DELKEY80
DELKEY30 CI,R3    MIDIS
         BLE      DELKEY80          NO MORE KEYS
         SW,R3    KEYSIZE           BACK UP TO PREV KEY
         MTB,0    *R6,R3
         BEZ      DELKEY30          THIS KEY IS DELETED
         AW,R3    FLAGSDSP
         LB,R8    *R6,R3
         OR,R8    X2                SET EOF
         STB,R8   *R6,R3
*
DELKEY80 PULL     R11
         B        *R11
*
DELKEY90 MTW,0    TYPEFLAG          FIRST KEY IN MI DOESNT MATTER
         BLEZ     DELKEY05          IF NOT A FILE
         LB,R8    *R6,R3            GET SIZE OF DELETED KEY
         BNEZ     %+3
         LW,R8    SCRL              DONT SCRUB
         AI,R8    -1
         LI,R4    0
         STB,R4   *R6,R3            CLEAR COUNT AND UNUSED KEY POSITIONS
         AW,R3    R8                FOR UPPER LEVEL TO WORK PROPERLY
         AI,R8    1
         SW,R8    KEYSIZE
         BGEZ     DELKEY80          EOF BIT WONT MATTER HERE
         AI,R3    1
         STB,R4   *R6,R3
         BIR,R8   %-2
         B        DELKEY80
         TITLE    '****  HEX2BIN  ****'
         SPACE    2
*D*  NAME:         HEX2BIN
*D*
*D*  REGISTERS:    R3, R4, R12, R13, R14 VOLATILE
*D*
*D*  CALL:         BAL,R15
*D*                RETURN SKIPPING IF NO ERROR
*D*
*D*  INPUT:        R12, R13 = EBCDIC, LEFT JUSTIFIED
*D*
*D*  OUTPUT:       R4 = BINARY NUMBER
*D*
*D*  DESCRIPTION:  CONVERT TEXT EBCDIC HEX NUMBER TO BINARY.
*D*                CONVERSION PROCEEDS FROM LEFT TO RIGHT IN R12, R13,
*D*                TERMINATING WITH FIRST ZERO OR BLANK BYTE.
*D*                IF ERROR ENCOUNTERED, RETURNS TO BAL+1 WITH
*D*                ADDRESS OF ERROR MESSAGE IN R14.
         SPACE    1
HEX2BIN  LI,R4    0
         AI,R15   1                 ASSUME NO ERRORS
HEX2B2   LB,R3    R12               NEXT BYTE TO CONVERT
         CI,R3    X'BF'
         BAZ      *R15              ZERO OR BLANK - DONE
         CLM,R3   DECNUM
         BCS,9    HEX2B6            NOT 0-9
         AI,R3    -'0'              CONVERT TO BINARY
HEX2B4   SLS,R4   4
         AW,R4    R3                ADD TO TOTAL
         SLD,R12  8                 SHIFT OFF DIGIT
         B        HEX2B2
*
HEX2B6   CLM,R3   HEXNUM
         BCS,9    HEX2B8            NOT A-F
         AI,R3    10-'A'            CONVERT TO BINARY
         B        HEX2B4
*
HEX2B8   LI,R14   MBADHEX           BAD HEX DIGIT
         AI,R15   -1
         B        *R15              ERROR EXIT
         TITLE    '****  DEC2BIN  ****'
         SPACE    2
*D*  NAME:         DEC2BIN
*D*
*D*  REGISTERS:    R3, R5, R12, R13, R14 VOLATILE
*D*
*D*  CALL:         BAL,R15
*D*                RETURN SKIPPING IF NO ERROR
*D*
*D*  INPUT:        R12, R13 = EBCDIC, LEFT JUSTIFIED
*D*
*D*  OUTPUT:       R5 = BINARY NUMBER
*D*
*D*  DESCRIPTION:  CONVERT EBCDIC DECIMAL NUMBER TO BINARY.
*D*                CONVERSION PROCEEDS FROM LEFT TO RIGHT IN R12, R13,
*D*                TERMINATING WITH FIRST ZERO OR BLANK BYTE.
*D*                IF ERROR ENCOUNTERED, RETURNS TO BAL+1 WITH
*D*                ADDRESS OF ERROR MESSAGE IN R14.
         SPACE    1
DEC2BIN  LI,R5    0
         AI,R15   1                 ASSUME NO ERRORS
DEC2B2   LB,R3    R12               GET NEXT CHAR
         CI,R3    X'BF'
         BAZ      *R15              ZERO OR BLANK - DONE
         CLM,R3   DECNUM
         BCS,9    DEC2B8            ILLEGAL CHAR
         AI,R3    -'0'
         MI,R5    10
         AW,R5    R3
         SLD,R12  8
         B        DEC2B2
*
DEC2B8   LI,R14   MBADDEC           BAD DECIMAL DIGIT
         AI,R15   -1
         B        *R15              ERROR EXIT
         TITLE    '****  BIN2HEX / BIN2DEC  ****'
         SPACE    2
*D*  NAME:         BIN2HEX
*D*  ENTRY:        BIN2DEC
*D*
*D*  REGISTERS:    R2, R3, R5 VOLATILE
*D*
*D*  CALL:         BAL,R15
*D*
*D*  INPUT:        R2 = BINARY NUMBER (BIN2HEX)
*D*                R3 = BINARY NUMBER (BIN2DEC)
*D*
*D*  OUTPUT:       R12, R13 = EBCDIC LEFT JUSTIFIED, TRAILING BLANKS
*D*                R5 = # NON-BLANK CHARACTERS IN R12, R13
*D*
*D*  DESCRIPTION:  THE BINARY NUMBER IS CONVERTED TO EBCDIC
*D*                HEXADECIMAL (BIN2HEX) OR DECIMAL (BIN2DEC).
         SPACE    1
BIN2HEX  LI,R5    0                 # CHARS PROCESSED
         LW,R12   BLANKS
         LW,R13   BLANKS
BIN2H10  SLD,R12  -8
         SLD,R2   -4
         SLS,R3   -28               NEXT HEX DIGIT
         LB,R3    CNVRT,R3          CONVERT TO EBCDIC
         STB,R3   R12
         AI,R5    1
         AI,R2    0
         BNEZ     BIN2H10           NOT DONE YET
         B        *R15
         SPACE    1
BIN2DEC  LI,R5    0                 # CHARS PROCESSED
         LW,R12   BLANKS
         LW,R13   BLANKS
BIN2D10  LI,R2    0
         DW,R2    =10
         SLD,R12  -8
         LB,R2    CNVRT,R2          CONVERT REMAINDER TO EBCDIC
         STB,R2   R12
         AI,R5    1
         AI,R3    0
         BNEZ     BIN2D10           NOT DONE YET
         B        *R15
         TITLE    '****  MOVTXT, MOVTXTC  ****'
         SPACE    2
*D*  NAME:         MOVTXTC
*D*  ENTRY:        MOVTXT
*D*
*D*  REGISTERS:    R4, R5 VOLATILE
*D*
*D*  CALL:         BAL,R10
*D*
*D*  INPUT:        R4 = BA OF TEXT STRING
*D*                R5 = # BYTES (MOVTXT ONLY)
*D*
*D*  OUTPUT:       THE STRING IS MOVED TO NEXT POSITION IN PRINT BUFFER
*D*
*D*  DESCRIPTION:  MOVE TEXTC (MOVTXTC) OR TEXT (MOVTXT) STRING TO
*D*                THE PRINT BUFFER.
         SPACE    1
MOVTXTC  LB,R5    0,R4              TEXTC COUNT
         AI,R4    1                 POINT PAST COUNT
*
MOVTXT   AW,R5    PRPOS             DONT MOVE PAST END OF BUFFER
         CI,R5    BA(PRPOS)
         BLE      %+2
         LI,R5    BA(PRPOS)
         SW,R5    PRPOS
         SCS,R5   -8
         OR,R5    PRPOS             ADD DESTINATION BYTE ADDR
         MBS,R4   0
         STW,R5   PRPOS             NEW DESTINATION
         B        *R10
         TITLE    '****  PUTMES, PUTMESC  ****'
         SPACE    2
*D*  NAME:         PUTMESC
*D*  ENTRY:        PUTMES
*D*
*D*  REGISTERS:    R1, R4, R5 VOLATILE
*D*
*D*  CALL:         BAL,R10
*D*
*D*  INPUT:        R1 = COLUMN NUMBER
*D*                R4 = BYTE ADDRESS OF TEXT OR TEXTC
*D*                R5 = BYTE COUNT (PUTMES ONLY)
*D*
*D*  DESCRIPTION:  PLACE TEXTC (PUTMESC) OR TEXT (PUTMES) STRING
*D*                AT THE INDICATED COLUMN IN PRINT BUFFER.  IF
*D*                SPECIFIED COLUMN IS BEYOND CURRENT POSITION,
*D*                BLANKS ARE MOVED IN, IF IT IS BEYOND CURRENT
*D*                POSITION, THE MESSAGE OVERWRITES PREVIOUS STRINGS.
         SPACE    1
PUTMES   LI,R15   MOVTXT
         B        %+2
PUTMESC  LI,R15   MOVTXTC
         AI,R1    BA(PRBUF)
PUTM05   CW,R1    PRPOS
         BLE      PUTM10            INSERT OVER EXISTING TEXT
         SW,R1    PRPOS             # BYTES TO BLANK
         SCS,R1   -8
         OR,R1    PRPOS             ADD BA OF DESTINATION
         MBS,0    BA(BLANKS)        MOVE BLANKS
PUTM10   STW,R1   PRPOS             SAVE NEW POSTION
         B        *R15              MOVE THE TEXT
         TITLE    '****  PUTHEXL, PUTHEXR, PUTDECL, PUTDECR  ****'
         SPACE    2
*D*  NAME:         PUTDECL
*D*  ENTRY:        PUTDECR
*D*  ENTRY:        PUTHEXL
*D*  ENTRY:        PUTHEXR
*D*
*D*  REGISTERS:    R1, R2, R3, R4, R5, R15 VOLATILE
*D*
*D*  CALL:         BAL,R10
*D*
*D*  INPUT:        R1 = COLUMN NUMBER
*D*                R2 = BINARY NUMBER (PUTHEXL, PUTHEXR)
*D*                R3 = BINARY NUMBER (PUTDECL, PUTDECR)
*D*
*D*  DESCRIPTION:  PLACE CONVERTED BINARY NUMBER AT A SPECIFIED
*D*                COLUMN NUMBER IN PRINT BUFFER.  COLUMN MAY BE
*D*                EITHER A BEGINNING COLUMN (PUTHEXL, PUTDECL)
*D*                FOR LEFT JUSTIFICATION, OR ENDING COLUMN
*D*                (PUTHEXR, PUTDECR) FOR RIGHT JUSTIFICATION.
*D*                BINARY NUMBER MAY BE CONVERTED TO EITHER
*D*                DECIMAL (PUTDECR/PUTDECL) OR HEX (PUTHEXL/PUTHEXR).
         SPACE    1
PUTDECL  BAL,R15  BIN2DEC           DECIMAL, LEFT JUSTIFIED
         B        PUTHEX2
PUTDECR  BAL,R15  BIN2DEC
         B        PUTHEX4
*
PUTHEXL  BAL,R15  BIN2HEX           HEX, LEFT JUSTIFIED
PUTHEX2  LI,R4    R12*4             BA OF TEXT
         B        PUTMES
PUTHEXR  BAL,R15  BIN2HEX           HEX, RIGHT JUSTIFIED
PUTHEX4  SW,R1    R5                POINT TO START
         AI,R1    1
         B        PUTHEX2
         TITLE    '****  MOVDEC, MOVHEX  ****'
         SPACE    2
*D*  NAME:         MOVHEX
*D*  ENTRY:        MOVDEC
*D*
*D*  REGISTERS:    R2, R3, R4, R5, R12, R13 VOLATILE
*D*
*D*  CALL:         BAL,R10
*D*
*D*  INPUT:        R2 = BINARY NUMBER (MOVHEX)
*D*                R3 = BINARY NUMBER (MOVDEC)
*D*
*D*  DESCRIPTION:  CONVERTS THE BINARY NUMBER TO EITHER EBCDIC
*D*                DECIMAL (MOVDEC) OR HEXADECIMAL (MOVHEX) AND
*D*                PUTS THE TEXT IN THE PRINT BUFFER.  IS THE SAME
*D*                AS CALLING BIN2DEC/BIN2HEX FOLLOWED BY MOVTXT.
         SPACE    1
MOVDEC   BAL,R15  BIN2DEC
MOVDEC2  LI,R4    R12*4             BA OF TEXT
         B        MOVTXT
*
MOVHEX   BAL,R15  BIN2HEX
         B        MOVDEC2
         TITLE    '****  DUMPBUF, INITBUF  ****'
         SPACE    2
*D*  NAME:         DUMPBUF
*D*  ENTRY:        DUMPB
*D*  ENTRY:        DUMPECHO
*D*  ENTRY:        INITBUF
*D*
*D*  REGISTERS:    ALL VOLATILE
*D*
*D*  CALL:         BAL,R15
*D*
*D*  DESCRIPTION:  DUMPS THE PRINT BUFFER TO ONE OR MORE DEVICES.
*D*                DUMPBUF - LINE PRINTER ONLY
*D*                DUMPB - LINE PRINTER PLUS UC OR OC IF ONLINE OR GHOST
*D*                DUMPECHO - UC OR OC ONLY
*D*                INITBUF - REINITIALIZE BUFFER POINTERS.  AUTOMATICALLY
*D*                CALLED AT END OF DUMPBUF, DUMPB AND DUMPECHO.
         SPACE    1
DUMPBUF  LW,R10   PRPOS             BA OF NEXT AVAIL BYTE
         AI,R10   -BA(PRBUF)        # BYTES TO WRITE
         BEZ      *R15              EXIT IF NOTHING TO WRITE
         LI,R3    0                 BTD
         LI,R14   PRBUF             BUFFER ADDRESS
         PUSH     R15
         BAL,R15  LPWRITE           WRITE THROUGH M:LO
         PULL     R15
INITBUF  LI,R10   BA(PRBUF)         NEXT AVAILABLE BYTE
         STW,R10  PRPOS
         B        *R15
         SPACE    2
DUMPECHO LW,R14   Y1                WRITE ONLY TO USER (NOT LP)
         B        DUMPB1
DUMPB    LW,R14   J:JIT             WRITE TO USER AND LP
DUMPB1   LW,R3    PRPOS
         AI,R3    -BA(PRBUF)
         LI,R10   X'15'
         STB,R10  PRBUF,R3          CARRIAGE RETURN AT END
         LW,R10   R3
         LC       R14
         BCS,1    DUMPB1A           SPECIAL DUMP TO USER ONLY
         BCR,12   DUMPB2            BR IF BATCH
         LI,R3    0                 BTD
         LI,R14   PRBUF             BUFFER ADDRESS
         PUSH     R15
         BAL,R15  LPWRITE           WRITE THROUGH M:LO
         PULL     R15
         MTW,0    CORESDCB
         BNEZ     INITBUF           M:LO AND ECHODCB TO SAME PLACE
DUMPB1A  AI,R10   1                 INCLUDE CARRIAGE RETURN
*
DUMPB2   LI,R3    0                 ASSUME VFC
         LI,R14   X'100'
         CW,R14   *ECHODCB
         BANZ     DUMPB4            YES - VFC ON
         LI,R3    1                 NO VFC - SKIP VFC CHAR
         AI,R10   -1                DECR BYTE COUNT
DUMPB4   M:WRITE  *ECHODCB,(BUF,PRBUF),(SIZE,*R10),(BTD,*R3),WAIT
         B        INITBUF
         TITLE    '****  TABLE DRIVEN OUTPUT  ****'
         SPACE    2
*D*  NAME:         BUILD
*D*
*D*  REGISTERS:    ALL VOLATILE
*D*
*D*  CALL:         BUILD PROC
*D*
*D*  DESCRIPTION:  PROC TO BUILD MESSAGES IN OUTPUT BUFFER.
*D*                PROC CALL IS OF THE FORM:
*D*                   BUILD    (OPT,ADDR,COL),(OPT,ADDR,COL), ...
*D*                OPTIONS ARE:
*D*                  TEXT:  ADDR MAY BE ADDRESS OF TEXTC OR A
*D*                         TEXT STRING IN QUOTES
*D*                  HEX, DEC:  ADDR IS VALUE TO CONVERT, OR IF
*D*                      *ADDR IS LOC CONTAINING VALUE.  VALUE IS
*D*                      PUT IN LEFT JUSTIFIED.
*D*                  RHEX, RDEC:  SAME AS DEC/HEX BUT RIGHT JUSTIFIED.
*D*                  SPACE:  SPACE OVER ADDR # SPACES.
*D*                  DUMPBUF, DUMPB, DUMPECHO:  CALL THE INDICATED ROUTINE.
*D*                IF COL IS SPECIFIED, IT IS COLUMN NUMBER TO PLACE
*D*                THE INDICATED ITEM.  IF NOT SPECIFIED, ITEM IS
*D*                PLACED AT NEXT LOCATION IN PRINT BUFFER.
*D*                THE ,E AND ,L OPTIONS AFTER PROC NAME MAY BE USED
*D*                TO GENERATE ONLY ROUTINE CALL OR ONLY TABLE,
*D*                RESPECTIVELY, AS IN SYSTEM BPM PROCS.
*D*
*D*                GENERATED TABLE:
*D*                  BIT 0  -  SET IF THIS IS LAST ENTRY IN CHAIN.
*D*                  BIT 1-7  -  COLUMN # (ZERO IF NONE)
*D*                  BIT 8-11  -  KEYWORD TYPE
*D*                  BIT 12  -  SET IF ADDR FIELD IS INDIRECT
*D*                  BIT 13-31  -  ADDR
         SPACE    1
TBLDMP   STM,R0   TBLREGS           SAVE THE REGISTERS
         LW,R6    *TBLXPSD          GET WORD FOLLOWING XPSD
         MTW,1    TBLXPSD           INCR RETURN ADDRESS
TBLDMP1  LW,R2    0,R6              GET NEXT TABLE ENTRY
         LB,R1    R2                COLUMN NUMBER
         LW,R5    0,R6
         SCS,R5   12                RIGHT JUSTIFY AND
         AND,R5   M4                  MASK ROUTINE #
         LI,R7    8                 DEFAULT MOVTXT, PUTMES
         CW,R2    Y8
         AND,R2   M19               MASK OFF ADDR
         BAZ      %+3
         LB,R7    *R2
         LW,R2    0,R2              GET INDIRECT
         LW,R3    R2                MOVE IN CASE DEC
         LW,R4    R2                MOVE IN CASE TEXT
         SLS,R4   2
         LI,R10   NXTTBL            RETURN
         LI,R15   NXTTBL            RETURN
         CI,R5    DUMP#
         BL       TBLDMP2           NOT DUMP COMMAND
         CI,R2    X'FF'
         BAZ      TBLDMP2           NOTHING SPECIFIED
         STB,R2   PRBUF             PUT IN VFC CHAR
TBLDMP2  AND,R1   M7                MASK COL #
         BNEZ     TVEC1-1,R5        COLUMN IS SPECIFIED
         B        %,R5              NO COLUMN
         B        MOVTXTC           TEXT
         B        MOVHEX            HEX
         B        MOVDEC            DEC
         B        MOVHEX            RHEX
         B        MOVDEC            RDEC
         B        SPACE             SPACE
         B        MOVTXT0
         B        FILL
         B        DUMPBUF           DUMPBUF
         B        DUMPB             DUMPB
         B        DUMPECHO          DUMPECHO
*
TVEC1    B        PUTMESC           TEXT
         B        PUTHEXL           HEX
         B        PUTDECL           DEC
         B        PUTHEXR           RHEX
         B        PUTDECR           RDEC
         B        SPACE             SPACE
         B        PUTMES0
         B        FILL
DUMP#    EQU      %-TVEC1
         B        DUMPBUF           DUMPBUF
         B        DUMPB             DUMPB
         B        DUMPECHO          DUMPECHO
*
FILL     SLD,R4   -2-8-32           GET # TO MOVE
         LI,R4    BA(PRBUF)
         AW,R4    R1
         STW,R4   PRPOS
         MTW,1    PRPOS
         STB,R3   0,R4
         B        MOVTXT
*
PUTMES0  RES
MOVTXT0  STW,R7   R5                SET COUNT IN 5, WHERE IT BELONGS
         BEZ      MOVTXT
         B        PUTMES
*
SPACE    LW,R1    R2                MOVE # SPACES
         AW,R1    PRPOS
         B        PUTM05
*
NXTTBL   LW,R2    0,R6              LAST TABLE ENTRY
         AI,R6    1                 POINT TO NEXT
         CW,R2    Y0008
         BAZ      TBLDMP1           NOT DONE YET
         LCI      0
         LM,R0    TBLREGS           RESTORE REGISTERS
         LPSD,0   TBLXPSD           RETURN
         TITLE    '****  HEXDUMP  ****'
         SPACE    2
*F*  NAME:         HEXDUMP
*F*
*F*  PURPOSE:      DUMP CORE TO LINE PRINTER WITH EBCDIC TRANSLATION
*F*
*F*  DESCRIPTION:  CORE IS DUMPED IN HEX WITH EBCDIC TRANSLATION
         SPACE    1
*D*  NAME:         HEXDUMP
*D*  ENTRY:        HEXDUMPB
*D*
*D*  REGISTERS:    ALL PRESERVED
*D*
*D*  CALL:         BAL,R11
*D*
*D*  INPUT:        R12 = FIRST LOCATION TO DUMP
*D*                R13 = # WORDS TO DUMP (HEXDUMP), # BYTES (HEXDUMPB)
*D*                      IF < 0, NO SPACING BETWEEN WORDS
*D*                R14 = ADDRESS TO PRINT FOR WORD POINTED TO BY R12.
*D*                      IF < 0, NO ADDRESSES PRINTED.
*D*
*D*  DESCRIPTION:  CORE IS DUMPED BEGINNING AT LOCATION POINTED TO BY
*D*                R12, 8 WORDS PER LINE WITH ONE BLANK BETWEEN
*D*                WORDS (UNLESS R13 < 0).  EACH LINE BEGINS WITH
*D*                AN ADDRESS THAT IS A MULTIPLE OF 8 (UNLESS R14 < 0,
*D*                IN WHICH CASE THE FIRST WORD DUMPED IS AT
*D*                THE BEGINNING OF THE LINE).  DUPLICATE LINES
*D*                ARE SUPPRESSED, WITH AN ASTERISK AFTER THE ADDRESS
*D*                TO INDICATE DELETED LINES.
*D*                IF THE CELL DMPFLG IS NON-ZERO, THE DUMP WILL BE
*D*                TO BOTH USER TERMINAL AND LP.
*D*                IF ONLINE, AND USER HAS PRESSED BREAK KEY, DUMP
*D*                WILL HALT EARLY AND OUTPUT WILL BE PURGED.
         SPACE    1
HEXDUMP  PUSH     R13
         SLS,R13  2                 CONVERT WORDS TO BYTES
         B        %+2
HEXDUMPB PUSH     R13
         PUSH     15,R14
         LW,R2    LPFLAG            GET PRINT-MODE FLAG
         CI,R2    2                 WAS 'F' SPECIFIED?
         BE       HXEXIT            IF SO OMIT ALL HEX DUMPS
         LI,R2    -2
         STW,R2   DUPFLAG           DISABLE DUPLICATE LINE CHECKING
         LW,R2    R14               SAVE R14
         LI,R14   MSPACE
         BAL,R15  PRINT             PRINT BLANK LINE
         LW,R14   R2                RESTORE R14
         LI,R2    8
         STW,R2   #COL              # COLUMNS PER WORD
         LI,R2    0
         STW,R2   #BYTES1
         LI,R3    1                 # SPACES BETWEEN WORDS
         AI,R13   0
         BGEZ     HX1A              NORMAL SPACING
         LCW,R13  R13               NO SPACING BETWEEN WORDS
         LI,R14   -1                SUPRESS ADDRESS PRINTING
         LI,R3    0
HX1A     STW,R3   #SPACES
         AWM,R3   #COL
         LI,R2    3
         AND,R2   R13               # LEFT-OVER BYTES
         STW,R2   #BYTES
         SLS,R13  -2                # WORDS TO DUMP
*
HX1      EQU      %
         CI,R13   0
         BG       HX5               NOT DONE
         LW,R11   #BYTES
         BNEZ     HX5               SOME LEFT-OVER BYTES
HXEXIT   PULL     16,R13
         B        *R11
*
HX5      LW,R1    BLANKS
         LI,R2    34
         STW,R1   PRBUF-1,R2        BLANK BUFFER
         BDR,R2   %-1
*
         LI,R1    0
         LI,R2    8                 # WORDS PER LINE
         LI,R10   0
         AI,R14   0
         BLZ      HX11              SUPRESS PRINTING OF ADDRESS
         CI,R14   7
         BAZ      HX10              BR IF START ON MULTIPLE OF 8
*
*  FIRST LOCATION NOT MULTIPLE OF 8 - CORRECT SO THAT NEXT LINE
*  WILL START ON LOCATION THAT IS MULTIPLE OF 8
*
         LW,R1    R14
         AND,R14  =X'FFFFFFF8'      ROUND DOWN
         AND,R1   =X'7'             REMAINDER
         SW,R2    R1                R2 = # WORDS TO PRINT THIS LINE
         LW,R10   R1                # WORDS TO SKIP
         MW,R1    #COL              # COLUMNS PER WORD
*
HX10     EQU      %
         PUSH     9,R10
         LW,R2    R14               ADDRESS TO PRINT
         LI,R1    5                 COLUMN #
         BAL,R10  PUTHEXR           PUT IN RIGHT JUSTIFIED
         PULL     9,R10
*
HX11     CW,R2    R13               R2 = # WORDS TO PRINT THIS LINE
         BLE      HX12              R13 = # WORDS REMAINING
         LW,R2    R13               END OF DUMP - SHORT LINE
*
HX12     PUSH     R2
         SW,R13   R2                DECR REMAINING WORDS
         LW,R11   DUPFLAG
         BLZ      HX20              DUP CHECKING DISABLED
         CI,R2    8                 IF LESS THAN 8 WORDS ON THIS
         BL       HX16                LINE, PRINT IT - IS LAST LINE
         AI,R13   0                 ALSO LAST LINE IF NO WORDS REMAIN
         BLEZ     HX16
         LW,R8    R12
         LW,R9    R12               R9 = ADDRESS OF START OF THIS LINE
         AI,R8    -8                R8 = ADDRESS OF PREVIOUS LINE
         SLD,R8   2
         OR,R9    Y2                CHECK 32 BYTES
         CBS,R8   0
         BNE      HX16              LINES NOT THE SAME
         LI,R8    1
         STW,R8   DUPFLAG           SET DUPLICATE
         B        HX52
*
HX16     LI,R5    0                 LINE NOT SAME AS PREVIOUS
         XW,R5    DUPFLAG
         BEZ      HX20              NOT IN DPULICATE MODE
         LI,R5    '*'**8            WERE THE SAME - PUT MARKER
         STS,R5   PRBUF+1             IN THIS LINE
*
HX20     AI,R1    DUMP:HEX          R1 = INDEX OF FIRST WORD TO PRINT
         LI,R3    0
HX35     LI,R7    8                 # HEX CHARS PER WORD
HX36     LW,R5    *R12,R3           GET NEXT WORD
         AI,R3    1
HX38     LI,R4    0
         SLD,R4   4                 NEXT CHAR INTO R4
         LB,R4    CNVRT,R4          CONVERT TO EBCDIC
         STB,R4   PRBUF,R1          PUT IN PRINT BUFFER
         AI,R1    1
         BDR,R7   HX38              DO ONE WORD
         AW,R1    #SPACES           SPACE TO NEXT WORD
         BDR,R2   HX35              R2 = # WORDS ON THIS LINE
*
         AI,R13   0
         BNEZ     HX40              NOT LAST LINE
         LW,R5    *SPD              # WORDS ON THIS LINE
         CI,R5    8
         BE       HX40              LINE IS FULL
         LI,R7    0
         XW,R7    #BYTES            IS THERE A PARTIAL LINE
         BEZ      HX40              NO
         STW,R7   #BYTES1
         SLS,R7   1                 CONVERT BYTES TO HEX CHARS
         B        HX36
*
*  PUT IN EBCDIC TRANSLATION
*
HX40     LI,R1    DUMP:EBC          COL # OF START OF XLATION
         SLS,R10  2                 BYTE OFFSET TO BEGINNING OF XLATION
         AW,R1    R10               COLUMN TO START IN
         LI,R4    '*'
         STB,R4   PRBUF,R1          DELIMITER
         AI,R1    1
         ANLZ,R4  SOURCE            BA OF START OF STRING
         ANLZ,R5  DEST              BA OF SPACE IN PRBUF
         LW,R15   *SPD              # WORDS PRINTED THIS LINE
         SLS,R15  2                 # BYTES
         AW,R15   #BYTES1           REMAINDER BYTES
         STB,R15  R5
         MBS,R4   0                 MOVE TO PRBUF
*
         LI,R4    BA(XLATE)
         ANLZ,R5  DEST              TRANSLATE CHARACTERS
         STB,R15  R5
         TBS,R4   0
*
         AW,R1    R15
         LI,R4    '*'
         STB,R4   0,R5              TRAILING DELIMITER
*
*  WRITE OUT THE BUFFER
*
         AI,R5    1
         STW,R5   PRPOS             NEXT AVIALABLE BYTE
         PUSH     R14
         LI,R15   HX48              RETURN ADDRESS
         MTW,0    DMPFLG
         BEZ      DUMPBUF           DUMP TO LP
         B        DUMPB             DUMP TO USER
HX48     PULL     R14
*
         LW,R5    DUPFLAG
         BGEZ     HX52
         AI,R14   0
         BLZ      HX54              NO ADDRESS PRINTING
         MTW,1    DUPFLAG
HX52     AI,R14   8
HX54     PULL     R15               # WORDS PRINTED THIS LINE
         AW,R12   R15               INCREMENT ADDRESS OF NEXT LINE
         LC       J:JIT
         BCR,8    HX1               NOT ONLINE
         LI,R1    0
         XW,R1    DISPFLG
         BEZ      HX1               USER DIDN'T PRESS BREAK KEY
         M:PURGE  WRITE             PURGE ALL OUTPUT
         B        HXEXIT            EXIT FROM HEXDUMP
*
SOURCE   LB,0     *R12              FOR ANLZ
DEST     LB,0     PRBUF,R1          FOR ANLZ
         TITLE    '****  WRITE ROUTINES  ****'
         SPACE    2
*D*  NAME:         PRINT
*D*  ENTRY:        DOPRINT
*D*  ENTRY:        LPWRITE
*D*
*D*  REGISTERS:    ALL VOLATILE
*D*
*D*  CALL:         BAL,R11          DOPRINT
*D*                BAL,R15          PRINT, LPWRITE
*D*
*D*  INPUT:        R14 = MESSAGE ADDRESS
*D*                R10 = BYTE COUNT (LPWRITE)
*D*                R3 = BYTE DISPLACEMENT (LPWRITE)
*D*
*D*  DESCRIPTION:  PRINT - WRITE MESSAGE TO LINE PRINTER
*D*                DOPRINT - WRITE TO LP AND USER TERMINAL
*D*                LPWRITE - WRITE TO LP.  ALL LP WRITES WHICH
*D*                CAN OCCUR DURING HGP RECON MUST COME HERE.
*D*                IF LPDCTX < 0, IS NOT HGP RECON, SO USES M:WRITE.
*D*                OTHERWISE IS HGP RECON, SO MOVES MESSAGE TO LP
*D*                BUFFER AND, IF LP NOT BUSY, QUEUES UP THE WRITE
*D*                VIA LPIO (NEWQNWM).
         SPACE    1
DOPRINT  BAL,R15  INITBUF
         LW,R4    R14               MESSAGE ADDRESS
         SLS,R4   2                 BYTE ADDRESS
         BAL,R10  MOVTXTC           MOVE TO PRBUF
         LW,R15   R11               MOVE RETURN ADDRESS
         B        DUMPB             PRINT THE LINE
         SPACE    2
PRINT    LB,R10   *R14              BYTE COUNT
         LI,R3    1                 BTD
*
LPWRITE  EQU      %
         MTW,0    LPDCTX
         BLZ      LPWR80            USE M:WRITE (NOT PUBLIC HGPRECON)
         BEZ      *R15              NO PRINTING DESIRED
         MTW,0    LPFLAG
         BLZ      *R15              NO PRINTING DESIRED
         LCI      0
         STM,R0   TEMP
LPWR10   LW,R2    LPCNT             # I/O OPERATIONS OUTSTANDING
         CI,R2    3
         BGE      LPWR10            ALL BUFFERS IN USE
         CI,R10   127
         BLE      %+2
         LI,R10   127               BYTE COUNT TOO BIG
         LW,R15   LPNXT
         MI,R15   32
         AW,R15   LPBUF             ADDRESS OF BUFFER
         STB,R10  *R15              PTT IN BYTE COUNT
         SLD,R14  2
         AW,R14   R3                SOURCE BYTE DISPLACEMENT
         AI,R15   1                 SKIP OVER BYTE COUNT
         STB,R10  R15
         MBS,R14  0                 MOVE MESSAGE TO LP BUFFER
         LW,R2    LPNXT
         AI,R2    1                 INCR CURRENT BUFFER NUMBER
         AND,R2   M2
         STW,R2   LPNXT
         DISABLE                    ****  DISABLE
         LW,R2    LPCNT
         BNEZ     LPWR50            I/O IS CURRENTLY OUTSTANDING
         ENABLE                     ****  ENABLE
         MTW,1    LPCNT             COUNT # I/O'S WAITING
         BAL,R11  LPIO              START THE I/O
         B        %+2
LPWR50   MTW,1    LPCNT
         ENABLE                     ****  ENABLE
         LCI      0
         LM,R0    TEMP
         B        *R15
*
LPWR80   PUSH     R2
         LW,R2    Y002
         CW,R2    M:LO
         BAZ      LPWR82            DON'T WRITE IF DCB CLOSED
         M:WRITE  M:LO,(BUF,*R14),(SIZE,*R10),(BTD,*R3),WAIT
LPWR82   PULL     R2
         B        *R15
         TITLE    '****  GRANERR  ****'
         SPACE    2
*F*  NAME:         GRANERR
*F*
*F*  PURPOSE:      RETRY I/O, IF NECESSARY READ DUAL GRANULE.  IF
*F*                NO RETRIES REMAIN, PRINT ERROR MESSAGES.
*F*
*F*  DESCRIPTION:  IF RETRIES REMAIN, THE I/O IS QUEUED AGAIN.
*F*                OTHERWISE, THE DUAL IS READ IF IT EXISTS.
*F*                IF NO RETIRES AND NO DUAL, AN ERROR MESSAGE IS
*F*                PRINTED AND THE GRANULE DUMPED.
         SPACE    1
*D*  NAME:         GRANERR
*D*
*D*  REGISTERS:    ALL PRESERVED
*D*
*D*  INTERFACE:    ERRMSG, SNAPGRAN
*D*
*D*  CALL:         BAL,R11
*D*
*D*  INPUT:        R7 = BUF TABLE INDEX
*D*                R15 = ERROR CODE
*D*
*D*  DESCRIPTION:  IF THE NO RETRY FLAG IS NOT SET IN ERROR CODE,
*D*                IORETRY IS CALLED.  IF RETRIES REMAIN, EXIT.
*D*                IF DUAL EXISTS AND HAS NOT BEEN READ, READ IT
*D*                AND EXIT.  OTHERWISE PRINT ERROR MESSAGES,
*D*                SNAP THE GRANULE, AND EXIT.
         SPACE    1
GRANERR  PUSH     15,R0
         STW,R15  ERRCODE           SAVE ERROR CODE
         CI,R15   ERR#99
         BNE      %+2               NOT I/O ERROR
         BAL,R1   IOERR             DUMP ERRLOG IF PUBLIC HGP RECON
         CI,R15   NORETRY
         BANZ     GRANER38          BR IF NO RETRIES ARE TO BE DONE
         BAL,R10  IORETRY           RETRY THE I/O
         BNEZ     GRANER40          SOME RETRIES REMAIN
*  NO MORE RETRIES
         LW,R11   FL:DUAL
         CW,R11   BUFDA,R7
         BANZ     GRANER30          ALREADY READ DUAL
         LW,R8    BUFDUAL,R7
         BLEZ     GRANER30          NO DUAL OR JUST ALLOCATED
         LW,R11   FL:UPDT
         CW,R11   BUFDA,R7
         BANZ     GRANER30          DON'T READ DUAL IF BUFFER UPDATED
         BAL,R11  ERRMSG            GIVE ERROR MESSAGE FOR MASTER
         BAL,R11  SNAPGRN           SNAP, OVERRIDING DUMPFLAG
         LI,R4    BA(MDUALRD)       'ATTEMPTING TO READ DUAL'
         BAL,R10  MOVTXTC
         LW,R2    BUFDUAL,R7        DISC ADDRESS OF DUAL
         AND,R2   M24
         BAL,R10  MOVHEX
         BAL,R15  DUMPBUF           PRINT THE LINE
*
         LW,R11   FL:DUAL
         STS,R11  BUFDA,R7          SET FLAG TO INDICATE DUAL
         BAL,R11  DISCIOA           READ THE DUAL
         BAL,R11  IOSPIN            WAIT FOR IT
         LW,R6    BUFADR,R7
         BAL,R10  VALBUF            RECHECK FIRST 3 WORDS
         BEZ      GRANER40          O.K.
         LW,R11   FL:DUAL           BAD DUAL, KILL READING IT
         STS,R10  BUFDA,R7
         LW,R11   Y8
         STS,R11  BUFDUAL,R7
         LI,R4    BA(MAST)
         BAL,R10  MOVTXTC
         LI,R4    X'FF'
         AND,R4   R15               GET CODE
         LW,R4    ERRTBL,R4
         AND,R4   M24
         BAL,R10  MOVTXTC
         LI,R4    BA(MBAK2PRIM)
         BAL,R10  MOVTXTC
         BAL,R15  DUMPBUF
         MTB,1    BUFNRT,R7         GET THE OLD ONE BACK
         BAL,R10  IORETRY
         BAL,R11  IOSPIN
         B        GRANXIT
*
*  RETRIES EXHAUSTED - NO DUAL OR DUAL BAD
*
GRANER38 LI,R8    0
         STB,R8   BUFNRT,R7         SET NO MORE RETRIES
         BAL,R10  IORETRY           RELEASE ANY LINKED BUFFERS
*
GRANER30 EQU      %
         BAL,R11  ERRMSG            PRINT ERROR MESSAGES
         BAL,R11  SNAPGRN           SNAP, OVERRIDING DUMPFLAG
         B        GRANXIT
*
GRANER40 LI,R15   0
         STW,R15  ERRCODE
         BAL,R11  IOSPIN            WAIT FOR I/O TO COMPLETE
GRANXIT  PULL     15,R0
         LW,R15   ERRCODE
         B        *R11
         TITLE    '****  ERRMSG  ****'
         SPACE    2
*D*  NAME:         ERRMSG
*D*  ENTRY:        ERRMSG1
*D*
*D*  REGISTERS:    R7 PRESERVED
*D*
*D*  CALL:         BAL,R11
*D*
*D*  INPUT:        R7 = BUF TABLE INDEX
*D*                CURMES = BA OF CURRENT MESSAGE
*D*                ERRCODE = ERROR CODE
*D*
*D*  DESCRIPTION:  PRINT MESSAGE 'ERROR IN XXX', WHERE XXX IS TEXTC
*D*                MESSAGE POINTED TO BY CURMES.
*D*                PRINT '**** YYYY   CODE = A', WHERE YYYY IS MESSAGE
*D*                POINTED TO BY ERROR MESSAGE TABLE, A = THE ERROR
*D*                CODE IN ERRCODE.
*D*                IF CODE INDICATES BAD DISC ADDRESS, PRINT THE
*D*                DISC ADDRESS IN CELL BADDA.
*D*                EXIT IF ENTERED AT ERRMSG1.
*D*                IF LINK CHECK FAILURE, PRINT EXPECTED LINK.
*D*                PRINT DISC ADDRESS OF CURRENT BUFFER (BUFDA).
*D*                IF KEY ASSOCIATED ERROR, PRINT WORD AND BYTE DISPL
*D*                INTO BUFFER OF CURRENT KEY.
*D*                PRINT FILE NAME AND ACCOUNT.
         SPACE    1
ERRMSG   PUSH     R11
         LI,R11   ERRM4A            RETURN FROM ERRMSG1
ERRMSG1  PUSH     R11
         MTW,1    ERRCNT            INCREMENT ERROR COUNT
         BUILD    (TEXT,MERRIN),(TEXT,*CURMES),(DUMPBUF)
*
         LI,R4    BA(MAST)          ' **** '
         BAL,R10  MOVTXTC
         LI,R4    #ERR              SIZE OF ERROR TABLE
         LI,R3    #ERR+ERRTBL       LOCATION OF LAST ENTRY IN TABLE
         LW,R5    ERRCODE
ERRM2    CB,R5    *R3               LOOK FOR THIS ERROR CODE
         BE       ERRM3             FOUND IT
         AI,R3    -1
         BDR,R4   ERRM2
         B        ERRM4             DIDN'T FIND IT
*
ERRM3    LI,R4    X'7FFFF'
         AND,R4   0,R3              BA OF MESSAGE
         BAL,R10  MOVTXTC
ERRM4    LI,R4    BA(MCODE)         '    CODE = '
         BAL,R10  MOVTXTC
         LI,R3    X'FF'
         AND,R3   ERRCODE
         BAL,R10  MOVDEC            CONVERT ERROR CODE TO DECIMAL
         LI,R15   ERRM4D
         LC       J:JIT
         BCR,8    DUMPBUF           NOT ONLINE - TO LP ONLY
         B        DUMPB             ONLINE - TELL USER ERROR MESSAGE
ERRM4D   LW,R15   ERRCODE
         CI,R15   BADA
         BAZ      ERRM4B            NOT BAD DISC ADDRESS
         BUILD    (TEXT,MBADDA),(HEX,*BADDA),(DUMPBUF)
*
ERRM4B   PULL     R3
         B        0,R3
*
ERRM4A   LI,R3    ERR#07
         CW,R3    ERRCODE
         BNE      ERRM5             NOT LINK CHECK FAILURE
         LI,R4    BA(MLINKCHK)      'EXPECTED LINK = '
         BAL,R10  MOVTXTC
         LW,R2    BUFDACHK,R7       EXPECTED LINK DISC ADDRESS
         AND,R2   M24
         BAL,R10  MOVHEX
         BAL,R15  DUMPBUF
*
ERRM5    EQU      %
*
         LI,R4    BA(MDISCADR)      'DISC ADDRESS'
         BAL,R10  MOVTXTC
         LW,R2    BUFDA,R7
         AND,R2   M24               DISC ADDRESS OF CURRENT BUFFER
         BAL,R10  MOVHEX            CONVERT TO EBCDIC, PUT IN PRINT BUF
         BAL,R15  DUMPBUF           PRINT THE LINE
*
         LI,R4    KEY
         CW,R4    ERRCODE           IS THIS A KEY-ASSOCIATED ERROR
         BAZ      ERRMSG5           NO
         LI,R4    BA(MERRLOC1)      'KEY LOCATION = WORD '
         BAL,R10  MOVTXTC
         LW,R2    CMDL              CURRENT BUFFER BYTE INDEX
         SLS,R2   -2                WORD INDEX
         BAL,R10  MOVHEX
         LI,R4    BA(MERRLOC2)      ', BYTE '
         BAL,R10  MOVTXTC
         LI,R2    3
         AND,R2   CMDL              BYTE OFFSET
         BAL,R10  MOVHEX
*
ERRMSG5  LW,R15   TYPEFLAG
         BLZ      ERRMSG8           ACCOUNT DIRECTORY
         BAL,R15  DUMPBUF
         LI,R1    5                 COL #
         LI,R4    BA(MACCT)
         BAL,R10  PUTMESC           ' ACCOUNT ='
         LI,R5    8                 # BYTES IN ACCOUNT
         LI,R4    BA(CURACCT)
         BAL,R10  MOVTXT
         LW,R15   TYPEFLAG
         BLEZ     ERRMSG8           NOT FILE
         LI,R1    26                COL #
         LI,R4    BA(MFNAME)
         BAL,R10  PUTMESC
         LI,R4    BA(CURFILE)
         BAL,R11  PRKEY
ERRMSG8  PULL     R15
         B        DUMPBUF           PRINT THE LINE
         TITLE    '****  SNAPGRAN  ****'
         SPACE    2
*F*  NAME:         SNAPGRAN
*F*
*F*  PURPOSE:      SNAP A BUFFER
*F*
*F*  DESCRIPTION:  DUMP A BUFFER IN HEX WITH EBCDIC TRANSLATION
         SPACE    1
*D*  NAME:         SNAPGRAN
*D*
*D*  REGISTERS:    R7 PRESERVED
*D*
*D*  CALL:         BAL,R11
*D*
*D*  INPUT:        R7 = BUF TABLE INDEX OF BUFFER TO BE DUMPED
*D*
*D*  DESCRIPTION:  IF BUFFER HAS BEEN PREVIOUSLY SNAPPED (FL:SNAP SET),
*D*                EXIT.  SET FL:SNAP.  PRINT DISC ADDRESS OF BUFFER
*D*                CONTENTS AND THE DUAL ADDRESS.  PRINT FILE
*D*                NAME AND ACCOUNT.  CALL HEXDUMP TO DUMP BUFFER.
         SPACE    1
SNAPGRAN RES
         MTW,0    DUMPFLAG          ONLY SNAP IF DUMPING
         BEZ      *R11
SNAPGRN  RES                        ENTRY FOR UNCONDITIONAL SNAP
         LW,R9    FL:SNAP           UNLESS, OF COURSE
         CW,R9    BUFDA,R7          HAS BUFFER ALREADY BEEN SNAPPED
         BANZ     *R11              YES - DO NOTHING
         STS,R9   BUFDA,R7
         PUSH     R11
*
         BUILD    (TEXT,MSNAPG),(TEXT,*CURMES)
         LW,R11   BUFDA,R7
         CW,R11   FL:DUAL
         BAZ      SNAP2             THIS ISN'T DUAL
         LI,R4    BA(MDUAL2)        ' DUAL'
         BAL,R10  MOVTXTC
SNAP2    EQU      %
         LI,R4    BA(MGRAN)         ' GRANULE '
         BAL,R10  MOVTXTC
         LW,R2    BUFDA,R7
         CW,R2    FL:DUAL
         BAZ      %+2
         LW,R2    BUFDUAL,R7        GET DUAL DISC ADDRESS
         AND,R2   M24               DISC ADDRESS OF CURRENT BUFFER
         BAL,R10  MOVHEX            CONVERT, MOVE TO PRINT BUFFER
*
         CW,R11   FL:DUAL
         BANZ     SNAP4             THIS IS THE DUAL
         LW,R11   BUFDUAL,R7
         BLEZ     SNAP4             NONE, OR BAD
         LI,R4    BA(MDUAL1)        ' DUAL = '
         BAL,R10  MOVTXTC
         LW,R2    BUFDUAL,R7
         AND,R2   M24               PUT DUAL ADDRESS IN MESSAGE
         BAL,R10  MOVHEX
*
SNAP4    LW,R15   TYPEFLAG
         BLZ      SNAP10            NOT FILE DIRECTORY OR FILE
         LI,R1    65                COLUMN #
         LI,R4    BA(MACCT)         'ACCOUNT = '
         BAL,R10  PUTMESC
         LI,R4    BA(CURACCT)
         LI,R5    8                 # CHARS
         BAL,R10  MOVTXT            MOVE THE CURRENT ACCOUNT
*
SNAP10   BAL,R15  DUMPBUF           PRINT THE LINE
*
         LW,R15   TYPEFLAG
         BLEZ     SNAP50            NOT FILE
         LI,R1    15                COLUMN #
         LI,R4    BA(MFNAME)        'FILE NAME = '
         BAL,R10  PUTMESC
         LI,R4    BA(CURFILE)       ADDRESS OF FILE NAME
         BAL,R11  PRKEY             PUT FILE NAME IN PRINT BUFFER
         BAL,R15  DUMPBUF
*
SNAP50   LW,R12   BUFADR,R7         VIRTUAL ADDRESS OF BUFFER
         LI,R13   512               # WORDS TO DUMP
         LI,R14   0                 ADDRESS TO PRINT
         PULL     R11
         B        HEXDUMP           DUMP IT
         TITLE    '****  PRFNAM  ****'
         SPACE    2
*F*  NAME:         PRKEY
*F*
*F*  PURPOSE:      MOVE TEXTC TO PRINT BUFFER.  IF TEXT CONTAINS ANY
*F*                NON-PRINTABLE CHARACTERS, ALSO PUT IN A HEX
*F*                DUMP OF THE STRING.
*F*
*F*  DESCRIPTION:  THE STRING IS MOVED TO THE PRINT BUFFER, AND
*F*                ANY NON-PRINTING CHARACTERS ARE TRANSLATED TO '.'.
*F*                IF ANY WERE FOUND, A HEX TRANLATION OF THE STRING
*F*                IS MOVED INTO THE PRINT BUFFER.
         SPACE    1
*D*  NAME:         PRKEY
*D*
*D*  REGISTERS:    ALL VOLATILE
*D*
*D*  CALL:         BAL,R11
*D*
*D*  INPUT:        R4 = BA OF KEY
*D*
*D*  DESCRIPTION:  THE KEY IS MOVED TO THE PRINT BUFFER.
*D*                ANY NON-PRINTING CHARACTERS ARE TRANSLATED TO
*D*                PERIODS.  IF ANY WERE FOUND, THE KEY IS
*D*                TRANSLATED TO HEX AND PLACED IN THE PRINT BUFFER.
         SPACE    1
PRKEY    STW,R4   TEMP+15           SAVE ADDRESS OF KEY
         BAL,R10  MOVTXTC           MOVE NAME TO PRINT BUFFER
         LW,R14   TEMP+15           BA OF KEY
         LW,R15   =X'20000000'+BA(TEMP)  DISTINATION = TEMP
         MBS,R14  0                 MOVE KEY TO TEMP
         LI,R4    BA(XLATE)         TRANSLATION TABLE
         LI,R5    BA(TEMP)+1
         LB,R15   TEMP              # BYTES IN NAME
         AND,R15  M5
         STB,R15  TEMP              MAKE SURE TEXTC ISN'T TOO BIG
         STB,R15  R5
         TBS,R4   0                 TRANSLATE NON-PRINTING CHARS TO '.'
*
         LW,R4    TEMP+15           BA OF FILE NAME
         LI,R5    BA(TEMP)+1        IF NAME IN TEMP IS NOT THE SAME
         STB,R15  R5                  AS IN CURFILE, AT LEAST ONE CHAR
         CBS,R4   1                   IS NON-PRINTABLE
         BE       *R11              ALL PRINTABLE - RETURN
         LI,R4    BA(MHEX1)         '  (X'''
         BAL,R10  MOVTXTC
         LW,R1    PRPOS             BA OF NEXT BYTE IN PRBUF
         LW,R6    TEMP+15           ADDRESS OF KEY
         LB,R4    0,R6              # BYTES IN NAME
PRK2     AI,R6    1                 INCR TO NEXT CHARACTER
         LB,R2    0,R6              GET NEXT DIGIT
         BAL,R15  BIN2HEX           CONVERT IT TO EBCDIC HEX
         CI,R5    1
         BNE      %+3
         SLS,R12  -8                LEADING ZERO - PUT IT IN
         OR,R12   =X'F0000000'
         SCS,R12  8                 NEXT DIGIT AT RIGHT
         STB,R12  0,R1              PUT IN PRBUF
         AI,R1    1
         SCS,R12  8
         STB,R12  0,R1
         AI,R1    1
         CI,R1    BA(PRBUF)+33*4
         BGE      PRK4              BEYOND END OF PRBUF
         BDR,R4   PRK2              DO REST OF CHARACTERS IN KEY
*
PRK4     STW,R1   PRPOS             NEW END OF BUFFER
         LI,R4    BA(MHEX2)         ')'''
         BAL,R10  MOVTXTC
         B        *R11
         TITLE    '****  PRFILE  ****'
         SPACE    2
*D*  NAME:         PRFILE
*D*
*D*  REGISTERS:    ALL VOLATILE
*D*
*D*  CALL:         BAL,R11
*D*
*D*  INPUT:        CURACCT = CURRENT ACCOUNT
*D*                CURFILE = CURRENT TEXTC FILE NAME
*D*
*D*  DESCRIPTION:  PRINT CURRENT FILE NAME AND ACCOUNT ON USER
*D*                CONSOLE.
         SPACE    1
PRFILE   PUSH     R11
         BAL,R15  INITBUF
         LI,R4    BA(MACCT)         'ACCOUNT ='
         BAL,R10  MOVTXTC
         LI,R4    BA(CURACCT)
         LI,R5    8                 # BYTES
         BAL,R10  MOVTXT            MOVE CURRENT ACCOUNT TO PRINT BUF
         LI,R4    BA(MACCT1)+1
         LI,R5    4
         BAL,R10  MOVTXT            MOVE SOME BLANKS
         LI,R4    BA(CURFILE)
         BAL,R11  PRKEY             PUT IN FILE NAME
         PULL     R15
         B        DUMPECHO          PRINT TO USER ONLY
         TITLE    '****  MESSAGES  ****'
         SPACE    2
MSG1     TEXTC    'BLINK/FLINK DISC ADDRESS BAD'
MSG2     TEXTC    'GRANULE CONTROL WORD BAD'
MSG2A    TEXTC    'SCR BAD'
MSG3     TEXTC    'LINK CHECK FAILURE'
MSG4     TEXTC    'BAD KEY'
MSG5     TEXTC    'FIT NAME DOESN''T MATCH DIRECTORY'
MSG6     TEXTC    'BAD FIT VLPS'
MSG7     TEXTC    'SEGMENT CONTROL WORD ERROR'
MSG8     TEXTC    'UNBLOCKED SEGMENT DISC ADDRESS BAD'
MSG10    TEXTC    'DUAL BLINK WRONG'
MSG11    TEXTC    'DUAL DISC ADDR WRONG'
MSG12    TEXTC    'DUAL FLINK BAD'
MSG21    TEXTC    'INCORRECT EOF FLAG'
MSG51    TEXTC    'ILLEGAL DISC ADDRESS'
MSG53    TEXTC    'DUAL ALLOCATION IN MASTER HGP'
MSG54    TEXTC    'DUAL ALLOCATION IN CURRENT FILE OR DIRECTORY'
MSG60    TEXTC    'INCORRECT FDA IN FIT'
MSG61    TEXTC    'INCORRECT LDA IN FIT'
MSG62    TEXTC    'INCORRECT CCBD IN FIT'
MSG63    TEXTC    'INCORRECT SIZE IN 0C VLP'
MSG64    TEXTC    'BAD GAVAL/NGAVAL IN FIT'
MSG99    TEXTC    'HARDWARE I/O ERROR'
MBADHEX  TEXTC    ' ILLEGAL HEX DIGIT'
MBADDEC  TEXTC    ' ILLEGAL DECIMAL DIGIT'
MERRIN   TEXTC    'B**** ERROR IN '
MFIT     TEXTC    'FIT'
MDISCADR TEXTC    ' **** DISC ADDRESS = '
MCODE    TEXTC    '    CODE = '
MSNAPG   TEXTC    'B SNAP OF '
MGRAN    TEXTC    ' GRANULE '
MDUAL1   TEXTC    '    DUAL = '
MDUAL2   TEXTC    ' DUAL'
MDUALRD  TEXTC    'B ATTEMPTING TO READ DUAL GRANULE '
MBAK2PRIM TEXTC   ' - REREADING PRIMARY GRAN'
MDELKEY  TEXTC    ' KEY DELETED - '
MTRUNC1  TEXTC    'A---> TRUNCATED AT PREVIOUS GRANULE <---'
MTRUNC2  TEXTC    'A---> FDA BAD - KEY REMOVED FROM DIRECTORY <---'
MERRLOC1 TEXTC    ' KEY LOCATION = WORD '
MERRLOC2 TEXTC    ', BYTE '
MACCT    TEXTC    ' ACCOUNT = '
MACCT1   TEXTC    '     ACCOUNT = '
MFNAME   TEXTC    'FILE NAME = '
MHEX1    TEXTC    '   (X'''
MHEX2    TEXTC    ''')'
MAST     TEXTC    ' **** '
MSPACE   TEXTC    '  '
MLINKCHK TEXTC    '    EXPECTED LINK = '
MBADDA   TEXTC    ' **** BAD DISC ADDRESS = '
MCONDEL  TEXTC    'A**** END OF GRANULE SET AT WORD '
MERLOG   TEXTC    'C ERROR LOG:'
         TITLE    '****  ERROR CODES  ****'
         SPACE    2
#ERR     SET      0
ERRTBL   EQU      %-1
         SPACE    2
ERR#01   ERR      1+TRUNC,MSG1      BLINK DISC ADDRESS BAD
ERR#02   ERR      2+TRUNC,MSG1      FLINK DISC ADDRESS BAD
ERR#03   ERR      3+TRUNC,MSG2      GRANULE NOT RIGHT TYPE (KEYED/CONSEC)
ERR#04   ERR      4+TRUNC,MSG2      KEYED NAV BAD
ERR#05   ERR      5+TRUNC,MSG2      KEYED MI LEVEL WRONG
ERR#06   ERR      6+TRUNC,MSG2A     SCR BAD
ERR#07   ERR      7+TRUNC,MSG3      LINK CHECK FAILURE
ERR#09   ERR      9+TRUNC,MSG2      CONSEC NAV BAD
ERR#10   ERR      10,MSG10          DUAL BLINK DISC ADDR WRONG
ERR#11   ERR      11,MSG11          DUAL DISC ADDR WRONG
ERR#12   ERR      12,MSG12          DUAL FLINK DA BAD OR MISSING
ERR#20   ERR      20+DEL+KEY,MSG4   KEY BYTE COUNT BAD
ERR#21   ERR      21+KEY+NORETRY,MSG21 INCORRECT EOF FLAG
ERR#22   ERR      22+DEL+KEY+BADA,MSG4  MASTER DA BAD
ERR#23   ERR      23+DEL+KEY+BADA,MSG4  DUAL DA BAD
ERR#24   ERR      24+DEL+KEY,MSG4   BLDISP/BLKSIZE BAD
ERR#25   ERR      25+DEL+KEY,MSG4   BLK BAD
ERR#26   ERR      26+DEL+KEY,MSG4   FLAGS BAD
ERR#31   ERR      31+TRUNC,MSG5     FIT NAME DIFFERS FROM DIRECTORY
ERR#32   ERR      32+TRUNC,MSG6     FIT VLP CHAIN DOESN'T TERMINATE
ERR#33   ERR      33+TRUNC,MSG6     REQUIRED FIT VLP MISSING
ERR#34   ERR      34+TRUNC,MSG6     FIT X!09' VLP BAD
ERR#35   ERR      35+TRUNC,MSG6     FIT X'0C' VLP BAD
ERR#40   ERR      40+DEL+KEY,MSG7   SEG CNTRL WORD BYTE COUNT TOO BIG
ERR#41   ERR      41+DEL+KEY,MSG7   SEG CNTRL WORD BACK POINTER BAD
ERR#42   ERR      42+DEL+KEY,MSG7   SEG CNTRL WORD ILLEGAL HERE
ERR#43   ERR      43+DEL+KEY,MSG8   CONSEC UNBLOCKED DISC ADDR BAD
ERR#44   ERR      44+DEL+KEY,MSG7   CONSEC BKSPC CNTRL WORD ERROR
ERR#51   ERR      51+NORETRY+BADA,MSG51  NO HGP FOR THIS DCTX
ERR#52   ERR      52+NORETRY+BADA,MSG51  RELATIVE SECTOR NOT IN HGP
ERR#53   ERR      53+NORETRY+BADA,MSG53  DUAL ALLOCATION IN MASTER HGP
ERR#54   ERR      54+NORETRY+BADA,MSG54  DUAL ALLOCATION IN CURRENT HGP
ERR#60   ERR      60+NORETRY,MSG60  FDA BAD IN FIT
ERR#61   ERR      61+NORETRY,MSG61  LDA BAD IN FIT
ERR#62   ERR      62+NORETRY,MSG62  CCBD BAD IN FIT
ERR#63   ERR      63+NORETRY,MSG63  SIZE BAD IN FIT
ERR#64   ERR      64+NORETRY,MSG64  GAVAL/NGAVAL BAD
ERR#99   ERR      99+TRUNC,MSG99    HARDWARE I/O ERROR
         TITLE    '****  EBCDIC TRANSLATION TABLE  ****'
         SPACE    2
XGEN     CNAME
         PROC
XLATE    EQU      %
         DO       256/4
         TEXT     '....'            GENERATE TABLE OF PERIODS
         FIN
XLEND    EQU      %
LEGCHARS SET      'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789',;
                  '.(+|&%*);,-/%:#@''=<> ',;
                  '`!ž?"~' CENT-BANG-UNDERSCORE-QUES-DBLQUOTE-NOT
LEGC     SET      S:UT(LEGCHARS)
I        DO       LPTYPE
         ORG,1    BA(XLATE)+LEGC(I)
         DATA,1   LEGC(I)
         FIN
         ORG      XLEND
         PEND
*
         XGEN
         TITLE    '****  STATIC DATA  ****'
         SPACE    2
         BOUND    8
DECNUM   DATA     '0','9'
HEXNUM   DATA     'A','F'
BLANKS   TEXT     ' '
*
CNVRT    TEXT     '0123456789ABCDEF'
XFF00FFFF DATA    X'FF00FFFF'
EOFBIT   EQU      %
X2       DATA     X'00000002'
M2       DATA     X'00000003'
M4       DATA     X'0000000F'
M5       DATA     X'0000001F'
M7       DATA     X'0000007F'
M8       DATA     X'000000FF'
M19      DATA     X'0007FFFF'
M24      DATA     X'00FFFFFF'
Y0008    DATA     X'00080000'
Y002     DATA     X'00200000'
Y004     DATA     X'00400000'
Y01      DATA     X'01000000'
Y1       DATA     X'10000000'
Y2       DATA     X'20000000'
Y0A      DATA     X'0A000000'
Y00FF    DATA     X'00FF0000'
Y3       DATA     X'30000000'
Y3FFF    DATA     X'3FFF0000'
Y8       DATA     X'80000000'
*
IR6R3    LB,0     *R6,R3            FOR ANLZ INSTRUCTION
IR13     LB,0     *R13              ANLZ
         TITLE    '****  DYNAMIC DATA  ****'
         SPACE    2
         CSECT    0
FIXSD:   TEXT     'FIXSD'
*
BLKDISP  RES      1
BLKSIZE  RES      1
DABLK    RES      1
DADUAL   RES      1
FLAGSDSP RES      1                 DISP TO FLAGS
FLAGS    RES      1                 FLAGS FROM CURRENT KEY
PREVFLAG RES      1                 FLAGS OF PREVIOUS KEY
FITNAME  RES      1
ELOGFPT  RES      1
*
*  HEXDUMP
*
DMPFLG   DATA     0                 DUMP TO LP
DUPFLAG  RES      1
#COL     RES      1
#BYTES   RES      1
#BYTES1  RES      1
#SPACES  RES      1
*
*  TBLDMP
*
         BOUND    8
TBLXPSD  DATA     0,0
         :PSD     (IA,TBLDMP),(WK,1),MASTER,MAP
TBLREGS  RES      16
*
DISCDCB  DATA     1
         DO1      8
         DATA     0
         END

