         DEF      TSTHGP:
TSTHGP:  EQU      %
         PCC      0
*
         SYSTEM   SIG7FDP
UTSPROC  SET      0
S69PROC  SET      1
MONPROC  SET      1
DISCBPROC SET     1
         SYSTEM   UTS
*
         CLOSE    PUSH,PULL
         CLOSE    BLINK
PUSH     CNAME    X'09',X'0B'
PULL     CNAME    X'08',X'0A'
         PROC
LF       EQU      %
         DO       NUM(AF)>1
         LCI      AF(1)&X'F'
         FIN
         GEN,8,4,20   NAME(NUM(AF)),AF(NUM(AF)),R:TSTACK
         PEND
         SPACE    2
TAB      EQU      X'05'
CR       EQU      X'15'
         SPACE    1
TXTC     CNAME
         PROC
         LOCAL    I,LST
         BOUND    4
LF       EQU      %
LST      SET      S:UT(AF)
         GEN,8,8,8,8  NUM(LST),LST(1),LST(2),LST(3)
I        DO       NUM(LST)/4
         GEN,8,8,8,8  LST(I*4),LST(I*4+1),LST(I*4+2),LST(I*4+3)
         FIN
         PEND
         SPACE    2
RXPSD    COM,4,1,1,1,1,24 0,RDBFLG,RDBFLG,1,RDBFLG,AF(1)
         TITLE    '****  EXTERNAL DEFINITIONS  ****'
         SPACE    2
         DEF      TSTHGP,CLSFILS
         DEF      RRSG
         DEF      SAVHGP
         DEF      RELFDA,RRBG10
         DEF      SCANCFU
         TITLE    '****  EXTERNAL REFERENCES  ****'
         SPACE    2
         REF      ACNCFU,BGRCFU,LASTCFU,CFUSIZE
         REF      CLSPRI
         REF      J:JIT
         REF      RCHKDA
         REF      HGP
         REF      DCT4,DCTSIZ,DCT1
         REF      R:DCT22
         REF      R:DISCLIMS
         REF      TYOUT
         REF      RCBUF
         REF      AVRTBL,AVRTBLNE,AVRTBLSIZ,BATAPE,DCT16
         REF      WRDISK,R:TSTACK,R:FNDHGP
         REF      WRDISK1,RDDISK,R:CHKDA
         REF      R:HGP
         REF      M:XX,J:DCBLINK
         REF      FILCFU
         REF      J:DCBLL,J:DCBUL,M:OC,M:UC
         REF      J:BASE
         REF      RNVAT,RNPVCYL,RPVCYL
         REF      MAPSPARE
         REF      TB:FLGS
         REF      TOP,BOTTOM,TEMPBOT
         REF      WORDCNT,ADJSTCNT
         REF      CATBUF,BUFMASK
         REF      GARBTIME
         SREF     RDBFLG,DBPSD1,DBPSD2,DBPSD3,DBPSD4,DCBADR
*
         TITLE    '****  REGISTERS  ****'
         SPACE    4
R0       EQU      0
R1       EQU      1
R2       EQU      2
R3       EQU      3
R4       EQU      4
R5       EQU      5
R6       EQU      6
R7       EQU      7
R8       EQU      8
R9       EQU      9
R10      EQU      10
R11      EQU      11
R12      EQU      12
R13      EQU      13
R14      EQU      14
R15      EQU      15
         TITLE    '****  DEBUG ERROR CODES  ****'
         SPACE    2
ERR#1    EQU      1                 BAD DCB NAME TABLE ADDR
ERR#2    EQU      2                 BAD DCB ADDRESS
ERR#3    EQU      3                 BAD CFU ADDRESS
ERR#4    EQU      4                 BAD CFU NAME/ACCOUNT POINTERS
ERR#5    EQU      5                 BAD DISC ADDR IN CFU
ERR#6    EQU      6                 CAN'T MAP BUF1 OR BUF2
ERR#7    EQU      7                 CAN'T WRITE OUT UPDATED BUFFERS
ERR#8    EQU      8                 ** UNUSED **
ERR#9    EQU      9                 ** UNUSED **
ERR#A    EQU      X'A'              CAN'T FIND FIT
ERR#B    EQU      X'B'              DCB/CFU ACCOUNTS DIFFERENT
ERR#C    EQU      X'C'              CFU/DCB/FIT NAMES DIFFER
ERR#D    EQU      X'D'              BAD OR MISSING VLPS IN FIT
ERR#E    EQU      X'E'              CAN'T WRITE UPDATED FIT
ERR#F    EQU      X'F'              ERROR CLOSING LABELLED TAPE
ERR#10   EQU      X'10'             ERROR RELEASING OUT/OUTIN FILE
         TITLE    '****  TSTHGP  ****'
         SPACE    2
TSTHGP   EQU      %
         SPACE    2
*
*
*  VALIDATE ACCOUNT AND FILE NAME POINTERS IN ACNCFU
*
*
         SPACE    2
         PUSH     R11
         LW,R8    ACNCFU+13         ACCOUNT POINTER
         CI,R8    BGRCFU
         BLE      ZAPCFU            MUST BE BETWEEN BGRCFU
         CI,R8    LASTCFU+19          AND END OF CFUS
         BGE      ZAPCFU
         CI,R8    1                 MUST BE ON DW BOUNDARY
         BANZ     ZAPCFU
*
         LW,R8    ACNCFU+15         FILE NAME POINTER
         CW,R8    ACNCFU+13         MUST BE ABOVE ACCOUNT TABLE
         BLE      ZAPCFU
         CI,R8    LASTCFU+19          AND BEFORE END OF CFU AREA
         BL       ALLYCHK           BOTH ARE OK
*
ZAPCFU   EQU      %                 POINTERS ARE BAD
         LI,R4    CFUMES
         RXPSD    DBPSD1            GO TO DEBUG MODULE
         BAL,R11  TYOUT             TELL OPERATOR
         LI,R8    ACNCFU
         STW,R8   ACNCFU+13         PUT ARBITRARY GOOD
         STW,R8   ACNCFU+15           CORE ADDRESS IN BOTH
         PAGE
         SPACE    2
*
*
*  THE FOLLOWING CODE CHECKS THE VALIDITY OF THE IN-CORE
*  DISK ADDRESS BUFFERS AND THEIR CONTENTS AND POINTERS.
*
*
         SPACE    2
*  FIX BUFFER POINTERS IF ALLOCAT WAS ADJUSTING BUFFERS
*  AT THE TIME OF THE CRASH.
         SPACE
         SPACE
ALLYCHK  EQU      %
         LI,R1    3                 LOAD BUFFER NUMBER
CATSUP   EQU      %
         LI,R4    0
         LH,R3    TEMPBOT,R1        GET TEMP BOT
         LH,R2    ADJSTCNT,R1       GET COUNT
         BEZ      NEXT              NO ACTION IN THIS ONE
         BLZ      CATSIN            ALLYCAT HARD AT WORK
         LH,R3    BOTTOM,R1         GET BOTTOM
         LI,R2    0
CATSIN   EQU      %
         STH,R3   BOTTOM,R1
         STH,R3   TEMPBOT,R1
         AH,R2    WORDCNT,R1
         STH,R2   WORDCNT,R1
         STH,R4   ADJSTCNT,R1
         SPACE    3
*  NOW CHECK TO SEE IF THE WORD COUNT FOR EACH BUFFER
*  MATCHES THE SPACE BETWEEN TOP AND BOTTOM POINTERS.
         SPACE
NEXT     LH,R2    TOP,R1            FIND DIFFERENCE BETWEEN
         SH,R2    BOTTOM,R1         TOP AND BOTTOM
         BGEZ     POSITIVE          IF NEGATIVE CALCULATE
         AW,R2    BUFMASK,R1        BUFFER LENGTH MINUS
         AI,R2    1                 ABSOLUTE DIFFERENCE
POSITIVE CH,R2    WORDCNT,R1        IS IT EQUAL TO WORD COUNT
         BNE      ERROR1            NO... DISCARD THE GRANS
         AI,R1    -1                TRY NEXT BUFFER
         BGEZ     CATSUP
         SPACE    3
*  CHECK FOR ALLOCATION BUFFER OVERLAPS
         SPACE
         LI,R1    0                 START FROM THE FIRST ONE
         LI,R3    3                 NUMBER OF POSSIBLE OVERLAPS
TEST     LW,R2    CATBUF,R1         GET BUFFER ADDRESS
         AW,R2    BUFMASK,R1        LAST WORD IN BUFFER
         AI,R1    1                 INCREMENT TO NEXT BUFFER
         CW,R2    CATBUF,R1         IS THERE AN OVERLAP
         BGE      ERROR2            YES... TELL OPERATOR
         BDR,R3   TEST              NO...CHECK NEXT
         SPACE    3
*  CHECK ALL THE DISK ADDRESSES BEFORE RELEASING ANY
         SPACE
         LI,R1    4                 FOUR BUFFERS TO DO
NEXTBUF  AI,R1    -1                ARE THERE ANY MORE
         BLZ      TST24             QUIT IF NOT
         SPACE
         LW,R2    CATBUF,R1         GET BUFFER ADDRESS
         LH,R3    TOP,R1            GET NEXT D.A. DISPLACEMENT
         LH,R4    WORDCNT,R1        PICK UP WORD COUNT
         SPACE
NEXTDA   AI,R4    -1                ARE THERE ANY MORE
         BLZ      NEXTBUF           NO... TRY NEXT BUFFER
         AI,R3    -1                YES... DECREMENT DISPL
         AND,R3   BUFMASK,R1        CHECK FOR WRAPAROUND
         SPACE
         LW,R8    *R2,R3            PICK UP DISK ADDRESS
         BAL,R11  R:CHKDA           IS IT O.K.
         BCR,15   ERROR3            N0... QUIT COMPLETELY
         SPACE
         B        NEXTDA            GO BACK FOR MORE
         SPACE    3
*  WRITE APPROPRIATE ERROR MESSAGE
         SPACE
ERROR1   LI,R4    CNTERR
         B        ERREXIT
ERROR2   LI,R4    OVLPERR
         B        ERREXIT
ERROR3   LI,R4    DAERR
         SPACE
ERREXIT  EQU      %
         RXPSD    DBPSD2            GO TO DEBUG MODULE
         BAL,R11  TYOUT             TYPE THE MESSAGE
         STW,R11  SPDFLG            FLAG FOR NO SAVE
         B        TST24
         SPACE
CNTERR   TXTC     CR,'DISK ADDRESS COUNT ERROR',CR
OVLPERR  TXTC     CR,'DISK ADDRESS BUFFER OVERLAP',CR
DAERR    TXTC     CR,'BAD DISK ADDRESS IN BUFFER',CR
CFUMES   TXTC     CR,'ACNCFU NAME/ACCOUNT POINTERS BAD',CR
         SPACE
*
*  CHECK HGP HEADERS OF IN-CORE PUBLIC HGPS
*
TST24    EQU      %
         LI,7     HGP
         LI,5     R:HGP
TST25    LW,4     1,5
         CI,4     X'4000'
         BANZ     TST27             PRIVATE,  DO NOTHING
         LI,4     6
         LW,10    *4,7
         CW,10    *4,5
         BNE      TST30             ERROR IN HGP
         BDR,4    %-3
TST27    LW,7     0,7
         LW,5     0,5
         BNEZ     TST25
         PULL     11
         B        *11
*
TST30    LI,4     HGPER
         BAL,11   TYOUT
         PULL     11
         B        *11
HGPER    TXTC     CR,'HGP MALFORMED',CR
SPDFLG   DATA     0
         PAGE
         SPACE    2
*  SAVE ALL THE DISK ADDRESSES IN THE BUFFERS
         SPACE
SAVHGP   PUSH     R11               SAVE THE LINK
         MTW,0    SPDFLG            DON'T SAVE
         BNEZ     CLSPRIV           IF BAD DATA
         SPACE
         LI,R1    4                 FOUR BUFFERS TO DO
NEXTBUF1 AI,R1    -1                ARE THERE ANY MORE
         BLZ      CLSPRIV           QUIT IF NOT
         SPACE
         LW,R2    CATBUF,R1         GET BUFFER ADDRESS
         SPACE
NEXTDA1  MTH,-1   WORDCNT,R1        DECREMENT WORD COUNT
         BLZ      NEXTBUF1          NO MORE... NEXT BUFFER
         SPACE
         LH,R3    TOP,R1            GET NEXT DISK ADDRESS
         AI,R3    -1
         AND,R3   BUFMASK,R1        CHECK FOR WRAPAROUND
         STH,R3   TOP,R1            AND UPDATE TOP POINTER
         SPACE
         LI,R8    0
         XW,R8    *R2,R3            PICK UP DISC ADDRESS
         CI,R1    2                 IS IT SYMBIONT
         BNE      %+2               NO...
         OR,R8    Y8                YES... SET SYMBIONT FLAG
         BAL,R11  RRBG              RELEASE D.A. TO STACK
         BEZ      NEXTBUF1          SKIP BUF IF ERR FOUND
         B        NEXTDA1           CONTINUE IF O.K.
         PAGE
         SPACE    5
*
*        SEARCH AVR TABLE FOR PRIVATE PACKS.  IF ANY ARE
*        AVR'D, RE-WRITE HGP TO PACK AFTER SUITABLE VERIFICATION.
*
CLSPRIV  EQU      %
         LI,1     AVRTBLNE-AVRTBLSIZ # PRIVATE ENTRIES
         BEZ      SAV30             NONE, QUIT
SAV22    LD,2     AVRTBL+AVRTBLSIZ+AVRTBLSIZ-2,1 GET AN ENTRY
         INT,5    3                 SET CC; GET INDEX TO MAP
         BCR,2    SAV25             NOT AVR'D
         LI,8     BATAPE+AVRTBLSIZ-1 DCTX OF PAKC
         AW,8     1
         SLS,8    16                FORM DISC ADDRESS
         LI,15    512*4             SIZE
         BAL,11   RDDISK            READ VTOC
         B        SAV35             ERROR - TELL OPERATOR
         LI,R14   PRIVM2
         LD,6     RCBUF
         CW,6     =':LBL'
         BNE      SAV40
         CW,7     2                 RIGHT SN
         BNE      SAV40             NO, ERROR
         LH,7     RCBUF+4           GET CYLSZ FROM PACK
         BEZ      %+4               NONE, DONT CHECK IT
         LI,3     BA(HGP+1)+3
         CB,7     *5,3              IS IT GOOD
         BNE      SAV40             NO
         LW,7     RCBUF+6           CHECK 00070000 WORD TOO
         CW,7     HGP+6,5
         BNE      SAV40
         INT,7    RCBUF+4           PREPARE TO MOVE BITMAP
         CW,7     HGP+4,5
         BNE      SAV40
         AI,7     2                 INCLUDE NVAT IN COPY
         AI,5     HGP+4             START COPY AT NVAT
         LW,9     *5,7
         STW,9    RCBUF+4,7         COPY NVAT THROUGH PER BIT MAP
         BDR,7    %-2
         LI,3     512*4
         LI,4     RCBUF
         BAL,11   WRDISK1
         B        SAV35             ERROR - TELL OPERATOR
         B        SAV25
SAV35    LI,R14   PRIVM3
SAV40    LH,4     8
         LD,10    DCT16,4           GET DEVICE MESSAGE
         SLD,10   16
         AI,11    X'1540'           ADD CR
         LCI      2
         STM,10   DEV1              PUT INTO MESSAGE
         STM,10   DEV2
         LW,R4    R14               MOVE ADDR OF LAST PART OF MESSAGE
*
SAV24    BAL,R11  TYOUT
SAV25    BDR,R1   SAV22             DO THE REST
SAV30    PULL     R11
         B        *R11              RETURN
         LI,4     PRIVM2
         B        SAV24
*
PRIVM2   TXTC     ' VTOC DOESN''T MATCH DPNDD '
DEV1     EQU      PRIVM2+5
PRIVM3   TXTC     ' VTOC I/O ERROR DPNDD '
DEV2     EQU      PRIVM3+4
         TITLE    '****  RELEASE GRANULES  ****'
*
*                 FREE AGRANULE FOR FILE OR SYMBIONT.  LINK = 11.
*                 D.A. IN 8. 8 CLEARED IF NO RELEASE.
*
RRSG     OR,8     Y8
RRBG     STW,11   RRBGEX            SAVE RETURN
         PUSH     9,15
         STW,8    RBGSAV            MUST SAVE R8
         LW,15    8
         AND,8    M24
         BAL,R11  RCHKDA
         BCR,15   RELERX            BAD DISC ADDRESS
         MTW,0    CLSPRI
         BEZ      RRBG02            PRIVATE DISC ADDR NOT ALLOWED
         LI,R7    X'1FFFF'
         AND,R7   PAT,R6            HGP ADDRESS IF PRIVATE
         LI,R3    DCBPRIVBIT
         CW,R3    PRIV,R6
         BANZ     RRBG02            IT IS PRIVATE
         BAL,3    R:FNDHGP
         BEZ      RELERX            NO MEANS BAD DA
RRBG02   EQU      %
         LW,3     3,7               #SEC/GRAN
         LW,2     1,7               FLAGS
         CI,2     X'8000'           CYL BIT ON
         BAZ      %+3               NO
         AND,2    M8                YESS, GET NGC
         MW,3     2                 NSG*NGC = # SEC/CYL
         LI,0     0
         LSECTA,1   8               RELATIVE SECTOR #
         DW,0     3
         AI,0     0
         BNEZ     RELEX             NOT GRANULE OR CYLINDER BOUNDARY
         MTW,0    CLSPRI
         BEZ      RRBG04            CON'T BE PRIVATE
         LI,R11   DCBPRIVBIT
         CW,R11   PRIV,R6
         BANZ     RPRIV             PRIVATE DISC ADDRESS
RRBG04   EQU      %
         MTW,0    RELFDA            FIRST DISC ADDR
         BNEZ     %+3               NO
         STW,15   RELFDA            YES, USE IT
         B        RELEX             AND EXIT
         PSW,15   RELSTAK           PUT IT IN RELEASE STACK
         BCR,8    RELEX             EXIT IF PUSH NOT ABORTED
RRBG15   EQU      %                 ALTERNATE ENTRY POINT
         XW,15    RELFLK            SET FORWARD LINK AND GET
*                                   DA FOR THIS ONE
         BNEZ     %+3               BR IF NOT FIRST SECTOR
         LW,15    RELFDA            IS FIRST, FDA IS THE ONE
         BEZ      RELEX             IF ZERO, NEVER HAD ANY DA'S
         INT,1    RELSTAK+1         SET UP COUNT
         STW,1    RELREM
         LI,4     RELNAV            BUF ADDRESS
         LW,8     15
         AND,8    M24
         BAL,11   WRDISK            WRITE IT
         B        RRBG30            ERROR, BAD DEAL
RRBG20   LCI      4                 OK, RE INIT STACK
         LM,0     RRBGINIT
         STM,0    RELSTAK
         B        RELEX             AND GET OUT
RRBG30   LI,8     0                 ERROR, THROW AWAY ALL
         STW,8    RELFDA            DISC ADDRESSES
         STW,8    RELFLK
         B        RRBG20            AND REINIT STAK
RELERX   LI,8     0
         STW,8    RBGSAV
RELEX    PULL     9,15
         LW,8     RBGSAV            RESTORE DISC ADDRESS
         AND,8    M24
         B        *RRBGEX
*
RRBG10   STW,11   RRBGEX            SAVE RETURN
         PUSH     9,15
         B        RRBG15
*
RPRIV    EQU      %
         LSECTA,R1  R8
         CI,R1    60
         BGE      RPRIV4            NOT IN NVAT
         AI,R8    -X'10000'         POINT TO PREVIOUS VOL #
         BAL,R11  RCHKDA            FIND THE HGP
         BCR,15   RELERX
         BAL,R11  RNVAT             RELEASE IT
RPRIV1   BEZ      RELERX            ERROR
         B        RELEX
*
RPRIV4   BAL,R11  RPVCYL
         B        RPRIV1
*
RRBGINIT DATA     STAK-1
         GEN,1,15,16 1,252,0
         DATA     0
         DATA     0
         BOUND    8
RELSTAK  DATA     STAK-1
         GEN,1,15,16 1,252,0
RELNAV   DATA     0
RELREM   DATA     0
RELFLK   DATA     0
RELFDA   DATA     0
STAK     RES      252
*
RRBGEX   DATA     0
RBGSAV   RES      1
*
*
R:RNBG   PUSH     2,14
RNBG10   EQU      %
         STW,8    RNBGTMP           SAVE DISC ADDRESS
         BAL,11   RRBG              RELEASE IT
         BEZ      RNBG20            NOT RELEASED, QUIT
         BAL,3    LOAD%SECTOR       GET SECTOR ADDRESS IN 11            DISCB
         AI,11    2                 *** ASSUME 2 SECT/GRAN ***          DISCB
*************************************** ALL DEVICES ************
         BAL,3    STORE%SECTOR      STORE SECTOR ADDRESS IN 8           DISCB
         BDR,15   RNBG10
         LW,8     RNBGTMP           RESTORE FIRST DISC ADDRESS
RNBG20   PULL     2,14
         AI,8     0                 SET CC FOR RETURN
         B        *14               RETURN
*
R:RNCYL  PUSH     2,14
         STW,8    RNCYLTMP
RNCYL10  BAL,11   RRBG
         BEZ      RNBG20
         PUSH     8,R3
         BAL,3    LOAD%SECTOR       GET SECTOR ADDRESS IN 11            DISCB
         BAL,3    R:FNDHGP          GET HGP                             DISCB
         LI,3     X'FF'             GET THE NUMBER OF GRANULES          DISCB
         AND,3    1,7                 PER CYLINDER                      DISCB
         SLS,3    1                 MULTIPLY BY 2                       DISCB
*                                   *** ASSSUME 2 SECTORS/GRAN ***      DISCB
         AW,11    3                 BUMP DISC ADDRESS FOR NEXT CYL      DISCB
         BAL,3    STORE%SECTOR      STORE SECTOR ADDRESS IN 8           DISCB
         BDR,15   RNCYL10
         LW,8     RNCYLTMP
         B        RNBG20
*
RNBGTMP  DATA     0
         PULL     8,R3
RNCYLTMP DATA     0
*
*                                                                       DISCB
LOAD%SECTOR EQU   %                                                     DISCB
         LSECTA,11  8               LOAD SECTOR ADDRESS                 DISCB
         B        0,3               RETURN                              DISCB
*                                                                       DISCB
STORE%SECTOR EQU  %                                                     DISCB
         STSECTA,11,7  8            STORE SECTOR ADDRESS                DISCB
         B        0,3               RETURN                              DISCB
         TITLE    '****  CLSFILS  ****'
         SPACE    2
*
*  CLOSE ALL USER'S DCBS
*
         SPACE    2
CLSFILS  EQU      %
         STW,R11  CLSFLSX           SAVE RETURN
         STW,R11  CLSERRXIT         ERROR EXIT ADDRESS
         LI,R1    X'7FFFF'
         STW,R1   SDCBADR           ZAP CFU DCB ADDRESS
*
         LW,R1    J:DCBUL
         SW,R1    J:DCBLL           # DCB PAGES-1
         BLZ      XXCLS             NONE
         LW,R0    J:DCBLL
         AI,R1    1                 # DCB PAGES
         SLD,R0   9
         LCI      2
         STM,R0   DCBADR            SET UP FOR SNAPS
*
         LI,R8    X'1FFFF'
         AND,R8   J:DCBLINK
         BEZ      XXCLS             NO DCBS
*
DCBTBL   LI,R1    ERR#1
         STW,R1   ERRCODE           BAD DCB TABLE CODE
         AI,R8    1                 POINT TO TEXTC
         LW,R1    *R8               DCB NAME
         BEZ      XXCLS             NO MORE DCBS
         LB,R2    R1                TEXTC COUNT
         BNEZ     DCBFND            FOUND A DCB
         LW,R8    R1                MUST BE POINTER TO NEXT TABLE
         SLS,R1   -9                PAGE ADDRESS
         CLM,R1   J:DCBLL
         BCS,9    CLSERR            NOT IN DCB PAGES
         B        DCBTBL            GO PROCESS THIS TABLE
*
DCBFND   EQU      %                 FOUND A DCB
         LI,R6    ERR#2
         STW,R6   ERRCODE           BAD DCB ADDRESS CODE
         SLS,R2   -2
         AW,R8    R2
         AI,R8    1                 POINT TO DCB ADDRESS
         LW,R6    *R8               DCB ADDRESS
         CI,R6    M:OC
         BE       DCBTBL            DON'T
         CI,R6    M:UC                CLOSE
         BE       DCBTBL                SPECIAL DCBS
         LW,R11   R6
         SLS,R11  -9                PAGE ADDRESS
         CLM,R11  J:DCBLL
         BCS,9    CLSERR            BAD ADDRESS
         CW,R1    TXTCFU
         BE       CFUDCB            M:*
         STW,R8   SAVPTR
         MTW,1    CLSPRI            SET PRIVATE DA OK
         BAL,R11  CLSFIL            CLOSE THE DCB
         MTW,-1   CLSPRI
         LW,R11   CLSFLSX           RESTORE ERROR RETURN ADDRESS
         STW,R11  CLSERRXIT
         LW,R8    SAVPTR
         B        DCBTBL
*
XXCLS    LI,R6    M:XX              NOT IN DCB TABLE
         MTW,1    CLSPRI
         BAL,R11  CLSFIL
         MTW,-1   CLSPRI
         MTW,1    CLSFLSX           INCR RETURN
         B        *CLSFLSX
*
CFUDCB   STW,R6   SDCBADR           SAVE FOR CHKCFU
         B        DCBTBL
*
TXTCFU   TEXTC    'M:*'
SDCBADR  DATA     0
CLSFLSX  RES      1
SAVPTR   RES      1
         TITLE    '****  CLSFIL  ****'
         SPACE    2
*
*  CLOSE A DCB.  R6 = DCB ADDRESS
*    NO REGISTERS SAVED
*
         SPACE    2
CLSFIL   EQU      %
         STW,R11  CLSFLX
         STW,R11  CLSERRXIT
         LW,R1    ='INST'
         CW,R1    J:BASE+4
         BNE      CLSF40            USER WASN'T IN INST
*
*  CLEAN UP AFTER INST.  PERFORMS OPERATIONS ANALOGOUS TO THOSE
*    IN INSTCLNUP (WRTF).
*
         CW,R6    J:BASE+8          IS IT FOR THIS DCB
         BNE      CLSF40            NO
         LI,R1    X'1FFFF'
         AND,R1   CFU,R6
         LB,R5    J:BASE            BUFF2 BUFFER INDEX
         BEZ      CLSF30            NO BUFF2
         LI,R4    BUFF1
         BAL,R2   MAPSPARE          MAP IT IN
         B        CLSF40            ERROR
         LW,R8    J:BASE+1          GET THE DISC ADDRESS
         LI,R3    2048              BYTE COUNT
         BAL,R11  1D1               MODIFY IT IF HALF GRANULE
         LI,R4    BUFF1             RE-LOAD BUFFER ADDRESS
         BAL,R11  WRDISK1
         BAL,R11  CLSERR1           ERROR
         CI,R1    FILCFU
         BG       CLSF30            NOT DIRECTORY
         LW,R8    ACNCFU+4          DISC ADDR OF DUAL
         BEZ      CLSF30
         BAL,R11  WRDISK1
         BAL,R11  CLSERR1           ERROR
*
CLSF30   LB,R5    J:BASE+2          BUFF3 BUFFER
         BEZ      CLSF40            THERE ISN'T ONE
         LI,R0    1
         CW,R0    J:BASE+2          CHECK IF UPDATED
         BAZ      CLSF40            NOT UPDATED
         LI,R4    BUFF1
         BAL,R2   MAPSPARE          MAP IT IN
         B        CLSF40            ERROR
         LW,R8    J:BASE+3          DISC ADDRESS TO WRITE TO
         LI,R3    2048              BYTE COUNT
         BAL,R11  1D1               MODIFY IT IF HALF GRANULE
         LI,R4    BUFF1             RE-LOAD BUFFER ADDRESS
         BAL,R11  WRDISK1           WRITE IT
         BAL,R11  CLSERR1           ERROR
         CI,R1    FILCFU
         BG       CLSF40            NOT DIRECTORY
         LW,R8    ACNCFU+10         DISC ADDR OF DUAL
         BEZ      CLSF40
         BAL,R11  WRDISK1
         BAL,R11  CLSERR1           ERROR
*
CLSF40   EQU      %
*
         LW,R1    FCD,R6
         CW,R1    Y002
         BAZ      *CLSFLX           DCB CLOSED
*
         LI,R1    X'F'
         AND,R1   ASN,R6
         CI,R1    2
         BG       *CLSFLX           NOT DISC OR LABELLED TAPE
         SPACE    2
*
*  MAP BUF1 AND BUF2
*
         LI,R1    ERR#6
         STW,R1   ERRCODE           ERROR CODE FOR MAPPING ERROR
         LI,R4    BUFF1             BUF1 VIRTUAL ADDRESS
         LI,R5    BUF1MSK
         AND,R5   BUFX,R6
         BEZ      %+3               NO BUF1
         BAL,R2   MAPSPARE          MAP IT
         B        CLSERR            ERROR RETURN
*
         LI,R4    BUFF2             BUF2 VIRTUAL ADDRESS
         LI,R5    BUF2MSK
         AND,R5   BUFX,R6
         BEZ      %+4               NO BUF2
         SLS,R5   -5                RIGHT JUSTIFY
         BAL,R2   MAPSPARE          MAP IT
         B        CLSERR            ERROR RETURN
*
         LI,R1    2
         CW,R1    ASN,R6
         BANZ     CLSLBL            LABELLED TAPE
*
         LI,R1    X'1FFFF'
         AND,R1   CFU,R6            CFU ADDRESS
         BAL,R11  CFUCHK            VALIDATE IT
         B        %+2               ACNCFU OR FILCFU
         B        *CLSFLX           CFU NOT ACTIVE
         SPACE    2
         LW,R11   FUN,R6
         SLS,R11  -17               RIGHT JUSTIFY FUNCTION
         CI,R11   1
         BANZ     *CLSFLX           INPUT - NOTHING TO DO
         SPACE    2
*
*  WRITE OUT BUF1 AND BUF2 IF UPDATED
*
         LI,R11   ERR#7
         STW,R11  ERRCODE
         LW,R11   BBUD,R6
         CW,R11   Y004
         BAZ      TRUNC2            BUF1 NOT UPDATED
         LI,R4    BUF1MSK
         AND,R4   BUFX,R6
         BEZ      TRUNC2            NO BUF1
         LW,R3    CBD,R6
         SLS,R3   -17               CURRENT DISPLACEMENT
         AI,R3    0
         BEZ      TRUNC1A
         AI,R3    3                 ROUND UP
         AND,R3   =X'7FC'
         LI,R4    HACCBD
         STH,R3   *R1,R4            NEW CCBD IN CFU
         LW,R0    BCDA,R6
         STW,R0   SREC,R1           NEW DATA GRANULE ADDRESS
*
TRUNC1A  LI,R3    2048              BYTE COUNT
         LI,R4    BUFF1             VIRTUAL BUFFER ADDRESS
         LW,R8    BCDA,R6           DISC ADDRESS
         BAL,R11  WRDISK1           WRITE IT
         BAL,R11  CLSERR1           ERROR RETURN
*
TRUNC2   EQU      %
         LW,R4    MIUD,R6
         CW,R4    Y002
         BAZ      CHKFIL
         LI,R4    BUF2MSK
         AND,R4   BUFX,R6
         BEZ      CHKFIL            NO BUF2
         LI,R4    BUFF2             BUFFER ADDRESS
         LW,R8    DCBCDAM,R6        DISC ADDRESS
         LI,R3    2048
         BAL,R11  1D1               ADJUST BYTE COUNT
         BAL,R11  WRDISK1           WRITE IT
         BAL,R11  CLSERR1           ERROR RETURN
         CI,R1    FILCFU
         BG       CHKTEMP           NOT DIRECTORY
         LW,R8    ACNCFU+4          DISC ADDR OF DUAL
         BEZ      CHKFIL
         BAL,R11  WRDISK1
         BAL,R11  CLSERR1           ERROR
*
CHKFIL   CI,R1    FILCFU
         BG       CHKTEMP           NOT FILCFU OR ACNCFU
         LI,R5    X'1FFFF'
         LI,R4    X'1FFFF'
         AND,R4   TCFU,R6           USER'S CFU ADDRESS
         STS,R4   CFU,R6            MOVE TO CFU
         LW,R1    R4
         BAL,R11  CFUCHK            VALIDATE USER'S CFU
         B        TCFUBAD           TCFU IS ACNCFU OR FILCFU
         B        TCFUBAD           TCFU NOT ACTIVE
*
CHKTEMP  EQU      %
         LW,R4    2,R1              ACCOUNT AND NAME DISPLACEMENTS
         BEZ      RELFILE           TEMP FILE - RELEASE IT
         CW,R4    Y2
         BE       RELFILE           FILE IS BEING RELEASED
         LW,R2    FUN,R6
         SLS,R2   -17
         CI,R2    X'A'
         BANZ     RELFILE           RELEASE OUT AND OUTIN
         SPACE    2
         LI,R11   X'30'
         CS,R11   ORG,R6
         BE       *CLSFLX           RANDOM - NOTHING TO DO
         LW,R11   TDA,R1
         BLZ      RELFILE
1A1      RES      0
*
*  FIND FIT BY READING FROM FDA
*
         BAL,R11  GETFIT            FIT ADDR INTO FITDA
         SPACE    2
*
*  COMPARE ACCOUNTS IN DCB AND CFU
*
         LI,R11   ERR#B
         STW,R11  ERRCODE
         BAL,R11  GETFLACN          R8=ACCOUNT, R9=NAME
         B        CLSERR            COULDN'T FIND ONE OR BOTH
         LCI      2
         LM,R4    *R8               GET DCB ADDOUNT
         INT,R2   2,R1              ACCOUNT/NAME DISPLACEMENTS
         LI,R11   DCBPRIVBIT
         CW,R11   0,R6
         BANZ     COMPNAM           PRIVATE HAS NO ACCOUNT
         LC       GARBTIME          WAS GARBAGE COLLECTOR RUNNING
         BCS,4    COMPNAM           YES - CFU AREA INVALID
         CD,R4    *ACNCFU+13,R2     COMPARE
         BNE      CLSERR
         SPACE    2
*
*  COMPARE CFU AND FIT NAMES
*
COMPNAM  LI,R7    ERR#C
         STW,R7   ERRCODE
         LI,R7    RCBUF+4           ADDR OF CONSEC FIT
         LI,R0    X'20'
         CW,R0    ORG,R6
         BAZ      COMPNAM1          CONSEC FILE
         LI,R7    RCBUF+X'B0'       KEYED HALF GRAN FIT ADDR
         LI,R0    X'4000'
         CW,R0    RCBUF+2           CHECK FOR FULL/HALF GRAN
         BAZ      COMPNAM1          HALF
         LI,R7    RCBUF+X'1B0'      FULL GRAN FIT ADDR
*
COMPNAM1 LC       GARBTIME          IS GARBAGE COLLECTOR ACTIVE
         BCS,4    COMPNAM5          YES - CFU AREA MEANINGLESS
         LW,R4    R3
         LW,R5    R7                FIT FILE NAME
         SLD,R4   2
         LB,R0    0,R4              LENGTH OF NAME
         AI,R0    1                 INCLUDE TEXTC COUNT
         STB,R0   R5
         CBS,R4   0
         BNE      CLSERR            ERROR
         SPACE    2
*
*  COMPARE FIT AND DCB NAMES
*
COMPNAM5 LW,R5    R7                FIT NAME LOC
         LW,R4    R9                DCB NAME LOC
         SLD,R4   2
         STB,R0   R5
         AI,R7    9                 POINT TO FIRST FIT VLP
         CBS,R4   0
         BE       UPDATE            NAMES AGREE
         LI,R12   9                 MIGHT BE SYNONYMOUS
         BAL,R11  LOCCOD            FIND SYNONYMOUS COUNT
         B        CLSERR
         SLS,R3   1                 HW INDEX
         AI,R3    4
         LH,R3    *R7,R3            # SYNONYMOUS FILES
         BEZ      CLSERR            MUST BE AT LEAST ONE
         SPACE    2
*
*  UPDATE MODE - UPDATE INFO IN FIT
*      R7 POINTS TO FIRST VLP IN FIT
*
UPDATE   LI,R12   ERR#D
         STW,R12  ERRCODE
         LI,R12   X'0D'
         BAL,R11  LOCCOD            FILE SIZE VLP
         B        CLSERR            SHOULD BE ONE
         LW,R2    CLK,R6
         SLS,R2   9
         SAS,R2   -9                SIGN EXTENSION
         AWM,R2   *R7,R3            NEW SIZE
*
         LI,R12   X'0C'
         BAL,R11  LOCCOD            CFU INFO VLP
         B        CLSERR
         LI,R4    X'1FFFF'
         AND,R4   CFU,R6
         AW,R3    R7                R3=FIRST WORD OF X'0C' VLP
         LI,R5    X'8000'
         AND,R5   3,R3              SAVE O-BIT FROM FIT
         LCI      7
         LM,R7    FDA,R4
         LW,R8    TDA,R4
         LI,R11   0
         LCI      7
         STM,R7   0,R3              MOVE DISC ADDRESSES, CCBD
         LI,R12   X'FF'
         AND,R12  0,R4              SLIDES
         LC       *R4
         BCR,2    %+2               BR IF CFU O-BIT NOT SET
         AI,R12   X'8000'           SET O-BIT
         OR,R12   R5                SET O-BIT IF ORIGINALLY IN FIT
         LI,R13   X'FFFF'
         STS,R12  3,R3
*
*  WRITE OUT UPDATED FIT
*
         LI,R8    ERR#E
         STW,R8   ERRCODE
         LW,R8    FITDA             DISC ADDRESS
         LI,R4    RCBUF             BUFFER ADDRESS
         LI,R3    2048              BYTE COUNT
         BAL,R11  1D1               ADJUST BYTE COUNT
         BAL,R11  WRDISK1           WRITE IT
         B        CLSERR            ERROR RETURN
         B        *CLSFLX           EXIT FROM CLSFIL
         TITLE    '****  CFUCHK  ****'
         SPACE    2
*  PURPOSE:  VALIDATE A CFU
*
*  INPUT:  R1 = CFU ADDRESS
*
*  CALL:  BAL,R11  CFUCHK
*        RETURN NORMAL IF ACNCFU OR FILCFU
*        RETURN +1 IF USER CFU AND ACTIVE BIT RESET
*        RETURN +2 IF OK
*
         SPACE    2
CFUCHK   EQU      %
         STW,R11  CFURET
         LI,R2    ERR#3
         STW,R2   ERRCODE           BAD CFU ADDRESS CODE
         CI,R1    FILCFU
         BE       ACNFIL
         BG       USRCFU
         CI,R1    ACNCFU
         BNE      CLSERR
*
ACNFIL   EQU      %                 ACNCFU OR FILCFU
         LW,R8    CDAM,R1
         BAL,R0   CHKDA
         STW,R8   DCBCDAM,R6        MOVE TO DCB FOR UPDATING BUF2
         B        *CFURET
*
USRCFU   EQU      %
         LW,R10   ACNCFU+13         START OF ACCOUNT AREA
         AI,R10   2-CFUSIZE         HIEST LEGAL ADDR IN LO CORE
         CW,R1    R10                 FOR A CFU
         BG       SPECCFU           MIGHT BE CFU IN M:*
         LI,R10   BGRCFU
USRLOOP  CW,R1    R10
         BE       ADDROK            ADDRESS OK
         BL       CLSERR            BAD ADDRESS
         AI,R10   CFUSIZE           TRY ANOTHER
         B        USRLOOP
*
SPECCFU  EQU      %
         LW,R10   SDCBADR           EITHER M:* ADDR OR X'7FFFF'
         AI,R10   1                 CFUS BEGIN IN WORD 1
         LI,R2    5                 M:* HOLDS 5 CFUS
SPECLOOP CW,R1    R10
         BE       ADDROK            GOOD CFU
         BL       CLSERR            BAD
         AI,R10   CFUSIZE
         BDR,R2   SPECLOOP          TRY AGAIN
         B        CLSERR            BAD
         SPACE    2
*
*  CFU ADDRESS IS GOOD
*
ADDROK   MTW,1    CFURET            INCR RETURN ADDRESS
         LW,R10   0,R1
         CW,R10   Y00FE             ARE THERE ANY USERS
         BAZ      *CFURET           NO - CFU INACTIVE
         AI,R10   X'E0000'          SUBTRACT ONE USER
         STW,R10  0,R1
         LC       *R1
         BCR,4    *CFURET           RETURN IF NOT ACTIVE
         SPACE    2
*
*  VALIDATE ACCOUNT AND NAME POINTERS
*
         MTW,1    CFURET            BUMP RETURN ADDRESS
         LI,R10   ERR#4
         STW,R10  ERRCODE
         LI,R10   DCBPRIVBIT
         CW,R10   PRIV,R6
         BANZ     CHKNAM            PRIVATE HAS NO ACCOUNT
*
         LW,R10   2,R1              PICK UP POINTERS
         BEZ      VALDA             TEMP FILE
         CW,R10   Y2
         BE       VALDA             FILE BEING RELEASED
         LB,R9    R10
         CI,R9    X'03'
         BG       CLSERR            BAD
         BL       CHKACN            MUST BE INDEX TO ACCOUNT TABLE
*
*  MUST BE * FILE - WORD 2 CONTAINS TEXTC NAME
*
         LW,R2    J:JIT             BYTES 1 AND 2 MUST
         SLS,R2   8                   HAVE USER'S SYSID
         LW,R3    =X'FFFF00'
         CS,R2    R10
         BNE      CLSERR
         LI,R2    #STAR             BYTE 3 MUST HAVE
         CB,R10   STARTBL,R2          LEGAL * NAME
         BE       VALDA             IT DOES
         BDR,R2   %-2
         B        CLSERR            IT DOESN'T
         SPACE    2
STARTBL  DATA,1   0,'B','D','G','L','T','N'
#STAR    EQU      BA(%)-BA(STARTBL)-1
         BOUND    4
         SPACE    2
*
*  CHECK FOR LEGAL ACCOUNT TABLE INDEX
*
CHKACN   EQU      %
         LH,R2    R10               ACCOUNT TABLE DW INDEX
         SLS,R2   1                 WORD INDEX
         AI,R2    2
         AW,R2    ACNCFU+13
         CW,R2    ACNCFU+15         MUST BE BELOW NAME TABLE
         BGE      CLSERR
         SPACE    2
*
*  VALIDATE NAME ADDRESS
*
CHKNAM   EQU      %
         INT,R3   2,R1              NAME INDEX
         LC       GARBTIME
         BCS,4    VALDA             NAME POINTER NOT VALID
         CW,R3    ACNCFU+16
         BGE      CLSERR            TOO LARGE
         CW,R3    ACNCFU+15
         BL       CLSERR            TOO SMALL
         LB,R2    *R3               TEXTC COUNT
         BEZ      CLSERR
         CI,R2    31
         BG       CLSERR            BAD TEXTC COUNT
         SPACE    2
*
*  VALIDATE ALL DISC ADDRESSES IN CFU
*
VALDA    EQU      %
         LW,R8    FDA,R1
         BAL,R0   CHKDA
         LW,R8    GAVAL,R1
         BAL,R0   CHKDA
         LW,R8    SREC,R1
         BAL,R0   CHKDA
         LW,R8    LDA,R1
         BAL,R0   CHKDA
         LW,R8    TDA,R1
         LI,R0    X'30'
         AND,R0   ORG,R6
         CI,R0    X'20'
         BNE      %+2               TDA VALID ONLY FOR KEYED
         BAL,R0   CHKDA
         B        *CFURET           RETURN TO CALLER
         SPACE    2
*
*  VALIDATE DISC ADDRESSES
*
CHKDA    AND,R8   M24               MASK OFF DISC ADDRESS
         BEZ      *R0               RETURN IF ZERO
         BAL,R11  RCHKDA
         BCS,15   *R0               RETURN IF OK
         LI,R2    ERR#5
         STW,R2   ERRCODE
         B        CLSERR
         SPACE    4
TCFUBAD  LI,R0    ERR#3             BAD CFU ADDRESS
         STW,R0   ERRCODE
         B        CLSERR
         TITLE    '****  LOCATE FIT  ****'
         SPACE    2
*  PURPOSE:  LOCATE FIT BY READING FORWARD FROM FDA
*
*  CALL:  BAL,R11  GETFIT
*
*  OUTPUT:  RETURNS WITH FIT DISC ADDRESS IF FITDA IF FOUND,
*             GOES TO CLSERR IF NOT.
*
         SPACE    2
GETFIT   EQU      %
         STW,R11  FINDRET
         LI,R0    ERR#A
         STW,R0   ERRCODE
         LI,R8    0
         STW,R8   BLINK             FDA BLINK SHOULD BE ZERO
         LI,R2    0                 # TIMES TO FLINK FORWARD
         LW,R8    SREC,R1           RANDOM FIT
         LI,R3    X'30'
         CS,R3    ORG,R6
         BE       GETFIT4           IT'S RANDOM
         LW,R8    M24
         AND,R8   FDA,R1            REMOVE EMPTY FILE FLAG
         LI,R2    2000              MAX # READS
*
GETFIT4  LI,R15   2048              BYTE COUNT
         BAL,R11  1D2               ADJUST SIZE
         BAL,R11  RDDISK            READ IT
         B        CLSERR            ERROR RETURN
         LW,R11   RCBUF             BLINK OF GRANULE READ
         CW,R11   BLINK
         BNE      CLSERR            DOESN'T MATCH
         STW,R8   BLINK             NEXT EXPECTED BLINK
*
         LI,R11   X'20'
         CW,R11   ORG,R6
         BAZ      GETFIT6           CONSEC FIT AT FDA
*
         LI,R11   X'8000'           MAY HAVE TO SEARCH FOR KEYED FIT
         CW,R11   RCBUF+2           LOOK FOR FIT FLAG
         BANZ     GETFIT6           FOUND IT
         LW,R8    RCBUF+FLINK       FLINK DISC ADDRESS
         BDR,R2   GETFIT4           READ FLINK
         B        CLSERR            TOO MANY READS
*
GETFIT6  STW,R8   FITDA
         B        *FINDRET
         TITLE    '****  LOCATE FILE NAME/ACCOUNT  ****'
         SPACE    2
*  PURPOSE:  LOCATE FILE NAME AND ACCOUNT IN DCB
*
*  INPUT:  R6 = DCB ADDRESS
*
*  CALL:  BAL,R11  GETFLACN
*
*  OUTPUT:  R8 = ADDRESS OF ACCOUNT
*           R9 = ADDRESS OF NAME
*
*  VOLATILE:  R7
*
GETFLACN PUSH     9,R11
         LI,R7    X'1FFFF'
         AND,R7   FLP,R6            VLP POINTER
         LI,R12   X'01'             NAME VLP
         BAL,R11  LOCCOD
         B        GETFLXIT          DIDN'T FIND
         LW,R9    R7
         AW,R9    R3                SAVE LOCATION OF NAME
*
         LI,R12   X'02'
         BAL,R11  LOCCOD            FIND ACCOUNT
         B        GETFLXIT          DIDN'T FIND
         LW,R8    R7
         AW,R8    R3                SAVE ACCOUNT LOCATION
         LI,R7    0                 FOUND FLAG
*
GETFLXIT PULL     9,R11
         AI,R7    0
         BNEZ     *R11              DIDN'T FIND EXIT
         AI,R11   1
         B        *R11              FOUND EXIT
         TITLE    '****  LOCATE VLPS  ****'
         SPACE    2
*  PURPOSE:  LOCATE VLPS
*
*  INPUT:  R7 = ADDRESS OF FIRST VLP
*          R12 = VLP CODE
*
*  CALL:  BAL,R11  LOCCOD
*
*  OUTPUT:  R3 = INDEX BEYOND R7 OF START OF VLP
*
*    RETURN NORMAL IF NOT FOUND
*    RETURN SKIPPING IF FOUND
*
*  VOLATILE:  R1,R3,R12,R13
*
         SPACE    2
LOCCOD   EQU      %
         LI,R3    0
LOCCOD1  LW,R13   *R7,R3            NEXT CONTROL WORD
         AI,R3    1                 POINT PAST CONTROL WORD
         CB,R12   R13
         BE       LOCCOD2           FOUND VLP
         CW,R13   Y00FF
         BANZ     *R11              LAST CONTROL WORD - DIDN'T FIND
         AND,R13  XFF
         AW,R3    R13               POINT TO NEXT CONTROL WORD
         B        LOCCOD1
*
LOCCOD2  AI,R11   1                 NORMAL RETURN
         B        *R11
         TITLE    '****  ADJUST BYTE COUNTS  ****'
         SPACE    2
*  ADJUST BYTE COUNT FOR FULL/HALF GRANULES
         SPACE    2
1D1      EQU      %
         CI,R8    1
         BAZ      *R11              EVEN REL SECTOR
         LI,R3    1024              ODD - REDUCE BYTE COUNT
         B        *R11
         SPACE    4
1D2      EQU      %
         CI,R8    1
         BAZ      *R11              EVEN REL SECTOR
         LI,R15   1024              ODD - REDUCE BYTE COUNT
         B        *R11
         TITLE    '****  RELEASE FILE  ****'
         SPACE    2
*  PURPOSE:  RELEASE A FILE'S GRANULES
         SPACE    2
RELFILE  EQU      %
         LI,R5    ERR#10
         STW,R5   ERRCODE
*
         LI,R5    X'30'
         CS,R5    ORG,R6
         BE       RELRANDOM         RELEASE RANDOM FILE
*
*  RELEASE KEYED OR CONSECUTIVE FILE
*
         LW,R8    FDA,R1            FIRST DISC ADDRESS
         AND,R8   M24               SCRUB BAD BITS
         STW,R8   RCBUF+FLINK       PSEUDO FLINK
         LI,R2    0
         STW,R2   BLINK             EXPECTED BLINK
         LI,R2    2000              MAX # READS
         STW,R2   FLPCNT
*
REL10    LW,R8    RCBUF+FLINK       NEXT DISC ADDR TO READ
         BNEZ     1A2               NOT DONE
         LW,R1    CFU,R6
         LW,R8    TDA,R1
         BGEZ     *CLSFLX
         STW,R8   FDA,R1
         AND,R8   M24
         STW,R8   LDA,R1
         LI,R8    0
         STW,R8   GAVAL,R1
         STW,R8   SREC,R1
         STW,R8   SCFU,R1
         B        1A1
1A2      RES      0
         BAL,R11  RRBG              RELEASE IT
         MTW,-1   FLPCNT
         BLZ      CLSERR            MAY BE LOOPING - QUIT
         LI,R15   512*4             BYTE COUNT
         BAL,R11  1D2               CHK SIZE
         BAL,R11  RDDISK            READ IT
         B        CLSERR            ERROR RETURN
         XW,R8    BLINK
         CW,R8    RCBUF
         BNE      CLSERR            EXPECTED BLINK NOT FOUND
*
         LI,R3    X'20'
         CW,R3    ORG,R6
         BANZ     RELKEYED          KEYED FILE
*
         LH,R3    RCBUF+NAVX
         CI,R3    X'3FFF'
         BANZ     CLSERR            NOT CONSEC GRANULE
*
         INT,R0   RCBUF+2
         BCR,8    REL10             NO UNBLOCKED RECORDS
*
         LI,R3    2
RELCON   AI,R3    1                 POINT TO NEXT CONTROL WORD
         CI,R3    512
         BGE      REL10             AT END OF BLOCK
         LI,R2    5
         CH,R3    RCBUF,R2
         BG       REL10             PAST LAST CONTROL WORD
         LW,R0    RCBUF,R3          GET CONTROL WORD
         BGEZ     RELCON10          BLOCKED RECORD - IGNORE
         LW,R8    M24
         AND,R8   RCBUF,R3          DISC ADDR OF UNBLOCKED RECORD
         BAL,R11  RRBG              RELEASE IT
         B        RELCON            GO TO NEXT CONTROL WORD
*
RELCON10 INT,R0   R0
         AI,R0    3                 ROUND UP BYTE COUNT
         SLS,R0   -2                CONVERT TO WORDS
         AW,R3    R0                POINT TO END OF DATA
         B        RELCON
         SPACE    4
*
*  RELEASE KEYED FILE DATA GRANULES
*
RELKEYED EQU      %
         LI,R1    BASCR
         LB,R2    *R6,R1            SCR = KEYM+1
         LI,R1    3
         CB,R2    RCBUF+NAVX,R1     SCR MUST BE IN WORD 2
         BNE      CLSERR
         LH,R1    RCBUF+NAVX        GET NAV
         CI,R1    MIDIS
         BL       CLSERR            OUT OF
         CI,R1    X'800'
         BGE      CLSERR              LEGAL RANGE
*
         LI,R3    MIDIS
RELKEY10 CH,R3    RCBUF+NAVX
         BGE      REL10             AT END OF BLOCK
         AW,R3    R2                POINT PAST KEY
         MTB,0    RCBUF,R3          ONLY RELEASE
         BNEZ     RELKEY20            IF DISPLACEMENT
         AI,R3    1                   INTO DATA
         MTB,0    RCBUF,R3            GRANULE
         BEZ      RELBLK              IS ZERO
         AI,R3    -1                NON-ZERO, DON'T RELEASE
RELKEY20 AI,R3    13                POINT TO NEXT KEY
         B        RELKEY10
*
RELBLK   EQU      %                 RELEASE THE DATA GRANULE
         AI,R3    3                 POINT TO DISC ADDRESS
         LI,R1    -4
         LB,R0    RCBUF,R3          GET DISC ADDRESS
         STB,R0   R9,R1             PUT INTO R8
         AI,R3    1
         BIR,R1   %-3
         BAL,R11  RRBG              RELEASE IT
         AI,R3    5                 POINT TO NEXT KEY
         B        RELKEY10
         TITLE    '****  RELEASE RANDOM FILE  ****'
         SPACE    2
*  PURPOSE:  RELEASE PUBLIC RANDOM FILE
         SPACE    2
RELRANDOM EQU     %
         LW,R8    FDA,R1            STARTING DISC ADDRESS
         LW,R15   TDA,R1            # GRANULES IN FILE
         BEZ      *CLSFLX           ZERO SIZE - EXIT
         LI,R7    DCBPRIVBIT
         CW,R7    PRIV,R6
         BAZ      RANPUB            PUBLIC FILE
*
*  RELEASE PRIVATE RANDOM FILE
*
         LI,R9    0                 PRIVATE FLAG
*
*  RELEASE CYLINDER ALLOCATED RANDOM FILE
*        R3 = CURRENT VOL # / DCTX
*        R8 = CURRENT DISC ADDRESS
*        R9 = >0 IF PUBLIC
*        R15 = # GRANULES TO RELEASE
*
RRR      LDCTX,R3 R8                GET VOL #/DCTX
RRR0     LW,R10   R15               SAVE TOTAL TO RELEASE
RRR1     BDR,R9   RRR0A             BR IF PUBLIC
         BAL,R11  RCHKDA            LOCATE HGP
         BCR,15   CLSERR
         LI,R7    X'1FFFF'
         AND,R7   PAT,R6            HGP ADDRESS
         B        RRR0B
*
RRR0A    STDCTX,R3 R8               PUT IN CURRENT DCTX
         BAL,R11  R:FNDHGP          FIND PUBLIC HGP
         BEZ      CLSERR
*
RRR0B    INT,R4   1,R7              GET DCTX, CYLSZ
         AND,R5   M8
         BEZ      CLSERR            # GRAN/CYL CAN'T BE ZERO
         BDR,R9   RRR2              BR IF PUBLIC
         AI,R8    0
         BNE      RRR2              IF REL SECTOR IS ZERO, MUST
         AW,R8    R5                  INCREMENT PAST NVAT
         CI,R8    30
         BL       %-2
         SLS,R8   1                 CONVERT TO SECTORS
*
RRR2     LSECTA,R11  R8             RELATIVE SECTOR ADDRESS
         LB,R4    R:DCT22,R4        DISC TYPE
         BEZ      CLSERR
         LW,R15   R:DISCLIMS,R4     # SECTORS ON DEVICE
         SW,R15   R11
         SLS,R1   -1                # GRANS TO END OF PACK
         CW,R15   R10               RELEASE THE SMALLER OF TOTAL
         BL       %+2                 TO RELEASE AND # TO END
         LW,R15   R10                 OF THIS PACK
         AW,R15   R5
         AI,R15   -1
         DW,R15   R5                # CYLINDERS TO RELEASE
         BDR,R9   RRR3              BR IF PUBLIC
         BAL,R11  RNPVCYL           RELEASE PRIVATE CYLINDERS
         BEZ      CLSERR
         B        RRR4
*
RRR3     BAL,R14  R:RNCYL           RELEASE PUBLIC CYLINDERS
         BEZ      CLSERR
RRR4     AI,R3    1                 INCR DCTX / VOL #
         LI,R8    0                 POSITION TO BEGINNING OF PACK
         MW,R15   R5                # GRANULES RELEASED
         SW,R10   R15
         BGZ      RRR1              NOT DONE YET
         B        *CLSFLX           DONE
         SPACE    2
*
*  RELEASE PUBLIC RANDOM FILE
*
RANPUB   EQU      %
         LW,R9    R15               # TO RELEASE
         BAL,R3   R:FNDHGP          LOCATE HGP
         BEZ      CLSERR            ERROR
         LW,R3    1,R7              HGP FLAGS
         CI,R3    X'8000'           IS IT CYLINDER ALLOCATED
         BANZ     RANPUB1           YES
         BAL,R14  R:RNBG            NO - RELEASE GRANULES
         B        *CLSFLX           DONE
         SPACE    2
*
*  RELEASE PUBLIC CYLINDER ALLOCATED RANDOM FILE
*
RANPUB1  LI,R9    X'7FFFF'          PUBLIC FLAG
         B        RRR
         TITLE    '****  CLOSE LABELLED TAPE  ****'
*
* CLOSE LABELED TAPE DCB
* R6 -> DCB
*
CLSLBL   EQU      %
         LI,R1    ERR#F
         STW,R1   ERRCODE
         LW,R1    Y0008
         CW,R1    EOP,R6
         BAZ      *CLSFLX           LAST OPERATION NOT WRITE
         LW,R1    Y001
         CW,R1    BFL,R6            IS TBT SET
         BANZ     CLSLBL20          YES - BUFFER WAS TRUNCATED
         LI,R1    BUF1MSK           BUFFER NOT TRUNCATED - MUST
         AND,R1   BUFX,R6             WRITE IT OUT
         BNEZ     CLSLBL2
         BAL,R11  CLSERR1           ERROR - NO BUFFER
         B        CLSLBL20          WRITE THE CONTROL RECORDS
*
CLSLBL2  EQU      %
         LI,2     512
         LW,3     BUFF1-1,2         MOVE BUFFER TO UNMAPPED MEMORY
         STW,3    RCBUF-1,2
         BDR,2    %-2
         LI,0     DA(WRTRCBUF)
         BAL,R11  TPIO              ISSUE SIO
*
CLSLBL20 EQU      %
         LI,0     DA(WRTEOF)
         BAL,R11  TPIO              ISSUE SIO
         B        *CLSFLX
*
         BOUND    8
WRTRCBUF EQU      %
         GEN,8,24 1,BA(RCBUF)
         GEN,8,24 0,512*4
WRTEOF   GEN,8,24 X'73',0           TM
         GEN,8,24 X'20',0
         GEN,8,24 1,BA(:EOF)        :EOF
         GEN,8,24 X'20',12
         GEN,8,24 X'73',0           TM
         GEN,8,24 X'20',0
         GEN,8,24 1,BA(:EOR)        :EOR
         GEN,8,24 X'20',12
         GEN,8,24 X'73',0           TM
         GEN,8,24 X'20',0
         GEN,8,24 X'73',0           TM
         DATA     0
*
:EOF     TEXT     ':EOF'
         DATA     2048              PBS - PREV BLOCK SIZE
:EOR     TEXT     ':EOR'
*
TPIO     EQU      %                 ISSUE SIO TO TAPE
         LI,R1    X'FF'
         AND,R1   DSI,R6            DCT INDEX
         BEZ      CLSERR            ERROR
         CI,R1    DCTSIZ
         BG       CLSERR            ERROR
         LB,R2    DCT4,R1           DEVICE TYPE
         LC       TB:FLGS,R2        DEVICE TYPE FLAGS
         BCS,4    CLSERR            NOT TAPE - ERROR
         BCR,8    CLSERR            NOT TAPE - ERROR
         LH,R1    DCT1,R1           DEVICE ADDRESS
*
         SIO,R4   *R1
         BCS,12   CLSERR            SIO REJECTED - GIVE UP
         LI,R2    1000
TPIO4    LI,R3    2000
         TIO,R4   *R1               CHECK I/O
         BCR,12   *R11              RETURN IF I/O COMPLETE
         BDR,R3   %                 DELAY
         BDR,R2   TPIO4
         HIO,R2   *R1               GIVE UP
         B        CLSERR
         TITLE    '****  SCANCFU  ****'
         SPACE    2
*  PURPOSE:  SCAN ALL CFUS AFTER CYCUSR TO FIND OPEN ONES
*
*  CALL:  BAL,R11  SCANCFU
*
         SPACE    2
SCANCFU  EQU      %
         PUSH     R11
         LW,R3    ACNCFU+13         START OF ACCOUNT AREA
         AI,R3    2-CFUSIZE         LAST VALID CFU ADDRESS
         LI,R1    BGRCFU-CFUSIZE
*
SCANLOOP AI,R1    CFUSIZE           POINT TO NEXT CFU
         CW,R1    R3
         BG       SCANEND           DONE
         INT,R2   0,R1
         BCR,4    SCANLOOP          NOT ACTIVE
         CI,R2    X'FE'
         BAZ      SCANLOOP          NO USERS
         RXPSD    DBPSD4            ERROR - # USERS > 0
         B        SCANLOOP
*
SCANEND  PULL     R11
         B        *R11
*
         TITLE    '****  DATA CELLS  ****'
         SPACE    2
*
*  DATA CELLS
*
         SPACE    1
BLINK    RES      1
CFURET   EQU      %
FINDRET  RES      1
CLSFLX   RES      1
ERRCODE  DATA     X'FF'
FITDA    DATA     0
FLPCNT   RES      1
CLSERRXIT RES     1
CLSERRXIT1 DATA   0
         TITLE    '****  CONSTANTS  ****'
         SPACE    2
Y8       DATA     X'80000000'
Y2       DATA     X'40000000'
Y004     DATA     X'00400000'
Y002     DATA     X'00200000'
Y001     DATA     X'00100000'
Y0008    DATA     X'00080000'
Y00FF    DATA     X'00FF0000'
Y00FE    DATA     X'00FE0000'
*
XFF      DATA     X'FF'
M24      DATA     X'00FFFFFF'
M8       EQU      XFF
         TITLE    '****  ERROR HANDLING ****'
         SPACE    2
*
*  HANDLE ERROR ENCOUNTERED DURING CLOSE
*
         SPACE    2
CLSERR1  EQU      %                 RETURN *R11 AFTER PROCESSING
         STW,R11  CLSERRXIT1
*
CLSERR   EQU      %                 EXIT FROM CLSFIL OR CLSFILS
         RXPSD    DBPSD3            GO TO DEBUG MODULE
         MTW,0    CLSERRXIT1
         BEZ      *CLSERRXIT        ENTERED VIA CLSERR
         LI,R11   0                 ENTERED VIA CLSERR1
         XW,R11   CLSERRXIT1        ZERO FLAG AND GET RETURN
         B        *R11
         END

