MONPROC  SET      1
BITS     SET      1                 GET MASKS & TABLE BITS
DISCBPROC SET     1                                                     DISCB
         SYSTEM   UTS
WRTF:    EQU      %
         PCC      0
*
     SPACE         3
*M*  WRTF          PROCESS M:WRITE CALS FOR DISC FILES
     SPACE         3
*P*  NAME:         WRTF
*P*
*P*  PURPOSE:      PROVIDE LOGIC FOR M:WRITE CALS TO DISC FILES.
*P*
*P*  DESCRIPTION:  ENTER HERE FROM MSRRDWRT IN IORT AFTER
*P*                MERGING FPR INFORMATION INTO DCB.
*P*                ONE LOGICAL RECORD IS READ INTO THE USER'S BUFFER
         TITLE    '**** WRTF ****'
K17      EQU      X'17'
K0       EQU      X'0'
K1       EQU      X'1'
K3       EQU      X'3'
KA       EQU      X'A'
K15      EQU      X'15'
KN2      EQU      -X'2'
KN3      EQU      -X'3'
ENCRYPT  EQU      16                DCB LOC FOR ENCRYPT KEY ADDRESS
XTRB     EQU      0                 DON'T BUILD LVL1 ON THE FLY
         SPACE    3
         OPEN     WXBUFSIZ,XBUFSIZ
WXBUFSIZ EQU      X'200'
XBUFSIZ  EQU      X'800'
         PAGE
R0       EQU      0
R1       EQU      1
R2       EQU      2
R3       EQU      3
R4       EQU      4
R5       EQU      5
R6       EQU      6
R7       EQU      7
SR1      EQU      8
SR2      EQU      9
SR3      EQU      10
SR4      EQU      11
D1       EQU      12
D2       EQU      13
D3       EQU      14
D4       EQU      15
         SPACE    3
FITSIZE  EQU      80
NWFITST  EQU      WXBUFSIZ-FITSIZE
         PAGE
         SPACE    2
         DEF      WRTF:             MODULE NAME FOR PATCHING
         DEF      IOSFILE           PROCESS M:WRITE CAL
         DEF      ENTER1            ENTER KEY IN DIRECTORY OR FILE
         DEF      ENTERO            BUILD FIRST FILE GRANULE
         DEF      GETDGRAN          ALLOCATE GRANULE FOR FILE
         DEF      RW1               REWRITE KEYED RECORD, NEW GREATER
*,*                                   THAN OR EQUAL TO ORIGINAL
         DEF      RW2               REWRITE KEYED RECORD, NEW LESS
*,*                                   THAN ORIGINAL
         DEF      RW3               READ KEYED FILE DATA GRANULE
         DEF      INSTCLNUP         CLEAN UP AFTER INST SUBROUTINE
         DEF      RW3A              READ KEYED FILE DATA GRANULE
         DEF      IMAGE3            SET ARS IN DCB AT END OF READ/WRITE
         DEF      IOSEQUB1          SYMBOL USED TO SEE IF SETUPUB
*,*                                   CALLED TO ENTER KEY
         DEF      RWRAND            READ/WRITE RANDOM FILE
         DEF      RW4               BUILD NEW KEY ENTRY ON WRITE
         DEF      SETUPWR           SET CFU AND DCB FOR WRITE
         DEF      UPDBLK            PUT NEW BLK, BLKSIZ IN MI ENTRY
         DEF      GZREEX            ENTRY FOR CLOSE TO RE-EXECUTE CAL
         DEF      GZAPCFU           CFU INDEX OF MPOOL ADDR USED IN
*,*                                   GRANULE CLEANING
         DEF      GZAPBIT           BIT IN GZAPCFU USED FOR FLAG
         DEF      GZPRIV            BIT IN USER'S JB:PRIV TO ENABLE
*,*                                   GRANULE CLEANING
         DEF      GZAP              INITIATE GRANULE CLEANING
         DEF      GZQUS             QUEUE USER UNTIL GRANULE CLEANING DONE
         DEF      NODUAL            ZERO IF NO DUAL DIRECTORIES
         DEF      CLSROOT           TFILE FOR JOB FILES
         PAGE
         SPACE    2
         REF      COMKEY            COMPARE TWO KEYS
         REF      EOFMITST          SEE IF AT EOF IN FILE OR DIRECTORY
         REF      ESTABBUF          WHEN NO FILE GRANULE IN CORE, READ
*,*                                   EITHER LAST GRANULE READ OR FDA
         REF      GBG               ALLOCATE GRANULE
         REF      GETCFU            GET CFU ADDRESS FROM DCB
         REF      GETCMD            GET CMD FROM DCB
         REF      GETCSA            GET CURRENT DISC ADDR
         REF      GETFUN            GET FUNCTION FROM DCB
         REF      GETSEC            GET AN MI BUFFER (BUFF2)
         REF      KEYER1            REPORT I/O ERR 18-00
         REF      KEYER2            REPORT I/O ERR 16-00
         REF      KEYER4            REPORT I/O ERR 13-00
         REF      KEYTRAN           MOVE KEY FROM MI TO DCB
         REF      MSREXIT           EXIT FROM READ/WRITE CAL, NO ERROR
         REF      MSR01EXIT         EXIT FROM CAL WITH ERROR
         REF      PRCRD1            POSITION RECORD FORWARD ONE
         REF      PULLEXIT          PULL LINK FROM STACK, RETURN
         REF      REDSECL           READ DISC WITH LINK CHECK
         REF      SAVBLK            STORE NEW BLK IN DCB
         REF      SETCMD            SET DCB CMD TO MIDIS
         REF      SETCMD1           SET DCB CMD TO (R3)
         REF      SETEOPW           SET WRITE OCCURRED IN DCB
         REF      SETTRN            SET DCB TRN
         REF      SETTYC            SET DCB TYC
         REF      SETUPUB           SEARCH DIRECTORY OR FILE FOR GIVEN KEY
         REF      TRNTST            CHECK IF DCB TRN SET
         REF      WRTXEND           END-ACTION TO RELEASE POOL BUFFER
         REF      PVQUEUE1          QUEUE I/O WITH END-ACTION
         REF      YFFFE
         REF      DLTSEG            OVERLAY # OF DLT MODULE
         REF      YFFFFFFFC
         REF      INITARS           SAVE SPACE IN TSTACK FOR ARS
         REF      TRANX             EXIT FROM READ/WRITE CAL
         REF      PUTSZBF           SET DCB CDA, BLK, QBUF
         REF      IOSPIN            WAIT FOR I/O TO COMPLETE
         REF      RESBLK            RESTORE DCB CDA, BLK, QBUF
         REF      Y0038
         REF      PUF               JIT DISPL OF WHO IS RUNNING
         REF      SETBLK            SAVE DCB CDA, BLK, QBUF
         REF      INCREMENT%SECTOR  ADD TO SECTOR FIELD OF DISC ADDR
         REF      SECTOR#MASK       MASK FOR SECTOR PART OF DISC ADDR
         REF      Y06
         REF      NB31TO0
         REF      UBLK              MOVE KEYED RECORD FROM DATA GRAN
*,*                                   TO USER'S BUFFER
         REF      TRNS1             TRANSFER DATA FOR READ AND WRITE CALS
         REF      CLRBBUF           WRITE BUFF1 IF UPDATED, RELEASE BUFFER
         REF      CLRBFUB           TRUNC THE MI BUFFER(BUFF2)
         REF      GETBBUF           GET A BUFF1
         REF      GETCBD            GET DCB CBD
         REF      SAVCBD            STORE NEW DCB CBD
         REF      FNDHGP            LOCATE HGP
         REF      GCYL              ALLOCATE A CYLINDER
         REF      GPVCYL            ALLOCATE CYLINDER ON PRIVATE PACK
         REF      GNVAT             ALLOCATE GRANULE FROM PRIV NVAT
         REF      RCYL              RELEASE PUBLIC CYLINDER
         REF      SETBTDQ           SET DCB HBTD TO UBTD
         REF      SETBTDZ           ZERO DCB BTD
         REF      GETSBUF           GET FPOOL BUFFE
         REF      T:GBUF            ALLOCATE FPOOL PAGE
         REF      T:RBUF            RELEASE FPOOL PAGE
         REF      T:MBUF            MAP IN FPOOL PAGE
         REF      T:SBUF            MOVE FPOOL BUFFER TO ANOTHER WINDOW
         REF      FMCHKDA           VALIDATE DISC ADDRESS
         REF      REDSEC8           ALTERNATE REDSEC ENTRY
         REF      REDSECB           READ UPPER LEVEL
         REF      JB:FBUL           LAST FILE BUFFER PAGE
         REF      JXBUFVP           1ST FILE BUFFER PAGE
         REF      1C0               REPORT I/O ERR 75
         REF      MAPBUFS           MAP IN BUFF1 AND BUFF2 FOR DCB
         REF      SLDMOVE           SLIDE KEYS IN MI OR DIRECTORY
         REF      24BM2             MAGIC NUMBER FOR SLIDING KEYS
         REF      RAD1ST            SET IF TO ALLOCATE FILES ON RAD
         REF      GETORG            GET DCB ORG
         REF      GETVNO            GET CURRENT OPEN VOL #
         REF      NXTVOL            GET # OF NEXT PRIV VOL IN SET
         REF      PRIVDCB           CHECK IF DCB ASSIGNED TO PRIV PACK
         REF      PVQUEUE           QUEUE I/O, NO END-ACTION
         REF      PVREADTP          QUEUE DISC READ
         REF      SETPVI            SET DCB FOR GIVEN PRIV VOL #
         REF      SETVNO            SET DCB VOL #
         REF      SWXPV             SWITCH TO NEXT PRIV VOL
         REF      GETTYC            GET DCB TYC
         REF      NSPC              # SECTORS PER CYLINDER ON DISC DEVICE
         REF      DCT22             DISC TYPE
         REF      DISCLIMS          # SECTORS ON DISC DEVICE
         REF      J:BASE            TEMP STORAGE AREA IN JIT
         REF      J:JIT             ADDRESS OF JIT
         REF      FILCFU            CFU TO READ FILE DIRECTORY
         REF      Y3
         REF      SEQPOS            POSITION CONSECUTIVE FILE
         REF      ACNCFU            CFU FOR READING ACCOUNT DIRECTORY
         REF      1A91              READ NEXT MI OR DIRECTORY GRANULE
         REF      1A3               COMPARE KEYS
         REF      RWREX1            CALL SETBLK, PUTSZBF
         REF      PRDCRM            JIT DISPL TO PERM RAD REMAINING
         REF      TMDCRM            JIT DISPL TO TEMP RAD REMAINING
         REF      TMPDCPK           JIT DISPL TO PEAK TEMP RAD
         REF      TMPDPPK           JIT DISPL TO PEAK TEMP PACK
         REF      BGRCFU            BEGINNING OF USER CFUS
         REF      1A8               READ CURRENT GRANULE, POINT TO END
         REF      Y00FE
         REF      BFRMWR            FINISH CURRENT KEY ENTRY ON UPDATE
         REF      RMB               RELEASE MPOOL BUFFER
         REF      HGP               ADDR OF IN-CORE HGP HEADERS
         REF      DCT23             HGP DISPL
         REF      T:RUE             REPORT EVENT ON A USER
         REF      E:WU              EVENT:  WAKE UP
         REF      NEWQNW            QUEUE I/O WITH NO WAIT
         REF      IOSPRTN           FINAL RETURN FOR CALS
         REF      PULLEXIT1         PULL LINK, INCREMENT IT, RETURN
         REF      ALLODIR           ALLOCATE DIRECTORY GRANULES
         REF      E:SL              EVENT:  SLEEP
         REF      T:REG             REPORT EVENT, GIVE UP CONTROL OF CPU
         REF      U:MISC            # TICS TO SLEEP
         REF      S:CUN             CURRENT USER #
         REF      SEQPOSD           POSITION CONSECUTIVE FILE
         REF      YFC
         REF      Y000C
         REF      YC                BITS 0,1
         REF      MSRWRTX           OK GET OUT OF CAL
         REF      MSRTFILE          PROCESS TFILE CAL
         DO1      XTRB
         REF      XTRAGRAN          UNUSED GRANULE FOR MULTI LEVELS
         SPACE    3
CYLFLG   EQU      FILCFU+FILDISP+6
*
BUF2FLGS EQU      J:BASE
BUFF2DA  EQU      J:BASE+1
BUF3FLGS EQU      J:BASE+2
BUFF3DA  EQU      J:BASE+3
INSTFLG  EQU      J:BASE+4
BUFHDR   EQU      J:BASE+5          ALSO USES +6 AND +7
DCBADR   EQU      J:BASE+8          DCB ADDRESS (FOR TSTHGP)
*
NODUAL   DATA     1                 ZERO FOR SYSTEM WITH NO DUAL DIRECTORIES
K3RDWRD  GEN,16,16   MIDIS,X'4000'
*
BUFF3    EQU      X'9800'
         PAGE
         SPACE    2
*F*  NAME:         IOSFILE
*F*
*F*  PURPOSE:      SET UP FOR WRITE OPERATION.  DETERMINE WHICH
*F*                SPECIFIC WRITE ROUTINE TO USE.
     SPACE         2
*D*  NAME:         IOSFILE
*D*
*D*  REGISTERS:    ALL VOLATILE
*D*
*D*  CALL:         BRANCH FROM MSRRDWT.  EXIT IS TO PULLALLEXIT
*D*
*D*  INPUT:        R6 = DCB ADDRESS
*D*
*D*  DESCRIPTION:  IF SHARED KEYED FILE:  IF AN UPDATE IS IN PROGRESS
*D*                ON THIS FILE BY ANOTHER USER, SLEEP UNTIL
*D*                IT COMPLETES.
*D*
*D*                IF CONSEC, GO TO SEQ0.
*D*
*D*                IF KEYED AND DCB OPEN OUTPUT WITH SEQUENTIAL,
*D*                GIVE I/O ERR 17 IF NO KEY SPECIFIED
*D*                OR NEITHER NEWKEY NOR ONEWKEY SPECIFIED.
*D*                IF KEY NOT GREATER THAN LAST KEY WRITTEN, GIVE
*D*                I/O ERR 18.  IF LAST OPERATION WAS NOT WRITE,
*D*                DELETE FORWARD, THEN WRITE.
*D*
*D*                IF KEYED AND DCB OPEN OUTPUT DIRECT OR UPDATE,
*D*                GIVE I/O ERR 16 IF KEY ALREADY EXISTS AND ONEWKEY
*D*                NOT SPECIFIED AND NEWKEY SPECIFIED.  OTHERWISE,
*D*                WRITE RECORD.
*D*
*D*                IF RANDOM, GO TO RWRAND.
*
IOSFILE  EQU      %
*  PERFORM SETUP FOR SHARED KEYED UPDATES
*  ELIMINATE RANDOM FILES.
         LI,R4    1B4               SET RETURN
SETUPWR  LW,R2    CFU,R6
         LW,D2    0,R2
         OR,D2    Y02               SET WRITE OCCURRED
         STW,D2   0,R2
         CI,D2    X'4000'           CHK 4 RANDOM
         BANZ     0,R4              IT IS RANDOM
         B        1,R4
*
1B4      RES      0
         B        RWRAND            IT'S A RANDOM
         LW,R1    Y001              FOR WAT BIT
         LW,R0    RWS,R6
         LW,12    ORG,6
         CI,12    X'20'             CHK FOR KEYED
         BAZ      SEQ0              IT'S CONSEC
         LI,15    X'1FFFF'
         CW,2     Y0008
         BANZ     IOSEQUB           UPDATE FILE
         LI,SR3   K17               KEY WASNT SPECIFIED--ERROR
         AND,15   KAD,R6
         BEZ      MSR01EXIT
*E*  ERROR:        17-00
*E*  DESCRIPTION:  ATTEMPT TO WRITE TO OUT/OUTIN FILE WITHOUT A KEY
         CW,12    Y3
         BAZ      MSR01EXIT
*E*  ERROR:        17-00
*E*  DESCRIPTION:  ATTEMPT TO WRITE TO OUT/OUTIN FILE WITHOUT
*E*                SPECIFYING EITHER NEWKEY OR ONEWKEY OPTIONS
         CI,12    2
         BANZ     IOSEQUB1
*  ROUTINE FOR OUTPUT SEQUENTIAL FILES
         BAL,R0   ESTABBUF
         B        IOSEQUB4
         BAL,R0   GETCMD            AT BOF
         BNEZ     OSEQUB1           NO
         LI,0     1                 ENTRY POINT #
         B        OSEQUB5
*
OSEQUB1  EQU      %                 FILE IS POSITIONED PAST BOF
         BAL,1    COMKEY
         BL       KEYER1            KEYOUT OF ORDER
         BG       OSEQUB4           ORDER OK
*                                   KEYS ARE EQUAL--MAY BE OK
         BAL,D2   TRNTST
         BAZ      KEYER2
OSEQUB4  EQU      %
         LW,R1    Y0008             PREVIOUS OP = WRITE
         CW,R1    EOP,R6
         BANZ     IOSEQUB4          YES, CONTINUE WRITING
*                                   DELETE FORWARD INFO
*
         LI,0     3                 ENTRY POINT #
OSEQUB5  RES      0
         DO       XTRB
         LW,R2    CFU,R6
         LW,11    TDA,R2            IS MULTI STARTED
         BEZ      OSEQUB3           BRANCH IF NOT
         LW,11    Y2                SET THE
         STS,11   0,R2               O BIT
         FIN
OSEQUB3  LI,R2    DLTSEG            SEGMENT #
         LI,11    IOSEQUB4          RETURN ADDRESS
         B        T:OVERLAY         DELETE FORWARD INFO
         PAGE     IOSEQUB           UPDATE ROUTINE FOR UNBUFFERED FILES
*
*  ALL WRITES ON UPDATE KEYED FILES.
*
IOSEQUB  EQU      %
         AND,D4   KAD,R6
         BNEZ     IOSEQUB1          YES
         LI,R1    X'40000'   PREVIOUS OPN MUST BE READ
         CW,R1    EOP,R6
         BANZ     IOSEQUB3          IT IS
         LI,SR3   K15               OPERATION ERROR
         B        MSR01EXIT
*E*  ERROR:        15-00
*E*  DESCRIPTION:  ATTEMPT TO WRITE TO KEYED FILE WITHOUT SPECIFYING
*E*                A KEY WHEN THE PREVIOUS OPERATION WAS NOT A READ
IOSEQUB3 EQU      %
         BAL,D2   SETTRN
*  FIND IMPLIED KEY POSITION.
*  IMPLIED KEY IS THAT OF THE RECORD JUST READ PREVIOUSLY.
         BAL,SR4  PRCRD1
IOSEQUB3B  EQU    %
*  WE ARE WRITING OVER THE CONTENTS OF A PREVIOUSLY EXISTING KEY.
         LW,D1    Y0008             WRITE BIT
         LI,SR4   MSREXIT           FORCE RETURN
         B        TRNS1             REWRITE
*
IOSEQUB1 EQU      %
         BAL,SR4  SETUPUB
         B        IOSEQUB1A         COULDNT FIND KEY
*
         LW,R1    ONWK,R6           GET ONWK & NWK
         CW,R1    Y2                ONWK
         BANZ     IOSEQUB3B          ON
         CW,R1    Y1                  OR NWK
         BAZ      IOSEQUB3B            OFF
         B        KEYER2            NEWKEY OPTION GIVEN ON EXISTING KEY
         PAGE
*  ALL WRITES FOR CONSECUTIVE FILES.
SEQ0     RES      0
         LI,0     MSREXIT
         LI,D1    X'80000'          EOP = WRITE
         BAL,7    SEQPOS            FIND POSITION
SEQ02    B        SEQ01             NOT EMPTY FILE
         LW,12    RWS,6             RECORD SIZE
         BEZ      TRANX             NO RECORD
         STW,12   W19,6             SET 1ST SEG FLAG
WBUFS    EQU      BUFSIZ**-2
         BAL,0    GETDGRAN          ALOOCATE A GRANULE
         BEZ      SATDISK           NONE AVAILABLE
LINE308  RES      0
         STW,8    BCDA,6            SAVE DISK ADDR
         STW,8    FDA,1             SET BOF LOC
         STW,8    LDA,1             SET EOF LOC
         BAL,0    GETBBUF   . PRIV.PACK SWITCH LOSES BBUF
         LI,8     0                 BLINK = 0 FOR BOF
         STW,8    TDA,1             INIT REC COUNT
SEQ1C    STW,8    BUFF1             SET BLINK
         LI,8     0                 FLINK = 0 FOR EOF
         STW,8    BUFF1+1           SET FLINK
         LI,3     3                 ZAP
         LW,15    BUFF1
         BNEZ     SEQ1N             NOT 1ST GRAN
         LW,8     =FX'80B13'        ROOM FOR FIT
         STW,8    BUFF1+3           LOOKS LIKE DEL'D REC
         LI,8     3                 1ST POSN
         LI,3     FITSIZE+4         NEXT POSITION
SEQ1N    RES      0
         STW,8    BUFF1,3           PREV LOC
         STW,3    BUFF1+2           SET GRAN CONTROL WD
SEQ1B    LW,15    Y004              SET UPDATED
         STS,15   BBUD,R6            FLAG
W19      EQU      19
SEQ1J    RES      0
         LW,12    RWS,6             REMAINING RECORD SIZE
         BGZ      SEQ1O             NOT A SPECIAL
         LI,13    X'E0000'          RESET CBD TO FORCE CLRBBUF
         STS,12   CBD,R6             TO WRITE ENTIRE GRANULE
         B        PULLEXIT          BACK TO OPEN
SEQ1O    RES      0
         INT,3    BUFF1+2           DISPERSE CONTROL WORD
         BCR,4    SEQ1G             BRANCH IF NOT FULL
SEQ1F    LI,1     DCBSWXVBIT
         CW,1     SWXV,6
         BAZ      SEQ1F1            NO VOLUME SWITCH
         PULL     8                 GET NVAT
         B        SEQ1F2
SEQ1F1   BAL,0    GETDGRAN          ALOOCATE ANOTHER GRAN
         BNEZ     SEQ1F2            BR IF WE GOT ONE
         LCW,4    W19,6             IS IT FAK
         BEZ      %+3               BR IF IT ISN'T
         AWM,4    W19,6             RESET POSITIONING
         B        SATDISK
         INT,3    BUFF1+2
         BCS,4    %+2               BR IF FULL
SEQA1    LW,3     BUFF1,3           GET PREV CTL WD
         LW,4     BUFF1,3
         AND,4    NB31TO0+30        RESET C
         STW,4    BUFF1,3
         B        SATDISK
*
SEQ1F2   RES      0
         STW,8    BUFF1+1           SET FLINK IN OLD GRAN
         PUSH     8                 SAVE NEW GRAN ADDR
         BAL,0    CLRBBUF           WRITE OLD
         LI,1     DCBSWXVBIT
         CW,1     SWXV,6
         BAZ      SEQ1M             NO VOLUME SWITCH
         LI,0     0
         STS,0    SWXV,6            RESET SWITCH FLAG
         BAL,R0   GETVNO
         AI,R3    1
         BAL,R0   SWXPV               SWITCH TO NEXT VOL
         BAL,0    GETVNO
         BNEZ     SEQ1M             SKIP IF VOL IS MOUNTED
         PULL     8
         B        SATDISK
SEQ1M    RES      0
         BAL,0    GETBBUF           GET A NEW BUFFER
         PULL     8                 RETRIEVE GRAN ADDR
         LW,1     CFU,6
         STW,8    BCDA,6            UPDATE POS
         XW,8     LDA,1             SET NEW EOF POS
         B        SEQ1C
         SPACE    2
SEQ01    LW,7     W14,6             CURRENT RECORD #
W14      EQU      14
         LW,1     CFU,6
         CW,7     TDA,1             CHECK LAST REC #
         BE       SEQ1B1            OK
         OVERLAY  DLTSEG,3          DLT FRWD INFO
         LI,7     SEQ02             SET RETURN
         B        SEQPOSD           SET POSITION
SEQ1B1   LW,12    BCDA,6
         STW,12   LDA,1             MAKE SURE LDA IS CORRECT
         LW,12    RWS,6             RECORD SIZE
         STW,12   W19,6             SET 1ST SEG FLAG
         BNEZ     SEQ1B
         B        SEQ2E+2
         SPACE    3
SEQ1G    CI,3     WBUFS-2
         BG       SEQ1F             IT'S FULL UP
         LW,R1    CFU,R6
         LCW,4    W19,6             INIT SEG FLAG
         BEZ      SEQ2B             NOT 1ST
         AWM,4    W19,6             RESET 1ST FLAG
         LW,4     Y4                FAK = 1
         MTW,1    TDA,1             UP REC COUNT FOR FILE
         MTW,1    W14,6             SET POSN
SEQ2B    CI,12    BUFSIZ-15         CHK BLOCKED
         BL       SEQ3A             YES
         LI,R0    X'1FFFF'          IS
         AND,R0   ENCRYPT,R6         ENCRYPTION
         BNEZ     SEQ3A               SPECIFIED
         CI,3     3                 BRANCH IF
         BLE      SEQ2F              1ST ENTRY IN GRANULE
         LW,15    BUFF1,3           PREV CTL WD POSN
         AI,15    1
         SW,15    3
         BGEZ     SEQ2F
*  BRANCH IF 1ST SEG IN GRAN OR PRECEEDING SEG WAS UNBLOCKED
         AI,3     1                 NXT POS
         OR,R4    Y1                SPECIAL BACKSPACE
         MTW,1    BUFF1+2           UPDATE POSITION
SEQ2F    RES      0
         BAL,0    GETDGRAN          ALLOCATE A GRANULE
         BNEZ     SEQ2F1            BR IF WE GOT ONE
         LC       4
         BCR,4    SEQA2             BR IF FAK NOT ON
         MTW,-1   TDA,1             DECR RECORD COUNT
         MTW,-1   W14,6             DECR POSITION
SEQA2    LC       4                 GET FLAGS AGAIN
         BCR,1    %+2               BR IF NO SPEC BACKSPACE
         MTW,-1   BUFF1+2           ADJUST POINTER
         INT,3    BUFF1+2           DISPERSE CTL WD
         CI,3     3
         BLE      SATDISK           BR IF 1ST ENTRY IN GRAN
         B        SEQA1             GO ERASE C
*
SEQ2F1   RES      0
         LI,1     DCBSWXVBIT
         CW,1     SWXV,6
         BAZ      %+3               NO VOLUME SWITCH
         PUSH     8                 SAVE NEW GRANULE
         B        SEQ3AA            FILL UP OLD GRANULE
         OR,4     Y8                SET UNBLOCKED FLAG
         CI,12    BUFSIZ            CHK MULTI SEGMENT RECORD
         BLE      SEQ2C             ONLY 1 SEG
         AW,4     Y28               SET C & SIZE
         LI,12    BUFSIZ            MAX SEG SIZE
         B        SEQ2D
Y28      DATA     X'2F000000'
         SPACE    3
SEQ2C    LW,1     RWS,6             SIZE
         AI,1     15-BUFSIZ         SET
         SCS,1    -8                 SEG
         AW,4     1                   SIZE
SEQ2D    BAL,0    SAVBLK            SAVE SEGMENT SIZE
         BAL,D4   SETBTDQ           MOVE UBTD TO HBTD
         LI,0     -BUFSIZ           UPDATE
         AWM,0    RWS,6             RECORD SIZE
         STW,8    CDA,6             FOR Q
         OR,4     CDA,6             COMPLETE CONTROL WORD
         STW,4    BUFF1,3           INSERT CTL WD
         AI,3     1                 NXT POS
         LW,1     Y8                SET
         STS,1    BUFF1+2            UNBLOCKED FLAG
         LI,4     IMAGE2            ROUTINE ADDR
         B        SEQ3E
         SPACE    3
SEQ2E    LI,14    BUFF1             RESTORE BFR PNTR
         LW,12    RWS,6             REMAINING SIZE
         BGZ      SEQ1J             MORE TO GO
         LW,12    BCDA,6            CURRENT GRANULE
         STW,12   DCBCDAM,6         SAVE POSITION
         INT,3    BUFF1+2           BFR CTL WD
         BCR,4    %+2               NO
         LI,3     WBUFS             END OF BFR
         LI,0     TRANX             TO GET OUT
         B        SETCMD1
         SPACE    4
SEQ3AA   CW,4     Y1                ARE WE SPECIAL BACKSPACEING
         BAZ      SEQ3A             NO, ALL OK
         SW,4     Y1                YES, DONT
         MTW,-1   BUFF1+2           DECR POINTERS TO BACKSPACE CNTL
         AI,3     -1
SEQ3A    AW,14    3                 SEG CTL WD POSN
         LW,15    14
         AI,3     1                 1ST DATA BYTE POSN
         SLS,3    2                 BYTE ALIGN
         AW,3     RWS,6             END DATA BYTE POSN+1
         LW,1     3
         AI,1     -BUFSIZ           MUST WE SEGMENT
         BLEZ     SEQ3B             NO
         SW,12    1                 SEGMENT LENGTH
         OR,4     Y2                SET C BIT
SEQ3B    STW,1    RWS,6             RESIDUE OF REC IF ANY
         LI,13    X'7FFF'           MASK
         SLD,12   16                CTL WD POSN
         OR,4     12                INSERT SIZE IN CTL WD
         AWM,4    *14               CTL WD TO BFR
         SLD,12   1                 DCB POSN
         STS,12   BLK,6             LENGTH TO DCB
         AI,15    1                 1ST DATA BYTE IN BFR
         SCS,12   15                ALIGN TO WORD BDRY
* THE CODE FROM HERE TO SEQ3B2+1 WILL HAVE TO BE REPLACED
* FOR BPM ON A SIGMA 5. YOU CAN USE RECTRAN AS FOLLOWS:
*    SOURCE BUFFER IS QBUF IN THE DCB
*    SOURCE BYTE DISPLACEMENT IS BTD IN THE DCB
*    # OF BYTES TO BE MOVED IS IN REGISTER 12
*    DESTINATION BUFFER IS BUF1 IN THE DCB WITH 0 BTD
         LW,14    QBUF,6            USER BFR ADDR
         LI,1     3                 MASK
         LW,0     BTD,6             USER BYTE DISPLACEMENT
         SLS,0    -4                ALIGN TO WORD BDRY
         SLD,14   2                 BYTE ALIGN
         STS,0    14                INSERT BTD
         AI,12    -256              CHK FOR 1 MBS
         BLZ      SEQ3B2            ONLY 1 REQ'D
         AND,15   M19
SEQ3B1   OR,15    YFC               COUNT = 252
         MBS,14   0                 MOVE 'EM OUT
         AI,12    -252              DO WE NEED ANOTHER 252
         BGEZ     SEQ3B1            YUP
SEQ3B2   STB,12   15                COUNT FOR FINAL MOVE
         MBS,14   0                 MOVE THE LAST
         LI,R1    X'1FFFF'          IS ENCRYPTION
         AND,R1   ENCRYPT,R6         SPECIFIED
         BEZ      SEQ33             BRANCH IF NOT
         LI,SR2   X'ABCDE'          GENERATE
         INT,R7   BUFF1+2           BUFFER OFFSET
         AI,R7    BUFF1+1           BUFFER ADDRESS
         BAL,R4   CONCR1C           GO ENCRYPT
SEQ33    RES      0
         LI,14    BUFF1             RESTORE BFR PNTR
         AI,3     3                 NXT WORD
         SLS,3    -2                WORD ALIGN
         LI,4     IMAGE3            ROUTINE ADDR
SEQ3E    RES      0
         CI,3     WBUFS
         BL       SEQ3C             BRANCH IF NOT FULL
         LW,1     Y4                SET
         STS,1    BUFF1+2            FULL FLAG
         B        SEQ3D
SEQ3C    LI,1     5
         LH,0     BUFF1,1           PREV CTL WD
         STH,3    BUFF1,1           NEW POSN
         STW,0    BUFF1,3           FOR BACKUP
SEQ3D    RES      0
         LI,0     SEQ2E             SET
         PUSH     0                  RETURN
         B        0,4               UPDATE ARS & QBUF
         PAGE     ENTER1
DBLINK   EQU      WXBUFSIZ-2        DUAL BLINK POSITION
DFLINK   EQU      WXBUFSIZ-1        DUAL FLINK POSITION
*
*  SET UP THE 1ST(FIT) GRANULE OF A KEYED OR CONSECUTIVE FILE.
ENTERO   PUSH     SR4
         LI,D2    X'20'
         CW,D2    ORG,6
         BAZ      ENTERO2
*  IT'S A KEYED FILE.
         BAL,SR4  ENTER1
ENTERO1  B        PULLEXIT
*
*  IT'S A CONSECUTIVE FILE.
ENTERO2  BAL,R0   CLRBFUB           GET RID OF BUFF2
         BAL,R0   GETDGRAN          START THE FIT GRANULE
         BEZ      PULLEXIT
         LI,0     0
         STW,0    RWS,6
         B        LINE308
*                                   OBTAIN ENOUGH ROOM FOR NEW ENTRY
*                                   IN MASTER INDEX
ENTER1   EQU      %
ENTER2   EQU      %
         PUSH     1,SR4
         BAL,R0   GETSEC            GET BUFF2
         LW,D1    FDA,R1
         BNEZ     INSERTUB1         NOT AN EMPTY FILE
         BAL,R2   GETIGRAN          GET AN INDEX GRANULE
         BEZ      PULLEXIT
*                                   INIT FIRST SECTOR
         LW,SR4   Y002              SET MIUD
         STS,SR4  MIUD,R6
         LI,SR4   K0
         BAL,R0   INITMI
         OR,D4    Y8
         STW,D4   FDA,R1            SET EMPTY FILE FLAG
         LI,0     ENTERO1
         CW,0     *TSTACK
         BE       PULLEXIT          PHONY FIT
*
         BAL,R0   SETCMD            SET CMD
*
INSERTEOF   EQU   %
         BAL,2    SETEOF            CLEAR EOF
         BAL,R0   SETEOPW+2
         BAL,R0   INST
         BAL,R0   SETEOPW
         PULL     1,R2              GET RETURN
SETEOF   LW,R3    CMD,R6
         LH,3     3
         CI,R3    MIDIS
         BLEZ     B2
         AI,R3    KN3
         LI,R1    X'1FFFF'
         AND,R1   CFU,R6
         CI,R1    ACNCFU
         BG       %+2               SKIP IF NOT ACCOUNT DIRECTORY
         AI,R3    2                 SPECIAL FORMAT
         LB,R0    BUFF2,R3
         CI,R2    INSERTEOF+1       DO WE WANT TO CLEAR
         BNE      %+3               SKIP TO SET EOF
         AND,R0   NB31TO0+2         ERASE EOF BIT
         B        %+2
         OR,R0    X2                SET EOF BIT
         STB,R0   BUFF2,R3
         LW,R3    CMD,R6
         LH,R3    R3
B2       B        0,R2
*
3C1      LI,D2    0                 FOR BLINK TEST
         BAL,R0   REDSECL           READ IN THE GRAN
         B        INSERTEOF-1
*
INSERTUB1  EQU    %
         BLZ      3C1
         LI,2     HACMD
         LH,3     *6,2
         BNEZ     %+3
         LI,3     MIDIS
         STH,3    *6,2
         BAL,R0   EOFMITST+3
         B        INSERTEOF         INSERT ON END OF FILE
*  TO POSITION INSERTION WITH RESPECT TO DELETED ENTRIES.
         LI,R2    HACMD
         LW,D4    KBUF,R6
4B1      STH,R3   *R6,R2
         SW,R3    IMT,R6
         CI,R3    MIDIS
         BGE      4B2
         LW,D1    BUFF2
         BEZ      INSTPA
         BAL,R2   1A8               BACK UP A SECTOR OF MI
         B        4B1+1
4B2      BAL,R1   1A3
         BL       4B1
*
         B        INSTPA            INSERT AT OTHER THAN EOF
         TITLE    '**** INST ****'
*
*  PURPOSE:  INSERT A NEW KEY IN MI OR DIRECTORY
*
*  INPUT:  R3 = BYTE INDEX INTO BUFF2 OF KEY LOCATION
*
*  CALL:  BAL,R0  INST
*
*  ALL REGISTERS VOLATILE
*
INST     EQU      %
         OR,R0    Y4                FOR COMPLEN, SET EOF FLAG
         PUSH     1,R0
*  TO POSITION INSERTION WITH RESPECT TO DELETED ENTRIES.
         LI,R2    HACMD
         LW,D4    KBUF,R6
         CI,R1    FILCFU
         BG       4B3A
         B        4B1               BACK-UP TO LAST KEY IF DIRECTRY
4B3      AW,R3    IMT,R6            INCR TO NEXT KEY
         STH,R3   *R6,R2            SAVE NEW POSITION
4B3A     CH,R3    BUFF2+NAVX        CHECK FOR END OF GRANULE
         BL       4B4
         LW,D1    BUFF2+1
         BEZ      INSTPA
         BAL,R3   1A91              READ NEXT SECTOR OF MI
         B        4B3A              CHECK FIRST KEY IN THIS GRAN
4B4      BAL,R1   1A3               COMPARE DESIRED KEY WITH CURRENT
         BG       4B3
*
INSTPA   EQU      %
         LI,R2    0
         STW,R2   BUF3FLGS          CLEAR
         STW,R2   BUFF3DA            POINTERS
         BAL,R0   GETCSA            BUFF2 DISC ADDRESS
         STW,D2   BUFF2DA           SAVE IT
*
DCDAM    EQU      ACNCFU+4          DUAL OF CDAM FOR DRCTRYS
RDA      EQU      ACNCFU+6          REQUESTED DISK ADDRESS
DRDA     EQU      ACNCFU+7
REDFLGS  EQU      ACNCFU+18         CTL FLAGS FOR DUAL READS
DIGRAN   EQU      ACNCFU+9          DUAL DA FROM GETIGRAN
DBUFF3   EQU      ACNCFU+10         DUAL FOR BUFF3
*
         LW,R0    ='INST'           SET FLAG
         STW,R0   INSTFLG            FOR RECOVERY
         STW,R6   DCBADR            SAVE DCB ADDRESS FOR TSTHGP
         LW,R3    Y002
         AND,R3   MIUD,R6           GET MIUD FLAG
         STS,R2   MIUD,R6           RESET MIUD
         SCS,R3   11                RIGHT JUSTIFY MIUD
         STW,R3   BUF2FLGS  SET OR RESET BUFF2 UPDATED BIT
         LI,R3    BUF2MSK
         AND,R3   BUFX,R6           BUFF2 INDEX
         STS,R2   BUFX,R6           ZAP IT IN DCB
         SLS,R3   -5                RIGHT JUSTIFY
         STB,R3   BUF2FLGS          SAVE THE INDEX
         CI,R1    FILCFU
         BG       INSTPA5           BR IF NOT DIRECTORY
         LW,R7    Y2
         STS,R7   *TSTACK           SET DIRECTORY FLAG
         LW,R3    FILCFU+FDA
         BGEZ     INSTPA5           NOT MAKING DIRECTORY NON-EMPTY
         MTB,1    CYLFLG            MAKE SURE EMPTY FLAG RESET IN FDA
         LI,R3    MIDIS             FORCE NAV=MIDIS WHEN INSERTING
         STH,R3   BUFF2+NAVX          INTO EMPTY DIRECTORY
*
INSTPA5  LW,R3    Y8
         STS,R2   FDA,R1            CLEAR EMPTY FILE FLAG
         CI,R1    FILCFU
         BLE      INSTPA7           NOT FILE
         LI,R5    X'8000'
         CW,R5    0,R1
         BAZ      INSTPA7           NOT SHARED
         LI,R5    X'FFFF'
         AND,R5   SCFU,R1
         BEZ      INSTPA7           NO SECONDARY CFU
         STS,R2   FDA,R5            CLEAR EMPTY FLAG IN INPUT CFU
*
INSTPA7  LI,D3    BUFF2
*
         LW,R3    CMD,R6
         LH,R3    R3                INDEX TO KEY
*
INST2D   EQU      %
         LI,R2    NAV
         CH,R3    *D3,R2            CHK 4 END OF BLOCK
         BL       INST1             NO
         LH,R3    *D3,R2            FORCE AT NAV IF GREATER
         BAL,R0   COMPLEN           YES - ROOM ENOUGH
         BLE      INST2Y            YES
*
*  NOT ENOUGH ROOM IN THIS BLOCK
*
         BAL,R0   GETBUF            GET A BUFF3
         LW,SR2   BUFF2+DFLINK      DUAL FLINK IF DIRECTORY
         LW,D4    BUFF2+FLINK
         BNEZ     INST2E1           ALREADY HAVE A FLINK
         BAL,R2   GETIGRAN          GET A GRANULE
         BEZ      INSTXIT           NONE AVAILABLE
INST2E1  CI,R1    FILCFU
         BG       INST2E            NOT A DIRECTORY
         STW,SR2  DRDA              REDSEC
         STW,D4   RDA                CONTROL INFO
         STW,SR2  BUFF2+DFLINK      DUAL FLINK
         LW,SR1   DCDAM             DUAL DA OF PREV GRAN
         STW,SR1  BUFF3+DBLINK      DUAL BLINK
         LI,R0    0
         STW,R0   REDFLGS           REDSEC
INST2E   STW,D4   BUFF3DA           BECOMES BUFF3
         LW,D1    BUFF2+FLINK
         BNEZ     INST2A            BR IF THERE IS A FLINK
*
*  NO FLINK - ADD NEW GRANULE AT EOF
*
         STW,D4   BUFF2+FLINK       PUT IN NEW FLINK
         LW,SR4   BUFF2DA           BLINK OF NEW GRANULE
         BAL,R0   INITMI1 INIT 1ST 3 WDS OF BUFF3
         LI,R5    1
         STS,R5   BUF2FLGS          SET BUFF2 UPDATED BIT
*
INST2C   EQU      %
         BAL,R0   SETCMD            SET CMD = MIDIS
         B        INST2D            GO TRY AGAIN
         SPACE    2
*
*  READ THE NEXT GRANULE
*
INST2A   EQU      %
         LW,R0    BUFF2+DFLINK      SET UP BUFF3 DUAL
         STW,R0   DBUFF3
         LW,D2    BUFF2DA           DA FOR LINK CHK
         BAL,R0   REDGRANL          READ INTO BUFF3
         LI,D3    BUFF3             REDSEC CLOBBERS D3
         B        INST2C            GO TRY AGAIN
         PAGE
         SPACE    2
*
*  INSERT AT POINT OTHER THAN END OF BLOCK
*
INST1    EQU      %
         CI,R3    MIDIS             BRANCH IF INSERT AT
         BE       INST4               FIRST KEY POSITION
*
INST3    EQU      %
         BAL,R0   COMPLEN
         BLE      INST3X1           BR IF ROOM ENUF
*
         LB,SR3   BUF3FLGS
         BNEZ     INST41B           ALREADY HAVE BUFF3
         BAL,R0   GETBUF            DON'T HAVE - GET ONE
         LW,D1    BUFF2+FLINK
         STW,D1   BUFF3DA
         BEZ      INSTN             BR IF NO FLINK
         CI,R1    FILCFU
         BG       INST3A3           NOT A DIRECTORY
         LW,D2    BUFF2+DFLINK
         STW,D1   RDA               REDSEC
         STW,D2   DRDA               CONTROL
         STW,D2   DBUFF3
         LI,D2    0
         STW,D2   REDFLGS
INST3A3  RES      0
         LW,D2    BUFF2DA           LINK CHECK DISC ADDRESS
         BAL,R0   REDGRANL          READ INTO BUFF3 WITH LINK CHECK
         LI,D3    BUFF3             REDSEC CLOBBERS D3
         BAL,R4   MULCHK            CHK MULTI-LEVEL RESTRICTION
         B        %+2               NONE
         B        INSTN             YES - MUST GET NEW GRANULE
INST3A1  RES      0
         BAL,R0   COMPLEN
         BG       INSTN             BR IF NOT ENOUGH ROOM
         STH,R4   BUFF3+NAVX        NEW BUFF3 NAV
         LW,D2    R5
         AI,D2    -MIDIS            # BYTES CURRENTLY USED
         BLEZ     %+2               NONE - NOTHING TO SLIDE
         BAL,R2   SLDDWN1           D2 HAS # BYTES TO SLIDE
*
*  MOVE LAST KEY FROM BUFF2 TO FIRST POSITION IN BUFF3
*
         LI,R7    1
         STS,R7   BUF3FLGS          SET BUFF3 UPDATED
         LI,R0    INST2YA           RETURN FROM SETCMD
         LW,R7    CMD,R6
         LH,R7    R7
         CH,R7    BUFF2+NAVX
         BE       SETCMD
         LW,R7    IMT,R6            # BYTES IN KEY
         LH,R4    BUFF2+NAVX
         SW,R4    R7
         STH,R4   BUFF2+NAVX        SET NEW NAV
         AI,R4    BUFF2**2          SOURCE BYTE ADDRESS
         LI,R5    BUFF3**2+MIDIS    DESTINATION BYTE ADDRESS
         STB,R7   R5
         MBS,R4   0
*
*  SLIDE DOWN KEYS IN BUFF2
*
INST3X   EQU      %
         LI,D3    BUFF2
         LH,R5    BUFF2+NAVX
         LH,R4    BUFF2+NAVX
         AW,R4    W14,R6            NEW NAV
         STH,R4   BUFF2+NAVX        SET NEW NAV
         LI,R2    IMAGEREC
*
         LW,D2    R5
         SW,D2    R3                # BYTES TO MOVE
SLDDWN1  EQU      %
         ANLZ,R5  SLDDWN5   LB,0  *D3,R5
*
         DW,D2    IMT,R6            # KEYS TO MOVE
         LW,SR2   IMT,R6            KEY SIZE
         MW,SR2   24BM2
         STW,SR2  J:BASE+11
         SLS,SR2  -1
         LW,SR1   SR2
         LI,SR2   X'7FFFF'
         STS,SR1  SLDMOVE+1         CHANGE MBS ARG FIELD
         AW,R5    IMT,R6            INCR 2 KEYS
         AW,R5    IMT,R6
         B        SLDMOVE
*
SLDDWN5  LB,0     *D3,R5
         SPACE    3
*
*  BUILD NEW BLOCK
*
INSTN    EQU      %
         BAL,R2   GETIGRAN          GET A GRANULE
         BEZ      INSTXIT           COULDN'T GET ONE
         LI,D3    BUFHDR
         LW,SR4   BUFF2DA           BLINK
         LW,D1    BUFF3DA           FLINK
         BNEZ     %+3               BR IF BUF3 ACTIVE
         LI,D3    BUFF3
         STW,D4   BUFF3DA
         BAL,R0   INITMI1           SET UP 3 WORDS IN J:BASE
         LI,R2    12                BYTE COUNT
         LW,D1    D4                DISC ADDRESS
         LI,SR2   0                 NO END ACTION
         STW,D1   BUFF2+FLINK       CHANGE BUFF2 FLINK
         LI,R5    1
         STS,R5   BUF2FLGS          SET BUFF2 UPDATED FLAG
         LW,R7    *D3,R5
         BEZ      INST3A2           BR IF BUFF3 WASN'T ACTIVE
*
         BAL,R0   WRIT              WRITE OUT THE 3 WORDS
         STW,D1   BUFF3             NEW BUFF3 BLINK
         CI,R1    FILCFU
         BG       %+3               NOT A DIRECTORY
         LW,R2    DIGRAN            DUAL DA
         STW,R2   BUFF3+DBLINK      SET DUAL BLINK
         LI,R2    2048              BYTE COUNT
         LI,D3    BUFF3             VIRTUAL BUFFER ADDRESS
         LW,D1    BUFF3DA           DISC ADDRESS
         LB,R7    BUF3FLGS          END ACTION INFO
         LI,SR2   WRTXEND           END ACTION ADDRESS
         BAL,R0   WRIT              WRITE IT
         SD,R4    R4                CLEAR R4 AND R5
         LCI      2
         STM,R4   BUF3FLGS          CLEAR BUFF3 POINTERS
         BAL,R0   GETBUF            GET A NEW BUFF3
         STW,D4   BUFF3DA
         LCI      2
         LM,SR4   BUFHDR
         LW,R7    DBUFF3            FOR DUAL FLINK BELOW
         LW,SR2   DIGRAN
         BAL,R0   INITMI1
*
INST3A2  CI,R1    FILCFU
         BG       INST3A1           NOT A DIRECTORY
         LW,SR1   DBUFF3            DUAL OF BUFF3
         STW,SR1  BUFF2+DFLINK      SET DUAL FLINK
         STW,R7   BUFF3+DFLINK      AND AGAIN
         LW,R7    BUFF2+DDA         DUAL OF THIS GRANULE
         LW,R0    BUFF2
         BNEZ     %+2
         LW,R7    8,R1              IF FDA, GET FROM CFU
         STW,R7   BUFF3+DBLINK      SET DUAL BLINK
         B        INST3A1
*
*  INSERT AT MIDIS (FIRST KEY POSITION)
*
INST4    EQU      %
         LW,D1    *D3               CHK FOR FDA
         BEZ      INST3             BRANCH IF 1ST ON LVL 0
         BAL,R4   MULCHK            CHK MULTI-LEVEL RESTRICTION
         B        INST3             BR IF NONE
         LB,SR3   BUF3FLGS
         BNEZ     INST41B           ALREADY HAVE BUFF3
         STW,D1   BUFF3DA           NEW BUFF3 DISC ADDRESS
         BAL,R0   GETBUF            GET A BUFF3
         LW,R0    BUFF2+DBLINK      SET UP DUAL OF BUFF3
         STW,R0   DBUFF3
         LW,D1    BUFF3DA           DISC ADDRESS TO READ
         LW,D2    BUFF2DA           LINK CHECK DISC ADDRESS
         OR,D2    Y8                BLINK CHECK
         BAL,R0   REDGRANL          READ IT
*
*  SWITCH BUFF2 AND BUFF3
*
         BAL,R0   BUFMOVE           MOVE BUFF2 TO BUFF3
INST41B  LI,D3    BUFF2
         LH,R3    BUFF2+NAVX
         BAL,R0   SETCMD1           SET CMD TO BUFF2 NAV
         BAL,R0   COMPLEN           CHECK FOR ENOUGH ROOM
         BLE      INST3Y            YES - GO INSERT KEY
         B        INSTN             NO - GET NEW GRANULE
         SPACE    3
*
*  PURPOSE:  CHECK IF AN UPPER LEVEL INDEX ENTRY POINTS
*            TO THIS BLOCK
*
*  INPUT:  R1 = CFU ADDRESS
*          D3 = CURRENT BUFFER ADDRESS
*
*  CALL:  BAL,R4  MULCHK
*
*  OUTPUT:  NORMAL RETURN - NOT POINTED TO BY UPPER LEVEL
*           SKIPPING RETURN - POINTED TO BY UPPER LEVEL
*
MULCHK   LI,R1    X'1FFFF'
         AND,R1   CFU,R6
         LC       *R1
         BCR,2    0,R4              NO MULTI-LEVEL
         LI,R2    NAVX
         LW,R0    *D3,R2
         CI,R0    X'100'            CHECK ADDED FLAG
         BANZ     0,R4              BR IF ADDED SINCE MUL REBUILT
         B        1,R4
         SPACE    3
*
*  PURPOSE:  CLEAN UP BY WRITING OUT UPDATED BUFFER, RELEASING
*            BUFFERS, AND RESTORING SAVED VALUES.
*
*  CALL:  BAL,SR4   INSTCLNUP
*
INSTCLNUP EQU     %                 EXTERNAL ENTRY POINT
         PUSH     SR4
INSTXIT  EQU      %                 INTERNAL ENTRY - EXIT TO
         LB,R7    BUF3FLGS
         BEZ      INSTCL3           NO BUFF3
         LI,D3    BUFF3
         LI,R5    1
         CW,R5    BUF3FLGS
         BAZ      INSTCL2           NOT UPDATED - RELEASE BUFFER
         LI,R2    2048              BYTE COUNT
         LI,SR2   WRTXEND           END ACTION ADDRESS
         LW,D1    BUFF3DA           DISC ADDRESS
         BAL,R0   WRIT              WRITE IT (NO WAIT)
         LI,R5    -1                RELEASE VIRTUAL ONLY
INSTCL2  BAL,R2   T:RBUF
         STW,R2   BUF3FLGS          ZAP BUFFER INDEX
*
INSTCL3  LW,D1    BUFF2DA           BUFF2 DISC ADDRESS
         LI,R1    X'1FFFF'
         AND,R1   CFU,R6
         CI,R1    FILCFU
         BG       INSTCL4           BR IF USER CFU
         STW,D1   CDAM,R1
         B        INSTCL5
INSTCL4  STW,D1   DCBCDAM,R6
INSTCL5  LB,SR3   BUF2FLGS          BUFF2 BUFFER INDEX
         SLS,SR3  5
         LI,SR4   BUF2MSK
         STS,SR3  BUFX,R6           STORE IN DCB
         LW,R5    Y002
         STS,R5   MIUD,R6           SET BUFF2 UPDATED
         STW,R5   INSTFLG           CLEAR FLAG FOR RECOVERY
         B        PULLEXIT          RETURN
         PAGE
*
*  PURPOSE:  DETERMINE IF CURRENT BUFFER HAS ROOM ENOUGH
*            FOR ONE MORE KEY
*
*  INPUT:  D3 = VIRTUAL BUFFER ADDRESS
*
*  CALL:  BAL,R0  COMPLEN
*
*  OUTPUT:  CC SET FOR:
*            BLE  BRANCHES IF ROOM ENOUGH
*            BG   BRANCHES IF NOT ROOM ENOUGH
*           R4 = CURRENT NAV PLUS KEY SIZE (NEW NAV)
*           R5 = CURRENT NAV
*
COMPLEN  RES      0
         LI,SR4   0
SPARE    EQU      19
         LW,D1    IMT,R6            ENTRY SIZE
         LC       *TSTACK
         BCR,2    COMPLEN1          NOT A DIRECTORY
         BCR,4    COMPLEN6          NOT END OF DIRECTORY
         LCW,SR4  D1
         SAS,SR4  1                 TWO SPARE SLOTS
         LW,R4    *D3
         BNEZ     COMPLEN6          NOT 1ST GRANULE
         SAS,SR4  1                 MAKE IT 4 SPARE SLOTS
COMPLEN6 AI,SR4   -11               FOR DUAL BLINK & FLINK
         B        COMPLEN2
COMPLEN1 RES      0
         BCR,4    COMPLEN3          NOT END OF FILE
         LI,SR4   X'FF'
         AND,SR4  SPARE,6
         LCW,SR4  SR4
COMPLEN3 RES      0
         LI,R4    NAVX
         LW,R4    *D3,R4
         CI,R4    X'8000'
         BANZ     COMPLEN4          HERE'S THE FIT
         LW,R4    *D3
         BNEZ     COMPLEN2          NOT FDA EITHER
COMPLEN4 AI,SR4   (NWFITST**2)-XBUFSIZ
COMPLEN2 AI,SR4   XBUFSIZ-1
         LI,R4    X'4000'
         LI,R2    NAVX
         CW,R4    *D3,R2
         BANZ     %+2
         AI,SR4   -(XBUFSIZ/2)
         LI,R2    NAV
         LH,R5    *D3,R2
         LW,R4    R5
         AW,R4    IMT,R6            NEW TENTATIVE SIZE
         CW,R4    SR4               LIMIT CHECK
         B        *R0
         SPACE    3
INST3X1  CI,D3    BUFF2
         BE       INST3X            WE'RE OK
         LI,R0    INST3X            SET RETURN
*  FALL INTO BUFMOVE
*
*  PURPOSE:  SWITCH BUFF2 AND BUFF3.  WILL OBTAIN BUFF2 (AFTER
*              SWITCH) IF ONE DOESN'T EXIST.
*
*  CALL:  BAL,R0  BUFMOVE
*
BUFMOVE  EQU      %
         PUSH     9,D1
         CI,R1    FILCFU
         BG       %+4               NOT A DIRECTORY
         LW,R0    DCDAM
         XW,R0    DBUFF3            XCHANGE DUALS
         STW,R0   DCDAM
         LCI      2
         LM,R0    BUF2FLGS          SWITCH
         LM,R2    BUF3FLGS            BUFF2 AND
         STM,R2   BUF2FLGS              BUFF3
         STM,R0   BUF3FLGS                POINTERS
         LB,SR3   BUF3FLGS
         LI,D3    BUFF3
         BAL,R2   T:SBUF            MAP INTO BUFF3
         LI,D3    BUFF2
         LB,SR3   BUF2FLGS
         BAL,R2   T:MBUF            MAP IT IN
         PULL     9,D1
         B        *R0
         SPACE    3
*
*  PURPOSE:  READ A GRANULE WITH LINK CHECK
*
*  INPUT:  D1 = DISC ADDRESS TO READ
*          D2 = DISC ADDRESS FOR LINK CHECK
*          D3 = VIRTUAL BUFFER ADDRESS
*
*  CALL:  BAL,R0  REDGRANL
*
REDGRANL EQU      %
         MTB,4    R0                RETRY COUNT
         AND,D1   M31
         PUSH     9,D1
         B        REDSEC8           READ THE GRANULE
         SPACE    3
*
*  PURPOSE:  CALL PVQUEUE1, NO-WAIT WRITE WITH END-ACTION
*
*  INPUT:  R2 = BYTE COUNT
*          R7 = END ACTION INFO
*          SR2 = END ACTION ADDRESS (ZERO IF NONE)
*          D1 = DISC ADDRESS
*          D3 = VIRTUAL BUFFER ADDRESS
*
*  CALL:   BAL,R0   WRIT
*
WRIT     EQU      %
         PUSH     9,D1
         CI,R1    FILCFU
         BG       WRTSEC12          NOT A DIRECTORY
         CI,D3    BUFF3
         BNE      WRTSEC12          CATCH IT LATER
         LW,SR1   DBUFF3
         BLEZ     WRTSEC12          PRIVATE
         BAL,SR4  FMCHKDA
         BCR,15   WRTSEC12          NONO
         PUSH     SR2               SAVE END ACTION
         LW,D1    DBUFF3
         BAL,SR3  RWREX1
         OR,SR1   Y06               WRITE ORDER CODE
         BAL,SR4  PVQUEUE
         BAL,SR4  IOSPIN            LINGER AWHILE
         BAL,R0   RESBLK            BALANCE
         PULL     SR2               RESTORE END ACTION
         LW,R4    TSTACK
         LCI      9
         LM,D1    -8,R4             RESTORE REGS
WRTSEC12 RES      0
*
         LW,SR1   D1
         BAL,SR4  FMCHKDA
         BCR,15   WRIT2             BAD DISC ADDRESS
         BAL,SR3  RWREX1
         OR,SR1   Y06               WRITE ORDER CODE
         LW,SR3   R7                MOVE END ACTION INFO
         BAL,SR4  PVQUEUE1
         BAL,R0   RESBLK
         PULL     9,D1
         B        *R0
*
WRIT2    EQU      %
         CI,D3    BUFF3
         BNE      1C0
         LI,D4    1                 IF BUFF3, RESET UPDATED
         STS,D3   BUF3FLGS            FLAG SO THAT INSTCLNUP
         B        1C0                 WON'T COME THRU HERE AGAIN
         PAGE
*
*  PURPOSE:  OBTAIN A BUFFER
*
*  INPUT:  D3 = VIRTUAL ADDRESS OF DESIRED BUFFER
*
*  CALL:  BAL,R0  GETBUF
*
*  OUTPUT:  BUFFER MAPPED INTO DESIRED SPOT
*
GETBUF   EQU      %
         LI,D3    BUFF3             ALWAYS GET BUFF3
         PUSH     6,D3
         BAL,R2   T:GBUF            GET A BUFFER
         AI,SR3   0
         BNE      GBXIT             GOT ONE
         LI,SR3   TOPMSK
         AND,SR3  BUFX,R6           CHECK FOR TOP BUFFER
         BEZ      GTRUNC            NONE
         SLS,SR3  -10               RIGHT JUSTIFY INDEX
         LI,SR4   TOPMSK
         STS,SR3  BUFX,R6           REMOVE INDEX FROM DCB
         BAL,R2   T:MBUF            REMAP BUFFER
         B        GBXIT             GET OUT
*
*  TRUNCATE SOME DCB
*
GTRUNC   EQU      %
         STW,R6   J:BASE+11         SAVE DCB ADDRESS
         LI,R6    0                 INDICATE ANY DCB
         BAL,R0   GETSBUF
         LW,R6    J:BASE+11         RESTORE DCB ADDRESS
         BAL,R0   MAPBUFS           RE-MAP BUFF1 FOR THIS DCB
         LI,D3    BUFF2
         LB,SR3   BUF2FLGS
         BEZ      %+2               NO BUFF2
         BAL,R2   T:MBUF            RE-MAP BUFF2
         LI,R2    -5
         LW,D3    *TSTACK,R2        ADDRESS OF DESIRED BUFFER
         BAL,R2   T:GBUF            GET THE ONE FREED
GBXIT    EQU      %
         PULL     6,D3
         AI,SR3   0                 DID WE GET A BUFFER
         BEZ      GETBUF            NO - TRY AGAIN
         STB,SR3  BUF3FLGS          SAVE BUFFER POINTER
         B        *R0
         PAGE
*
*  PURPOSE:  OBTAIN A GRANULE FOR AN INDEX BLOCK
*
*  CALL:  BAL,R2  GETIGRAN
*
*  OUTPUT:  CC3 AND CC4 RESET IF COULDN'T GET ONE
*           DISC ADDRESS IN SR1 AND D4
*
GETIGRAN EQU      %
         BAL,R0   GETDGRAN
         LW,D4    SR1
         B        0,R2
         TITLE    '**** GETIGRAN ****'
         SPACE    2
*        PURPOSE: TO ALLOCATE A GRANULE FOR KEYED AND CONSECUTIVE
*                 FILES ON EITHER PUBLIC DEVICES OR PRIVATE VOLUME SETS
*
*        INPUT:   R6=DCB ADR
*
*        CALL:    BAL,R0   GETDGRAN
*
*        OUTPUT:  SR1=DISC ADDRESS OBTAINED.
*                 DCB:SWXV SET IF PRIVATE CONSECUTIVE FILE GRANULE
*                   ALLOCATED FROM NEXT VOLUME.
*        IF FILE IS PUBLIC AND
*                   DCB:CFU>FILCFU, THE GRANULE ACCOUNTING CELLS
*                   IN THE JIT ARE MODIFIED.
*        IF J:RNST=0 GRANULE WILL BE ALLOCATED EVEN IF JIT
*          SAYS THERE IS NO SPACE AVAILABLE
*
*        REGS:    ALL REGISTERS SAVED EXCEPT SR1
*
         CLOSE    TAB1
GETDGRAN EQU      %
         PUSH     15,SR2
*----------------------------------*
         BLOCK
*----------------------------------*
         BAL,D2   GETCFU
         BAL,R0   PRIVDCB
         BANZ     GPRIV
         LI,5     PRDCRM
         LI,3     TAB2
         CI,1     FILCFU            FD & AD ALWAYS TRY RAD FIRST
         BLE      ALLODIRB          IT'S A DIRECTORY
         LW,D2    YC                CHK FOR JOB FILE
         CS,D2    FIL1,R6            SPECIFICATION
         BE       GET1              BRANCH IF JOB FILE
         BAL,D2   GETFUN
         CI,D1    5                 IN, INOUT ALWAYS PERM
         BANZ     %+4
         MTW,0    FIL1,R6           IS FILE TEMP
         BLZ      %+2               NO
GET1     LI,R5    TMDCRM            YES, CHARGE FOR TEMP
         MTW,0    RAD1ST            PREFER RAD SET
         BEZ      GG50              NO
         CI,SR4   DCBCYLBIT         YES
         BAZ      ALLOCM1
         LI,3     TAB4
         B        ALLOC
GG50     CI,SR4   DCBNOSEPBIT
         BAZ      GG70
         LI,4     BARNDEV
         LB,4     *6,4              GET DEVICE SPECIFIED
         CI,4     7                 RAD
         BE       ALLOCM1
         CI,SR4   DCBCYLBIT
         BAZ      GET2
GG90     LI,3     TAB3
         B        ALLOC
GG70     CI,SR4   DCBCYLBIT
         BANZ     GG90
         LI,SR2   X'40000'
         CW,SR2   NXTA,R6
         BANZ     ALLOCM1           IT'S A STAR FILE
GET2     CI,R5    TMDCRM            IS IT TEMP
         BNE      ALLOC
ALLOCM1  LI,R3    TAB1
*
* ALLOCATE EM - R3 = TABLE OF WHAT ORDER TO TRY
*               R5 = JIT OFFSET TO DO ACCOUNTING
*
ALLOC    LI,SR2   3
         BAL,D2   GETCFU
         B        0,R3
RETURN   AI,3     1
         BDR,SR2  %-3
ALOCX    LI,D1    X'A'              CAN'T GET GIVE I/O ERR 57
         BAL,R0   SETTYC
         LI,SR1   0
EXIT     PULL     15,SR2
         AND,SR1  M24               SET CC & CLEAR BAD BITS
         B        *R0
*
GRAD     BAL,R2   CHKLIMS           SEE IF RAD AUTHORIZED
         MTW,0    J:JIT,R5          TEST USED IN CHKLIMS
         B        RETURN            LIMIT EXCEEDED                      DISCB
         LI,0     X'7'              CODE FOR GBG
         BAL,SR4  GBG
         BEZ      RETURN            DIDN'T GET, TRY ANOTHER
         B        ACCT
*
GPACK    LW,SR1   GAVAL,R1          ON PACK TRY GAVAL FIRST
         BNEZ     GPACK20           IS SOME, USE ONE
         BAL,R2   CHKLIMS           ISN'T, CHECK LIMITS
         MTW,0    J:JIT+1,R5
         B        RETURN            LIMIT EXCEEDED                      DISCB
         LI,0     X'B'              CODE FOR PACK
         BAL,SR4  GBG
         BEZ      RETURN
         B        ACCT1
GPACK20  LI,R0    EXIT              SET RETURN ADDRESS
GPACK21  EQU         %                                                  DISCB
         MTB,-1      SR1                                                DISCB
         BNEZ        SOME%LEFT                                          DISCB
         LI,SR1   0                 SET TO ZERO                         DISCB
         B           XCHNG%GAVAL                                        DISCB
SOME%LEFT EQU        %                                                  DISCB
*                                   ASSUME 2 SECT/GRAN FOR PACK         DISCB
         LI,R2       1                                                  DISCB
         MTH,2       SR1,R2         BUMP SECTR BY TWO                   DISCB
         BNC         XCHNG%GAVAL    NO CARRY EVERYTHING OK              DISCB
         MTH,-2      SR1,R2         RESET SECTOR ADDR                   DISCB
         BAL,R2      INCREMENT%SECTOR BUMP SECTOR BY 2                  DISCB
XCHNG%GAVAL EQU      %                                                  DISCB
         XW,SR1   GAVAL,R1
         B        *R0
*
GTCYL    LW,SR1   GAVAL,R1          ON CYL, TRY GAVAL FIRST
         BNEZ     GPACK20           IS ONE, GO GET IT
         BAL,SR4  GCYL
         BEZ      RETURN            DIDN'T GET, RETURN
         LB,R0    SR1               GET # GRAN GOTTEN                   DISCB
         BAL,D2   GETCFU            GET CFU ADDRESS IN 1 .DESTROYED BY GCYL
         LW,SR4   J:JIT+1,5         GET CURRENT LIMIT
         BAL,R2   CHKLIMS           TEST TO SEE IF EXCEEDS AUTHORIZED   DISCB
         CW,SR4   R0
         B        REL%CYL           EXCEEDED LIMIT                      DISCB
ACCT2    STW,SR1  GAVAL,R1          GOT IT, STORE IN CFU
         BAL,R0   GPACK21           GO ALLOCATE ONE GRANULE
*
* FALL THROUGH TO DO ACCOUNTING
*
ACCT1    AI,5     1
ACCT     BAL,D2   GETCFU
         LB,R2    SR1
         BNEZ     %+2
         LI,2     1
         CI,R1    BGRCFU
         BL       EXIT              DIRECTORIES DON'T COST
         LI,D2    X'8000'           CHK 4 SHARED
         CW,D2    0,R1
         BAZ      %+4               NOPE
         LW,R1    SCFU,R1
         AWM,R2   SREC,R1
         B        %+2
         AWM,R2   CLK,R6            INCR FILE SIZE
         LI,SR4   DCBPRIVBIT
         CW,SR4   PRIV,R6
         BANZ     EXIT              NO JIT ACCOUNTING FOR PRIV FILES
         LCW,R2   R2
         AWM,R2   J:JIT,R5
         LI,R1    TMPDCPK           SET PEAK TEMP VALUES
         CI,R5    TMDCRM            PERM VALUE
         BL       EXIT              YES, EXIT
         BE       %+2               NO, BRANCH IF RAD
         LI,R1    TMPDPPK           CHANGE TO PACK
         LW,R2    J:JIT,R5          GET PRESENT VALUE
         CW,R2    J:JIT,R1          BIGGER THAN OLD
         BGE      EXIT              YEP, EXIT, WE LOOK FOR SMALL VALUES
         STW,R2   J:JIT,R1
         B        EXIT
*                                                                       DISCB
REL%CYL  EQU      %                 RELEASE CYLINDER                    DISCB
         PUSH     R3                SAVE VECTOR ADDR
         BAL,SR4  RCYL              RELEASE CYL ALLOCATED               DISCB
         PULL     R3                RESTORE VECCTOR ADDRESS
         B        RETURN            RETURN                              DISCB
*
GPRIV    EQU      %
         CI,R1    FILCFU
         BNE      GG128
         MTB,1    CYLFLG            SET FILCFU UPDATED
GG128    LW,SR1   GAVAL,R1          ANY IN CURRENT CYL
         BNEZ     GPACK20           YEP, USE ONE
GG130    BAL,SR4  GPVCYL            TRY TO GET ON CUR VOL
         BEZ      GPRIV20           CAN'T
GG135    RES      0
         LI,R1    X'1FFFF'
         AND,R1   CFU,R6
         B        ACCT2
*
GPRIV20  BAL,D2   GETCFU
         CI,1     FILCFU            MUST BE ON VOLUME 1
         BE       ALOCX             CAN NOT DO, EXIT
         BAL,R0   GETORG
         BL       GG180
         LI,R3    1                 KEYED FILE - START ON VOL 1
GG150    BAL,R0   SETVNO            STORE (R3) IN DCB:VNO
         BAL,D4   SETPVI            POINT DCB TO THIS VOLUME
         BAL,SR4  GPVCYL            IS A CYL AVAIL ON THIS VOLUME
         BNEZ     GG135             YES
         BAL,SR4  NXTVOL            NO - ARE THERE ANY MORE VOLUMES
         BE       ALOCX             NO
         AI,R3    1                 YES - ADVANCE TO NEXT VOLUME
         B        GG150
*
GG180    EQU      %                    *CONSECUTIVE FILE
         BAL,SR4  NXTVOL      R3=VNO       DOES THE NEXT VOLUME EXIST
         BE       ALOCX                        NO,EXIT
         LW,R0    FDA,R1                   IS THIS AN EMPTY FILE
         BNEZ     GG200                        NO
         AI,R3    1
         BAL,R0   SWXPV                 YES,SWITCH TO NEXT VOL
         BAL,R0   GETVNO            CURRENT VOL #
         BNEZ     GG130             VOL SWITCH WORKED
         B        ALOCX             VOL SWITCH FAILED - GET OUT
GG200    BAL,SR4  GNVAT                     ALLOCATE A GRAN FROM NVAT
         BEZ      ALOCX                         NONE AVAILABLE,EXIT
         MTW,1    CLK,R6            INCR FILE SIZE
         LI,R3    DCBSWXVBIT        SET FLAG TO SWITCH TO NEXT VOL
         STS,R3   SWXV,R6
         B        EXIT
*
*
CHKLIMS  LW,D2    Y0038
         AND,D2   J:JIT+PUF         MONITOR GETS NO CHEX
         BEZ      2,R2              MONITOR GETS NO CHEX                DISCB
         CI,R1    BGRCFU
         BL       2,R2              DIRECTORIES DON'T COUNT
         EXU      0,R2              USE TEST PROVIDED
         BG       2,R2              OK FOR ALLOCATION                   DISCB
         B        1,R2              LIMITS EXCEEDED, DON'T ALLOCATE     DISCB
*                                                                       DISCB
*
TAB1     B        GRAD
TAB2     B        GPACK
         B        GTCYL
TAB4     B        GRAD
TAB3     B        GTCYL
         B        GPACK
         B        GRAD
         SPACE    2
ALLODIRB BAL,R0   ALLODIR           GO TO CLS TO ALLOCATE DIRECTORY
         B        ALOCX             ERROR - NOT ENOUGH GRANULES
         B        EXIT              NORMAL RETURN
         PAGE
CLSROOT  LI,R2    HAFLD             GET FILE NAME
         LH,R2    *R6,R2
         AW,R2    FLP,R6
         LW,R3    TSTACK            WHERE NAME WILL BE
         STW,R3   J:BASE            SAVE ADDR OF NAME
         PULL     R4                GET ERROR CODE
         LB,SR3   *R2               NAME LENGTH IN BYTES
         AND,SR3  M5                DON'T GET ANY GARBAGE
         AI,SR3   4                 ROUND UP + KL BYTE
         SCS,SR3  -6                ALIGN FOR LC
         LC       SR3
         LM,R7    0,R2              MOVE NAME TO TSTACK
         PSM,R7   TSTACK
         PUSH     R4                SAVE ERROR CODE
*        REGISTER A TFILE CAL FOR THE JOB FILE
         LI,R7    FPT+1
         BAL,SR4  MSRTFILE
JB1      PULL     SR3               GET ERROR CODE
         LI,R2    0                 RESET THE ERROR AND ABNORMAL
         LI,R3    X'1FFFF'            RETURN ADDRESSES; THEY DON'T
         STS,R2   ERA,R6              BELONG TO THE USER.
         STS,R2   ABA,R6
         CI,SR3   X'FFFFE'          0 & 1 ARE OK
         BAZ      MSRWRTX           A OK
         B        MSR01EXIT
*
FPT      GEN,1,7,7,17 1,X'0F',0,R6  REUSE THE DCB
         DATA     X'D8000050'
         DATA     JB1
         DATA     JB1
         DATA     0
         PZE      *J:BASE
         TITLE    '**** INITMI ****      **** INITMI1 ****'
         SPACE    2
*        PURPOSE: TO INITIALIZE THE FIRST 3 WORDS OF AN INDEX GRANULE
*
*        ENTRIES: IF ENTERED AT INITMI,THE FLINK IS SET TO ZERO
*                 IF ENTERED AT INITMI1,THE FLINK IS SET TO (D1)
*
*        INPUT:   R1=CFU ADR
*                 SR4=DISC ADR OF BLINK
*                 D1=DISC ADR OF FLINK (INITMI1)
*                 D3=DCB:BUF2
*                 D3=ADDRESS OF BUFFER
*
*        CALL:    BAL,R0  INITMI    OR     BAL,R0  INITMI1
*
*        OUTPUT:  CFU:CDAM OR DCBCDAM SET TO ADDR OF GRANULE GOTTEN
*                 D1=0,IF ENTERED AT INITMI
*
*        REGS:    VOLATILE-R2,R5,D1(INITMI)
*
INITMI   EQU      %
         LI,D1    0                 SET FLINK TO ZERO
INITMI1  EQU      %
         LI,R2    BASCR
         LB,D2    *R6,R2
         AW,D2    K3RDWRD           SR4-D2 HAVE 1ST 3 WDS OF MI
         CI,D3    BUFHDR
         BE       IT30              THERE'LL BE ANOTHER TIME
         CI,R1    FILCFU
         BG       IT05              BR IF MI
         STW,D4   CDAM,R1
DDA      EQU      DBLINK-1
         LI,R2    DDA
         STW,SR2  *D3,R2            SET DUAL DA IN BUFFER
         AI,SR4   0
         BNEZ     %+4
DFDA     EQU      8
         STW,SR2  DFDA,R1           SET DUAL OF FDA
         LI,R2    DBLINK
         STW,SR4  *D3,R2            RESET DUAL BLINK ALSO
         AI,D1    0
         BNEZ     %+3
         LI,R2    DFLINK
         STW,D1   *D3,R2            AND DUAL FLINK
         CI,D3    BUFF2
         BE       %+3
         STW,SR2  DBUFF3            BUFF3 DUAL DA
         B        IT30
         STW,SR2  DCDAM             BUFF2 DUAL DA
IT30     LCI      3
         STM,SR4  *D3               INIT 1ST 3 WRDS OF DRCTRY GRAN
         B        *R0               GET OUT
IT05     STW,D4   DCBCDAM,R6
         LW,R2    CFU,R6
         LI,R5    X'8000'           CHK SHARE  CFU
         CW,R5    0,R1
         BAZ      IT06              NOT SHARE
         LW,R2    SCFU,R1
BANGAVAL EQU      12                BA(NGAVAL)
         LI,R5    BANGAVAL
         MTB,1    *R2,R5            COUNT OF LINK CHANGES
IT06     RES      0
         AI,D1    0                 CHK 4 LDA
         BNEZ     %+3               BR IF NOT
         STW,D4   LDA,R1
         STW,D4   LDA,R2
         LC       *R1
         BCR,2    %+2
         AI,D2    X'100'            SET ADDED FLAG IN MI
         LI,R2    3
         MTB,1    *R1,R2            INCREMENT CFU:SLIDES
         BEZ      IT20
         LW,R2    0,R1              SLIDES
         LI,R5    4*19+1            LSLIDES LOC
         CB,R2    *R6,R5
         BLE      IT301             STILL OK
IT20     LI,R5    X'FF'                         NO,SET SLIDES IN CFU
         STS,R5   0,R1                             SO THAT HIGHER LEVEL
*                                                  REBUILT AT CLOSE
IT301    LCI      3                 INIT 1ST 3 WORDS OF MI
         STM,SR4  *D3
         DO       1
         B        *R0
         ELSE
         LW,R5    0,R1              GET OUT IF
         CB,R5    Y04
         BL       *R0               GET OUT IF NOT ENUF LEVEL 0'S
         CW,R5    =X'20008000'       LVL 1 EXISTS OR
         BANZ     *R0                 SHARED
         DO       XTRB
         CI,R5    X'A00'            CHK FOR CREATE
         BAZ      IT99              BRANCH IF NOT
         LI,R2    2                 CHK FOR DIRECT ACCESS
         CW,R2    ACS,R6
         BAZ      *R0               GET OUT IF SEQUENTIAL
         FIN
IT99     AI,D1    0                 IS FLINK ZERO
         BNEZ     IT97              SKIP IF NOT
         LW,R2    TDA,R1            IS THERE A TOP YET
         BEZ      *R0               DON'T START IF STILL IN ORDER
IT97     LW,R2    CDA,R6            SAVE FOR UNBLOCKED DATA
         PUSH     10,SR4
         LW,D1    TDA,R1            IS THERE A MULTI GRANULE
         BNEZ     IT100             BRANCH IF THERE IS
         LB,R5    JB:FBUL           UNLESS FPOOL
         AI,R5    -JXBUFVP-3         IS GREATER
         BLEZ     PULLE               OR EQUAL 5
         LI,R5    LSLIDES
         LB,R5    *R6,R5
         AI,R5    -X'FF'            IS MULTI PROHIBITED
         BEZ      PULLE             SKIP IF IT IS
         BAL,D2   GETUP             GET A GRANULE FOR LIST OF DISK ADDRESSES
         DO       XTRB
         B        PULLE             BRANCH IF NONE AVAILABLE
         ELSE
IT991    RES      0
         FIN
         LI,R2    X'88000' -X'78000' ADJUST
         AWM,R2   BUFF1+NAVX         CONTROL WORD
         LW,R2    TSTACK
         LW,R5    LDA,R1            LAST LVL0 GRANULE
         LW,R4    -8,R2             CURRENT FLINK
         LW,R3    DCBCDAM,R6        CURRENT LVL 0 GRANULE
         LW,R2    -9,R2             CURRENT BLINK
         LW,R1    FDA,R1            FIRST LVL 0 GRANULE
         CW,R5    R4                IS FLINK THE LAST
         BE       IT983             SKIP IF SO
         CW,R1    R2                IS BLINK THE 1ST
         BE       IT985             SKIP IF SO
         MTH,1    BUFF1+NAVX        THERE ARE 5 SIGNIF
IT983    LCI      5                 MAYBE ONLY 4 SIGNIF
         STM,R1   BUFF1+NAVX+1      MOVE 'EM IN
         B        IT95
*
IT985    LCI      4
         STM,R2   BUFF1+NAVX+1
IT95     LW,D2    Y004              MARK
         STS,D2   BBUD,R6            UPDATED
IT96     LI,R0    PULLE             SET THE RETURN
         LW,R1    CFU,R6
         LI,R2    509               MAX # ENTRIES
         CH,R2    BUFF1+NAVX
         BG       CLRBBUF
         LW,SR4   Y2                SET THE
         STS,SR4  0,R1               O BIT
         B        CLRBBUF           TRUNC THE BLKNG BFR
         SPACE    2
PULLEM   BAL,R0   CLRBBUF
         LW,R1    CFU,R6
         LI,R2    0
         STW,R2   TDA,R1            BLITZ THE GARBAGE
         STW,R2   BCDA,R6           ZAP DSK ADDR FOR IMAGE4
PULLE    PULL     10,SR4            RESTORE REGS
         STW,R2   CDA,R6             & CDA FOR BLOCKED DATA
         B        *R0               TO GET OUT
         SPACE    2
IT100    BAL,R0   REDSECB           READ THE GRANULE LIST
         B        PULLEM            BAD NEWS
         LI,R1    X'8400'           VALIDITY CHECK
         CS,R1    BUFF1+NAVX
         BNE      PULLEM            BAD NEWS
         LD,R0    BUFF1             ANOTHER CHECK
         BNEZ     PULLEM
         LH,R1    BUFF1+NAVX        # OF GRANULE ADDRS IN TABLE
         BLEZ     PULLEM
         CI,R1    509               MAX CAPACITY
         BGE      PULLEM
         LW,R2    TSTACK
         LW,R0    DCBCDAM,R6
         LW,R4    -9,R2             BLINK
         LW,R5    -8,R2             IS FLINK ZERO
         BEZ      IT106
IT104    CLR,R4   BUFF1+NAVX,R1     LOOK UP POSITION
         BCR,12   IT105
         BE       IT106
         BDR,R1   IT104
         STW,R1   BCDA,R6           ZAP THE DSK ADDR FOR IMAGE4
         B        IT96              POSITION NOT LOCATABLE
         SPACE    2
IT106    AI,R1    1
IT105    LH,R3    BUFF1+NAVX
         CI,R3    509               IS IT FULL
         BGE      IT95              BRANCH IF IT IS
         MTH,1    BUFF1+NAVX        ADD AN ENTRY
IT108    CW,R1    R3                ARE WE POSITIONED CORRECTLY
         BG       IT109             SKIP IF WE ARE
         LW,D3    BUFF1+NAVX,R3     SLIDE
         STW,D3   BUFF1+NAVX+1,R3    DOWN
         BDR,R3   IT108
IT109    STW,R0   BUFF1+NAVX,R1     ENTER NEW ENTRY
         CLR,R4   R0                IS THIS 2ND TIME AROUND
         BE       IT95              BRANCH IF
         BCR,12   IT95               IT IS
         CW,R4    BUFF1+NAVX-1,R1   CAN WE INSERT A 2ND
         BE       IT107             SKIP IF BLINK ALREADY IN
         LW,R0    R4                PUT THE
         B        IT105              BLINK IN
IT107    CW,R5    BUFF1+NAVX+1,R1   HOW ABOUT THE FLINK
         BE       IT95              BRANCH IF ALREADY IN
         LW,R0    R5                INSERT THE FLINK
         BNEZ     IT106              IF THERE IS ONE
         B        IT95              NOTHING MORE TO DO
         FIN
         SPACE    3
         TITLE    '**** ENTKEYUB ****'
IOSEQUB1A EQU     %
*  INSERT A NEW RECORD INTO A KEYED FILE.
         LW,R1    Y3                CHK
         AND,R1   ONWK,R6            NWK & ONWK
         BEZ      KEYER4            ISN'T
IOSEQUB4 LI,R3    K0  TRANSFER KEY TO USER'S BUFFER
         LW,D3    KAD,R6
         BAL,R1   KEYTRAN           PUT KEY IN KBUF
         LI,R0    MSREXIT           SET RETURN
         SPACE    3
*                                   INSERT RECORD INFO INTO MASTER
*                                   INDEX AND WRITE OUT RECORD
*                                   CMD= POINTER TO WHERE INSERTION
*                                   BEGINS
*
         LI,D4    0                 FOR ENCRYPTION SEED FOR MULTI-
*                                    SEGMENT RECORDS
         PUSH     2,D4
*
*
*                                   GO BACK TO PREVIOUS SECTOR IF CMD
*                                   = MIDIS
         LI,R2    X'F0000'
         AND,R2   CMD,R6
         CW,R2    Y000C
         BNE      ENTKEYUB2
         LW,D1    BUFF2             IS THERE A BLINK
         BEZ      ENTKEYUB2
         BAL,R2   1A8               READ CDAM SECTOR & PT TO END
*
ENTKEYUB2 EQU     %
*                                   INITIALIZATION
         BAL,SR4  INITARS
ENTKEYUB1  EQU    %
*                                   BLOCKING ROUTINE FOR OUTPUT OF
*                                   NEW KEYS
*
         LW,D1    RWS,R6
         BEZ      BLK0              ENTER KEY BUT DONT WRITE
         LI,R0    X'1FFFF'          IS
         AND,R0   ENCRYPT,R6         ENCRYPTION
         BNEZ     BLK6                SPECIFIED
         LI,R0    UBLKD
         CI,D1    BUFSIZ-15         CHECK FOR UNBLOCKED
         BGE      CLRBBUF           TRUNC BUF1,WRT UNBLKD
*                 WRITE BLOCKED
*
BLK6     RES      0
         LI,D3    BUF1MSK
         AND,D3   BUFX,R6
         BEZ      BLK1              NO BUFFER
         LI,D3    BUFF1
         LI,R3    X'E0000'
         AND,R3   CBD,R6
         BEZ      BLK3
         CW,R3    Y1
         BGE      BLK3
         SCS,R3   15
         LI,R4    BLK4              SET RETURN IF NOT FULL
BLK44    CI,R3    BUFSIZ-40         ARE WE ALMOST FULL
         BL       0,R4              GET OUT IF NOT
         LCW,R0   R3
         AI,R0    BUFSIZ            SPACE REMAINING
         CW,R0    RWS,R6            IS IT ENUF
         BGE      0,R4              GET OUT IF RECORD WILL FIT
         LW,R3    CFU,R6
         LI,R1    X'F0000'          THROW AWAY THE BLKNG
         STS,R0   CCBD,R3            BUFFER REMAINDER
         B        BLK3
*
BLK4     EQU      %
         LW,R1    BFL,R6
         CW,R1    Y008
         BAZ      %+2               NO NEED TO WAIT
         BAL,SR4  IOSPIN
         LI,R1    HAPBD
         STH,R3   *R6,R1            SAVE PBD
         LI,R4    X'30'
         AND,R4   BTD,R6            BYTE
         SLS,R4   -4                 DISPLACEMENT
         LW,D4    QBUF,R6           USER BUFFER
         ANLZ,R4  RBLK4
         LI,R2    BUFSIZ
         SW,R2    R3
         CW,R2    RWS,R6
         BLE      %+2
         LW,R2    RWS,R6
         BAL,0    SVSIZ             SIZE IN R2
         ANLZ,R5  BUFF1R3 BUFF1,R3  BUFFER BYTE ADDRESS
         AW,R3    R2                NXT BFR POSN
         AI,R3    3
         AND,R3   YFFFFFFFC
         AI,R2    -256
         BLZ      RBLK1
RBLK2    OR,R5    YFC               MOVE 252 BYTES
         MBS,R4   0
         AI,R2    -252
         BGEZ     RBLK2
RBLK1    STB,R2   R5
         MBS,R4   0
         BAL,0    SAVCBD
         LW,R3    Y004              SET UPDATE FLAG
         STS,R3   BFL,R6
         LI,R1    X'1FFFF'          IS ENCRYPTION
         AND,R1   ENCRYPT,R6         SPECIFIED
         BEZ      BLK5M1            BRANCH IF NOT
         LW,R4    KBUF,R6           GENERATE
         LW,SR2   0,R4               RANDOM NUMBER
         SLS,SR2  -16                 SEED
         LI,R7    X'FFFF'           MONITOR
         AND,R7   PBD,R6             BUFFER
         SLS,R7   -2                  OFFSET
         AI,R7    BUFF1                & BUFFER ADDRESS
         LI,R4    BLK5M1            SET RETURN
CONCR1C  LW,SR3   BLK,R6             RECORD SIZE
         AI,SR3   X'60000'            IN
         SLS,SR3  -19                  WORDS
         LW,R5    ARS,R6            GET SLOT IN TSTACK
         SLS,R5   -17
         MTW,0    TSTACK-2,R5       IS THIS A CONTINUATION
         BEZ      %+3               SKIP IF NOT
         LW,SR2   TSTACK-2,R5       PICK UP THE PREVIOUS ENTRY
         B        CONCR1            GO ENCRYPT
         EOR,SR2  0,R1              RANDOM NUMBER SEED
         OR,SR2   X1                MAKE IT ODD
         B        CONCR1            GO ENCRYPT
         REF      CONCR1
BLK5M1   RES      0
         LW,R0    Y0008
BLK5     EQU      %
         LW,R1    Y0008
         STS,R0   BFL,R6            BLOCKED RECORD
BLK0     EQU      %
         BAL,SR4  ENTER2
         LW,D1    RWS,R6
         BLEZ     TRANX
*                                   CHECK FOR ABORT
*
         BAL,R4   GETTYC           *WAS ENTER2 ABLE TO ALLOCATE THE
         CI,R3    KA                NECESSARY DATA AND INDEX GRANULES
         BNE      ENTKEYUB1             YES
*                                       NO,EXIT WITH 'DISK SAT' CODE
SATDISK  LI,D1    KA
         LI,R0    TRANX
         B        SETTYC
*
BUFF1R3  LB,0     BUFF1,R3          FOR ANLZ INSTRUCTION
*
BLK3     EQU      %
         LW,R0    Y004
         CW,R0    BBUD,R6           CHECK BUF1 UPDATED FLAG
         BAZ      BLK1
         BAL,R0   CLRBBUF           WRITE OUT UPDATED BUFFER IN NEC
*
BLK1     EQU      %
         LW,R1    CFU,R6
         LW,D3    SREC,R1
         LI,R4    HACCBD
         LH,R3    *R1,R4
         BNEZ     %+3
UBLKD    RES      0
         BAL,R0   GETDGRAN          ALLOCATE A DATA GRANULE
         LW,D3    SR1
         AI,D3    K0
         BE       SATDISK
         STW,D3   CDA,R6
         LW,D1    RWS,R6
         CI,D1    BUFSIZ-15
         BL       BLK4A             WRITE BLOCKED
         LI,R0    X'1FFFF'          IS
         AND,R0   ENCRYPT,R6         ENCRYPTION
         BNEZ     BLK4A               SPECIFIED
         LI,R2    BUFSIZ
         BAL,R0   SVSIZ
         LI,R1    X'F0000'
         AND,R1   PBD,R6
         STW,R1   PBD,R6
         B        BLK5
BLK4A    EQU      %
         BAL,R0   SAVCBD            SET UP AVAIL LOC
         STW,D3   BCDA,R6           SAVE BLOCK DISK ADR AND SIZE
         BAL,R0   GETBBUF           GET BLOCKING BUFFER
         LW,D1    RWS,R6
         BAL,R0   GETCBD
         BEZ      BLK4              NEW BLOCK, GO MOVE
         BAL,R4   BLK44             CHK IF IT'S FULL OR NOT
         PUSH     8,D1              OLD BLOCK, GET IT IN
         BAL,R4   RW3A
         B        BLK4
RBLK4    LB,R1    *D4,R4            FOR ANLZ
*
SVSIZ    EQU      %
         SW,D1    R2                DECREMENT NO REMAINING
         STW,D1   RWS,R6
         BGEZ     %+2
         AW,R2    RWS,R6            ADJUST SIZE
         LW,D1    R2
         B        SAVBLK
         TITLE    '**** IMAGEREC ****'
INST2Y   CI,D3    BUFF2
         BE       INST3Y
INST2YA  BAL,R0   BUFMOVE           XCHNG BUFF2 & BUFF3
*                                   INSERT IMAGE OF KEYED RECORD
*                                   TRANSFER KEY TO BUFFER
INST3Y   STH,R4   BUFF2+NAVX        NEW NAV
IMAGEREC EQU      %
         LW,R0    BUFF2
         LI,R1    X'1FFFF'
         AND,R1   CFU,R6
         CI,R1    FILCFU
         BNE      %+2
         STW,R0   FILCFU+16         SET CDAM LINK CHECK IF FD
         LI,R4    X'30'
         AND,R4   0,R6              BTD
         SLS,R4   2
         LW,R5    Y00FE
         STS,R4   2,R6              RESET TYC
         LW,R5    Y02               CLEAR TRN
         STS,R4   5,R6
         AW,R4    Y0008             WRITE EOP
         LW,R5    =X'C10C0'
         STS,R4   0,R6
         LW,R4    KBUF,R6
         SLS,R4   2
         ANLZ,R5  SLOW2+1
         LB,R0    0,R4              TEXTC COUNT OF KEY
         AND,R0   M5                MASK EXTRANEOUS BITS
         AI,R0    1                 COUNT TEXTC COUNT
         STB,R0   R5                PUT IN FOR MBS
         MBS,R4   0                 MOVE KEY FROM KBUF TO MI
*  NOTE:  ONLY THE KEY LENGTH # OF BYTES IS MOVED RATHER THAN
*    SCR BYTES TO PREVENT PASSWORD FROM ENDING UP IN MI GRANULE
*    IF FILE NAME IS SHORT.
         DO       0
         DO       XTRB
         CI,R3    MIDIS             IS IT THE 1ST ENTRY
         BNE      1E1               NO ACTION
         LW,R5    0,R1
         CI,R5    X'A00'            IS IT A CREATE
         BAZ      1E1               NOPE, IT'S UPDATE
         CW,R5    Y2                HAVE WE BEEN SHUT OFF
         BANZ     1E1               BRANCH IF NO MORE BUILD
         LI,R5    2
         CW,R5    ACS,R6            IS ACCESS SEQUENTIAL
         BANZ     1E1               BRANCH IF NOT
         CI,R1    FILCFU            IS IT A FILE
         BLE      1E1               SKIP IF NOT
         LB,R5    JB:FBUL           UNLESS FPOOL
         AI,R5    -JXBUFVP-3         IS GREATER
         BLEZ     1E1                 OR EQUAL 5
         LW,D1    TDA,R1            HAVE WE STARTED
         BNEZ     REDUP             BRANCH IF WE HAVE
         LW,D2    BUFF2             IS IT FDA
         BEZ      1E1               BRANCH IF SO
         LI,R5    LSLIDES
         LB,R5    *R6,R5
         AI,R5    -X'FF'            IS MULTI PROHIBITED
         BEZ      1E1               SKIP IF IT IS
         LW,SR1   CDA,R6            SAVE FOR UNBLOCKED
         PUSH     SR1                DATA DISK ADDRESS
         LI,SR1   DCBCYLBIT+DCBPRIVBIT
         AND,SR1  PRIV,R6           IS IT CYLINDER
         BNEZ     SETGG             SKIP IF SO
         XW,SR1   XTRAGRAN          IS THERE AN EXTRA HANDY
         BEZ      SETGG             SKIP IF NOT
         BAL,SR4  FMCHKDA           IS IT A GOOD ONE
         BCR,15   SETGG             NONO
         LI,D2    SETGG+1           SET RETURN
         B        GETUP+2
SETGG    BAL,D2   GETUP             START LVL 1
         B        1E1M              NO GRANULES
         B        REDUP1
*
REDUP    LW,R0    CDA,R6            SAVE FOR UNBLOCKED
         PUSH     R0                 DATA GRANULES
         BAL,R0   REDSECB           READ THE TOP
         B        SETO              SET O BIT & GET ON WITH LVL 0
         LW,R0    BUFF1+FLINK       VALIDITY CHECK
         BNEZ     SETO
REDUP1   LH,R5    BUFF1+NAVX
         CI,R5    MIDIS             ANOTHER CHECK
         BGE      REDUP11           BRANCH IF OK
SETO     LW,R1    CFU,R6
         LW,SR4   Y2
         STS,SR4  0,R1              SET THE O BIT
         B        1E1M
*
REDUP11  LI,R2    X'FF'
         AND,R2   BUFF1+NAVX        SCR
         AI,R2    4                 SPACE FOR DSK ADDR
         AH,R2    BUFF1+NAVX        TENTATIVE NEW NAVX
         CI,R2    2048
         BLE      REDUP2            BRANCH IF ROOM ENUF
         LI,D2    GETUP2            SET RETURN
         ELSE
         B        1E1
         FIN
GETUP    BAL,R0   GETDGRAN          GET AN UPPER GRANULE
         DO       XTRB
         BEZ      *D2               NONE AVAILABLE
         LI,R2    3
         LW,R1    CFU,R6
         MTB,1    *R1,R2            BUMP SLIDES
         BNEZ     %+2               SKIP IF OK
         MTB,-1   *R1,R2            BACK TO X'FF'
         ELSE
         B        PULLE
         FIN
         LI,R2    0                 ASSUME NO BLINK
         XW,SR1   TDA,R1            SET NEW TOP
         DO       XTRB
         CI,D2    GETUP2            CHK ASSUMPTION
         BNE      GETUP1            BLINK IS 0
         LW,R2    SR1               OLD TDA IS BLINK
         LW,R3    Y004              CHANGE
         STS,R3   BBUD,R6            THE
         LW,R3    TDA,R1              FLINK
         STW,R3   BUFF1+FLINK
         FIN
GETUP1   BAL,R0   CLRBBUF
         BAL,R0   GETBBUF
         LI,R3    0                 FLINK IS 0
         STD,R2   BUFF1             SET BLINK & FLINK
         LI,R2    BASCR
         LB,R2    *R6,R2            SCR FOR REDSEC CHK
         AW,R2    =X'C0400'
         STW,R2   BUFF1+NAVX
         LW,R2    TDA,R1
         STW,R2   BCDA,R6           FOR CLRBBUF LATER
         DO       XTRB
         LW,R2    D2
         B        1,R2              NORMAL RETURN
         ELSE
         B        IT991
         FIN
         DO       XTRB
*
GETUP2   B        SETO
         B        REDUP1
         SPACE    2
REDUP2   STH,R2   BUFF1+NAVX        NEW NAV FOR UPPER
         LW,SR4   Y004              MARK
         STS,SR4  BBUD,R6            UPDATED
         AI,R5    BUFF1**2          DESTINATION
         LW,R0    BUFF1+NAVX
         STB,R0   R5                COUNT
         LI,R4    BUFF2**2+MIDIS    SOURCE
         MBS,R4   0                 MOVE THE KEY
         LI,R0    4
         STB,R0   R5                COUNT
BUFF2DAB EQU      BUFF2DA+BUFF2DA+BUFF2DA+BUFF2DA
         LI,R4    BUFF2DAB          SOURCE
         MBS,R4   0                 MOVE THE DISK ADDRESS
         BAL,R0   CLRBBUF
         LW,R1    CFU,R6
         LI,R3    X'FF'
         CS,R3    0,R1              IS SLIDES AT MAX
         BE       1E1M
         LI,R3    3
         LI,R4    5                 COUNT 1ST 4 LVL 0'S
         CB,R4    *R1,R3
         BGE      1E1M
         MTB,-1   *R1,R3            REDUCE SLIDES
1E1M     LI,R3    MIDIS
         PULL     R0                RESTORE FOR UNBLOCKED
         STW,R0   CDA,R6             DATA DISK ADDRESS
         FIN
         FIN
1E1      LW,R0    SCR,R6
         LB,R0    R0
         AW,R3    R0
         LI,D1    X'E0000'
         AND,D1   BLK,R6
         BEZ      IMGZ              WRITE ZERO RECORD LENGTH
*
         SCS,D1   15
         AI,D1    3                 ROUND UP
         AND,D1   YFFFFFFFC         D1=# BYTES TO RESERVE IN BUF1
         LW,R0    PBD,R6            PBD=BYTE INDEX IN BUF1
         STH,R0   D1
         BAL,R4   SLOW3
*
         LW,D1    BCDA,R6
         BNEZ     %+3
         LW,R1    CFU,R6            BUFF1 TRUNCATED - DISC ADDR
         LW,D1    SREC,R1             MOVED TO SREC IN CFU
         LW,R4    Y0008
         CW,R4    BFL,R6
         BANZ     IMAGE4
         LW,D1    CDA,R6
IMAGE4   EQU      %
         BAL,R4   SLOW3
         BAL,R4   SLOW1
*
         LI,D1    0                 ASSUME NO FLAGS
         LW,R4    RWS,R6
         BLEZ     IMG2
         LI,D1    1                 CONTINUATION
IMG2     EQU      %
         LW,R4    16,R6             NLR
         CI,R4    X'20000'
         BAZ      %+4
         AI,R4    -X'20000'
         STW,R4   16,R6             RESET NLR
         AI,D1    4                 SET FAK
         STB,D1   BUFF2,R3
         AI,R3    3
         LI,R2    HACMD
         STH,R3   *R6,R2            SET CMD
*
*  WRITE OUT UPDATED BUFFERS, RESET DCB VALUES
*
         BAL,SR4  INSTCLNUP
         LI,R0    X'E0000'
         AND,R0   BLK,R6
         BEZ      PULLEXIT          ZERO LENGTH RECORD
*
*
*                                   WRITE RECORD
         LW,R0    Y0008             BLOCKED RECORD
         CW,R0    BFL,R6
         BAZ      IMAGE2            NO--WRITE UNBLOCKED
         BAL,R0   GETCBD            SHOULD BLOCK BE WRITTEN
         CI,R3    BUFSIZ
         BL       IMAGE3
         BAL,R0   CLRBBUF           WRITE IT
*
IMAGE3   EQU      %
         LW,D1    BLK,R6
         SLS,D1   -17
         LW,R1    ARS,R6            CALCULATE ADR OF 'ARS' IN TSTACK
         SLS,R1   -17
         AWM,D1   TSTACK,R1
         SLS,D1   -2
         LI,D2    X'1FFFF'
         AW,D1    QBUF,R6
         STS,D1   QBUF,R6           UPDATE QBUF, DON'T OVERFLOW FIELD
         B        PULLEXIT
IMAGE2   EQU      %
         LI,R4    1                 WRITE DATA GRANULE
         BAL,SR4  PVREADTP
         LI,R3    K0
         BAL,R0   SAVCBD
         B        IMAGE3
*
*
*
IMGZ     EQU      %
         LI,SR4   10
         LI,R1    X'1FFFF'
         AND,R1   CFU,R6
         CI,R1    FILCFU
         BG       %+2
         LI,SR4   6
         LI,R4    IMG2
         B        SLOW2+1
         TITLE    '**** REWRITEUB ****'
RW1      EQU      %
*                                   RECORD GT OR EQ TO ORIG
         LW,R0    RWS,R6
         BEZ      RW2
         LW,R1    R3
         AI,R1    -7
         MTB,0    BUFF2,R1
         BNEZ     RW11
         AI,R1    -1
         MTB,0    BUFF2,R1
         BNEZ     RW11
*
*        SIZE OF REC TO BE UPDATED WAS ZERO LENGTH, BUT UPDATE IS NON-0.
*                 REMOVE OLD KEY, THEN INSERT RECORD
         AI,R1    11                NEXT ENTRY POSITION
         LI,R2    HACMD
         STH,R1   *R6,R2            UPDATE DISPLACEMENT IN DCB
         SW,R1    IMT,R6            BACK UP TO NO DATA ENTRY
         LI,R7    0
         STB,R7   *D3,R1            CLEAR KEY
         LW,R7    Y002
         STS,R7   MIUD,R6           MI CHANGE
         B        ENTKEYUB1         NOW GO INSERT NON-ZERO LENGTH RECORD
RW11     EQU      %
*                                   SET CONT BIT
         OR,R2    X1
         STB,R2   BUFF2,R3
         AI,R3    KN2
         BAL,R7   STORSIZ
         LW,D1    BLK,R6
         SLS,D1   -19
         AWM,D1   QBUF,R6
*
RW4      RES      0
         LI,R1    -X'20000'
         OPEN     NLR
NLR      EQU      16
         AWM,R1   NLR,R6            RESET NLR
         B        ENTKEYUB1
*
RW2      EQU      %
*                                   REC LESS THAN ORIG
         BAL,R0   GETCMD
RW22     EQU      %
         BAL,R7   STORSIZ
         CI,R4    K1
         BAZ      TRANX
*
         CH,R3    BUFF2+2           CHK NAV
         BL       RW21
         LW,D1    BUFF2+FLINK       GET FLINK
         BEZ      TRANX
         BAL,R0   GETCSA
         BAL,R0   REDSECL           READ SECTOR WITH LINK CHECK
         BAL,R0   SETCMD
RW21     EQU      %
         AW,R3    IMT,R6
         AI,R3    -3
         LB,D1    BUFF2,R3
         CI,D1    4
         BANZ     TRANX
         AI,R3    -2
         LI,D1    K0
         BAL,R0   SAVBLK
         B        RW22
*
*
RW3      EQU      %                 READ IN BLOCK FOR UPDATE
         LW,R7    R3
         LW,SR1   R6
         LI,R4    UBLK              FORCE RETURN
RW3A     PUSH     R4
         BAL,R0   SETBLK
         BAL,D4   SETBTDZ           ZERO MON BYTE DISPL
         LI,R2    BUFSIZ
         LI,D3    BUFF1
         BAL,SR4  PUTSZBF
         LI,R4    0                 READ DATA GRANULE
         BAL,SR4  PVREADTP
         BAL,SR4  IOSPIN
         BAL,R0   RESBLK
         PULL     9,D1
         B        0,R4
*
UPDBLK   EQU      %                 FROM RDF TRNS
         AI,R3    -1                R3 IN NOW POINTING AT LO ORDER MI BL
         SLS,D1   -17               BYTES RIGHT ADJUSTED
         STB,D1   BUFF2,R3          LO ORDER MI BLK
         SCS,D1   -8                GET REMAINDER OF DCB BLK
         AI,R3    -1                R3 POINTING AT HI ORDER MI BLK
         STB,D1   BUFF2,R3          MI BLK NOW UPDATED
         SCS,D1   6                 BLKSIZ NOW HAS WORD ALIGNMENT
         AI,R3    5                 R3 POINTING AT NEXT ENTRY ON MI
         LW,D2    Y002
         STS,D2   MIUD,R6           SET BUF2 UPDATED
         B        BFRMWR            BACK TO RDF
*
STORSIZ  EQU      %
*                                   UPDATE NEW BYTE COUNT
         LI,D3    BUFF2
         LI,R4    STORSIZ1
SLOW1    LW,D1    BLK,R6
         SLS,D1   -1
         LI,SR4   2
SLOW2    SCS,D1   8
         STB,D1   BUFF2,R3
         AI,R3    1
         BDR,SR4  SLOW2
         B        0,R4
SLOW3    LI,SR4   4
         B        SLOW2
STORSIZ1 RES      0
         BAL,R0   SETEOPW
         LB,R4    BUFF2,R3
         AI,R3    K3
         LW,R0    R7
         B        SETCMD1
         TITLE    '**** RWRAND ****'
*D*  NAME:         RWRAND
*D*
*D*  REGISTERS:    ALL VOLATILE
*D*
*D*  CALL:         BRANCH FROM IOSFILE OR ISEQUB
*D*
*D*  INPUT:        R6 = DCB ADDRESS
*D*                R7 = FPT ADDRESS
*D*                R8 = FPT CODE (X'10' = READ, X'11' = WRITE)
*D*
*D*  DESCRIPTION:  IF FILE IS BEING CLEANED, USER IS PARKED.
*D*                IF # BYTES TO READ/WRITE IS ZERO, CURRENT BLOCK
*D*                # IN KBUF OF DCB IN INCREMENTED AND ROUTINE EXITS.
*D*                REQUESTED BLOCK # AND # BYTES ARE CHECKED TO
*D*                INSURE THAT REQUESTED BLOCKS LIE WITHIN THE FILE
*D*                (I/O ERROR 42 IF THEY DON'T).
*D*                THE FILE IS THEN READ/WRITTEN IN TRACK SIZE
*D*                CHUNKS (TO MAKE FLAWED TRACK AND CYLINDER CROSSING
*D*                WORK RIGHT).  THE DISC ADDRESS IS INCREMENTED
*D*                AFTER EACH I/O.  IF IT GOES BEYOND THE END OF
*D*                THE DEVICE, IT IS CHANGED TO SECTOR ZERO ON
*D*                THE NEXT DEVICE (FOR PRIVATE, TO THE FIRST SECTOR
*D*                BEYOND THE VTOC ON THE NEXT VOLUME).
*
         SPACE    2
RWRAND   BAL,D4   SETBTDQ           MOVE UBTD TO HBTD
         LI,D1    0
         BAL,R0   SETTYC            CLEAR TYC
****************************************************************
         BLOCK                      FORCE TO MASTER CPU
****************************************************************
         LW,R1    CFU,R6            GET CFU ADDRESS
         BAL,R0   GZQUS             WAIT IF BEING CLEANED
         B        GZBREAK           USER ESCAPED
         LI,R3    X'1FFFF'
         LS,R2    BUF,R6            MOVE BUFFER ADDRESS
         STS,R2   QBUF,R6           FOR QUEUE
         LW,R5    KBUF,R6           GET ADDRESS OF KBUF
         LW,SR3   RWS,R6            GET NUM BYTES TO READ/WRITE
         BNEZ     BKGRND
         MTW,1    0,R5              ZERO LENGTH, UPDATE KEY
         B        RWRDUN1           SET ARS AND GET OUT
BKGRND   EQU      %
         AND,R6   M17               SCRUB OFF BAD BITS
         LW,R1    CFU,R6            GET CFU ADDRESS
         CI,SR1   X'11'             IS WRITE SPECIFIED
         BNE      %+3               NO, ZERO IS CORRECT FC
         LI,R4    4                 YES, 4 IS FC
         STB,R4   R6
         LW,D4    TDA,R1            TOTAL GRANULES IN FILE
         SW,D4    0,R5              - RELATIVE GRANULE
         BLE      ERR01
         LW,SR1   SR3               GET REQUESTED SIZE
         AI,SR1   2047              ROUND UP
         SLS,SR1  -11               MAX #GRANS TO READ
         CW,SR1   D4                BIGGER THAN FILE
         BLE      %+3               NO,OK
         SLS,D4   11                YES, ALLOW ONLY FILE SIZE
         LW,SR3   D4                TO BE READ/WRITTEN
         STW,SR3  J:BASE+4          AND SAVE # TO READ
         LW,SR1   FDA,R1            GET STARTING DISC ADDRESS
         LW,D3    0,R5              GET RELATIVE GRANULE
         BLZ      ERR01             NEGATIVE ALSO BAD
         LCI      2
         STM,R5   J:BASE
         SLS,D3   1                 CONVERT REL GRAN TO REL SECTOR
         BAL,R3   FNDHGP            GET HGP ADDRESS IF PUHLIC
RWR23    LI,R4    DCBPRIVBIT        CHECK FOR PRIVATE
         CW,R4    PRIV,R6           RANDOM FILE
         BAZ      RWR24             NO. ITS PUBLIC
         LDCTX,R3 SR1               LOCATE HGP FOR THIS VOLUME
         BAL,R0   SETVNO
         BAL,D4   SETPVI            SET PV INDICATORS
         LI,R4    X'FF'             MASK
         AND,R4   1,R7              NUMBER OF GRAN PER CYL
         SLS,R4   1                 CONVERT TO SECTORS
         LW,SR2   SECTOR#MASK       IF BELOW NVAT, ADD CYLS UNTIL IT ISNT
         CS,SR1   =60
         BGE      RWR24
         AW,SR1   R4
         B        %-3
RWR24    AI,R7    1                 POINT TO WORD 1 OF HGP
         LH,R5    *R7               GET DCT INDEX
         LB,R5    DCT22,R5          GET SUBTYPE
         LW,SR2   DISCLIMS,R5
         LI,R4    X'FF'             MASK FOR GRAN/CYL
         AND,R4   0,R7              EXTRACT GRAN/CYL
         BEZ      NOT%CYL%ALL       NOT CYLINDER ALLOCATED              DISCB
         SLS,R4   1                 CONVERT # GRAN/CYL TO SECT/CYL      DISCB
         DW,SR2   R4                CORRECT FOR PARTIAL CYL
         MW,SR2   R4                BACK TO SIZE
NOT%CYL%ALL EQU   %                                                     DISCB
         LSECTA,R3  SR1             REL SECTOR #                        DISCB
         LCW,R4   R3                                                    DISCB
         AW,R4    SR2               COMPUTE SIZE OF DEVICE
         SW,D3    R4                DECREMENT REL SECTOR
         BL       RWR22             IN THIS DEVICE
RWR21    RES
         AI,SR1   X'10000'          INCREMENT TO NEXT DEVICE,VOL
         AND,SR1  DCT%MASK%1        RESET REL SECTOR
         BAL,R0   PRIVDCB           IF PRIVAT IS OK NOW
         BANZ     RWR23
         BAL,R3   FNDHGP            IF PUBLIC, FIND NEXT CYL DEVICE
         LI,R4    X'FF'
         AND,R4   1,R7
         BEZ      RWR21             NOT HTIS ONE, TRY NEXT
         B        RWR24             CONTINUE
RWR22    EQU      %                                                     DISCB
         AW,R3    D3                PROPER SECTOR #                     DISCB
         AW,R3    R4                MINUS DEVICE SIZE                   DISCB
         BAL,D4   STR%SECTOR        STORE SECTOR # WITH DCT
RWR22A    EQU       %
          LI,R4     0
          LW,R5     R3                  MOVE REL.SECTOR # TO REG. 5
          LH,R2     *R7                 REG.2=DCT INDEX FROM HGP
          LB,R2     DCT22,R2            GET DCT TYPE
          DW,R4     NSPC,R2             CK REL.SECT.WITHIN A CYL.
          LW,R6     R4
          LW,R5     R4                  REL.SECT.WITHIN A CYL.
          LI,R4     0
          DW,R4     1,R7                DIV. BY SECTORS PER TRACK
          LCW,R4    R4
          AW,R4     1,R7                COMP.SECTORS LEFT ON THIS TRACK
          CI,R4     1                   CK GRANULE CROSSES TRACK BOUNDARY
*                                       EXCEPT AT END OF A CYL.
          BAZ       RWREVEN
          AW,R6     R4                  NEXT TRACK-1ST SECTOR
          CW,R6     NSPC,R2             END OF CYLINDER
          BGE       RWR22B              YES
         AI,R4    1
RWR22B   EQU      %
         AND,R4   NB31TO0+1         OR THROW AWAY EXTRA
RWREVEN  EQU      %
         CI,R4    32                LIMIT MAX I/O TO 8K WORDS
         BLE      RWR25             ITS OK
         LI,R4    32                ITS TO BIG USE MAX
RWR25    SLS,R4   10                CONVERT SECTORS TO BYTES
         CW,SR3   R4                CHECK REQUEST SIZE
         BG       %+2
         LW,R4    SR3               USE SMALLEST
         LW,R2    R4                SWITCH REGS
         LCI      2                 RESTORE REGS
         LM,R5    J:BASE
         PUSH     8,R2              SAVE 7,SR1,SR2
         STW,SR1  CDA,R6            DA FOR THIS OPERATION
         LW,R3    YFFFE
         SLS,R2   17                SHIFT RECORD SIZE INTO PLACE
         STS,R2   BLK,R6            STORE IN DCB
         LW,SR1   R6                SET FC & DCB ADD FOR QUEUE
         BAL,SR4  PVQUEUE
         PULL     8,R2
         SW,SR3   R2                SUBTRACT BYTES TRANSFERRED
         BLEZ     RWRDUN            EXIT IF DONE
         SLS,R2   -2                # OF WDS
         AWM,R2   QBUF,R6           INCREMENT BUFFER ADDRESS
         SLS,R2   -8                SECTOR COUNT
         AW,R3    R2                INCREMENT SECTOR #                  DISCB
         BAL,D4   STR%SECTOR        STORE SECTOR # WITH DCT
         CW,R3    SR2               CHECK FOR END OF DEVICE
         BL       RWR22A            NOT AT END
         LI,D3    0                 FAKE IT FOR RWR23
         B        RWR23
RWRDUN   LW,SR3   J:BASE+4          GET # WE READ/WROTE
         AI,SR3   2047              ROUND UP TO GRANULES
         SLS,SR3  -11               DIVIDE BY 2048
         AWM,SR3  0,R5              INCREMENT RELGRAN
         LW,SR3   J:BASE+4          RESTORE NO WE READ/WROTE
RWRDUN1  XW,SR3   RWS,R6            PUT IN DCB
         LW,R2    RWS,R6
         LI,R3    X'7FFF'
         SLD,R2   17
         STS,R2   ARS,R6            BOTH PLACES
         CW,SR3   RWS,R6            DID WE READ # REQUESTED
         BE       MSREXIT           YES, NORM EXIT, OTHERWISE ABN
         BAL,SR4  IOSPIN
         LW,SR3   E5744             SET ERROR CODE
         B        MSR01EXIT
*E*  ERROR:        57-44
*E*  DESCRIPTION:  ATTEMPT TO READ PAST END OF RANDOM FILE
*
STR%SECTOR EQU    %
         STSECTA,R3  SR1            STORE SECTOR # WITH DCT
         B        *D4               RETURN
ERR01    LI,SR3   0
         LW,SR4   YFFFE
         STS,SR3  ARS,R6            SET RECORD SIZE TO ZERO
         STW,SR3  RWS,R6
         LI,SR3   X'42'             SET ERROR CODE
         B        MSR01EXIT         AND TAKE ERROR EXIT
*E*  ERROR:        42-00
*E*  DESCRIPTION:  STARTING BLOCK NUMBER FOR RANDOM FILE IS
*E*                NEGATIVE OR BEYOND END OF FILE
E5744    GEN,7,25 X'44',X'57'
GZBREAK  BDR,SR4  MSR01EXIT         ABNORMAL FOR MONITOR CALS
GZREEX   AI,R4    -6-16-2           POINT TO CAL ADDR
         LD,SR3   *R4
         AI,SR3   -1
         STD,SR3  *R4
         B        MSREXIT           AND RETURN TO USER
         PAGE
*
*
*
GZFDA    EQU      0
GZREM    EQU      1
GZPREV   EQU      2
GZCFU    EQU      4
GZUSER   EQU      5
GZAPBIT  EQU      BT31TO0+32
GZAPCFU  EQU      3
GZPRIV   EQU      2
GZAP     EQU      %
         LW,R1    SR3               GET BUFFER ADDR IN INXED REG
         LW,SR1   GZFDA,R1          PREVIOUS WRITE ADDR
         BEZ      GZAPX             SOMEBODY DID CLS,REL
         LSECTA,R3 SR1              REL SECTOR #
         AW,R3    GZPREV,R1         PREV WRITE SIZE
GZAP0    LDCTX,D1 SR1               GET DCTX
         LW,R2    D1                IN INDEX REG
         LH,R7    DCT23,R2          HGP DISP
         LB,R4    DCT22,R2          DISK TYPE
*        CALCULATE END SECTOR # OF DEVICE
         LW,D2    DISCLIMS,R4       LAST IF NOT CYL ALLOCATED:
         LI,D3    X'FF'             CHECK FOR CYL DEVICE
         AND,D3   HGP+1,R7
         BEZ      %+4               NOT CYL ALLOCATED
         SLS,D3   1                 IN SECTORS
         DW,D2    D3                # CYLS
         MW,D2    D3                MAX SECTOR#
         CW,R3    D2                is this the end of device
         BL       GZAP1             NO, STAY HERE
         LI,R3    X'FF'
         AI,R2    1                 NEXT DEVICE
         LH,R7    DCT23,R2          THAT IS CYLINDER ALLOCATED
         CW,R3    HGP+1,R7
         BAZ      %-3
         LI,R3    0                 SET SECTOR #
         STH,R2   SR1               SET DCTX
         B        GZAP0
GZAP1    EQU      %
         BAL,D4   STR%SECTOR
         STW,SR1  GZFDA,R1          PUT IN BUFFER
         SW,D2    R3                DONT WRITE BEYOND END OF DEVICE
         CI,D2    64                LIMIT WRITE TO 16K
         BLE      %+2
         LI,D2    64
         LI,R2    0
         DW,R2    NSPC,R4           DONT WRITE OVER CYLINDER BOUNDARY
         LCW,R2   R2
         AW,R2    NSPC,R4
         LW,D4    SR1               FLAG TO CONTINUE
         CW,R2    D2                CHECK FOR MAX
         BLE      %+2
         LW,R2    D2
         AWM,R2   GZREM,R1          DECREMENT REMAINING SECTORS
         BLZ      %+3               STILL MORE NEXT TIME
         SW,R2    GZREM,R1          NO, WRITE ONLY WHAT'S LEFT
         LI,D4    0                 AND QUIT NEXT TIME IN
         STW,R2   GZPREV,R1         SAVE IT
         OR,D1    NEWQ12            SET UP PARAMETERS FOR NEWQ
         LW,D2    Y1                WRITE SKIP FLAG
         XW,D4    GZFDA,R1
         LW,D3    GZPREV,R1
         SLS,D3   10
         LI,R0    GZAP
         BDR,SR4  NEWQNW
NEWQ12   DATA,1   1,255,10,0
*
*
*
GZAPX    INT,R5   GZCFU,R1          GET CFU ADDRESS
         STW,SR1  GZAPCFU,R5        ZAP CLEANER ADDRESS
         LW,D3    R1                SAVE ADDR FOR RELEASE
         LI,R5    0                 UNBLOCK THE USER IF HES THERE
         LI,R6    E:WU
         DISABLE
         XW,R5    GZUSER,R1
         BEZ      RMB               RMB ENABLES
         PUSH     SR4
         BAL,SR4  T:RUE             T:RUE ENABLES
         PULL     SR4
         B        RMB
         PAGE
*
*        QUEUE A USER WHO IS TRYING TO FIDDLE WITH A FILE
*        THAT IS BEING CLEANED
*        CFU ADDR IN R1
*        BAL,R0   GZQUS
*        BLOWS    4 AND 11
*        RETURNS TO BAL+1 IF USER BREAKS OUT WITH:
*        (4) ADDRESS OF R11 IN PUSHALL
*        (10) 1404 ABNORMAL CODE
*        (11) 0 IF USER CAL (RETURN IS IOSPRTN)
*        OTHERWISE TO BAL+2
*
GZQUS    EQU      %
         PUSH     R0                SAV RETURN
         DISABLE                    FIRST CHECK THAT WE ARE STILL CLEANING
         LW,R4    GZAPCFU,R1
         CW,R4    GZAPBIT
         BAZ      GZQUSX            NO, RETURN TO USER
         PUSH     R6
         LW,R6    S:CUN             STUFF USER # IN BUFFER
         STW,R6   GZUSER,R4
         LW,SR4   %                 WAIT A LONG TIME
         STW,SR4  U:MISC,R6
         LI,R6    E:SL
         BAL,SR4  T:REG
         PULL     R6
         LW,R1    CFU,R6            RESTORE R1
         LW,R4    GZAPCFU,R1        WE WOKE UP.. IS IT TIME TO DO SO
         CW,R4    GZAPBIT
         BAZ      GZQUSX            YES..RETURN
         LI,SR4   0                 ZAP USER # IN BUFFER
         STW,SR4  GZUSER,R4
         ENABLE
         LW,R4    TSTACK            FIND PUSHALL IN STACK
         AI,R4    -1
         CW,R4    1,R4
         BNE      %-2
         LI,SR4   IOSPRTN           SET FLAG FOR USER CAL
         EOR,SR4  0,R4
         LAW,SR4  SR4               MAKE POSITIVE
         LI,SR3   X'1408'           ABNORMAL CODE FOR MOVE CAL
         SCS,SR3  -8
         B        PULLEXIT
*E*  ERROR:        14-04
*E*  DESCRIPTION:  RANDOM READ/WRITE HAD PUT USER TO SLEEP TO WAIT
*E*                FOR GRANULE CLEANING TO COMPLETE, BUT USER
*E*                INTERRUPTED OUT OF THE WAIT
GZQUSX   ENABLE
         B        PULLEXIT1
         TITLE    '************  WRTF  *************'
         END

