P1       CSECT    1
D1       CSECT    0
*
M:DO     DSECT    1
*
UTSPROC  SET      1
S69PROC  SET      1
MONPROC  SET      1
DISCBPROC SET     1
         SYSTEM   UTS
         SYSTEM   BPM
*
         PCC      0
,FPT0,FPT1 M:PT   1                 FPT'S IN PROTECTED MEMORY
*
P1:      EQU      P1
FPT0:    EQU      FPT0
PT:      EQU      PT
         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    3
PC       EQU      '<'
         SPACE    1
C        EQU      1
EOF      EQU      2
FAK      EQU      4
         SPACE    1
HOU      EQU      3
         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'
KEY      EQU      X'8000'
         SPACE    1
OCRDCNT  EQU      80
         SPACE    1
JITBUF   EQU      X'1FA00'
AJITBUF  EQU      X'1FC00'
RBUF     EQU      JITBUF
RBUFEND  EQU      RBUF+511+512
UTSTACK  EQU      TSTACK-J:JIT+JITBUF
         SPACE    1
ADSCR    EQU      9
ADKSIZE  EQU      ADSCR+3+3+2+1
FDSCR    EQU      32
FDKSIZE  EQU      FDSCR+4+5
         TITLE    '****  ASSEMBLY SWITCHES  ****'
         SPACE    2
DEBUG    SET      1                 1 = DEBUG
         SPACE    2
VERS     SET      1                 1 = ALLOW USE ON B00 SYSTEMS
         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
         SPACE    2
TAB      SET      X'05'             TAB CHAR FOR TXTC PROC
CR       SET      X'15'             CARRIAGE RETURN
         TITLE    '****  EXTERNAL DEFINITIONS  ****'
         SPACE    2
         DEF      D1
         DEF      P1
         DEF      P1:
         DEF      PT
         DEF      PT:
         DEF      FPT0
         DEF      FPT0:
         TITLE    '****  EXTERNAL REFERENCES  ****'
         REF      ACNCFU
         REF      ALLODIRA
         REF      ALLOQ
         REF      ALLOREG
         REF      AVRTBL
         REF      AVRTBLNE
         REF      AVRTBLSIZ
         REF      BATAPE
         REF      BGRAN
         REF      BGRCFU
         REF      BOOTFLG
         REF      CHKDAQ
         REF      CFUSIZE
         REF      CURGRAN
         REF      CYL%SHFT
         REF      DATE
         REF      DCTSIZ
         REF      DCT1
         REF      DCT3
         REF      DCT7
         REF      DCT22
         REF      DCT24
         REF      DISCLIMS
         REF      DUMPFILE
         REF      E:CBK
         REF      E:IC
         REF      E:OCR
         REF      E:SL
         REF      ERBLOCK
         REF      F:MONDMP
         REF      F:RB
         REF      FGRAN1
         REF      FGRAN2
         REF      FGRAN3
         REF      GBG
         REF      GI:SDA
         REF      GIB:UN
         REF      GMB
         REF      HGP
         REF      HGPSIZE
         REF      INCREMENT%SECTOR
         REF      J:EUP
         REF      J:JIT
         REF      J:TCB
         REF      J:TELFLGS
         REF,1    JB:PNR
         REF,1    JB:BCP
         REF      JBUPVPA
         REF      JCLE
         REF      JDA
         REF      JDDLL
         REF      JDLL
         REF      JLMAP
         REF      JVLH
         REF      LASTCFU
         REF      LFGUN
         REF      LLNDD
         REF      LPART
         REF      M:ADRINCR
         REF      M:C
         REF      M:GASLIM
         REF      M:SI
         REF      M:UC
         REF      MB:GAM6
         REF      MB:GAM7
         REF      MB:SDI
         REF      NCYL
         REF      NEWQNWM
         REF      NSPC
         REF      NSPT
         REF      OCDCT
         REF      OPNCLSTK
         REF      OPNCLSUS
         REF      P:NAME
         REF      PH:DDA
         REF      PL:CHG
         REF      PL:JIF
         REF      PLH:FLG
         REF      PNAMEND
         REF      QUEUE
         SREF     RA:DA
         SREF     RAB:BLINK
         SREF     RB:FLAG
         REF      RBG
         SREF     RBLIMSIX
         SREF     RBLIMSZ
         REF      RCVCODE
         REF      RCVRAD
         REF      RCVRCNT
         REF      RCVRGFC
         REF      RCYL
         REF      RMB
         REF      RSG
         REF      S:CUN
         REF      S:DP
         REF      S:GJOBTBL
         REF      S:MBSF
         REF      SEC%SHFT
         REF      SGCHD
         REF      SGRAN
         REF      SIOMF
         REF      SIOW
         REF      SNDDX
         REF      SSTAT
         REF      SYSACCT
         SREF     T:RAREL
         REF      T:REG
         REF      T:RUE
         REF      T:UBLKOCU
         REF      TABLE
         REF      TABLESZ
         REF      TIME
         REF      TRK%SHFT
         REF      U:MISC
         REF      UB:ACP
         REF      UB:APR
         REF      UB:ASP
         SREF     UB:C#
         REF      UB:DB
         REF      UB:MF
         REF      UB:SWAPI
         REF      UB:US
         REF      UH:FLG
         REF      75BUF
         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
EABR     CNAME
         PROC
LF       SET      %-EABR+X'F0'
         B        AF
         PEND
         SPACE    2
TXTC     CNAME
         PROC
         LOCAL    I,VEC
LF       SET      %
VEC      SET      NUM(S:UT(AF)),S:UT(AF),' ',' ',' '
I        DO       NUM(VEC)/4
         GEN,8,8,8,8  VEC(I*4-3),VEC(I*4-2),VEC(I*4-1),VEC(I*4)
         FIN
         PEND
         TITLE    '****  INITIALIZATION  ****'
         SPACE    2
         USECT    P1
START    EQU      %
         LI,R8    M:LO
         STW,R8   ECHODCB           ASSUME BATCH
*
         LI,R2    63
         STB,R2   DCTX,R2           SET UP DCTX FOR PUBLIC
         BDR,R2   %-1
         STB,R2   DCTX
*
         M:XCON   XCONADR           EXIT CONTROL
         M:INT    INTADR            INTERRUPT CONTROL
         M:PC     PC                PROMPT CHARACTER
         M:DEVICE M:DO,VFC
         M:DEVICE M:LO,VFC
         LI,R1    X'1FFFF'
         AND,R1   F:FIX+FLP         ADDRESS OF F:FIX VLPS
         LI,R6    0
         LI,R12   1                 SEARCH FOR FILE NAME
         BAL,R4   LOCC2
         NOP
         STW,R1   FIXNAME           SAVE ADDRESS OF FILE NAME
         LI,R1    X'1FFFF'
         AND,R1   F:FIX+FLP
         LI,R12   2                 SEARCH FOR ACCOUNT
         BAL,R4   LOCC2
         NOP
         STW,R1   FIXACCT
         LI,R8    TCBSTK-1          SET UP TCB STACK POINTER TO
         LW,R9    =TCBSTKSZ**16       POINT TO LFG DATA
         STD,R8   *J:TCB
         DO       VERS=1
         LI,R8    ALLODIRA          IS IT C00 OR LATER
         BNEZ     %+2               YES
         MTW,1    VERSFLAG          SET PRE-C00 FLAG
         FIN
         LC       J:JIT
         BCS,4    START4            GHOST
         BCR,8    START5            BATCH
         LI,R8    M:UC
         STW,R8   ECHODCB           ONLINE
         LI,R14   MPROMPT           'FIX HERE'
         BAL,R11  DOPRINT
         B        START5
*
START4   LI,R8    M:OC
         STW,R8   ECHODCB
START5   M:SYS,E  M:SYSFPT          MASTER MODE
         BCS,8    PRIVLOW           NOT ENOUGH PRIVILEGE
         CI,R8    QUEUE
         BNE      BADMON            WRONG MONSTK
         LC       J:JIT
         BCS,4    GHSTINIT          GHOST
         BCR,8    BTCHINIT          BATCH
         LI,R14   MASPDB
         LW,R6    S:CUN
         LB,R4    UB:ASP,R6         CAN'T FORCE EXTENDED USER
         BNEZ     MESSOUT             SIZE IF SPECIAL SHARED
         LB,R4    UB:DB,R6            PROCESSOR, LIBRARY, OR
         BNEZ     MESSOUT             DEBUGGER ASSOCIATED
         LW,R9    Y002
         STS,R9   J:TELFLGS         SET EXTENDED FLAG
         LI,R9    X'FF'
         STW,R9   J:EUP             CHANGE END USER PAGE
         LI,R2    JB:BCP
         STB,R9   0,R2              INCR BOTTOM COMMON PAGE
         B        RDLOOP
BTCHINIT M:READ   M:C,(BUF,INBUF),(SIZE,80),(ERR,RDLOOP),(ABN,RDLOOP)
         SPACE    3
*
*  BATCH/ONLINE  -  READ AND PROCESS COMMANDS
*
RDLOOP   BAL,R11  READ              READ A RECORD
         BCS,1    EXIT              EOF
*
RDLOOP2  BAL,R11  GETFIELD          GET COMMAND FIELD
         BCS,4    LOOPEND           BLANK LINE
*
         LI,R11   0
         STW,R11  CURFILE           RESET FILE NAME
         STW,R11  CURACCT             AND ACCOUNT
*
         LI,R2    0
         LI,R3    #COM              RESET COMMAND
         STW,R2   COMFLAG-1,R3        PRESENT FLAGS
         BDR,R3   %-1
*
         STW,R2   ERRCNT            ZAP # ERRORS ENCOUNTERED
         LI,R2    63
         STB,R2   DCTX,R2           INITIALIZE DCT CONVERSION
         BDR,R2   %-1                 TABLE ONE-TO-ONE
         STB,R2   DCTX
*
         LI,R2    #COM
CHKCOM   LW,R3    COMTXT-1,R2
         CW,R3    FBUF
         BE       FNDCOM            FOUND IT
         BDR,R2   CHKCOM
         LI,R14   MUNKCOM           'UNKNOWN COMMAND'
         B        ERROR2
         SPACE    3
*
*  LEGAL COMMAND
*
FNDCOM   STW,R2   COMINDX           SAVE COMMAND TABLE INDEX
         MTW,1    COMFLAG-1,R2      SET COMMAND PRESENT FLAG
         BAL,R11  PARSE             SEARCH FOR OPTIONS
         LW,R2    COMINDX
         B        COMLOC-1,R2       GO TO APPROPRIATE ROUTINE
         SPACE    2
MAIL     LI,R2    MAILFLAG
         B        SRFLAG
*
AUTO     LI,R2    AUTOFLAG
         B        SRFLAG
*
COMP     LI,R2    COMPFLAG
         B        SRFLAG
*
SNAP     LI,R2    SNAPFLAG
SRFLAG   LI,R3    0                 ASSUME NO
         LI,R11   B:YES
         CW,R11   CUROPT            WAS 'YES' PRESENT
         BAZ      %+2               NO
         LI,R3    1
         STW,R3   0,R2              SET/RESET THE FLAG
         B        LOOPEND
         TITLE    '****  ACCOUNT/FILE DIRECTORY  ****'
         SPACE    2
*
*  CHECK/FIX/DUMP ACCOUNT DIRECTORY
*
         SPACE    1
ACNDIR   EQU      %
         MTW,1    WORKFLAG          SET USEFUL WORD DONE
         BAL,R11  ALLOCBUF          GET CORE BUFFERS
         B        NOPAGES           NOT ENOUGH CORE
         LW,R11   BUFMAX
         AI,R11   -4
         LI,R2    3
         STB,R11  TYPMAX,R2         ALL BUT 4 BUFFERS ARE
         MTB,4    TYPMAX            TYPE 3, OTHER 4 ARE TYPE 0
         LI,R11   0
         STW,R11  SRCHKEY
         STW,R11  CURBUF
         STW,R11  PREVBUF
         STW,R11  PREV1BUF
         STW,R11  NXTBUF
         STW,R11  FITBUF
         STW,R11  DIRBUF
         STW,R11  ORDRFLAG
         STW,R11  LOCDA
         LW,R2    SN
         BNEZ     ACNDIR4
         LW,R2    Y002              NO SERIAL #
         CW,R2    F:PV              IF DCB OPEN, CLOSE IT TO
         BAZ      ACNDIR4             RELEASE PRIVATE PACK
         M:CLOSE  F:PV,REL
*
ACNDIR4  LW,R10   CUROPT
         CI,R10   B:AD+B:FD         IF EITHER 'AD' OR 'FD'
         BANZ     ACNDR15             SPECIFIED, SEARCH DIRECTORIES
         LI,R4    0                 PREPARE TO RESET NXTF FLAG
         CI,R10   B:FNAM
         BANZ     %+2               IF SPECIFIC FILE NAME NOT GIVEN,
         LI,R4    X'400'              SET NXTF FLAG IN OPEN FPT
         STW,R4   NXTF
*
         LW,R11   REMFLAG
         BNEZ     ACNDR15           SEARCH DIRECTORIES IF REMOVE
         B        FIT
*
ACNDR10  LI,R15   B:FNAM
         STS,R15  CUROPT            FORCE FIT TO BE FOUND
*
ACNDR15  BAL,R11  DCTSET            SET UP VOL # TO DCT INDEX TABLE
         BAL,R15  GETOCU            BECOME OPEN/CLOSE USER
         BAL,R11  ADINIT            SET UP ACCOUNT DIR VALUES
*
         LCI      2
         LM,R2    CURACCT           CURRENT ACCOUNT
         DO       VERS=1
         LW,R11   VERSFLAG
         BEZ      ACNDR20           NOT PRE-C00
         LW,R1    =X'0B404040'      FORM PRE-C00 ACCN DIR KEY
         LCI      3
         STM,R1   SRCHKEY           STORE KEY TO SEARCH FOR
         B        ACNDR30
         FIN
*
ACNDR20  STB,R3   SRCHKEY+2         SAVE LAST BYTE OF KEY
         SLD,R2   -8
         LCI      2
         STM,R2   SRCHKEY           PUT AWAY KEY
         LI,R11   8
         STB,R11  SRCHKEY           TEXTC COUNT
*
ACNDR30  LW,R8    ACNCFU+FDA        MASTER FIRST DISC ADDR
         LW,R9    ACNCFU+DFDA       DUAL FIRST DISC ADDRESS
         LW,R11   SN
         BEZ      ACNDR35           PUBLIC
         LI,R8    DPADFDA           ACCOUNT DIRECTORY DISC ADDRESS
*
ACNDR35  BAL,R11  SRCHDIR           SEARCH ACCOUNT DIRECTORY
         B        ENDPROC2          ERROR
*
         LI,R11   B:FD+B:ACCT+B:FNAM  IS FILE DIRECTORY TO BE SEARCHED
         CW,R11   CUROPT
         BAZ      ENDPROC2          NO
*
         LW,R9    LOCDA             WAS ACCOUNT FOUND
         BLEZ     FILDIR20          NO
         BAL,R11  FDINIT            SET UP FILE DIR VALUES
         LI,R8    BA(CURFILE)
         LW,R9    =X'20000000'+BA(SRCHKEY)  MOVE CURRENT FILE NAME
         MBS,R4   0                   TO SEARCH KEY
         LW,R8    LOCDA             MASTER DISC ADDRESS
         LW,R9    LOCDUAL           DUAL DISC ADDRESS
         BAL,R11  SRCHDIR           SEARCH DIRECTORY
         B        ENDPROC2
         B        FILDIR40
*
FILDIR20 LI,R14   MNOSACCT          'NO SUCH ACCOUNT'
FILDIR30 BAL,R11  DOPRINT
         B        ENDPROC2
*
FILDIR40 LI,R9    B:FNAM
         CW,R9    CUROPT
         BANZ     FIT               GO GET FIT
*
ENDPROC2 EQU      %
         BAL,R11  RBUFS             RELEASE ALL BUFFERS
         LI,R7    0
         XW,R7    DIRBUF
         BEZ      %+2
         BAL,R15  RELBUF
         BAL,R11  REL
         LW,R11   Y002
         CW,R11   F:FIX
         BAZ      %+2
         M:CLOSE  F:FIX,SAVE        CLOSE F:FIX IF OPEN
         BAL,R15  INITBUF
         LI,R4    BA(MSPACE)        PUT IN SPACE FOR VFC
         BAL,R10  MOVTXTC
         LI,R4    BA(MERR1)
         LW,R3    ERRCNT
         BEZ      ENDPR4            NO ERRORS
         BAL,R10  MOVDEC
         LI,R4    BA(MERR)          ' ERROR'
ENDPR4   BAL,R10  MOVTXTC
         LI,R4    BA(MS)            'S'
         LW,R3    ERRCNT            # ERRORS ON THIS COMMAND
         CI,R3    1
         BE       %+2
         BAL,R10  MOVTXTC           MAKE MESSAGE PLURAL
         BAL,R15  DUMPB
         B        LOOPEND
         SPACE    3
*
*  COMMAND PROCESSING COMPLETED
*
LOOPEND  LC       J:JIT
         BCR,4    RDLOOP            BATCH/ONLINE - READ ANOTHER
         B        GHSTI1            ISSUE ANOTHER READ
GHSTIDLE EQU      %
         DISABLE                    ****  DISABLE
         LW,R11   OCREQ1            IS OC BEING READ FOR COMMANDS
         BNEZ     GHSTI2            YES
         XW,R11   OCREQ             DOES OPERATOR WANT TO START READ
         BEZ      GHSTI5            NO - NOTHING TO DO
         ENABLE                     ****  ENABLE
         LI,R14   MPROMPT           'FIX HERE'
         BAL,R11  DOPRINT
         MTW,1    OCREQ1            SET READING IN PROGRESS
GHSTI1   LI,R4    BA(MKEYIN)        MESSAGE TO WRITE
         BAL,R11  KEYIN             START THE READ
         B        GHSTIDLE          WAIT FOR READ TO COMPLETE
*
GHSTI2   LW,R11   OCIOCNT           IS READ REQUEST FINISHED
         BNEZ     GHSTI5            NO
         ENABLE                     ****  ENABLE
         STW,R11  OCREQ             CLEAR REQUEST FLAG
         LW,R11   INCNT             # BYTES READ
         BEZ      EXIT              NONE - FINISHED
         B        RDLOOP2           PROCESS COMMAND
*
GHSTI5   M:WAIT   50*30             SLEEP FOR 30 MINUTES
         B        GHSTIDLE
         SPACE    4
*
*  SEE IF FIT IS TO BE READ
*
FIT      EQU      %
         LW,R8    DIRBUF
         BEZ      FILE10            HAVEN'T SEARCHED DIRECTORY
         LW,R8    LOCDA             MOVE FIT DISC ADDRESS
         BLEZ     FILE99            NO SUCH FILE FOUND
         B        FILE20
*
FILE10   BAL,R11  RELOCU            DON'T ISSUE M:OPEN WHILE OPNCLSUS
         LI,R9    5
         STW,R9   BUSYCNT           # TIMES TO TRY IF FILE BUSY
         STW,R9   BUSYFLAG
FILE12   LI,R1    0                 RESET ERROR FLAG
         LW,R4    NXTF
FILE12A  LI,R5    X'400'
         STS,R4   OPNFIX+1          SET OR RESET NXTF FLAG
         M:OPEN,E OPNFIX            OPEN THE FILE
         LI,R4    0
         LW,R5    Y008
         STS,R4   OPNFIX            RESET NXTA FLAG
         LCI      2
         LM,R4    *FIXACCT          MOVE ACCOUNT AND FILE
         STM,R4   CURACCT             FROM DCB TO
         LCI      8                   FPT
         LM,R3    *FIXNAME
         STM,R3   CURFILE
         LW,R9    Y002
         CW,R9    F:FIX
         BANZ     FILE15            NO ERRORS IF DCB OPEN
         CI,R1    X'02'
         BE       FILEX10           END OF FILES ON OPEN NEXT
         CI,R1    X'75'
         BE       ACNDR10           FILE INCONSISTENCY - SEARCH DIRECTORY
         CI,R1    X'03'
         BE       FILE99            NO SUCH FILE
         LI,R4    0                 PREPARE TO RESET NXTF FLAG
         CI,R1    X'08'
         BE       FILE12A           SYNON - RESET NXTF AND OPEN
         CI,R1    X'14'
         BNE      FILE90            UNKNOWN ERROR
         CI,R2    1                 CHECK FOR 14-01
         BNE      FILE90
         LI,R14   MFILBUSY          'FILE BUSY'
         XW,R4    BUSYFLAG
         BEZ      %+2               ALREADY PRINTED MESSAGE ONCE
         BAL,R11  DOPRINT
         MTW,-1   BUSYCNT
         BEZ      FILE14            NO MORE RETRIES
         M:WAIT   3                 WAIT A WHILE
         LI,R4    0
         B        FILE12A           TRY AGAIN
*
FILE14   LI,R4    BA(MFILSKIP)      'FILE SKIPPED'
         BAL,R10  MOVTXTC
         LI,R4    BA(CURFILE)       BA OF FILE NAME
         BAL,R11  PRKEY             PUT NAME IN BUFFER
         LI,R4    BA(MACCT1)        '  ACCOUNT = '
         BAL,R10  MOVTXTC
         LI,R4    BA(CURACCT)       ACCOUNT
         LI,R5    8                 # BYTES
         BAL,R10  MOVTXT
         BAL,R15  DUMPBUF
         B        FILEXIT
*
FILE15   M:TRUNC  F:FIX             RELEASE ANY BUFFERS
         LI,R1    X'1FFFF'
         AND,R1   F:FIX+CFU         CFU ADDRESS
         LW,R8    FDA,R1            FDA OF FILE
         LI,R9    X'30'
         CS,R9    F:FIX+ORG
         BNE      %+2
         LW,R8    SREC,R1           GET RANDOM FILE FIT DISC ADDR
FILE20   STW,R8   FITDA             SAVE ADDRESS OF FIT
         BAL,R11  RELOCU            RELEASE OPEN/CLOSE USER
         LW,R7    FITBUF
         BNEZ     FILE30            DON'T GET BUFFER IF ALREADY HAVE ONE
         LI,R2    0
         BAL,R15  GETBUF            GET TYPE 0 BUFFER
         BEZ      %                 ERROR
         STW,R7   FITBUF
FILE30   LW,R8    FITDA
         STW,R8   BUFDA,R7
         BAL,R11  DISCRD
         BAL,R11  IOSPIN
         LW,R15   BUFINFO,R7        COMPLETION CODE
         BNEZ     FILERR            HARDWARE READ ERROR
         BAL,R11  FITCHK            VALIDATE FIT
         BNEZ     FILERR            BAD FIT
         LI,R7    0
         XW,R7    DIRBUF
         BEZ      %+2
         BAL,R15  RELBUF            RELEASE DIRECTORY BUFFER
         LW,R7    FITBUF
         LW,R11   DUMPFLAG
         BEZ      %+2
         BAL,R11  SNAPGRAN
         LW,R11   HGPRFLAG
         BNEZ     FILE40
         LI,R11   B:FIT
         CW,R11   CUROPT
         BANZ     FILEXIT           EXIT IF ONLY FIT WANTED
         LW,R11   Y002
         CW,R11   F:FIX
         BAZ      FILE10            OPEN DCB IF NOT OPEN
*
FILE40   LI,R2    BA(MFILE)
         STW,R2   CURMES            CURRENT MESSAGE = 'FILE'
         LI,R2    0
         STW,R2   #RECS             INITIALIZE # RECORDS IN FILE
         STW,R2   SRCHKEY           DON'T LOOK FOR SPECIFIC KEY
         LW,R2    ORGL              ORGANIZATION OF FILE
         B        %,R2
         B        CONSEC
         B        KEYED             KEYED FILE
         B        RANDOM            RANDOM FILE
         SPACE    3
*
*  CONSECUTIVE FILE
*
CONSEC   EQU      %
         LW,R6    BUFADR,R7         ADDRESS OF FIT BUFFER
         LW,R8    FLINK,R6
         BEZ      CON10             ONE GRANULE FILE
*
         LI,R2    3
         BAL,R15  GETBUF            GET TYPE 3 BUFFER
         BEZ      %                 ERROR
         STW,R8   BUFDA,R7
         LW,R2    FITBUF
         STB,R7   BUFLINK,R2        LINK FIT BUFFER TO NEXT
         LW,R8    BUFDA,R2          FIT DISC ADDRESS
         AND,R8   M24
         STW,R8   BUFDACHK,R7       LINK CHECK DA FOR NEXT GRAN
         BAL,R11  DISCRD            START READ OF NEXT GRANULE
*
CON10    LW,R7    FITBUF
         STW,R7   CURBUF            CURRENT BUFFER IS FIT
*
CON20    BAL,R11  IOSPIN            WAIT FOR I/O TO COMPLETE
         LW,R6    BUFADR,R7
         LW,R15   BUFINFO,R7
         BNEZ     CONERR            ERROR ON THIS GRANULE
         LI,R10   MIDIS
         STW,R10  CMDL              SET CURRENT MI INDEX
         LW,R10   ORGL
         CI,R10   1
         BLE      CON25             CONSECUTIVE
         BAL,R11  FNDKEY            CHECK KEYED GRANULE
         NOP
         BNEZ     FILEXIT
         B        CON26
*
CON25    BAL,R10  CHKCON            CHECK IT
*
         LW,R10   #RECS1            INCREMENT # RECORDS IN FILE BY
         AWM,R10  #RECS               # RECORDS IN THIS GRANULE
*
CON26    LW,R8    BUFDA,R7
         AND,R8   M24               SAVE DISC ADDRESS IN CASE
         STW,R8   LDAL                THIS IS LAST GRANULE
*
         LW,R11   DUMPFLAG
         BEZ      %+2
         BAL,R11  SNAPGRAN          DUMP GRANULE IF COMMAND = DUMP
*
         LW,R7    CURBUF
         XW,R7    PREVBUF           CURRENT BUFFER BECOMES PREVIOUS
         BEZ      CON30             NO PREVIOUS
         CW,R7    FITBUF
         BE       CON30             DON'T RELEASE FIT BUFFER
         BAL,R15  RELBUF
CON30    LW,R7    CURBUF
         LB,R7    BUFLINK,R7        NEXT BUFFER
         STW,R7   CURBUF            NEW CURRENT BUFFER
         BNEZ     CON20
         B        FILEXIT           AT END
*
*  ERROR IN CONSECUTIVE FILE
*
CONERR   BAL,R11  GRANERR           RETRY IT
         BEZ      CON20             RETRY SUCCESSFUL
         CI,R15   TRUNC
         BAZ      FILEXIT           SOLUTION TO ERROR ISN'T TRUNCATION
         LW,R11   FIXFLAG
         BEZ      FILEXIT           NOT 'FIX'
         BAL,R11  TRUNCATE          TRUNCATE THE FILE
         B        FILEXIT           NO MORE RETRIES
         SPACE    3
*
*  KEYED FILE
*
KEYED    EQU      %
         LW,R11   HGPRFLAG
         BEZ      CONSEC            IGNORE UPPER LEVEL IF NOT RECON
         LI,R2    0
         BAL,R15  GETBUF            GET BUFFER TO READ UPPER MI
         STW,R7   DIRBUF
         LW,R1    VLP0C             ADDRESS OF X'0C' VLP
         LW,R8    TDA,R1            DISC ADDR OF TOP OF MUL
         BEZ      KEY60             NO UPPER LEVEL EXISTS
         STW,R8   BUFDA,R7
         LI,R9    -1
         STW,R9   LINKFLAG          NO LINK CHECKING
KEY10    BAL,R11  DISCRD
         BAL,R11  IOSPIN
         LI,R11   -1
         STW,R11  KEYLEVEL          DO NOT CHECK KEY LEVEL
         LI,R11   0
         STW,R11  LINKFLAG          PERFORM LINK CHECKING
         LW,R6    BUFADR,R7
KEY20    BAL,R10  VALBUF            VALIDATE FIRST 3 WORDS
         BEZ      KEY40             OK
         BAL,R11  GRANERR
         BEZ      KEY20             TRY AGAIN
*
*  UNRECOVERABLE ERROR - GET RID OF MUL
*
KEY30    LI,R14   MMULDEL
         BAL,R15  PRINT
KEY32    BAL,R11  IOSPIN
         LB,R2    BUFLINK,R7        GET NEXT LINKED BUFFER
         STW,R2   TEMP
         CW,R7    DIRBUF
         BE       %+2
         BAL,R15  RELBUF
         LW,R7    TEMP
         BNEZ     KEY32             RELEASE ALL BUFFERS
         LW,R2    FITBUF
         LW,R9    FL:UPDT
         STS,R9   BUFDA,R2          SET FIT UPDATED
         LI,R2    TDA
         STW,R7   *VLP0C,R2         ZAP TDA IN FIT
         LI,R2    3
         LW,R7    *VLP0C,R2
         AND,R7   =X'FFFF7FFF'      RESET O-BIT
         STW,R7   *VLP0C,R2
         B        KEY60             EXIT
*
KEY40    LI,R11   X'1C00'
         CW,R11   NAVX,R6
         BAZ      KEY60             LEVEL 0 - EXIT
         LW,R8    BLINK,R6
         AND,R8   M24
         BEZ      KEY50             FOUND BEGINNING OF THIS LEVEL
KEY42    XW,R8    BUFDA,R7
         AND,R8   M24
         MTB,1    R8                BLINK CHECK
         STW,R8   BUFDACHK,R7
         B        KEY10             FIND BEGINNING OF LEVEL
*
*  HAVE FOUND FDA ON TOP LEVEL
*
KEY50    LI,R11   X'1C00'
         AND,R11  NAVX,R6
         SLS,R11  -10               RIGHT JUSTIFY LEVEL #
         STW,R11  KEYLEVEL
         LW,R8    BUFDA,R7
         BAL,R11  ALLOCG            ALLOCATE GRANULE
         BCS,11   KEY30             ERROR
         LW,R8    BLINK,R6
         BNEZ     KEY53             NOT FIRST ON LEVEL
         LI,R5    BA(LOCDA)
         MTB,4    R5
         LW,R4    R6
         SLS,R4   2
         AW,R4    SCRL
         AI,R4    MIDIS             POINT TO DA OF FIRST KEY
         MBS,R4   0                 MOVE DA OF FDA ON NEXT LEVEL
         LW,R8    LOCDA
         BAL,R11  CHKDA
         BCR,15   KEY30             BAD DISC ADDRESS
KEY53    LI,R2    3
         BAL,R15  GETBUF            GET TYPE 3 BUFFER
         LW,R8    FLINK,R6
         BEZ      KEY58             ONLY ONE GRANULE ON THIS LEVEL
         STW,R8   BUFDA,R7
         BAL,R11  DISCRD
KEY55    BAL,R11  IOSPIN
         LW,R6    BUFADR,R7
         LW,R15   BUFINFO,R7        CHECK RESULTS OF VALBUF
         BNEZ     KEY30             ERROR
         BAL,R11  ALLOCG            ALLOCATE IT
         BCS,11   KEY30             ERROR
KEY58    LB,R2    BUFLINK,R7        NEXT BUFFER
         STW,R2   TEMP
         BAL,R11  RELBUF            RELEASE THIS BUFFER
         LW,R7    TEMP
         BNEZ     KEY55             MORE TO GO
*
*  PROCESS NEXT LOWER LEVEL
*
         MTW,-1   KEYLEVEL
         BLEZ     KEY60             DONE
         LW,R8    LOCDA
         LW,R7    DIRBUF
         B        KEY42
*
*  FINISHED
*
KEY60    LI,R7    0
         XW,R7    DIRBUF
         BAL,R15  RELBUF
         B        CONSEC
         SPACE    3
*
*  RANDOM FILE
*
RANDOM   EQU      %
         LW,R11   HGPRFLAG
         BEZ      FILEXIT           NOTHING TO DO IF NOT RECON
         LW,R8    FITDA
         BAL,R11  ALLOCG            ALLOCATE FIT GRANULE
         BCS,11   FILERR
         LW,R8    *VLP0C            DATA FDA
         LI,R2    1
         LW,R15   *VLP0C,R2         # GRANULES IN FILE
         BLEZ     FILEXIT           NONE
         LDCTX,R1 R8
         LW,R10   R15               SAVE # TO RELEASE
*
RAN10    BAL,R5   FNDHGP            LOCATE HGP OF DATA
         B        RANERR            CAN'T FIND
         INT,R4   1,R7
         CI,R5    ATPRIVBIT         CHECK FOR PRIVATE PACK
         AND,R5   M8                # GRAN/CYL
         BAZ      RAN30
         CW,R8    SECTOR%MASK%1
         BANZ     RAN30
         AW,R8    R5                CHANGE PRIVATE REL SECTOR ADDR
         CI,R8    30                  OF ZERO TO FIRST ADDR PAST VTOC
         BL       %-2
         SLS,R8   1
RAN30    LSECTA,R11  R8
         LB,R4    DCT24,R4          DISC TYPE
         LW,R15   DISCLIMS,R4       # SECTORS ON DEVICE
         SW,R15   R11
         SLS,R15  -1                # GRANS FROM HERE TO END OF DEVICE
         CW,R15   R10               RELEASE SMALLEST OF FILE SIZE OR
         BL       %+2                 SIZE OF SPACE ON PACK
         LW,R15   R10
         AW,R15   R5
         AI,R15   -1
         DW,R15   R5                ROUND UP TO NEXT CYLINDER
         LW,R14   R15
         LW,R13   R15
RAN40    BAL,R11  ALLOCG
         BCS,11   RANERR
         LI,R1    1
         MTH,2    R8                INCR SECTOR ADDRESS
         BNC      RAN42
         EOR,R8   Y008
         CW,R8    Y008
         BANZ     %+2
         EOR,R8   Y004
RAN42    BDR,R14  RAN40
         AI,R8    X'10000'          INCR DCTX/VOL #
         AND,R8   DCT%MASK%1        ZERO RELATIVE SECTOR
         MW,R13   R5                CONVERT BACK TO GRANULES
         SW,R10   R13
         BGZ      RAN10             MORE TO DO
         B        FILEXIT
*
RANERR   BAL,R11  ERRMSG
         B        FILERR
*
*  ERROR IN FIT
*
FILERR   EQU      %
         LW,R11   HGPRFLAG
         BNEZ     RELFIT
         LW,R11   FIXFLAG
         BEZ      FILEXIT           DO NOTHING IF NOT FIX
         LW,R7    DIRBUF
         BEZ      ACNDR10           DIDN'T GET HERE FROM DIRECTORY
         BAL,R11  TRUNC10           DELETE FROM DIRECTORY
         B        FILEXIT
*
FILE90   EQU      %
         LCI      2
         STM,R1   TEMP              SAVE ERROR CODE AND SUB-CODE
         LI,R4    BA(MIOERR)
         BAL,R10  MOVTXTC
         LW,R2    TEMP
         SLS,R2   8
         AW,R2    TEMP+1            COMBINE MAJOR AND SUB-CODE
         BAL,R10  MOVHEX
         BAL,R15  DUMPB
         B        ENDPROC2
*
FILE99   LI,R14   MNOSFILE          'NO SUCH FILE'
         B        FILDIR30
*
FILEXIT  BAL,R11  RBUFS             RELEASE ALL BUFFERS
         LW,R4    Y002
         CW,R4    F:FIX
         BAZ      %+2
         M:CLOSE  F:FIX,SAVE        CLOSE DCB IF OPEN
         LW,R11   HGPRFLAG
         BNEZ     FILEND
         LW,R4    NXTF
         BNEZ     FILE10            NXTF SET - GO OPEN NEXT FILE
         B        ENDPROC2          DONE
*
*  END OF FILES OR END OF ACCOUNTS ON OPEN NEXT
*
FILEX10  CI,R2    1
         BE       ENDPROC2          END OF ACCOUNTS - DONE
         LI,R11   B:ACCT+B:FNAM
         CW,R11   CUROPT            STOP IF A FILE OR ACCOUNT SPECIFIED
         BANZ     ENDPROC2
         LW,R11   Y008              NO ACCOUNT - MUST WANT ALL
         STS,R11  OPNFIX            SET NXTA FLAG
         LW,R11   Y01
         STW,R11  CURFILE           ZAP CURRENT FILE NAME
         B        FILE10
         SPACE    2
RBUFS    PUSH     R11
         LI,R2    #CBUFS
RBUFS10  LI,R7    0
         XW,R7    CBUFS,R2
         BEZ      RBUFS20           NO BUFFER HERE
         CW,R7    FITBUF
         BE       RBUFS20           SAME AS FITBUF - DON'T RELEASE
         PUSH     R2
         BAL,R15  RELBUF
         PULL     R2
RBUFS20  BDR,R2   RBUFS10
*
         LW,R11   HGPRFLAG
         BNEZ     RBUFS30
         LI,R7    0
         XW,R7    FITBUF
         BEZ      RBUFS30
         BAL,R15  RELBUF
RBUFS30  PULL     R11
         B        *R11
         TITLE    '****  SRCHDIR  ****'
         SPACE    2
*
*  PURPOSE:  SEARCH ACCOUNT AND FILE DIRECTORIES FOR SPECIFIC KEY
*
*  INPUT:  R8 = DISC ADDRESS OF FDA
*          R9 = DISC ADDRESS OF DUAL FDA
*          SRCHKEY CONTAINS KEY TO FIND (ZERO IF NO SPECIFIC KEY)
*
*  CALL:  BAL,R11  SRCHDIR
*
*  OUTPUT:  RETURN SKIPPING IF NO ERRORS ENCOUNTERED
*
         SPACE    1
SRCHDIR  EQU      %
         PUSH     R11
*
         DO       VERS=1
         LW,R11   SN
         BNEZ     %+3               PRIVATE LIKE PRE-C00 PUBLIC
         LW,R11   VERSFLAG
         BEZ      %+2
         LI,R9    0                 NO DUALS IF PRE-C00
         FIN
*
         LI,R2    0
         BAL,R15  GETBUF            GET TYPE 0 BUFFER
         BEZ      %
         STW,R7   CURBUF            CURRENT BUFFER NUMBER
         STW,R8   BUFDA,R7          DISC ADDRESS
         STW,R8   DIRFDA            SAVE FDA
         AND,R9   M24
         STW,R9   DFLINKL           SAVE DUAL
*
         LI,R8    0
         STW,R8   LINKFLAG          PERFORM LINK CHECKING
         STW,R8   KEYLEVEL          LEVEL = 0
         STW,R8   LASTKEY           NO PREVIOUS KEY
         STW,R8   ORDRFLAG          NO OUT OF ORDER KEYS
         STW,R8   PREVBUF           NO PREVIOUS BUFFER
         STW,R8   PREV1BUF          NO PREVIOUS-PREVIOUS BUFFER
         STW,R8   NXTBUF            NO NEXT BUFFER
         STW,R8   DUALFLAG          DUAL NOT READ
         STW,R8   PREVFLAG          ZERO FLAGS OF PREVIOUS KEY
         STW,R8   LOCDA             HAVEN'T FOUND DESIRED KEY
*
         BAL,R11  DISCRD            READ FDA GRANULE
*
SRCH30   BAL,R11  IOSPIN            WAIT FOR I/O TO COMPLETE
*
         LI,R11   0
         STW,R11  ERRCNT1           # ERRORS IN CURRENT BUFFER
*
         LW,R8    DFLINKL
         STW,R8   BUFDUAL,R7
*
         LW,R6    BUFADR,R7         BUFFER ADDRESS
         BAL,R10  VALBUF            CHECK 3 HEADER WORDS
         BNEZ     SRCH90            ERROR
*
         LW,R8    FLINK,R6
         BEZ      SRCH35            NO FLINK
         LW,R9    BUFDA,R7
         AND,R9   M24               DISC ADDRESS OF CURRENT BUFFER
         LI,R2    0
         BAL,R15  GETBUF            GET TYPE 0 BUFFER
         BEZ      %
         STW,R7   NXTBUF
         STW,R8   BUFDA,R7
         STW,R9   BUFDACHK,R7       LINK CHECK DISC ADDRESS
         BAL,R11  DISCRD            START READ OF FLINK
         LW,R7    CURBUF
*
SRCH35   LI,R3    MIDIS
         STW,R3   CMDL              CURRENT BYTE DISPL INTO BUFFER
*
         LW,R6    BUFADR,R7
         BAL,R11  FNDKEY            VALIDATE BUFFER
         B        SRCH80            FOUND THE DESIRED KEY
         BNEZ     SRCH90            ERROR
*
         BAL,R10  DUALCHK           VALIDATE DUAL POINTERS
*
         LW,R11   DUMPFLAG
         BEZ      %+2
         BAL,R11  SNAPGRAN          DUMP THE GRANULE
*
         LI,R8    0
         XW,R8    DUALFLAG          WAS DUAL GRANULE READ
         BEZ      SRCH45            NO
         LW,R8    ERRCNT1           WERE ANY ERRORS FOUND IN DUAL
         BNEZ     SRCH45            YES
         LI,R14   MDUALOK           'DUAL SUCCESSFULLY READ'
         BAL,R15  PRINT
         LW,R11   FL:UPDT
         STS,R11  BUFDA,R7          SET UPDATED TO FORCE WRITE-OUT
*
SRCH45   LI,R7    0
         XW,R7    NXTBUF            SLIDE DOWN ALL BUFFER POINTERS
         XW,R7    CURBUF
         XW,R7    PREVBUF
         XW,R7    PREV1BUF
         BEZ      %+2               GET RID OF LAST IF THERE IS ONE
         BAL,R15  RELBUF
*
         LW,R7    CURBUF
         BNEZ     SRCH30            THERE IS MORE TO DO
         BAL,R11  RBUFS             DONE - GET RID OF BUFFERS
         LI,R7    0
*
SRCH50   PULL     R11
         AI,R11   1                 NO ERRORS - RETURN SKIPPING
         B        *R11
*
SRCH80   LI,R7    0
         XW,R7    CURBUF
         STW,R7   DIRBUF            MOVE CURRENT BUFFER TO DIRBUF
         B        SRCH50            EXIT
*
SRCH90   EQU      %                 UNRECOVERABLE ERROR
         PULL     R11
         B        *R11
         TITLE    '****  DUALCHK  ****'
         SPACE    2
*
*  PURPOSE:  VALIDATE DIRECTORY DUAL LINKS
*
*  CALL:  BAL,R10  DUALCHK
*
         SPACE    1
DUALCHK  EQU      %
         DO       VERS=1
         LI,R8    0
         MTW,0    VERSFLAG
         BNEZ     DUAL40            SKIP DUALS IF PRE-C00
         FIN
         LW,R11   SN
         BNEZ     DUAL40            NO DUALS IF PRIVATE
*
DUAL10   LW,R6    BUFADR,R7
         LW,R2    PREVBUF
         BEZ      DUAL30            NO PREVIOUS BUFFER - THIS IS FDA
         LW,R8    BUFDUAL,R2        DUAL OF PREVIOUS GRANULE
         CW,R8    DBLINK,R6           SHOULD BE DUAL FLINK
         BE       DUAL20
         LI,R15   ERR#10            DUAL BLINK WRONG
         BAL,R11  GRANERR           RETRY
         BEZ      DUAL10
         LW,R11   FIXFLAG           NO MORE RETRIES
         BEZ      DUAL20            NOT 'FIX' - DO NOTHING
         STW,R8   DBLINK,R6         MAKE IT RIGHT
         LW,R11   FL:UPDT
         STS,R11  BUFDA,R7          SET UPDATED FLAG
*
DUAL20   LW,R8    DFLINKL           DUAL FLINK OF PREVIOUS GRANULE
         CW,R8    DDA,R6              SHOULD BE DUAL OF THIS GRANULE
         BE       DUAL30            OK
         LI,R15   ERR#11            DUAL DA WRONG
         BAL,R11  GRANERR           RETRY
         BEZ      DUAL10
         LW,R11   FIXFLAG           NO MORE RETRIES
         BEZ      DUAL30            DO NOTHING - NOT 'FIX'
         STW,R8   DDA,R6            MAKE IT RIGHT
         LW,R11   FL:UPDT
         STS,R11  BUFDA,R7          SET UPDATED BIT
*
DUAL30   LW,R8    FLINK,R6
         BEZ      DUAL40            NO FLINK MEANS NO DUAL FLINK
         LW,R8    DFLINK,R6         DUAL FLINK OF THIS GRANULE
         AND,R8   M24
         STW,R8   DFLINKL
         BAL,R11  CHKDA
         BCS,15   DUALXIT           OK
         LI,R15   ERR#12            BAD DISC ADDRESS
         BAL,R11  GRANERR           RETRY
         BEZ      DUAL10
         LW,R8    FIXFLAG
         BEZ      DUALXIT           NOT 'FIX' - DO NOTHING
         LW,R11   FL:UPDT
         STS,R11  BUFDA,R7          MARK UPDATED
         BAL,R11  GETGRAN           ALLOCATE A GRANULE
         STW,R8   DFLINK,R6
         OR,R8    Y8                INDICATE JUST ALLOCATED
DUAL40   STW,R8   DFLINKL           SAVE IT
*
DUALXIT  B        *R10
         TITLE    '****  DISCRD, DISCWRT  ****'
         SPACE    2
*
*  PURPOSE:  READ AND WRITE DISC.  THE BUF TABLE ENTRY MUST
*            ALREADY HAVE A BUFFER ADDRESS, DISC ADDRESS AND
*            DUAL DISC ADDRESS (ZERO IF NONE).
*
*  INPUT:  R7 = INDEX INTO BUF TABLE OF ENTRY TO BE QUEUED
*
*  CALL:  BAL,R11  DISCRD/DISCWRT
*
         SPACE    1
DISCRD   LI,R2    0                 READ FUNCTION CODE
         B        %+2
DISCWRT  LI,R2    1                 WRITE FUNCTION CODE
         STB,R2   BUFCODE,R7        SAVE ORDER 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,R12   DCTX,R2           CONVERT VOL # TO DCT INDEX
         STDCTX,R12  R8
         BAL,R6   CHKDAQ
         BCS,15   DAOK
         M:SNAP   'BAD DA',(D1,D1END)
         M:XXX
*
DAOK     EQU      %
         LW,R5    RAFLAG
         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
         PULL     15,R3
         B        *R11
         SPACE    3
*
*  QUEUE I/O FOR ANY DEVICE
*
*  INPUT:
*        R2 = FUNCTION CODE (FOR NEWQNWM)
*        R7 = BUFFER INDEX OR SPECIAL CODE
*        R12 = DCT INDEX
*        R13 = BA OF BUFFER
*        R14 = BYTE COUNT
*        R15 = DISC ADDRESS
*
         SPACE    1
IOQUEUE  PUSH     15,R3
         B        IOQ10
         SPACE    3
*
DISCIO6  LW,R5    S:CUN             DEVICE DOWN
         MTB,-1   UB:MF,R5
         M:SNAP   'DEV DOWN'
         M:XXX
BADBUF   M:SNAP   'BUF INDX',(D1,D1END)
         M:XXX
BADADR   M:SNAP   'BUF ADDR',(D1,D1END)
         M:XXX
         SPACE    2
*
*  UN-MAPPED END-ACTION ROUTINE  -  EXECUTED IN AN MPOOL
*
         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
#EASTK   EQU      34-EASTACK-2      MAX # WORDS AVAIL FOR STACK
         DO       #EASTK>6
#EASTACK EQU      6                 SET #EASTACK TO MIN(#EASTK,6)
         ELSE
#EASTACK EQU      #EASTK
         FIN
         TITLE    '****  DRDWAIT/DWRWAIT  ****'
         SPACE    2
*
*  PURPOSE:  READ DISC WITH WAIT
*
*  INPUT:  R2 = # WORDS TO READ
*          R7 = BUFFER WORD ADDRESS
*          R8 = DISC ADDRESS (PRIVATE OR PUBLIC FORMAT)
*
*  CALL:  BAL,R11 DRDWAIT           READ
*         BAL,R11 DWRWAIT           WRITE
*
*  OUTPUT:  R15 = 0  NORMAL COMPLETION
*               = 1  I/O ERROR
*               = 2  BAD DISC ADDRESS
*
         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
         BAL,R11  CHKDA
         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
DIO50    EQU      %
DIOXIT   PULL     15,R0
         AI,R15   0
         B        *R11
         TITLE    '****  SEEKCONV  ****'
         SPACE    2
*
*  PURPOSE:  CONVERT PHYSICAL SEEK ADDRESS TO DCT/REL SECTOR
*
*  INPUT:  R7 = USER #
*          R8 = PHYSICAL SEEK ADDRESS
*
*  CALL:  BAL,R11  SEEKCONV
*
*  OUTPUT:  R8 = DCT/REL SECTOR
*           R9 = RELATIVE SECTOR
*
         SPACE    1
SEEKCONV PUSH     7,R1
         LW,R4    UBSWAPI
         AI,R7    0
         BLZ      %+2               BR IF SPECIAL - DON'T LOOK AT USER
         LB,R4    UB:SWAPI,R7       SWAP DEVICE INDEX
         LB,R1    MB:SDI,R4         DCT INDEX
         LB,R4    DCT22,R1          DISC TYPE
         LW,R3    R8                MOVE INPUT DISC ADDRESS
         AND,R3   M24
         LI,R9    0
         LI,R6    48                ASSUME RAD
         LW,R2    NCYL,R4           # CYLINDERS ON DEVICE
         BEZ      TRK%CVT           NONE - MUST BE RAD
*
         LI,R2    0
         LI,R5    32                SHIFT OFFSET FOR PACK
         LI,R6    X'7F'
         AND,R6   CYL%SHFT,R4       GET CYL SHIFT FACTOR
         SW,R5    R6                RK = CYL SIZE
         SLD,R2   0,R5              R2=CYL # RIGHT JUSTIFIED
         LW,R9    R2
         MW,R9    NSPC,R4           # CYLS * NSPC = # SECTORS
*
TRK%CVT  LI,R5    X'7F'
         AND,R5   TRK%SHFT,R4       TRACK SHIFT FACTOR
         SW,R6    R5
         SLD,R2   0,R6              R2 = TRACK ADDRESS
         LI,R6    X'7F'
         AND,R6   SEC%SHFT,R4       SECTOR SHIFT FACTOR
         SW,R5    R6
         SCS,R3   0,R5              RIGHT JUSTIFY SECTOR FIELD
         AW,R9    R3
         LW,R3    R2
         MW,R3    NSPT,R4           CONVERT TRACKS TO SECTORS
         AW,R9    R3                GRAND TOTAL IN SECTORS
         LW,R8    R9
         CI,R8    X'10000'          SPLIT THE SECTOR FIELD
         BAZ      %+2
         OR,R8    Y008
         CI,R8    X'20000'
         BAZ      %+2
         OR,R8    Y004
         LW,R2    R1                DCT INDEX
         LI,R3    X'3F'
         SLD,R2   16
         STS,R2   R8
         PULL     7,R1
         B        *R11
         TITLE    '****  IORETRY  ****'
         SPACE    2
*
*  PURPOSE:  RETRY AN I/O AFTER AN ERROR
*
*  INPUT:  R7 = BUF TABLE INDEX
*
*  CALL:  BAL,R10  IORETRY
*
*  OUTPUT:  CC SET FOR BEZ IF RETRIES EXHAUSTED.
*           CC SET FOR BNEZ IF I/O RETRIED.
*
         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
         MTB,0    BUFNRT,R7
         BEZ      *R10              NO MORE RETRIES
         MTB,-1   BUFNRT,R7         DECR # RETRIES REMAINING
         BAL,R11  DISCIO            RE-QUEUE THE I/O
         LCI      15
         B        *R10
         TITLE    '****  IOSPIN  ****'
         SPACE    2
*
*  PURPOSE:  WAIT FOR I/O TO COMPLETE ON A BUFFER
*
*  INPUT:  R7 = BUF TABLE INDEX
*
*  CALL:  BAL,R11  IOSPIN
*
         SPACE    1
IOSPIN   EQU      %
         MTW,1    SPINCNTT          INCR # CALLS TO IOSPIN
         LW,R1    FL:IOP
         DISABLE                    **** DISABLE
         CW,R1    BUFDA,R7
         BAZ      IOSPRET           NO I/O IN PROGRESS
         MTW,1    SPINCNT           COUNT # IOSPINS
         PUSH     7,R5
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
         BAZ      IOSPIN8           I/O COMPLETE
         LW,R11   MPOOLADR
         BEZ      IOSPIN4           NO END-ACTION BUFFER
         PLW,R5   *EASPD
         BSU      IOSPIN4           NOTHING WAITING TO BE PROCESSED
         PSW,R5   *EASPD            PUT IT BACK
         MTW,1    #INTLOST          MUST HAVE LOST AN INTERRUPT
         PUSH     9,R12             SAVE REST OF REGISTERS
         BAL,R15  REL70             PERFORM PSEUDO END-ACTION
         PULL     9,R12
         B        IOSPIN4
*
IOSPIN8  PULL     7,R5
IOSPRET  ENABLE                     **** ENABLE
         B        *R11
         TITLE    '****  CHKDA  ****'
         SPACE    2
*
*  PURPOSE:  CONVERT DISC ADDRESS TO PUBLIC FORMAT AND VALIDATE IT
*
*  INPUT:  R8 = DISC ADDRESS
*          TABLE DCTX CONTAINS PRIVATE TO PUBLIC CONVERSION
*
*  CALL:  BAL,R11  CHKDA
*
*  OUTPUT:  R8 = DISC ADDRESS IN PUBLIC FORMAT
*           CC = 0 IF ERROR
*
         SPACE    1
CHKDA    PUSH     4,R4
         LDCTX,R6 R8
         LB,R6    DCTX,R6           CONVERT VOL # TO DCT INDEX
         STDCTX,R6 R8
         BAL,R6   CHKDAQ            VALIDATE PUBLIC DISC ADDRESS
         STCF     R11
         PULL     4,R4
         LCF      R11
         B        *R11
         TITLE    '****  GETOCU  ****'
         SPACE    2
*
*  PURPOSE:  BECOME OPEN/CLOSE USER
*
*  CALL:  BAL,R15  GETOCU
*         BAL,R11  RELOCU
*
         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
         STW,R2   OPNCLSTK          ZAP SO PULLALLE WON'T RELEASE
         LH,R6    UH:FLG,R2
         OR,R6    BT31TO0+4         SET OPEN/CLOSE USER FLAG
         STH,R6   UH:FLG,R2
         ENABLE                     ****  ENABLE
         B        *R15
         SPACE    2
RELOCU   LW,R0    S:CUN
         SW,R0    OPNCLSUS
         BNEZ     *R11              NOT OPEN/CLOSE USER
         B        T:UBLKOCU
         TITLE    '****  GETBUF  ****'
         SPACE    2
*
*  PURPOSE:  GET AN ENTRY IN BUF TABLES
*
*  INPUT:  R2 = BUFFER TYPE
*
*  CALL:  BAL,R15  GETBUF
*
*  OUTPUT:  R7 = BUFFER ADDRESS (ZERO IF NONE)
*
         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
*
*  PURPOSE:  RELEASE ENTRY IN BUF TABLES.
*
*  INPUT:  R7 = BUF TABLE INDEX
*
*  CALL:  BAL,R15  RELBUF
*
         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
         CW,R2    FL:UPDT
         BAZ      REL40             NOT UPDATED
REL10    EQU      %
         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
*
*  BUFFER NOT UPDATED
*
REL40    EQU      %
         LI,R2    0
         XW,R2    BUFDUAL,R7
         STW,R2   BUFDA,R7          MOVE BUFDUAL TO BUFDA
         BNEZ     REL10             THERE IS A DUAL
*
*  CHECK FOR END-ACTION TO BE DONE
*
         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      %
         MTB,1    R7                TYC = 1
         PSW,R7   *EASPD            PUT INTO END-ACTION STACK
         LW,R14   INTBUSY           IF ALREADY PROCESSING IN BREAK
         BNEZ     REL50               HANDLER, NO NEED TO BUILD ENVIR
*
*  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   0                 ASSUME NO SPACER WORD
         LW,R0    *J:TCB            TOP OF STACK
         CI,R0    1
         BAZ      %+3
         LI,R13   -1                MUST ADD SPACER WORD TO PUT
         PSW,R0   *J:TCB              PSD ON DW
*
         LW,R1    *J:TCB
         AI,R1    2                 ADDRESS OF PSD
         LCI      3
         PSM,R13  *J:TCB            FLAG, PSD
         LCI      0
         PSM,R0   *J:TCB            REGISTERS
         PSW,R15  *J:TCB            UN-USED WORD
         B        INTADR2
*
         DO       DEBUG=1
RELERR   M:SNAP   'REL ERR',(D1,D1END)
         M:XXX
         FIN
         TITLE    '****  ALLOCBUF  ****'
         SPACE    2
*
*  PURPOSE:  ALLOCATE BUFFER SPACE
*
*  CALL:  BAL,R11  ALLOCBUF
*
         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  M:SNAP   'CORE',(J:JIT,J:JIT+511)
         M:SNAP   'CORE',(D1,D1END)
         M:XXX
         TITLE    '****  FITCHK  ****'
         SPACE    2
*
*  PURPOSE:  VALIDATE FIT GRANULE
*
*  INPUT:  R7 = BUF TABLE ENTRY OF FIT GRANULE
*
*  CALL:  BAL,R11  FITCHK
*
*  OUTPUT:  R15 = ERROR CODE (ZERO IF NO ERRORS)
*
         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    BA(MFIT)          CURRENT MESSAGE = 'FIT'
         STW,R9   CURMES
*
         LI,R9    1
         STW,R9   TYPEFLAG          TYPE = FILE
         STW,R9   FITFLAG           SET 'READING FIT' FOR VALBUF
*
         LI,R9    0
         STW,R9   KEYLEVEL          KEYED FILE LEVEL = 0
         STW,R9   ERRCODE           NO ERROR
*
         LW,R6    BUFADR,R7         BUFFER ADDRESS
         BAL,R10  VALBUF            VALIDATE FIRST 3 WORDS
         BNEZ     FITERR            ERROR
*
*  LOCATE FIT
*
         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
         LB,R8    CURFILE           # CHARS IN FILE NAME
         AI,R8    1                 INCLUDE TEXTC COUNT
         STB,R8   R13
         CBS,R12  0                 COMPARE
         STCF     *SPD              SAVE FOR LATER
*
*  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
*
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 - FILE NAME IN DIRECTORY
         LC       *SPD                MUST MATCH FIT
         BNE      FITERR
*
*  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
         AI,R1    2
         LW,R4    ORGL
         CI,R4    2
         BNE      %+2               ONLY CHECK TDA IF KEYED
         BAL,R4   CHKVLD            TDA
         AI,R1    1
         BAL,R4   CHKVLD            SREC
         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
*
*  PURPOSE:  VALIDATE A CONSECUTIVE FILE GRANULE
*
*  INPUT:  R6 = BUFFER ADDRESS
*
*  CALL:  BAL,R10  CHKCON
*
         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  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
         LI,R5    0                 PREV SEG = BKSPC CNTRL
         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   CHKC20            OK
         LI,R15   ERR#43
         LI,R14   CHKER10           ERROR ROUTINE ADDRESS
         B        CHKCERR           BAD DISC ADDRESS
*
*  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  ERRMSG
*  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  LI,R2    NAVX
         AND,R3   M8
         STW,R3   *R6,R2
*
         LI,R4    BA(MCONDEL)       'END OF GRANULE SET AT WORD '
         BAL,R10  MOVTXTC
         LW,R2    R3                INDEX OF END OF GRANULE
         BAL,R10  MOVHEX
         BAL,R15  DUMPBUF           PRINT THE MESSAGE
         B        CHKCXIT
         TITLE    '****  LOCCODE  ****'
         SPACE    2
*
*  PURPOSE:  LOCATE A SPECIFIC VLP
*
*  INPUT:  R6 = BUFFER ADDRESS
*          FITVLPX = WORD INDEX INTO BUFFER OF FIRST VLP
*          R12 = VLP CODE TO SEARCH FOR
*
*  CALL:  BAL,R4  LOCCODE
*
*  OUTPUT:  R1 = WORD INDEX OF FIRST DATA WORD OF VLP
*          R13 = CONTROL WORD
*
*      RETURNS SKIPPING IF VLP FOUND
*
         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
*
*  PURPOSE:  VALIDATE A DIRECTORY, KEYED MI OR CONSEC GRANULE
*
*  INPUT:  R6 = BUFFER ADDRESS
*          SCRL <0  GRANULE MAY BE KEYED OR CONSEC FORMAT
*               =0  MUST BE CONSEC
*               >0  MUST BE KEYED, SCRL MUST MATCH SCR UNLESS
*                     SCRL = X'FF'
*          KEYLEVEL >= 0, KEYED GRAN MUST HAVE THIS LEVEL #
*                   < 0, DON'T CHECK
*                      KEYLEVEL IGNORED FOR CONSEC GRANULES.
*
*  CALL:  BAL,R10  VALBUF
*
*  OUTPUT:  R15 = ERROR CODE (ZERO IF NO ERROR)
*
         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   LW,R15   SCRL
         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
         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
         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
         LW,R15   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
*
*  PURPOSE:  VERIFY DIRECTORY OR KEYED FILE GRANULE
*
*  CALL:  BAL,R11  FNDKEY
*
         SPACE    1
FNDKEY   PUSH     R11
         LI,R3    0
         STW,R3   #RECS1            # RECORDS IN THIS GRANULE
FND10    EQU      %
         LI,R3    0
         STW,R3   ERRCODE           NO ERRORS
         LW,R3    CMDL              CURRENT BUFFER BYTE DISPL
         LI,R2    NAV
         CH,R3    *R6,R2
         BGE      FNDXIT            AT END OF GRANULE
*
         LI,R15   ERR#20
         LB,R8    *R6,R3            BYTE COUNT OF KEY
         AND,R8   M7                SCRUB MI UPPER LEVEL FLAG
         BEZ      FND40             DELETED KEY
         CW,R8    SCRL
         BGE      FNDERR            KEY SIZE TOO LARGE
*
         LI,R13   LKEY              ADDRESS OF PREVIOUS KEY
         BAL,R11  COMKEY            COMPARE PREV WITH CURRENT
         BLE      FND40             OK
         MTW,1    ORDRFLAG          OUT-OF-ORDER KEYS
*
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
*
         DO       VERS=1
         LW,R5    VERSFLAG
         BNEZ     FNDMI             PRE-C00 ACCT DIR SAME AS FILE DIR
         FIN
         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
         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
         BLZ      FNDDA5            DON'T CHECK DUAL
         BAL,R11  CHKDA
         BCR,15   FNDERR            ERROR
*
FNDDA5   ANLZ,R4  IR6R3  LB,0 *R6,R3  BA OF CURRENT KEY
         LW,R5    =X'20000000'+BA(LKEY)
         MBS,R4   0                 CURRENT KEY BECOMES LAST KEY
         LW,R11   TYPEFLAG
         BLEZ     FNDDA7            BR IF AD OR FD
         LW,R11   HGPRFLAG
         BEZ      FNDDA7            BR IF NOT HGP RECON
         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   FNDERR1           ERROR - DELETE THE KEY
FNDDA7   LW,R6    BUFADR,R7
         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
         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   BAL,R11  GRANERR
         BEZ      FND10             RETRIES REMAIN
         LW,R11   FIXFLAG
         BEZ      INCRKEY           DON'T FIX
         LW,R15   ERRCODE
         CI,R15   DEL               NO - IS IT TO DELETE THE KEY
         BAZ      INCRKEY           NO - CONTINUE
FNDERR1  BAL,R11  DELKEY
         B        FND10
         LI,R15   0
         STW,R15  DESCL
         LW,R5    =X'02000002'+BA(DESCL)
         MBS,R4   0                 MOVE DESCRIPTOR BITS
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,R8    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
         B        FNDDA
         TITLE    '****  COMKEY  ****'
         SPACE    2
*
*  PURPOSE:  COMPARE KEY A WITH KEY B
*
*  INPUT:  R13 = WORD ADDRESS OF KEY A
*          R6 = WORD ADDRESS OF BUFFER
*          R3 = BYTE INDEX INTO BUFFER OF KEY B
*
*  CALL:  BAL,R11  COMKEY
*
*  OUTPUT:  CONDITION CODES SET FOR BG, BE, BL (KEY A
*             COMPARED WITH KEY B)
*
         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  ****'
*
*  TRUNCATE DIRECTORY AT LAST GOOD GRANULE
*
TRUNCATE EQU      %
         LW,R7    PREVBUF           PREVIOUS (LAST GOOD) BUFFER
         BEZ      TRUNC10           NONE GOOD
         PUSH     R11
         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
         LI,R2    NAV
         LH,R3    *R6,R2            NAV
         AI,R3    -1                FLAGS FOR ACCOUNT DIRECTORY
         DO       VERS=1
         LW,R8    VERSFLAG
         BNEZ     %+3               PRE-C00 SAME AS FILE DIRECTORY
         FIN
         LW,R8    TYPEFLAG
         BLZ      %+2
         AI,R3    -2                NOT AD - BACK UP TWO MORE
         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
         LW,R9    FL:UPDT
         STS,R9   BUFDA,R7          SET UPDATED FLAG
TRUNCXIT PULL     R11
         B        *R11
         SPACE    2
*
*  FIRST GRANULE OF DIRECTORY IS BAD - REMOVE KEY FROM DIRECTORY
*
TRUNC10  EQU      %
         PUSH     R11
         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
*
*  PURPOSE:  DELETE CURRENT KEY
*
*  INPUT:  CMDL = BYTE INDEX OF KEY TO BE DELETED
*          R7 = BUF TABLE INDEX
*
*  CALL:  BAL,R11  DELKEY
*
         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      DELKEY20          YES
*
         LW,R9    BUFDA,R7
         AND,R9   FLR:SNAP          RESET BUFFER SNAPPED FLAG
         OR,R9    FL:UPDT           SET UPDATED
         STW,R9   BUFDA,R7
*
         LI,R4    BA(MAST)          ' **** '
         BAL,R10  MOVTXTC
         LW,R4    CURMES            CURRENT MESSAGE
         BAL,R10  MOVTXTC
         LI,R4    BA(MDELKEY)       ' KEY DELETED - '
         BAL,R10  MOVTXTC
         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
         LH,R8    *R6,R2            CURRENT NAV
         SW,R8    KEYSIZE
         STH,R8   *R6,R2            NEW NAV
*
         LW,R3    CMDL
         SW,R8    R3                # BYTES TO MOVE
         BLEZ     DELKEY20          NONE
*
         LW,R4    R3
         AW,R4    KEYSIZE
DELKEY10 LB,R9    *R6,R4
         STB,R9   *R6,R3
         AI,R3    1
         AI,R4    1
         BDR,R8   DELKEY10
DELKEY20 PULL     R11
         B        *R11
         TITLE    '****  GETGRAN  ****'
         SPACE    2
*
*  PURPOSE:  GET A PUBLIC GRANULE
*
*  CALL:  BAL,R11  GETGRAN
*
*  OUTPUT:  R8 = DISC ADDRESS (ZERO IF NONE AVAILABLE)
*
         SPACE    2
GETGRAN  PUSH     15,R9
         LI,R0    X'070B'           TRY PACK THEN RAD
         BAL,R11  GBG               GET BACKGROUND GRANULE
         PULL     15,R9
         AND,R8   M24
         B        *R11
         TITLE    '****  DCTSET  ****'
         SPACE    2
*
*  PURPOSE:  INITIALIZE TABLE DCTX.
*              PUBLIC:  SET THE TABLE TO CONVERT DCT INDICES INTO
*                       THE SAME DCT INDICES.
*              PRIVATE:  CONVERT VOLUME NUMBER TO DCT INDEX.  ENTRIES
*                        IN THE TABLE BEYOND THE LIMITS OF THE PACK
*                        SET SIZE WILL CONVERT TO ZEROS.
*            IF PRIVATE, F:PV WILL BE OPENED TO GET THE SET MOUNTED.
*
*  CALL:  BAL,R11  DCTSET
*
         SPACE    1
DCTSET   LW,R1    Y002
         CW,R1    F:PV              IF DCB ALREADY OPEN, NO
         BANZ     *R11                NEED TO CHANGE TABLE
*
         LI,R2    63                ASSUME PUBLIC - SET TABLE TO
         STB,R2   DCTX,R2             CONVERT ONE-TO-ONE
         BDR,R2   %-1
         STB,R2   DCTX
*
         LCI      2
         LM,R1    CURACCT           MOVE ACCOUNT  TO
         STM,R1   PVACCT              F:PV OPEN FPT
         LM,R1    SN-1              MOVE SN INFO
         STM,R1   PVSN-1
         AI,R2    0
         BEZ      *R11              PUBLIC - EXIT
*
         LI,R2    64/4              PRIVATE - ZERO DCTX
         LI,R1    0
         STW,R1   DCTX-1,R2
         BDR,R2   %-1
         M:OPEN,E OPNPV             OPEN F:PV
         LW,R9    Y002
         CW,R9    F:PV
         BAZ      FILE90            ERROR - DCB NOT OPEN
*
         LI,R2    X'FF00'
         AND,R2   PVSN-1
         SLS,R2   -8                # VOLUMES IN SET
*
DCTST10  LI,R1    AVRTBLNE-AVRTBLSIZ
DCTST20  LD,R4    AVRTBL+AVRTBLSIZ+AVRTBLSIZ-2,R1
         CW,R4    PVSN-1,R2         FIND SERIAL NUMBER IN AVRTBL
         BE       DCTST30
         BDR,R1   DCTST20
         B        DCTST40           DIDN'T FIND - SHOULDN'T HAPPEN
*
DCTST30  AI,R1    BATAPE+AVRTBLSIZ-1   DCT INDEX
         STB,R1   DCTX,R2
DCTST40  BDR,R2   DCTST10
         B        *R11
         TITLE    '****  READ  ****'
         SPACE    2
*  PURPOSE:  READ A RECORD FROM M:SI
*
*  CALL:   BAL,R11  READ
*
*  OUTPUT:  CC = 0  NO ERRORS
*              = 1  EOF
*           RECORD IN INBUF, BYTE COUNT IN INCNT
*
         SPACE    1
READ     EQU      %
         MTW,1    IDLEFLAG          SET IDLE
         M:READ   M:SI,(BUF,INBUF),(SIZE,INBUFSIZ),(BTD,1),;
                    (ERR,RDERR),(ABN,RDERR)
         LH,R4    M:SI+ARS
         SLS,R4   -1
READEND  AI,R4    0                 # BYTES READ
         BEZ      READ2
         LB,R3    INBUF,R4          LAST CHAR READ
         CI,R3    X'40'
         BGE      %+2
         AI,R4    -1                REMOVE ACTIVATION CHAR
*
READ2    LI,R3    0
         STW,R3   IDLEFLAG          RESET IDLE
         LI,R3    PC
         STB,R3   INBUF             PUT IN PROMPT CHAR
         LW,R3    BOOTFLG
         BNEZ     READ10            SYSTEM NOT UP - DON'T WRITE
         LW,R3    R4                # BYTES IN RECORD
         AI,R3    2                 COUNT PROMPT CHAR AND VFC
         CI,R3    2
         BLE      %+2               DON'T PRINT IF NOTHING READ
         M:WRITE  M:LO,(BUF,INBUF-1),(SIZE,*R3),(BTD,3),WAIT
*
         LC       J:JIT
         BCR,8    READ10            NOT ONLINE
*
         LI,R3    X'F'
         AND,R3   M:SI
         CI,R3    3
         BNE      ECHOIN            M:SI NOT ASSIGNED TO DEVICE
         LI,R3    X'3F00'
         AND,R3   M:SI+1            DEVICE TYPE
         CI,R3    X'1000'
         BE       READ10            M:SI ASSIGNED TO 'ME'
*
*  ECHO INPUT IMAGE
*
ECHOIN   LW,R3    R4                SAVE BYTE COUNT
         LI,R8    X'15'             CARRIAGE RETURN
         AI,R3    1
         STB,R8   INBUF,R3          PUT CARRIAGE RETURN AT END
         AI,R3    1                 INCLUDE PROMPT CHAR
         M:WRITE  M:UC,(BUF,INBUF),(SIZE,*R3),(BTD,0),WAIT
         MTW,1    M:SIFLG           SET 'NOT ASSIGNED TO TTY'
READ10   STW,R4   INCNT             SAVE BYTE COUNT
         LI,R3    1
         STW,R3   INPOS             POINT TO NEXT CHARACTER
         LCI      0
         B        *R11
*
*  I/O ERROR ON M:SI
*
RDERR    EQU      %
         LB,R3    R10
         CI,R3    5
         BE       RDEOF
         CI,R3    6
         BE       RDEOF
         M:SNAP   'M:SI ERR',(M:SI,M:SI+79)
         M:XXX
*
*  END-OF-FILE
*
RDEOF    LCI      1
         B        *R11
         TITLE    '****  PARSE  ****'
         SPACE    2
*
*  PURPOSE:  BREAK INPUT INTO SERIAL #, FILE NAME, ACCOUNT, OPTIONS
*
*  CALL:  BAL,R11  PARSE
*
*  OUTPUT:  SERIAL NUMBER IN SN
*           FILE NAME IN FNAME
*           ACCOUNT IN ACCT
*           APPROPRIATE WORDS NON-ZERO IN SUBLOC1
*
         SPACE    1
PARSE    STW,R11  PARSERET
*
         LI,R10   0
         STW,R10  SN                NO SERIAL NUMBER
         STW,R10  FNAME             NO FILE NAME
         STW,R10  ACCT              NO ACCOUNT
         STW,R10  FLDFLG
         LI,R5    #OPT
         STW,R10  OPTLOC-1,R5
         BDR,R5   %-1               RESET ALL FLAGS
         STW,R10  CUROPT            NO OPTIONS FOUND YET
         LI,R11   X'FF00'
         STS,R10  SN-1              RESET # USED WORDS IN FPT
*
PAR10    BAL,R11  GETFIELD
         BCS,4    *PARSERET         NO MORE FIELDS
         LI,R12   '#'
         BAL,R11  SPLITFLD          LOOK FOR SERIAL #
         AI,R7    0
         BGEZ     PARSN             THERE IS ONE
         LI,R12   '.'
         BAL,R11  SPLITFLD          SPLIT FILE NAME AND ACCOUNT
         AI,R7    0
         BLZ      PAROPT            NO '.' - CAN'T BE NAME/ACCOUNT
*
         LI,R3    B:ACCT            ASSUME NO FILE NAME
         LI,R2    X:ACCT
         AI,R6    0
         BEZ      PARACCT           NO NAME
         CI,R6    31
         BG       FIELDBIG          FIELD TOO BIG
         LI,R2    BA(FBUF)
         LI,R3    BA(FNAME)+1
         STB,R6   R3
         MBS,R2   0                 MOVE TO FPT
         STB,R6   FNAME             TEXTC COUNT
         LI,R2    BA(FBUF)
         LI,R3    BA(CURFILE)+1
         STB,R6   R3
         MBS,R2   0                 MOVE FILE NAME TO CURFILE
         STB,R6   CURFILE
         LI,R3    B:FNAM            FILE NAME AND ACCOUNT
         LI,R2    X:FNAM
*
PARACCT  BAL,R11  CHKOPT            CHECK LEGALITY
         LCI      2
         LM,R2    SBUF
         STM,R2   ACCT
         STM,R2   CURACCT           SET CURRENT ACCOUNT
         AI,R7    0
         BGZ      PAR10             THERE WAS AN ACCOUNT
         LI,R14   MNOACCT
         B        ERROR2            NO ACCOUNT
*
*  NOT SN OR NAME/ACCOUNT - MUST BE OTHER OPTION
*
PAROPT   LI,R2    #OPT              # LEGAL OPTIONS
         LI,R3    OBIT
         LW,R4    FBUF
PAROPT2  SLS,R3   -1                SHIFT BIT FOR THIS OPTION
         CW,R4    OPTTXT-1,R2
         BE       PAROPT6
         BDR,R2   PAROPT2
         LI,R14   MUNKOPT           UNKNOWN OPTION
         B        ERROR2
*
PAROPT6  BAL,R11  CHKOPT            CHECK LEGALITY OF OPTION
         MTW,1    OPTLOC-1,R2       SET THE FLAG
         B        PAR10
*
*  SERIAL NUMBER
*
PARSN    LI,R14   MSNGHST           'OPTION ILLEGAL FOR GHOST'
         LC       J:JIT
         BCS,4    ERROR2
         LI,R3    B:SN
         LI,R2    X:SN
         BAL,R11  CHKOPT            CHECK LEGALITY OF OPTION
         LI,R14   MILLDEV           'ILLEGAL DEVICE'
         CI,R6    2
         BG       ERROR2            DEV TYPE TOO LONG
         AI,R6    0
         BLEZ     ERROR2
         LH,R2    FBUF
         LI,R3    X'FFFF'
         STS,R2   DEVTYPE           PUT TEXT IN FPT
         LCI      2
         LM,R8    SBUF              GET SERIAL NUMBER
         STM,R8   FBUF
         LW,R8    BLANKS
         STW,R8   FBUF+2
         LI,R12   '-'               LOOK FOR DEVICE TYPE QUALIFIER
         BAL,R11  SPLITFLD
         LI,R14   MILLDEV
         AI,R7    0
         BLZ      PARSN30           NO QUALIFIER
         BEZ      ERROR2            MUST BE 1 OR 2 CHARS
         CI,R7    2
         BG       ERROR2
         LH,R2    SBUF
         LI,R3    X'FFFF'
         STS,R2   DEVTYPE           PUT DEVICE TYPE IN FPT
*
PARSN30  LI,R14   MILLSN            'ILLEGAL SN'
         AI,R6    0
         BLEZ     ERROR2            ERROR IF NO SN
         CI,R6    4
         BG       ERROR2            TOO LARGE
         LW,R2    FBUF
         CW,R2    SN
         STW,R2   SN
         BE       PARSN40           SERIAL NUMBER SAME AS LAST TIME
         LW,R3    Y002
         CW,R3    F:PV              IF DCB OPEN, CLOSE IT TO
         BAZ      %+2                 RELEASE PREVIOUS PACK SET
         M:CLOSE  F:PV,REL
PARSN40  LI,R3    X'100'
         STS,R3   SN-1              # USED WORDS = 1
         B        PAR10
         SPACE    2
*
*  CHECK LEGALITY OF AN OPTION
*    BAL,R11  CHKOPT
*
*    R2 = INDEX TO OPT TABLES
*    R3 = BIT SET  (B:SN,B:ACCT,B:ALL, ETC.)
*  RETURNS *R11 IF ALLRIGHT, ELSE GOES TO ERROR2
*
CHKOPT   LI,R14   MILLOPT           'OPTION ILLEGAL WITH COMMAND'
         LW,R5    COMINDX
         CW,R3    COMOPT-1,R5
         BANZ     ERROR2            NOT LEGAL WITH THIS COMMAND
         LI,R14   MDUPOPT           'DUPLICATE OPTION'
         CW,R3    CUROPT
         BANZ     ERROR2
         LI,R14   MOPTERR           'CONFLICTING OPTIONS'
         LW,R5    OPTOPT-1,R2
         CW,R5    CUROPT
         BANZ     ERROR2
         STS,R3   CUROPT            OK - SET OPTION PRESENT
         B        *R11
         TITLE    '****  GETFIELD  ****'
         SPACE    2
*
*  PURPOSE:  GET NEXT FIELD FROM INPUT COMMAND
*
*  CALL:   BAL,R11  GETFIELD
*
*  OUTPUT:  R7 = # CHARACTERS IN FIELD
*           R12 = DELIMITER
*           CC = 0   A FIELD WAS FOUND
*              = 4   NO MORE FIELD EXIST
*
         SPACE    1
GETFIELD LI,R7    (FBUFSIZ+3)/4
         LW,R9    BLANKS            BLANK FBUF
         STW,R9   FBUF-1,R7
         BDR,R7   %-1
         STW,R7   GETNCHK           CHECK FOR HEX AND CHAR FIELDS
         LI,R9    -1                FLAG FOR PROCESSING LEADING BLANKS
*
GETF10   AI,R9    0
         BGZ      GETF15
         LW,R3    INPOS             NOT PROCESSING TRAILING BLANKS
         STW,R3   ENDFLD            MARK CURR POSITION AS END OF FIELD
*
GETF15   BAL,R10  GETCHAR           R12 = NEXT CHAR
         BCS,4    GETF40            NO MORE CHARS
         BCR,3    GETF20            NOT DELIMITER
         BCR,2    GETF35            DELIMITER - NOT BLANK
*  BLANK ENCOUNTERED
         AI,R9    0
         BNEZ     GETF10            LEADING BLANK - KEEP ON
         LI,R9    1                 SET END OF FIELD FLAG
         STW,R9   GETNCHK
         MTW,-1   ENDFLD            BACK UP END OF FIELD POINTER
         B        GETF15
*
*  NOT DELIMITER
*
GETF20   AI,R9    0
         BGZ      GETF30            END OF TRAILING BLANKS
         CI,R7    FBUFSIZ
         BG       FIELDBIG          TOO MANY CHARS IN FIELD
         STB,R12  FBUF,R7           STORE IN BUFFER
         AI,R7    1
         LI,R9    0
         B        GETF10            GET NEXT CHAR
*
*  FIELD TERMINATED BY NON-DELIMITER AFTER ONE OR MORE BLANKS
*
GETF30   MTW,-1   INPOS             BACK UP INPUT POINTER
GETF32   LI,R12   X'40'             DELIMITER = BLANK
GETF35   LCI      0
         B        *R11
*
*  NO MORE CHARS IN INPUT BUFFER
*
GETF40   AI,R9    0
         BGZ      %+2               DON'T DECR POINTER IF TRAIL BLANKS
         MTW,-1   ENDFLD            BACK UP END-OF-FIELD POINTER
         AI,R7    0
         BNEZ     GETF32            SOME CHARACTERS WERE READ
         LCI      4                 SET NO FIELD FLAG
         B        *R11
*
*  FIELD TOO LARGE
*
FIELDBIG LI,R14   MF2LNG
         B        ERROR
         TITLE    '****  SPLITFLD  ****'
         SPACE    2
*
*  PURPOSE:  SPLIT TWO FIELDS
*
*  INPUT:  FIELDS TO BE SPLIT IN FBUF
*          R12 = CHAR WHICH SPLITS FIELDS
*
*  CALL:  BAL,R11  SPLITFLD
*
*  OUTPUT:  FIRST STRING IN FBUF, SECOND IN SBUF
*           R6 = # CHARS IN STRING 1
*           R7 = # CHARS IN STRING 2 (-1 IF SPLIT CHAR NOT FOUND)
*
         SPACE    1
SPLITFLD LI,R6    (SBUFSIZ+3)/4
         LW,R7    BLANKS            BLANK SBUF
         STW,R7   SBUF-1,R6
         BDR,R6   %-1
*
         LI,R7    -1                ASSUME NO SPLIT CHAR FOUND
SPLIT10  LB,R13   FBUF,R6
         CW,R13   R12
         BE       SPLIT20           FOUND SPLIT CHAR
         CI,R13   X'40'             TERMINATE AT BLANK
         BE       *R11
         AI,R6    1
         CI,R6    FBUFSIZ
         BL       SPLIT10
         B        *R11              NO SPLIT CHAR FOUND
*
SPLIT20  LI,R7    0                 # CHARS IN SECOND STRING
         LI,R13   X'40'
         LW,R5    R6                CURRENT INDEX INTO FBUF
SPLIT25  STB,R13  FBUF,R5           BLANK LAST CHAR
         AI,R5    1
         CI,R5    FBUFSIZ
         BGE      *R11              DONE - END OF FBUF
         LB,R14   FBUF,R5           PICK UP NEXT CHAR
         CI,R14   X'40'
         BE       *R11              DONE - END OF FIELD
         CI,R7    SBUFSIZ
         BGE      SPLITERR          ERROR - FIELD TOO LONG
         CW,R12   R14
         BE       SPLITERR          ERROR - ANOTHER SPLIT CHAR
         STB,R14  SBUF,R7           STORE THIS CHAR
         AI,R7    1
         B        SPLIT25
*
SPLITERR LI,R14   MILLSYN           'ILLEGAL SYNTAX'
         B        ERROR2
         TITLE    '****  GETCHAR  ****'
         SPACE    2
*
*  PURPOSE:  GET NEXT CHARACTER FROM INPUT BUFFER
*
*  CALL:  BAL,R10  GETCHAR
*
*  OUTPUT:  R12 = NEXT CHARACTER
*           R13 = NEXT CHAR AFTER ONE IN R12
*           CC = 0  OK
*              = 1  DELIMITER IN R12
*              = 2  BLANK IN R12
*              = 4  NO NEXT CHARACTER
*
         SPACE    1
GETCHAR  BAL,R15  NXTCHAR           GET NEXT CHAR FROM INBUF
         BCS,4    NOCHARS           NO MORE
         MTW,0    FLDFLG
         BLZ      HEXFLD            CURRENTLY IN HEX FIELD
         BGZ      CHARFLD           CURRENTLY IN CHAR FIELD
*  NO SPECIAL FIELD IN PROGRESS
         MTW,0    GETNCHK           ARE SPECIAL FIELDS IGNORED
         BNEZ     CHKDELIM          YES
         CI,R12   'X'
         BE       BEGHEX            MAYBE BEGIN HEX FIELD
         CI,R12   ''''
         BE       BEGCHAR           BEGIN CHARACTER FIELD
*
CHKDELIM LI,R3    #DELIM
         CB,R12   DELIMS,R3
         BE       FNDELIM           FOUND A DELIMITER
         BDR,R3   %-2
GETOK    LCI      0                 NOT DELIMITER
         B        *R10
*
FNDELIM  CI,R12   X'40'
         BE       FNDBLNK
         LCI      1                 DELIMITER - NOT BLANK
         B        *R10
FNDBLNK  LCI      2                 BLANK
         B        *R10
*
NOCHARS  MTW,0    FLDFLG            NO MORE CHARS IN INBUF
         BNEZ     UNTERM            FIELD NOT TERMINATED
         LCI      4
         B        *R10
*
*  UNTERMINATED FIELD
*
UNTERM   LI,R14   MUTFLD
         B        ERROR
*
*  POSSIBLE BEGINNING OF HEX FIELD
*
BEGHEX   CI,R13   ''''              IS NEXT CHAR QUOTE
         BNE      CHKDELIM          NO - NOT HEX FIELD
         LI,R13   -1
         STW,R13  FLDFLG            SET HEX FIELD FLAG
         BAL,R15  NXTCHAR           GET THE QUOTE
         BCS,1    UNTERM            NO CHARS AFTER QUOTE
         LW,R4    R3                SAVE INDEX OF FIRST CHAR IN STRING
BEGHEX2  LB,R12   INBUF,R3          GET NEXT CHAR
         CI,R12   ''''              FIND CLOSING QUOTE
         BE       BEGHEX4
         AI,R3    1
         CW,R3    INCNT
         BLE      BEGHEX2
         B        UNTERM            NO CLOSING QUOTE
*
BEGHEX4  SW,R3    R4                # CHARS IN FIELD
         LW,R4    R3
         BEZ      GETCHAR           EMPTY FIELD
BEGHEX5  LI,R14   0
         BAL,R15  NXTCHAR           GET NEXT CHARACTER
         STB,R12  R14               SAVE IT
         SCS,R12  -8                POSITION
         CI,R4    1                 IF ODD # CHARS IN FIELD,
         BANZ     BEGHEX6             ONLY GET ONE CHAR FIRST TIME
         BAL,R15  NXTCHAR           GET SECOND CHAR
         SLS,R12  16
         OR,R12   R14               COMBINE BOTH DIGITS
BEGHEX6  BAL,R15  HEX2BIN           CONVERT TO BINARY
         LW,R12   R4                MOVE BINARY NUMBER
         B        GETOK
*
*  BEGIN CHARACTER STRING
*
BEGCHAR  LI,R3    1
         STW,R3   FLDFLG            SET CHAR FIELD IN PROGRESS
         B        GETCHAR
*
*  PROCESS HEX FIELD
*
HEXFLD   CI,R12   ''''
         BNE      HEXFLD2           NOT END
FLDEND   LI,R12   0
         STW,R12  FLDFLG            SIGNAL END OF SPECIAL FIELD
         B        GETCHAR
*
HEXFLD2  LI,R4    0
         MTW,-1   INPOS             BACK OVER CHAR JUST GOTTEN
         B        BEGHEX5           GET AND COMBINE TWO DIGITS
*
*  PROCESS CHARACTER FIELD
*
CHARFLD  CI,R12   ''''
         BNE      GETOK             NOT END
         CI,R13   ''''              IS IT TWO IN A ROW
         BNE      FLDEND            NO - END OF FIELD
         BAL,R15  NXTCHAR           YES - GIVE SECOND
         B        GETCHAR
*
*  GET NEXT CHAR IN R12, ONE AFTER IN R13
*
NXTCHAR  LI,R12   0                 ZAP IN CASE
         LI,R13   0                 NO CHARS IN BUFFER
         LW,R3    INPOS             INDEX OF NEXT CHAR
         CW,R3    INCNT
         BG       NXTCH4            NO MORE
         MTW,1    INPOS             INCR NEXT CHAR POINTER
         LB,R12   INBUF,R3
         AI,R3    1
         CW,R3    INCNT             IS THERE ANOTHER CHAR
         BG       NXTCH2            NO
         LB,R13   INBUF,R3
         LCI      0
         B        *R15
NXTCH2   LCI      1
         B        *R15
NXTCH4   LCI      4
         B        *R15
         TITLE    '****  HEX2BIN  ****'
         SPACE    2
*
*  PURPOSE:  CONVERT EBCDIC HEX TO BINARY
*
*  INPUT:  EBCDIC IN R12,R13 LEFT JUSTIFIED.  CONVERSION
*           TERMINATES WITH ZERO OR BLANK
*
*  CALL:  BAL,R15  HEX2BIN
*
*  OUTPUT:  R4 = BINARY NUMBER
*
         SPACE    1
HEX2BIN  LI,R4    0
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
         B        ERROR
         TITLE    '****  BIN2HEX  ****'
         SPACE    2
*
*  PURPOSE:  CONVERT BINARY TO EBCDIC HEX
*
*  INPUT:  BINARY NUMBER IN R2
*
*  CALL:  BAL,R15  BIN2HEX
*
*  OUTPUT:  R5 = # NON-BLANK CHARACTERS
*           R12,R13 = EBCDIC, LEFT JUSTIFIED BLANK FILLED
*
         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
         TITLE    '****  BIN2DEC  ****'
         SPACE    2
*
*  PURPOSE:  CONVERT BINARY TO EBCDIC DECIMAL
*
*  INPUT:  R3 = BINARY NUMBER
*
*  CALL:  BAL,R15  BIN2DEC
*
*  OUTPUT:  R5 = # NON-BLANK CHARACTERS
*           R12,R13 = EBCDIC, LEFT JUSTIFIED BLANK FILLED
*
         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
*
*  PURPOSE:  MOVE TEXT OR TEXTC STRING INTO OUTPUT BUFFER
*
*  INPUT:  R4 = BA OF STRING
*          R5 = # BYTES (MOVTXT ONLY)
*
*  CALL:  BAL,R10  MOVTXT
*         BAL,R10  MOVTXTC
*
         SPACE    1
MOVTXTC  LB,R5    0,R4              TEXTC COUNT
         AI,R4    1                 POINT PAST COUNT
*
MOVTXT   SCS,R5   -8                POSITION BYTE COUNT FOR MBS
         OR,R5    PRPOS             ADD DESTINATION BYTE ADDR
         MBS,R4   0
         STW,R5   PRPOS             NEW DESTINATION
         B        *R10
         TITLE    '****  PUTMES, PUTMESC  ****'
         SPACE    2
*
*  PURPOSE:  MOVE TEXT OR TEXTC TO OUTPUT BUFFER AT A
*               GIVEN COLUMN
*
*  INPUT:  R1 = COLUMN #
*          R4 = BA OF TEXT
*          R5 = BYTE COUNT (PUTMES ONLY)
*
*  CALL:  BAL,R10  PUTMES
*         BAL,R10  PUTMESC
*
         SPACE    1
PUTMES   LI,R15   MOVTXT
         B        %+2
PUTMESC  LI,R15   MOVTXTC
         AI,R1    BA(PRBUF)
         CW,R1    PRPOS
         BL       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
*
*  PURPOSE:  CONVERT BINARY NUMBER TO EBCDIC AND PUT IN OUTPUT
*            BUFFER AT A GIVEN COLUMN, RIGHT OR LEFT JUSTIFIED.
*            LEFT JUSTIFIED BEGINS AT INDICATED COLUMN, RIGHT
*            JUSTIFIED ENDS IN INDICATED COLUMN.
*
*  CALL:
*        BAL,R10   PUTDECL/PUTDECR
*          R1 = COL #
*          R3 = BINARY NUMBER
*
*        BAL,R10   PUTHEXL/PUTHEXR
*          R1 = COL #
*          R2 = BINARY NUMBER
*
         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
         B        PUTHEX2
         TITLE    '****  MOVDEC, MOVHEX  ****'
         SPACE    2
*
*  PURPOSE:  CONVERT BINARY NUMBER TO EBCDIC, PUT IN OUTPUT BUFFER
*
*  INPUT:  R2 = BINARY NUMBER (MOVHEX)
*          R3 = BINARY NUMBER (MOVDEC)
*
*  CALL:  BAL,R10  MOVDEC
*         BAL,R10  MOVHEX
*
         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
*
*  PURPOSE:  DUMP CONTENTS OF PRBUF, INITIALIZE  POINTERS
*
*  CALL:  BAL,R15  DUMPBUF          WRITES THROUGH M:LO
*         BAL,R15  DUMPB            WRITES THROUGH *ECHODCB
*         BAL,R15  INITBUF
*
         SPACE    1
DUMPBUF  LW,R10   PRPOS             BA OF NEXT AVAIL BYTE
         AI,R10   -BA(PRBUF)        # BYTES 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
DUMPB    LW,R3    PRPOS
         AI,R3    -BA(PRBUF)
         LI,R10   X'15'
         STB,R10  PRBUF,R3          CARRIAGE RETURN AT END
         LW,R10   R3
         LC       J:JIT
         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
         AI,R10   1                 INCLUDE CARRIAGE RETURN
DUMPB2   EQU      %
         M:WRITE  *ECHODCB,(BUF,PRBUF),(SIZE,*R10),(BTD,0),WAIT
         B        INITBUF
         TITLE    '****  HEXDUMP  ****'
         SPACE    2
*
*  PURPOSE:  DUMP CORE IN HEX WITH TRANSLATION
*
*  INPUT:  R12 = FIRST CORE LOCATION TO BE DUMPED
*          R13 = # WORDS TO DUMP.  IF < 0, NO SPACING BETWEEN WORDS
*          R14 = ADDRESS TO BE PRINTED (<0 IF NONE)
*
*  CALL:  BAL,R11  HEXDUMP
*
*    ALTERNATE ENTRY POINT - HEXDUMPB
*          R13 = # BYTES TO DUMP
*
         SPACE    1
HEXDUMP  PUSH     R13
         SLS,R13  2                 CONVERT WORDS TO BYTES
         B        %+2
HEXDUMPB PUSH     R13
         PUSH     15,R14
         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
         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    6                 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,R2    *SPD              # WORDS ON THIS LINE
         CI,R2    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
         BAL,R15  DUMPBUF
         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
         B        HX1
*
SOURCE   LB,0     *R12              FOR ANLZ
DEST     LB,0     PRBUF,R1          FOR ANLZ
         TITLE    '****  FLAG ERROR  ****'
         SPACE    2
ERROR2   LW,R3    ENDFLD            POINT TO END OF LAST FIELD
         B        ERROR1
ERROR    LW,R3    INPOS
         AI,R3    -1
*
*  PRINT ERROR MARKER - R3 CONTAINS INDEX
*
ERROR1   BAL,R11  ERRMARK
ERROR3   BAL,R11  DOPRINT           PRINT MESSAGE
         LC       J:JIT
         BCR,12   ERROR5            BATCH - EXIT
         BCS,4    LOOPEND           GHOST
         MTW,0    M:SIFLG           ONLINE - TRY AGAIN IF M:SI
         BEZ      RDLOOP              ASSIGNED TO TTY
*
ERROR5   LI,R14   MERRXIT
         BAL,R11  DOPRINT
         M:XXX
         SPACE    3
ERRMARK  LI,R7    (INBUFSIZ+3)/4
         LW,R9    BLANKS            BLANK BUFFER
         STW,R9   INBUF-1,R7
         BDR,R7   %-1
         AI,R3    1
         LI,R7    '%'
         STB,R7   INBUF,R3
         AI,R3    1
         LI,R7    X'15'
         STB,R7   INBUF,R3          PUT IN CARRIAGE RETURN
         LC       J:JIT
         BCR,12   ERRMRK2           BR IF BATCH
         M:WRITE  M:LO,(BUF,INBUF),(SIZE,*R3),(BTD,0),WAIT
         AI,R3    1                 INCLUDE CARRIAGE RETURN IF NOT BATCH
ERRMRK2  EQU      %
         M:WRITE  *ECHODCB,(BUF,INBUF),(SIZE,*R3),(BTD,1)
         B        *R11
*
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
         SLS,R15  7
         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   M:WRITE  M:LO,(BUF,*R14),(SIZE,*R10),(BTD,*R3),WAIT
         B        *R15
         TITLE    '****  GRANERR  ****'
         SPACE    2
*
*  PURPOSE:  RETRY I/O ON A GRANULE.  IF RETRIES EXHAUSTED, WILL READ
*              DUAL IF ONE EXISTS.
*
*  INPUT:  CURBUF POINTS TO CURRENT BUF TABLE ENTRY
*          R15 = ERROR CODE
*
*  CALL:  BAL,R11  GRANERR
*
*  OUTPUT:  CC SET FOR:
*            BEZ IF NO RETRIES REMAINING
*            BNEZ IF RETRY SUCCESSFUL
*
         SPACE    1
GRANERR  PUSH     16,R0
         STW,R15  ERRCODE           SAVE ERROR CODE
         BAL,R10  IORETRY           RETRY THE I/O
         BNEZ     GRANER40          SOME RETRIES REMAIN
*  NO MORE RETRIES
         LW,R11   DUALFLAG          HAS DUAL BEEN READ
         BNEZ     GRANER30          YES - NO MORE HOPE
         LW,R8    BUFDUAL,R7
         BLEZ     GRANER30          NO DUAL OR JUST ALLOCATED
         BAL,R11  ERRMSG            GIVE ERROR MESSAGE FOR MASTER
         BAL,R11  SNAPGRAN          SNAP THE MASTER
         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
         MTW,1    DUALFLAG          INDICATE DUAL READ
         BAL,R11  DISCIOA           READ THE DUAL
         B        GRANER40
*
*  RETRIES EXHAUSTED - NO DUAL OR DUAL BAD
*
GRANER30 EQU      %
         BAL,R11  ERRMSG            PRINT ERROR MESSAGES
         BAL,R11  SNAPGRAN          DUMP THE BUFFER
         B        GRANXIT
*
GRANER40 LI,R15   0
         STW,R15  ERRCODE
         BAL,R11  IOSPIN            WAIT FOR I/O TO COMPLETE
GRANXIT  PULL     16,R0
         LW,R15   ERRCODE
         B        *R11
         TITLE    '****  ERRMSG  ****'
         SPACE    2
*
*  PURPOSE:  PRINT TWO MESSAGES AS FOLLOWS:
*           'ERROR IN XXXX'
*           'DISC ADDRESS YYYY    ERROR CODE ZZ'
*
*  INPUT:  'CURMES' CONTAINS BYTE ADDRESS OF MESSAGE 'XXXX'
*          R7 = BUF TABLE INDEX.  'YYYY' IS BUFDA.
*          'ERRCODE' CONTAINS THE ERROR CODE ZZ
*
*  CALL:  BAL,R11  ERRMSG
*
         SPACE    1
ERRMSG   PUSH     R11
         MTW,1    ERRCNT            INCREMENT ERROR COUNT
         MTW,1    ERRCNT1           # ERRORS FOR THIS GRANULE
         LI,R4    BA(MERRIN)        'ERROR IN '
         BAL,R10  MOVTXTC           MOVE TO PRINT BUFFER
         LW,R4    CURMES            BA OF TEXTC STRING
         BAL,R10  MOVTXTC           MOVE TO PRINT BUFFER
         BAL,R15  DUMPBUF           PRINT THE LINE
*
         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
         BAL,R15  DUMPBUF           PRINT THE LINE
         BAL,R15  INITBUF           DISCARD ANYTHING IN BUFFER
*
         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  PULL     R15
         B        DUMPBUF           PRINT THE LINE
         TITLE    '****  SNAPGRAN  ****'
         SPACE    2
*
*  PURPOSE:  DUMP CURRENT BUFFER ALONG WITH ITS DISC ADDRESS
*
*  INPUT:  R7 = BUF TABLE INDEX OF CURRENT BUFFER
*
*  CALL:  BAL,R11  SNAPGRAN
*
         SPACE    1
SNAPGRAN LW,R9    FL:SNAP
         CW,R9    BUFDA,R7          HAS BUFFER ALREADY BEEN SNAPPED
         BANZ     *R11              YES - DO NOTHING
         STS,R9   BUFDA,R7
         PUSH     R11
*
         LI,R4    BA(MSNAPG)        'SNAP OF '
         BAL,R10  MOVTXTC
         LW,R4    CURMES
         BAL,R10  MOVTXTC
         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
         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
         BEZ      SNAP4             THERE IS NO DUAL
         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    '****  ERROR ROUTINES  ****'
         SPACE    2
PRIVLOW  LI,R14   MPRIVLOW          NOT ENOUGH PRIV
MESSOUT  BAL,R11  DOPRINT
         M:XXX
*
BADMON   LI,R14   MBADMON           BAD MONSTK
         B        MESSOUT
*
SUPERCLS CAL1,9   6                 SUPERCLOSE
         LI,R11   0
         STW,R11  WORKFLAG
         B        LOOPEND
*
EXIT     EQU      %
         MTW,0    WORKFLAG
         BEZ      %+2               DON'T SUPERCLOSE UNLESS WORK DONE
         CAL1,9   6                 SUPERCLOSE
         LI,R11   0
         STW,R11  OCREQ1            OPERATOR COMMUNICATION TERMINATED
         LC       J:JIT
         BCS,4    GHSTIDLE          GHOST - GO TO IDLE LOOP
EXIT2    M:EXIT
         TITLE    '****  PRFNAM  ****'
         SPACE    2
*
*  PURPOSE:  MOVE KEY TO PRINT BUFFER.  IF KEY CONTAINS ANY
*    NON-PRINTABLE CHARACTERS, ALSO PRINT THE NAME IN HEX.
*
*  INPUT:  R4 = BA OF KEY
*
*  CALL:  BAL,R11  PRKEY
*
         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
         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
         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
         BDR,R4   PRK2              DO REST OF CHARACTERS IN KEY
*
         STW,R1   PRPOS             NEW END OF BUFFER
         LI,R4    BA(MHEX2)         ')'''
         BAL,R10  MOVTXTC
         B        *R11
         TITLE    '****  KEYIN  ****'
         SPACE    2
*
*  PURPOSE:  ISSUE KEYIN SEQUENCE TO OPERATOR'S CONSOLE
*
*  INPUT:  R4 = BA OF MESSAGE TO SEND
*
*  CALL:  BAL,R11  KEYIN
*
*  OUTPUT:  OCIOCNT = NUMBER OF READ REQUESTS OUTSTANDING
*           INBUF = RECORD READ (BTD = 1)
*           INCNT = NUMBER OF BYTES READ (EXCLUSIVE OF ACTIVATION CHAR)
*
         SPACE    1
KEYIN    PUSH     R11
         LB,R14   0,R4              # BYTES IN MESSAGE
         LW,R13   R4                BA OF MESSAGE
         AI,R13   1                 SKIP TEXTC COUNT
         LI,R12   OCDCT             DCT INDEX OF OC
         LI,R7    XOCWRT            SPECIAL BUFFER CODE
         LI,R2    1                 FUNCTION CODE (WRITE)
         BAL,R11  IOQUEUE           QUEUE THE I/O
*
         LI,R14   OCRDCNT           BYTE COUNT FOR READ
         LI,R13   BA(INBUF)+1       BA OF BUFFER
         LI,R7    XOCRD             SPECIAL BUFFER CODE
         LI,R2    0                 FUNCTION CODE (READ)
         MTW,1    OCIOCNT           INCR # READS OUTSTANDING
         PULL     R11
         B        IOQUEUE           QUEUE IT THEN RETURN TO CALLER
         SPACE    3
*
*  ISSUE M:KEYIN SEQUENCE TO OPERATOR'S CONSOLE AND WAIT FOR
*  REPLY TO BE RECEIVED.
*
*  INPUT:  R4 = BA OF MESSAGE TO SEND.  REPLY READ INTO INBUF WITH
*              BYTE DISPLACEMENT OF 1.
*
OCKEYIN  PUSH     R11
         BAL,R11  KEYIN             ISSUE WRITE AND READ
OCK10    DISABLE                    ****  DISABLE
         LW,R11   OCIOCNT           HAS READ FINISHED
         BEZ      OCK20             YES
         M:WAIT   10                NO
         B        OCK10
OCK20    ENABLE                     ****  ENABLE
         PULL     R11
         B        *R11
         SPACE    3
OCMESS   LB,R14   0,R4              TEXTC COUNT
         LW,R13   R4
         AI,R13   1                 BA OF MESSAGE
         LI,R2    1                 FCN CODE FOR WRITE
         LI,R7    XOCWRT            SPECIAL BUFFER CODE FOR OC WRITE
         LI,R12   OCDCT             DCT INDEX
         B IOQUEUE                  QUEUE THE I/O
         TITLE    '****  PUBHGPS  ****'
         SPACE    2
*
*  PURPOSE:  BUILD ONE COPY OF PUBLIC HGPS
*
*  CALL:  BAL,R11  PUBHGPS
*
*  OUTPUT:  PUBLIC HGPS BUILT STARTING AT 'HGP2'.  PRIVATE HGPS
*           AND THOSE WITH NO PER OR PFA WILL BE SKIPPED.
*           RETURN SKIPPING IF ENOUGH CORE AVAILABLE.
*
         SPACE    1
PUBHGPS  PUSH     R11
         LI,R7    0
         STW,R7   GETNXT            INDICATE NO PAGES GOTTEN YET
         LI,R7    HGP               ADDRESS OF HGP HEADERS
HGPLOOP  LW,R2    1,R7
         CI,R2    ATPRIVBIT
         BANZ     HGPNXT            PRIVATE - SKIP
         SLS,R2   -16
         AND,R2   M8                DCT INDEX
         LB,R3    DCT24,R2
         CI,R3    X'82'
         BANZ     HGPNXT            IGNORE IF PARTITIONED
         LW,R9    4,R7              # PER AND PFA WORDS
         BEZ      HGPNXT            NONE - SKIP IT
         BAL,R11  BLDHGP            BUILD ONE HGP
         B        HGPERR            NOT ENOUGH CORE
*
HGPNXT   LW,R7    0,R7              LINK TO NEXT
         BNEZ     HGPLOOP
         LW,R2    NXTHGP
         SW,R2    HGP2              # WORDS IN HGPS
         CI,R2    HGPSIZE           CAN'T BE > SYSGEN BUILT HGPS
         BG       HGPERR            TOO BIG
         LW,R2    GETNXT
         SW,R2    NXTHGP            # WORDS TO END OF CURRENT PAGE
         BLEZ     HGPNXT8           NONE
HGPNXT4  STW,R7   *NXTHGP           ZERO REMAINING SPACE IN PAGE
         MTW,1    NXTHGP
         BDR,R2   HGPNXT4
HGPNXT8  PULL     R11
         AI,R11   1
         B        *R11
*
HGPERR   LI,R11   0
         STW,R11  HGP2
         XW,R11   #PAGES
         M:FP     *R11              FREE ANY PAGES GOTTEN
         PULL     R11
         B        *R11              ERROR RETURN
         TITLE    '****  BLDHGP  ****'
         SPACE    2
*
*  PURPOSE:  BUILD ONE HGP HEADER AND BIT MAP
*
*  INPUT:  R7 = ADDRESS OF HGP HEADER
*
*  CALL:  BAL,R11  BLDHGP
*
*  OUTPUT:  ADDRESS OF FIRST WORD PAST HGP IN NXTHGP.
*
*  HGP HEADER FORMAT:
*
*      WORD
*        0        LINK TO NEXT HGP
*        1        0,DCTX,TYPE,NGC   (8,8,8,8)
*        2        FIRST PER SECTOR (ZERO IF NO PER)
*        3        FIRST PFA SECTOR (# SECTORS ON DEVICE IF NO PFA)
*        4        FIRST SECTOR BEYOND END OF DEVICE
*        5        # PER WORDS, DISPL TO PER BIT MAP  (16,16)
*                     IF PRIVATE, NAVAT
*        6        # PFA WORDS, DISPL TO PFA BIT MAP  (16,16)
*
         SPACE    1
GETNXT   EQU      TEMP+15
CURHGP   EQU      TEMP+14
PREVHGP  EQU      TEMP+13
NXTHGP   EQU      TEMP+12
PFASTRT  EQU      TEMP+11
BLDHGP   EQU      %
         LW,R8    GETNXT            ADDRESS OF FIRST UN-ALLOCATED WORD
         BNEZ     BLDH10            NOT FIRST CALL
         STW,R8   CURHGP
         STW,R8   PREVHGP
         LI,R4    0                 MAKE BLDGET1 GET ONLY 1 PAGE
         LI,R5    0
         LI,R12   0
         BAL,R10  BLDGET1           ALLOCATE A PAGE
         BEZ      BLDH90
         AI,R9    -512
         STW,R9   NXTHGP            ADDRESS OF FIRST WORD
         STW,R9   HGP2
*
BLDH10   LI,R8    0
         XW,R8    NXTHGP            RIPPLE DOWN HGP ADDRESSES
         XW,R8    CURHGP
         STW,R8   PREVHGP
         LW,R4    CURHGP            ADDRESS OF CURRENT HGP
         LI,R5    0                 CURRENT HGP DISPLACEMENT
         LI,R12   7                 INSURE THAT THERE ARE 7
         BAL,R10  BLDGET              WORDS REMAINING
         BEZ      BLDH10            OUT OF PAGES
*
         LI,R8    0                 LINK TO NEXT HGP
         STW,R8   0,R4
         STW,R8   5,R4              ZERO PER AND PFA POINTERS
         STW,R8   6,R4
         LW,R9    1,R7
         CI,R9    ATCYLBIT
         BANZ     BLDH12            BR IF CYL ALLOCATED
         AND,R9   YFFFFFF           GRANULE - FORCE # GRAN/CYL TO 1
         AI,R9    1
BLDH12   STW,R9   1,R4
         STW,R4   *PREVHGP          LINK PREVIOUS HGP TO THIS ONE
         STW,R8   2,R4              FIRST PER SECTOR = 0
         STW,R8   3,R4              FIRST PFA SECTOR = 0
         LI,R2    5
         LB,R2    *R4,R2            DCT INDEX
         LB,R3    DCT22,R2          DISC TYPE
         LW,R15   DISCLIMS,R3       # SECTORS ON DEVICE
         STW,R15  4,R4              FIRST SECTOR BEYOND DEVICE
*
*  BUILD PER MAP
*
         LI,R5    7                 CURRENT INDEX INTO HGP
         LI,R2    8
         LH,R14   *R7,R2            # WORDS IN PER MAP
         BEZ      BLDH30            NO PER
         INT,R9   6,R7              PFA FIRST SECTOR
         INT,R3   4,R7              # PFA WORDS
         AI,R3    0
         BNEZ     BLDH20
         LW,R9    R15               NO PFA - END OF PER IS END OF DEVICE
BLDH20   STW,R5   5,R4              WORD INDEX TO PER BIT MAP
         LW,R8    2,R4              PER FIRST SECTOR
         STW,R9   3,R4              PER LAST SECTOR
         BAL,R15  BLDMAP            BUILD PER MAP
         B        BLDH90            NOT ENOUGH CORE
         LI,R2    10
         STH,R14  *R4,R2            SET # WORDS USED IN BIT MAP
*
*  BUILD PFA
*
BLDH30   EQU      %
         LI,R2    9
         LH,R14   *R7,R2            # PFA BIT MAP WORDS
         BEZ      BLDH40            NONE - NO PFA
         STW,R5   6,R4              WORD INDEX TO PFA BIT MAP
         LW,R8    3,R4              PFA FIRST SECTOR
         LW,R9    4,R4              PFA LAST SECTOR
         BAL,R15  BLDMAP            BUILD THE PFA BIT MAP
         B        BLDH90            NOT ENOUGH CORE
         LI,R2    12
         STH,R14  *R4,R2            SET # WORDS USED IN BIT MAP
*
BLDH40   EQU      %
         LI,R12   1
         BAL,R10  BLDGET            INSURE 1 WORD REMAINS
         BEZ      BLDH90            NOT ENOUGH ROOM
         AW,R4    R5                POINT TO FIRST WORD PAST BIT MAP
         STW,R4   NXTHGP            ADDRESS OF NEXT HGP
         AI,R11   1
         B        *R11              NORMAL EXIT
*
BLDH90   EQU      %
         B        *R11              NOT ENOUGH CORE
         TITLE    '****  BLDMAP  ****'
         SPACE    2
*
*  PURPOSE:  BUILD ONE BIT MAP SEGMENT
*
*  INPUT:  R5 = INDEX INTO HGP OF START OF BIT MAP
*          R4 = ADDRESS OF HGP
*          R8 = FIRST RELATIVE SECTOR
*          R9 = LAST RELATIVE SECTOR
*
*  CALL:  BAL,R15  BLDMAP
*
*  OUTPUT:  R5 = INDEX OF FIRST WORD PAST BIT MAP
*           R14 = # WORDS IN BIT MAP
*        RETURNS SKIPPING IF ENOUGH CORE IS AVAILABLE
*
         SPACE    1
BLDMAP   SW,R9    R8
         SLS,R9   -1                # GRANULES
         LW,R2    1,R4
         CI,R2    ATCYLBIT
         AND,R2   M8                MASK OFF # GRAN/CYL
         BAZ      %+2               NOT CYL
         DW,R9    R2                CONVERT # GRANULES TO # CYLS
*  R9 = # BITS IN BIT MAP
         LW,R12   R9
         SLD,R12  -5                R12 = # FULL WORDS IN BIT MAP
         SLS,R13  -27               R13 = # BITS IN LAST WORD
         AI,R13   0
         BEZ      %+2               IF PARTIAL WORD, INCR # WORDS
         AI,R12   1
         BAL,R10  BLDGET
         BEZ      *R15              NOT ENOUGH CORE
         LW,R14   R12               # FULL WORDS
         LI,R2    0
         STW,R2   *CURHGP,R5        ZERO THE HGP
         AI,R5    1
         BDR,R12  %-2
         AI,R15   1                 NORMAL EXIT
         B        *R15
         SPACE    4
*
*  INSURE ENOUGH PAGES HAVE BEEN ALLOCATED.
*
*  R4 = HGP ADDRESS
*  R5 = CURRENT DISPLACEMENT
*  R12 = # WORDS TO BE ADDED
*
BLDGET   LW,R8    R12
         AW,R8    R5
         AW,R8    R4                R8 = FIRST WORD BEYOND
         CW,R8    GETNXT
         BL       *R10              OK
BLDGET1  M:GP     1                 GET ONE PAGE
         CI,R8    1
         BNE      BLDGET2           CAN'T GET THE PAGE
         AI,R9    512
         STW,R9   GETNXT
         MTW,1    #PAGES
         B        BLDGET
BLDGET2  LCI      0
         B        *R10
         TITLE    '****  ALLOCG/ALLOCS  ****'
         SPACE    2
*
*  PURPOSE:  ALLOCATE A GRANULE OR CYLINDER IN HGPS
*
*  INPUT:  R8 = DISC ADDRESS
*
*  CALL:  BAL,R11  ALLOCG           ALLOCATE PFA GRANULE OR CYLINDER
*         BAL,R11  ALLOCS           ALLOCATE SYMBIONT GRANULE
*
*  OUTPUT:  R15 = ERROR CODE
*                    0 = NO ERRORS
*                    ERR#51 = NO HGP FOR DCT INDEX
*                    ERR#52 = RELATIVE SECTOR NOT WITHIN LIMITS OF HGP
*                    ERR#53 = DUALLY ALLOCATED IN HGP1
*                    ERR#54 = DUALLY ALLOCATED IN HGP2
*           CC = 1---  BAD DISC ADDRESS (ERR#51 OR ERR#52)
*              = ---1  DUALLY ALLOCATED IN HGP1 (ERR#53)
*              = --1-  DUALLY ALLOCATED IN HGP2 (ERR#54)
*              = -1--  NOT MASTER OF CYLINDER
*
         SPACE    1
ALLOCG   LI,R6    4                 FLAG FOR PFA
         B        %+2
ALLOCS   LI,R6    3                 FLAG FOR PER
         LI,R15   0                 NO ERRORS YET
ALLOCKD  LCI      15
         STM,R0   TEMP              SAVE ALL REGISTERS
         LDCTX,R1 R8                DCT INDEX OF GRANULE
         BAL,R5   FNDHGP            LOCATE HGP
         B        ALLOC40           CAN'T FIND IT - BAD DISC ADDRESS
         BAL,R5   FNDBIT            LOCATE BIT IN BITMAP
         B        ALLOC50           RELATIVE SECTOR OUT OF RANGE
         CI,R15   X'100'
         BANZ     ALLOGKD           BR IF NON-MASTER KEYED FILE DATA
         LW,R5    1,R7
         CI,R5    ATCYLBIT
         BAZ      ALLOG10           NOT CYLINDER ALLOCATED
         CW,R15   Y4
         BAZ      ALLOG10           MASTER OF CYLINDER
ALLOGKD  CW,R3    *HGPDISP,R2       CHECK AGAINST CURRENT HGP COPY
         BANZ     ALLOCXIT          ALREADY THERE - OK
         CW,R3    0,R2              CHECK AGAINST MASTER HGP
         BANZ     ALLOC10           ERROR
         STB,R4   R2
         LW,R5    CURDATA           # DISC ADDRS SAVED IN DATADA
         AI,R5    1
         CI,R5    384
         BGE      ALLOCXIT          NO MORE ROOM
         STW,R2   *DATADA,R5        SAVE IT
         STW,R5   CURDATA
         B        ALLOCXIT
*
ALLOG10  STB,R4   R2
         LW,R5    CURDATA
         BLEZ     ALLOG30           NONE SAVED
         LI,R6    0
         CW,R2    *DATADA,R6        SEE IF THIS DA IS IN LIST
         BE       ALLOG20
         AI,R6    1
         BDR,R5   %-3
         B        ALLOG30           NOT IN LIST
ALLOG20  LW,R4    R6                REMOVE FROM LIST
ALLOG22  AI,R3    1
         CW,R6    CURDATA
         BGE      ALLOG30
         LW,R8    *DATADA,R6
         STW,R8   *DATADA,R4        SHUFFLE DOWN LIST
         AI,R4    1
         B        ALLOG22
*
ALLOG30  CW,R3    0,R2              CHECK IF ALLOCATED IN MASTER HGP
         BANZ     ALLOC10           YES
         CW,R3    *HGPDISP,R2       CHECK OTHER HGP COPY
         BANZ     ALLOC20
         CW,R15   Y4                IS IT NOT MASTER OF CYLINDER
         BANZ     ALLOCXIT          YES - DON'T SET BIT
         STS,R3   0,R2              ALLOCATE IN BOTH HGPS
         STS,R3   *HGPDISP,R2
*
ALLOCXIT LCI      15
         LM,R0    TEMP              RESTORE REGISTERS
         STW,R15  ERRCODE
         LC       R15               EXIT CONDITION CODES
         B        *R11
*
ALLOC10  LW,R15   =X'10000000'+ERR#53    ERROR CODE PLUS CC = 0001
         B        ALLOCXIT
*
ALLOC20  LW,R15   =X'20000000'+ERR#54  ERROR CODE PLUS CC = 0010
         B        ALLOCXIT
*
ALLOC40  LI,R15   ERR#51
         B        %+2
ALLOC50  LI,R15   ERR#52
         OR,R15   Y8                SET BAD DISC ADDRESS FLAG
         B        ALLOCXIT
         TITLE    '****  FNDHGP/FNDHGP1  ****'
         SPACE    2
*
*  PURPOSE:  LOCATE AN HGP GIVEN A DCT INDEX
*
*  INPUT:  R1 = DCT INDEX
*          R7 = FIRST HGP ADDRESS (FNDHGP1 ONLY)
*
*  CALL:  BAL,R5  FNDHGP            SEARCH HGP CHAIN POINTED TO BY HGP1
*         BAL,R5  FNDHGP1           SEARCH HGP CHAIN POINTED TO BY R7
*
*  OUTPUT:  R7 = HGP ADDRESS
*           RETURNS SKIPPING IF HGP FOUND
*
         SPACE    1
FNDHGP   LW,R7    HGP1
FNDHGP1  LI,R2    5                 BYTE DISPL OF DCT INDEX
FNDHGP2  CB,R1    *R7,R2
         BE       1,R5              FOUND IT
         LW,R7    0,R7              LINK TO NEXT HGP
         BNEZ     FNDHGP2
         B        0,R5              NO MORE
         TITLE    '****  FNDBIT  ****'
         SPACE    2
*
*  PURPOSE:  GIVEN A DISC ADDRESS, FIND THE BIT IN AN HGP
*
*  INPUT:  R6 = 3 IF PER, 4 IF PFA
*          R7 = HGP ADDRESS
*          R8 = DISC ADDRESS
*
*  OUTPUT:  R2 = ADDRESS OF WORD CONTAINING BIT
*           R3 = BIT MASK
*
         SPACE    1
FNDBIT   LSECTA,R3  R8              RELATIVE SECTOR
FNDBIT1  CW,R3    *R7,R6            COMPARE WITH MAX REL SECT
         BGE      0,R5              TOO BIG
         AI,R6    -1
         SW,R3    *R7,R6            SUBTRACT BEGINNING REL SECTOR
         BLZ      0,R5              REL SECT TOO SMALL
         SLS,R3   -1                GRANULE INDEX INTO BIT MAP
         LW,R4    1,R7
         CI,R4    ATCYLBIT          IS THIS CYLINDER ALLOCATED
         BAZ      FNDB20            NO
         AND,R4   M8                # GRAN/CYL
         LI,R2    0
         DW,R2    R4
         AI,R2    0                 REMAINDER NON-ZERO IF DISC ADDR
         BEZ      %+2                 NOT ON CYL BOUNDARY
         LW,R15   Y4                IT ISN'T - SET FLAG FOR EXIT CC
FNDB20   LW,R2    R3
         SLD,R2   -5                R2 = WORD INDEX INTO THIS BIT MAP
         SLS,R3   -27               BIT INDEX INTO WORD
         AI,R6    3
         INT,R9   *R7,R6            DISPL TO START OF BIT MAP
         AW,R2    R9                WORD DISPL INTO HGP
         AW,R2    R7                ADDRESS OF WORD
         LCW,R4   R3
         LW,R3    BT31TO0+32,R4     BIT MASK
         B        1,R5              NORMAL EXIT
         TITLE    '****  HGPZAP  ****'
         SPACE    2
*
*  PURPOSE:  ZERO ALL HGPS IN A CHAIN
*
*  INPUT:  R7 = ADDRESS OF FIRST HGP
*
*  CALL:  BAL,R11  HGPZAP
*
         SPACE    1
HGPZAP   STW,R11  TEMP+1
HGPZ02   STW,R7   TEMP
         LW,R3    6,R7              HW 0 = # PFA WORDS
         LI,R4    ATPRIVBIT
         CW,R4    1,R7
         BANZ     %+2               SKIP PER IF PRIVATE
         AW,R3    5,R7              ADD # PER WORDS
         SLS,R3   -16               TOTAL # WORDS TO ZERO
         LI,R2    0
         DW,R2    =(14*3)
         STW,R2   TEMP+2            # WORDS LEFT OVER AFTER STM LOOP
         LW,R2    TEMP              CURRENT HGP ADDRESS
         AI,R2    7                 POINT PAST HEADER
         LI,R4    0
         LCI      13
         STM,R4   R5                ZERO REGISTERS 4 TO 1
         AI,R3    0
         BEZ      HGPZ20            NO STM LOOPS
*
HGPZ10   LCI      14
         STM,R4   0,R2              ZERO 14 WORDS AT A TIME
         STM,R4   14,R2
         STM,R4   14+14,R2
         AI,R2    14*3              INCR POINTER
         BDR,R3   HGPZ10
*
HGPZ20   LW,R3    YE
         XW,R3    TEMP+2            RETRIEVE # LEFT OVER WORDS
         BEZ      HGPZXIT           NONE
HGPZ30   CI,R3    14
         BG       %+3               MORE THAN 14 - DO 14 THIS TIME
         SCS,R3   -4                LESS THAN 14 - PUT # IN CC SPOT
         XW,R3    TEMP+2            PUT IT AWAY, MAKE R3 NEGATIVE
         LC       TEMP+2            SET CC TO # WORDS TO ZERO
         STM,R4   0,R2
         AI,R2    14
         AI,R3    -14
         BGZ      HGPZ30            MORE TO DO
*
HGPZXIT  LW,R7    *TEMP             ADDRESS OF NEXT HGP
         BNEZ     HGPZ02            MORE TO DO
         B        *TEMP+1           DONE - EXIT
         TITLE    '****  HGPINVERT  ****'
         SPACE    2
*
*  PURPOSE:  INVERT BITS IN HGPS AND CHANGE LINKS
*
*  INPUT:  R6 = NEW ADDRESS OF FIRST HGP
*           R7 = ADDRESS OF FIRST HGP
*
*  CALL:  BAL,R11 HGPINVERT
*
*  OUTPUT:  EXITS SKIPPING IF NO ERRORS
*
         SPACE    1
HGPINVERT EQU     %
         LCW,R15  R7
         AW,R15   R6                BIAS TO ADD TO LINKS
         PUSH     R11
*
HGPI10   LI,R14   0
         LW,R8    3,R7              LAST PER SECTOR + 1
         SW,R8    2,R7              R8 = # PER SECTORS
         BLEZ     HGPI30            NONE
         SLS,R8   -1                # GRANULES
         INT,R5   5,R7              DISPL TO PER BIT MAP
HGPI15   SLD,R8   -5                R8 = # FULL WORDS IN BIT MAP
         SLS,R9   -27               R9 = # BITS IN PARTIAL WORD
         AW,R5    R7                ADDRESS OF START OF BIT MAP
HGPI20   LW,R10   0,R5              GET NEXT BIT MAP WORD
         EOR,R10  M32               INVERT THE BITS
         STW,R10  0,R5
         AI,R5    1
         BDR,R8   HGPI20            DO ALL FULL WORDS
         AI,R9    0
         BEZ      HGPI30            NO PARTIAL WORD
         LW,R10   Y8                BUILD MASK - BITS SET WHERE LEGAL
         B        %+2
         SAS,R10  -1
         BDR,R9   %-1
         LW,R9    0,R5              PICK UP PARTIAL WORD
         EOR,R9   M32               FLIP THE BITS
         AND,R9   R10               AND OFF ILLEGAL BITS
         STW,R9   0,R5
*
HGPI30   BDR,R14  HGPI40            BR IF DONE
         LW,R9    4,R7              END OF PFA
         SW,R9    3,R7              R9 = # PFA SECTORS
         BLEZ     HGPI20            NO PFA
         SLS,R9   -1                GRANULES
         LW,R2    1,R7
         CI,R2    ATCYLBIT
         AND,R2   M8                # GRANULES / CYL
         BAZ      %+2
         DW,R9    R2                CYLINDER - CONVERT # GRAN TO # CYLS
         LW,R8    R9
         INT,R5   6,R7              DISPL TO BIT MAP
         LI,R14   20                FLAG TO STOP AFTER THIS ONE
         B        HGPI15
*
*
*  CHANGE HGP HEADER TO STANDARD FORMAT
*
HGPI40   LW,R10   5,R7
         LW,R11   6,R7
         SLD,R10  -16
         STH,R10  R11               R11 = # PER WORDS, # PFA WORDS
         LW,R12   2,R7              PER FIRST SECTOR
         LW,R9    5,R7
         STH,R9   R12               PER DISPL
         LW,R13   3,R7              PFA FIRST SECTOR
         LW,R9    6,R7
         STH,R9   R13               PFA DISPL
         LI,R9    ATPRIVBIT
         BAZ      HGPI50            BR IF PUBLIC
         LW,R12   5,R7              RESTORE NVAT FOR PRIVATE
         AND,R11  M16               ZAP # PER WORDS
HGPI50   LW,R8    1,R7
         LI,R2    HGP
HGPI55   CW,R8    1,R2              SEARCH FOR THIS HGP HEADER
         BE       HGPI58              TO FIND NST AND NSG
         LW,R2    0,R2              LINK TO NEXT
         BNEZ     HGPI55
         PULL     R11               ERROR - CAN'T FIND HGP
         B        *R11
*
HGPI58   LCI      2
         LM,R9    2,R2              PICK UP TWO WORDS FROM HGP HEADER
         LCI      5
         STM,R9   2,R7              SET UP HEADER
         LW,R2    0,R7              GET LINK
         BEZ      HGPI60            DONE
         AWM,R15  0,R7              CHANGE LINK
         LW,R7    R2
         B        HGPI10
*
HGPI60   PULL     R11
         AI,R11   1
         B        *R11              NORMAL EXIT
         TITLE    '****  BREAK INTERRUPT HANDLER  ****'
         TITLE    '****  ACNCALC  ****'
         SPACE    2
*
*  PURPOSE:  CALCULATE DISC ADDRESSES OF ACCOUNT DIRECTORY MAIN
*            AND DUAL GRANULES.
*
*  CALL:  BAL,R11  ACNCALC
*
*  OUTPUT:  R8 = DISC ADDR OF MAIN GRANULE
*           R9 = DISC ADDR OF DUAL GRANULE
*           RETURN SKIPPING IF ALL OK
*
*  TEMP+0 = FIRST RAD HGP
*  TEMP+1 = FIRST GRANULE PACK
*  TEMP+2 = FIRST CYLINDER PACK
*  TEMP+3 = LAST RAD
*  TEMP+4 = LAST GRANULE PACK
*  TEMP+5 = LAST CYLINDER PACK
*
         SPACE    1
ACNCALC  EQU      %
         LI,R1    0
         LCI      6
         LM,R2    R1                ZAP TEMP STORAGE
         STM,R2   TEMP
         LW,R7    HGP1
         BEZ      *R11              ERROR - NO HGPS
         LI,R2    6                 BYTE INDEX TO DEVICE TYPE
         LI,R1    5                 BYTE INDEX TO DCTX
ACNC10   LW,R8    5,R7              BYTE INDEX TO DCTX
         CW,R8    YFFFF
         BAZ      ACNC30            NO PFA - SKIP THIS DEVICE
         LB,R3    *R7,R1            DCT INDEX
         LB,R8    DCT24,R3          DCT INDEX
         CI,R8    X'82'
         BANZ     ACNC30            PARTITIONED - DON'T ALLOCATE HERE
         LB,R8    *R7,R2            DEVICE TYOE
         LI,R3    1                 ASSUME GRANULE PACK
         CI,R8    X'0B'
         BE       ACNC20            YES
         LI,R3    0                 ASSUME RAD
         CI,R8    X'07'
         BE       ACNC20            YES
         LI,R3    2                 MUST BE CYLINDER PACK
ACNC20   STW,R7   TEMP+3,R3         SAVE LAST HGP OF THIS TYPE
         LW,R8    TEMP,R3
         BNEZ     %+2               BR IF NOT FIRST
         STW,R7   TEMP,R3           SAVE FIRST HGP OF THIS TYPE
ACNC30   LW,R7    0,R7
         BNEZ     ACNC10
*
*  CALCULATE MAIN DISC ADDRESS
*
         LI,R3    -3                LOOK IN THIS ORDER:
         LW,R7    TEMP+3,R3           RAD, GRANULE PACK, CYLINDER PACK
         BNEZ     ACNC40            FOUND ONE
         BIR,R3   %-2
         B        *R11              CAN'T FIND ANY DEVICES
ACNC40   LW,R3    3,R7              FIRST PFA SECTOR ADDRESS
         LW,R8    1,R7              DCT INDEX IN BYTE 1
         STB,R8   R8                # GRAN/CYL IN BYTE 0
         STSECTA,R3  R8             PUT IN REL SECTOR
*
*  CALCULATE DUAL DISC ADDRESS
*
         LW,R7    TEMP+4            GRANULE PACK
         BNEZ     ACNC50
         LW,R7    TEMP+3            RAD
         BNEZ     ACNC50
         LW,R7    TEMP+5            CYLINDER PACK
         BEZ      *R11              NONE FOUND - ERROR
ACNC50   LW,R3    4,R7
         AI,R3    -2                LAST SECTOR ON DEVICE
         LI,R9    X'FF'
         AND,R9   1,R7              # GRAN PER CYL
         DW,R3    R9                ROUND DOWN TO FIRST GRAN
         MW,R3    R9                  IN LAST CYLINDER
         LW,R9    1,R7              DCT INDEX IN BYTE 1
         STB,R9   R9                # GRAN/CYL IN BYTE 0
         STSECTA,R3  R9
         AI,R11   1                 NORMAL EXIT
         B        *R11
         TITLE    '****  INTERRUPT HANDLER  ****'
         SPACE    2
*
*    BREAK INTERRUPT HANDLER
*
*
*        HANDLES INTERRUPTS FROM:
*
*          1 - I/O END-ACTION
*          2 - OPERATOR/USER
*          3 - FILE MANAGEMENT (GHOST ONLY)
*
*
         SPACE    2
INTADR   EQU      %
         M:SYS,E  M:SYSFPT
         DISABLE                    **** DISABLE
*
INTADR2  PSW,R1   *J:TCB            SAVE ADDRESS OF PSD
*
         MTW,1    INTR1             COUNT # INTERRUPTS
         LW,R8    INTBUSY           IF ALREADY PROCESSING HERE,
         BNEZ     PULLE               EXIT IMMEDIATELY
         MTW,1    INTBUSY           SET BUSY FLAG
         LI,R8    0
         STW,R8   INTP              # ITEMS PROCESSED
         LI,R8    1
         STW,R8   INTR1             COUNT THIS INTERRUPT
*
INTADR10 ENABLE                     **** ENABLE
         LI,R8    0
         STW,R8   INTP1             # ITEMS PROCESSED THIS PASS
         LW,R8    S:CUN
         CW,R8    LFGUN             DON'T CHECK 75BUF UNLESS WE
         BNE      INTIO               ARE THE RIGHT LFG
         SPACE    2
*
*  MOVE ANY USER NUMBERS FROM 75BUF TO INTERNAL LIST (GHOST ONLY)
*
INT75    DISABLE                    **** DISABLE
         LW,R4    75BUF
         BEZ      INTIO             NO USERS
         LW,R2    SAVBUF
         SCS,R2   8
         CI,R2    X'FF'
         BANZ     INTIO             NO ROOM IN INTERNAL LIST
         LI,R5    -4
         LI,R9    0
INT75A   LB,R8    R4+1,R5           GET NEXT BYTE
         BNEZ     INT75B            GOT ONE
         BIR,R5   INT75A
*
INT75B   STB,R9   R4+1,R5           ZERO THE BYTE
         OR,R2    R8                PUT IN IN SAVBUF
         STW,R2   SAVBUF
         STW,R4   75BUF
         ENABLE                     **** ENABLE
         MTW,1    INTP              COUNT 1 ITEM PROCESSED
         MTW,1    INTP1
         B        INT75
         SPACE    3
*
*  PROCESS I/O END-ACTION
*
INTIO    DISABLE                    ****  DISABLE
         LW,R5    MPOOLADR          ADDRESS OF END-ACTION ROUTINE
         BEZ      INTEND            THERE ISN'T ONE
         PLW,R4   *EASPD            GET NEXT END-ACTION TASK
         BSU      INTEND            STACK EMPTY
*
         ENABLE                     **** ENABLE
         MTW,-1   #IO               DECT # I/O'S OUTSTANDING
         MTW,1    INTP              INCR COUNT OF # PROCESSED
         MTW,1    INTP1
         LH,R7    R4
         AND,R7   M8                R7 = BUF TABLE INDEX
         CI,R7    X'F0'
         BGE      INTIO5            IGNORE BAD TYC IF SPECIAL
         LW,R9    BUFDA,R7
         AND,R9   FLR:IOP           RESET I/O IN PROGRESS
         STW,R9   BUFDA,R7
         LB,R9    R4                TYC
         CI,R9    1
         BNE      EAIOERR           ERROR - RETRY THE I/O
INTIO5   BAL,R11  EA                PERFORM END-ACTION
         SPACE    3
*
*
INTEND   LW,R8    INTP1             WAS ANYTHING DONE ON THIS PASS
         BNEZ     INTADR10          YES - LOOK FOR MORE
*
         DISABLE                    **** DISABLE
         LI,R8    0
         STW,R8   INTBUSY           CLEAR RE-ENTRANCE FLAG
         XW,R8    INTR1
         AWM,R8   INTR              INCREMENT TOTAL # INTERRUPTS
         CW,R8    INTP              COMPARE # INTERRUPTS RECEIVED WITH
         BLE      PULLE               # OPERATIONS PERFORMED
         LW,R8    BOOTFLG           OPERATOR MUST WANT TO TALK
         BEZ      INTEND8           NOT HGP RECON - JUST SET FLAG
         LW,R8    OCREQ
         BNEZ     PULLE             SEQUENCE IN PROGRESS - IGNORE
         BAL,R11  OCMESS1           INITIATE KEYIN SEQUENCE
         DISABLE                    **** DISABLE
INTEND8  MTW,1    OCREQ             OPERATOR COMMUNICATION IN PROGRESS
         SPACE    3
*
*  PULL ENVIRONMENT FROM TCB STACK AND EXIT
*
PULLE    PLW,R1   *J:TCB            ADDRESS OF PSD
         STW,R1   PULLEPSD
         AI,R1    2
         STW,R1   PULLEREG          ADDRESS OF REGISTERS
         LI,R2    -19               REMOVE TRAP CODE, PSD, REGISTERS
         MSP,R2   *J:TCB
         PLW,R2   *J:TCB            FLAG WORD
         AI,R2    0
         BGEZ     %+2               NO SPARE WORD
         PLW,R2   *J:TCB            PULL PAD WORD
         LCI      0
         LM,R0    *PULLEREG         RESTORE REGISTERS
         LPSD,0   *PULLEPSD         LOAD PSD
         SPACE    2
EARETRY  PULL     R10               LINK REGISTER FOR IORETRY
         B        IORETRY           RETRY THE I/O
         SPACE    2
EAIOERR  LI,R9    ERR#99            HARDWARE I/O ERROR
         STW,R9   BUFINFO,R7
         BAL,R10  IORETRY           RETRY THE I/O
         B        INTEND
         SPACE    2
*
*  MAPPED END-ACTION
*
EA       EQU      %
         PUSH     R11
         CI,R7    X'F0'
         BGE      EABR-X'F0',R7     GO TO SPECIAL ROUTINE
         LW,R2    BUFDA,R7
         AND,R2   FLR:EA            RESET END-ACTION NEEDED FLAG
         STW,R2   BUFDA,R7
         LB,R2    BUFTYPE,R7        END-ACTION TYPE
         DO       DEBUG=1
         CI,R2    4
         BG       EAERR
         FIN
         B        %+1,R2
         B        EAXIT             0
         B        EATYP1            1
         B        EATYP2            2
         B        EATYP3            3
         B        EATYP4            4
*
EAXIT    ENABLE                     ****  ENABLE
         PULL     R11
         B        *R11
         SPACE    1
*
*  SPECIAL END-ACTION PROCESSING
*
EABR     EQU      %
XLPIO    EABR     LPEA              LINE PRINTER
XOCRD    EABR     OCRD              READ FROM OPERATOR'S CONSOLE
XOCWRT   EABR     EAXIT             WRITE TO OPERATOR'S CONSOLE
         SPACE    1
*
*  KEYED FILE END-ACTION
*
EATYP1   EQU      %
         DO       0
         LW,R6    BUFADR,R7         BUFFER ADDRESS
         BAL,R10  VALBUF            VALIDATE BUFFER JUST READ
         STW,R15  BUFINFO,R7        SAVE ERROR CODE
         BNEZ     EARETRY           ERROR - RETRY THE READ
         LW,R8    FLINK,R6          FLINK OF GRANULE JUST READ
         AND,R8   M24
         BEZ      EAXIT             DONE - NO FLINK
         LW,R3    M24
         LW,R2    BUFDA,R7          DA OF GRAN JUST READ
         LI,R3    0
         DISABLE                    **** DISABLE
EA1LOOK  CS,R2    GL,R3             SEARCH GL
         BE       EA1AA             FOUND IT
         AI,R3    1
         CW,R3    GLSIZE
         BLE      EA1LOOK           NOT DONE YET
         FIN
EAERR    M:SNAP   'EA ERR',(D1,D1END)
         M:XXX
         DO       0
*
EA1AA    LW,R2    R8                FLINK DA
         CW,R3    GLSIZE
         BGE      EA1ENTER          AT END
         LW,R6    R7                MOVE BUFFER INDEX FOR EASET
         CS,R2    GL,R3             IS FLINK NEXT DA IN GL
         BE       EA1BLINK          YES
* ENTER FLINK DA INTO GL
EA1ENTER LW,R15   GLSIZE
         CI,R15   #GL               IS THERE ROOM
         BGE      EASET             NO
         SW,R15   R3                # WORDS TO MOVE
         LW,R4    GLSIZE
EA1SLD   LW,R14   GL-1,R4           SLIDE TABLE UP
         STW,R14  GL,R4
         AI,R4    -1
         BDR,R15  EA1SLD
         MTW,1    GLSIZE            INCR # USED ENTRIES
         STW,R8   GL,R3             PUT IN THE DA
*
EA1BLINK EQU      %
         LW,R8    BLINK,R6          BLINK OF GRAN JUST READ
         AND,R8   M24
         CW,R8    GL-2,R3           IS IT PREV GL ENTRY
         BNE      EAXIT             NO - GET OUT
*
*  SEARCH FOR NEXT ENTRY IN GL THAT HAS NOT BEEN READ AND
*    QUEUE AN I/O
*
EA1SRCH  EQU      %
         AI,R3    1
         CW,R3    GLSIZE
         BG       EASET             NO MORE GL ENTRIES
         LW,R8    GL-1,R3           CHECK NEXT
         BLZ      EA1SRCH           HAS ALREADY BEEN READ
         LW,R6    R7                MOVE BUFFER INDEX FOR EASET
         LI,R2    1                 EA TYPE
         BAL,R15  GETBUF            GET A BUF TABLE ENTRY
         BEZ      EASET             NONE AVAILABLE
         LW,R9    Y8
         STS,R9   GL-1,R3           SET 'READ INITIATED' FLAG
         ENABLE                     ****  ENABLE
         STW,R8   BUFDA,R7          DISC ADDRESS
         BAL,R11  DISCRD
         B        EAXIT
         FIN
*
EASET    LW,R9    FL:EA             SET FLAG TO INDICATE THAT
         STS,R9   BUFDA,R6            END-ACTION MUST BE RE-DONE
         B        EAXIT
         SPACE    2
*
*  TYPE 2 - READ BACKWARDS
*  TYPE 3 - READ FORWARD
*
EATYP2   EQU      %
EATYP3   EQU      %
         LW,R6    BUFADR,R7         BUFFER ADDRESS
         BAL,R10  VALBUF            VALIDATE BUFFER
         STW,R15  BUFINFO,R7        SAVE ERROR CODE
         BNEZ     EARETRY           THERE WAS AN ERROR - RETRY
         LI,R4    1
         AND,R4   R2
         LW,R8    *R4,R6            BLINK OR FLINK
         AND,R8   M24
         BEZ      EAXIT
         LW,R6    R7                SAVE BUF TABLE INDEX
         BAL,R15  GETBUF            GET A BUF TABLE ENTRY
         BEZ      EASET             NONE AVAILABLE
         DO       DEBUG=1
         LB,R14   BUFLINK,R6
         BNEZ     EAERR
         FIN
         STB,R7   BUFLINK,R6        POINT PREVIOUS TO THIS ONE
         STW,R8   BUFDA,R7          DISC ADRESS TO READ
         LW,R8    BUFDA,R6          PREVIOUS DISC ADDRESS
         EOR,R4   X1
         STB,R4   R8                SAVE LINK CHECK TYPE
         STW,R8   BUFDACHK,R7         IS LINK CHECK FOR THIS READ
         BAL,R11  DISCRD            QUEUE THE I/O
         B        EAXIT
         SPACE    2
*
*  TYPE 4 - RELEASE BUFFER
*
EATYP4   EQU      %
         PULL     R15               LINK REGISTER
         B        RELBUF            RELEASE THE BUFFER
         SPACE    3
*
*  END-ACTION FOR LINE PRINTER (PUBLIC HGP RECON ONLY)
*
LPEA     EQU      %
         LW,R2    LPCUR
         AI,R2    1                 INCREMENT POINTER TO NEXT
         AND,R2   M2                  BUFFER TO BE WRITTEN
         STW,R2   LPCUR
         MTW,-1   LPCNT             DECR # BUFFERS WAITING
         BEZ      EAXIT             NO MORE
         LI,R11   EAXIT             RETURN FROM LPIO
*
LPIO     EQU      %                 START I/O ON CURRENT BUFFER
         LW,R12   LPDCTX
         BLEZ     *R11              NO I/O TO BE DONE
         LW,R13   LPCUR
         SLS,R13  7
         AW,R13   LPBUF             WORD ADDRESS OF BUFFER
         LB,R14   *R13              BYTE COUNT
         SLS,R13  2
         AI,R13   1                 BYPASS TEXTC COUNT
         LI,R2    3                 FCN = WRITE WITH FORMAT
         LI,R7    XLPIO             SPECIAL BUFFER INDEX
         B        IOQUEUE           QUEUE THE I/O
         SPACE    3
*
*  END-ACTION FOR READ FROM OPERATOR'S CONSOLE
*
OCRD     EQU      %
         AND,R4   M16               REMAINING BYTE COUNT
         LCW,R4   R4
         AI,R4    OCRDCNT           R4 = # BYTES READ
         BAL,R11  READEND           PERFORM CLEANUP
         MTW,-1   OCIOCNT           DECR # I/O'S TO OC
         LW,R11   OCFLG
         BLZ      EAXIT             NOTHING ELSE TO DO
*  SPECIAL SEQUENCE IN PROGRESS
         BGZ      OCHK50            CHECK RESPONSE FROM 2ND MESSAGE
*  THIS IS RESPONSE FROM LP ADDRESS CHANGE
         LW,R11   INCNT             # BYTES READ
         BEZ      OCHK30            NONE - DON'T CHANGE ADDRESS
         CI,R11   2
         BNE      OCHK10
         BAL,R11  GETFIELD          2 CHARS - MUST BE 'SA'
         BCS,4    OCERR             ERROR - NO FIELD
         LH,R11   FBUF              GET THE CHARS
         CI,R11   X'F0000'+'SA'
         BE       OCHK30            'SA' - DON'T CHANGE ADDRESS
         B        OCERR             ERROR
*
* THREE CHARS - MUST BE 'NDD' ADDRESS
*
OCHK10   CI,R11   3
         BNE      OCERR             TOO MANY CHARS
         BAL,R11  GETFIELD          GET THEM
         BCS,4    OCERR             ERROR - NO FIELD
         CI,R7    3                 MUST GET THREE CHARS
         BNE      OCERR
         LB,R7    FBUF              GET CHANNEL NUMBER
         BIF,X560 OCHK14            BR IF TAURUS
         AI,R7    -'A'              SIGMA - CHANGE TO IOP #
         BLZ      OCERR             TOO SMALL
         CI,R7    7
         BG       OCERR             TOO BIG
OCHK12   SLS,R7   8                 JUSTIFY CHANNEL #
         STW,R7   TEMP              SAVE IT
         LW,R12   FBUF
         SLS,R12  8                 LEFT JUSTIFY 'DD'
         BAL,R15  HEX2BIN           CONVERT TO BINARY
         OR,R4    TEMP              ADD IN CHANNEL
         LI,R5    DCTSIZ
         CH,R4    DCT1,R5           SEARCH FOR IT IN DCT TABLES
         BE       OCHK20            OK
         BDR,R5   %-2
         B        OCERR             NOT IN DCT TABLES
*
*  PERFORM MNEMONIC TO CLUSTER/UNIT CONVERSION FOR TAURUS
*
OCHK14   LI,R4    #CLUS
OCHK15   CB,R7    CLUSTER,R4        SEARCH CLUSTER TABLE
         BE       OCHK12            FOUND IT
         AI,R4    -1
         BGEZ     OCHK15
         B        OCERR             ILLEGAL MNEMONIC
*
OCHK20   STW,R5   LPDCTX            SAVE NEW DCT INDEX
         MTW,1    OCFLG             SET TO PROCESS SECOND MESSAGE
OCHK30   LI,R4    BA(MOC2)          PROMPT FOR SECOND MESSAGE
         BAL,R11  KEYIN
         B        EAXIT
*
*  A RESPONSE HAS BEEN MADE TO CHANGE MODE QUESTION
*
OCHK50   LW,R4    INCNT
         BEZ      OCHK70            NOTHING READ - DON'T CHANGE
         LI,R4    1
         LB,R4    INCNT,R4          GET FIRST CHAR
         LI,R5    0
         CI,R4    'E'
         BE       OCHK54            PRINT ERRORS ONLY
         LI,R5    -1
         CI,R4    'N'
         BE       OCHK54            PRINT NOTHING
         LI,R5    1
         CI,R4    'A'
         BNE      OCERR             ILLEGAL CHAR
OCHK54   STW,R5   LPFLAG
OCHK70   LI,R4    -1
         STW,R4   OCFLG             SEQUENCE TERMINATED
         LI,R4    0
         STW,R4   OCREQ             ALLOW ANOTHER TO BE STARTED
         B        EAXIT
*
*  ERROR ENCOUNTERED - SAY 'EH' AND PROMPT AGAIN
*
OCERR    BAL,R10  DATERR            PRINT 'EH'
         LW,R11   OCFLG
         BGZ      OCHK30            REPEAT LAST MESSAGE
         BAL,R11  OCMESS1           REPEAT FIRST MESSAGE
         B        EAXIT
*
*  PROMPT FOR LINE PRINTER ADDRESS CHANGE
*
OCMESS1  LI,R2    X'FF'
         AND,R2   LPDCTX            'DD' PORTION OF CURRENT ADDRESS
         BAL,R15  BIN2HEX           CONVERT TO EBCDIC
         SLS,R12  -8
         CI,R5    1
         BNE      %+3               BR IF NO LEADING ZERO
         SLS,R12  -8                PUT IN LEADING ZERO
         OR,R12   Y00F
         LI,R7    X'3F00'
         AND,R7   LPDCTX
         SLS,R7   -8                RIGHT JUSTIFY IOP ADDRESS
         BIF,X560 OCMESS5           BR IF TAURUS
         AI,R7    'A'               SIGMA - CONVERT IOP # TO MNEMONIC
OCMESS2  STB,R7   R12               PUT IN CHANNEL MNEMONIC
         STW,R12  MOC1+6            SAVE ADDRESS IN MESSAGE
         LI,R12   0
         STW,R12  OCFLG             SET TO RESPOND TO SEC MESSAGE
         LI,R4    BA(MOC1)
         B        KEYIN             INITIATE KEYIN SEQUENCE
*
*  CONVERT TAURUS UNIT/CLUSTER TO MNEMONIC
*
OCMESS5  LB,R7    CLUSTER,R7
         B        OCMESS2
         TITLE    '****  EXIT CONTROL ROUTINE  ****'
         SPACE    2
*
*  EXIT CONTROL
*
XCONADR  M:INT    INTADR            RE-ESTABLISH INTERRUPT CONTROL
         PUSH     3,R8
         M:SYS,E  M:SYSFPT          MASTER MODE
         M:XCON   0                 TURN OFF EXIT CONTROL
         PULL     3,R8
         CI,R8    X'FF'
         BAZ      EXIT              M:EXIT - RE-ISSUE THE CAL
*
         CI,R8    X'38'             OPERATOR ABORT, ERROR,
         BANZ     XCONABRT            LINE DISCONNECT
         CI,R8    X'C0'
         BANZ     CLEANUP           M:ERR OR M:XXX
*
*  TRAP OR LIMIT EXCEEDED
*
         SLS,R11  17                MOVE SUB-CODE
         OR,R12   R11               MERGE MAJOR AND SUB CODES
         STW,R12  ABRTCODE
         CW,R12   =X'A5080000'      ONLINE CONTROL-Y
         BE       CLEANUP           YES - DON'T SNAP
         M:SNAP   'XCON',(D1,D1END)
         LW,R0    J:TCB
         LW,R4    J:TCB
         AI,R4    299
         M:SNAP   'TCB',(*R0,*R4)
         B        CLEANUP           RELEASE USERS, ETC
*
XCONABRT EQU      %                 ABORT IMMEDIATELY
         LW,R14   BOOTFLG
         BNEZ     NORECON           MUST BE DOING PUBLIC RECON
         MTW,0    IDLEFLAG
         BNEZ     EXIT2             IDLE - DON'T PRINT ERROR MESSAGE
         LW,R10   ABRTCODE
         BEZ      %+2               NOT TRAP
         M:MERC                     GIVE USER THE TRAP MESSAGE
         LI,R14   MABRT             'FIX ABORTING'
         B        MESSOUT
*
*  ATTEMPT TO CLEAN UP
*
CLEANUP  EQU      %
         BAL,R11  REL               RELEASE OCU, MPOOL, BUFFERS
*        BAL,R11  RELUSERS          RELEASE FREPORT USERS
         B        XCONABRT
         TITLE    '****  GHOST INITIALIZATION  ****'
         SPACE    2
GHSTINIT EQU      %
         LW,R5    BOOTFLG
         BNEZ     SYSINIT           SYSTEM NOT UP YET - DO INITIALIZATION
         LW,R4    S:CUN
         LW,R5    LFGUN
         BNEZ     %+3
         STW,R4   LFGUN
         STW,R5   75BUF
*
         LI,R4    BA(MKEY1)
         BAL,R10  MOVTXTC           BUILD PROMPT MESSAGE FOR
         LW,R2    S:CUN               KEYIN SEQUENCE
         BAL,R10  MOVHEX
         LI,R4    BA(MKEY2)
         BAL,R10  MOVTXTC
         LW,R10   PRPOS
         AI,R10   -BA(PRBUF)-1      # CHARS IN MESSAGE
         STB,R10  PRBUF             PUT IN TEXTC COUNT
         LCI      3
         LM,R10   PRBUF
         STM,R10  MKEYIN            MOVE MESSAGE
         BAL,R15  INITBUF           INITIALIZE PRBUF POINTERS
         B        GHSTIDLE
         TITLE    '****  PGDISC  ****'
         SPACE    2
*
*  PURPOSE:  BUILD TABLE TO CONVERT USER'S VIRTUAL ADDRESSES
*            TO SWAPPER DISC ADDRESSES.
*
*  INPUT:  R0 = ADDRESS OF DW PAIR OF VIRTUAL PAGE LIMITS
*          R7 = USER #
*
*  CALL:  BAL,R11 PGDISC
*
*  OUTPUT:  R3 = # PAGES FOUND
*           THE TABLES PAGE (BYTE TABLE OF VIRTUAL PAG NUMBERS) AND
*           DISC (WORD TABLE OF DISC ADDRESSES) ARE SET UP.  INDEX
*           0 INTO PAGE CONTAINS # USEFUL ENTRIES.
*
         SPACE    1
PGDISC   LI,R3    0
         LW,R2    UBSWAPI
         AI,R7    0
         BLZ      %+2               BR IF SPECIAL - USE INTERNAL TABLE
         LB,R2    UB:SWAPI,R7       SWAPPER TABLE INDEX
         LB,R6    JVLH+JITBUF       LMAP HEAD
         LI,R4    0
         LW,R5    JCLE+JITBUF
         AI,R5    -4
         DW,R4    =10
         LW,R1    R5
         SLS,R1   3
         AW,R1    R4
         AI,R1    4
         B        %+2
NEXTDA   LI,R4    6
         LW,R13   R4                SAVE # TIMES TO DO LOOP
         SLS,R4   -1
         LH,R14   JDA+JITBUF,R5     GET NEXT DISC ADDRESS
         LB,R15   MB:GAM6,R2
NXTDA0   AI,R14   2
         CS,R14   M:GASLIM,R2
         BLE      NXTDA1
         AW,R14   M:ADRINCR,R2
         MTB,0    MB:GAM7,R2
         BEZ      NXTDA1
         AI,R14   1
NXTDA1   BDR,R4   NXTDA0
NEXTPGE  CLM,R6   *R0               IS THIS PAGE DESIRED
         BCS,9    NXTPG1            NO
         AI,R3    1                 YES - INCR POINTER INTO TABLES
         STB,R6   PAGE,R3           PUT AWAY VIRTUAL PAGE #
         STW,R14  DISC,R3           AND DISC ADDRESS
         MTW,0    S:DP
         BEZ      %+2               RAD SWAPPER
         STW,R1   DISC,R3           PACK SWAPPER - SAVE SECTOR INDEX
         CI,R3    27
         BGE      NXTPG2            TOO MANY ENTRIES IN TABLE - STOP
*
NXTPG1   AI,R14   -2
         CS,R14   M:GASLIM,R2
         BL       NXTPG1A
         SW,R14   M:ADRINCR,R2
         MTB,0    MB:GAM7,R2
         BEZ      %+2
         AI,R14   -1
NXTPG1A  AI,R1    -2
         LB,R6    JLMAP+JITBUF,R6     GET NEXT PAGE FROM LMAP
         BEZ      NXTPG2            NO MORE
         AI,R13   -2
         BGEZ     NEXTPGE           STILL MORE GRANULES IN GROUP
         AI,R5    -1
         BGEZ     NEXTDA            GET NEXT GRANULE GROUP
*
NXTPG2   STB,R3   PAGE              SAVE # USED ENTRIES
         AI,R3    0
         BEZ      *R11              EXIT IF NOTHING FOUND
         PUSH     R11               CONVERT ENTRIES IN DISC TO
         LW,R8    S:DP                RELATIVE SECTOR/DCT INDEX FORMAT
         BNEZ     NXTPG5            BR IF PACK SWAPPER
*  RAD SWAPPER - ENTRIES IN DISC ARE PHYSICAL SEEK ADDRESSES
NXTPG3   LW,R8    DISC,R3
         BAL,R11  SEEKCONV          CONVERT IT
         STW,R8   DISC,R3
         BDR,R3   NXTPG3
NXTPG4   PULL     R11
         LB,R3    PAGE
         B        *R11
*
*  PACK SWAPPER - DISC CONTAINS SECTOR INDEX INTO USER'S CYLINDER
NXTPG5   LW,R8    UBC#
         AI,R7    0
         BLZ      %+2               IF SPECIAL, USE INTERNAL TABLE
         LB,R8    UB:C#,R7          CYL # FOR THIS USER
         SLS,R8   16                FORM PHYSICAL SEEK ADDRESS
         BAL,R11  SEEKCONV          CONVERT TO RELATIVE SECTOR
         LDCTX,R1 R8                DCT INDEX
NXTPG6   LW,R8    R9                REFRESH RELATIVE SECTOR OF CYL
         AW,R8    DISC,R3           ADD SECTOR DISPLACEMENT
         CI,R8    X'10000'          SPLIT SECTOR FIELD IF NECESSARY
         BAZ      %+2
         OR,R8    Y008
         CI,R8    X'20000'
         BAZ      %+2
         OR,R8    Y004
         STDCTX,R1  R8              ADD DCT INDEX
         STW,R8   DISC,R3
         BDR,R3   NXTPG6
         B        NXTPG4
         TITLE    '****  RDJIT  ****'
         SPACE    2
*
*  PURPOSE:  READ A JIT AND AJIT AND VERIFY THE JIT
*
*  INPUT:  R7 = USER #
*          R8 = JIT DISC ADDRESS (SEEK ADDRESS)
*          R9 = AJIT DISC ADDRESS (ZERO IF NO AJIT)
*
*  CALL:  BAL,R11  RDJIT
*
*  OUTPUT:  R15 = 0  OK
*               = 1  I/O ERROR
*               = 2  BAD DISC ADDRESS
*               = 3  BAD JIT
*
         SPACE    1
RDJIT    PUSH     R11
         LW,R1    R9                SAVE AJIT DISC ADDRESS
         BAL,R11  SEEKCONV          CONVERT JIT DA TO DCT/REL SECT
         LI,R2    512               # WORDS TO READ
         LI,R7    JITBUF            ADDRESS TO READ INTO
         BAL,R11  DRDWAIT           READ IT
         BNEZ     RDJXIT            ERROR
         LW,R8    R1                RESTORE AJIT DISC ADDRESS
         BEZ      RDJ10             NO AJIT
         BAL,R11  SEEKCONV
         LI,R7    AJITBUF
         BAL,R11  DRDWAIT
         BNEZ     RDJXIT            ERROR
*
RDJ10    LI,R15   3                 ASSUME JIT BAD
         LW,R4    UTSTACK           TOP OF STACK POINTER
         LI,R5    1
         LH,R5    UTSTACK+1,R5      GET # WORDS USED
         BLZ      RDJXIT            ERROR
         SW,R4    R5                TOP MINUS # WORDS USED MUST
         CI,R4    TSTACK+1            BE THE EMPTY TOP OF STACK
         BNE      RDJXIT
         LH,R4    UTSTACK+1         # WORDS REMAINING
         BLZ      RDJXIT            CAN'T BE NEGATIVE
         LI,R15   0                 EVERYTHING OK
RDJXIT   PULL     R11
         AI,R15   0
         B        *R11
         TITLE    '****  RDPAGES  ****'
         SPACE    2
*
*  PURPOSE:  READ USER PAGES GIVEN A JIT AND VIRTUAL PAGE LIMITS
*
*  INPUT:  PAGE AND DISC TABLES SET UP BY PGDISC
*
*  CALL:  BAL,R11 RDPAGES
*
*  OUTPUT:  R4 = FIRST USER VIRTUAL WORD ADDRESS
*           R5 = FIRST BUFFER ADDRESS
*           R15 = 0  NO ERRORS
*               = 1  I/O ERROR
*               = 2  BAD DISC ADDRESS
*               = 3  CAN'T GET ENOUGH PAGES
*
         SPACE    1
RDPAGES  PUSH     R11
         LI,R15   0                 ASSUME NO ERRORS
         LB,R3    PAGE              # PAGES TO READ
         BEZ      RDPXIT            NONE
         M:GP     *R3               GET THE PAGES
         CW,R8    R3
         BNE      RDPXIT1           DIDN'T GET ALL OF THEM
         LW,R5    R9                SAVE FIRST BUFFER ADDRESS
*
RDP10    LI,R2    512               # WORDS TO READ
         LW,R7    R9                BUFFER ADDRESS
         LW,R8    DISC,R3           DISC ADDRESS
         BAL,R11  DRDWAIT           READ THE PAGE
         BNEZ     RDPXIT            ERROR
         AI,R9    512
         BDR,R3   RDP10
*
         LB,R3    PAGE
         LB,R4    PAGE,R3           FIRST VIRTUAL PAGE
         SLS,R4   9
RDPXIT   PULL     R11
         AI,R15   0
         B        *R11
*
RDPXIT1  M:FP     *R8               GIVE BACK ANY GOTTEN
         LI,R15   3
         B        RDPXIT
         TITLE    '****  SYSTEM INITIALIZATION  ****'
         SPACE    2
*
*  SYSTEM INITIALIZATION
*
*        INITIALIZE CFU AREA
*        READ AND PROCESS RECOVERY BUFFER
*        IF TAPE BOOT, INITIALIZE ALLYCAT DATA AND ACCOUNT DIRECTORY
*        WRITE RBBAT RECOVERY FILE
*
         SPACE    2
SYSINIT  EQU      %
         SPACE    2
*
*  OPEN M:LO AND M:DO TO LINE PRINTER IN DIAGNOSTIC MODE
*
         LI,R1    M:DO
         LI,R2    X'3FFF'
         AND,R2   LLNDD             LINE PRINTER ADDRESS
         AI,R2    X'4000'           DIAGNOSTIC FLAG
         M:OPEN,E DEVOPN
         LI,R1    M:LO
         M:OPEN,E DEVOPN
         SPACE    2
*
*  INITIALIZE CFU AREA
*
         LW,R11   ACNCFU+13         IF ALREADY INITIALIZED, GET OUT
         BNEZ     EXIT2
         LI,R0    LASTCFU+21-BGRCFU
         SLS,R0   1
         AI,R0    LASTCFU+21-BGRCFU
         SLS,R0   -3                3/8 OF CFU SPACE
         AI,R0    BGRCFU
         LI,R1    BGRCFU
         LI,R2    X'FF00'
CFUIN1   CW,R1    R0
         BG       CFUIN2            DONE WITH 8 WORD BLOCKS
         STW,R2   0,R1              SET UP WORD ZERO
         AI,R1    CFUSIZE           INCR TO NEXT
         B        CFUIN1
*
CFUIN2   AI,R1    -1
         AND,R1   =X'FFFFFFFE'      ROUND DOWN
         STW,R1   ACNCFU+13         START OF ACCOUNT AREA
         LI,R1    X'10000'
         STW,R1   ACNCFU+14         1 ACTIVE ACCOUNT
         LI,R1    1
         LD,R2    SYSACCT           ':SYS'
         STD,R2   *ACNCFU+13,R1
         LI,R1    LASTCFU+23
         SW,R1    ACNCFU+13         SPACE REMAINING
         SLS,R1   -3                1/8 SPACE REMAINING FOR ACCOUNTS
         AW,R1    ACNCFU+13
         AND,R1   =X'FFFFFFFE'      ROUND DOWN
         STW,R1   ACNCFU+16         NEXT AVAIL LOC FOR NAME
         STW,R1   ACNCFU+15         BASE OF NAME AREA
*
         SPACE    2
*
*  READ AND PROCESS RECOVERY BUFFER
*
*        THOSE ENTRIES THAT ARE NOT PROCESSED HERE ARE DONE IN GHOST1
*
         LW,R5    =X'05010001'      SET UP COMBUF HEADER
         STW,R5   SGCHD
         LI,R1    0
         LCI      4
         STM,R1   R2
         STM,R2   SGCHD+1           CLEAR REST OF SGCHD
         M:GVP    RBUF
         BCS,8    INITERR
         M:GVP    RBUF+512
         BCS,8    INITERR           CAN'T GET THE PAGE
         LB,R8    X'2A'
         CI,R8    X'22'             IS IT COLD TAPE BOOT
         BE       ALLYINIT          YES - INITIALIZE ALLYCAT DATA
*
         LI,R2    512               # WORDS TO READ
         LI,R7    RBUF              BUFFER ADDRESS
         LW,R8    RCVRAD            DISC ADDRESS
         BAL,R11  DRDWAIT           READ DISC WITH WAIT
         BNEZ     BADRBUF           ERROR
         LI,R7    RBUF+512
         AI,R8    2                 DISC ADDRESS OF SECOND GRANULE
         BAL,R11  DRDWAIT           READ SECOND HALF OF RECOVERY BUF
         BNEZ     BADRBUF
         LB,R8    RBUFEND
         CI,R8    4
         BNE      DATIME            RECOVERY BUFFER DOES NOT EXIST
*
         LI,R2    RBUFEND-1         FIRST CONTROL WORD
         LW,R8    0,R2              GET IT
         CI,R8    X'40404'
         BNE      %+2               EXTA WORD NOT PRESENT
         AI,R2    -1                SKIP ZAP FLAG
*
PROCBUF  LW,R3    0,R2              GET NEXT CONTROL WORD
         LB,R4    R3                CODE
         BEZ      BADRBUF           ERROR
         CI,R4    MAXCODE
         BGE      BADRBUF           ERROR
         LI,R1    1
         SH,R2    R3,R1             POINT TO START OF BUFFER
         PUSH     2,R2
         B        %,R4
*
RCVRBR   EQU      %-1
         B        ERLOG              1  ERROR LOG
         B        RETURN             2  COC MESSAGE
         B        RETURN             3  RECOVERY DUMP
         B        BADRBUF            4  RECOVERY BUFFER SIZE
         B        RETURN             5  **UNUSED**
         B        DNDV               6  PARTITIONED DEVICES (DOWN DEVICES)
         B        RETURN             7  SYMFILES
         B        RETURN             8  JITS FOR ACCOUNTING
         B        LIMIT              9  SYSTEM LIMITS
         B        RETURN             A  **UNUSED**
         B        RETURN             B  PERFORM HGP RECONSTRUCTION
         B        RETURN             C  **UNUSED**
         B        RELGRAN            D  RELEASE GRANULES
         B        RETURN             E  **UNUSED**
         B        SYMGDATA           F  RBBAT DATA
         B        RETURN            10  COMM BUFFERS
         B        SYMGERR           11  RBBAT ERROR WORD PLUS MISC.
         B        RETURN            12 TRANSACTION PROCESSING
MAXCODE  EQU      %-RCVRBR
         SPACE    3
*
*  RESTORE ERRLOG POINTERS
*
         OPEN     CURBUF
         REF      CURBUF
ERLOG    DISABLE                    ****  DISABLE
         LCI      8
         LM,R4    0,R2
         STW,R4   SGRAN
         STW,R5   BGRAN
         STW,R6   CURGRAN
         STW,R7   FGRAN1
         STW,R8   FGRAN2
         STW,R9   FGRAN3
         STW,R10  ERBLOCK
         STW,R11  CURBUF
         LI,R6    -2
ERLOG10  LW,R0    8,R2              RESTORE CURRENT BUFFER
         STW,R0   *CURBUF,R6
         AI,R6    1
         AI,R2    1
         CI,R6    64
         BLE      ERLOG10           NOT DONE YET
         ENABLE                     ****  ENABLE
         B        RETURN
         CLOSE    CURBUF
         SPACE    3
*
*  PARTITIONED (DOWN) DEVICES
*
DNDV     LI,R6    X'FF'
         AND,R6   R3                # ENTRIES TO PROCESS
DNDV1    LW,R3    0,R2              GET NEXT ENTRY
         LI,R5    X'FF'
         AND,R5   0,R2              GET DCT INDEX
         CI,R3    X'400'            DEVICE FLAG
         BAZ      DNDV4             DEVICE NOT PARTITIONED
         LB,R4    DCT3,R5
         OR,R4    X20               SET PARTITIONED FLAG
         STB,R4   DCT3,R5
         LB,R4    SNDDX             # SYMBIONT DEVICES
         CB,R5    SNDDX,R4          IS THIS DEVICE SYMBIONT
         BE       DNDV2             YES
         BDR,R4   %-2
         B        DNDV4             NO
DNDV2    LI,R1    3
         STB,R1   SSTAT,R4          SET STATUS = NOT AVAILABLE
*
DNDV4    LB,R4    DCT24,R5          CONTROLLER FLAG
         CI,R3    X'100'            IS CONTROLLER PARTITIONED
         BAZ      %+2               NO
         OR,R4    X4                YES
         DO       0                 OLD DEVICE DOWN CODE
         CI,R3    X'200'
         BAZ      %+2
         OR,R4    X40
         FIN
         STB,R4   DCT24,R5
         AI,R2    1
         BDR,R6   DNDV1             DO REST OF DEVICES
         SPACE    3
*
*  RESTORE SYSTEM LIMITS
*
LIMIT    EQU      %
         LI,R7    -TABLESZ          TABLE SIZE
         SLS,R2   2                 BYTE ADDRESS
*
LIM10    LW,R5    TABLE+TABLESZ,R7    GET NEXT ENTRY
         LI,R4    0
         SLD,R4   15                R4 = COUNT
         SLS,R5   -15               R5 = ADDRESS
         LW,R3    R5
         BEZ      LIM40             TABLE NOT IN SYSTEM
         AI,R4    0
         BNE      %+2
         LI,R4    4                 ONE WORD (4 BYTE) TABLE
LIM20    CI,R4    255
         BLE      LIM30             DO IT IN ONE MBS
         LI,R6    252
         STB,R6   R3                BREAK IT INTO 252 BYTE BLOCKS
         MBS,R2   0
         AI,R4    -252
         B        LIM20
*
LIM30    STB,R4   R3                BYTE COUNT
         MBS,R2   0
         AI,R2    3                 ROUND UP
         AND,R2   =X'FFFFFFFC'
LIM40    BIR,R7   LIM10
*
*  DIDDLE REMOTE BATCH TABLES
*
         LI,R5    -RBLIMSZ
         BEZ      LIM60             NO REMOTE BATCH
         LI,R3    RBLIMSIX
         LW,R8    Y02
         LI,R9    2
LIM50    LW,R6    RB:FLAG+RBLIMSIX+RBLIMSZ,R5
         AND,R6   =X'DFFFFFEA'
         OR,R6    X20
         SPACE    3
*
*  RECONSTRUCT SYMBIONT FILES
*
HGPRSYM  EQU      %
         LI,R14   MBEGSYM
         BAL,R15  PRINT
*
         LW,R7    ADBUF1            RELEASE ALL BUFFERS
         BAL,R15  RELBUF
         LW,R7    ADBUF2
         BAL,R15  RELBUF
         LW,R7    FDBUF1
         BAL,R15  RELBUF
         LW,R7    FDBUF2
         BAL,R15  RELBUF
         LW,R7    FITBUF
         BAL,R15  RELBUF
*
         LI,R7    0
         XW,R7    BUFMAX
         M:FP     *R7               FREE BUFFER PAGES
         LW,R7    HGP2
         SW,R7    HGP1
         BEZ      %+3
         SLS,R7   -9
         M:FP     *R7               FREE SECOND HGP COPY
         LI,R7    0
         STW,R7   HGPDISP
         LW,R7    HGP1
         STW,R7   HGP2
         M:GVP    JITBUF
         BCS,8    SYMBERR           GET PAGES TO READ JIT AND AJIT
         M:GVP    AJITBUF
         BCS,8    SYMBERR
         LW,R8    RBJIT
         BEZ      SYMBRB            NO RBBAT JIT - CHECK :RBBRVR
         B        RDRBJIT           READ RBBAT JIT, RETURN TO SYM10
*
*  RBBAT JIT, AJIT AND STATIC DATA ARE IN CORE
*    R5 = WA OF STATIC DATA
*
SYM10    LW,R3    1,R5              INDEX TO LAST DA
         LW,R4    2,R5              CURRENT COMM BUF ADDR
         AW,R5    0,R5              FIRST DA ADDRESS
SYM15    LW,R8    *R5,R3            NEXT FDA
         BAL,R11  SYMBCHK           ALLOCATE THE FILE
         BDR,R3   SYM15
         LB,R3    PAGE
         M:FP     *R3               FREE STATIC DATA PAGES
*
*  PROCESS COMMUNICATION BUFFERS
*
         LI,R1    JITBUF
         LW,R8    RBJIT
         BEZ      SGCBUF            IF NO JIT, ALREADY READ COMM BUFS
         LI,R2    512               RE-READ RECOVERY BUFFER
         LI,R7    JITBUF
         LW,R8    RCVRAD
         BAL,R11  DRDWAIT
         BNEZ     SYMBERR
         LI,R7    AJITBUF
         AI,R8    2
         BAL,R11  DRDWAIT
         BNEZ     SYMBERR
         LB,R4    JITBUF+511+512
         CI,R4    4
         BNE      GI                NO RECOVERY BUFFER - SKIP COMM BUFS
         LI,R1    JITBUF+511+511
         LW,R4    0,R1
         CI,R4    X'40404'
         BNE      %+2               SKIP ZAP FLAG
SGC10    AI,R1    -1
         LB,R8    *R1
         LI,R3    1
         SH,R1    *R1,R3
         CI,R8    X'10'             SEARCH FOR COMM BUF ENTRY
         BE       SGCBUF
         LI,R9    JITBUF+511+512
         SH,R9    JITBUF+511+512,R3
         CW,R1    R9
         BG       SGC10             MORE TO CHECK
         B        GI                NO COMM BUF ENTRY
*
SGCBUF   EQU      %
         LI,R3    HOU
         LB,R2    *R1,R3            POINTER TO FIRST USED ENTRY
         AI,R4    -SGCHD            INDEX INTO SGCHD
         BLZ      SGCB10            NOT LEGAL
         CI,R4    255
         BG       SGCB10            NOT LEGAL
         AI,R2    0
         BEZ      SGCB12            NO USED CHAIN
SGCB11   CW,R2    R4                'FREE' ENTRY IN CHAIN
         BNE      %+2               NO
         LI,R4    0                 YES - PRETEND NO CURRENT COMM BUF
         LW,R2    *R1,R2
         LB,R2    R2                FLINK TO NEXT IN CHAIN
         BNEZ     SGCB11            MORE TO GO
         LB,R2    *R1,R3            HEAD OF CHAIN
         AI,R4    0
         BEZ      SGCB3             NO ENTRY - PROCESS CHAIN
SGCB12   LW,R3    *R1,R4            LINK FREE ENTRY ONTO CHAIN
         STB,R2   R3
         STW,R3   *R1,R4
         LW,R2    R4
         B        SGCB3
SGCB10   AI,R2    0
         BEZ      GI                NO CHAIN PRESENT
*
*  PROCESS CHAIN
*
SGCB3    LI,R4    X'FF'
         AND,R4   *R1,R2            ENTRY TYPE
         BEZ      SGCB4
         CI,R4    5                 ONLY PROCESS TYPES 1 TO 5
         BG       SGCB4
         AI,R1    1
         LW,R8    *R1,R2            DISC ADDRESS
         AI,R1    -1
         BAL,R11  SYMBCHK
*
SGCB4    LW,R2    *R1,R2
         LB,R2    R2                LINK TO NEXT
         BNEZ     SGCB3
*
*  PROCESS FILES FROM GI TABLES
*
GI       LI,R1    3
GI10     LB,R2    GIB:UN,R1
         BEZ      GI20              UNUSED
         LW,R8    GI:SDA,R1         DISC ADDRESS
         BAL,R11  SYMBCHK
GI20     BDR,R1   GI10
*
*  ALL RECONSTRUCTION IS COMPLETE
*
HGPRDONE LI,R14   MHGPDONE
         BAL,R15  PRINT
         B        ALLYINV           WRITE OUT HGPS
         SPACE    2
*
*  ERROR IN SYMBIONT FILE RECOVERY
*
SYMBERR  M:SNAP   'SYMB ERR',(D1,D1END)
         M:SETDCB,E  RBSET
         M:CLOSE  F:RB,SAVE
         B        HGPRDONE
         SPACE    2
*
*  RECOVER SYMBIONT FILES FROM :RBBRVR FILE
*
SYMBRB   M:OPEN F:RB,(FILE,':RBBRVR'),IN,(ERR,HGPRDONE),(ABN,HGPRDONE)
         M:GP     255
         BCS,8    SYMBERR
         STB,R8   PAGE              REMEMBER # PAGES GOTTEN
         SLS,R9   9+2
         M:READ   F:RB,(BUF,*R9),(SIZE,*R8),(KEY,TXRBSD),;
                    (ERR,SYMBERR),(ABN,SYMBERR)
         M:READ   F:RB,(BUF,JITBUF),(SIZE,2048),(KEY,TXRBCM),;
                    (ERR,SYMBERR),(ABN,SYMBERR)
         M:CLOSE  F:RB,SAVE
         B        SYM10
         SPACE    3
*
*  ALLOCATE GRANULES FOR SYMBIONT FILE
*  R8 = DISC ADDRESS OF FDA
*
SYMBCHK  AND,R8   M24
         BEZ      *R11
         PUSH     16,R0
         LI,R7    0
         STW,R7   ADBUF2
         LI,R7    JITBUF
         STW,R7   ADBUF1
         STW,R8   *ADBUF2           PSEUDO FLINK
         LI,R6    0
         STW,R6   DBUF1             LINK CHECK DISC ADDRESS
*
SYMBC10  LW,R8    *ADBUF2           NEXT DA
         BEZ      SYMBC30           DONE
         LI,R15   ERR#02            BAD FLINK
         BAL,R11  CHKDA
         BCR,15   SYMBCERR
         LI,R2    256               # WORDS TO READ
         LW,R7    ADBUF1            BUFFER ADDRESS
         BAL,R11  DRDWAIT           READ IT
         BEZ      SYMBC20           NO ERRORS
         LI,R15   ERR#99            MUST BE HARDWARE ERROR
         B        SYMBCERR
SYMBC20  LI,R15   ERR#07            LINK CHECK FAILURE
         LW,R11   255,R7
         CW,R11   DBUF1
         BNE      SYMBCERR
         STW,R8   DBUF1
         LW,R7    ADBUF1
         XW,R7    ADBUF2            SWITCH BUFFER POINTERS
         BNEZ     %+2
         LI,R7    AJITBUF
         STW,R7   ADBUF1
         CI,R8    1
         BANZ     SYMBC10           NOT EVEN SECTOR - DON'T ALLOCATE
         BAL,R11  ALLOCS
         BCR,15   SYMBC10           OK
         BAL,R11  ALLOCG            MAY BE PFA
         BCR,15   SYMBC10           OK
*
SYMBCERR STW,R15  ERRCODE
         LI,R14   MSYMBERR
         BAL,R15  PRINT
         BAL,R11  ERRMSG
         LI,R14   MSYMTRUN
         BAL,R15  PRINT
         LW,R7    ADBUF2
         BEZ      SYMBC30           FDA BAD - CAN'T DO ANYTHING
         LI,R8    0
         STW,R8   255,R7            SET FLINK = 0
         LW,R8    DBUF1             DISC ADDR OF PREV GRAN
         LI,R2    256
         BAL,R11  DWRWAIT
SYMBC30  PULL     16,R0
         B        *R11
         STW,R6   RB:FLAG+RBLIMSIX+RBLIMSZ,R5
         LH,R6    DCT7,R3           DA OF COMMAND LIST
         STD,R8   0,R6              INITIALIZE COMMAND LIST
         AI,R3    1
         BIR,R5   LIM50
*
*  PARTITION TABLES
*
LIM60    LI,R5    0
         STW,R5   S:MBSF            ALLOW JOBS TO BE SCHEDULED
         LI,R5    X'FFFF'
         STW,R5   PL:CHG            SET ALL PARTITIONS CHANGED
*
         LI,R5    LPART             # PARTITIONS
LIM70    LH,R4    PLH:FLG,R5
         AND,R4   PL:JIF            RESET ALL BUT JOB INDEPENDENT
         STH,R4   PLH:FLG,R5
         AI,R5    -1
         BGEZ     LIM70
         B        RETURN
         SPACE    3
*
*  SAVE POINTER TO GRANULES TO RELEASE
*
RELGRAN  LW,R10   0,R2
         STW,R10  RELFDA            SAVE DISC ADDRESS OF BUFFER
         B        RETURN
         SPACE    3
*
*  GET RBBAT JIT AND AJIT DISC ADDRESSES
*
SYMGDATA LW,R4    1,R2              JIT DISC ADDRESS
         STW,R4   RBJIT
         LW,R4    0,R2              AJIT
         STW,R4   RBAJIT
         B        RETURN
         SPACE    3
*
*  RBBAT ERROR WORD PLUS MISCELLANEOUS ITEMS
*
SYMGERR  LCI      2
         LM,R4    0,R2
         STW,R4   SGCHD+3           RBBAT ERROR WORD
         STW,R5   RCVRCNT           # RECOVERIES
         LW,R4    RBUFEND-1
         CI,R4    X'40404'
         BE       SYMG10            BOOT AFTER ZAP
         MTW,1    RCVRCNT           INCR # RECOVERIES
         LI,R5    X'7'
         AND,R5   RCVRCNT
         STS,R5   DMPNAME+1         SET UP NAME OF MONDUMP FILE
         LW,R5    =X'01010202'
         STW,R5   DMPNAME-1         PUT NAME VLP HEADER IN
*
SYMG10   LW,R4    2,R2
         BEZ      SYMG20            NO SUA PENDING
         LI,R5    X'FFFF'
         STS,R4   DUMPFILE+1        RESTORE # JITS
         MTW,1    DUMPFILE          SET DUMPFILE BUSY
SYMG20   LB,R5    X'2A'
         BNEZ     SYMG30            ONLY RESTORE DATE/TIME IF CRASH
         LCI      2
         LM,R4    3,R2              EBCDIC DATE
         STM,R4   DATE
         LW,R4    5,R2              EBCDIC TIME
         STW,R4   TIME
SYMG30   LW,R4    6,R2              SCREECH CODE
         STW,R4   RCVCODE
         LH,R4    RCVCODE
         CI,R4    X'89'
         BNE      RETURN            NOT ALLYCAT SCREECH
         MTW,1    HGPRFLAG          FORCE HGP RECONSTRUCTION
         B        RETURN
         SPACE    3
RETURN   PULL     2,R2
         AI,R2    -1
         INT,R3   RBUFEND
         AW,R3    R2
         CI,R3    RBUFEND
         BG       PROCBUF           NOT DONE YET
         SPACE    3
*
*  VALIDATE DATE/TIME
*
DATIME   EQU      %
         BAL,R7   CHKDATE           VALIDATE IN-CORE DATE
         B        GETDATE           BAD - ASK FOR IT
         BAL,R7   CHKTIME           VALIDATE IN-CORE TIME
         B        GETDATE           BAD
         B        CHKHGPR           DATE AND TIME OK
*
GETDATE  LI,R4    BA(MDATE)
         BAL,R11  OCKEYIN           ASK OPERATOR FOR DATE
         LI,R4    HA(DATE)
         LI,R5    3                 # FIELDS EXPECTED
         LI,R10   GETDATE           ERROR RETURN
         BAL,R11  MOVDAT            MOVE DATE FROM INPUT BUFFER TO CORE
         LH,R11   DATE+1            MOVE OVER YEAR
         LI,R7    X'4040'           INSERT BLANKS
         STH,R7   R11
         STW,R11  DATE+1
         BAL,R7   CHKDATE           VALIDATE IT
         B        DATERR            ERROR
*
GETIME   LI,R4    BA(MTIME)
         BAL,R11  OCKEYIN           PROMPT FOR TIME
         LI,R4    HA(TIME)
         LI,R5    2                 # FIELDS EXPECTED
         LI,R10   GETIME            ERROR RETURN
         BAL,R11  MOVDAT
         BAL,R7   CHKTIME           VALIDATE TIME
         B        DATERR            ERROR
         SPACE    3
*
*  ASK IF OPERATOR WANTS TO DO HGP RECONSTRUCTION
*
CHKHGPR  LB,R0    X'2A'
         BEZ      CHKHGP1           CRASH - DON'T ASK
         LW,R0    X'2A'
         BGEZ     HGPRASK           NOT BOOT UNDER FILES - ASK
         LW,R0    BOOTFLG
         BGEZ     CHKHGP1           BOOT UNDER, 'I' NOT SPECIFIED
HGPRASK  LI,R4    BA(MHGPR)
         BAL,R11  OCKEYIN
         LI,R1    1
         LB,R1    INBUF,R1          GET FIRST CHAR
         CI,R1    'Y'
         BNE      %+2
         MTW,1    HGPRFLAG          DO RECONSTRUCTION IF 'Y'
CHKHGP1  LW,R1    HGPRFLAG
         BNEZ     PUBHGPR           PERFORM PUBLIC HGP RECONSTRUCTION
         SPACE    3
*
*  RELEASE GRANULES SAVED BY FIRST PHASE OF RECOVERY
*
RELGRANS LW,R0    HGPRFLAG
         BNEZ     RBFILE            DON'T RELEASE IF RECONSTRUCTION
         LW,R8    RELFDA            DISC ADDRESS OF FIRST GRANULE
         BEZ      RBFILE            NONE TO RELEASE
RELG10   LI,R2    512               # WORDS TO READ
         LI,R7    RBUF              BUFFER ADDRESS
         BAL,R11  DRDWAIT           READ DISC WITH WAIT
         BNEZ     RELGERR           ERROR - GIVE UP
         BAL,R10  R2:RG             RELEASE IT
         BEZ      RELGERR           ERROR - GIVE UP
         LW,R8    RBUF+3
         CW,R8    RELFDA            FDA MUST MATCH
         BNE      RELGERR
         LW,R4    RBUF+1
         BLZ      RELGERR
         BEZ      RELG30            EMPTY GRANULE
         CI,R4    252
         BG       RELGERR           TOO BIG
         LI,R3    3
RELG20   AI,R3    1
         LW,R8    RBUF,R3           GET NEXT DISC ADDRESS
         BAL,R10  R2:RG             RELEASE IT
         BEZ      RELGERR           ERROR - QUIT
         BDR,R4   RELG20
RELG30   LW,R8    RBUF+2            FLINK
         BNEZ     RELG10            MORE TO GO
RELGERR  EQU      %
RELXIT   LI,R14   X'50000'          FORCE ALLYCAT STACKS TO BE
         BAL,R4   ALLOQ               EMPTIED IN CASE SAME DA
         BAL,R0   ALLOREG             RELEASED MORE THAN ONCE
         SPACE    3
*
*  CHECK FOR EXISTENCE OF RBBAT RECOVERY FILE.  IF IT ALREADY
*  EXISTS, DO NOT DESTROY IT SINCE WE ARE IN A MULTIPLE RECOVERY
*  SITUATION.
*
RBFILE   M:OPEN,E OPN:MON           OPEN MONDMP FILE OUT
         M:OPEN   F:RB,(FILE,':RBBRVR',':SYS'),IN,(ABN,NORB),(ERR,NORB)
         LB,R4    RBUFEND           RECOVERY FILE ALREADY EXISTS.  KEEP
         CI,R4    4                   IT ONLY IF THERE IS NO RECOVERY
         BNE      RBFSAVE             BUFFER (WHICH MEANS MULTIPLE RECOV)
         M:SETDCB,E  RBSET          IGNORE ERRORS ON CLOSE
         M:CLOSE  F:RB,REL
         B        NORB10            GO OPEN FILE OUTPUT
*
RBFSAVE  LI,R1    -1                FILE EXISTS - SET FLAG FOR RBBAT
         STW,R1   SGCHD+2             TO SAY THAT # DYN PAGES UNKNOWN
         B        RBFIL42           CLOSE FILES AND EXIT
         SPACE    2
*
*  ERROR ENCOUNTERED
*
RBERR    LW,R11   HGPRFLAG
         BNEZ     SYMBERR
         M:SNAP   'RBERR',(D1,D1END)
         LI,R11   2
         STW,R11  SGCHD+3           SET ERROR WORD TO SAY WE FAILED
RBERR10  LI,R14   X'60000'          TELL ALLOCAT TO RELEASE ALL
         LI,R15   0                   SYMBIONT SPACE SINCE NO RBBAT
         BAL,R4   ALLOQ               RECOVERY INFO EXISTS
         M:SETDCB,E  RBSET          IGNORE ERRORS ON CLOSE
         M:CLOSE  F:RB,REL          RELEASE RBBAT RECOVERY FILE
         B        RBFIL50           CLOSE MONDMP FILE AND EXIT
         SPACE    2
*  I/O ERROR OPENING RBBAT RECOVERY FILE
         SPACE    1
NORB     LB,R1    R10
         CI,R1    X'03'             BETTER BE NO SUCH FILE
         BNE      RBERR             UNKNOWN I/O ERROR - GIVE UP
         SPACE    2
*
*  FILE DOES NOT EXIST - BUILD ONE
*
NORB10   EQU      %
         M:OPEN   F:RB,OUT,SAVE,(ABN,RBERR),(ERR,RBERR),KEYED,;
                    DIRECT,(KEYM,7)
         DO       JITBUF=RBUF=0
         M:FVP    RBUF
         M:FVP    RBUF+512
         M:GVP    JITBUF
         BCS,8    INITERR
         M:GVP    AJITBUF
         BCS,8    INITERR
         FIN
         LW,R8    RBJIT             RBBAT JIT DA FROM RCRY BUFFER
         BEZ      RBERR10           NONE - NO RBBAT INFO TO SAVE
RDRBJIT  LW,R9    RBAJIT            AJIT DISC ADDRESS
         LI,R7    -1                SPECIAL USER #
         LH,R1    R8
         AND,R1   M8                SWAP TABLE INDEX
         STW,R1   UBSWAPI           SET FOR SEEKCONV
         LW,R2    S:DP
         BEZ      RBFIL20           BR IF RAD SWAPPER
         SLD,R8   8
         AND,R8   Y00FF             MASK OFF ALL BUT CYL #
         AND,R9   Y00FF
         AI,R8    2                 JIT ON SECTOR 2 OF CYL
         LH,R1    R8
         STW,R1   UBC#              SAVE CYL # FOR PGDISC
*
RBFIL20  BAL,R11  RDJIT             READ RBBAT JIT
         BNEZ     RBERR             ERROR
         LW,R11   HGPRFLAG
         BNEZ     RBSTAT            IF HGP RECON, READ RBBAT STATIC DATA
*
*  WRITE ENVIRONMENT RECORD
*
         INT,R5   UTSTACK+1         # WORDS USED IN STACK
         CI,R5    19
         BL       RBSTAT            NO ENVIRONMENT
         LCI      2
         LM,R4    UTSTACK+2         MOVE PSD UP ONE WORD TO REMOVE
         STM,R4   UTSTACK+3           HOLE BETWEEN PSD AND REGS
         M:WRITE  F:RB,(BUF,UTSTACK+3),(SIZE,18*4),(KEY,TXRBIV),;
                    NEWKEY,(ABN,FIXERR),(ERR,FIXERR)
         M:WRITE  F:MONDMP,(BUF,UTSTACK+3),(SIZE,18*4),(KEY,TXRBIV),;
                    NEWKEY,(ABN,FIXERR),(ERR,FIXERR)
*
*  WRITE STATIC DATA
*
RBSTAT   LI,R0    JDLL+JITBUF
         LI,R7    3                 USER #
         BAL,R11  PGDISC            SET UP PAGE/DISC TABLES
         BEZ      RBERR             MUST FIND SOME STATIC DATA
         BAL,R11  RDPAGES           READ IT
         BNEZ     RBERR             ERROR - GIVE UP
         LW,R11   HGPRFLAG
         BNEZ     SYM10
         LB,R4    PAGE              # PAGES READ
         SLS,R4   11                # BYTES TO WRITE
         LI,R8    TXRBSD            KEY
,RBFPT   M:WRITE  F:RB,(BUF,*R5),(SIZE,*R4),(KEY,*R8),NEWKEY,;
                    (ABN,RBERR),(ERR,RBERR)    GIVE UP IF ANY ERROR
,MDFPT   M:WRITE  F:MONDMP,(BUF,*R5),(SIZE,*R4),(KEY,*R8),NEWKEY,;
                    (ABN,FIXERR),(ERR,FIXERR)    IGNORE ERRORS
*
*  WRITE DYNAMIC DATA
*
RBFIL30  LB,R3    PAGE              # PAGES GOTTEN TO READ STATIC DATA
         M:FP     *R3               FREE THEM
*
         LI,R0    JDDLL+JITBUF
         LI,R7    3                 USER #
         BAL,R11  PGDISC            BUILD PAGE/DISC TABLES
         STW,R3   SGCHD+2           SAVE # DYN PAGES FOR RBBAT
         BEZ      RBFIL40           NONE - DON'T WRITE
         BAL,R11  RDPAGES           READ THEM
         BNEZ     RBERR             ERROR - GIVE UP
         LB,R4    PAGE              # PAGES READ
         SLS,R4   11                # BYTES
         LI,R8    TXRBDD            ADDRESS OF KEY
         M:WRITE,E  RBFPT
         M:WRITE,E  MDFPT
*
RBFIL40  LB,R3    PAGE              # PAGES GOTTEN
         M:FP     *R3               GIVE THEM BACK
*
RBFIL42  LI,R3    RCVRGFC
         STW,R3   SGCHD+1           TELL RBBAT THAT FILE EXISTS
,RBSET   M:SETDCB F:RB,(ERR,FIXERR),(ABN,FIXERR)  IGNORE ERRORS
         M:CLOSE  F:RB,SAVE
RBFIL50  M:CLOSE  F:MONDMP,SAVE     SAVE MONDMP FILE
RBFILEND EQU      %
         LI,R15   0                 TELL GHOST1 EVERYTHING OK
         SPACE    3
*
*  EXIT FROM FIX TO GHOST1
*
*  R15 = COMPLETION CODE TO PUT IN 75BUF
*        0 = NO ERRORS
*        1 = SUCCESSFUL HGP RECONSTRUCTION
*        -1 = HGP RECON FAILURE
*        -2 = BAD RECOVERY BUFFER
*
INITXIT  STW,R15  75BUF
         M:XCON   0                 TURN OFF EXIT CONTROL
         M:FVP    JITBUF            FREE BUFFER PAGES
         M:FVP    AJITBUF
         DO       JITBUF=RBUF=0
         F:FVP    RBUF
         F:FVP    RBUF+512
         FIN
         M:FP     255               FREE ANY LEFT OVER DYNAMIC
         M:FCP    255                 AND COMMON PAGES
*
         LI,R1    JB:PNR
         LB,R1    0,R1              GHOST JOB TABLE INDEX
         LD,R6    TXTGHST1
         STD,R6   S:GJOBTBL,R1      SET GHOST NAME TO 'GHOST1'
         LW,R4    S:CUN
         LI,R5    PNAMEND-1
         CD,R6    P:NAME,R5         FIND GHOST1'S PROCESSOR NUMBER
         BE       %+2
         BDR,R5   %-2
         STB,R5   UB:ACP,R4         SET GHOST1 AS COMMAND PROCESSOR
         M:EXIT                     EXIT TO COMMAND PROCESSOR
         TITLE    '****  PUBLIC HGP RECONSTUCTION  ****'
         SPACE    2
*
*  PERFORM HGP RECONSTRUCTION ON PUBLIC FILE SYSTEM
*
PUBHGPR  EQU      %
         M:FVP    RBUF
         M:FVP    RBUF+512
         DO       RBUF=JITBUF=0
         M:FVP    JITBUF
         M:FVP    AJITBUF
         FIN
         M:GCP    1                 GET PAGE FOR LINE PRINTER
         BCS,8    NOCORE
         STW,R9   DATADA
         AI,R9    384
         STW,R9   LPBUF
         LI,R9    0
         STW,R9   CURDATA           # ENTRIES IN DATADA
*
         LI,R5    #CBUFS
         STW,R9   CBUFS-1,R5        ZERO BUFFER POINTERS
         BDR,R5   %-1
         STW,R9   DIRBUF
*
         LW,R5    LLNDD             ADDRESS OF LINE PRINTER
         LI,R4    DCTSIZ
         CH,R5    DCT1,R4           FIND DCT INDEX
         BE       %+2
         BDR,R4   %-2
         STW,R4   LPDCTX
*
         LI,R14   MPAGE
         BAL,R15  PRINT
         M:TIME   TEMP
         LI,R4    BA(MHGPUB)
         BAL,R10  MOVTXTC
         LI,R4    BA(TEMP)
         LI,R5    4*4
         BAL,R10  MOVTXT            MOVE DATE/TIME TO BUFFER
         BAL,R10  DUMPBUF           PRINT IT
*
         BAL,R11  PUBHGPS           BUILD ONE HGP COPY
         B        NOCORE            NOT ENOUGH CORE
*
         LW,R11   HGP2
         STW,R11  HGP1
         BAL,R11  PUBHGPS           BUILD SECOND COPY
         B        NOHGP2            NOT ENOUGH SPACE
*
SETPOINT LW,R4    HGP2
         SW,R4    HGP1
         STW,R4   HGPDISP           SET UP DISPLACEMENT BETWEEN HGPS
*
         BAL,R11  ALLOCBUF          ALLOCATE I/O BUFFERS
         B        NOCORE            NOT ENOUGH CORE
         MTB,6    TYPMAX            6 TYPE 0 BUFFERS
         LW,R11   BUFMAX
         AI,R11   -6
         LI,R2    3                 REST ARE TYPE 3
         STB,R11  TYPMAX,R2
*
*  SET UP BUFFER POINTERS FOR STATIC BUFFERS
*
         LI,R2    0                 BUFFER TYPE
         BAL,R15  GETBUF
         STW,R7   ADBUF1
         BAL,R15  GETBUF
         STW,R7   ADBUF2
         BAL,R15  GETBUF
         STW,R7   FDBUF1
         BAL,R15  GETBUF
         STW,R7   FDBUF2
         BAL,R15  GETBUF
         STW,R7   FITBUF
*
         MTW,1    FIXFLAG           FIX ANY ERRORS ENCOUNTERED
*
*  LOCATE ACCOUNT DIRECTORY
*
         BAL,R11  ACNCALC
         STW,R8   ACNCFU+FDA        SAVE MAIN AND
         STW,R9   ACNCFU+8            DUAL FDA
         BAL,R11  ADINIT            SET ACCOUNT DIR VALUES
         LW,R2    ADBUF1
         STW,R2   DBUF1
         LW,R7    ADBUF2
         STW,R7   DBUF2
*
BEGINDIR STW,R8   BUFDA,R7          PUT AWAY MAIN FDA
         STW,R9   BUFDUAL,R7        AND DUAL FDA
         BAL,R11  DISCRD            START THE READ
DCHK08   LI,R8    0
         STW,R8   LINKFLAG          PERFORM LINK CHECKING
         STW,R8   FITFLAG           FIT NOT PRESENT
         STW,R8   KEYLEVEL          LEVEL 0
         LI,R8    -1
         STW,R8   SRCHKEY           STOP SEARCH AT NEXT KEY
         LW,R7    DBUF1
         XW,R7    DBUF2             EXCHANGE BUFFER POINTERS
         STW,R7   DBUF1
         BAL,R11  IOSPIN            WAIT FOR NEXT I/O TO COMPLETE
         LW,R6    BUFADR,R7
*
DCHK10   BAL,R10  VALBUF            CHECK FIRST 3 WORDS
         BEZ      DCHK20            OK
         BAL,R11  GRANERR           RETRY
         BEZ      DCHK10
*
*  UNRECOVERABLE ERROR IN DIRECTORY
*
DIRERR1  BAL,R11  ERRMSG
DIRERR   LW,R8    BLINK,R6
         BEZ      DIRER10           FDA IS BAD
         LW,R2    DBUF2
         LW,R6    BUFADR,R2
         LI,R8    0
         STW,R8   FLINK,R6          NOT FDA- SET FLINK OF PREV
         LW,R9    FL:UPDT             GRANULE TO ZERO
         STS,R9   BUFDA,R2
         B        ENDBLK2           END OF DIRECTORY
*
DIRER10  LW,R8    TYPEFLAG
         BLZ      DIRER20           BR IF ACCOUNT DIRECTORY
         BAL,R11  ADINIT
         LW,R3    ADCMD
         STW,R3   CMDL
         LCI      2
         LM,R7    ADBUF1            CHANGE BUFFER POINTERS
         STM,R7   DBUF1
         BAL,R11  DELKEY            DELETE ACCOUNT DIRECTORY KEY
         B        DCHK40
*
DIRER20  LI,R14   MADBAD
         BAL,R11  DOPRINT           TELL OPERATOR AND LINE PRINTER
         B        NORECON           TELL OPERATOR CAN'T DO RECON
*
RELFIT   BAL,R11  FDINIT
         LW,R3    FDCMD
         STW,R3   CMDL
         BAL,R11  DELKEY            DELETE KEY FROM FILE DIRECTORY
         B        DCHK40
*
DCHK20   LI,R8    0
         STW,R8   HGPDISP           LOOK ONLY AT FIRST HGP
         LW,R8    BUFDA,R7
         BAL,R11  ALLOCG            ALLOCATE MAIN DA
         BCS,11   DIRERR1           ERROR
         LW,R8    BUFDUAL,R7
         AND,R8   M24
         BEZ      DCHK30            NO DUAL
         BAL,R11  ALLOCG            ALLOCATE DUAL
         BCR,11   DCHK30            OK
*  DUAL IS DUALLY ALLOCATED
         BAL,R11  ERRMSG
         LI,R14   MRELDUAL          'DUAL REMOVED FROM DIRECTORY'
         BAL,R15  PRINT
         LW,R6    BUFADR,R7
         LI,R8    0
         STW,R8   BUFDUAL,R7
         LW,R8    BLINK,R6
         BEZ      DCHK22            NO BLINK - THIS IS FDA
         LW,R2    DBUF2
         LW,R3    BUFADR,R2
         LI,R8    0
         STW,R8   DFLINK,R3         SET PREV DUAL FLINK TO ZERO
         STW,R8   DDA,R6            SET CURRENT DUAL TO ZERO
         LW,R9    FL:UPDT
         STS,R9   BUFDA,R7
         STS,R9   BUFDA,R2
         B        DCHK30
*
*  DUAL OF FDA IS BAD
*
DCHK22   LW,R8    TYPEFLAG
         BGEZ     DCHK24            BR IF FILE DIRECTORY
         LI,R8    0
         STW,R8   ACNCFU+8
         B        DCHK30
*  ZAP DUAL DA IN AD KEY
DCHK24   LI,R8    0
         LW,R4    ADBUF1
         LW,R5    BUFADR,R4
         SLS,R5   2                 BA OF AD BUFFER
         AW,R5    ADCMD             BA OF AD KEY
         AI,R5    ADSCR+3           DUAL DA IN KEY
         LI,R3    3
         STB,R8   0,R5
         AI,R5    1
         BDR,R3   %-2
         LW,R9    FL:UPDT
         STS,R9   BUFDA,R4
*
DCHK30   LW,R7    DBUF2
         BAL,R11  BUFWRT            WRITE OUT DBUF2 IF UPDATED
         LW,R2    DBUF1
         LW,R6    BUFADR,R2
         LW,R8    BUFDA,R2          DA OF CURRENT BUFFER
         AND,R8   M24
         STW,R8   BUFDACHK,R7       BECOMES LINK CHECK DA
         LW,R8    FLINK,R6
         BEZ      DCHK40            NO FLINK - END
         STW,R8   BUFDA,R7
         LW,R8    DFLINK,R6
         STW,R8   BUFDUAL,R7
         BAL,R11  DISCRD            START NEXT READ
*
DCHK40   LW,R7    DBUF1
         LW,R3    ADCMD             CURRENT DISPL INTO ACCOUNT DIR
         LW,R8    TYPEFLAG
         BLZ      %+2
         LW,R3    FDCMD             CURRENT DISPL INTO FILE DIR
         STW,R3   CMDL
         BAL,R11  FNDKEY            LOCATE NEXT KEY
         B        %+2               FOUND ONE
         B        ENDBLOCK          NO MORE KEYS
         LW,R3    CMDL
         LI,R4    ADCMD
         LW,R8    TYPEFLAG
         BLZ      %+2
         LI,R4    FDCMD
         STW,R3   0,R4              PUT AWAY CMD
         LI,R4    BA(MSPACE)
         LW,R11   TYPEFLAG
         BGEZ     %+2
         LI,R4    BA(MADKEY)
         BAL,R10  MOVTXTC
         LW,R4    BUFADR,R7
         SLS,R4   2
         AW,R4    CMDL              BA OF CURRENT KEY
         BAL,R11  PRKEY
         BAL,R15  DUMPBUF
         LI,R14   MSPACE
         LW,R11   TYPEFLAG
         BGEZ     %+2
         BAL,R15  PRINT
         LW,R8    LOCDA             DISC ADDR OF FD OR FILE
         LW,R2    TYPEFLAG
         BGEZ     FILE20            BR IF FILE
*
*  PROCESS FILE DIRECTORY
*
         BAL,R11  FDINIT
         LCI      2
         LM,R2    DBUF1
         STM,R2   ADBUF1
         LM,R2    FDBUF1
         STM,R2   DBUF1             CHANGE BUFFER PONTERS
         LW,R8    LOCDA
         LW,R9    LOCDUAL
         B        BEGINDIR
*
*  PROCESS NEXT FILE IN DIRECTORY
*
FILEND   LW,R7    FITBUF
         BAL,R11  BUFWRT            WRITE OUT FIT IF UPDATED
*
         LW,R5    CURDATA
         BLEZ     FILEND6           NO DISC ADDRESSES
         LW,R4    CURDATA
FILEND2  AI,R4    -1
         LW,R2    *DATADA,R4        GET NEXT ENTRY
         LB,R3    R2
         AI,R3    X'FFF00'          FORM NEGATIVE INDEX
         LW,R3    BT31TO0+32,R3     GET BIT MASK
         STS,R3   0,R2              SET BIT IN HGP
         BDR,R5   FILEND2
         STW,R5   CURDATA           ZAP COUNT
*
FILEND6  LW,R7    HGP2
         CW,R7    HGP1
         BE       %+2               ONLY 1 HGP COPY
         BAL,R11  HGPZAP            2 COPIES - ZERO SECOND
         LI,R3    FDKSIZE
         AWM,R3   FDCMD
         B        DCHK40
*
*  END OF DIRECTORY
*
ENDBLOCK LW,R11   FLINK,R6
         BNEZ     DCHK08
ENDBLK2  LW,R11   TYPEFLAG
         BLZ      HGPRSYM           END OF AD - LOOK AT PER
         BAL,R11  ADINIT
         LCI      2
         LM,R2    ADBUF1
         STM,R2   DBUF1
         LI,R3    ADKSIZE
         AWM,R3   ADCMD
         B        DCHK40
ADINIT   LI,R4    ADSCR
         LI,R5    ADKSIZE
         DO       VERS=1
         MTW,0    VERSFLAG
         BEZ      %+2
         LI,R5    12+4+5            PRE-C00
         FIN
         LI,R6    BA(MACNDIR)
         LI,R7    -1
ADINIT2  STW,R4   SCRL
         STW,R5   KEYSIZE
         STW,R6   CURMES
         STW,R7   TYPEFLAG
         B        *R11
*
FDINIT   LI,R4    FDSCR
         LI,R5    FDKSIZE
         LI,R6    BA(MFILDIR)
         LI,R7    0
         B        ADINIT2
*
BUFWRT   PUSH     R11
         LW,R11   FL:UPDT
         CW,R11   BUFDA,R7
         BAZ      BUFWRT2
         BAL,R11  DISCWRT
         BAL,R11  IOSPIN
BUFWRT2  PULL     R11
         B        *R11
*
NOCORE   LI,R14   MHGPCORE
         BAL,R15  PRINT
*
NORECON  LI,R4    BA(MHGPFAIL)
         BAL,R11  OCMESS            PRINT MESSAGE TO OC
         LI,R12   D1
         LI,R13   D1END-D1+1
         LI,R14   D1
         BAL,R11  HEXDUMP           DUMP DATA
         LI,R15   -1
         B        INITXIT
*
*  CAN'T GET ENOUGH CORE FOR SECOND COPY OF HGPS
*
NOHGP2   LI,R14   MNOHGP2
         BAL,R15  PRINT
         LW,R15   HGP1
         STW,R15  HGP2
         B        SETPOINT
         TITLE    '****  INITIALIZE ALLOCAT DATA ON TAPE BOOT  ****'
         SPACE    2
*
*  ON INITIAL TAPE BOOT, BUILD PUBLIC HGPS AND WRITE THEM OUT TO
*  ALLOCAT DATA.  ALSO ALLOCATE AND INITIALIZE FDA OF THE ACCOUNT DIR.
*
         SPACE    2
ALLYINIT EQU      %
         BAL,R11  PUBHGPS           BUILD ONE COPY OF PUBLIC HGPS
         B        INITERR           ERROR
         LW,R11   HGP2
         STW,R11  HGP1              MOVE ADDRESS OF HGPS
         LI,R0    0
         STW,R0   HGPDISP
*
*  SEARCH HGPS TO FIND FIRST AND LAST OF THE FOLLOWING TYPES:
*        RAD
*        GRANULE ALLOCATED PACK
*        CYLINDER ALLOCATED PACK
*
         BAL,R11  ACNCALC           CALCULATE ACCOUNT DIR DISC ADDRS
         B        INITERR           ERROR
         STW,R8   RBJIT             SAVE MAIN DA
         STW,R9   RBAJIT              AND DUAL DA
         BAL,R11  ALLOCG            ALLOCATE MAIN DA
         BCS,11   INITERR           ERROR
         LW,R8    RBAJIT            DUAL DA
         BAL,R11  ALLOCG            ALLOCATE DUAL
         BCS,11   INITERR           ERROR
         MTB,-1   RBJIT
         BEZ      ALLYI50           # GRAN/CYL = 1
         LW,R8    RBJIT
         BAL,R2   INCREMENT%SECTOR  INCREMENT SECTOR ADDRESS BY 2
         STW,R8   ALLODIRA
*
ALLYI50  MTB,-1   RBAJIT            CHECK DUAL FOR CYL
         BEZ      ALLYINV           NOT CYL - DONE
         LW,R8    RBAJIT
         BAL,R2   INCREMENT%SECTOR  INCREMENT SECTOR ADDR BY 2
         STW,R8   ALLODIRA+1
*
*  INVERT HGP BITS, REFORMAT HGP HEADERS, RELINK HGPS
*
ALLYINV  LI,R6    JBUPVPA           ADDR OF FIRST HGP IN ALLOCAT DATA
         LW,R7    HGP1
         BAL,R11  HGPINVERT
         B        INITERR           ERROR
*
         LW,R2    #PAGES            # PAGES ALLOCATED FOR HGPS
         SLS,R2   9                 # WORDS TO WRITE
         LW,R7    HGP1              ADDRESS OF FIRST HGP
         LB,R9    MB:SDI            DCT INDEX OF FIRST SWAPPER
         LI,R3    2                 ALLYCAT USER #
         LB,R3    UB:APR,R3         ALLYCAT PROCESSOR #
         LH,R8    PH:DDA,R3         ALLOCAT DATA DISC ADDRESS
         STH,R9   R8
         BAL,R11  DWRWAIT           WRITE IT
         BNEZ     INITERR
         LI,R11   0
         XW,R11   HGPRFLAG
         BNEZ     RBFILE            IF HGPRECON, BUILD RBBAT FILE
*
*  INITIALIZE ACCOUNT DIRECTORY FDA
*
         LI,R5    511
         LI,R4    0
         STW,R4   JITBUF,R5         ZERO BUFFER
         BDR,R5   %-1
         STW,R4   JITBUF
*
         LW,R5    =(X'00004000'+MIDIS**16+X'09')
         STW,R5   JITBUF+2
         LI,R2    512               # WORDS TO WRITE
         LI,R7    JITBUF
         LW,R8    RBJIT
         BAL,R11  DWRWAIT
         BNEZ     INITERR
         LW,R8    RBAJIT
         BAL,R11  DWRWAIT
         BNEZ     INITERR
*
         LW,R8    RBJIT
         OR,R8    Y8                SET EMPTY FILE FLAG
         STW,R8   ACNCFU+FDA
         LW,R8    RBAJIT
         STW,R8   ACNCFU+8          DUAL DISC ADDRESS
         B        INITXIT           GET OUT
         SPACE    2
BADRBUF  M:SNAP   'RCVRBUF',(RBUF,RBUFEND)
         LI,R4    BA(MNORCVR)
         BAL,R11  OCMESS            TELL OPERATOR CAN'T RECOVER
         LI,R15   -2                BAD RECOVERY BUFFER FLAG
         B        INITXIT           EXIT TO GHOST1
INITERR  M:SNAP   'INITERR',(JITBUF,AJITBUF+511)
         M:SNAP   'DATA',(D1,D1END)
         B        %
         SPACE    3
R2:RG    PUSH     2,R3
         BAL,R6   CHKDAQ            VALIDATE DISC ADDRESS
         BCR,15   R2:EXIT1          BAD
         LDCTX,R1 R8
         LI,R7    HGP
         BAL,R5   FNDHGP1
         B        R2:EXIT1          CAN'T FIND HGP
         LI,R11   R2:EXIT           RETURN FROM RCYL, RBG, RSG
         LW,R3    1,R7
         CI,R3    ATCYLBIT          IS HGP CYLINDER ALLOCATED
         BANZ     RCYL              YES
         AI,R8    0                 IS IT SYMBIONT
         BGEZ     RBG               NO
         B        RSG               YES
R2:EXIT1 LI,R8    0
R2:EXIT  PULL     2,R3
         AI,R8    0
         B        *R10
         SPACE    3
CHKDATE  LI,R3    3
         LI,R13   X'F0F0'
CHKD10   LH,R4    DATE,R3           GET NEXT ITEM
         BGZ      CHKD20            MUST BE TWO BLANKS
         CS,R13   R4                OTHERWISE MUST BE TWO DECIMAL DIGITS
         BNE      0,R7              NO - ERROR
CHKD20   CH,R4    MAXD,R3
         BG       0,R7              TOO BIG
         CH,R4    MIND,R3
         BL       0,R7
         BE       CHKD30            BR IF TWO BLANKS
         AI,R4    X'606'            CHECK FOR 'F0' THRU 'F9'
         CS,R13   R4
         BNE      0,R7              ERROR
CHKD30   AI,R3    -1
         BGEZ     CHKD10            DO ALL FOUR ITEMS
         LW,R4    DATE              MONTH - DAY
         LI,R6    6
         CW,R4    BADATES,R6        CHECK FOR ILLEGAL MONTH/DAY
         BE       0,R7
         BDR,R6   %-2
         CW,R4    BADATES           CHECK FOR FEB 29
         BNE      1,R7              NO - DATE IS OK
         LI,R4    X'103'            CHECK FOR LEAP YEAR
         AND,R4   DATE+1
         BEZ      1,R7              OK - EVEN DECADE, YEAR = 4 OR 8
         CI,R4    X'102'            MAY ALSO BE ODD DECADE AND
         BE       1,R7                YEAR 2 OR 6
         B        0,R7              NOT LEAP YEAR
         SPACE    3
CHKTIME  LI,R3    1
         LI,R13   X'F0F0'
CHKT10   LH,R4    TIME,R3           GET NEXT ITEM
         CS,R13   R4
         BNE      0,R7              NOT DECIMAL DIGITS
         CH,R4    MAXT,R3
         BG       0,R7              TOO BIG
         AI,R4    X'606'            CHECK FOR 'F0' THRU 'F9'
         CS,R13   R4
         BNE      0,R7
         AI,R3    -1
         BGEZ     CHKT10            DO BOTH ITEMS
         B        1,R7
*
MOVDAT   LI,R8    0
MOVDAT10 BAL,R15  NXTCHAR           GET NEXT CHAR FROM INPUT BUFFER
         BCS,4    MOVDAT20          NO MORE CHARS
         LI,R7    #DTDELIM
         CB,R12   DTDELIM,R7
         BE       MOVDAT20          DONE - FOUND DELIMITER
         BDR,R7   %-2
         SLS,R8   8                 NOT DELIMITER - ACCUMULATE CHAR
         OR,R8    R12
         B        MOVDAT10
*
MOVDAT20 CW,R8    YFFFF
         BANZ     DATERR            ERROR - MORE THAN TWO CHARS
         CI,R8    X'FF00'
         BANZ     %+2
         AI,R8    '0'**8            SUPPLY LEADING ZERO
         STH,R8   0,R4              PUT IT AWAY
         AI,R4    1
         BDR,R5   MOVDAT            DO REST OF FIELDS
MOVDAT30 BAL,R15  NXTCHAR           CHECK FOR EXTRA FIELDS
         BCS,4    *R11              NO MORE CHARS - EXIT
         CI,R12   X'40'
         BE       MOVDAT30          ALLOW TRAILING BLANKS
*
DATERR   LI,R4    BA(MEH)
         LW,R11   R10
         B        OCMESS
         TITLE    '****  FIXERR  ****'
         SPACE    2
*
*  ERROR OPENING F:FIX
*
FIXERR   EQU      %
         LB,R1    R10               MAJOR CODE
         LH,R2    R10
         AND,R2   M8
         SLS,R2   -1                SUB-CODE
         B        *R8               RETURN TO CAL+1
         TITLE    '****  REL  ****'
         SPACE    2
*
*  PURPOSE:  RELEASE ALL ITEMS AT END OF PROCESSING
*              (OPEN/CLOSE USER, MPOOL BUFFER, BUF PAGES)
*
*  CALL:  BAL,R11  REL
*
         SPACE    1
REL      PUSH     R11
         ENABLE                     **** ENABLE
*
         BAL,R11  RELOCU            RELEASE OPEN/CLOSE USER
*
         LW,R2    S:CUN
         MTB,0    UB:MF,R2
         BNEZ     %-1               WAIT FOR ALL I/O TO COMPLETE
         LI,R14   0
         XW,R14   MPOOLADR
         BEZ      %+2
         BAL,R11  RMB               RELEASE MPOOL BUFFER
*
         M:FP     255               RELEASE ALL DYNAMIC PAGES
         PLW,R7   BUFREE
         BNSU     %-1               EMPTY FREE BUFFER STACK
         LI,R8    0
         STW,R8   BUFMAX            LARGEST LEGAL BUF INDEX
*
         PULL     R11
         B        *R11
         TITLE    '****  MESSAGES  ****'
         SPACE    2
MF2LNG   TEXTC    ' FIELD TOO LONG'
MBADHEX  TEXTC    ' ILLEGAL HEX DIGIT'
MUTFLD   TEXTC    ' UNTERMINATED FIELD'
MILLSYN  TEXTC    ' ILLEGAL SYNTAX'
MILLOPT  TEXTC    ' OPTION ILLEGAL WITH COMMAND'
MUNKOPT  TEXTC    ' UNKNOWN OPTION'
MILLSN   TEXTC    ' ILLEGAL SN'
MNOACCT  TEXTC    ' MISSING ACCOUNT AFTER FILE NAME'
MILLDEV  TEXTC    ' ILLEGAL DEVICE TYPE'
MPRIVLOW TEXTC    ' INSUFFICIENT PRIVILEGE'
MBADMON  TEXTC    ' LOADED WITH WRONG MONSTK'
MASPDB   TEXTC    ' CAN''T RUN WITH LIBRARY OR DEBUGGER ASSOCIATED'
MPROMPT  TEXTC    ' FIX HERE'
MUNKCOM  TEXTC    ' UNKNOWN COMMAND'
MERRXIT  TEXTC    '  INPUT ERRORS - JOB ABORTED'
MDUPOPT  TEXTC    ' DUPLICATE OPTION'
MOPTERR  TEXTC    ' CONFLICTING OPTIONS'
MABRT    TEXTC    ' **** FIX ABORTING'
MSNGHST  TEXTC    ' OPTION ILLEGAL FOR GHOST'
MERRIN   TEXTC    'B**** ERROR IN '
MACNDIR  TEXTC    'ACCOUNT DIRECTORY'
MFILDIR  TEXTC    'FILE DIRECTORY'
MFILE    TEXTC    'FILE'
MFIT     TEXTC    'FIT'
MDISCADR TEXTC    'A  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 '
MDUALOK  TEXTC    'A DUAL SUCCESSFULLY READ'
MNOSACCT TEXTC    ' NO SUCH ACCOUNT'
MNOSFILE TEXTC    ' NO SUCH FILE'
MIOERR   TEXTC    'A**** I/O ERROR '
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 '
MERR     TEXTC    ' ERROR'
MS       TEXTC    'S'
MERR1    TEXTC    'NO ERROR'
MADKEY   TEXTC    'B  ACCOUNT = '
MADBAD   TEXTC    ' ACCOUNT DIRECTORY DESTROYED'
MMULDEL  TEXTC    'CUPPER LEVEL INDEX DELETED'
MSYMBERR TEXTC    'CERROR IN SYMBIONT FILE'
MBEGSYM  TEXTC    'CBEGINNING SYMBIONT FILE RECONSTRUCTION'
MHGPDONE TEXTC    'CHGP RECONSTRUCTION COMPLETE'
MSYMTRUN TEXTC    'CSYMBIONT FILE TRUNCATED'
MACCT    TEXTC    'ACCOUNT = '
MACCT1   TEXTC    '     ACCOUNT = '
MFNAME   TEXTC    'FILE NAME = '
MHEX1    TEXTC    '   (X'''
MHEX2    TEXTC    ''')'
MFILBUSY TEXTC    ' FILE BUSY'
MFILSKIP TEXTC    'A FILE SKIPPED   NAME = '
MAST     TEXTC    ' **** '
MSPACE   TEXTC    ' '
MLINKCHK TEXTC    '    EXPECTED LINK = '
MCONDEL  TEXTC    'A**** END OF GRANULE SET AT WORD '
MKEY1    TXTC     0,CR
MKEY2    TXTC     ':',TAB,TAB,PC
MDATE    TXTC     CR,'DATE(MM/DD/YY)='
MTIME    TXTC     CR,'TIME(HH:MM)='
MEH      TXTC     CR,'  ??',CR
MHGPR    TXTC     CR,'DO YOU WANT HGP RECONSTRUCTION(Y/N)?'
MNORCVR  TXTC     CR,CR,TAB,'CANNOT RECOVER',CR,CR
MHGPCORE TEXTC    'CCORE SIZE TOO SMALL FOR HGP RECONSTRUCTION'
MHGPFAIL TXTC     CR,CR,TAB,'HGP RECONSTRUCTION FAILURE',CR,CR
MNOHGP2  TEXTC    'CNOT ENOUGH CORE FOR 2 COPIES OF HGPS - ',;
                    'PROCEEDING WITH ONE COPY'
MRELDUAL TEXTC    'BDUAL REMOVED FROM DIRECTORY'
MPAGE    TEXTC    '1'
MHGPUB   TEXTC    'B PUBLIC HGP RECONSTRUCTION INITIATED AT '
MOC1     TXTC     CR,'CHANGE LP ADDRESS   LPNDD => LP'
MOC2     TXTC     CR,'PRINT ALL, ERRORS ONLY, OR NOTHING(A,E,N)?'
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 MISSING OR BAD'
MSG51    TEXTC    'ILLEGAL DISC ADDRESS'
MSG53    TEXTC    'DUAL ALLOCATION IN MASTER HGP'
MSG54    TEXTC    'DUAL ALLOCATION IN CURRENT FILE OR DIRECTORY'
MSG99    TEXTC    'HARDWARE I/O ERROR'
         BOUND    8
TXTGHST1 TEXTC    'GHOST1'
TXRBIV   TEXTC    'RBBATIV'
TXRBSD   TEXTC    'RBBATSD'
TXRBDD   TEXTC    'RBBATDD'
TXRBCM   TEXTC    'RBBATCM'
         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            KEY OUT OF ORDER
ERR#22   ERR      22+DEL+KEY,MSG4   MASTER DA BAD
ERR#23   ERR      23+DEL+KEY,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,MSG51          NO HGP FOR THIS DCT INDEX
ERR#52   ERR      52,MSG51          RELATIVE SECTOR NOT IN HGP
ERR#53   ERR      53,MSG53          DUAL ALLOCATION IN MASTER HGP
ERR#54   ERR      54,MSG54          DUAL ALLOCATION IN CURRENT HGP
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'
*
DELIMS   DATA,1   0,'/',';',' '
#DELIM   EQU      BA(%)-BA(DELIMS)-1
         BOUND    4
DTDELIM  DATA,1   0,' ',':','/'    DELIMITERS FOR DATE/TIME
#DTDELIM EQU      BA(%)-BA(DTDELIM)-1
         BOUND    4
BLANKS   TEXT     ' '
*
CNVRT    TEXT     '0123456789ABCDEF'
MIND     TEXT     '0101  70'        MIN VALUES FOR DATE
MAXD     TEXT     '1231  99'        MAX VALUES FOR DATE
MAXT     TEXT     '2359'            MAX VALUES FOR TIME
BADATES  DATA     '0229','0230','0231','0431','0631','0931','1131'
DEVOPN   GEN,1,7,7,17  1,X'14',0,R1    DCB = *R1
         DATA     X'00040003'
         PZE      *R2               DEVICE TYPE IN R2
*
M:SYSFPT M:SYS,L
*
*  FLAGS FOR BUFDA
*
FL:IOP   DATA     X'80000000'       I/O IN PROGRESS
FLR:IOP  DATA     X'7FFFFFFF'
FL:SNAP  DATA     X'20000000'       BUFFER HAS BEEN SNAPPED
FLR:SNAP DATA     X'DFFFFFFF'
FL:UPDT  DATA     X'10000000'       BUFFER IS UPDATED
FLR:UPDT DATA     X'EFFFFFFF'
FL:EA    DATA     X'08000000'       END-ACTION MUST BE DONE
FLR:EA   DATA     X'F7FFFFFF'
FL:DUAL  DATA     X'04000000'       BUFDA AND BUFDUAL SWITCHED
FLR:DUAL DATA     X'FBFFFFFF'
*
M2       DATA     X'00000003'
M7       DATA     X'0000007F'
M8       DATA     X'000000FF'
M16      DATA     X'0000FFFF'
M24      DATA     X'00FFFFFF'
YFF      DATA     X'FF000000'
YE       DATA     X'E0000000'
Y8       DATA     X'80000000'
Y4       DATA     X'40000000'
Y3FFF    DATA     X'3FFF0000'
Y3       DATA     X'30000000'
Y2       DATA     X'20000000'
Y1       DATA     X'10000000'
Y01      DATA     X'01000000'
Y02      DATA     X'02000000'
Y06      DATA     X'06000000'
Y0A      DATA     X'0A000000'
Y00FF    DATA     X'00FF0000'
Y002     DATA     X'00200000'
Y004     DATA     X'00400000'
Y008     DATA     X'00800000'
Y00F     DATA     X'00F00000'
YFFFF    DATA     X'FFFF0000'
YFFFFFF  DATA     X'FFFFFF00'
M32      DATA     -1
*
IR6R3    LB,0     *R6,R3            FOR ANLZ INSTRUCTION
IR13     LB,0     *R13              ANLZ
*
SPFPT    M:WRITE,L M:LO,(BUF,BLANKS),(SIZE,2),(BTD,0),WAIT
         TITLE    '****  DYNAMIC DATA  ****'
         SPACE    2
         USECT    D1
*
STKSIZ   EQU      80
SPD      DATA     %+1
         DATA,2   STKSIZ,0
         DO1      STKSIZ
         DATA     X'BAD'
         DATA     P1
*
*  THE TCB STACK POINTER DOUBLEWORD IS MODIFIED TO POINT TO
*    THE FOLLOWING STACK (THE TCB STACK IS NOT LARGE ENOUGH).
*
TCBSTKSZ EQU      21*(#EASTACK+1)       21 WORDS PER INTERRUPT ENVIRONMENT
TCBSTK   EQU      %
         DO1      TCBSTKSZ
         DATA     X'0BAD0000'
#SN      EQU      20
OPNFIX   GEN,8,24  X'14',F:FIX      M:OPEN
         DATA     X'C1040001'
         DATA     FIXERR,FIXERR
         DATA     4                 INOUT
DEVTYPE  DATA,2   0,'DP'            DEVICE TYPE
         GEN,8,8,8,8  1,0,8,8
CURFILE  RES      8
         GEN,8,8,8,8  2,0,2,2
CURACCT  RES      2
         GEN,8,8,8,8  7,1,0,#SN
SN       RES      #SN
*
OPNPV    GEN,8,24 X'14',F:PV
         DATA     X'C5441001'
         DATA     FIXERR,FIXERR
         DATA     3                 ORG = RANDOM
         DATA     8                 OUTIN
         DATA     1                 REL
PVDEV    RES      1                 DEVICE TYPE
         DATA     0                 RSTORE
         GEN,8,8,8,8  1,0,1,1
         TEXTC    ' '
         GEN,8,8,8,8  2,0,2,2
PVACCT   RES      2
         GEN,8,8,8,8  7,1,0,#SN
PVSN     RES      #SN
*
OPN:MON  GEN,8,24 X'14',F:MONDMP
         DATA     X'C7480001'
         DATA     FIXERR,FIXERR     IGNORE I/O ERRORS
         DATA     2                 KEYED
         DATA     2                 DIRECT
         DATA     2                 OUT
         DATA     2                 SAVE
         DATA     7                 KEYM
         DATA     X'00010202'       NO X'01' VLP - WILL GET ERR 14
DMPNAME  TEXTC    'MONDMP0'
         DATA     X'04010202'
         TEXT     ' 00100  '        EXPIRE 1 DAY HENCE
*
INBUFSIZ EQU      81
         DATA     'A'               VFC CHAR
INBUF    RES      (INBUFSIZ+3)/4
*
FBUFSIZ  EQU      40
FBUF     RES      (FBUFSIZ+3)/4
*
SBUFSIZ  EQU      8
*
*  TAURUS UNIT/CLUSTER TO DEVICE MNEMONIC CONVERSION TABLE
*
CLUSTER  TEXT     'A%#@:   '
         TEXT     'BCDEFG  '
         TEXT     'HIJKLM  '
         TEXT     'NOPQRS  '
         TEXT     'TUVWXY  '
         TEXT     'Z01234  '
         TEXT     '56789  '
#CLUS    EQU      BA(%)-BA(CLUSTER)
SBUF     RES      (SBUFSIZ+3)/4
*
PRBUF    RES      34                OUTPUT PRINT BUFFER
PRPOS    DATA     BA(PRBUF)         NEXT AVAILABLE BYTE
*
INCNT    RES      1
INPOS    RES      1
FLDFLG   DATA     0
ENDFLD   DATA     0
GETNCHK  DATA     0
M:SIFLG  DATA     0
ABRTCODE DATA     0
SAVBUF   DATA     -1
PARSERET RES      1
ECHODCB  RES      1
EASPD    DATA     0
MPOOLADR DATA     0
ACCT     RES      2
FNAME    RES      8
NXTF     RES      1
FIXNAME  RES      1
FIXACCT  RES      1
TEMP     RES      16
*
SCRL     RES      1
CMDL     RES      1
ORGL     RES      1
LDAL     RES      1
DESCL    RES      1
DIRCMD   RES      1
KEYLEVEL RES      1
KEYSIZE  RES      1
TYPEFLAG RES      1
LASTKEY  RES      1
ORDRFLAG RES      1
DUALFLAG RES      1
*
CBUFS    EQU      %-1
CURBUF   RES      1
PREVBUF  RES      1
PREV1BUF RES      1
NXTBUF   RES      1
#CBUFS   EQU      %-CBUFS-1
*
ADBUF1   RES      1
ADBUF2   RES      1
FDBUF1   RES      1
FDBUF2   RES      1
DBUF1    RES      1
DBUF2    RES      1
ADCMD    RES      1
FDCMD    RES      1
DATADA   RES      1
CURDATA  RES      1
FITBUF   RES      1
DIRBUF   RES      1
FITDA    RES      1
BUSYCNT  RES      1
BUSYFLAG RES      1
BLKSIZE  RES      1
BLKDISP  RES      1
FITVLPX  RES      1
VLP09    RES      1
VLP0C    RES      1
VLP0D    RES      1
ERRCODE  RES      1
CURMES   RES      1
DFLINKL  RES      1
LINKFLAG RES      1
SRCHKEY  RES      8
LKEY     RES      8
DABLK    RES      1
DADUAL   RES      1
FLAGS    RES      1
PREVFLAG RES      1
VERSFLAG DATA     0
LOCDA    RES      1
LOCDUAL  RES      1
DIRFDA   RES      1
LPCNT    DATA     0                 # LP BUFFERS WAITING
LPNXT    DATA     0                 NEXT LP BUFFER TO PUT MESSAGE IN
LPCUR    DATA     0                 NEXT LP BUFFER TO PRINT
LPDCTX   DATA     -1                LP DCT INDEX
LPBUF    RES      1                 ADDRESS OF FIRST LP BUFFER
LPFLAG   DATA     0                 PRINT ERRORS ONLY DURING HGP RECON
OCIOCNT  DATA     0                 # I/O'S QUEUED TO OC
MKEYIN   RES      3
FITFLAG  DATA     0
IDLEFLAG DATA     0                 0 = NOT IDLE
RAFLAG   DATA     T:RAREL           ZERO IF NO READ-AHEAD IN SYSTEM
OCREQ    DATA     0                 NON-ZERO IF UNSOLICITED BREAK
OCREQ1   DATA     0                 NON-ZERO IF OPERATOR COMMUN IN PROG
OCFLG    DATA     -1                NO SPECIAL SEQUENCE IN PROGRESS
HGP1     RES      1                 FIRST HGP COPY
HGP2     RES      1                 SECOND HGP COPY
HGPDISP  DATA     0
#PAGES   DATA     0                 # PAGES OBTAINED FOR HGPS
UBSWAPI  RES      1
UBC#     RES      1
WORKFLAG DATA     0
*
*  STATISTICS CELLS
*
SPINCNTT DATA     0                 # CALLS TO IOSPIN
SPINCNT  DATA     0                 # I/O SPIN REGS
IOCNT    DATA     0                 # I/O READ/WRITE CALLS
ERRCNT   RES      1                 # ERRORS DURING CURRENT COMMAND
ERRCNT1  RES      1                 # ERRORS FOR CURRENT GRANULE
#RECS    RES      1                 # RECORDS IN FILE
#RECS1   RES      1                 # RECORDS IN CURRENT GRANULE
#INTLOST DATA     0                 # INTERRUPTS LOST
BUFCNT   DATA     0                 # BUFFERS ALLOCATED
#READS   DATA     0
*
*
*
RELFDA   DATA     0
RBJIT    DATA     0
RBAJIT   DATA     0
*
COMINDX  RES      1
*
CUROPT   RES      1
MAILFLAG DATA     0
AUTOFLAG DATA     0
SNAPFLAG DATA     0
COMPFLAG DATA     1
*
*  HEXDUMP
*
DUPFLAG  RES      1
#COL     RES      1
#BYTES   RES      1
#BYTES1  RES      1
#SPACES  RES      1
*
*  BREAK INTERRUPT RECEIVER
*
INTBUSY  DATA     0                 SET WHEN IN INTERRUPT HANDLER
INTR     DATA     0                 # BREAKS RECEIVED SINCE INITIATION
INTR1    DATA     0                 # BREAKS WHILE INBUSY SET
INTP     DATA     0                 # EVENTS PROCESSED SINCE INTBUSY SET
INTP1    DATA     0                 # EVENTS PROCESSED THIS PASS
PULLEREG DATA     0                 ADDRESS OF REGISTERS IN TCB STACK
PULLEPSD DATA     0                 ADDRESS FO PSD IN TCB STACK
#IO      DATA     -#EASTACK
*
*  BUFFER TABLES
*
TBL      CNAME
         PROC
         LOCAL    T
T        SET      SCOR(CF(2),W,H,,B)
LF       EQU      %
         DISP     LF
         RES      (#BUF+T)/T+(T=1)
         PEND
#BUF      EQU     30
BUFMIN   EQU      8                 MINIMUM # BUFFERS
BUFMAX   DATA     0                 # BUFFERS ALLOCATED
BUFDA    TBL,W                      DISC ADDRESS AND FLAGS
BUFDUAL  TBL,W                      DUAL DISC ADDRESS
BUFADR   TBL,W                      VIRTUAL BUFFER ADDRESS
BUFINFO  TBL,W                      INFORMATION
BUFDACHK TBL,W                      LINK CHECK DISC ADDRESS
BUFTYPE  TBL,B                      END-ACTION TYPE
BUFCODE  TBL,B                      I/O FUNCTION CODE
BUFNRT   TBL,B                      # RETRIES REMAINING
BUFLINK  TBL,B                      INDEX OF NEXT BUFFER
*
         BOUND    8
BUFREE   DATA     %+1               FREE BUFFER STACK
         GEN,1,15,1,15  1,#BUF,1,0
         RES      #BUF
*
TYPCUR   RES      2                 CURRENT # BUFFERS USED
TYPMAX   RES      2                 MAX # BUFFERS ALLOWED
*
         DO       0
#GL      EQU      100
GL       RES      #GL
GLSIZE   DATA     0                 # USED ENTRIES
         FIN
*
DCTX     RES      64/4              CONVERT VOL # TO DCT INDEX
*
PT       EQU      %
         DO1      80
         DATA     0
DISCDCB  DATA     1
         DO1      8
         DATA     0
PAGE     RES,1    28
DISC     EQU      %-1
         RES      27
D1END    EQU      %-1               END OF DATA
         TITLE    '****  COMMAND/OPTION PROCS  ****'
         SPACE    2
*
*  COMMAND AND OPTION PROCS
*
         SPACE    2
COMTXT   CSECT    1
COMOPT   CSECT    1
COMLOC   CSECT    1
COMFLAG  CSECT    0
OPTTXT   CSECT    1
OPTOPT   CSECT    1
OPTLOC   CSECT    0
         SPACE    2
COMMAND  CNAME    0,COMTXT,COMOPT,COMLOC,COMFLAG,#COM
OPTION   CNAME    1,OPTTXT,OPTOPT,OPTLOC,COMFLAG,#OPT
         PROC
         LOCAL    I,J,R
         USECT    NAME(2)
         DO       TCOR(AF(1),S:C)=1
         TEXT     AF(1)
         ERROR,7,S:NUMC(AF(1))>4 'AF(1) > 4 CHARS'
         ELSE
         DATA     0
AF(1)    SET      NAME(6)+1
         FIN
*
R        SET      S:KEYS(3,*26,OPT,LOC,FLAG)
*
*  'OPT'
*
         USECT    NAME(3)
J        SET      0
I        DO       NUM(AF(R(3)))-1
J        SET      J|AF(R(3),I+1)
         FIN
         DATA     J||X'FFFFFFFF'
*
*  'LOC'
*
         USECT    NAME(4)
         DO       R(4)<=R(1)+1
         DO       NAME(1)=0
         B        AF(R(4),2)        'COMMAND'
         FIN
         ELSE                       'LOC' NOT PRESENT
         DO       NAME(1)=0
         ERROR,7,1 'MISSING KEYWORD ''LOC'''
         DATA     0                 'COMMAND MUST HAVE 'LOC'
         ELSE
         RES      1
         FIN
         FIN
*
*  'FLAG'
*
         DO       R(5)<=R(1)+1
         USECT    NAME(5)
AF(R(5),2) RES    1
         ELSE
         DO       NAME(1)=0
         USECT    NAME(5)
         RES      1
         FIN
         FIN
*
*  INCREMENT COUNTS OF # OF COMMANDS AND OPTIONS
*
         DO       NAME(1)=0
#COM     SET      #COM+1
         ELSE
#OPT     SET      #OPT+1
LF(1)    SET      OBIT
OBIT     SET      OBIT**1
         FIN
         PEND
         SPACE    2
OBIT     SET      1
#OPT     SET      0
#COM     SET      0
         TITLE    '****  COMMAND TABLES  ****'
         SPACE    2
*  DEFINE LEGAL COMMANDS AND THE OPTIONS WHICH MAY BE USED WITH EACH
*
*  'LOC' IS THE ADDRESS TO BRANCH TO AFTER PARSING THE INPUT LINE
*
*  'OPT' ARE THE OPTIONS WHICH ARE LEGAL WITH THE COMMAND
*
*  'FLAG' IS THE LOCATION TO SET NON-ZERO WHEN THE COMMAND IS ENCOUNTERED
         SPACE    2
         COMMAND  'FIX',(LOC,ACNDIR),(FLAG,FIXFLAG),;
                    (OPT,B:SN,B:FNAM,B:ACCT,B:AD,B:FD,B:75)
         COMMAND  'REMO',(LOC,ACNDIR),(FLAG,REMFLAG),;
                    (OPT,B:SN,B:FNAM,B:ACCT)
         COMMAND  'DUMP',(LOC,ACNDIR),(FLAG,DUMPFLAG),;
                    (OPT,B:SN,B:FNAM,B:ACCT,B:AD,B:FD,B:F,B:ALL,B:FIT)
         COMMAND  'CHEC',(LOC,ACNDIR),;
                    (OPT,B:SN,B:FNAM,B:ACCT,B:AD,B:FD)
         COMMAND  'HGPR',(LOC,HGPR),(OPT,B:SN),(FLAG,HGPRFLAG)
         COMMAND  'LIST',(LOC,LIST)
         COMMAND  'END',(LOC,EXIT)
         COMMAND  'MAIL',(LOC,MAIL),(OPT,B:YES,B:NO)
         COMMAND  'AUTO',(LOC,AUTO),(OPT,B:YES,B:NO)
         COMMAND  'SNAP',(LOC,SNAP),(OPT,B:YES,B:NO)
         COMMAND  'COMP',(LOC,COMP),(OPT,B:YES,B:NO)
         COMMAND  'PRIN',(LOC,SUPERCLS)
         TITLE    '****  OPTION TABLES  ****'
         SPACE    2
*  DEFINE LEGAL OPTIONS.
*
*  AF(1) IS EITHER A TEXT OPTION OR A SYMBOL WHICH IS SET TO
*    THE INDEX OF THIS OPTION INTO THE OPTION TABLES.
*
*  'OPT' IS THE LIST OF OPTIONS WHICH MAY ALREDY HAVE BEEN
*    ENCOUNTERED WHEN THIS OPTION IS.
         SPACE    2
B:AD     OPTION   'AD',(OPT,B:SN,B:F)
B:FD     OPTION   'FD',(OPT,B:SN,B:ACCT,B:F)
B:F      OPTION   'F',(OPT,B:SN,B:FNAM,B:ACCT,B:ALL,B:FIT,B:FD,B:AD)
B:ALL    OPTION   'ALL',(OPT,B:SN,B:FNAM,B:F)
B:FIT    OPTION   'FIT',(OPT,B:SN,B:FNAM,B:F)
B:SN     OPTION   X:SN    **SERIAL NUMBER
B:FNAM   OPTION   X:FNAM,(OPT,B:SN)    **FILE NAME AND ACCOUNT
B:ACCT   OPTION   X:ACCT,(OPT,B:SN)    **ACCOUNT WITHOUT FILE NAME
B:YES    OPTION   'YES'
B:NO     OPTION   'NO'
B:75     OPTION   '75',(OPT,B:SN)
         TITLE    '****  DCBS  ****'
         SPACE    2
M:LO     DSECT    1
M:LO     M:DCB    (DEVICE,'LP')
M:DO     M:DCB    (DEVICE,'LP')
M:OC     DSECT    1
M:OC     M:DCB    (DEVICE,'OC'),INOUT
F:FIX    DSECT    1
F:FIX    M:DCB    (FILE,'1234567890123456789012345678901'),(SN,#SN)
F:PV     DSECT    1
F:PV     M:DCB    (FILE,'1234567890123456789012345678901'),(SN,#SN)
         USECT    P1
         END      START

