         DEF      FISH
FISH     EQU      %  FUNCTIONAL INTEGRITY OF SYSTEM HARDWARE
*    CREATED 6/22/72  KDR
MONPROC  SET      1
  TITLE  '* * CP-V / ERR:FIL INTERFACE * *'
         REF      BUF1,BUF2         ERROR LOG BUFFER ADDRESSES
EBUF1    EQU      BUF1
EBUF2    EQU      BUF2
         CLOSE    BUF1,BUF2
         SYSTEM   UTS
         DEF      T:RDERLOG
         REF      SYSACCT,CURGRAN
         REF      RBG,TRAPEXIT,CJOB,SGRAN
         REF      ERRLOG40
         REF      QUEUE,M17,CURBUF,BATYC
         REF      M24
         REF      Y01
         REF      CC0RST
         REF      CHKDA
         REF      CKLIMIT
         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
         RES      40
DRSZ     EQU      %-DRIVE
         PAGE
*                 READ ERROR LOG PROCEDURE:
*                   REG 6 CONTAINS BUF. ADDR.
*                   RETURN NEXT BLOCK OF ERRLOG:
*                     CC1-4 = 0 IF OK.
*                     CC1 = 1 IF ACCT NOT :SYS
*                     CC2 = 1 IF READ ERROR
*                     CC3 = 1 IF LAST
*                     CC4 = 1 IF NO ERRORS YET
*                 EXIT TO TRAPEXIT AFTER CC SET IN STACK (PSD = DW AT
*                   (TSTACK)-17 )
*                 RELEASE GRANULES WHEN SECOND HALF GIVEN TO USER
*
*
         PAGE
*
*        INSURE USER IS IN :SYS AND OWNS PAGE FOR READ ERROR LOG
*        CAL - READ IF OK - REJECT IF NOT.
*
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      %
         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      DISABLE
         LW,1     SGRAN
         BEZ      T:30              CORE BUFFER IS ONLY BUFFER
         CW,1     CURGRAN
         BE       T:30              CURGRAN HASN'T BEEN WRITTEN
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
         LI,4     BAFCN
         MTB,0    *8,4
         BNEZ     %-1
         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      %
         LW,8     0,6               GET BUFFER'S BLINK
         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
         LW,8     1,6               GET BUFFER'S FLINK
         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     MTW,0    *M24,1            IS BUFFER QUEUED TO WRITE OUT
         BLZ      T:32              BUFFER HAS BEEN WRITTEN
         LW,2     2,1               NO  - IS USED WORD COUNT = 0
         BNEZ     T:33              NO - PASS THIS ONE TO USER
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     LCI      0                 CC'S TO PASS TO USER
T:35     BAL,0    T:SCC
         AI,9     1                 BUMP COUNT OF BUFFERS MOVED
         AI,2     3                 ADJUST INDEX
         LW,3     *1,2
         STW,3    *6,2
         AI,2     -1
         BGEZ     %-3
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 64*4,0
         PAGE
* THIS ROUTINE INTERFACES BETWEEN THE USER WHO WISHES TO
* WRITE THE ERRLOG FILE AND THE MONITOR ROUTINE
* ERRLOG
         DEF      T:WTERLOG
         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'
*****************
*  M:DMOD#, M:DPART, & M:DRET CAL PROCESSORS.
*
*    ENTER :
*             R6  = DEVICE ADDRESS (VALUE OF WORD 0 IN FPT)
*             R7  = ADDRESS OF WORD 1 IN FPT
*
*****************
         SPACE    3
         DEF      T:MODPRTRT
         SPACE    2
         REF      PUSHALL,PULLALLEXIT
         REF      SNDDX,SYMX,SSIG,SSTAT
         REF      DCT3,DCT4,DCT24
         REF      OH:NM
         REF      BATAPE,AVRTBLNE
         REF      SV:RSIZ,SB:RTY,SH:RTOT
         REF      S:OSPIN,S:GSPIN,S:BSPIN
         REF      S:MBSF
         REF      TIME
         REF      CALBAD
         REF      DEVMOD#,CNTMOD#
         REF      DCTSIZ,DCT1A,DCT1P
         REF      XFFFF,YF,YC,Y8,Y4,24BM2
         REF      RBLIMS
         SREF     RB:FLAG
         SREF     ACTBIT,LIPBIT,OFFBIT
********
         PAGE
********
NOALLOC  EQU      X'80'             NO ALLOCATE FLAG WHEN PART.
OLDWND   EQU      X'40'             OLD DIAG.DOWN FLAG
DOWND    EQU      X'20'
DOWNC    EQU      X'04'
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
********
         PAGE
********
T:MODPRTRT EQU    %           <---  ENTER
         SPACE    2
         REF      J:BASE
         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
********
*  PROCESS M:DMOD# CAL
********
         SPACE    3
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
NXTDCT   EQU      %
         CH,R6    DCT1P,R1
         BE       DCTFND      YES-- FIND DEV.ADDR.
         LI,R8    DCT1A       NO--- SEARCH ALTERNATE
         CI,R8    DCT1P
         BE       NOTEQ       NO--- DUAL ACCESS (NO ALTERNATE)
         CH,R6    DCT1A,R1    YES--
         BNE      NOTEQ       NO--- FIND DEV.ADDR.
DCTFND   EQU      %           YES-- GOOD DEV.ADDR.
         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,R1    DCT4,R1           DEV.TYPE MNEMONIC INDEX
         LH,R10   OH:NM,R1          GET TYPE MNEMONIC
         AND,R8   XFFFF
         AND,R9   XFFFF
         AND,R10  XFFFF
         LW,R1    TSTACK
         STW,R8   STKR8,R1          DEV.MOD.# INTO USER'S R8(SR1)
         STW,R9   STKR9,R1          CONT.MOD.# INTO USER'S R9(SR2)
         STW,R10  STKR10,R1         YY INTO USER'S R10(SR3)
         B        XIT               EXIT
*----------------
         PAGE
*****************
*  SUB-ENTRY FOR CHECKING FOR ANOTHER DEVICE ADDRESS
*        IDENTICAL TO ORIGINAL REQUESTED ONE.
*
*  R1  = DCT INDEX
*  R6  = DEVICE ADDRESS
*  R15 = LINK, ALSO >0 FLAG FOR PARTITION/RETURN ENTRY
         SPACE    2
NOTEQ    EQU      %           <---  ENTER
         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
********
*  PROCESS M:DPART CAL
********
         SPACE    3
MDPART   EQU      %           <---  ENTER
         BAL,R15  FINDADDR    ****  VALIDATE DEVICE ADDRESS
*
*  R1 = DCT INDEX
*  R2(BIT0) = 0,  ADDRESS VALID
*           = 1,  ADDRESS INVALID
*
         CW,R2    Y8
         BAZ      PARTDEV     YES-- ADDRESS O.K.
         LW,R2    Y4          NO--- CC2 = 1
         B        XIT               EXIT
*----------------
PARTDEV  EQU      %                 PARTITION DEVICE
         DISABLE                    DISABLE INTERRUPTS
         LI,R14   NOALLOC           CONT.DOWN FLAG =0, DONT ALLOC.=1
         LB,R5    *R7               GET FPT SUB-CODE
         CI,R5    CNTFLG
         BAZ      %+2         YES-- DEVICE REQUEST
         OR,R14   L(DOWNC)    NO--- CONTROLLER, CONT.DOWN FLAG
         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
*----------------
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--
         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    R14                 CONTROLLER
         STB,R4   DCT24,R1              DOWN
         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
         LI,R5    1                 SET FLAG TO PARTITIONING
         ENABLE                     ENABLE INTERRUPTS
         CI,R14   DOWNC
         BANZ     PARTCNT     YES-- CONTROLLER REQUEST
*                             NO--- DEVICE
         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
         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
         LCI      4
         PLM,R4   TSTACK            RESTORE VULNERABLE REGISTERS
         AND,R6   XFFFF             SAVE DEV.ADDR.
         LW,R1    R4                RESTORE DCT INDEX
         CI,R5    0
         BEZ      MORETRN     YES-- RETURN TYPE REQUEST
*                             NO--- PARTITION TYPE REQUEST
         BAL,R15  NOTEQ       ****  SEARCH FOR ANOTHER ADDR.THE SAME
         CW,R2    Y8
         BAZ      PARTDEV     YES-- MORE DEV.ADDRESSES
NORMXIT  EQU      %           NO---
         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
********
*  PROCESS M:DRET CAL
********
         SPACE    3
MDRET    EQU      %           <---  ENTER
         BAL,R15  FINDADDR    ****  VALIDATE DEVICE ADDRESS
*
*  R1 = DCT INDEX
*  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
         B        XIT               EXIT
*----------------
RETDEV   EQU      %                 RETURN DEVICE
         DISABLE                    DISABLE INTERRUPTS
         LI,R14   NOALLOC+OLDWND    CONT.DOWN FLAG =0. DONT ALLOC.=1
*                                     OLD DIAG.DOWN FLAG =0
         LB,R4    *R7               GET FPT SUB-CODE
         CI,R4    CNTFLG
         BAZ      %+2         YES-- DEVICE REQUEST
         OR,R14   L(DOWNC)    NO--- CONTROLLER, CONT.DOWN FLAG
         CI,R1    BATAPE
         BL       NOTTPE            CANT CHECK IF BUSY IF NOT SPINDLE
         CI,R1    BATAPE+AVRTBLNE
         BGE      NOTTPE            CANT CHECK IF BUSY IF NOT SPINDLE
*
*  RETURN TAPE OR PACK
*  THE FOLLOWING CODE IS SIMILAR TO MODULE MUL ROUTINE OPENDEV
*        FOR CHECKING IF DEVICE IS ALLOCATED
*        ALSO SIMILAR TO MODULE IORT  ROUTINES DHHIT & SPINS.
*
         LW,R4    R1                DCT INDEX
         SCS,R4   -5                MODULO 32
         LB,R2    R4                GET DCT INDEX REMAINDER
         SLS,R2   -3
         AI,R2    BT31TO0+1
         LW,R2    *R2               GET BIT MASK FROM TABLE
*
*  R2 = BIT MASK, BIT 31 TO 0
*  R4 = REL.WORD IN BIT TABLES S:OSPIN, S:GSPIN, & S:BSPIN
*
         CW,R2    S:OSPIN,R4
         BANZ     DVBSY       YES-- BUSY - ONLINE
         CW,R2    S:GSPIN,R4  NO---
         BANZ     DVBSY       YES-- BUSY - GHOST
         CW,R2    S:BSPIN,R4  NO---
         BANZ     DVBSY       YES-- BUSY - BATCH
NOTTPE   EQU      %           NO---
         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
*----------------
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
         STS,R4   R10                 DEVICE
         STB,R10  DCT3,R1               DOWN FLAG
         LW,R5    R14
         LB,R10   DCT24,R1          SET
         STS,R4   R10                 CONTROLLER & OLD DIAG.FLAGS
         STB,R10  DCT24,R1              UP
         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      %
         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
         LI,R5    0                 SET FLAG TO RETURN
         ENABLE                     ENABLE INTERRUPTS
         CI,R5    DOWNC
         BANZ     RETCNT      YES-- CONTROLLER REQUEST
*                             NO---
         LI,R13   DEVMOD#           DEV.MOD.# TABLE
ERLGCNT  EQU      %
         LW,R14   L(X'52030000')    ERR.LOG CODE(RET), # WRDS/ENTRY
         B        ERRLGCMN
*----------------
MORETRN  EQU      %
         BAL,R15  NOTEQ       ****  SEARCH FOR ANOTHER ADDR.THE SAME
         CW,R2    Y8
         BAZ      RETDEV      YES-- MORE DEV.ADDRESSES
         B        NORMXIT     NO---
*----------------
DVBSY    EQU      %
         CI,R14   DOWNC
         BAZ      NOTCNT      NO--- CONTROLLER REQUEST
         LI,R5    DOWNC       YES-- SET CONT. ONLY MASK
         LI,R4    0
         LB,R10   DCT24,R1
         STS,R4   R10               RESET CONTROLLER DOWN FLAG
         STB,R10  DCT24,R1
NOTCNT   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'
         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
         SPACE    4
R0       EQU      0
R1       EQU      1
R2       EQU      2
R3       EQU      3
R4       EQU      4
R5       EQU      5
R6       EQU      6
R7       EQU      7
SR1,R8   EQU      8
SR2,R9   EQU      9
SR3,R10  EQU      10
SR4,R11  EQU      11
D1,R12   EQU      12
D2,R13   EQU      13
D3,R14   EQU      14
D4,R15   EQU      15
DOWN     EQU      X'20'             DOWN BIT IN DCT3
NOERR    EQU      4                 NOERR BIT IN DCT3
         PAGE
***************************************
*
* REFS FOR DIAGNOSTIC CALS
*
***************************************
         REF      ERO,MSGOUT,OV:NMSZ
         REF      NEWQ
         REF      OB:BTX,OB:GTX,OB:OTX
         REF      TYPMNSZ,OV:SIZ,AVRTBL
         REF      TB:FLGS,J:NRS,JBUPVP
         REF      Y004,XFF,M6
         REF      S:CUN,UH:FLG2,JB:PPC
         REF      S:LCORE,S:PCORE,SL:STLM
         REF      JX:CMAP,OPNSEG,J:CLS
         REF      DID,J:JIT,T:ABORTM
         REF      CHKBIT0,CHKBIT,IOCHEK1
         REF      Y002,Y2
         REF      YFF,Y08,MINUS2,M9,HIGH,FPMC
         REF      SCNTXT,Y04
         REF      MSR01EXIT,JB:PRIV
         REF      IOSPRTN,MSREXIT
         REF      DCT9,M16,M7
         REF      GMB,RMB,GMBSIZ
***************************************
*
* DEFS FOR DIAGNOSTIC CALS
*
***************************************
         DEF      T:DOPEN,T:MAP
         DEF      T:LOCK,T:DCLOSE,T:BLIST
         PAGE
SETRTRN  EQU      %
         LI,R11   IOSPRTN           RETURN THRU CALPROC I/O SPIN
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  LW,D3    =X'0A000009'      NO,ERRROR 09 SUBCODE 0A
         B        T:ABORTM          ABORT HIM
*************************************************
*
*  ABNORMAL, ERROR, AND NORMAL RETURNS FOR DIAGNOSTIC CALS
*
*************************************************
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
         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
         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
*************************************************
*
*
*   PROCESS THE M:LOCK CAL
*
*
*************************************************
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'090B'           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
**************************************************
*
*
*   PROCESS THE M:MAP CAL
*
*
**************************************************
T:MAP    EQU      %
         BAL,R2   PRVCHKA0    ****  CHECK PRIVILEGE =>A0
         BAL,R2   SETSTK      ****  SET UP TSTACK
         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'090E'           ABN 09 SUBCODE 0E
         B        DIAGXIT0
         LI,R2    8                 ABN 09 SUBCODE 08
         B        DIAGABN
         PAGE
**********************************************
*
*   PROCESS THE M:DOPEN CAL
*
*       ENTER:
*             R6 = DCB ADDRESS
*             R7 = ADDRESS OF FPT + 1
*
***********************************************
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    0
         STW,R4   NVA,R6
         STW,R4   SND,R6
         STW,R4   QBUF,R6
         STW,R4   BUF,R6            INITIALIZE MPOOL ADDR.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
         LB,R2    *R7,R2            # WORDS FROM VLP OF FPT
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,R3    DCTSIZ            YUP
         AND,D1   M16               KEEP ONLY DEV.ADDR.
DOP1     EQU      %
         CH,D1    DCT1P,R3          FIND DEV.ADDR.
         BE       DOP2              YUP, GOTCH'YA
         CH,D1    DCT1A,R3          CHECK ALTERNATE DEV.ADDR.
         BE       DOP2
         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,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
         LI,R0    0                 ASSUME NONTAPE DEVICE
         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
         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
         LI,R0    1                 GOT A TAPE
         BAL,D4   GETDCTX           GET A DCTX
* STORE TYPE & DCTX
SETDSI   RES      0
         LI,R1    BADSI
         STB,R2   *R6,R1            DCTX TO DSI
DOP3     EQU      %
         LB,D1    DCT3,R2
         SLS,D1   -6
         LI,D2    X'F'
         SLD,D1   17
         STS,D1   FUN,R6            SET FUNCTION IN DCB
         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
         LI,R4    4                 CONTROLLER PART BIT
         CB,R4    DCT24,R2          IS CONTROLLER PARTITIONED
         BANZ     CHKPATH           YUP, THATS GOOD
         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
         LW,R13   Y002
         STS,R13  0,R6              SET DCB TO OPEN
         AI,R0    0                 IS IT A TAPE
         BEZ      NOTT              NO
         OVERTO   OPNTPSEG,OPNT#
         REF      OPNTPSEG,OPNT#
NOTT     OVERTO   OPNSEG,2
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      %
         LB,R2    DCT4,R3           TYPE CODE
         B        OPT6
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        BADDEV
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
         LI,R2    3                 NOPE, ERROR HIM
         B        DIAGABN           ABN 09 SUBCODE 03
PACK     RES      0
         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      BADDEV            NO, ERROR
         B        SETDSI
GETDCTX  RES      0
         AI,R1    0                 IS DCT ALREADY OBTAINED
         BNEZ     *D4               YES
         LI,R2    DCTSIZ            # OF DCTS
         CB,R3    DCT4,R2           GET DCTX BY MATCHING TYPE
         BE       *D4               R2=DCTX
         BDR,R2   %-2               TRY AGAIN
         B        BADDEV            CANT FIND, ERROR
         PAGE
***********************************************
*
*   PROCESS THE M:DCLOSE CAL
*
*       ENTER:
*             R6 = DCB ADDRESS
*             R7 = ADDRESS OF FPT + 1
*
***********************************************
T:DCLOSE EQU      %
         BAL,R2   PRVCHKA0    ****  CHECK PRIVILEGE =>A0
         BAL,R2   SETRTRN     ****  SET UP RETURN
         LW,D2    J:CLS             CLOSE INFO
         BGZ      %+3               NO
         LI,R1    1
         STW,R1   J:CLS             CLOSE FLAG
         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
ZAPCLS   EQU      %
         LI,SR4   0
         STW,SR4  J:CLS
         B        CLSABRT           ABN A
CLS1     EQU      %
         LI,SR3   1
         LW,D2    Y2                MASK FOR DIAG DCB
         LS,D2    DIAG,R6           IS DCB A DIAG DCB
         BEZ      CLSABRT           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
         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      TYPCHK            YUP, 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    TYPCHK            YUP, IT'S PARTITIONED
         LI,SR3   9                 NO, NOT PARTITIONED
         B        CLSABRT           ABN 09 SUBCODE 00
TYPCHK   RES      0
         BAL,R5   SET%STATUS        SET DCT3 APPROPRIATELY
         LC       TB:FLGS,R3        GET DEVICE FLAGS
         BCR,8    NOTAPE            NOT A TAPE
         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
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
         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,SR1   Y004
         LW,SR2   MASKCLS
         STS,SR1  TTL,R6
         LI,SR3   0
         XW,SR3   J:CLS
         CI,SR3   9
         BGE      ZAPCLS
         B        DIAGXIT
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,R1
         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
**********************************************
*
*   PROCESS THE M:BLIST AND M:SIO CALS
*
*       ENTER:
*             R6 = DCB ADDRESS
*             R7 = ADDRESS OF FPT + 1
*             R8 = FPT CODE
*
***********************************************
T:BLIST  EQU      %
         BAL,R2   PRVCHKA0    ****  CHECK PRIVILEGE =>A0
         BAL,R2   SETRTRN     ****  SET UP RETURN
         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
         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,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
         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
         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
         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
         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
         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
         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
         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
         OR,D2    Y4                SET BIT FOR COM LIST
         LI,D3    1                 TIME-OUT INCREMENT
         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      BADPAGE
         AW,R4    R5
BACK     EQU      %
         CI,R4    X'FF800'          OVERLAPPING PAGES
         BANZ     BADPAGE           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
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
         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
         BE       BADCL       YES-- FIND THIS TIC ADDR.IN IOCDS
         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
         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
         B        CLCHK             GET NEXT IOCD
BADCL    EQU      %
         LI,R2    7                 ABN 09 SUBCODE 07
         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
FISHSZ       EQU  %-FISH
         END      FISH

