*M*      CLS      THE CLOSE FILE MODULE.
BITS     SET      1
MONPROC  SET      1
ANSPROC  SET      1
DISCBPROC SET     1
*
         SYSTEM   UTS
*
CLS:     EQU      %
         PCC      0
         SPACE    2
S:S      FNAME
         PROC
         PEND     AF(AF(1)+2)
         SPACE    3
*
*  RABAL COMMAND  (CONDITIONAL READ AHEAD BRANCH AND LINK)
*
*        BAL,CF(2) AF               BAL IF READ AHEAD INCLUDED
*        BCS,0     AF               NOP IF NO INCLUDED
*
RABAL    COM,1,7,1,1,1,1,3,17 ;
          AFA(1),X'69'+RAFLAG,;
          S:S((CF(2)&8)=0,RAFLAG),;
          S:S((CF(2)&4)=0,RAFLAG),;
          S:S((CF(2)&2)=0,RAFLAG),;
          S:S((CF(2)&1)=0,RAFLAG),;
           AF(2),AF(1)
         TITLE    '**** CLS ****'
         BOUND    8
K2       EQU      2
KD       EQU      X'D'
K0       EQU      X'0'
K1       EQU      X'1'
K8000    EQU      X'8000'
K1FFFF   EQU      X'1FFFF'
KN1      EQU      -X'1'
         SPACE    3
         OPEN     WXBUFSIZ,XBUFSIZ
WXBUFSIZ EQU      X'200'
XBUFSIZ  EQU      X'800'
FITSIZE  EQU      80
NWFITST  EQU      WXBUFSIZ-FITSIZE
XTRB     SET      0                 DON'T BUILD LVL 1 ON FLY
         PAGE
R0       EQU      0
R1       EQU      1
R2       EQU      2
R3       EQU      3
R4       EQU      4
R5       EQU      5
R6       EQU      6
R7       EQU      7
SR1      EQU      8
SR2      EQU      9
SR3      EQU      10
SR4      EQU      11
D1       EQU      12
D2       EQU      13
D3       EQU      14
D4       EQU      15
         SPACE    3
*P*      NAME:    CLS
*P*      PURPOSE  TO CLOSE FILE AND DEVICE  DCBS
         PAGE
*F*      NAME:    CLSSEG
*F*      PURPOSE  THE ENTRY TRANSFER VECTOR FOR THE CLOSE OVERLAY
*
*        DONT RUN CLOSE ON SLAVE CPU'S
*
         BLOCK                      GOTCHA...
         LW,1     0
         B        CLSV1,1
CLSV1    B        MSRCLSA           0    ENTRY FROM MONITOR-M:CLOSE
         B        REL               1
         B        MSRCLS            2    ENTRY FROM CALPROC
         B        DELFWD            3
         B        DELETE            4
         B        DELSET            5
         B        DELO              6
         B        DELAA             7
         B        BADA              8
         B        ERFILDAX          9    LOG ERROR IN ERRLOG
         B        CLSALL           10    CLOSE ALL USER DCBS
         SPACE    3
         DEF      CLS:              NAME FOR MODULE PATCHING
         DEF      FINDFIL1          FIND A NAME IN THE ACCT DRCTRY
         DEF      FNESCR            SET UP FOR FILE DRCTRY READ
         DEF      ERFILDAX          LOG 75 ERROR IN ERRLOG
         DEF      ALLODIR           ALLOCATE DIRECTORY GRANULES
         DEF      EPWRT1            INSERT NEW NAME IN FD
         SPACE    3
         REF      SL:EX             DEFAULT EXPIRATION INTERVAL
         REF      SL:MEX            DEFAULT EXPIRATION INTERVAL
         REF      J:JIT             JOB INFO TABLE
         REF      DELFWD            DELETE FORWARD
         REF      DELETE            PROCESS M:DELREC CALS
         REF      DELSET            RETURN FRM IORT FOR DELREC
         REF      DELO              RELEASE FILE DRCTRY ENTRY
         REF      DELAA             DELETE FILE OR ACCT NAME
         REF      ACNCFU            THE ACCOUNT CFU
         REF      CHKBIT1           PROCESS THE CAL'S FPT
         REF      CHKBIT            CHECK FOR FPT PRESENCE BIT
         REF      CHKBIT0           CHECK FOR FPT PRESENCE BIT
         REF      DATE              CURRENT DATE
         REF      DELF              RELEASE A FILE
         REF      GETDEV            GET DCT INDEX OR STREAM #
         REF      DOUBLEONE         DBLWD 1,1
         REF      DOUBLEZERO        DBLWD OF ZEROS
         REF      FILCFU            THE FILE CFU
         REF      GETASN            GET THE ASSIGNMENT FIELD
         REF      GETBBUF           GET A BUFF1.
         REF      GETBUFM           GET AN MI(BUFF2) BFR
         REF      GETCMD            GET POSN IN MI BFR
         REF      GETFUN            GET THE FUNCTION FIELD
         REF      GETTYC            GET THE TYPE OF COMPLETION
         REF      IOCHEK1           WAIT FOR I/O TO FINISH
         REF      INCREMENT%SECTOR  CHANGE DSK ADDR TO NXT GRAN
         REF      MSRWRTX           CAL EXIT PATH
         REF      MSR01EXIT         CAL ERROR EXIT PATH
         REF      PULLEXIT          NORMAL STACK RETURN
         REF      PULLEXIT1         SKIPPING STACK RETURN
         REF      PULLFOUR          GET NXT 4 BYTES FROM MI
         REF      PUNWEOF           WRITE !EOD ON PUNCH DEVICE.
         REF      PUSHALL           SET STACK MARKER
         REF      RAFLAG            READ AHEAD TOGGLE
         REF      READPVAD          READ PRIVATE FILE ACCOUNT DIRECTORY
         REF      REDSEC            READ MI NO LINK CHK
         REF      REL               RELEASE A FILE
         REF      SETCMD            SET MI POSN TO BEG OF GRAN
         REF      SETCMD1           SET MI POSN AS SPEC'D
         REF      SETEOPW           SET END OPN TO WRITE & MIUD
         REF      SETUPUB           FIND SPECIFIED DRCTRY ENTRY
         REF      CHKPAX            CHECK PRIVATE ACCT INDEX
         REF      WRTSEC            WRITE THE MI(BUFF2) BFR
         REF      CLRBFUB           WRITE OUT BUFF2 IF UPDATED
         REF      CLRBBUF           TRUNCATE DATA BLKNG BFR(BUFF1)
         REF      M:XX              DCB IN JIT
         REF      J:XP              DEFAULT EXPIRATION INFO
         REF      J:ASSIGN          DEFAULT READ NONE FLAG
         REF      JB:PRIV           USER'S PRIVLEGE LEVEL
         REF      J:FDDA            LOGON ACCT FD 1ST GRANULE
         REF      J:ACCN            LOGON ACCT NAME IN JIT
         REF      PRDCRM            PERM RAD REMAINING
         REF      YFF               BITS 0-7
         REF      Y06               BITS 5-6
         REF      Y00FE             BITS 8-14
         REF      Y00FF             BITS 8-15
         REF      OPNTPSEG          OVERLAY WITH OPEN TAPE
         REF      CLSTP#            OVERLAY WITH CLOSE TAPE
         REF      CLSLBL#           OLAY W/ CLOSE LABEL TAPE
         REF      ENTER1            NEW ENTRY IN DIRECTORY
         REF      RNBG              RELEASE N PUBLIC GRANS
         REF      DCT22             INDEX TO SYSGEN TBLS
         REF      DISCLIMS          # GRANULES ON A DEVICE BY TYPE
         REF      TB:FLGS           TYPE OF DEVICE
         REF      MAPBUFS           MAP BUFF1 & BUFF2
         REF      INSTCLNUP         CLEAN UP AFTER MI INSERTION
         REF      U:MISC            FOR SLEEP COUNT
         REF      E:SL              SLEEP CODE FOR SCHEDULER
         REF      75BUF             USER # FOR 75 ERROR
         REF      75TABLE           LIFO BFR FOR 75 DSK ADDRS
         REF      LFGUN             USER # OF THE FIX GHOST
         REF      E:CBK             BREAK EVENT FLAG
         REF      T:RUE             REPORT USER EVENT
         REF      T:SBUF            SWITCH A DCB POOL BUFFER
         REF      UB:OV             OVERLAY TABLE
         REF      ERRLOG            WRITE ERROR LOG ROUTINE
         REF      FNDKY             FIND A DRCTRY ENTRY
         REF      IOSPIN            RUNDOWN THE I/O ON A DCB
         REF      E:OCR             OPN CLS USR REQUEST EVENT
         REF      T:REG             REPORT EVENT & GIVEUP
         REF      CLSVNO            CLOSES PRIVATE VOLUMES
         REF      FMCHKDA           VERIFY VALIDITY OF DISK ADDRESS
         REF      FNDHGP            FIND HEAD OF GRAN POOL
         REF      PRIVDCB           TEST DCB FOR PRIVATE
         REF      SETVNO            SET PRIV VOLUME #
         REF      GBG               ALLOCATE PFA GRANULE
         REF      GCYL              ALLOCATE PFA CYLINDER
         REF      GSBP              ALLOCATE PFA SEPARATED PAIR
         REF      RMAOVSEG          SEG # FOR DIAGNOSTIC DCB CODE
         REF      T:CLOSIT#         ENTRY # FOR M:DCLOSE
         REF      C:CFU             # OPEN CFUS
         REF      DCT4              DEVICE TYPE
         REF      DCT9              DIAGNOSTIC OPEN FLAGS
         REF      RNCYL             RELEASE N PUBLIC CYLINDERS
         REF      RNPVCYL           RELEASE N PRIV CYLINDERS
         REF      SETPVI            SET PRIV VOL INDICATORS
         REF      SAVBLK            SET BLK FIELD IN DCB
         REF      BLANK             TEXT OF 4 BLANKS
         REF      Y006              BITS 9 & 10
         REF      TRUNC             TRUNCATE BFRS FROM DCB
         REF      Y0014             BITS 11 & 13
         REF      J:STAR            FIT DSK ADDRS FOR * FILES
         REF      REDSECL           READ MI WITH LINK CHK
         REF      ACNTBL            TBL OF ACCT DRCTRY GRANS
         REF      S:CUN             CURRENT USER #
         REF      OPNCLSUS          OPEN CLOSE USER #
         REF      CHKANS1           CHK FOR ANS TAPE DCB
         REF      J:CLS             READ ERROR CONTROL IN JIT
         REF      DCTSIZ            SIZE OF DCT TABLES
         REF      MULSEG            OVERLAY WITH MUL MODULE
         SREF     T:RAPURGD         PURGE READ AHEAD
         REF      TXTCFU            NAME OF M:* DCB
         REF      J:DCBLINK         POINTER TO DCBS FROM JIT
         REF      Y03               BITS 6&7
         REF      BGRCFU            START OF USER CFU AREA
         REF      T:UBLKOCU         GIVE UP OPN CLS USER STATE
         REF      UH:FLG            USER FLAGS
         REF      UH:FLG2           MORE USER FLAGS
         REF      DCT%MASK%1        SELECT SUBFIELD FROM DCT
         REF      GZQUS             CHK 4 GRANULE CLEANING
         REF      GZAPCFU           CLEANING FIELD IN CFU
         REF      GZAPBIT           CLEANING BIT IN CFU
         REF      GZREEX            REEXECUTE CAL EXIT
         REF      GETDGRAN          GET A GRANULE
         REF      NB31TO0           TBL OF SINGLE RESET BITS
         REF      YFFFF             BITS 0-15
         REF      OPNSEG            OVERLAY WITH OPNF MODULE
         REF      J:USCDX
         REF      UB:APR            ASSOCIATED SHARED PROCESSOR LIST
         REF      P:NAME            LIST OF SHARED PROCESSR NAMES
         REF      TIME              TIME OF DAY
         REF      DUMPFILE          SUA DUMP FILE CONTROL INFO
         REF      XA
         REF      J:BASE            TEMP STORAGE
         REF      ALLODIRA          FILE DIR CYL REMNANTS
         REF      NODUAL            ZERO IF NO DUALS ARE WANTED
         REF      YC                BITS 0,1
         REF      SYSID             JIT OFFSET
         REF      CLSROOT           TFILE FOR JOB FILES
         DO1      XTRB
         REF      XTRAGRAN          UNUSED GRANULE FOR MULTI-LEVELS
*
DESC     EQU      17                DESCRIPTORS IN DCB
NOACUP   EQU      5                 DCB WD 5,BIT 5
SHARE    EQU      7
*
DIGRAN   EQU      ACNCFU+9
SYNFLAG  EQU      J:BASE+4
DDA      EQU      X'1FD'
*
MASKCLS  DATA     X'60BC00'
TWRD     GEN,16,16   MIDIS,X'4020'
Y00FC    DATA     X'00FC0000'
         BOUND    8
DAYCHK   DATA     X'40F0F0F0',X'FFF0F0F0'
HOURCHK  DATA     X'F0F04040',X'F0F0FFFF'
         SPACE    3
XF0F0    DATA     X'F0F0'
V24      DATA     24
ALL      TEXT     'ALL '
NONE     DATA     C'NONE'
         TEXT     '    '
BLANKS   EQU      BLANK
Y008F    DATA     X'008F0000'
Y018     DATA     X'01800000'
NEVER    TEXT     'NEVER'
CYLFLG   EQU      FILCFU+FILDISP+6
FITCFU   EQU      FILCFU+4          FITCFU+CDAM = FILCFU+SREC
         OPEN     TCFU
TCFU     EQU      13
*
         PAGE
LOCCODEC LI,D1    9
*D*      NAME:    LOCCODEB
*D*      ENTRY    LOCCODEA
*D*      REGISTERS  R3,R7, & D2 ARE VOLATILE
*D*      CALL     R5 IS THE LINK, SKIPPING EXIT TAKEN IF CODE
*D*               FOUND.
*D*      ENVIRONMENT  MAPPED MASTER
*D*      INPUT    SEARCH CODE IN D1
*D*      OUTPUT   D2 HAS VLP ENTRY CTL WD IF FOUND
*D*               R3 POINTS TO 1ST WORD OF ENTRY
*D*      DESCRIPTION  TO FIND AN ENTRY IN A VLP, LOCCODEB USED FOR
*D*               FIT SEARCH, LOCCODEA USED FOR DCB SEARCH.
*  TO LOCATE AN ENTRY IN THE FILE'S FIT.
LOCCODEB LI,R7    BUFF2+WFNEMAX+5
         LW,3     BUFF2+NAVX
         CI,R3    X'8000'
         BAZ      LOCCODEA+1
         AI,R7    NWFITST-4
         CI,3     X'4000'
         BANZ     LOCCODEA+1
         AI,R7    -(WXBUFSIZ/2)
         B        LOCCODEA+1
LOCCODEA EQU      %
*  TO LOCATE AN ENTRY IN THE VLP OF THE DCB.
         LW,R7    FLP,R6
*                                   ENTRY POINT IF CURRENT SIZE OF
*                                   ZERO IS TO REPRESENT NO CODE
         LI,R3    K0
LOCCODE1 LW,D2   *R7,R3
         AI,R3    K1
         CB,D1    D2
         BE       LOCCODE2
         CI,D2    X'10000'          CHECK FOR END
         BANZ     BIR5
         AND,D2   M8
         AW,R3    D2
         B        LOCCODE1
LOCCODE2 RES      0
         LI,R1    K2
         LB,R1    D2,R1             CURRENT SIZE
         BNEZ     1,R5
         B        0,R5              ZERO - DIDN'T FIND
*                                   PARAMETER
*                                   R7 = ADDR OF LIST
*                                   D1 = CODE DESIRED
         SPACE    2
SETACD   LI,D1    2                 FIND NAME AND ACCOUNT VLPS
         LI,R2    HAACD
SETACD2  BAL,R5   LOCCODEA
         NOP
         STH,R3   *R6,R2
         AI,R2    HAFLD-HAACD
         BDR,D1   SETACD2
         B        *R0
         PAGE
*                DATE MANIPULATING SUBROUTINES
         SPACE    3
DECTOBIN EQU      %
*D*      NAME:    DECTOBIN
*D*      DESCRIPTION
*DO*
*D*
*                CONVERTS THE EBCDIC DECIMAL NUMBER IN SR3 TO A BINARY
*                NUMBER IN SR4. USES R0 FOR LINK AND D4 FOR WORK.
*                CONVERSION STOPS AFTER 4 DIGITS OR WHEN NEXT BYTE
*                 =X'00'
*FIN*
*
         LI,SR4   0
DECTOBIN1 EQU    %
         LB,D4    SR3               GET NEXT INPUT DIGIT
         BEZ      BIR5
*                MULTIPLY SUM BY 10 AND ADD NEXT DIGIT
         MI,SR4   10
         AND,D4   M4
         AW,SR4   D4
         SLS,SR3  8                 POSITION NEXT DIGIT
         B        DECTOBIN1
         SPACE    5
COMPDAT  EQU      %
*D*      NAME:    COMPDAT
*D*      DESCRIPTION
*DO*
*D*
*                COMPARES 2 DATES AND RETURNS NORMALLY IF 'A' ISLATER
*                THAN 'B', OR RETURNS SKIPPING IF 'A' IS EQUAL TO OR
*           EARLIER THAN 'B'. DATES ARE IN EBCDIC,TWO WORDS AS FOLLOWS:
*                  WD 0 M M D D
*                  WD 1 H H Y Y
*                 WHERE: EACH FIELD IS 2 EBCDIC DIGITS:
*                  MM MONTH
*                  DD DAY
*                  HH HOUR
*                  YY YEAR
*                SR1= ADDRESS OF DATE 'A'
*                R2 = ADDRESS OF DATE 'B'
*                BAL,R0 COMPDAT
*FIN*
*
         PUSH     4,D1
         LCI      2
*                FETCH AND FORMAT BOTH DATES
         LM,D1    *SR1
         LM,D3    0,R2
         SCD,D1   -16               REARRANGE TO YY,MM,DD,HH
         SCD,D3   -16               DITTO 'B'
         CD,D1    D3                BOTH APPEAR NEGATIVE SO BRANCH LOCIC
         BG       %+2
         AI,R5    1                 A LS/EQ B
         PULL     4,D1
BIR5     B        0,R5
         SPACE    5
ADDATBIN EQU      %
*            SAME AS ADDATBCD EXCEPT INCREMENT IS BINARY HOURS IN D1
*
         PUSH 16,R0
         CI,D1    X'C000'
         BG       ADDATSPE          SPECIFIC DATE FORM
         SAD,D1   -32
         DW,D1     V24
         B        ADDATBDH
*D*      NAME:    ADDATSPE
*D*      DESCRIPTION
*DO*
*D*
*                       SPECIFIC DATE FORM --SET DATE INSTEAD OF
*                          DOING INCREMENT
*                                     FORMAT OF HALF WORD IS:
*                                   11MMMMDDDDDYYYYY
*
*                                    WHERE MMMM=MONTH
*                                          DDDDD=DAY
*                                          YYYYY=YEAR-70
*                                            (EG, 3 IS 1973)
*                                      ALL AS BINARY NUMBERS.
*FIN*
ADDATSPE EQU      %
         AND,D1   M14               CLEAR HIGH ORDER ONES
         LI,R3    3                 3 FIELDS TO CONVERT
ADDATSPE1 EQU     %
         LI,R1    X'1F'             MASK FIELD
         AND,R1   D1
         EXU      STDAT-1,R3
         SLS,D1   -5
         BDR,R3   ADDATSPE1
         LI,R1    70
         AWM,R1   1,R2              ADD BIAS TO YEAR
         B        ADDAT4E1          GO CONVERT BACK TO BCD
STDAT    STH,R1   *R2
         STW,R1   0,R2
         STW,R1   1,R2
*
*D*      NAME:    ADDATVER
*D*      DESCRIPTION
*DO*
*D*
ADDATVER EQU      %
*            CHECKS FORMAT OF INCREMENT FOR BLANK,DIGIT,DIGIT,DIGIT
*            IN WORD 0 AND DIGIT,DIGIT,BLANK,BLANK IN WORD 1
*             RETURNS TO BAL+1 IF FORMAT ERROR, OTHERWISE,
*             PROCEEDS TO ADDATBCD FOR RETURN TO BAL+2
*            R1=INCREMENT ADDRESS,R2=DATE ADDR DESTROYS SR3,SR4
*FIN*
*
         LD,SR3   DAYCHK            DAY MUST BE BLANK & 3 DIGITS
         CS,SR3   0,R1
         BNE      BIR5
         LD,SR3   HOURCHK           HOUR MUST BE 2 DIGITS & 2 BLANKS
         CS,SR3   1,R1
         BNE      BIR5
         AI,R5    1   FORMAT OK, KICK RETURN
*
*              ADD DATES-EBCDIC DAYS/HOURS
*              R1=ADDRESS OF INCREMENT
*                WD 0 - D D D
*                WD 1 H H - -
*              R2=ADDRESS OF DATE
*                WD 0 M M D D
*                WD 1 H H Y Y
*              DATE IS UPDATED BY NUMBER OF HOURS AND DAYS IN INCREMENT
*
         PUSH   16,R0
*                CONVERT INCREMENT TO FORM FOR ADDATBDH
         LW,SR3   0,R1              DAYS
         BAL,R5   DECTOBIN
         LW,D2    SR4
         LI,SR3   X'F0000'
         AND,SR3  1,R1              HOURS
         BAL,R5   DECTOBIN
         LW,D1    SR4
*
ADDATBDH EQU      %                 ADD DATES-BINARY DAYS/HOURS
*                D1=BINARY HOURS
*                D2=BINARY DAYS
*
*                CONVERT DATE TO BINARY
         LI,R1    3
ADDAT4A  EQU      %
         LH,SR3   *R2,R1
         SLS,SR3  16                2 DIGITS
         BAL,R5   DECTOBIN  CVTS EBCDIC SR3 TO BINARY
         STH,SR4  *R2,R1
         AI,R1    -1
         BGEZ     ADDAT4A           CONVERT ALL 4 FIELDS
*                ADD HOURS FIELDS WITH CARRY TO DAYS
         LW,D4    1,R2
         AH,D1    D4
ADDAT4A1 EQU      %
         STH,D1   D4
         AI,D1    -24
         BL       ADDAT4A2
         MTW,1    0,R2              +1 DAY
         B        ADDAT4A1
ADDAT4A2 EQU      %
         STW,D4   1,R2
*                ADD DAYS AND ADJUST FOR MONTHS
         AW,D2    0,R2
         LH,R1    D2                MONTH
         BEZ      ADDAT4D           MONTH = 0
         AND,D2   M16
ADDAT4C  EQU      %
*                CHECK MONTH OVERFLOW
         CI,R1    12
         BLE      ADDAT4C1          MONTH OK, CHECK DAYS AGAIN
         AI,R1    -12               RESETS TO JAN
         MTW,1    1,R2              KICK YEAR
         B        ADDAT4C
ADDAT4C1 EQU      %
         LB,D4    ADDATMON,R1       DAYS/MONTH
         CW,D2    D4
         BLE      ADDAT4D           MONTH NOT CHANGED
         CI,R1    2                 FEBRUARY TEST
         BNE      ADDAT4B
*                OH HELL-ITS FEBRUARY--CHECK LEAP YEAR
         LW,SR3   1,R2
         CI,SR3   3
         BANZ     ADDAT4B
*                ITS LEAP YEAR
         CI,D2    29
         BLE      ADDAT4D           ITS EXACTLY FEB 29-OUT
         AI,D2    -1                REDUCE DAYS FOR NUMBER 29
ADDAT4B  EQU      %
         LB,SR3   ADDATMON,R1       REDUCE DAYS BY
         SW,D2    SR3                # IN MONTH
         AI,R1    1                 INCREMENT MONTH
         B        ADDAT4C
*                PUT MONTH & DAY BACK
ADDAT4D  EQU      %
         STH,R1   D2                MONTH BACK INTO WORD
         STW,D2   0,R2
*                CONVERT OUTPUT BACK INTO EBCDIC
ADDAT4E1 EQU      %
         LI,R1    3
ADDAT4E  EQU      %
         LH,SR3   *R2,R1
         SAD,SR3  -32
         DW,SR3   XA
         SLS,SR3  24
         SCD,SR3  8
         OR,SR4   XF0F0             MAKE EBCDIC
         STH,SR4  *R2,R1
         AI,R1    -1
         BGEZ     ADDAT4E
*
PL16BIR0 RES      0
         PULL     16,R0
         B        0,R5
         SPACE 3
ADDATMON EQU    %
*                NUMBER OF DAYS PER MONTH, INDEXED BY THE MONTH 1-12
         DATA,1   0,31,28,31,30,31,30,31,31,30,31,30,31,0
         BOUND    4
         SPACE    5
SETFIDATE EQU     %
*D*      NAME:    SETFIDATE
*D*      DESCRIPTION
*DO*
*D*
*                SET DATE VLP IN FIT
*                  D1=VLP TYPE CODE
*                  SR3=WD0 TO SET
*                  SR4=WD1 TO SET
*            D2=WD2 TO SET IF MODIFICATION DATE
*                  BAL,R0 SETFIDATE
*FIN*
         LW,R2    D2
         BAL,R5   LOCCODEB
         B        CHK0NDW           SEE IF IT WAS THERE BUT
*                                    WITH NDW SET TO 0.
SETFID1  AW,R7    R3                POINT TO FIRST VLP DATA WORD
         LI,R5    0                 ASSUME MIUD NOT TO BE SET
         XW,SR3   0,R7              PUT IN FIRST TWO WORDS
         XW,SR4   1,R7
         LI,R3    -2
         CW,SR3   0,R7              IS FIRST WORD SAME
         BE       %+2
         LW,R5    Y002              NO - SET UPDATED BIT
         CW,SR4   1,R7
         BE       %+2
         LW,R5    Y002
         LI,SR3   2                 ASSUME 2 WORD VLP
         CI,D1    X'A'
         BNE      SETFID5           CORRECT
         LI,SR3   3                 3 WORD VLP
         CW,R2    2,R7
         STW,R2   2,R7
         BE       SETFID5           NO CHANGE HERE
         LW,R5    Y002              TO SET MIUD
SETFID5  CB,SR3   *R7,R3            CHECK # ACTIVE WORDS
         STB,SR3  *R7,R3
         BE       %+2               THE SAME
SETUD    LW,R5    Y002              MAKE IT UPDATED
         STS,R5   MIUD,R6           SET BUFF2 UPDATED ONLY IF A CHANGE
         B        *R0
*
CHK0NDW  AI,R1    0
         BNEZ     *R0               VLP WAS REALLY NOT THERE.
         B        SETFID1           WAS THERE BUT EMPTY.
         SPACE    5
DOEXPDAT  EQU     %
*D*      NAME:    DOEXPDAT
*D*      DESCRIPTION
*DO*
*D*
*             SETS EXPIRATION DATE
*        A IF A DCB:VLP IS PRESENT AND HAS 2 DATAWORDS AND IS LS/EQ
*            CURRENT DATE+MAX. EXPIRATION, FIT SET F/DCB:VLP
*        B IF 'A' EXCEPT DCB:VLP EXCEEDS MAX. EXP. PERIOD, OR
*            (2) IS OUT/OUTIN AND NO DCB*VLP, FIT SET =
*                USER DEFAULT+CURRENT DATE
*        C IF 'B' EXCEPT NO USER DEFAULT, FIT SET =
*            SYSTEM DEFAULT(14 DAYS)+CURRENT DATE
*        D OTHERWISE, IF INOUT & EXPIRATION HAS PASSED, FIT SET=
*            CURRENT DATE + 1 HOUR
*
*        R0=RETURN ADDRESS   ALL REGS SAVED
*FIN*
*
         PUSH     16,R0
         LI,D1    4                 EXP DATE VLP
         BAL,SR1  GETDATD           FETCH DATE FROM DCB
         B        DOEXPINCHK        NO VALID DCB:VLP
         PUSH     2,SR3           SAVE DCB:VLP IN STACK
*                CHECK IF DATE IS INCREMENT FORM AND CONVERT IF SO
         BAL,R5   DOSUB
         LI,R1    -2                DCB:VLP 2 WORDS BEFORE CURRENT
         AW,R1    R2
*                ALL SETUP...NOW ATTEMPT ADD
         BAL,R5   ADDATVER
         B        DOEXPDAT1         NOT INCREMENT FORM
         PULL     4,SR1             MOVE INCREMENTED DATE TO 1ST
         PUSH     4,SR3
DOEXPDAT1 EQU     %
         BAL,R5   PL2SR3
*                CHECK LEGALITY OF DATE
DOEXPDAT2 EQU     %
         LW,D1    J:XP
         AND,D1   M16
         BNEZ     %+2               ZERO IS NONE SO USE SYSTEM MAX
         LI,D1    SL:MEX            SYSTEM DEFAULT MAX EXP PERIOD
         CI,D1    X'FFFF'        MAX=NEVER
         BE       DOEXPSET          NO LIMIT SO ACCEPT
         BAL,R5   DOSUB
         BAL,R5   ADDATBIN  ADD INCREMENT TO CURRENT DATE
         LI,SR1   -2
         AW,SR1   R2                ADDRESS OF SAVED DCB:DATE
         BAL,R5   COMPDAT
         B        DOEXPDEFH         DCB:DATE LATER THAN MAX.
*                DATE IS WITHIN LIMITS SET INTO FIT
         BAL,R5   PL2SR3
DOEXPSET EQU      %
         BAL,R5   PL2SR3
DOEXPSETA LI,D1   4
         BAL,R0   SETFIDATE
DOEXPEXIT EQU     %
         B        PL16BIR0
*
DOEXPINCHK EQU    %                 NO DCB:VLP-CHECK FOR INOUT
         BAL,D2   GETFUN
         CI,D1    4
         BE       DOEXPIN           DO CASE 'D' FOR INOUT
         B        DOEXPDEF          SET DEFAULT FOR OUT/OUTIN
DOEXPDEFH EQU     %                 HSKP STACK, THEN SET MAX
         PULL     4,SR1
         B        DOEXPSETA
DOEXPDEF EQU      %
         LH,D1    J:XP              DEFAULT IN HOURS  CASE 'B2'
         BNEZ     %+2               NO DEFAULT FOR THIS USER
         LI,D1    SL:EX             SYSTEM DEFAULT   CASE'C2'
         AND,D1   M16
         CW,D1    M16
         BNE      DOEXPDEF1
         LW,SR3   NEVER
         LW,SR4   NEVER+1
         B        DOEXPSETA
DOEXPDEF1 EQU     %
         BAL,R5   DOSUB
DOEXPINC EQU      %
         BAL,R5   ADDATBIN
         B        DOEXPDAT2
DOEXPIN  EQU      %         CASE 'D'...NO VLP,INOUT--CHK EXPIRED
         BAL,R5   LOCCODEB          FIND FIT EXP DATE
         B        DOEXPEXIT
         AW,R3    R7
         BAL,R5   DOSUB
         LW,SR1   R3                FIT IS 'A' DATE
         BAL,R5   COMPDAT
         B        DOPULL2X          'A' GR 'B'
*                PAST EXPIRATION, RESET TO CURRENT + 1 HOUR
         LI,D1    1                 INCREMENT - 1 HOUR
         B        DOEXPINC
DOPULL2X EQU      %                 HSKP STACK AND EXIT
         LI,R5    PL16BIR0
PL2SR3   RES      0
         PULL     2,SR3
         B        0,R5
         SPACE    3
DOSUB    BAL,SR1  DTTMSET
         PUSH     2,SR3
         LI,2     -1
         AW,2     TSTACK
         B        0,R5
         PAGE
GETDATD  EQU      %                 FORCED DCB REFERENCE
*D*      NAME:    GETDATD
*D*      DESCRIPTION
*DO*
*D*
*        FETCHES UP TO THREE WORDS OF DATA FROM A VLP
*        D1=VLP CODE
*        R7=START OF VLP LIST
*        BAL,SR1  GETDAT
*        RETURNS R1= -1   NO VLP FOUND
*                    0  VLP HAD NO DATA WORDS
*                    BITS 0-3 CONTAIN NUMBER OF DATA WORDS RETURNED
*                 SR3-D1= DATA WORDS OR EBCDIC BLANKS
*            BUT NOT MORE THAN 3 WORDS--A DATE VLP
*        RETURN IS SKIPPING IF VLP IS FOUND AND CONTAINS DATA
*FIN*
*
         LI,R1    -1                INITIALIZE NBR WDS NOT 0
         BAL,R5   LOCCODEA
         B        *SR1              R1=-1;NO VLP  =0;NO DATA
         LW,SR4   BLANKS            INITIALIZE TO BLANKS
         LW,D1    BLANKS
         SCS,R1   -4                NBR WDS SET IN R1 BY LOCCODEA
         LC       R1
         BCS,12   BISR1
         LM,SR3   *R7,R3
         AI,SR1     1
BISR1    RES      0
         B        *SR1
         PAGE
         SPACE    5
*
*D*      NAME:    SETDATE
*D*      DESCRIPTION
*DO*
*D*
*        ROUTINE TO BUILD AND SET A DATE VLP IN THE FIT
*        ENTRY IS SET FROM THE DCB:VLP IF PRESENT AND HAS AT LEAST
*        2 DATA WORDS, OTHERWISE IS SET FROMCURRENT DATE/TIME
*           D1 = VLP CODE TO BE GENERATED
*           D3 = FIT ADDRESS
*           R2 = CURRENT FIT WORD INDEX
*           R0 = RETURN ADDRESS
*           D2 = NUMBER OF DATA WORDS TO ALLOCATE
*        SETDAT3  SETS D2 = 3
*        SETDAT2  SETS D2 = 2
*        DESTROYS R1,R3,SR1-D2
*        UPDATES R2 TO POINT TO NEXT AVAILABLE WORD IN FIT
*FIN*
SETDAT2  EQU     %
         LI,D2    2
SETDATE  EQU      %
         PUSH     R0
         PUSH     2,D1
         BAL,SR1  GETDATD           FIND DCB:VLP IF WITH DATA
         B        SETDATN           NONE OR NO DATA--USE CURRENT
         SCS,R1   4                 RJ NUMBER OF DATA WORDS
SETDATR  EQU      %
*                BUILD ENTRY AND STORE DATA IN IT
         PULL     R0                NAW (F/D2)
         LW,R7    TSTACK            WILL BE ADDR OF DATA IN STACK
         PULL     D2                CODE (F/D1)
         PUSH     3,SR3             DATA FROM GETDATD OR DTTMSET
         LW,D1    D2
         LI,R3    0
         BAL,SR1  SETENT            GO SET ENTRY
         PULL     3,SR3            HSKP STACK
         LW,R7    FLP,R6            RESTORE R7
         AI,SR3   0                 NO DATA WDS
         BNE      PULLEXIT
         LI,R3    -3
         AW,R3    R2
         LI,SR3   X'F00FF'
         AND,SR3  *D3,R3
         STW,SR3  *D3,R3
         B        PULLEXIT
*
SETDATN  EQU      %                 GET CURRENT DATE
         CI,D1    X'10'             IF BACKUP & NO DA,SET NULL VLP
         BNE      SETDATT
         LI,SR3   0
         B        SETDATR
SETDATT  EQU      %
         BAL,SR1  DTTMSET
         LW,D1    TIME              THIRD WORD FOR CREATION
         LW,R1    *TSTACK           NUMBER OF WORDS TO USE
         B        SETDATR
         PAGE
*D*  NAME:         BLDESC
*D*
*D*  REGISTERS:    ALL VOLATILE
*D*
*D*  CALL:         BAL,R0
*D*
*D*  DESCRIPTION:  EXIT IF PRIVATE PACK FILE (THEY HAVE NO
*D*                DESCRIPTORS).  IF FILE IS SYNONYMOUS, SET
*D*                J:BASE SO LC RETURNS BANZ, ELSE BAZ.
*D*                RESET DCB:DESC BYTES 1-3.  IF NO X'11'
*D*                VLP IN DCB AND FUNCTION IS OUT, OUTIN OR
*D*                INOUT WITH NO WRITES, EXIT.  OTHERWISE,
*D*                USE ZEROS FOR DESCRIPTORS.  IF X'11' VLP
*D*                IS IN DCB AND Y008 BIT IN DATA WORD IS SET,
*D*                USE USER SPECIFIED DESCRIPTORS.  STORE BYTE 1
*D*                OF DESCRIPTORS IN BYTE 1 OF DCB:DESC
*D*                (IF DEFAULT DESCRIPTORS, SET IN X'8F').
*D*                IF USER SET X'100' IN DESCRIPTOR, STORE USER'S
*D*                X'C00' BITS IN DCB:DESC.  ALSO STORE USER'S
*D*                X'200' BIT IF GHOST OR IF PRIV >= X'A0'.
*D*                ALSO SET:
*D*                  X'8000'        PASSWORD PRESENT
*D*                  X'4000'        SYNONYMOUS FILE
*D*                  X'2000'        RANDOM
*D*                BYTES 1 AND 2 WILL BE PLACED IN THE FILE DIRECTORY
*D*                AS THE STATIC AND DYNAMIC DESCRIPTORS, RESPECTIVELY.
*
BLDESC   PUSH     R0
         LI,R0    X'800'
         CW,R0    PRIV,R6
         BANZ     PULLEXIT
         PUSH      D1
         LW,SR1   DESC,R6           CLR DESC IN DCB
         CI,SR1   1                 HAVE WE ALREADY DONE IT?
         BANZ     BLDESC5           YUP, GET OUT
         CW,SR1   Y006              IS IT SYNON
         STCF     SYNFLAG           BANZ IF SYNON
         AND,SR1  YFF
         AI,SR1   1                 SHOW WE HAVE DONE IT
         STW,SR1  DESC,R6
*                 GET USERS DESCRIPTORS IF PRESENT
         LI,D1    X'11'
         BAL,R5   LOCCODEA
         B        BLDESC2A         NO USER DCB:VLP-CHK MODE
*                 DO DYNAMIC DESCRIPTORS
         LW,SR1   *R7,R3
         CW,SR1   Y008
         BANZ     %+2
BLDESC1  EQU      %
         OR,SR1   Y008F             NOT SET SO USE DEFAULT
         LW,SR2   Y00FF
         STS,SR1  DESC,R6
*                 DO STATIC DESCRIPTORS
         CI,SR1   X'100'
         BAZ      BLDESC4           NONE TO SET FROM DCB:VLP
         LI,SR2   X'C00'
         STS,SR1    DESC,R6         SET 'NO ACCESS UPDATE'&'NO BACKUP'
*                 PROCESS BIT 6 IF GHOST OR PRIV=A0
         LC       J:JIT
         BCS,4    BLDESC3           IT'S A GHOST
         LI,R3    BA(JB:PRIV)
         LB,R3    0,R3
         CI,R3    X'A0'
         BL       BLDESC4           NEITHER GHOST NOR PRIV=A0
BLDESC3  EQU      %
         LI,SR2   X'200'
         STS,SR1  DESC,R6           SET 'NO BACKUP'&'NO PURGE'
*                 NOW DO FILE CHARACTERISTICS
BLDESC4  EQU      %
*                 CHECK FOR PASSWORD
         LI,D1    3
         BAL,R5   LOCCODEA
         B        %+3             NO PASSWORD
         LI,SR2   X'8000'
         STS,SR2  DESC,R6           SET 'PASSWORDED' DESC
*                 CHECK RANDOM
         LI,SR2   X'30'
         CS,SR2   ORG,R6
         BNE      %+3               NOT RANDOM
         LI,SR2   X'2000'
         STS,SR2  DESC,R6           SET 'RANDOM' DESC
*                 CHECK SYNON
         LC       SYNFLAG
         BAZ      %+3               NOT SYNON
         LI,SR2   X'4000'
         STS,SR2  DESC,R6           SET 'SYNON' DESC
BLDESC5  EQU      %
         PULL     D1
         B        PULLEXIT
BLDESC2A EQU      BLDESC1
         PAGE
*D*      NAME:    FINDFILINT
*D*      ENTRY    FINDFILS
*D*      REGISTERS  ALL BUT R6 VOLATILE
*D*      CALL     R0 IS THE LINK, SKIPPING EXIT IF FOUND
*D*      DESCRIPTION  FIND AND READ THE FIT OF A SPECIFIED
*D*               FILE, INT ENTRY USES CFU NAME, S ENTRY
*D*               USES DCB NAME
FINDFILINT  EQU   %
         LW,R3    TCFU,R6
         INT,R3   2,R3
FINDFILI EQU      %
*
         PUSH     1,R0
         LI,0     X'40000'
         CW,0     NXTA,R6
         BAZ      FIND1             NOT * FILE
         LW,R3    CFU,R6
         LW,R0    2,R3              FILE NAME
         LI,3     NSTARF
         CB,0     STARTBL,3
         BE       %+3               FOUND IT
         BDR,3    %-2
         B        PULLEXIT          NOT FOUND
         LB,3     STRTBL,3          *FILE INDEX
         LI,D1    CL1A1             CHK FOR RELEASE
         SW,D1    *TSTACK
         BEZ      6B23              GET OUT IF RELEASE
         LW,R1    CFU,R6
         LW,D1    FDA,R1
         XW,D1    J:STAR,R3         FIT DISC ADDRESS
         BEZ      PULLEXIT          DOESN'T EXIST
         LI,D2    X'100'
         STS,D2   J:CLS             DON'T CHK SCR
         LI,D2    0                 LINK CHECK
         BAL,R0   REDSECL
         B        PULLEXIT1
*
6B23     STW,D1   J:STAR,R3
         B        PULLEXIT          TREAT AS NOT FOUND
*
STARTBL  DATA,1   0
         DATA,1   'B'
         DATA,1   'D'
         DATA,1   'G'
         DATA,1   'L'
         DATA,1   'T'
         DATA,1   'N'  FOR LNKTRC USE ONLY
NSTARF   EQU      BA(%)-BA(STARTBL)-1
         BOUND    4
STRTBL   DATA,1   0
         DATA,1   0 B
         DATA,1   1 D
         DATA,1   2 G
         DATA,1   3 L
         DATA,1   4 T
         DATA,1   5 N
         BOUND    4
         SPACE    3
*****    SEARCH THE FILE DIRECTORY     *****
*
FIND1    RES      0
*                                   ADR OF FILE CFU
*
         LW,R4    KBUF,R6
         STW,R4   KAD,R6            KEY IS IN KBUF
         LCI      8
         LM,R7    0,R3              GET FILE NAME
         STM,R7   0,R4              MOVE TO KBUF IN DCB
*
         BAL,R0   CLRBFUB           WRITE OUT AD IF UPDATED
*
         BAL,R0   2A0
         LC       ACNCFU+11
         BNE      SLCLS            *FILCFU POINTS TO A DIFFERENT FD,
*                                   SET UP FILCFU  AND SEARCH FOR
*                                   FILE NAME FROM START OF FD
*                                  *FILCFU POINTS TO THE SAME FD, SEARCH
*                                   FOR FILE NAME FROM CURRENT POS.
         LW,D1    FILCFU+CDAM
         LW,D2    FILCFU+16         BLINK SAVED BY REDSEC
         BAL,R0   REDSECL
         B        FASCLS
SLCLS    EQU      %
         LW,D1    FILCFU+FDA
         LI,D2    0
         BAL,R0   REDSECL           READ SECTOR WITH LINK CHECK
         LI,R4    WXBUFSIZ-5
         LI,R3    X'4000'           HALF/FULL GRANULE FLAG
         CW,R3    BUFF2+NAVX
         BANZ     %+2
         AI,R4    -X'100'
         LCI      4
         LM,SR1   BUFF2,R4
         LW,D2    Y8
         AI,SR1   0
         BGEZ     %+2
         STS,D2   FILCFU+FDA        TRANSFER EMPTY FILE FLAG
         AND,SR1  Y008              MASK OFF CYL FLAG
         STW,SR1  CYLFLG
         STW,SR3  FILCFU+GAVAL
         STW,SR4  FILCFU+FSP
FASCLS   EQU      %
         BAL,SR4  SETUPUB
         B        PULLEXIT          DIDNT FIND
         LW,D1    FILCFU+CDAM
         STW,D1   CDA,R6
         AI,R3    FNEMAX
         LI,R0    X'800'
         CW,R0    PRIV,R6
         BANZ     FASCLS2
         LI,R0    CL1A1             IS IT A RELEASE
         CW,R0    *TSTACK
         BE       FASCLS2           SKIP IF RELEASING
         AI,R3    4                 POINT TO BLK
*                  HANDLE DESCRIPTORS
         LW,D2    Y002              MASK FOR SETTING MIUD
         LW,D1     DESC,R6
         SCS,D1   16                R.J. DYNAMIC DESC
         CW,D1    Y004              SET DYNAM FLAG(F/25)
         BAZ      %+3               'DO DYNAMIC' FLAG IS OFF
         STB,D1   *D3,R3
         STS,D2   MIUD,R6           FORCE WRITEOUT
*                 NOW HANDLE STATIC DESCRIPTORS
         AI,R3     1
         SCS,D1   8
         CW,D1    Y2
         BAZ      %+3               'DO STATIC' FLAG IS OFF
         STB,D1   *D3,R3
         STS,D2   MIUD,R6           FORCE WRITEOUT
*                   HSKP DESC
         LI,D1    X'FFF01'
         AND,D1   DESC,R6
         XW,D1    DESC,R6
         AI,R3    -5                RESET R3 FOR DABLK
         CI,D1    X'40'             WAS DYNAM DESC SET
         BAZ      FASCLS2
         LI,D2    X'10'             YES-FLAG FOR BACKCHK
         STS,D2   DESC,R6
FASCLS2  EQU      %
*
         BAL,R0   PULLFOUR
         STW,D1   J:BASE+9
         LW,D1    FUN,R6
         LW,R1    TCFU,R6
         CW,D1    Y0014
         BANZ     RDFIT1            IT'S OUT/OUTIN
*
*  READ IN THE FIT.
         LW,SR1   J:BASE+9          DISK ADDR
         BAL,SR4  FMCHKDA
         BCS,15   RDFIT2
         BAL,SR4  DELAA             DELETE FD ENTRY
         LW,SR3   CDA,R6            FD SECTOR
         LI,SR1   3                 75-03
         BAL,SR4  ERFILDA
         LI,SR3   CLSFIL5M
         STW,SR3  *TSTACK
         LI,SR3   X'7506'           75-03
SAVERR   SCS,SR3  -8
         CW,SR3   J:CLS             SAVE THE WORST
         BLE      %+2
         STW,SR3  J:CLS
         B        PULLEXIT          DIDN'T FIND EXIT
         SPACE    3
RDFIT2   BAL,R0   CLRBFUB           GET RID OF FD GRANULE
         LW,D1    J:BASE+9
         BAL,0    RSTSCR
         LI,R2    FITCFU
         LI,R3    X'1FFFF'
         STS,R2   CFU,R6            CHANGE CFU POINTER
         BAL,R0   REDSEC
         B        PULLEXIT1         FOUND
*
RDFIT1   LW,D1    FDA,1             SET NEW FIT ADDR
         AND,D1   M31
         LI,2     -4
         AI,3     -1
         STB,D1   *D3,3
         SLS,D1   -8
         BIR,2    %-3
         LW,1     Y002
         STS,1    MIUD,R6           SET FD GRANULE UPDATED
         LI,1     X'100'
         STS,1    J:CLS             READ FIT FLAG
         B        RDFIT2
         SPACE    2
RSTSCR   LI,2     BAKEYM
         LB,3     *6,2
         AI,3     1
         B        SETSCR
         SPACE    3
*D*      NAME:    FINDFIL1
*D*      REGISTERS  AL  BUT R6 VOLATILE
*D*      CALL     R0 IS THE LINK, SKIPPING EXIT IF FOUND
*D*      DESCRIPTION  FIND THE FILE DIRECTORY FOR A
*D*               SPECIFIED ACCOUNT.
         SPACE    2
*****    SEARCH THE ACCOUNT DIRECTORY   *****
*****    OBTAIN OPEN-CLOSE-USER PRIVILEGE    *****
*
FINDFIL1 EQU      %
*                                   R7 = ADR OF ACCOUNT NO
*
         PUSH     1,R0
         LI,0     X'40000'
         CW,0     NXTA,R6
         BANZ     PULLEXIT1         IT'S A STAR FILE
         SPACE    3
*  SET OPNCLS USER BLOCK
         LW,4     6                 SAVE DCB ADDR
1F1      DISABLE
         LW,2     S:CUN
         LW,0     OPNCLSUS
         BEZ      1F2
         CW,2     OPNCLSUS
         BE       1F2
         LI,6     E:OCR
         LI,11    1F1
         B        T:REG
         SPACE    3
1F2      RES   0
         LW,6     4
         STW,2    OPNCLSUS
         ENABLE
         LH,4     UH:FLG,2
         OR,4     BT31TO0+4         SET OPNCLS USER BIT
         STH,4    UH:FLG,2
         SPACE    3
         BAL,SR4  TRUNC             RELEASE MI BUFFER
         BAL,R0   SETACD
         OPEN     IMT
IMT      EQU      14
         LI,R3    HAACD
         LH,R3    *R6,R3            GET DISPL TO ACCT VLP IN DCB
         LCI      2
         LM,R2    *R3,R7            GET ACCOUNT FROM DCB
         LM,R4    FILCFU+ACNDISP
         LI,D2    DCBPRIVBIT
         LI,D1    DCBPRIVBIT
         AND,D1   PRIV,R6
         SLD,D1   5
         BNEZ     CL61
         CD,R2    R4
         BNE      CL61
         CS,D1    FILCFU
CL61     STCF     ACNCFU+11
         BE       FIND3
*  TAKE THE ABOVE BRANCH IF FILE CFU ALREADY SET UP FOR
*  DESIRED ACCOUNT.
*
         STS,D1   FILCFU
FIND4    RES      0
         LI,R5    X'1FFFF'
         LCI      2
         STM,R2   FILCFU+ACNDISP
         BAL,R0   PRIVDCB
         BANZ     CLSDAOK2          IT'S PRIVATE
         LW,R4    KBUF,R6
         SCD,R2   24
         LW,R1    M24
         AND,R1   R3
         OR,R1    Y08
         STS,R4   KAD,R6
         LCI      3
         STM,R1   0,R4
         LI,R4    ACNCFU
         STS,R4   CFU,R6
         LM,R2    FILCFU+ACNDISP
         LI,D1    0                 ZAP THE DUAL FDA
DFDA     EQU      8                 DUAL FDA LOCATION
         STW,D1   FILCFU+DFDA
         SPACE    3
*  SEARCH THE ACCOUNT TABLE IN MONITOR DATA TO GET THE
*  BEST STARTING GRANULE FOR THE ACCOUNT DIRECTORY SEARCH.
*
         SLD,2    -1                MAKE ACCT NAME POSITIVE
         LI,4     -1000             NO ACTION YET FLAG
         LD,0     DOUBLEZERO        NO DISK & START SRCH
         B        3A4               ENTER SEARCH
         SPACE    3
3A0      LW,12    ACNTBL+1,1        MSH
         LW,13    ACNTBL+2,1        LSH
         SD,12    2                 WHAT'S THE DIFFERENCE
         BLZ      3A1               GOT A GOOD ONE
         BGZ      3A3               NO GOOD
         LW,0     ACNTBL+3,1        DISK ADDR
         LW,SR1   ACNTBL+4,1        DUAL
         B        3A6               WE LUCKED OUT
3A1      AI,4     0                 IS THIS THE 1ST GOOD ONE
         BLZ      3A2               YUP
         CD,10    12                CHK WITH PREV GOOD ONE
         BGE      3A3               OLD ONE IS BEST
3A2      LW,4     1                 SAVE POSITION
         LD,10    12                SAVE DIFFERENCE
3A3      AI,R1    4                 NXT TABLE ENTRY
3A4      CW,1     ACNTBL            CHK END OF TABLE
         BL       3A0               NOT THE END
         BIR,4    3A6               BRNCH IF NOTHING FOUND
         LW,0     ACNTBL+2,4        DISK ADDRESS
         LW,SR1   ACNTBL+3,4        DUAL
3A6      STW,0    ACNCFU+CDAM       SET SECTOR ADDR
         STW,SR1  ACNCFU+4          STORE DUAL
         LW,SR1   ACNCFU+CDAM
         BEZ      3A7
         BAL,SR4  FMCHKDA           VERIFY
         BCS,15   3A7               OK
         LI,0     0
         STW,0    ACNTBL            ERASE TABLE
         B        3A6               USE FDA
3A7      RES      0
*                                                   THE ACN IN THE DCB
ACNSCR   EQU      9                 SCR FOR ACCT DIRECTORY
         LI,R3    ACNSCR
         LI,R2    X'10'  ACCT DIRECTORY ENTRY LENGTH
         BAL,R0   SETSCR-1
         LI,SR1   0
         STW,SR1  ACNCFU+4          BLITZ THE DUAL
         LW,SR4   ACNCFU+CDAM
         CW,SR4   ACNCFU+FDA
         BNE      %+2               NOT THE FIRST
         STW,SR1  ACNCFU+CDAM       TO GET LINK CHK & DUAL
         BAL,SR4  SETUPUB
         B        NOACCT
         AI,R3    ACNSCR+3
         BAL,R0   PULLFOUR          GET DUAL FDA
         SLS,D1   -8                MAKE IT A DA
         LW,SR1   D1
         BEZ      FIND2
         BAL,SR4  FMCHKDA
         BCR,15   %+2               BR IF BAD
         STW,D1   FILCFU+DFDA
FIND2    RES      0
         AI,R3    -7                 ACK UP TO MAIN FDA
         BAL,R0   PULLFOUR
         SLS,D1   -8                MAKE IT A DA
         LW,SR1   D1
         BAL,SR4  FMCHKDA           CHECK DISC ADR
         BCS,15   CLSDAOK1          GO IF DISC ADR OK
         LW,SR3   ACNCFU+CDAM       CURRENT AD SECTOR
         LI,SR1   5                 75-05
         BAL,SR4  ERFILDA           TO ERROR FILE
         STW,SR4   FILCFU+ACNDISP
         BAL,SR4  DELAA             DELETE THE BAD ENTRY
CLS7505ERR EQU    %
         CI,R5    CLSFITMODRTN      IF RETURN WAS SUPPOSED TO GO
         BNE      %+2                 TO FIT MOD CODE,
         BAL,R5   CLSMOV1TO2          RESTORE BUFF2.
         BAL,SR4  TRUNC             WRITE OUT UPDATED BUF2
         LI,SR3   X'750A'           7505
         B        SAVERR
CLSDAOK2 BAL,R5   CLSGETPVFDA       GET THE FILE DIRECTORY ADDRESS.
CLSDAOK1 EQU      %
         STW,D1   FILCFU+FDA
         B        PULLEXIT1
NOACCT   STW,SR4  FILCFU+ACNDISP
         B        PULLEXIT
         SPACE    2
FIND3    LW,SR1   NODUAL
         BEZ      PULLEXIT1         IGNORE DUAL IF NONE IN SYSTEM
         LW,SR1   FILCFU+DFDA       CHK IF DUAL PRESENT
         BEZ      FIND4
         BAL,SR4  FMCHKDA
         BCS,15   PULLEXIT1         A OK
         B        FIND4             WE NEED THE DUAL
         TITLE    '**** MSRCLS ****'
*F*      NAME:    MSRCLSA
*F*      ENTRY    MSRCLS
*F*      DESCRIPTION
*DO*
*F*
*                                   THIS ROUTINE CLOSES A DCB
*                                   R6 =DCB ADR
*                                   R7=PLIST
*                                   SR1 =OPCODE
*FIN*
*
MSRCLSB  REMEMBER
         OR,SR4   Y8                SET FLAG TO INDICATE CLSALL
MSRCLSA  BAL,R0   MAPBUFS           MAP BUFF1 AND BUFF2
MSRCLS   BAL,R1   PUSHALL
         LI,SR3   X'A'
         LW,SR4   Y002
         AND,SR4  FCD,R6
         BEZ      MSRCLS9           CAN'T CLOSE CLOSED DCB
*E*  ERROR:        0A-00
*E*
*E*  DESCRIPTION:  ATTEMPT TO CLOSE A CLOSED DCB
         SPACE    1
         BAL,R2   CHKBIT0
         NOP
         BAL,R2   CHKBIT
         NOP                        IGNORE P1 AND P2
         BAL,R2   CHKBIT
         STS,D1   ERA,R6            ERROR ADDRESS
         BAL,R2   CHKBIT
         STS,D1   ABA,R6            ABNORMAL ADDRESS
*
         LI,SR1   0                 NO ERRORS
         LI,SR3   0
CNM      EQU      1                 =1 IF TP SLAVE LINES SUPPORTED
         DO       CNM
         REF      CNMLNDCB          SLAVE LINE DCB MASK = X'803'
         REF      LNDEVCD           OP LBL CODE FOR SLAVE LINE ='LN'
         SREF     KILLIO            CLEAN UP SLAVE COC LINE TABLES
         SREF     MODE5             SLAVE COC LINE TYPE BITS
         SREF     CLRMULIO          RUN DOWN SLAVE MOC LINE I/O
*
*
         LW,R1    CNMLNDCB          GET MASK FOR SLAVE LINE DCB
         CS,R1    0,R6              SEE IF THIS IS A SLAVE LINE DCB
         BE       SLVLNCLS          B, IF SO
         FIN
         ANSBAL,R0 CHKANS1
         BAL,SR4  IOCHEK1           WAIT FOR IO TO FINISH
         BAL,R0   GETASN
         LW,R1    Y00FE
         STS,R0   TYC,R6            RESET TYC
         LI,R1    CLSVEC
          B         *D2,R1
CLSDEV   EQU      %                 CLOSE THE PARTICULAR DEVICE
*                                   DONT DO EOF IF FORMAT BIT SET
*                                   WRITE END OF FILE
         BAL,D4   GETDEV            GET DCTX OR STREAM #
         CI,R3    DCTSIZ
         BG       NODIAG            NOT DIAGNOSTIC OPEN
         INT,SR4  DCT9,R3
         BCR,2    NODIAG            NOT OPEN IN DIAGNOSTIC MODE
         LI,R7    X'200'            M:DCLOSE FPT - 'SAME' OPTION
         PUSH     R7
         LW,R7    TSTACK            ADDRESS OF FPT
         OVERTO   RMAOVSEG,T:CLOSIT#  GO CLOSE DIAGNOSTIC DCB
NODIAG   EQU      %
         LI,R5    K8000
         AND,R5   FRM,R6            DOES DCB SAY (DRC)...
         BNEZ     CHKTPE            --->YES. NEVER PUNCH !EOD.
         CI,R3    DCTSIZ            IS IT A REAL DEVICE...
         BG       STREAM            --->NO. SEE IF STREAM.
         LB,R0    DCT4,R3
PP       EQU      3                 **** TEMP
         CI,R0    PP
         BE       PUNCH             ---> PUNCH !EOD ON P.T. PUNCH.
CP       EQU      5                 **** TEMP
         CI,R0    CP
         BE       PUNCH             ---> PUNCH !EOD ON CARD PUNCH.
CHKTPE   EQU      %
         LI,R1    BADEVTP
         LB,R1    *R6,R1            GET DEVICE TYPE
         AND,R1   M6                SCRUB OFF BAD BITS
         LC       TB:FLGS,R1        GET TYPE OF DEVICE
         BCR,8    MSRCLSX2          NOT TAPE
*                                   TAPE FOUND
         OVERTO   OPNTPSEG,CLSTP#
STREAM   LI,R5    X'FF'
         AND,R5   CLK,R6
         BEZ      MSRCLSX2          ---> NON-STREAM NON-DEV; FORGET IT
         LW,R5    *J:USCDX,R5       GET C.B. POINTER.
         LW,R1    1,R5              GET DEV TYPE WORD.
         CW,R1    Y002              IS IT C.P.-TYPE DEVICE...
         BAZ      MSRCLSX2          --->NO. FORGET IT.
PUNCH    EQU      %
         BAL,R0   PUNWEOF           WRITE !EOD ON PUNCH DEVICE.
MSRCLSX2 EQU      %
*                                   CLEAR DEVICE OPTIONS
         BAL,SR4 IOSPIN
SLVLNCLS EQU      %
*                                   RESET WORDS 15,16,17,18 OF THE DCB
         LD,R0    DOUBLEZERO
         LD,R2    DOUBLEZERO
         LCI      4
         STM,R0   TAB1,R6
*
         LI,1     X'1FFFF'          IS IS A SYMBIONT DEVICE
         STS,0    CLK,6             ZERO THE CONTEXT BLOCK LINK ITEM
*
         LW,SR4   NXTF,R6           SAVE NEW JOB FILE FLAG
         LW,R1    CLSMSK            RESET ONWK,NWK,SEQ,SID,TRN,NXTF
         STS,R0   SEQ,R6
         DO       CNM
         LW,R1    CNMLNDCB          GET MASK FOR SLAVE LINE DCB
         CS,R1    0,R6              SEE IF THIS IS A SLAVE LINE DCB
         BNE      CLSDEV1           B, IF NOT
         LI,R3    BARNDEV           RNDEV OFFSET
         LB,R2    *R6,R3            GET VALUE OF RNDEV BYTE
         BEZ      CLSMULN           0 MEANS MULTI-PNT LN
         STB,R0   *R6,R3            SET RNDEV BYTE BACK TO 0
         AI,R2    -1                R2= TRUE LINE#.
         LB,SR4   MODE5,R2
         AND,SR4  NB31TO0+6           TURN OFF X'20' (DCB OPEN).
         STB,SR4  MODE5,R2
         BAL,SR4  KILLIO              PURGE ALL I/O ON LINE.
         B        REINIT
CLSMULN  EQU      %
         BAL,SR4  CLRMULIO            KILL I/O ON MULTIPOINT LINE.
*
REINIT   EQU      %
         LI,R1    X'1FFFF'          MASK FOR DCB'S TOLF & OP LBL FIELDS
         LI,R0    LNDEVCD           GET DEVICE TYPE CODE FOR SLAVE LINE
         AI,R0    X'10000'          SET DCB'S TOLF BIT
         STS,R0   1,R6              REINITIALIZE TOLF & OP LBL FIELDS
*
CLSDEV1  EQU      %
         FIN
*                                  *RESET FCD,SWXV,AGV,EGV,PRIV,DIR,XUP
*                                   SET FCI
         LW,R0    Y004
         LW,R1    MASKCLS
         STS,R0   TTL,R6
         B        CLSX              FINISHED
         SPACE    2
CLSVEC   EQU      %-1
         B        CLSFIL
         B        CLSLBL
         B        CLSDEV
         LW,SR4   11,R6             GET CFU
         MTH,-2   *SR4              DECR USE CNT
         B        MSRCLSX2
CLSMSK    DATA     X'3F000000'
         SPACE    2
*  FINAL EXIT FROM CLS
         SPACE    1
MSRCLS9  STW,SR3  J:CLS             SAVE ERROR CODE
CLSX     LI,SR3   0
         XW,SR3   J:CLS
         LW,R2    TSTACK
         CW,SR4   Y01               CHK FOR NEW JOB FILE
         BAZ      CLSX2
         LI,R3    X'E'              ASN = FILE CHK
         CW,R3    ASN,R6
         BANZ     CLSX2             BRANCH IF NOT
         PUSH     SR3               SAVE ERROR
         BAL,R0   SETACD            RESTORE NAME POINTER
         DESTRUCT CLSROOT           GO TFILE FROM ROOT
CLSX2    AI,R2    -1
         CW,R2    1,R2              SEARCH FOR STACK MARKER
         BNE      CLSX2
         LW,R3    0,R2              GET RETURN ADDRESS FROM PUSHALL
         BLZ      MSRWRTX           IF CLSALL, DON'T DESTRUCT
*
2B0      CI,SR3   X'FFFFE'
         BAZ      CLSX6             NO ERROR IF ZERO OR ONE
         DESTRUCT MSR01EXIT         EXIT WITH ERROR
CLSX6    DESTRUCT MSRWRTX
         SPACE    1
CLSLBL   EQU      %
         OVERTO   OPNTPSEG,CLSLBL#
         SPACE    3
CLSFILD  RES      0
         DO       XTRB
         LW,R2    ACS,R6            CHK FOR DIRECT OR
         CI,R2    X'12'              RANDOM OR CONSEC
         BANZ     CLSFILC           SKIP IF SO
         CI,R2    X'20'             ASSURE IT'S KEYED
         BAZ      CLSFILC           SKIP IF NOT
         LW,R2    TDA,R1            HAVE WE STARTED THE TOP
         BEZ      CLSFILC
         LI,R2    3                 SLIDES BYTE IN CFU
         LC       *R1               WERE WE STOPPED
         BCS,2    CLSFILB
         CI,R7    5                 HOW MANY LVL 0'S
         BGE      CLSFILB           ENUF LVL 0'S
         AI,R7    -1                NO MORE TOP IN COUNT
         STB,R7   *R1,R2            MODIFY SLIDES
         LI,R2    0
         XW,R2    TDA,R1            ERASE THE TOP
         LI,SR4   DCBPRIVBIT+DCBCYLBIT
         CW,SR4   PRIV,R6           IS IT CYL OR PRIV
         BANZ     CLSFILC           SKIP IF SO
         STW,R2   XTRAGRAN          SAVE THE GRANULE
         FIN
*  CHECK FOR BUILDING A MULTI-LEVEL PYRAMID.
CLSFILC  RES      0
         CI,R7    4
         BL       0,R5
CLSFILE  RES      0
         LW,SR4   Y02               SET WRITE
         STS,SR4  0,R1               OCURRED
         PUSH     R5
         LI,SR4   X'F00'            FORCE UPDATE
         LI,SR3   X'500'            SPECIAL UPDATE
         STS,SR3  0,R1
         BAL,SR4  TRUNC
         OVERLAY  MULSEG,0
         B        PULLEXIT
*
         DO       XTRB
CLSFILB  AI,R7    -4                LVL 0 RETENTION
         STB,R7   *R1,R2            MODIFY SLIDES
         BDR,R7   CLSFILE           SKIP IF MORE THAN 1 LVL 1
         B        0,R5              ONLY 1 ON LVL 1
         FIN
         SPACE    2
JOBSTAR  LCI      4                 ASSUME JOB
         LW,SR4   YC
         CS,SR4   FIL1,R6           CHK FOR JOB
         BE       *R0               BRANH IF IT'S A JOBBER
         LI,SR4   X'40000'
         CW,SR4   NXTA,R6           CHK FOR *
         B        *R0
         SPACE    2
8D1      LW,R0    Y002              CHK IF BFR2 UPDATED
         CW,R0    MIUD,R6
         BAZ      CLSFIL2           GET OUT IF NOT
         PUSH     SR1               SAVE SAVE/REL FLAG
         BAL,SR4  TRUNC             DUMP THE BUFFERS
         PULL     SR1
         B        4D1               TRY AGAIN
         TITLE    '**** CLSFIL ****'
*F*      NAME:    CLSFIL
*F*      PURPOSE  CLOSE A FILE DCB
*F*      DESCRIPTION
*DO*
*F*
*                                   R6 = DCB ADR
*                                   R7 = ADR OF PLIST
*                                   SR1 = CLOSE OPCODE
*FIN*
*
CLSFIL   EQU      %
         LW,SR3   =X'060000B8'      B8-03
         LW,R3    S:CUN
         LH,R3    UH:FLG2,R3
         CI,R3    X'0800'           CHECK FOR REAL-TIME LOCK-IN-CORE
         BANZ     MSRCLS9           YES - DON'T ALLOW CLOSE
*E*      ERROR:   B8-03
*E*      MESSAGE:  Restricted CAL issued while locked in core
*E*      DESCRIPTION:  A real-time user attempted to close a
*E*        disk file after locking himself in core with M:HOLD
*
*
         PUSH     R7
         RABAL,SR4  T:RAPURGD       PURGE ANY READ AHEAD FOR THIS DCB
         PULL     R7
         LI,R1    1
         STW,R1   J:CLS             INDICATE FILE CLOSE IN PROGRESS
         LI,SR1   0                 ASSUME NO FPT CLS CODE
         STW,SR1  PBD,R6            ASSUME NO SYNS,CMD OK
         BAL,R2   CHKBIT1           GET FPT CLS CODE
         LW,SR1   D1                GOT ONE
*
         LI,D1    0                 ASSUME NO FIT MODS
         LW,D2    Y01               RESET TFILE FLAG
         STS,D1   NXTF,R6            FOR JOB FILES
         LI,D2    X'100'
         CW,D2    0,R7              ARE THERE VLPS IN FPT
         BAZ      4D2               NO - NO MODS
         BAL,R0   JOBSTAR
         BANZ     4D2               NO MODS FOR * OR JOB FILES
         LI,R2    X'20000'
         CW,R2    SHARE,R6
         BANZ     4D2               NO MODS IF SHARE
         LW,R2    Y0008
         CW,R2    FUN,R6
         BAZ      4D2               NO MODS UNLESS UPDATE
         LW,R2    Y006
         CW,R2    DESC,R6           IS IT A SYNON
         BAZ      4D2M1             SKIP IF OK
         LW,SR3   =X'1400000A'      0A-0A
         STW,SR3  J:CLS
*E*      ERROR:   0A-0A
*E*  DESCRIPTION:  ATTEMPT TO MODIFY A FILE OPEN ON A SYNON NAME
         B        4D2               TURN OFF THE MOD BIT
4D2M1    LI,D1    X'100'            TURN ON THE MOD BIT
4D2      STS,D1   0,R6              SET/RESET FLAG
*
4D1      LI,R1    X'1FFFF'          GET THE
         AND,R1   CFU,R6             CFU ADDRESS
         STW,R1   TCFU,R6           SAVE IT
*  VERIFY THAT WE HAVE A VALID CFU.
         CW,R1    ACNCFU+13         END OF LOW CORE CFUS
CFUDCB   SET      1                 CFU DCB EXISTS
         DO       CFUDCB=1
         BL       CLSF10            ITS IN LOW CORE
         LW,R3    J:DCBLINK
         LW,R0    1,R3
         CW,R0    TXTCFU            CHK IF CFU DCB EXISTS
         BNE      MSRCLSX4          BAD NEWS
         SW,R1    2,R3              START OF CFU DCB
         CI,R1    40
         BGE      MSRCLSX4          OFF THE END
         AI,R1    -1                START OF CNTXT CFUS
         B        CLSF10+1
         ELSE
         BGE      MSRCLSX4          NOT A CFU
         FIN
CLSF10   AI,R1    -BGRCFU           START OF CFUS
         CI,R1    X'E0007'          CHK - OR NOT =0 MOD 8
         BAZ      CLSFIL56          BRANCH IF OK
MSRCLSX4 LI,SR3   BGRCFU            AS GOOD AS ANY
         LI,SR4   X'1FFFF'
         STS,SR3  CFU,R6
         BAL,SR4  TRUNC             TRUNCATE THE BUFFERS
         OPEN     MSRCLSX4
         B        MSRCLSX4
CLSFIL56 LI,SR3   BUF1MSK
         AND,SR3  BUFX,R6
         BEZ      CLSFIL55          SKIP IF NO BLOCKING BUFFER
         PUSH     SR1               SAVE THE FILE RETENTION
         DO       0                 ******** JLJ'S CLS SHRINKER
         LW,R1    TCFU,R6
         LW,R0    M31
         AND,R0   FDA,R1            GET FIT DISK ADDRESS
         CW,R0    BCDA,R6           IS IT IN BUFF1
         BNE      CLS55M1           NO, TRUNC IT
         STW,R0   DCBCDAM,R6        FOR CREATE 1 GRANULE FILE
         SLS,SR3  5                 MOVE TO BUFF2
         LI,SR4   X'7FFF'
         STS,SR3  BUFX,R6
         SLS,SR3  -5
         LI,D3    BUFF2             REMAP IT TO BUFF2
         BAL,R2   T:SBUF
         LW,R2    Y004              IS IT UPDATED
         CW,R2    BBUD,R6
         BAZ      CLS55M2           SKIP IF NOT UPDATED
         LCW,R2   Y002
         AWM,R2   MIUD,R6           RESET BBUD, SET MIUD
         B        CLS55M2
         FIN                        ******** JLJ'S CLS SHRINKER
*
CLS55M1  RES      0
         BAL,R0   CLRBBUF           CLEAR BLOCKING BUFFER
CLS55M2  PULL     SR1               RESTORE THE FILE RETENTION
*                                   BUT RETAIN MI IF FIT MAY BE THERE
CLSFIL55 RES      0
         LI,SR4   X'60BAD'          BAD CFU FLAG
         LW,R1    TCFU,R6
         LI,R5    X'100'
         CW,R5    0,R6
         BAZ      9A1               NO FIT MODIFICATIONS ARE TO BE DONE
         LW,R5    Y02
         STS,R5   0,R1              SET WRITE OCCURED FLAG TO CHANGE DATES
9A1      LW,R7    0,R1              1ST WORD OF THE CFU
         LW,D1    FUN,R6
         CW,R7    Y00FE             CHECK FOR
         BAZ      CLSX5CP1           NO USERS AT ALL
         LC       R7                CHK FOR
         BCR,4    CLSX5CP1          CFU NOT ACTIVE
         CW,R7    Y00FC
         BANZ     8D1               MORE THAN 1 USER
         LI,R5    X'FFFF'
         AND,R5   SCFU,R1           IS THER  A 2NDRY?
         BEZ      9A11              SKIP IF NOT
         LC       *R5               IS IT ACTIVE
         BCR,4    9A12              BAD NEWS IF NOT
         CW,R5    ACNCFU+13         MUST BE IN LOW CORE
         BGE      9A12              BAD 2NDRY
         AI,R5    -BGRCFU           START OF CFUS
         CI,R5    X'E0007'          CHK - OR NOT ZERO MOD 8
         BANZ     9A12              BAD 2NDRY
         INT,R5   SCFU,R1           2NDRY CFU ADDR IF ANY
9A11     CI,R7    X'8000'           CHK 4 SHARED
         BANZ     9A2               SKIP IF SHARED
         CI,SR1   K1                RELEASE OP SPECIFIED
         BAZ      CLSFIL1
         AI,R5    0                 IS THERE A 2NDARY
         BEZ      CLS5              SKIP IF NOT
         LW,R3    0,R5
         CI,R3    X'4000'           IS IT RANDOM
         BAZ      CLS5              BRANCH IF NOT RANDOM
         AND,R3   Y00FE             ARE THERE ANY 2NDRY USERS?
         BNEZ     8D1               BRANCH IF THERE ARE SOME
         STW,R3   SCFU,R5
         STW,R3   SCFU,R1
         MTW,-1   C:CFU
         STW,R3   2,R5              CLOBBER NAME IN 2NDRY
         STW,R3   0,R5
         LI,R5    0                 NO MORE 2NDRY
         SPACE    2
CLS5     RES      0
         SPACE    3
*F*      NAME:    CLSFIL5
*F*      PURPOSE  TO RELEASE A FILE
*                                   RELEASE FILE
*
*
*                                   SEE IF WE ARE RELEASING A SYNON
*                                   FILE
         LW,R3    Y1
         STS,R3   0,R1              ASSUME RELEASE
*
         CW,D1    Y0014
         BANZ     CLSFIL5M   MUST DUMP FOR CORRECT RELEASE
         CI,D1    X'20000'
         BAZ      CL12              IT'S UPDATE
         LI,R2    X'4000'
         CW,R2    USR,R6
         BANZ     CLSFIL2M          DON'T DELETE
         LI,D2    X'60000'          CHANGE TO UPDATE
         AWM,D2   FUN,R6             FOR RECOVERY
CL12     LI,SR1   X'700'            SPECIAL CLOSE FUNCTION FOR CFU
         LI,SR2   X'F00'            FORCE
         STS,SR1  0,R1               FUNCTION
         LW,R2    Y006
         CW,R2    DESC,R6
         BAZ      CL1               NOT SYNON
         STS,R2   0,R1              RESET THE REL BIT
         LW,D2    Y03               FORCE CFU R/W FOR FINDFILS
         STS,D2   0,R1
         BAL,R0   FINDFIL1
         B        CLSFIL5M
         BAL,R0   FINDFILS
         B        CL2SYN
         LI,R0    -1
         B        CL2A
*
CL1      RES      0
*                                   EXISTS
         BAL,R0   FINDFIL1
         B        CLSFIL5M          TRUNC BUFFERS
         BAL,R0   FINDFILINT
CL1A1    B        CLSFIL5M          RELEASE A * FILE
*
*                                   DELETE FILE INFO
*
         BAL,R5   LOCCODEC
         B        CL6A              NO SYNON
         AI,R3    2
         LW,R3    *R7,R3
         LH,R3    R3
         BEZ      CL6A              NO SYNON
*
*
*                                   DELETE SYNON ENTRIES
         BAL,11   DELF
         LW,11    FILCFU+SREC
CL6      EQU      %
         PUSH     11
         LW,SR1   11
         BAL,SR4  FMCHKDA
         BCR,14   CLSFIL14
*  LOOP THROUGH THE FILE DIRECTORY DELETING ALL ENTRIES
*  WITH A FIT DISK ADDRESS THAT MATCHES THE MASTER'S.
CL6C1    RES      0
         LW,R1    CFU,R6
         LW,D1    FDA,R1
         LI,D2    0
         BAL,R0   REDSECL           READ SECTOR WITH LINK CHECK
         LI,R3    MIDIS
CL6C     EQU      %
         BAL,SR4  FNDKY
         B        CL7
         BAL,R0   GETCMD
         LW,R1    CFU,R6
         LW,R1    CDAM,R1
         STW,R1   CDA,R6
         AI,R3    FNEMAX
         BAL,R0   PULLFOUR
         CW,D1    *TSTACK
         BNE      CL6D1
         BAL,SR4  DELAA             MATCH - DELETE ENTRY
         B        CL6C1
CL6D1    RES      0
         BAL,R0   GETCMD
         AI,R3    FNEMAX+9
         B        CL6C
         SPACE    3
         B        CLSFIL5M  THIS MUST PRECEDE CL6A
CL6A     EQU      %
         BAL,11   DELF
         B        CLSFIL14
CL7      LI,0     0                 RESET EOF
         LW,1     Y00FE
         STS,0    TYC,6
CLSFIL14 EQU      %
         LW,D1    FILCFU+FDA        UPDATE SECTOR INFO
         BEZ      CLSFIL5M          BR IF FILE DIRECTORY DELETED
         LB,D2    CYLFLG
********************************************************
********************************************************
*  BYTE ZERO OF CYLFLG IS SET NON-ZERO WHENEVER A
*  CHANGE IS MADE TO FILCFU THAT MUST BE POSTED BACK
*  TO THE FIRST GRANULE OF THE FILE DIRECTORY (SUCH
*  AS GAVAL/NGAVAL OR EMPTY DIRECTORY FLAG).  IN
*  THEORY, THE POSTING BACK OF INFO SHOULD NOT HAVE
*  TO BE DONE IF CYLFLG BYTE ZERO IS ZERO, THEREBY
*  SAVING A READ AND A WRITE FOR EVERY CLOSE THAT
*  CREATES A NEW FILE OR DELETES AN EXISTING ONE.
*  HOWEVER, OCCASIONALLY FILE DIRECTORY KEYS GET OUT
*  OF ORDER.  IT APPEARS THAT SOMETIMES WHEN THE FIRST
*  KEY IS ADDED TO AN EMPTY DIRECTORY, THE FILCFU
*  INFO IS NOT POSTED BACK.  WHEN THE SECOND KEY IS
*  ADDED, IT IS ADDED IN FRONT OF THE FIRST KEY SINCE
*  THE EMPTY DIRECTORY FLAG IS ON, AND ITS EOF BIT IS
*  SET.  THIS SITUATION IS VERY INTERMITTENT, AND I
*  HAVE BEEN UNABLE TO DETERMINE WHY IT HAPPENS.
*  THEREFORE, I HAVE INSERTED THE FOLLOWING BRANCH
*  INSTRUCTION TO FORCE THE POSTING OF THE FILCFU INFO.
*  IF YOU CAN FIND THE ERROR, REMOVE THE BRANCH TO
*  SPEED UP FILE RESTORES.     (JFJ)
********************************************************
********************************************************
         B        %+2               ALWAYS FORCE POSTING
         BEZ      CLSFIL5M          NOTHING TO DO, NOTHING CHANGED
DCDAM    EQU      4
CBLINK   EQU      16
         LW,R3    FILCFU+CDAM       SAVE FILE
         LW,R4    ACNCFU+DCDAM       DIRECTORY
         LW,D4    FILCFU+CBLINK       POSITION
         LI,D2    0
         BAL,R0    REDSECL          READ SECTOR WITH LINK CHECK
         LI,R2    WXBUFSIZ-5
         LI,SR2   X'4000'
         CW,SR2   BUFF2+NAVX
         BANZ     %+2
         AI,R2    -X'100'
         LW,SR2   CYLFLG
         AND,SR2  Y008              SAVE ONLY CYLINDER FLAG
         STW,SR2  CYLFLG
         MTW,0    FILCFU+FDA
         BGEZ     %+2               NOT EMPTY DIRECTORY
         OR,SR2   Y8                SAVE EMPTY FLAG
         LW,SR4   GAVAL+FILCFU
         LW,D1    FSP+FILCFU
         CW,SR2   BUFF2,R2          CHK FOR CHANGES
         BNE      8C2               IT CHANGED
         CW,SR4   BUFF2+2,R2
         BNE      8C2
         CW,D1    BUFF2+3,R2
         BE       8C1               SKIP WRITE IF NO CHANGE
8C2      RES      0
         LCI      4
         STM,SR2  BUFF2,R2
         LW,SR2   Y002              SET BFR UPDATED
         STS,SR2  MIUD,R6
8C1      BAL,R0   CLRBFUB
         STW,R3   FILCFU+CDAM       RESTORE FILE
         STW,R4   ACNCFU+DCDAM       DIRECTORY
         STW,D4   FILCFU+CBLINK       POSITION
         XW,D1    ACNCFU
         CI,D1    X'F4008'
         BNE      CLSFIL5M          NOT A NEW ACCT
*
*  CREATE A NEW ENTRY IN THE ACCOUNT DIRECTORY.
*
         LW,R7    ACD,R6
         LH,R7    R7
         AW,R7    FLP,R6
         LW,R1    KBUF,R6
         LCI      2
         LM,D3    0,R7              ACCOUNT NAME
         SCD,D3   24
         LW,D2    M24
         AND,D2   D4
         OR,D2    Y08
         LCI      3
         STM,D2   0,R1
         LI,R3    ACNSCR
         LI,R2    X'10'
         BAL,R0   SETSCR-1
         LI,R2    ACNCFU
         LI,R3    X'1FFFF'
         STS,R2   CFU,R6
         LW,R3    FILCFU
         BAL,R0   SETCMD1
         LI,D1    0
         STW,D1   ACNCFU+4          ZAP THE DUAL
         LW,D1    ACNCFU+CDAM
         BEZ      %+2
         BAL,R0   REDSEC
         LW,R2    ACNCFU+DFDA
         LW,R0    BUFF2
         BEZ      %+2               IT'S FDA
         LW,R2    BUFF2+DDA
         STW,R2   ACNCFU+4          SET UP DCDAM
         LW,D1    FILCFU+FDA
         B        EPWRT             ENTER NEW ACCOUNT
*
*
         SPACE    2
*E*  ERROR:        57-00
*E*
*E*  DESCRIPTION:  INSUFFICIENT GRANULES TO CLOSE AND SAVE A FILE
*
CLERX    LI,SR3   X'57'
CLERX1   STW,SR3  J:CLS             SAVE THE ERROR CODE
CLSFIL5  LI,SR1   1                 SIGNAL RELEASE
         B        CLSFIL55          CHK NOU & RELEASE
         PAGE
*
9A12     LI,R4    0
         LI,R5    X'FFFF'
         STS,R4   SCFU,R1           BLITZ THE 2NDRY CFU
CLSFIL5M BAL,SR4  TRUNC             DUMP ALL BUFFERS
CLSFIL2  RES      0
         OPEN     CLSFIL2
CLSFIL2  EQU      CLSFIL5M
         LW,R4    TCFU,R6
         LW,1     Y00FC
         LI,R5    X'1FFFF'
         STS,R4   CFU,R6            CORRECT CFU
         CW,1     0,4
         BANZ     MSRCLSX5          SOMEBODY SNUCK IN
         LI,R1    X'FFFF'
         AND,R1   SCFU,R4           OPEN IN AND OUT
         BEZ      MSRCLSX3          NO
         LI,R2    0
         LW,R3    0,R1
         AND,R3   0,R4              MERGE WD 0 OF BOTH CFUS
         CI,R3    X'400'            ARE BOTH UPDATE
         BAZ      CLSF2B            SKIP IF NOT BOTH UPDATE
         STS,R1   ACNCFU+12         FOR GARBAGE COLLECTOR
         STW,R2   0,R1              YES - GET RID OF FIT MOD CFU
         STW,R2   2,R1              AND ITS NAME
         MTW,-1   C:CFU             DECR # OPEN CFUS
         B        CLSF2C
CLSF2B   LI,R3    X'C000'
         CW,R3    0,R4              IF RANDOM OR SHARED, DON'T RELEASE
         BANZ     MSRCLSX5
CLSF2C   STW,R2   2,R4              CLOBBER NAME (NO REOPEN)
         LI,R3    X'FFFF'
         STS,R2   SCFU,R1
         STS,R2   SCFU,R4
MSRCLSX3 EQU      %
*****
*****CAN UNBLOCK CLOSE USERS AFTER THIS POINT
         LW,0     S:CUN
         SW,0     OPNCLSUS
         BNEZ     %+2               WE'RE NOT THE ONE
         BAL,11   T:UBLKOCU
*****
         LW,R4    CFU,R6
         LI,11    X'30'             FOR TEST OF ORG BELOW
         LW,R1    2,R4              ACCT & NAME LOCS
         BEZ      9C1               ITS A TEMP
         CW,R1    Y03
         BGE      9C1               ITS A STAR
         STS,11   ACNCFU+12         SET SIGNIF CLOSE FLAG
9C1      RES      0
         LC       *R4
         BCR,1    MSRCLSX5
*  CLOBBER THE NAME SO FILE CAN BE OPENED DURING RELEASE
         LW,1     Y4
         STW,1    2,R4
         CS,11    ORG,R6
         BE       RELRAND           IT'S RANDOM
         BAL,0    RSTSCR
         AI,3     13
         STW,3    IMT,R6
         BAL,11   REL
*
MSRCLSX5 EQU      %
         BAL,R0   PRIVDCB           IS A PRIVATE FILE BEING CLOSED
         BAZ      CLSX5C                NO
         BAL,SR4  TRUNC             DUMP ALL BUFFERS
         BAL,SR4  CLSVNO            CLOSE ALL OPEN VOLUMES
CLSX5C   EQU      %
         LW,R1    CFU,R6
         LW,SR4   0,R1
         AI,SR4   -X'20000'  TAKE AWAY A USER
         CW,SR4   Y00FE             ANY USERS LEFT
         BANZ     CLSX4             YUP
         CI,SR4   X'C000'           CHK 4 RANDOM OR SHARED
         BAZ      CLSX5CP           NEITHER
         LI,D1    X'FFFF'           CHK 4 2NDARY
         AND,D1   SCFU,R1
         BNEZ     CLSX4             THERE IS ONE
CLSX5CP  RES      0
         LI,SR4   0
         CI,R1    X'18000'
         BANZ     CLSX5CP1          ONLY COUNT ROOT CFUS
         MTW,-1   C:CFU             DECR # OPEN CFUS
CLSX5CP1 RES      0
         LW,R1    CFU,R6
         LI,D1    X'14000'          PRIVATE & RANDOM
         AND,D1   0,R1
         AW,SR4   D1
CLSX4    RES      0
         PUSH     SR4               SAVE NEW 1ST WORD CONTENTS
         BAL,SR4  TRUNC             DUMP ALL BUFFERS
         PULL     SR4
         LI,R1    X'1FFFF'
         AND,R1   CFU,R6
         STW,SR4  0,R1
*
*  IF THERE ARE NO MORE USERS FOR THIS CFU, MOVE CFU TO HIGH END
*  OF CFU AREA TO INCREASE THE CHANCE THAT IT CAN BE USED FOR
*  A FAST REOPEN OF THIS FILE
*
         CI,SR4   X'E0000'          IS ANY ACTIVITY REMAINING
         BANZ     MSRCLSX4          SKIP SHUFFLE IF SO
         LW,SR4   2,R1
         BLEZ     MSRCLSX4          NO FILE NAME
         LH,SR4   SR4
         CI,SR4   X'C200'
         BANZ     MSRCLSX4          BRANCH IF * OR DELETE BUT NOT PRIVATE
         CI,R1    X'18000'
         BANZ     MSRCLSX4          CFU IN M:*
         LI,SR4   X'E0000'          ACTIVITY MASK
         LI,R2    -BGRCFU
         AW,R2    ACNCFU+17
         AND,R2   L(X'1FFF8')
         AI,R2    BGRCFU  POTENTIAL HI CFU TO MOVE TO
CLSX6A   AI,R2    -8
         CW,R2    R1
         BG       CLSX6B            IT LOOKS OK SO FAR
CLSX6C   LI,R2    4                 MOVE BACK TO THE END
         AW,R2    ACNCFU+13
         B        CLSX6D
CLSX6B   CW,R2    ACNCFU+13         RECHECK
         BGE      CLSX6C            OFF THE END
         CW,SR4   0,R2              ANY ACTIVITY?
         BANZ     CLSX6A            BRANCH IF IT'S IN USE
         LCI      8
         LM,R7    0,R1
         STM,R7   0,R2              MOVE CFU
         STW,R1   2,R1              ZAP OLD CFU NAME/ACCT POINTER
CLSX6D   STW,R2   ACNCFU+17
*
MSRCLSX4 EQU      %
*  IF FILE EXTENSION, SWITCH FUNCTION TO OUTIN
         LI,D1    X'10000'
         CW,D1    0,R6
         BAZ      8B1
         LW,D1    Y001
         LW,D2    Y00FE
         STS,D1   FUN,R6
8B1      RES      0
         LW,R2    S:CUN
         LH,SR4   UH:FLG,R2
         AND,SR4  NB31TO0+3         RESET SIGNIF FILE OPN BIT
         STH,SR4  UH:FLG,R2
*
         LI,SR3   X'3F00'
         AND,SR3  RNDEV,R6          GET RNDEV
         LI,SR4   X'1FFFF'
         STS,SR3  DSI,R6            PUT BACK IN DSI FOR NEXT OPEN
*
         B        MSRCLSX2          CLOSE OUT THE DCB
         CLOSE    MSRCLSX4
*
RELRAND   LW,R1   TCFU,R6            RELEASE RANDOM FILE
         LW,SR1   FDA,R1
         CW,SR1   DUMPFILE+3        IS THIS THE SUA FILE
         BNE      RRAND2            NO
         LI,D4    -1                YES - SET SO IT WON'T BE USED
         STW,D4   DUMPFILE
         STW,D4   DUMPFILE+3        ALSO ZAP FDA FOR GOOD MEASURE
RRAND2   LW,D4    TDA,R1            # GRANULES IN FILE
         BEZ      MSRCLSX5          ZERO GRANULE FILE
         LI,R7    DCBPRIVBIT
         CW,R7    0,R6              PRIVATE FILE
         BAZ      RRANDPUB          NO, PUBLIC
         SPACE    2
*D*      NAME:    RRR0
*D*      DESCRIPTION
*DO*
*D*
* RRANDPRI - RELEASE PRIVATE RANDOM FILE
*                 D4 HAS # GRANULES TO RELEASE
*                 R6 HAS DCB ADDR
*                 SR1 HAS FIRST DISC ADDR
*FIN*
         LDCTX,3  8                 SET INITIAL VOLUME #
         LI,9     0                 SET PRIVATE FLAG
*        COMMON ROUTINE FOR ANY CYL ALLOCATED FILE (PUB OR PRIV)
*        9 CONTAINS FLAG - BDR FAILS ON PRIVATE FILES
RRR0     LW,10    15                SAVE TOTAL TO RELEASE
RRR1     BDR,9    %+4
         BAL,R0   SETVNO            SET PV INDICATORS
         BAL,15   SETPVI
         B        %+3
         BAL,3    FNDHGP            SET HGP ADDRESS, BASED ON DISC ADDR IN 8
         BEZ      MSRCLSX5          ERROR, GIVE UP
         INT,4    1,7               GET DCTX, CYLSZ
         AND,5    M8
         BEZ      MSRCLSX5          ERROR, GIVE UP
         AI,8     0                 IF NO DCTX, SET TO SECTOR AFTER NVAT
         BNE      RRR2
         AW,8     5
         CI,8     30                WHICH IS THE FIRST CYLINDER PAST GRAN 29
         BL       %-2
         SLS,8    1
RRR2     LSECTA,11 8                FIGURE IF FILE CROSSES PACK BOUNDARY
         LB,4     DCT22,4
         LW,15    DISCLIMS,4        AND RELEASE ONLY THIS ONE IF SO
         SW,15    11                # SECTORS LEFT HERE
         SLS,15   -1                # GRANS
         CW,15    10                IF FILE ENDS FIRST,
         BL       %+2               ONLY RELEASE IT OF COURSE
         LW,15    10
         AW,15    5
         AI,15    -1
         DW,15    5                 # CYLS TO RELEASE
         BDR,9    RRR3
         BAL,11   RNPVCYL           RELEASE PRIVATE
         BEZ      MSRCLSX5          ERROR, GIVE UP
         AI,3     1                 INCREMENT VOLUME#
         LI,8     0                 START NEXT AT NVART
         B        RRR4
RRR3     BAL,11   RNCYL             RELEASE PUBLIC
         BEZ      MSRCLSX5          ERROR, GIVE UP
         AND,8    DCT%MASK%1
         AI,8     X'10000'          INCREMENT DCTX
         BAL,3    FNDHGP
         LI,3     X'FF'
         CW,3     1,7
         BAZ      %-4
RRR4     MW,15    5                 COMMON CODE - CALCULATE # GRANS RELEASED
         SW,10    15
         BGZ      RRR1              NOT DONE YET
         B        MSRCLSX5          EXIT
*
RRPUB20  RES      0
         LI,R3    0                 ZAP FDA
         STW,R3   GZFDA,R5
         BAL,R0   GZQUS             AND WAIT
RRANDPUB EQU      %                 DO ACCOUNTING FIRST
GZFDA    EQU      0
         DISABLE                    IF FILE IS BEING CLEANED,
         LW,5     GZAPCFU,1         TURN OFF THE CLEANING
         CW,5     GZAPBIT           AND WAIT FOR IT TO FINISH
         BANZ     RRPUB20           THE CURRENT TRACK
         ENABLE
         LDCTX,R5  SR1              DCT INDEX                           DISCB
         LI,R2    0                 ASSUME RAD
         LB,R5    DCT4,R5           DEV TYPE
         CI,R5    7
         BE       %+2               IT IS RAD
         LI,R2    1                 PACK
         LI,R3    PRDCRM+J:JIT
         LW,D1    FUN,R6
         CW,D1    Y0014             CHK OUTIN & OUT
         BAZ      %+4
         LW,SR2   FIL1,R6
         LC       SR2               COUNT AGAINST TEMP IF
         BCR,8    %+2                 RELEASE
         BCR,4    %+2                 OR NOT SAVE (JOB).
         AI,R3    2                 POINT TO TEMP CELLS
         AWM,D4   *R3,R2            INCR JIT VALUES
*
* RRANDPUB  -  RELEASE RANDOM PUBLIC FILE
*        D4 HAS # GRANS TO RELEASE
*        SR1 HAS FIRST DISC ADDRESS
         SPACE    1
         LW,SR2   D4                REMEMBER # TO RELEASE
         BAL,R3   FNDHGP            FIND PROPER HGP
         BEZ      MSRCLSX5          ERROR BAD FDA
         LW,R3    1,R7
         CI,R3    X'8000'
         BANZ     RRPUB30           IT'S CYL
         BAL,SR4  RNBG              IN'S GRANS, RELEASE
         B        MSRCLSX5
*
RRPUB30  LW,9     %                 SET PUBLIC CYL FLAG
         B        RRR0              AND RELEASE IT
         SPACE    3
*
*  ALLOCATE PUBLIC DIRECTORY GRANULES
*
ALLODIR1 LW,SR2   NODUAL
         BEZ      ALLODIR7          BR IF NO DUAL TO BE ALLOCATED
         LI,R0    7                 PREFER RAD
         BAL,SR4  GSBP              GET SEPARATED PAIR
         BEZ      PULLEXIT          OUT OF GRANULES
         CI,R1    FILCFU
         BL       ALLODIR2          ITS THE ACCOUNT DIRECTORY
         LW,SR4   Y018              FILCFU UPDATED AND CYL PRESENT
         CW,SR1   YFF
         BAZ      %+2               NO CYLINDER
         STW,SR4  CYLFLG
         CW,SR2   YFF
         BAZ      %+2
         STW,SR4  CYLFLG
ALLODIR2 STD,SR1  ALLODIRA
         B        ALLODIRC
*
ALLODIR  PUSH     R0                SAVE LINK
         LD,SR1   ALLODIRA
         BEZ      ALLODIR1          NO REMNANTS LEFT
         LW,SR1   SR2               CHK THE DUAL FIRST
         BAL,R2   ALLODIR8          CHK GAVAL & NGAVAL
         AI,SR1   0                 CHK THE PRIMARY NOW
         BAL,R2   ALLODIR8           2NDARY WAS OK
ALLODIRC RES      0
         AI,SR2   0
         BNEZ     %+3               THERE IS A DUAL DISK ADDRESS
         XW,SR2   SR1
         STD,SR1  ALLODIRA          SWITCH MAIN AND DUAL
         AI,SR1   0
         BNEZ     ALLODIR3          GOT BOTH MAIN AND DUAL
ALLODIR7 LI,R0    7                 TRY RAD FIRST
         BAL,SR4  GBG
         BNEZ     ALLODIR4          GOT IT
         LI,R0    X'B'              TRY PACK NEXT
         BAL,SR4  GBG
         BNEZ     ALLODIR4          GOT IT
         BAL,SR4  GCYL              CYLINDER IS LAST RESORT
         BEZ      PULLEXIT          NONE AVAIL
ALLODIR4 STW,SR1  ALLODIRA
ALLODIR3 XW,SR1   SR2
         BAL,R2   ALLODIR5          SET UP THE DUAL
         XW,SR1   SR2
         XW,SR2   ALLODIRA+1
         BAL,R2   ALLODIR5          SET UP THE MAIN
         XW,SR1   ALLODIRA
         STW,SR2  DIGRAN            SAVE DUAL DISK ADDRESS
         LW,R2    TSTACK
         STW,SR2  -15,R2            SET SR2 IN TSTACK
         B        PULLEXIT1         EXIT NORMALLY
*
ALLODIR5 MTB,-1   SR1               CHK NGAVAL
         BNC      ALLODIR6          NOT CYLINDER
         BEZ      ALLODIR6          LAST GRANULE
         LI,R3    1
         MTH,2    SR1,R3            NEXT GRANULE ADDRESS
         BNC      0,R2              IT'S OK
         MTH,-2   SR1,R3            OVERFLOW
         B        INCREMENT%SECTOR
ALLODIR6 LI,SR1   0                 NO MORE IN CYLINDER
         B        0,R2
         SPACE    2
ALLODIR8 BEZ      0,R2              NOTHING IS OK
         BAL,R3   FNDHGP            GET THE HGP HEADER
         BEZ      ALLODIR1          ERROR
         LW,R3    1,R7              GET CYL & NGC
         CW,R3    ATCYLBIT          IS IT CYLINDER
         BAZ      ALLODIR1          BRANCH IF BAD
         AND,R3   M8                ISOLATE NGC
         CB,R3    SR1               CHK NGAVAL
         BLE      ALLODIR1          IT'S BAD
         AND,SR1  M24               GET GAVAL
         BAL,SR4  FMCHKDA           VERIFY DISK ADDR
         BCR,15   ALLODIR1          BAD NEWS
         LD,SR1   ALLODIRA          RELOAD THE PAIR
         B        0,R2              GOOD RETURN
         SPACE    3
*  AN INPUT OR UPDATE FILE IS BEING CLOSED, BUT THERE IS
*  A SECONDARY CFU SPECIFIED.
MULTIPLE LW,D2    0,R1              CURRENT CFU
         CI,D2    X'C000'           CHK 4 SHARED OR RANDOM
         BAZ      8D1               BRANCH IF NEITHER
         LW,D3    1,R5              SCFU 1ST WORD
         CW,D3    Y00FE
         BANZ     8D1               THERE'S STILL A USER
         CI,D2    X'400'            LOOK 4 UPDATE
         BANZ     MULT1             WE GOT IT
         LW,R2    SCFU,R1           SWITH CFU
         LI,R3    X'1FFFF'           TO THE
         STS,R2   CFU,R6              OUTPUT ONE
         LI,R3    -X'20000'         ADJUST
         AWM,R3   0,R1               THE
         LI,SR1   X'20000'            COUNTS
         AWM,SR1  0,R2                 OF USERS
         B        4D1  START OVER WITH UPDATE CFU
*
MULT1    LI,R2    0
         STW,R2   1,R5              BLITZ THE 2NDARY
         STW,R2   3,R5              AND ITS NAME
         MTW,-1   C:CFU             DECR # OPEN CFUS
         LI,R3    X'FFFF'           ERASE THE
         STS,R2   SCFU,R1            2NDARY POINTER
         STS,R2   SCFU+1,R5         CLEAR OTHER SCFU POINTER TOO
         CI,D2    X'4000'           CHK 4 RANDOM
         BANZ     MULT2              SKIP IF IT IS
         LW,R2    SREC+1,R5         GET SIZE CHANGE
         LW,R3    M24
         STS,R2   CLK,R6            SET IT INTO DCB
MULT2    RES      0
         B        MULTR
         PAGE
CLSFIL2M STS,R2   0,R1              RESET THE REL BIT
9A2      RES      0
         CW,D1    Y0014             OUTPUT & SHARED
         BANZ     CLSX5CP1           IS A NO-NO
         SPACE    2
*F*      NAME:    CLSFIL1
*F*      PURPOSE  TO CLOSE AND SAVE A FILE
CLSFIL1  AND,R7   M8                CFU:SLIDES
         CW,D1    Y0014             CHK CREATE NEW FILE
         BANZ     CLSFIL4
         BDR,R5   MULTIPLE
MULTR    LI,R4    X'700'            SPECIAL CLOSE FUNCTION FOR CFU
         LI,R5    X'8F00'           RESET SHARE &
         STS,R4   0,R1               FORCE FUNCTION
         LC       *R1
         BCR,2    NOMULI-1
         LI,R5    LSLIDES
         CB,R7    *R6,R5
         BLE      NOMULI
         BAL,R5   CLSFILC           BUILD A MUL
NOMULI   RES      0
         BAL,R0   JOBSTAR           CHK FOR JOB OR * FILE
         LW,R2    TCFU,R6
         BAZ      9A3               SKIP IF NOT JOB OR *
         LW,R2    0,R2
         CW,R2    Y06
         BANZ     CLSIN             READ FIT IF WRITTEN
         B        CLSFIL2           GET OUT IF NO WRITES
         SPACE    2
9A3      LW,D1    DESC,R6
         CW,D1    Y004              IS IT A NEW SYNON
         BANZ     CL5               BRANCH IF SO
         BAL,R0   PRIVDCB           NO DESCRIPTORS
         BANZ     CLSINUP            FOR PRIVATES
         LI,D1    X'11'
         BAL,R5   LOCCODEA
         B        CLSINUP           NO DESC IN DCB
         LW,R5    *R7,R3
         CW,R5    Y008
         BANZ     SLCLSU            CHANGE DYNAMICS
*
*  THIS PATH CLOSES AN UPDATE OR INPUT DCB BY READING THE FIT
*  DIRECTLY, I.E. WITHOUT A DIRECTORY SCAN.
*
CLSINUP  RES      0
         LW,R2    TCFU,R6
         LW,R2    0,R2
         CW,R2    Y06
         BAZ      CLSIN2            IT'S INPUT ONLY
         BAL,R0   PRIVDCB           NO DESCRIPTORS
         BANZ     7G2                FOR PRIVATES
         LI,R3    4*DESC+1
         LB,SR1   *R6,R3            GET DYNAMIC FLAGS
         AI,SR1   -X'8F'
         BE       7G2               SKIP IF DRCTRY NOT REQ'D
         AI,SR1   -X'20'            IS IT AN OLD SYNON
         BE       CLSIN              JUST POST JIT CHANGES
SLCLSU   RES      0
*
*  A DIRECTORY SEARCH IS REQUIRED.
*
         BAL,R0   FINDFIL1
         B        CLSFIL5M
         LW,R0    Y006
         CW,R0    DESC,R6
         STCF     SYNFLAG           BANZ IF SYNON
         BAL,R0   PRIVDCB
         BANZ     CL2PR
         BAL,R0   BLDESC            BUILD DESCRIPTORS IN DESC
         LI,SR2   X'40'
         STS,SR2  DESC,R6           'DO DYNAMIC' FLAG ON
CL2PR    EQU      %
         BAL,R0   FINDFILS
         B        CL5               NEW SYNON
         LC       SYNFLAG           CHECK FOR SYNON
         BAZ      CL2NS             NOT SYNON
CL2SYN   EQU      %
         BAL,R0   FINDFIL1
         B        CLSFIL5M
         BAL,R0   FINDFILINT
         B        9A13              CHK FOR SYNON RELEASE
CL2NS    EQU      %
*  UPDATE THE FIT ENTRIES
         LI,D2    X'30'
         CS,D2    ORG,R6            IS IT RANDOM?
         BE       UPD09             YES - DON'T UPDATE SIZE OR CFU INFO
*                                   SET UP FOR DISK ADR ROUTINE
*                                   UPDATE FILE SIZE
         LI,D1    KD
         BAL,R5   LOCCODEB
         B        UPDFSIZ
         LW,R2    CLK,R6
         SLS,2    9                 SIGN
         SAS,R2   -9                 EXTENSION
         AWM,R2   *R7,R3            ADD NEW SIZE
         AI,R2    0
         BEZ      UPDFSIZ           NO CHANGE TO FIT
         BAL,R0   SETUD             SET UPDATED FLAG
UPDFSIZ  EQU      %
         BAL,R0   DSKADRA           SET UP CHANGES IN DA
*
UPD09    EQU      %
         BAL,R5   LOCCODEC
         B        9A13              CHK FOR SYNON RELEASE
         AW,R3    R7
         AI,R3    2
         LW,R4    DESC,R6
         SLS,R4   -8
         LI,R5    X'8F00'
         CS,R4    0,R3              CHECK IF ANY CHANGE
         STS,R4   0,R3              SET IN CASE OF CHANGE
         BE       %+2
         BAL,R0   SETUD             CHANGE - SET UPDATED FLAG
         SLS,R3   1
         LI,R2    HAPBD
         LH,R2    *R6,R2
         LW,R4    R2
         BEZ      8B2               NO CHANGE
         AH,R2    0,R3              UPDATE SYNON COUNT
         STH,R2   0,R3
         BAL,0    SETUD             FORCE WRITEOUT
8B2      RES      0
         SPACE    2
*D*  NAME:         DATEUP
*D*
*D*  REGISTERS:    ALL VOLATILE
*D*
*D*  CALL:         BAL,R0
*D*
*D*  DESCRIPTION:  IF * FILE, WRITE FIT IF UPDATED AND EXIT.
*D*                OTHERWISE, SET ACCESS DATE TO CURRENT DATE
*D*                UNLESS NO READS OR WRITES WERE DONE.
*D*                SET BACKUP DATE IF SPECIFIED IN DCB.
*D*                IF WRITES WERE DONE, SET EXPIRATION AND
*D*                MODIFICATION DATES.
*D*                WRITE FIT OUT IF MODIFIED.
         BAL,R0   JOBSTAR
         BANZ     CLSFIL5M          WE'RE DONE IF * OR JOB
         LW,R1    TCFU,R6
         LW,R2    0,R1
         CW,R2    Y03               DON'T CHANGE ACCESS DATE IF NO
         BAZ      BACKUPIN            READS OR WRITES
*                 ACCESS DATE
         LW,R2    Y04
         AND,R2   NOACUP,R6
         BNEZ     BACKUPIN          'NO ACCESS UPDATE' SET
         LI,D1    X'F'              ACCESS DATE VLP
         BAL,SR1  GETDATD           FROM DCB
         BAL,SR1  ACCCUR            SET SR1TO RETURN HERE
         LI,D1    X'F'
         BAL,R0   SETFIDATE         SET IT INTO FIT
         B        BACKUPIN
ACCCUR   EQU      %
         AI,R1    0                 VLP WITH NO DATA
         BNE      DTTMSET       NO...RETURN TO ACCIN1 W/CURRENT DATE
*                NOW DO BACKUP DATE
BACKUPIN EQU      %
         LI,D1    X'10'
         BAL,SR1  GETDATD
         BAL,SR1  BACCUR            SET SR1 FOR RETURN HERE
         LI,D1    X'10'
         BAL,R0   SETFIDATE
         B        EXPDAT
BACCUR   EQU      %
*                 BU VLP W/NO DATA SAYS SET TO CURRENT DATE
         AI,R1    0
         BE       DTTMSET           VLP=0,GET CUR DATE & RET BACKIN1
*                NEXT..EXPIRATION DATE
EXPDAT   EQU      %
         LW,R1    TCFU,R6
         LW,D1    Y02
         CW,D1    0,R1              WERE ANY WRITES DONE
         BAZ      UPFIT             NO, DON'T CHANGE EXP AND MOD DATES
         BAL,R5   DOEXPDAT
*                 MODIFICATION DATE
         LI,D1    X'A'
         BAL,SR1  GETDATD
         B        CURMOD
         LW,D2    D1
         B        SETMOD
CURMOD   EQU      %
         BAL,SR1  DTTMSET
         LW,D2    TIME
SETMOD   EQU      %
         LI,D1    X'A'
         BAL,R0   SETFIDATE
*
*  PROCESS FIT MODIFICATION OPTIONS ON M:CLOSE CAL
UPFIT    LI,R2    X'100'
         CW,R2    0,R6              ARE FIT MODS DESIRED
         BAZ      8B4               NO
         LW,R2    TSTACK
         AI,R2    -1
         CW,R2    1,R2              SEARCH FOR STACK MARKER
         BNE      %-2
         LW,R4    -4,R2             GET FPT ADDR
         LW,R3    0,R4
         BAL,R0   PRIVDCB           IF NOT PRIVATE FILE,
         BAZ      CLSDOMODS           DO THE FIT MODIFICATIONS.
         STW,R3   J:BASE+11         SAVE REGISTERS TO BE CREAMED.
         STW,R4   J:BASE+10
*
         BAL,R0   CLRBBUF           CLEAR BUFF1 AND
         BAL,R0   GETBBUF             GET IT BACK.
*
         LI,R3    X'100'            SAVE CONTENTS OF BUFF2 IN BUFF1
         LD,R0    BUFF2-2,R3          SINCE BUFF2 WILL BE DESTROYED
         STD,R0   BUFF1-2,R3          BY PVAD READ.
         BDR,R3   %-2
*
         BAL,R5   CLSGETPVFDA       GET FDA AND PAX.
*
CLSFITMODRTN  BAL,R5 CLSMOV1TO2     MOVE BUFF1 CONTENTS TO BUFF2.
*
         BAL,R0   CLRBBUF           GET RID OF BUFF1.
*
         LW,R3    J:BASE+11         RESTORE R3 AND R4.
         LW,R4    J:BASE+10
*
         STW,D1   J:BASE+11         SAVE FDA AND PAX FOR MUL(FITMOD).
         STB,R2   J:BASE+11
*
CLSDOMODS EQU     %                 DO THE FIT MODIFICATIONS.
         OVERLAY  MULSEG,7
         B        CLSFIL5M          TO GET OUT
         SPACE    2
8B4      RES      0
         LW,D1    Y002              IS MI MODIFIED?
         CW,D1    MIUD,R6
         BAZ      %+2
         BAL,R0   CLRBFUB           WRITE IF SO
         CI,R4    K1
         BNE      CL2B
         B        CL10
*
CL5      STCF     SYNFLAG
         BAL,D2   GETFUN
         CI,D1    1
         BANZ     CLSFIL5M
         LI,R0    K1
CL2A     EQU      %
         LI,R1    HAPBD
         STH,R0   *R6,R1
         B        CL2SYN
*
9A13     LI,R2    HAPBD
         LH,R4    *R6,R2            CHK FOR SYNON RELEASE
CL2B     EQU      %
         CI,R4    KN1
         BNE      CLSFIL5M          BRANCH IF NO SYNONS
         LI,R0    CL6A-1
FINDFILS INT,R3   FLD,R6
         AW,R3    FLP,R6
         B        FINDFILI
         SPACE    2
7G2      LI,R0    X'100'            CHK FOR FIT MODS
         CW,R0    0,R6
         BANZ     SLCLSU            SLOW CLOSE FOR CHANGES
CLSIN    RES      0
         LW,R1    CFU,R6            GET CFU ADDRESS
         LW,D1    SREC,R1           RANDOM FIT
         LI,D2    0                 LINK CHK
         LI,R3    X'30'
         CS,R3    ORG,R6            CHK IF RANDOM
         BE       CLSIN1
         LW,D1    FDA,R1            FIT FOR NON RANDOM
         B        CLSIN1
         SPACE    2
7G0      LI,R0    X'8000'           FIT PRESENT BIT
         CW,R0    BUFF2+NAVX
         BANZ     7G1               WE GOT IT
         LI,R0    X'20'             CHK FOR CONSEC
         CW,R0    ORG,R6
         BAZ      7G1               OK FOR CONSEC
         LW,D1    BUFF2+FLINK
         LW,D2    DCBCDAM,R6
CLSIN1   BAL,R0   REDSECL           READ THE FIT
         B        7G0
         SPACE    2
7G1      LW,R7    CFU,R6
         LW,D1    Y06               NEED TO UPDATE FIT?
         CW,D1    0,R7
         BAZ      8B2               NO WRITES, DATES ONLY
         LW,R0    Y006
         CW,R0    DESC,R6
         STCF     SYNFLAG           SAVE SYNON STATE
         B        CL2NS
         SPACE    2
CLSIN2   LI,D1    X'10'             BACKUP DATE
         BAL,SR1  GETDATD           IS THERE ONE?
         B        %+2               SKIP IF NOT
         B        CLSIN             MUST PROCESS DATES
         AI,R1    0                 CHK FOR VACANT VLP
         BE       CLSIN  MUST SET BACKUP TO CURRENT TIME
         LW,R2    TCFU,R6
         LW,R0    0,R2              TO CHK ACTIVITY
         CW,R0    Y03
         BAZ      CLSFIL5M          NO ACTIVITY
         LW,R0    Y04               CHK THE NO ACCESS
         CW,R0    NOACUP,R6          DATE UPDATE FLAG
         BANZ     CLSFIL5M          NOTHING TO DO
*****    CHANGE THE NXT INSTR TO    B  CLSIN     *******
*****    TO PROCESS ACCESS DATE UPDATES          *******
         B        CLSFIL5M DON'T PROCESS ACCESS DATE FOR READ ONLY
         PAGE
*  CLOSE AN OUT OR OUTIN FILE.
*
CLSFIL4  EQU      %
         CI,SR1   K2                SAVE OP MUST BE SPECIF ON CLE
         BAZ      CLSFIL5
         LW,SR1   FIL1,R6
         BGEZ     CLSFIL5
*
*                                   INPUT FILE
         LI,SR3   X'51'
         BDR,R5   CLERX1            CLOSED IN WRONG ORDER
*
*E*  ERROR:        51-00
*E*
*E*  DESCRIPTION:  ATTEMPT TO CLOSE OUTPUT FILE WITH SAVE WHEN THE
*E*                OLD COPY IS STILL OPEN IN.
*
         LI,SR2   X'30'             CHK FOR RANDOM
         CS,SR2   ORG,R6
         BE       6A1               BRANCH IF RANDOM
         LI,SR1   X'400'            INHIBIT NEW USERS BY
         LI,SR2   X'F00'             FORCING CFU FUNCTION
         STS,SR1  0,R1                TO UPDATE
         BAL,R5   CLSFILD           BUILD A MUL
*  WHEN CREATING A NEW FILE, FIRST BUILD & WRITE THE FIT.
*F*      NAME:    CLSFIL4
*F*      PURPOSE  CREATE A NEW FILE
         LW,D1    FDA,R1            FOR THE FIT
         BNEZ     7A1               OK
         B        CLERX             BAD NEWS
*  WRITE THE FIT OUT NOW
6A1      RES      0
         BAL,0    GZQUS             CHECK FOR CLEANING AND WAIT IF SO
         B        GZBREAK           ABORT CLOSE IF BREAK, ETC.
         BAL,R0   GETBUFM           GET A BUFF2
         LW,D1    SREC,R1           FIT DISK ADDRESS
         STW,D1   DCBCDAM,R6
         LI,R3    0
         LI,R2    X'4000'           FIT FLAG
         LD,R0    DOUBLEZERO
         LCI      4
         STM,R0   BUFF2
         B        7A2               BUILD THE FIT
GZBREAK  BDR,11   CLSFIL5           RELEASE FILE IF MONITOR CALL
         B        GZREEX            REEXECUTE CAL IF USER
         SPACE    3
7A3      BAL,R0   WRTSEC            WRITE OUT THE FIT
         STW,1    TCFU,6
         BAL,R0   FINDFIL1
         B        CLSFIL4A          FILE DOESNT EXIST
*                                   FOUND ACCOUNT NO
*                                   CAN FILE BE FOUND
CL10     EQU      %
         BAL,R0   PRIVDCB
         BANZ     CL10P
         BAL,R0   BLDESC            (RE)BUILD DESC
         LI,SR2   X'60'
         STS,SR2  DESC,R6
CL10P    EQU      %
         BAL,R0   FINDFILS     SEARCH THE FILE DIRECTORY
         B        CLSFIL4B          DIDNT FIND FILE
*                                   CREATING NEW SYNONYMOUS
         SPACE    2
*F*      NAME:    CL10
*F*      PURPOSE
*DO*
*F*
*  CREATING A NEW FILE OVER A PREVIOUSLY EXISTING FILE WITH
*  THE SAME I.D.
*FIN*
         LW,SR4   BUFF2
         BLZ      CLSFIL2           COULDN'T READ FIT
         BAL,R5   LOCCODEC
         B        CLSFIL2
         AW,R3    R7
         LW,SR4   2,R3
         LW,R4    TCFU,R6
         LI,R5    K1FFFF
         STS,R4   CFU,R6
         LW,D1    -2,R3             LDA
         STW,D1   LDA,R4
         LW,D1    -5,R3             O BIT
         LW,D2    Y2
         SLS,D1   14
         STS,D1   0,R4
         LW,D1    -7,R3             TDA
         STW,D1   TDA,R4
         LW,D1    -8,R3             FDA
         STW,D1   FDA,R4
         LW,R3    0,R3              ORG,KEYM
         SLS,R3   -16
         LI,R2    BAKEYM
         STB,R3   *R6,R2
         SLD,R2   28
         LI,R3    X'F0'             PUT ORG IN DCB
         STS,R2   ORG,R6              FOR RELEASE
         LW,D2    Y1                SET RELEASE
         STS,D2   0,R4
         LH,D2    SR4               RELEASE SYNON FILES
         BEZ      CLSFIL2
         BAL,R0   CLRBFUB          GET RID OF FIT BEFORE CHANGING CFU
         LI,D3    BUFF2
         LI,R0    CL6-1             RETURN
2A0      LI,R2    FILCFU
         LI,R3    K1FFFF
         STS,R2   CFU,R6
FNESCR   EQU      2A0
2A1      LI,R3    FNEMAX
         LI,R2    X'29'             FILE DIR ENTRY LENGTH
         STW,R2   IMT,R6            SET IMT FOR DIRECTORY
SETSCR   LI,R2    BASCR
         STB,R3  *R6,R2
         B       *R0
         PAGE                       SAVE ACCOUNT NO
CLSFIL4A EQU      %                 DIDNT FIND ACCOUNT NO
*                                   INSERT ACCOUNT NO.
*                                   CREATE NEW FILE DIRECTORY
*
*F*      NAME:    CLSFIL4A
*F*      PURPOSE  CREATE A NEW FILE DIRECTORY
*
         BAL,R0   CLRBFUB           WRITE OUT AD IF UPDATED
         LI,D1    X'F4008'          NEW DIRECTORY FLAG
         STW,D1   ACNCFU
         LI,R0    0                 SET UP FILCFU FOR A NEW FILE DIR.
         STW,R0   FILCFU+FSP
         STW,R0   FILCFU+GAVAL
         STW,R0   CYLFLG
         MTB,1    CYLFLG            SET FILCFU INFO UPDATED
         BAL,R0   GETCMD
         STW,R3   FILCFU            RESETS PRIV
*                                   IS IT :SYS?
         BAL,R0   GETDGRAN          GET A PAIR
         BEZ      CLERX             OUT OF GRANULES
         STW,SR2  FILCFU+DFDA       DUAL DA
         STW,SR1  FILCFU+CDAM
         OR,SR1   Y8                SET EMPTY FILE FLAG FOR INST
         STW,SR1  FILCFU+FDA
         BAL,R0   2A0
         BAL,R0   GETBUFM           GET BUFFER FOR M.I.
         LD,SR3   DOUBLEZERO
         LW,D1    TWRD
         LCI      3
         STM,SR3  BUFF2
         BAL,R0   SETCMD            SET CMD = MIDIS
         BAL,R0   WRTSEC            WRITE OUT FD FDA
         BAL,R0   BLDESC            BUILD DESCRIPTORS IN DESC
         PAGE
*  CREATE A NEW ENTRY IN THE FILE DIRECTORY
CLSFIL4B  EQU     %
*F*      NAME:    CLSFIL4B
*F*      PURPOSE  CREATE A NEW ENTRY IN A FILE DIRECTORY
         LW,R1    TCFU,R6
         LW,D1    FDA,R1
         LI,D2    X'30'
         CS,D2    ORG,R6
         BNE      4B2               IT'S NOT RANDOM
         LW,D1    SREC,R1           FIT LOC
4B2      RES      0
         AND,D1   M31
         LI,R0    X'40000'
         CW,R0    NXTA,R6
         BANZ     CLSFIL2           ITS A STAR
         BAL,R0   2A1
         INT,R7   FLD,R6
         AW,R7    FLP,R6
         LW,R5    KBUF,R6
         LCI      8
         LM,D2    0,R7
         STM,D2   0,R5              MOVE FILE NAME TO KBUF
EPWRT    LI,R0    CLSFIL4P          RETURN ADDRESS
EPWRT1   PUSH     R0
         PUSH     D1                SAVE DISK ADDRESS
         LI,D1    0
         BAL,R0   SAVBLK
         OPEN     NLR
NLR      EQU      16
         LI,R1    X'20000'          SET NLR
         STS,R1   NLR,R6
         BAL,SR4  ENTER1            UPDATE DIRECTORY
         BAL,R4   GETTYC
         PULL     D1                RESTORE DISK ADDRESS
         CI,R3    X'A'
         BE       PULLEXIT          OUT OF GRANULES
         BAL,R0   GETCMD
         AI,R3    -9
         CI,R1    FILCFU
         BL       CLSFIL4Z          IT'S ACCOUNT DIRECTORY
         LI,SR4   4
         BAL,R0   CLSFIL4Y          INSERT DISK ADDRESS
         BAL,R0   PRIVDCB
         LI,R0    0
         BANZ     CLSFIL4R
         LW,R0     DESC,R6          MOVE INTO FD ENTRY
         SCS,R0   16
         OR,R0    X80               FORCE FLAG ON
         STB,R0   BUFF2,R3          SET DYNAMIC
         SCS,R0   8
CLSFIL4R LI,R1    HAPBD
         LH,R1    *R6,R1
         BLEZ     %+2               NOT A NEW SYNON
         OR,R0    X40               FLAG NEW SYNON
         AI,R3    1
         STB,R0   BUFF2,R3          SET STATIC
         B        PULLEXIT1         NORMAL EXIT
CLSFIL4P B        CLERX             ERROR EXIT
         B        CLSFIL14          NORMAL EXIT
*
CLSFIL4Z SCS,D1   8
         LI,SR4   3
         BAL,R0   CLSFIL4Y          INSERT MAIN DISK ADDRESS
         LW,D1    FILCFU+DFDA
         SCS,D1   8
         LI,SR4   3
         LI,R0    CLSFIL5M          SET RETURN
*
CLSFIL4Y SCS,D1   8
         STB,D1   BUFF2,R3
         AI,R3    1
         BDR,SR4  CLSFIL4Y
         B        *R0
       PAGE
*  BUILD A NEW FIT.
*F*      NAME:    7A1
*F*      PURPOSE  BUILD A NEW FILE INFORMATION TABLE(FIT).
7A1      LI,D2    0                 4 LINK TEST
         BAL,R0   REDSECL           READ THE FIT GRAN
7A2      RES      0
         BAL,R0   BLDESC            SET UP THE DESCRIPTORS
*        ENTER FILE NAME
         LI,D1    1
         BAL,5    LOCCODEA
         B        CLSFIL5M          NAME LOST, GET OUT
******      NAME ENTRY WITHOUT VLP CONTROL WORD.
         LCI      8                 PICK UP THE NAME
         LM,SR1   *R3,R7
         LI,R2    (MIDIS+4)/4+9     ASSUME CONSEC
         LI,R1    X'20'
         CW,R1    ORG,R6
         BAZ      4B5               IT IS
         LI,R3    X'8000'           SET THE FLAG
         STS,R3   BUFF2+2
         LI,R2    NWFITST+9
4B5      LI,R0    0                 FOR 9TH WORD
         LCI      9
         STM,SR1  BUFF2-9,R2        NAME TO FIT
         LI,D3    BUFF2
         LI,R3    X'40000'
         CW,R3    NXTA,R6
         BANZ     6C1               IT'S A * FILE
         LW,R3    YC                CHK FOR NEW
         CS,R3    FIL1,R6            JOB FILE
         BE       4B6               BRANCH IF IT IS
         STW,R2   J:BASE+6          SAVE POSITION
         LI,R4    #VLPCODE          # VLP CODES TO PROCESS NOW
FIL2     PUSH     R4
         LB,D1    VLPCODE,R4        GET NEXT CODE
         BAL,R5   LOCCODEA          LOOK FOR IT IN DCB
         B        FIL4              NOT THERE
         LW,SR1   *R7,R3            FOUND - GET FIRST DATA WORD
         B        %,R4
         B        VLPEX             EXECUTE VEHICLE
         B        VLPEX             EXECUTE ACCOUNTS
         B        VLPWR             WRITE ACCOUNTS
         B        VLPRD             READ ACCOUNTS
         B        FIL31             PASSWORD
*
VLPWR    CW,SR1   NONE              IGNORE WRITE=NONE
         BNE      FIL3
         CI,R1    4
         BE       FIL3              IT'S AN APL SPECIAL WORK SPACE
         B        FIL9
*
VLPCODE  DATA,1   0,X'15',X'14',6,5,3   ORDER IS IMPORTANT!!!!
#VLPCODE EQU      BA(%)-BA(VLPCODE)-1
         BOUND    4
*
FIL31    LI,R1    2                 FORCE TO 2 WORD ENTRY
FIL3     LW,R0    R1
VLPEX    EQU      FIL3
VLPRD    EQU      FIL3
         LW,SR1   R2
         AW,SR1   R1
         SW,SR1   J:BASE+6
         CI,SR1   40
         BL       FIL8              ENOUGH ROOM
         CI,D1    X'15'
         BNE      %+2
         AI,R1    -1                UNDER ENTRIES ARE 3 WORDS LONG
         AI,R1    -2
         BGZ      FIL3              TRY AGAIN
         B        FIL9              NO ROOM FOR ANY
*
FIL4     CI,D1    5
         BNE      FIL9              NOT READ ACCOUNT
         LC       J:ASSIGN          NO READ ACCOUNT IN DCB - IS THIS
         BCR,1    FIL9                A DEFAULT READ=NONE ACCOUNT
         LI,D1    2
         BAL,R5   LOCCODEA
         NOP                        IGNORE NOT-FOUND RETURN
         LCI      2                 GOT ACCOUNT
         LM,SR1   *R7,R3            GET DCB ACCOUNT
         LM,R4    J:ACCN            AND USER'S ACCOUNT
         CD,R4    SR1
         BNE      FIL9              NOT SAME
         LI,D1    5                 RESTORE VLP CODE
         LI,R0    2
         LI,R3    NONE
         SW,R3    R7
*
FIL8     BAL,SR1  SETENT            ENTER VLPS INTO FIT
FIL9     PULL     R4
         BDR,R4   FIL2
******       EXPIRATION DATE X'04'
         LI,D1    4
         BAL,R0   SETDAT2
         BAL,R5   DOEXPDAT  RESET DATE ACCORDING TO EXP RULES
******       ACCESS DATE X'0F'
         LI,D1    X'F'
         BAL,R0   SETDAT2
******       BACKUP DATE X'10'
         LI,D1    X'10'
         BAL,R0   SETDAT2
******       CREATION DATE X'0E'
         LI,D1    X'E'
         BAL,R0   SETDAT2           2 WORDS FOR CREATION
******       MODIFICATION DATE X'0A'
         LI,D1    X'A'
         LI,D2    3                 3 WORD ENTRY
         BAL,R0   SETDATE
*
******       FILE SIZE X'0D'
6C1      RES      0
         LI,D1    KD                FILESIZE
         LI,R0    K1
         BAL,SR1  SETENT
         LI,D1    X'30'
         AND,D1   ORG,R6
         CI,D1    X'30'             IS IT RANDOM
         BNE      %+3               NO USE 22 BITS
         LW,D1    M24               24 BITS IF RANDOM
         B        %+2
         LW,D1    M22
         AND,D1   CLK,R6            SIZE OF FILE
         STW,D1   BUFF2-1,R2
******       CFU INFORMATION X'0C'
         LI,D1    12                CFU INFO RESERVED
         LI,R0    7
         BAL,SR1  SETENT
*                                   NO O BIT TO START
         STW,R2   BUFF2-4,R2
         LW,R3    TCFU,R6
         LW,SR3   FDA,R3            GET FDA
         STW,SR3  BUFF2-7,R2
         LW,SR3   0,6
         SLS,SR3  -9                CYL
         LI,SR4   X'200'
         LS,SR3   0,6               NOSEP
         SLS,SR3  -8
         LI,R3    BAKEYM
         LB,R0    *R6,R3
         STH,R0   SR3
         LI,R0    X'30'
         AND,R0   ORG,R6            ORG
         BNEZ     %+2
         LI,R0    X'10'             MAKE IT EXPLICIT CONSEC
         SLS,R0   -4
         STB,R0   SR3
         LW,SR4   WRDL0,R6          LSLIDES,LRDL0,SPARE
         LW,D1    DESC,R6           GET THE DESCRIPTORS
         SLS,D1   -8
         AND,D1   M12               SET #SYNONS TO ZERO
         AI,D1    X'8000'
         LW,R7    TSTACK
         PUSH     3,SR3
******       DCB INFO & # OF SYNONS X'09'
*  UPDATE THE ENTRIES IN THE X'0C' ENTRY OF THE FIT.
         LI,D1    9
         MTB,1    D1
         LI,R0    3
         LI,R3    1
         BAL,SR1  SETENT            PUT AWAY FILE ATTRIBUTES.
         BUMP     -3,R0
         LW,R3    R2
         SLS,R3   2
         BAL,R0   SETCMD1
         BAL,R0   SETEOPW
         LI,R0    7A3               SET RETURN
DSKADRA  LI,D1    12
         BAL,R5   LOCCODEB
         B        *0
         LW,R4    TCFU,R6
         AW,R3    R7
         LI,R5    0                 ASSUME NO CHANGES
         LI,SR4   X'60BAD'          BAD CFU FLAG
         LW,SR1   FDA,R4
         LW,SR2   M31
         CS,SR1   0,R3              ONLY THE E BIT MAY CHANGE
         BNE      9A13              CHK FOR SYNON RELEASE
         LCI      7
         LM,R7    FDA,R4            CFU INFO
         STW,SR4  R7+1              MOVE TDA
         AND,SR3  YFFFF             MASK OFF CCBD
         LI,D4    X'FF'
         AND,D4   0,R4              GET SLIDES
         OR,SR3   D4
         LC       *R4
         BCR,2    %+2               O-BIT NOT SET
         AI,SR3   X'8000'           SET O-BIT
         LI,R2    -7
DSKADRC  LW,D4    R7+7,R2           GET FIRST NEW FIT WORD
         CW,D4    0,R3              COMPARE WITH OLD FIT VALUE
         STW,D4   0,R3              STORE NEW IN CASE DIFFERENT
         BE       %+2
         LW,R5    Y002              NOT SAME - PREPARE TO SET MIUD
         AI,R3    1                 ADVANCE TO NEXT FIT WORD
         BIR,R2   DSKADRC
         STS,R5   MIUD,R6           SET UPDATED IF ANY CHANGES
         B        *R0
         SPACE    3
*
DTTMSET  LW,SR4   DATE+1            PUT MMDDHHYY IN SR3,SR4
         LH,SR3   TIME
         STH,SR3  SR4
         LW,SR3   DATE
         B        *SR1
*
4B6      LI,D1    3                 PASSWORD CODE
         LI,R0    1                 1 WORD ENTRY
         INT,SR4  J:JIT+SYSID       USE SYSID FOR USER
         LW,R3    Y01               SET NXTF FOR
         STS,R3   NXTF,R6            TFILE FLAG
         LI,R3    SR4               SET UP
         SW,R3    R7                 POINTER
         LI,SR1   6C1               SET RETURN
*        FALL INTO SETENT
SETENT   EQU      %
         SCS,D1   -8
         AW,D1    R0
         LI,R4    K2
         STB,R0   D1,R4
         STW,D1   BUFF2,R2
         AI,R2    K1
         LW,D2    *R7,R3            TRANSFER
         STW,D2   BUFF2,R2           PARAMETERS
         AD,R2    DOUBLEONE
         BDR,R0   %-3
         B        *SR1
CLSGETPVFDA EQU   %
         PUSH     R5                SAVE RETURN ADDRESS.
         LI,R5    X'1FFFF'          CLOBBER TO FORCE
         STW,R5   FILCFU+CDAM         READ.
         BAL,D4   READPVAD          GET PRIVATE VOLUME AD.
         LI,R5    X'1FFFF'
         AND,R5   CFU,R6            GET CFU ADDRESS
         LW,R5    2,R5                THEN ID WORD.
         SCS,R5   10                GET
         AND,R5   M7                  PAX.
*
         BAL,D4   CHKPAX            CHECK PAX VALUE AND GET FDA IN D1.
         B        CLSERR2100        ERROR RETURN.
         PULL     R5                RESTORE RETURN ADDRESS.
         AI,D1    0                 IF RETURNED FDA IS POSITIVE,
         BGZ      0,R5                ALL'S WELL--PAX IN R2.
         LI,SR1   5                 OTHERWISE ERROR 75-05.
         LW,SR3   D1                PASS FDA TO ERFILDA AND
         BAL,SR4  ERFILDA             LOG ERROR.
         B        CLS7505ERR
*
CLSERR2100 EQU    %
         PULL     R5                CHUCK RETURN ADDRESS.
         CI,R5    CLSFITMODRTN      IF RETURN WAS SUPPOSED TO GO
         BNE      %+2                 TO FIT MOD CODE,
         BAL,R5   CLSMOV1TO2          RESTORE BUFF2.
         BAL,SR4  TRUNC             TRUNCATE BUFFERS,
         LI,SR3   X'2100'             PASS ERROR CODE,
         B        SAVERR              AND ERROR EXIT.
*E*      ERROR    21-00  PRIVATE PACK CONSISTENCY CHECK FAILURE
*E*      DESCRIPTION: A PRIVATE VOLUME ACCOUNT INDEX WAS INCORRECT
*,*               AND COULD NOT BE CORRECTED BECAUSE THE ACCOUNT NUMBER
*,*               WAS NOT IN THE PRIVATE VOLUME ACCOUNT DIRECTORY.
*
********************
CLSMOV1TO2 EQU    %                 MOVES BUFF1 TO BUFF2.
         LI,R3    X'100'            RESTORE BUFF2.
         LD,R0    BUFF1-2,R3
         STD,R0   BUFF2-2,R3
         BDR,R3   %-2
         B        0,5               RETURN.
         TITLE    '****  CLSALL  ****'
         SPACE    2
*F*      NAME:    CLSALL
*F*      PURPOSE: CLOSE ALL USER DCBS
*F*      DESCRIPTION:  USER'S DCB NAME TABLE(S) IS SEARCHED.  ALL
*F*               DCBS FOUND ARE CLOSED WITH DEFAULT OPTIONS
*F*               (EXCEPT M:DO, WHICH IS CLOSED WITH SAVE).
*F*               M:XX MAY ALSO BE CLOSED IF DESIRED.
         SPACE    1
*D*      NAME:    CLSALL
*D*      REGISTERS:  ALL VOLATILE
*D*      CALL:    OVERLAY  CLSSEG,CLSALL#
*D*      INPUT:   R6=M:XX IF M:XX IS TO BE CLOSED
*D*      DESCRIPTION:  IF R6=M:XX, M:XX IS CLOSED.  THE FIRST DCB
*D*               NAME TABLE (POINTED TO BY J:DCBLINK) IS SEARCHED.
*D*               ALL DCBS FOUND ARE CLOSED WITH DEFAULT OPTIONS
*D*               EXCEPT M:DO, WHICH IS CLOSED WITH SAVE.
*D*               PROCESSING CONTINUES UNTIL NO MORE DCB NAME TABLES
*D*               EXIST.  ANY ERRORS ENCOUNTERED ARE IGNORED.
         SPACE    1
CLSALL   LI,SR1   X'15'             FPT CODE
         BAL,R1   PUSHALL
         LI,R2    X'1FFFF'
         AND,R2   J:DCBLINK
         CI,R6    M:XX
         BE       CLSA24            GO CLOSE M:XX FIRST
*
CLSA10   AI,R2    0
         BEZ      CLSAX             DONE
*
         LI,R7    DOUBLEZERO        DEFAULT FPT
         LW,R3    1,R2              FIRST WORD OF DCB NAME
         CW,R3    TXTCMDO
         BNE      CLSA14            NOT M:DO
         LW,R4    2,R2
         LB,R4    R4
         CB,R4    TXTCMDO+1
         BNE      CLSA14            NOT M:DO
         LI,R7    SAVEFPT           CLOSE M:DO WITH SAVE
CLSA14   LB,R4    R3                TEXTC COUNT
         BNEZ     CLSA20            GOT A NAME
         LI,R2    X'1FFFF'
         AND,R2   R3                MUST BE POINTER TO ANOTHER
         B        CLSA10              DCB NAME TABLE
*
CLSA20   SLS,R4   -2
         AI,R4    2
         AW,R2    R4                POINT TO DCB ADDRESS
         LW,R6    0,R2
CLSA24   LW,SR4   Y002
         CW,SR4   FCD,R6
         BAZ      CLSA10            ALREADY CLOSED
         LI,SR1   X'15'             FPT CODE
         PUSH     R2
         BAL,SR4  MSRCLSB
         PULL     R2
         B        CLSA10
*
CLSAX    DESTRUCT MSRWRTX           RETURN TO CALLER
SAVEFPT  PZE      *0
         DATA     2                 SAVE
*
TXTCMDO  TEXTC    'M:DO'
         TITLE    '**** DISC ERRORS ****'
*F*  NAME:         BADA
*F*  PURPOSE:      TO ANALYZE AND REPORT FILE INCONSISTENCIES
*
*D*  NAME:         BADA
*D*
*D*  CALL:         OVERTO  CLSSEG,BADA#   IF X'700' BITS NOT SET IN J:CLS
*D*                OVERLAY CLSSEG,BADA#   IF X'700' BITS SET
*D*
*D*  INPUT:        R4 = OVERLAY NUMBER OF CURRENT OVERLAY BEFORE CALL
*D*                SR4 = RETURN ADDRESS (IF ENTERED VIA OVERLAY)
*D*
*D*                J:CLS
*D*                  X'100' - FIT WAS BEING READ, RETURN TO CALLER IF ERROR
*D*                  X'200' - RETURN TO CALLER IF ERROR
*D*                  X'400' - DON'T LOG ERROR IN ERRLOG IF ERROR
*D*                  BITS 8-15 IF NON-ZERO CONTAIN IN BITS 9-15 THE
*D*                    SUB-CODE TO REPORT.  IF ZERO, A SUB-CODE WILL
*D*                    BE DETERMINED BY THE CFU ADDRESS IN DCB:CFU.
*D*                  BITS 0-6 CONTAIN THE SUBCODE AND BITS 25-31 THE
*D*                    MAJOR CODE OF THE HIGHEST ERROR SO FAR ENCOUNTERED
*D*                    DURING THIS CLOSE CAL.  ZERO IF NOT PROCESSING
*D*                    A CLOSE CAL.  MAJOR CODE FIELD CONTAINS A 1 IF
*D*                    PROCESSING CLOSE CAL BUT NO ERROR YET.
*D*
*D*  OUTPUT:       RETURN TO CALLER OF REDSEC IF ANY OF X'700' BITS
*D*                SET IN J:CLS.  OTHERWISE, GO TO CLSFIL2 IF IN CLOSE
*D*                CAL AND NOT DELETING FILE, MSRCLSX5 IF IN CLOSE CAL
*D*                AND DELETING FILE, OVERTO OPNSEG,1 TO RELEASE CFUS
*D*                IF ERROR DURING OPEN, RELEASE BUFFERS AND EXIT VIA
*D*                MSR01EXIT IF ERROR DURING ANY CAL EXCEPT OPEN/CLOSE.
*D*                IN ANY EVENT, BITS 7-23 OF J:CLS ARE CLEARED.
*
BADA     EQU      %
         STW,R4   J:FDDA            SAVE OVERLAY #
         LW,R3    J:CLS
         CI,R3    X'700'            ARE WE TO RETURN TO CALLER
         BAZ      %+2               NO
         PUSH     SR4               YES - SAVE RETURN ADDRESS
         LW,R1    ='INST'
         CW,R1    J:BASE+4
         BNE      %+2               DIDN'T COME FROM INST
         BAL,SR4  INSTCLNUP         YES - CLEAN UP FIRST
         LI,R0    X'1FFFF'
         AND,R0   CFU,R6
         LW,R1    TSTACK
         LW,R3    J:CLS
         CI,R3    X'700'
         BAZ      %+2
         AI,R1    -1                ACCOUNT FOR LINK IN STACK
         LW,D1    -8,R1             GET D1 FROM REDSEC REGISTERS
         LI,SR1   4                 ASSUME 75-04
         CI,R0    FILCFU
         BG       MI
         STW,R0   FILCFU+ACNDISP    ZAP ACCOUNT
         BE       BADA04            BAD FILE DIRECTORY
         LI,SR1   6                 75-06
         SPACE    2
BADA04   EQU      %
         LI,R7    0
         XW,R7    J:FDDA            PICK UP OVERLAY #
         LI,R3    X'400'
         CW,R3    J:CLS             IS THE ERROR TO BE LOGGED
         BANZ     BADARET           NO
         LW,SR3   D1
         LH,SR4   J:CLS
         AND,SR4  M8
         BEZ      %+2               NO SUB-CODE EXPLICITLY STATED
         LW,SR1   SR4               USE THE SPECIFIED SUB-CODE
         AND,SR1  M7                SCRUB EXTRANEOUS BITS
         BAL,SR4  ERFILDAX          LOG ERROR IN ERRLOG
         LW,SR3   SR1               ERROR
         AI,SR3   X'7500'**-1       ADD IN MAJOR CODE
         SCS,SR3  -7                ALIGN
         LW,R1    J:CLS
         CW,R1    =X'FE00007F'
         BAZ      8A2               NOT IN CLS - DON'T SET J:CLS
         LW,R2    TCFU,R6
         INT,D2   2,R2              NAME/ACCT POINTERS
         BCS,4    8A2               DON'T TELL USER IF ERROR DELETING
         CW,SR3   J:CLS             SAVE WORST ERROR
         BLE      %+2
         STW,SR3  J:CLS
8A2      CI,R1    X'700'
         BANZ     BADARET           RETURN TO CALLER
*
         LW,R1    J:CLS             GET NEW J:CLS IN CASE IT CHANGED
         AND,R1   =X'FE00007F'
         STW,R1   J:CLS             RESET FLAGS
         BEZ      OPERC1            BR IF NOT IN CLS
         LW,1     TCFU,6
         INT,D2   2,R1
         BCS,4    MSRCLSX5          DELETING A FILE
         B        CLSFIL5M  NOT DELETING - EXIT FROM CLS
         SPACE    3
*
*  RETURN TO CALLER OF REDSEC/REDSEC1
*
BADARET  EQU      %
         LW,R3    =X'FE00007F'
         STW,R3   BUFF2             SET ERROR FLAG FOR CALLER
         AND,R3   J:CLS
         STW,R3   J:CLS             RESET FLAG BITS
         PULL     SR4               RETURN ADDRESS
         B        *SR4              RETURN TO REDSEC IN RDF
*
MI       LI,SR1   3                 ASSUME 75-03
         CI,R0    FITCFU
         BE       BADA04            CORRECT
         LW,D1    DCBCDAM,R6
         LI,SR1   0
         LI,1     6                 # OF STAR FILES
         CW,D1    J:STAR-1,1
         BNE      %+2
         STW,SR1  J:STAR-1,1
         BDR,1    %-3
         LI,SR1   2                 75-02
         B        BADA04
         SPACE    3
*
OPERC1   EQU      %
         LW,SR4   Y002
         CW,SR4   0,R6              IS IT OPENED
         BANZ     OPERC2
         OVERTO   OPNSEG,1
OPERC2   RES      0
         STW,SR3  J:CLS             SAVE ERROR CODE
         LI,SR3   0
         LW,SR4   Y006
         STS,SR3  MIUD,R6           RESET BUFFER UPDATED FLAGS
         BAL,SR4  TRUNC             GET RID OF BUFFERS
         LI,SR3   0
         XW,SR3   J:CLS
         B        2B0               GET OUT
         PAGE
         SPACE    2
*
*F*      NAME:    ERFILDA
*F*      PURPOSE  TO BUILD AN ERRLOG ENTRY FOR  A 75 ERROR
*F*      DESCRIPTION
*DO*
*F*
*  PURPOSE:  BUILD ERRLOG ENTRY FOR I/O ERROR 75
*
*  INPUT:  R6 = DCB ADDRESS
*          SR1 = SUB-CODE
*          SR3 = DISC ADDRESS
*
*  CALL:   BAL,SR4  ERFILDA
*
*  REGISTERS SAVED:  R6-SR4
*FIN*
*
ERFILDA  BLOCK                      MAKE SURE ON MASTER
         LW,R7    S:CUN
         LB,R7    UB:OV,R7          OVERLAY # OF CLS FOR FREPORT
ERFILDAX EQU      %
         LW,R3    Y00FE
         LW,R2    Y001
         CS,R2    TYC,R6            CHECK TYC FOR I/O ERROR
         BNE      ERFIL10           NO
         OR,SR1   X40               YES - CHANGE SUB-CODE
         LI,R2    0
         STS,R2   TYC,R6            RESET TYC
*
ERFIL10  EQU      %
         STB,SR1  SR3               MAKE SUB-CODE PART OF DISC ADDR
         LI,R5    6
         CW,SR3   75TABLE-1,R5      CHECK IF DA PREVIOUSLY REPORTED
         BE       *SR4              YES
         BDR,R5   %-2
*
         LI,R5    -5
         LW,R4    75TABLE+6,R5      SHIFT TABLE DOWN
         STW,R4   75TABLE+5,R5
         BIR,R5   %-2
         STW,SR3  75TABLE+5         ENTER LATEST ENTRY
*
         AND,SR3  M24               SCRUB SUB-CODE FROM DISC ADDRESS
         PUSH     6,R6
         CI,SR1   X'7F'
         BE       BLDERR            DON'T WAKE FIX IF HARDWARE ERR
         LW,R5    LFGUN             USER # OF LFG
         BLEZ     BLDERR            NOT THERE
         CW,R5    S:CUN             DON'T WAIT IF THE LFG
         BE       BLDERR              GOT THE 75 ERROR
         LW,R4    S:CUN
         LB,R4    UB:APR,R4         THIS USER'S SHARED PROCESSOR
         LD,SR3   P:NAME,R4         NAME OF PROCESSOR
         CW,SR3   TXTFIX            IS IT FIX
         BE       BLDXIT            YES - DON'T LOG AN ERROR
         LW,R4    75BUF
         SCS,R4   8                 CHECK IF ROOM
         CI,R4    X'FF'               FOR ANOTHER USER #
         BANZ     BLDERR            NO
         OR,R4    S:CUN             YES - ENTER USER #
         STW,R4   75BUF
         LI,R6    E:CBK             REPORT BREAK EVENT FOR LFG
         BAL,SR4  T:RUE               (R5 HAS USER #)
         LW,R4    S:CUN
         LI,R6    25                SLEEP 15 SECONDS
         STW,R6   U:MISC,R4
         LI,R6    E:SL
         BAL,SR4  T:REG             WAIT UNTIL GHOST FINISHES
*
*  BUILD ERRLOG ENTRY
*
BLDERR   EQU      %
         LW,R1    TSTACK
         LCI      5
         LM,R6    -5,R1             RESTORE REGISTERS
*
         LI,R4    X'F0'
         AND,R4   ORG,R6            ORGANIZATION OF FILE
         SLS,R4   12                PUT IN LEFT HW
         LW,R5    Y00FE
         AND,R5   FUN,R6
         SLS,R5   -17               FUNCTION
         OR,R4    R5                R4 = (ORG,FUN)  (16,16)
         LI,D1    1
         BAL,R5   LOCCODEA          FIND FILE NAME IN DCB VLP
         NOP
         LW,D4    R7
         AW,D4    R3                SAVE LOCATION OF NAME
         LI,D1    2
         BAL,R5   LOCCODEA          FIND ACCOUNT
         NOP
         LW,R1    BLANKS            NO ACCOUNT IF OUT/OUTIN REL
         LW,R2    BLANKS
         CI,R4    X'A'
         BAZ      BLD4              IN/INOUT, ACCOUNT EXISTS
         MTW,0    FIL1,R6
         BGEZ     BLD5              RELEASE - THERE IS NO ACCOUNT
BLD4     LCI      2
         LM,R1    *R7,R3            PICK UP ACCOUNT
BLD5     LW,R3    SR3               BAD DISC ADDRESS
         LI,SR3   DCBPRIVBIT
         CW,SR3   PRIV,R6
         BAZ      BLD7              BR IF PUBLIC
         LI,R7    BAVDCTX
         LB,SR3   *R6,R7            GET DCT INDEX
         LI,SR4   X'3F'
         SLD,SR3  16
         STS,SR3  R3                CONVERT VOL # TO DCTX
BLD7     LI,SR3   X'3F'
         AND,SR3  SR1               ERROR CODE MINUS I/O ERROR FLAG
         LI,R7    #NAMERR
         CB,SR3   NAMERR,R7         SHOULD FILE NAME BE PUT IN ERRLOG
         BE       BLD8              YES
         BDR,R7   %-2
         LI,D4    TXTBLNK           GET BLANKS FOR FILE NAME
BLD8     LCI      8
         LM,SR2   *D4               MOVE FILE NAME
         LW,R7    SR1               SUB-CODE
         SLS,R7   1
         OR,R7    FICODE            ADD MAJOR CODE
         LI,R6    R7                MESSAGE ADDRESS
         BAL,R5   ERRLOG            LOG IT
BLDXIT   PULL     6,R6
         B        *SR4
         SPACE    2
FICODE   DATA     X'1A0E7500'       ERRLOG CODE/COUNT, ERR CODE
TXTFIX   TEXTC    'FIX'
TXTBLNK  TEXTC    ' '               DUMMY FILE NAME
NAMERR   DATA,1   0,1,2,3,7,X'3D'   SUB-CODES THAT PERTAIN TO A FILE
#NAMERR  EQU      BA(%)-BA(NAMERR)-1
         CLOSE    CLSFIL2
         TITLE    '************ CLS *********'
         END

