MONPROC  SET      1
DISCBPROC SET     1                                                     DISCB
         SYSTEM   UTS
         DEF      WRTF
WRTF     EQU      %
         PCC      0
NUPRIV   EQU      0
*
         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'
K1FFFF   EQU      X'1FFFF'
KN2      EQU      -X'2'
KN3      EQU      -X'3'
         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
         DEF      IOSFILE
         DEF      ENTER1
         SPACE    3
         DEF      GETDGRAN
FITSIZE  EQU      80
NWFITST  EQU      WXBUFSIZ-FITSIZE
         PAGE
         SPACE    1
         REF      Y8
         REF      COMKEY
         REF      DOUBLEONE
         REF      EOFMITST
         REF      ESTABBUF
         REF      GBG
         REF      GETCFU
         REF      GETCMD
         REF      GETCSA
         REF      GETFUN
         REF      GETSEC
         REF      KEYER1
         REF      KEYER2
         REF      KEYER4
         REF      KEYTRAN
         REF      MSREXIT
         REF      MSR01EXIT
         REF      PRCRD1
         REF      PULLEXIT
         REF      REDSECL
         REF      SAVBLK
         REF      SETCMD,SETCMD1
         REF      SETEOPW
         REF      SETTRN
         REF      SETTYC
         REF      SETUPUB
         REF      TRNTST
         REF      WRTSEC
         REF      WRTXEND
         REF      PVQUEUE1
BUFF3    EQU      X'9800'
         REF      Y0008
         REF      YFFFE
         REF      DLTSEG
         REF      Y2
         REF      Y1
         REF      YFFFFFFFC
         REF      INITARS
         REF      TRANX
         REF      PUTSZBF
         REF      IOSPIN
         REF      RESBLK
         REF      Y0038,PUF
         REF      SETBLK
         REF         INCREMENT%SECTOR                                   DISCB
         REF      SECTOR#MASK                                           DISCB
K3RDWRD  GEN,16,16   MIDIS,X'4000'
         REF      Y008
         REF      Y001
         REF      Y004
         REF      Y06
         REF      M5
         REF      M31
         DEF      RW3
         DEF      RW2
         DEF      RW1
         DEF      INSTCLNUP
         REF      UBLK
         REF      TRNS1
         REF      CLRBBUF
         REF      GETBBUF
         REF      GETCBD
         REF      SAVCBD
         REF      FNDHGP,GCYL,GPVCYL,GNVAT
         REF      RCYL                                                  DISCB
         REF      SETBTDQ
         REF      SETBTDZ
         REF      GETSBUF
         REF      T:GBUF,T:RBUF,T:MBUF,T:SBUF
         REF      FMCHKDA
         REF      REDSEC8,RWREX,1C0
         REF      MAPBUFS
         REF      SLDMOVE
         REF      24BM2
         REF      RAD1ST
         REF      M24
         REF      Y002
         REF      GETORG
         REF      GETSNADR
         REF      GETVNO
         REF      NXTVOL,PRIVDCB,PVQUEUE,PVREADTP
         REF      SETPVI,SETVNO
         REF      SWXPV
         REF      GETTYC
         REF      NSPC
         REF      DCT22
         REF      DISCLIMS
         REF      J:BASE
         REF      J:JIT
         DEF      RW3A,IMAGE3
         REF      FILCFU
NFD      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)
*
         PAGE
         SPACE    2
*
*  GENERAL ENTRY POINT FOR ALL FILE WRITES.
*  IOSFILE IS ENTERED FROM MSRRDWT - IT GIVES CONTROL
*    TO THE CORRECT DISC FILE ROUTINE
*
IOSFILE  EQU      %
*  PERFORM SETUP FOR SHARED KEYED UPDATES
*  ELIMINATE RANDOM FILES.
         LI,R4    1B4               SET RETURN
         DEF      SETUPWR
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
         CI,D2    X'8000'           CHK FOR SHARE
         BAZ      1,R4              NOT SHARED
         LI,D4    X'91827'          SHARED UPDATER FLAG
         PUSH     D4                FOR PULLALLEXIT
1B1      LI,D4    X'2000'           SHARED UPDATE IN PROGRESS FLAG
         CW,D4    0,R2
         BAZ      1B2               FILE IS AVAILABLE FOR UPDATE
         STW,R6   J:BASE+5          SAVE DCB ADDR
         LI,R6    1                 SLEEP COUNT
         LW,R1    S:CUN
         STW,R6   U:MISC,R1
         LI,R6    E:SL              SLEEP FLAG
         BAL,SR4  T:REG             SNOOOOOZZZZE
         LW,R6    J:BASE+5          RESTORE DCB ADDR
         B        1B1
*
1B2      AWM,D4   0,R2              SET UPDATE IN PROGRESS
         LW,R1    SCFU,R2
         MTW,1    GAVAL,R1          UPDATE WRITE COUNT
         B        1,R4
*
1B4      RES      0
         B        RWRAND            IT'S A RANDOM
         LW,R1    Y001              FOR WAT BIT
         LW,R0    RWS,R6
         REF      Y02
         LW,12    ORG,6
         CI,12    X'20'             CHK FOR KEYED
         BAZ      SEQ0              IT'S CONSEC
         REF      E:SL,T:REG,U:MISC,S:CUN
         LI,15    X'1FFFF'
         CW,2     Y0008
         BANZ     IOSEQUB           UPDATE FILE
         LI,SR3   K17               KEY WASNT SPECIFIED--ERROR
         AND,15   KAD,R6
         BEZ      MSR01EXIT
         REF      Y3
         CW,12    Y3
         BAZ      MSR01EXIT
         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  LI,2     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
*
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      %
         DEF      IOSEQUB1
         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
         REF      SEQPOS
         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    LI,3     2                 GET
         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,3           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
         BEZ      SATDISK           BAD NEWS
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
         BEZ      SATDISK           VOL NOT MOUNTED
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
         REF      SEQPOSD
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-1
         BL       SEQ2A             PLENTY OF ROOM
         BG       SEQ1F             IT'S FULL UP
         CI,12    BUFSIZ-15         CHK FOR UNBLOCKED
         BL       SEQ1F             NOT ENUF ROOM
SEQ2A    LW,1     CFU,6
         LCW,4    W19,6             INIT SEG FLAG
         BEZ      SEQ2B             NOT 1ST
         AWM,4    W19,6             RESET 1ST FLAG
         REF      Y4
         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
         CI,3     3                 BRANCH IF
         BG       SEQ2H              NOT 1ST ENTRY IN GRAN
         MTW,0    *TSTACK           CHK SPEC BACKSPACE
         BGEZ     %+2               BRNCH IF NOT
         PULL     4                 GET ABORTED CTL WD
         B        SEQ2F
SEQ2H    RES      0
         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
         CI,3     WBUFS
         BL       SEQ2G             NOT OFF THE END
         OR,4     Y8                SET FLAG
         PUSH     4                 SAVE CTL WD PARTIAL
         B        SEQ1F             GET ANOTHER GRAN
SEQ2G    OR,4     Y1                SPECIAL BACKSPACE
         MTW,1    BUFF1+2           UPDATE POSITION
SEQ2F    RES      0
         BAL,0    GETDGRAN          ALLOCATE A GRANULE
         BEZ      SATDISK           FRESH OUT
         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
         REF      M19
         AND,15   M19
SEQ3B1   OR,15    YFC               COUNT = 252
         REF      YFC
         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,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
         DEF      ENTERO
         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,0    GETDGRAN          PHONY FIT
         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
         REF      ACNCFU
         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
         DEF      WRTFEXT,WRTFEX1
WRTFEX1  RES      0
         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
         LB,R0    BUFF2,R3
         EOR,R0   X2
         STB,R0   BUFF2,R3
         AI,R3    K3
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
WRTFEXT  RES      0
         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
4B3      STH,R3   *R6,R2
         AW,R3    IMT,R6
         CH,R3    BUFF2+NAVX
         BL       4B4
         LW,D1    BUFF2+1
         BEZ      INSTPA
         REF      1A91
         BAL,R3   1A91              READ NEXT SECTOR OF MI
         B        4B3+2
4B4      BAL,R1   1A3
         REF      1A3
         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       %+3               BR IF NOT DIRECTORY
         LW,R7    Y2
         STS,R7   *TSTACK           SET DIRECTORY FLAG
*
         LW,R3    Y8
         STS,R2   FDA,R1            CLEAR EMPTY FILE FLAG
*
         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
         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,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
         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
*
SLDDWN   EQU      %
         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    DCDAM             DUAL FOR BUFF2
         STW,R7   BUFF3+DBLINK      SET DUAL BLINK
         B        INST3A1
*
*  INSERT AT MIDIS (FIRST KEY POSITION)
*
INST4    EQU      %
         BAL,R4   MULCHK            CHK MULTI-LEVEL RESTRICTION
         B        INST3             BR IF NONE
         LW,D1    *D3
         BEZ      INST3             IT'S THE FDA
         LB,SR3   BUF3FLGS
         BNEZ     INST41B           ALREADY HAVE BUFF3
         STW,D1   BUFF3DA           NEW BUFF3 DISC ADDRESS
         BAL,R0   GETBUF            GET A BUFF3
         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   EQU      %
         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)
COMPLEN5 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
BUFM10   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
         REF      RWREX1
         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
         REF      PRDCRM,TMDCRM,TMPDCPK
         REF      TMPDPPK
GETDGRAN EQU      %
         PUSH     15,SR2
         BAL,D2   GETCFU
         BAL,R0   PRIVDCB
         BANZ     GPRIV
         LI,5     PRDCRM
         LI,3     TAB2
         CI,1     FILCFU            FD & AD ALWAYS TRY RAD FIRST
         BLE      ALLODIR           IT'S A DIRECTORY
         BAL,D2   GETFUN
         CI,D1    5                 IN, INOUT ALWAYS PERM
         BANZ     %+4
         MTW,0    FIL1,R6           IS FILE TEMP
         BLZ      %+2               NO
         LI,5     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      ALLOC
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
         CI,R5    TMDCRM
         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
         LW,D2    Y001
         STS,D2   WAT,R6            SET WAIT
         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
         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
         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
         BAL,SR4  RCYL              RELEASE CYL ALLOCATED               DISCB
         B        RETURN            RETURN                              DISCB
*
GPRIV    EQU      %
         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
         LW,1     CFU,R6
         STW,SR1  GAVAL,R1          STORE IN CFU
         LB,0     SR1
         LI,D2    X'8000'           CHK 4 SHARED
         CW,D2    0,R1
         BANZ     %+3               IT IS
         AWM,0    CLK,R6            INCR FILE SIZE
         B        GPACK20
         LW,R2    SCFU,R1
         AWM,0    SREC,R2
         B        GPACK20           AND GET OUT
GPRIV20  BAL,D2   GETCFU
         CI,1     FILCFU            MUST BE ON VOLUME 1
         BE       ALOCX             CAN NOT DO, EXIT
         BAL,R0   GETORG
         BL       GG180
         BAL,R0   GETVNO               *KEYED FILE,ATTEMPT TO ALLOCATE
         BAL,R0   GETSNADR                  ON OTHER VOLUMES IN THE
         LW,D3    R3                        SET,STARTING WITH THE LAST
         LW,R3    R2
GG150    CW,R3    D3                        IS THIS THE CURRENT VOL
         BE       GG170                         YES,SKIP
         BAL,R0   SETVNO
         BAL,D4   SETPVI
         BAL,SR4  GPVCYL                IS A CYL AVAILABLE ON THIS VOL
         BNEZ     GG135                     YES
GG170    BDR,R3   GG150                     NO,TRY NEXT VOLUME
         B        ALOCX                     NONE AVAILABLE,EXIT
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
         B        GG130                            AND TRY AGAIN
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
         REF      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
         REF      ALLODIRA,GSBP,YFF
ALLODIR1 LI,R0    7                 PREFER RAD
         BAL,SR4  GSBP   GET SEPARATED BACKGROUND PAIR
         BEZ      ALOCX             OUT OF GRANULES
         CI,R1    FILCFU
         BL       ALLODIR2          IT'S THE ACCT DRCTRY
         LW,SR4   Y008              MASTER FLAG FOR FILCFU
         CW,SR1   YFF               CHK FOR CYLINDER
         BAZ      %+2
         STS,SR4  NFD               SET CYL FLAG
         CW,SR2   YFF
         BAZ      %+2
         STS,SR4  NFD
ALLODIR2 STD,SR1  ALLODIRA
*
ALLODIR  LD,SR1   ALLODIRA
         BEZ      ALLODIR1          NO REMNANTS LEFT
         AI,SR2   0                 CHK DUAL CYL
         BNEZ     %+3               SOMETHING'S THERE
         XW,SR2   SR1
         STD,SR1  ALLODIRA
         AI,SR1   0
         BNEZ     ALLODIR3          GOT BOTH
         LI,R0    7                 TRY RAD FIRST
         BAL,SR4  GBG
         BNEZ     ALLODIR4          GOT IT
         LI,R0    X'B'              TRY PACK NEXT
         BAL,SR4  GBG
         BNEZ     ALLODIR4          GOT IT
         BAL,SR4  GCYL  CYLINDER IS THE LAST RESORT
         BEZ      ALOCX             OUT OF GRANULES
ALLODIR4 STW,SR1  ALLODIRA
ALLODIR3 XW,SR1   SR2
         BAL,R2   ALLODIR5          SET UP THE DUAL
         XW,SR1   SR2
         XW,SR2   ALLODIRA+1
         BAL,R2   ALLODIR5          SET UP THE MAIN LINE
         XW,SR1   ALLODIRA
         STW,SR2  DIGRAN            DIGRAN
         LW,R2    TSTACK
         STW,SR2  -14,R2            SET SR2 IN STACK
         B        EXIT
*
ALLODIR5 MTB,-1   SR1               CHK NGAVAL
         BNC      ALLODIR6          NOT CYLINDER
         BEZ      ALLODIR6          LAST GRANULE
         LI,R3    1
         MTH,2    SR1,R3            NXT GRANULE ADDRESS
         BNC      0,R2              IT'S OK
         MTH,-2   SR1,R3            SPECIAL CASE
         B        INCREMENT%SECTOR
ALLODIR6 LI,SR1   0                 NO MORE IN CYLINDER
         B        0,R2
         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
         LI,R2    0                 NO NEW FD GRAN
         CI,R1    FILCFU
         BG       IT05              BR IF MI
         BL       %+2
         REF      Y01
         LW,R2    Y01               ADD A GRAN TO FD
         CI,D3    BUFHDR
         BE       IT30              THERE'LL BE ANOTHER TIME
         AWM,R2   NFD
         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
         B        IT30
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      IT30              STILL OK
IT20     LI,R5    X'FF'                         NO,SET SLIDES IN CFU
         STS,R5   0,R1                             SO THAT HIGHER LEVEL
*                                                  REBUILT AT CLOSE
IT30     EQU      %
         LCI      K3                INITIALIZE FIRST THREE WORDS OF MI
         STM,SR4  *D3
         B        *R0
         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
ENTKEYUB  EQU     %
*                                   INSERT RECORD INFO INTO MASTER
*                                   INDEX AND WRITE OUT RECORD
*                                   CMD= POINTER TO WHERE INSERTION
*                                   BEGINS
*
         PUSH     1,R0
*
*
*                                   GO BACK TO PREVIOUS SECTOR IF CMD
*                                   = MIDIS
         LI,2     X'F0000'
         AND,2    CMD,R6
         REF      Y000C
         CW,2     Y000C
         BNE      ENTKEYUB2
         LW,D1    BUFF2             IS THERE A BLINK
         BEZ      ENTKEYUB2
         BAL,R2   1A8               READ CDAM SECTOR & PT TO END
         REF      1A8
*
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    UBLKD
         CI,D1    BUFSIZ-15         CHECK FOR UNBLOCKED
         BGE      CLRBBUF           TRUNC BUF1,WRT UNBLKD
*                 WRITE BLOCKED
*
         LI,D3    BUF1MSK
         AND,D3   BUFX,R6
         BEZ      BLK1              NO BUFFER
         LI,D3    BUFF1
         LI,3     X'E0000'
         AND,3    CBD,R6
         BEZ      BLK3
         CW,3     Y1
         BGE      BLK3
         SCS,3    15
*
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,4     X'30'
         AND,4    BTD,R6            BYTE
         SLS,4    -4                 DISPLACEMENT
         LW,D4    QBUF,R6           USER BUFFER
         ANLZ,4   RBLK4
         LI,2     BUFSIZ
         SW,2     3
         CW,2     RWS,R6
         BLE      %+2
         LW,2     RWS,R6
         BAL,0    SVSIZ             SIZE IN R2
         ANLZ,5   BUFF1R3 BUFF1,R3  BUFFER BYTE ADDRESS
         AW,3     2                 NXT BFR POSN
         AI,3     3
         AND,3    YFFFFFFFC
         AI,2     -256
         BLZ      RBLK1
RBLK2    OR,5     YFC               MOVE 252 BYTES
         MBS,4    0
         AI,2     -252
         BGEZ     RBLK2
RBLK1    STB,2    5
         MBS,4    0
         BAL,0    SAVCBD
         LW,3     Y004              SET UPDATE FLAG
         STS,3    BFL,R6
         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
         LW,D2    Y002
         STS,D2   WAT,R6            SET WAIT
         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,R2    BUFSIZ
         BAL,R0   SVSIZ
         LI,1     X'F0000'
         AND,1    PBD,R6
         STW,1    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
         PUSH     8,D1              OLD BLOCK, GET IT IN
         BAL,R4   RW3A
         B        BLK4
RBLK4    LB,1     *D4,4             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
         BAL,R0   BUFMOVE  XCHNG BUFF2 & BUFF3
*                                   INSERT IMAGE OF KEYED RECORD
*                                   TRANSFER KEY TO BUFFER
INST3Y   STH,R4   BUFF2+NAVX        NEW NAV
IMAGEREC EQU      %
         LI,4     X'30'
         AND,4    0,6               BTD
         SLS,4    2
         REF      Y00FE
         LW,5     Y00FE
         STS,4    2,6               RESET TYC
         LW,5     Y02               CLEAR TRN
         STS,4    5,6
         AW,4     Y0008             WRITE EOP
         LW,5     =X'C10C0'
         STS,4    0,6
         LW,4     KBUF,6
         SLS,4    2
         ANLZ,5   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,4    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.
         LW,0     SCR,6
         LB,0     0
         AW,3     0
         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,4     16,R6             NLR
         CI,4     X'20000'
         BAZ      %+4
         AI,4     -X'20000'
         STW,4    16,6              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,0     X'E0000'
         AND,0    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,3     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
         AWM,D1   QBUF,R6
         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,1     X'1FFFF'
         AND,1    CFU,R6
         CI,1     FILCFU
         BG       %+2
         LI,SR4   6
         LI,4     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
*
         DEF      RW4
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,3     -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
*
         DEF      UPDBLK
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
         REF      BFRMWR
*
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 ****'
*   RWRAND - READ WRITE RANDOM MODULE
*        HANDLES READ AND WRITE RANDOM - BACKGROUND AND FORGROUND
*        ENTER WITH:
*                 R6 -> DCB
*                 R7 -> FPT
*                 R8 HAS FPT CODE,  X'10' => READ
*                                   X'11' => WRITE
*
         REF      M17
         DEF      RWRAND
         SPACE    2
RWRAND   BAL,D4   SETBTDQ           MOVE UBTD TO HBTD
         LI,D1    0
         BAL,R0   SETTYC            CLEAR TYC
         LW,1     CFU,6             GET CFU ADDRESS
         BAL,0    GZQUS             WAIT IF BEING CLEANED
         B        GZBREAK           USER ESCAPED
         LI,3     X'1FFFF'
         LS,2     BUF,6             MOVE BUFFER ADDRESS
         STS,2    QBUF,6            FOR QUEUE
         LW,5     KBUF,6            GET ADDRESS OF KBUF
         LW,10    RWS,6             GET NUM BYTES TO READ/WRITE
         BNEZ     %+3
         MTW,1    0,5               ZERO LENGTH, UPDATE KEY
         B        RWRDUN1           SET ARS AND GET OUT
BKGRND   AND,6    M17               SCRUB OFF BAD BITS IN DCB ADDRESS
         CI,8     X'11'             IS WRITE SPECIFIED
         BNE      %+3               NO, ZERO IS CORRECT FC
         LI,4     4                 YES, 4 IS FC
         STB,4    6
         LW,15    TDA,1             TOTAL GRANULES IN FILE
         SW,15    0,5               - RELATIVE GRANULE
         BLE      ERR01
         LW,8     10                GET REQUESTED SIZE
         AI,8     2047              ROUND UP
         SLS,8    -11               MAX #GRANS TO READ
         CW,8     15                BIGGER THAN FILE
         BLE      %+3               NO,OK
         SLS,15   11                YES, ALLOW ONLY FILE SIZE
         LW,10    15                TO BE READ/WRITTEN
         STW,10   J:BASE+4          AND SAVE # TO READ
RWR2     LW,8     FDA,1             GET STARTING DISC ADDRESS
         LW,14    0,5               GET RELATIVE GRANULE
         BLZ      ERR01             NEGATIVE ALSO BAD
         LI,2     0                 FIRST FLAG
         LCI      2
         STM,R5   J:BASE
         SLS,14   1                 CONVERT REL GRAN TO REL SECTOR
         BAL,3    FNDHGP            GET HGP ADDRESS IF PUHLIC
RWR23    LI,4     DCBPRIVBIT        CHECK FOR PRIVATE
         CW,4     PRIV,6            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,4     X'FF'             MASK
         AND,4    1,7               NUMBER OF GRAN PER CYL
         SLS,4    1                 CONVERT TO SECTORS
         LW,9     SECTOR#MASK       IF BELOW NVAT, ADD CYLS UNTIL IT ISNT
         CS,8     =60
         BGE      RWR24
         AW,8     4
         B        %-3
RWR24    AI,7     1                 POINT TO WORD 1 OF HGP
         LI,2     1                 INDEX TO RIGHT HW
         LH,5     *7                GET DCT INDEX
         LB,5     DCT22,5           GET SUBTYPE
         LW,9     DISCLIMS,5
         LI,4     X'FF'             MASK FOR GRAN/CYL
         AND,4    0,7               EXTRACT GRAN/CYL
         BEZ      NOT%CYL%ALL       NOT CYLINDER ALLOCATED              DISCB
         SLS,4    1                 CONVERT # GRAN/CYL TO SECT/CYL      DISCB
         DW,9     4                 CORRECT FOR PARTIAL CYL
         MW,9     4                 BACK TO SIZE
NOT%CYL%ALL EQU   %                                                     DISCB
         LSECTA,3  8                REL SECTOR #                        DISCB
         LCW,4    3                                                     DISCB
         AW,4     9                 COMPUTE SIZE OF DEVICE
         SW,14    4                 DECREMENT REL SECTOR
         BL       RWR22             IN THIS DEVICE
RWR21    RES
         AI,8     X'10000'          INCREMENT TO NEXT DEVICE,VOL
         AND,SR1  DCT%MASK%1        RESET REL SECTOR
         BAL,0    PRIVDCB           IF PRIVAT IS OK NOW
         BANZ     RWR23
         BAL,3    FNDHGP            IF PUBLIC, FIND NEXT CYL DEVICE
         LI,4     X'FF'
         AND,4    1,7
         BEZ      RWR21             NOT HTIS ONE, TRY NEXT
         B        RWR24             CONTINUE
RWR22    EQU      %                                                     DISCB
         AW,3     14                PROPER SECTOR #                     DISCB
         AW,3     4                 MINUS DEVICE SIZE                   DISCB
         BAL,D4   STR%SECTOR        STORE SECTOR # WITH DCT
RWR22A    EQU       %
          LI,4      0
          LW,5      3                   MOVE REL.SECTOR # TO REG. 5
          LH,2      *7                  REG.2=DCT INDEX FROM HGP
          LB,2      DCT22,2             GET DCT TYPE
          DW,4      NSPC,2              CK REL.SECT.WITHIN A CYL.
          LW,6      4
          LW,5      4                   REL.SECT.WITHIN A CYL.
          LI,4      0
          DW,4      1,7                 DIV. BY SECTORS PER TRACK
          LCW,4     4
          AW,4      1,7                 COMP.SECTORS LEFT ON THIS TRACK
          CI,4      1                   CK GRANULE CROSSES TRACK BOUNDARY
*                                       EXCEPT AT END OF A CYL.
          BAZ       RWREVEN
          AW,6      4                   NEXT TRACK-1ST SECTOR
          CW,6      NSPC,2              END OF CYLINDER
          BGE       RWR22B              YES
         AI,4     1
RWR22B   EQU      %
         AND,4    NB31TO0+1         OR THROW AWAY EXTRA
RWREVEN  EQU      %
         CI,4     32                LIMIT MAX I/O TO 8K WORDS
         BLE      RWR25             ITS OK
         LI,4     32                ITS TO BIG USE MAX
RWR25    SLS,4    10                CONVERT SECTORS TO BYTES
         CW,10    4                 CHECK REQUEST SIZE
         BG       %+2
         LW,4     10                USE SMALLEST
         LW,2     4                 SWITCH REGS
         LCI      2                 RESTORE REGS
         LM,5     J:BASE
         PUSH     8,2               SAVE 7,8,9
         STW,8    CDA,6             DA FOR THIS OPERATION
         LW,3     YFFFE
         SLS,2    17                SHIFT RECORD SIZE INTO PLACE
         STS,2    BLK,6             STORE IN DCB
         LW,8     6                 SET FC & DCB ADD FOR QUEUE
         BAL,SR4  PVQUEUE
         PULL     8,2
         SW,10    2                 SUBTRACT BYTES TRANSFERRED
         BLEZ     RWRDUN            EXIT IF DONE
         SLS,2    -2                # OF WDS
         AWM,2    QBUF,6            INCREMENT BUFFER ADDRESS
         SLS,2    -8                SECTOR COUNT
         AW,3     2                 INCREMENT SECTOR #                  DISCB
         BAL,D4   STR%SECTOR        STORE SECTOR # WITH DCT
         CW,3     9                 CHECK FOR END OF DEVICE
         BL       RWR22A            NOT AT END
         LI,14    0                 FAKE IT FOR RWR23
         B        RWR23
RWRDUN   LW,10    J:BASE+4          GET # WE READ/WROTE
         AI,10    2047              ROUND UP TO GRANULES
         SLS,10   -11               DIVIDE BY 2048
         AWM,10   0,5               INCREMENT RELGRAN
         LW,10    J:BASE+4          RESTORE NO WE READ/WROTE
RWRDUN1  XW,10    RWS,6             PUT IN DCB
         LW,2     RWS,6
         LI,3     X'7FFF'
         SLD,2    17
         STS,2    ARS,6             BOTH PLACES
         CW,10    RWS,6             DID WE READ # REQUESTED
         BE       MSREXIT           YES, NORM EXIT, OTHERWISE ABN
         BAL,SR4  IOSPIN
         LW,10    E5744             SET ERROR CODE
         B        MSR01EXIT
*
STR%SECTOR EQU    %
         STSECTA,3   SR1            STORE SECTOR # WITH DCT
         B        *D4               RETURN
ERR01    LI,10    0
         LW,11    YFFFE
         STS,10   ARS,6             SET RECORD SIZE TO ZERO
         STW,10   RWS,6
         LI,10    X'42'             SET ERROR CODE
         B        MSR01EXIT         AND TAKE ERROR EXIT
E5744    GEN,7,25 X'44',X'57'
         DEF      GZREEX            ENTRY FOR CLOSE TO REEXECUTE CAL
GZBREAK  BDR,11   MSR01EXIT         ABNORMAL FOR MONITOR CALS
GZREEX   AI,4     -6-16-2           POINT TO CAL ADDR
         LD,10    *4
         AI,10    -1
         STD,10   *4
         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
         DEF      GZAPCFU,GZAPBIT,GZPRIV
         REF      RMB
         REF      HGP,GETHGP,DCT23
         REF      T:RUE,E:WU
         REF      NEWQNW
         REF      IOSPRTN
         DEF      GZAP
GZAP     EQU      %
         LW,1     10                GET BUFFER ADDR IN INXED REG
         LW,8     GZFDA,1           PREVIOUS WRITE ADDR
         BEZ      GZAPX             SOMEBODY DID CLS,REL
         LSECTA,3 8                 REL SECTOR #
         AW,3     GZPREV,1          PREV WRITE SIZE
GZAP0    LDCTX,4  8                 DCTX
         LW,12    4                 SAVE FOR NEWQ REGS
         LH,7     DCT23,4           HGPDISP
         LB,4     DCT22,4           DISK TYPE
*        CALCULATE END SECTOR # OF DEVICE
         LW,13    DISCLIMS,4        LAST IF NOT CYL ALLOCATED:
         LI,14    X'FF'             CHECK FOR CYL DEVICE
         AND,14   HGP+1,7
         BEZ      %+4               NOT CYL ALLOCATED
         SLS,14   1                 IN SECTORS
         DW,13    14                # CYLS
         MW,13    14                MAX SECTOR#
         CW,3     13                is this the end of device
         BL       GZAP1             NO, STAY HERE
         LI,3     X'FF'
         AI,8     X'10000'          YES, TO NEXT DEVICE
         AI,7     8                 THAT IS CYLINDER ALLOCATED
         CW,3     HGP+1,7
         BAZ      %-3
         LI,3     0                 SET SECTOR #
         B        GZAP0
GZAP1    EQU      %
         BAL,D4   STR%SECTOR
         STW,8    GZFDA,1           PUT IN BUFFER
         SW,13    3                 DONT WRITE BEYOND END OF DEVICE
         CW,13    HGP+2,7           IF CYLS END AT ODD SECTOR
         BGE      %+3
         LW,2     13
         B        %+3
         LI,2     0
         DW,2     HGP+2,7           CALCULATE REMAINDER OF TRACK
         LCW,2    2
         AW,2     HGP+2,7
         LW,15    8                 FLAG TO CONTINUE
         AWM,2    GZREM,1           DECREMENT REMAINING SECTORS
         BLZ      %+3               STILL MORE NEXT TIME
         SW,2     GZREM,1           NO, WRITE ONLY WHAT'S LEFT
         LI,15    0                 AND QUIT NEXT TIME IN
         STW,2    GZPREV,1          SAVE IT
         OR,12    NEWQ12            SET UP PARAMETERS FOR NEWQ
         LW,13    Y1                WRITE SKIP FLAG
         XW,15    GZFDA,1
         LW,14    GZPREV,1
         SLS,14   10
         LI,0     GZAP
         BDR,11   NEWQNW
NEWQ12   DATA,1   1,255,10,0
*
*
*
GZAPX    LW,2     GZCFU,1           GET CFU ADDRESS
         STW,8    GZAPCFU,2         ZAP CLEANER ADDRESS
         LW,14    1                 SAVE ADDR FOR RELEASE
         LI,5     0                 UNBLOCK THE USER IF HES THERE
         LI,6     E:WU
         DISABLE
         XW,5     GZUSER,1
         BEZ      RMB               RMB ENABLES
         PUSH     11
         BAL,11   T:RUE             T:RUE ENABLES
         PULL     11
         B        RMB
         PAGE
*
*        QUEUE A USER WHO IS TRYING TO FIDDLE WITH A FILE
*        THAT IS BEING CLEANED
*        CFU ADDR IN R1
*        BAL,0    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
*
         DEF      GZQUS
GZQUS    EQU      %
         PUSH     0                 SAV RETURN
         DISABLE                    FIRST CHECK THAT WE ARE STILL CLEANING
         LW,4     GZAPCFU,1
         CW,4     GZAPBIT
         BAZ      GZQUSX            NO, RETURN TO USER
         PUSH     6
         LW,6     S:CUN             STUFF USER # IN BUFFER
         STW,6    GZUSER,4
         LW,11    %                 WAIT A LONG TIME
         STW,11   U:MISC,6
         LI,6     E:SL
         BAL,11   T:REG
         PULL     6
         LW,4     GZAPCFU,1         WE WOKE UP.. IS IT TIME TO DO SO
         CW,4     GZAPBIT
         BAZ      GZQUSX            YES..RETURN
         LI,11    0                 ZAP USER # IN BUFFER
         STW,11   GZUSER,4
         ENABLE
         LW,4     TSTACK            FIND PUSHALL IN STACK
         AI,4     -1
         CW,4     1,4
         BNE      %-2
         LI,11    IOSPRTN           SET FLAG FOR USER CAL
         EOR,11   0,4
         LI,10    X'1408'           ABNORMAL CODE FOR MOVE CAL
         SCS,10   -8
         B        PULLEXIT
GZQUSX   ENABLE
         REF      PULLEXIT1
         B        PULLEXIT1
         END

