*M*      OBSE     MISCELLANEOUS ROUTINES USED BY VARIOUS OPENS.
MONPROC  SET      1
ANSPROC  SET      1
         SYSTEM   UTS
         PCC      0
OBSE:    EQU      %
         SPACE    3
*P*      NAME:    OBSE
*P*      PURPOSE  TO COLLECT THE MISCELLANEOUS SUBROUTINES
*P*               USED BY VARIOUS DCB OPENING MODULES.
         PAGE
         BOUND    8
K2       EQU      2
K9       EQU      X'9'
K0       EQU      X'0'
K1       EQU      X'1'
K4       EQU      X'4'
K5       EQU      X'5'
K6       EQU      X'6'
K14      EQU      X'14'
K4000    EQU      X'4000'
KFFFF    EQU      X'FFFF'
K1FFFF   EQU      X'1FFFF'
KN1      EQU      -X'1'
         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
         DEF      OBSE:             NAME FOR MODULE PATCHING
         DEF      LOCCODEA          FIND NON EMPTY DCB VLP ENTRY
         DEF      LOCCODEB          FIND VLP IN DCB
         DEF      LOCCODE           FIND A VLP ENTRY
         DEF      GETACNADR         GET ADDR OF DCB ACCN VLP
         DEF      GETFILADR         GET ADDR OF DCB NAME VLP
         DEF      CHKFLACN          SET UP & CHK DCB, SET USR BIT
         DEF      SECCHK            CHECK ACCESS PERMISSION TO A FILE
         DEF      OPER              FILE OPEN ERROR EXIT PATH
         DEF      SETACOG           SET ACCESS & ORGANIZATION
         DEF      SETSCR            SET THE SCR FIELD IN DCB
         DEF      ER1400            I/O ERROR 14-00
         DEF      OPNX              NORMAL OPEN CAL EXIT PATH
         DEF      DCBNCHK           LOOK FOR M: DCBS
         DEF      TRNINFO           MOVE FIT TO FPARAM BFR
         DEF      GETFUNA           CHK FOR OUT OR OUTIN
         DEF      OERX              OPN CAL ERROR EXIT PATH
         DEF      OPENER01          I/O ABNORMAL 01
         DEF      ORGCHK            LOOK FOR RANDOM ORGANIZATION
         SPACE    3
         OPEN     WXBUFSIZ,XBUFSIZ
WXBUFSIZ EQU      X'200'
XBUFSIZ  EQU      X'800'
         PAGE
         REF      DOUBLEONE         DBLWD 1,1
         REF      GETFUN            GET THE FUNCTION FIELD
         REF      MSR01EXIT         CAL ERROR EXIT PATH
         REF      MSRWRTX           NORMAL CAL EXIT PATH
         REF      XFF               BITS 24-31
         REF      Y01               BIT 7
         REF      S:CUN             CURRENT USER #
         REF      UH:FLG            USER'S FLAGS
         REF      ACCN              OFFSET IN JIT TO LOGON ACCOUNT
         REF      JB:PRIV           PRIVLEGE LEVEL IN JIT
         REF      Y0008             BIT 12
         REF      Y00FE             BITS 8-14
         REF      SYSACT            TEXT :SYS AND 4 BLANKS
         REF      BOOTFLG           BOOTING FLAG
         REF      CLSVNO            CLOSE ALL OPEN VOLUMES OF SET
         REF      J:BASE            SCRATCH STORAGE IN JIT
         REF      TRUNC             RELEASE BUFFERS
         REF      BGRCFU            START OF USER CFU AREA
         REF      ACNCFU            THE ACCOUNT CFU
         REF      J:JIT             JOB INFORMATION TABLE
         REF      J:STAR            TABLE OF * FILE FIT DSK ADDRESSES
         REF      MXFPL             M:XX DCB NAME
         REF      MULSEG            OVERLAY WITH THE MUL MODULE
         REF      OPV#              ENTRY FOR OPEN PRIV VOL
         REF      SETVAR            FIND START OF VLP IN FIT
         REF      T:IACU            CHK FOR ACCESS PERMISSION
         REF      SH:OPNM           OP LABELS
         REF      PLX1SR4           SKIPPING EXIT VIA SR4
         REF      UB:DB             DEBUGGER ASSOSCIATED TABLE
         REF      BT31TO0           TABLE CONSTANTS
         REF      T:SELFDESTRUCT    ZAP OVERLAY
         REF      C:CFU             # OPEN CFUS
         REF      M2
         REF      SYSID             USER ID OFFSET IN JIT
         REF      YC                BIT 0,1
         REF      M16               LO HALFWORD MASK
         REF      9H38              ALIGN ERROR CODE & EXIT
*
ONE      EQU      1
         SPACE    4
         BOUND    8
NONE     TEXT     'NONE'
         TEXT     'ALL'
         PAGE
*E*      ERROR:   01-00
*E*      DESCRIPTION  CANNOT OPEN A DCB BECAUSE OF INSUFFICIENT
*E*               INFORMATION.
OPENER01 LI,SR3   K1
         B        OERX
*D*      NAME:    OERX
*D*      DESCRIPTION  ALL OPEN ERRORS AND ABNORMALS COME HERE
*D*               TO DISASSOCIATE THE OPEN OVERLAY
OERX1    PULL     SR3               RESTORE ERROR CODE
OERX     EQU      %
         AI,SR3   0
         BEZ      OPNX              TEST FILE EXITS HERE WITH NO ERROR
         LI,11    MSR01EXIT
         B        T:SELFDESTRUCT
*D*      NAME:    OPNX
*D*      DESCRIPTION  ALL NORMAL OPEN EXITS PASS THROUGH
*D*               HERE TO DISASSOCIATE THE OPEN OVERLAY
OPNX     EQU      %
         LI,11    MSRWRTX
         B        T:SELFDESTRUCT
*
*
*
*D*      NAME:    LOCCODEA
*D*      REGISTERS R1, R3, R4, R7, & D2 ARE VOLATILE
*D*      CALL     R5 IS THE LINK, SKIPPING EXIT IF FOUND
*D*      DESCRIPTION  FIND A SIGNIFICANT VLP ENTRY
*D*      INPUT    D1 HAS REQUESTED VLP CODE
*
LOCCODEA EQU      %
*                                   ENTRY POINT IF CURRENT SIZE OF
*                                   ZERO IS TO REPRESENT NO CODE
         BAL,R4   LOCCODEB
         B        0,R5              DIDN'T FIND CODE
         LI,R1    K2
         LB,R1    D2,R1             CURRENT SIZE
         BEZ      0,R5              DIDN'T FIND
         B        ONE,R5
*D*      NAME:    LOCCODEB
*D*      ENTRY:   LOCCODE
*D*      REGISTERS R3,D2 VOLATILE
*D*      CALL     R4 IS LINK, SKIPPING EXIT IF FOUND
*D*      INPUT    D1 HAS REQUESTED VLP CODE
*D*      DESCRIPTION FIND A VLP ENTRY
LOCCODEB LW,R7    FLP,R6
LOCCODE  EQU      %                 LOCATE CODE OF VARIABLE LENGTH
*                                   PARAMETER
*                                   R7 = ADDR OF LIST
*                                   D1 = CODE DESIRED
         LI,R3    K0
LOCCODE1 LW,D2    *R7,R3
         AI,R3    K1
         CB,D1    D2
         BE       ONE,R4
         CI,D2    X'10000'          CHECK FOR END
         BANZ     0,R4
         AND,D2   XFF
         AW,R3    D2
         B        LOCCODE1
*
         SPACE    3
*D*      NAME:    ORGCHK
*D*      REGISTERS D2 IS VOLATILE
*D*      CALL     R4 IS THE LINK
*D*      DESCRIPTION  CHK DCB FOR RANDOM ORGANIZATION
ORGCHK   EQU      %
*          CHECK DCB FOR RANDOM ORGANIZATION
         LI,D2    X'30'
         CS,D2    ORG,R6
         B        0,4
         SPACE    3
*D*      NAME:    GETFUNA
*D*      REGISTERS  D1 IS VOLATILE
*D*      CALL     D2 IS THE LINK
*D*      DESCRIPTION  CHK DCB FUNCTION FOR OUT OR OUTIN
GETFUNA  EQU      %
         LW,D1    FUN,R6
         REF      Y0014
         CW,D1    Y0014             CHK OUTIN & OUT
         B        *D2
         SPACE    3
*
*D*      NAME:    COMPARE
*D*      REGISTERS R0,R2,R3,& D2 ARE VOLATILE
*D*      CALL     SR4 IS THE LINK
*D*      INPUT    STRING POINTERS IN R7 & D3, R7 OFFSET IN R3
*D*      DESCRIPTION  COMPARE WORD STRINGS
COMPARE  EQU      %                 COMPARE WORD STRING
         LI,R0    K2
COMPL    RES      0
*                                   R7 # SOURCE ADR
*                                   R3 = SOURCE DISPLACEMENT
*                                   D3 = DEST ADR
*                                   R1 = DEST DISPLACEMENT
*                                   R0 = NUMBER OF WORDS TO COMPARE
         LW,D2    *R7,R3
         CW,D2    *D3,R2
         BNE      BISR4             NO COMPARE
         AD,R2    DOUBLEONE
         BDR,R0   COMPL
         B        PLX1SR4           DO COMPARE, GO TO SR4+1
         SPACE    2
*D*      NAME:    GETACNADR
*D*      ENTRY:   GETFILADR
*D*      REGISTERS  R2 R7 VOLATILE
*D*      CALL     R0 IS THE LINK
*D*      DESCRIPTION  TO GET THE ADDRESS OF THE ACCOUNT
*D*               OR FILE NAME ENTRY IN THE VLP OF A DCB
GETACNADR  EQU    %                 GET ADR OF ACCOUNT NO
         LI,R2    HAACD
GETACNADR1  EQU   %
         LH,R7    *R6,R2
         AW,R7    FLP,R6
         B        *R0
GETFILADR EQU     %
         LI,R2    HAFLD             GET ADDRESS OF FILE NAME
         B        GETACNADR1
*
*
*
*
*D*      NAME:    CHKFLACN
*D*      REGISTERS  ALL VOLATILE
*D*      CALL     R0 IS THE LINK
*D*      DESCRIPTION  CHK TO SEE THAT THE DCB HAS SUFFICIENT
*D*               INFORMATION AND SPACE TO OPEN A FILE.
CHKFLACN EQU      %
         LI,D3    X'1FFFF'          MUST HAVE
         CW,D3    KBUF,R6            A KEY BUFFER
         BAZ      ER1406            BRANCH IF NONE
         CW,D3    FLP,R6            AND A VLP
         BAZ      ER1406
*                                   MUST BE SPACE FOR ACCOUNT NUMBER
         LI,D1    2                 LOOK FOR ACCOUNT SPACE
         BAL,R4   LOCCODEB
         B        ER1406            ERROR IF NO ACCT IN DCB
*                                   SET UP ACCOUNT NUMBER
         CI,D2    X'FE'             2 WORDS ARE REQUIRED
         BAZ      ER1406            BRANCH IF NOT ENUF
         LI,R2    HAACD             SET POINTER
         STH,R3   *R6,R2             IN DCB
         LW,R1    J:JIT+ACCN        GET LOGON
         LW,R2    J:JIT+ACCN+1       ACCOUNT
         CI,D2    X'FF00'           BRANCH IF
         BANZ     CHKFA1             USER SPEC'D AN ACCOUNT
         LCI      2                 USE THE
         STM,R1   *R7,R3             LOGON ACCOUNT
CHKFA1   CW,R1    *R7,R3            SEE IF IT'S LOGON ACCT
         BNE      CHKFA2A           SET USR TO ONE
         AI,R3    1
         CW,R2    *R7,R3            CHK LAST 4 CHARACTERS
         BNE      CHKFA2A           BRANCH IF THEY DON'T AGREE
         LI,D3    0                 TO RESET USR
CHKFA2A  LI,D4    X'4000'
         STS,D3   USR,R6
         LI,D1    K1                MUST HAVE FILE NAME
*                                   CHECK FOR NEXT OPTION
         LW,D3    Y01               CLR X'4000' FOR USR RESET
         AND,D3   NXTF,R6
         BNEZ     CHKFLACN3         SPECIFIED
*
         BAL,R5   LOCCODEA
         B        OPER3
         LW,R4    *R7,R3            1ST PART OF NAME
         LH,R2    R4                 & MORE 1ST
         CI,R2    X'0101'           CHK FUNNY FILE OR NO COUNT
         BL       OPER3             BAD NEWS
         CI,R2    FNEMAX**8         CHK BIGGEST NAME ALLOWED
         BL       1A1
*
OPER3    LI,SR4   X'40000'
         AND,SR4  NXTA,R6
         BNEZ     CHKFLACN5
*E*      ERROR:   14-06
*E*      DESCRIPTION  INSUFFICIENT OR CONFLICTING INFORMATION IN DCB
ER1406   LI,SR3   X'1400'**-1+6     14-06
         B        9H38
         SPACE    3
1A1      AND,D2   XFF               #WDS AVAILABLE
         SLS,D2   10                ALIGN
         CW,R2    D2
         BL       CHKFA51           THERE'S ENUF ROOM
*E*      ERROR:   01-00
*E*      DESCRIPTION   FILE NAME TOO LONG FOR DCB
         LI,SR3   1                 NOT ENUF RUUM
         B        OPER
CHKFA51  LW,D2    YC                CHK FOR JOB FILE
         CS,D2    FIL1,R6
         BNE      CHKFLACN5         BRANCH IF NOT
         LI,D1    X'4000'           CHK FOR USER
         CW,D1    USR,R6
         BAZ      CHKFA52           SKIP IF OK
         AWM,D2   FIL1,R6           SET TO SAVE FROM JOB
         B        CHKFLACN5
*
CHKFA52  CI,R2    X'300'            MAKE SURE NAME IS LONG ENUF
         BL       CHKFLACN5         NOT LONG ENUF FOR SUBSTITUTION
         AND,R4   M16               CHK FOR
         CI,R4    '::'               SUBSTITUTION CHARACTERS
         BNE      CHKFLACN5         NO SUBSTITUTE
         LW,D1    J:JIT+SYSID       USE SYSID
         LI,D2    X'FFFF'            FOR
         STS,D1   *R7,R3              SUBSTITUTION
         B        CHKFLACN5
*
CHKFLACN3 BAL,R4  LOCCODEB
         B        ER1406
         CI,D2    X'F8'             MUST BE 8 WORDS OR MORE
         BAZ      ER1406            LESS THAN 8 - ERROR
CHKFLACN5 EQU     %
         LI,R2    HAFLD             SAVE FILE NAME DISP
         STH,R3   *R6,R2
*
         B        *R0
         PAGE
*D*      NAME:    SECCHK
*D*      DESCRIPTION
*DO*
*D*
*        IS USER QUALIFIED TO USE THIS FILE
*                                   CHECK SECURITY
*                                   R3 = DISPLACEMENT IN BUFFER OF DEY
*                                   D3 = BUFFER ADDRESS
*FIN*
SECCHK   EQU      %                 CHECK SECURITY
         LW,D3    R7                FIT POINTER
*                                   MONITOR CAN OPEN ALLFILES
         LI,D1    3                 PASSWORD CODE
         BAL,R4   LOCCODE
         B        SECCHK1           PASSWORD IS NOT SPECIFIED
         CI,D2    X'FEFE'           CHK FOR JOB FILE
         BANZ     SECCH2            BRANCH IF NOT
         INT,SR4  J:JIT+SYSID       CHK THE
         CW,SR4   *R7,R3             USER ID
         BNE      CLRFIB            NO ACCESS
         LW,SR4   YC
         STS,SR4  FIL1,R6           SET JOB FILE SPECIFICATION
         B        PULLE2            IT'S OK
*
SECCH2   RES      0
         LW,R2    R3
         BAL,R5   LOCCODEA
         B        CLRFIB
         BAL,SR4  COMPARE
         B        CLRFIB
         LW,R7    D3                GO BACK AND CHECK ACCOUNTS
*
SECCHK1  LW,SR4   YC
         CS,SR4   FIL1,R6           CHK FOR JOB FILE
         BNE      SECCHK1A          SKIP IF OK
         AWM,SR4  FIL1,R6           RESET TO SAVE FROM JOB
SECCHK1A RES      0
         LI,D1    K4000             IS THIS USERS OWN FILE
         AND,D1   USR,R6
         BEZ      PULLE2            YES--CAN READ & WRITE
         LI,D1    K6                WRITE ACCTS
         BAL,R4   LOCCODE
         B        SECCHK4
SECCHK2  LI,SR2   X'FF'
         AND,SR2  D2
SECCHK2B LW,D2    *R7,R3
         CLM,D2   NONE
         BCR,12   SEC3A             BRANCH IF ALL TO CHK PRIV
         BE       SECCHK2R
         CW,D2    ='PUBL'           IS IT REALLY AVAILABLE?
         BE       SECCHK3            WITHOUT REGARD TO PRIVLEGE?
         LI,D3    J:JIT
         LI,R2    ACCN
         BAL,SR4  COMPARE
         B        SECCHK2A
SECCHK3  CI,D1    K6
         BE       SEC2              RESET USR BIT IF WRITE ACCESS
         LI,D1    X'C0'             CHK PRIVLEGE
         CB,D1    JB:PRIV            FOR C0 OR BETTER
         BG       PULLE2            NOT GOOD ENUF
SEC2     LI,D2    X'4000'           RESET USR BIT IN DCB
         STS,D1   USR,R6            ALLOW WRITE ACCESS
PULLE2   LI,D3    0                 RESET THE
         STB,D3   J:STAR             FETCH FLAG
         SPACE    3
*D*      NAME:    TRNINFO
*D*      CALL  SR1 IS THE LINK
*D*      DESCRIPTION
*DO*
*D*
*****    FPARAM   *****
*  THE FOLLOWING CODE TRANSFERS THE FIT INFO TO THE USER'S
*  FPARAM AREA.
*
*FIN*
TRNINFO  LI,D3    K1FFFF
         AND,D3   FPARAM,R6
         BEZ      *SR1
         LW,R7    D3                CHK BUFFER FOR WRITE ACCESS
         AI,R7    89                END OF BUFFER
         SLS,R7   -9                CONVERT TO PAGE
         BAL,SR4  T:IACU            CHK IT OUT
         BCS,3    CHKADR1           BRANCH IF BAD, CHK SJAC
         LW,R7    D3
         SLS,R7   -9                START OF BUFFER
         BAL,SR4  T:IACU
         BCR,3    TRNOK             BRANCH IF OK
CHKADR1  LW,R7    BOOTFLG
         BNEZ     CHKADR2           ALLOW IF GHOST1
TRNABRT  LI,SR3   X'1400'**-1+2     14-02
         B        9H38
*E*      ERR0R:   14-02
*E*      DESCRIPTION: FPARAM AREA NOT ACCESSABLE FOR WRITE
*
CHKADR2  LW,R7    S:CUN
         LH,R7    UH:FLG,R7
         EOR,R7   BT31TO0+13
         AND,R7   BT31TO0+13  EQ IF BIT WAS SET, ELSE NE
         BNE      TRNABRT           FPARAM NOT IN USER AREA
TRNOK    BAL,R0   SETVAR            GET FIT LOCATION
         NOP
         AI,D3    -9
         LW,2     FRSTWRD
         LI,D2    89                # WDS TO MOVE LESS 1
         LW,D4    FPARAM,R6
         STW,R2   *D4
         AI,D4    1
         LW,R0    *D3
         STW,R0   *D4
         AD,D3    DOUBLEONE
         BDR,D2   %-3
         B        *SR1
*
SECCHK2A AW,R3    R0
         AI,SR2   KN1
         BDR,SR2  SECCHK2B
SECCHK2R CI,D1    K6
         BE       SECCHK4           TRY FOR READS
         LI,D1    X'14'             EXECUTE ACCTS
         BAL,R4   LOCCODE
         B        CLRFIB
         B        SEC1
*
SEC0     LI,D1    X'14'             EXECUTE ACCTS
         BAL,R4   LOCCODE
         B        SEC3A             CHECK THIS GUY'S PRIVLEGE
SEC1     LI,SR2   X'FF'
         AND,SR2  D2
SEC11    LW,D2    *R7,R3
         CLM,D2   NONE
         BE       CLRFIB            NO ACCESS
         BCR,12   SEC99             GIVE ACCESS
         LI,D3    J:JIT
         LI,R2    ACCN
         BAL,SR4  COMPARE
         B        SEC12             NO HIT
SEC99    LI,D1    X'15'             ACCESS VEHICLE
         BAL,R4   LOCCODE
         B        SEC98             TRY FOR FETCH
         LI,R5    X'FF'
         AND,R5   D2                # WORDS IN 'UNDER' VLP
         AI,R5    2
         DW,R5    M2                R5 = # 3-WORD 'UNDER' BLOCKS
         LW,D1    MXFPL+5           M:XX ACCT
         LW,D2    MXFPL+6
         CD,D1    SYSACT            IS IT :SYS
         BNE      CLRFIB            NO ACCESS
         LW,R2    S:CUN
         LB,D2    UB:DB,R2
         BNEZ     CLRFIB            NO ACCESS
         AW,R3    R7
         SLS,R3   2                 BYTE ALIGN
         LW,R4    R3                SAVE BA OF FIRST 'UNDER' DATA WORD
SEC95    LB,R2    MXFPL+1           TEXTC COUNT OF M:XX FILE NAME
         AI,R2    -X'20'            CHK FOR SPECIAL FETCH FLAG
         BLEZ     CLRFIB            NO ACCESS
         CB,R2    0,R3              CHK LENGTHS
         BNE      SEC96             NOT SAME - TRY NEXT NAME
         AI,R3    1                 PASS OVER COUNT
         STB,R2   R3
         LI,R2    MXFPL+1           M:XX NAME
         SLS,R2   2                 BYTE ALIGN
         CBS,R2   1                 DON'T COMPARE COUNTS
         BE       SEC97             MATCH - GIVE ACCESS
SEC96    AI,R4    3*4               POINT TO NEXT 3-WORD BLOCK
         LW,R3    R4
         BDR,R5   SEC95             PROCESS REMAINING ENTRIES
         B        CLRFIB            NO ACCESS
*
SEC12    AW,R3    R0
         AI,SR2   KN1
         BDR,SR2  SEC11
         B        CLRFIB            NO ACCESS
SEC98    LC       J:STAR
         BCR,8    CLRFIB            BRANCH IF NOT FETCH
SEC97    LI,D1    X'C0'             IS IT A BOSS
         CB,D1    JB:PRIV
         BLE      SEC2              BRANCH IF IT IS
         LI,D2    X'100'            SPECIAL ACCESS FLAG
         STS,D2   0,R6
         B        PULLE2
*
SECCHK4  RES      0
         BAL,D2   GETFUN
         CI,D1    14
         BANZ     CLRFIB            NO ACCESS
         LI,D1    K5                READ ACCTS
         BAL,R4   LOCCODE
         B        SEC0
         B        SECCHK2
*
SEC3A    LI,R4    X'40'
         CB,R4    JB:PRIV           CHK FOR 40 OR BETTER
         BLE      SECCHK3           GIVE ACCESS
         BAL,R0   GETACNADR         GET THE ACCOUNT LOC
         LW,R2    0,R7              PICK UP
         LW,R3    1,R7               THE ACCOUNT
         CD,R2    SYSACT            IS IT :SYS
         BE       SECCHK3           GIVE ACCESS
         LW,R7    D3                RESTORE FIT POINTER
         CI,D1    6                 WAS IT WRITE
         BE       SECCHK4           TRY FOR READ ACCESS
CLRFIB   LI,D1    X'C0'             C0 USERS ARE BOSS
         CB,D1    JB:PRIV
         BLE      SEC2              IT'S A BOSS
         LI,R0    BUF2MSK
         AND,0    BUFX,R6
         BEZ      ER1400            BRANCH IF NO FIT
         LI,R2    WXBUFSIZ-1
         STW,R2   BUFF2,R2          DESTROY THE FIT
         BDR,R2   %-1
*E*      ERROR:   14-00
*E*      DESCRIPTION  ACCESS DENIED BECAUSE OF PASSWORD,
*E*               READ/WRITE ACCOUNT, OR ACCESS VEHICLE/ACCOUNT
ER1400   EQU      %
         LI,SR3   K14
*D*      NAME:    OPER
*D*      DESCRIPTION  ALL FILE OPEN ABORTS COME HERE
*D*               TO RUN DOWN ANY BFRS OR CFUS OR PRIVATE VOLUMES
OPER     RES      0
         PUSH     SR3               SAVE ERROR CODE
         BAL,SR4  TRUNC             GET RID OF BUFFERS
         LI,SR4   X'E'
         CW,SR4   ASN,R6
         BANZ     OERX1             BR IF NOT DISC FILE
         LI,R0    DCBPRIVBIT
         CW,R0    PRIV,R6
         BAZ      %+2               NOT PRIVATE
         BAL,SR4  CLSVNO            CLOSE ANY OPEN VOLUMES
         PULL     SR3               RESTORE ERROR CODE
         LI,R1    0
         STB,R1   J:STAR            RESET FETCH FLAG
         LI,R1    X'1FFFF'
         AND,R1   CFU,R6
         CI,R1    BGRCFU
         BGE      2W3
         LW,R1    J:BASE+7
         CI,R1    BGRCFU
         BL       3A3               NO CFU HERE
         CI,R1    X'FFFF'
         BGE      3A3
2W3      RES      0
         LW,D2    0,R1
         AI,D2    -X'20000'         DECREASE # OF USERS
         CW,D2    Y00FE
         BANZ     3A1               THERE'S A USER
         MTW,-1   C:CFU             DECR # OPEN CFUS
         MTW,1    ACNCFU+12
         LI,R2    X'FFFF'           CHK 4 SCFU
         AND,R2   SCFU,R1
         BEZ      3A2               THERE'S NONE
         LI,R3    X'F0000'
         AND,R3   SCFU,R2
         STW,R3   SCFU,R2
3A2      RES      0
         LI,D2    0
         STW,D2   2,R1              CLOBBER THE NAME & ACCT
         STW,D2   SCFU,R1
3A1      RES      0
         STW,D2   0,R1
3A3      LI,D1    X'3F00'
         AND,D1   RNDEV,R6          DEVICE TYPE
         LI,D2    X'1FFFF'          MOVE TO DSI FOR NEXT OPEN
         STS,D1   DSI,R6
         B        OERX              EXIT
         PAGE
*
*D*      NAME:    SETACOG
*D*      REGISTERS  ALL VOLATILE
*D*      CALL     SR4 IS LINK
*D*      DESCRIPTION  SET ACCESS & ORGANIZATION.  ALSO GET
*D*               PRIVATE VOLUMES MOUNTED AS APPROPRIATE.
SETACOG  EQU      %                 SET ACCESS AND ORGANIZATION
         BAL,R4   ORGCHK
         BNE      SETACOG1
         BAL,D2   GETFUNA
         BAZ      SETACOG1
         LW,D1    Y0008
         LW,D2    Y00FE
         STS,D1   FUN,R6            SET FUN = UPDATE
         B        *SR4
SETACOG1 EQU      %
         BAL,D2   GETFUNA
         BANZ     PPSET0X
         LI,D1    K9
         BAL,R4   LOCCODE           GET FILE INFO
         B        PPSET0X
         LW,D1    *R7,R3
         LI,D2    1
         SLD,D1   17
         STS,D1   CYL,R6            SET CYL ALLOC
         SLS,D1   -1
         SLD,D1   -8
         STS,D1   NOSEP,R6          NOSEP(INDEX ON PACK)
*                                   R3 = DISPLACEMENT OF CODE
         LM,D2    *R7,R3
         LB,D1    D2                ORG
         SLS,D1   K4
         LI,R1    BAKEYM
         LH,R0    D2                KEYM
         STB,R0   *R6,R1
         STW,D3   WRDL0,R6          SLIDES,LSLIDES,LRDL0,SPARE
*
*        MUST ASSURE CORRECT NUMBER OF VOLS ARE OPEN
*        FOR PRIV. PACKS, WHEN REPLACING EXISTTINGG
*        FILES, WHEN CONSEC IS INVOLVED
*
         LI,R1    X'800'
         CW,R1    PRIV,R6
         BAZ      PPSET0            NOT PRIVATE CONTINUE
         LI,D2    X'20'             CHECK THAT PROPER # VOLS OPEN
         CS,D1    ORG,6
         BE       PPSET0            YES
         PUSH     2,11              NOW GO OPEN THE PROPER NUMBER
         BAL,11   CLSVNO            CLOSE ALL OPEN VOLUMES
         STS,D1   ORG,6             SET ORG PROPERLY
         LI,9     X'80000'          SET 9 NEG SO OPV KNOWS US
         OVERLAY  MULSEG,OPV#
         PULL     3,11
         AI,13    0                 CHECK RETURN CODE FROM OPV
         BEZ      OPER              NO GOOD
PPSET0   LI,D2    X'70'
         STS,D1   ORG,R6
PPSET0X  EQU      %
         LI,R3    3                 ASSUME CONSEC
         LI,1     BAKEYM
         LI,2     X'20'
         CW,2     ORG,R6            ORGTEST
         BAZ      SETACOG3B         IT'S CONSEC
         LB,R3    *R6,R1
         BNEZ     SETACOG3A
         AI,R3    11
SETACOG3B   EQU   %
         LW,R0    SR4
         STB,R3   *R6,R1
         AI,R3    1
SETSCR   LI,R2    BASCR
         STB,R3   *R6,R2
         B        *R0
SETACOG3A  EQU    %
         CI,R3    FNEMAX-1          KEY CAN'T BE TOO LARGE
         BLE      SETACOG3B
         LI,R3    FNEMAX-1
         B        SETACOG3B
         SPACE    3
*
*D*      NAME:    DCBNCHK
*D*      REGISTERS  R2,R4,R5,SR1,D1, & D2 ARE VOLATILE
*D*      CALL     SR4 IS THE LINK, SKIPPING EXIT IF FOUND
*D*      DESCRIPTION
*DO*
*D*
*     CHECKS DCB NAME FOR 4 CHARS STARTING M: AND ENDING
*            WITH AN OPLBL.  EXITS SKIPPING IF PRESENT
*FIN*
DCBNCHK  RES      0
         LW,R2    TSTACK
         LW,R4    -4,R2
         LB,SR1   R4
         LW,D1    0,R4
         LW,D2    1,R4
         SLD,D1   -8
         CI,D1    X'4D47A'
         BNE      BISR4
         SLD,D1   16
         LI,R2    17                # ENTRIES FOR FILE EXTENSION
         LI,D2    KFFFF
OPFIND1  LH,D3    SH:OPNM,2         FIND M:II OPLB
         CS,D1    D3
         BE       OPFIND2           MATCH
         BDR,R2   OPFIND1
         CW,D1    MGODCB            M:GO ISN'T IN TABLE
         BNE      *SR4
         LI,R2    1                 M:GO IS FIRST ENTRY
OPFIND2  RES      0
         LI,D2    K1
         SLS,D2   -1,R2
         AI,SR4   1
BISR4    RES      0
         B        *SR4
MGODCB   TEXT     'M:GO'
FRSTWRD  DATA     X'01000909'       VLP CTL WD FOR FIT
*
         END

