MONPROC  SET      1
ANSPROC  SET      1
DISCBPROC SET     1                                                     DISCB
         SYSTEM   UTS
SYN      SET      1
         PCC      0
CLS      EQU      %
FCTRL    CNAME
         PROC
LF       GEN,8,8,8,8 AF(1),AF(4),AF(3),AF(2)
FITSZ    SET      FITSZ+AF(2)+1
         PEND
         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'
K3       EQU      X'3'
K4       EQU      X'4'
K5       EQU      X'5'
K6       EQU      X'6'
KA       EQU      X'A'
K4000    EQU      X'4000'
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
         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
         PAGE     CLS DEFS
         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
         SPACE    3
         DEF      CLS
         DEF      FINDFIL1
         SPACE    3
         REF      SL:EX,SL:MEX,J:JIT
         REF      DELFWD
         REF      DELETE
         REF      DELSET
         REF      DELO
         REF      DELAA
         PAGE     CLS REFS
         REF      ACNCFU
         REF      CHKBIT1
         REF      CLRMBG
         REF      DATE
         REF      DELF
         REF      DEVCHK
         REF      DOUBLEONE
         REF      DOUBLEZERO
         REF      FILCFU
         REF      GBG
         REF      GETASN
         REF      GETBUFM
          REF       GETCFU
         REF      GETCMD
         REF      GETFUN
         REF      GETTYC
         REF      IOCHEK1
         REF      INCREMENT%SECTOR                                      DISCB
         REF      MSRWRTX
         REF      MSR01EXIT
         REF      OPERC
         REF      PULLEXIT,PULLEXIT1
         REF      PULLFOUR
         REF      PUSHALL
         REF      PUTSZBF
         REF      RAFLAG
         REF      REDSEC
         REF      REL
         REF      SETBTDZ
         REF      SETCMD
         REF      SETCMD1
         REF      SETEOPW
         REF      SETUPUB
         REF      Y02
         REF      M8,DCT24
         REF      WRTSEC
         REF      M4
         REF      J:XP
         REF      J:ASSIGN
         REF      JB:PRIV
         REF      J:FDDA,J:ACCN
         REF      YFF
         REF      Y008
         REF      Y4,Y04
         REF      M16
         REF      XFF
         REF      Y002
         REF      Y00FE
         REF      Y00FF
         REF      Y8
         REF      OPNTPSEG
         REF      CLSTP#
         REF      CLSLBL#
         REF      ENTER1,WRBCDCC
         REF      RNBG
         REF      DCT22
         REF      DISCLIMS
         REF      TB:FLGS
         REF      M6
         REF      MAPBUFS
         REF      INSTCLNUP
         REF      U:MISC,E:SL,75BUF,75TABLE
         REF      LFGUN
         REF      E:CBK
         REF      T:RUE
         REF      UB:OV
         REF      ERRLOG
         REF      FNDKY
         REF      DEOD
         REF      IOSPIN
         REF      M:OC
DESC     EQU      17                DESCRIPTORS IN DCB
NOACUP   EQU      5                 DCB WD 5,BIT 5
         REF      E:OCR
         REF      T:REG
*
MASKCLS  DATA     X'60BC00'
         REF      Y004
TWRD     GEN,16,16   MIDIS,X'4020'
Y00FC    DATA     X'00FC0000'
         REF      CLOSEPV
         REF      FMCHKDA
         REF      GETORG
         REF      GETOVC
         REF      GPVCYL
         REF      GCYL
         REF      FNDHGP
         REF      PRIVDCB
         REF      SETVNO
         REF      DCT4,RNCYL,RNPVCYL,SETPVI
         REF      M24
         REF      BARNST
XFFFFFF  EQU      M24
         REF      SAVBLK
         BOUND    8
DAYCHK   DATA     X'40F0F0F0',X'FFF0F0F0'
HOURCHK  DATA     X'F0F04040',X'F0F0FFFF'
         SPACE    3
XF0F0    DATA     X'F0F0'
V24      DATA     24
NONE     DATA     C'NONE'
         TEXT     '    '
         REF      BLANK
BLANKS   EQU      BLANK
Y008F    DATA     X'008F0000'
NEVER    TEXT     'NEVER'
*        CONTROL FOR NULL FIT
FITSZ    SET      13
NULCTRL  FCTRL    3,0
         FCTRL    5,16
         FCTRL    6,16
         FCTRL    13,1,1
         FCTRL    12,7,7
         FCTRL    9,3,3,1
NULFITSZ EQU      FITSZ
NFD      EQU      FILCFU+FILDISP+6
NFIT     EQU      NFD
NFSP     EQU      NFD+1
         DO1      SYN=1
         REF      Y006
*
         REF      TRUNC
         OPEN     TCFU
TCFU     EQU      13
*
LFG      SET      1                 LFG AVAIL
         PAGE
LOCCODEC LI,D1    9
*  TO LOCATE AN ENTRY IN THE FILE'S FIT.
LOCCODEB LI,R7    BUFF2+WFNEMAX+5
         LW,3     BUFF2+NAVX
         CI,3     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
         CW,D2    Y00FF
         BANZ     BIR5
         AND,D2   XFF
         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
         PAGE
*                DATE MANIPULATING SUBROUTINES
         SPACE    3
DECTOBIN EQU      %
*                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'
*
         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      %
*                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'
*                SR2= ADDRESS OF DATE 'B'
*                BAL,R0 COMPDAT
*
         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
*                       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.
ADDATSPE EQU      %
         AND,D1   MASKS+14          CLEAR HI 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
*
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
*
         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
         REF      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     %
*                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
         LW,R2    D2
         BAL,R5   LOCCODEB
         B        CHK0NDW           SEE IF IT WAS THERE BUT
*                                    WITH NDW SET TO 0.
SETFID1  EQU      %
         AW,R7    R3
         STM,SR3  0,R7              SET 2 WD DATE
         LI,R3    -2
         LI,SR3   2
         CI,D1    X'A'
         BNE      %+3
         LI,SR3   3
         STW,R2   2,R7
         STB,SR3  *R7,R3            NDW=2
*                SET MOD FLAG SO WILL WRT FIT
SETUD    RES      0
         LW,SR4   Y002
         STS,SR4  MIUD,R6
         B        *R0
         SPACE    1
CHK0NDW  AI,R1    0
         BNEZ     *R0               VLP WAS REALLY NOT THERE.
         B        SETFID1           WAS THERE BUT EMPTY.
         SPACE    5
DOEXPDAT  EQU     %
*             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
*
         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
*        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
*
         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
*
*  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
         LB,R1    *R2               ACTIVITY BITS
         CI,R1    2
         BAZ      CLSIN2            IT'S INPUT ONLY
         LI,0     X'40000'
         CW,0     NXTA,R6
         BANZ     CLSIN             IT'S A * FILE
         LI,R3    4*DESC+1
         LB,SR1   *R6,R3            GET DYNAMIC FLAGS
         AI,SR1   -X'8F'
         BNE      SLCLSU            BITS MUST BE POSTED
         BAL,R0   FINDFIL1          TO SET OPNCLS USER ONLY
CLSIN    RES      0
         LW,R1    CFU,R6            GET CFU ADDRESS
         LW,D1    SREC,R1           FIT LOC
         LI,D2    0
         LI,3     X'30'
         CS,3     ORG,R6
         BE       CLSIN1            IT'S RANDOM
         LW,D1    FDA,R1
         B        CLSIN1
7G0      RES      0
         LI,0     X'8000'
         CW,0     BUFF2+NAVX
         BANZ     7G1
         LI,0     X'20'
         CW,0     ORG,6
         BAZ      7G1
         LW,D1    BUFF2+FLINK       FLINK
         LW,D2    DCBCDAM,R6        LINK CHK ADDR
CLSIN1   BAL,0    REDSECL
         B        7G0
CLSIN2   LW,0     Y04
         CW,0     NOACUP,R6
         BCS,4    CLSFIL2           NOTHING TO DO
         B        CLSIN
7G1      LW,12    Y00FC
         LW,7     CFU,R6
         CW,12    0,7
         BANZ     8D1
         LW,R4    Y02
         AND,R4   0,7
         BEZ      8B2               DO DATES ONLY
         B        CL2NS
         SPACE    3
         SPACE   5
DATEUP   EQU      %
*                 PROCESS ANY DATE CHANGES FOR IN/INOUT & WRT FIT
*                   IF FIT IS CHANGED
*                 PROCESS DATE CHANGES FOR IN/INOUT
         PUSH    R0
*                 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      %
         LI,D1    X'20000'
         CW,D1    FUN,R6
         BANZ     UPFIT             SKIP IF INPUT ONLY
         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
         B        UPFITYES          ALWAYS UPDATE FOR INOUT
UPFIT    EQU      %
*                IF FIT MODIFIED WRITE IT OUT
         LW,D1    Y002
         AND,D1   MIUD,R6
         BEZ      PULLEXIT
UPFITYES EQU      %
         B        WRTFIT+1          WRITE OUT FIT
         SPACE    5
*
*        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
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
BLDESC   EQU      %
*        BUILDS THE DESCRIPTORS IN THE DESC FIELD OF THE DCB FROM
*          THE DCB:VLP AND/OR OTHER DCB DATA
*        USES R3,R5,R7,SR1,SR2    LINKS ON R0
         PUSH      R0
         LI,R0    X'800'
         CW,R0    PRIV,R6
         BANZ     PULLEXIT
         PUSH      D1
         DO       SYN=1
         LW,SR1   DESC,R6           CLR DESC IN DCB
         CW,SR1   Y006              IS IT SYNON
         STCF     J:BASE            AND NOT 0 = SYNON
         FIN
         REF      J:BASE
         AND,SR1  YFF
         XW,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
         LW,R3     J:UN
         REF      J:UN
         AND,R3   Y4
         BNEZ     BLDESC3           IS 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
         DO       SYN=1
         LC       J:BASE
         BAZ      %+3               NOT SYNON
         LI,SR2   X'4000'
         STS,SR2  DESC,R6           SET 'SYNON' DESC
         FIN
BLDESC5  EQU      %
         PULL     D1
         B        PULLEXIT
BLDESC2A EQU      %
         LW,D1    FUN,R6
         CW,D1    Y0014             CHK OUTIN & OUT
         REF      Y0014
         BANZ     BLDESC2
         LW,R1    TCFU,R6           IF INOUT AND NOT WRITTEN,
         LW,SR2   Y02                   TREAT AS IN
         CW,SR2   0,R1
         BAZ      BLDESC5
BLDESC2  LI,SR1   0               SET DEFAULT DESCRIPTORS
         B        BLDESC1
         PAGE
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,0     CL1A1
         SW,0     *TSTACK
         BEZ      6B23
         LW,SR1   J:STAR,3
         BEZ      6B21              DOESN'T EXIST YET
         REF      J:STAR
         BAL,SR4  FMCHKDA
         BCS,15   6B22
6B21     LW,R1    CFU,6
         LW,0     FDA,1
6B23     STW,0    J:STAR,3
         B        PULLEXIT          TREAT AS NOT FOUND
6B22     RES      0
         LW,D1    J:STAR,3
         LI,R1    X'100'            SET THE FIT BIT
         STS,R1   J:CLS
         BAL,R0   REDSEC            READ THE FIT
         LW,R0    BUFF2
         BLZ      6B21              ERROR
         LW,R0    FDA,R1
         STW,0    J:STAR,3
         B        PULLEXIT1
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
*
         STW,R3   KAD,R6            LOC OF NAME
         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
         REF      REDSECL
         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
         STW,SR1  NFD
         STW,SR2  NFD+1
         STW,SR3  FILCFU+GAVAL
         STW,SR4  FILCFU+FSP
FASCLS   EQU      %
         LW,SR4   Y008
         STS,SR4  FUN,R6            SET FD PRESENT FLAG
         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
         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
         LW,D1    YFF
         AND,D1   DESC,R6
         LB,R0    *D3,R3
         SLS,R0   8
         AW,D1    R0
         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.
RDFIT    EQU      %
         LW,SR1   J:BASE+9          DISK ADDR
         BAL,SR4  FMCHKDA
         BCS,15   RDFIT2
         DO1      LFG=0
         BAL,SR4  DELAA             DELETE FD ENTRY
6B26     LW,SR3   CDA,R6            FD SECTOR
         LI,SR1   3                 75-03
         BAL,SR4  ERFILDA
         BAL,SR4  TRUNC
         LI,SR3   CLSFIL2
         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   RES      0
         LW,D1    J:BASE+9
         BAL,0    RSTSCR
         LI,R3    X'400'            SET FLAG TO RETURN HERE IF REDSEC
         STS,R3   J:CLS               FINDS AN ERROR
         LI,R3    0
         XW,R3    ACNCFU+4          RESET & SAVE DUAL
         LW,R2    FILCFU+16         SAVE BLINK
         BAL,R0   REDSEC
         STW,R3   ACNCFU+4          RESTORE DUAL
         STW,R2   FILCFU+16         RESTORE BLINK
         LW,D1    CDA,R6
         XW,D1    FILCFU+CDAM       SAVE CUR POS IN FILE DIR.
         STW,D1   FILCFU+SREC       ALSO SAVE FIT ADR
         LW,R0    BUFF2
         BLZ      6B26              ERROR
*
         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    BFL,6             FORCE WRITEOUT
         LI,1     X'100'
         STS,1    J:CLS             READ FIT FLAG
         B        RDFIT2
WRTFIT   PUSH     R0
         LI,R0    X'1FFFF'
         AND,R0   CFU,R6
         CI,R0    FILCFU
         BLE      %+3               IT'S A SLOW CLOSE
         PULL     R0
         B        WRTSEC            UPDATED FIT
         LI,R3    0
         XW,R3    ACNCFU+4          RESET & SAVE DUAL
         LW,R0    FILCFU+SREC
         XW,R0    FILCFU+CDAM
         STW,R0   FILCFU+SREC
         BAL,R0   WRTSEC
         LW,R0    FILCFU+SREC
         STW,R0   FILCFU+CDAM
         STW,R3   ACNCFU+4          RESTORE DUAL
         B        PULLEXIT
RSTSCR   LI,2     BAKEYM
         LB,3     *6,2
         AI,3     1
         B        SETSCR
         SPACE    3
*****    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
         LW,0     TSTACK
         AI,0     -2
         STW,0    OPNCLSTK
         SPACE    3
         LW,4     TCFU,6
         LW,5     0,4
         CW,5     Y00FC
         BANZ     8D1               SMEBDY SNUCK IN
         LI,R5    CLSIN             IS IT UPDATE ONLY
         CW,R5    *TSTACK
         BE       PULLEXIT          YUP
         SPACE    3
         BAL,SR4  TRUNC             RELEASE MI BUFFER
         LI,D1    2
         LI,R2    HAACD
CLSFILA1 STW,R3   J:BASE+1
         BAL,R5   LOCCODEA
         B        %+1
         STH,R3   *R6,R2
         AI,R2    HAFLD-HAACD
         BDR,D1   CLSFILA1
         OPEN     IMT
IMT      EQU      14
         LCI      2
         LM,R2    *J:BASE+1,R7
         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       PULLEXIT1
*  TAKE THE ABOVE BRANCH IF FILE CFU ALREADY SET UP FOR
*  DESIRED ACCOUNT.
*
         STS,D1   FILCFU
         LI,R5    X'1FFFF'
         STM,R2   FILCFU+ACNDISP
         BAL,R0   PRIVDCB
         BANZ     CLSDAOK2          IT'S PRIVATE
         LW,R4    KBUF,R6
         REF      Y08
         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
         LW,12    J:FDDA
         BEZ      AD25              NO FIL DIR DA
         CW,R2    J:ACCN
         BNE      AD25
         CW,R3    J:ACCN+1
         BE       CLSDAOK1          SAME ACCT USE DA
AD25     EQU      %
         CD,R2    SYSACCT
         BNE      %+3               NOT :SYS
         REF      SYSACCT,SYSACTL
         LW,12    SYSACTL
         BNEZ     CLSDA1            :SYS FILE DRCTORY
         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
         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,1     3                 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
3A6      STW,0    ACNCFU+CDAM       SET SECTOR ADDR
         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
         REF      ACNTBL
*                                                   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
         LI,SR4   0
DFDA     EQU      8                 DUAL FDA LOCATION
         STW,SR4  FILCFU+DFDA       RESET DUAL FDA
         BAL,SR4  FMCHKDA
         BCR,15   %+2               BR IF BAD
         STW,D1   FILCFU+DFDA
         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
         DO1      LFG=0             DON'T DELETE IF LFG IS AVAIL
         BAL,SR4  DELAA             DELETE THE BAD ENTRY
         BAL,SR4  TRUNC             WRITE OUT UPDATED BUF2
         LI,SR3   X'750A'           7505
         B        SAVERR
CLSDAOK2 STW,R5   FILCFU+CDAM       CLOBBER TO FORCE READ
         LI,D1    DPFDFDA           PRIV FD LOC
CLSDAOK1 EQU      %
         STW,D1   FILCFU+FDA
         B        PULLEXIT1
NOACCT   STW,SR4  FILCFU+ACNDISP
         B        PULLEXIT
CLSDA1   LW,SR1   D1
         BAL,SR4  FMCHKDA
         BCS,15   CLSDAOK1
         LI,12    0
         STW,12   SYSACTL
         B        AD25
         TITLE    '**** MSRCLS ****'
*                                   THIS ROUTINE CLOSES A DCB
*                                   R6 =DCB ADR
*                                   R7=PLIST
*                                   SR1 =OPCODE
MSRCLSA  EQU      %                 CLOSE DCB - BUFFERS NOT MAPPED
         BAL,R1   PUSHALL
         BAL,R0   MAPBUFS           MAP BUF1 AND BUF2
         LW,R1    TSTACK
         LCI      5
         LM,R6    -6,R1             RESTORE REGISTERS
         B        MSRCLSB
*
*  CLOSE DCB - ENTER HERE FROM CALPROC ONLY WITH BUFFERS MAPPED
*
MSRCLS   EQU      %
         REF      S:CUN,OPNCLSUS,OPNCLSTK
         BAL,R1   PUSHALL
MSRCLSB  EQU      %
         REF      J:CLS
         LI,1     1
         STW,1    J:CLS             CLOSE FLAG
         LW,D2    Y002              IS DCB ALREADY CLOSED
         AND,D2   FCD,R6
         BNEZ     MSRCLS1           NO
         LI,SR3   KA                YES--ABNORMAL CONDITION
MSRCLS9  EQU      %
         LI,11    0
         STW,11   J:CLS             RESET FLAG
         LI,11    MSR01EXIT
         B        T:SELFDESTRUCT
MSRCLS1  EQU      %
         CI,6     M:OC
         BE       MSRCLSX1          TRYING TO CLOSE SPECIAL DCB--DONT
         REF      CHKANS1
         CLEAR
CNM      EQU      1                 ***********TEMP CARD
         DO       CNM
         REF      ADR:ECB,INUSEL,CNMLNDCB,OPNBIT,LNDEVCD
         REF      ADDRMASK,KILLIO,MODE5,DCT23
         REF      ADR:LIST,VAL:INDX
         SREF     CLRMULIO
*
*
         LW,R1    CNMLNDCB          GET MASK FOR CNM LINE DCB
         CS,R1    0,R6              SEE IF THIS IS A CNM LN DCB
         BE       CNMLNCLS          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,R1   DEVCHK
         B        MSRCLSX2
         LI,R1    K8000
         AND,R1   FRM,R6
         BNEZ     CHKTPE
         CI,R0    PP
         BE       PUNWEOF
         CI,R0    CP
         BNE      CHKTPE
*
*
PUNWEOF  EQU      %
         LI,R2    KNEOD
         LI,D3    DEOD
         BAL,SR4  PUTSZBF
         BAL,D4   SETBTDZ
         BAL,D4   CLRMBG
         BAL,SR4  WRBCDCC
MSRCLSX2 EQU      %
*                                   CLEAR DEVICE OPTIONS
         BAL,SR4 IOSPIN
*                 THIS LOCATION = (SR4) AFTER IOSPIN CALL; USED AS FLAG
CNMLNCLS 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,R1    CLSMSK            RESET ONWK,NWK,SEQ,SID,TRN,NXTF
         STS,R0   SEQ,R6
         DO       CNM
         LW,R1    CNMLNDCB          GET MASK FOR CNM LN DCB
         CS,R1    0,R6              SEE IF THIS IS A CNM LN DCB
         BNE      CLSDEV1           B, IF NOT
         LW,R1    ADDRMASK
         STS,R0   ADR:ECB,R6        ZAP ANY REMAINING ECB ADR
         STW,R0   VAL:INDX,R6       ZAP ANY INDX VALUE
         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
         LW,R1    OPNBIT            PICK UP OPEN MASK
         AI,R2    -1                GET TRUE LN#
         LB,SR4   MODE5,R2          GET CNM COC LN SWITCHES
         STS,R0   SR4               RESET OPN BIT
         STB,SR4  MODE5,R2          RESTORE SWITCHES
         BAL,SR4  KILLIO            FOR BI-PNT LN, CANCEL I/O
         B        REINIT            GO REINITIALIZE LN DCB
*
CLSMULN  EQU      %
         LI,R1    X'FF'
         AND,R1   DSI,R6            GET DCT INDEX
         BAL,R2   CLRMULIO          PROCESS ANY OUTSTANDING LINE I/O
         LH,R2    DCT23,R1          GET CNM MOC LN SWITCHES
         EOR,R2   OPNBIT            RESET DCB IS OPEN BIT
         STH,R2   DCT23,R1          RESTORE SWITCHES
         LW,R1    ADR:LIST,R6       GET POL/SEL LIST ADDRESS
         LW,SR4   0,R1              GET LIST'S FLAGS
         EOR,SR4  INUSEL            RESET POL/SEL LIST'S IN-USE FLAG
         STW,SR4  0,R1              RESTORE LIST'S FLAGS
*
REINIT   EQU      %
         LI,R1    X'1FFFF'          MASK FOR DCB'S TOLF & OP LBL FIELDS
         LI,R0    LNDEVCD           GET DEVICE TYPE CODE FOR CNM LN
         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
         DO       CNM
         CI,SR4   CNMLNCLS          SEE IF WE GOT HERE VIA CNM CODE***********
         BNE      NODIAG            B, IF SO
         FIN
         LI,1     3
         CS,1     0,R6
         BNE      NODIAG
         LW,2     DSI,6
         AND,2    M8
         REF      DCTSIZ
         CI,2     DCTSIZ            DCTX OR LDEV
         BG       NODIAG            BRIF NO DCTX
         LB,1     DCT24,2           RESET DIAGNOSTIC USE BIT
         AND,1    NB31TO0+7
         STB,1    DCT24,2
NODIAG   EQU      %
MSRCLSX1 EQU      %
CLSVEC   EQU      %
         B        CLSX
         B        CLSFIL
         B        CLSLBL
         B        CLSDEV
         LW,SR4   11,R6             GET CFU
         MTH,-2   *SR4              DECR USE CNT
         B        MSRCLSX2
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
         BCS,4    MSRCLSX2          NOT TAPE
*                                   TAPE FOUND
         OVERTO   OPNTPSEG,CLSTP#
CLSMSK    DATA     X'3F000000'
CLSX     LI,SR3   0
         XW,SR3   J:CLS
         CI,SR3   9
         BGE      MSRCLS9
         LI,11    MSRWRTX
         B        T:SELFDESTRUCT
CLSLBL   EQU      %
         OVERTO   OPNTPSEG,CLSLBL#
         SPACE    3
CLSFILD  RES      0
*  CHECK FOR BUILDING A MULTI-LEVEL PYRAMID.
CLSFILC  CI,R7    4
         BL       0,R5
         CI,R2    X'100'            CHK 4 INPUT
         BAZ      %+2
         AI,R2    X'300'            CHANGE TO UPDATE
         OR,R2    Y02               SET WRITE OCCURED
         AND,R2   NB31TO0+16        NO SHARE NOW
         STW,R2   0,R1
         PUSH     R5
         OVERLAY  MULSEG,0
         B        PULLEXIT
         REF      MULSEG
         TITLE    '**** CLSFIL ****'
*                                   R5 = JIT ADR
*                                   R6 = DCB ADR
*                                   R7 = ADR OF PLIST
*                                   SR1 = CLOSE OPCODE
*
CLSFIL   EQU      %
         PUSH     R7
         BAL,11 TRUNC       CLEAR BUF1
         RABAL,SR4  T:RAPURGD       PURGE ANY READ AHEAD FOR THIS DCB
         SREF     T:RAPURGD
         PULL     R7
         LI,SR1   0                 ASSUME NO FPT CLS CODE
         DO1      SYN=1
         STW,SR1  PBD,R6            ASSUME NO SYNS,CMD OK
         BAL,R2   CHKBIT1           GET FPT CLS CODE
         LW,SR1   D1                GOT ONE
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.
         LW,R2    0,R1
         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
         REF      TXTCFU,J:DCBLINK
         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
         BANZ     MSRCLSX4          NOT A CFU
         LI,SR4   X'60BAD'          BAD CFU FLAG
         LW,R1    TCFU,R6
         LI,R5    X'FFFF'
         AND,R5   SCFU,R1
         REF      Y03
         LI,R3    X'40000'
         AND,R3   NXTA,R6           NOT 0 IF * FILE
         SLS,R3   8
         CW,R2    Y03               IF NOT RD/WRT,SET NOACUP
         BANZ     %+2
9A1      RES      0
         LW,R3    Y04
         STS,R3   NOACUP,R6
         CW,R2    Y00FE             CHK FOR
         BAZ      CLSX5CP1           NO USERS AT ALL
         LC       R2                CHK FOR
         BCR,4    CLSX5CP1          CFU NOT ACTIVE
         REF      BGRCFU
         BAL,R0   PRIVDCB     IS A PRIVATE FILE BEING CLOSED
         BAZ      CLSF30          NO
         LI,R4    BARNST  SAVE THE JOBS RUN STATUS
         LB,R0    J:JIT,R4  SET TO NOT ABORTED
         STB,R0   J:AMR
         REF      J:AMR
         STB,R3   J:JIT,R4
CLSF30   EQU      %
         CW,R2    Y00FC
         BANZ     8D1               MORE THAN 1 USER
         CI,SR1   K1                RELEASE OP SPECIFIED
         BAZ      CLSFIL1
         LI,R3    X'8000'           CHK 4 SHARED
         CW,R3    0,R1
         BANZ     CLSFIL1           DON'T RELEASE
         SPACE    3
*                                   RELEASE FILE
CLSFIL5  EQU      %
*
*
*                                   SEE IF WE ARE RELEASING A SYNON
*                                   FILE
         LW,R1    TCFU,R6
         LW,R3    Y1
         STS,R3   0,R1              ASSUME RELEASE
*
         LW,D1    FUN,R6
         CW,D1    Y0014
         BANZ     CLSFIL2           IT'S OUT/OUTIN
         CI,D1    X'20000'
         BAZ      CL12              IT'S UPDATE
         LB,D1    JB:PRIV           ONLY C0 DELETES OTHERS
         CI,D1    X'C0'
         BGE      %+4               DELETE IT
         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     EQU      %
         DO       SYN=1
         LW,D2    Y03
         STS,D2   0,R1              FORCE CFU R/W FOR FINDFILS
         LW,R2    Y006
         CW,R2    DESC,R6
         BAZ      CL1               NOT SYNON
         STS,R2   0,R1              RESET THE REL BIT
         BAL,R0   FINDFIL1
         B        CLSFIL5M
         BAL,R0   FINDFILS
         B        CL2SYN
         LI,R0    -1
         B        CL2A
         FIN
*
CL1      EQU      %
         LI,R2    X'C000'           RAN & SHARE
         CW,R2    0,R1
         BAZ      CL1B
         BDR,R5   CLSFIL2M          DON'T RELEASE
CL1B     RES      0
*                                   EXISTS
         BAL,R0   FINDFIL1
         B        CLSFIL2
         BAL,R0   FINDFILINT
CL1A1    RES      0
         B        CLSFIL2           RELEASE A * FILE
*
*                                   DELETE FILE INFO
         DO       SYN=1
*
         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
         B        CLSFIL2           THIS INSTRUCTION MUST PRECEED CL6A
         FIN
CL6A     EQU      %
*                                   R3 = DISPLACEMENT
         BAL,11   DELF
         B        CLSFIL14
CL7      LI,0     0                 RESET EOF
         LW,1     Y00FE
         STS,0    TYC,6
         B        CLSFIL14
*
CLSFIL5M LW,D2    Y001              FORCE OUTIN, OPN WILL CLEAN UP
         STS,D2   FUN,R6
         B        CLSFIL5
         PAGE
CLSFIL2M STS,R2   0,R1              RESET THE REL BIT
*
CLSFIL2  EQU      %
         BAL,11   TRUNC             DUMP FIT ETC.
         LW,R4    TCFU,R6
         LW,1     Y00FC
         LI,R5    X'1FFFF'
         STS,R4   CFU,R6            CORRECT CFU
         CW,1     0,4
         BANZ     8D1               SOMEBODY SNUCK IN
         LI,R1    X'FFFF'
         AND,R1   SCFU,R4           OPEN IN AND OUT
         BEZ      MSRCLSX3          NO
         LI,R2    X'C000'           CHK 4 RANDOM OR SHARED
         CW,R2    0,R4
         BANZ     8D1               CAN'T CLOSE NOW
         LI,R2    K0                CLEAR LINKAGE WITH CORRESPONDING CFU
         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
         REF      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
*        SOMEBODY SNUCK IN
8D1      RES      0
*
MSRCLSX5 EQU      %
         BAL,R0   PRIVDCB           IS A PRIVATE FILE BEING CLOSED
         BAZ      CLSX5C                NO
         REF      J:RNST
         LW,R3    J:AMR
         AND,R3   YFF
         STS,R3   J:RNST
         BAL,R0   GETOVC R3=DCB:OVC     YES,CLOSE ALL OPEN VOLUMES
         BEZ      CLSX5C-1
         BAL,R0   GETORG R4=DCB:ORG
         BL       CLSX5B
CLSX5A   BAL,R0   SETVNO  DCB:VNO=R3        KEYED FILE,ALL VOLS ARE OPEN
CLSX5B   BAL,R0   CLOSEPV                   CONSEC FILE,ONLY CURRENT VOL
         BDR,R3   CLSX5A                                IS OPEN
         STB,R3   J:AMR
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
CLSX5CP1 RES      0
         LW,R1    CFU,R6
         LI,D1    X'14000'          PRIVATE & RANDOM
         AND,D1   0,R1
         AW,SR4   D1
CLSX4    RES      0
         STW,SR4  0,R1
MSRCLSX4 EQU      %
*  IF FILE EXTENSION, SWITCH FUNCTION TO OUTIN
         LI,D1    X'10000'
         CW,D1    0,R6
         BAZ      8B1
         LW,D1    Y001
         REF      Y001
         LW,D2    Y00FE
         STS,D1   FUN,R6
8B1      RES      0
         LW,R2    S:CUN
         REF      UH:FLG
         LH,SR4   UH:FLG,R2
         AND,SR4  NB31TO0+3         RESET SIGNIF FILE OPN BIT
         STH,SR4  UH:FLG,R2
         LI,SR4   MSRCLSX2
         B        OPERC             RELEASE ALL BUFFERS
*
RELRAND   LW,R1   TCFU,R6            RELEASE RANDOM FILE
         LW,SR1   FDA,R1
         OPEN     CDAM
CDAM     SET      TDA
         LW,D4    CDAM,R1
         BEZ      MSRCLSX5          ZERO GRANULE FILE
         CLOSE    CDAM
         LI,R7    X'800'
         CW,R7    0,R6              PRIVATE FILE
         BAZ      RRANDPUB          NO, PUBLIC
         SPACE    2
* RRANDPRI - RELEASE PRIVATE RANDOM FILE
*                 D4 HAS # GRANULES TO RELEASE
*                 R6 HAS DCB ADDR
*                 SR1 HAS FIRST DISC ADDR
         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
         REF      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
*
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
         BAZ      RRPUB20           THE CURRENT TRACK
         LI,3     0                 ZAP FDA
         STW,3    GZFDA,5
         BAL,0    GZQUS             AND WAIT
         B        RRANDPUB          KEEP WAITING ON IT
RRPUB20  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
         BLZ      %+2
         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
*  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      CLSFIL2           NEITHER
         LW,D3    1,R5              SCFU 1ST WORD
         CW,D3    Y00FE
         BANZ     CLSFIL2           TEHER'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
         LI,R3    X'FFFF'           ERASE THE
         STS,R2   SCFU,R1            2NDARY POINTER
         CI,D2    X'4000'           CHK 4 RANDOM
         BANZ     MULTR             IT IS
         LW,R2    SREC+1,R5         GET SIZE CHANGE
         LW,R3    M24
         STS,R2   CLK,R6            SET IT INTO DCB
         AND,D2   NB31TO0+16        TURN OFF SHARE
         STW,D2   0,R1
         B        MULTR
         PAGE
CLSFIL1  EQU      %
         LI,R7    X'FF'
         AND,R7   0,R1              SLIDES
         LW,D1    FUN,R6
         CW,D1    Y0014             CHK CREATE NEW FILE
         BANZ     CLSFIL4
         BDR,R5   MULTIPLE
MULTR    RES      0
         LC       *R1
         BCR,2    NOMULI-1
         LI,R5    LSLIDES
         CB,R7    *R6,R5
         BLE      NOMULI
         BAL,R5   CLSFILC           BUILD A MUL
NOMULI   RES      0
         LI,R1    X'40000'
         CW,R1    NXTA,R6
         BANZ     CLSINUP
         LI,D1    X'11'
         BAL,R5   LOCCODEA
         B        CLSINUP           NO DESC IN DCB
         LW,R5    *R7,R3
         CW,R5    Y008
         BAZ      CLSINUP           NO CHANGE TO DYNAMICS
SLCLSU   RES      0
*
*  A DIRECTORY SEARCH IS REQUIRED.
*
         BAL,R0   FINDFIL1
         B        CLSFIL5M
         DO       SYN=1
         LW,R0    Y006
         CW,R0    DESC,R6
         STCF     J:BASE            SYNON STATE
         FIN
         BAL,R0   PRIVDCB
         BANZ     CL2PR
         BAL,R0   BLDESC            BUILD DESCRIPTORS IN DESC
         LW,SR2   Y008
         CW,SR2   DESC,R6
         BAZ      CL2PR             DONT SET IF USER DIDNT ASK
         LI,SR2   X'40'
         STS,SR2  DESC,R6           'DO DYNAMIC' FLAG ON
CL2PR    EQU      %
         BAL,R0   FINDFILS
         DO       SYN=1
         B        CL5               NEW SYNON
         LC       J:BASE            CHECK FOR SYNON
         BAZ      CL2NS             NOT SYNON
CL2SYN   EQU      %
         BAL,R0   FINDFIL1
         B        CLSFIL5M
         BAL,R0   FINDFILINT
         B        CLSFIL2           CANT FIND,MUST HAVE TRUNCATED
         ELSE
         B        CLSFIL5M          REL THE GRANULES
         FIN
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
UPDFSIZ  EQU      %
         BAL,R0   DSKADRA           SET UP CHANGES IN DA
*
UPD09    EQU      %
         BAL,R5   LOCCODEC
         B        CLSFIL5M          NO 09 ENTRY
         AW,R3    R7
         AI,R3    2
         LW,R4    DESC,R6
         SLS,R4   -8
         LI,R5    X'9FFF'
         STS,R4   0,R3              UPDATES DESCRIPTORS
         DO       SYN=1
         SLS,R3   1
         LI,R2    HAPBD
         LH,R2    *R6,R2
         LW,R4    R2
         AH,R2    0,R3              UPDATE SYNON COUNT
         STH,R2   0,R3
         FIN
         BAL,0    SETUD             FORCE WRITEOUT
8B2      RES      0
         BAL,R0   DATEUP            DO DATES & WRT FIT
*
         DO       SYN=1
         CI,R4    K1
         BNE      CL2B
         B        CL10
         ELSE
         B        CLSFIL2
         FIN
*
         DO       SYN=1
CL5      EQU      %
         BAL,D2   GETFUN
         CI,D1    1
         BANZ     CLSFIL5M
CL5A     EQU      %
         LI,R0    K1
CL2A     EQU      %
         LI,R1    HAPBD
         STH,R0   *R6,R1
         B        CL2SYN
*
CL2B     EQU      %
         CI,R4    KN1
         BNE      CLSFIL2
         LI,R0    CL6A-1
         FIN
FINDFILS INT,R3   FLD,R6
         AW,R3    FLP,R6
         B        FINDFILI
         SPACE    3
*  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,D1    X'51'             ERROR CODE
         BDR,R5   CLERXP1           CLOSED IN WRONG ORDER
         BAL,R5   CLSFILD           BUILD A MUL
*  WHEN CREATING A NEW FILE, FIRST BUILD & WRITE THE FIT.
         LW,D1    FDA,R1
         BNEZ     6A1               FDA ALREADY EXISTS
         REF      ENTERO
         BAL,SR4  ENTERO            GET AN FDA
         LW,D1    FDA,R1
         BEZ      CLERX
*  WRITE THE FIT OUT NOW
6A1      LI,R3    X'30'
         CS,R3    ORG,R6            CHK 4 RANDOM
         BNE      7A1               IT'S NOT RANDOM
         BAL,0    GZQUS             CHECK FOR CLEANING AND WAIT IF SO
         B        GZBREAK           ABORT CLOSE IF BREAK, ETC.
         REF      GZQUS
         REF      GZAPCFU,GZAPBIT
         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
         REF      GZREEX
         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
*  CREATING A NEW FILE OVER A PREVIOUSLY EXISTING FILE WITH
*  THE SAME I.D.
         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
         REF      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
         CS,R2    6A1               CHK FOR RANDOM
         BE       CLSFIL2           IT'S RANDOM, GET OUT
         STS,R2   ORG,R6              FOR RELEASE
         LW,D2    Y1                SET RELEASE
         STS,D2   0,R4
         LI,D1    4
         LI,R1    2
         STB,D1   *R4,R1            SET FCN FOR ACCT'NG
         DO       SYN=1
         LH,D2    SR4               RELEASE SYNON FILES
         BEZ      CLSFIL2
         LI,D3    BUFF2
         LI,R0    CL6-1             RETURN
         ELSE
         B        CLSFIL2
         FIN
2A0      LI,R2    FILCFU
         LI,R3    K1FFFF
         STS,R2   CFU,R6
         DEF      FNESCR
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
         REF      Y1
         PAGE                       SAVE ACCOUNT NO
CLSFIL4A EQU      %                 DIDNT FIND ACCOUNT NO
*                                   INSERT ACCOUNT NO.
*                                   CREATE NEW FILE DIRECTORY
*
*
         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,0    NFD               INIT CNTS OF FD + FIT
         STW,0    NFSP                            FSP
         BAL,R0   GETCMD
         STW,R3   FILCFU            RESETS PRIV
*                                   IS IT :SYS?
         REF      GETDGRAN
         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
         MTB,1    NFD               START THE COUNT
         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     %
         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
         MTW,1    NFIT              COUNT THE GRAN
4B2      RES      0
         REF      M31
         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
EPWRT    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
         CI,R3    X'A'
         BE       EPER              OUT OF GRANULES
         PULL     D1
         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
CLSFIL4T RES      0
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
CLSFIL4P EQU      %
*
CLSFIL14 EQU      %
         LW,D1    FILCFU+FDA        UPDATE SECTOR INFO
         BEZ      CLSFIL2           BR IF FILE DIRECTORY DELETED
         LI,D2    0
         BAL,R0    REDSECL          READ SECTOR WITH LINK CHECK
4C2      RES      0
         LI,R2    WXBUFSIZ-5
         LI,SR2   X'4000'
         CW,SR2   BUFF2+NAVX
         BANZ     %+2
         AI,R2    -X'100'
         LW,SR2   NFD
         LW,SR3   NFD+1
         LW,SR4   GAVAL+FILCFU
         LW,D1    FSP+FILCFU
         LCI      4
         STM,SR2  BUFF2,R2
         BAL,R0   WRTSEC
         XW,D1    ACNCFU
         CI,D1    X'F4008'
         BNE      CLSFIL2           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
         LW,D1    ACNCFU+CDAM
         BEZ      %+2
         BAL,R0   REDSEC
         LW,D1    FILCFU+FDA
         B        EPWRT             ENTER NEW ACCOUNT
*
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    CLSFIL2           INSERT DUAL DISK ADDRESS
*
CLSFIL4Y SCS,D1   8
         STB,D1   BUFF2,R3
         AI,R3    1
         BDR,SR4  CLSFIL4Y
         B        *R0
       PAGE
*  BUILD A NEW FIT.
7A1      LI,D2    0                 4 LINK TEST
         BAL,R0   REDSECL           READ THE FIT GRAN
7A2      RES      0
*        ENTER FILE NAME
         LI,D1    1
         BAL,5    LOCCODEA
         B        CLSFIL5           RELEASE THE FILE, NAME LOST
******      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
         STW,R2   J:BASE+6          SAVE POSITION
******        PASSWORD X'03'
         LI,D1    K3
         BAL,R5   LOCCODEA
         B        FIL9              NO PASSWORD
         LI,R0    K2
         BAL,SR1  SETENT
******       EXECUTE ACCTS X'14' & EXECUTE VEHICLE X'15'
FIL9     LI,D1    X'15'             EXECUTE VEHICLE
         BAL,R5   LOCCODEA
         B        FIL2              NO VEHICLE
         CI,R1    3
         BG       FIL2              BAD VEHICLE NAME
         LW,R0    R1
         BAL,SR1  SETENT
*
FIL2     LI,D1    X'14'             EXECUTE ACCOUNTS
         BAL,R5   LOCCODEA
         B        FILIMG2           NO ACCOUNTS
FIL3     LW,R0    R1
         LW,SR1   R2
         AW,SR1   R1
         SW,SR1   J:BASE+6
         CI,SR1   40
         BL       FIL4
         AI,R1    -2
         B        FIL3
FIL4     BAL,SR1  SETENT
*
******       READ X'05' AND WRITE X'06'  ACCOUNTS
FILIMG2  EQU      %
         LI,D1    K5                READ ACCOUNTS
FILIMG2A EQU      %
         BAL,R5   LOCCODEA
         B        FILIMG3A
6C2      LW,R0    R1
         LW,SR1   R2
         AW,SR1   R1
         SW,SR1   J:BASE+6
         CI,SR1   40
         BL       FILIMG2B          OK
         AI,R1    -2                REDUCE BY 1 ENTRY
         BGZ      6C2               TRY AGAIN
         B        FILIMG3A          NO ROOM
FILIMG2B EQU      %
         BAL,SR1  SETENT
         LB,D1    D1
FILIMG3  EQU      %
         AI,D1    K1
         CI,D1    K6                DO WRITE ACCOUNTS
         BE       FILIMG2A
******       EXPIRATION DATE X'04'
FILIMG4A EQU     %
         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
         REF      MASKS
         LW,D1    MASKS+22          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    L(X'1FFF00')
         AND,D1   DESC,R6           GET THE DESCRIPTORS
         SLS,D1   -8
         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    X'8000'
         AND,R5   3,R3              SAVE O IN FIT
         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      CLSX5CP1          BAD NEWS
         LCI      7
         LM,R7    FDA,R4            CFU INFO
         STM,R7   0,R3
         STW,SR4  1,R3              TDA
         LI,D2    X'FF'
         AND,D2   0,R4              SLIDES
         AND,SR3  YFFFF
         REF      YFFFF
         AW,D2    SR3
         LC       *R4
         BCR,2    %+2               O BIT
         AI,D2    X'8000'
         OR,D2    R5
         STW,D2   3,R3              DON'T LOOSE O BIT
         B        *R0
         SPACE    3
*
DTTMSET  LW,SR4   DATE+1            PUT MMDDHHYY IN SR3,SR4
         LH,SR3   TIME
         STH,SR3  SR4
         LW,SR3   DATE
2A2      B        *SR1
*
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
*
FILIMG3A EQU      %
         CI,D1    5                 CHK FOR DEFAULT 'NONE' FOR READ ACCTS
         BNE      FILIMG4A          NOT READ
         LW,R0    Y1                CHK JIT BIT
         CW,R0    J:ASSIGN
         BAZ      FILIMG3           JIT BIT NOT SET
         LI,R0    2                 SETUP READ ACCTS='NONE'
         LI,R3    NONE
         SW,R3    R7
         B        FILIMG2B          GO SET VLP
         TITLE    '**** GETFDHG ****'
*        PURPOSE: TO ALLOCATE EITHER A FIT HALF-GRANULE OR THE FIRST
*                 HALF-GRANULE IN AN ACCOUNT'S FILE DIRECTORY FROM THE
*                 FILE DIRECTORY POINTED TO BY FILCFU
*
*        INPUT:   R6=DCB ADR
*                 IF DCB:PRIV SET,DCB:VNO=1
*
*        CALL:    BAL,R0  GETFDHG
*
*        OUTPUT:  D1=DISC ADR OF ALLOCATED HALF-GRANULE,OR
*                   =0,IF NONE AVAILABLE
*                 CONDITION CODES SET  TO INDICATE THE VALUE OF D1
*
*        REGS:    VOLATILE:R1-R5,R7,SR1-SR4,D1-D4
*                 NONVOLATILE: R6
*
*
GETFDHG  RES      0
         PUSH     R0                SAVE THE LINK
         REF      PRDCRM
         LW,SR1   FILCFU+GAVAL     *ANY AVAILABLE GRANULES IN LAST CYL
         BNEZ     FD05              ALLOCATED TO FD,YES
         BAL,R0   PRIVDCB                           NO
         BAZ      FD10
         BAL,SR4  GPVCYL           *PRIVATE FD, ALLOCATE A CYLINDER
         BEZ      FDX               FROM VOLUME POINTED TO BY DCB
FD05     EQU      %
         B        GPACK19
FD10     EQU      %
         LI,7     3
FD15     EQU      %
         EXU      ALOCTAB,7
         BAL,11   GBG
         BNEZ     FDX
RETURN   BDR,7    FD15
         LI,SR1   0
FDX      PULL     R0                RESTORE RETUNR
         LW,D1    XFFFFFF
         AND,D1   SR1
         BNEZ     GETBUFM
         B        CLERX
*
GTCYL    EQU      %
         BAL,11   GCYL
         BEZ      RETURN
GPACK19  STW,SR1  FILCFU+GAVAL
         MTB,-1   SR1                                                   DISCB
         BNEZ     SOME%LEFT                                             DISCB
         LI,SR1   0                                                     DISCB
         B        XCHNG%GAVAL                                           DISCB
SOME%LEFT EQU     %                                                     DISCB
         LI,R2    1                                                     DISCB
*                                   ASSUME 2 SEC/GRAN FOR ALL PAKS      DISCB
         MTH,2    SR1,R2                                                DISCB
         BNC      XCHNG%GAVAL                                           DISCB
         MTH,-2   SR1,R2            RESTORE SECTOR #                    DISCB
         BAL,R2   INCREMENT%SECTOR  BUMP SECTOR #                       DISCB
XCHNG%GAVAL EQU   %                                                     DISCB
*                                   FOR ALL PACKS **********
         XW,SR1   FILCFU+GAVAL
         B        FDX
ALOCTAB  EQU      %-1
         B        GTCYL             CYL
         LI,0     7                 RAD
         LI,0     X'B'              PACK
         SPACE    3
EPER     EQU      %
CLERX    EQU      %
         LI,D1    X'57'             OUT OF DISK
CLERXP1  STW,D1   J:CLS
         B        CLSFIL5M          RELEASE THE FILE
         TITLE    '**** DISC ERRORS ****'
         REF      TIME
*
*  REPORT I/O ERROR 75  -  FILE INCONSISTENCY
*
*    FLAG BITS IN J:CLS
*        X'100'  -  CHANGE SUB-CODE TO X'03' (READING FIT)
*        X'200'  -  RETURN TO CALLER OF REDSEC
*        X'400'  -  DON'T LOG ERROR, RETURN TO CALLER
*
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    Y008
         STS,R0   FUN,R6            RESET FD PRESENT FLAG
         LW,D1    CDAM,R1           DISC ADDRESS
         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,SR2   X'100'
         CW,SR2   J:CLS             CHECK IF READING FIT
         BAZ      8A1               NO
         LI,SR1   3                 YES - CHANGE ERR CODE TO 75-03
8A1      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
         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
         BEZ      OPERC1            WEREN'T IN CLS
         CI,R1    X'FF8FF'
         BAZ      BADARET           WERE IN OPN - DON'T SET J:CLS
         CW,SR3   J:CLS             SAVE WORST ERROR
         BLE      %+2
         STW,SR3  J:CLS
         CI,R1    X'700'
         BANZ     BADARET           RETURN TO CALLER
*
         BAL,D2   GETCFU
         CI,1     FILCFU
         BG       %+2
         LW,1     TCFU,6
         LW,D2    2,1
         CW,D2    Y4
         BNE      CLSFIL2           NOT DELETING FILE
         B        MSRCLSX5          DELETING - EXIT FROM CLS
         SPACE    3
*
*  RETURN TO CALLER OF REDSEC/REDSEC1
*
BADARET  EQU      %
         LI,R3    X'FF8FF'
         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       EQU      %
         LW,D1    DCBCDAM,R6
         LI,SR1   0
         LI,1     5                 # OF * 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,7
OPERC2   RES      0
         PUSH     SR3               SAVE ERROR CODE
         BAL,SR4  OPERC             RELEASE ALL BUFFERS
         PULL     SR3               RESTORE ERROR CODE
         B        MSRCLS9           GET OUT
         REF      OPNSEG
         PAGE
         SPACE    2
*
*  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
*
ERFILDA  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      %
         LI,R5    6
         CW,SR3   75TABLE-1,R5      CHECK IF DA PREVIOUSLY REPORTED
         BE       *SR4              YES
         BDR,R5   %-2
*
         PUSH     6,R6              SAVE REGISTERS
         CI,SR1   X'70'             DON'T PUT RE-READ AND
         BGE      BLDERR              DUAL DIR READS IN 75TABLE
         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
*
         CI,SR1   X'40'             DON'T START GHOST IF 75-7F
         BANZ     BLDERR              OR HARDWARE ERROR
         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    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    100               SLEEP FOR 2 MINUTES
         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
         LCI      2
         LM,R1    *R7,R3            PICK UP ACCOUNT
         LW,R3    SR3               BAD DISC ADDRESS
         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
         PULL     6,R6
         B        *SR4
         SPACE    2
FICODE   DATA     X'1A0E7500'       ERRLOG CODE/COUNT, ERR CODE
         SPACE    2
##END    END      CLS

