*M*  IORT          FILE MANAGEMENT SUBROUTINES
S69PROC  SET      1
MONPROC  SET      1
ANSPROC  SET      1
BITS     SET      1
UFLAGS   SET      1
         SYSTEM   UTS
         PCC      0
CNM      EQU      1                 SET=1 FOR TP SLAVE LINE CODE
CJASN    EQU      4                 ASN=4 FOR COMMON JOURNAL
IORT:    EQU      %
     SPACE         3
*P*  NAME:         IORT
*P*
*P*  PURPOSE:      CONTAINS ROUTINES FOR:
*P*                  M:READ/M:WRITE FPT MERGE
*P*                  TAPE I/O END-ACTION
*P*                  C DEVICE READ LOGIC
*P*                  DEVICE READ LOGIC
*P*                  VARIOUS SUBROUTINES USED BY FILE MANAGEMENT
         SPACE    2
K2       EQU      2
K7FFF    EQU      X'7FFF'
K7       EQU      X'7'
K0       EQU      X'0'
K1       EQU      X'1'
K5       EQU      X'5'
K8       EQU      X'8'
KC       EQU      X'C'
K22      EQU      X'22'
K30      EQU      X'30'
K4000    EQU      X'4000'
K42      EQU      X'42'
K5A      EQU     X'5A'
K78      EQU      X'78'
KC0      EQU      X'C0'
K482     EQU      X'482'
K1000    EQU      X'1000'
K2000    EQU      X'00002000'
K1FFFF   EQU      X'1FFFF'
         TITLE    '    *****  IORT   *****   '
R0       EQU      0
R1       EQU      1
R2       EQU      2
R3       EQU      3
R4       EQU      4
R5       EQU      5
R6       EQU      6
R7       EQU      7
SR1      EQU      8
SR2      EQU      9
SR3      EQU      10
SR4      EQU      11
D1       EQU      12
D2       EQU      13
D3       SET      14
D4       SET      15
R12      EQU      12
         PAGE
         REF      J:JIT             ADDRESS OF JIT
         REF      :BIG              FLAG FOR LARGE MEMORY SIG9/560
         REF      DLTSEG            OVERLAY # OF DLT
         REF      CIC
         REF      IOSFILE           PROCESS M:WRITE FOR DISC
         REF      ISEQUB            PROCESS M:READ FOR DISC
         REF      MSRWRT
         REF      CJOB
         REF      E:NQW             EVENT:  ENQUEUE WAIT
         REF      E:SL              SNOOOOOZE CODE
         REF      E:NQR             EVENT:  RELEASE ENQUEUE WAIT
         REF      NEWQNW            UNMAPPED I/O, NO WAIT
         REF      T:REG             REPORT EVENT, GIVE UP CONTROL
         REF      TB:FLGS           DEVICE TYPE FLAGS
         REF      NB31TO0           TABLE OF BITS RESET
         REF      Y000C             BITS 12-13
         REF      Y0C               BITS 4-5
         REF      Y0038             BITS 10-12
         REF      Y00FE             BITS 8-14
         REF      Y00FF             BITS 8-15
         REF      OV:NMSZ
         REF      OH:NM
         REF      TYPMNSZ           SIZE OF TB:FLGS
         REF      OB:BTX
         REF      OB:GTX
         REF      OB:OTX
         REF      DCTSIZ            SIZE OF DCT TABLES
         REF      SV:RSIZ
         REF      Y006              BITS 9-10
         REF      ERO               JIT DISPL TO ERROR ADDRESS
         REF      ABO               JIT DISPL TO ABN ADDRESS
         REF      CCBEF
         REF      PUF               JIT USER PRIORITY
         REF      J:RNST            JIT RUN STATUS AND ABORT BITS
         REF      BAABC             JIT BYTE DISPL TO ABORT CODE
         REF      OPNSEG            OVERLAY # OF OPEN
         REF      Y3                BITS 2-3
         REF      S:CUN             CURRENT USER #
         REF      UH:FLG            USER FLAG TABLE
         REF      OPNCLSUS          USER CURRENTLY OPENING DISC FILE
         REF      J:ASSIGN
         REF      LBLTSEG           OVERLAY # OF LBLT
         REF      S:BUFMCD          DOUBLEWORDS FOR MAPPING BUFF1 &2
         REF      JXBUFVP           CMAP INDEX OF POOL BUFFERS
         REF      ENBSR4            ENABLE, B *SR4
         REF      T:AMRDWT#         ENTRY POINT FOR ASSIGN MERGE
         REF      STEPOVRSEG        OVERLAY # FOR STPNR
         REF      T:RUE             REPORT USER EVENT
         REF      E:NOCR            EVENT:  RELEASE OPN/CLS USER
         REF      COOP              QUEUE I/O FOR DEVICE
         REF      YFF               BITS 0-7
         REF      CLRBFUB           WRITE BUFF2 IF UPDATED
         REF      CLRBBUF           WRITE BUFF1 IF UPDATED
         REF      J:BASE            TEMP STORAGE IN JIT
         REF      J:JAC             USER'S ACCESS CODES
         REF      JOVVP             VIRT PAGE # OF FIRST MON OVRLY PG
         REF      JX:CMAP           USER'S MAP IMAGE
         REF      WRTXEND           CHAIN FPOOL BUFFER ON FREE CHAIN
         REF      XCF               X'CF'
         REF      R:NQW             RESOURCE SUB-QUEUE, ENQUEUE WAIT
         REF      SQR               STATE QUEUED FOR RESOURCE
         REF      SQRO              STATE QUEUED FOR RESOURCE OUT
         REF      UB:US             USER'S STATE
         REF      U:MISC
         REF      AVRFLGS           AVR TABLE FLAGS
         REF      AVRSID
         REF      AVRNOU            AVR TABLE # USERS
         REF      J:CCBUF           COMMAND CARD BUFFER
         REF      NBATAPE           NEG AVR TBL DISP TO TAPES
         REF      AVRTBL            TABLE OF AVR'D TAPES AND PACKS
         REF      Y7F               BITS 1-7
         REF      XEBCTB            BCD CONVERSION TABLE
         REF      EBCTOBCD          BCD CONVERSION TABLE
         REF      AVRTBLSIZ         SIZE OF AVRTBL
         REF      T:RBUF            RELEASE FPOOL BUFFER
         REF      R:OCR             OPN/CLS USER RESOURCE SUB-QUEUE
         REF      SB:RQ             RESOURCE Q
         REF      UB:MF             COUNT OF # I/O'S OUTSTANDING
         REF      REGIPSD           ENTRY TO T:REG FOR I/O WAIT
         REF      SV:LSIZ
         REF      SL:BXMF
         REF      J:ASPIN
         REF      E:CFB
         REF      ECBGBLK           GET 4-WD BLOCK FOR ECB PROCESSING
         REF      COMJRNL
         REF      ECBINIT           INITIALIZES ECB
         REF      ECBCHCK1          WAITS FOR ECB TO BE POSTED
         REF      ECBPOST1          POSTS THE ECB
         REF      REGMASK           REGISTER MASK = X'1FFF0'
         REF      J:RWECB           JIT LOC OF 4-WD BLK POINTER
         REF      OCDCT             DCT INDEX OF OC
         REF      MSROCRD           M:READ TO OPERATOR'S CONSOLE
         REF      J:COCOPT          COC OPTION WORD IN JIT
         REF      JOVVPA            ADDRESS OF OVERLAY AREA
         REF      AVRID
         REF      DOUBLEZERO
         PAGE
         SPACE    2
         DEF      IORT:             SYMBOL FOR MODULE PATCHING
         DEF      CHKBIT            GET FIRST FPT PRESENCE WORD
         DEF      CHKBIT0           SAME AS CHKBIT1, BUT LOAD X'1FFFF'
*,*                                   INTO D2 FOR LATER STS OF DATA.
         DEF      CHKBIT1           GET SUBSEQUENT FPT WORDS
         DEF      CHKREW            WAIT FOR REWIND COMPLETION
         DEF      CLRMBG            RESET MBG BIT IN DCB
         DEF      GETASN            GET DCB:ASN
         DEF      GETBTD            GET DCB:BTD
         DEF      GETDEV            GET DCB DEVICE TYPE ASSIGNMENT
         DEF      GETFUN            GET DCB FUNCTION
         DEF      GETTYC            GET CB:TYC
         DEF      INRRWS            INCR DCB:RWS BY DCB:BTD
         DEF      IOCHEK            PERFORM M:CHECK FUNCTIONS
         DEF      IOCHEK1           WAIT FOR I/O, SET TYC
         DEF      IOQUEUE           SET MBG, QUEUE AN I/O
         DEF      IOQUEUE1          QUEUE AN I/O
         DEF      IOSPIN            WAIT FOR DCB:FCN TO GO TO ZERO
         DEF      MAPBUFS           MAP BUF1 AND BUF2
         DEF      MERC              PROCESS M:MERC
         DEF      MSREXIT           EXIT FROM CALS
         DEF      MSROTHR           QUEUE AN I/O
         DEF      MSRRDWT           M:READ/M:WRITE
         DEF      MSRRDWT1          M:READ/M:WRITE, FROM CALPROC
         DEF      MSRWRTX           EXIT FROM CAL WITH NO ERRORS
         DEF      MSR01EXIT         EXIT FROM MON SERVICE WITH ERROR
         DEF      PULLALLEXIT       PULL DOWN TSTACK TO MARKER
         DEF      PULLEXIT          PULL REG, B INDIRECT
         DEF      PULLEXIT1         PULL REG, INCR IT, B INDIRECT
         DEF      PUTSZBF           PUT BUF ADDR, # BYTES IN DCB
         DEF      PUTSZBF1          MOVE RWS,BUF TO BLK,QBUF
         DEF      PUSHALL           PUSH R5-R11 AND MARKER
         DEF      READTP            ISSUE READ TO DEVICE
         DEF      RECTRAN           MOVE BYTE STRING
         DEF      RESBTD            SET NEW DCB:BTD
         DEF      SAVBLK            SET NEW DCB:BLK
         DEF      SAVRSZ            SET NEW DCB:RSZ
         DEF      SETBTDQ           SET HBTD TO UBTD
         DEF      SETBTDQ1          SET HBTD
         DEF      SETBTDZ           SET HBTD TO ZERO
         DEF      SETTYC            SET NEW DCB:TYC
         DEF      TAPEOP            I/O OPERATION TO TAPE
         DEF      WRTTPE            WRITE TO DEVICE
         DEF      DEOD              TEXT EOD
         DEF      TOFMESS           TOP OF FORM
         DEF      MODEFRM
         DEF      T:UBLKOCU         RELEASE OPEN/CLOSE USER
         DEF      YFFFFFFFC         BITS 0-29
         DEF      WRTELEND          WRITE LABELLED TAPE END-ACTION
         DEF      READLEND          READ LABELLED TAPE END-ACTION
         DEF      FCONCOM           FBCD CONVERSION
         DEF      MSRRED            READ DEVICE
         DEF      YFC               BITS 0-5
         DEF      JHKBIT            CHECK FOR FPT PRESENCE BIT
         DEF      JHKBIT1           CHECK FOR FPT PRESENCE BIT
         DEF      JHKBIT3           CHECK FOR FPT PRESENCE BIT
         DEF      PRECEA            TAPE PRECORD END-ACTION
         DEF      RDERX             EXIT READ/WRITE W/ ERR. (CALL IT)
         DEF      RDERXIT           EXIT READ/WRITE W/ ERR. (B TO IT)
         DEF      TYCODE            XLATE TYC TO ERR/ABN
         DEF      CHKANS0           CHECK DCB:ASN FOR ANS TAPE
         DEF      CHKANS1           CHECK DCB:ASN FOR ANS TAPE
         DEF      GETKEYSB          RECTRAN, MOVE FROM DCB:KBUF
         DEF      RECT2             RECTRAN, USER DISPL = 0
         DEF      GETOBTX           LOAD TABLE OF OB:*TX VALUES
*,*                                 WHERE * = B, G OR O
         DEF      DONEWQ            NO WAIT TAPE SPACING
         DEF      DONEWQP           NO WAIT TAPE PRECORD
         DEF      DONEWQM           NO WAIT TAPE SPACING
         DEF      DHHIT             DOES USER HAVE RESOURCE
         DEF      DHHIT1            DOES USER HAVE RESOURCE
         DEF      CHKWAT            CHECK IF WAT, ERR OR ABN SPECIFIED
         DEF      CAL11N7           ENTRY FROM CALPROC FOR READ/WRITE
         DEF      PLX1SR4           INCR SR4, BRANCH INDIRECT SR4
         DEF      CALLCK1           WAIT I/O EXIT FROM MOCIOP
         DEF      3ER5              CHECK TYC FOR ERROR
         PAGE
YFFFFFFFC DATA    X'FFFFFFFC'
YFC      DATA     X'FC000000'
Y001A    DATA     X'001A0000'
Y001C    DATA     X'001C0000'
Y001004  DATA     X'00100400'
DEOD     TEXT     '!EOD'
TOFMESS  TEXT     '1   '
*
*D*      NAME:    GETFUN
*D*      DESCRIPTION  GET DCB FUNCTION IN D1
GETFUN   EQU      %                 GET FUNCTION
         LW,D1    FUN,R6
         SCS,D1   15
         AND,D1   M4                ONLY 4 BITS USED
         B        *D2
*D*      NAME:    SAVBLK
*D*      DESCRIPTION  PUT (D1) INTO DCB BLK
SAVBLK   EQU      %
         LI,D2    K7FFF
         SLD,D1   17
         STS,D1   BLK,R6
         B        *R0
*D*      NAME:    SAVRSZ
*D*      DESCRIPTION  PUT (D1) INTO DCB RSZ
SAVRSZ   LI,D2    K7FFF
         SLD,D1   17
         STS,D1   RSZ,R6
         B        *R0
*D*      NAME:    SAVARS
*D*      DESCRIPTION  PUT (D1) INTO DCB ARS
SAVARS   LI,D2    K7FFF
         SLD,D1   17
         STS,D1   ARS,R6
         B        *R0
*D*      NAME:    GETASN
*D*      DESCRIPTION  GET DCB ASN IN D2
GETASN   EQU      %
         LI,D2    K7
         AND,D2   ASN,R6
         B        *R0
         SPACE    1
*D*  NAME:         GETTYC
*D*
*D*  OUTPUT:       R3 = DCB:TYC
*D*
*D*  CALL:         BAL,R4
*D*
*D*  DESCRIPTION:  LOAD DCB:TYC INTO R3
*
GETTYC   LW,R3    Y00FE
         AND,R3   TYC,R6
         SCS,R3   15                RIGHT JUSTIFY
         B        0,R4
         SPACE    2
*D*  NAME:         SETTYC
*D*
*D*  INPUT:        D1 = VALUE TO BE STORED INTO DCB:TYC
*D*
*D*  CALL:         BAL,R0
*D*
*D*  DESCRIPTION:  STORE CONTENTS OF D1 INTO DCB:TYC.
*D*                RESET DCB:EGV TO INDICATE USER HAS NOT BEEN
*D*                  GIVEN THE CURRENT TYC.
*
SETTYC   LI,D2    X'7F'
         SLD,D1   17
         STS,D1   TYC,R6
SETTYC1  LI,D2    X'1000'
SETTYC2  STS,D1   EGV,R6            SET/RESET EGV
         B        *R0
         PAGE     MSRRDWT
         SPACE    2
*F*  NAME:         MSRRDWT
*F*
*F*  PURPOSE:      PERFORM M:READ OR M:WRITE
*F*
*F*  DESCRIPTION:  THE FPT IS VALIDATED AND MERGED INTO DCB.
*F*                THE APPROPRIATE READ OR WRITE ROUTINE IS CALLED.
     SPACE         2
*D*  NAME:         MSRRDWT
*D*
*D*  ENTRY:        CAL11N7
*D*
*D*  REGISTERS:    R5, R6, R7, R9, R11 PRESERVED BY PUSHALL
*D*
*D*  CALL:         BAL,R11
*D*
*D*  INTERFACE:    EXITS TO T:AMRDWT IN STEPOVR IF ASSIGN MERGE,
*D*                TO IOSFILE IF M:WRITE TO DISC FILE,
*D*                TO WLBT IF M:WRITE TO LABELLED TAPE,
*D*                TO MSRWRT IF M:WRITE TO DEVICE,
*D*                TO COMJRNL IF M:WRITE TO COMMON JOURNAL,
*D*                TO ISEQUB IF M:READ TO DISC FILE,
*D*                TO RLBT IF M:READ TO LABELLED TAPE,
*D*                AND TO MSRRED IF M:READ TO DEVICE.
*D*
*D*  ENVIRONMENT:  MAPPED MASTER
*D*
*D*  INPUT:        R6 = DCB ADDRESS
*D*                R7 = ADDRESS OF FPT PARAMETER PRESENCE WORD
*D*                R8 = FPT CODE
*D*               R0 = WORD 0 OF CAL1 PSD (CAL11N7 ONLY)
*D*                R11 = LINK
*D*
*D*  OUTPUT:       AT FINAL EXIT, R10 = ERROR CODE AND SUB-CODE
*D*
*D*  DESCRIPTION:  MOST OF CODE FROM HERE TO 1Z8E IS ON FAST CAL
*D*                PATH.  EVERY 60 MICROSECOND ADDITION HERE RESULTS
*D*                IN 1 PERCENT REDUCTION IN CPU THROUGHPUT.
*D*
*D*                CAL11N7:  ENTER HERE FROM CALPROC FOR M:READ,
*D*                M:WRITE, M:DELREC, M:RAMR, M:WAMR.  IF EITHER
*D*                M:RAMR OR M:WAMR, DCB MUST BE CLOSED.  IN ANY
*D*                EVENT, MAPBUFS WILL NOT BE CALLED TO
*D*                MAP IN THE BUFFERS (CALPROC ALREADY DID IT).
*D*
*D*                MSRRDWT:  ENTER HERE FROM ANYWHERE IN MONITOR
*D*                TO DO M:READ OR M:WRITE.  A PUSHALL IS DONE TO
*D*                SAVE R5-R11, AND MAPBUFS CALLED TO MAP IN THE
*D*                FPOOL BUFFERS FOR THIS DCB.
*D*
*D*                GENERAL:  IF THE DCB IS NOT OPEN, A CALL IS MADE
*D*                TO OPEN TO OPEN IT.  IF SHARED KEYED FILE,
*D*                BUFFERS ARE TRUNCATED IF THERE HAVE BEEN ANY
*D*                UPDATES BY OTHER USERS SINCE THIS USER READ
*D*                THE CURRENT BUFFERS.
*D*                ERROR ADDRESS, ABNORMAL ADDRESS, BUFFER ADDRESS,
*D*                AND RECORD SIZE ARE MOVED TO THE DCB.
*D*                M:RAMR AND M:WAMR EXIT HERE TO STEPOVR.
*D*                KEY IS VALIDATED AND MOVED TO DCB.  M:DELREC
*D*                EXITS HERE TO DLT MODULE.  BTD, NEWKEY, ONEWKEY,
*D*                DIR AND BLOCK ARE MOVED TO DCB.
*D*                THE BUFFER ADDRESS AND BYTE COUNT ARE VALIDATED
*D*                AS FOLLOWS:  EACH PHYSICAL PAGE IN JX:CMAP
*D*                CORRESPONDING TO THE VIRTUAL BUFFER PAGES MUST
*D*                BE >= X'8000', AND THE ACCESS ON THE PAGES MUST
*D*                BE 00 FOR READ, 00, 01, OR 02 FOR WRITE.
*D*                A WRITE WITH FBCD MUST HAVE ACCESS OF 00.  ANY
*D*                OF THE FOLLOWING WILL ALLOW THE ABOVE CHECKS TO
*D*                BE BYPASSED:  SPECIAL JIT ACCESS, BIT
*D*                1 OF J:ASSIGN SET (THIS BIT IS RESET AT THE
*D*                END OF THE BUFFER CHECKS).
*D*                EXIT IS THEN MADE TO THE APPROPRIATE ROUTINE.
CAL11N7  EQU      %
         AND,R0   M17
         AI,R0    -J:JIT              WAS CAL DONE FROM MON OVERLAY...
         BGZ      CL11N7A           ---> NO.
         REMEMBER                     YES. REMEMBER WHICH ONE.
CL11N7A  LW,12    TSTACK              SIMULATE A PUSHALL:
         AI,12    -1                  TOP 8 WORDS OF STACK BECOME
         LI,R1    -7                  REGISTERS 5-11 AND
         LCI      8                   STACK MARKER (= %-1).
         STM,R5   *TSTACK,R1
         LW,D2    Y002
         CI,SR1   X'2E'             'AND' ZERO READ/WRITE,
*                                      NONZERO ASSIGN-MERGE.
         AND,D2   FCD,R6              ZERO DCB CLOSED, NONZERO OPEN.
         BNEZ     CL11NW            ---> R/W OR A-M WITH OPEN DCB.
         BANZ     1Z8H              ---> A-M WITH CLOSED DCB.
*                                   ---V R/W, DCB CLOSED; MUST OPEN.
************************************************************
         BLOCK                      BLOCK SLAVE CPU
************************************************************
         B        MSRRDWTA          ---> SKIP BUFFER MAP & PUSHALL.
         SPACE    2
*        MSRRDWT  ANALYZES PARAMETERS ON THE READ AND WRITE STATEMENTS
*        IT THEN BRANCHES TO THE APPROPRIATE ROUTINE FOR DISK FILES,
*        TAPE FILES, OR STANDARD DEVICES
*        R6 = DCB ADDRESS
*        R7 = PARAMETER LIST
*        CALLING SEQUENCE--BAL,SR4  MSRRDWT
*        SR1 = FPT CODE
*
*
MSRRDWT  EQU      %
         BAL,R0   MAPBUFS           MAP BUFF1 AND BUFF2
         REMEMBER
         BAL,R1   PUSHALL
         LW,D2    Y002              SEE IF DCB IS OPEN
         AND,D2   FCD,R6
         BNEZ     MSRRDWT1
MSRRDWTA RES      0
         LW,R5    J:BASE            REMEMBER POINTER TO USER'S R0.
         LI,R7    DOUBLEZERO+1      DUMMY FPT
         OVERLAY  OPNSEG,0
         STW,R5   J:BASE            RESTORE POINTER TO USER'S R0.
         LW,R1    Y002
         CW,R1    FCD,R6
         BANZ     1C1
         AND,SR3  YFF               SCRUB SUBCODE
         SLS,SR3  1                 ALIGN FOR SUBCODE
* DEFAULT OPEN FAILS;  REPORT 46 FOR READ OR 47 FOR WRITE
* WITH THE ERROR CODE FROM OPEN AS THE SUBCODE.
         AI,SR3   X'36'
         LW,R1    TSTACK
         AW,SR3   -4,R1
         B        MSR01EXIT
*E*
*E*  ERROR:        46-XX
*E*
*E*  DESCRIPTION:  IMPLICIT OPEN ON M:READ CAL HAS FAILED.  THE
*E*                SUB-CODE IS THE MAJOR CODE THAT WOULD HAVE
*E*                BEEN REPORTED HAD THIS BEEN AN M:OPEN.
*E*
*E*  ERROR:        47-XX
*E*
*E*  DESCRIPTION:  IMPLICIT OPEN ON M:WRITE CAL HAS FAILED.  THE
*E*                SUB-CODE IS THE MAJOR CODE THAT WOULD HAVE
*E*                BEEN REPORTED HAD THIS BEEN AN M:OPEN.
*E*
1C1      LW,R1    TSTACK
         LCI      7
         LM,R5    -7,R1
         B        MSRRDWT1
*
CL11NW   RES      0                   R/W OR A-M WITH OPEN DCB.
*********   FAST CAL PATH   **********
*  R6>DCB, R7>FPTW0, SR1=FPTCODE, CC=(ANZ, A-M),(NEZ, DCBOPEN)
         BAZ      MSRRDWT1          ---> R/W WITH OPEN DCB.
         LI,SR3   X'2E'
         B        MSR01EXIT
*E*
*E*  ERROR:        2E-00
*E*
*E*  DESCRIPTION:  USER ISSUED M:RAMR/M:WRAMR TO AN OPEN DCB.
*
MSRRDWT1 RES      0                 ALL READ, WRITE, DELREC COME HERE.
*********   FAST CAL PATH   **********
*  R6>DCB, R7>FPTW0, SR1=FPTCODE (10-R,11-W,0D-DEL).
* PERFORM SETUP FOR SHARED KEYED FILE OPERATIONS.
         LI,D2    X'20000'          DCB SHARE BIT
SHARE    EQU      7
         CW,D2    SHARE,R6
         BAZ      1Z8H              NOT SHARED
         LW,1     0,R6
         CI,1     14
         BANZ     1Z8H              NOT FILE
         LW,1     CFU,R6
         LW,2     0,1
         CI,2     X'4A00'           RAN OUTIN OUT
         BANZ     1Z8H              NOT APPLICABLE
         LI,2     X'FFFF'
         AND,2    SCFU,1
         BEZ      1Z8H              ONLY 1 CFU
         LW,R3    CFU,R6
         LI,D1    X'100'            FIND IN CFU
         CW,D1    0,R2
         BAZ      %+2               ALREADY IN R1
         LW,R1    R2
1Z7X     LW,D2    YFF
         LW,R2    TSTACK
         LW,D1    COUNTS,R1
         STS,D1   -2,R2             SAVE IN R10 OF PUSHALL
         CI,SR1   X'10'             IS IT A READ
         BE       1Z7               SKIP IF IT'S A READ
         LI,D2    X'2000'           SHARED WRITE IN PROGRESS BIT
         CW,D2    0,R3               IS IT SET
         BAZ      1Z7Y              SKIP IF NOT SET
         PUSH     R6                SAVE DCB
         LI,D2    2                 SLEEP COUNT
         LW,R6    S:CUN             CURRENT USER #
         STW,D2   U:MISC,R6
         LI,R6    E:SL              SLEEP CODE
         BAL,SR4  T:REG             SNOOOOOOOZE
         PULL     R6                RESTORE DCB
         B        1Z7X              TRY AGAIN
*
1Z7Y     STS,D2   0,R3              SET SHARED WRITE IN PROGRESS
         LI,D2    X'91827'          SHARED WRITE SENTINEL
         PUSH     D2                INSERT SENTINEL IN STACK
COUNTS   EQU      GAVAL
1Z7      RES      0
         LW,D2    M24
         CS,D1    CLK,R6
         BE       1Z8H              NO WRITES SO DON'T TRUNC
         STS,D1   CLK,R6
         PUSH     2,R7
         BAL,SR4  TRUNK             TRUNCATE BUF1 AND BUF2
         PULL     2,R7
1Z8H     RES      0
*********  FAST CAL PATH  *********
*  R6>DCB, R7>FPTW0, SR1=FPTCODE (10-R,11-W,0D-DEL,2D-RAMR,2E-WAMR).
* DECODE THE FPT FOR THE CAL.
*
         LI,R3    X'1FFFF'          STORE MASK
         LW,D3    1,R7              PRESENCE BITS & FLAGS
         AI,R7    X'80002'          FOR BIR BRANCHES
         LC       D3                BITS FOR ER,AB,BFR,SIZ
         BCR,12   NOERAB            BRANCH IF NO ERR OR ABN
         BCR,8    4A1               BRANCH IF NO ERROR ADDR
         BCS,4    4A2               BRANCH IF ABNORMAL ADDR EXISTS
*        ERROR EXISTS BUT NO ABNORMAL
         BAL,R1   JHKBIT5           GET ERROR ADDRESS
         STS,R2   J:JIT+ERO
         B        4A3
*        BOTH ERROR AND ABNORMAL EXIST
4A2      BAL,R1   JHKBIT5           GET ERROR ADDRESS
         STS,R2   J:JIT+ERO
*        ABNORMAL ADDRESS
4A1      BAL,R1   JHKBIT5           GET ABNORMAL ADDRESS
         STS,R2   J:JIT+ABO
4A3      LC       D3                RESTORE BUF & SIZE FLAGS
*
NOERAB   BCS,3    SIZBUF            BRANCH IF BUF AND/OR SIZE
JOSZEM   RES      0
         LW,R2    RSZ,R6            DEFAULT RECORD SIZE
         SLS,R2   -17               RIGHT JUSTIFY
JOSZE    STW,R2   RWS,R6
         CI,SR1   X'2D'
         BL       JOSZE3
*  ASSIGN/MERGE
************************************************************
         BLOCK                      BLOCK SLAVE CPU
************************************************************
         OVERTO   STEPOVRSEG,T:AMRDWT#
         SPACE    2
NOSIZ    BAL,R1   JHKBIT5           GET THE BUFFER ADDRESS
         STS,R2   BUF,R6
         B        JOSZEM            NO SIZE SPEC'D
         SPACE    2
SIZBUF   BCR,1    NOSIZ             BRANCH IF NO SIZE
         BCR,2    NBUFSIZ           BRANCH IF NO BUFFER ADDR
         BAL,R1   JHKBIT5           SET THE
         STS,R2   BUF,R6             BUFFER ADDRESS
NBUFSIZ  LI,R1    JOSZE             SET THE RETURN
         B        JHKBIT5           GET THE BUFFER SIZE
         SPACE    2
JOSZE3   RES      0
         LI,R2    0                 ASSUME NO P5
         CW,D3    Y08               CHK FOR P5 PRESENT
         BAZ      %+2               SKIP IF NOT
         BAL,R1   JHKBIT5           GET THE KEY OR SLAVE LINE INFO
         LI,R4    7                 ASN MASK; INCLUDE CJRNL
         AND,R4   ASN,R6
         BNEZ     %,R4
         B        JFILE
         DO       1                 REMOVE CODE IF BLK NOT NEEDED
         B        %+2
         NOP
         LW,SR3   RWS,R6            REMOVE IF
         LI,SR4   X'1FFFF'           BLK NO LONGER
         SLD,SR3  17                  NEEDED
         STS,SR3  BLK,R6
         B        %-1,R4
         FIN
         B        JFILE0            LABEL TAPE
         B        CKSLVASN          CK FOR TP SLAVE LINE DCB
         B        CJ:ASN            B, IF COMMON JOURNAL; SKIP P5
CKSLVASN EQU      %
         DO       CNM
         REF      CNMLNDCB,VAL:INDX
         LW,R1    CNMLNDCB          GET MASK FOR SLAVE LINE DCB
         CS,R1    0,R6              SEE IF THIS IS A SLAVE LINE DCB
         BNE      DEV:ASN           B, IF NOT; SKIP P5
         CI,D3    X'80'             CHK FOR AUTO FLAG
         BAZ      %+2               SKIP IF NONE
         AW,R2    Y1                MOVE IN THE AUTO FLAG
         STW,R2   VAL:INDX,R6         REMEMBER IN DCB.
         B        CHKBTD            --->ONWARD.
         FIN
*
JOVVPAW  GEN,15,17  0,JOVVPA
         SPACE    2
JFILE0   RES      0
JFILE    RES      0
         LI,D2    X'30'
         AND,D2   ORG,R6
         CI,D2    X'20'             IS IT KEYED
         BNE      NOKEY             BRANCH IF NOT
*****      KEY ADDRESS
         STS,R2   KAD,R6
         CS,R2    JOVVPAW
         BGE      4B1               SKIP IF OK
         CI,R2    X'1FFFF'          CHK FOR NO KEY
         BAZ      CHKDLT            THERE'S NO KEY
         B        1A4               KEY MUST BU IN MAPPED AREA
4B1      LW,SR4   KEYM,R6           MAX KEY LENGTH
         OR,SR4   M24                PAD IT OUT TO MAX
         LW,SR3   Y01               MIN LEGAL KEY
         CLR,SR3  0,R2              CHK IT OUT
         BCR,6    CHKDLT            BRANCH IF A OK
1A4      RES      0
         LI,SR3   K42               KEY LENGTH ERROR
         B        MSR01EXIT
*
*E*  ERROR:        42-00
*E*
*E*  DESCRIPTION:  KEY LENGTH ZERO OR GREATER THAN MAXIMUM,
*E*                OR KEY ADDRESS NOT IN USER'S VIRTUAL SPACE
*
         SPACE    2
CHKDLT   CI,SR1   X'D'              IS IT A DELREC
NOKEY    EQU      CHKDLT
         BNE      CHKBTD            BRANCH IF NOT
* M:DELREC CAL
************************************************************
         BLOCK                      BLOCK SLAVE CPU
************************************************************
         OVERTO   DLTSEG,5
         SPACE    2
*****      BYTE DISPLACEMENT(BTD)
CHKBTD   CW,D3    Y04               CHK P6 PRESENCE
CJ:ASN   EQU      CHKBTD
DEV:ASN  EQU      CJ:ASN
         BAZ      NOBTD             SKIP IF NO BYTE DISPLACEMENT
         BAL,R1   JHKBIT5           GET THE BTD
         LI,R3    X'30'             STORE MASK
         SLS,R2   4
         STS,R2   BTD,R6
NOBTD    RES      0
         CW,D3    Y02               CHK FOR P7 PRESENCE
         BAZ      SETRWECB          BRANCH IF NOT PRESENT
         BAL,R1   JHKBIT5           GET THE ECB SPECIFICATION
************************************************************
         BLOCK                      BLOCK SLAVE CPU
************************************************************
         LI,SR2   0                 INITIALIZE ECB W/0
         LW,SR3   R2                MOVE ECB ADR TO INPUT REG
         LW,R3    R2                SAVE ECB ADR ACROSS CALL, TOO
         BAL,SR4  ECBINIT           ATTEMPT TO INITIALIZE THE ECB
         AI,SR3   0                 IF INITIALIZATION ERROR,
         BNEZ     MSR01EXIT         --->REPORT IT.
ECBGET   BAL,R1   ECBGBLK           GET A 4-WORD BLOCK
         BNEZ     ECBGOT            ---> GOT IT.
         PUSH     R6
         LI,R6    E:CFB             DIDN'T GET IT;
         BAL,SR4  T:REG             WAIT FOR ONE.
         PULL     R6
         B        ECBGET
ECBGOT   LW,SR3   S:CUN
         STB,SR3  R3                R3= USER#,ECBADDR  8,24.
         STW,R3   1,R2                INTO 4-WORD BLOCK WORD 1.
         LI,R3    X'1FFFF'          ADDRESS MASK TO R3
         STS,R2   J:RWECB           SET 4-WORD BLK ADR OR 0 IN JIT
SETRWECB RES      0
         AI,D2    -X'30'            TEST ORG FLAG
         BNEZ     SKIPBLK           B, IF ORG NOT=RANDOM
         LW,R3    KBUF,R6           ELSE, GET ADR OF BUFF TO HOLD BLK#
*****      BLOCK NUMBER
         CW,D3    Y01               CHK FOR P8 PRESENCE
         BAZ      SKIPBLK           SKIP IF NOT
         BAL,R1   JHKBIT5           GET THE BLOCK NUMBER
         STW,R2   0,R3              SET THE BLOCK #
SKIPBLK  CI,R4    3                 IS IT A DEVICE
         BNE      COCOPT30          SKIP IF NOT A DEVICE
*****      COC CONDITIONAL READ, COC READ TIMEOUT
*
*  TRANSFER THE SPECIAL COC READ/WRITE OPTIONS TO J:COCOPT IF
*     USER IS ON-LINE
*
         CW,D3    Y008              CHK P9 PRESENCE
         BAZ      COCOPT30          SKIP IF NOT
         BAL,R1   JHKBIT5           GET THE COC INFO
         LC       J:JIT             CHECK JOB TYPE FLAGS
         BCR,8    COCOPT30          B/NOT ONLINE
         OR,R2    J:COCOPT          PRESERVE BITS COC DIDN'T CLEAR
         LI,R3    X'F7FFF'          MASK FOR J:COCOPT
         STS,R2   J:COCOPT          SET OR RESET J:COCOPT
*
COCOPT30 SLS,D3   16                POSITION P & F BITS
         LW,D4    Y001004
*****      WAT
         STS,D3   WAT,R6
*        INSERT THE WAIT BIT & RESET THE DIRECTION BIT
         SPACE    2
D3       SET      0
D4       SET      1
         SPACE    2
* CHECK VALIDITY OF BUFFER ADDRESS.
         LW,R2    RWS,R6            REQUESTED BYTE COUNT
         BGZ      %+3
         BEZ      1Z8C              ZERO BYTES - NO BUFFER CHECK
         BLZ      CHKLMER           NO NEGS
         LI,D4    0
         LI,D3    X'1FFFF'
         AND,D3   BUF,R6
         SLD,D3   -9
         SCS,D4   11
         LI,R2    X'30'
         AND,R2   BTD,R6
         SLS,2    -4
         AW,D4    RWS,R6
         AW,D4    R2
         AI,D4    2047
         SLS,D4   -11
         CI,D3    JOVVP
*****      FIRST PAGE OF BUFFER IN D3
*****      NUMBER OF PAGES IN THE BUFFER IN D4
         BGE      MEMLP1            FIRST PAGE NOT IN ROOT
RRCHK    RES      0
         LC       J:ASSIGN
         BCS,4    1Z8G1             DON'T CHK BIT SET
         LW,R3    S:CUN
         LH,R3    UH:FLG,R3
         CI,R3    SJAC              SPECIAL JIT ACCESS
         BAZ      CHKLMER           NOT SET - ERROR
1Z8G     CI,8     X'11'
         BE       1Z8D1             WRITE ALLOW IT
         CI,D3    X'20'
         BL       1Z8D1             IN THE ROOT - ALLOW IT
         CI,D3    JOVVP
         BL       CHKLMER
         LW,3     D3
         LOAD,3   JX:CMAP,3
         CI,3     X'22'
         BG       1Z8D1
         B        CHKLMER
MEMLP    AI,D3    1
MEMLP1   LW,R3    D3                MOVE CURRENT PAGE
         SCD,R2   -4
         SCS,R2   5
         LW,R3    J:JAC,R3
         SLD,R2   2,2
         AND,R2   M2
         BEZ      1Z8D
         CI,8     X'11'             IS THIS A WRITE
         BNE      RRCHK             BR IF READ
         LB,2     M2,2              YES, OK FROM 01,02
         BNEZ     RRCHK
         LI,R3    3
         CS,R3    0,R6
         BNE      1Z8D              NOT A DEVICE
         LI,R3    X'4000'           CHK FBCD
         CW,R3    0,R6
         BANZ     CHKLMER           BAD NEWS, FOR SURE
1Z8D     RES      0
         BDR,D4   MEMLP
         CI,D3    X'FF'
         BLE      1Z8C              OK - NOT PAST END OF VIRTUAL CORE
CHKLMER  LI,SR3   X'4A'             ABORT - ILLEGAL BUFFER ADDRESS
         LW,R4    S:CUN
         LH,R4    UH:FLG,R4
         CI,R4    DELA              IS DELTA ASSOCIATED
         BAZ      MSR01EXIT         NO - REPORT THE ERROR
*E*
*E*      ERROR:        ERROR 4A-00
*E*
*E*      DESCRIPTION:  ATTEMPT TO READ/WRITE PROTECTED MEMORY
*E*
CHKMER   LI,R1    PULLALLEXIT
         LI,SR1   0
         B        MSR012            CALL MERC TO SET ABORT BIT
*
1Z8G1    LW,R3    Y4                RESET THE
         STS,R2   J:ASSIGN           NO BFR CHK BIT
         B        1Z8G
*
1Z8D1    AW,D3    D4                CHK END OF VIRTUAL CORE
         CI,D3    X'100'
         BG       CHKLMER           BRANCH IF OFF THE END
*
1Z8C     RES      0
************************************************************
         BLOCK                      BLOCK SLAVE CPU
************************************************************
         SPACE    2
D3       SET      14
D4       SET      15
         SPACE    2
         LW,D2    FUN,R6            GET THE FUNCTION
         CI,SR1   X'11'
         BNE      1Z8F              BRANCH IF READ
         CW,D2    Y001C             IS DCB:FUN INPUT?
         BANZ     WVEC-1,R4         NO, WRITE OK IF OUT, INOUT, OR OUTIN
         LI,SR3   X'44'
         B        MSR01EXIT
*E*
*E*      ERROR:   44-00
*E*
*E*      DESCRIPTION: M:WRITE ISSUED TO A DCB OPEN IN.
*E*
         SPACE    2
WVEC     B        1Z8F1             DISK FILE
         B        1Z8F1             LABEL TAPE
         B        MSRWRT            DEVICE
         B        COMJRNL           COMMON JOURNAL
         SPACE    2
1Z8F1    SLS,D3   7                 SET
         LW,D4    Y3                 ONWK
         STS,D3   ONWK,R6             & NWK
         BDR,R4   WLBT              BRANCH IF LABEL TAPE
         B        IOSFILE           WRITE A DISK FILE
WLBT     RES      0
         LI,0     1                 ENTRY #
         LI,2     LBLTSEG           SEGMENT #
         B        T:OVER
         SPACE    2
*                 IT'S A READ
1Z8F     SLS,D3   -11               SET THE
         LI,D4    X'400'             DIRECTION
         STS,D3   DIR,R6              INDICATOR
         CW,D2    Y001A             IS DCB:FUN OUTPUT?
         BANZ     RVEC-1,R4         NO, READ OK IF INOUT, IN, OR OUTIN
         LI,SR3   X'40'
         B        MSR01EXIT
*E*
*E*      ERROR:   40-00
*E*
*E*      DESCRIPTION: M:READ ISSUED TO A DCB OPEN OUT.
*E*
         SPACE    2
RVEC     B        ISEQUB            DISK FILE
         B        RLBT              LABEL TAPE
         B        MSRRED            DEVICE
         SPACE    2
RLBT     RES      0
         SLS,D3   19                SET THE
         LW,D4    Y08                USER TRAILER
         STS,D3   ULBL,R6             LABEL INDICATOR
ULBL     EQU      ONWK
         LI,0     0                 ENTRY #
         B        WLBT+1
         PAGE
WRTELEND EQU      %
         LW,1     11                SAVE RETURN
         BAL,SR4  WRTXEND           LINK BUFFER TO FREE POOL CHAIN
         LW,11    1                 RESTORE RETURN ADDRESS
*
READLEND LW,R7    SR1               DCB ADDRESS
         LW,D1    TYC,R7
         SCS,D1   15
         AND,D1   M7
         CI,D1    K5
         BNE      LBLEND
         LW,D2    Y00FE
         STS,D1   TYC,R7
         LI,D1    X'40000'
LBLEND   EQU      %
         LI,D2    X'40000'
         STS,D1   BFL,R7
         B        *11
         SPACE    3
PRECEA   EQU      %                 PRECORD E.A.
         LH,2     14                AVRX
         STW,12   AVRSID,R2         TYC,,RRC  8,8,16
*
TAPEA    EQU      %                 TAPE SPACING EA ROUTINE
*                    END ACTION FOR TAPES,R14=AVRSID,USER#
*                      R11=LINK
         PUSH     11
         LH,2     14                CLR REW
         LB,5     AVRFLGS,2
         CW,12    Y08
         BAZ      TAPEA1            NO ERROR
         OR,5     X8                FLAG ERROR
         STB,5    AVRFLGS,2
TAPEA1   EQU      %
         MTH,-1   AVRNOU,2
         BG       TAPEAX            DONT WAKE, MORE I/O TO CPLT
         AND,5    XCF
         STB,5    AVRFLGS,2
         LH,R5    AVRID,R2          GET USER#
         LB,2     UB:US,5
         CI,2     SQR
         BE       %+3
         CI,2     SQRO
         BNE      TAPEAX            NOT WAITING
         LW,2     U:MISC,5
         LB,2     2
         CI,2     R:NQW
         BNE      TAPEAX            NOT WAITING FOR TAPE OP
         LI,6     E:NQR
         BAL,SR4  T:RUE             WAKE HIM(OR HER)
*
TAPEAX   PULL     11
         B        *11
         PAGE
         SPACE    2
*D*  NAME:         MSRRED
*D*
*D*  DESCRIPTION:  PROCESS M:READ FOR ALL DEVICE DCBS, INCLUDING
*D*                SYMBIONT (C DEVICE).
         SPACE    2
MSRRED   EQU      %
*
         LW,R0    Y0004
         LW,R1    Y000C
         STS,R0   EOP,R6
********************************************************
         BLOCK                      BLOCK SLAVE CPU
********************************************************
         LI,SR1   K1FFFF
         AND,SR1  R6
         LW,R3    CNMLNDCB
         CS,R3    ASN,R6            IF IT'S A SLAVE-LINE DCB,
         BE       MODEFRMA          ---> JUST READ FROM IT.
         BAL,D4   GETDEV            GET POINTER INTO DEVICE TABLE
         BEZ      REDCDEV3          NO DEVICE - RETURN EOF
         CI,R3    OCDCT
         BNE      MSRRED5           NOT OPERATOR'S CONSOLE
         BAL,R7   MSROCRD           GO DO SPECIAL PROCESSING
         B        REDCDEV3          ONLINE USER - GIVE EOF
         B        MODEFRMA          NORMAL RETURN - QUEUE READ
*
MSRRED5  EQU      %
         CI,R3    DCTSIZ+1+SV:RSIZ+1+1 'C' (CONTROL) DEVICE
         BE       MSRCDEV           YES
*
*  PROCESS M:READ FOR ALL DEVICES EXCEPT C DEVICE AND OPERATOR'S CONSOLE
*
MODEFRMA LI,SR4   REDX-1
*
MODEFRM  LW,R0    MOD,R6
         LI,R1    X'20000'          MOVE BCD/BINARY FLAG TO BIT 6 OF
         SLD,R0   8                   SR1 (IOQ FUNCTION CODE)
         STS,R0   SR1
*
         LI,R2    X'600'            MOVE DIRECTION FLAG AND PACK/UNPACK
         AND,R2   PCK,R6              FLAGS TO BITS 1 AND 2 OF IOQ
         SLS,R2   20                  FUNCTION CODE
         OR,SR1   R2
*
         CW,R0    Y004              CHECK FBCD
         BAZ      %+2
         OR,SR1   Y1                YES - SET FBCD FLAG
         CW,R0    Y008              IS DRC SET
         BAZ      *SR4              NO
         OR,SR1   Y01               YES - CHANGE FUNCTION CODE TO 1
PLX1SR4  AI,SR4   1
         B        *SR4              EXIT SKIPPING
*
*  PROCESS M:READ FROM THE C DEVICE
*
MSRCDEV  LI,R2    K78               PUT BUFFER ADDR AND SIZE INTO DCB
         LI,D3    J:CCBUF
         BAL,SR4  PUTSZBF
         LW,D4    J:JIT+CCBEF       IS CONTROL BUFFER FULL
         CW,D4    Y004
         BANZ     2C1               YES - TRANSFER RECORD
         CW,D4    Y008              WAS CONTROL COMMAND READ (EOF)
         BANZ     REDCDEV1          YES
         MTH,2    J:JIT+CIC         COUNT ONE MORE CARD READ.
         LW,R1    L(80**24+BA(J:CCBUF))  BLANK OUT J:CCBUF IN CASE
         MBS,R0   BA(Y4)            C-DEVICE CAN DO SHORT RECORDS.
         BAL,SR4  IOQUEUE
         BAL,SR4  IOCHEK1           WAIT FOR READ TO COMPLETE
*
         BAL,R1   CHKWAT
         BNEZ     %+2
         BAL,R0   SETTYC1
*                                   CHECK FORTRAN CONVERT OPTION
         LI,R2    K4000
         CW,R2    FCON,R6
         BAZ      RED3              DONT CONVERT
         BAL,R1   FCONCOM1
RED3     EQU      %
*                                   SR3 CONTAINS RESULT OF READ
         LB,R1    SR3               IS IT END OF FILE
         BNEZ     USRMOV
*                                   CHECK FOR ! IN BIN OR EBCDIC
         LW,D3    QBUF,R6
         LH,D1    *D3
         SLS,D1   -4
         LW,D2    MOD,R6
         CW,D2    Y0002
         BAZ      BCDTST
         CI,D1    K482
         BNE      USRMOV
         B        MONTEST
*
BCDTST   EQU      %
         SLS,D1   -4
         CI,D1    K5A
         BNE      USRMOV
MONTEST  EQU      %
         LW,R1    Y0038             SEE WHO IS RUNNING
         AND,R1   J:JIT+PUF
         BEZ      REDCDEV3
         LW,R1    Y008              SET CCBEF TO FULL
         STS,R1   J:JIT+CCBEF
         LI,R1    K2000             SET AGV FLAG
REDCDEV2 EQU      %
         STS,R1   AGV,R6            SET AGV FLAG
REDCDEV3 EQU      %
         LI,D1    K7                END OF PHYSICAL DATA
REDCDEV31 LI,R0   MSREXIT           RETURN FROM SETTYC
         B        SETTYC
*
2C1      EOR,D4   Y004
         STW,D4   J:JIT+CCBEF       SWITCH RECORD PRESENT FLAG
         LI,D1    X'50'
         BAL,R0   SAVARS
         LI,SR1   0
         LI,SR3   0                 NO ERROR
USRMOV   EQU      %                 TRANSFER DATA FROM MONITOR TO
*                                   USER BUFFER
         BAL,D4   GETBTD            UBTD IN R4
         LW,R3    R4
         LW,D3    BUF,R6            GET USERS BUFFER ADDRESS
         LI,D4    K1FFFF
         CS,D3    QBUF,R6
         BE       PULLALLEXIT
         LW,D4    QBUF,R6           MONITOR BUFFER ADDRESS
         LI,R4    K0                MONITOR BTD
         LW,R1    ARS,R6            GET SIZE OF RECORD
         SLS,R1   -17
         LW,R2    RWS,R6            GET SIZE OF USERS BUFFER
         AW,R2    R3                ADD IN BTD FOR RECTRAN
         BAL,SR4  RECTRAN           TRANSFER RECORD
         CW,R4    R1                DID ALL OF RECORD GET TRANSFERRED
         BGE      PULLALLEXIT       YES - EXIT
*                                   NO--RESET ARS
         LW,D1    R4                SET ACTUAL RECORD SIZE
         BAL,R0   SAVARS
         LB,R1    SR3               NORMAL READ
         BNEZ     PULLALLEXIT
         LI,D1    K2                LDT CODE
         B        REDCDEV31
         SPACE    2
REDCDEV1 LI,R1    X'2000'           HAS USER TRIED TO READ CONTROL
         CW,R1    AGV,R6              CARD TWICE FROM C DEVICE
         BAZ      REDCDEV2          NO
         LI,SR3   X'54'             YES - REPORT ERROR
         B        CHKMER
*E*
*E*  ERROR:        54-00
*E*
*E*  DESCRIPTION:  ATTEMPT TO READ CONTROL CARD MORE THAN ONCE
*E*                  FROM THE C DEVICE.  USER IS ABORTED REGARDLESS
*E*                  OF ANY ERROR OR ABNORMAL ADDRESSES SPECIFIED.
         PAGE     MSROTHR
*  QUEUE I/O FOR DEVICE READ/WRITE
         SPACE    1
         NOP
REDX     LW,D3    BUF,R6            USER BUFFER ADDRESS
         LW,R2    RWS,R6            USER REQUESTED # BYTES
         BNEZ     REDX2
         LI,R2    K1
         LI,D3    K0
REDX2    BAL,SR4  PUTSZBF           PUT BYTE COUNT AND BUF ADDR IN DCB
MSROTHR1 BAL,D4   SETBTDQ           MOVE UBTD TO HBTD
         BAL,D4   CLRMBG            RESET MONITOR BUFFER FLAG
         BAL,SR4  IOQUEUE1
*
         BAL,R0   GETASN            SET PAF IF ANS OR XEROX LABEL
         CI,D2    2
         BNE      NOPAF
         LW,D2    Y0008             ANS--SET PAF
         STS,D2   BFL,R6
NOPAF    EQU      %
         LI,SR4   K4000
         CW,SR4   FCON,R6
         BAZ      NOFCON            FBCD CONVERSION NOT DESIRED
*
*  FBCD CONVERSION
*
         CW,SR1   Y0C
         BANZ     NOFCON            IF WRITE, DON'T CONVERT NOW
         BAL,R0   GETASN
         CI,D2    3
         BNE      NOFCON            DON'T CONVERT IF NOT DEVICE DCB
         BAL,SR4  IOSPIN            WAIT FOR I/O TO COMPLETE
         LI,R1    NOFCON
FCONCOM1 LI,D3    XEBCTB            TRANSLATION TABLE
FCONCOM  LW,R2    QBUF,R6           BUFFER ADDRESS
         SLS,R2   2
         BAL,D4   GETBTD
         AW,R2    R4                BA OF USER BUFFER
         LW,R3    BLK,R6
         SLS,R3   -17               BYTE COUNT
         B        EBCTOBCD          DO THE CONVERSION
*
NOFCON   BAL,R3   GETAVR
         BGE      NOTAPF            NOT TAPE
         CW,1     Y00FF
         BAZ      NOTAPF            NOT OPEN IF NO USERS
         CI,1     X'FFFF'           MAKE TPOS NON-ZERO TO SHOW NOT AT LP
         BANZ     NOTAPF
         AI,1     1
         STD,0    AVRTBL,2
NOTAPF   EQU      %
*
**********   FAST CAL PATH  ***********
*
*D*  NAME:         MSREXIT
*D*
*D*  DESCRIPTION:  FINAL EXIT FOR CALS THAT GO TO FPT ERR/ABN
*D*                ADDRESSES.
*D*
*D*                IF FPT ERR/ABN ADDRESSES OR WAT NOT SPECIFIED,
*D*                RETURN TO CAL+1.  OTHERWISE, WAIT FOR ALL I/O
*D*                TO COMPLETE.  IF TYC IS NOT NORMAL, GO TO
*D*                RDERX TO TAKE APPROPRIATE ACTION.
*
MSREXIT  LI,R1    MSREXIT2
CHKWAT   LI,R5    J:JIT
         LW,D1    ERO+J:JIT
         OR,D1    ABO+J:JIT
         AND,D1   M17
         LW,D2    Y001
         LS,D1    WAT,R6
         B        0,R1
MSREXIT2 BEZ      MSRWRTX           NO-WAIT, EXIT WITHOUT CHECKING TYC
MSREXIT1 EQU      %
         LI,SR4   PULLALLEXIT
IOCHEK1  PUSH     1,SR4
         LW,1     Y7F
         AND,1    FCN,R6
         BEZ      CKEGV             NO I/O IN PROGRESS
********************************************************
         BLOCK                      BLOCK SLAVE CPU
********************************************************
         BAL,SR4  IOSPIN            FINISH IO
CKEGV    EQU      %
         LI,SR1   0
         LI,SR3   0                 NO ERRORS
         BAL,12   CHKREW            WAIT FOR UNFINISHED TAPE SPACE
         B        NOPRT             NOT TAPE
         BAL,R0   GETASN            DO POST PROCESS FOR ALL LABELS
         CI,D2    2
         BNE      NOPRT
*************************************************************
         BLOCK                      BLOCK SLAVE CPU
*************************************************************
         OVERLAY  LBLTSEG,7         POSTANS
NOPRT    EQU      %
         LI,R3    K1000
         CW,R3    EGV,R6
         BANZ     PULLEXIT          TYC HAS BEEN CHKD
         STS,R3   EGV,R6
3ER5     BAL,R4   GETTYC            TYC INTO R3
         DO       CNM
         SREF     LNERRTBL          *****SREF*****
*
         LW,R1    CNMLNDCB          GET MASK FOR SLAVE LINE DCB
         CS,R1    0,R6              SEE IF THIS IS A SLAVE LINE DCB
         BNE      GETREGCD          B, IF NOT & GET REGULAR CODE
         LI,R1    BARNDEV           GET DCB:RNDEV OFFSET
         LB,R1    *R6,R1            CK BI-PNT VS. MULTI-PNT
         BNEZ     GETREGCD          B, IF BI-PNT & GET REGULAR CODE
         LH,SR3   LNERRTBL,R3       ELSE, GET MULTI-PNT LINE CODE
         BEZ      PULLEXIT          OK, IF=0
         SCS,SR3  -8                ELSE, ADJUST CODE, SUB-CODE
         B        RDERX             GO CK CODE FOR ERR VS ABN
*
GETREGCD EQU      %
         FIN
         LB,SR3   CODE,R3           PICK UP REGULAR ERR/ABN CODE
         BEZ      PULLEXIT          NO ERR OR ABN
*
         DO       CNM
         LI,SR1   X'F'
         AND,SR1  ASN,R6            DCB ASSIGNMENT TYPE
         CI,SR1   CJASN
         BNE      RDERX             NOT COMMON JOURNAL
         LI,SR1   2
         STB,SR1  SR3               SET SUB-CODE TO 01
         FIN
*
*D*
*D*  NAME:         RDERX
*D*
*D*  INPUT:        R6 = DCB ADDRESS
*D*                SR3 = ERROR/ABNORMAL CODE
*D*                  MAJOR CODE, BITS 24-31; SUB-CODE, BITS 0-6
*D*
*D*  DESCRIPTION:  EXIT FROM CAL WITH ERROR.  WILL EITHER RETURN TO
*D*                FPT ERROR/ABNORMAL ADDRESS (IF PRESENT), OR WILL
*D*                SET ABORT BIT IN J:RNST.
*D*
RDERX    PULL     R1
         B        RDERX01
*D*      NAME:    RDERXIT
*D*      INPUT:   R6 = DCB ADDRESS
*D*               SR3= ERROR/ABNORMAL CODE. CODE(24-31),SUBCODE(0-6).
*D*      OUTPUT:  SR3=ERRABN+DCB- CODE0-7,SUBCODE8-14,DCB15-31.
*D*               SR1=FPT ERRABN ADDRESS OR 0 IF NONE.
*D*      DESCRIPTION: EXIT FROM CAL WITH ERROR. WILL SET ABORT BIT
*D*               BIT IN J:RNST IF NO FPT ERRABN ADDRESS, THEN WILL
*D*               GO TO PULLALLEXIT.
RDERXIT  LI,R1    PULLALLEXIT       R1= RETURN ADDRESS.
RDERX01  LW,SR1   ABO+J:JIT         ASSUME ABNORMAL
         CI,SR3   X'C0'
         BAZ      MSR012            CORRECT
         LW,SR1   ERO+J:JIT         NO - ERROR
*
MSR012   SCS,SR3  -8                POSITION MAJOR CODE IN BYTE 0
         AND,R6   M17
         OR,SR3   R6                MERGE DCB ADDR IN SR3
         AND,SR1  M17
         BNEZ     0,R1              ERROR/ABNORMAL ADDR EXISTS - EXIT
         BAL,SR4  MERC              NO ADDRESS - SET ABORT BIT
         B        0,R1
         SPACE    2
*D*
*D*  NAME:         MSR01EXIT
*D*
*D*  INPUT:        R6 = DCB ADDRESS
*D*                SR3 = ERROR/ABNORMAL CODE
*D*                  MAJOR CODE, BITS 24-31
*D*                  SUB-CODE, BITS 0-6
*D*
*D*  DESCRIPTION:  EXIT FROM CAL WITH ERROR.
*D*                 IF DCB CONTAINS APPROPRIATE ERROR/ABNORMAL ADDRESS,
*D*                 RETURN CONTROL THERE.
*D*                 OTHERWISE:
*D*                  IF ABORT CODE < X'40', RETURN TO CAL+1.
*D*                  IF ABORT CODE < X'80' AND > X'3F', SET BIT 6 IN
*D*                    J:RNST AND ABORT THE USER.
*D*                  IF ABORT CODE > X'7F', SET BIT 7 IN J:RNST AND
*D*                    ABORT THE USER.
*D*
MSR01EXIT EQU     %
         LI,R1    PULLALLEXIT       RETURN FROM MSR012
         LW,SR1   ABA,R6            ASSUME ABNORMAL
         CI,SR3   X'C0'
         BAZ      MSR012            CORRECT
         LW,SR1   ERA,R6            ERROR
         B        MSR012
         PAGE
*D*      NAME:    CHKANS0
*D*      ENTRY    CHKANS1
*D*      DESCRIPTION
*DO*
*D*
* CHKANS0 & CHKANS1 CHECK FOR ANS DCB ASSIGNMENTS
* CHKANS0=NORMAL RETURN IF ANS; RETURN+1 OF NOT
* CHKANS1=NORMAL RETURN IF NOT ANS; RETURN+1 IF ANS
*FIN*
*
CHKANS0  EQU      %
         PUSH     R0
         LI,R0    X'F'
         AND,R0   ASN,R6
         CI,R0    ANSASN
         BE       PULLEXIT          YES
         B        PULLEXIT1
*
CHKANS1  EQU      %
         PUSH     R0
         LI,R0    X'F'
         AND,R0   ASN,R6
         CI,R0    ANSASN
         BE       PULLEXIT1
PULLEXIT PULL     1,R0
         B        *R0
*D*      NAME:    GETAVR
*D*      DESCRIPTION  GETS AVR TABLE ENTRY FOR TAPE DCB.
*D*      OUTPUT   CC SET FOR BG IF DCB NOT TAPE
*D*               R0,R1 = AVR TABLE ENTRY
*D*               R2 = AVR TABLE INDEX
GETAVR   EQU      %
*                    GETS AVR ENTRY AND SETS R2=AVRX IF DCT=TAPE
         LI,2     2                 IF NOT DEVICE OR LABEL, NO TAPE
         CW,2     ASN,6
         BAZ      GETAVR1
         LI,2     X'3FFF'
         AND,2    DSI,6             IF TAPE, MARK AS OFF LOAD POINT
         SCS,2    -8                GET TYPE, SAVE DCTX
         LC       TB:FLGS,2
         BCR,8    GETAVR1           NOT TAPE
         BCS,4    GETAVR1           NOT TAPE
         LB,2     2                 DCTX
         AI,2     NBATAPE
         LD,0     AVRTBL,2
         CI,2     AVRTBLSIZ
         B        0,3
GETAVR1  LCI      2
         B        0,3
         PAGE
*********   FAST CAL PATH   *********
*
*D*  NAME:         MSRWRTX
*D*
*D*  DESCRIPTION:  EXIT FROM CAL WITH NO ERRORS
*
MSRWRTX  RES      0
         LI,SR1   0
         LI,SR3   0                 NO ERRORS
PULLALLEXIT  EQU    %
*
CLRSTK2  EQU      %
         PULL     1,R2              CLEAN UP THE STACK
         CW,R2    TSTACK
         BE       1Z8I
         CI,R2    X'91827'          SHRED UPDATE FLAG
         BNE      CLRSTK2
         PULL     1,R2              GET STACK MARKER
         CW,R2    TSTACK
         BNE      CLRSTK2
         STW,SR3  -1,R2             UPDATES
         STW,SR1  -3,R2
         BAL,SR4  TRUNK             DUMP THE BUFFERS
         LW,R3    CFU,R6
         LW,R1    0,R3
         AND,R1   NB31TO0+14  TURN OF SHARED UPDATE BIT IN CFU
         STW,R1   0,R3
         INT,R7   SCFU,R3           GET INPUT CFU
         MTW,1    COUNTS,R7         COUNT THE WRITE
         B        1Z8I1
         SPACE    1
TRUNK    PUSH     SR4
         BAL,R0   CLRBFUB
         BAL,R0   CLRBBUF
         LI,SR2   2
         LW,SR3   BUFX,R6
TRUNK1   LI,D3    X'1F'
         AND,D3   SR3
         BEZ      %+3
         LI,R5    0
         BAL,R2   T:RBUF
         SLS,SR3  -5
         BDR,SR2  TRUNK1
         SLS,SR3  10
         STW,SR3  BUFX,R6
         B        PULLEXIT
         SPACE    2
1Z8I     RES      0
         STW,SR3  -1,R2             UPDATES
         STW,SR1  -3,R2
1Z8I1    RES      0
         LI,R7    K1FFFF
         AND,R7   J:RWECB           SEE IF ECB WAS SPECIFIED.
         BEZ      ECBDONE           ---> NO ECB.
         LCW,R3   R7                ECB SPECIFIED.
         AWM,R3   J:RWECB           CLEAR OUT BLOCK ADDRESS.
************************************************************
         BLOCK                      BLOCK SLAVE CPU
************************************************************
         DISABLE                    *****   INHIBIT INTERRUPTS   *****
         LW,SR2   ARS,R6
         SLS,SR2  -17               SR2(08-31) = CURRENT ARS.
         BAL,R4   GETTYC
         STB,R3   SR2               SR2(00-07) = CURRENT TYC.
         MTB,0    *R7               IS THERE ANY MORE I/O OUTSTANDING?
         BNEZ     ECBINUSE          ---> YES.  DON'T POST.
         ENABLE                     *****    ALLOW  INTERRUPTS   *****
*                                   R7  = ADDRESS OF 4-WORD BLOCK.
         LW,SR1   S:CUN             SR1 = USER NUMBER.
*                                   SR2 = TYC(0-7),ARS(8-31).
         LW,SR3   1,R7              SR3 = ECB ADDRESS.
         BAL,SR4  ECBPOST1          **  GO POST ECB & FREE BLOCK.
         B        ECBDONE           ---> DONE WITH ECB.
ECBINUSE EQU      %
         STW,SR2  2,R7              CURRENT TYC/ARS TO POSTING WORD.
         LW,SR2   Y8
         STS,SR2  3,R7              TELL IOQ TO POST THE ECB.
         ENABLE                     *****    ALLOW  INTERRUPTS   *****
ECBDONE  EQU      %
         LI,R0    K0
         LI,R1    K1FFFF
         LI,R3    X'1FF80'
         CW,R3    ERO+J:JIT
         BAZ      %+2               DON'T CLEAR ERROR CODE
         STS,R0   ERO+J:JIT
         STS,R0   ABO+J:JIT
         LW,1     OPNCLSUS
         CW,R1    S:CUN
         BNE      1Z9               THIS USER ISN'T THE ONE
         BAZ      1Z9               BR IF NO BITS AT ALL
1Z80     RES      0
***********************************************************
         BLOCK                      BLOCK SLAVE CPU
***********************************************************
         STW,R0   OPNCLSUS          ZERO THE CELL
         LW,6     S:CUN
         LH,4     UH:FLG,6
         AND,4    NB31TO0+4         RESET OPNCLSUSR BIT
         STH,4    UH:FLG,6
         LI,4     R:OCR
         DISABLE
         LB,5     SB:RQ,4           TEST FOR ANYBODY WAITING
         BEZ      1Z8
         LI,6     E:NOCR
         BAL,11   T:RUE
1Z8      RES      0
         ENABLE
1Z9      PULL     7,R5
********************************************************************
         BLOCK                      BLOCK SLAVE CPU
**********************************************************************
         B        *11
*
*D*      NAME:    T:UBLKOCU
*D*      DESCRIPTION  IF ANY USER IS IN OPEN/CLOSE USER STATE
*D*               REPORT E:NOCR FOR HIM.
*D*      INPUT    R0=0
T:UBLKOCU EQU     %
         PUSH     7,R5
         B        1Z80
*
PUSHALL  EQU      %
         PUSH     7,R5
         LW,R0    TSTACK
         PUSH     1,R0
         B        0,R1
PULLEXIT1   EQU   %
         PULL     1,R0
         AI,R0    K1
         B        *R0
         PAGE     IOCHEK
*D*  NAME:         IOCHEK
*D*
*D*  INPUT:        R6 = DCB ADDRESS
*D*                R7 = FPT ADDRESS
*D*                SR1 = FPT CODE
*D*                SR4 = LINK REGISTER
*D*
*D*  OUTPUT:       SR1, SR3 ZERO IF NO ERRORS
*D*                IF ERROR, SR1 = USER'S ERROR/ABNORMAL ADDRESS AND
*D*                  SR3 = ERROR CODE AND DCB ADDRESS.
*D*
*D*  DESCRIPTION:  PERFORM PROCESSING FOR M:CHECK CAL.  WAIT FOR
*D*                ALL DCB I/O TO COMPLETE.  IF TYC IS NOT NORMAL,
*D*                GO TO RDERX FOR APPROPRIATE ERROR HANDLING.
*
IOCHEK   EQU      %
         LW,12    TSTACK            PUSHALL FUNCTION
         AI,12    -1
         LI,1     -7
         LCI      8
         STM,5    *TSTACK,1
         LW,D2    Y002
         AND,D2   FCD,R6            CK IF DCB IS OPEN
         BEZ      MSRWRTX           GET OUT IF NOT OPEN
         BAL,1    JHKBIT3
         STS,2    ERO+J:JIT
         BAL,1    JHKBIT
         STS,2    ABO+J:JIT
         BAL,R1   JHKBIT            CHECK FOR ECB SPECIFICATION
         B        CALLCK1           B, IF THERE & WAIT 'TIL POSTED
         DO       CNM
         LW,R1    CNMLNDCB          GET MASK FOR CNM LINE DCB
         CS,R1    0,R6              SEE IF THIS IS A CNM LN DCB
         BNE      MSREXIT1          B, IF NOT; NO PROBLEM
         LW,SR3   ECBERR6           BUT NO ECB ON LN I/O CK IS AN ERROR
         B        RDERXIT           ***   TAKE ERROR EXIT   ***
ECBERR6  DATA     X'0200005A'
*E*      ERROR:   5A-01
*E*      MESSAGE: NO ECB ADDRESS SUPPLIED WITH SLAVE LINE M:CHECK.
         ELSE
         B        MSREXIT1          BEGIN EXIT
         FIN
*
CALLCK1  EQU      %
*************************************************************
         BLOCK                      BLOCK SLAVE CPU
*************************************************************
         LW,R5    R2                MOVE ECB ADR TO INPUT REG
         BAL,SR4  ECBCHCK1          WAIT FOR ECB TO BE POSTED
         AI,SR3   0                   ANY ERRORS...
         BNEZ     RDERXIT           --->YES. QUIT WITH ERROR.
         LW,R3    CNMLNDCB          GET MASK FOR CNM LINE DCB
         CS,R3    0,R6              SEE IF THIS IS A CNM LINE DCB
         BNE      MSREXIT1          B, IF NOT; TYC IN DCB IS OK
         LW,R4    1,R5              GET COMPLETION CODE IN ECB
         MTB,1    R4                CK FOR ERR/ABN CODE VS TYC/ARS
         BEZ      SAVEXIT           B, IF CODE, SKIP TYC, ARS, INDX CKS
         LB,D1    R4                ELSE, GET TYC FROM POSTED ECB
         AI,D1    -1                MAKE THE TYC RIGHT AGAIN
         BAL,R0   SETTYC            STORE TYC IN DCB & SET EGV=1
         BAL,R1   JHKBIT            CHECK FOR INDX SPECIFICATION
         B        %+2               PROCESS IF THERE
         B        SETARS            ELSE, SET UP ARS IN DCB
         CW,R2    REGMASK           SEE IF ADR IS A REG
         BANZ     %+2               B, IF NOT
         AW,R2    J:BASE            ELSE, POINT TO USER'S REG VALUE
         LI,R3    1
         LB,R3    R4,R3             PICK UP INDEX VALUE
         STW,R3   0,R2              STORE IN USER'S INDX ADR
*
SETARS   EQU      %
         LI,R3    BARNDEV           GET DCB'S RNDEV OFFSET
         LB,R3    *R6,R3            CK RNDEV BYTE
         BNEZ     SAVEXIT           B, IF BI-PNT LN; ARS ALREADY SET
         LI,R5    X'E0000'          MASK FOR BLK & ARS DCB FIELDS
         SLS,R4   17                ADJUST ARS
         STS,R4   ARS,R6            STORE IN DCB
*
SAVEXIT  EQU      %
         LI,SR4   PULLALLEXIT       LOAD CORRECT EXIT ADR
         PUSH     1,SR4             SAVE IT
         B        CKEGV             CONVERT TYC CODE
         PAGE
         SPACE    2
*  TABLE FOR CONVERTING TYC VALUES INTO ABORT CODES
         SPACE    2
TYCODE   RES      0
CODE     RES      0
         DATA,1   0                 TYC=0 NORMAL-NO DEVICE I/O
         DATA,1   0                 TYC=1 NORMAL-DEVICE I/O
         DATA,1   7                 TYC=2 LOST DATA
         DATA,1   X'1D'             TYC=3 BEGINNING-OF-TAPE
         DATA,1   4                 TYC=4 BEGINNING-OF-FILE
         DATA,1   X'1C'             TYC=5 END-OF-REEL
         DATA,1   5                 TYC=6 END-OF-DATA
         DATA,1   6                 TYC=7 END-OF-FILE
         DATA,1   X'41'             TYC=8 READ ERROR
         DATA,1   X'45'             TYC=9 WRITE ERROR
         DATA,1   X'57'             TYC=A PUB DEV/PRIV SET SATURATED
         DATA,1   0                 TYC=B SLIDES=255
         DATA,1   0                 TYC=C PARTIAL HIGHER LEVEL INDEX BUILT
         DATA,1   X'33'             TYC=D; PURGE CAL ENDED RD/WRT
         DATA,1   X'5B'             TYC=E; LN HUNG UP W/RD PENDING
         DATA,1   X'5C'             TYC=F; LN HUNG UP; INCOMPLETE WRT
         DATA,1   X'23'             TYC=10; COC READ TIMED OUT
         DATA,1   X'24'             TYC=11; COC CONDITIONAL READ, NO INPUT
         DATA,1   0                 TYC=12 UNUSED
         DATA,1   X'4F'             TYC=13 WRITE ERROR AFTER END-OF-TAPE
         BOUND    4
         PAGE
         SPACE    2
*F*  NAME:         IOSPIN
*F*
*F*  PURPOSE:      WAIT FOR ALL I/O ON A GIVEN DCB TO TERMINATE.
     SPACE         2
*D*  NAME:         IOSPIN
*D*
*D*  REGISTERS:    DESTROYS R1
*D*
*D*  CALL:         BAL,SR4
*D*
*D*  INTERFACE:    CALLS THE SCHEDULER TO PUT THE USER IN I/O WAIT
*D*                STATE (SIOW) VIA XPSD TO REGIPSD.
*D*
*D*  ENVIRONMENT:  MASTER MAPPED
*D*
*D*  INPUT:        R6 = DCB ADDRESS
*D*
*D*  OUTPUT:       ALWAYS RETURNS ENABLED.
*D*
*D*  DESCRIPTION:  EXIT IF FCN FIELD OF DCB IS ZERO (NO I/O OUTSTANDING).
*D*                OTHERWISE, CALL SCHEDULER VIA XPSD TO REGIPSD
*D*                (HIGH SPEED ENTRY TO T:REG) TO PUT USER IN I/O
*D*                WAIT STATE (SIOW).  UPON RETURN FROM SCHEDULER,
*D*                EXIT IF UB:MF ZERO (NO I/O OUTSTANDING FOR USER),
*D*                OTHERWISE REPEAT ENTIRE SEQUENCE.
     SPACE         1
IOSPIN   LW,1     Y7F
         CW,1     FCN,R6
         BAZ      BSR4              EXIT IF NO I/O IN PROGRESS
         DISABLE
         AND,1    FCN,R6
         BEZ      ENBSR4            COMPLETED - EXIT
         XPSD,0   REGIPSD
         LW,1     S:CUN             GET CURRENT USER NO
         LB,1     UB:MF,1           AND GET HIS FUNCTION COUNT
         BEZ      ENBSR4            ALL I/O IS DONE - GET OUT
         ENABLE
         B        IOSPIN
         PAGE
GETKEYSB LI,R1    BASCR
         LB,R1    *R6,R1
         LW,D4    KBUF,R6
RECT2    LI,R4    0
RECT1    LI,R2    X'FFFF'
*   FALL INTO RECTRAN
*  RECTRAN FOR SIGMA7 USING MBS INSTRUCTION
*D*      NAME:    RECTRAN
*D*      DESCRIPTION  MOVE BYTE STRING FROM USER BUFFER TO MONITOR BUFFER
*DO*
*D*
*       R1 = USER BUFFER SIZE
*       R2 = MONITOR BUFFER SIZE
*       R3 = MONITOR BYTE DISP (IS INCREMENTED)
*       R4 = USER BYTE DISP    (IS INCREMENTED)
*       D3(R14) = MONITOR BUFFER ADDRESS (WA)
*       D4(R15) = USER BUFFER ADDRESS (WA)
*
*       BYTES MOVED FROM USER BUFFER
*       TO MONITOR BUFFER
*FIN*
*
RECTRAN  EQU      %
         LCI      5
         PSM,14   TSTACK
         ANLZ,5   2B1
         ANLZ,15  2B1+1
         LW,14    5
         SW,1     4                 GET # BYTES TO MOVE
         SW,2     3                 INTO R2
         CW,2     1
         BLE      REC5
         LW,2     1
REC5     EQU      %
         AW,3     2                 FIX R3 & R4 FOR RETURN
         AW,4     2
         AI,2     -256
         BLZ      REC1              1 MOVE
REC3     OR,15    YFC               COUNT = 252
         MBS,14   0
         AI,2     -252
         BGEZ     REC3
REC1     STB,2    15
         MBS,14   0
         LCI      5
         PLM,14   TSTACK
BSR4     B        *SR4
*
*
2B1      LB,5    *15,4
         STB,5    *14,3
         PAGE
         SPACE    2
*D*  NAME:         GETDEV
*D*
*D*  OUTPUT:       R3 = DCTX, LATX OR RATX
*D*
*D*  DESCRIPTION:  IF DCB IS OPEN, BYTE 3 OF DCB:DSI IS RETURNED
*D*                  (DCTX, LATX, OR RATX).
*D*                IF DCB IS CLOSED, THE CONTENTS OF WORD 1 IS
*D*                TRANSFORMED INTO AN APPROPRIATE VALUE AS IF
*D*                THE DCB WERE OPENED.
*
GETDEV   EQU      %
         LW,R3    Y006              *
         AND,R3   FCD,R6            * IS DCB OPEN OR OPENED...
         BNEZ     GETDEV4           --->DCB OPEN OR WAS OPENED.
         CI,R6    M:UC
         REF      M:UC              USER'S TERMINAL DCB IN JIT.
         BE       GETDEV5           ---> UC SPECIAL IF UNOPEN.
         PUSH     R2                * DCB NEVER OPENED. SAVE R2.
         LI,R3    DSI+2
         LH,R3    *R6,R3
         BGZ      GETDEV2
JD1      RES      0
         LI,R2    OV:NMSZ           SIZE OF NAME TABLE
         CH,R3    OH:NM,R2
         BE       %+2               FIND TEXT IN NAME TABLE
         BDR,R2   %-2               SEARCH ALL OF NAME TABLE
         LW,R3    R2                IF ZERO 'NO' DEVICE
KRD1     CI,3     OV:NMSZ-SV:LSIZ
         BGE      KRD2
         LB,2     J:JIT             JOB TYPE
         SLS,R2   -6                0=BATCH,1=GHOST,2=ONLINE
         EXU      GETOBTX,R2        R3=DCTX/RATX/LATX
         CLM,R3   RATRANGE          CHECK FOR RATX
         BCS,9    KRD2              NO-SET CC & RETURN
         LI,R3    0                 SET RATX TO ZERO
KRD2     PULL     2
GETDXIT  AND,R3   M8                SET CC
         B        *D4               RETURN
GETDEV2  EQU      %                 OP LABEL INDEX
         AND,R3   M8                GET OP LABEL INDEX
         AI,R3    TYPMNSZ           CONVERT TO TABLE INDEX
         B        KRD1
*
GETOBTX  EQU      %                 USED BY OPN & OPND
         LB,R3    OB:BTX,R3         BATCH
         LB,R3    OB:GTX,R3         GHOST
         LB,R3    OB:OTX,R3         ONLINE
         BOUND    8
RATRANGE DATA     DCTSIZ+1
         DATA     DCTSIZ+1+SV:RSIZ+1-1
GETDEV4  EQU      %                 * DCB OPEN OR OPENED; DSI OKAY.
         LI,R3    X'3F00'
         AND,R3   DSI,R6            R3= DEVTYPE**8.
         CI,R3    X'1000'           * IS IT A COC LINE...
         BNE      GETDEV6           ---> NOT A COC LINE.
GETDEV5  PUSH     R2                * COC LINE GETS SPECIAL TRTMNT.
         LI,R3    X'F0000'+'ME'
         B        JD1
GETDEV6  EQU      %                 * DCB OPEN(ED), NOT COC.
         SLS,R3   -8                R3= DEVICE TYPE.
         LC       TB:FLGS,R3        CC= DEVTYPE.
         LW,R3    DSI,R6
         BCR,8    GETDXIT           --->NOT DISC TYPE.
         BCR,4    GETDXIT           --->NOT DISC TYPE.
         AND,R3   M8                R3= DCTX,LATX,OR RATX
         LCI      0                 * BUT RETURN CC=0 FOR PACK.
         B        *D4               --->RETURN TO CALLER (DISC).
         PAGE
MSROTHR  LI,SR4   MSROTHR1
*
PUTSZBF1 EQU      %                 PUT USER BUFFER ADR AND SIZE INTO
         LW,R2    RWS,R6            ENTRIES FOR QUEUE
         LW,D3    BUF,R6
*
*D*      NAME:    PUTSZBF
*D*      DESCRIPTION  PUT R2 INTO DCB BLK AND D3 INTO DCB QBUF.
*
PUTSZBF  EQU      %                 PUT BUFFER AND SIZE IN DCB
         LI,R3    X'7FFF'
         SLD,R2   17
         STS,R2   BLK,R6
         LI,D4    K1FFFF
         STS,D3   QBUF,R6
         SCS,R2   15
         B        *SR4
*
INRRWS   LI,D4    INRRWS1
*
GETBTD   EQU      %                 GET BYTE DISPLACEMENT FROM DCB
         LI,R4    K30
         AND,R4   BTD,R6
         SLS,R4   -4
         B        *D4
*
*
*D*      NAME:    CHKREW
*D*      DESCRIPTION  DO NOTHING IF NOT TAPE.
*D*               BLOCK USER IF ANY OF FOLLOWING IS TRUE:
*D*                 1 - USER HAS MAX ALLOWED I/O OPERATIONS
*D*                     ALREADY OUTSTANDING
*D*                 2 - AN ASYNCHRONOUS REWIND IS IN PROGRESS
*D*                 3 - READ OR WRITE IS BEING QUEUED AND AT LEAST
*D*                     ONE ASYNCHRONOUS OPERATION IS OUTSTANDING.
*D*
*D*               PURPOSE OF THE ROUTINE IS TO PREVENT THE CURRENT
*D*               OPERATION FROM BEING QUEUED IF THAT OPERATION
*D*               WOULD CAUSE THE USER TO BE LOCKED IN CORE WHEN
*D*               THERE ARE OUTSTANDING REWINDS AND TAPE SPACINGS.
CHKREW   EQU      %                 SLEEPS USER IF REW IN PROGRESS
         LW,SR2   SR4               SAVE LINK
         BAL,R3   GETAVR
         BGE      *12               NOT A TAPE
CHKREW1  EQU      %
*                    BLOCK IF Q ENTRIES EXCEEDS BATCH MAX
         LH,R3    AVRNOU,2
         CW,R3    SL:BXMF
         BGE      CHKREW2
         LC       AVRFLGS,R2
         BCR,3    CHKREWX           NOT IN REW
         BCS,2    CHKREW2           IN REW, SO PUT TO SLEEP
         CI,12    IOQUEUE12         IS THIS REW CHK ONLY
         BNE      CHKREWX           YES
CHKREW2  EQU      %
***********************************************************
         BLOCK                      BLOCK SLAVES
*****************************************************************
         DISABLE                    AND TAPE END ACTION
         LC       AVRFLGS,2         MAKE SURE THERE'S STILL
         BCR,3    CHKREWX           SOMETHING TO WAIT FOR
         PUSH     R6
         LI,R6    E:NQW
         BAL,SR4  T:REG             SLEEP TILL REW CPLT
         LW,SR4   SR2
         PULL     R6
CHKREWX  ENABLE
         AI,12    1
         LB,3     AVRFLGS,2         DID WE GET AN ERROR
         CI,3     8
         BAZ      CHKREW5           NO
         MTB,-8   AVRFLGS,2         RESET FLAG
         LW,3     Y00FE             YES, SET TYC TO ERROR
         OR,2     Y001
         STS,2    TYC,6
         SW,2     Y001
         LI,3     X'1000'           AND RESET EGV
         STS,2    EGV,6
CHKREW5  LW,R3    Y002              SET R3 BIG IF DCB IS CLOSED
         CW,R3    FCD,R6            AND ERROR OCCURRED
         BANZ     %+2
         LW,R3    Y001
         AND,3    TYC,6             RETURN WITH TYC IN 3
         B        *12
         PAGE
         SPACE    2
*D*  NAME:         TAPEOP
*D*
*D*  ENTRY:        WRTTPE, READTP, IOQUEUE, IOQUEUE1
*D*
*D*  INPUT:        R6 = DCB ADDRESS (READTP, WRTTPE, TAPEOP)
*D*                SR1 = IOQ FUNCTION CODE, DCB ADDR (IOQUEUE,IOQUEUE1)
*D*                SR3 = IOQ FUNCTION CODE (TAPEOP)
*D*
*D*  CALL:         WRTTPE, READTP, TAPEOP - BAL,SR2
*D*                IOQUEUE, IOQUEUE1 - BAL,SR4
*D*
*D*  DESCRIPTION:  QUEUE UP I/O OPERATION.  IF TAPE, CHECKS FOR
*D*                OUTSTANDING ASYNCHRONOUS OPERATIONS AND WILL BLOCK
*D*                THE USER IF THERE ARE ANY.  INCREMENTS DCB:FCN
*D*                AND GOES TO COOP TO DO I/O TO REAL DEVICE
*D*                OR TO COOPERATIVE STREAM.
*D*                IOQUEUE SETS MBG FLAG AND ZEROS HBTD.
*
IOQUEUE  BAL,D4   SETMBG            SET MONITOR BUFFER FLAG
         BAL,D4   SETBTDZ           ZERO HBTD
         B        IOQUEUE1
*
WRTTPE   LI,SR3   X'26'
         B        TAPEOP
*
*
READTP   LI,SR3   K22
TAPEOP   LI,SR1   K1FFFF
         AND,SR1  R6
         STB,SR3  SR1
         LW,SR4   SR2
IOQUEUE1 EQU      %
         BAL,12   CHKREW
         B        IOQUEUE19         NOT TAPE
         LB,SR3   SR1
         CI,SR3   X'C'
         BLZ      IOQUEUE18         NOT FSF,BSF,REW
         CI,SR3   X'F'
         BGE      IOQUEUE18
         LW,1     SR3
         LB,SR3   OLDNEW,1          CONVERT TO NEWQ CODE
*D*      NAME:    DONEWQ
*D*      ENTRY    DONEWQM,DONEWQP
*D*      DESCRIPTION  QUEUE TAPE REWIND OR SPACING OPERATION
*D*               VIA NEWQNW.  AVRNOU IS INCREMENTED BY ONE
*D*               (COUNT OF ASYNCHRONOUS OPERATIONS).
DONEWQ   EQU      %                 SETS UP CALL TO NEWQNWM
         LI,15    0
DONEWQM  LI,0     TAPEA             END-ACTION FOR TAPE SPACING
DONEWQP  EQU      %                 PRECORD ENTRY POINT
         BAL,12   CHKREW1
         NOP      0
         BDR,3    *SR2              DONT KEEP FLAILING AROUND IF ERRORS
         LW,1     S:CUN
         STH,R2   1                 AVRX,USER #
         MTH,1    AVRNOU,2          COUNT OUTSTANDING ASYNC I/OS
         LB,12    AVRFLGS,2
         CI,SR3   8                 REW
         BNE      %+2
         OR,12    BT31TO0+6         REW FLAG
         OR,12    BT31TO0+5         ASYNC TAPE SPACE FLAG
         STB,12   AVRFLGS,2
         LW,12    1,6
         STB,12   13                SAVE DCTX
         LB,12    12                NRT
         SLD,12   8                 ,,NRT,DCTX
         LB,13    CJOB
         STH,13   12                ,PRI,NRT,DCTX
         STB,SR3  12                FUNCTION,PRI,NRT,DCTX
*
         LI,13    0
         LI,14    0
         BAL,11   NEWQNW
         NOP
         B        *SR2
OLDNEW   EQU      %-1
         DATA,1   4,5,0,0           BSR,FSR,,
         DATA     0
         DATA,1   7,6,8,3           FSF,BSF,REW,WEF
IOQUEUE18 EQU     %
         BAL,12   CHKREW            SLEEP FOR TAPE OPS CPLT
IOQUEUE12 EQU     %
         B        IOQUEUE19         NOT TAPE
         BDR,3    *SR2              GET OUT IF GETTING ERRORS
IOQUEUE19 EQU     %
         LI,R1    BAFCN
         LB,R0    *R6,R1
         BNEZ     IOQUEUE3          STILL SOME OUTSTANDING FUNCTIONS
         LI,R3    K1000             HAS THE TYC BEEN CHECKED
         AND,R3   EGV,R6
         BNEZ     IOQUEUE3          YES
         BAL,R4   GETTYC            NO--WAS IT AN ERROR--R3 = TYC
         CI,R3    K8
         BL       IOQUEUE3
         CI,R3    X'B'
         BE       IOQUEUE3          NOT REALLY AN ERROR
         LW,R5    Y02               USER IS QUEUEING AN I/O ON A DCB
         STS,R5   J:RNST              THAT HAD A PREVIOUS UN-CHECKED ERROR
         LB,R3    CODE,R3           ABORT HIM AFTER THIS I/O QUEUED.
         LI,R5    BAABC
         STB,R3   J:JIT,R5          PUT ABORT CODE IN JIT
IOQUEUE3 EQU      %
         DO       CNM
         LW,R3    CNMLNDCB          GET MASK FOR SLAVE LINE DCB
         CS,R3    0,R6              SEE IF THIS IS A SLAVE LINE DCB
         BE       SLVLNCD           B, IF SO; FURTHER PROCESSING NEEDED
         FIN
         MTB,1    *R6,R1
         B        COOP
*
*SETBTDZ -SETS BYTE DISPLACEMENT IN DCB POINTED BY R6  TO ZERO
*LINKED  BY D4   USES R0 AND R1
*
SETBTDZ  LI,R0    K0                LOAD ZEROS
SETBTDQ1 EQU      %
         LI,R1    KC0
         STS,R0   BTD,R6            SET BITE DISPL EQUAL TO ZERO
         B        *D4               RETURN
SETBTDQ  EQU      %
         LW,R0    BTD,R6
         SLS,R0   2
         B        SETBTDQ1
*
RESBTD   EQU      %
         SLS,D1   4
         LI,D2    K30
         DO       BTD=EGV
         B        SETTYC1+1
         ELSE
         STS,D1   BTD,R6
         B        *R0
         FIN
CLRMBG   LI,R0    0                 RESET DCB:MBG
         B        SETMBG1
*
SETMBG   EQU      %                 SET MONITOR BUFFER FLAG
         LW,R0    Y008
SETMBG1  EQU      %
         LW,R1    Y008
         DO       MBG=BTD
         B        SETBTDQ1+1
         ELSE
         STS,R0   MBG,R6
         B        *D4
         FIN
INRRWS1  RES      0
         AWM,R4   RWS,R6
         B        *SR4              RETURN
*
CHKBIT0  LI,D2    K1FFFF
CHKBIT1  EQU      %
         LW,D3    0,R7
         LI,R1    X'80001'
CHKBIT   EQU      %
         SLS,D3   1                 IS IT PRESENT
         BEV      1,R2              NO
         LW,D1    *R7,R1
         BGEZ     CHKBIT2           INDIRECT BIT NOT SET
         CI,D1    X'1FFF0'
         BANZ     %+2
         AW,D1    J:BASE
         LW,D1    *D1
CHKBIT2  EQU      %
         BIR,R1   0,R2
         SPACE    2
JHKBIT3  LI,R3    X'1FFFF'          MASK FOR STS
JHKBIT1  LW,D3    1,R7              PRESENCE BITS AND FLAGS
         AI,R7    X'80002'          FOR BIR BELOW
JHKBIT   SLS,D3   1                 SHIFT OFF NEXT  BIT
         BEV      1,R1              NO PRESENCE BIT
JHKBIT5  RES      0
         LW,R2    0,R7              GET INFO WORD
         BGEZ     JHKBIT2           NOT INDIRECT
         CI,R2    X'1FFF0'
         BAZ      JHKBIT4           INDIRECT THROUGH A REGISTER
         LW,R2    0,R2              INDIRECT, NOT THROUGH REGISTER
         BIR,R7   0,R1              RETURN INCREMENTING POINTER
*
JHKBIT4  LW,R2    *J:BASE,R2        PICK UP REGISTER CONTENTS
JHKBIT2  BIR,R7   0,R1              RETURN INCREMENTING POINTER
         PAGE
         SPACE    2
*D*
*D*  NAME:         MERC
*D*
*D*  INPUT:        SR3 = ERROR/ABNORMAL CODE IN BYTE 0
*D*
*D*  DESCRIPTION:  PROVIDE FACILITIES FOR ABORTING A USER IF THE
*D*                  APPROPRIATE ERROR/ABNORMAL ADDRESSES WERE NOT
*D*                  SPECIFIED.
*D*                IF MAJOR CODE < X'40', DO NOTHING.
*D*                IF MAJOR CODE BETWEEN X'40' AND X'80', SET I/O ERROR
*D*                  ABORT BIT (BIT 6) IN J:RNST.
*D*                IF MAJOR CODE >= X'80', SET TRAP ABORT BIT (BIT 7)
*D*                  IN J:RNST.
*D*                IF EITHER ABORT BIT IS SET, THE MAJOR CODE IS STORED
*D*                  IN J:ABC AND THE SUB-CODE IN J:ERO.
*D*
MERC     EQU      %
         LC       SR3
         BCR,KC   MERC1             AN ABNORMAL CODE
         LI,R2    BAABC
         LW,D1    SR3
         SCS,D1   8
         STB,D1   J:JIT,R2
         SLS,D1   -25
         LI,D2    X'1FFFF'
         STS,D1   ERO+J:JIT
         LW,D2    Y02
         LC       SR3
         BCR,8    %+2
         LW,D2    Y01
         STS,D2   J:RNST
MERC1    EQU      %
         B        *SR4
         PAGE
         SPACE    2
*F*  NAME:         MAPBUFS
*F*
*F*  PURPOSE:      MAP IN FPOOL BUFFERS FOR A GIVEN DCB.
     SPACE         1
*D*  NAME:         MAPBUFS
*D*
*D*  REGISTERS:    DESTROYS R1, R2, R12, R13
*D*
*D*  CALL:         BAL,R0
*D*
*D*  ENVIRONMENT:  MASTER MAPPED
*D*
*D*  INPUT:        R6 = DCB ADDRESS
*D*
*D*  OUTPUT:       MAP RELOADED FOR FPOOL WINDOW PAGES.
*D*
*D*  DESCRIPTION:  IF THE DCB HAS EITHER A BUFF1 OR A BUFF2, THE
*D*                PHYSICAL PAGE NUMBERS ARE PLACED IN THE BUFF1
*D*                AND BUFF2 WINDOW SLOTS.  THE MAP IS THEN RELOADED
*D*                FOR THOSE WINDOW PAGES.
*
MAPBUFS  EQU      %
         LI,R2    X'F'
         AND,R2   ASN,R6
         CI,R2    2
         BG       *R0               NOT DISC OR LABELLED TAPE
         LI,R2    BUF2MSK+BUF1MSK   MASK TO GET BUFFER INDEXES.
         AND,R2   BUFX,R6           GET BUFFER INDEXES.
         BEZ      MB19              ---> NO BUFFERS; DON'T MAP.
         SLS,R2   -5                GET BUFF2 INDEX.
         AI,R2    0                 ANY BUFF2...
         BEZ      MB17              ---> NO.
         AI,R2    JXBUFVP-1         CONVERT INDEX TO CMAP PAGE.
         LI,R1    BUFF2**-9         GET WINDOW PAGE NUMBER.
         LOAD,R12  JX:CMAP,R2       GET REAL PAGE NUMBER AND
         STORE,R12 JX:CMAP,R1       PUT INTO WINDOW MAP PAGE.
MB17     LI,R2    BUF1MSK           NOW FOR BUFF1.
         AND,R2   BUFX,R6           ANY BUFF1...
         BEZ      MB18              ---> NO.
         AI,R2    JXBUFVP-1         CONVERT INDEX TO CMAP PAGE.
         LI,R1    BUFF1**-9         GET WINDOW PAGE NUMBER.
         LOAD,R12  JX:CMAP,R2       GET REAL PAGE NUMBER AND
         STORE,R12 JX:CMAP,R1       PUT INTO WINDOW MAP PAGE.
MB18     LD,R12   S:BUFMCD+:BIG+:BIG GET THE PROPER MAP LOADING DW AND
         LDMAP,R12 0                LOAD THE MAP FOR THESE PAGES.
MB19     B        *R0               RETURN TO CALLER.
         PAGE
         SPACE    1
* DOES HE HAVE IT?
*        BAL,11   DHHIT
*        BANZ     YES
DHHIT    RES      0
         LW,4     2
DHHIT1   RES      0
         SCS,4    -5
         LB,0     4
         SLS,0    -3
         AI,0     BT31TO0+1
         LW,0     *0                PICK UP BIT
         CW,0     J:ASPIN,4         CHECK AGAINST JIT
         B        *11
         PAGE
         DO       CNM               DONE IF TP SLV LINES SUPPORTED
         SREF     MOCIOP            MOC SLAVE LINE I/O REQUEST PROCESSOR
         SREF     MODE              COC TBL ENTRY; HOLDS RD PENDING BIT
         REF      QUEUE             IOQ ENTRY POINT FOR COC SLV LN I/O
*
SLVLNCD  EQU      %
         LI,R4    BARNDEV
         LB,R5    *R6,R4            GET BIPOINT LINE# OR MULTIPOINT 0
         BEZ      MOCIOP            B, IF MULTIPOINT LINE
         CW,SR1   Y04               CK IF THIS IS A WRITE OPERATION
         BANZ     CALLIOQ           B, IF SO
         LW,SR3   LNERR02           ANTICIPATE TROUBLE
         AI,R5    -1                CNMPROC9 ADDED 1 TO INSURE NON-0
         LC       MODE,R5           SEE IF READ PENDING
         BCS,1    MSR01EXIT         ***> ERROR IF SO; REPORT IT NOW.
*
CALLIOQ  EQU      %
         MTB,1    *R6,R1            INCREMENT #I/O OPS NOT COMPLETED
         B        QUEUE             QUEUE THE REQUEST
*
LNERR02  DATA     X'00000059'       BI-PNT RD W/RD OUTSTANDING
*
         FIN
         END

