         DEF      TSTHGP:
TSTHGP:  EQU      %
         PCC      0
*
         SYSTEM   SIG7P
UTSPROC  SET      0
MONPROC  SET      1
DISCBPROC SET     1
         SYSTEM   UTS
*
     SPACE         3
*M*  TSTHGP        PERFORM RECOVERY OF FILES AT SYSTEM CRASH
     SPACE         3
*P*  NAME:         TSTHGP
*P*
*P*  PURPOSE:      PROVIDE FOR THE ORDERLY CLOSING OF DISC AND
*P*                LABELLED TAPE FILES OPEN AT THE TIME OF A
*P*                SYSTEM CRASH.
*P*                WRITE THE IN-CORE HGPS TO PRIVATE PACKS MOUNTED
*P*                AT CRASH TIME.
*P*                SAVE DISC ADDRESSES FROM ALLOCAT'S IN-CORE STACKS.
*P*
*P*  DESCRIPTION:  AS EACH USER IS LOCATED BY CYCUSR, CLSFILS IS
*P*                CALLED TO CLOSE ALL OPEN FILES.  UPDATED BUFFERS
*P*                ARE WRITTEN OUT, AND THE FIT IS UPDATED.
*P*                FILES OPEN OUTPUT ARE RELEASED.  :EOF AND
*P*                :EOR SENTINELS ARE WRITTEN TO LABELLED TAPES
*P*                OPEN OUT.
*P*                IN-CORE HGPS FOR ANY MOUNTED PRIVATE PACKS ARE
*P*                VERIFIED AND WRITTEN OUT TO THE VTOCS.
*P*                THE DISC ADDRESSES IN ALLOCAT'S IN-CORE STACKS
*P*                ARE SAVED, TO BE RELEASED LATER BY FIX.
     PAGE
     SPACE         2
         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            MODULE NAME FOR PATCHING
         DEF      CLSFILS           CLOSE ALL USER DCBS
         DEF      RRSG              RELEASE SYMBIONT GRANULE
         DEF      SAVHGP            SAVE ALLOCAT STACKS
         DEF      RELFDA            USED TO WRITE COLLECTED DA BUFFERS
         DEF      RRBG10            USED TO WRITE COLLECTED DA BUFFERS
         DEF      SCANCFU           SEARCH FOR OPEN CFUS
         DEF      ERRCODE           ERROR CODE FOR DEBUG MODULE
         TITLE    '****  EXTERNAL REFERENCES  ****'
         SPACE    2
         REF      ACNCFU            ACCOUNT CFU
         REF      BGRCFU            FIRST USER CFU
         REF      LASTCFU           END OF CFU AREA
         REF      CFUSIZE           SIZE OF USER CFU
         REF      CLSPRI            FLAG FOR PRIV DISC ADDRESS
         REF      J:JIT             VIRTUAL JIT ADDRESS
         REF      RCHKDA            VALIDATE DISC ADDRESS
         REF      HGP               ADDRESS OF HGP HEADERS
         REF      DCT4
         REF      DCT1
         REF      DCTSIZ            SIZE OF DCT TABLES
         REF      R:DCT22           RECOVERY COPY OF DCT22
         REF      R:DISCLIMS        RECOVERY COPY OF DISCLIMS
         REF      TYOUT             TYPE MESSAGE TO OPERATOR
         REF      RCBUF             RECOVERY BUFFER
         REF      AVRTBL            AVR TABLE
         REF      AVRTBLNE          # TAPES PLUS PACKS
         REF      AVRTBLSIZ         # TAPES
         REF      BATAPE            FIRST TAPE DCT INDEX
         REF      DCT16
         REF      WRDISK            WRITE DISK
         REF      R:TSTACK          RECOVERY'S STACK
         REF      R:FNDHGP          LOCATE HGP GIVEN DCTX
         REF      WRDISK1           WRITE DISK
         REF      RDDISK            READ DISK
         REF      R:CHKDA           VALIDATE DISC ADDRESS
         REF      R:HGP             RECOVERY'S COPY OF HGP HEADERS
         REF      M:XX
         REF      J:DCBLINK         POINTER TO FIRST DCB TABLE
         REF      FILCFU            FILE DIRECTORY CFU
         REF      J:DCBLL           FIRST PAGE OF DCBS
         REF      J:DCBUL           LAST PAGE OF DCBS
         REF      J:BASE            TEMP STORAGE IN JIT
         REF      JSBUF1VP          PAGE # OF SPECIAL BUFFER 1
         REF      RNVAT             RELEASE NVAT DISC ADDRESS
         REF      RNPVCYL           RELEASE N PRIV CYLINDERS
         REF      RPVCYL            RELEASE ONE PRIV CYLINDER
         REF      MAPSPARE          MAP IN FPOOL BUFFER
         REF      TB:FLGS           DEVICE TYPE FLAGS
         REF      TOP               TOP OF ALLOCAT BUFFER
         REF      BOTTOM            BOTTOM OF ALLOCAT BUFFER
         REF      TEMPBOT           TEMP BOTTOM OF ALLOCAT BUFFER
         REF      WORDCNT           # WORDS USED IN ALLOCAT BUFFER
         REF      ADJSTCNT          CHANGE IN BUFFER SIZE
         REF      CATBUF            START OF ALLOCAT BUFFERS
         REF      BUFMASK           ALLOCAT CIRCULAR BUFFER AMSKS
         REF      GARBTIME          FLAG FOR CFU GARBAGE COLLECTOR
         REF      PRDCRM            JIT DISPL TO REMAINING RAD GRANS
         REF      PRDPRM            JIT DISPL TO REMAINING PACK GRANS
         REF      SV1               ROUTINE TO PUT R15 INTO RECOVERY BUF
*
         SREF     RDBFLG            FLAG FOR PRESENCE OF DEBUG MODULE
         SREF     DBPSD1            DEBUG PSD 1
         SREF     DBPSD2            DEBUG PSD 2
         SREF     DBPSD3            DEBUG PSD 3
         SREF     DBPSD4            DEBUG PSD 4
         SREF     DCBADR            ADDRESS OF DCB PAGES
         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
         SPACE    5
         CLOSE    TCFU
TCFU     EQU      X'0D'
FITCFU   EQU      FILCFU+4
         TITLE    '****  TSTHGP  ****'
         SPACE    2
TSTHGP   EQU      %
         SPACE    2
*F*  NAME:         TSTHGP
*F*
*F*  PURPOSE:      VALIDATE CFU ARE NAME/ACCOUNT POINTERS.
*F*                VERIFY CONSISTENCY OF ALLOCAT STACK POINTERS.
     SPACE         1
*D*  NAME:         TSTHGP
*D*
*D*  REGISTERS:    ALL VOLATILE
*D*
*D*  CALL:         BAL,R11
*D*
*D*  ENVIRONMENT:  MASTER UNMAPPED
*D*
*D*  DESCRIPTION:  THE POINTERS TO ACCOUNT AND NAME AREAS IN CFU
*D*                AREA ARE VALIDATED.  IF BAD, A MESSAGE IS
*D*                PRINTED AND THEY ARE MADE BENIGN.
*D*
*D*                IF ALLOCAT WAS ACTIVE AT TIME OF CRASH, THE
*D*                BUFFER POINTERS ARE CORRECTED.
*D*                THE POINTERS ARE THEN CHECKED TO INSURE THAT
*D*                WORD COUNT MATCHES SPACE BETWEEN TOP AND BOTTOM
*D*                POINTERS.  BUFFER SIZES ARE CHECKED TO INSURE
*D*                THAT BUFFERS DO NOT OVERLAP.  ALL DISC ADDRESSES
*D*                ARE CHECKED FOR LEGALITY.
*D*                ANY ERRORS DETECTED RESULT IN THE FLAG SPDFLG
*D*                BEING SET.  SAVHGP WILL THEN IGNORE ALL DISC
*D*                ADDRESSES IN THE BUFFERS.
*D*
*D*                FINALLY THE HGP HEADERS IN CORE ARE CHECKED.
*D*                ANY ERROR RESULTS IN THE MESSAGE 'HGP MALFORMED'
*D*                PRINTED ON THE OC.  NO OTHER ACTION IS TAKEN.
         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
*
*O*  MESSAGE:      ACNCFU NAME/ACCOUNT POINTERS BAD
*O*
*O*  ACTION:       NONE
*O*
*O*  MEANING:      THE POINTERS DEFINING THE ACCOUNT AND NAME AREAS
*O*                IN THE CFU AREA ARE IN ERROR.  AS A RESULT, NO
*O*                OPEN FILES WILL BE CLOSED.  ANY FILES
*O*                OPEN INOUT MAY BE DAMAGED, AND GRANULE SPACE FOR
*O*                FILES OPEN OUT OR OUTIN MAY BE LOST.
*
         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
         PUSH     R4
         LI,R4    ERRHDR
         BAL,R11  TYOUT             TYPE HEADER
         PULL     R4
         BAL,R11  TYOUT             TYPE THE MESSAGE
         STW,R11  SPDFLG            FLAG FOR NO SAVE
         B        TST24
*
*O*  MESSAGE:      ERROR IN IN-CORE DISK ADDRESS BUFFERS - XXXX
*O*
*O*  ACTION:       NONE
*O*
*O*  MEANING:      THE IN-CORE DISK ADDRESS TABLES MAINTAINED BY ALLOCAT
*O*                ARE IN ERROR.  THE STRING XXXX DEFINES THE ERROR:
*O*                  COUNT ERROR - THE SPACE IN A BUFFER CALCULATED
*O*                    FROM THE TOP AND BOTTOM POINTERS IS DIFFERENT
*O*                    FROM THE COUNT
*O*                  BUFFER OVERLAP - THE TOP AND BOTTOM POINTERS OVERLAP
*O*                  BAD DISK ADDRESS FOUND - THE BUFFER CONTAINS A
*O*                    BAD DISK ADDRESS
*
         SPACE
CNTERR   TXTC     'COUNT ERROR',CR,CR
OVLPERR  TXTC     'BUFFER OVERLAP',CR,CR
DAERR    TXTC     'BAD DISK ADDRESS FOUND',CR,CR
ERRHDR   TXTC     CR,CR,'ERROR IN IN-CORE DISK ADDRESS BUFFERS - '
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     ATPRIVBIT
         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
*
*O*  MESSAGE:      HGP MALFORMED
*O*
*O*  ACTION:       NONE
*O*
*O*  MEANING:      THE HGP HEADERS LOADED WITH RECOVERY ARE DIFFERENT
*O*                FROM THE HEADERS IN LOW CORE.  MOST LIKELY LOW CORE
*O*                HAS BEEN CLOBBERED.
*
SPDFLG   DATA     0
         PAGE
         SPACE    2
*F*  NAME:         SAVHGP
*F*
*F*  PURPOSE:      SAVE ALL DISC ADDRESSES FROM ALLOCAT IN-CORE
*F*                STACKS.
*F*                WRITE IN-CORE HGPS TO VTOCS OF ANY CURRENTLY
*F*                MOUNTED PRIVATE PACKS.
     SPACE         1
*D*  NAME:         SAVHGP
*D*
*D*  REGISTERS:    ALL VOLATILE
*D*
*D*  CALL:         BAL,R11
*D*
*D*  ENVIRONMENT:  UNMAPPED MASTER
*D*
*D*  DESCRIPTION:  IF FLAG IS SET (SPDFLG) INDICATING STACKS ARE
*D*                INCONSISTENT, PROCEED TO PRIVATE PACK RECOVERY.
*D*                REMOVE ALL DISC ADDRESSES FROM STACKS, CALLING
*D*                RRBG TO SAVE THEM.
*D*
*D*                SEARCH AVR TABLE FOR AVR'D PRIVATE PACKS.
*D*                FOR EACH ONE FOUND, READ ITS VTOC AND VERIFY
*D*                THAT SERIAL NUMBER CORRESPONDS TO ONE IN AVRTBL.
*D*                MOVE HGP FROM CORE TO VTOC, WRITE VTOC.
*
         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                 GET HGP DISPLACEMENT
         LW,4     HGP+1,5           WORD 1 OF HGP
         CI,4     ATPRIVBIT
         BAZ      SAV25             NOT PRIVATE - IGNORE
         LC       3
         BCR,2    SAV42             NOT AVR'D - ZAP ENTRY
         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,4     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
         CI,7     X'70000'
         BNE      SAV40
         INT,7    RCBUF+4           PREPARE TO MOVE BITMAP
         CW,7     HGP+4,5
         BG       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,4     PRIVM3
SAV40    BAL,11   TYOUT             TYPE FIRST MESSAGE
         LH,4     8                 MOVE DCTX
         LD,10    DCT16,4           GET DEVICE MESSAGE
         SLD,10   8
         AI,11    X'15'             ADD CARRIAGE RETURN ON END
         LI,4     7                 TEXTC COUNT
         STB,4    10
         LCI      2
         STM,10   DEVADR
         LI,4     DEVADR
         BAL,11   TYOUT             TYPE DEVICE ADDRESS
         LD,2     AVRTBL+AVRTBLSIZ+AVRTBLSIZ-2,1
SAV42    LI,2     0
         AND,3    M16               REMOVE ENTRY TO PREVENT AUTO REMOUNT
         STD,2    AVRTBL+AVRTBLSIZ+AVRTBLSIZ-2,1
*
SAV25    BDR,R1   SAV22             DO THE REST
SAV30    PULL     R11
         B        *R11              RETURN
*
PRIVM2   TXTC     CR,'VTOC DOESN''T MATCH'
PRIVM3   TXTC     CR,'VTOC I/O ERROR ON'
DEVADR   RES      2
         SPACE    1
*O*  MESSAGE:      VTOC DOESN'T MATCH DPNDD
*O*
*O*  ACTION:       NONE
*O*
*O*  MEANING:      THE VTOC ON THE PRIVATE PACK IS EITHER DESTROYED,
*O*                OR THE SERIAL NUMBER DOESN'T MATCH THE AVR TABLES.
         SPACE    1
*O*  MESSAGE:      VTOC I/O ERROR ON DPNDD
*O*
*O*  ACTION:       NONE
*O*
*O*  MEANING:      HARDWARE I/O ERROR OCCURED WHILE READING OR
*O*                WRITING THE VTOC.  AN HGP RECON SHOULD BE
*O*                PERFORMED ON THE PACK BEFORE USING IT AGAIN.
         TITLE    '****  RELEASE GRANULES  ****'
*F*  NAME:         RRBG
*F*
*F*  PURPOSE:      SAVE PFA GRANULE FOR LATER RELEASE BY FIX
     SPACE         1
*F*  NAME:         RRSG
*F*
*F*  PURPOSE:      SAVE PER GRANULE FOR LATER RELEASE BY FIX
     SPACE         1
*D*  NAME:         RRBG
*D*
*D*  ENTRY:        RRSG
*D*
*D*  REGISTERS:    R15, R0-R7 SAVED
*D*
*D*  CALL:         BAL,R11
*D*
*D*  ENVIRONMENT:  MASTER, MAPPED OR UNMAPPED
*D*
*D*  INPUT:        R8 = DISC ADDRESS TO RELEASE
*D*
*D*  OUTPUT:       R8 = 0 IF BAD DISC ADDRESS
*D*
*D*  DESCRIPTION:  THE DISC ADDRESS IS VALIDATED VIA RCHKDA.
*D*                IF NOT CALLED FROM CLSFILS (CLSPRI=0) OR IF
*D*                DCB NOT PRIVATE, HGP IS LOCATED VIA R:FNDHGP.
*D*                IF PRIVATE, HGP ADDRESS IS IN DCB (SET BY
*D*                RCHKDA).  USING # GRAN/CYL, DISC ADDRESS IS
*D*                CHECKED FOR BEING ON GRANULE OR CYLINDER BOUNDARY
*D*                (IF NOT, EXIT).  IF PUBLIC, IT IS PUSHED INTO
*D*                RELSTAK.  IF PRIVATE, IT IS RELEASED INTO
*D*                APPROPRIATE IN-CORE HGP.
*
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      RRBG01            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
RRBG01   BAL,3    R:FNDHGP          LOCATE HGP FOR DISC ADDR IN R8
         BEZ      RELERX            NO MEANS BAD DA
RRBG02   EQU      %
         LW,3     3,7               #SEC/GRAN
         LW,2     1,7               FLAGS
         AND,R2   M8                # GRANULES/CYLINDER
         BNEZ     %+2
         LI,R2    1                 GRANULE ALLOCATED - MAKE IT RIGHT
         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
         LW,R11   FIL1,R6
         BGEZ     RRBG04            BR IF NOT PERMANENT FILE
         LI,R3    PRDPRM            ASSUME DISK GRANULE
         LI,R11   X'3F00'
         AND,R11  1,R7              DEVICE TYPE
         CI,R11   X'700'
         BNE      %+2               NOT RAD, MUST BE PACK
         LI,R3    PRDCRM            RAD
         AWM,R2   J:JIT,R3          UPDATE JIT ACCOUNTING CELLS
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
         PUSH     8,R3
RNCYL10  BAL,11   RRBG
         BEZ      RNBG20
         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
         PULL     8,R3
         B        RNBG20
*
RNBGTMP  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
*F*  NAME:         CLSFILS
*F*
*F*  PURPOSE:      CLOSE ALL DCBS FOR ONE USER
*F*
*F*  DESCRIPTION:  USER'S DCB NAME TABLE IS SEARCHED.  FOR EVERY
*F*                DCB, CLSFIL IS CALLED TO CLOSE IT.
     SPACE         1
*D*  NAME:         CLSFILS
*D*
*D*  REGISTERS:    ALL VOLATILE
*D*
*D*  CALL:         BAL,R11
*D*
*D*  ENVIRONMENT:  MASTER, MAPPED OR UNMAPPED
*D*
*D*  INPUT:        R6 = DCB ADDRESS
*D*
*D*  DESCRIPTION:  THE DCB NAME TABLE (POINTED TO BY J:DCBLINK)
*D*                IS SEARCHED.  FOR EACH DCB FOUND, CLSFIL IS
*D*                CALLED TO CLOSE IT.  EACH DCB ADDRESS IS
*D*                CHECKED FOR BEING WITHIN THE DCB AREA.
*D*                M:* (THE CFU AREA) IS CHECKED FOR AND BYPASSED.
*D*                BEFORE EACH CALL TO CLSFIL, CLSPRI IS SET
*D*                NON-ZERO TO ALLOW PRIVATE PACK DISC ADDRESSES.
*
         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
         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
         LW,R11   R1
         BAL,R2   DCBCHK            VALIDATE THE ADDRESS
         BCS,15   CLSERR            ERROR
         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
         LW,R11   R6
         SLS,R11  -9                PAGE ADDRESS
         BAL,R2   DCBCHK            VALIDATE THE ADDRESS
         BCS,15   CLSERR            ERROR
         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
*
DCBCHK   CLM,R11  J:DCBLL           MUST BE WITHIN DCB PAGES
         BCS,9    DCB4
DCB2     LCI      0                 OK
         B        0,R2
DCB4     CI,R11   JSBUF1VP          OR IN SPECIAL BUFFER 1
         BE       DCB2
         LCI      15                ERROR
         B        0,R2
*
TXTCFU   TEXTC    'M:*'
SDCBADR  DATA     0
CLSFLSX  RES      1
SAVPTR   RES      1
         TITLE    '****  CLSFIL  ****'
         SPACE    2
*D*  NAME:         CLSFIL
*D*
*D*  PURPOSE:      CLOSE ONE DCB
*D*
*D*  REGISTERS:    ALL VOLATILE
*D*
*D*  CALL:         BAL,R11
*D*
*D*  ENVIRONMENT:  MASTER MAPPED OR UNMAPPED
*D*
*D*  INPUT:        R6 = DCB ADDRESS
*D*                THE USER'S JIT MUST BE AT X'8C00', AND HIS
*D*                DCBS MUST BE PRESENT.  NO OTHER PARTS OF THE
*D*                USER ARE REQUIRED.
*D*
*D*  DESCRIPTION:  IF THE USER WAS IN THE WRTF INST ROUTINE, ANY
*D*                SPECIAL BUFFERS THAT WERE UPDATED ARE WRITTEN
*D*                OUT.
*D*
*D*                EXIT IF DCB CLOSED OR ASSIGNMENT NOT DISC FILE
*D*                OR LABELLED TAPE.
*D*                THE FPOOL BUFFERS ARE MAPPED IN.  IF LABELLED
*D*                TAPE, CLSLBL HANDLES THE REST OF THE CLOSE.
*D*                THE CFU ADDRESS IN DCB AND CFU ITSSELF ARE
*D*                VALIDATED.  THE USER COUNT IN CFU IS DECREMENTED.
*D*                IF DCB MODE IS INPUT, EXIT.
*D*                IF BUFF1 OR BUFF2 ARE UPDATED, WRITE THEM OUT.
*D*                IF FILE WAS BEING RELEASED, CONTINUE TO RELEASE IT.
*D*                IF OPENED OUT OR OUTIN, RELEASE THE FILE SINCE
*D*                A FILE DIRECTORY ENTRY HAS NOT YET BEEN MADE.
*D*                FOR UPDATE FILES, READ AND VERIFY THE FIT.  MOVE
*D*                INFO FROM CFU TO FIT AND WRITE IT OUT.  EXIT.
*
         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
         MTW,-1   J:BASE+8          DON'T COME HERE AGAIN
         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      %
*
         LI,R0    0
         LW,R1    Y002
         CW,R1    FCD,R6
         BAZ      *CLSFLX           DCB CLOSED, EXIT
         STS,R0   FCD,R6            RESET OPEN FLAG
*
         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   Y0002
         CW,R11   FUN,R6
         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    Y4
         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
         LI,R4    X'1FFFF'
         AND,R4   CFU,R6
         LI,R12   X'8000'
         CW,R12   0,R4
         BAZ      UPD20             NOT SHARED KEYED FILE
         LI,R5    X'FFFF'
         AND,R5   SCFU,R4
         LW,R2    SREC,R5           GRANULE COUNT CHANGE IN INPUT CFU
UPD20    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    FITCFU
         BE       ACNFIL
         BG       USRCFU
         CI,R1    FILCFU
         BE       ACNFIL
         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   Y4
         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,R9    Y0002
         CW,R9    FUN,R6
         BANZ     *CFURET           DON'T CHECK INPUT SHARED
         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  M8
         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 RANDOM FILE
         SPACE    2
RELRANDOM EQU     %
         LW,R8    FDA,R1
         AND,R8   M24
         BEZ      *CLSFLX           NOTHING TO DO
         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,R3   R:FNDHGP          GO FIND HGP
         BEZ      CLSERR
         LDCTX,R3 R8                DCTX
RRR0B    INT,R4   1,R7              GET DCTX, CYLSZ
         AND,R4   M8                DCT INDEX
         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,R4    ACNCFU+13         START OF ACCOUNT AREA
         AI,R4    -CFUSIZE+2        ADDRESS AFTER LAST VALID CFU
         LI,R1    BGRCFU-CFUSIZE
*
SCANLOOP AI,R1    CFUSIZE           POINT TO NEXT CFU
         CW,R1    R4
         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
*
*
         LW,R5    =X'06000002'      CODE WORD FOR PUBLIC FILE COPY
         STW,R5   FCODE
         CI,R3    X'4000'           RANDOM FILE
         BANZ     SCANLOOP          YES-SKIP
         CI,R3    X'400'            MODE=INOUT
         BAZ      SCANLOOP          NO-SKIP
         LW,R3    2,R1              ACCT/FNE
         LH,R5    R3                ACCT DW INDEX / DCTX FOR PRIV PACK
         AND,R3   =X'FFFF'          FILE NAME ADDRESS
         CI,R2    1                 PRIVATE VOLUME
         BANZ     PRIVATE           YES
         LD,R14   *ACNCFU+13,R5     ACCOUNT
SCAN1    EQU      %                 RETURN FROM PRIVATE PACK
         XW,R15   R14
         BAL,R11  SV1               FIRST WORD OF ACCT IN REC BUF
         XW,R15   R14
         BAL,R11  SV1               SECOND WORD OF ACCT IN REC BUF
         LB,R2    *R3               TEXTC COUNT
         AI,R2    1+3
         SLS,R2   -2                BOUND UP TO  WORD COUNT
         AWM,R2   FCODE             PUT WORD COUNT IN REC BUF CODE WORD
         LW,R15   *R3
         BAL,R11  SV1
         AI,R3    1
         BDR,R2   %-3               COPY FILE NAME TO REC BUF
         LW,R15   FCODE
         BAL,R11  SV1               PUT FILE COPY CODE WORD IN REC BUF
         B        SCANLOOP
*
*
PRIVATE  LW,R8    =DPADFDA          PRIVATE PACK ACCT DIR FDA
         STH,R5   R8                DCTX INTO SECTOR OF ACCT DIR
         LI,R15   256               SIZE OF ACCT DIR
         BAL,R11  RDDISK            GO-READ THE ACCT DIR
         B        SCANLOOP          ERROR- NEXT CFU
         LD,R14   AVRTBL,R5         SN OF PRIVATE PACK
         LW,R15   R14               SN OF PRIVATE PACK
         BEZ      SCANLOOP          NO SN PRESENT
         BAL,R11  SV1               INTO REC BUF
         LD,R14   RCBUF+4           ACCOUNT OF PRIVATE PACK
         LW,R5    =X'0C000003'      CODE WORD OF PRIVATE FILE COPY
         STW,R5   FCODE
         B        SCAN1             B/ INTO COMMON CODE
*
*
SCANEND  PULL     R11
         B        *R11
*
FCODE    DATA     0                 CODE WORD FOR FILE COPY
         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'
Y4       DATA     X'40000000'
Y004     DATA     X'00400000'
Y002     DATA     X'00200000'
Y001     DATA     X'00100000'
Y0008    DATA     X'00080000'
Y0002    DATA     X'00020000'
Y00FF    DATA     X'00FF0000'
Y00FE    DATA     X'00FE0000'
*
M24      DATA     X'00FFFFFF'
M16      DATA     X'FFFF'
M8       DATA     X'FF'
         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

