MONPROC  SET      1
ANSPROC  SET      1
         SYSTEM   UTS
         DEF      OPNTP
OPNTP    EQU      %
*                 SIGMA 5/7         BPM M:OPNT
         PAGE
K0       EQU      X'0'
K10000   EQU      X'10000'
K1FFFF   EQU      X'1FFFF'
         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     REFS
         REF      AVRTBL
         REF      TAPECHK
         REF      GETAVR
         REF      Y01
         REF      ANSFLGS
         REF      ANSPRT
         REF      AVRFNMT
         REF      AVRFLGS
         REF      BAQBUF
         REF      BATAPE,NBATAPE
         REF      GETTYC
         REF      IOSPIN
         REF      JB:PRIV
         REF      JULIAN
         REF      PUTSZBF
         REF      RDCLS
         REF      REWTP
         REF      SETTYC
         REF      SKRECR
         REF      SOLICIT
         REF      TB:FLGS
         REF      TB:FLGS1
         REF      Y4
         REF      XA
         REF      OPER
         PAGE     DEFS
         REF      OPNX
         REF      OPNLA
         REF      OPNLO
         REF      AOPNL1
         REF      OPNLBL
         REF      CLSTP
         REF      MSRCLSLBL
         REF      CLSLBL
         REF      RELTP
         PAGE
         DEF      OPNT1
         DEF      OPNT
         DEF      PROTCHK
         PAGE
         AI,0     %+1
*
         B        *0
         B        OPNLA
         B        OPNLO
         B        OPNT
         B        AOPNL1
         B        OPNLBL
         B        OPNT1
         B        RDCLS
         B        CLSTP
         B        MSRCLSLBL
         B        CLSLBL
         B        RELTP
         PAGE
         PAGE     OPNT
*                                   GET SERIAL NO. FOR TAPE
OPNT     EQU      %
         REF      OPNT2
         BAL,2    OPNT2
*
OPNT1    EQU      %
         BAL,5    TAPECHK
         LI,D2    1A1
         DEF      OPNT3
OPNT3    RES      0
         BAL,R3   GETAVR
         OR,R1    Y01               SET OPEN BIT
         AI,R1    K10000
         STD,R0   AVRTBL,R2         SET TO BUSY
         B        *D2
1A1      RES      0
*
         BAL,SR4  CCCHK
*
         REF      SETOPN
         BAL,0    SETOPN
         LI,D2    K1FFFF
         STS,D1   CLK,R6
*
*
ABN1411  EQU      %
         DEF      ABN1411
         LW,SR3   L(X'11'**25+X'14')
         B        OPER              REQUEST ASCII ON DRIVE W/O CC
         PAGE
ASCVOL1  DATA     X'564F4C31'       ASCII 'VOL1'
*
         DEF      VOL1,:ACN
BAAVRFNMT STB,SR4 AVRFNMT,R1
MVJXPR   GEN,8,24 5,19
         DEF      BAAVRFNMT
*
         BOUND    8
80UHL1   GEN,24,8,32 ,80,'UHL1'
80UTL1   GEN,24,8,32 ,80,'UTL1'
         DEF      80UHL1
         DEF      80UTL1
Y45      DATA     X'45000000'
         DEF      Y45
*
* SIXPACK HASHES A 6 CHARACTER SERIAL # INTO 1 WORD
* R1=BYTE ADDRESS OF SERAL #
* R2=RESULTS
* CALL BAL,SR4    SIXPACK
         DEF      SIXPACK
*
SIXPACK  EQU      %
         PUSH     3,R3
         LI,R5    0
         LI,R4    6
SIXPACK1 EQU      %
         LB,R3    0,R1
         AI,R1    1
         SLS,R3   26
         SLD,R2   2
         SLS,R3   -28
         MI,R5    10
         AW,R5    R3
         BDR,R4   SIXPACK1
         SLS,R2   20
         OR,R2    R5
         PULL     3,R3
         B        *SR4
         PAGE
PROTCHK  EQU      %                 SUBROUTINE TO PERFORM TAPE PROTECT
*                                     CHECKS FOR ANS. CALLED FROM USECHK
*                   IN OPNL. ENTERRED BY OVERLAY
*                   LBLTSEG,9. RETURNS SR1=0 IF TAPE OK,
*                   OR SR1=-1 IF NG.
         PUSH     SR4
         BAL,R3   GETAVR
*                       IF NOT PROTECTED, SKIP TO RING CHK
         LW,R3    ANSPRT
         BLZ      PROT7T
*                      7T ANS NOT SUPPORTED, SO BYPASS CHECKS
         LI,R3    X'3F00'
         AND,R3   DSI,R6            TYPE
         SLS,R3   -8
         LB,R3    TB:FLGS,R3
         AND,R3   L(X'C4')
         CI,R3    X'80'             7T
         BE       PROT7T            YES
         CI,12    IN
         BANZ     PROTOK            SKIP PROTCHK FOR IN
*
         LB,R3    ANSFLGS,R2        CLR ERROR BITS
         AND,R3   XCF
         REF      XCF
         STB,R3   ANSFLGS,R2
         CI,R3    4
         BAZ      PROT0B
*                    REOPEN OF IN MOUNT-IF AT LP, DO PROTCHK
         CW,R1    L(X'60007FFF')
         BAZ      PROT0B            AT LP, DO CHECKS
         CI,12    OUT+OUTIN         IF INOUT, FORCE IN SINCE NOT AT LP
         BANZ     PROTNG            OR FORCE ERROR IF OUTPUT
         LI,SR2   -3**17
         AWM,SR2  FUN,R6
         B        PROTOKIN
PROT0B   EQU      %
         AND,R1   NB31TO0+25        CLR OPN FOR KEYIN/AVR
         STD,R0   AVRTBL,R2
         CW,R1    Y2                CHK IF AVR'D
         BANZ     PROT1
         CI,R3    2
         BANZ     PROT2             YES-CHK IF PRIV=C0
PROT0A   EQU    %    REW TAPE, CHK 1ST RECORD FOR VOL1
         BAL,SR2  REWTP
         BAL,SR2  GETFLG1
         BCR,4    PROT0D            NO CC
         BAL,SR4  SETEBCD
PROT0D   EQU      %
         BAL,0    ANSLINIT
         REF      ANSLINIT
PROT0C   EQU      %
         STW,SR2  *D3               HSKP BUFFER
         LI,D1    0
         BAL,R0   SETTYC
         BAL,SR2  READTP
         BAL,SR4  IOSPIN
         REF      READTP
         LW,D3    QBUF,R6           GET ADDRESS OF BUFFER
         LW,SR2   *D3
         CW,SR2   ASCVOL1           CHECK FOR ASCII LABELS
         BE       PROASC
         LI,SR4   PROT3             IF NOT ANS, MUST RELEASE MB NOW
         CW,SR2   VOL1              IS ANS TAPE
         BNE      RMB
         BAL,R4   GETTYC
         CI,R3    1
PROT0E   EQU      %
         BG       RMB               ANY ABN=NOT ANS,E.G.,DEGAUSED
         BAL,R3   GETAVR            ASSURE AVR:SN SET
         LW,5     TSTACK
         LW,12    -1,5
         CI,12    X'2000'
         BAZ      PROT4             BRANCH IF NOT ANS DCB.
         LW,R1    D3
         AI,R1    1                 STEP TO BA OF SN
         SLS,R1   2
         BAL,SR4    SIXPACK
         CW,R0    R2                DO SN.S AGREE
         BE       PROT4
         CI,R0    -1
         BE       PROTSN            ANSSCRATCH...SO SAVE SN
         LI,SR4   PROT3C
         CI,12    X'4000'
         BAZ      RMB
         CI,R0    0                 ASSURE AVR:SN SET
         BNE      PROT4
PROTSN   EQU      %
         STW,R2   SR4
         BAL,R3   GETAVR
         STW,SR4  0
         STD,0    AVRTBL,2          SAVE SN IN AVR
PROT4    EQU      %
         BAL,SR2  READTP            READ HDR1
         BAL,SR2  SKRECR             AND REPOSITION BEFORE HDR1
         BAL,SR4  IOSPIN
         BAL,R3   GETAVR
         CW,R1    Y2                REW IF NOT AVR'D
         BANZ     %+2
         BAL,SR2  REWTP
         LW,D3    QBUF,R6
         ANLZ,SR3 BAQBUF
         LW,R1    R2                AVR INDEX
         MI,R1    6*4
         ANLZ,SR4 BAAVRFNMT         BYTE ADDRESS AVRFNMT
         AW,SR4   MVJXPR
         MBS,SR3  48
         BAL,SR4  RMB
PROT5    EQU      %                 MUST BE EXPIRED TO WRITE
         LW,5     TSTACK            RETRIEVE R12
         LW,12    -1,5
         REF      GMB,RMB
         BAL,SR4  JULIAN            SR1-2 = EBCDIC DATE
         BAL,R3   GETAVR
         LI,R1    6
         MW,R1    R2                FETCH TAPE EXP DATE F/AVR
         LW,SR3   AVRFNMT+4,R1      EXP DATE
         LW,SR4   AVRFNMT+5,R1
         OR,SR3   L(X'F0F0F0F0')    FORCE NUMERIC IN CASE OF ASCII
         OR,SR4   L(X'F0F0F0F0')
         AND,SR3  M8
         REF      M8
         CD,SR1   SR3
         BGE      PROT3B            TAPE EXPIRED
         LI,R1    2
         CI,12    X'2000'
         BANZ     PROT6
         LI,R1    3                 NO  'ANS VOL'
         B        PROT6
PROT2    EQU      %
         MTW,0    ANSPRT            NO BLP IF PROTECTED INSTALATION
         BLE      PROTOK2
         LB,1     JB:PRIV           CHK FOR C0 PRIV FOR BLP USER
         CI,1     X'C0'
         BGE      PROTOK2
         B        PROT0A
PROASC   EQU      %
         BAL,SR2  GETFLG1
         BCR,4    PROT0E
*
         BAL,SR4  SETASCII
         BAL,SR2  REWTP
         B        PROT0C
PROT1    EQU      %
         LB,1     ANSFLGS,R2
         CI,1     X'80'
         BANZ     PROT5             TAPE IS ANS
PROT3    EQU      %                 TAPE NOT ANS
         BAL,R3   GETAVR
         LW,5     TSTACK            RETRIEVE R12
         LW,12    -1,5
         CI,12    X'2000'           DCB ANS
         BANZ     PROT3A            YES
         LD,0     AVRTBL,R2         NO-IF NOT AVR'D, REW
PROT7T   EQU      %
         CW,1     Y2
         REF      Y2
         BANZ     PROTOK
PROT3B   EQU      %
         BAL,SR2  REWTP
         B        PROTOK
PROT3C   EQU      %
         BAL,SR2  REWTP
         LI,R1    1
         LI,SR4   ANSREEL
         REF      ANSREEL
         B        PROT6A
PROT3A   EQU      %
         BAL,SR2  REWTP
         LI,R1    1                 'NOT ANS'
PROT6    EQU      %                 PUT OUT ERROR MESSAGE
         LI,SR4   ANSERR
         REF      ANSERR
PROT6A   EQU      %
         LI,R2    BADSI
         LB,R2    *R6,R2
         AI,R2    NBATAPE
         STB,R1   SOLICIT,2         SET SOLICIT NON-ZERO
         LW,R4    R1
         LB,D4    ANSFLGS,2
         SLS,R4   4
         OR,D4    R4
         STB,D4   ANSFLGS,2         SET ERROR BITS
         AW,R1    TERR
         CI,R1    X'100'
         BAZ      %+2
         LW,R1    L('RING')         ENTRY FROM PROTOKIO
         PUSH     R1                SAVE R1 FOR BELOW
         BAL,SR4  *SR4
         PULL     R4                MESSAGE WORD
         CI,R0    0                 DID USER ABORT OR SOMETHING
         BLE      PROTNG1           SURE DID
         BAL,R3   GETAVR
         LB,1     ANSFLGS,R2
         CW,R4    L('RING')
         BE       PROTOK1           RETURN FROM SPECIAL ENTRY
         CI,1     X'30'             CHK ERR FLAGS-0=OVER RESPONSE
         BANZ     PROTNG
         LW,1     ANSPRT
         BEZ      PROTOK            NOT PROTECTED INSTALLATION
         LB,1     JB:PRIV
         CI,1     X'C0'             IS USER AT LEAST CO PRIV
         BL       PROTNG
PROTOK   EQU      %
*                   WRITE RING CHECK
         BAL,R3   GETAVR            AVR IX TO R2
         LI,R3    -1
         LW,D1    *TSTACK,R3        FLAGS TO D1
         CI,D1    IN
         BAZ      PROTOKIO
*                   IN-SET IN ONLY
PROTOKIN EQU      %
         LB,R3    ANSFLGS,R2
         OR,R3    X4                SET IN ONLY
         B        PROTOK3
PROTOKIO EQU      %                 INOUT-DO CHECK
         BAL,R4   GETTYC
         CI,R3    8
         BGE      PROTNG            SKIP OUT IF ERROR
         AI,R2    BATAPE
         LW,R3    R0                GET SN
         LD,R0    DCT13,2
         AI,R2    NBATAPE
         CW,1     Y4
         BANZ     PROTOK2           OK-RING IN
         LI,1     X'101'            'RING' MESSAGE....
*                                      1 FOR ERR FLAG
*                                     100 FOR 'NOT ANSERR'
         B        PROT6             DO MSG,WAIT KEYN,RETURN
PROTOK1  EQU      %                 RETURN FROM TYPR
         AND,1    XCF
         CB,1     ANSFLGS,R2
         BNE      PROTOK4
         LI,3     -1
         LW,D1    *TSTACK,R3
         CI,D1    OUT+OUTIN         NO 'READ' FOR OUTPUT
         BAZ      PROTOKIN
PROTOK4  EQU      %
         STB,1    ANSFLGS,R2        CLEAR ERROR FLAGS
         LD,0     AVRTBL,R2         CLR AVR BIT SO WILL DO REW
         AND,1    NB31TO0+31
         STD,0    AVRTBL,R2
         B        PROT0A             CHECK IF RING NOW IN
IN       EQU      X'100'
OUT      EQU      X'200'
INOUT    EQU      X'400'
OUTIN    EQU      X'800'
PROTOK2  EQU      %
         LB,R3    ANSFLGS,R2
         AND,R3   NB31TO0+3         CLR RD BIT
PROTOK3  EQU      %
         STB,R3   ANSFLGS,R2
         REF      DCT13
         LI,SR1   0
         B        PROTX
PROTNG   EQU      %
         LI,0     2
PROTNG1  EQU      %
         LI,1     -7                SAVE R0 IN TSTACK FOR ABORT TEST
         STW,0    *TSTACK,1
         LI,SR1   -1
PROTX    EQU      %
         PULL     SR4
         B        *SR4
TERR     TEXT     'ANS0'
         PAGE
TRNABRT  EQU      %                 DO 14 02 ERROR
         BAL,SR4  RLSBF
         REF      RLSBF
         LW,SR3   L(2**25+X'14')
         B        OPER
         DEF      TRNABRT
         SPACE    3
OPNTPSZ  EQU      %-OPNTP
ABN3001  EQU      %                 BAD USER HEADER
         REF      ABNRMB
         DEF      ABN3001
         LW,SR3   %+2
         B        ABNRMB
         ERRABNCD X'30',1
         SPACE    3
GETFLG1  EQU      %          SETS COND CODE FROM HI-ORDER TB:FLGSI
         DEF      GETFLG1
         LI,1     X'3F00'
         AND,1    DSI,6
         SLS,1    -8
         LC       TB:FLGS1,1
         B        *SR2
         SPACE    3
SETEBCD  EQU      %
         DEF      SETEBCD,SETASCII
*                   SETS AVRFLGS:CC TO EBCDIC IF DRIVE HAS CC
*                   AND DOES MODE SET
         LI,1     0
SETCC    EQU      %
*                   ENTRY POINT COMMON TO SETEBCD/ASCII
         BAL,SR2  GETFLG1
         BCR,4    *SR4              NO CC SO DONT TRY
*
DOCCMS   EQU      %                 DO CC MODE SET
         LB,0     AVRFLGS,2
         AND,0    NB31TO0+7         CLR CC
DOCCMS1  EQU      %
         DEF      DOCCMS1
         OR,0     1                 NEW CC BIT
         STB,0    AVRFLGS,2
         SLS,1    -6                RT JUSTIFY
         LW,15    CCMS,1
         B        MODSET            DOIO W/ R15=CODE
         REF      MODSET
CCMS     DATA     X'08000000',X'10000000'  0,1 CODE CONV-NO,YES
:ACN     TEXT     ':ACN'            2
:LBL     TEXT     ':LBL'            3
         DEF      :LBL
         DATA     X'40000000'       4 SET 800BPI
VOL1     TEXT     'VOL1'            5
         DATA     X'80000000'       6 SET 1600BPI
*
SETASCII EQU      %
*                   SETS AVRFLGS:CC TO ASCII IF DRIVE HAS CC
*                   AND DOES MODE SET
         LI,1     X'40'
         B        SETCC
CCCHK    EQU      %
         DEF      CCCHK
*                    CHECKS DCB:CCF, AVRFLGS, TB:BLGS1
*                    FOR CODE CONVERSION CHANGE.  DOES CHANGE IF
*                    APPROPRIATE, OR GIVES ERROR RETURN.
*                 R2=AVRIX
*                 R6=DCB ADDR
*                 SR4=LINK
         BAL,SR2  GETFLG1
         BCR,4    CCCHK1            NO CC...CHECK DCB
         LI,R0    X'F'
         AND,R0   ASN,R6
         CI,R0    3
         BNE      CCCHK2            NOT DEVICE SO MUSN'T CHANGE
DOCCSET  EQU      %
         DEF      DOCCSET
         LW,SR2   SR4
         LI,R1    X'80'
         AND,R1   ORG,R6            GET DCB:CCF
         BNEZ     SETASCII
         B        SETEBCD
*
CCCHK1   EQU      %
         LI,R1    X'80'
         AND,R1   ORG,R6
         BNEZ     ABN1411
*
CCCHK2   LB,R0    AVRFLGS,R2
         SLS,R0   1
         AND,R0   BT31TO0+8
         LI,R1    X'80'
         AND,R1   ORG,R6
         EOR,R1   R0
         BEZ      *SR4              DCB AND AVR SAME
*
ABN1413  LW,SR3   L(X'13'**25+X'14')
         DEF      ABN1413
         B        OPER
         END      OPNTP

