*M*      FSAVE    FAST SAVE PROCESSOR.
*P*      NAME:    FSAVE
*P*      PURPOSE: TO SAVE PUBLIC FILES ON PERMANENT DISK STORAGE TO
*P*               SECONDARY TAPE STORAGE AT OR NEAR TAPE SPEED. FILES
*P*               ARE SAVED ON A SELECTIVE BASIS.
*P*      DESCRIPTION: THE FSAVE PROCESSOR MUST BE RUN UNDER AN ACCOUNT
*P*               WITH C0 PRIVILEGE. THE TASKS TO BE PERFORMED ARE
*P*               DEFINED BY CONTROL COMMANDS AND THE FILES TO BE
*P*               SELECTED ARE DEFINED BY DATA RECORDS THAT FOLLOW
*P*               THE CONTROL COMMAND TO WHICH THEY APPLY.
*P*
*P*               FSAVE BYPASSES FILE MANAGEMENT AND INTERFACES
*P*               DIRECTLY WITH IOQ FOR ALL I/O OPERATIONS EXCEPT
*P*               FOR OPENING AND CLOSING THE OUTPUT TAPES (AS FREE
*P*               FORM TAPES). THUS, THE FILE MANAGEMENT TABLE
*P*               STRUCTURES AND VOLUME ORGANIZATIONS ARE KNOWN TO
*P*               FSAVE IN ORDER TO SIMULATE DISK AND XEROX
*P*               LABELED TAPE OPERATIONS. EACH FILE THAT IS
*P*               SAVED RETAINS ALL ITS ATTRIBUTES AND CAN BE
*P*               RESTORED BY EITHER THE FRES OR THE FILL PROCESSOR.
*P*      REFERENCE: OPERATIONS REFERENCE MANUAL.
*************
*
EASECT   CSECT    0
*
DATASEC  CSECT    0
*
PROCED   CSECT    1
*
FSTART   EQU      %
*
*
*
* NOTE: THE FOLLOWING ASSEMBLY SWITCH ALLOWS 6 DIFFERENT
*       VERSIONS OF FSAVE TO BE PRODUCED.
*
*        SWITCH SETTING            RESULT
*        --------------            ------
*           -1                      BPM/BTM F00/F01 ONLY...
*            +0                     BPM/BTM ...
*            +1                     UTS B01 ONLY
*            +2                     UTS C00 ONLY
*           +3                      UTS C01
*             +4                 UTS D00
*
**************
TAURUS   SET      1
SIGMA7   SET      1                 MBS VERSUS LB/STB STUFF
CPVC00   SET      1
UTS      SET      1
CPV      SET      2                 CPV SYSTEMS (ALL OF EM)
FILL     SET      1
*
         DO       CPV=0
UTS      SET      0                   BPM/BTM
         ELSE
UTS      SET      5                 FINAL UTS WAS D00
         FIN
*
         DO       CPV>=2
FILL     SET      1                 MAKE FILL COMPATIBLE TAPES
         ELSE
FILL     SET      0                 MAKE FPURGE TYPE TAPES
         FIN
*
         PAGE
         SYSTEM    SIG7FDP
         DO       UTS>=4
UTSPROC  SET      0
S69PROC  SET      1
         SYSTEM   UTS
         FIN
*                                                                           LMSC
*  PROCS ADAPTED FROM 'SYSTEM UTS'                                          LMSC
*                                                                           LMSC
LDCTX    CNAME                                                              LMSC
         PROC                                                               LMSC
         DO             NUM(AF)=2                                           LMSC
LF       GEN,1,7,4,3,17 AFA,X'32',CF(2),AF(2),AF(1)                         LMSC
         SLS,CF(2)      -16                                                 LMSC
         ELSE                                                               LMSC
LF       GEN,1,7,4,3,17 AFA,X'52',CF(2),0,AF(1)                             LMSC
         FIN                                                                LMSC
         AND,CF(2)  DCTMASK
         PEND                                                               LMSC
*                                                                           LMSC
*                                                                           LMSC
*                                                                           LMSC
STDCTX   CNAME                                                              LMSC
         PROC                                                               LMSC
LF       GEN,1,7,4,3,17 AFA,X'46',CF(2),AF(2),AF(1)                         LMSC
         SCS,CF(2)      -16                                                 LMSC
         AND,CF(2)  INVDMSK
         GEN,1,7,4,3,17 AFA,X'49',CF(2),AF(2),AF(1)                         LMSC
         SCS,CF(2)      16                                                  LMSC
         GEN,1,7,4,3,17 AFA,X'46',CF(2),AF(2),AF(1)                         LMSC
         PEND                                                               LMSC
*                                                                           LMSC
*                                                                           LMSC
*                                                                           LMSC
         OPEN     SECT%ERR                                                  LMSC
LSECTA   CNAME                                                              LMSC
         PROC                                                               LMSC
SECT%ERR SET      (CF(2)&1)=0|NUM(AF)>1|AF(1)>15|CF(2)=AF(1)                LMSC
         ERROR,7,SECT%ERR 'INVALID PROC USAGE'                              LMSC
LF       EQU      %
         LW,CF(2) SECMSK
         AND,CF(2)      AF(1)                                               LMSC
         MI,CF(2)       5**7                                                LMSC
         SCS,CF(2)      2                                                   LMSC
         STH,AF(1)      CF(2)                                               LMSC
         SCS,CF(2)      16                                                  LMSC
         PEND                                                               LMSC
         CLOSE    SECT%ERR                                                  LMSC
         PAGE
         SYSTEM   BPM
         DO       UTS=-1            F00/F01
         TITLE    ;
 '* * * B P M / B T M  F 0 0 / F 0 1  F I L E  S A V E  * * *'
         ELSE
         DO       UTS=0             GOO ONLY
         TITLE    ;
 '* * * B P M / B T M   F I L E   S A V E * * *'
         ELSE
         DO       UTS=2
         TITLE    ;
 '* * * U T S     C 0 0  F I L E  S A V E * * *'
         ELSE
         DO       UTS=1
         TITLE  ;
 '* * * U  T  S    B 0 0 / B 0 1   F  I  L  E    S  A  V  E * * *'
         ELSE
         DO       UTS=3
         TITLE    ;
 ' * * * U  T  S    C 0 1   F  I  L  E   S  A  V  E * * *'
         ELSE
         DO       UTS=4
         TITLE    ;
 ' * * * U  T  S    D 0 0   F  I  L  E   S  A  V  E * * *'
         ELSE
         DO       CPV>0
         TITLE    ;
 ' * * * C  P  -  V    F  A  S  T    S  A  V  E * * *'
         FIN
         FIN
         FIN
         FIN
         FIN
         FIN
         FIN
         PAGE
*
*        REGISTER NAMING CONVENTIONS
*
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
SR1      EQU      8
R9       EQU      9
SR2      EQU      9
R10      EQU      10
SR3      EQU      10
R11      EQU      11
SR4      EQU      11
R12      EQU      12
R13      EQU      13
R14      EQU      14
R15      EQU      15
         PAGE
*
*
*
*        FILE MANAGEMENT TABLE DEFINITIONS
*
*
*****
*        TABLE KEY LENGTHS
*****
*
FDKEYL   EQU      41                 FILE DIRECTORY KEYS
         DO       CPVC00=1
ACDKEYL  EQU      16                ACCOUNT DIRECTORY KEYS
         ELSE
ACDKEYL   EQU     21                 ACCOUNT DIRECTORY KEYS
         FIN
ACDKEYLPP EQU     21                PRIV PACK ACCOUNT DIR KEYS
MIXKEYL  EQU      14                TOTAL INDEX SECTOR KEY
*                                   LENGTH (PLUS KEYM VALUE)
*****
*        1ST KEY DISPLACEMENTS IN SECTORS
*****
MIDISP   EQU      12                 MASTER INDEX DISPLACEMENT
ACDISP   EQU      12                 ACN DIRECTORY DISPLACEMENT
FDDISP   EQU      12                 FILE DIRECTORY DISPLACEMENT
         DO       UTS>=2
SCWDISP  EQU      3                 DISP. TO 1ST SCW IN CONT. GRAN.
         FIN
*
*        ACCOUNT DIRECTORY DISPLACEMENT VALUES
*
         DO       CPVC00=1
ADKBD    EQU      -5                KEY END+1 TO BYTE3 OF DA
         ELSE
ADKBD    EQU      -6                KEY END+1 TO BYTE3 OF DISC ADDRS
         FIN
ADKBDPP  EQU      -6                KEY END+1 TO BYTE3 OF PRIV PACK DA
ADKFD    EQU      12                KEY START TO BYTE0 OF DISC ADDRS
*
*        FILE DIRECTORY DISPLACEMENT  VALUES
*
FDKBD    EQU      -6                KEY END+1 TO BYT3 OF DISC ADDRS
FDKFD    EQU      32                KEY START TO BYT0 OF DISC ADDRS
FDBKEOF  EQU      -3                FROM KEY END+1 TO EOF BYTE
         PAGE
*
*        MASTER INDEX DISPLACEMENT VALUES
*
MIKBD    EQU      -6                KEY END+1 TO BYT3 OF DISC ADDRS
*
*        THE FOLLOWING ALL HAVE TO HAVE 'KEYM'  ADDED TO IT
*
MIKFD    EQU      5                 KEY START TO BYT0 OF DISC ADDRS
MIKTOKD  EQU      10                KEY TO KEY DISPLACEMENT
*
*-----------------------------------------------------------*
*FIELD POSITION   *                 IS DISPLACEMENT TO
*-----------------------------------------------------------*
MIFLD1   EQU      1                 BLDISP
MIFLD2   EQU      3                 BLKDIZE
MIFLD3   EQU      5                 DABLK
MIFLD4   EQU      9                 RWS
MIFLD5   EQU      11                EOF/FAK/C BYTE
MIFLD6   EQU      12                FIDBUF
*-----------------------------------------------------------*
*
         PAGE
*
*
*        ACCOUNT DIRECTORY FORMAT
*
*0     1        4           12     16    18        19    20
*----------------------------------------------------------*
* 0B  * 404040 * ACCOUNT# * DABLK * BLK * FAK/EOF * FIDBUF *
*----------------------------------------------------------*
*
*
*
*
*        FILE DIRECTORY FORMAT
*0     1                    32      36   38       39   40*
*----------------------------------------------------------*
* KL  * FILE NAME * UNUSED * DABLK * BLK * FAK/EOF * FIDBUF*
*----------------------------------------------------------*
*
*
*
*
*        MASTER INDEX KEY FORMAT
*
*
*0     1  <KEYM>    0+KEYM   2+KEYM    4+KEYM  8+KEYM 10    12
*------------------------------------------------------------------*
* KL  * KEY ITSELF * BLDISP * BLKSIZE * DABLK * BLK * FAK * FIDBUF *
*------------------------------------------------------------------*
*
*
         PAGE
*
*        FILE MANAGEMENT I/O TYC LISTS
*
NORMAL   EQU      1                 NORMAL RETURN
LOSTDATA EQU      2
BOT      EQU      3                  BEGINNING OF TAPE
BOF      EQU      4                  BEGINNING OF FILE
EOR      EQU      5                  END OF REEL
EOD      EQU      6                  END OF DATA
EOF      EQU      7                  END OF FILE
READERR  EQU      8                  READ ERROR TYC
WRTERR   EQU      9                  WRITE ERROR TYC
         PAGE
*
*
*        UTS PROCEDURE PROC'S
*
*
BASEREG  CNAME
         PROC
LF       WD,0     X'37'
         LI,AF    0                 PHYSICAL PAGE NO.
         PEND
*
*
CALL     CNAME
         PROC
         DO       UTS>0
         DO       AF(2)=14
         ELSE
         LW,14    AF(2)             MOVE IT IF NECESSARY
         FIN
         BAL,R2   VTOPU-EASECT,R3   *CHANGE VIRTUAL TO PHYSICAL ROUTINE
         ELSE
         FIN
         PEND
         DO       UTS>0             ANY UTS SYSTEM
         PAGE
*
*        END ACTION PRE-PROCESSOR FOR UTS VERSION
         USECT    PROCED
*
EAINIT   EQU      %
         LW,2     EAPHYADR          PHYSICAL ENDACTION PAGE
         BEZ      EAINIT2           MUST BE NON-TAURUS MODE
EAINIT1  EQU      %
         LI,R3    X'7FE00'
         STS,R2   R0
         B        *R11
EAINIT2  LI,R2    EASECT            VIRTUAL ADDRESS
         SLD,R2   -9                PG# IN R2 / PG DISP IN R3
         WD,0     X'37'
         DO       UTS>4
         LOAD,R2  JX:CMAP,R2
         ELSE
         LB,R2    JB:CMAP,R2
         FIN
         SLD,R2   9                 R2 = ABS CORE ADRESS
         LI,R3    X'3FFFF'
         STS,R2   NOWUP+1
         STS,R2   FITENAC+1
         STS,R2   WTENAC+1
         STS,R2   SENTENAC+1
         B        EAINIT1           REJOIN
         USECT    EASECT
         PAGE
*
*        UTS VERSIONS: ADJUST MASTER FUNCTION/RETURN TO IOQ
*
MF:DWN   EQU      %                 DECREMENT MY MF
         STW,R11  EARETRN-EASECT,R3  **SAVE LINK TO IOQ
         LW,R5    CUN-EASECT,R3     GET MY USER #
         LB,R15   UB:US,R5          GET OUR STATE
         CI,R15   SW                WERE SITTING WAITING FOR I/O DONE
         BNE      NOWUP-EASECT,R3   NO
         REF      U:MISC
         LI,R6    2                 FOUR MILLISECONDS MORE
         LI,R7    X'7FFFF'
         STS,R6   U:MISC,R5         CLEAR SLEEPING COUNTER
NOWUP    EQU      %
         BASEREG  R3                *REACQUIRE THE BASE REGISTER
         LI,R14   IOCOUNT           VIRTUAL ADDRESS OF COUNTER
         CALL     VTOPU,R14         MAKE IT PHYSICAL ADDRESS
         MTW,-1   *R14              DECREMENT TOTAL I/O FOR SLAVE
*                                   PROGRAM PART OF FSAVE
         LW,R5    CUN-EASECT,R3     RESTORE USER # TO R5
         LB,R15   UB:US,R5          RESTORE CURRENT STATE
         LB,R14   UB:MF,R5          GET MASTER FUNCTION COUNT
         STB,R14  R14               PLOP IT IN BYTE 0
         SAS,R14  -24               AND RESTORE THE SIGN BIT
         AI,R14   -1                DECREMENT # LEFT
         BLZ      MF:ERR-EASECT,R3  *THASS AN ERROR STUPID
         STB,R14  UB:MF,R5          *STORE BACK IF POSITIVE VALUE
NOWUP1   EQU      %
         CI,R15   SIOW              WAITNG FOR PERMISSION
         BE       EAREP-EASECT,R3   YUP--> REPORT I/O COMPLETE
         CI,R15   SIOMF             WAITING DUE TOO MANY ENQ'D
         BNE      EAEXIT-EASECT,R3  NO--> BACK TO IOQ
EAREP    EQU      %
         MTB,1    UB:MF,R5          *NO---> KEEP I/O COUNT HIGH
EAREP1   EQU      %
         STW,R5   *TSTACK           PUT USER # BACK INTO STACK
EAEXIT   EQU      %
         LW,R11   EARETRN-EASECT,R3  **RESTORE R11
         B        *R11               **AND RETURN TO IOQ
*
MF:ERR   EQU      %
         LI,R14   0
         STB,R14  UB:MF,R5          CORRECT THE MF ENTRY
         B        NOWUP1-EASECT,R3  *AND EXIT TO IOQ FOR I/O COMPLETE
*
*
EARETRN  DATA     0
*
*
         ELSE
MF:DWN   EQU      %
         MTB,-1   M:EO+FCN          DECREMENT I/O COUNT IN DCB
         B        *R11              BPM JUST RETURNS TO IOQ
         FIN
         PAGE
*
*        END ACTION RECEIVER FOR ALL DISC I/O
*
FITENAC  BASEREG  R3                BASE REGISTER = R3
ENDACT   MTW,-1   DOPCNT-EASECT,R3  DECREMENT READ AHEAD COUNT
         STW,R12  DSTATUS-EASECT,R3 DISC STATUS
         CALL     VTOPU,R14
ENDACT0  LB,R2    *R14              GET TYPE
         CI,R2    X'80'             DATA REQUEST
         BE       ENDACT1-EASECT,R3 YEP
         AND,R2   M7F-EASECT,R3     EXTRACT INDEX TO TAPE TABLES
         CI,R2    #IBUF
         BG       ENDACT1-EASECT,R3 *PROBABLY RANDOM FILE
         LW,R1    MIX:CNT2-EASECT,R3 GET NUMBER RECEIVED
         AI,R2    MIX:STAT-EASECT   STAT TABLE
         STW,R1   *R2,R3            PUT # RECEIVED INTO IT
         MTW,1    MIX:CNT2-EASECT,R3 AND BUMP # RECEIVED
ENDACT1  EQU      %
         LW,R0    M24-EASECT,R3     MASK OFF TO
         AND,R0   *R14              DROP BUSY BIT
         LB,R1    R12               PUT TYC
         STB,R1   R0                INTO ADDRS CELL
         STW,R0   *R14              AND REPLACE
         B        MF:DWN-EASECT,R3
         PAGE
*
*        END ACTION RECEIVER FOR ALL DATA WRITES TO TAPE
*
WTENAC   BASEREG  R3
         MTW,-1   OPCNT-EASECT,R3   DROP I/O COUNT
         STW,R12  TPSTATUS-EASECT,R3  SAVE TAPE TYC
         LB,R5    R14               GET BUFFER INDEX
         AND,R5   M7F-EASECT,R3     CLEAR BUSY BIT
         CALL     VTOPU,R14
         LW,R0    M24-EASECT,R3     ADDRESS MASK
         AND,R0   *R14
         STW,R0   *R14
         SW,R14   R5                ADJUST POINTER TO BASE OF TABLE
         MTW,1    *R14              ADJUST BUF'S REMAINING
         AI,R14   -1
         MTW,-1   *R14              ONE LESS BUSY BUFFER
         LB,R1    R12               TYC TO R1
         BNE      WTENAC1-EASECT,R3
         LI,R1    9                 TYC OF 0 IS WRITE ERROR
WTENAC1  EQU      %
         CI,R1    NORMAL            IS NORMAL TYC
         BE       MF:DWN-EASECT,R3  YUP-> EXIT
         STW,R1   EOTBIT-EASECT,R3  NO--> REMEMBER IT FOR LATER
         B        MF:DWN-EASECT,R3  AND EXIT
         PAGE
*
*        END ACTION RECEIVER FOR ALL SENTINEL WRITES TO TAPE
*
SENTENAC BASEREG  R3
         MTW,-1   OPCNT-EASECT,R3   I/O COUNT
         STW,R12  TPSTATUS-EASECT,R3   SAVE TYC
         LB,R1    R12               TYC
         BNE      SENTENA1-EASECT,R3
         LI,R1    9                 TYC OF 0 IS WRITE ERROR
SENTENA1 EQU      %
         CI,R1    EOR
         BNE      WTENAC1-EASECT,R3
         STW,R1   SPECEOT-EASECT,R3 SET SPECIAL END OF REEL FLAG
         B        MF:DWN-EASECT,R3
         PAGE
         DO       UTS>0             ANY UTS SYSTEM
*
*        VIRTUAL TO REAL ADDRESS CONVERSION
*
VTOPU    EQU      %
         LW,R6    R14               MOVE EAI WORD
         AND,R6   M24-EASECT,R3     SCREEN ANY FLAGS
         SLD,R6   -9                R6 = PAGE# / R7 = PAGE DISP
         LW,R4    CUN-EASECT,R3     MY USER #
         DO       UTS>4
         LOAD,R4  UX:JIT,R4
         ELSE
         LB,R4    UB:JIT,R4
         FIN
         SLS,R4   9                 THE JIT PHYSICAL WORD ADDRESS
         AI,R4    JCMAP             DISP INTO CMAP (PHYSICAL)
         DO       UTS>4
         LOAD,R6  *R4,R6            ENTRY WE WANT
         ELSE
         LB,R6    *R4,R6            ENTRY WE WANT
         FIN
         SLD,R6   9                 R6 = PHYSICAL ADDRESS
         LW,R14   R6                PUT BACK INTO CALLER'S R14
         B        0,R2              AND RETURN
         FIN
M7F      GEN,24,8  0,X'7F'
FEAPATCH RES      40
         USECT    FSTART
         PAGE
*
*        I/O FUNCTION CODE
*
*        CONSTANTS
*
IOPRI    EQU      '3'               I/O PRIORITY
READFC   EQU      0                  9T AND/OR DISC READ
WRT      EQU      1                  WRITE 9T
BSR      EQU      4                  BACK SPACE RECORD
FSR      EQU      5                  FORWARD SPACE RECORD
BSF      EQU      6                  BACK SPACE FILE
FSF      EQU      7                 FORWARD SPACE FILE
         DO       UTS=-1            DO FOR F00/F01 BPM/BTM
WTM      EQU      8                  WRITE TAPE MARK
REWOL    EQU      9                  REWIND ON-LINE
         ELSE
WTM      EQU      3                 WRITE TAPE MARK
REWOL    EQU      8                 REWIND ON LINE
         FIN
REWOFL   EQU      10                 REWIND OFF-LINE
9TSENS   EQU      11                 9T SENSE
READRCVR EQU      14                 READ 9T WITH RECOVERY
READREV  EQU      16                 9T READ REVERSE
READISC  EQU      0                  READ DC
WRTDISC  EQU      1                  WRITE DC
CHKWRT   EQU      4                 WRITE W/CHECK WRITE
RETRY    EQU      48                MAX RECOVERIES
         PAGE
*
*        REFS FOR ANY VERSION OF FSAVE
*
         REF      M:SO              WRITE SORTED DATA CARDS DCB
         REF      MAXBQ             MAX BACKGROUND QUEUES AT ONE TIME
         REF      M:SI              READ DATA CARDS DCB
         REF      M:PO              WRITE STATS FILE DCB
         REF      AVRTBL            DISC PACK TABLE BASE WA
         REF      AVRTBLNE          # OF DISC PACKS IN AVRTBL
         REF      AVRTBLSIZ         TOTAL LENGTH OF TALBE (TAPES+PACKS)
         REF      ACNCFU            AD POINTER
         REF      M:LL              PRINT LINE WRITE DCB
         REF      M:DO              DCB FOR SNAP'S ETC...
         REF      M:C               IN BATCH - READ PROCESSOR CARD DCB
         REF      BATAPE            # OF TAPES IN SYSTEM DEF
         REF      M:OC              DCB TO TYPE THRU
         PAGE
*
*        REF'S FOR FILL COMPATIBLE VERSIONS OF FSAVE
*
         DO       FILL=1
         REF      M:EI
         FIN
         PAGE
*
*        BPM REFERENCES
*
         DO       UTS<=0
FCN      EQU      7                 DISP IN DCB TO I/O COUNT
         FIN
*
         PAGE
*
*        REF'S FOR TAURUS VERSIONS OF FSAVE
*
         DO       TAURUS=1
         REF      T:STLPP
         REF      T:RSPP
         FIN
         PAGE
*
*        REF'S FOR ANY UTS VERSION OF FSAVE
*
         DO       UTS>0             ANY UTS VERSION
         REF      UB:US             USER STATE TABLE
         REF      TSTACK            MONITOR'S PUSH DOWN STACK
         REF      J:JIT             USER JOB INFO TABLE
         REF      J:ACCN            ACCOUNT NUMBER AREA IN JIT
         REF      SIOW              WAIT FOR MF TO DROP USER STATE CODE
         REF      HGP               BASE OF HGP TABLES
         REF      DCTSIZ            LENGTH OF DCT TABLES
         REF      UB:MF             MASTER FUNCTION COUNT TABLE
         REF      S:CUN             CURRENT USER # WORD
         REF      NEWQNWM           NEWQ ENTRY
         REF      JCMAP             OFFSET IN JIT TO USER'S MAP
         REF      T:RUE             REPORT UNUSUAL EVENT
         REF      E:WU              WAKE UP EVENT CODE
         REF      SW                SLEEP STATE CODE
         REF      DCT22             DEVICE SUB-TYPE TABLE
         REF      S:HIR             HI-PRI USER NEEDED INCORE FLAG
         REF      DCT23             HGP POINTER FOR DISC DEVICES
         REF      BLOCKER           MP BLOCK ROUTINE
         REF      S:PNO             PROCESSOR NUMBER IN J:JIT
         REF      T:REG             REPORT EVENT AND GIVE UP CONTROL
         REF      J:XPSD
         FIN
         PAGE
*
*        REF'S FOR C00 CP-V VERSIONS OF FSAVE
*
         DO       CPV>=2            C00 CP-V ONLY
         REF      SIOMF             FINALLY DEF'D SOMEWHERE IN MONITOR
         ELSE
SIOMF    EQU      21                FOR ALL OTHERS SIMULATE THE DEF
         REF      M:EO              IF NOT C00 CP-V VERSION
         FIN
         PAGE
*
*        REF'S FOR DOO UTS VERSIONS OF FSAVE
*
         DO       UTS>=4
DIRSIZ   SET      512               D00 AND LATER HAVE FULL GRANULES
         REF      JX:CMAP           CMAP START IN USERS JIT
         REF      UX:JIT            JIT PAGE # TABLE IN ROOT
         ELSE
         REF      JB:CMAP
         REF      UB:JIT
         FIN
         DO       UTS<=3            EARLIER UTS VERSIONS STUFF
DIRSIZ   SET      256               SECTOR SIZE DIRECTORIES
         FIN
         PAGE
*
*        ANY CP-V VERSION OF FSAVE REFERENCES
*
         DO       CPV>0
         REF      DCT%MASK
         REF      SECTOR%MASK
         REF      DISCLIMS
         REF      INVERTED%DCT%MASK
         FIN
         PAGE
*
*        FSAVE DEF'S
*
         DEF      EASECT            START OF END ACTION AREA CODE
         DEF      FSTART
         DEF      DATASEC           DATA START
         DEF      FEAPATCH
         DEF      FPATCH
         DEF      INBUF
         PAGE
*
*
M:ACNCFU EQU      ACNCFU
         CLOSE    ACNCFU
         DO       UTS=-1            IF F00/FO1 VERSIONS
UTS      SET      0                 NO FURTHER NEED FOR IT
         FIN
         PAGE
*
*        ENTRY - COLLECT DATA BUFFERS,READ
*        CONTROL CARDS AND BEGIN TO PROCESS
*        THE TARGET FILE SYSTEM
*
*
         USECT    PROCED            GENERATE PROCEDURE HERE
*
INITIATE EQU      %
         DO       UTS=0
         CAL1,6   SYSFPT            OK-GET INTO MASTER MODE
         STW,R10  NEWQ              SAVE NEWQ'S ADDRS
         ELSE
         CAL1,1   OPEN:LL           OPEN M:LL WHEREVER IT POINTS TO
         CAL1,1   PAGEFPT           KICK OUT NEW PAGE
         CAL1,8   BREAK
         LI,R1    1
         CAL1,6   SYSFPT            GO MASTER MODE
         BCS,8    NOPRIV            CC1 SET IF PRIV<C0
         LW,R8    DCT%MASK
         STW,R8   DCTMASK
         LW,R8    SECTOR%MASK
         STW,R8   SECMSK
         LW,R8    INVERTED%DCT%MASK
         STW,R8   INVDMSK           SAVE MASK FOR LATER
*
         LI,R3    DCTSIZ
         STW,R3   DCTMAX            INIT CLM PAIR UPPER LIMIT
*
         LW,R2    S:CUN
         STW,R2   CUN               SAVE CURRENT USER (ME) FOR LATER
*
         LI,R0    0
         LW,R12   M:LL+1            ASSUME NOT A COC TERMINAL
         LI,R13   X'BF00'
         CS,R12   =X'9000'          IS COC TERMINAL OR LP OR WHAT
         BE       %+2               A COC DEVICE
         LI,R0    255               ANYTHING ELSE IS OK
         STW,R0   LPFLAG            REMEMBER WHAT WE'RE TALKING TO
*
        LI,R0     HGP
        STW,R0    HGPLOC            SAVE HGP LOCATION FOR RANDOM FILES
         DO1      TAURUS=0
         BAL,R15  SLAVE             GO BACK BROTHER
         REF      NEWQ              NEWQ ROUTINE IN MONITOR- USED TO
*,*                                 DETERMINE IF FSAVE IS LOADED WITH
*,*                                 THE RIGHT MONSTK.
         CI,R10   NEWQ              SEE IF CORRECT MONSTK
         BNE      BADMONS           NOPE...TRY AGAIN SISTER
         M:CAL    (IA,CAL3),MASTER
         LI,R15   FS:MSG            TYPE
         CAL1,2   TYP15             FSAVE HERE...
         BAL,R15  SPACE             ONE BLANK LINE OUT
         FIN
*
*        FOLLOWING IS FOR TAURUS MODE VERSIONS ONLY
*
         DO       TAURUS=1
         CAL1,8   EXCON             TURN ON EXIT CONTROL
         LI,R1    1
         CAL1,8   GTPG              GET A PAGE
         BCS,8    NOTENUFF          ERROR
         STW,9    EAADDR            SAVE VIRTUAL ADDR FOR ENDACTION
         LW,8     9
         BEZ      NOTENUFF
         AW,8     Y05               FREE SO IT WILL NOT COME BACK
         CAL1,8   R8                FREE THE VIRTUAL PAGE
*,*                                 END ACTION ROUTINES.
INIT10   EQU      %
         LI,R8    0                 SET FLAG TO REQUEST STEAL
INIT11   EQU      %
         BAL,R11  T:STLPP           STEAL ONE PHYSICAL PAGE
         AI,3     0
         BGZ      INIT15            GOT ONE
         BEZ      GRPG1             TRY AGAIN AFTER MAKING SURE
         AI,R8    0                 TEST FLAG
         BNEZ     GRPG1             ALREADY REQUESTED
*                                   PAGE IS THERE TO STEAL
         WD,0     X'37'
         REF      S:STLC            STOLEN PAGE LIMIT - USED TO
*,*                                 FORCE ALLOCATION OF PAGE.
         AWM,3    S:STLC            FORCE A PAGE
         BLZ      %+2
         STW,3    S:STLC
         WD,0     X'27'             ENABLE
         LI,R8    1                 SET FLAG
GRPG1    EQU      %
         LI,R1    1
         CAL1,8   GTPG              GET ONE PAGE
         CAL1,8   FREPG
         B        INIT11
INIT15   EQU      %
         CI,3     X'1FFFF'          MAKE SURE PAGE LESS THAN 128K
         BL       INIT20            OK
         BAL,11   T:RSPP            GIVE BACK PAGE JUST STOLE
         B        INIT10            TRY AGAIN
INIT20   EQU      %
         STW,3    EAPHYADR
         LW,8     EAADDR            VIRTUAL PAGE FOR ENDACTION
         CAL1,8   CVMFPT
         BAL,R15  SLAVE
         LI,R15   EASECT
         AND,R15  M9                OFFSET INTO PAGE OF START
         AW,R15   EAADDR            ALIGN IN STOLEN PAGE
         STW,R15  EAADDR            SAVE START OF ENDACTION ROUTINES
         AI,R15   EOTBIT-EASECT
         STW,R15  EOTFLAG
         LW,R15   EAADDR
         AI,R15   MIX:STAT-EASECT   START OF MIX STATUS TABLE
         STW,R15  MIXSTAT
         LI,R14   MIX:CNT1-EASECT   OFFSET
         AW,R14   EAADDR            ADDRESS NOW IN EA PAGE
         LI,R13   MIX:CNT2-EASECT   OFFSET
         AW,R13   EAADDR            ADDRESS
         STW,R14  MIXCNT1           SAVE FOR LATER
         STW,R13  MIXCNT2           DITTO
         ELSE
         LI,R2    EASECT
         AND,R2   BIASMASK          BASE PAGE WA OF THAT SECTION
         STW,R2   EAPHYADR          PUT IT AWAY FOR BPM VERSIONS
         FIN
*
*        FOR ALL SYSTEMS
*
         LW,R2    EAPHYADR
         LI,R3    EASECT
         AND,R3   M9                DISP IN THAT PAGE
         AW,R2    R3                R2 = BASE REGISTER ADDRS
         LI,R3    X'3FFFF'
         STS,R2   FITENAC+1
         STS,R2   WTENAC+1          STORE BASE REGISTER WA
         STS,R2   SENTENAC+1
         DO1      CPV>0
         STS,R2   NOWUP+1           FOR I/O END ACTION ROUTINES
*
         DO       TAURUS=1
         LW,R2    EAADDR            VIRTUAL WORD ADR OF ENDACTION PAGE
         LI,R8    EASIZE+1          GET LENGTH OF SPECIAL AREA
         LI,R3    EASECT
         LW,R15   0,R3              MOVE ENDACTION ROUTINE TO
         STW,R15  0,R2              PAGE WE KNOW IS LESS THAN 128K
         AD,R2    DOUBLEONE         FOR TARUS
         BDR,R8   %-3
         FIN
*
*        TERMINATE UTS SPECIAL CODE
*
         LI,R1    #IBUF
         CAL1,8   GTPG
         BCS,8    NOTENUFF
         AWM,R8   PAGETOTAL
         STW,R9   BUF:LIMS          REMEMBER FIRST PAGE WORD ADDRS
         STW,R1   INDPAGES          SAVE COUNT
INITIATE1 STW,R9  IBUF,R1           MOVE BUF WA TO TABLE
         AI,R9    512               STEP TO NEXT BUFFER
         BDR,R1   INITIATE1         COMPLETE TABLES
         STW,R9   BUF:LIMS+1        MARK BUFFER AREA UPPER
         LI,R1    2
         CAL1,8   GTPG              GET TWO PAGES
         BCS,8    SP:INIT           ERROR
         AWM,R8   PAGETOTAL         KEEP TRACK OF TOTAL
         STW,R1   FITBUFS           SETUP TABLE HEADING
         STW,R9   FITBUFS,R1
         AI,R9    512               NEXT WA
         BDR,R1   %-2               PUT AWAY ALL THE BUFFER ADDRESSES
         B        GET:CC            GATHER CONTROL CARDS
         DO       UTS>0
NOPRIV   EQU      %                 USER DOESN'T HAVE C0
         LI,R15   NOPRIVM
         CAL1,2   PRNT15            TELL USER
         LI,R1    BA(NOPRIVM)       AND OPERATOR
         B        BADMONS+3         AND QUIT
BADMONS  EQU      %                 FSAVE LOADED WITH WRONG MONSTK
         LI,R15   BADMONM
         CAL1,2   PRNT15
         LI,R1    BA(BADMONM)
         BAL,R15  TYPEIO
         B        FPEXIT
BADMONM  TEXTC    ' FSAVE LOADED WITH WRONG MONSTK...TRY AGAIN'
NOPRIVM TEXTC     ' *** C0 PRIVELEGE IS REQUIRED TO USE FSAVE '
         FIN
         PAGE
*
*        COULD NOT GET ENOUGH PAGES,ASK
*        FOR 5 PAGES OR QUIT IF .LT. 5 AVAIL
*
SP:INIT  LI,R7    GET:CC            ADDRS WHERE TO GO WHEN DONE
         PSW,R7   PDSTK             SAVED FOR EXIT HEREIN
SP:INIT1 LW,R5    PAGETOTAL         GET TOTAL PAGE CNT NOW
         LI,R6    X'09'             SET UP
         STB,R6   R5                FREE PAGE FPT
         CAL1,8   R5                FREE ALL WE GOT
         CAL1,8   GETPAGES          ASK FOR SOME NOW
         STW,R9   BUF:LIMS          SET BUFFER AREA LOWER LIMIT
         LI,R4    2048
         STW,R4   TBSIZ             INSURE TAPE BUF SIZE SETUP
         LI,R1    2                 SET DATA LOOP
         STW,R1   DAPAGES           LEAVE COUNT FOR LATER USE
         STW,R1   DBUF              SET TABLE HEAD FOR
         STW,R9   DBUF,R1           READING
         AI,R9    512               READING
         BDR,R1   %-2
         AI,R8    -2                STRIP OFF TWO PAGES
         BLEZ     NOTENUFF          BAD NEWS
         LI,R1    1                 ONE FOR TAPE
         STW,R1   TAPAGES           LEAVE COUNT SET
         STW,R1   TBUF              SET TABLE HEAD
         STW,R9   TBUF,R1           SET AWAY PAGE ADDRESS
         AI,R9    512               INCREMENT TO NEXT PAGE
         LI,R1    2                 TWO IPOOLS
         STW,R1   INDPAGES          LEAVE COUNT SET
         STW,R1   IBUF              SET TABLE HEAD
         STW,R9   IBUF,R1           SET TABLE ENGRY
         AI,R9    512               INCREMENT TO NEXT IPOOL
         BDR,R1   %-2
         AI,R8    -3                STRIP OFF THREE MORE PAGES
         BLEZ     NOTENUFF          NOT ENUFF TO RUN
         LI,R5    2
         STW,R5   FITBUFS           FIT READ AHEAD TABLE
         STW,R9   FITBUFS,R5        STORE BUFFER
         AI,R9    512
         BDR,R5   %-2
         AI,R8    -2
         BLEZ     NOTENUFF          BAD NEWS....
         STW,R9   LIMIT             SET UP
         STW,R9   CURPOS            SENTINEL RING BUFFER
         AI,R9    511               INCREMENT TO HIGH SPOT
         STW,R9   BUFTOP            LEAVE HIGH SPOT
         STW,R9   BUF:LIMS+1        SET BUFFER AREA UPPER LIMIT
         AI,R8    -1
         BLEZ     NOTENUFF
         LI,R7    9
         STB,R7   R8                LETS FREE UP THE ONES WE DONT NEED
         CAL1,8   R8                SINCE WE GOT ALL WE WANT NOW.
         PLW,R7   PDSTK
         B        0,R7
         PAGE
*
*
*
*        INITIALIZE DATA/TAPE BUFFER TABLES
*
*
*
INITIATE4 EQU     %
         PSW,R7   PDSTK             SAVE LINK IF DUMP MODE
         LI,R7    INITIATE5         SET UP RETURN FROM SP:INIT1 IN CASE
*                                   WE GO THERE FOR NOT ENOUGH PAGES
         PSW,R7   PDSTK
         LI,R1    1
         CAL1,8   GTPG
         AWM,R8   PAGETOTAL         KEEP TRACK OF TOTAL
         CI,R8    1                 DID WE GET ONE
         BL       SP:INIT1          NO-USE SPECIAL CASE
         STW,R9   LIMIT             SAVE BASE ADDRS
         STW,R9   CURPOS            START ADDRS
         AI,R9    511               FIX UP HIGH
         STW,R9   BUFTOP            ADDRS
         LW,R2    SIZCHK            USER CHANGE SIZE OF TAPE BUFFERS
         BEZ      INIT0             NOPE
         AND,R2   =X'0F0F'          EXTRACT NUMBERS
         SLD,R2   -4
         SLS,R3   -28
         XW,R2    R3
         MI,R3    10
         SLS,R3   -4
         AW,R2    R3                ADD EM UP
*
*        INSURE COMPATIBILITY WITH FRES (FRES CAN READ MAX OF 3K BUFFER)
*
         CLM,R2   MAXTBUF           COMPARE TO MAX PAGE COUNT POSSIBLE
         BCR,9    %+2               IS OKAY
         LI,R2    1                 BAK TO ONE IF BAD
         STW,R2   TBPSIZ            STORE PAGE COUNTER
         SLS,R2   9
         STW,R2   TBPWSIZ           STORE # OF WORDS
         SLS,R2   2
         STW,R2   TBSIZ             REMEMBER FOR TAPE WRITING
INIT0    EQU      %
         LW,R0    DUMP              WRITING TAPE
         AW,R0    STATS             OR PRODUCING DISKPOOL
         BEZ      INITIATE5         NO, NO NEED FOR THESE BUFS
         CAL1,8   GETPAGES          GET ALL POSSIBLEPAGES
         AWM,R8   PAGETOTAL         KEEP TRACK OF TOTAL
         CI,R8    3                 MUST HAVE AT LEAST 3
         BL       SP:INIT1          TOO FEW
         LI,R5    0                 TAPE BUFFER COUNTER
         LI,R6    0                 DISC BUFFER COUNTER
INIT1    EQU      %
         AI,R5    1
         CI,R5    #TBUF             FILLED THE TABLE UP YET
         BG       INIT2             **ALL DONE
         SW,R8    TBPSIZ            WHACK OFF ANOTHER BUFFER
         BLEZ     INIT3             ALL DONE
         STW,R9   TBUF,R5           STORE IT'S WA
         AW,R9    TBPWSIZ           BUMP TO NEXT WA OF NEXT BUF
         MTW,1    TBUF
         MTW,1    TAPAGES           KEEP BUF COUNTERS CORRECT
INIT2    EQU      %
         AI,R6    1                 ONE MORE DISC BUFFER
         CI,R6    #DBUF             AT MAX # OF DISC BUFFERS YET ?
         BG       INIT3             **ALL DONE W/EM
         AI,R8    -1                WHACK OFF ANOTHER BUFFER
         BLEZ     INIT3             ALL DONE
         STW,R9   DBUF,R6           STORE IT'S WA
         AI,R9    512               BUMP TO NEXT WA OF NEXT BUF
         MTW,1    DBUF
         MTW,1    DAPAGES           KEEP BUF COUNTERS COORRECT
         B        INIT1             LOOP AROUND AGAIN
INIT3    EQU      %
         AI,R9    -1
         STW,R9   BUF:LIMS+1        CREATE CLM PAIR
         CI,R8    0                 ANY PAGES LEFT
         BLEZ     INIT3A            NOPE
         LI,R7    9
         STB,R7   R8                CREATE FREE PAGE FPT
         CAL1,8   8                 FREE PAGES WE DONT NEED
INIT3A   EQU      %
         DO       FILL=1            FILL VERSIONS ONLY
         LW,R9    VOLUME            INSN SPECIFIED ON +VOL OPTION
         BEZ      INIT4B            NO - COMPUTE IT
         LI,R4    -4                CHECK INSN FOR FILL FORMAT
CHKREEL1 EQU      %
         LB,R8    R10,R4
         CB,R8    LOW,R4
         BL       INIT4A            NOT FILL FORMAT - IGNORE
         CB,R8    HI,R4
         BG       INIT4A
         BIR,R4   CHKREEL1          CHECK NEXT CHAR
         B        INIT4B            INSN OK
INIT4A   LI,R9    0
         STW,R9   VOLUME            CLEAR INSN SPECIFIED BY USER
INIT4B   EQU      %
         FIN
*
         PLW,R7   PDSTK             ADJUST STACK - DID NOT GO TO SP:INIT1
INITIATE5 CAL1,8  TIMFPT1           PUT TIME INTO DATE :BOF RECORD
         DO       FILL=1
*  R8 CONTAINS YEAR(LEFT-HALFWORD) AND JULIAN DAY(RIGHT-HALFWORD)
         LW,R0    DUMP              NO TAPE IMPLIES
         BEZ      INIT32            NO UPDATE :BREC
         LW,R0    VOLUME            USER INSN SPECIFIED
         BEZ      %+3               NO COMPUTE INSN
         STW,R0   REELSN
         B        INIT32
         INT,R3   R8                JULIAN DAY
         LI,R8    0                 CLEAR BUFFER
         LI,R1    R8**2+3           RIGHTMOST BYTE OF BUFFER
         BAL,R15  HEXTODEC          CONVERT JULIAN DAY
         LI,R1    2                 BYTE DISP.
         LB,R0    R8,R1             BINARY ZERO
         BNEZ     %+3               NO - ALL IS WELL
         LI,R0    'F0'              YES - MAKE IT
         STB,R0   R8,R1             DECIMAL
         STH,R8   REELSN            FILL TYPE OUTSN
OPENBREC EQU      %
,OPNBREC M:OPEN   M:EI,(FILE,'F:BREC',':SYS'),(INOUT),(DIRECT),;
                  (ERR,INIT4),(ABN,INIT4)
         LW,R1    BRECFLG           SKIP READ IF
         BNEZ     INIT31            OPEN FAILED
,RDBREC  M:READ   M:EI,(BUF,BRECREC),(SIZE,22*4),(KEY,BRECKEY),;
                  (ERR,INIT5),(ABN,INIT5)
         LH,R8    REELSN            TODAY
         CH,R8    BRECREC+1         DAY OF LAST BACKUP
         BNE      INIT31            MUST BE 1ST BACKUP TODAY
         LI,R1    2                 BYTE DISP.
         LB,R8    BRECREC+1,R1      PICK UP LETTER OF SET
         LB,R2    XTABLE
         CB,R8    XTABLE,R2
         BE       INIT31            START OVER IF LAST SET
         AI,R2    -1
         CB,R8    XTABLE,R2         SEARCH FOR LETTER
         BE       %+3               FOUND A MATCH
         BDR,R2   %-2               KEEP ON LOOKIN'
         B        INIT31            CAN'T FIND, MUST BE GARBAGE
         AI,R2    1                 USE NEXT LETTER FOR SET
         LB,R8    XTABLE,R2
         STB,R8   BRECREC+1,R1      STICK INTO SN
         LI,R1    3
         LI,R2    '0'               RECYCLE VOLUMN NO.
         STB,R2   BRECREC+1,R1      STICK IN X
         LW,R8    BRECREC+1
         STW,R8   REELSN
         B        INIT31+2
INIT31   LW,R8    REELSN            USE 1ST FOR TODAY
         STW,R8   BRECREC+1         FOR SN
         LW,R2    BRECFLG           SKIP UPDATE IF
         BNEZ     %+2               BRECFLG IS NON-ZERO
,WRBREC  M:WRITE  M:EI,(BUF,BRECREC),(SIZE,22*4),(KEY,BRECKEY)
INIT32   EQU      %
         FIN
         LI,R1    1                 HALF WORD POINTER
         MTW,0    SAVBYDATE         TEST FOR SAVE BY DATE
         BNEZ     INIT34            SKIP DEFAULT TEST IF SET
         MTW,0    SAVBYHOUR         CHECK SAVE BY TIME
         BEZ      INIT34            SKIP DEFAULT TEST IF NO TIME
         MTW,7    SAVBYDATE         SET SAVEBYDATE FLAF
         MTW,7    DEFFLG            SET FLAG FOR DEFAULT DATE
INIT34   EQU      %
         LW,R2    DATBUF+6          ,'69 ...(,7YY)
         LH,R3    DATBUF+3             24   (  HH)
         STW,R2   BKUPVLP+2
         STH,R3   BKUPVLP+2         2469    (HHYY)
         MTW,0    DEFFLG            CHECK DEFAULT FLAG
         BEZ      %+3               SKIP IF NOT SET
         LH,R3    R2,R1             YY
         STH,R3   SAVEDATE+1        SET DEFAULT DATE
         LW,R2    DATBUF+4          0 NO    (N MO)
         MTW,0    DEFFLG            CKECK DEFAULT FLAG
         BEZ      %+3
         LH,R3    DATBUF+5,R1       DD
         STH,R3   SAVEDATE,R1       SET DEFAULT DATE
         LW,R3    DATBUF+5          V 01    (N DD)
         STW,R3   BKUPVLP+1
         SLS,R2   16                NO      (MO  )
         SLS,R3   -16                 V     (  N )
         OR,R2    R3                NOV     (MON )
         AI,R2    X'3D'             INSERT HALF QUOTE
         LI,R3    12                SET SEARCH
         CW,R2    MONTHTAB,R3       FIND MATCH IN MONTH TABLE
         BE       %+2               GOTCHA
         BDR,R3   %-2
         LH,R2    MONTHN,R3         GET APPROPRIATE FIELD
         STH,R2   BKUPVLP+1         1101 (MMDD)
         MTW,0    DEFFLG            CHECK DEFAULT FLAG
         BEZ      %+2
         STH,R2   SAVEDATE          SET MM - DEFAULT DATE
         LI,R1    INITIATE          CALCULATE
         AND,R1   BIASMASK          BKGRND LOWER LIMIT
         STW,R1   DATBUF+8          FOR DATE RECORD
         PLW,R7   PDSTK             RESTORE
         LW,R1    SAVBYDATE         SAVE BY DATE
         BEZ      0,R7              NO
         LW,R1    SAVEDATE          ZERO IF NO DAY SPECIFIED
         BEZ      INTER22           RETURN AFTER STUFFING IN TODAY
         B        0,R7              AND USE EXIT LINK
         DO       FILL=1
INIT4    EQU      %                 CANNOT OPEN :BREC
         MTW,-1   BRECRTRY
         BLE      INIT45
         LH,15    10
         AND,15   MASK
         CI,15    X'1402'           FILE BUSY
         BNE      INIT45
         CAL1,8   =X'0F000001'
         B        OPENBREC          TRY AGAIN
INIT45   EQU      %
         STW,R10  BRECFLG           SET A FLAG
         B        *R8               AND CONTINUE
INIT5    EQU      %                 CANNOT READ SAV RECORD
         STW,R10  BRECFLG           SET A FLAG
         CAL1,1   CLOSE             CLOSE M:EI DCB
         B        *R8               AND CONTINUE
         FIN
         PAGE
*
*        GATHER CONTROL CARDS
*
GET:CC   EQU      %
         DO       UTS>0
         CAL1,1   PROMP             CLEAR PROMPT
         LC       J:JIT             CHECK ORIGIN
         BCS,12   RDCRD1            ONLINE/GHOST NO PROCESSOR CARD
         FIN
         CAL1,1   READC
         LB,R1    INBUF
         CI,R1    ' '               RUNNING AS PROCESSOR
         BE       RDCRD1
RDCRD    CAL1,1   WRTLL             ECHO IF APPROPRIATE
RDCRD1   BAL,R14  RCD               READ A COMMAND
         BAL,R15  INTER             CHECK FOR COMMANDS
         B        RDCRD2            IT IS A COMMAND
         B        RDCRD3            IT IS A DATA CARD
RDCRD2   EQU      %
         LI,R1    7
         LS,R1    M:SI              WHERE IS M:SI ASN
         CI,R1    1                 COMING FROM A FILE
         BE       RDCRD             YES--> ECHO INPUT
         MTW,0    LPFLAG            WRITING A COC TERMINAL
         BEZ      RDCRD1            YEP--> NO ECHO
         B        RDCRD             ELSE ECHO IF BATCH JOB
RDCRD3   EQU      %
         LI,15    0
         MTW,0    CCVOL             +VOL OPTION SPECIFIED
         BE       RDCRD3A           NO
         LW,R1    INBUF             GET INSN SPECIFIED
         STW,R1   VOLUME            SAVE
         STW,R1   REELSN            HONOR THE SERIAL # REQUEST
         STW,R15  CCVOL             CLEAR FLAG
         B        RDCRD2
RDCRD3A  EQU      %
         MTW,0    CCDEV             DEVICE TYPE SPECIFIED - +DEV
         BE       RDCRD3B
         LW,R1    INBUF             GET DEVICE
         SLS,R1   -16
         STW,R1   DEVFPT            STICK IN OPEN FPT
         STW,R15  CCDEV             CLEAR FLAG
         B        RDCRD2
RDCRD3B  EQU      %
         LW,R1    SELECT
         AW,R1    SKIP              DATA CARDS THIS TIME
         AW,R1    STARTSET
         AW,R1    STOPAT           CHECK ALL OPTIONS THAT HAVE DATA
         BEZ      NOCARDS          NONE OF EM...
         MTW,0    END              ONE OF EM - BUT DID WE READ END
         BNEZ     NOCARDS          YUP--> NO MORE DATA CARDS TO USE
*
         DO       UTS>0
         LI,R5    X'FFFF'
         LS,R4    J:JIT
         STS,R4   SOVLP0+3          SETUP UNIQUE FILE NAME
         STS,R4   SOVLP1+3          SETUP NAME IN MISSED CARD ROUTINE
*                                   FOR PRINTOUT OF MISSING ACCOUNTS AND
*                                   FILE NAMES...
*
         FIN
*
,,SOVLP0 M:OPEN   M:SO,(FILE,'DATACARDSXX'),(KEYED),(DIRECT),;
                  (JOB),(OUT),(KEYM,31),(ERR,SOERR),(ABN,SOABN)
MOCARDS  EQU      %
         MTW,0    LPFLAG            WRITING A COC TERMINAL
         BEZ      %+2               YUP--> NO ECHO NECESSARY
         CAL1,1   WRTLL             ELSE ECHO ALL INPUT
         BAL,R7   SKEYUP            CREATE RECORD KEY
         BAL,R14  RCD               READ NEXT CARD FROM DEVICE
         NOP                        LEAVE THESE
         NOP                        NOP'S TO SIMULATE
         NOP                        THE RETURN ON COMMAND HIT BY 'RCD'
*
         MTW,0    END               LAST CARD IN
         BEZ      MOCARDS           NOT YET
         M:CLOSE  M:SO,(SAVE)       SAVE SORT FILE
         LH,R0    M:SI
         CI,R0    32
         BAZ      %+2               NOT OPEN
         CAL1,1   CLS%SAV           ELSE CLOSE IT NOW
*
         DO       UTS>0
         LI,R5    X'FFFF'
         LS,R4    J:JIT             GET JOB ID FOR UNIQUE FILE NAME
         STS,R4   SOVLP+3           STICK JOB ID INTO FILE NAME FIELD
         FIN
*
,,SOVLP  M:OPEN   M:SI,(FILE,'DATACARDSXX'),(INOUT),(KEYED),(SEQUEN)
         LI,R9    0                 CLEAR
         STW,R9   END               END HIT FLAG
         BAL,R14  RD:COM            READ FIRST RECORD FROM SORT FILE
NOCARDS  LW,R0    LIST              IS M:LL LIST MODE SET
         BEZ       NOIPRI
         DO       UTS<=0
         LW,R1    REELSN            MOVE SN#
         STW,R1   PRTMESS+2         TO PAGE HEADER
         ELSE
         LI,R7    PRTMESS           ASSUME LP MODE
         MTW,0    LPFLAG            TRUE
         BNEZ     %+2               YES
         LI,R7    ONLNHDR           NO--> TALKING TO COC DEVICE
         STW,R7   LLHDRB            STORE TEXTC STRING ADDRESS
         FIN
         CAL1,1   LLHDR             TURN ON M:LL HEADER
         PAGE
*
*        CONTROL CARDS IN (ENUFF TO START ANYWAY)
*
NOIPRI EQU        %
         BAL,R7   INITIATE4         COMPLETE TABLE INITIALIZATION
         LI,R2    -34
         LW,R1    BLANK
         STW,R1   PBUF+34,R2
         BIR,R2   %-1
         DO       UTS<=0            BPM ONLY
         LW,R1    X'4E'            POINTER TO DCT1
         LW,R2    *R1              GET IT
         LB,R3    R2               AND PUT SIZE
         STW,R3   DCTMAX
         LI,R12   X'1FFFF'         ADDRS MASK
         AND,R12  10,R1            FOR HGP ADDRS
         STW,R12  HGPLOC
         LI,R8    1                SECTOR #
         LI,R1    1                INDEX TO DCTX IN HGP
         LW,R9     =X'7F0000'       MASK TO PICK
         LS,R8    *R12,R1          UP HGP DCTX (FOR SYSTEM DEVICE)
         LW,R1    X'4F'             BPM JIT POINTER
         AND,R1   M17               SCREEN IT TO 17 BITS...
         AI,R1    1                 POINT TO BPM JIT ACCN LOCATION
         STW,R1   ACNLOC            AND SAVE IT
         ELSE
         CAL3,0   0                 BACK TO MASTER MODE
         LW,R8    M:ACNCFU+1        GET DISC ADDRS OF FIRST AD SECTOR
         LI,R1    J:ACCN
         STW,R1   ACNLOC            SAVE LOC OF ACCOUNT #
         FIN
         STW,R8   ACNCFU            SAVE FOR INTERNAL PURPOSES
         MTW,0    PRIVATE           GOING TO TALK TO A PRIV DP
         BEZ      %+4               IF SO,
         LW,R15   =X'00010000'        USE FILE ID GIVEN IN ASSIGN
         STW,R15  OPENPOVLP           INSTEAD OF DISKPOOL.99999999;
         BAL,R15  PPINIT              THEN INIT FOR PRIVATE PACK SAVE.
*
         MTW,0    STATS
         BEZ      NOSTATS           NO DISKPOOL
         CAL1,1   OPENPO
         NOP      0                 IN CASE OPEN FAILS
NOSTATS  EQU      %
         LW,R2    SAVBYDATE
         OR,R2    SAVBYHOUR
         STW,R2   SKIPFDA           SAVE BYPASS FDA FLAG
         DO       CPV>0
         LI,R1    MAXBQ+2           SET NUMBER OF Q'S
         SLS,R1   -1                EQUAL TO HALF
         STW,R1   MAXMF
         BAL,R15  SLAVE             GO BACCK TO SLAVE
         FIN
         B        GETAD2
         PAGE
*
*         P R I V A T E   P A C K   I N I T I A L I Z A T I O N
*
PPINIT   LCI      0                 SAVE ALL
         PSM,0    PDSTK                      REGISTERS
         LI,R15   X'10002'
         STW,R15  ACNCFU            STORE DUMMY FIRST SECTOR OF AD ADDRS
         BAL,R15  PPSETFPT          GO SET UP THE OPEN FPT
         LCI      2
         LM,R8    *ACNLOC           GET CURRENT ACN#
         STM,R8   MYACCT            SAVED
         LM,R8    PPFPTACN          GET PRIV PACK ACN#
         STM,R8   *ACNLOC           IN THE JIT
         CAL1,1   PPOPNIN           FORCE ALL PACKS TO GET MOUNTED
         LCI      2
         LM,R8    MYACCT
         STM,R8   *ACNLOC           AND THEN RESTORE JIT ACN#
*
*  GET # OF VOLUMES INVOLVED
*
         LI,R1    2                 (R1) = BYTE OFFSET TO # SIG WORDS
         LB,R1    PP:SNVLP,R1       (R1) = # VOLS INVOLVED
         STW,R1   PP#VOL            SAVE IT
*
*  FIND A SN IN THE AVR TABLES
*
         LI,R1    1                 VOLUME COUNTER
PPINIT1  LW,R8    PP:SNVLP,R1       (R8) = VOLUME SN FROM DCB
         LI,R5    AVRTBLNE-1
PPINIT2  LD,R6    AVRTBL,R5         (R6,R7) = AVR TABLE ENTRY
         CW,R8    R6                IS THIS OUR VOLUME
         BE       PPINIT4           YES--GO PROCESS IT
         AI,R5    -1                NO---ADJUST INDEX
         BGEZ     PPINIT2           GO CHECK NEXT ENTRY - IF ANY
*
*  VOLUME NOT MOUNTED - CANT HAPPEN - ABORT
*
PPINIT3  EQU      %
         LI,R15   PPNOMOUN          ADDRESS OF ERROR MESSAGE
         B        PPINIT90
*
*  VOLUME MOUNTED - CHECK TABLE ENTRIES
*
PPINIT4  CI,R5    AVRTBLSIZ-1       IS IT A PACK OR TAPE
         BLE      PPINIT3           AARGH - TAPE - GO REPORT PROBLEM
         LI,R9    1                 BIT TO TEST WITH
         SCS,R9   -3                LINE UP FOR AVR'D BIT
         CW,R9    R7                HAS IT BEEN AVR'D
         BAZ      PPINIT7           NO---GO REPORT ERROR
         CI,R1    1                 IS THIS THE PRIMARY VOLUME
         BNE      PPINIT5           NO---SKIP PRIMARY CHECKS
         SLS,R9   -4                LINE UP FOR PRIM CHECKS
         CW,R9    R7                IS THIS THE PRIMARY VOLUME
         BAZ      PPINIT8           NO---GO REPORT ERROR
PPINIT5  AND,R7   M16               ISOLATE HGP DISPLACEMENT
         AW,R7    HGPLOC           ADD IN BASE ADDRESS OF HGP TABLES
         STW,R7   PPHGPADR,R1       SAVE FOR LATER USE
         LI,R9    X'4000'
         CW,R9    1,R7              GOT TO HAVE THAT BIT ON
         BAZ      PPINIT6           THASS AN ERROR FOLKS
         AI,R5    BATAPE            (R5) = DCT INDEX FOR VOLUME
         STW,R5   PPDCTX,R1         SAVE FOR LATER USE
         AI,R1    1                 BUMP TO NEXT VOLUME
         CW,R1    PP#VOL            HAVE ALL VOLUMES BEEN PROCESSED
         BLE      PPINIT1           NO---GO LOOK UP THE NEXT VOLUME
         LCI      0                 RESTORE
         PLM,0    PDSTK                     REGISTERS
         B        *R15              RETURN
*
PPINIT6  EQU      %                 GET RID OF MASTER MODE
         LI,R15   PPNOTPRV          ADDRESS OF ERROR MESSAGE
         B        PPINIT90
*
PPINIT7  EQU      %                 GET RID OF MASTER MODE
         LI,R15   PPNOTAVR          ADDRESS OF ERROR MESSAGE
         B        PPINIT90
*
PPINIT8  EQU      %                 GET RID OF MASTER MODE
         LI,R15   PPNOTPRM          ADDRESS OF ERROR MESSAGE
*
PPINIT90 CAL1,2   PRNT15            PRINT THE ERROR MESSAGE
         M:SNAP   'F:PP DCB',(PP:SNVLP,PP:SNVLP+PPMXVOL)
         CAL1,1   PPCLSSAV          CLOSE OUR PRIVATE VOLUMES
         CAL1,9    3                ABORT JOB
*
*
*        P R I V A T E   P A C K   E R R / A B N   R E T U R N S
*
*
PPOPNABN EQU      %
PPOPNERR EQU      %
*
*        RESTORE ORIGINAL RUNNING ACCOUNT #
*
         LCI      2
         LM,R8    MYACCT
         STM,R8   *ACNLOC
*
         LI,R15   PPBADOPN          ADDRESS OF ERROR MESSAGE
         CAL1,2   PRNT15            PRINT THE ERROR MESSAGE
         M:SNAP   'F:PP DCB',(F:PP,END:F:PP)
         M:SNAP   'OPEN FPT',(PPOPNIN,PPFPTEND)
         CAL1,9    3
*
*
*              P R I V A T E   P A C K   B U I L D   F P T
*
*
PPSETFPT LI,R1    BA(PACKSN)        BEGINNING OF USER OPTIONS
         LI,R8    BA(PACKSN)+16     END OF USER OPTIONS PLUS 1
*
*  SET-UP PRIMARY PACK VOLUME SERIAL NUMBER
*
         LI,R2    BA(PPFPTSN)       ADDRESS TO STORE PACK SN IN
         LI,R9    4                 4 CHARACTER MAX
         LI,R14   PPBADSN           ERROR MESSAGE ADDRESS
         BAL,R13  PPGETOPT          GO GET IT
         B        PPGOPT7           OOPS - SN IS REQUIRED - ERROR
*
*  SET-UP PRIVATE PACK ACCOUNT
*
         LI,R2    BA(PPFPTACN)      ADDRESS TO STORE ACCOUNT IN
         LI,R9    8                 MAXIMUM OF 8 CHARACTERS
         LI,R14   PPBADACN          ERROR MESSAGE ADDRESS
         BAL,R13  PPGETOPT          GO GET IT
         B        PPSFPT01          NOT THERE - USE DEFAULTS
         CI,R12   0                 WAS AN ACCOUNT SPECIFIED
         BNE      PPSFPT10          YES--USE IT
         LCI      2                 NO---USE
         LM,R12   *ACNLOC                    JIT
         STM,R12  PPFPTACN                       ACCOUNT
*
*  SET-UP PRIVATE PACK DEVICE TYPE
*
PPSFPT10 LI,R2    BA(PPFPTDEV)+2    ADDRESS TO STORE DEVICE TYPE IN
         LI,R9    2                 MAXIMUM OF 2 CHARACTERS
         LI,R14   PPBADDEV          ERROR MESSAGE ADDRESS
         BAL,R13  PPGETOPT          GO GET IT
         B        PPSFPT02          NOT THERE - USE DEFAULTS
         CI,R12   2                 WERE 2 CHARACTERS PROCESSED
         BE       *R15              YES--FPT NOW SET UP - RETURN
         CI,R12   0                 WAS NOTHING SPECIFIED
         BNE      PPGOPT7           NO---ERROR
         B        PPSFPT02          YES--GO USE DEFAULT
*
*  USE DEFAULTS
*
PPSFPT01 LCI      2                 USE
         LM,R8    *ACNLOC               JIT
         STM,R8   PPFPTACN                  ACCOUNT
PPSFPT02 LW,R8    PPDFTDEV          USE 'DP'
         STW,R8   PPFPTDEV                   DEVICE
         B        *R15              FPT NOW SET UP - RETURN
*
*
*             P R I V A T E   P A C K   G E T   O P T I O N
*
*
PPGETOPT LI,R12   0                 SET ZERO CHARACTERS PROCESSED
         CW,R1    R8                RUN OFF END OF CARD IN SCAN
         BGE      PPGOPT2           YES
PPGOPT1  LB,R10   0,R1              (R10) = BYTE FROM +PACK CARD
         CI,R10   ' '               IS IT A BLANK
         BE       PPGOPT5           YES--GO SCAN OUT CARD
         BL       PPGOPT2           LESS MEANS DELIMITER.....
         CI,R10   '.'               PERIOD IS DELIMITER
         BE       PPGOPT4
         CI,R10   ','               COMMA ALSO
         BE       PPGOPT4
         CW,R12   R9                IS THERE ROOM IN OUTPUT BUFFER
         BGE      PPGOPT7           NO---GO SIGNAL ERROR
         STB,R10  0,R2              YES--STORE IT
         AI,R1    1                 UPDATE
         AI,R2    1                        ALL
         AI,R12   1                            POINTERS
         CW,R1    R8                IS THERE MORE DATA TO PROCESS
         BL       PPGOPT1           YES--GO DO IT
*
*  FILL OUT OPTION WITH BLANKS
*
PPGOPT2  LI,R10   ' '               GET A BLANK TO STORE
         AI,R13   1                 SET UP <NOT END> RETURN
         LW,R11   R12               GET COUNT SO WE CAN CHANGE IT
PPGOPT3  CW,R11   R9                DO WE NEED TO STORE A BLANK
         BGE      *R13              NO---RETURN TO CALLER
         STB,R10  0,R2              YES---PUT IN A BLANK
         AI,R2    1                 INCREMENT
         AI,R11   1                           POINTERS
         B        PPGOPT3           GO SEE IF WE ARE DONE
*
*  TERMINATOR FOUND
*
PPGOPT4  AI,R1    1                 UPDATE INPUT POINTER
         B        PPGOPT2           GO BLANK FILL AND RETURN
*
*  BLANK FOUND - SCAN OUT BUFFER
*
PPGOPT5  AI,R1    1                 MOVE TO NEXT BYTE
         CW,R1    R8                ARE WE DONE
         BGE      PPGOPT6           YES--GO CHECK TYPE OF EXIT
         LB,R10   0,R1              NO---(R10) = BYTE FROM BUFFER
         CI,R10   ' '               IS IT A BLANK
         BE       PPGOPT5           YES--KEEP GOING
         BL       PPGOPT6           LESS IS TERMINATOR
         B        PPGOPT7           NO---GO FLAG ERROR
PPGOPT6  CI,R12   0                 WERE ANY CHARACTERS FOUND
         BE       *R13              NO---USE END OF CARD EXIT
         B        PPGOPT2           YES--GO BLANK FILL OPTION
*
*  POST ERROR MESSAGE AND ABORT
*
PPGOPT7  BAL,R15  SLAVE             GET RID OF MASTER MODE
         LW,R15   R14               (R15) = MESSAGE ADDRESS
         CAL1,2   PRNT15            SIGNAL ERROR
         CAL1,9    3                ABORT
*
*
*              P R I V A T E   P A C K   C O N S T A N T S
*
*
PPNOMOUN TEXTC    'PRIVATE VOLUME NOT MOUNTED'
PPNOTPRV TEXTC    'PRIVATE VOLUME NOT PRIVATE'
PPNOTAVR TEXTC    'PRIVATE VOLUME NOT AVR''D'
PPNOTPRM TEXTC    'PRIMARY PRIVATE VOLUME IS NOT PRIMARY'
PPCLSSAV M:CLOSE,L F:PP,(SAVE),(REM)
PPBADOPN TEXTC    'BAD OPEN TO PRIMARY PRIVATE PACK'
PPBADSN  TEXTC    'BAD SN SPECIFICATION ON +PACK CARD'
PPBADACN TEXTC    'BAD ACCOUNT SPECIFICATION ON +PACK CARD'
PPBADDEV TEXTC    'BAD DEVICE SPECIFICATION ON +PACK CARD'
PPDFTDEV DATA     'DP'
*
*
*                    P R I V A T E   P A C K   D C B
*
*
PPMXVOL  EQU      32
F:PP     DSECT    1
F:PP     M:DCB    (FILE,'FSAVEHOME','SOMEACNT'),(PASS,'MICKMOUS'),;
                  (KEYED),(DIRECT),(IN),(SAVE),(ABN,PPOPNABN),;
                  (ERR,PPOPNERR),(SN,PPMXVOL)
         DO       CPV>0
PP:SNVLP EQU      F:PP+32
END:F:PP EQU      F:PP+64
         ELSE
PP:SNVLP EQU      F:PP+29
END:F:PP EQU      F:PP+64
         FIN
*
*
*
*              P R I V A T E   P A C K   V A R I A B L E S
*
*
         USECT    DATASEC
         BOUND    8
PPOPNIN  GEN,8,24 X'14',F:PP        M:OPEN
         DATA     X'C5441041'       PP'S
         DATA     PPOPNERR          ERROR RETURN
         DATA     PPOPNABN          ABNORMAL RETURN
         DATA     3                 RANDOM
         DATA     8                 OUTIN
         DATA     1                 REL
PPFPTDEV DATA     X'C4D7'           DEVICE
         DATA     0                 RSTORE
         DATA     X'01000303'       FILE  NAME
         TEXTC    'FSAVEHOME'       FILE NAME
         DATA     X'02000202'       ACCOUNT
PPFPTACN TEXT     'SOMEACNT'
         DATA     X'07010101'       SN
PPFPTSN  TEXT     'PACK'            SN OF PACK TO SAVE
PPFPTEND EQU      %-1
PPDCTX   RES      PPMXVOL+1
PPHGPADR RES      PPMXVOL+1
PP#VOL   RES      1
PACKSN   RES      4
         PAGE
*
*        'GETAD' GET FIRST SECTOR OF ACCOUNT DIRECTORIES
*
*        'GETAD3' TO GET SUBSEQUENT SECTORS OF THE DIRECTORY
*
         USECT    PROCED
GETAD2   LW,R0    DUMP              IN OUTPUT MODE
         BEZ      GETAD1            MUST NOT BE SAVING FILES
         BAL,SR3  NEWREEL           GET TAPE MOUNTED
         BAL,R7   WRTDAT            WRITE THE 'DATE' FILE ON TAPE
GETAD1   LW,R8    ACNCFU            GET D/A OF ACCOUNT DIRECTORY
         BAL,R15  DTOGRAN           VERIFY ACNCFU ADDRS
         B        READFAIL          *****DISASTER*******
GETAD    EQU      %
         LI,R13   BA(ACBUF)
         BAL,R15  DISCIO            QUEUE UP
         B        READFAIL2         ***LINK FAILURE****
*
*
GETAD3   EQU      %
         MTW,0    DIRLISTSW         SNAP IT
         BEZ      %+2               NO
         BAL,R14  LISTAD            YES--> PUT IT OUT
         AND,R8   M24               MASK FLINK
         LW,R6    ACBUF             GET NEW SECTOR'S BLINK
        CW,R6    LASTAC            COMPARE TO WHERE WE WERE
         DO       CPVC00=1
         BNE      READFAIL2         BACK LINK FAILURE--GET THE DUAL
         ELSE
         BE       GETAD4            OK--> CONTINUE
         AI,R6    0                 ERROR,HAVE WE BACKED UP END
        BEZ      READFAIL2         YUP,BAD BLINK SEQUENCE
         STW,R6   ACFLINK           NOP,READ THE BLINK TO GET IN SYNC
         B        ADDONE            READ BACKWARDS...
         FIN
GETAD4   STW,R8   LASTAC            MARK CDA
         LD,R8    ACBUF
         STD,R8   ACBLINK           STORE BACK / FORE ADDRS POINTERS
         DO       CPVC00=1
         LW,R9    ACBUF+511         GET DUAL ACCT DIR GRANULE
         STW,R9   ADDUAL            SAVE IN CASE ADFLINK IS BAD
         FIN
         LH,R9    ACBUF+2           GET SECTOR NAV
         STW,R9   ACSIZE            AND SAVE
         LI,R1    ACDISP            DISPLACEMENT TO FIRST KEY
         STW,R1   NEXACN            SET AS NEXT INDEX
         STW,R1   CURACN            SET AS CURRENT INDEX
         PAGE
*
*        GET NEXT ACCOUNT FROM CURRENT ACCOUNT DIRECTORY
*
NACN     EQU      %
         LH,R0    M:PO
         CI,R0    32                IS M:PO DCB OPEN NOW
         BAZ      %+2              NO
         CAL1,1   CLSPO            YES--> CLOSE M:PO DCB
         LW,R3    NEXACN            GET NEXT INDEX
         STW,R3   CURACN            UPDATE CURRENT POINTER
         CW,R3    ACSIZE            INDEX=NAV YET
         BGE      ADDONE            SECTOR COMPLETED-GET NEXT
         LI,R2    ACDKEYL            KEYLENGTH FOR ACCOUNT DIRECTORY
         MTW,0    PRIVATE
         BEZ      NACN1             NOT PRIV PACK
         AI,R3    4                 POINT TO TEXT OF KEY
         LI,R2    ACDKEYLPP         LOAD LENGTH OF AD KEYS
         AWM,R2   NEXACN            UPDATE PTR
         B        NACN2             AND JUMP
NACN1    EQU      %
         AWM,R2   NEXACN            UPDATE NEXT AD BY PUBLIC KEY THEN
         DO       CPVC00=1
         AI,R3    1                 POINT TO TEXT OF KEY
         ELSE
         AI,R3    4                 POINT TO TEXT OF KEY
         FIN
NACN2    EQU      %
         LI,R5    BA(ACN#CURNT)     PLACE TO STICK IT
         LI,R2    BA(ACBUF)
         AW,R2    R3                ADD DISPLACEMENT TO TEXT IN KEY
         LI,R3    8                 # OF BYTES OF ACCOUNT #
         BAL,R15  MOVEBYT           MOVE IT INTO PLACE
         LD,R0    ACN#CURNT         CHECK ACCOUNT NUMBER
         BEZ      NACN              NONE OF OUR CHECKS WORK ON ZERO.
         PAGE
*
*        SCAN OPTIONS TO SEE WHAT SHOULD BE DONE WITH THIS ACCOUNT
*
SELCK    EQU      %
         LW,R1    SELECT            SELECTING FILES/ACCOUNTS
         BEZ      SKCK              NO--> CHECK SKIP
         LW,R1    END               GOT TO END YET
         BNEZ     ENDUP             YUP--> QUIT
         BAL,R15  ACCK              SEE IF CURRENT ACN EQUAL TO CARD
         BEZ      NACN              NOT AT IT YET...
         BLZ      SELCK0            GOTCHA
         BAL,R14  RD:COM            READ NEXT DATA CARD ON A PASS IT..
         B        SELCK             SEE WHAT TO DO WITH THIS CARD
*
*
SELCK0   EQU      %
         LI,R14   NOTLB             YES--> SET RETURN FROM
SELCK1   EQU      %
         LW,R0    ALL               DO ALL FILES IN THIS ACCOUNT
         BEZ      NOTLB             NOPE--> FILE NAME ON THIS CARD
SELCK2   EQU      %
         LI,R1    7
         LS,R1    M:SI              SEE IF STUFF IN FILE
         CI,R1    1
         BNE      %+2               NOPE
         CAL1,1   DELRECSI          ELSE DELETE THIS RECORD
         MTW,-1   DATACARDS         DECREMENT COUNT LEFT TO GO
         B        RD:COM            AND READ NEXT RECORD
*
*        CHECK TO SEE IF SKIP MODE
*
SKCK     EQU      %
         LW,R1    SKIP              IS IT
         BEZ      STOPCK            NOPE
         LW,R1    END               SEEN LAST DATA CARD YET
         BNEZ     SETALLF           IF END HIT - DO ALL FILES FROM HERE
         BAL,R15  ACCK              CURRENT ACCOUNT EQUAL TO DATA CARD
 BE SETALLF NO- DO ALL
         BLZ      SKCK1             YES - SKIP
         BAL,R14  RD:COM            READ NEXT DATA CARD
         B        SKCK              CHECK
SKCK1 EQU %
         LI,R14   NACN              SET RETURN ADDRESS
         B        SELCK1            AND READ NEXT CARD
*
*        TEST FOR STOP COMMAND
*
STOPCK   EQU      %
         LW,R1    STOPAT            STOP FLAG SET
         BEZ      STARTCK           NO--> CHK FOR START
         LW,R1    END               ALREADY READ THE LAST CARD
         BNEZ     ENDUP             YUP--> ALL DONE TODAY
         BAL,R15  ACCK              CHK CURRENT ACN VS CARD ACN
         BEZ      SETALLF           CURRENT NOT EQUAL TO DATA CARD
         BGZ      ENDUP             CURRENT WAS GREATER THAN DATA CARD
*                        ***BLZ INDICATES A HIT***
         LW,R0    ALL               ANY FILE NAME ON THIS CARD
         BEZ      SELCK0            YES--> FIND FILE IN THIS ACN
         CAL1,1   DELRECSI          OK--> DELETE THIS RECORD
         MTW,-1   DATACARDS         COUNT DOWN THE RECORD COUNT
         B        ENDUP             AND EXIT TO THE MONITOR
*
*        SEE IF START OPTION SET
*
STARTCK  EQU      %
         LW,R1    STARTSET          START SPECIFIED
         BEZ      SETALLF           NO--> DO ALL FILES IN ALL ACCOUNTS
         LW,R0    END               SEEN LAST DATA CARD YET
         BNEZ     SETALLF           YES--> DO ALL FROM HERE THEN
         BAL,R15  ACCK              CURRENT ACN MATCH CARD
         BEZ      NACN              NO MATCH YET
*
*        START OFF IF A MATCH HIT OR WE PASSED IT NOW
*
         LW,R1    ALL               FILE NAME ON THE CARD
         BEZ      SELCK0            YES--> FIND FILE IN THIS ACCOUNT
         LI,R14   SKCK              SET RETURN TO CHECK FOR
*                                   SKIPPING IN CURRENT ACCOUNT.
         B        SELCK2            AND READ NEXT RECORD
*
*
*
DELRECSI GEN,8,24  13,M:SI
         DATA      0,0              DELETE LAST RECORD READ
*
*        NO OPTIONS OR USE ALL FILES IN THIS ACCOUNT
*
SETALLF  EQU      %
         LI,R1    -1
         STW,R1   ALL               SET FLAG TO DO ALL FILES
         B        NOTLB             AND JOIN UP
         PAGE
*
*        EVERY NEW ACCOUNT GETS A NEW PAGE UNLESS IN DATE/HOUR MODE-->
*        IN THAT MODE WE MAY DEFER THIS UNTIL WE ACTUALLY SAVE
*        A FILE IN THAT ACCOUNT
*
ACNPAGE  EQU      %
         MTW,0    LIST              WRITING LO TODAY ??
         BEZ      0,R7              NO-> RETURN
         MTW,1    DEFER             SET FLAG
         CAL1,1   PAGEFPT           PUT OUT NEW PAGE
         CAL1,1   WRTBLNK           SKIP A LINE
         LI,R15   CR
         CAL1,2   PRNT15            PRINT CURRENT ACCOUNT # / REEL #
         CAL1,1   WRTBLNK           SKIP A LINE
         B        0,R7              RETURN TO CALLER
         PAGE
*
*        THIS ACCOUNT IS TO BE PROCESSED
*
NOTLB    EQU      %
         LW,R0     LIST             LIST MODE SET
         BEZ       NOPRINT          NO-SKIP PRINTING INFORMATION
         LI,R0    255               ASSUME NOT
         LW,R1    SAVBYDATE
         AW,R1    SAVBYHOUR
         BEZ      %+2               IS TRUE-> NOT THAT MODE
         LI,R0    0                 ELSE
         STW,R0   DEFER             LEAVE FLAG THEN
         AI,R0    0
         BEZ      %+2               GOING TO DEFER IT UNTIL LATER
         BAL,R7   ACNPAGE           PUT OUT NEW PAGE IF NOT DEFER MODE
NOPRINT  EQU      %                 *
         LI,R5    2
         STW,R5   FITBUFS
         LW,R10   FITBUFS,R5
         AND,R10  M17
         STW,R10  FITBUFS,R5
         BDR,R5   %-3               FREE UP ALL FIT BUFFERS
         LI,R1    0                 RESET THE NEW ACCOUNT'S
         STW,R1   LASTFD            BACK LINK
         PAGE
*
*        GOING TO USE THIS ACCOUNT - GET ITS FILE DIRECTORY
*
         LW,R2    NEXACN            NEXT INDEX TO AC DIRECTORY
GETDFD0  AI,R2    BA(ACBUF)         ADD CORE ADDRS
         MTW,0    PRIVATE
         BE       GETDFD1           NO
         AI,R2    ADKBDPP-3         BACK UP TO DA BYTE3 ON PRIV PACK
         B        %+2
GETDFD1  EQU      %
         AI,R2    ADKBD-3           BACK UP TO DISC ADDRS BYTE3
         DO       CPVC00=1
         LI,R3    8                 8 BYTE LOOP
         ELSE
         LI,R3    4                 4 BYTE LOOP
         FIN
         LI,R5    R8*4              DESTINATION BA
         BAL,R15  MOVEBYT           MOVE IT INTO R8
         DO       CPVC00=1
         AND,R8   M24               MASK OFF GARB FROM TEXTC
         SLS,R9   -8
         STW,R9   FDDUAL            SAVE DUAL FILE DIR GRANULE
         FIN
GETFD0   BAL,R15  DTOGRAN           VERIFY DISC ADDRESS
         B        ADERROR           BAD ACN KEY-REPORT IT
GETFDA   EQU      %
         LI,R13   BA(FDBUF)
GETFD    BAL,R15  DISCIO            GO READ IT
         B        READFAIL3         LINK FAILURE**********
*
*
*
GETFD1   EQU      %
         MTW,0    DIRLISTSW         SNAP DIRECTORIES
         BEZ      %+2               NO
         BAL,R14  LISTFD            YES
         AND,R8   M24               MASK FLINK
         LW,R6    FDBUF             GET NEW BLINK
         BEZ      GETFD1A
         MTW,0    PRIVATE
         BE       GETFD1A           NO PROBLEM WITH DA IF NOT PRIV PK
         LW,R9    R8                SAVE R8
         LW,R8    R6                MOVE NEW BLINK TO R8
         BAL,R15  DTOGRAN           CONVERT TO REAL DA FOR BLINK CHECK
         NOP                        IGNORE ERROR HERE
         LW,R6    R8                MOVE BLINK BACK FOR CHECK
         LW,R8    R9                RESTORE R8
GETFD1A  EQU      %
        CW,R6    LASTFD            COMPARE TO WHERE WE WERE
         DO       CPVC00=1
         BNE      READFAIL3         BACK LINK FAILURE-GET DDUAL
         ELSE
         BE       GETFD2            OK--> CONTINUE
        AI,R6    0                 BACKED UP TO END YET
        BEZ      READFAIL3         YUP,BAD BLINK SEQUENCE
        STW,R6   FDFLINK           NO,READ THE BLINK TO GET INTO SYNC
         B        FDDONE            SOMEWHERE IN DIRECTORY
         FIN
         PAGE
*
*        A FILE DIRECTORY SECTOR IS READY TO BE PROCESSED.
*        MOVE SECTOR INFO INTO TABLES,SET UP POINTERS TO
*        SEARCH THE SECTOR.
*
GETFD2  STW,R8   LASTFD            MARK CDA IN DIRECTORY
         LD,R8    FDBUF
         STD,R8   FDBLINK           STORE BACK/FORWARD POINTERS
         LI,R2    FDDISP            INITIAL INDEX
         DO       CPV>0
         LH,R9    FDBUF+3           START OF FILE DIRECTORY
         CI,R9    X'0100'           CHECK FOR DUMMY FILE
         ELSE
         CI,R8    0                 IS FIRST SECTOR OF DIRECTORY
         FIN
         BNE      %+2
         AI,R2    FDKEYL            SKIP OVER DUMMY FILE
         STW,R2   NEXFILE           AND STORE INDEX AWAY
         LH,R9    FDBUF+2           GET SECTOR NAV
         STW,R9   FDSIZE            AND SAVE
         PAGE
*
*        GET NEXT KEY FROM CURRENT FILE DIRECTORY SECTOR
*
GETFILE  EQU      %
         LI,R7    GETFILE2          STRAIGHT THRU EXIT ADDRS
         LW,R2    NEXFILE           MOVE 'NEX' KEY INDEX
         STW,R2   CURFILE           TO CURRENT INDEX
         CW,R2    FDSIZE            INDEX=NAV YET
         BGE      FDDONE            SECTOR COMPLETED-GET NEXT
         AI,R2    FDKEYL            ADD KEY ELNGTH
         STW,R2   NEXFILE           TO PRODUCE NEXT INDEX
GETFILE1 AI,R2    BA(FDBUF)         ADD CORE ADDRS
         DO       UTS>=3
         LI,R3    8
         ELSE
         LI,R3    4                 SO
         FIN
         LI,R5    R8*4
         AI,R2    FDKBD-3           POINT TO BYTE 0 OF DISC ADDRS
         BAL,R15  MOVEBYT           MOVE DISC ADDRS INTO R8
         B        0,R7              EXIT OR FALL THRU
GETFILE2 EQU      %
         STW,R8   FITDA             REMEMBER FIT DISC ADDRESS
         DO       UTS>=3
         SLS,R9   -8                POSITION IT
         AND,R9   =X'FFF0FFFF'      MASK OFF DYNAMIC BITS
         OR,R9    =X'00800100'      STICK IN CHANGE BITS
         STW,R9   STDESCR           AND SAVE
         LI,R1    0                 ASSUME NOT A SYNON FILE
         CI,R9    X'4000'           IS TRUE
         BAZ      %+2               YUP
         LI,R1    X'4000'           NO
         STW,R1   SYNFLAG           STORE ANSWER
         ELSE
         LI,R1    0
         STW,R1   SYNFLAG           CLEAR IT FOR BPM VERSIONS
         FIN
         PAGE
*
*        CHECK TO SEE IF OPTIONS INDICATE TO USE THIS FILE PRIOR
*        TO READING THE FIT INTO CORE
*
         BAL,R15  PUTNAME           MOVE NAME INTO :BOF RECORD
         LW,R1    ALL               DO ALL FILES
         BLZ      FITCHKS           YUP--> GET THE FIT NOW
GETFILE3 EQU      %
         LB,R3    INBUF+3           GET TEXTC CNT OF NAME ON CARD
         CB,R3    BOFBUF+2          WHO IS LONGER
         BGE      %+2               CARD IS
         LB,R3    BOFBUF+2          FILE IS
         LI,R4    BA(BOFBUF+2)+1
         LI,R5    BA(INBUF+3)+1     SET UP CBS REGISTERS
         BAL,R7   CBYTE             CHECK FOR MATCHING NAMES
         BE       FIT60             MATCH
         BG       FIT100            WE'RE PAST WHERE IT SHOULD FALL
*
*        CURRENT FILE IN FILE DIRECTORY DOESNT MATCH THE DATA CARD
*
FIT59    EQU      %
         LW,R1    SELECT
         AW,R1    STARTSET          SELECTING OR STARTING AT NAME
         BNEZ     GETFILE           YES--> MOVE TO NEXT FILE NAME
         B        FITCHKS           ANYTHING ELSE SAYS TO USE IT
         PAGE
*
*        CURRENT FILE MATCHES CURRENT DATA CARD NAME
*
FIT60    EQU      %
         LW,R1    SKIP
         STW,R1   SKIPX             SAVE CURRENT MODE IF SKIP
         LI,R1    7
         LS,R1    M:SI              WHERE IS M:SI ASSIGNED
         CI,R1    1                 TO A FILE
         BNE      %+2               NO
         CAL1,1   DELRECSI          YES--> DELETE CURRENT RECORD
         MTW,-1   DATACARDS         COUNT DOWN
         BAL,R14  RD:COM            READ THE NEXT DATA CARD
         BAL,R15  ACCK              TEST CUR ACN# .VS. CARD ACN#
*
*        COME THROUGH HERE IF ACCOUNT # STAYS THE SAME
*
         LW,R1    SKIPX             ARE WE (OR WERE WE BEFORE
*                                   LAST CARD) IN SKIP MODE
         BEZ      FIT70             NOT IN SKIP MODE
         LW,R0    END               SEEN LAST CARD YET
         BNEZ     FIT61             YES-> DO ALL FROM HERE THEN
         LW,R0    ACEQU             IS NEXT DATA CARD SAME ACN#
         BLZ      GETFILE           YES--> GET NEXT FILE NAME IN ACCOUNT
FIT61    EQU      %
         LI,R0    -1                NO--> ITS A NEW ACN#
         STW,R0   ALL               SO WE WILL DO ALL FILES REMAINING
         B        GETFILE           AFTER SKIPPING THIS ONE
*
FIT70    EQU      %
         LW,R1    SELECT
         BEZ      FIT80             NOT SELECT MODE
         LW,R0    END               DID WE READ THE LAST CARD
         BNEZ     FIT81             YES-> QUIT AFTER THIS FILE
         LW,R0    ACEQU             IS NEXT CARD DIFF ACN#
         BLZ      FITCHKS           IS SAME ACCOUNT# ON NEXT CARD
         B        FIT81             FORCE JUMP TO NEW ACN# NEXT PASS
*
*
FIT80    EQU      %
         LW,R1    STOPAT            IS STOP MODE
         BEZ      FIT90             NOPE
         LW,R0    END               HAVE WE SEEN THE LAST CARD
         BNEZ     FIT81             YUP--> NEXT TIME WE QUIT
         LW,R0    ACEQU             NO---> IS NEXT ACN# DIFFERENT
         BLZ      FITCHKS           NOPE-> LEAVE FLAGS ALONE
FIT81    EQU      %                 YES--> CHANGE ACCOUNTS NEXT FILE
*
*        FORCE EXIT TO NEXT ACCOUNT NUMBER AFTER THIS FILE IS DONE
*
         BAL,R7   CLRFD             YES---> FORCE EXIT OUT OF THIS ACN
         B        FITCHKS           SAVE FILE NOW THO....
*
FIT90    EQU      %
         LW,R1    STARTSET          IN START MODE
         BEZ      FITCHKS           NO--> SO SAVE THIS FILE I GUESS
FIT91    EQU      %
         LW,R1    END               SEEN LAST DATA CARD YET
         BNEZ     FIT92             IF LAST CARD - DO ALL FROM NOW ON
         BAL,R15  ACCK              TEST NEW CARD FOR DIFFERENT ACN#
         BLZ      FITCHKS           ITS THE SAME - LEAVE FLAGS AS IS
FIT92    EQU      %
         LI,R0    -1                IS LAST DATA CARD SEEN LET US
         STW,R0   ALL               SAY TO DO ALL FILES FROM HERE
         B        FITCHKS           GO GET EM
*
         PAGE
*
*        WE HAVE PASSED THE NAME GIVEN ON THE CURRENT DATA CARD -
*        WE WILL DO SOME THINKING HERE SO READ FOLLOWING CAREFULLY
*
FIT100   EQU      %
         LW,R1    SKIP              IN SKIP MODE
         BEZ      FIT110            NO
FIT105   EQU      %
         BAL,R14  RD:COM            READ THE NEXT DATA CARD
         B        FIT130            IF SAME ACCT CHECK NEW DATA CARD
*
FIT110   EQU      %
         LW,R1    SELECT
         BEZ      FIT120            NOT SELECT MODE EITHER
FIT112   EQU      %
         BAL,R14  RD:COM            READ NEXT DATA CARD
         LW,R0    END               SEEN LAST DATA CARD YET
         BNEZ     FIT115            YUP--> FORCE EXIT
         BAL,R15  ACCK              TEST FOR NEW ACCOUNT #
         BL       GETFILE3          CHECK FILE AGAIN WITH NEW DATA
FIT115   EQU      %
         BAL,R7   CLRFD             YES---> NEW ACCOUNT # GIVEN
         B        GETFILE           END THIS ACCOUNT AND START NEW ONE
*
FIT120   EQU      %
         LW,R1    STARTSET          IN START MODE
         BNEZ     FIT105            YES-> CHK FOR END/NEW ACN#
*
         LW,R1    STOPAT            ONE LAST MODE
         BNEZ     FIT112            YES-> CHK FOR END/NEW ACCOUNT #
         B        FITCHKS           NO--> JUST SAVE FILE I GUESS
FIT130   EQU      %                 CHECK NEW DATA CARD ACCT
         LW,R1    END               SEEN LAST DATA CARD YET
         BNEZ     FIT92             YES - NO MORE TO SKIP
         BAL,R15  ACCK              ACCT SAME AS ON LAST DATA CARD
         BLZ      GETFILE3          YES - CKECK FILE AGAIN - NEW DATA
         B        FIT92
         PAGE
*
*        FORCE EXIT TO NEXT ACCOUNT # NEXT TIME AROUND
*
CLRFD    EQU      %
         LI,R1    0
         STW,R1   FDFLINK           ERASE FORWARD LINK
         LI,R1    X'FFF'
         AWM,R1   NEXFILE           STEP INDEX IN DIRECTORY
         B        0,R7              AND RETURN
*
CLS%SAV  GEN,8,24  X'15',M:SI
         PZE      *0
         DATA     2
         PAGE
*
*        LOCATE FIT VIA READ-AHEAD ROUTINE AND CHECK TO SEE IF THE
*        FILE NAME IN THE FIT MATCHES THE FILE NAME IN THE FILE
*        DIRECTORY.
*
FITCHKS  EQU      %
         LW,R8    FITDA             GET CURRENT FIT DISC ADDRESS
         BAL,R11  LOCFIT            AND GET IT
         DO       UTS>=3            ASSUME FIT AT END OF SECTOR
         LW,R6    FITBUFWA          WA IF BUFFER FIT IS IN
         LW,R5    R6                COPY TO R5
         LW,R3    R6                AND TO R3
         AI,R3    4                 R3 IS FITLOC IF...
         AI,R6    DIRSIZ-80         R6 IS FITLOC IF...
         LI,R4    5
         LH,0     *R5,R4            TEST FOR
         BL       %+2
         LW,R6    R3                R3 IS THE WINNER
         STW,R6   FITLOC            REMEMBER IT
         LW,R5    R6                COPY IT TO R5
         SLS,R6   2
         STW,R6   FNEA
         AI,R5    9
         STW,R5   INITX
         ELSE
         LW,R6    FITBUFWA
         AI,R6    2                 ***POINT TO NAME WORD IN FIT
         STW,R6   FITLOC
         SLS,R6   2
         STW,R6   FNEA
         LW,R6    FITLOC
         AI,R6    10                FIRST CODE ENTRY IN THE FIT
         STW,R6   INITX             SAVED TO SCAN ON
         FIN
         MTW,0    FITLISTSW         USER WANT TO SEE IT FIRST
         BEZ      %+2               NO
         BAL,R14  LISTFIT           YES--> SHOW IT
         LB,R3    *FITLOC           GET FILE NAME BYTE COUNT FROM FIT
         BEZ      FITSNAP           ERROR IF ZERO/LESS
FITCHKS05 LW,R4   CURFILE           CURRENT INDEX TO DIRECTORY
         AI,R4    BA(FDBUF)         GETS CORE SBA
         DO       UTS>=3            CO1 CODE
         LW,R0    SYNFLAG           IS CURRENT FILE SYNON
         BEZ      FITCHKS07         NO
         AI,R5    -10               BAK IT UP
         STW,R5   INITX             AND SAVE IT FOR LATER
         LW,R3    =X'0B010909'      B ENTRY CODE WORD
         STW,R3   *INITX            STICK IT INTO FIT
         LB,R3    0,R4              YES,GET BYTE CNT FROM FD KEY
         FIN
         DO       UTS>0             ANY UTS CODE
FITCHKS07 STB,R3  FNEC              STORE BYTE CNT
         LI,R5    18                MAX PRINT LINE NAME
         CW,R3    R5                NAME OK
         BLE      %+2               YEP
         STB,R5   FNEC              NO,TRUNCATE NAME TO 18 BYTES
         FIN
         AI,R3    1                 CREATE FULL STRING COUNT
         STB,R3   FNEA              AND SAVE
         STB,R3   FNEB              DITTO
         DO       UTS>=3
         LW,R1    SYNFLAG
 BNE BLD:BOF YES - DONT CHECK FIT NAME FOR MATCH
         FIN
         LW,R5    FNEA              BA OF NAME IN THE FIT
         BAL,R7   CBYTE             COMPARE FIT TO FD KEY
         BE       BLD:BOF           **WINNERS GO TO HOME PLATE**
         LI,R15   FNERR             **BAD GUYS GET SKIPPED OVER**
FITCHKS21 EQU     %
         CAL1,2   PRNT15            W/ERROR MSG
         B        FITERR            AND SNAPS ON M:LL
         PAGE
*
*        FILE NAME IN FIT MATCHES FILE NAME IN DIRECTORY - WE'VE
*        DISCOVERED THAT WE WANT TO USE THIS FILE SO HERE WE GO
*
BLD:BOF  EQU      %
         BAL,R7   SCANF             BUILD THE :BOF RECORD
         DO       UTS>=3
         LW,R7    DUMP              WRITING TAPE TODAY
         BEZ      BLD:BOF0          NOPE-> NO CHECK ON AUTO BACKUP BIT
         LW,R7    SELECT            YES--> ARE WE SELECTING FILES
         BNEZ     BLD:BOF0          YES--> NO CHECK ON AUTO BACKUP BIT
         LW,R7    STDESCR           NO---> GET DESCRIPTOR BITS
         CI,R7    X'800'            IS THE 'NO-AUTO-BACKUP' BIT SET
         BANZ     GETFILE           YES - DONT SAVE
BLD:BOF0 EQU      %
         FIN
         BAL,R15  INITFIL           INIT ALL THE POINTERS/READ FDA
         LW,R1    BLANK
         MTW,0    SYNFLAG           IS FILE SYNON
         BEZ      %+2               NO
         LW,R1    SYNMSG
         STW,R1   TLABUF            THERE--> TAPE LABEL IS ALMOST DONE
*
         DO       FILL=1
         LI,R2    BKUPVLP           FOR FILL TAPES
         LW,R5    BUFLOC+1          MOVE BACKUP VLP TO TAPE LABEL
         BAL,R15  MOVENTRY
         SLS,R5   -2                BACK INTO A WORD ADDRESS
         LI,R2    VLP11
         BAL,R15  MOVENTRY
         SLS,R5   -2                BACK INTO A WORD ADDRESS
         STW,R5   BUFLOC+1          SAVE IT (TAPE LABEL CURRENT LOC)
         FIN
*
         LW,R4    BUFLOC            CURRENT LOC IN :BOF RECORD
         LW,R1    9ENTRY            LAST ENTRY TO GO INTO :BOF
         STW,R1   0,R4
         STW,R4   9LOC              SAVE WA OF NINE ENTRY IN THE :BOF
         AI,R4    1                 STEP TO NEXT LOC ON :BOF RECORD
         LH,R1    ORG               GET ORG AND KEYM
         MTW,0    SYNFLAG           IS CURRENT FILE SYNON
         BEZ      %+2               NOPE
         LI,R1    3                 YES-SET KEYM=3
         SLS,R1   8
         AI,R1    1                 INITIALIZE VOL FIELD
         SLS,R1   8
         STW,R1   *R4                  PUT ORG,KEYM,AND VOL IN :BOF RECORD
         LW,R2    RANDOM
         STW,R2   FGCOUNT           COPY HERE IN CASE OF LOG ONLY
         STW,R2   TLABUF+4          ALWAYS SAVE RSTORE FOR FILL
         LB,R1    ORG
         CI,R1    2
         BE       BLD:BOF1          BR IF KEYED
         LI,R3    4
         STW,R3   SCR               SET SCR TO KEYM+1 FOR CONSEC
         CI,R1    3
         BNE      %+2               BR IF CONSEC
         STB,R1   TLABUF+3
         LW,R1    =X'1030100'
         STW,R1   0,R4              STORE 09 ENTRY WORD
BLD:BOF1 EQU      %
         AI,R4    1                 TO NEXT LOC IN :BOF RECORD
         DO       FILL=1
         LW,R1    BUFLOC+1          END POSITION OF TLABEL
         AI,R1    -TLABUF           WORD SIZE OF BUFFER
         SLS,R1   2                 WORDS TO BYTES
         AI,R1    -1                TEXTC
         STB,R1   TPLFLG            FIX UP COUNT
         FIN
         LW,R1    TPLFLG
         MTW,0    LABELEDT          FPURGE TAPE
         BEZ      %+2               YES
         LI,R1    0                 NO-NO TAPE LABEL
         STW,R1   0,R4              MOVE IT TO TAPE LABEL
         AI,R4    1                 TO BOFBUF POSITION
         STW,R4   BUFLOC            SAVE POSITION
         AI,R4    -BOFBUF           GET WORD SIZE OF BOF BUFFER
         SLS,R4   2                 WORDS TO BYTES
         STW,R4   BOFSIZE
         LCI      2
         DO       UTS=0             FOR BPM
         LM,R2    CRE:DATE          GET THE CREATION DATE
         ELSE                       BUT FOR CP-V
         LM,R2    BKUPVLP+1         GET THE MODIFIED DATE
         FIN
*
         STM,R2   TLABUF+5          PUT INTO TAPE LABEL
*
         DO1      CPV>0
         LM,R2    MOD:DATE
*
         LW,R1    SAVBYDATE         CHECK IF SAVING
         AW,R1    SAVBYHOUR         BY DATE AND/OR HOUR
         BEZ      BLD:BOF4          NOT HOUR/DATE SAVING THIS TIME
         MTW,0    SAVBYDATE         BY DATE THEN
         BEZ      BLD:BOF2          NOPE
         LI,R5    1
         LH,R4    R3,R5
         CH,R4    SAVEDATE+1        DOES FILE QUALIFY BY YEAR..
         BL       GETFILE           NO...GET NEXT IF EARLIER YEAR
         BG       BLD:BOF3          SAVE IT IF LATER YEAR
         CW,R2    SAVEDATE          FILE QUALIFY
         BL       GETFILE           NO,GET NEXT IF EARLIER DATE
         BG       BLD:BOF3          SAVE IT IF LATER DATE
BLD:BOF2 EQU      %
         MTW,0    SAVBYHOUR         LOOK AT HOUR ALSO...
         BEZ      BLD:BOF3          NOPE..GO ON AND SAVE THIS FILE
         LI,R4    '59'
         SLS,R3   -16               POSITION HOUR
         STH,R3   R4                CREATE HOURS/MINUTES WORD
         CW,R4    SAVEHOUR          TEST AGAINST HOUR CREATED SUPPLIED
         BL       GETFILE           NOPE..GET NEXT FILE
BLD:BOF3 EQU      %
         MTW,0    DEFER             DID WE DEFER NEW PAGE TILL NOW
         BNEZ     %+2               NOPE
         BAL,R7   ACNPAGE           YUP--> PUT IT OUT NOW
BLD:BOF4 EQU      %
         LCI      2                 MOVE CURRENT
         LM,R0    ACN#CURNT         ACCOUNT# INTO
         STM,R0   TLABUF+1          TAPE LABEL BUFFER
         BAL,R15  BOFQUE            OK--WRITE THE :BOF RECORD
         BAL,R11  RELFIT            RELEASE THE FIT WE'RE DONT W/IT
         MTW,0    ALL               DOING ALL FILES
         BEZ      %+2               NOPE
         BAL,R11  NXTFIT            YES--> READ NEXT FIT
         LB,R2    ORG               GET FILE ORGANIZTION
         CI,R2    3                 IS FILE RANDOM
         BE       RANFILE           YES-PROCESS IS UNIQUE
         MTW,0    SYNFLAG           IS FILE SYNON
         BEZ      BLD:BOF5          NOPE
         MTW,0    LABELEDT          YES-BUT ARE WE WRITING FPURGE
         BNEZ     CKTIO             NO-REGULAR STYLE-WRITE :EOF
         LI,R2    BA(SYNBUF)        SET UP
         LI,R1    16                TO WRITE THE SYNON RECO
         LI,R15   CKTIO             SETUP RETURN ADDRESS
         B        MOVEI             Q/WRITE IT
BLD:BOF5 EQU      %
         LW,R8    FDA               CURRENT FILE HAVE AN INDEX CHAIN
         BGZ      MIXEND10          IF IT DOES GO DO IT
         B        CKTIO             FILE ALL DONE IF NO INDEX CHAIN
         PAGE
*
*        NEW INDEX SECTOR TO START ON
*
GETMIX   EQU      %
         STB,R1   R0                STORE BUF INDEX INTO BUF WA CELL
         STW,R0   MIXBUF            POINTER TO SECTOR
         LD,R2    *R0               GET BLINK/FLINK WORDS FROM BLOCK
         STW,R3   NEXDATA           SAVE FWD LINK DISC ADDRESS FOR LATER
         LI,R1    MIDISP            SET
         DO       UTS>=2
         LB,R2    ORG
         CI,R2    1                 CONSECUTIVE
         BG       %+2               NO-KEYED
         LI,R1    SCWDISP           YES-DISP. TO 1ST SCW
         FIN
         STW,R1   CURRMIX             INITIAL
         STW,R1   NEXTMIX               INDEX VALUES
         DO       UTS>=2
         CI,R2    1                 CONSECUTIVE
         BLE      GETMIX1           YEP-SPECIAL HANDLING
         FIN
         LI,R1    4
         LH,R1    *R0,R1            GET NAV
         DO       UTS>=2
         B        GETMIX2           CONTINUE
GETMIX1  EQU      %                 CONSECUTIVE-PROCESS GRAN. CW
         LI,R2    0
         LI,R1    2                 DISP. TO GRANULE CW
         INT,R1   *R0,R1            NAV OR LAST SCW TO R1
         BCR,4    %+2               CC1 SET IF GRAN. FULL
         AI,R2    1                 CONTROL GRANULE FULL
         STW,R2   FULL              0 IF NOT FULL - 1 IF FULL
         CI,R1    X'C000'           ANY FLAGS
         BAZ      %+2               NO
GETMIX2  EQU      %
         AND,R1   =X'3FFF'          YES--> FOR CONSEC MASK FLAGS OUT
         FIN
         STW,R1   MISIZE            SAVE SECTOR SIZE
         CI,R1    2048              COMPARE NAV TO MAX POSSIBLE VALUE
         BGE      BADMIBLK          THAT IS A DEFINITE ERROR
         DO       UTS>=2            NEW CONSECUTIVE FILES ONLY
         LB,R2    ORG
         CI,R2    1                 IS NEW CONSEC
         BLE      GETMIX3           YUP--> NO CHANGE
         FIN
         STW,R1   MISIZEX
         SLS,R0   2                 MIX BUFFER BA
         AWM,R0   NEXTMIX           MAKE POINTERS CORE BYTE ADDRESSES
         AWM,R0   MISIZEX           FOR QUICK USAGE
GETMIX3  EQU      %
         LW,R14   INDEX             WANT TO SEE BUFFER
         BEZ      %+2               NO
         BAL,R14  LISTMIX           YES, SNAP CURRENT ONE
         LW,R1    DUMP
         AW,R1    STATS             GOING TO USE TAPE BUFFERS
         BEZ      BLKD0             NOPE
         BAL,R15  BUILD             MOVE DISC ADDRESS'S OUT OF INDEX BLK
         BAL,R11  GETFOUR           AND READ SOME DATA GRANULES
         PAGE
*
*        BUILD BLOCKING BUFFERS / SEND TO TAPE
*
BLKD     EQU      %
         LW,R1    CURBUF            DO WE HAVE A BUFFER NOW
         BGZ      BLKD0             YUP
         BAL,R15  GETTBUF           GET ONE ASSIGNED NOW
BLKD0    EQU      %
         BAL,R15  QUEMIX            TRY TO GET A FORWARD LINK IN
         BAL,R15  GETKEY            GET A NEW KEY FROM MI BLOCK
         LW,R1    DUMP
         AW,R1    STATS             GOING TO BLOCK DATA
         BEZ      BLKD0             NOPE--> HURRY ALONG THEN
         LW,R1    FAK               IS 1ST APPEARANCE IN DISK FILE
         BEZ      BLKD2             NO--> MOVE DATA ONLY
         BAL,R7   DEPTH             GET # OF BYTES LEFT IN BUFFER
         CW,R3    SCR2              WILL THE NEXT KEY FIT
         BGE      BLKD1             YUP--> GOMOVE IT
         BAL,R15  QUEREC            WRITE OUT CURRENT BUFFER
         BAL,R15  GETTBUF           GET A NEW BUFFER
BLKD1    EQU      %
*
*        BRAND NEW KEY
*
         LI,R1    X'100'
         STW,R1   FLAGS             SET FIRST APPEARANCE ON TAPE ALSO
         BAL,R7   MOVEKEY           MOVE THE KEY NOW
BLKD2    EQU      %
         BAL,R15  MOVE              MOVE THE DATA RECORD TO BLOCKING BUF
         B        NOTDONE           DIDN'T COMPLETELY FIT THIS TIME
BLKD3    EQU      %
         BAL,R7   SCHEDULE
         BEZ      BLKD4             NO BUFFERS YET
         BAL,R11  GETFOUR
BLKD4    EQU      %
         LW,R1    CSET              IS CONTINUED RECORD IN MI CHAIN
         BNEZ     BLKD0             YES-> GET NEXT KEY
         LI,R2    0
         LI,R3    X'200'
         CW,R3    FLAGS             HAS THE RECORD BEEN CONTINUED
         BAZ      %+2               NOPE
         STW,R2   FLAGS             YES--> THIS MAKES IT THE LAST ONE
         LW,1     CONEOF            LAST REC IN CONSEC FILE
         BNEZ     %+2               YES DONT UPDATE KEY
         BAL,R15  KEYUP             MERGE FLAGS INTO BUFFER
         LW,R1    MIXEOF            END OF MI CHAN
         BNEZ     D                 YUP--> ALL DONE
         B        BLKD0             DO IT ALL AGAIN THEN...
         PAGE
*
*        RECORD DID NOT FIT COMPLETELY INTO THE BUFFER, DO FOLLOWING:
*
*        1. MARK RECORD AS SPLIT BETWEEN TAPE BLOCKS.
*        2. SEND THE CURRENT BLOCK OFF TO TAPE NOW.
*        3. GET A NEW BUFFER.
*        4. PROPAGATE THE RECORD KEY INTO THE NEW BUFFER.
*        5. MARK REMINAING RECORD BYTE COUNT TO MOVE INTO NEW BUF.
*        6. GO MOVE THE REST OF THE RECORD TO THE NEW BUFFER.
*
NOTDONE  EQU      %
         LI,R1    X'200'            INDICATE TAPE CONTINUED
         STS,R1   FLAGS
         BAL,R15  KEYUP             MERGE THE KEY INFO INTO BLOCK
         BAL,R15  QUEREC            AND SEND THE BLOCK OFF TO TAPE
         BAL,R15  GETTBUF           GET A NEW TAPE BUFFER
         LW,R1    LASTKEY           GET BA OF KEY IN MI BLOCK
         STW,R1   CURRMIX           STORE IT TO MOVE OVER NOW
         BAL,R7   MOVEKEY           MOVE THE KEY INTO THE NEW BUFFER
         LI,R1    0
         XW,R1    RWS2              GET # OF BYTES LEFT TO MOVE
         STW,R1   RWS               SAVED AS CURRENT BYTE COUNT
         LI,R1    X'200'            NOW ALL THE REST OF THE KEYS
         STW,R1   FLAGS             ARE CONTINUED ONLY....
         B        BLKD2             GO MOVE SOME MORE OF THE RECORD
MINUS4   DATA     -4
         PAGE
*
*        SET UP KEY FLAGS (P1,P2,P3) WORD POSITION
*
KEYUP    EQU      %
         LW,R0    FLAGS             GET THE KEY FLAGS
         LI,R1    0
         XW,R1    SIZE              GET SIZE OF REC ON TAPE
         STH,R0   R1                MERGE EM TOGETHER
         STW,R1   *P1P2P3           ....
         CI,R1    0
         BGZ      %+2
         BAL,R0   RCBERR            ERROR
         B        *R15
         PAGE
*
*        OUTPUT CURRENT TAPE BLOCK
*
D        EQU      %
         LI,R15   CKTIO             SETUP RETURN ADDRESS FOR QUEREC
QUEREC   EQU      %
         BAL,R7   DEPTH             GET # OF BYTES LEFT IN BUFFER
         AI,R5    3                 ROUND UP
         AND,R5   MINUS4            MASK OFF END BITS
         LI,R6    -1                SET
         LI,R7    QBUF              SET POINTER
         LI,R1    TBUF
         LW,R2    CURINDX           GET BUFFER #
         AW,R1    R2                R1 = DIRECT POINTER TO IT
         STB,R2   R1                CREATE END ACTION INFO WORD
         LW,R9    TBUF,R2
         OR,R9    Y8
         STW,R9   TBUF,R2           SET BUFFER IN TRANSIT
         B        MTIO              MERGE W/TAPE I/O ROUTINE
         PAGE
*
*        MOVE KEY TO BLOCKING BUFFER
*
*        INPUTS:
*        ------   -----------------
*        CURBUFBA NEXT CORE BA TO MOVE TO
*        CURRMIX  BA OF KEY TO MOVE TO BLOCKING BUFFER
*
*        OUTPUTS:
*        -------  ------------------
*        CURBUFBA UPDATED
*        LASTKEY  POINTS TO BA OF WHERE KEY WENT
*        P1P2P3   WORD ADDRESS OF WHERE KEY FLAGS GO IN BLOCKING BUF
*
MOVEKEY  EQU      %
         MTW,1    *CURBWA           BUMP # OF KEYS IN THIS BLOCK
         LW,R5    CURBUFBA          GET CURRENT BA IN BUFFER (CORE BA)
         AI,R5    3                 AND ROUND UP
         AND,R5   MINUS4            TO NEXT WORD (BYTES) BOUNDARY
         LW,R2    CURRMIX           BYTE ADDRS OF KEY IN MI BLOCK
         STW,R5   LASTKEY           SAVE IT FOR NOT DONE STUFF
         LW,R3    SCR               # OF BYTES IN THE KEY TOTAL
         BAL,R15  MOVEBYT           MOVE KEY INTO PLACE
         AI,R5    3                 ROUND UP DEST BA TO NEXT WRD BNDRY
         SLS,R5   -2
         STW,R5   P1P2P3            AND MARK AS PLACE FOR FLAGS TO GO
         AI,R5    1                 BUMP BY ONE WORD
         SLS,R5   2                 SO AS TO MARK
         STW,R5   CURBUFBA          NEW BUFFER BA FOR RECORD MOVE NEXT
         B        0,R7              RETURN TO CALLER
         PAGE
*
*        MOVE DATA RECORD TO BLOCKING BUFFER
*        INPUTS:
*
*        WORD     CONTENTS
*        -------- --------------------
*        TBSIZ    NUMBER OF BYTES IN A BLOCKING BUFFER (DYNAMIC)
*        CURBUFBA BYTE ADDRESS IN CURRENT BLOCKING BUFFER
*        CURDBLK  BYTE ADDRESS OF CURRENT DATA GRANULE BUFFER
*        RWS      BYTE COUNT OF CURRENT DATA RECORD
*        BLDISP   DISPLACEMENT INTO DATA GRANULE
*
MOVE     EQU      %
         AI,R15   1                 ASSUME RECORD FITS OKAY
         BAL,R7   DEPTH             GET # OF BYTES LEFT IN BUF
         BGZ      MOVE0             SOME ROOM SEEMS TO BE LEFT
         LI,R3    0                 NO ROOM LEFT AT ALL
         XW,R3    RWS               GET RECORD SIZE
         B        MOVE1             AND FORCE A SPLIT TAPE BLOCK
MOVE0    EQU      %
         CW,R3    RWS               DOES RECORD FIT
         BGE      MOVE2             YUP-> GO
         XW,R3    RWS               NO--> STORE REMAINING / GET TOTAL #
         BEZ      *R15              NO DATA RECORD TO MOVE
         SW,R3    RWS               CALCULATE HOW MUCH LEFT FOR NEXT TIME
MOVE1    EQU      %
         STW,R3   RWS2              AND SAVE IT TO MOVE NEXT PASS
         AI,R15   -1                DECREMENT RETURN TO LOOP AROUND
MOVE2    EQU      %
         LI,R3    0
         XW,R3    RWS               GET RECORD SIZE / LEAVE IT CLEARED
         BEZ      *R15              NOTHING TO DO
         LB,R7    CURDBLK           GET INDEX OF DATA GRANULE ENTRY
         BEZ      %+2               PROBABLY CONSEC FILE THEN..
         AWM,R3   RBHIST,R7         MOVE / UPDATE BYTES USED FROM IT
         LW,R5    CURBUFBA          GET BA OF TAPE BLOCKING BUFFER
         LW,R2    CURDBLK           GET BA OF DATA GRANULE BUFFER
         AW,R2    BLDISP            ADD DISP INTO DATA GRANULE
         AWM,R3   SIZE              UPDATE SIZE OF RECORD ON TAPE
         AWM,R3   BLDISP            UPDATE IN CASE WE SPLIT RECORD ON TAPE
MOVEBYT  EQU      %
         DO       SIGMA7=0
         LB,R6    0,R2              TRANSFER
         STB,R6   0,R5              BYTES
         AI,R5    1
         AI,R2    1
         BDR,R3   %-4                FINISH TRANSFER
         B        MOVE4
         ELSE
         LW,R4    R2                SOURCE BYTE ADDRS
MOVE3    EQU      %
         LI,R14   255               ASSUME BIGGEST MOVE
         CI,R3    255               IS ASSUMPTION TRUE
         BGE      %+2               YUP
         LW,R14   R3                NOPE--> GET LOWER COUNT
         STB,R14  R5                STOE COUNT FOR MBS
         MBS,R4   0                 MOVE STRING INTO PLACE
         SW,R3    R14               CALCULATE AMOUNT LEFT TO MOVE
         BGZ      MOVE3             MORE TO MOVE YET
         FIN
MOVE4    EQU      %
         CLM,R5   CURBUF            WAS MOVE TO CURRENT BLOCKNG BUFFER
         BCS,9    *R15              NOPE--> DONT UPDATE POINTER
         STW,R5   CURBUFBA          REMEMBER NEW LAST INDEX VALUE
         B        *R15              AND RETURN
         PAGE
*
*        CALCULATE DEPTH OF CURRENT BLOCKING BUFFER
*
DEPTH    EQU      %
         LW,R5    CURBUFBA          LAST BA STOPPED AT
         SW,R5    CURBUF            MINUS BASE OF BUFFR BA
         LW,R3    TBSIZ             MAX DEPTH OF A BUFFER
         SW,R3    R5                R3 = # OF BYTES LEFT
         B        0,R7              RETURN TO CALLER
         PAGE
*
*        GET MASTER INDEX KEY SUBROUTINE
*
GETKEY   EQU      %
         PSW,R15  PDSTK             SAVE RETURN LINK
         DO       UTS>=2            NEW CONSEC FILES ONLY
         LB,R6    ORG
         CI,R6    1                 CONSECUTIVE
         BLE      GETKEYN           YEP
         FIN
GETKEY0  EQU      %
         LW,R6    NEXTMIX
         STW,R6   CURRMIX           ADVANCE TO NEXT KEY IN BLOCK
         CW,R6    MISIZEX           COMPARE TO BLOCK DEPTH
         BGE      CHKEND            AT END -> CHECK FOR NEXT BLOCK
         LW,R5    MIKEYL            R5 = TOTAL LENGTH OF MI KEYS
         AWM,R5   NEXTMIX           ADVANCE TO NEXT POINTER
         LB,R5    0,R6              GET BYTE ZERO OF KEY
         BEZ      GETKEY0           DELETED RECORD--> GET NEXT ONE
         AW,R6    SCR               POINT TO BYTE 0 OF DISPLACEMENT
         LI,R5    10                2 + 4 + 2 + 2 WE DONT NEED
         LI,R7    13*4              REGISTER 13 BYTE ADDRESS
         DO       SIGMA7=0
         LB,R8    0,R6              MOVE
         STB,R8   0,R7              TO WORK SLOT
         AD,R6    DOUBLEONE
         BDR,R5   %-3
         ELSE
         STB,R5   R7                SET COUNT
         MBS,R6   0
         FIN
         SLS,R13  -16
         STW,R13  BLDISP            STORE DISPLACEMEN IN DATA GRANULE
         STW,R14  GRANULEADR        STORE DISC ADDRESS
         SLS,R15  -16
         STW,R15  RWS               STORE RECORD SIZE
         AWM,R15  FILESIZE          UPDATE TOTAL FILE SIZE
         LB,R4    0,R6              GET THE EOF/CSET/FAK BYTE
         LI,R5    1                 MASK FOR
         STS,R4   CSET              CONTINUE RECORD FLAG
         LI,R5    2
         STS,R4   MIXEOF            END OF CHAIN
         LI,R5    4
         STS,R4   FAK               FIRST APPEARANCE OF KEY FLAG
GETKEY01 LW,R2    GRANULEADR        GET D/A
         BEZ      CHKRWS             IF ZERO..CHECK RWS FOR ZERO
         LW,R1    DUMP              WRITING TAPE
         AW,R1    STATS             OR PRODUCING DISKPOOL
         BEZ      GETKEY5           NOPE..EXIT NOW
GETKEY1  LW,R1    DAPAGES           DATA COUNT
         LW,R3    M24               DISC ADDRESS MASK
GETKEY2  CS,R2    RB1,R1            IS DISC ADDRS IN TABLE
         BE       GETKEY3           FOUND IT
         BDR,R1   GETKEY2           KEEP TRYING
         B        QERROR             INTERNAL ERROR-D/A NOT IN CORE
GETKEY3  EQU      %
         LW,R4    DBUF,R1           GET GRANULE'S BUFFER WORD ADDRESS
         SLS,R4   2                 CONVERT TO BYTE ADDRS
         STW,R4   CURDBLK            SAVED FOR MOVER...
         STB,R1   CURDBLK           SAVE BUFFER # WHERE IT CAN BE FOUND
         LW,R0    RB1,R1            INCORE AS YET
         BGZ      GETKEY4           YUP-> GO USE IT
         BAL,R15  QUEMIX            <DEAD TIME>
         LB,R1    CURDBLK           RESTORE INDEX
GETKEY4  EQU      %
         AI,R1    RB1               CORE ADDRESS FOR IOSPIN
         BAL,R7   IOSPIN            GO WAIT FOR IT NOW
         BAL,R7   CHKIO             CHECK TYC
GETKEY5  EQU      %
         PLW,R15  PDSTK             RESTORE RETURN LINK
         MTW,0    FAK               IS START OF RECORD FLAG TRUE
         BEZ      *R15              NO
         MTW,1    RECNT             COUNT NUMBER OF RECORDS IN FILE
         B        *R15              RETURN TO CALLER
         PAGE
*
*        CURRENT DISC ADDRESS=0
*
CHKRWS   EQU      %
         MTW,0    RWS                IS RWS 0
         BEZ      GETKEY5           THAST OKAY--> RETURN
         M:SNAP   'RWS ERR'         THATS NOT SUPPOSED TO HAPPEN
         B        MIXSNAP           AND ABORT THIS FILE
BADMIBLK EQU      %
         M:SNAP   'NAV ERR'
         B        MIXSNAP           ABORT THIS FILE FOR SURE
RCBERR   EQU      %
         M:SNAP   'RCBERR'          RECORD CONTROL BLOCK ERROR
         B        MIXSNAP           ABORT THIS FILE
         PAGE
*
*        NAV HAS RUN-OUT ON CURRENT SECTOR,INSURE
*        THIS FILE HAS NOT ERROR IN INDEX CHAIN
*
CHKEND   EQU      %                 END OF A SECTOR
         PLW,R15  PDSTK             BALANCE THE STACK
         LW,R8    MIXEOF            FIND EOF BIT IN THAT LAST BLOCK
         BEZ      MIXEND            NO--> READ ANOTHER FWD LINK
         LB,R1    MIXBUF            BUF #
         BAL,R11  RELMIX            RELEASE THIS BUFFER
CHKENDZ  EQU      %                 MERGE HERE IF NO FWD LINK
         MTW,1    MIXEOF            SEEM TO BE DONE
         MTW,1    CONEOF            SET CONSEC END OF FILE FLAG
         LW,R1    RECNT             ANY RECORDS MOVED
         BEZ      CHKBUF            NULL FILE/ALL DELETED/ONE OF THE ABOVE
         LI,R1    0
         STW,R1   FAK
         STW,R1   CSET              CLEAR KEY FLAGS SO WE DONT STUMBLE
         B        BLKD4             MERGE TO WRITE LAST BLOCK OUT
*
*        IF NULL FILE WAS SENT TO TAPE- RELEASE THE BUFFER
*
CHKBUF   EQU      %
         LW,R2    CURINDX           INDEX OF CURRENT TAPE BUFFER
         BLEZ     CKTIO             NONE OR ERROR
         MTW,-1   TBUFBSY           ONE LESS BUFFER BUSY
         MTW,1    TBUF              PUT COUNT BAK IN SHAPE
         LW,R1    TBUF,R2           GET BUFFER WA
         AND,R1   M17               SCREEN IT (MAKE IT UNBUSY)
         STW,R1   TBUF,R2           STORE IT BAK
         B        CKTIO             AND FINISH OFF ZEE FILE...
         PAGE
         DO       UTS>=2
*
*        GETKEY FOR NEW CONSECUTIVE FILES
*
GETKEYN  EQU      %                 ENTERED FROM GETKEY (R1=0)
         LI,R1    0
         STW,R1   CURDBLK           *ERASE POINTER TO DATA BLOCK
         STW,R1   FAK               CLEAR KEY
         STW,R1   CSET                 VARIABLES
         STW,R1   MIXEOF            STORE ZERO
         BAL,R15  QUEMIX            SEE IF FLINK READY
         LI,R5    0
         LI,R6    1
         LW,R1    NEXTMIX           POINTS TO NEXT SCW
         LI,R7    BA(CONKEY)
         STW,R7   CURRMIX           SETUP POINTER TO KEY BUF
         LW,R2    FULL              1=GRANULE FULL
         CW,R1    MISIZE            POSITION OF NAV OR LAST SCW
         EXU      ENDTEST,R2        BGE OR BG CHKENDN
         INT,R2   *MIXBUF,R1        GET SCW
         BCR,2    CASE1             **NOT A CONTINUED RECORD
         STW,R6   CSET              SETUP BLOCK SPLIT
         BCR,4    CASE10            NOT FAK - JUMP
*                                   SET CFLG WHEN FAK AND CONT SET
         STW,R6   CFLG              SET REC CONTINUED IN PROGRESS FLAG
         B        CASE1A
CASE1    EQU      %
         BCR,4    CASE10            NOT FAK EITHER---> JUMP
CASE1A   EQU      %
         MTW,0    CSET              IS THIS REC GOING TO BE CONTINUED
         BNEZ     %+2               YUP
         STW,R5   CFLG              NO--> CLEAR CONTINUED IN PROGRESS
         STW,R6   FAK               FAK=1
         AWM,R6   CONKEY            UPDATE OLD CONSEC. FILE KEY
CASE10   EQU      %
         INT,R2   *MIXBUF,R1        TEST CCW FOOR UNBLOCKED RECORD
         BCS,8    UNBLKD            IS UNBLOCKED--> JUMP TO DO IT
         STW,R2   RWS               # OF BYTES IN SEGMENT
         SLS,R1   2                 CONVERT TO BYTES
         AI,R1    4                 POINTS TO BLOCKED DATA
         STW,R1   BLDISP            SAVE BYTE DISPLACEMENT
         AW,R1    R2                BLDISP+RWS
         AI,R1    3                 +3
         SLS,R1   -2                CONVERT TO WORD     DISPL.
         STW,R1   NEXTMIX           POINT TO NEXT SCW
         CW,R1    MISIZE            IS NEXT INDEX LAST IN BLOCK
         BGE      CASE1X            YES,DONT INDEX IT
         SLS,R1   1                 CONVERT TO HALFWORD DISPL.
         LH,R3    *MIXBUF,R1        NEXT SCW=0 IF CASE 3
         BNEZ     %+2               NOT BACKSPACE CW (CASE 3)
         MTW,1    NEXTMIX           CASE 3-SKIP CW
CASE1X   LW,R2    MIXBUF            WA OF CONTROL BUFFER
         SLS,R2   2                 CONVERT TO BYTES
         STW,R2   CURDBLK           STORE IT
         LB,R1    MIXBUF            INDEX INTO IBUF TABLES
         LW,R2    INDEXDA,R1        DISC ADDRESS
         AND,R2   M24
         STW,R2   GRANULEADR        OF GRANULE CONTAINING DATA
         LW,R2    FAK
         AW,R2    CFLG              IS THIS A DELETED RECORD
         BEZ      GETKEYN           YUP--> GET NEXT ONE CHUMP..
         LW,R2    RWS               OK--> GET BYTE COUNT OF RECORD
         AWM,R2   FILESIZE          UPDATE FILE TOTAL COUNT
         B        GETKEY5           RETURN VIA GETKEY
ENDTEST  BGE      CHKEND
         BG       CHKEND
         PAGE
*
*        UNBLOCKED CONSECUTIVE FILES HAVE DATA GRANULES ELSEWHERE
*
UNBLKD   EQU      %                 COME HERE IF UNBLOCKED SEGMENT
         STB,R2   R3,R6             DCTX IN R2 (BYTE 3)
         STW,R3   GRANULEADR        DISC ADDRESS OF DATA GRANULE
         SLS,R2   -8                #DATA BYTES-2033 IN R2
         AI,R2    2033              GUESS WHAT
         STW,R2   RWS               YOU GUESSED IT
         AI,R1    1                 POINT TO NEXT SCW
         STW,R1   NEXTMIX           SAVE POINTER
         LI,R1    0                 UNBLOCKED DATA SEGMENTS
         STW,R1   BLDISP            ALWAYS BEGIN AT BYTE 0
         LW,R1    FAK
         AW,R1    CFLG              IS THIS A DELETED RECORD
         BEZ      GETKEYN           YUP--> GET NEXT KEY
         AWM,R2   FILESIZE          UPDATE FILE TOTAL BYTE COUNT
         B        GETKEY01          LET GETKEY FINISH UP
         FIN
         PAGE
*
*        HAVENT READ THE CURRENT DATA GRANULE - BUMP OUT SOME TO GET
*        IN SYNC AGAIN
*
QERROR   EQU      %
         BAL,7    SCHEDULE
         BNEZ     QERROR3           SOME FREE BUFFERS
         BAL,R3   CLEAR             RELEASE ALL SHORT GRANULES
         BNEZ     QERROR3           WE GOT ONE
         MTW,1    DATARAT           THATS A READ-AHEAD RATE ERROR
         LI,R6    0                 INITTIALIZE TRUNC FLAG
         LW,R1    DAPAGES           REINIT LOOP
QERROR1  EQU      %
         LW,R8    RB1,R1            GET THIS D/A
         BEZ      QERROR2           NOTHING THERE
         AND,R8   M24               CLEAR TYC FIELD
         LW,R2    RBHIST,R1         # OF BYTES USED IN DATA GRANULE
         BNEZ     QERROR2           GET RID OF IT IF ANY USED
         LI,R7    X'3FF'
         AND,R7   DSTACK+1          # OF DA'S IN DSTACK
         CW,R8    DSTACK+1,R7       DONT PUT DUPS BACK IN STACK
         BE       QERROR1B
         BDR,R7   %-2
QERROR1A EQU      %
         PSW,R8   DSTACK            STICK DA BACK IN STACK
         BCR,12   QERROR1B          OK - NO OVERFLOW
         LI,R3    X'FFFFE'
         MSP,R3   DSTACK            MAKE ROOM
         MTW,1    DSTACKOVF         COUNT TIMES
         B        QERROR1A          TRY AGAIN
QERROR1B EQU      %
         CI,R6    0
         BNE      QERROR2A          DON'T TRUNC BUT ONCE
         LI,R6    1
         MTW,1    TRUNC1
QERROR2  EQU      %
         BAL,R11  RELDB             RELEASE IT
QERROR2A EQU      %
         BDR,R1   QERROR1           LOOK AT THEM ALL
QERROR3  EQU      %
         MTW,1    CATCHUP           FLAG CATCHING UP MODE
         LW,R8    GRANULEADR        GET DISC ADDRESS WE NEED
         PSW,R8   DSTACK            STICK IT IN STACK
         BAL,R15  DTOGRAN           CHECK IT
         BAL,R0   DATAERR           ERROR
         BAL,R11  GETFOUR           AND READ IT NOW..
         B        GETKEY01          GO ROUND AGIN AND FIX TABLES UP
*
*        RELEASE IN-CORE GRANULES/BUFFERS THAT DO NOT
*        APPEAR AGAIN IN THE FILE DATA STACK
*
CLEAR    EQU      %
         LI,R9    0
         LW,R1    DAPAGES           #OF DATA PAGES
CLEAR0   LI,R7    X'3FF'            GET CURRENT SIZE
         AND,R7   DSTACK+1          OF DATA GRANULE STACK
         LW,R5    M24
         LS,R5    RB1,R1            GET D/A
CLEAR1   CW,R5    DSTACK+1,R7       COMPARE TO STACK CONTENTS
         BE       CLEAR2            DON'T RELEASE NOW
         BDR,R7   CLEAR1
         BAL,R11  RELDB             RELEASE DATA ENTRIES
         AI,R9    1                 INCREMENT RELEASE COUNTER
         MTW,1    TRUNC1            COUNT TRUNCATIONS
CLEAR2   BDR,R1   CLEAR0            DO NEXT ONE
         AI,R9    0                 SET CC=CNT WHEN DONE
         B        0,R3
        PAGE
*
*        RELEASE DATA TABLE ENTRY
*
RELDB    EQU      %
         LI,R0    0
        LW,R12   DBUF,R1           GET ENTRY
        LC       R12               GET STATUS FLAG
         BCR,4    RELDB1            NOT BUSY
         MTW,0    RB1,R1            SPIN IF
         BLZ      %-1               END ACTION PENDING
         MTW,1    DBUF              INCREMENT TOTAL AVAILABLE
         AND,R12  M17
         STW,R12  DBUF,R1               BUFFER
         MTW,-1   DBUFBSY           ONE LESS BUSY BUFFER
RELDB1   EQU      %
        STW,R0   RB1,R1            CLEAR DISC ADDRS
         STW,R0   RBHIST,R1         CLEAR HISTORY ENTRY
         B        *R11              AND EXIT
         PAGE
*
*        RELEASE DATA BUFFERS THAT WE HAVE USED
*        COMPLETELY
*
SCHEDULE EQU      %
         LW,R1    DAPAGES           GET MAX COUNT
         LI,R3    0                 CLEAR COUNTER
SCHEDULE1 LW,R4   RB1,R1            GET ENTRY
         BEZ      SCHEDULE2         NOT IN USE
         LW,R4    RBHIST,R1         GET ENTRY
         CI,R4    X'800'
         BL       SCHEDULE2         NO-KEEP IT IN CORE
         MTW,1    TRUNC2            BUMP NORMAL ISMISS CNT
         AI,R3    1                 INCREMENT RELEASE COUNTER
         BAL,R11  RELDB             RELEASE IT
SCHEDULE2 EQU     %
         BDR,R1   SCHEDULE1         FINISH UP
         CI,R3    0                 SET CC'S IF ANY FREED
         B        0,R7              AND RETURN
         PAGE
*
*        RELEASE INDEX SECTOR BUFFER
*
RELMIX   EQU      %
         INT,R12  INDEXDA,R1
         BCS,8    %-1               I/O STILL IN PROGRESS
         LW,R12   IBUF,R1           GET ENTRY
         LC       R12               GET STATUS
         BCR,4    RELMIX1           NOT BUSY
         MTW,1    IBUF              BUMP AVAIL COUNTER
         AND,R12  M17               CLEAR FLAGS
         STW,R12  IBUF,R1           CLEAR BUSY BIT
         MTW,-1   IBUFBSY           ONE LESS BUSY BUFFER
RELMIX1  EQU      %
         LI,R0    0
         STW,R0   *MIXSTAT,R1       CLEAR STATUS ENTRY
         STW,R0   INDEXDA,R1        AND DISC ADDRESS ENTRY
         B        *R11              AND EXIT
         PAGE
*
*        END OF CURRENT INDEX SECTOR REACHED
*
MIXEND   EQU      %
         LB,R1    MIXBUF            GET CURRENT BUFFER #
         BAL,R11  RELMIX            AND RELEASE IT
MIXEND10 EQU      %
         LW,R6    NEXDATA           NEXT FLINK TO USE
         BEZ      CHKENDZ           NOTHING MORE TO DO - QUIT ZIS FILE
         LW,R7    M24
         LW,R1    INDPAGES          # OF BUFFERS WE OWN
         CS,R6    INDEXDA,R1        SEE IF FLINK ALREADY READ IN
         BE       MIXEND20          YES-> USE IT
         BDR,R1   %-2
         MTW,1    MIXRAT            DEFINITE READ-AHEAD ERROR
         STW,R6   NXTFLNK           FORCE IT TO BE NEXT ONE TOREAD
         BAL,R15  QUEMIX05          GET IT
         B        MIXEND10          FIND IT
MIXEND20 EQU      %
         LW,R2    R1                HOLD TABLE INDEX IN R2
         AI,R1    INDEXDA           MAKE R1 CORE ADDRESS OF IT
         BAL,R7   IOSPIN            WAIT FOR IT IF NECESSARY
         BAL,R7   CHKIO             CHECK IT'S TYC
         LW,R0    IBUF,R2           GET IT'S BUFFER WA
         LW,R8    *R0               GET THE FLINK'S BLINK ADDRESS
         CW,R8    LASTMIX           COMPARE TO BLINK IT IS SUPPOSED TO HAVE
         BNE      READFAIL5         **ZIS IS NOT ZOO GOOT
         STW,R6   LASTMIX           STORE AS NEXT EXPECTED BLINK ADDRS
         LW,R1    R2                PUT TABLE INDEX BACK INTO R1
         B        GETMIX            REJOIN MAIN PATH..
         PAGE
*
*        RANDOM FILE TAPE KEY
*
RANDKEY  EQU      %
         DATA     1                 WORD ZERO IS KEY COUNT
         DATA     X'03000000'       KEY ITSELF (BLOCK # IS INSERTED)
         DATA     X'05000800'       RECORD SIZE (BLOCK SEP FLAG)
*
         PAGE
*
*        READ ANOTHER SECTOR OF THE INDEX CHAIN
*
QUEMIX   EQU      %
         LW,R8    IBUF              GOTS ANY BUFS TO USE
         BEZ      BUILD             NOPE
         LW,R7    MIXBUF
         BEZ      BUILD             NO GO IF NO BUFER ASSIGNED
         LW,R8    MIXEOF            OKAY - > BUT HAVE WE HIT THE END
         BNEZ     BUILD             YUP--> DONT READ ANY FURTHER
QUEMIX05 EQU      %                 **FIRST TIME ENTRY
         STW,R15  BUILDX            STORE RETURN LINK
         LW,R8    NXTFLNK           ALREADY GOT ONE LINED UP..
         BNEZ     QUEMIX40          YUP-> GO
QUEMIX10 EQU      %
         LW,R8    1,R7              SEE BOUT NEXT FWD LINK
         BEZ      BUILD             EXIT IF NONE
         LW,R9    M24               MASK
         LW,R6    INDPAGES          # OF INDEX PAGES WE HAVE
         CS,R8    INDEXDA,R6        IS FLINK IN CORE
         BE       QUEMIX30          GO TO NEXT IF CURRENT IN
         BDR,R6   %-2               FINISH EXAMINATION
QUEMIX20 EQU      %
         STW,R8   NXTFLNK           SAVE THIS ONE AS NEXT EFFORT THEN
         B        QUEMIX40          GET INTO PROCESS
QUEMIX30 EQU      %
         LW,R7    INDEXDA,R6        THIS ONE SEEN END ACTION YET...
         BLZ      BUILD             NO,EXIT NOW,CAN'T USE IT
         LW,R7    IBUF,R6           YEP,GET ITS BUF WA
         B        QUEMIX10          TRY AGAIN
QUEMIX40 EQU      %
         LI,R8    0                 PICK UP
         XW,R8    NXTFLNK           NEXT FORWARD LINK
         BEZ      QUEMIX50          NONE-> SO EXIT
         BAL,R15  GETIBUF           GET A BUFFER THEN
         BEZ      QUEMIX50          NONE-> EXIT NOW
         LW,R7    R1                MOVE BUF INDEX TO R7
         BAL,R15  DTOGRAN           VERIFY FORWARD LINK
         BAL,R0   READFAIL5         THASS A LINK ERROR
         LW,R15   IBUF,R7           GET BUFFER WA
         OR,R15   Y8                SET BUFFER NOW IN TRANSIT
         STW,R15  IBUF,R7           AND RESTORE
         AI,R1    INDEXDA           CREATE END-ACTION-INFO WORD
         STB,R7   R8                SET BUF # INTO DISC ADDRESS
         LI,R7    X'F2'             HIGHER PRIORITY FOR READ-AHEAD
         BAL,R15  DISCIO20          QUEUE IT
         LW,R15   DUMP
         AW,R15   STATS             DO WE CALCULATE # OF GRANULES IN FILE
         BEZ      QUEMIX50          NO-> EXIT NOW
         MTW,1    FGCOUNT           YUP--> COUNT INDEX SECTOR AS ONE
QUEMIX50 EQU      %
         LW,R15   BUILDX            RESTORE RETURN LINK
         B        BUILD             GO TRY TO BUILD STACK UP
         PAGE
*
*        PROCESS THIS RANDOM FILE
*
RANFILE  EQU      %
         LW,R2    RANDOM            TOTAL GRANULES IN FILE
         STW,R2   RSTORE            SET LOOP THRU FILE
         STW,R2   FGCOUNT
         STW,R2   RECNT             IS RECORD COUNT ALSO
         LCI      3
         LM,R5    RANDKEY           GET RANDOM FILE TAPE KEY
         STM,R5   TLABUF            AND PUT IT IN WORK SPACE
         LW,R8    DUMP              WRITING TAPE
         AW,R8    STATS             OR PRODUCING DISKPOOL
         BNEZ     RANFILE1          YES..PROCEED
         STW,R2   RANDOM            SET GRANULE CNT FOR DISPLAY THEN
         SLS,R2   11                CONVERT GRANS TO BYTES
         STW,R2   FILESIZE          SAVE FOR DISPLAY
RANFILE0 B        CKTIO             PROCESS FURTHER
RANFILE1 LW,R8    FDA               FIRST GRANULE ADDRESS ON DEVICE
         BAL,R15  DTOGRAN           VERIFY IT - GET NSPT SETUP
         BAL,R0   MIXSNAP           AN ERROR OCCURED....
         LW,R1    DAPAGES           TOTAL DATA TABLES LENGTH
         BAL,R11  RELDB             RELEASE ALL BUSY ENTRIES
         BDR,R1   %-1
RANFILE4 EQU      %
         LW,R1    DAPAGES
RANFILE4A EQU     %
         LW,R12   DBUF,R1
         LC       R12               WAIT TILL END ACTION ON DBUFS
         BCS,8    RANFILE4A
         LI,R0    0
         STW,R0   RB1,R1            THEN CLEAR DISK ADDR TABLE
         BDR,R1   RANFILE4A
         LW,R5    DBUF              # OF DBUFS TO FILL
RANFILE5 MTW,0    RSTORE            DONE YET
         BLEZ     CKTIO             YES..
         BAL,R15  GETDBUF           GET A BUFFER
         BEZ      RANFILE8          NONE--> WRITE TAPE FOR AWHILE
         AI,R1    RB1               CREATE END-ACTION INFO WORD
         LW,R8    FDA               GET CDA
         BAL,R15  DTOGRAN           VERIFY DISC ADDRESS
         BAL,R0   MIXSNAP           ***ERROR
         BAL,R15  DISCIO2           AND QUEUE THIS READ UP
         LW,R7    FDA               DISK ADDR
         AND,R7   M16
         LH,R2    FDA               DISK ADDR
         AW,R7    NSPT              NSPT
         CW,R7    M16               NEW DISK ADDR SOVERFLOW TO BIT 17
         BLE      RANFILE7          NO - OK
         AND,R7   M16
         AI,R2    X'80'             SET UP EXTENDED DISK ADDR FORMAT
RANFILE7  EQU     %
         SLS,R2   16
         AW,7     2
         STW,R7   FDA
         MTW,-1   RSTORE            DROP GRAN COUNT
         BLEZ     %+2               DONE AT ZERO
         BDR,R5   RANFILE5          AND GET NEXT DISC ADDRS
RANFILE8 EQU      %
         LI,R1    RB1+1             BASE +
         AW,R1    DAPAGES           #BUFFERS GOTTEN
         STW,R1   NEXDATA           SET POINTER TO INITIAL
*
*        WRITE TAPE FOR A WHILE
*
RANFILE9 EQU      %
         MTW,-1   NEXDATA           STEP TO NEXT ENTRY
         LW,R1    NEXDATA           PICK UP THEEESS POINTER
         CI,R1    RB1               AT END YET
         BLE      RANFILE4          YES-RETURN AND READ SOME MORE
         LW,R2    0,R1              NO-IS DATA IN YET
         BEZ      RANFILE9          *GET NEXT TILL BOTTOM
         BAL,R7   IOSPIN            WAIT FOR EVENT
         BAL,R7   CHKIO             CHECK TYC
         AI,R1    -RB1              CALCULATE INDEX IN R1
         LW,R2    DBUF,R1           GET BUFFER WA
         AND,R2   M17               MASK BUF BUSY BIT OUT OF R2
         SLS,R2   2
         STW,R2   CURBUFBA          SAVE BUF BA
         STW,R2   CURBUF            SAVE BUF WA
         STW,R1   CURINDX           STORE INDEX AWAY
         LW,R2    PBS               GET PREV BLOCK BYTE COUNT
         STH,R2   TLABUF            SET INTO TAPE KEY
         LI,R2    BA(TLABUF)        LOAD BA POINTER TO TAPE KEY
         LI,R1    12                LOAD BYTE COUNT OF IT
         LW,R6    *EOTFLAG          GET LAST OP TYC
         CI,R6    EOR
         BNE      %+2               NOT EOR
         BAL,R15  EOTWAIT           EOR..CHANGE REELS
         BAL,R15  MOVEI             BLK/WRITE
         MTW,1    TLABUF+1          BUMP BLOCK COUNTER IN TAPE KEY
         LI,R7    QBUF
         LI,R6    -1
         LI,R5    2048
         AWM,R5   FILESIZE          INCREMENT # BYTES IN FILE
         LI,R1    DBUF
         LW,R2    CURINDX           RESTORE BUF INDEX
         LW,R15   DBUF,R2
         OR,R15   Y8                SET BUFFER BUSY
         STW,R15  DBUF,R2
         AW,R1    R2                R1 = DIRECT PTR
         STB,R2   R1
         BAL,R15  MTIO0             WRITE OUT THE RECORD
         B        RANFILE9          AND GET SOME MORE
         PAGE
*
*        BUFFER MANAGEMENT SUBROUTINES
*
*
*        GET TAPE OUTPUT BUFFER
*
GETTBUF  EQU      %
        LW,R1     DUMP
        AW,R1     STATS             DO WE NEED TO DO THIS
        BEZ       *R15              NOPE--> RETURN
         PSW,R15  PDSTK             SVE RETURN LINK
GETTBUF1 EQU      %
         LI,R3    TBUF              BUFFER TABLE
         LW,R1    TAPAGES           ORIGINAL COUNT GOTTEN
         BAL,R15  GETBUF            GET A BUFFER
         BEZ      GETTBUF1          DO AGAIN
         STW,R13  CURBUFBA          SAVE BYTE ADDRESS OF BUFFER
         STW,R1   CURINDX           REMEMBER INDEX VALUE
         STW,R13  CURBUF            STORE BUFFER BASE BA
         SLS,R13  -2                MAKE IT WA
         STW,R13  CURBWA            AND STORE
         LI,R15   0
         STW,R15  *CURBWA           CLEAR PBS/NKEY FIELDS IN BUFFER
         LW,R15   PBS               GET PREV BLOCK COUNT
         STH,R15  *CURBWA           AND STORE IN THIS BUFFER
         LW,R15   TBSIZ             MAX BYTES IN ONE BUFFER
         AW,R15   CURBUF            ADD BASE BA IN THIS BUFFER
         STW,R15  CURBUF+1          CREATE CLM PAIR FOR CHECKS
         MTW,4    CURBUFBA          START IT OFF BY CNTING NKEY/PBS FIELD
         PLW,R15  PDSTK             RESTORE RETURN LINK
         B        *R15              AND GO THERE
*
*        GET DISC INPUT (DATA) BUFFER
*
GETDBUF  EQU      %
         LI,R3    DBUF              R3 = BUFFER TABLE
         LW,R1    DAPAGES           R1 = ORIGINAL TOTAL
         B        GETBUF            MERGE
*
*        GET DISC INPUT (INDICES) BUFFER
*
GETIBUF  EQU      %
         LI,R3    IBUF
         LW,R1    INDPAGES
*
*        FALL THRU AND GET A BUFFER
*
*
*        BUFFER REQUEST DRIVER
*
GETBUF   EQU      %
         LW,R0    *M24,R3           GET BUFFER BUSY COUNTER
         AW,R0    0,R3              ADD BUFFER LEFT COUNTER
         CW,R0    R1                SHOULD MATCH ORIGINAL TOTAL
         B        %+2               DONT CHECK TIL DEBUGGED*******
         BAL,R0   PGMERR            IF NOT IS PROBLEM
         MTW,0    0,R3              TEST FOR AVAIL BUF
         BEZ      *R15              NONE
GETBUF2  EQU      %
         INT,R13  *R3,R1            LOOK FOR FREE
         BCR,4    GETBUF3           GOTCHA
         BDR,R1   GETBUF2           KEEP GOING
         AI,R1    0
         B        *R15
GETBUF3  EQU      %
         LW,R13   *R3,R1            GRAB EM
         AND,R13  M17
         CLM,R13  BUF:LIMS          TEST FOR LEGAL
         BCR,9    %+2               OK
         BAL,R0   PGMERR            E R R O R
         OR,R13   Y4                BUFFER IN USE FLAG
         STW,R13  *R3,R1            STORE BACK IN TABLE
         MTW,-1   0,R3              DECREMENT BUFFERS LEFT
         MTW,1    *M24,R3           BUMP BUFFERS BUSY
         SLS,R13  2                 RETURN IT AS A BA
         AI,R13   0                 SET CC'S
         B        *R15              AND EXIT TO CALLER
         PAGE
*
*        DATA GRANULE QUEUE AHEAD SUBROUTINE
*
GETFOUR  EQU      %
         PSW,R11  PDSTK             SAVE RETURN LINK
         BAL,R15  BUILD
         LW,R4    DBUF
GETFOUR0 EQU      %
         LW,R8    DBUF              GET # OF BUFFERS OUTSTANDING NOW
         CI,R8    1
         BG       GETFOUR1          NOT YET
         B        GETFOUR1          *************BYPASS TIL FSAVE FIXED
         MTW,0    CATCHUP           YES-> ARE WE IN HURRY MODE
         BEZ      GETFOUR2          NO--> EXIT TO CALLER
GETFOUR1 EQU      %
         PLW,R8   DSTACK            PULL ONE UP
         BCS,2    GETFOUR2          DE STACK SHE IS EMPTY
         CI,R8    0
         BEZ      GETFOUR2          BOTTOM OF STACK IF ZERO
         LW,R1    DAPAGES
         LW,R9    M24
         CS,R8    RB1,R1            ALREADY IN CORE
         BE       GETFOUR1          YES - PULL ANOTHER
         BDR,R1   %-2
         LW,R11   R8                SAVE DISK ADR IN CASE PRIV PK
         BAL,R15  DTOGRAN           VERIFY IT
         BAL,R0   DATAERR           ***BAD DISC ADDRESS
         BAL,R15  GETDBUF           GOOD-> ASK FOR A BUFFER
         BEZ      GETFOUR3          NONE-> RETURN TO CALLER
         LW,R15   DBUF,R1
         OR,R15   Y8
         STW,R15  DBUF,R1           SET BUFFER IN TRANSIT
         AI,R1    RB1               POINT TO CORE ADDRESS OF TABLE ENTRY
         BAL,R15  DISCIO2           QUEUE THIS GRANULE W/NO-WAIT I/O
         LI,0     0
         XW,0     CATCHUP
         B        %+2               ************BYPASS TIL FSAVE FIXED
         BNEZ     %+2
         BDR,R4   GETFOUR0          DO ANOTHER SET
GETFOUR2 EQU      %
         PLW,R11  PDSTK             GET LINK
         B        *R11              ALL DONE THIS PASS
GETFOUR3 EQU      %
         LW,R8    R11               STILL HAVE PRIV PK FORMAT
         PLW,R11  PDSTK             RESTORE RETURN LINK INTO R11
         PSW,R8   DSTACK            STICK GRANULE BACK INTO STACK
         B        *R11
         PAGE
*
*        MOVE DISC ADDRESS'S FROM INDEX SECTOR INTO THE DATA DISC
*        ADDRESS PUSH-DOWN STACK
*
BUILD    EQU      %
         STW,R15  BUILDX
         LW,R7    DUMP
         AW,R7    STATS             ANY REASON TO GET STACK BUILT
         BEZ      *BUILDX           NOPE
BUILD00  EQU      %
         LW,R4    *MIXCNT1          CURRENT #
         BEZ      *BUILDX           NONE OR ERROR
         LW,R2    INDPAGES
         CW,R4    *MIXSTAT,R2       SEE IF IT IS IN NOW
         BE       BUILD10           GOTCHA
         BDR,R2   %-2
         B        *BUILDX           EXIT THEN
BUILD10  EQU      %
         LW,R1    INDEXDA,R2        HAD END ACTION YET
         BLEZ     *BUILDX           NONE OR ERROR--> EXIT NOW
         LW,R1    R2                INDEX TO R1
         AI,R1    INDEXDA           CORE ADDRS FOR CHKIO ROUTINE
         BAL,R7   CHKIO             CHECK COMPLETION TYPE
BUILD20  EQU      %
         OR,R4    Y8
         STW,R4   *MIXSTAT,R2       STORE COMPLETED BIT IN TABLES
         STW,R2   NEWINDX           SAVE INDEX OF IT FOR LATER
         LCI      4
         LM,R10   TEMPPNTR          GET STACK REFRESHER
         STM,R10  TEMPSTK           AND CLEAR STACK TO EMPTY STATE
         LW,R4    IBUF,R2           GET WA OF THIS MI BLOCK
         AND,R4   M17               CLEAR BUF FLAGS
         DO       UTS>=2
         LB,R1    ORG
         CI,R1    1                 CONSECUTIVE
         BLE      BUILD170          YEP
         FIN
         LW,R7    R4                WA OF MI BUFFER
         LW,R1    2,R7              GET NAV WORD
         SLS,R1   -16               RIGHT JUSTIFY NAV
         SLS,R7   2                 CONVERT WA TO BA
         AW,R1    R7                R1 = LAST BYTE IN MI BLOCK
         AI,R7    MIDISP            R7 = START BYTE IN MI BLOCK
BUILD30  EQU      %
         LI,R3    4
         LI,R5    8*4
         LW,R2    R1                MOVE BYTE ADDRESS
         AI,R2    MIKBD+(-3)        ADJUST TO BYTE ZERO OF DISC ADDRESS
         BAL,R15  MOVEBYT           MOVE IT INTO R8
         SW,R1    MIKEYL            BACK UP ONE KEY
         LB,R0    0,R1              TEST CURRENT KEY FOR DELETED
         BEZ      BUILD40           YUP--> SKIP IT
         CW,R8    LASTGRAN          THIS D/A SAME AS LAST ONE
         BE       BUILD40           YUP->
         CI,R8    0                 IS THIS ADDRESS A ZERO
         BEZ      BUILD40           YUP--> SKIP IT
         PSW,R8   TEMPSTK           SAVE IT
         STW,R8   LASTGRAN          MAKE IT CURRENT LAST ONE ALSO
BUILD40  EQU      %
         CW,R1    R7                ARE WE DONE YET
         BG       BUILD30           NOT YET-> FINISH UP
         DO       UTS>=2
BUILD50  EQU      %                 BUILDN RETURNS HERE
         FIN
         LI,R7    X'1FF'
         LS,R7    TEMPSTK+1         GET COUNT PLACED INTO STACK
         BEZ      BUILD160          **NONE MOVED - EXIT
         STW,R7   COUNT2
         STW,R7   COUNT1            REMEMBER THE COUNTS FOR LATER
BUILD60  EQU      %
         B        BUILD110          ***********DONT TAKE OUT DUPS-FOR NOW
         LI,R3    0                 CLEAR COUNTER
         LI,R4    0                 FOR CLEARING AN ENTRY OUT
BUILD70  EQU      %
         LW,R6    R7                MOVE CURRENT INDEX TO R6
         AI,R6    -1                AND POINT TO NEXT LOWER ENTRY
         BLEZ     BUILD110          ALL DONE
         LW,R8    TEMPSTK+1,R7      GET A DISC ADDRESS
         BEZ      BUILD100          ALREADY TOOK IT OUT
BUILD80  EQU      %
         CW,R8    TEMPSTK+1,R6      COMPARE TO NEXT SLOT
         BNE      BUILD90           IS OK
         STW,R4   TEMPSTK+1,R6      REMOVE DUPES
        AI,R3     1                 COUNT UP REMOVALS
BUILD90  EQU      %
         BDR,R6   BUILD80           SCAN ON DOWN THE STACK
        AI,R3     0                 ANYTHING REMOVED THAT TIME
        BEZ       %+2               NOPE
        MTW,-1    COUNT1            YEP--> STEP DOWN THE COUNT BY ONE
BUILD100 EQU      %
         BDR,R7   BUILD60           SCAN THE ENTIRE TEMP STACK
BUILD110 EQU      %
         LI,R7    X'3FF'
         LS,R7    DSTACK+1          GET COUNT IN STACK RIGHT NOW
         LW,R5    R7                REMEMBER ORIGINAL SIZE OF STACK
         LW,R3    COUNT1            GET NUMBER LEFT AFTER DUPE REMOVAL
         BLEZ     BUILD160          SEEM TO HAVE MADE A MISTAKE
         AWM,R3   FGCOUNT           ADD TO TOTAL GRANULES IN FILE
         LW,R2    COUNT2            RESTORE THE ORIGINAL COUNTER ALOS
         AW,R7    R3                ADD COUNT TO GO INTO BIG STACK
         CI,R7    STACKSIZE-4       ROOM ENUFF...
         BGE      *BUILDX           NOPE--> SKIP READ AHEAD
         MSP,R3   DSTACK            OPEN UP THE BIG STACK
         CI,R5    0                 ANYTHING IN BIG STACK TO START WITH
         BNEZ     BUILD120          START MOVING EM
         LW,R7    R3                NOPE-> USE COUNT FROM TEMP STACK
         B        BUILD140          SINCE IT WAS ORIGINALLY EMPTY...
BUILD120 EQU      %
         LW,R0    DSTACK+1,R5       MOVE ENTRIES FROM OLD AREA
         BLEZ     BUILD130          **WHOA - THASS GARBAGE
         STW,R0   DSTACK+1,R7       UP TO NEW AREA
         AI,R7    -1
BUILD130 EQU      %
         BDR,R5   BUILD120          LOOP ON ORIGINAL # IN STACK
BUILD140 EQU      %
         LW,R0    TEMPSTK+1,R2      NOW GET STUFF FROM INTERMEDIATE STK
         BEZ      BUILD150          DELETED ENTRY
         STW,R0   DSTACK+1,R7       PLACE INTO BOTTOM OF BIG STACK
         AI,R7    -1
         BLEZ     BUILD160          WE'RE DONE - HOP TO THERE
BUILD150 EQU      %
         BDR,R2   BUILD140          MOVE EM ON UP THERE
BUILD160 EQU      %
         MTW,1    *MIXCNT1          BUMP TO NEXT NUMBER
         B        BUILD00           TRY FOR NEXT ONE
         PAGE
*
*        FOR DEBUG PURPOSES - COME HERE IF WE SCREWED UP
*
PGMERR   EQU      %
         M:SNAP   'PGMERR'
         CAL1,9   3                 AND BAIL OUT
         PAGE
         DO       UTS>=2
*
*        UPDATE DISC ADDRESS STACK WITH NEW
*        UNBLOCKED DATA SEGMENT DISC ADDRESSES
*
BUILD170 EQU      %                 R4=WA(IBUF)
         LI,R2    2                 DISP. TO GRANULE CW
         INT,R6   *R4,R2            GET CONTROL INFO.
         STCF     R0                STORE CONDITION CODES
         AW,R7    R4                R7 = TOP ADDRESS IN FILE
         LC       R0                RESTORE CC'S
         BCR,8    BUILD160          NOTHING IN THIS ONE - TRY NEXT ONE
         BCR,4    %+2               CC2 SET IF GRANULE FULL
         AI,R6    1                 R6=1 IF FULL, =0 IF NOT FULL
         AI,R4    SCWDISP           DISP. TO 1ST SCW IN GRAN.
BUILD180 INT,R2   *R4               GET SCW
         BCS,8    BUILD220          CC1 SET IF BLOCKED (CASE 2)
BUILD190 EQU      %
         AI,R4    1                 POINT TO DATA SEGMENT
         AI,R2    3                 ROUND UP NO. OF BYTES
         SLS,R2   -2                CONVERT TO WORDS
         AW,R4    R2                POINT TO NEXT SCW
BUILD200 CW,R4    R7                R7=NAV
         EXU      BBR31,R6          BGE OR BG BUILD31
         LH,R2    *R4               SEE IF CASE 3
         BNEZ     BUILD180          NOT CASE 3, CONTINUE
BUILD210 AI,R4    1                 CASE 3-SKIP OVER/CASE 2-GET NEXT SCW
         B        BUILD200          AND CONTINUE
*
*        UNBLOCKED SEGMENT
*
BUILD220 EQU      %
         LI,R1    1
         STB,R2   R3,R1             DCTX IN R2(BYTE 3)
         CW,R3    LASTGRAN          DISC ADDRESS SAME AS LAST ONE
         BE       BUILD210          YEP-DON'T SAVE
         STW,R3   LASTGRAN          NEW ONE
         PSW,R3   TEMPSTK           PLACE INTO SAVE STACK
         B        BUILD210          AND KEEP GOING
BBR31    BGE      BUILD50           RETURN VIA BUILD
         BG       BUILD50           RETURN VIA BUILD
         FIN
         PAGE
*
*        CHECK TYC IN CELL POINTED TO BY R1
*
CHKIO    EQU      %
         LW,R14   0,R1              GET DISC ADDRS CELL
         LB,R15   R14               GET TYC FROM IT
         CI,R15   NORMAL            SET CC'S TO TYC
         BE       0,R7              AND EXIT
*
*        BAD I/O, TYC IN R15,DISC ADDRS IN R14
*
ABNIO    EQU      %
         M:SNAP   'BAD I/O'
         B        MIXSNAP           ABORT CURRENT FILE
         PAGE
*
*        RAD/DISC I/O DRIVER
*
*        CALLING SEQUENCE:
*
*        R0       CONTAINS END ACTION (VIRTUAL) ADDRESS
*        R1       CONTAINS END ACTION INFO DESIRED
*        R8       GENERALIZED DISC ADDRESS
*        R13      BYTE ADDRESS OF BUFFER FOR THIS I/O
*        R15      RETURN LINK
*
*        NOTE THAT REGISTERS R1 THRU R8 ARE THE ONLY REGISTERS
*        PRESERVED
*
DISCIO2  EQU      %
         LI,R7    IOPRI+1           READ-AHEAD PRIORITY SETUP
DISCIO20 EQU      %                 COME HERE W/YOUR OWN PRIORITY
         MTW,-1   NOWAIT            SET NOWAIT TRANSFER
         B        DISCIO1A          GET INTO PROCESS
*
*        WAIT FOR COMPLETION ENTRY POINT
*
DISCIO   EQU      %
         LI,R1    RBUSY             END ACTION INFO WORD
         LI,R7    IOPRI-2           I/O PRIORITY
DISCIO1A EQU      %
         LCI      8
         PSM,R1   PDSTK             SAVE R1 THRU R8
         LW,R14   R8                DISK ADDR
         MTW,0    PRIVATE           PRIVATE PACK WERE SAVING
         BE       DISCIO1B          NO PROBLEM WITH END ACTION INFO
         LDCTX,R2 R14               GET DCTX
         LW,R3    CVNO              CURRENT VOL#
         CW,R2    PPDCTX,R3         DCTX CORRESPOND TO CURRENT VOL
         BE       %+3
         STW,R15  DISCIOX           NO - ERROR
         B        DISCIO5
         STDCTX,R3 R14              USE VOL# FOR EAN ACTION IF PRIV PK
DISCIO1B EQU      %
         OR,R14   Y8                SET BUSY BIT
         STW,R14  0,R1              MOVE TO END-ACTION POINTER
         LI,R14   2048              **ALL I/O IS ONE GRANULE'S WORTH
         LI,R2    DOPCNT-EASECT     BUMP TOTAL READ AHEAD CNT
         MTW,1    *EAADDR,R2
         STW,R15  DISCIOX           REMEMBER RETURN LINK
         LI,R0    FITENAC           SAME END ACTION FOR ALL I/O
         LI,R12   X'3000'
         AND,R7   MFF               ONE BYTE OF PRI
         STH,R7   R12               R12 READY TO GO TO NEWQ NOW
         AND,R8   M24               STRIP BUSY BIT
         LW,R15   R8                GET DISC ADDRESS
         LH,R6    R8                GET DCTX
         DO1      CPV>0
         AND,R6   DCTMASK           MASK OUT EXTENDED SECTOR
         OR,R12   R6                AND INSERT IT INTO NEWQ'S REGISTERS
         CI,R13   BA(ACBUF)         GOING FOR AD DIRECTORY
         BE       DISCIO4           DONT COUNT THOSE
         LI,R2    RADGRAN           ASSUME RAD GRANULE
         CI,R6    BATAPE            IS TRUE
         BL       DISCIO3           YUP--> COUNT UP A RAD GRANULE
         LI,R2    PACKGRAN          NO---> COUNT UP A DSK GRANULE
DISCIO3  EQU      %
         MTW,1    0,R2              BOOST COUNTER UP ONE
DISCIO4  EQU      %
         DO       UTS>0
         BAL,R2   BUMPMF            INCREMENT MY MASTER FUNCTION
         BAL,R11  EAINIT            INIT PHYSICAL ADDRESSES
         BAL,R11  NEWQNWM           CALL NEWQ NO-WAIT MAPPED
         ELSE
         MTB,1    M:EO+FCN          BUMP I/O COUNT IN DCB
         BAL,R11  *NEWQ              QUEUE RAD I/O REQUEST
         FIN
         B        DISCIO5           ***DEVICE DOWN RETURN FROM NEWQ
         DO1      CPV>0
         BAL,R15  SLAVE             RETURN TO SLAVE MODE NOW
         LI,R0    0
         XW,R0    NOWAIT            GET WAIT FLAG / CLEAR IT
         BNEZ     DISCIO5           OK - EXIT IF NOWAIT SET
         LI,R1    RBUSY             OK - R1 IS THE WAIT CELL LOC
         BAL,R7   IOSPIN            R1 POINTS TO WAIT CELL
         LB,R1    *R1               GET COMPLETION CODE
         CI,R1    NORMAL            IS OK
         BNE      %+2               NOT NORMAL COMPLETION
         MTW,1    DISCIOX           BUMP RETURN IF NORMAL
DISCIO5  EQU      %
         LCI      8
         PLM,R1   PDSTK             RETRIEVE R1 THRU R8
         B        *DISCIOX          RETURN TO CALLER
         PAGE
*
*        CALL REGISTERS FOR DISC I/O
*
QBUF     EQU      %
         DATA,1   READISC,IOPRI,RETRY,0   (R12)
        DATA      0                 R13: WILL CONTAIN BA OF BUFFER
        DATA      0                 R14: WILL CONTAIN RECORD BYTE COUNT
        DATA      0                 R15: WILL CONTAIN DISC ADDRESS
        DATA      FITENAC           R0: END ACTION ADDRESS
         PAGE
*
*F*      NAME:    MTIO
*F*      PURPOSE: TAPE HANDLER
*F*      DESCRIPTION: THIS ROUTINE QUEUES UP TAP I/O FOR FSAVE.
*F*               IT DOES SO BY BRANCHING TO THE MONITOR ROUTINE
*F*               NEWQNWM.
*
*    MAG TAPE DRIVER
*
*        CALLING SEQUENCE:
*
*        R1:      END ACTION INFORMATION DESIRED
*        R6=0     NORMAL CALL-COMMAND LIST HAS END ACTION ADDRS
*        R6<0     R5 CONTAINS BYTE COUNT,CURBUF IS BUF WA
*        R6>0     NO DATA XFER-R6=FCN CODE
*        R7=      POINTER TO CALL REGS
*
*
         USECT    PROCED            GENERATE PROCEDURE AGAIN
MTIO    EQU       %                ENTRY POINT......
         MTW,0    *EOTFLAG          WAITNG ON A TAPE ERROR/EOR
         BNEZ     EOTWAIT           YUP--> CHANGE TO NEW REEL NOW
MTIO0    EQU      %
         LCI      8
         PSM,R1   PDSTK             SAVE R1 THRU R8
         STW,R15  DISCIOX           SAVE RETURN LINK
         MTW,1    TPACC            INCREMENT TAPE ACCESS'S COUNT
        LCI       4                BRING UP
        LM,R12    0,R7             COMMAND LIST
        CI,R6     0                SPECIAL CALL
        BLZ       DATA             R6<0 INDICATES DATA PASSED
         LI,R0    SENTENAC
         CI,R6    0                 FCN PASSED
         BEZ      GONEWQ            NOPE..SET WRITE
         LI,R1    0                 FLAG NO TAPE TABLE USED...
         STB,R6   R12               YES..SET IT
         B        GONEWQ1
*
*        DATA WRITE REQUEST
*
DATA     EQU      %
         LI,R13   0
         STW,R13  CURBUF+1          MAKE CLM'S FAIL OVER AT 'MOVEBYT'
         STW,R13  CURBUFBA          CLEAR BUF LAST BA
         XW,R13   CURBUF            AND GET BUF BASE BA
         AND,R13  M24               DROP BUF # IN BYTE ZERO
         LW,R14   R5                MOVE BYTE COUNT TO NEWQ REGISTER
         LI,R0    WTENAC            LOAD END ACTION ADDRESS LOC
*
*        MERGE POINT FOR WRITING - BUFFERS / SENTINELS
*
GONEWQ   EQU      %
         STW,R14  PBS               STORE PREVIOUS BLOCK COUNT
         STW,R13  LSTBUF            REMEBER BA OF LAST BUFFER WRITTEN
         LI,R9    WRT               LOAD WRITE FUNCTION CODE
         STB,R9   R12               FOR NEWQ
GONEWQ1  EQU      %
         MTW,0    DUMP              REALLY WANT TO WRITE TAPE
         BEZ      MTIOX             NO..JUST PRODUCING DISKPOOL
         DO       TAURUS=1
         EQU      %
         LI,R2    OPCNT-EASECT      BUMP TAPE I/O COUNT
         MTW,1    *EAADDR,R2
         ELSE
         MTW,1    OPCNT             BUMP TAPE I/O COUNT
         FIN
         OR,R12   MTDCTX            SET TAPE DCT INTO R12
         DO       UTS>0
         BAL,R2   BUMPMF
         BAL,R11  EAINIT            SET UP PHYSICAL ADDRESSES
         BAL,R11  NEWQNWM           CALL NEWQ NO-WAIT MAPPED
         ELSE
         MTB,1    M:EO+FCN          BUMP I/O COUNT IN DCB
         BAL,R11  *NEWQ             QUEUE THE REQUEST
         FIN
         NOP      0                 IGNORE ERROR RETURNS
         DO1      CPV>0             IF CP-V
         BAL,R15  SLAVE             RETURN TO SLAVE
MTIOXIT  EQU      %
         LCI      8
         PLM,R1   PDSTK             RESTORE R1 THRU R8
         MTW,0    BLOCKS            DUMP EACH BUFFER
         BEZ      *DISCIOX          NO--> RETURN
         LW,R15   DISCIOX           YES-> GET LINK TO CALLER
         B        LISTOUTBUF        AND GO DUMP THE BUFFER
         PAGE
*
*        IN STATS MODE WE SIMULATE WRITING TAPE BUFFERS
*
MTIOX    EQU      %
         CI,R1    0
         BE       MTIOXIT           AND EXIT
         LB,R2    R1                GET INDEX
         AND,R1   M17               STRIP ALL BUT POINTER
         LW,R0    0,R1
         AND,R0   M17
         STW,R0   0,R1              MAKE BUF NOT BUSY
         SW,R1    R2                POINT TO BUF HEAD
         BGZ      %+2
         BAL,R0   PGMERR            *** E R R O R ***
         MTW,1    0,R1              BUMP BUF TABLE HEAD BY ONE
         MTW,-1   *M24,R1           DECREMENT BUSY COUNTER
         B        MTIOXIT           AND EXIT TO CALLER
         PAGE
*
*        FSAVE RUNS IN MASTER MODE ONLY WHILE QUEUEING
*        DATA,ETC, THEN RETURNS TO SLAVE MODE WHILE
*        PROCESSING.
*
SLAVE    EQU      %
         LPSD,0   SLPSD             ELSE,GO BACK TO SLAVE MODE
SLV:EXIT B        *R15              AND RETURN TO CALLER
         DO       UTS>0
         PAGE
*
*        CHECK MASTER FUNCTION FOR MAXIMUM
*        IF MAXIMUM,  SPIN
*        OTHERWISE,  BUMP MASTER FUNCTION
*
BUMPMF   EQU      %
         LW,R5    CUN               OUR USER NUMBER
BUMPMF0  EQU      %
         LW,R3    IOCOUNT           NUMBER OF I/O'S OUTSTANDING
         BEZ      BUMPMF1           GO GET EM TIGER
         CW,R3    MAXMF             AT MAX
         BG       BUMPMF0           YES--> HOLD HERE
         CAL3,0   0                 GO MASTER AND DISABLE...
         LW,R3    S:HIR             ARE ANY HIGH PRIORITY DUDES WAITING
         BGZ      BUMPMF2           YES-> PAUSE THEN
BUMPMF1  EQU      %
         CAL3,0   0                 BACK TO MASTER MODE AGAIN
         MTW,1    IOCOUNT           BUMP I/O COUNT INTERNALLY
         MTB,1    UB:MF,R5          AND CP-V'S TABLE
         B        0,R2              AND RETURN
*
*        HOLD UP IF HIGH PRIORITY PEOPLE WAITING TO RUN
*
BUMPMF2  EQU      %
         CI,R3    3                 HOW MANY PEOPLE HOLLERING
         BL       BUMPMF1           TOO FEW YET
         BAL,R15  SLAVE             TOO MANY - GO SLAVE
         B        %+2               ********DONT SLEEP FOR NOW
         CAL1,8   =X'0F000000'
         LW,R15   R8                RESTORE R15 W/DISC ADDRS
         B        BUMPMF1           AND EXIT
         FIN
GETMASTR EQU      %                 SAVE R8-R10 ACCROSS M:SYS CALS
         LCI      3
         PSM,R8   PDSTK
         CAL1,6   SYSFPT            GET MASTER MODE
         LCI      3
         PLM,R8   PDSTK
         B        *R3
         PAGE
*
*        END OF CURRENT OUTPUT REEL REACHED
*
EOTWAIT EQU       %                 ENTRY-PUT AWAY THE I/O REQUEST
         MTW,0    TAP:ERR           ARE WE PROCESSING ONE NOW
         BNEZ     MTIO0             YES-> GO ON
         LCI      0                 REGISTERS FOR THE I/O CALL
         PSM,R0   PDSTK             INPROGRESS
         LW,R1    *EOTFLAG          GET TYPE OF ERROR/EOR TYC
         CI,R1    BOT               AT BEGINNING OF TAPE
         BE       EOTWAITO3         YUP-> GO DO I/O
         CI,R1    EOR               ARE WE AT END OF REEL
         BE       EOTWAIT00         YES - SWITCH VOLUMES
         CI,R1    X'13'             ERROR AFTER END OF REEL
         BNE      IWTERR            NO - MUST BE WRITE ERROR
         MTW,0    EORERR            HAD ANY X'13'S BEFORE
         BNEZ     EOTWAIT04         YES - IGNORE
         MTW,1    EORERR            SET FLAG
EOTWAIT00 EQU     %
         DO       FILL=1
         ELSE
         LD,R0    ACN#CURNT
         LCI      2
         STM,R0   ACNBUF+1
         FIN
         MTW,1    TAP:ERR           SET TAPE ERROR PROCESS GATE
         BAL,R1   GOEOR             SEND EOR/EOV SENTINELS TO TAPE
         LI,R3    3
         LB,R1    REELSN,R3         GET X OF PRGX
         DO       FILL=1
         LB,R2    XTABLE            # OF VALUES FOR X
         CB,R1    XTABLE,R2         EQUAL TO LAST ONE
         BNE      EOTWAIT01         NO, FIND OUT WHICH ONE
         LI,R2    2                 BYTE DISP. TO LETTER
         MTB,1    REELSN,R2         BUMP TO NEXT HIGHER
         LI,R2    1                 RECYCLE X
         B        EOTWAIT02
         CB,R1    XTABLE,R2         FIND MATCH FOR X
         BE       %+2               FOUND IT
EOTWAIT01 BDR,R2  %-2               KEEP ON LOOKIN'
         AI,R2    1                 INDEX TO NEXT X
EOTWAIT02 LB,R1   XTABLE,R2         PICK UP NEXT VALUE FOR X
         STB,R1   BRECREC+1,R3      UPDATE :BREC
         ELSE
         AI,R1    1                 INCR
         CI,R1    '9'               TEST FOR CYCLE
         BLE      %+2               NOPE..DON'T RECYCLE
         AI,R1    -9                YES..RECYCLE
         FIN
         STB,R1   REELSN,R3         RESET CURRENT SERIAL#
         LW,R1    REELSN            RESTORE R1
EOTWAIT0 EQU      %
         DO       UTS=0
         STW,R1   PRTMESS+2         STORE INTO HEADER MSG
         FIN
         STW,R1   REELSN            PLACE BACK INTO FPT
         STW,R1   VOL#CURNT         STORE IT SO IT SHOWS ON PRINTOU
         MTW,1    VOL#              INCREASE VOLUMN #
         LW,R0    LIST              LIST SET
         BEZ      %+2               NO LISTING BEING DONE
         BAL,R7   ACNPAGE           PUT OUT A NEW PAGE
         BAL,R10  NEWREEL           AND ASK FOR A NEW REEL OF TAPE
EOTWAITO3 EQU     %
         LI,R6    0                 AND THEN RESET
         STW,R6   *EOTFLAG          CLEAR ERROR FLAG
         LI,R1    SPECEOT-EASECT
         STW,R6   TAP:ERR
         STW,R6   *EAADDR,R1
         STW,R6   EORERR
EOTWAIT04 EQU     %
         LCI      0                 RESTORE THE I/O
         PLM,R0   PDSTK             REQUEST REGISTERS WE INTERCEPTED
         CI,R6    0                 LLAST ORDER=DATA XFER
         BLZ      MTIO0             YES..WRITE IT NOW
         B        *R15              NOPE..IGNORE REQUEST
         PAGE
*
*        TAPE WRITE ERROR - RESTART THIS FILE
*
IWTERR   EQU       %
         MTW,1    TAP:ERR           SET ERROR PROCESSING FLAG
         LI,R1    BA(TPWRTERR)      TELL OPERATOR
         BAL,R15  TYPEIO            ABOUT THE WRITE
         LI,R15   TPWRTERR
         CAL1,2   PRNT15            PRINT MSG ABOUT ERROR ON TAPE
         LI,R6    0
         LI,R1    SPECEOT-EASECT    RELATIVE OFFSET
         STW,R6   *EOTFLAG
         STW,R6   *EAADDR,R1        CLEAR ALL EOT FLAGS
         LW,R6    CURINDX           IS THERE A TAPE BUFFER BUSY
         BLEZ     IWTERR1           NOPE
         LW,R0    TBUF,R6           GET
         AND,R0   M17               AND CLEAR
         STW,R0   TBUF,R6           BUSY BUFFER
         MTW,1    TBUF              BUMP AVAIL COUNT
         MTW,-1   TBUFBSY           ONE LESS BUSY
IWTERR1  EQU      %
         LI,R6    0
         STW,R6   TAP:ERR
         LCI      0
         PLM,R0   PDSTK
         LI,R15   FITCHKS
         B        EOFQ              WRITE A TM ON THE WAY
         PAGE
*
*        OUTPUT REEL REQUEST SUBROUTINE
*
NEWREEL  EQU      %
         PSW,R10  PDSTK             PUT AWAY LINK
         LW,R1    REELSN            MOVE SERIAL#
         STW,R1   LBLBUF+1          INTO SENTINEL BUFFER
         STW,R1   VOL#CURNT         OPER. INFO.
         CAL1,1   OPNTAPE           ASK FOR A NEW ONE
         LI,R3    X'FF'             MASK FOR DCTX
         AND,R3   M:EO+1            PICK IT UP FROM DCB
         CLM,R3   DCTLIM            COMPARE TO RANGE POSSIBLE
         BCS,9    DCTXERR           BAD NEWS
         STW,R3   MTDCTX            YES-SAVE IT FOR TAPE I/O
         LI,R6    REWOL             SET REWIND
         LI,R7    QBUF              SET CALL REGS
         BAL,R15  MTIO0             REW DEVICE
         LI,R2    BA(LBLBUF)        SET UP
         LI,R1    12                TO WRITE
         BAL,R15  MOVEI             :LBL RECORD
         LCI      2
         LM,2     BKUPVLP+1         GET CURRENT DATE
         STM,2    ACNBUF+3
         STM,2    ACNBUF+5
         LI,2     X'4040'           BLANK MINUTES
         STH,2    ACNBUF+4          IN CURRENT DATE
         STH,2    ACNBUF+6          IN EXPIR DATE
         MTW,1    ACNBUF+6          ADD 1 YY TO EXPIR DATE
         LI,R2    BA(ACNBUF)        SET UP
         LI,R1    28                TO WRITE
         BAL,R15  MOVEI             THE :ACN RECORD
         BAL,R15  WRTMARK           AND A TAPE MARK
         LW,R1    VOL#              GET VOLUMN#
         CI,R1    1                 ON FIRST REEL
         BE       NEWREEL3          YEP..DON'T WRITE OLD BOF
         LI,R3    6
         MTB,1    *9LOC,R3          INCREMENT REEL # IN :BOF RCRD
         BAL,R15  BOFQUE            WRITE OLD :BOF ON NEW TAPE
NEWREEL3 EQU      %
         PLW,R10  PDSTK             GET RETURN LINK
         B        *SR3              RETURN TO CALLER
         PAGE
*
*        SUBROUTINE TO WRITE DATE RECORD
*
WRTDAT   EQU      %
         MTW,0    LABELEDT          ARE WRITING FPURGE STYLE
         BNEZ     0,R7              NO--RETURN NOW
         PSW,R7   PDSTK             SAVE LINK
         LI,R2    BA(DATBOF)        SET UP :BOF
         LI,R1    49                TO WRITE
         BAL,R15  MOVEI             DATE RECORD
         LI,R2    BA(TLABUF)+1
         LI,R1    28                SEND TAPE LABEL
         BAL,R15  MOVEI             BUILD/WRITE RECORD
         BAL,R15  WRTMARK           WRITE TAPE MARK
         LI,R2    BA(DATBUF)        SET BA  OF BUFFER
         LI,R1    36                SET RECORD SIZE
         STW,R1   PBS               SET BLOCK SIZE VALUE
         BAL,R15  MOVEI             BUILD/WRITE RECORD
         BAL,R15  EOFQ              WRITE EOF SEQUENCE
         PLW,R7   PDSTK             GET LINK FROM STACK
         B        0,R7              AND RETURN
         DO       CPV>0             CP-V ONLY
         PAGE
*
*        CAL3 ROUTINE
*
CAL3     EQU      %
         STD,R0   CAL3TMP           SAVE 0/1
         LW,R0    J:XPSD            GET CAL TRAP I/A
         LI,R1    X'1FFFF'
         AI,R0    1                 BUMP BY ONE
         STS,R0   CAL3XIT           SETUP PSD
         BAL,R1   BLOCKER           INSURE WE'RE ON THE MASTER
         LD,R0    CAL3TMP           RESTORE R0/R1
         LPSD,0   CAL3XIT           GO BACK TO CALLER
         USECT    DATASEC
*
         BOUND    8
CAL3XIT  :PSD     (IA,ENDUP),MAP,MASTER,INH
*
CAL3TMP  DATA     0,0
         USECT    PROCED
         FIN                        TERMINATE CP-V CODE
         PAGE
*
*        INITIALIZE TO PROCESS A FILE
*
INITFIL  EQU      %
         PSW,R15  PDSTK             SAVE RETURN LINK
         LH,R2    ORG               GET FILE ORG/KEYM BYTES
         AND,R2   MFF               ISOLATE KEY MAX
         STW,R2   KEYM              SAVE IT
         LB,R4    ORG
         STB,R4   R2                CREATE TAPE LABEL WORD
         STW,R2   TLABUF+3          SAVE IT FOR FILL
         LW,R2    KEYM
         STW,R2   SCR               SAVE KEY LENGTH
         MTW,1    SCR               SCR = TOTAL LENGTH OF KEY (BYTES)
         AI,R2    MIXKEYL           R2 = TOTAL LENGTH OF MI KEYS
         STW,R2   MIKEYL            SAVE IT FOR GETKEY
         DO       UTS>=2            NEW CONSEC FILES ONLY
         LW,R2    ICONKEY
         STW,R2   CONKEY
         FIN
         LCI      4
         LM,R10   DSTKPNTR          GET STACK DBW REFRESHER
         STM,R10  DSTACK            AND REFRESH STACK DBW
         LI,R0    0
         STW,0    CFLG              CONT IN PROG FLAG (CON FILES)
         STW,0    CONEOF            CONSEC END OF FILE FLAG
         STW,R0   LASTGRAN          LAST GRANULE INTO TEMP STACK
         STW,R0   RECNT             CLEAR RECORD COUNTER (FAK COUNTER)
         STW,R0   CURBUF            CURRENT BLOCKING BUFFER
         STW,R0   MIXEOF            ENF OF MI CHAIN FLAG
         STW,R0   FERROR            RESET FILE ERROR FLAG
         STW,R0   FLAGS             TAPE RECORD FLAGS
         STW,R0   CURINDX
         STW,R0   SIZE              TAPE RECORD BYTE COUNT
         STW,R0   PBS               PREVIOUS TAPE BLOCK BYTE COUNT
         STW,R0   MIXBUF            CLEAR MI BUF POINTER
         STW,R0   LASTMIX           SET EXPECTED BLINK TO ZERO
         LW,R0    RANDOM            # OF GRANULES IN FILE
         STW,0    GRANULES          SAVE GRANULE COUNT
         LW,R1    DUMP
         AW,R1    STATS             WILL WE READ DATA GRANS TODAY
         BEZ      %+2               NO
         LI,R0    1                 YES
         STW,R0   FGCOUNT           IT IS INITIALIZED
         LW,R1    DUMP              WILL WE BE WRITING TAPE AT ALL
         BEZ      INITFILEC         NO - FREE TAPE BUFFERS
         LW,R1    TAPAGES           # TAPE BUFFS TO LOOK AT
INITFILEA EQU     %
         LW,R0    TBUF,R1           GET ADDR AND CONTROL INFO
         BL       INITFILEB         BUSY - END ACTION WILL CLEAR
         CW,R0    Y4                ONLY IN TRANSIT
         BAZ      INITFILEB         NO - FREE
         AND,R0   =X'BFFFFFFF'      CLEAR TRANSIT FLAG
         STW,R0   TBUF,R1
         MTW,1    TBUF              # AVAIL
         MTW,-1   TBUFBSY           # BUSY
INITFILEB EQU     %
         BDR,R1   INITFILEA
         B        INITFIL1
INITFILEC EQU     %
         LW,R1    TAPAGES           NO--> MUST INSURE BUFS FREE NOW
         STW,R1   TBUF              RE-INIT TABLE
         LW,R0    TBUF,R1
         AND,R0   M17
         STW,R0   TBUF,R1           FREE EM ALL
         BDR,R1   %-3
         STW,R1   TBUFBSY           NONE BUSY
INITFIL1 EQU      %
         LW,R1    DAPAGES
         BAL,R11  RELDB
         BDR,R1   %-1
         STW,R1   DBUFBSY           ZERO # BUSY DBUFS
         STW,R1   IBUFBSY           ZERO # BUSY IBIFS
         LW,R1    DAPAGES
         STW,R1   DBUF
         LI,R2    1
         STW,R2   *MIXCNT1
         STW,R2   *MIXCNT2          CLEAR RECEIVED COUNTERS
         LW,R1    INDPAGES
         BAL,R11  RELMIX            RELEASE ALL MI BUFFERS
         BDR,R1   %-1
         LW,R1    INDPAGES
         STW,R1   IBUF
         LW,R2    SCR               KEY TOTAL BYTE COUNT
         AI,R2    3                 ROUND UP
         AND,R2   MINUS4            TOTAL WORD COUNT IN BYTES
         AI,R2    8
         STW,R2   SCR2              SAVED FOR COMPARISONS....
         LW,R8    FDA               FIRST INDEX SECTOR
         BEZ      INITFIL2          DOESNT HAVE A CHAIN - SKIP OUT
         STW,R8   NXTFLNK           SAVE IT TO READ NEXT
         STW,R8   NEXDATA           LEAVE IT SET FOR MIXEND10 TO SEE
         LB,R1    ORG               LETS CHECK FILE ORG FIRST
         CI,R1    3                 IS RANDOM FILE
         BE       INITFIL2          YES--> DONT READ FDA LOCATION
         LW,R1    SKIPFDA           ARE WE IN DATE/HOUR SAVE MODE
         BNEZ     INITFIL2          YES--> DONT QUEUE UP FDA HERE
         BAL,R15  QUEMIX05          ELSE READ IT NOW
INITFIL2 EQU      %
         PLW,R15  PDSTK             GET RETURN LINK
         B        *R15              AND GO FINISH OFF THE :BOF RECORD
         PAGE
*
*        ANY ERROR FROM M:EO DCB GETS YOU HERE
*
DCTXERR  EQU      %
OPNABN   EQU      %
OPNERR   EQU      %
         M:SNAP   'OPNFAIL',(M:EO,M:EO+41)
         BAL,R0   PGMERR            ABORT
         PAGE
*
*        END OF REEL SUBROUTINE
*
GOEOR    EQU      %
         PSW,R1   PDSTK             SAVE LINK
         MTW,0    ENDOFSET          IS END OF SET
         BNEZ     GOEOR1            YES-NO :EOV SENTINEL
         BAL,R15  WRTMARK           WRITE TAPE MARK
         LI,R2    BA(EOVBUF)        SET UP
         LI,R1    12                TO WRITE
         BAL,R15  MOVEI             :EOV RECORD
         BAL,R15  WRTMARK           WRITE TAPE MARK
GOEOR1   LI,R7    12                LAST PBS
         STW,R7   EORBUF+1          INTO :EOR BUF
         LI,R2    BA(EORBUF)        SET UP
         LI,R1    12                TO WRITE
         BAL,R15  MOVEI             THE :EOR RECORD
         LI,R5    4
         BAL,R15  WRTMARK           WRITE SOME TAPE MARKS
         BDR,R5   %-1               4 TIMES
         DO       TAURUS=1
         LI,R1    OPCNT-EASECT      NOW SPIN DOWN
         MTW,0    *EAADDR,R1
         ELSE
         MTW,0    OPCNT             NOW SPIN DOWN
         FIN
         BGZ      %-1               ALL THOSE I/O REQUESTS
         DO       UTS>0
         MTW,0    ENDOFSET          IS END OF SET
         BEZ      %+3               NO
         LC       J:JIT             YES - IS IT ON-LINE
         BCS,8    %+2               YES - DON'T CLOSE REEL
         FIN
         CAL1,1   CLSEO             CLOSE THIS REEL OUT
         PLW,R1   PDSTK             RESTORE EXIT
         B        0,R1              AND RETURN
         PAGE
*
*        SEND BOF/TAPE LABEL RECORDS TO TAPE
*
BOFQUE   EQU      %
         PSW,R15  PDSTK
         LI,R2    BA(BOFBUF)        SOURCE BA
         LW,R1    BOFSIZE           SIZE IN BYTES
         BAL,R15  MOVEI             BUILD/WRITE RECORD
         MTW,0    LABELEDT          R WRITING FPURGE TYPE TAPE
         BNEZ     BOFQUE1           NO-DON'T WRITE TAPE LABEL
         LI,R2    BA(TLABUF)+1      OFFSET IT BY ONE BYTE
         DO       FILL=1
         LB,R1    TPLFLG            RECORD SIZE IN BYTES
         ELSE
         LI,R1    28                RECORD SIZE
         FIN
         BAL,R15  MOVEI             BUILD/WRITE RECORD
BOFQUE1  PLW,R15  PDSTK             GET RETURN LINK
         B        WRTMARK           WRITE TAPE MARK/RETURN
         PAGE
*
*        WAIT FOR END ACTION ON DISC ADDRESS POINTED
*        TO BY R1
*
IOSPIN   EQU      %
         MTW,0    0,R1              **AWAKE** IS I/O COMPLETE
         BGZ      0,R7              YUP-> RETURN TO CALLER
         B        IOSPIN
         PAGE
*
*        MOVE SENTINEL'S TO RING BUFFER PAGE
*
MOVEI    EQU      %
         LW,R3    CURPOS            GET CURRENT POSITION
         LW,R4    R1                MOVE # BYTES TO R4
         AI,R4    3                 ROUND UP
         SLS,R4   -2                TO TOTAL WORDS
         AW,R4    CURPOS            ADD CURRENT POSITION
         CW,R4    BUFTOP            COMPARE TO TOP
         BL       %+2               THERES STILL ROOM
         LW,R3    LIMIT             NO-RESET TO LOWER PAGE
         SLS,R3   2                 CHANGE DESTINATION TO BA
         STW,R3   SENTWRT1          PUT BA INTO COM LIST
         STW,R1   SENTWRT2          PUT SIZE INTO COM LIST
         DO       SIGMA7=0
         LB,R5    0,R2
         STB,R5   0,R3
         AD,R2    DOUBLEONE
         BDR,R1   %-3
         ELSE
MOVEIX   AI,R1    -255              MAX COUNT=255 BYTES
         BLEZ     %+4               COUNT<256 FINISH IN ONE MOVE
         OR,R3    YFF               MOVE 255 BYTES
         MBS,R2   0                 MOVE INTO POSITION
         B        MOVEIX            CONTINUE MOVE
         AI,R1    255               COUNT
         STB,R1   R3
         MBS,R2   0                 MOVE INTO POSITION
         FIN
         AI,R3    3                 ROUND UP DESTINATION
         SLS,R3   -2                TO WORD ADDRS
         STW,R3   CURPOS            LEAVE AS CURRENT POSITION
         LI,R1    0                 FLAG NO TAPE TABLE USED...
         LI,R6    0                 SET NORMAL END ACTION
         LI,R7    SENTWRT           SET POINTER
         B        MTIO0             LINK STILL IN R15
         PAGE
*
*        WRITE TAPE MARK SUBROUTINE
*
EOFQ     EQU      %
WRTMARK  EQU      %
         LI,R6    WTM               SET FCN CODE
         LI,R7    QBUF              SET POINTER
         B        MTIO0             LINK WAS R15
         PAGE
*
*        COULD NOT GET ANY MORE THAN 4 PAGES
*
NOTENUFF EQU      %
         LI,R15   LESSTHAN
         CAL1,2   PRNT15
         LI,R1    BA(LESSTHAN)
         BAL,R15  TYPEIO
         LI,R1     FPEXIT
         B         IORUNDWN
         PAGE
*
*        END-UP SUBROUTINE
*
ENDUP    EQU      %
         LW,R0     DUMP
         BEZ       NOEOR
         MTW,1    ENDOFSET          SET END OF VOLUMN SET FLAG
         BAL,R1    GOEOR          GO TO END OF TAPE ROUTINE
NOEOR    EQU      %
         LW,R1    DATACARDS         CHECK DATA CARD COUNT
         BEZ      NOEOR1            NONE LEFT
         LI,R1    7
         LS,R1    M:SI              SEE IF IT WAS FROM A FILE
         CI,R1    1                 WAS IT
         BNE      NOEOR1            NOPE
         CAL1,1   CLS%SAV           CLOSE IT
,,SOVLP1 M:OPEN   M:SI,(FILE,'DATACARDSXX'),(IN),(SEQUEN),;
                       (ERR,NOEOR1),(ABN,NOEOR1)
         CAL1,1   PAGEFPT           NEW PAGE
         BAL,R15  SPACE
         LI,R15   NOTFOUND
         CAL1,2   PRNT15
         BAL,R15  SPACE
         LI,R15   NOTFOUND1
         CAL1,2   PRNT15
         BAL,R15  SPACE
NOEOR0   EQU      %
         CAL1,1   READSI2           READ A RECORD FROM THE FILE
         LI,R4    ' '
         STB,R4   PBUF+3            BLANK THE TEXTC COUNT
         CAL1,1   WRTPBUF           WRITE THE RECORD
         B        NOEOR0            READ TILL END-OF-DATA
NOEOR1   EQU      %
         BAL,R15  DISPRUNTOTL
         LH,R0    M:PO              SEE IF M:PO DCB
         CI,R0    32                IS LEFT OPEN
         BAZ      %+2               NOPE-> JUMP
         CAL1,1   CLSPO             YEP,CLOSE OUT FILE (SAVED)
         BAL,R1    IORUNDWN
         LH,R0    M:SI
         CI,R0    32
         BAZ      NOEOR2
         LI,R1    7
         LS,R1    M:SI              SEE IF IT WAS FROM A FILE
         CI,R1    1
         BNE      NOEOR1A           NOPE
         M:CLOSE  M:SI,(REL)
         B        %+2
NOEOR1A  EQU      %
         CAL1,1   CLS%SAV           CLOSE IT IF IT WAS OPEN
NOEOR2   EQU      %
         CAL1,1   CLSLL             CLOSE M:LL (MAYBE FILE ASSIGNED)
         LW,R3    DUMP              DID WE WRITE TAPE
         BEZ      FPEXIT            NOPE--> EXIT NOW
         DO       FILL=1
         MTW,0    VOLUME            VOLUME SUPPLIED BY USER
         BNEZ     FPEXIT            YES - DONT UPDATE :BREC
         LW,R1    BRECFLG           SKIP UPDATE AND
         BNEZ     FPEXIT            CLOSE IF FLAG SET
         CAL1,1   WRBREC            WRITE OUT RECORD
         CAL1,1   CLOSE             CLOSE M:EI DCB
         FIN
         DO       TAURUS=1
FPEXIT   EQU      %
         LI,R3    0
         XW,R3    EAPHYADR          RELEASE STOLEN PAGE IF THERE
         BE       FPEXIT1           NONE
         CAL1,6   SYSFPT            GO MASTER MODE
         WD,0     X'37'             DISABLE FOR RELEASE
         BAL,11   T:RSPP            RELEASE PAGE FOR ENDACTION
         WD,0     X'27'             ENABLE
         BAL,R15  SLAVE             GO SLAVE
FPEXIT1  EQU      %
         CAL1,9   1                 EXIT
         ELSE
FPEXIT   CAL1,9   1                 RETURN TO BPM
         FIN
         DO       CPV>0
         PAGE
*
*        EXIT CONTROL ROUTINE
*
EXCON    GEN,8,24  X'19',EXCONT
*
EXCONT   EQU      %
         CI,8     X'FF'             CHECK FOR ERROR
         BAZ      EXCONT50          NO ERRORS
         LI,R15   USRABT            USER ABORTED MESSAGE
         CI,8     X'C8'
         BANZ     EXCONT0
         LI,R15   OPRABT            OPERATOR ABORT MESSAGE
         CI,8     X'30'
         BANZ     EXCONT0
         LI,R15   LIMABT            LIMIT ABORT MESSAGE
         CI,R8    4
         BAZ      EXCONT1
EXCONT0  EQU      %
         CAL1,2   PRNT15            PRINT ABORT MESSAGE
         B        ERRADD
EXCONT1  EQU      %
         STW,11   12                SUBCODE TO 12
         SLS,10   8
         AW,12    10                ERROR CODE TO 12
         LI,11    X'0300'
         STH,11   12                COMPLETE KEY IN R12
         LH,11    M:EI
         CI,11    X'20'
         BAZ      EXCONT5           BR IF NOT OPEN
         CAL1,1   CLOSE
EXCONT5  EQU      %
         LI,R3    BRECREC           BUFFER
         STW,12   *R3               SAVE THE KEY
         CAL1,1   OPNERFIL
         CAL1,1   READERFIL
         LW,4     M:EI+4
         SLS,4    -17
         CAL1,1   CLOSE
         M:WRITE  M:LL,(BUF,BRECREC),(SIZE,*4)
         B        ERRADD            SNAP IN BATCH
EXCONT50 EQU      %
         CAL1,6   SYSFPT            BAK TO MASTER MODE
EXCONT50A EQU     %
         LW,1     CUN
         LB,2     UB:MF,1           RUNDOWN ALL I/O
         STB,R2   R2
         SAS,R2   -24               RESTORE THE SIGN
         CI,R2    0                 IS ERROR APPROACHING
         BLEZ     EXCONT52          YUP-> EXIT NOW
         LI,R15   50                TOTAL WAIT = ONE MINUTE
         LW,R0    R2                COPY TO R0
EXCONT51 EQU      %
         LW,R2    R0                WHAT IS STATE OF IT
         BLEZ     EXCONT52          OK
         CAL1,8   =X'0F000001'      SLEEP ONE SECOND
         LB,R0    UB:MF,R1
         BEZ      EXCONT60          OK TO GO ON
         BDR,R15  EXCONT51          TRY FOR ONE MINUTE TOTAL
         M:KEYIN  (MESS,ASKOP),(REPLY,ASKBUF),;
                  (SIZE,8),(ECB,ECB)
         LW,R2    ECB               RESPONSE YET?
         BL       %-1
         LI,R1    1
         LB,R12   ASKBUF,R1
         CI,R12   'Q'
         BNE      EXCONT50A
EXCONT52 EQU      %
         LI,R0    0
         STB,R0   UB:MF,R1          FSAVE PROBABLY GOOFED ITSELF UP
EXCONT60 EQU      %
         MTW,0    MYACCT            WAS RUNNING ACCT SAVED DURING
*                                   PRIVATE PACK OPEN
         BE       EXCONT65          NO
         LCI      2
         LM,R8    MYACCT            RESET RUNNING ACCOUNT IN JIT
         STM,R8   J:ACCN
EXCONT65 EQU      %
         BAL,R15  SLAVE
         B        FPEXIT
ERRADDRD EQU      %
         CAL1,1   CLOSE
ERRADD   EQU      %
         LC       J:JIT
         BCS,8    EXCONT50          NO SNAP IF ON-LINE
         M:SNAP   'ABORTED',(DATASEC,FPATCH)
         B        EXCONT50
USRABT   TEXTC    'ABORTED BY USER'
OPRABT   TEXTC    'FSAVE ABORTED BY OPERATOR'
LIMABT   TEXTC    'LIMIT EXCEEDED - SEE R9 UNDER EXIT CONT'
ASKOP    TEXTC    ' FSAVE I/O COUNT NON ZERO - QUIT OR CONT (Q/C)?'
         FIN
         PAGE
*
*        ACCOUNT DIRECTORY SECTOR COMPLETED
*
ADDONE   EQU      %
         LW,R8    ACFLINK            GET FORWARD LINK ADDRS
         BEZ      ENDUP              IF ZERO--ALL DONE ....
         BAL,R15  DTOGRAN            VERIFY ADDRESS
         B        READFAIL2          ERROR RETURN
         B        GETAD             READ THE NEXT SECTOR THEN
         PAGE
*
*        RELEASE CURRENT FIT BUFFER
*
RELFIT   EQU      %
         LI,R6    0
         XW,R6    FITBUFWA          HAVE WE CLEARED CURRENT BUFFER
         BEZ      *R11              YUP--> RETURN
         LW,R7    M17
         LI,R5    2                 # OF ENTRIES
         CS,R6    FITBUFS,R5        FIND THIS ONE
         BE       RELFIT1           GOTCHA
         BDR,R5   %-2
         B        *R11              YOU MUST HAVE MADE AN ERROR
RELFIT1  EQU      %
         INT,R7   FITBUFS,R5        CHECK FOR BUSY
         BCR,4    *R11              THATS AN ERROR
         AND,R6   M17               CLEAR ANY BITS
         STW,R6   FITBUFS,R5        AND STICK INTO TABLE (FREEING IT)
         MTW,1    FITBUFS           COUNT BUFFERS FREE UP ONE
         LI,R0    0
         STW,R0   FITDAS,R5         ERASE ANY DISC ADDRESS
         STW,R0   FITKEY,R5         ERASE ANY KEY INFO LEFT
         B        *R11              RETURN TO CALLER
         PAGE
*
*        FIT DISC ADDRESS IN R8 - LOCATE IT IN OUR TABLES
*
LOCFIT   EQU      %
         PSW,R11  PDSTK             SAVE RETURN LINK
         MTW,0    FITBUFWA          WAS THE CURRENT BUFFER CLEARED
         BEZ      %+2               YUP
         BAL,R11  RELFIT            NOPE--> IT SHOULD HAVE BEEN THO
         STW,R8   FITGRAN           SAVE PP DISK ADDR FOR SEARCH
         BAL,R15  DTOGRAN           VERIFY THE DISC ADDRESS
         B        FDERR             FIT DISC ADDRESS ERROR
         XW,R8    FITGRAN           GET PPDISK ADDR IF PRIV PACK SAVE
*                                   AND SAVE CONVERTED FOR DISCIO
         LI,R5    2
         LW,R9    M24
         CS,R8    FITDAS,R5         SEE IF WE ALREADY READ IT BY NOW
         BE       LOCFIT1           YUP
         BDR,R5   %-2
         LW,R8    FITGRAN           GET CONVERTED DA IN CASE PRIV PACK
         MTW,1    FITRAT            FIT READ AHEAD ERROR
*
*        HAVE NOT READ THE FIT YET
*
         BAL,R11  GETFITBUF         GET A FIT BUFFER
         BEZ      PGMERR            **THAT CANNOT HAPPEN-BUT IT DID
         STW,R8   FITDAS,R5         STORE THE FIT ADDRESS
         SLS,R13  2                 BUFFER BYTE ADDRESS
         BAL,R15  DISCIO            READ IT
         B        FDERR             ERROR
*
*        R5 HAS INDEX TO FIT TABLES
*
LOCFIT1  EQU      %
         LW,R13   FITBUFS,R5        GET WA OF BUFFER
         AND,R13  M17               MASK BUF BUSY BIT
         STW,R13  FITBUFWA          REMEMBER CURRENT BUSY BUFFER
         SLS,R13  2                 CONVERT TO BA
         STW,R13  FITBUF            STORE FOR USE ELSEWHERE
         MTW,0    FITDAS,R5         HAS IT HAD END ACTION YET
         BLZ      %-1               NOT YET - WAIT FOR IT
         PLW,R15  PDSTK             RETRIEVE LINK
         B        *R15              RETURN TO CALLER
         PAGE
*
*        GET A FIT BUFFER
*
GETFITBUF EQU     %
         LI,R5    2                 NUMBER OF ENTRIES
         INT,R7   FITBUFS,R5        FIND A FREE BUFFER
         BCR,12   GETFITBUF1        GOTCHA
         BDR,R5   %-2               KEEP GOING
         LCI      0                 NONE TO BE HAD NOW
         B        *R11              RETURN
GETFITBUF1 EQU    %
         LW,R13   FITBUFS,R5        GET BUFFER ADDRESS
         OR,R13   Y4                SET BUSY BIT
         STW,R13  FITBUFS,R5        IN TABLES
         MTW,-1   FITBUFS           COUNT BUFFER BUSY DOWN
         AI,R13   0                 SET CONDITION CODES
         B        *R11              RETURN TO CALLER
         PAGE
*
*        TRY FOR NEXT FIT IN FILE DIRECTORY
*
NXTFIT   EQU      %
         LW,R2    NEXFILE           NEXT INDEX INTO FILE DIRECTORY
         AI,R2    FDKEYL            BUMP INDEX TO NEXT FILE
         CW,R2    FDSIZE            IS STILL INSIDE FD LIMITS
         BG       *R11              NOPE--> WAIT FOR NEXT FD SECTOR
         STW,R2   FITKEY            REMEMBER THE KEY..
         BAL,R7   GETFILE1          GET THE NEXT FIT DISC ADDRS
         BAL,R15  DTOGRAN           VERIFY IT
         B        *R11              ITS NOT A GOOD ONE - EXIT
         PSW,R11  PDSTK             SAVE RETURN LINK
         LI,R5    2
         LW,R9    M24
         CS,R8    FITDAS,R5         INSURE WE HAVENT READ IT ALREADY
         BE       NXTFIT3           GET OUT THEN
         BDR,R5   %-2
         BAL,R11  GETFITBUF         ASK FOR A BUFFER
         BEZ      NXTFIT3           NONE TO BE HAD NOW
         LW,R3    FITKEY            GET KEY WHERE D/A CAME FROM
         STW,R3   FITKEY,R5         AND PUT INTO TABLE
         SLS,R13  2                 BUFFER INTO BA
         LI,R1    FITDAS
         AW,R1    R5                CORE ADDRESS OF TABLE ENTRY
         OR,R1    Y2                MARK IT AS A FIT
         LI,R7    X'FC'
         BAL,R15  DISCIO20          READ W/LOWEST PRI FOR FITS
NXTFIT3  EQU      %
         PLW,R15  PDSTK
         B        *R15              AND RETURN TO CALLER
         PAGE
*
*        ERROR IN CURRENT ACCOUNT DIRECTORY KEY
*
ADERROR  EQU      %               SET UP
         LI,R15   ACMESS          PRINT ON
         CAL1,2   PRNT15          M:LL ALSO
         LI,R14   ENDOFD            YES..SET RETURN
         B        LISTAD            AND SNAP SECTOR
         PAGE
*
*        RUN DOWN ALL READ/WRITE AHEAD I/O
*
         DO       TAURUS=1
IORUNDWN EQU      %
         PSW,R2  PDSTK
         LI,R2    OPCNT-EASECT      SPIN ON DISC I/O
         MTW,0    *EAADDR,R2
         BGZ      %-1               UNTIL DONE
         LI,R2    DOPCNT-EASECT     SPIN ON TAPE I/O
         MTW,0    *EAADDR,R2
         BGZ      %-1               UNTIL DONE
         PLW,R2  PDSTK
         B        0,1
         ELSE
IORUNDWN MTW,0     OPCNT          SPIN ON DISC I/O
         BGZ       %-1            UNTIL DONE
         MTW,0     DOPCNT         SPIN ON TAPE I/O
         BGZ       %-1            UNTIL DONE
         B         0,1            AND RETURN
         FIN
         PAGE
*
*        DISPLAY FINAL TOTALS SUBROUTINE
*
DISPRUNTOTL EQU   %
         PSW,R15  PDSTK
         LI,R7    BLNKBYT           NEW HEADER STRING
         STW,R7   LLHDRB            RESET HEADER FOR M:LL
         CAL1,1   LLHDR
         LI,R0    0
         MTW,0    DUMP              WERE WRITING TAPE
         BNEZ     %+2               YES..DISPLAY # OF VOLUMNS
         STW,R0   VOL#              NOPE..RESET FOR STATISTICS
         CAL1,1   PAGEFPT           NEW PAGE FOR TOTAL'S
         LI,R2    38                PRINT LINE DISP.
         LI,R1    BA(STATISTICS)    MSG STRING
         BAL,R15  BUFSET            MOVE TO PRINT LINE
         BAL,R15  PRINT             AND PRINT IT
         BAL,R15  SPACE             SPACE ONE LINE
         LI,R7    DISPLEN           SET DISPLAY TABLE LENGTH
DISPLOOP EQU      %
         LW,R3    R3ST,R7           ANY VALUE IN BUCKET
         BEZ      DISPLOOP1         NO--> DONT DISPLAY IT
         LW,R1    R1ST,R7           ELSE GET BA OF MSG IT GOES WITH
         LI,R2    1                 PRINT LINE DISPLACEMENT
         BAL,R15  BUFSET            MOVE TO PRINT LINE
         LW,R3    R3ST,R7           GET ASSOCIATED VALUE
         BLZ      %+3               SAYS TO DISPLAY MSG ONLY
         LI,R1    BA(PBUF+9)+2      SET PRINT LINE DESTINATION
         BAL,R15  HEXTODEC          AND INSERT DECIMAL
         BAL,R15  PRINT             NOW PRINT ENTIRE LINE
DISPLOOP1 BDR,R7  DISPLOOP          GET NEXT ENTRY
         PLW,R7   PDSTK             RESTORE RETURN LINK
         B        0,R7              AND EXIT
         PAGE
*
*        TABLES CONTROLLING DISPLAY OF RUN STATISTICS
*
R1ST     EQU      %
         DATA     DISPLEN
         DATA     BA(DATARA)
         DATA     BA(MIXRA)
         DATA     BA(FITRA)
         DATA     BA(RAMSG)
         DATA     BA(FILSMSG)
         DATA     BA(TOTAMS)
         DATA     BA(TOTAPMS)
         DATA     BA(DINFO11)
         DATA     BA(DINFO3)
         DATA     BA(DINFO2)
         DATA     BA(DINFO1)
         DATA     BA(TOTFMS)
         DATA     BA(SYNCMSG)       # TIMES THRASHED ON DATA GRANULES
         DATA     BA(TRUNC2MSG)
         DATA     BA(TRUNC1MSG)
         DATA     BA(TRUNCMSG)
DISPLEN  EQU      WA(%)-WA(R1ST)-1
*
         USECT    DATASEC
R3ST     EQU      %
         DATA     DISPLEN
DATARAT  DATA     0
MIXRAT   DATA     0
FITRAT   DATA     0                 INITIAL READ AHEAD
         DATA     -1
FILSKPCNT DATA    0
RUNTOTL3 DATA     0
VOL#     DATA     1                 # OF TAPES USED
TPACC    DATA     0                 # OF TAPE I/O ACCESSES
RADXCNT  DATA     0
RADGCNT  DATA     0
         DATA     -1
RUNTOTL1 DATA     0
SYNC#    DATA     0                 # OF TIMES WE THRASHED ON DATA
TRUNC2   DATA     0
TRUNC1   DATA     0
         DATA     -1
*-------------------*
        PAGE
*
*
*        VERIFY DCTX/ADDRESS
*
*        CALLING SEQUENCE:
*
*        R15:     LINK
*        R8:      PUBLIC FILE DISC ADDRESS
*        RETURNS:
*                 LINK+1 IF BAD DISC ADDRESS
*                 LINK+2 IF GOOD DISC ADDRESS
*
*                 1. DCTX MUST BE IN RANGE.
*                 2. AN HGP EXISTS FOR THAT DCTX.
*                 3. SECTOR # IS WITHIN RANGE.
*
         USECT    PROCED
DTOGRAN  EQU      %
         MTW,0    PRIVATE
         BNEZ     PPDTOG            IF PRIVATE PACK BEING USED
*
*        NOTE THAT REGISTERS 2 , 3 AND 6 ASSUMED TO BE FREE
*
DTOGRAN0 EQU      %                 RETURN FROM PRIV PACK ROUTINE HERE
         DO       CPV>0
         CAL3,0   0                 GET INTO MASTER MODE AGAIN
         LH,R2    R8
         AND,R2   DCTMASK
         CLM,R2   DCTLIM            COMPARE TO POSSIBLE RANGE
         BCS,9    SLAVE             ***ERROR
         LB,R6    DCT22,R2          GET INDEX
         BEZ      SLAVE             ERROR
         LSECTA,3 R8                GET SECTOR #
         CW,R3    DISCLIMS,R6       COMPARE TO MAX POSSIBLE
         BGE      DTOGRAN1          POSSIBLE ERROR
         AI,R15   1
         LB,R3    ORG               IS THIS FILE RANDOM
         CI,R3    3
         BNE      SLAVE             NOPE
         LH,R3    DCT23,R2          IF SO WE NEED 'NSG' FROM HGP
         AI,R3    HGP
         LW,R3    3,R3              **GET SECTORS PER GRANULE
         STW,R3   NSPT              SAVED
         B        SLAVE             AND EXIT GOING BACK TO SLAVE MODE
         PAGE
*
*        POSSIBLE BAD DISC ADDRESS
*
DTOGRAN1 EQU      %
         LW,R6    R2                GET DCT INDEX
         LH,R2    DCT23,R6          GET HGP ADDRS
         AI,R2    HGP
         MTW,0    PRIVATE           IS THIS A PRIVATE PAC
         BNEZ     PPDTOG50          YUP
         B        FND3              NO--> PUBLIC
*
*
*        FOLLOWING IS FOR BPM DISC ADDRESS CHECKING
*
         ELSE
*
         AND,R8   M24
         LH,R6    R8                GET DCTX
         CLM,R6   DCTLIM            COMPARE TO POSSIBLE RANGE
         BCS,9    *R15              *ERROR
         LW,R2    HGPLOC            ADDRESS OF HGP
         LI,R3    5                 INDEX
         CB,R6    *R2,R3            TO FIND THIS MATCHING DCTX IN HGP
         BE       FND1              GOTCHA
         LW,R2    0,R2
         BGZ      %-3
         B        *R15              ERROR
FND1     EQU      %
         LW,R0    2,R2              GET NSPT FIELD
         LI,R3    NTYPS             MAX LOOP
         CW,R0    TYPS,R3           FND MATCHUP
         BE       FND2
         BDR,R3   %-2
         B        *R15              ERROR
FND2     EQU      %
         INT,R5   R8                GET SECTOR #
         CW,R5    SIZES,R3          COMPARE TO KNOWN AMOUNT
         BGE      FND3              POSSIBLE ERROR
         AI,R15   1                 GOOD ADDRESS
         LW,R5    3,R2              GET SECTORS PER GRANULE WORD
         STW,R5   NSPT              SAVED FOR RANDOM FILE ROUTINE
         B        *R15              GOOD ONE...
         FIN
         PAGE
*
*        POSSIBLE BAD DISC ADDRESS
*
*        R6 CONTAINS THE DCTX (VERIFIED)
*        R2 CONTAINS THE HGP WORD ADDRESS
*
FND3     EQU      %
         LB,R3    ORG               IS THIS A RANDOM FILE
         CI,R3    3                 IS IT RANDOM
         BNE      *R15              NOPE--> BAD DISC ADDRESS
*
*        IF THIS CURRENT DEVICE (DCTX IN R6) IS CYL - WE MUST FIND
*        THE NEXT CYL DEV IN THE SYSTEM FOR THIS RANDOM FILE TO OVERLAP
*        TO.
*        IF THIS DEVICE CURRENTLY IS GRANULE ALLOCATE - WE JUST MOVE
*        TO THE NEXT GRANULE ALLOCATED FILE DEVICE IN SEQUENCE.
*
FND4     EQU      %
         LI,R3    X'C000'
         LS,R3    1,R2              GET FLAGS FROM CURRENT HGP
         STW,R3   HGPTYPE           AND SAVE TO LOOK AT IN A SECOND
FND5     EQU      %
         AI,R6    1                 NEXT DCT INDEX
         CW,R6    DCTMAX            DONT GO TOO FAR
         BG       FND7              WHOOPS
         LW,R2    0,R2              GET NEXT HGP
         BEZ      FND7              TOO FAR
         MTW,0    HGPTYPE           LOOKING FOR CYL DEVICE
         BEZ      FND6              NOPE
         LI,R3    X'C000'
         AND,R3   1,R2              GET FLAGS FROM THIS HGP THEN
         CW,R3    HGPTYPE           IS A MATCH FOR WHAT WE WANT
         BNE      FND5              NOPE--> GO ON TO NEXT ONE
         LI,R3    9
         MTH,0    *R2,R3            TEST FOR PFA ON THIS DEVICE
         BEZ      FND5              NONE--> CANT USE THIS ONE EITHER
FND6     EQU      %
         LW,R0    M16
         AND,R0   6,R2              GET PFA FIRST SECTOR #
         STH,R6   R0                COMPOSE A DISC ADDRESS IN R0
         STW,R0   FDA               SAVE IT
         LW,R8    FDA               RELOAD R8
         DO CPV>0
         LW,R2    R15               SAVE THE RETURN ADDR
         BAL,R15  SLAVE
         LW,R15   R2                RESTORE THE RETURN ADDR
         FIN
         B        DTOGRAN           LOOP AROUND AND CHK THESE ONE
*
FND7     EQU      %
         DO       CPV>0
         B        SLAVE
         ELSE
         B        *R15
         FIN
         PAGE
*
*        PRIVATE PACK DISC ADDRS CHECKER
*
PPDTOG   EQU      %
         LDCTX,R3   R8              GET VNO FROM DISC ADDRESS
         AI,R3    0
         BEZ      *R15              BAD
         CW,R3    PP#VOL            IN RANGE
         BG       *R15              NOPE
         STW,R3   CVNO              STORE CURRENT VOL #
         LW,R6    PPDCTX,R3         GET MATCHNG DCTX
         BEZ      *R15              ERROR
         STDCTX,R6  R8              STORE IT
         B        DTOGRAN0          REJOIN
*
*        COME HERE IF RANDOM FILE OVERLAPS DEVICE
*
PPDTOG50 EQU      %
         LW,R2    CVNO              GET CURRENT VOLUME NUMBER
         AI,R2    1                 STEP IT
         CW,R2    PP#VOL            TOO FAR YET
         BG       *R15              YES
         STW,R2   CVNO
         LW,R3    PPHGPADR,R2       GET THE HGP WA
         LI,R0    X'FF'
         AND,R0   1,R3              GET THIS PACKS NGC
         LW,R6    R0                REMEMBER IT
         CI,R0    30                HAVE WE SKIPPED NVAT YET
         BGE      %+3               YES - GO ON
         AW,R0    R6                NO - ADD IN NGC AGAIN
         B        %-3               GO RETRY THE TEST
         LW,R3    3,R3              GET THIS DEVICES NSG
         MW,R3    R0                CONVERT GRANULES TO SECTORS
         STH,R2   R3                PUT THE VOLUME NUMBER IN
         STW,R3   FDA               LEAVE IT AROUNG FOR RANFILE
         LW,R8    FDA               GET IT BACK
         DO       CPV>0
         LW,R2    R15               SAVE RETURN ADDR
         BAL,R15  SLAVE             GO SLAVE
         LW,R15   R2                RESTORE RETURN ADDR
         FIN
         B        DTOGRAN           LOOP AROUND AND CHECK THIS ONE
         PAGE
*
*
*        DEVICE RECOGNITION TABLES
*
*
         DO       CPV=0             BPM OR UTS THRU D00
TYPS     DATA     0                 OFFSET
         DATA     82                7212  *
         DATA     16                7204    *  RADS
         DATA     12                7232  *
         DATA     11                7260 DISC PACK
         DATA     6                 7242       DISC PACK
NTYPS    EQU      WA(%)-WA(TYPS)-1
*
*        SECTOR LENGTH BY DEVICE (PARALLEL TO TYPS)
*
SIZES    DATA     0                 OFFSET
         DATA     64*82             7212  *
         DATA     512*16            7204    *  RADS
         DATA     512*12            7232  *
         DATA     200*20*11         7260 DISC PACK
         DATA     200*20*6          7242       DISC PACK
         FIN
*
         USECT    DATASEC
MISIZEX  DATA     0                 COPY OF MI BLOCK NAV
TAPKYS   DATA     0                 # OF KEYS SENT TO TAPE SO FAR
INVDMSK  DATA     0
SECMSK   DATA     0
         USECT    PROCED
*
         PAGE
*
*        FILE DIRECTORY KEY IS IN ERROR
*
FDERR    EQU      %
         LI,R15   FDMESS            PRINT
         CAL1,2   PRNT15            ERROR MSG
         BAL,R14  LISTFD            DUMP FD SECTOR
FDERR1   EQU      %
         MTW,1    FERROR            SET FILE ERROR FLAG
         LI,R15   SKIPFILMS         PRINT THE **PARTIAL FILE MSG**
         CAL1,2   PRNT15
         MTW,1    FILSKPCNT         BUMP SKIP COUNT
         LI,R7    X'FF'
         LS,R7    PDSTK+1           GET DEPTH OF STACK
         LCW,R7   R7                FLIP IT OVER
         MSP,R7   PDSTK             AND CRACK OPEN THE STACK AGAIN
         B        GOGET             PRINT FILE NAME,ETC...
         PAGE
*
*        BREAK CONTROL
*
BREAK    GEN,8,24 14,BRKHIT
*
BRKHIT   EQU      %
         BAL,R15  TACNT             SHOW ACCOUNT # AND OUTPUT REEL #
         BAL,R15  TFILNME           SHOW FLE NAME WE'RE ON
         CAL1,9   5                 AND RETURN TO WHERE WE WERE
         PAGE
*
*        FIT CONTENTS ERROR,NAME CORRESPONDENCE ERROR.
*
FITSNAP  EQU      %
         LI,R15   FITMESS           PRINT ERROR MSG
         CAL1,2   PRNT15            HERE
FITERR   EQU      %
         LW,R6    CURFILE           CURRENT FILE INDEX
         LW,R7    NEXFILE           NEXT INDEX
         LW,R4    FITBUFWA          WORD ADDRESS OF CURRENT FIT
         LW,R5    R4                COPY TO R5
         AI,R5    512               R5 = END OF FIT BUFFER
         M:SNAP   'FITERR',(*R4,*R5)
         B        FDERR1            TYPE FILE NAME,ETC...
         PAGE
*
*        SAVE CURRENT FILE DIRECTORY
*        KEY IN LOCATION 'BOFBUF+2'
*
PUTNAME  EQU      %
         LI,R0    0
         DO       SIGMA7=0
         LI,R1    -10
         STW,R0   BOFBUF+10,R1      ZIP NAME BUCKET
         BIR,R1   %-1
         ELSE
         LW,R1    BOFBUFBA
         MBS,R0   0                 ZIP NAME BUCKET TO ZERO
         FIN
         LW,R2    CURFILE           CURRENT INDEX
         AI,R2    BA(FDBUF)         CORE SBA
         LB,R3    0,R2              GET LENGTH OF KEY
         AI,R3    1                 PLUS ONE FOR TEXTC BYTE
         LI,R5    BA(BOFBUF+2)      PLACE TO PUT IT
         B        MOVEBYT           MOVE NAME INTO :BOF / RETURN
         PAGE
*
*        LIST CURRENT FILE DIRECTORY SUBROUTINE
*
LISTFD   EQU       %
         LI,R15   FDRMSG
         CAL1,2   PRNT15
         LI,R3    FDBUF
         B        LISTCALL          GET INTO LOOP
         PAGE
*
*        LIST CURRENT FIT SUBROUTINE
*
LISTFIT  EQU       %
         LI,R15   FITMSG1
         CAL1,2   PRNT15
         LW,R3    FITBUFWA          WORD ADDRS OF FIT
         B        LISTCALL          GET INTO LOOP
         PAGE
*
*        LIST CURRENT OUTPUT BUFFER
*
LISTOUTBUF EQU    %
         LI,R3    0
         XW,R3    LSTBUF            GET BA OF LAST BUFFER
         BEZ      *R15              NONE - OR ALREADY DID IT
         LW,R1    PBS               GET BYTE COUNT OF IT THEN
         SLS,R3   -2                MAKE IT A WORD ADDRESS
         B        PLIST             AND SNAP AREA
         PAGE
*
*        LIST CURRENT INDEX SECTOR
*
LISTMIX  EQU       %
         LI,R15   MIXMSG1
         CAL1,2   PRNT15
         LW,R3    MIXBUF            BUFFER POINTER WA
LISTCALL LI,R1    2048 *4           SNAP THESE MANY SENORES...
         BAL,R15   PLIST
         B         *R14
         PAGE
*
*        LIST CURRENT ACCOUNT DIRECTORY SECTOR
*
LISTAD   EQU       %
         LI,R15   ADRMSG1
         CAL1,2   PRNT15
         LI,R3     ACBUF
         B        LISTCALL          GET INTO LOOP
         PAGE
*
*        INDEX CONTENT,LINKAGE ERROR SUBROUTINE
*
MIXSNAP  EQU      %
         BAL,R14  LISTMIX           SNAP THE MIX BLOCK OUT
         MTW,0    DUMP              WRITING TAPE TODAY
         BEZ      FDERR1
         LI,R15   FDERR1            RETURN ADDRESS
         B        EOFQ              CLOSE OUT FILE ON TAPE
         PAGE
*
*
*        FILE ERROR
*                 DATA GRANULE ADDRESS ERROR
*
DATAERR  EQU      %
         LI,R15   MIXMESS           PRINT
         CAL1,2   PRNT15            ERROR MSG ON M:LL
         B        MIXSNAP           AND SNAP TABLES
         PAGE
*
*        FILE DIRECTORY SECTOR COMPLETED
*
FDDONE   EQU      %
         LW,R8    FDFLINK            GET FORWARD LINK
         BEZ      ENDOFD             IF ZERO--END REACHED
         BAL,R15  DTOGRAN            VERIFY ADDRS
         B        READFAIL3          ERROR RETURN
         B        GETFDA            READ THE NEXT SECTOR
         PAGE
*
*        FINISHED A FILE DIRECTORY
*
ENDOFD   EQU      %
         MTW,1    RUNTOTL3           RUN TOTAL # OF ACCOUNTS
         LW,R15   SAVBYDATE         NO-ARE WE SAVING BY DATE
         AW,R15   SAVBYHOUR         OR SAVIN BY HOUR ?
         BEZ      FILECOUNT         NOPE
         MTW,0    TOTLFILS          SAVE ANY FILES IN THIS ACCOUNT
         BEZ      GRANCOUNT         NOPE--> NO FILES SAVED IN ACCOUNT
*
*        IN HOUR/DATE MODE DONT PRINT ANYTHING IF NOTHING DONE
*
FILECOUNT LI,R1   BA(DASHMSG)
         DO       UTS=0             BPM CODE ONLY
         LI,R2    41
         ELSE
         LI,R2    16                PRINT LINE INDEX
         FIN
         BAL,R15  BUFSET
         LI,R1    BA(DASHMSG)       GET IT AGAIN
         LB,R3    0,R1
         AI,R1    1
         DO       UTS=0
         LI,R2    53
         ELSE
         LI,R2    26                PRINT LINE INDEX
         FIN
         BAL,R15  BUFSET1
         BAL,R15  LPRINT            AND PRINT LINE
         LI,R3    0
         XW,R3    TOTLFILS          # FILES IN THIS ACCOUNT SAVED
         STW,R3   POBUF+2           PUT INTO STATS FILE RECORD
         DO       UTS=0
         LI,R1    BA(PBUF)+27
         ELSE
         LI,R1    BA(PBUF+1)
         FIN
         BAL,R15  HEXTODEC
         BAL,R15  SPACE
         LI,R3    0
         XW,R3    ACNSIZE           # OF BYTES IN THIS ACCOUNT
         STW,R3   POBUF+4           STORE TOTAL BYTES
         DO       UTS=0
         LI,R1    BA(PBUF+15)
         ELSE
         LI,R1    BA(PBUF+7)+5
         FIN
         BAL,R15  HEXTODEC
         LW,R3    ACNGRAN           # OF GRANULES IN THIS ACCOUNT
         STW,R3   POBUF+3           STORE TOTAL GRANULES
         DO       UTS=0
         LI,R1    BA(PBUF+12)
         ELSE
         LI,R1    BA(PBUF+4)+7
         FIN
         BAL,R15  HEXTODEC
         BAL,R15  LPRINT            PRINT IT
         LI,R15   0
         XW,R15   ACNGRAN           GET # OF GRANULES IN ACCOUNT
         SW,R15   PACKGRAN         -TOTAL PACK GRANS IN ACCT
         SW,R15   RADGRAN          -TOTAL RAD GRANS IN ACCT
         BEZ      GRANCOUNT         SHOULD BE ZERO
         LW,R3    RADGRAN           OTHERWISE, ADJUST.
         CW,R3    PACKGRAN          FIND OUT WHICH IS LARGER
         BG       %+3
         AWM,R15  PACKGRAN          PACK IS LARGER, ADJUST IT.
         B        GRANCOUNT
         AWM,R15  RADGRAN           RAD  IS LARGER, ADJUST IT.
GRANCOUNT EQU     %
         LI,R3    0
         XW,R3    RADGRAN           # OF RAD GRANULES
         AWM,R3   RADXCNT           UPDATE TOTAL RAD ACCESSES
         STW,R3   POBUF+5
         LI,R3    0
         XW,R3    PACKGRAN          # OF PACK GRANULES
         AWM,R3   RADGCNT           UPDATE TOTAL PAK ACCESSES
         STW,R3   POBUF+6
         LW,R0    STATS
         BEZ      NACN              NOT IN STATS MODE TODAY
         LW,R0    ALL
         BGEZ     NACN              NOPE--> DONT UPDATE STATS FILE
         LCI      2
         LM,R0    ACN#CURNT         CURRENT ACCOUNT #
         STM,R0   POBUF             INTO RECORD
         STM,R0   POKEY+1           INTO THE KEY
         CAL1,1   WRTPO             YES..WRITE RECORD
         B        NACN
         PAGE
*
*        FILE IS COMPLETE
*
CKTIO    EQU      %
         BAL,R15  EOFQ              SEND EOF SEQUENCE
         MTW,1    TOTLFILS          COUNT # OF FILES
         MTW,1    RUNTOTL1          AND RUN TOTAL FILES
         LI,R14   0                 END OF TAPE WRITING SENTINELS
         LI,R1    SPECEOT-EASECT
         XW,R14   *EAADDR,R1        IF SO CLEAR FLAG AND PUT WHERE IT
         STW,R14  *EOTFLAG          BELONGS FOR REEL CHANGE
         B        GOGET
         PAGE
*
*        FIND FIT CODE SUBROUTINE
*
CODESCAN EQU      %
         LW,R2    INITX             STARTING PLACE IN THE FIT
         LI,R15   128               MAX TRAVEL THRU ONE FIT
CODESCAN1 EQU     %
         INT,R12  *R2               GET LEI BYTE
         CB,R0    *R2
         BE       1,R6              GOTCHA
         CI,R12   7                 IS LEI INDICATED
         BANZ     0,R6              YEP
         AND,R13  MFF               NO--> STRIP OUT WORD COUNT
         AW,R2    R13               POINT TO END OF FIELD
         AI,R2    1                 STEP IT TO NEXT CODE ENTRY
         BDR,R15  CODESCAN1         KEEP GOING
         B        FITERR            ABORT THIS FILE - FIT IS WEIRD
         PAGE
*
*        MOVE VLP ENTRIES FROM THE FIT TO THE :BOF RECORD AND INTERNAL
*        BUFFERS WHENEVER WE WANT AN ENTRY FOR LATER  (PRINT LINE..ETC.)
*
SCANF    EQU      %
         PSW,R7   PDSTK             SAVE RETURN LINK
         LI,R0    X'0B'
         BAL,R6   CODESCAN          QUIK CHK FOR SYNON FILES
         B        %+2               NOT SYNON
         MTH,1    *R2               SET LEI IF SYNON FILE
         LI,R5    10
         STW,R5   BOFSIZE           INITIALIZE # OF WORDS USED SO FAR
         LI,R5    7
         STB,R5   TPLFLG            STORE COUNT IN TAPE LABEL
         LI,R5    BOFBUF+10         FIRST LOC IN :BOF TO USE
         STW,R5   BUFLOC            REMEMBER IT FOR USE LATER
         LD,R2    BOFINFO
         STD,R2   BOFBUF            SETUP 1ST TWO WORDS
         DO1      FILL=1
         LI,R5    TLABUF+7          FIRST SPOT IN TAPE LABEL
         STW,R5   BUFLOC+1
         LI,R7    #CODES            MAX LOOP
SCANF1   EQU      %
         LB,R0    CODES,R7          GET A CODE ENTRY
         LW,R6    SLOTS,R7          IS AN INTERNAL FIELD TO BE USED
         BEZ      SCANF2            NO
         LC       COUNTS,R7         YES--> GET # OF WORDS
         LM,R10   DZERO
         STM,R10  0,R6              AND SUPPRESS INTERNAL FIELD
SCANF2   EQU      %
         BAL,R6   CODESCAN          SEE IF CODE EXISTS IN FIT
         B        SCANF5            NOPE--> GO TO NEXT ONE
         CI,R13   X'3F00'           ANY USEFUL WORDS INDICATED
         BAZ      SCANF5            NOPE--> REJECT THIS ONE
         STW,R2   CRNTLOC           SAVE CURRENT LOC OF IT IN FIT
         LW,R5    BUFLOC            :BOF CURRENT WA
         MTB,0    FITZ,R7           DOES THIS ENTRY GO TO THE :BOF
         BEZ      SCANF3            NOPE-->
         LW,R6    BOFSIZE           GET # OF WORDS MOVED SO FAR
         CI,R6    124               AT MAX BOF RECORD YET
         BGE      SCANF3            YES--> HAVE TO SKIP THESE
         BAL,R15  MOVENTRY          YES--->
         BAL,R15  CLRLEI            REMOVE LEI FLAG
         SLS,R5   -2                BACK INTO A WORD ADDRS
         STW,R5   BUFLOC            UPDATE CURRENT :BOF LOC
         AI,R5    -BOFBUF           CALCULATE DEPTH IN WORD COUNT NOW
         STW,R5   BOFSIZE           AND SAVE FOR USE AGAIN
SCANF3   EQU      %
         LW,R6    SLOTS,R7          MOVE ENTRY TO INTERNAL LOC
         BEZ      SCANF4            NOPE-->
         LW,R1    CRNTLOC           YES--> GET CURRENT LOC
         LC       COUNTS,R7         GET # OF WORDS WE WANT FROM IT
         LM,R10   1,R1              GET DATA ONLY
         STM,R10  0,R6              AND MOVE TO OUR LOC
SCANF4   EQU      %
         LW,R5    BUFLOC+1          TAPE LABEL LOC
         MTB,0    TITZ,R7           DOES THIS ENTRY GO TO THE TAPE LABEL
         BEZ      SCANF5            NOPE
         LB,R5    TPLFLG            GET COUNT IN TAPE LABEL NOW
         CI,R5    64                AT MAX SIZE
         BG       SCANF5            YES--> CANT MOVE THESE NOW
         LW,R2    CRNTLOC           GET CURRENT LOC IN FIT TABLE
         LW,R5    BUFLOC+1          GET TAPE LABEL CURRENT LOC
         BAL,R15  MOVENTRY          AND MOVE TO TAPE LABEL
         BAL,R15  CLRLEI            REMOVE LEI FLAG
         SLS,R5   -2                BACK INTO A WORD ADDRS
         STW,R5   BUFLOC+1          UPDATE TAPE LABEL CURRENT LOC
         AI,R5    -TLABUF           CALCULATE # WORDS USED TO DATE
         STB,R5   TPLFLG            AND SAVE
SCANF5   EQU      %
         BDR,R7   SCANF1            FINISH OFF THESE DATA....
         PLW,R7   PDSTK             GET BACK THE LINK
         B        0,R7              AND RETURN TO THE CALLER
         PAGE
*
*        STRIP LEI FLAG FROM ALL VLP'S IN TAPE LABEL AND :BOF RECORDS
*
CLRLEI   EQU      %
         LW,R14   *KICKOUT          LAST USED DEST WA
         AND,R14  =X'FF00FFFF'      CLEAR LEI BYTE
         STW,R14  *KICKOUT          AND REPLACE
         B        *R15              RETURN TO :BOF BUILDER
         PAGE
*
*        STATIC DATA FOR FIT TO :BOF ROUTINE
*
CODES    EQU      %
         DATA,1   #CODES,;          0
                  12,;              1
                  9,;               2
                  13,;              3
                  3,;               4
                  5,;               5
                  6,;               6
                  4,;               7
                  10,;              8
                  14,;              9
                  15,;              10
                  20,;              11
                  21,;              12
                  16,;              13
                  11                14
#CODES   EQU      BA(%)-BA(CODES)-1
         BOUND    4
*
COUNTS   EQU      %
         DATA,1   #CODES,;          0
                  16,;              1
                  48,;              2 (3 WORDS FROM 09 ENTRY)
                  32,;              3 (2 WORDS FROM 0D ENTRY)
                  32,;              4
                  32,;              5
                  32,;              6
                  32,;              7
                  48,;              8
                  32,;              9
                  32,;              10
                  32,;              11
                  32,;              12
                  32,;              13
                  16                14
         BOUND    4
*
FITZ     EQU      %
         DATA,1   #CODES,;          0
                  0,;               1
                  0,;               2
                  0,;               3
                  1,;               4
                  1,;               5
                  1,;               6
                  0,;               7
                  0,;               8
                  0,;               9
                  0,;               10
                  0,;               11
                  0,;               12
                  0,;               13
                  0                 14
         BOUND    4
*
TITZ     EQU      %
         DATA,1   #CODES,;          0
                  0,;               1
                  1,;               2 (09 ENTRY INTO TAPE LABEL)
                  1,;               3 (0D ENTRY INTO TAPE LABEL)
                  0,;               4
                  0,;               5
                  0,;               6
                  1,;               7
                  1,;               8
                  1,;               9
                  1,;               10
                  1,;               11
                  1,;               12
                  0,;               13
                  1                 14
         BOUND    4
*
SLOTS    EQU      %
         DATA     #CODES            0
         DATA     FDA               1
         DATA     ORG               2
         DATA     RANDOM            3
         DATA     FILE%PASWRD       4
         DATA     READ:AC           5
         DATA     0                 6
         DATA     EXP:DATE          7
         DATA     MOD:DATE          8
         DATA     CRE:DATE          9
         DATA     ACC:DATE          10
         DATA     0                 11
         DATA     0                 12
         DATA     BKP:DATE          13
         DATA     SYNFLAG           14
*
         PAGE
*
*        PRINT FILE NAME,FILE INFO SUBROUTINE
*
NO%DUMP  EQU      %
         LI,R15   NO%DMPMSG         PRINT ERROR MSG BOUT NO-BACKUP BIT
         CAL1,2   PRNT15            FOR USER'S BENEFIT
GOGET    EQU     %
         MTW,0    FERROR            FERROR MODE SET
         BEZ      GOGET1            NO,NO DISPLAY OF TABLES
         M:SNAP   'TBUFS',(TBUF,TBUF+#TBUF)
         M:SNAP   'DBUFS',(DBUF,RBHIST+#DBUF)
         M:SNAP   'IBUFS',(IBUF,INDEXDA+#IBUF)
         LW,R1    MIXSTAT
         LW,R2    MIXSTAT
         AI,R2    #IBUF             TOP OF TABLE
         M:SNAP   'ISTAT',(*R1,*R2)
         M:SNAP   'TABLES',(DCTMASK,LBLBUF)
         M:SNAP   'STACK',(DSTACK,STACK+STACKSIZE+124)
GOGET1   EQU      %
         MTW,0    LIST              SUPPOSED TO BUILD PRINT LINE
         BEZ      NODATE2           NOPE--> EXIT
         LW,R4    FNEB              YES-->
         LW,R5    FNEC              PRINT LINE DEST BA
         LB,R6    0,R4              BYTE CNT OF FILE NAME
         STB,R6   R5                SET FOR MBS
         AI,R4    1                 POINT TO TEXT STRING
         DO       SIGMA7=0
         LB,R6    R5                COUNT
         LB,R7    0,R4
         STB,R7   0,R5
         AD,R4    DOUBLEONE
         BDR,R6   %-3
         ELSE
         MBS,R4   0
         FIN
         MTW,0    SYNFLAG           CURRENT SYNON
         BEZ      NOELEV            NOPE-BYPASS CHECK
         LW,R1    SYNMSG            YEP
         DO       UTS=0
         STW,R1   PBUF+19
         ELSE
         STW,R1   PBUF+09
         FIN
         B        NODATE1           ALL DONE WITH THIS LINE
NOELEV   EQU      %
         LI,R3    0
         XW,R3    FGCOUNT           GET COUNT OF UNIQUE GRANULES FOR FILE
         LW,3     GRANULES          GRANULE COUNT FROM FIT
         AWM,R3   ACNGRAN           UPDATES ACCOUNT TOTAL
         DO       UTS=0
         LI,R1    BA(PBUF+12)
         ELSE
         LI,R1    BA(PBUF+4)+7
         FIN
         BAL,R15  HEXTODEC
         LI,R3    0
         XW,R3    FILESIZE          # OF BYTES IN FILE
         AWM,R3   BLKDBYTES         UPDATE # SENT TO TAPE
         AWM,R3   ACNSIZE           UPDATE ACCOUNT TOTAL
         DO       UTS=0
         LI,R1    BA(PBUF+15)
         ELSE
         LI,R1    BA(PBUF+7)+5
         FIN
         BAL,R15  HEXTODEC
NOSAVET  LB,R1    ORG               GET FILE'S ORGANIZATION
         LW,R1   ORGTX,R1           GET ORG TEXT TYPE
         DO       UTS=0
         STW,R1   PBUF+17           PRINT LINE SLOT
         LI,R0    TLABUF+4          CREATION DATE STILL IN TLABUF
         LI,R2   4
         LH,R1   *R0,R2             GET HOUR
         STH,R1   PBUF+24,R2        MOVE 'HOUR' TO PRINT LINE
         AI,R2    1                 JUMP INDEX
         LH,R4   *R0,R2             GET YEAR CREATED
         SLD,R4  -16
         LI,R4   '/'                SLASH
         SLD,R4  -8
         LI,R1   3
         LH,R4   *R0,R1             GET DAY CREATED
         SLD,R4  -8
         STW,R5   PBUF+24           MOVE '/DAY/YEAR' TO LINE
         SLD,R4  -8
         LI,R4   '/'                SLASH
         SLD,R4  -8
         LI,R1   2
         LH,R4   *R0,R1             GET MONTH CREATED
         SLD,R4  -16
         STW,R5   PBUF+23           MOVE '  MONTH/' TO LINE
         LCI      2
         LM,R10   FILE%PASWRD
         STM,R10  PBUF+21           STICK PASSWORD INTO PRINT LINE
         ELSE
         STW,R1   PBUF+09           STORE ORG IN PRINT LINE
         MTW,0    LPFLAG            WRITING LP
         BNEZ     DATE:LP0          YUP
         LI,R3    0                 NO
         XW,R3    RECNT             GET RECORD COUNT IN FILE
         LI,R1    BA(PBUF+11)+6
         BAL,R15  HEXTODEC
         B        NODATE1           ALL DONE W/PRINT LINE
DATE:LP0 EQU      %
         LW,R6    DATE:TAB          GET LENGTH OF DATE TABLES
DATE:LP  EQU      %
         LB,R7    DATE:PS,R6
         AI,R7    PBUF
         LW,R1    DATE:TAB,R6       SOURCE
         BAL,R15  IN:DATE
         BDR,R6   DATE:LP           FINISH UP
         FIN
NODATE1  EQU      %
         CAL1,1   NLINES
         BAL,R15  LPRINT            PRINT ENTIRE LINE NOW
         CI,R8    1                 HOW MANY LINES LEFT ON THIS PAGE
         BNE      %+2               MORE TO GO YET
         BAL,R7   ACNPAGE           PUT OUT NEW PAGE ON M:LL NOW
NODATE2  EQU      %
         MTW,0    ALL
         BEZ      %+2               NOT DOING ALL FILES IN THIS ACN
         BAL,R11  NXTFIT            QUEUE ANOTHER FIT IF POSSIBLE
         B        GETFILE
         DO       UTS>0
         PAGE
*
*        INSERT DATE INTO PRINT LINE,CALLLING SEQUENCE;
*
*        R1:      POINTS TO DATE BUFFER (TWO WORDS)
*        R7:      CONTAINS PRINT LINE WA
*
IN:DATE  EQU      %
         LCI      2
         LM,R4    0,R1              GET BOTH WORDS
         CW,R4    ='NEVE'           IS TEXT OF NEVER...
         BE       IN:DATE0          YES-> STORE AND QUIT
         CI,R5    0                 OR JUST NOTHING TO DO
         BE       *R15
         MTB,0    DATE:FLD,R6       IS A DATE
         BNEZ     IN:DATE1          YEP
IN:DATE0 EQU      %
         LCI      2                 NO-> STORE IT
         STM,R4   0,R7              INTO PRINT LINE
         B        *R15              RETURN
IN:DATE1 EQU      %
         LCI      3
         LM,R10   DBLANK
         STM,R10  BLD:DATE          ZIP THE BUFFER TO ALL BLANKS
         LW,R4    0,R1              GET MMDD FIELD
         AND,R4   =X'0F0FFFFF'      MASK OFF ODD BITS
         STH,R4   BLD:DATE+1        INSERT DD INTO BUFFER
         SLS,R4   -16               POSITION MONTH
         CI,R4    X'09'             IS SEPTEMBER
         BLE      IN:DATE2          YEP
         AND,R4   MFF               DROP BYTE 0-2
         AI,R4    10                CONVERT TO HEX VALUE
IN:DATE2 LW,R3    MONTHTAB,R4       GET EBCDIC MONTH
         STW,R3   BLD:DATE          STORE INTO BUFFER
         LW,R3    BLD:DATE+1        GET DAY FIELD BACK
         MTB,0    HOUR:DI,R6        IS HOUR TO GO INTO MSG
         BEZ      IN:DATE4          YEP,BUILD IT IN
IN:DATE3 LCI      3                 NO,MSG IS COMPLETE
         LM,R3    BLD:DATE          MOVE ENTIRE
         STM,R3   0,R7              MSG TO PRINT LINE
         B        *R15              RETURN TO LOOP
IN:DATE4 LW,R4    1,R1              GET HHYY FIELD
         SLS,R4   -16               POSITION HH
         SLD,R4   -8                MOVE BYTE ONE OF HH
         AND,R5   YFF               CLEAR OUT R5
         OR,R4    LPR               INSERT LEFT PAREN
         OR,R3    R4                INTO MSG WORD 1
         STW,R3   BLD:DATE+1        BACK TO BLOCK
         OR,R5    RPR               INSERT RIGHT PAREN
         STW,R5   BLD:DATE+2        INTO BLOCK
         B        IN:DATE3          AND MOVE TO BUFFER
         FIN
         PAGE
*
*
*        BUILD RECORD AND KEY TO OUTPUT TO SORTED FILE
*
*
SKEYUP   EQU      %
         LB,2     INBUF             GET FIRST CHAR ON CARD
         CI,2     X'40'             BLANK IS A COMMENT CARD
         BE       0,R7              YES--> DONT PUT IT IN FILE EITHER
         LI,R2    -10
         LI,R3    0                 CLEAR
         STW,R3   RKEY+10,R2          KEY
         BIR,R2   %-1                   BUFFER
*
*
         LD,R0    DBLANK            GET A PAIR OF BLANKS
         STD,R0   CARDACN           CLEAR THIS BUFFER
*
         LI,R2    0                 INDEX INTO CARD
         LI,R3    0                 INDEX INTO ACN BUF
         LI,R4    8                 MAX LOOP
SKEYUP0  EQU      %
         LB,R0    INBUF,R2          GET BYTE FROM CARD IMAGE
         CI,R0    ' '               IS CHAR BLANK
         BLE      SKEYUP1           YES--> STOP
         CI,R0    '.'               USE PERIOD AS DELIM ALSO
         BE       SKEYUP1           END
         CI,R0    ','               OR A COMMA
         BE       SKEYUP1           END
         STB,R0   CARDACN,R3        STORE A CHAR
         AD,R2    DOUBLEONE         NEXT SET OF CHARACTERS
         BDR,R4   SKEYUP0
SKEYUP1  EQU      %
         AI,R3    1                 STEP OVER THAT CHAR TO NEXT BYTE
         LI,R4    60                MAX SCAN ON FILE NAME
         LI,R2    0                 INDEX INTO CARD TEMP BUF
SKEYUP2  EQU      %
         LB,R0    INBUF,R3          GET A CHAR
         CI,R0    ' '
         BG       SKEYUP3           OKAY TO STORE
         CI,R2    0                 HAVE WE MOVED ANY YET
         BGZ      SKEYUP4           YES--> QUIT NOW
         B        SKEYUP35          NO---> SKIP OVER THESE THEN
SKEYUP3  EQU      %
         STB,R0   CARDBUF,R2        ELSE STICK IT OVER THERE
         AI,R2    1                 BUMP INDEX INTO CARD TEMP BUF
SKEYUP35 EQU      %
         AI,R3    1
         BDR,R4   SKEYUP2
SKEYUP4  EQU      %
         STW,R2   DURINDX           REMEMBER COUNT
         BAL,R0   BINBUF            BLANK THE ENTIRE CARD NOW
*
         LD,R0    CARDACN
         STD,R0   INBUF             PLACE THE ACCOUNT # BACK ONTO CARD
         LI,R2    BA(CARDBUF)
         LI,R5    BA(INBUF+3)+1     CARD COLUMN 14 IS WHERE IT GOES
         LW,R3    DURINDX           # BYTES IN NAME
         BAL,R15  MOVEBYT           MOVE NAME BACK ONTO CARD
*
*        ACCOUNT # AND FILE NAME ARE BACK IN PLACE WITH BLANKS
*        EVERYWHERE ELSE ON CARD - NOTE THAT FILE NAME STARTS
*        IN CARD COLUMN 14 NO MATTER WHERE IT WAS WHEN WE READ IT.
*
         LI,R6    31                MAX CHARS IN A FILE NAME
         LI,R3    0                 USE FOR TEXT COUNT
         LI,R2    1                 INDEX INTO FILE NAME
SKEYUP5  EQU      %
         LB,R0    INBUF+3,R2        GET A BYTE OF FILE NAME
         CI,R0    ' '               IS BLANK OR WORSE
         BLE      SKEYUP6           YES--> ALL DONE
         AD,R2    DOUBLEONE         NO--> COUNT CHARACTERS
         BDR,R6   SKEYUP5           FINISH LOOKING AT NAME
SKEYUP6  EQU      %
         STW,R3   DURINDX           SAVE COUNT OF CHARS
         CI,R3    0                 ANY CHARS FOUND
         BEZ      SKEYUP7           NO CHARACTERS FOUND
         STB,R3   INBUF+3           PUT TEXTC COUNT ONTO CARD
SKEYUP7  EQU      %
         LI,R2    BA(CARDACN)
         LI,R3    8                 ALWAYS 8 BYTES IN ACCOUNT #
         LI,R5    BA(RKEY)+1        DESTINATION FOR ACN#
         BAL,R15  MOVEBYT           MOVE ACCOUNT # INTO PLACE
         LW,R3    DURINDX           FILE NAME BYTE COUNT
         BEZ      SKEYUP8           NO FILE NAME ON CARD
         LI,R2    BA(INBUF+3)+1     FILE NAME IS HERE
         BAL,R15  MOVEBYT
SKEYUP8  EQU      %
         LW,R14   DURINDX           GET FILE NAME COUNT
         AI,R14   8                 8 FOR ACN#
         CI,R14   31                MAX KEY COUNT
         BLE      %+2               NO
         LI,R14   31                RESTRICT TO 31 MAX
         STB,R14  RKEY              PUT THE KEY COUNT INTO KEY
         MTW,1    DATACARDS         COUNT DATA CARDS
         LW,R3    CURMODE           GET CURRENT MODE
         STW,R3   INBUF+19          STICK IT INTO THE CARD
         M:WRITE  M:SO,(BUF,INBUF),(SIZE,80),(KEY,RKEY),;
                  (ONEWKEY),(WAIT)
         B        0,R7              WRITE RECORD AND EXIT THIS PASS
         PAGE
*
*        MOVE  FROM FIT TO BOF SUBROUTINE
*
MOVENTRY EQU      %
         STW,R5   KICKOUT           SAVE DESTINATION WA FOR LATER
         INT,R3   *R2               GET # OF WORDS
         AND,R3   M3F               EXTRACT
         AI,R3    1                 ADJUST TO COVER LEADING WORD
         SLD,R2   2                 SHIFT INTO BA FORMAT
         SLS,R5   2                 DESTINATION INTO BYTE FORMAT
         B        MOVEBYT           JOIN UP W/MOVE STRING ROUTINE
M3F      GEN,24,8 0,63
*
*        HEX TO DECIMAL SUBROUTINE
*
HEXTODEC EQU      %
         LI,R14   3                 # OF BYTES PRIOR TO A COMMA
DIVIDE   LI,R2    0
         DW,R2    TEN
         AI,R2    X'F0'
         STB,R2   0,R1
         AI,R1    -1
         CI,R3    ZERO
         BEZ      *R15              DONE IF ZERO
         BDR,R14  DIVIDE
         LI,R2    ','               YES
         STB,R2   0,R1              MOVE COMMA TO PRINT LINE
         BDR,R1   HEXTODEC          GO ROUN AGAIN
*        CANNOT FALL THRU
         PAGE
*
*        TYPE ACCOUNT/FILE NAME SUBROUTINES
*
TACNT    EQU      %
         LI,R1    BA(CR)
       B       TYPEIO        LINK STILL IN R15
TFILNME EQU       %
         LW,R1    FNEB              LOC OF FILE NAME
       B       TYPEIO        GO TYPE MSG
         PAGE
*
*        MOVE OPTION FIELD#2 INTO CARD COLUMNS 9-12 (BYTES 8-11)
*        NO MATTER WHERE IT WAS ON ORIGINAL CARD
*
REFORMAT EQU      %
         LCI      0
         PSM,R0   PDSTK
         LI,R1    0                 INITIAL INDEX ONTO CARD
         LI,R4    0
         LI,R3    8                 MAX LOOP TO FIND DELIMITER
REFORM0  EQU      %
         LB,R0    INBUF,R1          PICK UP A BYTE
         CI,R0    ' '
         BL       REFORM5           NO OPTION FIELD ON CARD
         BE       REFORM1           THATS A DELIM
         CI,R0    '.'
         BE       REFORM1           SO IS THAT
         CI,R0    ','
         BE       REFORM1           SO IS THAT
         AI,R1    1
         BDR,R3   REFORM0           SCAN TILL WE HIT END OF FIELD
         B        REFORM11          WHOOPS--> LOOP RAN OUT ON VALID STUFF
REFORM1  EQU      %
         AI,R1    1                 STEP OVER THE DELIMITER
REFORM11 EQU      %
         LI,R3    32                MAX LENGTH OF FIELD#2
         LI,R5    0                 SET LEADING BLANKS FLAG
REFORM2  EQU      %
         LB,R0    INBUF,R1          GET NEXT BYTE
         CI,R0    ' '               WHAT KIND OF CHARACTER
         BL       REFORM5           NEW LINE CHARACTER PROBABLY
         BG       REFORM3           MOVE NON-BLANK CHARACTERS
         CI,R5    0                 PASSED ALL LEADING BLANKS YET
         BEZ      REFORM4           NOT YET--> IGNORE LEADING BLANKS
REFORM3  EQU      %
         STB,R0   STACK,R4          STORE THE CHARACTER
         AD,R4    DOUBLEONE         STEP INDEX AND FLAG
REFORM4  EQU      %
         AI,R1    1                 NEXT INCOMING INDEX
         BDR,R3   REFORM2           SCAN ON TILL END
REFORM5  EQU      %
         STW,R4   RANDOM            SAVE COUNT MOVED
         BAL,R0   BINBUF            BLANK THE CARD BUFFER COMPLETELY
         LW,R2    CURMODE           GET
         STW,R2   INBUF             AND STORE THE OPTION COMMAND
         LI,R2    BA(STACK)
         LI,R5    BA(INBUF)+8       BYTE 9 OR WORD TWO BNDRY
         LW,R3    RANDOM            NUMBER OF BYTES IN FIELD 2
         BEZ      %+2               NONE
         BAL,R15  MOVEBYT           MOVE BACK ONTO CARD
         LCI      0
         PLM,R0   PDSTK             RESTORE ALL OF EM
         B        0,R6              RETURN TO CONTROL CARD INTERPRETER
         PAGE
*
*        INTERPRET CARD IN 'INBUF' FOR POSSIBLE
*        FSAVE CONTROL COMMAND
*
INTER    EQU      %
         LW,R7    R15               MOVE LINK TO R7
         LI,R0    0                 PREPARE TO TURN OFF COM
         LI,R1    -#COMMANDS        LENGTH OF TABLES
         LW,R2    INBUF             GET WORD1 IMAGE
         CW,R2    COMS+#COMMANDS,R1 FIND MATCH
         BE       INTER1            GOTCHA
         BIR,R1   %-2               FINISH
         LI,R2    '+'
         CB,R2    INBUF             IS THIS A CONTROL CARD
         BE       INTER4            YES..MUST BE ERROR
         LCI      0                 NOT A COMMAND
         B        1,R7              TAKE EXIT PLUS ONE
INTER1   EQU      %
         STW,R2   CURMODE           SAVE CURRENT OPTION
         STW,R1   CURMODE1          AND THE INDEX TO IT
         BAL,R6   REFORMAT          CHECK OUT THE COMMAND CARD
         LW,R3    INBUF+2           THEN PICK UP OPTION FIELD#2
         CW,R3    OFFCOM            SUPPOSED TO TURN OFF COMMAND
         BNE      INTER2            NO,JUMP
         STW,R0   SWITCH+#COMMANDS,R1 YES,TURN IT OFF
         B        INTER3            AND EXIT
INTER2   STW,R2   SWITCH+#COMMANDS,R1 SET COMMAND SWITCH
         CW,R2    COMDAY            IS IT +DAY (ANOTHER SPECIAL CASE)
         BE       %+3               YES, DON'T SWEAT IF NOTHING THERE
         CW,R3    BLANK             ANYTHING THERE
         BE       INTER3            NO,JUMP
         LW,R3    SWITCH1+#COMMANDS,R1 SUPPOSED TO HAVE ONE
         BEZ      INTER3            NO,NO FIELD2
         PSW,R7   PDSTK             SAVE R7 IN CASE 4 WORD OPTION
         LC       R3                GET FIELD LENGTH
         LM,R4    INBUF+2           GET FIELD 2
         STM,R4   0,R3              MOVE TO BUFFER
         PLW,R7   PDSTK             RESTORE R7
         CW,R2    COMDAY            SPECIAL CASE FOR +DAY
         BNE      INTER3            NOT +DAY
         CW,R4    BLANK             ANY DAY SPECIFIED
         BE       INTER22           NO, USE TODAY'S DATE
         LI,R1    0                 INDEX
INTER21  LB,R6    R4,R1             GET A CHAR.
         CI,R6    '0'               CHECK TO
         BL       INTER5            SEE IF
         CI,R6    '9'               A VALID
         BG       INTER5            NUMBER
         CI,R1    5                 DONE YET
         BGE      INTER3            YUP
         AI,R1    1                 INDEX
         B        INTER21
INTER22  EQU      %                 DATE LEFT OUT..USE TODAY
         LCI      2
         LM,R4    BKUPVLP+1
         SLS,R5   16                LEFT JUSTIFY YEAR
         STD,R4   SAVEDATE
INTER3   CW,R2    ENDCOM            WAS THIS COMMAND END
         BE       1,R7              YES,NO MORE INPUT
         LCI      8                 ELSE SET COMMAND CODES
         B        0,R7              AND EXIT
INTER4   EQU      %                 UNRECOGNIZED CONTROL CARD
         LI,R1    BA(XMSSG)         PRINT ERROR
         BAL,R15  TYPEIO            MESSAGE
         LI,R15   XMSSG             PRINT ON
         CAL1,2   PRNT15            M:LL ALSO
         B        FPEXIT            AND GO BYEBYE
INTER5   EQU      %                 INVALID DATE ON +DAY
         LI,R1    BA(XMSSG1)
         BAL,R15  TYPEIO
         LI,R15   XMSSG1
         CAL1,2   PRNT15
         B        FPEXIT
         PAGE
*
*        CHECK IF CURRENT ACCOUNT # MATCHES
*        CURRENT DATA CARD
*
*
*        RETURNS:
*         'ALL'   =  -1 IF 'ALL' FILES MODE
*                 =   0 IF NOT
*
*
*        'ACEQU'  =  -1 IF ACCOUNT# EQUAL
*                 =   0 IF NOT EQUAL
*                 =   1 IF NOT EQUAL YET
*
ACCK     EQU       %
         LI,R2     0                *
         LI,R4    BA(ACN#CURNT)
         LI,R5    BA(INBUF)
         LI,R3    8                 WANT TO CHECK CURRENT # VERSS CARD
         BAL,R7   CBYTE             GO CHECK EM
         BE       ACE               GOTCHA
         BL       MODECK            CURRENT IS LESS THAN REQUESTED
         STW,R2   ALL               CLEAR ALL
         LI,R2    1                 SET CURRENT IS GREATER THAN REQUEST
MODECK   STW,R2    ACEQU            NO-SET ACCOUNTS ARE NOT EQUAL
         CI,R2    0                 SET CC'S FOR RETURN
         B         *R15             AND RETURN
ACE      LI,R2    -1                SET ACCOUNT EQUAL FLAG
         LI,R0     0              * ASSUME NO FILE NAME ON CARD
         LW,R1    INBUF+3           CHK ASSUMPTION
         BNEZ     %+2             * THERE IS A NAME ON CARD
         LI,R0    -1                NO NAME FOUND-ALL FILES IN ACN
         STW,R0    ALL              SAVE ALL FILES FLAG
         B         MODECK           AND SET 'ACEQU'
         PAGE
*
*        THIS ROUTINE READS CARDS FROM THE DEVICE WHILE WE
*        ARE BUILDING THE SORTED FILE
*
RCD      EQU      %
         MTW,0    END
         BNEZ     *R14              ALREADY READ LAST CARD
         BAL,R0   BINBUF            BLANK THE INPUT BUFFER
         CAL1,1   READSI            READ A CARD
         LW,R1    INBUF
         CW,R1    ENDCOM            LAST CARD
         BNE      RCD1              NOPE
RCD0     EQU      %
         STW,R1   END               SAY LAST CARD
         B        *R14              AND RETURN
RCD1     EQU      %
         LI,R2    -#COMMANDS
         CW,R1    COMS+#COMMANDS,R2 SEE IF THIS IS A COMMAND
         BE       RCD2              **COMMAND FOUND
         BIR,R2   %-2
         AI,R14   2                 NOT A COMMAND--JUMP TO BUILD FILE
         B        *R14              NOT A COMMAND
RCD2     MTW,0    DATACARDS         ARE WE BUILDING THE FILE
         BEZ      *R14              NO--> GO EXAMINE THIS COMMAND
         STW,R1   CURMODE           YES-> CHANGE THE CURRENT OPTION
         STW,R2   CURMODE1          SAVE THE INDEX TO IT
         LW,R1    LPFLAG            WRITING THE LP
         BEZ      RCD               NOPE-> GO ON
         CAL1,1   WRTLL             ELSE ECHO THIS CARD TO LP
         B        RCD               AND READ ANOTHER CARD
*
*        ANY ERROR/ABNORMAL FROM M:SI COMES HERE
*
SETENDUP EQU      %
         LW,R1    ENDCOM
         B        RCD0              STORE IT AND EXIT
         PAGE
*
*        PLACE ALL BLANKS INTO CARD INPUT BUFFER
*
BINBUF   EQU      %
         PSW,R0   PDSTK             SAVE RETURN LINK
         DO       SIGMA7=0
         LI,R1    -20
         LI,R0    0
         STW,R0   INBUF+20,R1
         BIR,R1   %-1
         ELSE
         LCI      3
         LM,R0    DBLANK
         STM,R0   INBUF             BLANK COLUMNS 1 THRU 12
         LI,R0    0                 AND ZERO THE REST OF THE CARD
         LW,R1    INBUFBA
         MBS,R0   0
         FIN
         PLW,R0   PDSTK
         B        *R0
SYNMSG   TEXT     ' SYN'
         PAGE
*
*        ERROR/ABNORMAL FROM STATISTICS FILE
*
OPNPOABN EQU      %
OPNPOERR EQU      %
         LB,R15   R10
         CI,R15   3                 DISKPOOL NOT FOUND
         BNE      POERR             NO-SOME OTHER ERROR
         MTW,-2   POFCN             SET FPT TO OUT
         CAL1,1   OPENPO            CREATE DISKPOOL
         CAL1,1   CLSPO             SAVE IT
         MTW,2    POFCN             RESET  TO INOUT
         CAL1,1   OPENPO            OPEN INOUT
         B        *R8               AND RETURN..
POERR    EQU      %
         LI,R15   0                 ASSUME WE'LL NEVER GET M:PO OPEN:
         STW,R15  STATS               GIVE UP ON STATS REPORT.
         LI,R15   FILERROR          PRINT ERROR MESSAGE
         CAL1,2   PRNT15            ABOUT PROBLEM
         B        *R8               RETURN TO CAL+2
         PAGE
*
*        THIS ROUTINE ONLY READS DATA CARDS FROM THE SORTED FILE -
*        IT IS NOT USED TO READ RECORDS FROM A DEVICE (CARD READER OR
*        COC TERMINAL)
*
*        NOTE THAT NEW LINES AND STUFF WERE REMOVED BEFORE THESE
*        RECORDS WERE WRITTEN - SO THIS ROUTINE JUSTS READS.
*
RD:COM   EQU      %
         STW,R14  SORT              SAVE LINK
         MTW,0    END
         BNEZ     *SORT             ALREADY SEEN LAST DATA CAD
         CAL1,1   READSI            READ A CARD
         LI,R1    7
         LS,R1    M:SI              CHEK WHERE MM:SI COMES FROM
         CI,R1    1
         BNE      *R14              NOTHING TO DO
         LW,R2    INBUF+19
         CW,R2    CURMODE           SAME OPTION AS BEFORE
         BE       RD:COM1           YUP
         LI,R0    0
         LW,R1    CURMODE1
         STW,R0   SWITCH+#COMMANDS,R1
RD:COM1  EQU      %
         LI,R1    -#COMMANDS
         CW,R2    COMS+#COMMANDS,R1
         BE       RD:COM2
         BIR,R1   %-2
         B        *SORT
RD:COM2  EQU      %
         STW,R2   SWITCH+#COMMANDS,R1 TURN ON NEW OPTION
         STW,R1   CURMODE1          SAVE INDEX
         STW,R2   CURMODE           AND NAME
         B        *SORT
         USECT    DATASEC
CURMODE  DATA     0
CURMODE1 DATA     0
         USECT    PROCED
         PAGE
*
*        CHECK CURRENT FILE NAME AGAINST DATA CARD
*
*        DATA CARD STRING STARTS IN CC14
*        CURRENT FILE NAME IS IN 'BOFBUF+2'
*
*
CBYTE    EQU      %
         DO       SIGMA7=0
         LB,R1    0,R4              GET INPUT BYTE
         CB,R1    0,R5              COMPARE TO CURRENT ACCOUNT/FILE
         BNE      1,R7
         AI,R4    1                 EQUAL MEANS BUMP
         AI,R5    1                 INDEX VALUES
         BDR,R3   CBYTE             AND CONTINUE WITH COUNT
         B        *R14              AND RETURN-FIELDS ARE EQUAL
         ELSE
         STB,R3   R5                SET COUNT
         CBS,R4   0
         B        0,R7              RETURN AND LET CALLER FIGURE IT OUT
         FIN
         PAGE
*
*        ACNCFU DISC ADDRESS ERROR
*
READFAIL EQU      %
         DO       CPVC00
         LW,R8    ACNCFU+8          DUAL ACCT DIR GRANULE
         BAL,R15  DTOGRAN           CHECK FOR VALID ADDR
         B        READFAIL1         BAD DISK ADDR
         B        GETAD             TRY ALTERNATE DIR GRANULE
READFAIL1 EQU     %
         FIN
         LI,R15   RF1
         CAL1,2   PRNT15
         M:SNAP   'ACNCFU',(ACNCFU,ACNCFU+3)
         B        READFAILX          MUST ABORT ON THIS ERROR
         PAGE
*
*        ACCOUNT DIRECTORY LINK FAILURE
*
READFAIL2 EQU     %                 LINKAGE FAILURE IN AD
         DO       CPVC00=1
         LI,R8    0
         XW,R8    ADDUAL            HAVE WE TRIED DUAL ACC GRAN YET
         BE       READFAIL2A        YES - REPORT ERROR
         BAL,R15  DTOGRAN           VERIFY ADDRESS
         B        READFAIL2A        NO GOOD
         B        GETAD             TRY ALTERNATE DIR GRANULE
READFAIL2A EQU    %
         FIN
         LW,R13   LASTAC            PLACE LAST AD ADDRS IN R13
         LW,R14   ACBLINK
         LW,R15   ACFLINK
         M:SNAP   'ACLINK',(ACBUF,ACBUF+3)
         LI,R15   RF3
         CAL1,2   PRNT15
         B        READFAILX         MUST ABORT
         PAGE
*
*        LINK FAILURE IN FILE DIRECTORY
*
READFAIL3 EQU     %
         DO       CPVC00=1
         LI,R8    0
         XW,R8    FDDUAL            HAVE WE TRIED DUAL FD GRAN YET
         BE       READFAIL3A        YES - REPORT ERROR
         BAL,R15  DTOGRAN           VERIFY ADDRESS
         B        READFAIL3A        NO GOOD
         B        GETFDA            BRANCH TO LOAD UP REGISTE@S
READFAIL3A EQU    %
         FIN
         LW,R13   LASTFD
         LW,R14   FDBLINK
         LW,R15   FDFLINK
         M:SNAP   'FDLINK',(FDBUF,FDBUF+3)
         LI,R15   RF4
         CAL1,2   PRNT15
         B        ENDOFD            LOG END OF ACCOUNT
         PAGE
*
*        LINK FAILURE IN INDEX CHAIN
*
READFAIL5 EQU     %
         LI,R15   RF5
         CAL1,2   PRNT15
         B        MIXSNAP           SNAP/CLEANUP,ETC...
*
*
READFAILX EQU     %
         B        ENDUP             AND EXIT
         PAGE
*
*        PRINT AND CLEAR LINE SUBROUTINE
*
LPRINT   EQU      %
         MTW,0    LIST              LISTING MODE ON
         BEZ      *R15              NOPE..EXIT
         CAL1,1   WRTPBUF           WRITE THE PRINT LINE
         DO       SIGMA7=0
         LI,R1    -34
         LI,R0    0
         STW,R0   PBUF+34,R1        CLEAR PRINT LINE
         BIR,R1   %-1
         ELSE
         LW,R1    PBUFBA
         LW,R0    Y4                GET CHAR FOR MBS
         MBS,R0   0                 ZAP PRINT LINE
         FIN
         B        *R15
         PAGE
*
*        SNAP AREA POINTED TO BY R3 AND THE NUMBER
*        OF BYTES IN R1
*
PLIST    EQU      %
         MTW,0    LIST              LIST MODE SET..
         BEZ      *R15              NO--> RETURN
         AI,R1    -1                TRUNCATEE COUNT TO GET UPPER LIMIT
         SLS,R1   -2                MAKE TOTAL WORDS
         LW,R4    R3                BASE ADDRS
         AW,R4    R1                ADD EM UP
         AND,R3   M17
         AND,R4   M17               DEBUG DOESN'T LIKE EXTRA BITS
         M:SNAP   '    ',(*R3,*R4)
         B        *R15              AND RETURN
         PAGE
*
*        BUILD/MOVE TO PRINT LINE SUBROUTINES
*
*
BUFSET   EQU       %
         LB,R3    0,R1              R3 = NO OF BYTES TO PRINT
         AI,R1    1                 R1 = SBA OF MESSAGE
CLRBUF   EQU      %
         DO       SIGMA7=0
         LI,R5    -34
         LI,R0    0
         STW,R0   PBUF+34,R5
         BIR,R5   %-1
         ELSE
         PSW,R1   PDSTK
         LW,R1    PBUFBA
         LW,R0    Y4                GET CHAR FOR MBS BUFFER BLANKING
         MBS,R0   0                 ZAP LAST PRINT LINE
         PLW,R1   PDSTK             RESTORE R1
         FIN
BUFSET1  EQU      %
         DO       SIGMA7=0
         LW,R4    R1                SBA TO R4
         LB,R5    0,R4              GET A BYTE
         STB,R5   PBUF,R2           MOVE TO PRINT LINE
         AI,R4    1                 INCREMENT SBA
         AI,R2    1                 INCREMENT PBUF INDEX
         BDR,R3   %-4               FINISH UP
         ELSE
         LI,R5    BA(PBUF)          DESTINATION BA
         LW,R4    R1                SOURCE BA
         AW,R5    R2                DISP IN PRINT LINE
         STB,R3   R5                SET COUNT
         MBS,R4   0                 MOVE MSG STRING
         FIN
         B        *R15
         PAGE
*
*        WRITE PRINT LINE SUBROUTINE
*
PRINT    EQU       %
         MTW,0    LIST              LISTING MODE ON
         BEZ      *R15              NNOPE..EXIT
         CAL1,1   WRTPBUF
         B         *R15
SPACE    EQU       %
         MTW,0    LIST              LISTING MODE ON
         BEZ      *R15              NOPE..EXIT
         CAL1,1   WRTBLNK
         B         *R15
         PAGE
*
*        FILE MANAGEMENT ERROR FROM SORT FILE
*
SOERR    EQU      %
SOABN    EQU      %
         LI,R15   SOMSG
         CAL1,2   PRNT15            PRINT ERROR MSG
         M:SNAP   ' '
         CAL1,9   3                 ABORT RUN
         PAGE
*        SEND MSG TO OPERATOR'S CONSOLE
*
*        TYPEIO2 IS ENTRY FOR R1 = BA OF TEXTC MSG
*        TYPEIO  IS ENTRY FOR R1 = BA OF TEXT MSG AND R3 = BYTE COUNT
*
TYPEIO   EQU      %
         LB,R3    0,R1
         AI,R1    1
TYPEIO2  EQU      %
         LI,R2     3
         AND,R2    R1
         SLS,R1    -2             WORD ADDRESS OF MESS BUFFER IN R1
         CAL1,1   WRTOC
         B        *R15
         PAGE
*
READSI2  GEN,8,24  X'10',M:SI
         GEN,8,24  X'F0',16
         DATA     NOEOR1,NOEOR1
         DATA     PBUF,80
INBUFBA  GEN,8,24  17*4,BA(INBUF+3)
*
BOFBUFBA GEN,8,24  10*4,BA(BOFBUF+2)   **FIRST TEN WORDS OF NAME SLOT
         PAGE
*
*
*        MESSAGES/TEMP CELLS/ETC....
*
*
*
         USECT    PROCED
GETPAGES GEN,8,24 8,20
         BOUND    8
DBLANK   DATA     X'40404040',X'40404040'
         DATA     X'40404040',X'40404040'
DZERO    DATA     0,0,0,0
MAXTBUF  DATA     1,6               MAX TAPE BUFFER LIMITS (PAGES)
*
DOUBLEONE DATA    1,1
DSTKPNTR DATA     STACK-1
         GEN,1,15,1,15   1,STACKSIZE,1,0
         DATA     0,0
*
TEMPPNTR DATA     TEMPSTK+1
         DATA     X'80788000'
         DATA     0,0
*
         DO       UTS=0
SLPSD    GEN,10,22 2,SLV:EXIT       NON-MAPPED
         ELSE
SLPSD    GEN,10,22 3,SLV:EXIT       OR MAPPED
         FIN
         DATA     0
         DO       FILL=1
TIMFPT1  GEN,8,1,23  X'10',1,DATBUF+3     M:TIME
         ELSE
TIMFPT1  GEN,8,24 X'10',DATBUF+3
         FIN
CLSEO    GEN,8,24 X'15',M:EO
         PZE      *X'20'
         DATA     1
WRTPBUF  GEN,8,24 X'11',M:LL
         GEN,8,24 X'34',0
         DATA     PBUF,132,0
*
WRTBLNK  GEN,8,24 X'11',M:LL
         DATA     X'30000000'
         DATA     BLANK,4
READSI   GEN,8,24 X'10',M:SI
         GEN,8,24 X'F0',16
         DATA     SETENDUP,SETENDUP,INBUF,80
WRTOC    GEN,8,24 X'11',M:OC
         DATA     X'34000000'
         PZE      *R1               BUFFER ADDRESS IN R1
         PZE      *R3               SIZE IN R3
         PZE      *R2               BTD IN R2
PBUFBA   GEN,8,24 132,BA(PBUF)      FOR BUFFER BLANKING
*
CLSLL    GEN,8,24  X'15',M:LL
         PZE      *0
         DATA     2                 IN CASE M:LL WENT TO FILE
*
OPEN:LL GEN,8,24  X'14',M:LL
        DATA      0                *****IN CASE M:LL ASSIGNED TO FILE
*
PAGEFPT  GEN,8,24 X'04',M:LL
         USECT    DATASEC
LLHDR    GEN,8,24 X'26',M:LL
         DATA     X'C0000000'
LLHDRB   DATA     PRTMESS
         DATA     1                 PRINT LINE POSITION
POBUFSZ  EQU      7                 ALLOW ROOM FOR RAD AND PACK GRANS
OPENPO   GEN,8,24 20,M:PO
         DATA     X'F7480001'
         DATA     OPNPOABN
         DATA     OPNPOERR
         DATA     POBUF
         DATA     POBUFSZ*4
         DATA     2
         DATA     2
POFCN    DATA     4,2,15
OPENPOVLP EQU     %                 WE'LL NULL VLP IF PRIVATE PACK.
         DATA     X'01000303'
         TEXTC    'DISKPOOL'
         DATA     X'02010202'
         TEXT     '99999999'
         USECT    PROCED
WRTPO    GEN,8,24 17,M:PO
         DATA     X'08000050'       KEY/WAIT BITS
         DATA     POKEY
CLSPO    GEN,8,24 21,M:PO
         DATA     X'80000000'
         DATA     2
*
*
         DO       TAURUS>0
OPNERFIL GEN,8,24 X'14',M:EI        OPEN ERRMSG FILE
         DATA     X'C7480001'
         DATA     ERRADD
         DATA     ERRADD
         DATA     2                 KEYED FILE
         DATA     2                 DIRRECT ACCESS
         DATA     1                 INPUT
         DATA     2                 SAVE
         DATA     4                 MAX KEY SIZE
         DATA     X'01000202'
         TEXTC    'ERRMSG'          FILE NAME
         DATA     X'02010202'
         TEXT     ':SYS    '        ACCOUNT
READERFIL GEN,8,24 X'10',M:EI
         DATA     X'F8000000'
         DATA     ERRADDRD
         DATA     ERRADDRD
         PZE      *R3               BUFF
         PZE      80                SIZE
         PZE      *R3               KEYAD
CLOSE    GEN,8,24 X'15',M:EI
         DATA     X'80000000'
         DATA     2                 SAVE
*
*
         FIN
*
*
         USECT    DATASEC
OPNTAPE  GEN,8,24 20,M:EO
         DATA     X'E9040040'
         DATA     OPNABN
         DATA     OPNERR
         DATA     BUF
         DATA     15
         DATA     2
         DO1      CPV>=2
DEVFPT   GEN,16,16 0,'9T'
         DO       UTS=0
DEVFPT   DATA     X'18A00'
         ELSE
         DO       CPV<2
DEVFPT   GEN,16,16 0,'MT'
         FIN
         FIN
         DATA     X'08010101'       OUTSN
         DO       FILL=1
REELSN   TEXT     '01A0'
         TEXT     '00AA'            LOWEST VALID FILL TYPE INSN
LOW      EQU      %
         TEXT     '99Z9'            HIGHEST VALID FILL TYPE INSN
HI       EQU      %
         ELSE
REELSN   TEXT     'PRG1'
         FIN
BUF      TEXT     ' '
         USECT    PROCED
         DO       UTS=0
STKMS    TEXTC    ' ***BPM STACK SIZE TOO SMALL'
         FIN
LESSTHAN EQU      %
   TEXTC ' NOT ENOUGH CORE TO RUN, LESS THAN 5 PAGES AVAILABLE.'
READC    GEN,8,24 X'10',M:C
         GEN,4,20,8  X'F',0,16
         DATA     SETENDUP,SETENDUP
         DATA     INBUF,80
WRTLL    GEN,8,24 X'11',M:LL
         GEN,4,28 3,0
         DATA     INBUF,80
PRNT15   EQU      %
         GEN,8,24 X'01',0
         PZE      *0
         PZE      *15               MSG ADDRS IN R15
TYP15    GEN,8,24 X'02',0
Y8       PZE      *0
         PZE      *15
TRUNCMSG TEXTC '#DATA BUFFER DISMISSAL EVENTS'
TRUNC1MSG TEXTC '  TRUNCATED:'
TRUNC2MSG TEXTC   '  SCHEDULED:'
NLINES   GEN,8,24 X'2A',M:LL        NLINES FPT (LINES REMAINING ON PAGE)
         PAGE
*
*
         USECT    DATASEC
*
9LOC     DATA     0                 LOC OF NINE ENTRY IN :BOF RECORD
         DO1      UTS<=0
NEWQ     DATA     0                 CORE ADDRESS OF NEWQ
NEXACN   DATA     0                 NEXT ACN INDEX
NEXFILE  DATA     0                 NEXT FD INDEX
ACSIZE   DATA     0                 SIZE OF CURRENT AC SECTOR
FDSIZE   DATA     0                 SIZE OF CURRENT FD SECTOR
ACNSIZE  DATA     0                 #OF BYTES IN CURRENT ACCOUNT
PAGETOTAL DATA    0                 TOTAL PAGES GOTTEN
DAPAGES  DATA     0                 TOTAL DATA BUFFER PAGES
TAPAGES  DATA     0                 TOTAL TAPE BUFFER PAGES
INDPAGES DATA     0                 TOTAL INDICES BUFFERS
ACNGRAN  DATA     0                 #GRANULES IN CURRENT ACCOUNT
EAADDR   DATA     EASECT            *END ACTION PAGE VIRTUAL WA
EAPHYADR DATA     0                 *END ACTION PAGE PHYSICAL WA
EOTFLAG  DATA     EOTBIT            *END OF REEL FLAG
MIXSTAT  DATA     MIX:STAT          *
MIXCNT1  DATA     MIX:CNT1          *
MIXCNT2  DATA     MIX:CNT2          *
PACKGRAN DATA     0                 *# OF PACK GRANULES
RADGRAN  DATA     0                 *# OF RAD
RECNT    DATA     0                 * # OF RECORD IN FILE
DEFER    DATA     255
SCR      DATA     0                 KEYM+1 COUNT SAVED HERE
SCR1     DATA     0                 # OF WORDS IN KEY (BYTE COUNT FORM)
SCR2     DATA     0                 KEY BYTE COUNT/FLAGS/4 BYTES OF DATA
CURACN   DATA     0                 CURRENT INDEX TO ACN DIRECTORY
ENDOFSET DATA     0                 END OF TAPE REEL VOLUMNS FLAG
CURFILE  DATA     0                 CURRENT FILE DIRECTORY INDEX
LASTAC   DATA     0                 LAST ACN SECTOR DISC ADDRESS
LASTFD   DATA     0                 LAST FD  SECTOR DISC ADDRESS
FILESIZE DATA     0   #OF TOTAL DATA BYTES BY MASTER KEYS
BLKDBYTES DATA  0    #OF TOTAL DATA BYTES SENT TO TAPE
FNEA     GEN,8,24 0,BA(FITBUF+3)
FNEB     GEN,8,24 0,BA(BOFBUF+2)
         DO       UTS=0
FNEC     GEN,8,24 0,BA(PBUF)+18
         ELSE
FNEC     GEN,8,24 0,BA(PBUF)
         FIN
TOTLFILS DATA     0
SYNFLAG  DATA     0                 CURRENT FILE=SYNON FLAG
VOLUME   DATA     0                 USER SUPPLIED SERIAL # FLAG
ALL      DATA     0                 DO ALL FILES IN CURRENT ACCOUNT
MYACCT   DATA     0,0               SAVE RUNNING ACCOUNT DURING PPOPEN
ACEQU    DATA     0                 ACCOUNT# EQUAL TO DATA CARD FLAG
         USECT    PROCED            ****PROCEDURE HERE*****
*
*
*
9ENTRY   DATA,1   9,1,2,2
Y05      GEN,8,24   5,0
CVMFPT   GEN,8,24   X'87',3
         GEN,8,24   X'80',8
*
GTPG     GEN,8,24   X'88',R1
FREPG    GEN,8,24   9,1
*
ORGTX    TEXT     'CON'
         TEXT     'CON'
         TEXT     'KEYD'
         TEXT     'RAN'
*
TOTAPMS  TEXTC    '#TAPES USED:'
TOTFMS   TEXTC    '#FILES PROCESSED:'
*
RAMSG    TEXTC    '# OF READ-AHEAD ERRORS:'
FITRA    TEXTC    '  FITS:'
MIXRA    TEXTC    '  MIX:'
DATARA   TEXTC    '  DATA:'
DINFO1   TEXTC    '# OF I/O ACCESS''S:'
DINFO11  TEXTC    '  TAPE:'
DINFO2   TEXTC    '  PACK:'
DINFO3   TEXTC    '  RAD:'
TOTAMS   TEXTC    '#ACCOUNTS PROCESSED:'
STATISTICS EQU    %
         DO       CPV>0
   TEXTC '* * * C P - V   F S A V E   S T A T I S T I C S * * *'
         ELSE
         DO       UTS>0
  TEXTC '* * * U T S   F S A V E   S T A T I S T I C S * * *'
         ELSE
  TEXTC '* * * B P M   F S A V E   S T A T I S T I C S * * *'
         FIN
         FIN
ACMESS   EQU      %
   TEXTC ' ***FILE DIRECTORY ADDRESS ERROR IN ACCOUNT KEY'
FNERR    EQU      %
         TEXTC '**FILE NAME IN FIT DOES NOT MATCH FD KEY'
ACNCFUMS TEXTC    '****ACNCFU TABLE****'
TPWRTERR EQU      %
   TEXTC ' IRRECOVERABLE TAPE WRITE ERROR'
FDRMSG   TEXTC    '**FILE DIRECTORY'
FITMSG1  TEXTC    '**FILE INFO TABLE'
MIXMSG1  TEXTC    '**INDEX SECTOR'
ADRMSG1  TEXTC    '**ACCOUNT DIRECTORY'
BLNKBYT  TEXTC    ' '
SYNCMSG  TEXTC    '  MULTIPLE HITS: '
TEN      DATA     10
ICONKEY  DATA     X'02FFFFFF'       INITIAL VALUE OF
ZERO     EQU      0
SYSFPT   DATA     X'08000000'
M16      DATA     X'0000FFFF'
YFF      GEN,8,24 -1,0
MFF      GEN,24,8 0,-1
FILERROR TEXTC    '*** ERROR UPDATING STATS FILE'
SYNERR   TEXTC    'SYNON FILE CANNOT BE SAVED'
XMSSG    TEXTC    ' UNRECOGNIZED CONTROL CARD..RUN ABORTED'
XMSSG1   TEXTC    ' INVALID DATE ON +DAY COMMAND'
RF1      TEXTC    ' CANNOT READ FIRST ACCOUNT DIRECTORY SECTOR'
RF3      TEXTC    ' LINK FAILURE IN ACCOUNT DIRECTORY'
RF4      TEXTC    ' LINK FAILURE IN FILE DIRECTORY'
RF5      TEXTC    ' LINK FAILURE IN INDEX CHAIN'
SOMSG    TEXTC    ' I/O ERROR FROM SORT FILE (OUTPUT PHASE) '
NO%DMPMSG TEXTC   ;
  '** FOLLOWING FILE SKIPPED DUE TO NO-BACKUP BIT IN FD KEY **'
*
MONTHTAB EQU      %
         TEXT     '   '
         TEXT     'JAN'''
         TEXT     'FEB'''
         TEXT     'MAR'''
         TEXT     'APR'''
         TEXT     'MAY'''
         TEXT     'JUN'''
         TEXT     'JUL'''
         TEXT     'AUG'''
         TEXT     'SEP'''
         TEXT     'OCT'''
         TEXT     'NOV'''
         TEXT     'DEC'''
MONTABL  EQU      WA(%)-WA(MONTHTAB)-1
         DO       UTS>0
FS:MSG   TEXTC    'F00 FSAVE HERE'
PROMP    GEN,8,24 X'2C','<'
         FIN
MONTHN   TEXT     '0101020304050607080910111200'
         USECT    DATASEC
*
POKEY    GEN,8,24 11,0
         DATA     0,0
*
         USECT    PROCED
NOTFOUND TEXTC    '*** FOLLOWING FILES WERE NOT FOUND ***'
NOTFOUND1 TEXTC   'ACCOUNT#    FILE NAME '
FILEMSG  EQU      %-3
FDMESS   EQU      %
   TEXTC '  ***FIT DISC ADDRESS ERROR IN FILE DIRECTORY KEY'
MASK     DATA     X'FFFE'
M17      DATA     X'1FFFF'
M9       DATA     X'1FF'
Y4       DATA     X'40000000'
Y3       GEN,4,28 3,0
Y2       GEN,4,28 2,0
MF       DATA     15
FILSMSG  TEXTC    '#FILES SKIPPED:'
FITMESS  TEXTC    ' ERROR IN FILE INFORMATION TABLE'
NO:DTMSG TEXT     'NONE'
DASHMSG  TEXTC    '--------'
MIXMESS  TEXTC    ' ERROR IN MASTER INDEX'
SKIPFILMS TEXTC   '**** FOLLOWING FILE PARTIALLY SAVED ***'
         DO       UTS=0             BPM HEADER
PRTMESS  EQU      %
   TEXTC 'VOLUMN                FILE NAME          ',;
         '  GRANULES    BYTES        ORG    TYPE',;
         '    PASSWORD    DATE    HOUR        COMMENTS'
         ELSE
PRTMESS  TEXTC    ' FILE NAME        GRANULES  ',;
                  'BYTES   ORG     CREATION    ',;
                  'EXPIRES     ',;
                  'ACCESSED        ',;
                  'MODIFIED        ',;
                  'BACKED-UP       ',;
                  'PASSWORD    ',;
                  'READ'
*
ONLNHDR  TEXTC    ' FILE NAME        GRANULES  ',;
                  'BYTES   ORG     RECORDS'
         FIN
BIASMASK DATA     X'7FE00'
         USECT    DATASEC
TAP:ERR  DATA     0
ASKBUF   RES,1    8                 KEYIN BUF FOR BAD MF
FDA      DATA     0                 FIRST INDEX SECTOR DISC ADDRS
FITDA    DATA     0                 ADDRESS OF CURRENT FIT ON DISC
         DO       CPVC00=1
ADDUAL   DATA     0                 DUAL ACCT DIR GRANULE
FDDUAL   DATA     0                 DUAL FD GRANULE
         FIN
         PAGE
*
*        UTS FILE DATE TABLES
*
         USECT    PROCED
DATE:TAB EQU      %
         DATA     #DATES            GENERATE TABLE LENGTH
         DATA     BKP:DATE          LAST BACKUP DATE
         DATA     MOD:DATE          LAST MODIFICATION DATE
         DATA     ACC:DATE          LAST ACCESS DATE
         DATA     EXP:DATE          EXPIRATION DATE
         DATA     CRE:DATE          CREATION DATE
         DATA     FILE%PASWRD
         DATA     READ:AC
#DATES   EQU      WA(%)-WA(DATE:TAB)-1
*
*
DATE:PS  EQU      %
         DATA,1   0,25,21,17,14,11,29,32
         BOUND    4
*
DATE:FLD DATA,1   0,1,2,3,4,5,0,0
         BOUND    4
*
         USECT    DATASEC
*
*
READ:AC  DATA     0,0
BKP:DATE DATA     0,0
MOD:DATE DATA     0,0,0
ACC:DATE DATA     0,0
EXP:DATE DATA     0,0
CRE:DATE DATA     0,0
*
*
LPR      DATA,1   0,0,' ',0
RPR      DATA,1   0,':','0','0'
BLD:DATE DATA     0,0,0
*
*
HOUR:DI  DATA,1   #DATES,0,0,0,-1,-1
         BOUND    4
         PAGE
*
*        ACCEPTABLE CONTROL COMMANDS FOR FSAVE
*
         USECT    PROCED
COMS     EQU      %
         TEXT     '+DEB'            DEBUG (NO LONGER USED THO)
         TEXT     '+LOG'
         TEXT     '+BLO'            DUMP OUTPUT BLOCKS
         TEXT     '+LIS'            LIST FILE INFO ON M:LL
         TEXT     '+IND'            DUMP EACH INDEX SECTOR
         TEXT     '+FIT'            DUMP EACH FIT SECTOR
         TEXT     '+TAB'            DUMP TABLES AFTER EACH FILE
         TEXT     '+DIR'            DUMP EACH AD/FD SECTOR
         TEXT     '+SOR'            SORT DATA CARDS
         TEXT     '+DUM'            PRODUCE OUTPUT TAPE
         TEXT     '+ACN'            USE PROVIDED ACN#
         TEXT     '+SIZ'            CHANGE TAPE BUFFER SIZE
         TEXT     '+LBL'            USE PROVIDED SERIAL#
         TEXT     '+PAC'            WORK WITH PRIVATE PACKS                 LMSC
ENDCOM   TEXT     '+END'            ENDS INPUT STREAM
COMSEL   TEXT     '+SEL'            SELECT ONLY
         TEXT     '+STA'            START AT
         TEXT     '+STO'            STOP AT
COMSKI   TEXT     '+SKI'            SAVE ALL SKIPPING
COMDAY   TEXT     '+DAY'            SAVE BY DATE PROVIDED OR TODAY
         TEXT     '+HOU'            SAVE BY HOUR PROVIDED
         TEXT     '+VOL'            INSN SPECIFIED BY USER
         TEXT     '+DEV'            DEVICE TYPE
#COMMANDS EQU     WA(%)-WA(COMS)    LENGTH OF TABLE
         PAGE
*
*        COMMAND SWITCHES,PARALLEL TO COMS
*
         USECT    DATASEC
SWITCH   EQU      %
         DATA     0                 DEBUG SWITCH
LOGSW    DATA     1                 DEFAULT RUN MODE
BLOCKS   DATA     0
LIST     DATA     1                 DEFAULT CONDITION
INDEX    DATA     0
FITLISTSW DATA    0
TABLES   DATA     0
DIRLISTSW DATA    0
SORT     DATA     1
DUMP     DATA     0
ACNSW    DATA     0
SIZCHK   DATA     0
LBLSW    DATA     0
PRIVATE  DATA     0                 DEFAULT IS PUBLIC FILE SYSTEM           LMSC
         DATA     0
SELECT   DATA     0
STARTSET DATA     0
STOPAT   DATA     0
SKIP     DATA     0
SAVBYDATE DATA    0
SAVBYHOUR DATA    0
CCVOL    DATA     0                 INSN SPECIFIED BY USER FLAG
CCDEV    DATA     0                 DEVICE SPECIFIED FLAG
LABELEDT DATA     0
         PAGE
*
*        FIELD TWO LEGALITY TABLE;
*
*        ENTRY SETTINGS:
*        0        NOT LEGAL
*        NON-ZERO FIELD COUNT AND BUFFER POINTER
*
         USECT    PROCED
SWITCH1  EQU      %
         DATA     0                 DEBUG SWITCH1
         GEN,4,28 1,STATS           WORD COUNT/POINTER
         DATA     0                 INDEX 2
         DATA     0                 3
         DATA     0                 4
         DATA     0                 5
         DATA     0                 6
         DATA     0                 7
         DATA     0                 8
         GEN,4,28 1,STATS           INDEX 9
         GEN,4,28 2,ACNBUF+1
         GEN,4,28 1,SIZCHK          PLACE TO DUMP CONTENTS
         GEN,4,28 1,REELSN
         GEN,4,28 4,PACKSN                                                  LMSC
         DATA     0,0,0,0,0
         GEN,4,28 2,SAVEDATE
         GEN,4,28 1,SAVEHOUR
         DATA     0
         PAGE
*
*        REMAINING POINTERS/CELLS FOR RUNNING FSAVE
*
         USECT    DATASEC
*
BRECRTRY DATA     10
BKUPVLP  DATA     X'10000202'
         DATA     0,0
*
*
DATACARDS DATA    0
CRNTLOC DATA      0                 CURRENT LOC IN THE FIT
SAVEHOUR DATA     0
         BOUND    8
SAVEDATE DATA     C'MMDD','YY  '    SECOND WORD IS YEAR
STATS    DATA     0
DEFFLG   DATA     0                 DEFAULT DATE FLAG
OFFCOM   TEXT     'OFF'
ECB      DATA     0                 KEYIN EVENT FLAG
         PAGE
*
*        ACCOUNT/FILE DIRECTORY AND FIT BUFFERS
*
*
         BOUND    8
CARDACN  DATA     0,0
FILE%PASWRD DATA  0,0
BLANK    EQU      DBLANK
INBUF    RES      20
*
PBUF     RES      136/4             PRINT LINE BUFFER
*
ACNCFU   RES      20
*
*
*
         BOUND    8
*
ACBUF    RES      512
*
*
         BOUND    8
*
FDBUF    RES      512
*
*
         BOUND    8
*
*
BOFBUF   RES      132
*
*                                   RECORDS ON TAPE
*
         BOUND    8
PDSTK    DATA     %+1
         DATA     X'400000'
         RES      64
*
TLABUF   EQU      %                 TAPE LABEL BUFFER
         DO1      70
         DATA     0
         PAGE
*        FIT READ-AHEAD TABLES
*
FITBUFWA DATA     0                 CURRENT FIT BUFFER WORD ADDRESS
FITBUF   DATA     0                 CURRENT FIT BUFFER BYTE ADDRESS
*
FITBUFS  DATA     2
         DATA     0,0               SLOTS FOR FIT BUFFER WA'S
*
FITDAS   DATA     2
         DATA     0,0               SLOTS FOR FIT DISC ADDRESSES
*
FITKEY   DATA     2
         DATA     0,0               SLOTS FOR INDEX IN FD
*
         PAGE
*
*        BUFFER MANAGEMENT TABLES
*
*        FOLLOWING EQU'S CONTROL MAXIMUM # OF PAGES
*        THE PROGRAM WILL USE,ESSENTIALLY TABLE DEFINITIONS
*
*
#TBUF    EQU      3
#DBUF    EQU      10
#IBUF    EQU      2
*
         DO       UTS>2
STACKSIZE EQU     #IBUF*120+(#DBUF)  FULL GRANULE INDEX SECTORS
         ELSE
STACKSIZE EQU     #IBUF*64+(#DBUF)  DATA ADDRESS STACK
         FIN
         PAGE
*
*
*        TAPE BUFFER ADDRESS TABLE
*
*
*
TBUFBSY  EQU      %
         DATA     0
TBUF     EQU      %
         DATA     0
         DO1      #TBUF
         DATA     0
         PAGE
*
*
*        DATA BUFFER ADDRESS TABLE
*
*
*
DBUFBSY  EQU      %
         DATA     0
DBUF     EQU      %
         DATA     0
         DO1      #DBUF
         DATA     0
         PAGE
*
*
*        DISC ADDRESS TABLE
*        PARALLEL TO DBUF
*
*
*
RB1      EQU      %
         DATA     0
         DO1      #DBUF
         DATA     0
         PAGE
*
*
*        DISC ADDRESS USE HISTORY TABLE
*        PARALLEL TO DBUF/RB1
*
*
RBHIST   EQU      %
         DATA     #DBUF
         DO1      #DBUF
         DATA     0
         PAGE
*
*
*        INDICES TABLES
*
*
IBUFBSY  EQU      %
         DATA     0
IBUF     DATA     0
         DO1      #IBUF
         DATA     0
INDEXDA  EQU      %
         DATA     #IBUF
         DO1      #IBUF
         DATA     0
         DO1      UTS>0
         USECT    EASECT
MIX:STAT DATA     0
         DO1      #IBUF
         DATA     0
MIX:CNT1 DATA     0
MIX:CNT2 DATA     0
MIX:SW   DATA     0
         PAGE
*
*
*
*
*
*        BLOCKING BUFFER VARIABLE CELLS
*
*
*
         USECT    DATASEC
DCTMASK  DATA     0                 COPY OF DCT%MASK FROM ROOT
HGPTYPE  DATA     0                 USED TO FIND CYL ALLOCATED DEVICES
CURBWA   DATA     0                 WORD ADDRS OF CURRENT BLOCKING BUFFER
CURBUFBA DATA     0                 BA OF CURRENT TAPE BUFFER
TBSIZ    DATA     2048              BYTE COUNT IN ONE TAPE BUFFER
TBPSIZ   DATA     1                 PAGE COUNT IN ONE TAPE BUFFER
TBPWSIZ  DATA     512               WORD COUNT IN ONE TAPE BUFFER
CATCHUP  DATA     0                 >>0 SAYS WE TRYING TO GET GRANULE
END      DATA     0
         BOUND    8
DCTLIM   DATA     1
DCTMAX   DATA     0                 CLM PAIR FOR CHECKING DCT'S
*
CURBUF   DATA     0,0               BUF BASE BA / TOP BA IN THAT BUFFER
*
BUF:LIMS DATA     0,0               BUFFER LOW/HIGH AREA WA'S
CR       TEXTC    ' ACCOUNT#                      '
*
ACN#CURNT EQU     CR+4
VOL#CURNT EQU     CR+7
*
FDBLINK  DATA     0                 BACK LINK CURRENT FD SECTOR
FDFLINK DATA      0                 FWD LINK CURRENT SECTOR
*
ACBLINK  DATA     0                 CURRENT AD SECTOR
ACFLINK  DATA     0                 FWD LINK CURRENT AD SECTOR
*
CSET     DATA     0                 CONTINUED RECORD FLAG
P1P2P3   DATA     0                 MARKER FOR TAPE KEY
KEYM     DATA     0                 KEY MAX BYTE COUNT
MIXEOF   DATA     0                 END OF MASTER INDEX CHAIN FALG
CONEOF   DATA     0                 CONSEC END OF FILE FLAG
GRANULES DATA     0                 GRANULE COUNT FROM FIT
IOCOUNT  DATA     0                 SLAVE PROGRAM I/O COUNTER
RWS      DATA     0                 RECORD SIZE
RWS2     DATA     0                 #BYTES LEFT TO MOVE TO NEW BUFFER(CURRENT RE
BLDISP   DATA     0                 DISPLACEMENT INTO DATA GRANULE
CURDBLK  DATA     0                 CURRENT DATA GRANULE BUF ADDRS
LASTKEY  DATA     0                 TAPE KEY FLAG
FLAGS    DATA     0                 BLOCKING BUFFER FLAGS FOR EACH KEY
DURINDX  DATA     0                 SCRATCH CELL FOR REFORMAT/SKEYUP
FGCOUNT  DATA     0                 CNT OF NON-DUPE FILE DATA GRANULES
         DO1      UTS>0
MAXMF    DATA     0
         DO       UTS>=2
FULL     DATA     0                 NON-ZERO IF CONTROL GRAN. FULL
CONKEY   DATA     0                 OLD CONSEC. FILE KEY
CFLG     DATA     0                 CONT IN PROG FLAG FOR CONSEC FILES
         FIN
LPFLAG   DATA     1                 0 = WRITING A COC TERMINAL
MIKEYL   DATA     0                 TOTAL LENGTH OF MI BLOCK KEYS
FITLOC   DATA     0                 DISP TO FIT IN MI BLOCK
         BOUND    8
BUFLOC   DATA     0,0               DISP INTO :BOF AND TAPE LABEL BUFS
VLP11    DATA     X'11010101'       VLP FOR DESCRIPTORS FOR FILL
STDESCR  DATA     0                 DESCRIPTORS RIGHT JUSTIFIED
FAK      DATA     0                 FIRST APPEARANCE OF INDEX KEY FLAG
SIZE     DATA     0                 INDIVIDUAL RECORD SEGMENT SIZE
CURINDX  DATA     0                 CURRENT TABLE INDEX
GRANULEADR DATA   0                 CURRENT DATA DISC ADDRESS
FITGRAN  DATA     0                 TEMP CELL FOR PRIV PACK
EORERR   DATA     0                 ERROR AFTER END OF REEL
MISIZE   DATA     0                 CURRENT SECTOR NAV
CURRMIX  DATA     0                 CURRENT SECTOR INDEX
NEXTMIX  DATA     0                 NEXT INDEX TO CURRENT SECTOR
DROPCNT  DATA     2048              #BYTES BLOCKED PRIOR TO DISMISSAL
BUILDX   DATA     0                 EXIT FOR 'BUILD' ROUTINE
LASTGRAN DATA     0                 LAST DISC ADDRESS INTO DATA STACK
NXTFLNK  DATA     0                 NEXT FWD LINK CURRENT FILE
FERROR   DATA     0                 ERROR ON FILE IF >0
KICKOUT  DATA     1                 *
MIXBUF   DATA     0                 WA OF CURRENT INDICES BUFFER
NEXDATA  DATA     0                 NEXT INDEX SECTOR INDEX
NSPT     DATA     0                 #SECTORS PER TRACK IF RANDOM FILE
ACNLOC   DATA     0                 POINTS TO LOC OF ACCOUNT #
RSTORE   DATA     0                 #GRANULES IN RANDOM FILE
BUFTOP   DATA     0                 HIGHEST WA TO USE IN SENTINEL BUF
LIMIT    DATA     0                 DITTO
NEWINDX  DATA     0                 *
NOWAIT   DATA     0                 *
LASTMIX  DATA     0                 **EXPECTED BLINK FOR CURRENT MI SECTOR
HGPLOC   DATA     0
COUNT1   DATA     0                 # PLACED INTO TEMP STACK
COUNT2   DATA     0                 NUMBER LEFT AFTER DUPE REMOVAL
CVNO     DATA     0                 CURRENT VOLUME # IN USE (PRIV)
DISCIOX  DATA     0                 RETURN ADDRESS FOR DISC HANDLER
SKIPFDA  DATA     0
SKIPX    DATA     0                 SAVE CURRENT MODE IF +SKIP
         DO1      UTS>0
         USECT    EASECT
DOPCNT   DATA     0                 #OUTSTANDING Q ENTRIES DISC I/O
RBUSY    DATA     0
DSTATUS  DATA     0                 CURRENT DISC STATUS
OPCNT    DATA     0                 #OF TAPE OPERATINS CURRENTLY
TPSTATUS DATA     0                 CURRENT TAPE TYC
EOTBIT   DATA     0                 SET IF AT EOR
SPECEOT  DATA     0                 SPECIAL END OF TAPE FLAG FOR SENTINELS
M24      GEN,8,24 0,-1              MASK
         DO1      UTS>0
         USECT    DATASEC
MTDCTX   DATA     0                 DEVICE INDEX OF REEL
CURPOS   DATA     0                 WA OF SENTINEL RING BUF
*                                   CURRENT POSITION
RANDOM   DATA     0,0,0             # GRANULES IN FILE (FROM FIT VLP 0D)
LSTBUF   DATA     0                 LAST TAPE BUFFER
INITX    DATA     FITBUF+12         START WA FOR CODESCAN
         DO1      UTS>0
         USECT    EASECT
CUN      DATA     -1
*
*
         USECT    DATASEC
*
*
ORG      DATA     0,0,0,0           HOLDS ENTIRE 09 ENTRY FROM FIT
SENTWRT  DATA,1   WRT,IOPRI,RETRY,0
SENTWRT1 DATA     0
SENTWRT2 DATA     0
         DATA     0
         PAGE
*
*        TAPE SENTINEL'S
*
         BOUND    8
BOFINFO  EQU      %
DATBOF   EQU      %
         TEXT     ':BOF'
         DATA     X'01000808'
         TEXTC    'DAT'
         DATA     0,0,0,0,0,0,0
         DATA     X'09010202'
         DATA     X'00030139'
TPLFLG   DATA     X'1B000000'
BOFSIZE  DATA     64*4
LBLBUF   TEXT     ':LBLPRG1    '    F00 WRITES 12 BYTES
DATBUF   DATA      1
         DATA,1    3,0,0,0,1,0,0,X'18'
         DO1       5
         TEXT      '    '
         DATA      X'2E00'
EOFBUF  TEXT      ':EOF'
        DATA      0
         DATA     0
SYNBUF  DATA      1
         DATA     X'03000000'       DUMMY KEY
         DATA     X'01000004'       DUMMY TAPE KEY
         TEXT     'SYN '
EORBUF  TEXT      ':EOR'
        DATA      0
         DATA     0
EOVBUF  TEXT      ':EOV'
PBS      EQU      %
        DATA      0
         DATA     0
         DO       FILL=1
*
XTABLE   TEXTC    '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ'
*
ACNBUF   TEXT     ':ACN:SYS '
         DATA     0,0,0,0
*
BRECREC  EQU      %
         DO1      22
         DATA     0                 :BREC RECORD FOR FILL
*
BRECKEY  TEXTC    'SAV'
BRECFLG  DATA     0
*
         ELSE
*
ACNBUF   TEXT     ':ACN99999999'
*
         FIN
         PAGE
*
*
*        GRANULE STACK FOR FILE I/O
*
*
*
         BOUND    8
DSTACK   DATA     STACK-1
         GEN,1,15,1,15  1,STACKSIZE,1,0
RKEY     EQU      %
STACK    EQU      %
         LIST     0
         DO1      STACKSIZE
         DATA     0
         LIST     1                 GEN'D ZEROS FOR STACK....
*
*
*
         BOUND    8
TEMPSTK  DATA     %+1
         DATA,1    X'80',120,X'80',0
TMPSTK   EQU      %                 DATA PORTION STARTS HERE
CARDBUF  EQU      %
POBUF    EQU      %
         LIST     0                 LISTING OFF (168 ZERO WORDS FOLLOW)
         DO1      120
         DATA     0
         LIST     1
*
*
DSTACKOVF DATA    0                 DSTACK OVERFLOW COUNT
FPATCH   EQU      %
         DO1      100
         DATA     0
         PAGE
         DO       CPV>=2
M:EO     DSECT    1
M:EO     M:DCB    (DEVICE,'MT'),(OUTSN)
         FIN
         USECT    EASECT
EASIZE   EQU      %-EASECT          GENERATE TOTAL LENGTH OF SPECIAL CODE
*
         USECT    PROCED            AND GENERATE LITERALS IN PROCEDURE
*
FPTOP    END      INITIATE

