*M*      FIX1     FIX PROCESSOR - REPAIRS FILES, DOES HGP RECONSTRUCTION
P        CSECT    1
D        CSECT    0
TBLSECT  CSECT    1
TXTSECT  CSECT    1
*
M:DO     DSECT    1
*
UTSPROC  SET      1
S69PROC  SET      1
MONPROC  SET      1
DISCBPROC SET     1
         SYSTEM   UTS
         SYSTEM   BPM
*
         PCC      0
,,FPT1:  M:PT     1                 FPT'S IN PROTECTED MEMORY
*
P:       EQU      P
D:       EQU      D
         SPACE    2
*P*  NAME:         FIX1
*P*
*P*  PURPOSE:      PROVIDE FACILITIES FOR THE EXAMINATION OF AND
*P*                REPAIR OF THE FILE SYSTEM
*P*
*P*  DESCRIPTION:  THE USER MAY CAUSE SELECTED FILES OR DIRECTORIES
*P*                TO BE DUMPED, CHECKED OR REPAIRED.
         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
DFDA     EQU      8
DDA      EQU      X'1FD'
DBLINK   EQU      X'1FE'
DFLINK   EQU      X'1FF'
NORETRY  EQU      X'400'
KEY      EQU      X'8000'
         SPACE    1
OCRDCNT  EQU      80
         SPACE    1
ADSCR    EQU      9
ADKSIZE  EQU      ADSCR+3+3+1
FDSCR    EQU      32
FDKSIZE  EQU      FDSCR+4+5
TDAFIT   EQU      1                 DISPLACEMENT INTO FIT X'0C' VLP OF TDA
LDAFIT   EQU      6
         TITLE    '****  ASSEMBLY SWITCHES  ****'
         SPACE    2
DEBUG    SET      1                 1 = DEBUG
         SPACE    2
VERS     SET      1                 1 = ALLOW USE ON B00 SYSTEMS
         SPACE    2
TAB      SET      X'05'             TAB CHAR FOR TXTC PROC
CR       SET      X'15'             CARRIAGE RETURN
         TITLE    '****  EXTERNAL DEFINITIONS  ****'
         SPACE    2
         DEF      D:                DATA ADDRESS
         DEF      P:                PROCEDURE ADDRESS
         DEF      PT:               PATCH AREA
         DEF      FPT1:             FPT AREA
         DEF      SNAP:             FOR PATCHING
         DEF      FL:IOP            FLAG:  I/O IN PROGRESS
         DEF      FLR:IOP           MASK:  RESET FL:IOP
         DEF      FL:SNAP           FLAG:  BUFFER HAS BEEN SNAPPED
         DEF      FLR:SNAP          MASK:  RESET FL:SNAP
         DEF      FL:UPDT           FLAG:  BUFFER IS UPDATED
         DEF      FLR:UPDT          MASK:  RESET FL:UPDT
         DEF      FL:EA             FLAG:  END-ACTION MUST BE PERFORMED
         DEF      FLR:EA            MASK:  RESET FL:EA
         DEF      FL:DUAL           FLAG:  DUAL HAS BEEN READ
         DEF      FLR:DUAL          MASK:  RESET FL:DUAL
         DEF      SPD               INTERNAL STACK POINTER DW
         DEF      CURFILE           CURRENT FILE BEING FIXED
         DEF      CURACCT           CURRENT ACCOUNT
         DEF      SN                PRIMARY SN OF CURRENT PACK SET
         DEF      INBUFSIZ          SIZE OF INPUT BUFFER
         DEF      INBUF             INPUT BUFFER
         DEF      PRBUF             LINE PRINTER BUFFER
         DEF      PRPOS             CURRENT POSITION IN PRBUF
         DEF      EASPD             END-ACTION STACK ADDRESS
         DEF      MPOOLADR          ADDRESS OF END-ACTION MPOOL
         DEF      LOGACCT           LOGON ACCOUNT
         DEF      TEMP              16 WORDS OF TEMP STORAGE
         DEF      SCRL              SIZE OF CURRENT KEYS
         DEF      CMDL              CURRENT DISPL INTO BUFFER
         DEF      ORGL              ORGANIZATION OF CURRENT FILE
         DEF      DIRCMD            DISPL INTO DIR BUFFER
         DEF      KEYLEVEL          EXPECTED MI LEVEL
         DEF      KEYSIZE           SIZE OF CURRENT KEY ENTRY
         DEF      TYPEFLAG          AD, FD, OR FILE
         DEF      CBUFS             START OF BUFFER POINTERS
         DEF      #CBUFS            # BUFFER POINTERS
         DEF      PREVBUF           BUFFER CONTAINING BLINK GRANULE
         DEF      FITBUF            BUFFER CONTAINING FIT
         DEF      DIRBUF            BUFFER CONTAINING DIRECTORY
         DEF      FITVLPX           ADDRESS OF FIT VLPS
         DEF      VLP09             LOC OF X'09' VLP
         DEF      VLP0C             LOC OF X'0C' VLP
         DEF      VLP0D             LOC OF X'0D' VLP
         DEF      ERRCODE           # OF LAST ERROR ENCOUNTERED
         DEF      CURMES            ADDRESS OF CURRENT MESSAGE
         DEF      LINKFLAG          SET IF NOT TO LINK CHECK
         DEF      SRCHKEY           KEY THAT FNDKEY IS TO SEARCH FOR
         DEF      SYNFLAG           SET IF SYNON FILE
         DEF      LPCNT             # LP I/O BUFFERS IN USE
         DEF      LPNXT             NEXT LP I/O BUFFER TO USE
         DEF      LPDCTX            LP DCT INDEX
         DEF      LPBUF             ADDRESS OF LP BUFFER
         DEF      LPFLAG            PRINT NOTHING, ERRORS OR ALL
         DEF      OCIOCNT           # I/O'S QUEUED TO OC
         DEF      FITFLAG           SET IF PROCESSING FIT
         DEF      OCREQ             SET IF UNSOLICITED BREAK RECEIVED
         DEF      #PAGES            # PAGES GOTTEN
         DEF      SPINCNTT          # CALLS TO IOSPIN
         DEF      SPINCNT           # I/O SPIN EVENTS
         DEF      IOCNT             # I/O READ/WRITE CALLS
         DEF      ERRCNT            # ERRORS DURING CURRENT COMMAND
         DEF      #RECS             # RECORDS ENCOUNTERED
         DEF      #RECS1            # RECORDS IN THIS GRANULE
         DEF      #INTLOST          # INTERRUPTS LOST
         DEF      BUFCNT            # BUFFERS ALLOCATED
         DEF      #READS            # I/O READS
         DEF      CUROPT            OPTION FLAGS FOR THIS COMMAND
         DEF      SNAPFLAG          SET IF TO DO FREPORT DUMP
         DEF      BUFREE            FREE I/O BUFFER POOL
         DEF      #BUF              MAX # I/O BUFFERS ALLOWED
         DEF      BUFMIN            MIN # I/O BUFFERS ALLOWED
         DEF      BUFMAX            # BUFFERS ALLOCATED
         DEF      TYPMAX            MAX # I/O BUFFERS OF EACH TYPE
         DEF      TYPCUR            CURRENT # I/O BUFFERS
         DEF      DCTX              VOL # TO DCT INDEX CONVERSION
         DEF      CLEANUP           EXIT CLEANLY TO MONITOR
         DEF      DCTSET            SET DCTX, MOUNT VOLUMES IF PRIV
         DEF      DCTSET1           SET UP VOL # TO DCTX CONVERSION TBL
         DEF      FILE20            RECONSTRUCT A FILE
         DEF      FIXERR            ERR/ABN FOR M:OPEN
         DEF      LDAL              DISC ADDR OF END OF FILE
         DEF      LOCDA             DISC ADDR FOUND BY FNDKEY
         DEF      LOCDUAL           DUAL DISC ADDR FOUND BY FNDKEY
         DEF      XOCRD             SPECIAL EN-ACTION CODE, OC READ
         DEF      XOCWRT            SPECIAL END-ACTION CODE, OC WRITE
         DEF      MESSOUT           PRINT MESSAGE, ABORT
         DEF      INPOS             CURRENT POSITION IN INBUF
         DEF      INTADR2           FAKE AN INTERRUPT
         DEF      LPIO              QUEUE AN I/O TO PRINTER
         DEF      ERROR             ERROR ON INPUT COMMAND
         DEF      #IO               # I/O'S IN PROGRESS
         DEF      #EASTACK          SIZE OF END-ACTION STACK
         DEF      ECHODCB           DCB TO WRITE TO USER
         DEF      SNAPDAT           SNAP FIX DATA
         DEF      NXTCHAR           GET NEXT CHAR FROM INBUF
         DEF      DISPFLG           SET IF TO DISP NAME/ACCOUNT
         DEF      REL               RELEASE MPOOL, BUFFER PAGES
         DEF      DUALRD            CHECK IF DUAL GRANULE READ
         DEF      GETFIELD          GET NEXT FIELD FROM INPUT BUFFER
         DEF      FBUF              LOC OF FIELD GOTTEN VIA GETFIELD
         DEF      ENDPROC2          FINISH PROCESSING OF COMMAND
         DEF      CALLNEWQ          QUEUE I/O VIA NEWQNWM, NO END-ACTION
         DEF      LPTAPE            SET IF OUTPUT ASSIGNED TO TAPE
         DEF      MOC2              MESSAGE TO PROMPT FOR HGPR OPTIONS
         DEF      ACCTSUM           SUMMARY FOR AN ACCOUNT
         DEF      FDHDFLG           >= ZERO IF ACCOUNT HEADER PRINTED
         DEF      CORESDCB          ZERO IF ECHODCB AND M:LO NOT SAME DEV
         DEF      ENVSIZE           # WORDS IN ONE ENVIRONMENT
         DEF      #GRAN             # GRANULES IN ONE FILE
         DEF      #FDGRAN           # GRANULES IN FILE DIRECTORY
         DEF      #FILGRAN          # GRANULES IN ALL FILES
         DEF      #RANFIT           # GRANULES OF RANDOM FILE FITS
         DEF      GAVALC            GRAN SIZE OF CYL THAT GAVAL'S IN
         DEF      GAVALL            WORD FOR COMPUTING CORRECT GAVAL/NGAVAL
         DEF      CCBDL             ACTUAL CCBD
         DEF      SRECL             SREC FROM FIT FOR COMPUTING CCBDL
         DEF      EOFCMD            CMD OF LAST ENCOUNTERED EOF FLAG
         DEF      EOFDA             DISC ADDR OF LAST ENCOUNTERED EOF FLAG
         DEF      BUFERR            NO BUFFERS ABORT
         TITLE    '****  EXTERNAL REFERENCES  ****'
         REF      ACNCFU            ACCOUNT DIR CFU
         REF      ACNTBL            TABLE OF ACCOUNT DIR DISC ADDRS
         REF      ADINIT            SET UP POINTERS FOR AD
         REF      ALLOCBUF          GET PAGES FOR I/O BUFFERS
         REF      ALLOCG            ALLOCATE GRANULE IN BIT MAP
         REF      AVRTBL            AVR TABLE
         REF      AVRTBLNE          # TAPES + PACKS
         REF      AVRTBLSIZ         # TAPES
         REF      BATAPE            FIRST TAPE DCT INDEX
         REF      BGRCFU            FIRST USER CFU
         REF      BIN2HEX           CNVRT BIN TO EBCDIC HEX
         REF      BOOTFLG           FLAG FOR SYSTEM UP YET
         REF      BUFWRT            WRITE OUT I/O BUFFER
         REF      CHKCON            VALIDATE CONSEC GRANULE
         REF      CHKDA             VALIDATE DISC ADDRESS
         REF      CFUSIZE           # WORDS PER CFU
         REF      DATERR            PRINT MESSAGE ON OC
         REF      DCT%MASK%1        MASK OFF DCTX FROM DISC ADDR
         REF      DCTSIZ            SIZE OF DCT TABLES
         REF      DCT1              DEVICE ADDRESS
         REF      DCT22             DISC DEVICE TYPE
         REF      DCT3              CHECK PARTITIONED FLAG
         REF      DCT4              DEVICE TYPE (TB:FLGS INDEX)
         REF      DEC2BIN           CONVERT EBCDIC DECIMAL TO BINARY
         REF      DELKEY            DELETE KEY
         REF      DISCLIMS          # SECTORS ON DEVICE
         REF      DISCRD            READ DISC INTO I/O BUFFER
         REF      DISCWRT           WRITE DISC FROM I/O BUFFER
         REF      DMPFLG            HEXDUMP FLAG
         REF      DOPRINT           WRITE MESSAGE TO USER
         REF      DUMPB             DUMP PRBUF TO USER
         REF      DUMPBUF           DUMP PRBUF TO LINE PRINTER
         REF      DUMPHGP           DUMP ALLOCAT OR PRIV PACK HGPS
         REF      BADDA             TO SET BAD DISC ADDRESS
         REF      ERR#51            AND ITS ERROR MESSAGE
         REF      FDINIT            INITIALIZE POINTERS FOR FD
         REF      FILCFU            CFU FOR READING FILE DRCTRY
         REF      FILEND            HGP RECON, DONE WITH FILE
         REF      FITCHK            VALIDATE FIT
         REF      FITNAME           BA OF FILE NAME IN FIT
         REF      FNDHGP            FIND HGP GIVEN DCT INDEX
         REF      FNDHGP1           FIND HGP IN LOW CORE
         REF      FNDKEY            LOCATE SPECIFIC KEY
         REF      FPMC              FREE PAGE MAP CONSTANT
         REF      FREPORT           DUMP USER WHO GOT 75 ERROR
         REF      GETBUF            GET I/O BUFFER FROM FREE POOL
         REF      GETOCU            GECOME OPN/CLS USER
         REF      GRANERR           REPORT ERROR ON GRANULE
         REF      HEXDUMP           DUMP CORE IN HEX
         REF      HEX2BIN           CNVRT HEX EBCDIC TO BINARY
         REF      HGP               ADDR OF IN-CORE HGP HEADERS
         REF      HGPR              PERFORM PRIV PACK HGP RECON
         REF      INITBUF           INITIALIZE PRBUF POINTERS
         REF      IOQUEUE           QUEUE AN I/O
         REF      IORETRY           RETRY AN I/O
         REF      IOSPIN            WAIT FOR I/O TO COMPLETE
         REF      J:ACCN            ACCOUNT IN JIT
         REF      J:DDLL            DYNAMIC DATA LOWER LIMIT
         REF      J:DDUL            DYNAMIC DATA UPPER LIMIT
         REF      J:DLL             DATA LOWER LIMIT
         REF      J:EXTENT          EXIT CONTROL FLAGS
         REF      J:EUP             END USER PAGE
         REF      J:JIT             JIT ADDRESS
         REF      J:TCB             TCB ADDRESS
         REF      J:TELFLGS         FLAGS
         REF,1    JB:BCP            LOWEST COMMON PAGE
         REF      JBUPVP            FIRST USER PAGE #
         REF      JX:CMAP           USER'S VIRT TO PHYS PAGE TABLE
         REF      KEYIN             PERFORM KEYIN TO OP CONSOLE
         REF      LFGUN             USER # OF FREPORT
         REF      LOCC2             LOCATE VLP IN DCB
         REF      M:C               DCB
         REF      M:OC
         REF      M:SI              DCB TO READ COMMANDS
         REF      M:UC              DCB TO WRITE TO ONLINE USER
         REF      MADKEY            MESSAGE 'ACCOUNT ='
         SREF     MODE              # COC BREAKS RECEIVED
         REF      MOVDEC            CNVRT BIN TO DEC, PUT IN PRBUF
         REF      MOVHEX            CNVRT BIN TO HEX, PUT IN PRBUF
         REF      MOVTXT            MOVE TEXT TO PRBUF
         REF      MOVTXTC           MOVE TEXTC TO PRBUF
         REF      NEWQNWM           QUEUE I/O NO WAIT
         REF      NOPAGES           INSUFFICIENT CORE
         REF      NORECON           TRAP DURING HGP RECON
         REF      PRFILE            PRINT FILE NAME AND ACCOUNT
         REF      PRINT             PRINT MESSAGE ON LINE PRINTER
         REF      PRKEY             MOVE KEY TO PRBUF
         REF      PRT               JIT DISPL OF OUTPUT SYMB PRIO
         REF      PUTDECR           DEC NUMBER RIGHT JUSTIFIED
         REF      PUTMES            TEXT AT GIVEN COLUMN #
         REF      PUTMESC           TEXTC AT GIVEN COL #
         REF      QUEUE             QUEUE I/O VIA DCB
         REF      R:OCR             OPN/CLS USER SUB-QUEUE
         REF      RBG               RELEASE GRANULE
         REF      RBUF              POINTER TO RECOVERY BUFFER
         REF      RBUFSIZE          # PAGES IN RECOVERY BUFFER
         REF      RELBUF            RELEASE I/O BUFFER TO FREE POOL
         REF      RELFIT            RELEASE FIT
         REF      RELOCU            RELEASE OPN/CLS USER STATUS
         REF      RELPACKS          RELEASE EXCL USE OF PACKS
         REF      RMB               RELEASE MPOOL BUFFER
         REF      S:BUIS
         REF      S:CUN             CURRENT USER #
         REF      S:OUIS
         REF      SAVBUF            USERS WAITING FOR FREPORT
         REF      SB:RQ             RESOURCE SUB-QUEUE HEAD
         REF      SNAPGRAN          DUMP I/O BUFFER IN HEX
         REF      SYSINIT           SYSTEM INITIALIZATION
         REF      TB:FLGS           DEVICE TYPE FLAGS
         REF      TBLXPSD           BUILD OUTPUT BUFFER
         REF      TRUNCATE          TRUNCATE FILE OR DIRECTORY
         REF      TRUNC10           TRUNCATE DIRECTORY AT FDA
         REF      TSTACK            TEMP STACK IN JIT
         REF      UB:ASP            ASSOCIATED SHARED PROCESSOR
         REF      UB:DB             ASSOCIATED DEBUGGER
         REF      UB:MF             I/O COUNT
         REF      UH:DL             USER FLAGS
         REF      UH:FLG2           MORE USER FLAGS
         REF      VALBUF            VALIDATE WORDS 0-2 OF BUFFER
         REF      75BUF             USERS QUEUED FOR FREPORT
         REF      ERR#10
         REF      ERR#11
         REF      ERR#12
         REF      ERR#22
         REF      ERR#60
         REF      ERR#99
         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
SNAP     CNAME    0
SNAPX    CNAME    1
         PROC
LF       PUSH     R4
         BAL,R4   SNAPDAT
         DO       TCOR(AF,S:C)=1
         TEXTC    AF
         ELSE
         DATA     AF
         FIN
         DO1      NAME=1
         M:XXX
         PEND
         SPACE    2
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
         SPACE    2
BUILD    CNAME
         PROC
         LOCAL    MAIN,TBL,TYPE,ADDR
LF(1)    SET      %
MAIN     SET      %
         DO       SCOR(CF(2),E)
TBL      SET      AF
         ELSE
         USECT    TBLSECT
TBL      SET      %
LF(2-SCOR(CF(2),L))  SET  %
*
I        DO       NUM(AF)           PROCESS ALL AF ENTRIES
TYPE     SET      SCOR(AF(I,1),TEXT,HEX,DEC,RHEX,RDEC,SPACE,;
                  TXT,FILL,DUMPBUF,DUMPB,DUMPECHO)
ADDR     SET      S:UFV(AF(I,2))
         DO       TYPE=1&TCOR(AF(I,2),S:C)=1
         USECT    TXTSECT
ADDR     SET      %
         TEXTC    AF(I,2)           GENERATE THE SPECIFIED TEXT
         USECT    TBLSECT
         FIN
         DO1      TYPE=8            IF FILL
ADDR     SET      AF(I,2)+(AF(I,4)-AF(I,3))**8
*
         GEN,1,7,4,1,19  AFA(I,2),AF(I,3),TYPE,I=NUM(AF),ADDR
*
         FIN
*
         USECT    MAIN
         FIN
         DO       SCOR(CF(2),L)=0
         XPSD,2   TBLXPSD
         DATA     TBL
         FIN
         PEND
         TITLE    '****  INITIALIZATION  ****'
         SPACE    2
         USECT    P
START    EQU      %
         LCI      2
         LM,R8    J:ACCN
         STM,R8   LOGACCT           SAVE LOG-ON ACCOUNT
         LI,R8    M:LO
         STW,R8   ECHODCB           ASSUME BATCH
*
         LW,R2    J:EUP             PUT RBUF AT TOP OF MEMORY
         AI,R2    -RBUFSIZE+1
         SLS,R2   9                 # WORDS
         STW,R2   RBUF              ADDRESS OF START OF BUFFER
         LI,R2    63
         STB,R2   DCTX,R2           SET UP DCTX FOR PUBLIC
         BDR,R2   %-1
         STB,R2   DCTX
*
         M:PC     PC                PROMPT CHARACTER
         M:DEVICE M:DO,VFC
         M:DEVICE M:LO,VFC
         M:SETDCB M:LO,(ERR,FIXERR),(ABN,FIXERR)
         M:SETDCB M:DO,(ERR,FIXERR),(ABN,FIXERR)
         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
*
         LC       J:JIT
         BCS,4    START4            GHOST
         BCR,8    START5            BATCH
         LI,R8    M:UC
         STW,R8   ECHODCB           ONLINE
         M:DEVICE M:UC,VFC
         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
         M:XCON   XCONADR           EXIT CONTROL
         M:INT    INTADR            INTERRUPT CONTROL
         LW,R4    S:CUN
         DISABLE                    **** DISABLE
         LH,R2    UH:FLG2,R4
         OR,R2    =X'2000'          SET 'DON'T OUTSWAP' FLAG
         STH,R2   UH:FLG2,R4
         ENABLE                     **** ENABLE
         LC       J:JIT
         BCS,4    GHSTINIT          GHOST
         BCS,8    OPNLO             ONLINE
*
BTCHINIT M:READ   M:C,(BUF,INBUF),(SIZE,80),(ERR,RDLOOP),(ABN,RDLOOP)
OPNLO    M:OPEN   M:LO,OUT,SAVE
         LI,R3    3
         CS,R3    M:LO
         BNE      RDLOOP            M:LO NOT DEVICE, NOT SAME AS ECHODCB
         M:DEVICE M:LO,(CORRES,*ECHODCB)
         STW,R8   CORESDCB          ZERO IF NOT SAME DEVICE
LOOPEND  LC       J:JIT
         BCS,4    GHSTI1            READ IF NOT GHOST
         SPACE    3
*
*  BATCH/ONLINE  -  READ AND PROCESS COMMANDS
*
RDLOOP   M:PC     PC                RESTORE PROMPT CHAR
         BAL,R11  READ              READ A RECORD
         BCS,1    EXIT              EOF
*
RDLOOP2  LI,R11   0
         STW,R11  SRCHKEY
         STW,R11  DIRBUF
         STW,R11  KEYLEVEL
         STW,R11  LOCDA
         STW,R11  FITBUF
         STW,R11  #FILES
         STW,R11  #FDS
         STW,R11  #FDGRANS
         LI,R2    #CBUFS
         STW,R11  CBUFS,R2
         BDR,R2   %-1
*
         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
         STW,R11  EOFDA-1           CLEAR EOF FLAGS
         STW,R11  EOFDA
*
         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
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
*D*  NAME:         ACNDIR
*D*
*D*  REGISTERS:    ALL VOLATILE
*D*
*D*  CALL:         BRANCH FROM FNDCOM
*D*
*D*  DESCRIPTION:  PROCESS FIX/CHECK/REMOVE/DUMP/FIND COMMANDS.
*D*                ALLOCATE I/O BUFFERS.  IF 'VTOC' OR 'CFU'
*D*                OPTIONS SPECIFIED, GO TO APPROPRIATE ROUTINE.
*D*                IF 'AD' OR 'FD' NOT SPECIFIED AND COMMAND NOT
*D*                'REMOVE', GO TO LOC FIT TO OPEN DIRECTLY
*D*                TO FILE (NO DIRECTORY SEARCH IS DONE).
*D*                BECOME OPEN/CLOSE USER.  BUILD ACCOUNT
*D*                DIRECTORY KEY TO SEARCH FOR.  CALL SRCHDIR
*D*                TO SEARCH ACCOUNT DIRECTORY FOR THE SPECIFIED
*D*                ACCOUNT.  IF FOUND AND FILE DIRECTORY IS TO BE
*D*                SEARCHED, SET UP FILE NAME KEY AND SEARCH FOR
*D*                IT.
         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   -6
         LI,R2    3
         STB,R11  TYPMAX,R2         ALL BUT 6 BUFFERS ARE
         MTB,6    TYPMAX              TYPE 3, OTHERS ARE TYPE 0
         LI,R11   -1
         STW,R11  FDHDFLG
         LW,R10   CUROPT            GET OPTION FLAGS
         CI,R10   B:VTOC
         BANZ     FIXVTOC           'VTOC' SPECIFIED
         CI,R10   B:CFU
         BANZ     FIXCFU            'CFU' SPECIFIED
         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
,PVREL   M:CLOSE  F:PV,REL,REM
*
ACNDIR4  BAL,R11  DCTSET
         LW,R10   CUROPT
         CI,R10   B:FD
         BANZ     CHKFD             SEE IF ALL FILE DIRECTORIES
         CI,R10   B:HGPS
         BANZ     DUMPHGP           DUMP ALLOCAT OR PRIV PACK HGPS
ACNDIR5  CI,R10   B:AD+B:FD         IF EITHER 'AD' OR 'FD'
         BANZ     ACNDR15             SPECIFIED, SEARCH DIRECTORIES
         CI,R10   B:XDA
         BANZ     DISCADDR          ONE GRANULE THING
         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
         OR,R11   FINDFLAG
         BNEZ     ACNDR15           SEARCH DIRECTORIES IF REMOVE
         B        FIT
*
ACNDR10  LI,R15   B:FNAM
         STS,R15  CUROPT            FORCE FIT TO BE FOUND
         LW,R15   DIRBUF
         BNEZ     FILERR            GIVE UP - BEEN HERE BEFORE
*
ACNDR15  BAL,R15  GETOCU            BECOME OPEN/CLOSE USER
         BAL,R11  ADINIT            SET UP ACCOUNT DIR VALUES
*
         LI,R2    0
         STW,R2   FDLOC
         STW,R2   FITLOC
         STW,R2   FINDLOC
*
         LCI      2
         LM,R2    CURACCT           CURRENT ACCOUNT
         LW,R11   SN
         BEZ      ACNDR20           PUBLIC
         LW,R1    =X'0B404040'      FORM PRIVATE AD KEY
         LCI      3
         STM,R1   SRCHKEY           STORE KEY TO SEARCH FOR
         B        ACNDR30
*
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  STW,R8   ADLOC             SAVE AD FDA
         BAL,R11  SRCHDIR           SEARCH ACCOUNT DIRECTORY
         B        ENDPROC2          ERROR
*
         LW,R11   FINDLOC
         BEZ      %+2               NOTHING FOUND
         STW,R11  ADLOC
         LW,R11   LOCDA             FDA OF FD
         STW,R11  FDLOC
*
         LI,R11   B:FD+B:FNAM+B:ACCT   IS FILE DIRECTORY TO BE SEARCHED
         CW,R11   CUROPT
         BAZ      ACNDR40           NO
*
         LW,R9    LOCDA             WAS ACCOUNT FOUND
         BEZ      FILDIR20          NO
         LW,R11   REMFLAG
         BEZ      ACNDR37           COMMAND NOT REMOVE
         LI,R11   B:FNAM            WAS A FILE NAME SPECIFIED
         CW,R11   CUROPT
         BANZ     ACNDR37           YES - GO FIND FILE NAME IN FD
         LW,R7    DIRBUF            NO - REMOVE FILE DIRECTORY
         BAL,R11  DELKEY              NAME FROM ACCOUNT DIRECTORY
         STW,R11  FILCFU+ACNDISP    ZAP CURRENT FILCFU POINTERS
         B        ENDPROC2
*
ACNDR37  BAL,R11  FDINIT            SET UP FD VALUES
         LI,R8    BA(CURFILE)
         LW,R9    =X'20000000'+BA(SRCHKEY)  MOVE CURRENT FILE NAME
         MBS,R8   0                   TO SEARCH KEY
         LW,R8    LOCDA             MASTER DISC ADDRESS
         BLZ      ENDPROC2          THE KEY HAD AN ERROR
         LW,R9    LOCDUAL           DUAL DISC ADDRESS
         BAL,R11  SRCHDIR           SEARCH DIRECTORY
         B        ENDPROC2
         LW,R11   FINDLOC
         BEZ      %+2
         STW,R11  FDLOC
         LW,R11   LOCDA
         STW,R11  FITLOC
*
         LI,R9    B:FNAM
         CW,R9    CUROPT
         BAZ      ACNDR40           FILE NAME NOT SPECIFIED
         LW,R9    LOCDA             WAS FILE FOUND
         BEZ      FILE99            NO
         LW,R11   FINDFLAG
         BEZ      FIT               PROCESS FILE IF 'FIND' NOT SPECIFIED
ACNDR40  LW,R11   FINDFLAG          WAS COMMAND 'FIND'
         BEZ      ENDPROC2          NO
         LI,R4    BA(MAD)
         BAL,R10  MOVTXTC
         LW,R2    ADLOC             ACCOUNT DIRECTORY DISC ADDRESS
         BAL,R10  MOVHEX
         LW,R2    FDLOC
         BEZ      ACNDR42           NO FILE DIRECTORY FOUND
         LI,R4    BA(MFD)
         BAL,R10  MOVTXTC
         BAL,R10  MOVHEX
         LW,R2    FITLOC
         BEZ      ACNDR42           NO FIT FOUND
         LI,R4    BA(MFIT)
         BAL,R10  MOVTXTC
         BAL,R10  MOVHEX
ACNDR42  BAL,R15  DUMPB
         B        ENDPROC2
*
FILDIR20 LI,R14   MNOSACCT          'NO SUCH ACCOUNT'
FILDIR30 BAL,R11  DOPRINT
         LI,R11   -1                SUPRESS # ERRORS MESSAGE
         STW,R11  ERRCNT
*
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
         LW,R15   ERRCNT
         BLZ      LOOPEND           DON'T REPORT # ERRORS
         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
*D*  NAME:         CHKFD
*D*
*D*  DESCRIPTION:  IF SPECIFIC ACCOUNT WAS SPECIFIED, RETURN TO
*D*                ACNDIR5.  OTHERWISE, ALL FILE DIRECTORIES ARE
*D*                TO BE PROCESSED.  PRINT HEADER MESSAGE.
*D*                PROCESSING LOOP:  LOCATE NEXT FILE DIRECTORY
*D*                  FDA FROM ACCOUNT DIRECTORY.  PROCESS ENTIRE
*D*                  DIRECTORY.  PRINT ACCOUNT #, #FILES,
*D*                  # FD GRANULES.  IF ONLINE USER PUSHED BREAK
*D*                  KEY, PRINT THE MESSAGE TO BOTH LP AND USER,
*D*                  OTHERWISE LP ONLY.  IF THERE IS A USER IN
*D*                  SOCU (STATE WAITING TO BECOME OPEN/CLOSE USER),
*D*                  CALL RELOCU TO RELEASE OPEN/CLOSE STATUS.
*D*                REPEAT LOOP UNTIL NO MORE ACCOUNTS.
         SPACE    1
CHKFD    CI,R10   B:ACCT
         BANZ     ACNDIR5           SPECIFIC ACCOUNT
*  BUILD LINE PRINTER HEADER
         BUILD    (TEXT,MACCT,10),(TEXT,MFILES,23),(TEXT,MFDGRAN,36),;
                  (DUMPBUF,'C')
*
         MTB,1    TYPMAX
         LI,R2    3
         MTB,-1   TYPMAX,R2         GIVE ONE MORE TYPE 0
         LI,R2    0
         BAL,R15  GETBUF
         STW,R7   DIRBUF
         LW,R8    ACNCFU+FDA        ACCOUNT DRCTRY FDA
         LW,R9    ACNCFU+DFDA       DUAL FDA
         LW,R2    SN
         BEZ      CHKFD10           PUBLIC
         LI,R8    DPADFDA           PRIV PACK AD FDA
         LI,R9    0
*
CHKFD10  XW,R8    BUFDA,R7          SET NEW DISC ADDR
         AND,R8   M24
         STW,R8   BUFDACHK,R7       SET LINK CHECK DISC ADDR
         AND,R9   M24
         STW,R9   BUFDUAL,R7
         LI,R3    MIDIS
         STW,R3   ADCMD
CHKFD15  BAL,R15  GETOCU            BECOME OPEN/CLOSE USER
         BAL,R11  ADINIT
         LW,R7    DIRBUF
         STW,R7   LINKFLAG          ENABLE LINK CHECKING
         BAL,R11  DISCRD
         BAL,R11  IOSPIN
         LW,R6    BUFADR,R7
         BAL,R10  VALBUF
         BNEZ     CHKFD80
*
CHKFD20  BAL,R11  ADINIT
         LW,R7    DIRBUF
         LW,R6    BUFADR,R7
         LI,R2    -1
         STW,R2   SRCHKEY           FIND NEXT KEY
         LW,R3    ADCMD
         STW,R3   CMDL
         BAL,R11  FNDKEY
         B        CHKFD50           FOUND NEXT KEY
         BNEZ     CHKFD80           ERROR
*  NO MORE KEYS IN THIS GRANULE
         LW,R7    DIRBUF
         LW,R6    BUFADR,R7
         LW,R8    FLINK,R6
         LW,R9    DFLINK,R6
         AND,R8   M24
         BEZ      CHKFD70           ALL DONE
         LW,R6    BUFDA,R7          SAVE BLINK
         BAL,R15  RELBUF            WRITE IF UPDATED
         LI,R2    0                 GET ANOTHER BUFFER
         BAL,R15  GETBUF
         BEZ      BUFERR
         STW,R6   BUFDA,R7
         STW,R7   DIRBUF
         B        CHKFD10
*
CHKFD80  LI,R14   MADERR
         BAL,R11  DOPRINT
         MTW,1    ERRCNT            COUNT AN ERROR
CHKFD70  RES
         LW,R11   #FILES            DID WE GET ANY
         BEZ      ENDPROC2          NO
         BUILD    (FILL,'-',7,42),(DUMPBUF)
         BUILD    (RDEC,*#FDS,12),(TEXT,' ACCTS'),;
                  (RDEC,*#FILES,27),(RDEC,*#FDGRANS,42),;
                  (DUMPB,'A')
         B        ENDPROC2
*
CHKFD50  LW,R3    CMDL
         AI,R3    ADKSIZE           INCR TO NEXT KEY
         SLS,R6   2                 BYTE ADDRESS OF BUFFER
         MTW,0    SN
         BEZ      %+3
         AI,R6    3                 DIFFERENT KEY FORMAT FOR PRIV
         AI,R3    5
         STW,R3   ADCMD
         AW,R6    CMDL              BA OF THIS KEY
         LW,R7    =X'08000000'+BA(CURACCT)
         MBS,R6   1                 MOVE ACCOUNT
         LI,R6    0
         STW,R6   SRCHKEY           SEARCH ALL OF DIRECTORY
         STW,R6   EOFDA             NO EOF YET
         BAL,R11  FDINIT
         LW,R8    LOCDA
         LW,R9    LOCDUAL
         BAL,R11  SRCHDIR
         BAL,R11  RBUFS             RELEASE BUFFERS IF ERROR
         BUILD    (TXT,CURACCT,10)
         LW,R1    #RECS             MAKE ACCUMULATIONS
         AWM,R1   #FILES
         LW,R1    #FDGRAN
         AWM,R1   #FDGRANS
         MTW,1    #FDS
         BUILD    (RDEC,*#RECS,27),(RDEC,*#FDGRAN,42)
         LI,R15   CHKFD55           RETURN
         LI,R10   0
         XW,R10   DISPFLG           DOES USER WANT TO SEE WHERE WE ARE
         BEZ      DUMPBUF           NO - LP ONLY
         B        DUMPB             YES - LP AND USER CONSOLE
CHKFD55  LI,R4    R:OCR
         LB,R5    SB:RQ,R4          ARE THERE ANY USERS IN SOCU
         BEZ      CHKFD20           NO
         BAL,R11  RELOCU            YES - LET THEM HAVE OPNCLSUS
         B        CHKFD15
         PAGE
         SPACE    2
         PAGE
*
*        DISCADDR:
*        DUMP OR FIX A GRANULE
*        IF FIX, ASSOCIATE DELTA TO DO IT
*
DISCADDR RES
         LW,R8    HEXDA             CHECK IT
         BAL,R11  CHKDA
         BCR,15   DISC30
         LI,R2    0                 GET A BUFFER
         BAL,R15  GETBUF
         STW,R7   CURBUF
         STW,R8   BUFDA,R7
         BAL,R11  DISCRD
         BAL,R11  IOSPIN
         MTW,-1   TYPEFLAG          NO ACCOUNT
         BAL,R11  SNAPGRAN          DUMP IF DUMP
         CAL1,4   ASSDEL
DISC05   CAL1,4   DISDEL
         MTB,-1   ERRCNT
         M:INT    INTADR            RESTORE BREAK CONTROL
         B        ENDPROC2          FIX USES DELTA
*
ASSDEL   GEN,8,7,17 4,1,%+3
         TEXTC    'DELTA'
         DATA     DISC10            GET
         DATA     DISC20            PUT
         DATA     DISC05            RETURN
         DATA     0
DISDEL   GEN,8,24 5,0
         TEXTC    'DELTA'
*
DISC10   PUSH     R7
         LW,R7    CURBUF
         CI,R3    -512
         BANZ     DISC15            ERR
         AW,R3    BUFADR,R7
         LW,R3    0,R3
DISC12   PULL     R7
         LCI      0
         B        0,R4
DISC15   PULL     R7
         LCI      15
         B        0,R4
*
DISC20   PUSH     R7
         MTW,0    FIXFLAG
         BEZ      DISC15
         LW,R7    CURBUF
         CI,R3    -512
         BANZ     DISC15
         PUSH     R3
         AW,R3    BUFADR,R7
         STS,R0   0,R3
         LW,R3    FL:UPDT
         STS,R3   BUFDA,R7
         PULL     R3
         B        DISC12
*
DISC30   LI,R14   MNOSGRAN
         B        FILDIR30
GHSTIDLE EQU      %
         BAL,R11  FREPORT           PROCESS ANY USERS WAITING
         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   MTW,1    IDLEFLAG          SET IDLE
         M:WAIT   50*30             SLEEP 30 MINUTES
         LI,R11   0
         STW,R11  IDLEFLAG          SET NOT IDLE
         STW,R11  DISPFLG
         B        GHSTIDLE
         SPACE    4
*D*  NAME:         FIT
*D*
*D*  DESCRIPTION:  OPEN DCB INOUT TO A FILE, PROCESS THE FILE ACCORDING
*D*                TO THE COMMANDS GIVEN.
*D*                M:OPEN CAL IS ISSUED, WITH NXTF FLAG SET IN FPT
*D*                IF USER DID NOT SPECIFY A FILE NAME (ALL FILES
*D*                IN AN ACCOUNT OR IN ENTIRE FILE SYSTEM ARE TO
*D*                BE PROCESSED).  FILE NAME AND ACCOUNT ARE MOVED
*D*                TO CURFILE AND CURACCT.  NXTA FLAG IN FPT IS
*D*                RESET.  IF NO ERRORS ON OPEN, PRINT HEADER
*D*                IF THIS IS FIRST FILE IN ACCOUNT.  PRINT FILE
*D*                NAME AND ACCOUNT ON USER TERMINAL IF BREAK KEY
*D*                WAS PRESSED.  GET FIT DISC ADDRESS FROM CFU.
*D*                READ AND VALIDATE FIT.  IF 'FIT' OPTION
*D*                SPECIFIED, EXIT.  OTHERWISE, PROCESS ACCORDING
*D*                TO ORGANIZATION TYPE.
         SPACE    1
FIT      EQU      %
         LW,R7    DIRBUF
         BEZ      FILE10            HAVEN'T SEARCHED DIRECTORY
         LW,R8    LOCDA             MOVE FIT DISC ADDRESS
         BEZ      FILE99            NO SUCH FILE FOUND
         LW,R11   REMFLAG
         BEZ      FILE20            COMMAND NOT 'REMOVE'
         BAL,R11  DELKEY            REMOVE FILE NAME FROM FD
         B        ENDPROC2
*
FILE10   BAL,R11  RELOCU            DON'T ISSUE M:OPEN WHILE OPNCLSUS
         LI,R9    3
         STW,R9   BUSYCNT           # TIMES TO TRY IF FILE BUSY
FILE12   LI,R1    0                 RESET ERROR FLAG
         LW,R4    NXTF
FILE12A  LI,R5    X'400'
         STS,R4   OPNFIX+1          SET OR RESET NXTF FLAG
         LI,R5    1                 OPEN INPUT IF NOT FIXING
         MTW,0    FIXFLAG
         BEZ      %+2
         LI,R5    4
         STW,R5   OPNFIX+4
         M:OPEN,E OPNFIX            OPEN THE FILE
         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
         LI,R4    0
         LW,R5    Y008
         STS,R4   OPNFIX            RESET NXTA FLAG
         STW,R4   SYNFLAG
         STW,R4   #GRAN
         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
         MTW,-1   BUSYCNT
         BEZ      FILEX2            GIVE UP
         M:WAIT   2                 WAIT A WHILE
         LI,R4    0
         B        FILE12A           TRY AGAIN
*
FILE15   M:TRUNC  F:FIX             RELEASE ANY BUFFERS
         LI,R4    0
         LW,R5    Y008
         CW,R5    OPNFIX            CHECK IF NXTA SET
         STS,R4   OPNFIX            RESET IT
         BAZ      FILE16            WAS NOT SET
         LI,R4    BA(MADKEY)
         BAL,R10  MOVTXTC           'ACCOUNT ='
         LI,R4    BA(CURACCT)
         LI,R5    8                 # BYTES
         BAL,R10  MOVTXT            MOVE ACCOUNT TO PRINT BUFFER
         BAL,R15  DUMPBUF
         LI,R15   0
         STW,R15  #FDGRAN           ZERO # FILE DIR GRANULES
         STW,R15  #FILGRAN          # FILE GRANULES
         STW,R15  #RANFIT           # RANDOM FILE FITS
         STW,R15  EOFDA             CLEAR FILE DIRECTORY EOF LOC
         LI,R15   -1
         STW,R15  FDHDFLG           NO HEADER PRINTED YET
*
FILE16   LI,R11   0
         XW,R11   DISPFLG
         BEZ      %+2
         BAL,R11  PRFILE            PRINT FILE NAME AND ACCOUNT
*
         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
         AND,R8   M24               SCRUB EMPTY FILE FLAG
FILE20   LI,R11   0
         STW,R11  #RECS             # RECORDS IN THIS FILE
         STW,R11  #GRAN             # GRANULES IN THIS FILE
         STW,R8   FITDA             SAVE ADDRESS OF FIT
         AI,R8    0
         BLZ      FILEX2            KEY WAS FOUND BUT HAD AN ERROR
         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      BUFERR            ERROR - NO BUFFER
         STW,R7   FITBUF
FILE30   LW,R8    FITDA
         STW,R8   BUFDA,R7
         LI,R8    0
         STW,R8   VLP0C
         STW,R8   SYNFLAG
         STB,R8   BUFLINK,R7        MAKE SURE LINK IS ZERO
         BAL,R11  DISCRD
         BAL,R11  IOSPIN
         LW,R15   BUFINFO,R7        COMPLETION CODE
         BNEZ     RANERR            HARDWARE READ ERROR
         BAL,R11  FITCHK            VALIDATE FIT
         STW,R11  LINKFLAG          ENABLE LINK CHECKING
         BNEZ     FILERR            BAD FIT
         LI,R7    0
         XW,R7    DIRBUF
         BEZ      %+2
         BAL,R15  RELBUF            RELEASE DIRECTORY BUFFER
         LW,R7    FITBUF
         BAL,R11  SNAPGRAN
         LH,R11   CURFILE
         CI,R11   X'0100'           IS IT FUNNY FILE
         BE       FILEX2            YES - IGNORE IT
         LW,R11   HGPRFLAG
         BNEZ     FILE38            BR IF HGP RECON
         LI,R11   B:FIT
         CW,R11   CUROPT
         BANZ     FILEX2            EXIT IF ONLY FIT WANTED
         LW,R11   Y002
         CW,R11   F:FIX
         BANZ     FILE40
         B        FILE10            GO OPEN FILE
*
FILE38   LW,R11   SYNFLAG
         BNEZ     FILEX2            DONE IF SYNONYMOUS FILE
         LW,R8    FITDA             ALLOCATE FIT GRANULE
         BAL,R11  ALLOCG            NOW SO FILE IS DELETED IF DUALLY
         BCS,11   RANERR            ALLOCATED
*
FILE40   LI,R2    MFILE
         STW,R2   CURMES            CURRENT MESSAGE = 'FILE'
         STW,R2   LINKFLAG          ENABLE LINK CHECKING
         LI,R2    0
         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
*D*  NAME:         CONSEC
*D*
*D*  DESCRIPTION:  PROCESS CONSEC FILE AND KEYED FILE LEVEL 0 MI.
*D*                IF NOT ONE GRANULE FILE, GET TYPE 3 BUFFER AND
*D*                START READ OF THE FLINK GRANULE.  ENTER PROCESSING
*D*                LOOP:
*D*                  WAIT FOR I/O TO COMPLETE.  CALL FNDKEY OR
*D*                  CHKCON TO VALIDATE GRANULE.  CALL ALLOCG TO
*D*                  ALLOCATE THE GRANULE.  IF THERE IS ANOTHER
*D*                  GRANULE IN FORWARD DIRECTION (BUFLINK NON-ZERO),
*D*                  POINT TO IT AND REPEAT LOOP.
         SPACE    1
CONSEC   EQU      %
         STW,R7   CURBUF            SSET CURRENT BUFFER
         LW,R6    BUFADR,R7         ADDRESS OF FIT BUFFER
         LW,R8    FLINK,R6
         BEZ      CON20             ONE GRANULE FILE
*
         LI,R2    3
         BAL,R15  GETBUF            GET TYPE 3 BUFFER
         BEZ      BUFERR            ERROR - NO BUFFER AVAIL
         LW,R6    FITBUF            WHERE TO PUT FLINK
         STB,R7   BUFLINK,R6        LINK PREV BUFFER TO NEXT
CON10    RES
         STW,R8   BUFDA,R7
         LW,R8    BUFDA,R6          BLINK CHECK
         AND,R8   M24
         STW,R8   BUFDACHK,R7       LINK CHECK DA FOR NEXT GRAN
         BAL,R11  DISCRD            START READ OF NEXT GRANULE
         LW,R7    CURBUF            BUFFER TO PROCESS
*
CON20    BAL,R11  IOSPIN            WAIT FOR I/O TO COMPLETE
         LW,R15   BUFINFO,R7
         BNEZ     CONERR            ERROR ON THIS GRANULE
*
         LW,R8    BUFDA,R7
         AND,R8   M24               DISK ADDR OF GRANULE JUST READ
         CW,7     FITBUF            FIT IS ALREADY ALLOCATED
         BE       %+3
         BAL,R11  ALLOCG            ALLOCATE IT
         BCS,11   CONERR            ERROR
         STW,R8   LDAL              DISK ADDR OF LAST GOOD GRANULE
         LW,R6    BUFADR,R7
*
         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
         B        CON26
*
CON25    BAL,R10  CHKCON            CHECK IT
*
CON26    LW,R10   #RECS1            INCREMENT # RECORDS IN FILE BY
         AWM,R10  #RECS               # RECORDS IN THIS GRANULE
*
         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,R6    CURBUF
         LI,R11   0                 CLEAR FLINK LEST ERROR OCCURS HERE
         LB,R7    BUFLINK,R6        IS THERE A NEXT BUFFER
         STB,R11  BUFLINK,R6        (EOF OR FIT ERR USUALLY)
         STW,R7   CURBUF            NEW CURRENT BUFFER
         BNEZ     CON20
         LW,R7    BUFADR,R6         SHOULD THERE BE ANOTHER BUFFER
         LW,R8    FLINK,R7
         BEZ      FILEXIT           NO, DONE
         LI,R2    3                 YES, MUST HAVE HAD ERROR
         BAL,R15  GETBUF            RESTART READAHEAD
         BEZ      BUFERR
         STW,R7   CURBUF
         B        CON10
*
*  ERROR IN CONSECUTIVE FILE
*
CONERR   BAL,R11  GRANERR           RETRY IT
         BEZ      CON20             RETRY SUCCESSFUL
         LW,R11   FIXFLAG
         BEZ      FILEX2            NOT 'FIX'
         BAL,R11  TRUNCATE          TRUNCATE THE FILE
         B        FILEXIT           NO MORE RETRIES
         SPACE    3
*D*  NAME:         KEYED
*D*
*D*  DESCRIPTION:  PROCESS KEYED FILE UPPER LEVEL INDEX STRUCTURE.
*D*                IF NO UPPER LEVEL STRUCTURE (FIT:TDA ZERO), EXIT
*D*                TO CONSEC.  READ TDA GRANULE.  IF TDA GRANULE IS
*D*                A LEVEL 0 GRANULE, EXIT TO CONSEC.
*D*                IF TDA GRANULE HAS A BLINK, READ BACKWARDS UNTIL
*D*                FIRST GRANULE ON TOP LEVEL IS FOUND.
*D*                PROCESSING LOOP:
*D*                  IF AT BEGINNING OF A LEVEL, SAVE DISC ADDRESS
*D*                  FROM FIRST KEY (THE DISC ADDRESS OF START OF
*D*                  NEXT LOWER LEVEL).  ALLOCATE THE CURRENT GRANULE.
*D*                  READ FORWARD TO END OF LEVEL, ALLOCATING EACH
*D*                  GRANULE.  AT END OF LEVEL, IF CURRENT LEVEL
*D*                  > 1, PICK UP SAVED DISC ADDRESS OF START OF
*D*                  NEXT LOWER LEVEL AND REPEAT PROCESS WITH IT.
*D*                EXIT TO CONSEC.
         SPACE    1
KEYED    EQU      %
         LI,R4    MKEYMUL
         STW,R4   CURMES            CHANGE CURRENT MESSAGE
         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    TDAFIT,R1         DISC ADDR OF TOP OF MUL
         BEZ      KEY60             NO UPPER LEVEL EXISTS
         STW,R8   BADDA             SET IF BAD
         LI,R15   ERR#51
         BAL,R11  CHKDA
         BCR,15   KEY30             REMOVE TREE IF BAD TDA
         STW,R8   BUFDA,R7
         LI,R9    -1
         STW,R9   LINKFLAG          NO LINK CHECKING
         STW,R9   KEYLEVEL          DON'T CHECK KEY KEVEL
KEY10    BAL,R11  DISCRD
         BAL,R11  IOSPIN
         LW,R6    BUFADR,R7
KEY20    BAL,R10  VALBUF            VALIDATE FIRST 3 WORDS
         BEZ      KEY40             OK
         BAL,R11  GRANERR
         BEZ      KEY20             TRY AGAIN
         B        KEY32             GIVE UP
*
*  UNRECOVERABLE ERROR - GET RID OF MUL
*
KEY30    OR,R15   =NORETRY          SET NO RETRY FLAG
         BAL,R11  GRANERR           GIVE MESSAGE
KEY32    RES
         LW,R11   FIXFLAG
         BEZ      KEY60             DON'T FIX
         LI,R14   MMULDEL
         BAL,R15  PRINT
         LW,R2    FITBUF
         LW,R9    FL:UPDT
         STS,R9   BUFDA,R2          SET FIT UPDATED
         LI,R2    TDAFIT
         LI,R7    0
         STW,R7   *VLP0C,R2         ZAP TDA IN FIT
         LI,R2    3
         LI,R7    X'FF'
         STS,R7   *VLP0C,R2         SET SLIDES TO FORCE MUL REBUILD
         B        KEY60             EXIT
*
KEY40    LI,R11   X'1C00'
         STW,R11  LINKFLAG          ENABLE LINK CHECKING
         AND,R11  NAVX,R6
         SLS,R11  -10               RIGHT JUSTIFY KEY LEVEL
         STW,R11  KEYLEVEL
         AI,R11   0
         BEZ      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    LW,R8    BUFDA,R7
         BAL,R11  ALLOCG            ALLOCATE GRANULE
         BCS,11   KEY30             ERROR
         LW,R6    BUFADR,R7         RESTORE BUFFER ADDRESS
         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
         LI,R15   ERR#22            BAD DISC ADDR IN KEY
         LW,R8    LOCDA
         BAL,R11  CHKDA
         BCR,15   KEY30             BAD DISC ADDRESS
KEY53    RES
         BAL,R11  SNAPGRAN          DUMP THE GRAN IF DUMP COMMAND
         LW,R6    BUFADR,R7         RESTORE BUFFER ADDR
         LW,R8    FLINK,R6
         BEZ      KEY58             ONLY ONE GRANULE ON TDA LEVEL
         LI,R2    3
         BAL,R15  GETBUF            GET TYPE 3 BUFFER
         STW,R8   BUFDA,R7
         LW,R2    DIRBUF            BUFFER CONTAINING TDA
         LW,R11   BUFDA,R2
         AND,R11  M24
         STW,R11  BUFDACHK,R7       LINK-CHECK DISC ADDRESS
         BAL,R11  DISCRD
KEY55    BAL,R11  IOSPIN
         LW,R15   BUFINFO,R7        CHECK RESULTS OF VALBUF
         BNEZ     KEY30             ERROR
         LW,R8    BUFDA,R7          GET THE DISC ADDRESS
         BAL,R11  ALLOCG            ALLOCATE IT
         BCS,11   KEY30             ERROR
         BAL,R11  SNAPGRAN          DUMP IF DUMP COMMAND
         LB,R2    BUFLINK,R7        NEXT BUFFER
         STW,R2   TEMP
         BAL,R15  RELBUF            RELEASE THIS BUFFER
         LW,R7    TEMP
         BNEZ     KEY55             MORE TO GO
*
*  PROCESS NEXT LOWER LEVEL
*
KEY58    MTW,-1   KEYLEVEL
         BLEZ     KEY60             DONE
         LW,R8    LOCDA
         LW,R7    DIRBUF
         STW,R8   BUFDA,R7          DISC ADDRESS TO READ NEXT
         LI,R9    0
         STW,R9   BUFDACHK,R7       ZERO BLINK FOR LINK CHECK
         B        KEY10
*
*  FINISHED
*
KEY60    LI,R7    0
         STW,R7   KEYLEVEL
         XW,R7    DIRBUF
         BAL,R15  RELBUF
         LI,R4    MFILE             RESTORE FILE MESSAGE
         STW,R4   CURMES
         LW,R7    FITBUF            RESTORE FIT BUFFER INDEX
         B        CONSEC
         SPACE    3
*D*  NAME:         RANDOM
*D*
*D*  DESCRIPTION:  PROCESS RANDOM FILE.
*D*                ALLOCATE FIT GRANULE.  IF NOT HGP RECON, EXIT.
*D*                GET START OF FILE AND # GRANULES FROM FIT.
*D*                ALLOCATE THE GRANULES, SWITCHING TO NEXT VOLUME
*D*                WHEN NECESSARY.
         SPACE    1
RANDOM   EQU      %
         LI,R11   0
         XW,R11   #GRAN             DON'T COUNT FIT AS PART OF FILE
         AWM,R11  #RANFIT             BUT AS PART OF RANDOM FITS
         LW,R8    *VLP0C            DATA FDA
         LW,R15   *VLP0D            #GRANULES II FIE
         BLEZ     FILEXIT           NONE
         LW,R11   HGPRFLAG
         BEZ      RAN50             NOT HGP RECON
         LW,R10   R15               SAVE # TO RELEASE
*
RAN10    LDCTX,R1 R8
         LB,R1    DCTX,R1           CONVERT VOL # TO DCTX
         BAL,R5   FNDHGP            LOCATE HGP
         B        RANERR            CAN'T FIND
         INT,R4   1,R7
         CI,R5    ATPRIVBIT         CHECK FOR PRIVATE PACK
         AND,R5   M8                # GRAN/CYL
         BAZ      RAN30
         LW,R4    R8
         AND,R4   SECTOR%MASK       MASK OFF SECTOR ADDRESS
         BNEZ     RAN30             NOT AT SECTOR ZERO
         AW,R4    R5                MOVE PAST NVAT
         CI,R4    30
         BL       %-2
         SLS,R4   1                 CONVERT GRANULES TO SECTORS
         OR,R8    R4                CHANGE REL SECTOR IN DISC ADDR
RAN30    LSECTA,R11  R8
         LB,R4    DCT22,R1          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
         LW,R2    R5                MOVE # GRAN/CYL
RAN41    MTH,2    R8,R1             INCR SECTOR ADDRESS
         BNC      RAN42
         EOR,R8   Y008
         CW,R8    Y008
         BANZ     %+2
         EOR,R8   Y004
RAN42    BDR,R2   RAN41             INCR SECTOR ADDR TO NEXT CYLINDER
         BDR,R14  RAN40             ALLOCATE NEXT CYLINDER
         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
         LW,R15   *VLP0D            REFRESH COUNT
*
RAN50    STW,R15  #GRAN             SET # GRANULES IN FILE
         B        FILEXIT
*
RANERR   LW,R7    FITBUF            RESTORE BUFFER NUMBER FOR DUMP
         BAL,R11  GRANERR
*        BEZ      WHOKNOWSWHERE     ALWAYS FROM ALLOCG-NORETRIES
*
*  ERROR IN FIT
*
FILERR   EQU      %
         LW,R11   HGPRFLAG
         BNEZ     RELFIT
         LW,R11   FIXFLAG
         BEZ      FILEX2            DO NOTHING IF NOT FIX
         LW,R7    DIRBUF
         BEZ      ACNDR10           DIDN'T GET HERE FROM DIRECTORY
         BAL,R11  TRUNC10           DELETE FROM DIRECTORY
         B        FILEX2
*
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
         MTW,1    ERRCNT
         B        ENDPROC2
*
FILE99   LI,R14   MNOSFILE          'NO SUCH FILE'
         B        FILDIR30
*
*D*  NAME:         FILEXIT
*D*  ENTRY:        FILEX2
*D*
*D*  DESCRIPTION:  FINAL CLEANUP FROM PROCESSING A FILE.
*D*                ENTER AT FILEXIT IF ENTIRE FILE PROCESSED WITH
*D*                NO ERRORS.  ENTER AT FILEX2 IF ENTIRE FILE NOT
*D*                PROCESSED ('FIT' OPTION) OR ERRORS FOUND
*D*                THAT WERE NOT FIXED.
*D*                FILEXIT VERIFIES AND FIXES IF NECESSARY SEVERAL
*D*                FIT VALUES:  LDA, AND # RECORDS FOR CONSEC.
*D*                AT FILEX2 THE BUFFERS ARE RELEASED, DCBS CLOSED,
*D*                AND FINAL STATISTICS FOR THIS FILE PRINTED.
*
FILEXIT  LW,R11   HGPRFLAG
         BNEZ     FILEX1            HGP RECON - KNOW FILE SIZE
         LW,R11   *VLP0D            GET FILE SIZE FROM FIT
         STW,R11  #GRAN
FILEX1   RES
         LW,R7    FITBUF
         LW,R6    VLP0C             ADDRESS OF X'0C' VLP IN FIT
         BEZ      FILEX2
         LW,R3    Y002
         CW,R3    F:FIX             IF DCB OPEN, GET NGAVAL,CCBD FROM CFU
         BAZ      FILEX11
         LW,R3    F:FIX+1
         LW,R8    3,R3              NGAVAL
         STW,R8   2,R6
         LW,R8    4,R3
         LI,R9    X'F0000'
         STS,R8   3,R6
FILEX11  RES
         LW,R8    #GRAN
         LI,R3    2                 FOR CHECKING ORG
         CW,R3    ORGL
         BL       FILEX15           RANDOM, CHECKONLY SIZE
         LW,R8    FITDA             FDA SHOULD BE FIT
         LI,R9    -1                FULL WORD COMPARE
         MTW,0    #RECS             UNLESS EMPTY FILE
         BNEZ     %+2
         LW,R9    M24
         BAL,R10  CHKFIT
         DATA                       WORD0,ERR60
*
         LW,R8    LDAL              TRUE LDA
         BAL,R10  CHKFIT
         GEN,16,16 6,1              WORD6,ERR61
         LW,R8    CCBDL
         AND,R8   M27               800 IS ZERO
         LI,R9    X'F0000'          LEFT HALF MASK
         CW,R3    ORGL              CCBD FOR KEYED ONLY
         BNE      %+3
         BAL,R10  CHKFIT
         GEN,16,16 3,2              WORD3,ERR62
         LW,R8    #RECS             TRUE # RECORDS IN FILE
FILEX15  LI,R9    -1                FULL WORD MASK
         CW,R3    ORGL              CHECK SIZE FOR CONSEC
         BE       %+3               AND RANDOM
         BAL,R10  CHKFIT
         GEN,16,16 1,3              WORD1, ERR63
         INT,R9   GAVALL            RECONSTRUCT GAVAL/NGAVAL
         MW,R9    GAVALC
         LB,R10   GAVALL
         AI,R10   1                 NEXT GRAN IN CYL
         LW,R8    GAVALC            COMPUTE # LEFT
         SW,R8    R10
         BEZ      FILEX17
         AW,R9    R10
         SLS,R9   1                 SECTOR# ON DEVICE
         STB,R8   GAVALL            # LEFT
         LW,R8    GAVALL            DCTX
         STSECTA,R9,R11 R8
FILEX17  LI,R9    -1                CHECK FULL WORD
         BAL,R10  CHKFIT
         GEN,16,16 2,4              WORD2, ERR64
         B        FILEX2
         SPACE    5
CHKFIT   RES
         INT,R14  *R10              GET DISP INTO 0CVLP(R14) AND ERR CODE
         AI,R10   1                 INCR RETURN
         CS,R8    *R14,R6           IS IT RIGHT
         BE       *R10              YES
         BG       %+3
         CI,R9    X'F0000'
         BE       %+5
         AI,R15   ERR#60            REAL ERROR MSG
         LI,R11   MFITM             SET FIT ERR MESSAGE
         STW,R11  CURMES
         BAL,R11  GRANERR           PUT MSG
         MTW,0    FIXFLAG           ARE WE FIXING
         BEZ      *R10              NO
         STS,R8   *R14,R6           YES
         LW,R11   FL:UPDT
         STS,R11  BUFDA,R7
         LI,R2    X'20'             IF F:FIX IS OPEN, DONT LET
         CH,R2    F:FIX             CLOSE UNDO THE FIX
         BAZ      *R10
         LW,R11   Y06
         LW,R2    F:FIX+1
         STS,R10  0,R2
         B        *R10
*
FILEX2   BAL,R11  RBUFS             RELEASE ALL BUFFERS
         LI,R7    0
         XW,R7    DIRBUF
         BEZ      %+2
         BAL,R15  RELBUF            RELEASE DIRECTORY BUFFER
         LW,R4    Y002
         CW,R4    F:FIX
         BAZ      %+2
         M:CLOSE  F:FIX,SAVE        CLOSE DCB IF OPEN
         BAL,R11  FILEINFO          PRINT STATISTICS FOR THIS FILE
         LW,R11   #GRAN
         AWM,R11  #FILGRAN          ACCUMULATE TOTAL FILE GRANULES
*
         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
         CW,R11   CUROPT            STOP IF SPECIFIC ACCOUNT DESIRED
         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    '****  FIX/DUMP VTOCS  ****'
         SPACE    2
*D*  NAME:         FIXVTOC
*D*
*D*  DESCRIPTION:  REPAIR PRIVATE PACK VTOC UNDER USER CONTROL.
*D*                A DCB IS OPENED TO THE SERIAL NUMBER SPECIFIED
*D*                ON THE COMMAND LINE IN DEVICE MODE (THE SYSTEM
*D*                DOES NOT READ AND VERIFY THE VTOC).  IF THE
*D*                COMMAND WAS 'DUMP', THE VTOC IS READ AND
*D*                DUMPED TO LP.
*D*                THE USER IS ASKED THE # GRANULES/CYLINDER.  A
*D*                DEFAULT OF 30 IS USED IF NONE SPECIFIED.
*D*                THE USER IS ASKED THE PRIMARY SERIAL #.  IF ONE
*D*                IS NOT SPECIFIED, IT IS ASSUMED THAT THE PRIMARY
*D*                WAS SPECIFIED ON THE COMMAND LINE.
*D*                A VTOC IS BUILT, WITH AN HGP THAT HAS ALL GRANULES
*D*                ALLOCATED.
*D*                THE USER IS ASKED FOR THE OTHER SERIAL NUMBERS IN
*D*                THE SET IF THIS IS THE PRIMARY.  ALL SERIAL
*D*                NUMBERS SPECIFIED ARE PLACED IN THE SERIAL NUMBER
*D*                TABLE.  THE VTOC IS THEN WRITTEN OUT AND THE
*D*                PACK IS RELEASED.
*
FIXVTOC  LI,R14   MNOSNACT          'MISSING SN OR ACCOUNT'
         CI,R10   B:SN
         BAZ      ERROR3            MUST SPECIFY SN
*
         M:CLOSE  F:PV,REL,REM      CLOSE DCB IF OPEN
         LW,R3    DEVTYPE           PACK TYPE
         STW,R3   VTDEV             MOVE TO FPT
         LI,R3    1
         XW,R3    SN
         STW,R3   VTSN              MOVE SERIAL #
         LI,R1    0
         M:OPEN,E VTOPEN            OPEN DEVICE PACK
         AI,R1    0
         BNEZ     FILE90            UNEXPECTED I/O ERROR
         LI,R14   MILLDEV           'ILLEGAL DEVICE TYPE'
         LI,R2    X'FF'
         AND,R2   F:PV+DSI          DCT INDEX
         BEZ      ERROR3
         CI,R2    DCTSIZ
         BG       ERROR3
         LB,R2    DCT22,R2          DISC TYPE
         BEZ      ERROR3            NOT DISC
         LW,R11   DUMPFLAG
         BNEZ     DUMPVTOC          DUMP, NOT FIX
*
*  ASK FOR # GRANULES/CYLINDER
*
         M:PC     '.'               CHANGE PROMPT CHAR
         LI,R2    30
         STW,R2   GRANCYL           DEFAULT VALUE
         LI,R14   MGRANCYL
         BAL,R11  DOPRINT
         BAL,R11  READ
         BCS,1    VTOC40            EOF - TAKE DEFAULT
         BAL,R11  GETFIELD
         BCS,4    VTOC40            EMPTY FIELD - TAKE DEFAULT
         LCI      2
         LM,R12   FBUF
         BAL,R15  DEC2BIN           CONVERT DECIMAL EBCDIC TO BINARY
         B        ERROR2            BAD DECIMAL DIGIT
         STW,R5   GRANCYL
*
*  ASK FOR PRIMARY SERIAL NUMBER
*
VTOC40   LW,R4    VTSN
         STW,R4   VTPRIM            ASSUME PRIMARY WAS SPECIFIED
         LI,R14   MPRIM
         BAL,R11  DOPRINT
         BAL,R11  READ
         BCS,1    VTOC45            EOF - TAKE DEFAULT
         BAL,R11  GETFIELD
         BCS,4    VTOC45            EMPTY FIELD
         CI,R7    4
         BG       FIELDBIG          CAN'T HAVE MORE THAN 4 CHARS
         LW,R4    FBUF
         STW,R4   VTPRIM
*
*  BUILD VTOC
*
VTOC45   LI,R2    0
         BAL,R15  GETBUF            GET A BUFFER
         STW,R7   FITBUF
         LW,R2    BUFADR,R7         BUFFER ADDRESS
         LW,R8    =':LBL'           WORD 0
         LW,R9    VTSN                   1
         LW,R10   BLANKS                 2
         LI,R13   0                      5
         LI,R14   X'70000'               6
         LCI      7
         STM,R8   0,R2
*
         LI,R4    512-7             # REMAINING WORDS IN VTOC
         LI,R5    511
         STW,R13  *R2,R5            ZERO REST OF VTOC
         AI,R5    -1
         BDR,R4   %-2
*
         LI,R5    X'FF'
         AND,R5   F:PV+DSI          DCT INDEX OF PACK
         LB,R3    DCT22,R5          DISC TYPE
         LW,R5    DISCLIMS,R3       # SECTORS ON PACK
         SLS,R5   -1                # GRANULES
         DW,R5    GRANCYL           # CYLINDERS
         AI,R5    31
         DW,R5    =32               # WORDS IN BIT MAP
         LW,R8    R5
         LW,R4    GRANCYL
         STH,R4   R5
         STW,R5   4,R2              NGC,MAPWL
         AI,R8    7                 POINT PAST HGP HEADER
         STW,R8   3,R2
*
         LW,R9    R2
         AI,R9    511
         STW,R9   VTOCEND           LAST WORD OF VTOC
         LI,R14   MVTOCBIG          'VTOC TOO BIG'
         AW,R2    R8                POINT TO NSN
         CW,R2    VTOCEND
         BGE      ERROR3            BIT MAP TOO BIG
         STW,R2   NSN               SAVE SN LIST ADDRESS
         LI,R3    1
         LW,R4    VTPRIM
         LCI      2
         STM,R3   0,R2              PUT IN PRIMARY SN
         CW,R4    VTSN
         BNE      WRTVTOC           NOT PRIMARY - DONE
*
VTOC48   LI,R14   MINPSN
         BAL,R11  DOPRINT
VTOC50   BAL,R11  READ
         BCS,1    VTOC55            EOF - NO MORE SN'S
         BAL,R11  GETFIELD
         BCS,4    VTOC55            EMPTY RECORD
         CI,R7    4
         BG       FIELDBIG          TOO MANY CHARS
         LI,R14   MVTOCBIG
         MTW,1    *NSN              INCR # SERIAL NUMBERS
         LW,R2    *NSN
         AW,R2    NSN               ADDR OF THIS SN
         CW,R2    VTOCEND
         BG       ERROR3            NOT ENOUGH ROOM
         LW,R4    FBUF
         STW,R4   0,R2
         B        VTOC50
*
VTOC55   LW,R2    VTSN
         CW,R2    VTPRIM            IF PRIMARY BEING FIXED, IS OK
         BE       WRTVTOC             IF NO SERIAL #'S ENTERED
         LW,R2    *NSN
         CI,R2    1
         BLE      VTOC48            MUST HAVE AT LEAST TWO
*
*  WRITE OUT VTOC
*
WRTVTOC  LI,R7    0
         XW,R7    FITBUF
         LI,R2    X'FF'
         AND,R2   F:PV+DSI          DCT INDEX OF PACK
         SLS,R2   16                DISC ADDRESS
         OR,R2    FL:UPDT           SET UPDATED FLAG
         STW,R2   BUFDA,R7
VTOC80   BAL,R15  RELBUF            RELEASE AND WRITE THE BUFFER
         M:CLOSE,E  PVREL           RELEASE THE PACK
         B        ENDPROC2
*
*  DUMP THE VTOC
*
DUMPVTOC LI,R14   MVTOC
         BAL,R15  PRINT
         LI,R2    0
         BAL,R15  GETBUF
         LI,R2    X'FF'
         AND,R2   F:PV+DSI          DCT INDEX
         SLS,R2   16                DISC ADDRESS
         STW,R2   BUFDA,R7
         BAL,R11  DISCRD
         BAL,R11  IOSPIN
         LW,R12   BUFADR,R7         BUFFER ADDRESS
         LI,R13   512
         LI,R14   0
         BAL,R11  HEXDUMP
         B        VTOC80            EXIT
         TITLE    '****  FIX/DUMP CFUS  ****'
         SPACE    2
*D*  NAME:         FIXCFU
*D*
*D*  DESCRIPTION:  FIX AND/OR DUMP A CFU.
*D*                THE CFU AREA IS SEARCHED FOR A CFU POINTING
*D*                TO THE SPECIFIED NAME AND ACCOUNT.  WHEN FOUND,
*D*                IT IS DUMPED TO USER TERMINAL AND LP.  IF
*D*                COMMAND WAS 'FIX', THE CFU NAME/ACCOUNT POINTERS
*D*                ARE ZEROED, AND ANY SCFU LINKS ARE CLEARED.
*
FIXCFU   LI,R14   MMISFNAM
         CI,R10   B:FNAM            MUST SPECIFY FILE NAME
         BAZ      ERROR3
         CI,R10   B:SN
         BAZ      CFU22             BR IF PUBLIC FILE
*  SEARCH FOR PRIMARY DCT INDEX
         LI,R1    AVRTBLNE-AVRTBLSIZ   # PACK ENTRIES
         BLEZ     CFU15             NO PRIVATES
CFU10    LD,R2    AVRTBL+AVRTBLSIZ+AVRTBLSIZ-2,R1
         CW,R2    SN
         BE       CFU20             FOUND IT
         BDR,R1   CFU10
CFU15    LI,R14   MNOCFU
         B        ERROR3            NO SUCH CFU
*
CFU20    AI,R1    X'3C00'+BATAPE+AVRTBLSIZ-1     DCTX OF PRI/FLAG
         B        CFU30
*
*  SEARCH FOR PUBLIC ACCOUNT
*
CFU22    LCI      2
         LM,R2    CURACCT           ACCOUNT TO SEARCH FOR
         LH,R1    ACNCFU+14         # ACTIVE ACCOUNTS
CFU25    CD,R2    *ACNCFU+13,R1
         BE       CFU30             GOT IT
         BDR,R1   CFU25
         B        CFU15             NO SUCH ACCOUNT
*
CFU30    SLS,R1   16
*
*  SEARCH FOR FILE NAME
*
         LB,R2    CURFILE
CFU32    AI,R2    1                 # BYTES IN TEXTC NAME
         CI,R2    3
         BAZ      CFU34             WORD BOUNDARY
         STB,R1   CURFILE,R2        ZAP TRAILING BYTES
         B        CFU32
*
CFU34    SLS,R2   -2                # WORDS IN NAME
         LW,R4    ACNCFU+15         START OF NAME AREA
CFU35    LW,R5    R2                # WORDS IN NAME
         LI,R6    0
CFU36    LW,R7    *R4,R6
         CW,R7    CURFILE,R6        COMPARE NAMES
         BNE      CFU38             NO MATCH
         AI,R6    1                 TRY NEXT WORD
         BDR,R5   CFU36
         OR,R1    R4                MERGE IN FILE NAME ADDR
         B        CFU40             FOUND THE NAME
*
CFU38    LB,R6    *R4               TEXTC COUNT OF THIS NAME
         AI,R6    4
         SLS,R6   -2                # WORDS IN NAME
         AW,R4    R6                POINT TO NEXT NAME
         CW,R4    ACNCFU+16
         BL       CFU35             MORE TO GO
         B        CFU15             AT END OF NAMES
*
*  FOUND BOTH NAME AND ACCOUNT/DCTX
*
CFU40    LI,R2    BGRCFU            NOW FIND A CFU OPEN TO THE FILE
CFU42    CW,R1    2,R2
         BE       CFU44             FOUND A MATCH
CFU43    AI,R2    CFUSIZE
         CW,R2    ACNCFU+13
         BL       CFU42             NOT DONE YET
         B        ENDPROC2          DONE
*
*  MATCH - CHECK IF PUBLIC OR PRIVATE
CFU44    LI,R4    0
         LW,R4    DUMPFLAG
         BNEZ     CFU50             DUMP ONLY
         STW,R4   2,R2              ZAP THE NAME
         LI,R5    X'FFFF'
         AND,R5   4,R2
         BEZ      CFU50             NO SCFU
         STS,R4   4,R2              ZAP SCFU POINTER
         CI,R5    BGRCFU
         BL       CFU50             BAD SCFU POINTER
         CW,R5    ACNCFU+13
         BGE      CFU50             BAD SCFU POINTER
         LI,R3    X'FFFF'
         CS,R2    4,R5              DOES SCFU POINT BACK
         BNE      CFU50             NO - DON'T TOUCH IT
         STW,R4   2,R5              ZAP SCFU TOO
         STW,R4   4,R5
*
*  DUMP A CFU
*
CFU50    MTW,1    DMPFLG            DUMP TO USER TERMINAL
         LW,R12   R2
         LW,R14   R2
         LI,R13   CFUSIZE
         BAL,R11  HEXDUMP           DUMP MAIN CFU
         LI,R12   X'FFFF'
         AND,R12  4,R2              SCFU
         BEZ      CFU55             NONE
         LW,R3    R12
         CW,R1    2,R3
         BE       CFU55             DON'T DUMP SCFU IF WILL FIND LATER
         LW,R14   R12
         BAL,R11  HEXDUMP
CFU55    MTW,-1   DMPFLG
         B        CFU43             LOOK FOR MORE
         TITLE    '****  SRCHDIR  ****'
         SPACE    2
*D*  NAME:         SRCHDIR
*D*
*D*  REGISTERS:    ALL VOLATILE
*D*
*D*  CALL:         BAL,R11
*D*                RETURNS SKIPPING IF NO ERRORS ENCOUNTERED
*D*
*D*  INPUT:        R8 = DISC ADDRESS OF FDA OF DIRECTORY
*D*                R9 = DISC ADDRESS OF DUAL OF FDA
*D*
*D*  DESCRIPTION:  SEARCHES THE DIRECTORY FOR THE GIVEN KEY,
*D*                READING DUALS WHEN NECESSARY.  IN ADDITION,
*D*                IF 'COMPACT=YES' WAS SPECIFIED (THE DEFAULT),
*D*                KEYS IN THE DIRECTORY WILL BE MOVED FORWARD
*D*                IN BLOCKS OF 10 TO REDUCE THE SIZE OF THE
*D*                DIRECTORY.  IF THERE ARE NO KEYS REMAINING,
*D*                THE FILE DIRECTORY KEY WILL BE REMOVED FROM
*D*                THE ACCOUNT DIRECTORY.  ALL EMPTY GRANULES
*D*                RESULTING FROM THE COMPRESSION PROCESS ARE
*D*                RETURNED TO THE SYSTEM.
         SPACE    1
SRCHDIR  EQU      %
         PUSH     R11
*
         LW,R11   SN
         BEZ      %+2               BR IF PUBLIC
         LI,R9    0                 NO DUALS FOR PRIVATE
*
         LI,R2    0
         BAL,R15  GETBUF            GET TYPE 0 BUFFER
         BEZ      BUFERR
         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   #FDGRAN           # FILE DIRECTORY GRANULES
         STW,R8   #RECS             # RECORDS
         STW,R8   PREVBUF           NO PREVIOUS BUFFER
         STW,R8   PREV1BUF          NO PREVIOUS-PREVIOUS BUFFER
         STW,R8   NXTBUF            NO NEXT BUFFER
         STW,R8   PREVFLAG          ZERO FLAGS OF PREVIOUS KEY
         STW,R8   LOCDA             HAVEN'T FOUND DESIRED KEY
         STW,R8   FINDLOC
*
         BAL,R11  DISCRD            READ FDA GRANULE
*
SRCH30   BAL,R11  IOSPIN            WAIT FOR I/O TO COMPLETE
*
         LW,R8    DFLINKL
         STW,R8   BUFDUAL,R7
*
SRCH32   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      BUFERR
         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     SRCH92            ERROR
*
         LW,R11   #RECS1
         AWM,R11  #RECS             UPDATE TOTAL # KEYS
         MTW,1    #FDGRAN           INCR # GRANULES
         LW,R8    BUFDUAL,R7
         BLEZ     %+2
         MTW,1    #FDGRAN           COUNT DUAL TOO
*
         BAL,R10  DUALCHK           VALIDATE DUAL POINTERS
*
         BAL,R11  SNAPGRAN          DUMP THE GRANULE
         BAL,R2   DUALRD            PRINT MESSAGE IF DUAL WAS READ OK
*
SRCH45   LW,R11   COMPFLAG
         BEZ      SRCH48            NO DIRECTORY COMPRESSION DESIRED
         LW,R11   DUMPFLAG
         OR,R11   FINDFLAG
         BNEZ     SRCH48            NO COMPRESSION IF DUMPING OR FINDING
*
*  COMPRESS DIRECTORY BY MOVING KEYS FORWARD AND DELETING
*  EMPTY GRANULES.
*
         LDCTX,R1 BUFDA,R7
         LB,R1    DCTX,R1
         LI,R7    HGP               ADDRESS OF IN-CORE HGPS
         BAL,R5   FNDHGP1
         B        SRCH48
         LW,R5    1,R7
         CI,R5    ATCYLBIT
         BANZ     SRCH48            DO NOTHING IF CYL ALLOCATED
*
         LW,R2    PREV1BUF
         BEZ      SRCH48            NO BUFFER BEFORE THIS ONE - GET OUT
         LW,R5    BUFADR,R2
         LI,R3    NAV
         LH,R1    *R5,R3            NAV OF PREV1BUF
         LI,R8    X'800'            # BYTES IN ONE BUFFER
         LI,R9    X'4000'
         CW,R9    NAVX,R5
         BANZ     %+2
         LI,R8    X'400'            HALF GRANULE
         SW,R8    R1                SPACE REMAINING
         LW,R10   KEYSIZE
         SLS,R10  2                 SIZE OF 4 KEYS
         LW,R7    PREVBUF
         LW,R6    BUFADR,R7
         LH,R12   *R6,R3            NAV OF PREVBUF
         CI,R12   MIDIS             IS IT EMPTY
         BE       SRCH46            YES - TRY TO GET RID OF IT
         CW,R8    R10               IS THERE ROOM TO MOVE 4 KEYS
         BLE      SRCH48            NO - DO NOTHING
         LW,R13   FL:UPDT
         STS,R13  BUFDA,R2          SET BOTH BUFFERS UPDATED
         STS,R13  BUFDA,R7
         SW,R12   KEYSIZE
         STH,R12  *R6,R3            NEW PREVBUF NAV
         AW,R1    KEYSIZE
         STH,R1   *R5,R3            NEW PREV1BUF NAV
         SLS,R5   2
         AW,R5    R1
         SW,R5    KEYSIZE           BA OF DESTINATION
         LW,R4    R6
         SLS,R4   2
         AI,R4    MIDIS             BA OF SOURCE
         LW,R9    KEYSIZE
         STB,R9   R5                # BYTES TO MOVE
         MBS,R4   0                 MOVE ONE KEY
*
         LW,R5    R6
         SLS,R5   2
         AI,R5    MIDIS             BA OF FIRST LOC IN PREVBUF
         AI,R12   -MIDIS            # BYTES TO SLIDE UP
         BLEZ     SRCH46            NONE - EMPTY GRANULE
SRCH45C  LB,R8    0,R4              SLIDE UP
         STB,R8   0,R5
         AI,R4    1
         AI,R5    1
         BDR,R12  SRCH45C
         B        SRCH45            TRY TO MOVE MORE KEYS
*
*  EMPTY GRANULE - TRY TO RELEASE IT
*
SRCH46   LI,R4    3
         STW,R4   *R6,R4            ZAP FIRST KEY
         LDCTX,R1 BUFDA,R7          DCT INDEX OF GRAN TO BE RELEASED
         LB,R1    DCTX,R1
         LI,R7    HGP
         BAL,R5   FNDHGP1
         B        SRCH47P
         LW,R5    1,R7
         CI,R5    ATCYLBIT
         BANZ     SRCH47P           CYL - DON'T GET RID OF IT
*
         LW,R2    PREV1BUF
         LW,R7    PREVBUF
         LW,R4    BUFADR,R2
         LW,R8    BUFDA,R7
         AND,R8   FLR:UPDT          RESET UPDATED FLAG
         STW,R8   BUFDA,R7
         LW,R8    FLINK,R6          TRANSFER FLINK
         STW,R8   FLINK,R4
         LW,R8    DFLINK,R6
         STW,R8   DFLINK,R4         AND DUAL FLINK
         LW,R13   FL:UPDT
         STS,R13  BUFDA,R2          SET PREV1BUF UPDATED
         LW,R3    CURBUF
         BEZ      SRCH47            NO NEXT BUFFER
         LW,R5    BUFADR,R3
         STS,R13  BUFDA,R3          SET UPDATED FLAG
         LW,R8    BLINK,R6          MOVE BLINK
         STW,R8   BLINK,R5
         LW,R8    DBLINK,R6
         STW,R8   DBLINK,R5         AND DUAL BLINK
         LW,R7    CURBUF
         BAL,R11  BUFWRT            WRITE IT OUT
SRCH47   LW,R7    PREV1BUF
         BAL,R11  BUFWRT            WRITE OUT THE OTHER ONE
*
SRCH47A  LW,R6    PREVBUF
         LW,R8    BUFDA,R6          MAIN DA TO GET RID OF
         AND,R8   M24
         BEZ      SRCH47P           DONE
         LI,R11   0
         LW,R10   TYPEFLAG
         BGEZ     SRCH47C           BR IF NOT ACCOUNT DIRECTORY
         STW,R11  ACNTBL            ZAP ACNTBL ENTRIES
SRCH47C  BAL,R11  RBG               RELEASE IT
         MTW,-1   #FDGRAN           COUNT THE DELETE
         LW,R6    PREVBUF
         LI,R8    0
         XW,R8    BUFDUAL,R6        MOVE DUAL
         AND,R8   M24
         STW,R8   BUFDA,R6
         B        SRCH47A           GET RID OF DUAL
*
SRCH47P  LI,R7    0
         XW,R7    PREVBUF
         BAL,R15  RELBUF
         LI,R7    0
         XW,R7    NXTBUF            SLIDE DOWN BUFFERS
         XW,R7    CURBUF
         STW,R7   PREVBUF
         B        SRCH49
*
SRCH48   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
*
SRCH49   LW,R7    CURBUF
         BNEZ     SRCH30            THERE IS MORE TO DO
         LW,R7    PREVBUF
         BNEZ     SRCH45            MORE TO DO
         LW,R7    PREV1BUF
         BEZ      SRCH49A           ALL DONE
         LW,R6    COMPFLAG          LEAVE IT ALONE
         BEZ      SRCH49A           YES
         LW,R6    BUFADR,R7
         LW,R8    BLINK,R6
         OR,R8    FLINK,R6
         BNEZ     SRCH49A           NOT ONLY GRANULE
         LI,R3    NAV
         LH,R8    *R6,R3
         CI,R8    MIDIS
         BNE      SRCH49A           NOT EMPTY
*
*  DIRECTORY CONTAINS ONE EMPTY GRANULE - TRY TO RELEASE IT
*  AND REMOVE ENTRY FROM ACCOUNT DIRECTORY
*
         LDCTX,R1 BUFDA,R7
         LB,R1    DCTX,R1
         LI,R7    HGP
         BAL,R5   FNDHGP1
         B        SRCH49A
         LW,R5    1,R7
         CI,R5    ATCYLBIT
         BANZ     SRCH49A           CYL ALLOCATED - CAN'T RELEASE
         LW,R2    S:BUIS            CURRENT # BATCH JOBS
         AW,R2    S:OUIS
         LC       J:JIT
         BCS,4    %+2               BR IF GHOST
         AI,R2    -1                DECR SELF IF BATCH OR ONLINE
         AI,R2    0
         BG       SRCH49A           USERS ARE AROUND - CAN'T DO
         STW,R2   ACNTBL            CLEAR CORE DIRECTORY
*
         BAL,R11  ADINIT            SET UP FOR ACCOUNT DIRECTORY
         LW,R7    DIRBUF
         BEZ      SRCH49A
         LW,R3    DIRCMD
         STW,R3   CMDL
         STW,R3   ADCMD
         LI,R14   MNULLFD           'NULL FILE DIRECTORY DELETED'
         BAL,R15  PRINT
         BAL,R11  DELKEY            GET RID OF IT
         LW,R7    PREV1BUF
         LW,R8    BUFDA,R7
         BAL,R11  RBG               RELEASE THE GRANULE
         MTW,-1   #FDGRAN           DECR # GRANULES
         LW,R7    PREV1BUF
         LW,R8    BUFDUAL,R7
         AND,R8   M24
         BEZ      SRCH49A
         BAL,R11  RBG               GET RID OF DUAL
         MTW,-1   #FDGRAN           DECR # GRANULES
*
SRCH49A  BAL,R11  RBUFS
         LI,R7    0
*
SRCH50   PULL     R11
         AI,R11   1                 NO ERRORS - RETURN SKIPPING
         B        *R11
*
SRCH80   LW,R8    BUFDA,R7
         AND,R8   M24
         STW,R8   FINDLOC
         BAL,R2   DUALRD            PRINT MESSAGE IF DUAL WAS READ
         LI,R7    0
         XW,R7    CURBUF
         XW,R7    DIRBUF
         BEZ      %+2
         BAL,R15  RELBUF            GET RID OF DIRECTORY BUFFER
         BAL,R11  RBUFS             GET RID OF OTHER BUFFERS
         B        SRCH50            EXIT
*
SRCH90   EQU      %                 UNRECOVERABLE ERROR
         BAL,R11  GRANERR           RETRY
         BEZ      SRCH32
         LW,R11   FIXFLAG           NO MORE RETRIES
         BEZ      SRCH92            COMMAND NOT 'FIX'
         BAL,R11  TRUNCATE          TRUNCATE THE DIRECTORY
SRCH92   PULL     R11
         B        *R11
         SPACE    3
DUALRD   PUSH     R2
         LW,R8    FL:DUAL
         CW,R8    BUFDA,R7          WAS DUAL READ
         BAZ      DUALRDX           NO
         LI,R14   MDUALOK           'DUAL SUCCESSFULLY READ'
         BAL,R15  PRINT
         LW,R15   FIXFLAG
         BEZ      DUALRDX           DON'T FIX
         LW,R15   FL:UPDT
         STS,R15  BUFDA,R7          SET BUFFER UPDATED
DUALRDX  PULL     R2
         B        0,R2
         TITLE    '****  DUALCHK  ****'
         SPACE    2
*D*  NAME:         DUALCHK
*D*
*D*  REGISTERS:    R7 PRESERVED
*D*
*D*  CALL:         BAL,R10
*D*
*D*  INPUT:        R7 = BUF TABLE INDEX OF DIRECTORY GRANULE
*D*
*D*  DESCRIPTION:  THE DUAL POINTERS ARE VALIDATED AND FIXED
*D*                IF NECESSARY.
         SPACE    1
DUALCHK  EQU      %
         LI,R8    0
         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
         LW,R9    M24
         CS,R8    DBLINK,R6           SNOULD 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
         BLZ      DUAL30            PREV WAS BAD, SO DON'T CHECK
         CS,R8    DDA,R6            OTHERWISE, SHOULD MATCH CURRENT
         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
         BEZ      DUAL40            NO DUAL HERE
         BAL,R11  CHKDA
         BCS,15   DUAL40            OK
         LI,R15   ERR#12            BAD DISC ADDRESS
         BAL,R11  GRANERR           RETRY
         BEZ      DUAL10
         LW,R8    FIXFLAG
         BEZ      %+3               NOT FIXING, JUST DONT USE AS FLINK
         LW,R11   FL:UPDT
         STS,R11  BUFDA,R7          MARK UPDATED
         LI,R8    0                 ZAP THE DUAL
         STW,R8   DFLINK,R6
         OR,R8    Y8                INDICATE JUST ALLOCATED
DUAL40   STW,R8   DFLINKL           SAVE IT
*
DUALXIT  B        *R10
         TITLE    '****  DCTSET  ****'
         SPACE    2
*D*  NAME:         DCTSET
*D*  ENTRY:        DCTSET1
*D*
*D*  REGISTERS:    ALL VOLATILE
*D*
*D*  INTERFACE:    AVRTBL
*D*
*D*  INPUT:        R7 = ADDRESS OF SERIAL NUMBER VLPS IN DCB (DCTSET1)
*D*
*D*  DESCRIPTION:  SET UP DCTX TABLE TO CONVERT PRIVATE VOL # TO
*D*                DCT INDEX.  FOR PUBLIC, IT IS SET 1 TO 1.
*D*                DCTSET:
*D*                  SET UP DCTX ONE-TO-ONE.  IF PUBLIC, EXIT.
*D*                  ZERO DCTX.  IF F:PV NOT OPEN, OPEN IT.
*D*                  POINT TO SERIAL NUMBER LIST IN DCB.
*D*                DCTSET1:
*D*                  LOOP THRU SERIAL NUMBER LIST AND AVRTBL, PUTTING
*D*                  APPROPRIATE DCT INDICES IN DCTX.
         SPACE    1
DCTSET   EQU      %
*
         LI,R2    63                ASSUME PUBLIC - SET TABLE TO
         STB,R2   DCTX,R2             CONVERT ONE-TO-ONE
         BDR,R2   %-1
         STB,R2   DCTX
         LW,R3    Y008
         STS,R2   OPNPV             SET NO NXTA
         LI,R3    8
         STW,R3   OPNPV+5           SET FUN OUTIN
*
         LW,R1    DEVTYPE
         STW,R1   PVDEV             MOVE DEVICE TYPE
         LCI      2
         LM,R3    CURACCT           MOVE ACCOUNT TO
         STM,R3   PVACCT              F:PV OPEN FPT
         LM,R1    SN-1              MOVE SN INFO
         STM,R1   PVSN-1
         AI,R2    0
         BEZ      *R11              PUBLIC - EXIT
         AI,R3    0
         BNEZ     DCTST03           BR IF USER SPECIFIED AN ACCOUNT
         LW,R3    Y008
         STS,R3   OPNPV             NO ACCT, TRY FOR THE FIRST ONE
         STW,R4   OPNPV+5           ST FUN
         LM,R1    J:ACCN
         STM,R1   PVACCT            USE CURRENT ACCOUNT AS DEFAULT
         STM,R1   CURACCT
*
DCTST03  LI,R2    64/4              PRIVATE - ZERO DCTX
         LI,R1    0
         STW,R1   DCTX-1,R2
         BDR,R2   %-1
*
         LW,R9    Y002
         CW,R9    F:PV
         BANZ     DCTST05           ALREADY OPEN - JUST SET UP DCTX
         LCI      2
         LM,R4    PVACCT
         STM,R4   J:ACCN            CHANGE ACCOUNT TO SAME AS PACK
         M:OPEN,E OPNPV             OPEN F:PV
         LCI      2
         LM,R4    F:PV+32           GET ACCT FROM DCB
         STM,R4   PVACCT
         LI,R3    8
         XW,R3    OPNPV+5           IF FUN WAS IN, MAKE OUTIN
         BEZ      DCTST03
         LCI      2
         LM,R4    LOGACCT
         STM,R4   J:ACCN            RESTORE LOGON ACCOUNT
         CW,R9    F:PV
         BAZ      FILE90            ERROR - DCB NOT OPEN
*
DCTST05  LB,R7    F:PV+VSND         DISPL TO SN LIST IN VLPS
         AW,R7    F:PV+FLP          POINT TO SN LIST
DCTSET1  LI,R2    X'FF00'
         AND,R2   0,R7
         SLS,R2   -8                # VOLUMES IN SET
*
DCTST10  LI,R1    AVRTBLNE-AVRTBLSIZ
DCTST20  LD,R4    AVRTBL+AVRTBLSIZ+AVRTBLSIZ-2,R1
         CW,R4    *R7,R2            FIND SERIAL # 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
*D*  NAME:         READ
*D*  ENTRY:        READEND
*D*
*D*  REGISTERS:    ALL VOLATILE
*D*
*D*  OUTPUT:       RECORD IN INBUF, BYTE COUNT IN INCNT
*D*                FOR READ, CC=0 IF NO ERROR, CC=1 IF EOF
*D*
*D*  DESCRIPTION:  READ:
*D*                  SET IDLE FLAG.  ISSUE M:READ TO M:SI.  WAIT
*D*                  FOR I/O TO COMPLETE.
*D*                READEND:
*D*                  FINISH READ PROCESSING.  REMOVE ANY ACTIVATION
*D*                  CHARACTER FROM END OF BUFFER.  SET IDLE FLAG
*D*                  TO NOT IDLE.  IF NOT HGP RECON, WRITE IMAGE
*D*                  OF RECORD TO LP.  IF ONLINE AND INPUT FROM
*D*                  OTHER THAN TERMINAL, WRITE IMAGE TO
*D*                  TERMINAL.  SET INCNT TO # CHARS IN BUFFER.
*D*                  SET INPOS TO POINT TO FIRST CHAR.
         SPACE    1
READ     EQU      %
         MTW,1    IDLEFLAG          SET IDLE
         LI,R3    1
         STW,R3   INPOS             NEXT CHAR LOCATION
         LI,R3    0
         STW,R3   INCNT             NOTHING READ YET
         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      READ10            DON'T PRINT IF NOTHING READ
         LW,R8    CORESDCB
         BNEZ     READ10            DON'T WRITE IF M:LO = ECHODCB
         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
         SNAPX    'M:SI ERROR'
*
*  END-OF-FILE
*
RDEOF    LCI      1
         B        *R11
         TITLE    '****  PARSE  ****'
         SPACE    2
*D*  NAME:         PARSE
*D*
*D*  REGISTERS:    ALL VOLATILE
*D*
*D*  CALL:         BAL,R11
*D*
*D*  INPUT:        INPUT STRING IN INPUT BUFFER
*D*
*D*  OUTPUT:       SERIAL # IN SN
*D*                FILE NAME IN FNAME AND CURFILE
*D*                ACCOUNT IN ACCT AND CURACCT
*D*                FLAGS FOR PRESENT OPTIONS IN CUROPT
*D*
*D*  DESCRIPTION:  SUCCESSIVE FIELDS ARE OBTAINED FROM INPUT BUFFER
*D*                VIA GETFIELD.  THEY ARE INTERPRETED AND CHECKED
*D*                IF LEGAL WITH THIS COMMAND AND WITH PREVIOUSLY
*D*                SPECIFIED OPTIONS.
         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
         INT,R2   FBUF+1            IF EXACTLY 6 CHARS, MEBBE DISCADDR
         CI,R3    '  '
         BNE      PAROPT3
         CI,R2    X'BF'
         BAZ      PAROPT3
         LCI      2
         LM,R12   FBUF
         BAL,R15  HEX2BIN
         B        PAROPT3
         CW,R4    DCT%MASK%1        IS THERE A DCTX
         BAZ      PAROPT3           NO
         STW,R4   HEXDA             SAVE IT FOR LATER
         LI,R2    X:XDA
         LI,R3    B:XDA
         B        PAROPT6
PAROPT3  RES
         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
         LH,R2    FBUF              GET THE DEVICE TYPE
         AI,R6    0
         BGZ      %+2               USER SPECIFIED ONE
         LI,R2    'DP'              DEFAULT DEVICE TYPE
         LI,R3    X'FFFF'
         STS,R2   DEVTYPE           PUT TEXT IN FPT
         LCI      4
         LM,R8    SBUF              GET SERIAL NUMBER
         STM,R8   FBUF
         LW,R8    BLANKS
         LI,R12   '.'               CHECK FOR ACCOUNT
         BAL,R11  SPLITFLD
         AI,R7    0
         BLEZ     PARSN20           NONE
         LI,R3    B:ACCT
         LI,R2    X:ACCT
         BAL,R11  CHKOPT            ACCOUNT ONLY
         LCI      2
         LM,R8    SBUF
         STM,R8   ACCT
         STM,R8   CURACCT
PARSN20  RES
         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,REM
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
*D*  NAME:         GETFIELD
*D*
*D*  REGISTERS:    ALL VOLATILE
*D*
*D*  CALL:         BAL,R11
*D*
*D*  OUTPUT:       R7 = # CHARACTERS IN FIELD
*D*                R12 = DELIMITER
*D*                CC = 0  A FIELD WAS FOUND
*D*                   = 4  NO MORE FIELDS EXIST
*D*
*D*  DESCRIPTION:  OBTAIN THE NEXT FIELD FROM INBUF, MOVE IT
*D*                TO FBUF.  LEADING BLANKS ARE IGNORED.  THE
*D*                FIELD TERMINATES WITH THE FIRST DELIMITER.
         SPACE    1
GETFIELD LI,R7    (FBUFSIZ+3)/4
         LI,R8    0
         LW,R9    BLANKS            BLANK FBUF
         STW,R9   FBUF-1,R7
         STW,R8   FBUF1-1,R7
         BDR,R7   %-2
         STW,R7   GETNCHK           CHECK FOR HEX AND CHAR FIELDS
         STW,R7   FLDFLG            NO SPECIAL FIELD IN PROGRESS
         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
         STB,R14  FBUF1,R7          STORE IN FIELD FLAG
         AI,R7    0
         BNEZ     GETF22            NOT FIRST CHAR OF FIELD
         LW,R3    INPOS
         STW,R3   BEGFLD            REMEMBER BEGINNING  OF FIELD
GETF22   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
*D*  NAME:         SPLITFLD
*D*
*D*  REGISTERS:    ALL VOLATILE
*D*
*D*  CALL:         BAL,R11
*D*
*D*  INPUT:        FIELD TO BE SPLIT IN FBUF
*D*                R12 = CHARACTER WHICH SPLITS FIELD
*D*
*D*  OUTPUT:       FIRST STRING IN FBUF, SECOND IN SBUF
*D*                R6 = # CHARS IN FIRST STRING
*D*                R7 = # CHARS IN SECOND (-1 IF SPLIT CHAR NOT FOUND)
*D*
*D*  DESCRIPTION:  THE STRING IN FBUF IS SEARCHED UNTIL THE SPLIT
*D*                CHARACTER IS FOUND.  IF NOT FOUND, EXIT WITH
*D*                R7 = -1.  OTHERWISE, MOVE SECOND FIELD TO SBUF.
*D*                NOTE THAT R6 MAY BE ZERO IF FIRST CHAR OF FBUF
*D*                WAS THE SPLIT CHARACTER.
         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   FBUF1,R6
         BNEZ     SPLIT15           SKIP OVER CHAR AND HEX FIELDS
         LB,R13   FBUF,R6
         CW,R13   R12
         BE       SPLIT20           FOUND SPLIT CHAR
         CI,R13   X'40'             TERMINATE AT BLANK
         BE       *R11
SPLIT15  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      SPLTER1           ERROR - FIELD TOO LONG
         CI,R12   '#'               WITH # PERMIT #XXXX-RT.ACCOUNT1
         BE       %+3
         CI,R7    8                 ALL OTHERS MAX 8 CHARS
         BGE      SPLTER1
         CW,R12   R14
         BE       SPLTER2            ERROR - ANOTHER SPLIT CHARACTER
         STB,R14  SBUF,R7           STORE THIS CHAR
         AI,R7    1
         B        SPLIT25
*
SPLTER1  LI,R14   MF2LNG
         B        SPLITERR
SPLTER2  LI,R14   MILLSYN
SPLITERR LW,R3    BEGFLD            BEGINNING OF FIELD
         AW,R3    R5                ADD CURRENT DISPLACEMENT
         B        ERRORA            PRINT MESSAGE
         TITLE    '****  GETCHAR  ****'
         SPACE    2
*D*  NAME:         GETCHAR
*D*
*D*  REGISTERS:    ALL VOLATILE
*D*
*D*  CALL:         BAL,R10
*D*
*D*  OUTPUT:       R12 = NEXT CHAR
*D*                R13 = CHAR AFTER ONE IN R12
*D*                CC = 0  OK
*D*                   = 1  DELIMITER IN R12
*D*                   = 2  BLANK IN R12
*D*                   = 4  NO NEXT CHARACTER
*D*                R14 = NON-ZERO IF CHAR IN SPECIAL FIELD
*D*
*D*  DESCRIPTION:  GET NEXT CHARACTER FROM INBUF.  THIS ROUTINE
*D*                TAKES CARE OF HEX AND TEXT FIELDS, STRIPPING
*D*                OFF CONTROL SEQUENCES AND BUILDING CHARACTERS
*D*                FROM HEX DIGITS.
         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    LI,R14   0                 NOT SPECIAL FIELD
         B        %+2
GETOK1   LI,R14   1                 CHAR OR HEX FIELD
         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
         B        ERROR2            BAD HEX DIGIT
         LW,R12   R4                MOVE BINARY NUMBER
         B        GETOK1
*
*  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      GETOK1            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    '****  FLAG ERROR  ****'
         SPACE    2
ERROR2   LW,R3    ENDFLD            POINT TO END OF LAST FIELD
         B        ERROR1
ERROR    LW,R3    INPOS
ERRORA   AI,R3    -1
*
*  PRINT ERROR MARKER - R3 CONTAINS INDEX
*
ERROR1   PUSH     R11
         BAL,R11  ERRMARK
         PULL     R11
ERROR3   PUSH     R11
         BAL,R11  DOPRINT
         PULL     R11
         MTW,0    BOOTFLG
         BEZ      ERROR3A           ALREADY UP
         LCI      1                 ERROR DURING BOOT
         B        *R11              RETURN TO CALLER OF GETFIELD
ERROR3A  LI,R1    -1
         STW,R1   ERRCNT            SUPRESS # ERRORS
         LC       J:JIT
         BCR,12   ERROR5            BATCH - EXIT
         BCS,4    ENDPROC2          GHOST
         MTW,0    M:SIFLG           ONLINE - TRY AGAIN IF M:SI
         BEZ      ENDPROC2            ASSIGNED TO TTY
*
ERROR5   LI,R14   MERRXIT
         BAL,R11  DOPRINT
         M:XXX
         SPACE    3
ERRMARK  BAL,R15  INITBUF
         PUSH     R14
         LW,R1    R3
         AI,R1    1                 INDEX OF MARKER
         LI,R4    BA(M%)
         BAL,R10  PUTMESC           PUT IN MARKER
         BAL,R15  DUMPB             PRINT IT
         PULL     R14
         B        *R11
         TITLE    '****  ACCOUNT AND FILE SUMMARIES  ****'
         SPACE    2
*D*  NAME:         FILEINFO
*D*
*D*  REGISTERS:    ALL VOLATILE
*D*
*D*  CALL:         BAL,R11
*D*
*D*  DESCRIPTION:  PRINT SUMMARY FOR ONE FILE:  ORG, #GRANULES,
*D*                # RECORDS, AND FILE NAME.  IF 'FIT' OPTION
*D*                WAS SPECIFIED, SKIP # GRANULES AND # RECORDS.
         SPACE    1
FILEINFO MTW,0    LPFLAG
         BLEZ     *R11              PRINT NOTHING - EXIT
         LH,R14   CURFILE           NOTHING FOR DUMMY FILE
         CI,R14   X'100'
         BE       *R11
         PUSH     R11
         MTW,1    FDHDFLG
         BGZ      FILINF15          ALREADY PRINTED HEADING
         LI,R14   MFDHDR
         BAL,R15  PRINT
*
FILINF15 LW,R1    BUSYCNT
         BNEZ     FILINF18          FILE WASN'T BUSY
         BUILD    (TEXT,MFILBUSY,10)
         B        FILINF20
FILINF18 LW,R1    SYNFLAG
         BNEZ     FILINF20          BR IF SYNONYMOUS FILE
         LI,R1    2                 COL #
         LI,R4    BA(ORGTBL)
         AW,R4    ORGL              BA OF ORGANIZATION CHAR
         LI,R5    1                 # BYTES
         BAL,R10  PUTMES
         LW,R10   CUROPT
         CI,R10   B:FIT             IF LOOKING AT FITS ONLY,
         BANZ     FILINF20            DON'T KNOW GRANULES OR RECORDS
*
         BUILD    (RDEC,*#GRAN,13),(RDEC,*#RECS,26)
*
FILINF20 BUILD    (TEXT,MSPACE,33)
*
         LI,R4    BA(CURFILE)
         BAL,R11  PRKEY             PRINT FILE NAME
         LI,R15   FILINF25          RETURN
         LW,R11   BUSYCNT
         BNEZ     DUMPBUF           FILE WASN'T BUSY
         B        DUMPB             TELL USER FILE BUSY
*
FILINF25 LW,R11   SYNFLAG
         BEZ      FILINF30          NOT SYNONYMOUS
         LI,R4    BA(MSYNON)
         BAL,R10  MOVTXTC
         LW,R4    FITNAME           BA OF FIT NAME
         BAL,R11  PRKEY
         BAL,R15  DUMPBUF
*
FILINF30 PULL     R11
         B        *R11
         SPACE    4
ACCTSUM  MTW,0    LPFLAG
         BLEZ     *R11              DO NOTHING UNLESS PRINT ALL
         PUSH     R11
         BUILD    (TEXT,MGRANFIL),(DEC,*#FILGRAN),;
                  (TEXT,MDRCTRY),(DEC,*#FDGRAN)
         LW,R3    #RANFIT
         BEZ      ACCTS25           DON'T PRINT IF ZERO
         BUILD    (TEXT,MRANFIT),(DEC,*#RANFIT)
ACCTS25  BUILD    (TEXT,MTOTAL)
         LW,R3    #FILGRAN
         AW,R3    #FDGRAN
         AW,R3    #RANFIT
         BAL,R10  MOVDEC
         PULL     R15
         B        DUMPBUF
         TITLE    '****  ERROR ROUTINES  ****'
         SPACE    2
PRIVLOW  LI,R14   MPRIVLOW          NOT ENOUGH PRIV
MESSOUT  BAL,R11  DOPRINT
         M:XXX
*
BADMON   LI,R14   MBADMON           BAD MONSTK
         LC       J:JIT
         BCR,4    MESSOUT           NOT GHOST
         M:TYPE   (MESS,*R14)
         M:XCON   0                 TURN OFF EXIT CONTROL
         M:XXX
*
SUPERCLS CAL1,9   6                 SUPERCLOSE
         LI,R11   0
         STW,R11  WORKFLAG
         B        LOOPEND
*
EXIT     EQU      %
         LC       J:JIT
         BCR,4    EXIT2             EXIT IF NOT GHOST
         LI,R11   0
         XW,R11   WORKFLAG
         BEZ      %+2               DON'T SUPERCLOSE UNLESS WORK DONE
         CAL1,9   6                 SUPERCLOSE
         LI,R11   0
         STW,R11  OCREQ1            OPERATOR COMMUNICATION TERMINATED
         B        GHSTIDLE          GO TO IDLE LOOP
*
EXIT2    M:XCON   0                 TURN OFF EXIT CONTROL
         BAL,R5   CLEANDCB
         M:EXIT
         TITLE    '****  INTERRUPT HANDLER  ****'
         SPACE    2
*F*  NAME:         INTADR
*F*
*F*  PURPOSE:      HANDLE M:INT INTERRUPTS
*F*
*F*  DESCRIPTION:  THIS ROUTINE RECEIVES M:INT INTERRUPTS FOR
*F*                  1 - I/O END-ACTION
*F*                  2 - OPERATOR/USER INT KEYIN/BREAK KEY
*F*                  3 - FILE MANAGEMENT WHEN 75 ERROR IS DETECTED
         SPACE    1
*D*  NAME:         INTADR
*D*  ENTRY:        INTADR2
*D*
*D*  REGISTERS:    ALL PRESERVED.  THE USER REGISTERS ARE SAVED
*D*                IN TCB STACK BEFORE COMING HERE.
*D*
*D*  CALL:         ENTER HERE WHEN SCHEDULER NOTICES E:CBK EVENT
*D*
*D*  INPUT:        R1 = ADDRESS OF PSD IN TCB STACK
*D*
*D*  DESCRIPTION:  SAVE PSD POINTER IN TCB.  IF WAS INTERRUPTED
*D*                IN INTERRUPT ROUTINE, EXIT.
*D*                INT75:  IF THIS USER IS SAME AS CELL LFGUN
*D*                  (THIS USER IS HANDLING FREPORT FUNCTIONS),
*D*                  MOVE ANY USER NUMBERS FROM 75BUF TO INTERNAL
*D*                  CELL SAVBUF.
*D*                INTIO:  IF THERE IS AN I/O END-ACTION MPOOL BUFFER,
*D*                  TRY TO PULL A WORD OUT OF ITS STACK.  IF
*D*                  SUCCESSFUL, CALL ROUTINE EA TO PROCESS THE
*D*                  MAPPED END-ACTION FOR THE I/O REQUEST.
*D*                INTEND:  IF SOMETHING WAS DONE ON THIS PASS,
*D*                  GO BACK TO TOP TO SEE IF THERE IS ANYTHING ELSE
*D*                  TO DO.  IF NOT, CHECK IF # INTERRUPTS >
*D*                  # ITEMS PROCESSED.  IF SO, OPERATOR TYPED 'INT'
*D*                  OR ONLINE USER PUSHED BREAK.  IF GHOST AND KEYIN
*D*                  SEQUENCE ALREADY IN PROGRESS, IGNORE, OTHERWISE
*D*                  START ONE BY QUEUEING UP KEYIN SEQUENCE TO OC.
*D*                  SET DISPFLG SO THAT CURRENT FILE/ACCOUNT
*D*                  WILL BE DISPLAYED.  IF ONLINE, RESET # COC
*D*                  BREAKS RECEIVED TO ZERO.
*D*                PULLE:  PULL ENVIRONMENT FROM TCB AND EXIT.
         SPACE    2
INTADR   EQU      %
         DISABLE                    **** DISABLE
*
INTADR2  PSW,R1   *J:TCB            SAVE ADDRESS OF PSD
*
         MTW,1    INTR1             COUNT # INTERRUPTS
         BAL,R11  RSETBRK           RESET UH:DL
         LW,R7    J:TCB
         INT,R8   1,R7
         CW,R9    ENVSIZE           CHECK TCB STACK FOR > 1 ENVIR
         BG       PULLE             YES - GET OUT
         LI,R8    1
         STW,R8   INTR1             COUNT THIS INTERRUPT
INTADR4  LI,R8    0
         STW,R8   INTP              # ITEMS PROCESSED
*
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
         XW,R8    INTR1
         AWM,R8   INTR              INCREMENT TOTAL # INTERRUPTS
         CW,R8    INTP              COMPARE # INTERRUPTS RECEIVED WITH
         BG       INTEND4             # OPERATIONS PERFORMED
         LC       J:JIT
         BCR,8    PULLE             NOT ONLINE
         LI,R2    X'FF'             CHECK TO SEE IF ANY COC
         AND,R2   M:UC+1              BREAKS RECEIVED
         LB,R8    MODE,R2
         CI,R8    3
         BAZ      PULLE             NO
INTEND4  MTW,1    DISPFLG           SET TO DISPLAY CURRENT INFO
         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
         MTW,1    OCREQ
         LW,R11   INTR1             HAVE ANY INTERRUPTS COME IN
         BNEZ     INTADR4           YES - PROCESS THEM
INTEND8  MTW,1    OCREQ             OPERATOR COMMUNICATION IN PROGRESS
         LC       J:JIT
         BCR,8    PULLE             NOT ONLINE
         CAL1,8   MODEFPT           RESET # COC BREAKS RECEIVED
         SPACE    3
*
*  PULL ENVIRONMENT FROM TCB STACK AND EXIT
*
PULLE    DISABLE                    **** DISABLE
         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
RSETBRK  LW,R4    S:CUN
         LH,R5    UH:DL,R4
         AND,R5   =X'EFFF'          RESET BRK BIT
         STH,R5   UH:DL,R4
         B        *R11
         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
*D*  NAME:         EA
*D*
*D*  DESCRIPTION:  PERFORMED MAPPED END-ACTION.
*D*                ALL I/O THAT NEEDS END-ACTION IS PERFORMED SPECIFYING
*D*                AN MPOOL AS THE END-ACTION ADDRESS.  THE ROUTINE
*D*                IN THE MPOOL, ENTERED WHEN THE I/O COMPLETES,
*D*                PUSHES A WORD OF INFORMATION INTO A STACK IN THE
*D*                MPOOL AND REPORTS THE BREAK EVENT (E:CBK) FOR FIX.
*D*                EVENTUALLY, FIX IS ENTERED AT INTADR, AND WE END
*D*                UP HERE WITH THE INFO WORD FROM THE MPOOL STACK
*D*                IN R4 AND THE BUF TABLE INDEX IN R7.
*D*                IF R7 >= X'F0', GO TO SPECIAL PROCESSING ROUTINE
*D*                (LP I/O, OC I/O DON'T USE BUF TABLES, BUT HAVE
*D*                SPECIAL INDICES INSTEAD).
*D*                THE END-ACTION BUFFER TYPES ARE:
*D*                  1 - NOT IMPLEMENTED
*D*                  2,3 - VALIDATE THE BUFFER JUST READ
*D*                        WITH VALBUF.  OBTAIN ANOTHER BUFFER OF
*D*                        SAME TYPE, LINK IT TO CURRENT BUFFER VIA
*D*                        BUFLINK, AND START I/O FOR IT.  TYPE 2
*D*                        READS BLINKS, TYPE 3 FLINKS.  IF AN ERROR
*D*                        RESULTS FROM VALBUF, SAVE ERROR CODE IN
*D*                        BUFINFO AND STOP.  IF CAN'T GET ANOTHER
*D*                        BUFFER, SET FL:EA TO CAUSE THIS END-ACTION
*D*                        TO BE REPEATED WHEN A BUFFER IS RELEASED.
*D*                  4 - RELEASE A BUFFER.  MOVE BUFDUAL TO BUFDA, ZERO
*D*                      BUFDUAL.  IF NEW BUFDA IS ZERO, EXIT.  OTHERWISE,
*D*                      QUEUE A WRITE TO THE DUAL.
*
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    PUSH     R4
         LW,R4    S:CUN
         MTB,0    UB:MF,R4
         BNEZ     %-1
         M:SNAP   'EA ERR',(D,DEND)
         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     R11               RETURN LINK
         LW,R15   R11               MOVE FOR RELBUF
         LI,R8    0
         XW,R8    BUFDUAL,R7        MOVE DUAL TO MAIN
         AND,R8   M24
         STW,R8   BUFDA,R7
         BEZ      RELBUF            NO DUAL - RELEASE BUFFER
         B        DISCWRT           WRITE TO DUAL
         SPACE    3
*
*  END-ACTION FOR LINE PRINTER (PUBLIC HGP RECON ONLY)
*
LPEA     EQU      %
         LB,R9    R4                GET TYC
         CI,R9    5
         BNE      LPEA80            NOT END OF TAPE
         MTW,0    LPTAPE
         BEZ      LPEA80            NOT WRITING TO TAPE DRIVE
*
         LW,R12   LPDCTX            DCT INDEX OF TAPE DRIVE
         BLEZ     LPEA80            NOT THERE
         LI,R13   3                 WRITE TAPE MARK
         BAL,R11  CALLNEWQ
         BAL,R11  CALLNEWQ          AND ANOTHER ONE
         LI,R13   X'B'              REWIND OFF-LINE
         BAL,R11  CALLNEWQ
*
LPEA80   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
         MI,R13   32
         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 CODE:  WRITE WITH FORMAT (LP)
         LW,R7    LPTAPE            IS I/O GOING TO TAPE
         BEZ      LPIO5             NO
         LI,R2    1                 YES - FCN CODE FOR 9T WRITE
         LW,R1    R13               BA OF MESSAGE
         AW,R1    R14               BA OF FIRST BYTE PAST MESSAGE
         CI,R14   12
         BGE      LPIO5
         LI,R14   12                FORCE RECORD LENGTH > NOISE LENGTH
         STB,R14  R1
         MBS,R0   BA(BLANKS)        MOVE IN TRAILING BLANKS
*
LPIO5    LI,R7    XLPIO             SPECIAL BUFFER INDEX
         B        IOQUEUE           QUEUE THE I/O
*
CALLNEWQ PUSH     3,R11
         OR,R12   =X'200A00'        PRIO, RETRIES
         STB,R13  R12               FUNCTION CODE
         LI,R0    0                 NO END-ACTION
         BAL,R11  NEWQNWM           QUEUE THE I/O
         NOP
         PULL     3,R11
         B        *R11
         SPACE    3
*
*  END-ACTION FOR READ FROM OPERATOR'S CONSOLE
*
OCRD     EQU      %
         LB,R2    R4                TYC
         CI,R2    1
         BE       OCRD10            NORMAL TYC
         STW,R2   INBUF             ZAP BUFFER
         LI,R4    OCRDCNT           PRETEND NO BYTES READ
OCRD10   AND,R4   M16               REMAINING BYTE COUNT
         LCW,R4   R4
         AI,R4    OCRDCNT           R4 = # BYTES READ
         BNEZ     %+2
         STW,R4   INBUF             NO INPUT ZAPS BUFFER TOO
         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   1
         BE       OCHK70            ONE CHAR MEANS IGNORE MESSAGES
         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,R4    FBUF              IOP MNEMONIC
         CI,R4    ' '
         BE       OCERR             BLANK IS ILLEGAL
         LI,R7    #CLUS             ASSUME 560
         LI,R12   CLUSTER
         BIF,X560 OCHK11            BR IF 560
         LI,R7    #SIGIOP           THIS IS A SIGMA MACHINE
         LI,R12   SIGIOP
OCHK11   CB,R4    *R12,R7           SEARCH TABLE FOR MNEMONIC
         BE       OCHK12            FOUND IT
         AI,R7    -1
         BGEZ     OCHK11
         B        OCERR             ILLEGAL MNEMONIC
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
         B        OCERR             BAD HEX DIGIT
         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   LW,R4    R7                MOVE THE CHANNEL CHAR
         LI,R7    #CLUS
OCHK15   CB,R4    CLUSTER,R7        SEARCH TABLE FOR IT
         BE       OCHK12
         AI,R7    -1                KEEP LOOKING
         BGEZ     OCHK15
         B        OCERR             ILLEGAL MNEMONIC
*
OCHK20   LC       DCT3,R5
         BCS,2    OCERR             THE SPECIFIED DEVICE IS PARTITIONED
         STW,R5   LPDCTX            SAVE NEW DCT INDEX
         LI,R11   0                 ASSUME DEVICE NOT TAPE
         LB,R4    DCT4,R5           DEVICE TYPE
         LC       TB:FLGS,R4
         BCR,8    OCHK22            NOT TAPE
         BCS,4    OCHK22            NOT TAPE
         LI,R11   1                 TAPE
OCHK22   STW,R11  LPTAPE
*
OCHK30   MTW,1    OCFLG             SET TO PROCESS SECOND MESSAGE
         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
         LH,R4    INBUF             GET RESPONSE
         BEZ      OCHK60
         LB,R5    OCHKANS
         CB,R4    OCHKANS,R5
         BE       OCHK60
         BDR,R5   %-2
         B        OCERR
OCHK60   AI,R5    -2
         STW,R5   LPFLAG
OCHK70   LI,R4    -1
         STW,R4   OCFLG             SEQUENCE TERMINATED
         LI,R4    0
         STW,R4   OCREQ             OPERATOR COMMUNICATION DONE
         B        EAXIT
OCHKANS  TEXTC    'NEAF'
*
*  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  LW,R2    LPDCTX            DCT INDEX OF LINE PRINTER
         LH,R2    DCT1,R2           ADDRESS OF PRINTER
         STW,R2   TEMP              SAVE IT
         AND,R2   M8                '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   TEMP
         SLS,R7   -8                RIGHT JUSTIFY IOP ADDRESS
         LB,R9    CLUSTER,R7        ASSUME 560
         BIF,X560 OCMESS2           CORRECT
         LB,R9    SIGIOP,R7         NO, SIGMA
OCMESS2  STB,R9   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
*O*  MESSAGE:      CHANGE LP ADDRESS  LPNDD => LP
*O*  ACTION:       TYPE IN NEW ADDRESS FOR LINE PRINTER, OR JUST
*O*                CARRIAGE RETURN TO LEAVE IT THE SAME.
*O*  MEANING:      DURING HGP RECONSTRUCTION, THE OPERATOR KEYED IN
*O*                'INT FIX.', AND FIX IS ASKING IF THE ADDRESS OF
*O*                LINE PRINTER IT USES IS TO BE CHANGED.  THE DEVICE
*O*                ADDRESS SUPPLIED BY THE OPERATOR MAY BE ANY
*O*                LINE PRINTER OR TAPE DRIVE KNOWN TO THE SYSTEM.
         TITLE    '****  EXIT CONTROL ROUTINE  ****'
         SPACE    2
*
*  EXIT CONTROL
*
XCONADR  M:INT    INTADR            RE-ESTABLISH INTERRUPT CONTROL
         PUSH     4,R8
         M:SYS,E  M:SYSFPT          MASTER MODE
         M:XCON   0                 TURN OFF EXIT CONTROL
         LW,R1    0,R1              PSD FROM TCB
         AND,R1   M17
         CI,R1    X'A000'           MUST BE ABOVE A000 OR M:MERC GOOFS
         BGE      %+2
         LI,R1    X'A000'
         STW,R1   ABRTLOC           SAVE IT FOR M:MERC
*
         LW,R2    S:CUN
         LB,R7    UB:MF,R2          WAIT FOR I/O TO COMPLETE
         BNEZ     %-1
         CW,R2    LFGUN
         BNE      %+2               NOT THE GHOST COPY
         STW,R7   LFGUN             PREVENT USERS FROM BEING QUEUED
         DISABLE                    ****  DISABLE
         BAL,R11  RSETBRK           RESET BREAK BIT
         ENABLE                     ****  ENABLE
         LW,R7    J:TCB
         INT,R8   1,R7              R9 = CURRENT TCB STACK SIZE
         AI,R9    25
         STW,R9   ENVSIZE           SAVE ENVIRONMENT SIZE
         LCI      2
         LM,R8    LOGACCT           RESTORE LOG-ON ACCOUNT
         STM,R8   J:ACCN
         PULL     4,R8
         CI,R8    X'FF'
         BAZ      EXIT2             M:EXIT - RE-ISSUE THE CAL
*
         CI,R8    X'30'
         BANZ     OPABRT            OPERATOR ABORT OR ERROR
*
         CI,R8    X'F8'             IS IT TRAP OR LIMIT
         BANZ     CLEANUP           NO
*
*  TRAP OR LIMIT EXCEEDED
*
         SLS,R10  24                MAJOR CODE IN BYTE 0
         SLS,R11  17                MOVE SUB-CODE
         OR,R10   R11               COMBINE
         STW,R10  ABRTCODE          SAVE IT
         CW,R10   =X'A5080000'      ONLINE CTRL-Y (A5-04)
         BE       CLEANUP           YES - DON'T SNAP
XCONDMP  SNAP     'XCON'
*
*  ATTEMPT TO CLEAN UP LOOSE ENDS
*
CLEANUP  BAL,R11  REL               RELEASE OCU, MPOOL, BUFFERS
         BAL,R11  RELPACKS          REL EXCL USE OF PACKS
*
         LCI      2
         LM,R8    LOGACCT           RESTORE LOGON ACCOUNT
         STM,R8   J:ACCN
         LW,R14   BOOTFLG
         BNEZ     NORECON           MUST BE DOING PUBLIC RECON
         MTW,0    IDLEFLAG
         BNEZ     EXIT2             IDLE - DON'T PRINT ERROR MESSAGE
         BAL,R5   CLEANDCB          CLEAN UP DCBS
         LW,R8    ABRTLOC           ADDRESS OF TRAP
         LW,R10   ABRTCODE
         BEZ      %+2               NOT TRAP
         M:MERC                     GIVE USER THE TRAP MESSAGE
         M:XXX
*
CLEANDCB M:CLOSE  M:LO,SAVE
         LC       J:JIT
         BCR,8    0,R5              NO MORE UNLESS ONLINE
         M:DEVICE M:UC,NOVFC
         B        0,R5
*
OPABRT   MTW,0    IDLEFLAG          OPERATOR ABORT OR ERROR
         BEZ      XCONDMP           NOT IDLE - DUMP CORE
         LI,R11   0
         STB,R11  J:EXTENT          ZAP EXIT CONTROL FLAGS
         M:CLOSE  M:LO,SAVE
         CAL1,8   LDEVDLT           M:LDEV 'L1',DELETE
         M:EXIT
         SPACE    3
BUFERR   SNAPX    'BUFFER ERR'
         SPACE    3
SNAPDAT  XW,R4    *SPD
         LCI      0
         STM,R0   REGS              SAVE THE REGISTERS
         BAL,R15  INITBUF
         LI,R4    BA(MDSP)          DOUBLE SPACE
         BAL,R10  MOVTXTC
         LW,R4    *SPD              ADDRESS OF LOC AFTER BAL
         MTB,0    *R4
         BNEZ     %+2               IT'S TEXTC
         LW,R4    0,R4              NO - POINTER TO TEXT
         SLS,R4   2
         BAL,R10  MOVTXTC
         BAL,R15  DUMPBUF
*
         LI,R4    BA(MLOC)
         BAL,R10  MOVTXTC
         LW,R2    *SPD
         AI,R2    -2                ADDRESS OF SNAP PROC
         BAL,R10  MOVHEX
         BAL,R15  DUMPBUF
*
         LI,R14   MREGS
         BAL,R15  PRINT
         LI,R12   REGS
         LI,R13   16
         LI,R14   0
         BAL,R11  HEXDUMP           DUMP REGISTERS IN HEX
*
         LI,R14   MDATA
         BAL,R15  PRINT
         LI,R1    FPMC              FREE PAGE MAP CONSTANT
         LI,R2    JBUPVP            FIRST USER PAGE #
SNAPD1   COMPARE,R1  JX:CMAP,R2
         BE       SNAPD4            NO PAGE HERE
         CLM,R2   J:DLL
         BCR,9    SNAPD2            BR IF DATA PAGE
         CLM,R2   J:DDLL
         BCS,9    SNAPD4            BR IF NOT DATA OR DYN DATA
SNAPD2   LW,R12   R2
         SLS,R12  9
         LW,R14   R12
         LI,R13   512
         BAL,R11  HEXDUMP           DUMP IT
SNAPD4   AI,R2    1                 INCR TO NEXT PAGE
         CW,R2    J:EUP
         BLE      SNAPD1            GO TO END OF USER
*
         PULL     R4                ADDR OF WORD AFTER BAL
         LB,R5    *R4
         SLS,R5   -2
         AI,R5    1                 # WORDS OF TEXT
         AW,R4    R5                ADDRESS TO RETURN TO
         STW,R4   SNAPRET
         LCI      0
         LM,R0    REGS              RESTORE ORIGINAL REGISTERS
         B        *SNAPRET
         TITLE    '****  GHOST INITIALIZATION  ****'
         SPACE    2
GHSTINIT EQU      %
         LW,R5    BOOTFLG
         BNEZ     SYSINIT           SYSTEM NOT UP YET - DO INITIALIZATION
         M:OPEN   M:LO,OUT,SAVE
         LW,R4    S:CUN
         LW,R5    LFGUN
         BNEZ     %+3
         STW,R4   LFGUN
         STW,R5   75BUF
*
         BUILD    (TEXT,MKEY1),(HEX,*S:CUN),(TEXT,MKEY2)
         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    '****  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'
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    ' FIX LOADED WITH WRONG MONSTK'
MFITM    TEXTC    'FIT'
MPROMPT  TEXTC    ' FIX F00 HERE'
MUNKCOM  TEXTC    ' UNKNOWN COMMAND'
MERRXIT  TEXTC    '  INPUT ERRORS - JOB ABORTED'
MDUPOPT  TEXTC    ' DUPLICATE OPTION'
MOPTERR  TEXTC    ' CONFLICTING OPTIONS'
MSNGHST  TEXTC    ' OPTION ILLEGAL FOR GHOST'
MDUALOK  TEXTC    'A DUAL SUCCESSFULLY READ'
MNOSACCT TEXTC    ' NO SUCH ACCOUNT'
MNOSFILE TEXTC    ' NO SUCH FILE'
MNOSGRAN TEXTC    ' NO SUCH GRANULE'
MIOERR   TEXTC    'A**** I/O ERROR '
MERR     TEXTC    ' ERROR'
MS       TEXTC    'S'
MERR1    TEXTC    'NO ERROR'
MMULDEL  TEXTC    'CUPPER LEVEL INDEX DELETED'
MADERR   TEXTC    'BACCOUNT DIRECTORY ERROR - COMMAND ABORTED'
MNULLFD  TEXTC     'B**** NULL FILE DIRECTORY DELETED'
MFILE    TEXTC    'FILE'
MKEYMUL  TEXTC    'KEYED UPPER LEVEL INDEX'
MFILBUSY TEXTC    '** FILE BUSY **'
MSPACE   TEXTC    ' '
MKEY1    TXTC     0,CR
MKEY2    TXTC     ':',TAB,PC
MOC1     TXTC     CR,'CHANGE LP ADDRESS   LPNDD => LP'
MOC2     TXTC     CR,'PRINT ALL, FILENAMES, ERRORS ONLY, OR ',;
                  'NOTHING (A/F/E/N)? '
MDSP     TEXTC    'B'
MLOC     TEXTC    'BSNAP LOCATION = '
MREGS    TEXTC    'BREGISTERS:'
MDATA    TEXTC    'BDATA:'
MAD      TEXTC    ' AD = '
MFD      TEXTC    ', FD = '
MFIT     TEXTC    ', FIT = '
MNOSNACT TEXTC    ' MISSING SN OR ACCOUNT'
MGRANCYL TEXTC    ' # GRANULES/CYL'
MVTOCBIG TEXTC    ' VTOC TOO BIG - # GRAN/CYL TOO SMALL OR TO0 ',;
                    'MANY SN''S'
MINPSN   TEXTC    ' INPUT OTHER SN''S'
MMISFNAM TEXTC    ' MISSING FILE NAME'
MNOCFU   TEXTC    ' NO SUCH FILE OPEN'
MPRIM    TEXTC    ' INPUT PRIMARY SN'
MVTOC    TEXTC    'C  VTOC:'
MACCT    TEXTC    'ACCOUNT'
MFILES   TEXTC    '# FILES'
MFDGRAN  TEXTC    '# FD GRANULES'
M%       TEXTC    '%'
MGRANFIL TEXTC    'A    GRANULES:  FILE = '
MDRCTRY  TEXTC    ', DIRECTORY = '
MRANFIT  TEXTC    ', RANDOM FITS = '
MTOTAL   TEXTC    ', TOTAL = '
MFDHDR   TEXTC    'AORG     GRANULES     RECORDS       NAME'
MSYNON   TEXTC    '    SYNONYMOUS TO '
         TITLE    '****  STATIC DATA  ****'
         SPACE    2
*
DELIMS   DATA,1   0,'/',';',' '
#DELIM   EQU      BA(%)-BA(DELIMS)-1
         BOUND    4
BLANKS   TEXT     ' '
*
ORGTBL   TEXT     'CCKR'
*
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'
M8       DATA     X'000000FF'
M16      DATA     X'0000FFFF'
M17      DATA     X'1FFFF'
M24      DATA     X'00FFFFFF'
M27      DATA     X'7FFFFFF'
Y06      DATA     X'6000000'
Y8       DATA     X'80000000'
Y01      DATA     X'01000000'
Y002     DATA     X'00200000'
Y004     DATA     X'00400000'
Y008     DATA     X'00800000'
Y00F     DATA     X'00F00000'
X1       DATA     X'00000001'
*
MODEFPT  GEN,8,3,21  6,1,0
         DATA     X'80000000'
         DATA     3                 RESET # BREAKS RECEIVED
LDEVDLT  GEN,8,24 X'1A',0
         DATA     X'80000040'
         DATA,2   0,'L1'
*
*  SIGMA IOP NUMBER TO MNEMONIC CONVERSION TABLE
*
SIGIOP   TEXT     'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
#SIGIOP  EQU      BA(%)-BA(SIGIOP)-1
*
*  560 CLUSTER/UNIT NUMBER TO MNEMONIC CONVERSION TABLE
*
CLUSTER  TEXT     'A%#@:   '
         TEXT     'BCDEFG  '
         TEXT     'HIJKLM  '
         TEXT     'NOPQRS  '
         TEXT     'TUVWXY  '
         TEXT     'Z01234  '
         TEXT     '56789ž  '
#CLUS    EQU      BA(%)-BA(CLUSTER)-1
*
*  PATCH AREA
*
PT:      EQU      %
         DO1      80
         DATA     0
         TITLE    '****  DYNAMIC DATA  ****'
         SPACE    2
         USECT    D
*
STKSIZ   EQU      80
SPD      DATA     %+1
         DATA,2   STKSIZ,0
         DO1      STKSIZ
         DATA     X'BAD'
         DATA     P
REGS     RES      16
#EASTACK EQU      6
*
*  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,1
SN       DATA     0
*
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,1
PVSN     RES      1
*
VTOPEN   GEN,8,24 X'14',F:PV
         DATA     X'C0040003'       DEVICE PACK
         DATA     FIXERR,FIXERR
VTDEV    DATA     0
         DATA,1   7,1,1,1
VTSN     DATA     0
*
INBUFSIZ EQU      81
         DATA     'A'               VFC CHAR
INBUF    RES      (INBUFSIZ+3)/4
*
FBUFSIZ  EQU      40
FBUF     RES      (FBUFSIZ+3)/4
FBUF1    RES      (FBUFSIZ+3)/4
*
SBUFSIZ  EQU      16
SBUF     RES      (SBUFSIZ+3)/4
*
PRBUF    RES      34                OUTPUT PRINT BUFFER
PRPOS    DATA     BA(PRBUF)         NEXT AVAILABLE BYTE
*
INCNT    RES      1
INPOS    RES      1
BEGFLD   RES      1
FLDFLG   DATA     0
ENDFLD   DATA     0
GETNCHK  DATA     0
M:SIFLG  DATA     0
ABRTCODE DATA     0
ABRTLOC  DATA     0
ADLOC    RES      1
FDLOC    RES      1
FITLOC   RES      1
FINDLOC  RES      1
FDHDFLG  RES      1
SNAPRET  RES      1
PARSERET RES      1
ECHODCB  RES      1
EASPD    DATA     0
MPOOLADR DATA     0
ADCMD    RES      1
ACCT     RES      2
FNAME    RES      8
NXTF     RES      1
FIXNAME  RES      1
FIXACCT  RES      1
LOGACCT  RES      2                 LOGON ACCOUNT
TEMP     RES      16
*
SCRL     RES      1
CMDL     RES      1
ORGL     RES      1
LDAL     RES      1
GAVALC   DATA     1                 CYLINDER SIZE OF GAVAL CYLINDER
GAVALL   DATA     0
CCBDL    RES      1
SRECL    RES      1
         RES      1
EOFCMD   RES      3
EOFDA    RES      2
DIRCMD   RES      1
KEYLEVEL RES      1
KEYSIZE  RES      1
TYPEFLAG RES      1
*
CBUFS    EQU      %-1
CURBUF   RES      1
PREVBUF  RES      1
PREV1BUF RES      1
NXTBUF   RES      1
#CBUFS   EQU      %-CBUFS-1
*
FITBUF   RES      1
DIRBUF   RES      1
FITDA    RES      1
BUSYCNT  DATA     5
CORESDCB DATA     0                 ASSUME M:LO/ECHODCB NOT SAME DEVICE
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
PREVFLAG RES      1
SYNFLAG  RES      1
DISPFLG  DATA     0
LOCDA    RES      1
LOCDUAL  RES      1
DIRFDA   RES      1
HEXDA    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
LPTAPE   DATA     0                 NON-ZERO IF WRITING TO TAPE
LPFLAG   DATA     1                 PRINT EVERYTHING
OCIOCNT  DATA     0                 # I/O'S QUEUED TO OC
MKEYIN   RES      3
FITFLAG  DATA     0
IDLEFLAG DATA     0                 0 = NOT IDLE
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
#PAGES   DATA     0                 # PAGES OBTAINED FOR HGPS
VTOCEND  RES      1
GRANCYL  RES      1
NSN      RES      1
VTPRIM   RES      1
ENVSIZE  DATA     25                INITIAL ENVIRONMENT SIZE
WORKFLAG DATA     0
#FILGRAN RES      1
#FDGRAN  RES      1
#RANFIT  RES      1
#GRAN    RES      1
#FILES   RES      1
#FDS     RES      1
#FDGRANS RES      1
*
*  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
#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
*
*
COMINDX  RES      1
*
CUROPT   RES      1
SNAPFLAG DATA     0
SNAP:    EQU      SNAPFLAG          FOR PATCHING
COMPFLAG DATA     1
*
*  BREAK INTERRUPT RECEIVER
*
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
         DEF      LF
         RES      (#BUF+T)/T+(T=1)
         PEND
#BUF     EQU      15
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
*
*  PATCH AREA
*
         DO1      20
         DATA     0
DEND     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|S:UFV(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) DATA   0
         DEF      AF(R(5),2)
         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
         DEF      LF(1)
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:FIT,B:VTOC,B:CFU,B:XDA)
         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:XDA,;
                    B:FIT,B:VTOC,B:CFU,B:HGPS)
         COMMAND  'CHEC',(LOC,ACNDIR),;
                    (OPT,B:SN,B:FNAM,B:ACCT,B:AD,B:FD,B:FIT)
         COMMAND  'FIND',(LOC,ACNDIR),(FLAG,FINDFLAG),;
                    (OPT,B:SN,B:ACCT,B:FNAM)
         COMMAND  'HGPR',(LOC,HGPR),(OPT,B:SN,B:ACCT),(FLAG,HGPRFLAG)
         COMMAND  'END',(LOC,EXIT)
         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:HGPS)
B:ALL    SET      0                 NOT IMPLEMENTED
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:VTOC   OPTION   'VTOC',(OPT,B:SN)
B:XDA    OPTION   X:XDA,(OPT,B:SN)  DISC ADDRESS
B:CFU    OPTION   'CFU',(OPT,B:SN,B:FNAM)
B:HGPS   OPTION   'HGPS',(OPT,B:SN,B:ACCT,B:F)
         TITLE    '****  DCBS  ****'
         SPACE    2
M:LO     DSECT    1
M:LO     M:DCB    (FILE,8),(ASN,DEVICE),(DEVICE,'LP'),OUT,SAVE
M:DO     M:DCB    (FILE,8),(ASN,DEVICE),(DEVICE,'LP'),OUT,SAVE
F:FIX    DSECT    1
F:FIX    M:DCB    (FILE,8),(SN,#SN)
F:PV     DSECT    1
F:PV     M:DCB    (FILE,8),(SN,#SN)
         USECT    P
         END      START

