*****************
*M* RDERLOG PROCESS READ/WRITE ERRLOG & DIAGNOSTIC CAL'S
*****************
         DEF      FISH:             PATCHING DEF
FISH:    RES      0 FUNCTIONAL INTEGRITY OF SYSTEM HARDWARE MODULE BASE
*    CREATED 6/22/72  KDR
MONPROC  SET      1
  TITLE  '* * CP-V / ERR:FIL INTERFACE * *'
         PAGE
TEST     SET      0                 =0, NO TEST MODE CODE
*                                   =1, TEST MODE(ON-LINE DEBUGGING)
********
* CODE FOR ON-LINE DEBUGGING ONLY.....
****
         DO       TEST=1
DISABLE  CNAME    1
ENABLE   CNAME    2
         PROC
LF       NOP      NAME
         PEND
         FIN
********
*P***************
*P*      NAME:    RDERLOG, FISH
*P*      PURPOSE: TO PROCESS USER CAL1,6 PROCEDURES FOR ON-LINE
*P*               DIAGNOSTICS & READ/WRITE ERRLOG INFO.
*P*      DESCRIPTION: THIS MODULE IS PART OF THE CP-V OVERLAY
*P*               RMAOV. THE CAL1,6 PROCESSOR INTERPRETES &
*P*               PERFORMS THE REQUESTS FOR THE FOLLOWING SYSTEM
*P*               PROCEDURES:
*P*                 1. M:DMOD#
*P*                 2. M:DPART
*P*                 3. M:DRET
*P*                 4. M:LOCK
*P*                 5. M:MAP
*P*                 6. M:DOPEN
*P*                 7. M:DCLOSE
*P*                 8. M:BLIST
*P*                 9. M:SIO
*P*      REFERENCE:  SPECS.DWG.# 703198,703240,703126,703162
*P***************
         PAGE
         REF      BUF1,BUF2         ERROR LOG BUFFER ADDRESSES
EBUF1    EQU      BUF1
EBUF2    EQU      BUF2
         CLOSE    BUF1,BUF2
         SYSTEM   UTS
         PAGE
*
*        EXTERNAL REFERENCES FRO ERR:FIL INTERFACE
*
         REF      BATYC             * BYTE ADDRESS OF TYC DCB SLOT
         REF      CC0RST            * RESET CC0 IN USER'S PSD
         REF      CHKDA             * EXAM D/A ROUTINE
         REF      CJOB              * LOCATION X'4F'
         REF      CKLIMIT           * CHK BUF ADRS ROUTINE
         REF      CURBUF            * ERROR LOG CURRENT BUF POINTER
         REF      CURGRAN           * CURRENT SECTOR OF ERROR FILE
         REF      ERRLOG40          * END ACTION RCVR FOR ELOG I/O
         REF      ERRLOG5           * ROUTINE TO GET ERROR LOG GRANULES
         REF      IOSPIN           * WAIT FOR I/O COMPLETE  (IORT)
         REF      M17               * DATA X'0001FFFF'
         REF      M24               * DATA X'00FFFFFF'
         REF      QUEUE             * I/O WITH A DCB-NO END ACTION
         REF      RBG               * RELEASE USER FILE GRANULE
         REF      SGRAN             * STARTING SECTOR OF ERROR FILE
         REF      SYSACCT           * TEXT OF ':SYS   '
         REF      TRAPEXIT          * EXIT CAL RETURN POINT
         REF      Y01               * DATA X'01000000'
         PAGE
*
*  DRIVER FOR RMAOV
*
         AI,0     DRIVE
         B        *0
DRIVE    EQU      %-1
         B        T:RDERLOG
         B        T:WTERLOG
         B        T:MODPRTRT
         B        T:BLIST
         B        T:DOPEN
         B        T:DCLOSE
         B        T:LOCK
         B        T:MAP
         B        T:CLOSIT
         RES      5
DRSZ     EQU      %-DRIVE
         PAGE
*F*
*F*      NAME:
*F*               T:RDERLOG
*F*
*F*      PURPOSE:
*F*               CAL PROCESSOR FOR READ ERROR LOG CALS.
*F*
*F*      DESCRIPTION:
*F*               TYPICALLY ERR:FIL IS THE GUY WHO HAS EXECUTED
*F*               THE READ ERROR LOG CAL.
*F*
*F*               IF ERR:FIL'S BUFFER ADDRESS CHECKS OUT OK - WE
*F*               WILL EITHER READ THE NEXT SECTOR OF THE FILE AND
*F*               EXIT TO ERR:FIL - OR WE WILL SEE IF THE INCORE
*F*               BUFFER(S) CAN BE PASSED TO ERR:FIL.
*F*
*F*               IF WE EITHER PERFORM I/O SUCCESSFULLY OR PASS
*F*               AN INCORE BUFFER WE PASS BACK CONDITION CODES TO
*F*               ERR:FIL TO INDICATE TO HIM TO DO THE CAL AGAIN UNTIL
*F*               WE HIT THE END OF FILE OR THERE ARE NO MORE BUFS
*F*               TO PASS HIM.
*F*
*F*               CERTAIN ERROR EXITS CAN BE TAKEN BACK TO  THE
*F*               READ ERROR LOG CAL, IE;
*F*
*F*      CONDITION CODE             MEANING
*F*      -------------              ----------------------------------
*F*      CC1 - CC4 = 0              GAVE YOU A BUFFER
*F*      CC1 = 1                    YOU ARE NOT AUTHORIZED
*F*      CC2 = 1                    GOT AN I/O ERROR TRYING TO READ IT
*F*      CC3 = 1                    NO MORE TO GIVE YOU
*F*      CC4 = 1                    CURRENTLY UN-USED
*F*
         PAGE
*F*
*F*      NAME:
*F*               T:RDERLOG
*F*
*F*      PURPOSE:
*F*               CHECKS TO SEE IF I/O SHOULD BE DONE AND IF SO
*F*               DOES IT .
*F*
*F*      DESCRIPTION:
*F*               1. CHECKS FOR :SYS AND IF OK GOES TO STEP 3.
*F*               2. ABORTS IF STEP# 1 FAILED.
*F*               3. CHECKS FOR BUFFER LIMITS OK-IF SO GOES TO STEP#5.
*F*               4. ABORTS IF STEP#3 FAILED.
*F*               5. CHECKS IF ANY BUFFERS TO READ INTO CORE-GOES TO
*F*                  STEP 7 IF SO.
*F*               6. CHECKS IF ANY INCORE BUFFERS CAN BE MOVED - GOES
*F*                  STEP#9 IF SO.
*F*               7. PERFORMS I/O INTO USER'S BUFFER.
*F*               8. EXITS TO CAL USER IF I/O OK.
*F*               9. MOVES INCORE BUFFER TO USER IF BUFFER HAS
*F*                  ANYTHING IN IT.
*F*
*F*
*F*               BUFFER CHECKING IS DONE VIA 'CKLIMIT'
*F*
*F*               EXIT IN EITHER NORMAL/ABNORMAL CASE IS TO
*F*               'TRAPEXIT'.
*F*
T:RDERLOG EQU     %
         LW,5     CJOB              GET JIT POINTER
         LW,7     TSTACK            GET PSD POINTER
         AI,7     -17
         LCI      2                 :SYS IS A MUST
         LM,12    1,5
         CD,12    SYSACCT
         BNE      T:EXIT2
         PUSH     3,6
         XW,6     7
         LI,15    1024              RECL IN BYTES
         BAL,0    CKLIMIT
         STCF     0
         PULL     3,6
         LC       0
         BCR,3    T:1
T:EXIT2  LCI      8
T:EXIT   BAL,0    T:SCC
T:EXIT1  EQU      %
         BAL,5    ERRLOG5           LET ERRLOG CATCH UP ON GRANULES
         ENABLE
         DESTRUCT TRAPEXIT
T:SCC    STCF     11
         LD,12    *7
         LCF      11
         STCF     12
         STD,12   *7
         B        *0
         PAGE
*
*        USER PASSES - SEE IF WE MUST READ THE MONITORS'S FILE
*        BUILT BY ERRLOG - OR PASS THHE IN CORE BUFFER IF NO I/O
*        IS REQUIRED.
*
T:1      EQU      %
         DISABLE                    * * * DISABLE * * *
         LW,1     SGRAN
         BEZ      T:30              CORE BUFFER IS ONLY BUFFER
         LW,2     CURGRAN           GET THE CURENT GRANULE
         BEZ      T:30              NONE
         CW,2     1                 SGRAN = CURGRAN
         BE       T:30              YUP--NO I/O TO DO
T:2      EQU      %
         ENABLE
         LW,8     TSTACK            PUSH A SMALL DCB INTO TSTACK
         AI,8     1
         LI,12    9
         MSP,12   TSTACK
         LCI      7
         LM,9     ERLOGDCB
         LW,0     6
         AND,0    M17
         OR,0     Y01               SET FCN = 1
         LCI      9
         STM,9    *8
         BAL,11   QUEUE
         XW,6     8                 DCB TO 6 / BUF ADRS TO 8
         BAL,11   IOSPIN            WAIT FOR I/O TO COMPLETE
         XW,6     8                 BUF ADRS TO 6 / DCB TO 8
         LI,4     BATYC
         LB,4     *8,4
         CI,4     X'FC'
         BAZ      T:3                NO ERROR
         LCI      4                 ERROR, SET CC FOR RETURN
         BAL,0    T:SCC
         DISABLE
         LI,12    0                 CAN'T TRUST DA'S SO JUST IGNORE
         STW,12   SGRAN             ALL THE REST OF THE FILE
         B        BUMPSTK           CLEAR STACK AND GET OUT
*
*        RELEASE THE BUFFER BACK LINK - SAVE THE FORWARD LINK
*        FOR THE NEXT READ OF THE MONITOR FILE
*
T:3      EQU      %
         LI,8     0
         XW,8     0,6               GET/CLEAR BACK LINK DISC ADDRS
         BEZ      %+2               NO BACK LINK THERE
         BAL,11   T:RBG             SEE ABOUT DISC ADDRESS
*
*        NOTE:    THE DISC ADDRESS EITHER GOES BACK TO ERROR
*                 LOG OR ITS GIVEN TO GRAN.
*
         DISABLE
         LI,8     0
         XW,8     1,6               GET/CLEAR FWD LINK DISC ADDRS
         LI,4     0                 IN CASE OF ERROR
         BAL,11   CHKDA             CHECK DISC ADDRESS
         BEZ      %+2               BAD ----- CANT SAVE
         XW,4     8                 IF GOOD SWITCH AROUND
         STW,4    SGRAN             SAVE GOOD OR BAD VALUE
T:4      LCI      0                 SET CC'S
         BAL,0    T:SCC             FOR ERR:FIL
BUMPSTK  LI,1     -9                CLEAR STACK OF DCB
         MSP,1    TSTACK
         B        T:EXIT1
         PAGE
*
*        SEE ABOUT PASSING THE INCORE BUFFER'S UP TO ERR:FIL
*
T:30     DISABLE
         LI,9     0                 COUNT OF BUFFERS MOVED
         LI,4     2                 TWO PASS LOOP
         LW,1     CURBUF            GET CURRENT BUFFER ADDRESS
T:31     EQU      %
         INT,5    *M24,1            GET NEXT WA / TEST IO IN PROGRESS
         BCS,4    T:32              BUFFER BEING WRITTEN OUT NOW
         SW,5     1                 CALCULATE # WORDS USED TO DATE
         CI,5     3                 ONLY HEADER WORDS USED....
         BNE      T:33              NO-BUF HAS BEEN IN USE<<MOVE IT>>
T:32     CI,1     EBUF1             IS CURRENT BUFFER EBUF1
         BE       %+2               YEP
         LI,1     EBUF1+EBUF1-EBUF2 NO - WAS EBUF2
         AI,1     EBUF2-EBUF1       CALCULATE NEXT BUFFER ADDRESS
         BDR,4    T:31              CHECK IT
         B        T:40              DONE
T:33     EQU      %
         STW,5    2,1               STORE WORD COUNT IN BUFFER
         LCFI     0                 CLEAR CC'S TO RESET PSD FOR USER
T:35     BAL,0    T:SCC
         AI,9     1                 BUMP COUNT OF BUFFERS MOVED
         LW,3     *1,5              * GET WORD FROM ERRLOG BUFFER
         STW,3    *6,5               * AND MOVE TO ERR:FIL BUFFER
         AI,5     -1                  * DECREMENT COUNT LEFT TO MOVE
         BGEZ     %-3                  * MOVE TILL COUNT EXHAUSTED
T:36     LW,8     0,1               GET DISC ADDRESS
         BEZ      %+2               NOPE
         BAL,11   T:RBG             YES - CLEAR IT
         LW,14    1                 BUFFER WA SO WE CAN SIMULATE
         BAL,11   ERRLOG40          ERROR LOG END ACTION
         DISABLE
T:40     CI,9     0                 DID WE DO ANYTHING AT ALL
 BNEZ T:EXIT1 YES - EXIT THE CAL
T:41     LCI      1                 ERRLOG EOF HIT IF NONE MOVED
         BAL,0    T:SCC
T:42     B        T:EXIT1           DESTRUCT AND GET OUT
         PAGE
*
*        SEE IF WE CAN GIVE DISC ADDRESS IN R8 BACK
*        TO ERROR LOGGER TO USE LATER
*
T:RBG    PUSH     11                SAVE EXIT LINK
         BAL,11   CHKDA             IS THIS A GOOD DISC ADDRESS
         BEZ      T:RBG3            BAD D/A - LET RBG LOG ERROR RECORD
T:RBG1   DISABLE
         LI,3     4                 # SPOTS TO CHECK
         LI,2     CURGRAN           STARTING AT HERE
 MTW,0 0,2 IS THER A DISC ADDRESS THERE
         BEZ      T:RBG2            YEP
         AI,2     1
         BDR,3    %-3               KEEP LOOKING
         B        T:RBG3            HAVE TO GIVE IT AWAY
T:RBG2   STW,8    0,2               PUT IT HERE
         ENABLE
         B        T:RBG4            OK - GET OUT
T:RBG3   PUSH     7,1               RBG BLOWS 1,2 AND 7
         BAL,11   RBG               RELEASE GRANULE BACK TO GRAN
         PULL     7,1               RETRIEVE REGSITERS
T:RBG4   PULL     11                GET EXIT LINK
         B        *11               AND GET OUT
ERLOGDCB DATA     1,0
         GEN,8,24 10,0
         DATA     0,0,0
         GEN,15,17      128*4,0     BUFFER BYTE COUNT , ZIP
         PAGE
* THIS ROUTINE INTERFACES BETWEEN THE USER WHO WISHES TO
* WRITE THE ERRLOG FILE AND THE MONITOR ROUTINE
* ERRLOG
         REF      T:IACU
         REF      CC2SET
         REF      ERRLOG
T:WTERLOG EQU     %
         AND,6    M17               MASK ADR OF MESSAGE
         LW,7     6                 PAGE # OF MESSAGE
         SLS,7    -9
         BAL,11   T:IACU            DOES USER HAVE SPECIFIED PAGE
         BCR,2    %+2               YES
         BCS,1    CC2SETD
*
         BAL,5    ERRLOG
         DESTRUCT CC0RST            RETURN CITH CC=0
CC2SETD  EQU      %
         DESTRUCT CC2SET
         TITLE    'PROCESS CALS: M:DMOD#, M:DPART, M:DRET'
*F***************
*F*      NAME:    T:MODPRTRT
*F*      PURPOSE: PROCESS THE M:DMOD#, M:DPART, & M:DRET CALS.
*F***************
         SPACE    4
SP:IOCD  SET      1                 =1  BYPASS IOCD FLAG/TIC CHECKS
*                                   =0  DO IOCD FLAG/TIC CHECKS
         SPACE    4
*****************
*DO*
*D*      NAME:    T:MODPRTRT
*        DESCRIPTION:
*  M:DMOD#, M:DPART, & M:DRET CAL PROCESSORS.
*
*    INPUT:
*             R6  = DEVICE ADDRESS (VALUE OF WORD 0 IN FPT)
*             R7  = ADDRESS OF WORD 1 IN FPT
*
*        INTERFACE:  PUSHALL,CALBAD,MDPART,MDRET,MDMOD#.
*        REGISTERS:  R1 USED, R5-R11 SAVED
*FIN*
*****************
         PAGE
         REF      PUSHALL           ROUTINE
*,*                           SAVE REG.5-11 IN STACK
         REF      PULLALLEXIT       ROUTINE
*,*                           RESTORE REG.5-11 & EXIT
         REF      CALBAD            ROUTINE
*,*                           BAD CAL EXIT
         REF      DCT1P             INPUT HALF WORD
*,*                           SEARCH FOR PRIMARY DEV.ADDR.
         REF      DCT1A             INPUT HALF WORD
*,*                           SEARCH FOR ALTERNATE DEV.ADDR.
         REF      DCTSIZ            INPUT
*,*                           SIZE OF DCT TABLES
         REF      DCT2              INPUT BYTE
*,*                           OBTAIN DEV.QUEUING INDEX
         REF      DCT3              INPUT OUTPUT BYTE BITS 2,5
*,*                           CHECK &/OR SET PARTITION FLAG &/OR
*,*                             NOERR FLAG
         REF      DCT4              INPUT BYTE
*,*                           OBTAIN DEV.TYPE INDEX
         REF      DCT24             INPUT OUTPUT BYTE BITS 0,5,7
*,*                           CHECK &/OR SET DON'T ALLOCATE DEV.FLAG,
*,*                             &/OR CONT.PARTITIONED FLAG. CHECK
*,*                             IF DEV.IS PARTITIONABLE OR NOT.
         REF      OH:NM             INPUT HALF WORD
*,*                           SEARCH FOR DEV.TYPE MNEMONIC
         REF      SV:RSIZ           INPUT
*,*                           SIZE OF SB:RTY TABLE
         REF      SB:RTY            INPUT BYTE
*,*                           SEARCH FOR RESOURCE TYPE WHICH
*,*                             HAS RESOURCE COUNTS
         REF      SH:RTOT           OUTPUT HALF WORD
*,*                           MODIFY RESOURCE COUNTS WHEN
*,*                             PARTITIONING OR RETURNING A DEV.
         REF      SH:RBCU           INPUT HALF WORD
*,*                           CURRENT RESOURCES USED BY BATCH
         REF      SH:ROCU           INPUT HALF WORD
*,*                           CURRENT RESOURCES USED BY ON-LINE
         REF      SH:RGCU           INPUT HALF WORD
*,*                           CURRENT RESOURCES USED BY GHOST
         REF      S:MBSF            OUTPUT WORD
*,*                           SET NON 0 WHEN DEV.IS PARTITIONED
*,*                             OR RETURNED SO RE-SCHEDULING
*,*                             CAN BE DONE
         REF      SNDDX             INPUT BYTE
*,*                           SEARCH TO SEE IF DEV.IS SYMBIONT
         REF      SYMX              INPUT BYTE
*,*                           CHECK SYMBIONT FOR INPUT VS OUTPUT
         REF      SSIG              INPUT OUTPUT BYTE
*,*                           CHECK FOR LEGITIMATE SIGNAL CHAR.,
*,*                             OR SET SIGNAL CHAR.WHEN
*,*                             PARTITIONING DEV.
         REF      SSTAT             INPUT OUTPUT BYTE
*,*                           CHECK FOR SYMBIONT BEING SUSPENDED,
*,*                             OR SET STATUS TO NOT AVAILABLE
*,*                             OR AVAILABLE WHEN PARTITIONING
*,*                             OR RETURNING A DEV.RESPECTIVELY
         REF      AVRNOU            INPUT HALF WORD
*,*                           CHECK IF SPINDLE IS BUSY
         REF      BATAPE            INPUT
*,*                           MODIFY DCT INDEX TO AVRTBL INDEX
         REF      AVRTBLNE          INPUT
*,*                           SIZE OF AVRTBL TABLE
         REF      DEVMOD#           INPUT HALF WORD
*,*                           OBTAIN DEV.MODEL #
         REF      CNTMOD#           INPUT HALF WORD
*,*                           OBTAIN CONT.MODEL #
         REF      RBLIMS            INPUT DOUBLE WORD
*,*                           CHECK DCT INDEX IF REMOTE BATCH
         SREF     RB:FLAG           INPUT OUTPUT WORD
*,*                           REMOTE BATCH STATION FLAG TABLE
*,*                             INDICATING PARTITIONED OR NOT
         SREF     ACTBIT            INPUT
*,*                           CHECK IF REMOTE BATCH ACTIVE FLAG
         SREF     LIPBIT            INPUT
*,*                           CHECK IF REMOTE BATCH IN LOGON
         SREF     OFFBIT            INPUT
*,*                           FLAG WHICH INDICATES IF REMOTE BATCH
*,*                             STATION IS PARTITIONED OR NOT
         REF      TIME              INPUT WORD
*,*                           OBTAIN MONITORS RELATIVE TIME
         REF      NB31TO0           CONSTANT TABLE
         REF      XFFFF             CONSTANT X'FFFF'
         REF      X3                CONSTANT X'00000003'
         REF      X4                CONSTANT X'00000004'
         REF      X20               CONSTANT X'00000020'
         REF      X80               CONSTANT X'00000080'
         REF      Y1                CONSTANT X'10000000'
         REF      Y4                CONSTANT X'40000000'
         REF      Y8                CONSTANT X'80000000'
         REF      YC                CONSTANT X'C0000000'
         REF      YF                CONSTANT X'F0000000'
         REF      24BM2             CONSTANT X'FFFFFE'
         REF      M3                CONSTANT X'00000007'
         REF      J:BASE            OUTPUT WORD
*,*                           TEMP.CELL IN JIT
********
         PAGE
********
SC1      EQU      1                 SC1 ONLY FLAG MASK
SC2      EQU      2                 SC2 ONLY FLAG MASK
NOALLOC  EQU      X'80'             NO ALLOCATE FLAG WHEN PART.
OLDWND   EQU      X'40'             OLD DIAG.DOWN FLAG
PART:DV  EQU      Y01               DEV.PART.BEFORE CONT.
DOWND    EQU      X'20'
DOWNCP   EQU      X'08'             PRIM.CONT.PARTITIONED FLAG
DOWNCA   EQU      X'10'             ALT.CONT.PARTITIONED FLAG
NOTAVAIL EQU      3                 SYMB.NOT AVAILABLE FLAG
ACTIVE   EQU      1                 SYMBIONT ACTIVE FLAG
OUTPUT   EQU      2                 OUTPUT SYMBIONT
CNTFLG   EQU      X'20'             FPT CONTROLLER FLAG
STKR8    EQU      -15               REL.POSITION IN STACK OF R8
STKR9    EQU      -14               REL.POSITION IN STACK OF R9
STKR10   EQU      -13               REL.POSITION IN STACK OF R10
STKCC    EQU      -25               REL.POSITION IN STACK OF PSD
MIOPMASK EQU      X'80'             MASK TO CHK.4 MUC  VS SUC
MIOPCNTM EQU      X'3FF0'           IOP/CONT.PART OF DEV.ADDR.
SIOPCNTM EQU      X'3F80'           IOP/CONT.PART OF DEV.ADDR.
********
NEGR3    EQU      %                 MASK TABLE
*                             IF PRIM (01), GET 10 (ALT)
*                             IF ALT (10), GET 01 (PRIM)
*                             IF PRIM=ALT (101), GET 10 (ALT)
         DATA,1   0              -0-NULL
         DATA,1   SC2            -1-WAS PRIM.,GET ALT.MASK
         DATA,1   SC1            -2-WAS ALT.,GET PRIM.MASK
         DATA,1   0              -3-NULL
         DATA,1   0              -4-NULL
         DATA,1   SC2            -5-WAS DUAL, PRIM=ALT, GET ALT.MASK
         DATA,1   0              -6-NULL
         DATA,1   0              -7-NULL
         BOUND    4
********
PARTFLG  EQU      %
         DATA     0              -0-NULL
         GEN,8,24 DOWNCP,1          ---SOFTWARE CHANNEL 1---
         GEN,8,24 DOWNCA,2          ---SOFTWARE CHANNEL 2---
         DATA     0              -3-NULL
********
STATFLG  EQU      %
         DATA     0              -0-NULL
         DATA     SC1**25        -1-SC1 FLAG
         DATA     SC2**25        -2-SC2 FLAG
         DATA     0              -3-NULL
********
STATMASK DATA     (DOWNCP+DOWNCA+(SC1+SC2)**1)**24
********
         PAGE
********
T:MODPRTRT EQU    %           <---  ENTER
         SPACE    2
         STW,R6   J:BASE+1          SAVE DEV.ADDR.
         LI,R6    6                 FAKE OUT PUSHALL,R6=DCB ADDR.,OR=6
         BAL,R1   PUSHALL     ****  SAVE R5-R11
         LW,R6    J:BASE+1          RESTORE DEV.ADDR.
         AND,R6   XFFFF             KEEP DEV.ADDR.
         LB,R5    *R7               GET FPT SUB-CODE (FLAG)
         SLS,R5   -6
         EXU      RMATV,R5    --->  EXIT TO CAL PROCESSOR
         B        CALBAD      EEEE  ERROR
*----------------
RMATV    EQU      %
         B        MDPART        -00-M:DPART CAL
         B        MDRET         -01-M:DRET CAL
         B        MDMOD#        -10-M:DMOD# CAL
         LI,R14   X'AE'         -11-ILLEGAL CAL
*----------------
         PAGE
********
*D*
*D*      NAME:    MDMOD#
*D*      ENTRY:   FINDADDR
*D*      DESCRIPTION:  PROCESS M:DMOD# CAL.
*D*
*D*      INPUT:
*D*               R6 = DEVICE ADDRESS
*D*               R7 = ADDRESS OF FPT +1
*D*
*D*      OUTPUT:
*D*               USERS R8  = DEVICE MODEL # (HEX.,RIGHT JUSTIFIED)
*D*               USERS R9  = CONTROLLER MODEL # (HEX.,RIGHT JUSTIFIED)
*D*               USERS R10 = DEV.TYPE MNEMONIC(EBCDIC,RIGHT JUSTIFIED)
*D*                           BIT-0 = 1  DEVICE BUSY
*D*                           BIT-1 = 1  DEVICE PARTITIONED
*D*                           BIT-2 = 1  CONT.PARTITIONED (SC1/SC2)
*D*                           BIT-3 = 1  S:CUN=DID (DIAG KEYIN DONE)
*D*                           BIT-4 = 1  SC2 PARTITIONED
*D*                           BIT-5 = 1  SC1 PARTITIONED
*D*               USERS CC1 = 0  VALID DEVICE ADDRESS
*D*                         = 1  INVALID DEVICE ADDRESS
*D*
*D*      INTERFACE:  NOTEQ,XIT.
*D*      REGISTERS:  R1-R2,R4,R8-R10,R15 USED
*D*
*D*      FINDADDR ROUTINE SEARCHES DCT1P/1A FOR GIVEN DEVICE
*D*      ADDRESS.
*D*
*D*      INPUT:
*D*               R6 = DEVICE ADDRESS
*D*               R9 = SC1 OR SC2 FLAG INDICATING WHICH PATH TO
*D*                    CHECK PRIM. VS ALT. (DCT1P/DCT1A)
*D*               R15= 0  M:DMOD# CAL
*D*                  > 0  M:DPART/M:DRET CAL
*D*
*D*      OUTPUT:
*D*               R1 = DCT INDEX (BITS 8-31)
*D*                           BIT-5 = 1  PRIM=ALT & BIT-7 = 1 (PRIM)
*D*                           BIT-6 = 1  ALT.DEV.ADDR.
*D*                           BIT-7 = 1  PRIM.DEV.ADDR.
*D*               R2 = 0   DEVICE ADDRESS VALID
*D*                  = Y8  INVALID DEVICE ADDRESS
*D*
*D*      CALL:    R15 = LINK
*D*
********
         PAGE
MDMOD#   EQU      %           <---  ENTER
         LI,R15   0                 FLAG TO VALIDATE DEV.ADDR.& CONTINUE
         SPACE    2
FINDADDR EQU      %           <---  ENTER FOR DEV.ADDR.VALIDATION
*  R15 = 0, MODEL # ENTRY
*  R15 > 0, PARTITION/RETURN ENTRY
*        R15 = LINK
         SPACE    2
         LI,R1    DCTSIZ
         LI,R9    SC1+SC2           SET FLAG TO BOTH PATHS
NXTDCT   EQU      %
         LI,R2    0
         STB,R2   R1
         CI,R9    SC1
         BAZ      NXTDCTX     YES-- LOOK AT ALT.PATH
         LI,R2    SC1         NO--- PRIM.
         CH,R6    DCT1P,R1
         BE       DCTFND0     YES-- FIND DEV.ADDR.
NXTDCTX  EQU      %           NO--- SEARCH ALTERNATE
         LI,R8    DCT1A
         CI,R8    DCT1P
         BE       NOTEQX      NO--- DUAL ACCESS (NO ALTERNATE)
         CI,R9    SC2         YES--
         BAZ      NOTEQX      NO--- SEARCH ALT.PATH
         LI,R2    SC2         YES-- ALT.FLAG
         CH,R6    DCT1A,R1
         BNE      NOTEQX      NO--- FIND DEV.ADDR.
DCTFND   EQU      %           YES-- GOOD DEV.ADDR.
         STB,R2   R1                SAVE SC1/SC2 FLAG
         LI,R2    0                 CC'S = 0
         CI,R15   0
         BNEZ     *R15        --->  RETURN, NOT M:DMOD# CAL
         LH,R8    DEVMOD#,R1        GET DEVICE MODEL #
         LH,R9    CNTMOD#,R1        GET CONTROLLER MODEL #
         LB,R3    DCT4,R1           DEV.TYPE MNEMONIC INDEX
         LH,R10   OH:NM,R3          GET TYPE MNEMONIC
         AND,R8   XFFFF
         AND,R9   XFFFF
         AND,R10  XFFFF
         LW,R3    TSTACK
         STW,R8   STKR8,R3          DEV.MOD# INTO USER'S R8(SR1)
         STW,R9   STKR9,R3          CONT.MOD# INTO USER'S R9(SR2)
         LW,R4    R1                DON'T DESTROY DCT INDEX
         AI,R4    -BATAPE           IF SPINDLE, SEE IF BUSY
         BLZ      NO:BSY      NO--- SPINDLE (TAPE/PACK)
         CI,R4    AVRTBLNE    YES-- POSSIBLY
         BGE      NO:BSY      NO--- SPINDLE
         LD,R8    AVRTBL,R4   YES--
         CW,R8    L(X'C1FF0000')
         BANZ     DEV:BSY     YES-- DEV.BUSY
         LH,R8    AVRNOU,R4   NO---
         BEZ      NO:BSY      NO--- DEV.BUSY
DEV:BSY  EQU      %           YES--
         OR,R10   Y8                SET FLAG FOR USER
NO:BSY   EQU      %
         LB,R9    DCT3,R1           GET
         AND,R9   L(DOWND)            DEVICE PARTITIONED
         SCS,R9   -7                  FLAG
         STS,R9   R10               SET FLAG FOR USER
         LW,R15   DCT9,R1
         LB,R15   R15               GET FLAGS
         CI,R15   DOWNCP+DOWNCA
         BAZ      %+3         NO--- CONT.PARTITIONED
         LW,R9    Y2                YES---> SET CONT. PART. FLAG
         STS,R9   R10               SET FLAG FOR USER
         AND,R15  L(DOWNCP+DOWNCA)
         SCS,R15  -9
         STS,R15  R10               SET CONT.PATH PART. FLAG
         LW,R3    S:CUN             USER # WE'RE DEALING WITH HERE
         LB,R9    JB:PRIV           AND HIS PRIVILEGE LEVEL
         CI,R9    X'C0'             IS HE HI-PRIV PEOPLE
         BGE      HIPRIV            YUP-> GO
         CW,R3    DID               NO--> DID OPERATOR AUTHORIZE HIM
         BNE      SAVE:FLG          NOPE..
HIPRIV   EQU      %
         STW,R3   DID               SAVE IF HI-PRIV PATH...
         OR,R10   Y1          YES-- SET FLAG FOR USER
SAVE:FLG EQU      %
         STW,R10  STKR10,R3         YY & FLAGS INTO USER'S R10(SR3)
         B        XIT               EXIT
*----------------
DCTFND0  EQU      %
         LI,R8    DCT1A
         CI,R8    DCT1P
         BE       DCTFND      NO--- DUAL SYSTEM
         CH,R6    DCT1A,R1    YES-- POSSIBLY POOLED DEV.
         BNE      DCTFND      NO--- PRIM.ADDR.=ALT.ADDR.
         AI,R2    4           YES-- SET FLAG
         B        DCTFND
*----------------
         PAGE
*****************
*DO*
*D*      NAME:    NOTEQ
*        ENTRY:   XIT
*        DESCRIPTION:
*           NOTEQ -
*  SUB-ENTRY FOR CHECKING FOR ANOTHER DEVICE ADDRESS
*        IDENTICAL TO ORIGINAL REQUESTED ONE.
*           XIT -
*        PERFORM EXIT BACK TO USERS CAL +1.
*
*        INPUT:
*  R1  = DCT INDEX
*  R6  = DEVICE ADDRESS
*  R15 = LINK, ALSO >0 FLAG FOR PARTITION/RETURN ENTRY
*
*
*        OUTPUT:
*  CC1-4 INTO USERS PSD
*
*        INTERFACE:  T:SELFDESTRUCT,PULLALLEXIT.
*        REGISTERS:  R1-R3,R11 USED, R15 SAVED
*FIN*
*****************
         SPACE    2
NOTEQ    EQU      %           <---  ENTER
         LB,R9    R1                GET FLAGS SC1/SC2 FOR SEARCH
NOTEQX   EQU      %
         BDR,R1   NXTDCT      NO--- DONE SEARCHING
         LW,R2    Y8          YES-- BAD DEV.ADDR.,  CC1 = 1
         CI,R15   0
         BNEZ     *R15        --->  RETURN, NOT M:DMOD# CAL
XIT      EQU      %
         LW,R3    M16
         LS,R3    TSTACK+1          PICK UP WORD-COUNT OF TSTACK
         CI,R3    27                IS THERE 1 ENVIRONMENT + PUSHALL?
         BNE      XIT1              NO - MUST BE OTHER THAN CAL1 CALL
         LW,R3    YF
         LW,R1    TSTACK
         AI,R1    STKCC
         AND,R1   24BM2
         STS,R2   *R1               CC'S INTO USER'S PSD
XIT1     EQU      %
         LI,R11   PULLALLEXIT       EXIT TO ROUTINE
         B        T:SELFDESTRUCT -->EXIT & GET RID OF OVERLAY
*----------------
         PAGE
********
*D*
*D*      NAME:    MDPART
*D*      ENTRY:   ERRLGCMN
*D*      ENTRY:   RETDONE
*D*      DESCRIPTION:  PROCESS M:DPART CAL.
*D*
*D*      ERRLGCMN - COMMON ERRLOG ROUTINE TO MAKE AN ERROR LOG ENTRY.
*D*      RETDONE & PRTDONE -
*D*               COMMON EXIT FOR PARTITION/RETURN REQUESTS
*D*                WHICH ARE O.K.
*D*
*D*      INTPUT:
*D*               R6 = DEVICE ADDRESS
*D*               R7 = ADDRESS OF FPT +1
*D*
*D*      OUTPUT:
*D*               CC2 = 1  INVALID DEVICE ADDRESS
*D*               CC1 = 1  SYMBIONT SUSPENDED WITH I/O LEFT
*D*               CC1-2 = 00  ALL IS O.K.
*D*               CC4 = 1  PART.PATH OF DUAL ONLY, NO DEV.
*D*
*D*      INTERFACE:  FINDADDR,XIT,ERRLOG,MORETRN,NOTEQ,COMPARE.
*D*      REGISTERS:  R0-R6,R8-R15 USED, R7 SAVED
*D*
********
         SPACE    3
MDPART   EQU      %           <---  ENTER
         DISABLE
         BAL,R15  FINDADDR    ****  VALIDATE DEVICE ADDRESS
*
*  R1 = DCT INDEX (BITS 8-31)
*                 BIT-5 = 1 PRIM.=ALT. & BIT-7 = 1 (PRIM)
*                 BIT-6 = 1 ALT.ADDR.
*                 BIT-7 = 1 PRIM.ADDR.
*  R2(BIT0) = 0,  ADDRESS VALID
*           = 1,  ADDRESS INVALID
*
         CW,R2    Y8
         BAZ      PARTDEV     YES-- ADDRESS O.K.
         LW,R2    Y4          NO--- CC2 = 1
         ENABLE
         B        XIT               EXIT
*----------------
PARTDEV  EQU      %                 PARTITION DEVICE
         PSW,R1   TSTACK            SAVE ORIG.DCT INDEX
PARTITEM EQU      %
         LB,R14   *R7               GET FPT SUB-CODE
         LB,R4    DCT3,R1
         CI,R14   CNTFLG
         BAZ      DEV:ONLY    YES-- PART.DEV.REQUEST
         LB,R3    R1          NO--- CONT., GET SC1/SC2 CODE
         AND,R3   M3
         LB,R5    NEGR3,R3          GET SC2/SC1 MASK
         LW,R0    R4                SAVE IN CASE CONT.PART.DEV.
*                                   EXCEEDES RTOT & CONT.IS RETURNED
         AND,R0   X3
         CW,R3    R4                ADDR.FOUND VS SC1/SC2
         BAZ      P0:01:10    NO--- DEV.ADDR.= SC1 OR SC2
         CW,R5    R4          YES-- TRY OTHER PATH
         BAZ      P:01:10     YES-- SC1 OR SC2 (01/10)
P:11:    EQU      %           NO--- PART.PATH ONLY
         OR,R14   Y8                SPECIAL EXIT FLAG
P:11:00  EQU      %
         LW,R12   DCT9,R1
         LW,R8    R12               SAVE IN CASE CONT.PART.DEV.
*                                   EXCEEDES RTOT & CONT.IS RETURNED
         LW,R11   R4
         AND,R3   X3
         AND,R11  R3                GET OLD DCT3 SC1/SC2
         LW,R10   R3
         SCD,R10  -7
         STS,R10  R12               SAVE OLD DCT3 SC1/SC2 IN DCT9
         LCW,R9   R3                SET OLD DCT3 SC1/SC2 =0
         AI,R9    -1                1'S COMPLEMENT
         AND,R4   R9
         OR,R12   PARTFLG,R3        SET PART.SC1/SC2
         STW,R12  DCT9,R1
         STB,R4   DCT3,R1
         CW,R14   Y8
         BAZ      DEV:ONLY    YES-- DEV.PART.ALSO
         B        DNTINCRD    NO--- CONT.PATH ONLY
*----------------
P:00:    EQU      %
         LI,R3    SC1               PRIM.PATH FLAG
         B        P:11:00
*----------------
P0:01:10 EQU      %
         CW,R5    R4
         BAZ      P:00:       YES-- SC1/SC2 =0
P:01:10  EQU      %           NO--- SC1/SC2 =01,10
         LW,R3    R4                PRIM./ALT.PATH FLAG
         B        P:11:00
*----------------
DEV:ONLY EQU      %
         LI,R2    SV:RSIZ+1
         LB,R4    DCT4,R1           GET CURRENT DEV.TYPE INDEX
NXT:RTY  EQU      %
         CB,R4    SB:RTY,R2
         BE       CHKRES#     YES-- FIND DEV.TYPE = CURRENT TYPE
         BDR,R2   NXT:RTY     NO--- DONE SEARCH
DO:PART  EQU      %           YES--
         CLM,R1   RBLIMS
         BCR,9    REMOTE      YES-- REMOTE BATCH DEVICE
*                             NO---
         LB,R2    SNDDX             # SYMBIONT DEVICES
NXTSYMDV EQU      %
         CB,R1    SNDDX,R2
         BE       SYMTYP      YES-- FIND SYMBIONT
         BDR,R2   NXTSYMDV    NO--- DONE SEARCH
REMOTOFF EQU      %           YES--
         LI,R15   0                 NOT SYMB.DEV.FLAG
         B        NOTSYMDV
*----------------
CHKRES#  EQU      %
         LH,R4    SH:RTOT,R2        TOTAL # RESOURCES AVAILABLE
         SH,R4    SH:RBCU,R2          - BATCH CURRENT
         SH,R4    SH:ROCU,R2          - ON-LINE CURRENT
         SH,R4    SH:RGCU,R2          - GHOST CURRENT
         BGZ      DO:PART     NO--- ALL RESOURCES IN USE
         CI,R14   CNTFLG      YES-- CANNOT PARTITION ITEM(S)
         BAZ      ITEMNOPT    YES-- DEVICE PARTITION REQUEST
RETCONT  EQU      %           NO--- CONTROLLER REQUEST
         LH,R2    DCT1P,R1          GET CURRENT DEV.ADDR.
         LB,R10   R1                GET SC1/SC2 FLAG
         CI,R10   SC1
         BANZ     %+2         YES-- PRIM.ADDR.
         LH,R2    DCT1A,R1    NO--- ALT.ADDR.
         LB,R15   DCT2,R1           GET CURRENT CHANNEL INDEX
         LI,R3    MIOPCNTM          MUC  TYPE MASK
         CI,R2    MIOPMASK
         BANZ     %+2         YES-- MUC  TYPE
         LI,R3    SIOPCNTM    NO--- SUC  TYPE, SIOP MASK
         LI,R4    DCTSIZ
NX:CNT   EQU      %
         CB,R15   DCT2,R4
         BE       RET:CNT     YES-- SAME CHANNEL INDEX
NOT:CNT  EQU      %           NO---
         BDR,R4   NX:CNT      NO--- DONE LOOKING FOR SAME CHANNEL
         B        ITEMNOPT    YES--
*----------------
RET:CNT  EQU      %
         LH,R14   DCT1P,R4          GET SAME CHANNELS DEV.ADDR.
         CI,R10   SC1
         BAZ      %+2         YES-- PRIM.ADDR.
         LH,R14   DCT1A,R4    NO--- ALT.ADDR.
         CS,R2    R14
         BNE      NOT:CNT     NO--- IOP/CONTROLLER SAME AS CURRENT
*                             YES--
* R0 = ORIGINAL DCT3 VALUE (BIT 6-7)
* R8 = ORIGINAL DCT9 VALUE (BIT 3-6)
         LW,R2    R0
         LI,R3    SC1+SC2
         LB,R14   DCT3,R4
         STS,R2   R14               SET CONT.STATUS AS IT WAS
         STB,R14  DCT3,R4
         LW,R2    R8
         LW,R3    STATMASK
         STS,R2   DCT9,R4           SET CONT.STATUS AS IT WAS
         B        NOT:CNT           TO NEXT CHANNEL
*----------------
REMOTE   EQU      %
         LW,R2    RB:FLAG,R1        REMOTE BATCH FLAGS
         CI,R2    ACTBIT+LIPBIT     ACTIVE OR BEING LOGGED ON
         BANZ     REMOTACT    YES-- ACTIVE/LOGGON STATE
         LI,R15   OFFBIT      NO---
         STS,R15  RB:FLAG,R1        SET TO OFF
         B        REMOTOFF
*----------------
SYMTYP   EQU      %
         LB,R4    SSTAT,R2
         BEZ      NOTACT      YES-- SYMBIONT SUSPENDED
         LI,R15   0           NO--- SET FLAG
         CI,R4    ACTIVE
         BANZ     SYMB        YES-- SYMBIONT ACTIVE
PRTOK    EQU      %           NO---
         LI,R15   NOTAVAIL          SET FLAG=SYMB.NOT AVAIL.
         B        SYMB
*----------------
NOTACT   EQU      %
         LH,R4    SCNTXT,R2
         BEZ      PRTOK       NO--- SYMBIONT SUSPENDED
REMOTACT EQU      %           YES--
         CI,R14   CNTFLG
         BANZ     RETCONT     YES-- CONT.REQUEST
ITEMNOPT EQU      %           NO--- DEV.REQUEST
         ENABLE
         PLW,R1   TSTACK            ORIGINAL DCT INDEX
         LW,R2    Y8                CC1 = 1
         B        XIT               EXIT
*----------------
SYMB     EQU      %
         LI,R4    'Q'
         LB,R3    SYMX,R2           INPUT/OUTPUT FLAG
         CI,R3    OUTPUT
         BANZ     %+2         YES-- OUTPUT SYMBIONT
         LI,R4    'L'         NO--- INPUT
         STB,R4   SSIG,R2           SET SYMBIONT SIGNAL
         CI,R15   0
         BEZ      %+2         YES-- SYMB.POSSIBLY SUSPENDED
         STB,R15  SSTAT,R2    NO--- SET STATUS = NOT AVAILABLE
         LI,R15   1                 SYMBIONT DEVICE FLAG
NOTSYMDV EQU      %
         LB,R4    DCT3,R1           SET
         LW,R13   R4
         OR,R4    L(DOWND)            DEVICE
         STB,R4   DCT3,R1               DOWN
         LB,R4    DCT24,R1          SET
         OR,R4    L(NOALLOC)          TO NO
         STB,R4   DCT24,R1              ALLOCATION
         CI,R14   CNTFLG
         BANZ     NOPRTDV     YES-- CONTROLLER REQUEST
         LW,R4    DCT9,R1     NO--- DEVICE
         OR,R4    PART:DV
         STW,R4   DCT9,R1           SET PART.FLAG FOR DEV.PART.ALONE
NOPRTDV  EQU      %
         CI,R15   0
         BNEZ     DNTINCRD    YES-- SYMBIONT DEVICE
         LB,R4    DCT4,R1     NO--- DEV.TYPE INDEX
         LI,R3    SV:RSIZ+1
NXTRSRCP EQU      %
         CB,R4    SB:RTY,R3
         BE       INCRCTD     YES-- FIND DEV.RESOURCE
         BDR,R3   NXTRSRCP    NO--- DONE SEARCH
         B        DNTINCRD    YES--
*----------------
INCRCTD  EQU      %
         CI,R13   DOWND
         BANZ     DNTINCRD    YES-- DEV.ALREADY DOWN
*                             NO--- INCREMENT COUNT
         MTH,-1   SH:RTOT,R3        DECREMENT TOTAL COUNT
         STW,R4   S:MBSF            FORCE RBBAT TO RE-SCHEDULE JOBS
DNTINCRD EQU      %
         LW,R4    R1                SAVE DCT INDEX
* R1 = DCT INDEX
* R4 = DCT INDEX
* R6 = DEV.ADDR.
         LB,R10   R1
         CI,R14   CNTFLG
         BAZ      PRT:DEV     YES-- PART.DEV.REQUEST
*                             NO--- PART.CONT.REQUEST
         BAL,R15  COMPARE     ****  FIND MORE DEV.IN CONT.
         B        NORMXITP       -0-NO MORE, FINISHED
         B        PARTITEM       -1-CONTINUE
*----------------
PRT:DEV  EQU      %
         BAL,R15  NOTEQ       ****  SEARCH FOR ANOTHER ADDR.THE SAME
         CW,R2    Y8
         BAZ      PARTITEM    YES-- MORE DEV.ADDRESSES SAME
NORMXITP EQU      %           NO---
         ENABLE
         PLW,R1   TSTACK            ORIGINAL DCT INDEX
         LW,R4    R1
         LB,R10   R1                PRIM./ALT.FLAGS
         LH,R6    DCT1P,R1          PRIM.ADDR.
         CI,R10   SC1
         BANZ     %+2         YES-- PRIM.TYPE
         LH,R6    DCT1A,R1    NO--- ALT.TYPE
LOGITP   EQU      %
         LI,R5    1                 SET FLAG TO PARTITIONING
         PSW,R14  TSTACK            SAVE FPT INFO
         CI,R14   CNTFLG
         BANZ     PARTCNT     YES-- CONTROLLER REQUEST
*                             NO--- DEVICE REQUEST
         LI,R13   DEVMOD#           DEV.MOD.# TABLE
ERLGPRT  EQU      %
         LW,R14   L(X'51030000')    ERR.LOG CODE(PART), # WRDS/ENTRY
*
*  FORM PARTITIONED DEVICE ERROR LOG ENTRY
*
ERRLGCMN EQU      %
         LCI      4
         PSM,R4   TSTACK            SAVE VULNERABLE REGISTERS
         PSW,R10  TSTACK            SAVE PRIM./ALT.PATH FLAG
         LH,R10   *R13,R1           DEV.MOD.#/CONT.MOD.#
         AND,R10  XFFFF
         OR,R10   R14               ERR.LOG CODE, # WORDS/ENTRY
         LW,R11   TIME              RELATIVE TIME
         LW,R12   R6                FLAG=0(DEV), =1(CONT), DEV.ADDR.
         LI,R6    R10               ERR.LOG ENTRY BUFFER ADDR.
         BAL,R5   ERRLOG      ****  RECORD ERROR LOG INFO
         PLW,R10  TSTACK            RESTORE PRIM./ALT.PATH FLAG
         LCI      4
         PLM,R4   TSTACK            RESTORE VULNERABLE REGISTERS
         AND,R6   XFFFF             SAVE DEV.ADDR.
         PLW,R14  TSTACK            RESTORE FPT INFO
         CI,R5    0
         BEZ      MORETRN     YES-- RETURN TYPE REQUEST
*                             NO--- PARTITION TYPE REQUEST
         BAL,R15  COMPARE     ****  LOOK FOR MORE DEV.SAME
         B        PRTDONE        -0-NO MORE, FINISHED
         B        LOGITP         -1-CONTINUE
*----------------
PRTDONE  EQU      %
RETDONE  EQU      %
         CW,R14   Y8
         BAZ      P:R:NXT     YES-- PART.DEV.IN CONT.
         LW,R2    Y1          NO--- PATH ONLY, SET CC4=1
         B        XIT
*----------------
P:R:NXT  EQU      %
         LI,R2    0                 CC2 = 0
         B        XIT               EXIT
*----------------
PARTCNT  EQU      %                 PART.SNGL.ACCESS/DUAL ACCESS CONT.
         LI,R13   CNTMOD#           CONTROLLER MODEL #
         OR,R6    Y8                CONTROLLER FLAG
         B        ERLGPRT
*----------------
         PAGE
********
*D*
*D*      NAME:    COMPARE
*D*      DESCRIPTION:  DETERMINE IF ANOTHER DEVICE ADDRESS EXISTS
*D*               WHICH HAS THE SAME IOP/CONT OR CLUSTER/UNIT VALUE
*D*               AS A GIVEN DEVICE ADDRESS.
*D*
*D*      INPUT:
*D*               R1 = CURRENT DCT INDEX & FLAGS
*D*               R4 = ORIGINAL DCT INDEX & FLAGS
*D*               R6 = CURRENT DEVICE ADDRESS
*D*              R10 = SC1/SC2 FLAGS (PRIM./ALT.)
*D*              R14 = FLAG FOR DEV./CONT.REQUEST
*D*
*D*      OUTPUT:
*D*               R1 = NEXT DCT INDEX & FLAGS
*D*               R6 = NEXT DEVICE ADDRESS
*D*               EXIT +0 = ABNORMAL RETURN (I.E., ALL DONE)
*D*               EXIT +1 = NORMAL RETURN (I.E., CONTINUE)
*D*
*D*      CALL:    R15 = LINK
*D*
*D*      REGISTERS:  R1-R2,R6,R8-R9,R15 USED, R4,R10 SAVED
*D*
********
         SPACE    3
COMPARE  EQU      %           <---  ENTER
         CI,R14   CNTFLG
         BAZ      *R15        --->  RETURN, NOT DEV.IN CONT.
         AND,R1   M16
         AI,R1    1                 TO NEXT DCT INDEX
         CI,R1    DCTSIZ
         BG       *R15        --->  RETURN, ALL DONE
         LB,R2    DCT2,R1     NO--- FURTHER CHECKS NEEDED
         CB,R2    DCT2,R4
         BNE      COMPARE     YES-- END OF CHANNEL, MAYBE
         LH,R8    DCT1P,R1    NO--- NEXT DEV.ADDR.
         CI,R10   SC1
         BANZ     %+2         YES-- PRIM.ADDR.
         LH,R8    DCT1A,R1    NO--- ALT.ADDR.
         LI,R9    MIOPCNTM          MUC MASK
         CI,R8    MIOPMASK          MULTI-UNIT TYPE
         BANZ     %+2         YES-- MUC TYPE
         LI,R9    SIOPCNTM    NO--- SUC MASK
         CS,R8    R6
         BNE      COMPARE     NO--  SAME CONT.
         LW,R6    R8          YES-- GET NEXT DEV.ADDR.
         STB,R10  R1                SET FLAGS (SC1/SC2)
         AI,R15   1                 EXIT +1
         B        *R15        --->  RETURN
*----------------
         PAGE
********
*D*
*D*      NAME:    MDRET
*D*      ENTRY:   MORETRN
*D*      DESCRIPTION:  PROCESS M:DRET CAL.
*D*         MORETRN -
*D*      SUB-ENTRY FOR RETURNING A DEVICE WHICH MAY HAVE MORE
*D*      THAN ONE DEVICE ADDRESS IN THE SYSTEM WHICH
*D*      ARE EQUAL.
*D*
*D*      INPUT:
*D*               R6 = DEVICE ADDRESS
*D*               R7 = ADDRESS OF FPT +1
*D*
*D*      OUTPUT:
*D*               CC1-2 = 11  INVALID DEVICE ADDRESS
*D*               CC1 = 1  DEVICE IS BUSY
*D*               CC4 = 1  RETURN PATH OF DUAL ONLY, NO DEVICES
*D*
*D*      INTERFACE:  FINDADDR,XIT,NOTEQ,RETDONE,ERRLGCMN,COMPARE.
*D*      REGISTERS:  R2-R6,R10-R15 USED, R7 SAVED
*D*
********
         SPACE    3
MDRET    EQU      %           <---  ENTER
         DISABLE
         BAL,R15  FINDADDR    ****  VALIDATE DEVICE ADDRESS
*
*  R1 = DCT INDEX (BITS 8-31)
*        BIT-5 = 1  PRIM.=ALT. & BIT-7 = 1 (PRIM.)
*        BIT-6 = 1  ALT.ADDR.
*        BIT-7 = 1  PRIM.ADDR.
*  R2(BIT0) = 0,  ADDRESS VALID
*           = 1,  ADDRESS INVALID
*
         CW,R2    Y8
         BAZ      RETDEV      YES-- ADDRESS O.K.
         LW,R2    YC          NO--- CC1 = 1,  CC2 = 1
         ENABLE
         B        XIT               EXIT
*----------------
RETDEV   EQU      %                 RETURN DEVICE
         PSW,R1   TSTACK            SAVE ORIGINAL DCT INDEX
RETITEM  EQU      %
         LB,R14   *R7               GET FPT SUB-CODE
         CI,R14   CNTFLG
         BAZ      DEVBSY      YES-- DEVICE REQUEST
*                             NO--- CONTROLLER REQUEST
         LW,R2    R6                DEVICE ADDRESS
         LB,R11   DCT2,R1           CHANNEL INDEX
         LI,R3    MIOPCNTM          MUC MASK
         CI,R2    MIOPMASK
         BANZ     %+2         YES-- MULTI-UNIT CONT.
         LI,R3    SIOPCNTM    NO--- SINGLE UNIT CONT.
         LI,R4    DCTSIZ
TRYMOR   EQU      %
         CB,R11   DCT2,R4
         BE       CNTBSY      YES-- SAME CHANNEL
NOTHIS1  EQU      %           NO---
         BDR,R4   TRYMOR      NO--- DONE
         B        NOTBSY      YES--
*----------------
CNTBSY   EQU      %
         LH,R12   DCT1P,R4          PRIM.DEV.ADDR.
         CW,R1    Y01
         BANZ     %+2         YES-- PRIM.TYPE
         LH,R12   DCT1A,R4    NO--- ALT.DEV.ADDR.
         CS,R2    R12
         BNE      NOTHIS1     NO--- SAME IOP/CONT.,ETC.
         LW,R15   DCT9,R4     YES--
         CW,R15   Y2
         BAZ      NOTHIS1     NO--- DEV.BUSY WITH DIAGNOSTICS
         B        ITEMBUSY    YES---
*----------------
DEVBSY   EQU      %
         LW,R12   DCT9,R1
         CW,R12   Y2
         BANZ     ITEMBUSY    YES-- DEV.BUSY WITH DIAGNOSTICS
NOTBSY   EQU      %           NO---
         CI,R14   CNTFLG
         BAZ      ONLY:DEV    YES-- RETURN DEVICE
         LI,R4    0           NO---
         LB,R3    R1                GET SC1/SC2 CODES
         AND,R3   X3
         LW,R5    PARTFLG,R3        GET PART.SC1/SC2 MASK
         CW,R5    DCT9,R1
         BAZ      TRY:ALT     NO--- PRIM.PART., NO TRY ALT.
NOTBSYX  EQU      %           YES--
         STS,R4   DCT9,R1           SET RETURN SC1/SC2
         LW,R5    STATFLG,R3        STATUS FLAG MASK
         LI,R4    0
         LS,R4    DCT9,R1           GET ORIGINAL SC1/SC2 STATUS
         XW,R4    R3                OBTAIN 0 MASK FROM R3
         STS,R4   DCT9,R1           RESET SC1/SC2 STATUS
         XW,R4    R3
         SLD,R4   -25
         LB,R11   DCT3,R1           SET SC1/SC2
         STS,R4   R11                 TO ORIGINAL VALUE
         STB,R11  DCT3,R1
         LB,R3    R1                GET SC1/SC2 CODE
         LB,R5    NEGR3,R3          GET SC2/SC1 MASK
         OR,R14   Y8                SPECIAL EXIT FLAG
         CB,R5    DCT3,R1
         BANZ     DNTDECRD    NO--- RETURN DEVICE
         EOR,R14  Y8          YES-- RESET SPECIAL EXIT FLAG
ONLY:DEV EQU      %
         CI,R14   CNTFLG
         BAZ      RET:DV      YES-- DEVICE REQUEST
         LW,R4    DCT9,R1     NO--- CONTROLLER
         CW,R4    PART:DV
         BANZ     NORETDV     YES-- DEV.PART.BEFORE CONT.,NO RET.DEV.
RET:DV   EQU      %           NO--- THEN RETURN DEVICE ALSO
         LI,R4    0
         LB,R2    SNDDX             # SYMBIONT ENTRIES
NXTSYM   EQU      %
         CB,R1    SNDDX,R2
         BE       SETSSTAT    YES-- SYMBIONT DEVICE
         BDR,R2   NXTSYM      NO--- DONE SEARCH
         LI,R15   0           YES-- NOT SYMB.DEV.FLAG
         B        RETRNDV
*----------------
TRY:ALT  EQU      %
         LI,R3    SC2               ALT.PATH MASK
         STB,R3   R1
         LW,R5    PARTFLG,R3        GET PART.SC2 MASK
         B        NOTBSYX
*----------------
SETSSTAT EQU      %
         STB,R4   SSTAT,R2          SET SYMB.NOT ACTIVE
         LI,R15   1                 SYMB.DEV.FLAG
RETRNDV  EQU      %
         LI,R5    DOWND
         LB,R10   DCT3,R1           RESET
         LW,R8    R10               SAVE DOWND FOR FURTHER CHECKING
         STS,R4   R10                 DEVICE
         STB,R10  DCT3,R1               DOWN FLAG
         LI,R5    NOALLOC+OLDWND
         LB,R10   DCT24,R1          SET
         STS,R4   R10                 DONT ALLOCATE & OLD DIAG.FLAGS
         STB,R10  DCT24,R1              UP
         LI,R4    0
         LW,R5    PART:DV           RESET DEV.PART.ALONE FLAG,
         STS,R4   DCT9,R1             I.E.,NOT IN CONT.REQUEST
NORETDV  EQU      %
         CI,R15   0
         BNEZ     DNTDECRD    YES-- SYMB.DEVICE
         LB,R4    DCT4,R1     NO---
         LI,R3    SV:RSIZ+1
NXTRSRCR EQU      %
         CB,R4    SB:RTY,R3
         BE       DECRCTD     YES-- FIND DEV.RESOURCE
         BDR,R3   NXTRSRCR    NO--- DONE SEARCH
         B        DNTDECRD    YES--
*----------------
DECRCTD  EQU      %
         CI,R8    DOWND
         BAZ      %+2         NO--- WAS DEV.REALLY DOWN, DONT COUNT
*                             YES-- DO RESOURCE COUNTING
         MTH,1    SH:RTOT,R3        INCREMENT TOTAL COUNT
         STW,R4   S:MBSF            FORCE RBBAT TO RE-SCHEDULE JOBS
DNTDECRD EQU      %
         LW,R4    R1                SAVE DCT INDEX
*  R1 =  DCT INDEX
*  R4 =  DCT INDEX
*  R6 =  DEVICE ADDRESS
         LB,R10   R1                GET SC1/SC2 CODE
         CI,R14   CNTFLG
         BAZ      RET:DEV     YES-- RETURN DEVICE
*                             NO--- CONTROLLER
         BAL,R15  COMPARE     ****  FIND OTHER DEVICES THE SAME
         B        NORMXITR       -0-END OF SEARCH
         B        RETITEM        -1-CONTINUE
*----------------
RET:DEV  EQU      %
         BAL,R15  NOTEQ       ****  SEARCH FOR ANOTHER ADDR.THE SAME
         CW,R2    Y8
         BAZ      RETITEM     YES-- MORE DEV.ADDRESSES
NORMXITR EQU      %           NO---
         ENABLE
         PLW,R1   TSTACK            RESTORE ORIGINAL DCT INDEX
         LW,R4    R1
         LB,R10   R1                GET SC1/SC2 CODE
         LH,R6    DCT1P,R1          PRIM.DEV.ADDR.
         CI,R10   SC1
         BANZ     %+2         YES-- PRIM.TYPE
         LH,R6    DCT1A,R1    NO--- ALT.DEV.ADDR.
LOGITR   EQU      %
         LI,R5    0                 SET FLAG TO RETURN
         PSW,R14  TSTACK
         CI,R14   CNTFLG
         BANZ     RETCNT      YES-- CONTROLLER REQUEST
         LI,R13   DEVMOD#     NO--- DEV.MOD.# TABLE
ERLGCNT  EQU      %
         LW,R14   L(X'52030000')    ERR.LOG CODE(RET), # WRDS/ENTRY
         B        ERRLGCMN
*----------------
MORETRN  EQU      %
         BAL,R15  COMPARE     ****  FIND MORE DEV.ADDR.SAME
         B        RETDONE        -0-DONE SEARCH
         B        LOGITR         -1-CONTINUE
*----------------
ITEMBUSY EQU      %
         ENABLE                     ENABLE INTERRUPTS
         LW,R2    Y8                CC1 = 1
         B        XIT               EXIT
*----------------
RETCNT   EQU      %                 RETURN CONTROLLER
         LI,R13   CNTMOD#           CONT.MOD.# TABLE
         OR,R6    Y8                CONTROLLER FLAG
         B        ERLGCNT
*----------------
         TITLE    'PROCESS DIAGNOSTIC CALS'
*F***************
*F*      NAME:    T:LOCK, T:MAP, T:DOPEN, T:DCLOSE, T:BLIST
*F*      PURPOSE: PROCESS THE M:LOCK, M:MAP, M:DOPEN, M:DCLOSE,
*F*               M:BLIST, & M:SIO SYSTEM PROCEDURES.
*F***************
         PAGE
*
* DIAGNOSTIC DCB DEFINITIONS
*
DIAG     EQU      5
PRI      EQU      21
CLIST    EQU      21
CHAN     EQU      11
PATH     EQU      11
STA      EQU      14
SWAPCT   EQU      19
BAPRI    EQU      4*PRI
SP:TYP   EQU      X'B'              PACK DEV.TYPE INDEX
CP:TYP   EQU      X'5'              CARD PUNCH DEV.TYPE INDEX
CP7160   EQU      X'7160'           CP MODEL# FOR 7160 DEV.
SIO:TYP  EQU      X'400'            FPT FLAG FOR SIO VS. TIO/TDV/HIO
TIO:TYP  EQU      X'200'            FPT FLAG FOR TIO
TDV:TYP  EQU      X'100'            FPT FLAG FOR TDV
HIO:TYP  EQU      X'80'             FPT FLAG FOR HIO
         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
R8       EQU      8
SR1      EQU      8
*
R9       EQU      9
SR2      EQU      9
*
R10      EQU      10
SR3      EQU      10
*
R11      EQU      11
SR4      EQU      11
*
R12      EQU      12
D1       EQU      12
*
R13      EQU      13
D2       EQU      13
*
R14      EQU      14
D3       EQU      14
*
R15      EQU      15
D4       EQU      15
*
DOWN     EQU      X'20'             DOWN BIT IN DCT3
NOERR    EQU      4                 NOERR BIT IN DCT3
         PAGE
***************************************
*
* REFS FOR DIAGNOSTIC CALS
*
***************************************
         REF      J:JIT             INPUT BITS 0-1
*,*                           CHECK ON-LINE VS GHOST VS BATCH MODE
         REF      ERO               OUTPUT BYTE 3 IN J:JIT+ERO
*,*                           ERROR SUB-CODE VALUE IN JIT
         REF      J:NRS             INPUT BITS 15-31
*,*                           CURRENT SWAP COUNT IN JIT
         REF      JBUPVP            INPUT
*,*                           LOWEST VIRTUAL PAGE # USER CAN HAVE
         REF      JB:PPC            INPUT BYTE 0
*,*                           USER PAGE COUNT IN JIT
         REF      JX:CMAP           INPUT BYTE OR HALF WORD TABLE
*,*                           PHYSICAL PAGE # USING VIRTUAL PAGE #
*,*                             AS INDEX INTO IT FOR USER, IN JIT
         REF      HIGH              INPUT WORD
*,*                           HIGHEST LEGAL PAGE #
         REF      FPMC              INPUT
*,*                           PHYSICAL PAGE # OF A RELEASED PAGE
         REF      JB:PRIV           INPUT BYTE 0 IN JIT
*,*                           USERS PRIVILEGE LEVEL
         REF      S:LCORE           INPUT OUTPUT WORD
*,*                           TOTAL PAGES CURRENTLY LOCKED
         REF      S:PCORE           INPUT WORD
*,*                           # PAGES OF CORE AVAILABLE TO USER
         REF      SL:STLM           INPUT WORD
*,*                           MAX.# OF STOLEN PAGES
         REF      UH:FLG2           INPUT OUTPUT HALF WORD BIT 2
*,*                           CHECK/SET/RESET LOCKED IN CORE FLAG
         REF      S:CUN             INPUT WORD
*,*                           CURRENT USER #
         REF      DID               INPUT WORD
*,*                           USER # FROM DIAG KEYIN
         REF      DCT9              INPUT OUTPUT WORD BITS 2-6
*,*                           SET/RESET PART.FLAGS & ORIG.DCT3
*,*                           SC1/SC2 VALUES
*,*                           SET/RESET DEV.IN DIAGNOSTIC MODE
         REF      SCNTXT            INPUT HALF WORD
*,*                           SYMBIONT CONTEXT BLOCK INFO
         REF      AVRTBL            INPUT DOUBLE WORD BIT 32
*,*                           CHECK FOR PUBLIC VS PRIVATE SPINDLE
         REF      OV:NMSZ           INPUT
*,*                           SIZE OF OH:NM TABLE
         REF      TYPMNSZ           INPUT
*,*                           SIZE OF OH:NM TABLES DEV.MNEMONICS
         REF      OV:SIZ             INPUT
*,*                           SIZE OF OH:NM TABLES OP-LABELS
         REF      TB:FLGS           INPUT BYTE BITS 0-3
*,*                           CHECK FOR RESOURCE TYPE
         REF      OB:BTX            INPUT BYTE
*,*                           OBTAIN BATCH DCT, RAT, OR LDV INDEX
         REF      OB:GTX            INPUT BYTE
*,*                           OBTAIN GHOST DCT, RAT, OR LDV INDEX
         REF      OB:OTX            INPUT BYTE
*,*                           OBTAIN ON-LINE DCT, RAT, OR LDV INDEX
         REF      MSGOUT            ROUTINE
*,*                           DISPLAY MESSAGE ON OC
         REF      NEWQ              ROUTINE
*,*                           QUEUE AN I/O REQUEST
         REF      T:ABORTM          ROUTINE
*,*                           ABORT EXIT FROM ON-LINE DIAGNOSTICS
         REF      CHKBIT0           ROUTINE
*,*                           INITIATE ANALYSIS OF CAL FPT
         REF      CHKBIT            ROUTINE
*,*                           CONTINUE ANALYSIS OF CAL FPT
         REF      IOCHEK1           ROUTINE
*,*                           WAIT FOR I/O RUN-DOWN
         REF      IOSPRTN           ROUTINE
*,*                           EXIT ON-LINE DIAGNOSTICS VIA I/O SPIN
         REF      MSREXIT           ROUTINE
*,*                           EXIT ON-LINE DIAGNOSTICS NORMALLY
         REF      MSR01EXIT         ROUTINE
*,*                           EXIT ON-LINE DIAGNOSTICS ABNORMALLY
         REF      GMB               ROUTINE
*,*                           GET MONITOR BUFFER
         REF      RMB               ROUTINE
*,*                           RELEASE MONITOR BUFFER
         REF      GMBSIZ            INPUT
*,*                           MONITOR BUFFER SIZE
         REF      OPNTPSEG          ROUTINE
*,*                           OPEN DCB TO OPLABEL OR DEV.& IS TAPE
         REF      OPNT#             ROUTINE
*,*                           ENTRY # INTO OPNTPSEG
         REF      CLSTP#            ROUTINE
*,*                           ENTRY # INTO OPNTPSEG
         REF      XFF               CONSTANT X'FF'
         REF      M6                CONSTANT X'3F'
         REF      M7                CONSTANT X'7F'
         REF      M9                CONSTANT X'1FF'
         REF      M16               CONSTANT X'FFFF'
         REF      MINUS2            CONSTANT X'FFFFFFFE'
         REF      Y2                CONSTANT X'20000000'
         REF      Y04               CONSTANT X'04000000'
         REF      Y08               CONSTANT X'08000000'
         REF      YFF               CONSTANT X'FF000000'
         REF      Y001              CONSTANT X'00100000'
         REF      Y002              CONSTANT X'00200000'
         REF      Y004              CONSTANT X'00400000'
         REF      Y0008             CONSTANT X'00080000'
         PAGE
*D*
*D*      NAME:    SETRTRN
*D*      ENTRY:   PRVCHKC0
*D*      ENTRY:   SETSTK
*D*      ENTRY:   PRVCHKA0
*D*      DESCRIPTION:  PERFORM NECESSARY PRIVILEGE LEVEL CHECKS
*D*               & SAVE INFO IN TEMP STACK.
*D*         PRVCHKC0 -
*D*      CHECK FOR PRIVILEGE LEVEL >= C0.
*D*         SETSTK -
*D*      SAVE INFO IN STACK.
*D*         PRVCHKA0 -
*D*      CHECK FOR PRIVILEGE LEVEL >= A0.
*D*
*D*      INTERFACE:  IOSPRTN,PUSHALL,T:ABORTM.
*D*      REGISTERS:  R1,R5,R11,R14 USED, R2 SAVED
*D*
SETRTRN  EQU      %
         LI,R11   IOSPRTN           RETURN THRU CALPROC I/O SPIN
         LI,R5    X'A0'
PRVCHKC0 EQU      %
         CI,R5    X'C0'
         BGE      SETSTK      YES-- > C0 PRIVILEGE, SKIP ID CHECK
         LW,R5    S:CUN       NO--- GET USER #
         CW,R5    DID
         BNE      NOTAUTH     NO--- USER AUTHORIZED
SETSTK   EQU      %           YES--
         STW,R6   J:BASE+1
         LI,R6    6
         BAL,R1   PUSHALL
         LW,R6    J:BASE+1
         B        0,R2              RETURN
PRVCHKA0 EQU      %
         LB,R5    JB:PRIV           USER'S PRIVILEGE LEVEL
         CI,R5    X'A0'
         BGE      0,R2        YES-- RETURN, PRIVILEGE => A0
*                             NO--- ERROR, <A0 PRIVILEGE
NOTAUTH  EQU      %
         LW,D3    =X'14000009'      NO - ERROR 09 SUBCODE 0A
         B        T:ABORTM          ABORT HIM
         PAGE
*************************************************
*DO*
*D*      NAME:    DIAGABN
*        ENTRY:   DIAGERR
*        ENTRY:   DIAGXIT
*        DESCRIPTION:
*           DIAGABN -
*        ABNORMAL RETURN FOR DIAGNOSTIC CALS.
*           DIAGERR -
*        ERROR RETURN FOR DIAGNOSTIC CALS.
*           DIAGXIT -
*        NORMAL RETURN FOR DIAGNOSTIC CALS.
*
*        INPUT:
*                 R2 = ERROR CODE & SUBCODE
*                      ERROR CODE = BYTE-0
*                      SUBCODE = BYTE-3
*
*        INTERFACE:  RMB,MSR01EXIT,MSREXIT,T:SELFDESTRUCT.
*        REGISTERS:  R3,R10-R11,R14 USED
*FIN*
*************************************************
DIAGABN  RES      0
         LI,R3    X'FF'
         STS,R2   J:JIT+ERO         SET SUBCODE
         LW,SR3   R2
         SCS,SR3  -7
         AI,SR3   9                 DIAG ABN CODE
DIAGABNX EQU      %
         LW,D3    BUF,R6            GET MPOOL ADDR.IF ONE WAS USED
         BEZ      DIAGERR     NO--- ANY USED
         BAL,SR4  RMB   ****  YES-- RELEASE IT
DIAGERR  LI,SR4   MSR01EXIT
         B        T:SELFDESTRUCT
DIAGXIT  EQU      %
         LI,R11   MSREXIT           EXIT TO IORT
         B        T:SELFDESTRUCT
         PAGE
         BOUND    4
PARTMSG  EQU      %
         DATA,1   PARTSZ-1
         DATA,12  ' PARTITIONED'
         DATA,1   X'15'
PARTSZ   EQU      BA(%)-BA(PARTMSG)
         BOUND    4
RETMSG   EQU      %
         DATA,1   RETSZ-1
         DATA,9   ' RETURNED'
         DATA,1   X'15'
RETSZ    EQU      BA(%)-BA(RETMSG)
         BOUND    4
MASKCLS  DATA     X'60BC00'
XTX      LB,R3    OB:BTX,R3         BATCH
         LB,R3    OB:GTX,R3         GHOST
         LB,R3    OB:OTX,R3         ONLINE
RTOT     MTH,-1   SH:RTOT,R3        DECREMENT TOTALS
         MTH,1    SH:RTOT,R3        INCREMENT TOTALS
         PAGE
*************************************************
*D*
*D*      NAME:    T:LOCK
*D*      ENTRY:   DIAGXIT0
*D*      ENTRY:   DIAGXIT1
*D*      ENTRY:   DIAGXIT2
*D*      DESCRIPTION:  PROCESS THE M:LOCK CAL.
*D*
*D*      INPUT:
*D*               R7 = ADDRESS OF FPT +1
*D*
*D*      INTERFACE:  PRVCHKA0,PRVCHKC0,PULLALLEXIT,T:SELFDESTRUCT.
*D*      REGISTERS:  R2-R4,R13 USED, R5-R11 SAVED
*D*
*D*         DIAGXIT0 -
*D*      PUT ERROR CODE FROM R2 INTO USERS R10
*D*
*D*      INPUT:
*D*               R2 = ABNORMAL CODE & SUBCODE
*D*
*D*      INTERFACE:  DIAGXIT1.
*D*      REGISTERS:  R2 USED
*D*
*D*         DIAGXIT1 -
*D*      SET USERS ERROR CODE TO 0, NORMAL EXIT.
*D*
*D*      INTERFACE:  DIAGXIT2.
*D*      REGISTERS:  R2,R7 USED
*D*
*D*         DIAGXIT2 -
*D*      NORMAL EXIT.
*D*
*D*      INTERFACE:  PULLALLEXIT,T:SELFDESTRUCT.
*D*      REGISTERS:  R11 USED
*D*
*************************************************
T:LOCK   EQU      %
         BAL,R2   PRVCHKA0    ****  CHECK PRIVILEGE =>A0
         BAL,R2   PRVCHKC0    ****  CHECK PRIVILEGE =>C0
         LW,R6    S:CUN             GET CURRENT USER #
         LH,D2    UH:FLG2,R6        GET USER FLAGS
         LI,SR1   X'800'            IS USER REQUESTING
         CW,SR1   0,R7              TO LOCK OR UNLOCK
         BAZ      UNLCK             UNLOCK REQUEST
         CI,D2    X'2000'           IS HE LOCKED NOW
         BANZ     T:LOCKRET         YUP, GET OUT
         LB,R2    JB:PPC            USER PAGE COUNT
         AW,R2    S:LCORE           ADD CURRENT # LOCKED
         LW,R4    S:PCORE           IS THERE SUFFICIENT
         SW,R4    SL:STLM           CORE AVAILABLE TO PERMIT
         CW,R2    R4                USER TO LOCK
         BGE      NOCORE            NOPE, ERROR HIM
LOCKXIT  RES      0
         STW,R2   S:LCORE           # PAGES LOCKED
         DISABLE                    KILL THE INTERRUPTS
         LH,D2    UH:FLG2,R6        GET USER FLAGS
         CW,SR1   0,R7              LOCK OR UNLOCK REQUEST
         BAZ      %+3               UNLOCK
         AI,D2    X'2000'           SET LOCK BIT
         B        %+2
         AI,D2    -X'2000'          RESET LOCK BIT
         STH,D2   UH:FLG2,R6        PUT FLAGS AWAY
         ENABLE                     LET 'EM COME
T:LOCKRET  EQU    %
         LI,SR3   0
         B        DIAGXIT1
UNLCK    EQU      %
         CI,D2    X'2000'           IS HE UNLOCKED NOW
         BAZ      T:LOCKRET         YUP, GET OUT
         LW,R2    S:LCORE           TOTAL PAGES CURRENTLY LOCKED
         LB,R3    JB:PPC            GET USER PAGE COUNT
         SW,R2    R3                SUBTRACT HIS SIZE FROM TOTAL
         BGEZ     LOCKXIT           SEE IF HE CHEATED
         LI,R2    0
         B        LOCKXIT           RETURN
NOCORE   EQU      %
         LI,R2    X'0916'           ABN 09 SUBCODE 0B
DIAGXIT0 EQU      %
         SLS,R2   16
         B        %+2
DIAGXIT1 EQU      %
         LI,R2    0
         LW,R7    TSTACK
         AI,R7    -13
         STW,R2   0,R7
DIAGXIT2 EQU      %
         LI,R11   PULLALLEXIT       EXIT TO IORT
         B        T:SELFDESTRUCT
         PAGE
**************************************************
*D*
*D*      NAME:    T:MAP
*D*      ENTRY:   VTP
*D*      ENTRY:   PTV
*D*      ENTRY:   BADPAGE
*D*      DESCRIPTION:  PROCESS THE M:MAP CAL.
*D*
*D*      INPUT:
*D*               R6 = CORE ADDRESS TO BE CONVERTED
*D*               R7 = ADDRESS OF FPT +1
*D*
*D*      OUTPUT:
*D*               USERS R8 = CONVERTED CORE ADDRESS
*D*
*D*      INTERFACE:  PRVCHKA0,SETSTK,VTP,PTV,DIAGXIT2.
*D*      REGISTERS:  R0,R2-R4 USED, R5-R11 SAVED
*D*
*D*         VTP -
*D*      CONVERT VIRTUAL PAGE # TO PHYSICAL PAGE #.
*D*
*D*      CALL:    R0 = LINK
*D*
*D*      INPUT:
*D*               R4 = VIRTUAL CORE ADDRESS
*D*
*D*      OUTPUT:
*D*               R5 = PHYSICAL CORE ADDRESS
*D*
*D*      INTERFACE:  BADPAGE.
*D*      REGISTERS:  R4-R5 USED, R0 SAVED
*D*
*D*         PTV -
*D*      CONVERT PHYSICAL PAGE # TO VIRTUAL PAGE #.
*D*
*D*      CALL:    R0 = LINK
*D*
*D*      INPUT:
*D*               R4 = PHYSICAL CORE ADDRESS
*D*
*D*      OUTPUT:
*D*               R5 = VIRTUAL CORE ADDRESS
*D*
*D*      INTERFACE:  BADPAGE.
*D*      REGISTERS:  R2-R5 USED, R0 SAVED
*D*
*D*         BADPAGE -
*D*      CORE PAGE ADDRESS REQUEST IS IN ERROR.
*D*
*D*      INPUT:
*D*               R8 = 2  M:MAP CAL
*D*                  > 2  OTHER CALS
*D*
*D*      OUTPUT:
*D*               R2 = ABNORMAL CODE & SUBCODE
*D*
*D*      INTERFACE:  DIAGXIT0,DIAGABN.
*D*      REGISTERS:  R2 USED
*D*
**************************************************
T:MAP    EQU      %
         BAL,R2   PRVCHKA0    ****  CHECK PRIVILEGE =>A0
         BAL,R2   SETSTK      ****  SET UP TSTACK
         LI,R8    2
         LI,R0    STUSR1            RETURN ADDRESS
         LW,R4    R6                ADR.TO BE CONVERTED
         LW,R3    0,R7              GET FPT+1
         CI,R3    X'800'            VIRT-PHYS OR PHYS-VIRT
         BAZ      VTP               VIRTUAL TO PHYSICAL
         B        PTV               PHYSICAL TO VIRTUAL
STUSR1   EQU      %                 STORE ADR IN USERS SR1
         LW,R7    TSTACK            COMPUTE ADDRESS OF
         AI,R7    -15               USERS SR1 IN TSTACK
         STW,R5   *R7
         B        DIAGXIT2
VTP      EQU      %
         AND,R4   M17               EXTRACT VIRT ADR
         SLD,R4   -9                GET VIRT PAGE #
         CI,R4    JBUPVP            IS IT IN HIS AREA
         BL       BADPAGE           NO, ERROR
         LOAD,R4  JX:CMAP,R4        GET PHYS PAGE #
         CI,R4    FPMC
         BE       BADPAGE
         SLD,R4   -23
         B        *R0
PTV      EQU      %
         SLD,R4   -9                GET PHYS PAGE #
         CW,R4    HIGH              IS PHYS ADR LEGAL
         BG       BADPAGE           NO, ERROR HIM
         LI,R3    X'FF'             HIGHEST VIRTUAL PAGE
         LI,R2    X'100'-JBUPVP     NUMBER OF PAGES IN HIS MAP
PPSRCH   EQU      %                 SEARCH FOR PHYS PAGE #
         COMPARE,R4  JX:CMAP,R3     DID WE FIND IT
         BNE      CHKNXT            NOPE, TRY AGAIN
         LW,R4    R3
         SLD,R4   -23
         B        *R0
CHKNXT   RES      0
         AI,R3    -1                DECREMENT PAGE #
         BDR,R2   PPSRCH            TRY AGAIN
BADPAGE  EQU      %
         CI,R8    2                 CHECK FLAG FOR TYPE OF EXIT
         BNE      %+3
         LI,R2    X'091C'           ABN 09 SUBCODE 0E
         B        DIAGXIT0
         LI,R2    8                 ABN 09 SUBCODE 08
         B        DIAGABN
         PAGE
**********************************************
*D*
*D*      NAME:    T:DOPEN
*D*      ENTRY:   BADDEV
*D*      ENTRY:   GETDCTX
*D*      ENTRY:   CLOSE
*D*      DESCRIPTION:  PROCESS THE M:DOPEN CAL.
*D*
*D*      INPUT:
*D*               R6 = DCB ADDRESS
*D*               R7 = ADDRESS OF FPT +1
*D*
*D*      INTERFACE:  PRVCHKA0,SETRTRN,DIAGERR,CHKBIT0,
*D*               CHKBIT,DIAGABN,CLOSE,GETDCTX,BADDEV.
*D*      REGISTERS:  R0-R4,R12-R15 USED, R5-R11 SAVED
*D*
*D*         BADDEV -
*D*      ILLEGAL DEVICE/DEVICE TYPE REQUESTED, THUS ERROR.
*D*
*D*      OUTPUT:
*D*               R1 = ABNORMAL SUBCODE (BYTE-3)
*D*
*D*      INTERFACE:  DIAGABN.
*D*      REGISTERS:  R2 USED
*D*
*D*         GETDCTX -
*D*      IF DCT INDEX UNKNOWN, DO NECESSARY OPEN & THEN
*D*      OBTAIN DCT INDEX FROM DCB.
*D*
*D*      CALL:    R15 = LINK
*D*
*D*      INPUT:
*D*               R1 = DSI FIELD FROM DCB BEFORE OPEN
*D*               R3 = DEVICE TYPE CODE
*D*               R0 = 0  DEVICE ADDRESS (NON-TAPE)
*D*                  = 1  DEVICE ADDRESS (TAPE)
*D*                  = 2  OPLABEL/DEV.TYPE (NON-TAPE)
*D*                  = 3  OPLABEL/DEV.TYPE (TAPE)
*D*               R6 = DCB ADDRESS
*D*
*D*      INTERFACE:  REMEMBER,OVERTO,PUSHALL,
*D*               OPNTPSEG (OPNT# AS RELATIVE ENTRY).
*D*      REGISTERS:  R0-R2,R11-R13 USED, R15 SAVED
*D*
*D*         CLOSE -
*D*      PERFORM CLOSE OF DCB WHEN IT HAS BEEN OPENED &
*D*      FURTHER SYNTAX CHECKS FIND THAT THE USERS INPUT
*D*      FOR M:DOPEN IS BAD.
*D*
*D*      CALL:    R11 = LINK
*D*
*D*      INPUT:
*D*               R2 = DCT INDEX
*D*               R6 = DCB ADDRESS
*D*
*D*      INTERFACE:  BADDEV.
*D*      REGISTERS:  R4 USED
*D*
***********************************************
T:DOPEN  EQU      %
         BAL,R2   PRVCHKA0    ****  CHECK PRIVILEGE =>A0
         BAL,R2   SETRTRN     ****  SET UP RETURN
         LI,SR3   X'2E'             OPEN AN OPEN DCB
         LW,D2    Y002              IS DCB ALREADY OPEN
         LS,D2    FCD,R6
         BNEZ     DIAGERR           YUP, ABNORMAL 2E
         LI,SR3   1
         LW,D2    Y2                IS DCB A DIAG DCB
         LS,D2    DIAG,R6           IF NOT, THEN
         BEZ      DIAGERR           ABNORMAL 01
         LI,R4    3
         LI,R5    X'F'
         STS,R4   ASN,R6            FORCE DCB TO DEV.TYPE
         LI,R4    0
         STW,R4   NVA,R6
         STW,R4   SND,R6
         STW,R4   QBUF,R6
         STW,R4   BUF,R6            INITIALIZE MPOOL ADDR.IN DCB
         LI,R5    4                 INDEX TO CLEAR
         STB,R4   *R6,R5            SOFTWARE CHANNEL FLAG IN DCB
         BAL,R2   CHKBIT0           CHECK PLIST
         STS,D1   DSI,R6            STORE TYPE,OPLBLE, OR DEV ADDR
         BAL,R2   CHKBIT            CHECK FOR STATUS ADR
         STS,D1   STA,R6            STATUS ADR
         BAL,R2   CHKBIT            CHECK FOR ABN ADR
         STS,D1   ABA,R6            ABN ADR PRESENT
         LW,R5    0,R7              GET FPT+1
         CI,R5    X'200'            SN OPTION PRESENT
         BAZ      CHKDEV            NOPE
         LW,D2    *R7,R1            YUP, CHECK CONTROL WORD
         LB,D1    D2
         CI,D1    7                 CORRECT VLP CODE
         BNE      DIAGERR           NOPE
         LW,D1    FLP,R6            GET FLP ADDRESS
         LW,D2    *D1               VLP CONTROL WORD
         LB,D3    D2
         CI,D3    7                 CORRECT VLP CODE
         BNE      DIAGERR           NOPE
         LI,R4    0                 VLP INDEX INTO DCB
         LI,R2    0
         LI,R3    X'FF00'
         STS,R2   *D1               SET # WORDS IN VLP =0
         LI,R2    3
         LB,R3    *D1,R2            # WORDS IN VLP OF DCB
         LI,R2    2
         LW,D2    *R7,R1
         LB,R2    D2,R2
NXTSN    EQU      %
         AI,R4    1                 TO NXT VLP WORD IN DCB
         CW,R4    R3
         BG       DIAGERR           VLP IN DCB NOT LARGE ENOUGH
         LI,D2    X'100'
         AWM,D2   *D1               INCREMENT VLP COUNT IN DCB
         AI,R1    1
         LW,D2    *R7,R1            SN IN FPT
         STW,D2   *D1,R4            PUT SN INTO DCB VLP
         AI,R2    -1                DECREMENT # FPT ENTRIES
         BGZ      NXTSN             NOT DONE YET
CHKDEV   LW,D1    DSI,R6
         CI,D1    X'8000'           PHYS. DEVICE ADR.
         BANZ     OPTYPE            NOPE,OPLABEL OR TYPMNE
         LI,R0    0
         LI,R3    DCTSIZ            YUP
         AND,D1   M16               KEEP ONLY DEV.ADDR.
DOP1     EQU      %
         CH,D1    DCT1P,R3          FIND DEV.ADDR.
         BE       DOP2PRM           PRIMARY ADDR.
         CH,D1    DCT1A,R3          CHECK ALTERNATE DEV.ADDR.
         BE       DOP2ALT           ALTERNATE ADDR.
         BDR,R3   DOP1              IF AT FIRST YOU DO
*                                   NOT SUCCEED,TRY,TRY
*                                   AND TRY  AGAIN
BADDEV   LI,R2    1                 NONEXISTENT DEVICE
         B        DIAGABN           ABN 09 SUBCODE 01
OPTYPE   EQU      %
         LI,R2    X'11'             ABN 09 SUBCODE 11
         CI,R5    X'480'
         BANZ     DIAGABN           ERROR, CHAN/PATH FOR TYPE/OPLABEL
*                                       IS NOT LEGAL
         LI,R5    0
         LI,R0    2
         LI,R3    OV:NMSZ           # OF GUYS IN OH:NM
         STH,D1   D1
         LH,D1    D1                CAUSE SIGN EXTENSION
OPT1     RES      0
         CH,D1    OH:NM,R3          TEXT NAME
         BE       OPT2              YUP
         BDR,R3   OPT1              NO, TRY AGAIN
ABNAB    LI,SR3   X'AB'             ABNORMAL AB
         B        DIAGERR           ERROR-NAME NOT FOUND
OPT2     EQU      %
         CI,R3    TYPMNSZ+OV:SIZ    LOGICAL RESOURCE
         BG       ABNAB             ERROR
         LB,R1    J:JIT             0=BATCH,1=GHOST,2=ONLINE
         SLS,R1   -6
         EXU      XTX,R1            DCTX,RATX,OR LATX
         CI,R3    DCTSIZ            DCTX
         BG       OPT5              NO, RATX OR LATX
         LB,R2    DCT4,R3           YUP, GET TYPE
         B        OPT6
OPT5     RES      0
         AI,R3    -DCTSIZ-1
         CI,R3    SV:RSIZ           GOT RATX
         BG       ABNAB             ERROR
         LB,R2    SB:RTY,R3         DEVICE TYPE
         LI,R3    0                 RAT=0
OPT6     AI,R3    X'8000'
         SLS,R2   8
         AW,R2    R3                TYPE
         LI,R3    X'1FFFF'          NOPE
         STS,R2   DSI,R6            INTO DCB
         LI,R3    BADSI
         LB,R1    *R6,R3            DSI
         AND,R2   XFF               DCTX/RATX=0
         LI,R3    BADEVTP
         LB,R3    *R6,R3            DEVTP
         AND,R3   M6                TYPE CODE
         BEZ      DOP3              DEVICE NO
* R1 HAS DSI, IF ZERO THEN RATX, IF NONZERO THEN DCTX
* R2 HAS DCTX
* R3 HAS TYPE CODE
* R5 HAS PRIM/ALT CONT.PARTITIONED FLAG
         LC       TB:FLGS,R3        TYPE FLAGS
         BCR,8    NONTAPE           NOT A TAPE OR PACK
         BCR,3    BADDEV            CANNOT HAVE THIS TYPE
         BCS,4    PACK              MUST BE A PACK
         AI,R0    1
         BAL,D4   GETDCTX           GET A DCTX
* STORE TYPE & DCTX
SETDSI   RES      0
         LI,R1    BADSI
         STB,R2   *R6,R1            DCTX TO DSI
DOP3     EQU      %
         LW,R4    R5                SAVE PRIM/ALT CONT.PART.FLAG
         LI,R5    4                 INDEX TO SET UP
         STB,R4   *R6,R5            SOFTWARE CHANNEL FLAG IN DCB
         LW,R5    0,R7              GET FPT+1 INFO
         CI,R5    X'480'            CHAN OR PATH REQUEST
         BAZ      CHKNOER           CHECK NOERR OPTION
         LI,SR2   X'18000'          DCB BITS FOR CHAN & PATH
         CI,R5    X'400'            CHAN SPECIFIED
         BAZ      NOCHAN            NO
         LW,R11   DCT9,R2           GET CONTROLLER FLAGS
         AND,R11  YFF               EXTRACT CONT FLAGS
         CW,R11   R4                IS CONTROLLER PARTITIONED...
         BANZ     CHKPATH           YUP, THATS GOOD
         BAL,R11  CLOSE       ****
         LI,R2    X'0C'             NOPE, THATS BAD
         B        DIAGABN           ABN 09 SUB 0C
NOCHAN   RES      0
         AI,SR2   -X'10000'         NO CONTROLLER NEEDED
CHKPATH  RES      0
         CI,R5    X'80'             WAS PATH REQUESTED
         BANZ     %+2               YES
         AI,SR2   -X'8000'          NO PATH REQUEST
         STS,SR2  CHAN,R6           SET BITS IN DCB
CHKNOER  EQU      %
         DISABLE
         LB,SR2   DCT3,R2
         OR,SR2   X4                YUP, SET FLAG FOR NOERR
         CI,R5    X'800'
         BANZ     %+2               NOERR IS SPECIFIED
         AND,SR2  NB31TO0+3         RESET NOERR FLAG, =X'FB'
         STB,SR2  DCT3,R2           IN DCT3-BIT 5
         LW,SR2   DCT9,R2
         OR,SR2   Y2                SET DEV.IN DIAG.MODE FLAG
         STW,SR2  DCT9,R2
         ENABLE
         LI,SR1   0
         LI,SR3   0
         B        DIAGXIT2
DOP2PRM  EQU      %
         LW,R5    PARTFLG+1         PRIM.CONT.PART.FLAG
         B        DOP2
DOP2ALT  EQU      %
         LW,R5    PARTFLG+2         ALT.CONT.PART.FLAG
DOP2     EQU      %
         LB,R2    DCT3,R3
         CI,R2    DOWN
         BANZ     DOP2A       YES-- DEV.PARTITIONED
         LI,R2    X'0D'       NO--- ERROR 09 SUBCODE 0D
         B        DIAGABN
DOP2A    EQU      %
         LW,R2    R3                DON'T DESTROY DCT INDEX
         AI,R2    -BATAPE           SEE IF SPINDLE (TAPE/PACK)
         BLZ      DOP2B       NO--- SPINDLE TYPE
         CI,R2    AVRTBLNE    YES-- POSSIBLY
         BGE      DOP2B       NO--- SPINDLE
         LD,R12   AVRTBL,R2   YES--
         CW,R13   L(X'C1FF0000')
         BANZ     DOP2C       YES-- DEVICE BUSY
         LH,R12   AVRNOU,R2   NO---
         BNEZ     DOP2C       YES-- DEVICE BUSY
DOP2B    EQU      %           NO---
         LB,R2    DCT4,R3           TYPE CODE
         B        OPT6
DOP2C    EQU      %
         LI,R2    2
         B        DIAGABN           ABN 09 SUBCODE 02
NONTAPE  EQU      %
         BAL,D4   GETDCTX           GET DCTX
*  SINCE DEVICE IS NOT A TAPE, THEN IT
*  MUST BE A LOCKED SYMBIONT DEVICE OR
*  ELSE AN ERROR RESULTS...
         LB,R4    SNDDX             # OF SYMBIONT  ENTRIES
         CB,R2    SNDDX,R4          FIND SYMBIONT INDEX
         BE       SYML              YUP, R4=SYMBIONT INDEX
         BDR,R4   %-2               NOPE, TRY AGAIN
         B        CLS:IT
SYML     EQU      %
         LB,SR1   SSIG,R4           SYMBIONT SIGNAL
         AH,SR1   SCNTXT,R4         SCNTXT SHOULD BE ZERO
         BEZ      SETDSI            SYM NOT ACTIVE
         CI,SR1   'L'               IS IT LOCKED
         BE       SETDSI            YUP, THINGS ARE DANDY
         CI,SR1   'Q'               IS IT LOCKED
         BE       SETDSI            YES
         BAL,R11  CLOSE       ****
         LI,R2    3                 NOPE, ERROR HIM
         B        DIAGABN           ABN 09 SUBCODE 03
PACK     RES      0
         AI,R0    4
         BAL,D4   GETDCTX           CHECK DCTX
         LW,R4    R2                GET DCTX
         AI,R4    -BATAPE           INDEX FOR AVRTBL
         LD,D3    AVRTBL,R4         AVR INFO
         AI,D4    0                 IS PACK PRIVATE
         BLZ      CLS:IT            NO, ERROR
         B        SETDSI
CLS:IT   EQU      %
         BAL,R11  CLOSE       ****
         B        BADDEV
CLOSE    EQU      %
         BAL,R4   SAME        ****
         B        *R11
GETDCTX  RES      0
         AI,R1    0                 IS DCT ALREADY OBTAINED
         BNEZ     OPEN:IT           YES
         LI,R2    DCTSIZ            # OF DCTS
         CB,R3    DCT4,R2           GET DCTX BY MATCHING TYPE
         BE       OPEN:IT           R2=DCTX
         BDR,R2   %-2               TRY AGAIN
         B        BADDEV            CANT FIND, ERROR
OPEN:IT  EQU      %
         LB,D1    DCT3,R2
         SLS,D1   -6
         LI,D2    X'F'
         SLD,D1   17
         STS,D1   FUN,R6            SET FUNCTION IN DCB
         PSW,D4   TSTACK
         CI,R0    3
         BE       OPN:MT            OPEN TAPE (OPLABEL/DEV.TYPE)
         CI,R0    6
         BE       OPN:DP            OPEN PACK (OPLABEL/DEV.TYPE)
         B        NO:MT:DP          OPEN DEVICE DIRECT (DEV.ADDR.)
*                             R0 =  0  DEV.ADDR. - NON TAPE
*                             R0 =  1  DEV.ADDR. - TAPE
*                             R0 =  2  OPLABEL/DEV.TYPE - NON TAPE
*                             R0 =  3  OPLABEL/DEV.TYPE - TAPE
*                             R0 =  4  DEV.ADDR. - PACK
*                             R0 =  6  OPLABEL/DEV.TYPE - PACK
OPN:DP   EQU      %
OPN:MT   EQU      %
         LI,R11   CHK:OPN           RETURN POINT
         REMEMBER
         BAL,R1   PUSHALL           SAVE 5-11
         LI,R0    X'20'
         LW,R1    L(X'C00000FF')
         STS,R0   DIAG,R6           SET DCB FOR OPNTPSEG
         OVERTO   OPNTPSEG,OPNT#
*----------------
NO:MT:DP EQU      %
         LW,D4    Y002
         STS,D4   0,R6              SET DCB OPEN
         B        IS:OPN
*---------------
*  OPNTPSEG RETURNS TO HERE
********
CHK:OPN  EQU      %
         LW,D4    0,R6
         CW,D4    Y002
         BANZ     IS:OPN      YES-- DID OPNTPSEG OPEN DCB
         LB,R14   R10         NO--- SAVE ERROR CODE
         SLS,R10  8
         SLS,R10  -25
         LI,R11   X'FF'
         STS,R10  J:JIT+ERO         PUT SUB-CODE INTO JIT
         SCS,R10  -7
         AW,R10   R14               SUB-CODE & ERROR CODE
         B        DIAGABNX
*----------------
IS:OPN   EQU      %
         LI,R1    BADSI             YES,OPENED O.K.
         LB,R2    *R6,R1
         PLW,D4   TSTACK
         B        *D4
         PAGE
***********************************************
*D*
*D*      NAME:    T:DCLOSE
*D*      ENTRY:   SAME
*D*      ENTRY:   SET%STATUS
*D*      ENTRY:   T:CLOSIT
*D*      DESCRIPTION:  PROCESS THE M:DCLOSE CAL.
*D*
*D*      T:CLOSIT - SPECIAL ENTRY FOR CLSTP IN OPNTPSEG
*D*               FOR THE DIAGNOSTIC CLOSING OF DIAGNOSTIC
*D*               DCBS.
*D*
*D*      INPUT:
*D*               R6 = DCB ADDRESS
*D*               R7 = ADDRESS OF FPT +1
*D*
*D*      INTERFACE:  PRVCHKA0,SETRTRN,IOCHEK1,SAME,SET%STATUS,
*D*               BADDEV,MSGOUT,DIAGERR.
*D*      REGISTERS:  R0-R4,R13 USED, R5-R11 SAVED
*D*
*D*         SAME -
*D*      CLOSE DCB WITHOUT CHANGING STATUS OF DEVICE,
*D*      I.E., DONT PARTITION OR RETURN IT.
*D*
*D*      CALL:    R4 = LINK IF SAME ROUTINE CALLED SEPARATELY.
*D*               R4 = 0  IF ENTERED AS PART OF T:DCLOSE ROUTINE.
*D*
*D*      INPUT:
*D*               R2 = DCT INDEX
*D*               R6 = DCB ADDRESS
*D*
*D*      INTERFACE:  DIAGXIT
*D*      REGISTERS:  R0,R5,R8-R10 USED, R4 SAVED
*D*
*D*         SET%STATUS -
*D*      SET STATUS FOR DEVICE, I.E., PARTITION/RETURN IT
*D*      OR LEAVE IT THE SAME.
*D*
*D*      CALL:    R5 = LINK
*D*
*D*      INPUT:
*D*               R1 = STATUS TYPE INDEX
*D*                  = -1  SAME AS PREVIOUS STATUS
*D*                  = 0   PARTITION IT
*D*                  = 1   RETURN IT
*D*
*D*      REGISTERS:  R8 USED, R5 SAVED
*D*
***********************************************
T:DCLOSE EQU      %
         BAL,R2   PRVCHKA0    ****  CHECK PRIVILEGE =>A0
         BAL,R2   SETRTRN     ****  SET UP RETURN
T:CLOSIT EQU      %
         LI,R4    BADSI
         LB,R2    *R6,R4            R2=DCTX
         LW,D2    Y002              IS DCB ALREADY CLOSED
         AND,D2   FCD,R6
         BNEZ     CLS1              NOPE
         LI,SR3   X'A'              YES, ERROR
         B        DIAGERR           ABN A
CLS1     EQU      %
         LI,SR3   1
         LW,D2    Y2                MASK FOR DIAG DCB
         LS,D2    DIAG,R6           IS DCB A DIAG DCB
         BEZ      DIAGERR           NO, ABN 01
         LI,SR4   0
         STW,SR4  BUF,R6            INITIALIZE MPOOL ADDR.IN DCB
         BAL,SR4  IOCHEK1           YES, WAIT FOR IO TO FINISH
         LI,R4    BADEVTP
         LB,R3    *R6,R4            R3=DEVICE TYPE
         AND,R3   M6                ZAP DIRTY BITS
         LI,R4    0
         LW,R5    0,R7              GET PLIST
         CI,R5    X'200'            SAME OPTION
         BANZ     SAME              YES
         CI,R5    X'400'            RETURN OPTION
         BANZ     RET%DEV           YES
         LI,R1    0                 NO, PART OPTION IMPLIED
         LB,R4    DCT24,R2          IS DEVICE PERMITTED TO
         CI,R4    1                 BE PARTITIONED
         BAZ      TYPCHKX     YES.. GO AHEAD
         LI,SR3   X'49'             NO, ABN 49
         B        CLSABRT
RET%DEV  RES      0
         LI,R1    1                 RETURN FLAG
         LC       DCT3,R2           MAY DEVICE BE RETURNED
         BCS,2    TYPCHKY     YES-- IT'S PARTITIONED, BUT CHECK CONT.
CANTRET  EQU      %           NO--- NOT PARTITIONED OR CONT.IS PART.
         LI,SR3   9                 NO, NOT PARTITIONED
         B        CLSABRT           ABN 09 SUBCODE 00
TYPCHKX  EQU      %
         LI,R4    0
         LC       DCT3,R2
         BCS,2    SAME2       YES-- ALREADY PARTITIONED
*                             NO---
TYPCHK   RES      0
         BAL,R5   SET%STATUS        SET DCT3 APPROPRIATELY
         LC       TB:FLGS,R3        GET DEVICE FLAGS
         BCR,8    NOTAPE            NOT A TAPE
         LB,R5    DCT4,R2
         LI,R3    SV:RSIZ+1
2:NX:RTY EQU      %
         CB,R5    SB:RTY,R3
         BE       COUNT:IT          YES, FOUND RESOURCE TYPE, FIX #
         BDR,R3   2:NX:RTY          NO, NO FIND YET
         B        SAME1             DON'T FIX COUNTS AS NO NEED TO
COUNT:IT EQU      %
         LW,R13   DIAG,R6
         CI,R13   X'20'
         BANZ     SAME1       YES-- DCB OPENED BY OPNTPSEG
*                             NO--- THEN DO RESOURCE COUNTING
         EXU      RTOT,R1           ADJUST RESOURCE TOTALS
         B        SAME1
NOTAPE   EQU      %
         LB,R4    SNDDX             MUST BE A SYMBIONT DEVICE
         CB,R2    SNDDX,R4          FIND SYMBIONT INDEX
         BE       RET%PART          R4=SYMBIONT INDEX
         BDR,R4   %-2
         B        BADDEV            ERROR, NOT SYMBIONT
TYPCHKY  EQU      %
         LW,R8    DCT9,R2
         LB,R8    R8
         CI,R8    DOWNCP+DOWNCA
         BAZ      TYPCHK      YES-- RET.DEV.OK., YES, CONT.NOT PART.
         LB,R5    DCT3,R2     NO--- CHECK FURTHER
         AND,R5   X3                CURRENT SC1/SC2 VALUE
         SLS,R8   -1
         AND,R8   X3                ORIGINAL SC1/SC2 VALUE B-4 PART.
         CI,R8    SC1+SC2
         BE       CANTRET     NO--- RET.OK., NO, CONT.IS PART.
         OR,R5    R8          YES-- CHECK FURTHER
         CI,R5    SC1+SC2
         BE       TYPCHK      YES-- RET.OK., YES, CONT.PATH PART.ONLY
         B        CANTRET     NO--- CANT RET., SINGLE ACCESS CONT.PART.
RET%PART RES      0
         AI,R1    0
         BGZ      RETSYM            RETURN SYMBIONT
         LI,R0    3                 PART SYM DEVICE
         B        SYMSTAT
RETSYM   EQU      %
         LI,R0    0
SYMSTAT  EQU      %
         STB,R0   SSTAT,R4          SET SYMBIONT STATUS
SAME1    RES      0
         LI,R13   PARTMSG           ASSUME PART SPECIFIED
         AI,R1    0                 PART OR RETURN
         BEZ      TEL%OP            PART SPECIFIED
         LI,R13   RETMSG            RETURN SPECIFIED
TEL%OP   EQU      %
         LW,R1    R2                DCTX IN R1
         BAL,R5   MSGOUT            TELL OPERATOR WHATS HAPPENING
         LI,R4    0
         B        SAME2
SAME     EQU      %                 DEVICE TO REMAIN IN SAME STATUS
         LI,R1    -1                SAME FLAG
         BAL,R5   SET%STATUS        SET DCT3 ACCORDINGLY
SAME2    EQU      %
         DISABLE
         LW,SR1   DCT9,R2
         AND,SR1  NB31TO0+30        -Y2
         STW,SR1  DCT9,R2           RESET DEV.IN DIAG.MODE
         LB,SR1   DCT3,R2
         AND,SR1  NB31TO0+3         =X'FB'
         STB,SR1  DCT3,R2           RESET NOERR FLAG
         ENABLE
         LW,R8    DIAG,R6
         CI,R8    X'20'
         BANZ     ENTRCLS     YES-- DCB OPENED BY OPNTPSEG
*                             NO---
         LW,SR1   Y004
         LW,SR2   MASKCLS
         STS,SR1  TTL,R6
CHKXIT   EQU      %
         CI,R4    0
         BNEZ     0,R4              SPECIAL ENTRY INTO SAME S.R.
         LI,SR1   0
         LI,SR3   0
         B        DIAGXIT
ENTRCLS  EQU      %                 CLOSE DDCB THRU OPNTPSEG
         PSW,R4   TSTACK            SAVE EXIT FLAG
         LW,R9    Y0008
         LI,R8    0
         STS,R8   EOP,R6            SET TO 0 FOR OPNTPSEG
         LW,R7    R6
         AI,R7    DIAG              POINT TO FPT(FLAG)=X'20'
         LI,R11   RETCLS            RETURN POINT FROM OPNTPSEG
         REMEMBER
         BAL,R1   PUSHALL           SAVE 5-11
         OVERTO   OPNTPSEG,CLSTP#
*----------------
*  OPNTPSEG RETURNS TO HERE
********
RETCLS   EQU      %
         LW,R9    Y2
         STS,R9   DIAG,R6           RESTORE DIAG FLAG IN DCB
         PLW,R4   TSTACK            RESTORE EXIT FLAG
         B        CHKXIT
*----------------
CLSABRT  EQU      %
         LI,R1    -1                KEEP DEVICE IN SAME STATUS
         LI,R5    DIAGERR           TRANSFER ADDRESS
SET%STATUS  EQU   %                 PART & NOERR BITS IN DCT3
*                                   ARE SET APPROPRIATELY
         DISABLE                    DISABLE INTERRUPTS
         LB,SR1   DCT3,R2           SET OR RESET PARTITIONED
         EXU      PARTBIT,R1        BIT ACCORDING TO PART,
         STB,SR1  DCT3,R2           RETURN, OR SAME OPTION
         LB,SR1   DCT24,R2
         EXU      DONTALOC,R1       SET/RESET DONT ALLOCATE FLAG ALSO
         STB,SR1  DCT24,R2
         ENABLE
         B        0,R5              RETURN
         AND,SR1  NB31TO0+3         KEEP SAME STATUS, =X'FB'
PARTBIT  OR,SR1   X20               SET PARTITIONED BIT, =X'20'
         AND,SR1  =X'DB'            RESET PARTITION BIT
         NOP      0                 LEAVE AS IS
DONTALOC OR,SR1   X80               PART & SET NO ALLOCATION, =X'80'
         AND,SR1  M7                RET & RESET NO ALLOCATION, =X'7F'
         PAGE
**********************************************
*D*
*D*      NAME:    T:BLIST
*D*      ENTRY:   CHKDCB
*D*      ENTRY:   BADCL
*D*      DESCRIPTION:  PROCESS THE M:BLIST AND M:SIO CALS.
*D*
*D*      INPUT:
*D*               R6 = DCB ADDRESS
*D*               R7 = ADDRESS OF FPT +1
*D*
*D*      INTERFACE:  PRVCHKA0,SETRTRN,DIAGERR,CHKBIT0,CHKBIT,
*D*               DIAGABN,VTP,GMB,CHKDCB,BADCL,RMB,DIAGXIT,
*D*               NEWQ,BADDEV,BADPAGE.
*D*      REGISTERS:  R0-R4,R12-R15 USED, R5-R11 SAVED
*D*
*D*         CHKDCB -
*D*      PROCESS COMMAND LIST 1 WORD (OUT OF A DOUBLE WORD)
*D*      AT A TIME & CHECK FOR INCONSISTANCIES & REQUIRED
*D*      INTERRUPT TYPE FLAGS.
*D*
*D*      CALL:    R0 = LINK
*D*
*D*      INPUT:
*D*               R1 = INDEX TO CURRENT COMMAND LIST WORD IN DCB
*D*                    & USERS AREA
*D*               R5 = CURRENT COMMAND LIST WORD
*D*               R10= MAXIMUM SIZE OF COMMAND LIST AREA IN DCB
*D*               R11= CURRENT COMMAND LIST I/O ORDER CODE
*D*
*D*      OUTPUT:
*D*               R1 = INDEX TO NEXT WORD IN COMMAND LIST AREA
*D*                    IN DCB & IN USERS AREA
*D*
*D*      INTERFACE:  BADCL,DIAGABN.
*D*      REGISTERS:  R1-R2,R4-R5 USED, R0,R10 SAVED
*D*
*D*         BADCL -
*D*      BAD COMMAND LIST ERROR ROUTINE.
*D*
*D*      OUTPUT:
*D*               R2 = ABNORMAL SUBCODE
*D*
*D*      INTERFACE:  DIAGABN.
*D*      REGISTERS:  R2 USED
*D*
***********************************************
T:BLIST  EQU      %
         BAL,R2   PRVCHKA0    ****  CHECK PRIVILEGE =>A0
         BAL,R2   SETRTRN     ****  SET UP RETURN
         LI,R2    -4
         LB,SR1   *R7,R2            GET FPT CODE
         LI,SR3   1                 ABNORMAL CODE
         LW,D2    Y002              IS DCB OPEN
         LS,D2    FCD,R6
         BEZ      DIAGERR           NO, ABNORMAL 01
         LW,D2    Y2                IS DCB A DIAG DCB
         LS,D2    DIAG,R6           IF NOT, THEN
         BEZ      DIAGERR           ABNORMAL 01
         LW,R13   M17
         AND,R13  QBUF,R6
         BNEZ     DIAGERR     YES-- DIAG DCB USED BY READ/WRITE
         LW,R13   Y001        NO---
         STS,R13  WAT,R6            RESTORE WAIT FLAG IN DCB
         LW,R2    0,R7              GET WORD-1 OF FPT
         CI,R2    SIO:TYP
         BANZ     I:O:INST    YES-- TIO/TDV/HIO REQUEST
*                             NO---
         LI,D2    0
         STW,D2   BUF,R6            INITIALIZE MPOOL ADDR.IN DCB
         CI,SR1   8                 M:BLIST OR M:SIO CALL
         BAZ      SIO1              M:SIO CALL
         LI,D2    X'1FFFF'          MASK FOR J:NRS
         LW,D1    J:NRS             GET USER SWAP COUNT
         STS,D1   SWAPCT,R6         SAVE THE SWAP COUNT
         BAL,R2   CHKBIT0           CHECK PLIST
         STS,D1   KBUF,R6           USERS COMMAND LIST ADDRESS
         LI,R4    BAPRI             BYTE ADDRESS OF PRIO
         BAL,R2   CHKBIT            CHECK FOR PRIORITY OPTION
         B        %+2               GOT ONE
         LI,D1    X'FF'             DEFAULT
         STB,D1   *R6,R4            STORE PRIO IN DCB
         LI,R4    ERA**2
         BAL,R2   CHKBIT            CHECK FOR & GET TIMEOUT IF ONE
         B        %+2               TIMEOUT DEFINED
         LI,D1    1                 NO TIMEOUT FOUND, DEFAULT = 1
         CI,D1    1
         BGE      %+2         YES-- WAS VALUE =>1
         LI,D1    1           NO--- FORCE IT TO 1, WAS =0
         CI,D1    63
         BLE      %+2         YES-- TIMEOUT =<63
         LI,D1    63          NO--  FORCE MAX.=63
         STB,D1   *R6,R4            SAVE IN DCB'S NRA FIELD
         LI,R2    BADEVTP
         LB,R2    *R6,R2            GET DEV.TYPE INDEX FROM DCB
         AND,R2   M6
         CI,R2    SP:TYP
         BNE      NO:SP       NO--- SPINDLE TYPE DEVICE
         LI,D1    1           YES-- TIMEOUT FORCED TO 1
         STB,D1   *R6,R4              IN DCB'S NRA FIELD
NO:SP    EQU      %
         LI,R2    4                 ABN CODE
         LW,SR1   CLIST,R6          GET DCB CLIST ADR
         AND,SR1  M17               GET CLEAN ADDRESS
         BEZ      DIAGABN           ABN 09 SUBCODE 04
         LI,R1    3                 BYTE INDEX FOR CONTROL WORD
         LW,D3    FLP,R6            VLP POINTER FOR DCB
MWCL     RES      0
         LB,D4    *D3               CODE # OF VLP
         CI,D4    X'07'             IS IT A SN VLP
         BNE      NOTSN             NO, CHECK FOR CLIST
         LB,R4    *D3,R1            NO. WORDS RESERVED FOR SN
         AI,R4    1
         AW,D3    R4
         B        MWCL              GET MAX WORDS IN DCB CLIST VLP
NOTSN    EQU      %                 NOT SN VLP
         CI,D4    X'12'             IS IT CLIST VLP
         BNE      DIAGABN           NO, ERROR
         LB,SR3   *D3,R1            MAX WORDS IN VLP IN DCB
         CI,D3    1
         BANZ     %+2               DON'T ALLOW FOR EXTRA WORD
         AI,SR3   1                 ALLOW FOR EXTRA WORD IN DCB VLP
*                             ABOVE CHECKS THAT WORD IS NOT LOST
         LI,SR2   0
         LI,R1    ARS*4             BYTE POSITION IN DCB
         STB,SR2  *R6,R1            SET DCB TO NO HAVE CHAN.PROG.
         AND,SR1  MINUS2
         LI,SR2   X'1FFFF'
         AND,D3   SR2
         SW,D3    SR1
         BGEZ     DIAGABN
         AI,D3    1                 # WORDS IN CLIST AREA OF VLP
         AW,SR3   D3
         AND,SR2  KBUF,R6           USER CLIST ADR
         BEZ      BADCL             ABN 09 SUBCODE 07
         LW,R4    SR1               ADR OF IOCDS IN DCB
         BAL,R0   VTP               VIRTUAL TO PHYSICAL
         SLS,R5   -1                CONVERT TO DOUBLEWORD ADR
         STW,R5   TAB1,R6           SAVE IN DCB
         LW,R4    SR2
         BAL,R0   VTP         ****  CHECK USERS CMND.LIST ADDR.
         PAGE
*        R0 IS USED AS BAL REG FOR SUBROUTINES VTP AND CHKDCB
*        R1 IS THE INDEX INTO THE COMMAND LIST IN THE DCB
*        R2 IS MAINLY USED FOR THE ABNORMAL SUBCODE
*        R4 IS THE INPUT REG FOR VTP WHICH CONTAINS A
*           VIRTUAL WORD ADDRESS
*        R5 IS THE OUTPUT REG FROM VTP WHICH CONTAINS THE
*           CORRESPONDING PHYSICAL ADDRESS
*        R6 CONTAINS THE DCB ADDRESS
*        R7 CONTAINS THE ADDRESS OF FPT+1
*        SR1 CONTAINS THE ADDRESS OF THE COMMAND LIST IN THE DCB
*        SR2 CONTAINS THE ADDRESS OF THE USERS VIRTUAL COMMAND LIST
*        SR3 CONTAINS THE MAX SIZE IN WORDS THAT HAS BEEN RESERVED
*            IN THE DCB FOR THE COMMAND LIST
*        D1 CONTAINS EACH WORD OF THE COMMAND LIST FOR PROCESSING
*           IT IS ALSO USED AS THE INPUT REG FOR CHKDCB
*        D2 CONTAINS A MASK OF YFF TO DETECT TRANSFER IN CHANNEL(TIC)
*        R3,D3,D4 ARE USED FOR MISCELLANEOUS REASONS
         SPACE    4
         LI,R5    10                # TRIES TO GET MPOOL
         BAL,SR4  GMB         ****  GET MPOOL
         BNEZ     GOT:BUF     YES-- GET AN MPOOL
         BDR,R5   GMB         NO--- DONE TRYING
NO:BUF   EQU      %           YES--
         LI,R2    X'0F'
         B        DIAGABN           ABN 09 SUBCODE 0F
GOT:BUF  EQU      %
         STW,D3   BUF,R6            MPOOL ADDR.INTO DCB
         LI,R1    GMBSIZ
         CI,R1    13
         BL       NO:BUF      NO--- ENOUGH ROOM FOR MAX.SIZE IOCD PROG
*                             YES--
         LI,R1    0                 INDEX
         STW,R1   *D3               INITIALIZE # ENTRIES =0
         LW,D2    YFF               MASK FOR TIC
CLCHK    EQU      %
         LW,D3    BUF,R6            GET MPOOL ADDR.
         MTW,1    *D3               # ENTRIES IN TABLE +1
         LW,R2    *D3               INDEX INTO TABLE
         LW,R0    SR2
         AW,R0    R1                ADDR.OF CURRENT IOCD
         STW,R0   *D3,R2            PUT IOCD ADDR.INTO TABLE
         LW,D1    *SR2,R1           USER COMMAND LIST
         CS,D1    Y08               NO, IS IT A TIC
         BE       TICCOM            YES, PROCESS IT
         DO       SP:IOCD=1
*
*  TIC TO PREV.IOCD, GET 1 MORE IOCD
*
         LI,D4    0                 EXIT FLAG USED LATER
LASTCL   EQU      %
*
*  END
*
         FIN
         LW,R2    D1                NO, GET BYTE ADDRESS
         LI,R3    0                 INITIALIZE R3
         STS,D1   R3
         SLD,R2   -2                CONVERT TO WORD ADDRESS
         LW,R4    R2                INPUT REG FOR VTP
         BAL,R0   VTP               VIRTUAL TO PHYSICAL
         AW,R5    R3                ADD REMAINDER
         SCS,R5   2                 REMAINDER
         LB,SR4   R5                GET IOCD ORDER CODE
         BAL,R0   CHKDCB            STORE RESULT IN DCB
         LW,R5    *SR2,R1           2ND WORD OF IOCD
         DO       SP:IOCD=1
*
*  DON'T CHECK FOR IOCD FLAGS
*
         CI,D4    0
         BNEZ     *D4         YES-- EXIT FLAG SET
         LC       R5          NO--- GET IOCD FLAGS
         BCS,8    DCHAIN            DATA CHAINED
         BCS,2    CCHAIN            COMMAND CHAINED
CLEND:1  EQU      %                 END OF COMMAND LIST
*
*  END BYPASS CHECK FOR IOCD FLAGS
*
         ELSE
         CW,R5    Y04               IS IUE BIT SET
         BAZ      BADCL             NOPE, ERROR
         LC       R5                DATA OR COMMAND CHAINING
         BCS,4    BADCL             IZC BIT SET-ERROR
         BCS,8    DCHAIN            YES, DATA CHAIN
         BCS,2    CCHAIN            YES, COMMAND CHAIN
         BCR,1    BADCL             ICE BIT SHOULD BE SET
         FIN
         BAL,R0   CHKDCB            NO, LAST ONE-STORE IT
CLEND    EQU      %                 FINISHED PROCESSING IOCDS
         LI,R2    6                 ABN SUBCODE
         CI,R1    25                IOCDS EXCEED LIMIT
         BGE      DIAGABN           YES
         LI,R5    ARS*4             BYTE POSITION IN DCB
         STB,R1   *R6,R5            # WORDS IN DCB'S CHAN.PROG.
         LW,D3    BUF,R6            GET MPOOL ADDR.
         BAL,SR4  RMB         ****  RELEASE MPOOL
         LI,SR3   0                 ZAP ERROR CODE
         STW,SR3  BUF,R6            SET TO 0, NO MORE RELEASES
         LW,R5    0,R7              GET FPT+1
         CI,R5    X'800'            SIO OPTION PRESENT
         BAZ      DIAGXIT           NO, RETURN
STARTIO  RES      0                 LET NEWQ DO HIS THING
         LI,R2    4                 SUBCODE
         LI,R4    ARS*4             BYTE POSITION IN DCB
         MTB,0    *R6,R4
         BEZ      DIAGABN           NO CHAN.PROG.IN DCB
         LI,R2    5                 SUBCODE
         LI,D2    X'1FFFF'          MASK FOR J:NRS
         LS,D1    J:NRS             GET CURRENT SWAP COUNT
         CS,D1    SWAPCT,R6         HAS DIAG USER BEEN SWAPPED
         BNE      DIAGABN           ABN 09 SUBCODE 05
         LI,R4    X'1FFFF'          MASK
         AND,R4   STA,R6            STATUS ADDRESS
         BAL,R0   VTP               VIRTUAL TO PHYSICAL
         LW,R1    R5                EAI FOR NEWQ
         AND,R5   M9
         CI,R5    512-13            IS IT LEGAL
         BG       BADPAGE           NO
         LI,R3    BADSI                  SET REGS FOR NEWQ
         LB,D1    *R6,R3            GET DCTX
         LI,R3    BAPRI             USER PRIO IN DCB
         LB,R5    *R6,R3            GET PRIORITY
         STH,R5   D1                D1=FC,PRI,RET,DCTX
         LW,D2    TAB1,R6           PHYS DA OF COM LIST
         LI,R3    4                 INDEX TO EXTRACT
         LB,R3    *R6,R3            SOFTWARE CHANNEL FLAGS
         STB,R3   R13               INSERT THEM INTO NEWQ'S REGISTERS
         OR,R13   Y4                INSERT DA(CLIST) FLAG FOR NEWQ
         LI,R3    ERA**2
         LB,D3    *R6,R3            GET TIMEOUT FROM DCB
         LI,D4    0                 SEEK ADDRESS
         LI,R0    0                 NO END ACTION
         BAL,SR4  NEWQ              START I/O
         B        BADDEV            ERROR EXIT, DEV DOWN &
*                                   SYS ID DO NOT MATCH
         B        DIAGXIT
CHKDCB   EQU      %
         CW,R1    SR3               ENOUGH ROOM IN DCB
         BGE      BADCL             NO, ABNORMAL
         STW,R5   *SR1,R1           IOCD WORD INTO DCB
         AI,R1    -1
         CI,R1    1
         BANZ     SAV:ORDR          1ST WRD.IOCD,SAVE ORDER CODE
         INT,R5   R5                IS THIS I/O LEGAL
         LI,R4    X'7FF'
         AND,R4   *SR1,R1
         LI,R2    ARS*4             BYTE POSITION IN DCB
         LB,R2    *R6,R2            GET ORDER CODE
         CI,R2    X'0C'             READ REVERSE CODE
         BNE      FORE        NO--- READ REVERSE OP-CODE
         AI,R5    -1          YES-- SIZE -1
         SW,R4    R5                END BUF.ADDR. - SIZE
         B        BACK
FORE     EQU      %
         AI,R5    -1
         BLZ      XPAGE
         AW,R4    R5
BACK     EQU      %
         CI,R4    X'FF800'          OVERLAPPING PAGES
         BANZ     XPAGE             YES
BUMPIT   RES      0
         AI,R1    2                 INCREMENT INDEX
         B        *R0               RETURN
SAV:ORDR EQU      %
         CI,SR4   0
         BEZ      BUMPIT      NO--- NEW ORDER CODE (NOT IN DATA CHAIN)
         LI,R2    ARS*4       YES-- BYTE POSITION IN DCB
         STB,SR4  *R6,R2            SAVE ORDER CODE IN DCB
         B        BUMPIT
         DO       SP:IOCD=1
*
*  DON'T CHECK FOR IOCD FLAGS
*
DCHAIN   EQU      %
CCHAIN   EQU      %
*
*  END BYPASS CHECK FOR IOCD FLAGS
*
         ELSE
DCHAIN   EQU      %                 DATA CHAINING
         LI,R2    1                 POINTER TO NEXT IOCD
         AW,R2    R1
         LW,D3    *SR2,R2           GET ORDER OF NEXT IOCD
         LW,D4    D2                MASK OF YFF-CHECK FOR TIC
         CS,D3    Y08               IS IT A TIC
         BNE      NOTIC             NO, LOOK AT 2ND WORD OF IOCD
         LI,R2    1
         SLS,D3   1                 YES, CONVERT TO WORD ADDRESS
         B        HTE               CHECK HTE BIT
NOTIC    EQU      %
         LW,D3    SR2               DONT DESTROY SR2
         LW,R2    R1                POINT TO 2ND WORD
         AI,R2    2                   IN NEXT IOCD
HTE      EQU      %                 HTE BIT MUST BE THE SAME IN
*                                   ALL IOCDS FOR DATA CHAINING
         EOR,R5   *D3,R2            IS HTE BIT THE SAME
         CW,R5    Y08               FOR BOTH IOCDS
         BANZ     BADCL             NO, ABNORMAL
         LW,R5    *SR2,R1           YES, RESTORE CURRENT IOCD
         LC       R5                CHECK ICE BIT
CCHAIN   EQU      %                 COMMAND CHAINING
         BCS,1    BADCL             ICE BIT SET-ERROR
         FIN
         BAL,R0   CHKDCB            PUT IN DCB
         B        CLCHK             GET NEXT IOCD
TICCOM   EQU      %
         INT,R5   D1
         SLS,R5   1                 CONVERT TO WORD ADDRESS
         LW,R0    BUF,R6            GET MPOOL(TABLE) ADDR.
         LW,R4    *R0               # ENTRIES IN TABLE
NXTADDR  EQU      %
         CW,R5    *R0,R4
         DO       SP:IOCD=1
*
*  TIC TO PREV.IOCD IS OK
*
         BE       TIC:OK
*
*  END TIC TO PREV.IOCD OK
*
         ELSE
         BE       BADCL       YES-- FIND THIS TIC ADDR.IN IOCDS
         FIN
         BDR,R4   NXTADDR     NO--- DONE SEARCH
*                             YES--
         SW,R5    SR2
         SW,R5    R1                CALCULATE
         AI,R5    -2                  NEW USERS CMND.LIST
         AW,SR2   R5                  ADDR.AFTER CURRENT TIC
         LW,R4    SR1
         AW,R4    R1                MAKE TIC IN DCB
         AI,R4    2                   POINT TO IOCD
         DO       SP:IOCD=1
*
*  TIC TO PREV.IOCD IS OK
*
         LI,D3    0                 EXIT FLAG USED LATER
PROCTIC  EQU      %
*
*  END TIC TO PREV.IOCD OK
*
         FIN
         LI,SR4   0                   AFTER TIC, ORDER CODE =0
         BAL,R0   VTP               VIRTUAL TO PHYSICAL
         SLS,R5   -1                CONVERT TO DOUBLEWORD ADDRESS
         AW,R5    Y08               ADD TIC ORDER TO ADR
         BAL,R0   CHKDCB            RESULT IN DCB
         LI,R5    1                 2ND WORD OF TIC
         BAL,R0   CHKDCB            STORE IT
         DO       SP:IOCD=1
*
*  TIC TO PREV.IOCD OK
*
         CI,D3    0
         BNEZ     *D3         YES-- RETURN TO CALLER
*                             NO---
*  END TIC TO PREV.IOCD OK
*
         FIN
         B        CLCHK             GET NEXT IOCD
         DO       SP:IOCD=1
*
*  TIC TO PREV.IOCD OK
*
TIC:OK   EQU      %
         LW,R11   *R0               # ENTRIES IN IOCD ADDR.TABLE
         SW,R11   R4                REL.POSIT.IN IOCDS WHERE TIC GOES
         SLS,R11  1                 # WORDS (WAS DOUBLE WORDS)
         LW,R4    SR1               ADDR.IN IOCD OF TIC
         SW,R4    R11               ADDR.IN IOCD WHERE TIC GOES
         AW,R4    R1
         LI,D3    TICRETRN          EXIT FLAG USED AS RETURN
         B        PROCTIC           PROCESS & BUILD TIC IN DCB
TICRETRN EQU      %                 RETURN POINT
         CW,R1    SR3
         BGE      BADCL       NO--- ANY ROOM LEFT IN DCB FOR IOCDS
         LI,R2    0           YES--
         STW,R2   *SR1,R1           NEXT IOCD = 0 (END OF IOCDS)
         LI,R2    BADEVTP
         LB,R2    *R6,R2            GET DEV.TYPE INDEX FROM DCB
         AND,R2   M6
         CI,R2    CP:TYP
         BNE      CLEND       NO--- CP TYPE DEV.
         LI,R2    BADSI       YES--
         LB,R2    *R6,R2            GET DCT INDEX
         LH,R2    DEVMOD#,R2        GET DEV.MOD#
         CI,R2    CP7160
         BNE      CLEND       NO--- CP7160 TYPE DEV.
         LW,D1    *SR2,R1     YES-- GET 1 MORE IOCD AFTER TIC
         LI,D4    CLEND:1           EXIT FLAG
         B        LASTCL            PROCESS LAST IOCD
*
*  END TIC TO PREV.IOCD OK
*
         FIN
BADCL    EQU      %
         LI,R2    7                 ABN 09 SUBCODE 07
         B        DIAGABN
XPAGE    EQU      %
         LI,R2    9                 ERR 09, SUBCODE 09
         B        DIAGABN
SIO1     EQU      %                 START I/O REQUEST
         LI,R2    4                 ABN SUBCODE
         LI,R4    X'1FFFF'
         AND,R4   CLIST,R6          VIRTUAL ADR OF COM LIST
         BEZ      DIAGABN           ABN 09 SUBCODE 04
         BAL,R0   VTP               VIRTUAL TO PHYSICAL CONVERSION
         SLS,R5   -1                CONVERT TO DOUBLEWORD ADRESS
         STW,R5   TAB1,R6
         B        STARTIO
         PAGE
I:O:INST EQU      %
         LI,R11   -1                WORD-0 OF STATUS
         LI,R14   0                 WORD-3 OF STATUS (INITIALLY)
         LI,R3    BADSI
         LB,R3    *R6,R3            GET DCT INDEX FROM DCB
         LH,R15   DCT1P,R3          GET DEV.ADDR.
         CI,R2    TIO:TYP
         BANZ     DO:TIO      YES-- TIO REQUESTED
         CI,R2    TDV:TYP     NO---
         BANZ     DO:TDV      YES-- TDV REQUESTED
         CI,R2    HIO:TYP     NO---
         BANZ     DO:HIO      YES-- HIO REQUESTED
         LI,R2    X'10'       NO---
         B        DIAGABN           ABN 09 SUBCODE X'10' (16)
DO:TIO   EQU      %
         LCI      0
         TIO,R12  *R15
I:O:CMN  EQU      %
         STCF     R14               SAVE CONDITION CODES
         OR,R14   R15               SAVE DEV.ADDR.
         LW,R15   STA,R6            GET STATUS BUFFER ADDR.FROM DCB
         LCI      4
         STM,R11  *R15              PUT STATUS IN USER'S AREA
         B        DIAGXIT           EXIT
DO:TDV   EQU      %
         LCI      0
         TDV,R12  *R15
         B        I:O:CMN
DO:HIO   EQU      %
         LCI      0
         HIO,R12  *R15
         B        I:O:CMN
*****************
         END

