*
*
*M*      WRTD      WRITE DEVICE-MONITOR SERVICE FOR DEVICE WRITING
*
*        RJR  3-9-73  16:40  'LDEV/IRBT' CP-V A00
*        RJR  4-18-73  18:50  'A00D'(DONE ON 7E).
*                 CATALOG NO. 70XXXX  SIGMA 6/7/9 CP-V WRTD
*                 CATALOG NO. 70XXXX  SIGMA 6/7/9 UTS  WRTD
*                 CATALOG NO. 704719  SIGMM 5/7   BPM  WRTD
*
MONPROC  SET      1
         SYSTEM   UTS
         DEF      WRTD:             PATCHING DEF
WRTD:    RES
         DEF      MSRLP78           * IOD PATH TO COOP FOR TOP.
         OPEN     BUFX  SINCE 'BUFX' IS DEFINED IN SYSTEM UTS ALSO
         PAGE
         BOUND    8
BAPKTC   EQU      BAOVC             *BYTE ADDRESS OF RECORD PACKET COUNT
NUMBIT   EQU      X'200'
K0       EQU      X'0'
K1       EQU      X'1'
K3       EQU      X'3'
K4       EQU      X'4'
K8       EQU      X'8'
KC       EQU      X'C'
KF       EQU      X'F'
K12      EQU      X'12'
K50      EQU      X'50'
K6B      EQU      X'6B'
K71      EQU      X'71'
K78      EQU      X'78'
KF0      EQU      X'F0'
KFF      EQU      X'FF'
KC0      EQU      X'C0'
KFF0     EQU      X'FF0'
K8000    EQU      X'8000'
KFFFF    EQU      X'FFFF'
K1FFFF   EQU      X'1FFFF'
KN1      EQU      -X'1'
KN2      EQU      -X'2'
KN3      EQU      -X'3'
KN4      EQU      -X'4'
         PAGE
R0       EQU      0
R1       EQU      1
R2       EQU      2
R3       EQU      3
R4       EQU      4
R5       EQU      5
R6       EQU      6
R7       EQU      7
SR1      EQU      8
SR2      EQU      9
SR3      EQU      10
SR4      EQU      11
D1       EQU      12
D2       EQU      13
D3       EQU      14
D4       EQU      15
         PAGE     DEFS WRTDEV
         DEF      INTCHR            * INTERPRET VFC CHAR ROUTINE.
*,*                                 * MAY CALL HEADERTEST.
         DEF      MSRWRT            * MAIN ENTRY FOR DEVICE WRITE
*,*                                 * DCB ASN=3(ALSO ANS TPE DCBS)
         DEF      IOGETBF           * COMMON DEVICE IO MPOOL ACQUISITION
*,*                                 * ROUTINE(CENTRALIZED).
         DEF      PUNWEOF           * WRITE !EOD ON CP ROUTINE.
         DEF      SLINECNT          SET LINE COUNT.
         DEF      GLINECNT          GET LINE COUNT.
         PAGE     REFS WRTDEV
         REF      CLRMBG            * IORT ROUTINE TO CLEAR MPOOL
*,*                                 * GIVEN BIT IN DCB.
         REF      DCT4              * DEVICE TYPE TABLE.
         REF      GETBTD            * FETCH BTD FROM DCB ROUTINE.
         REF      GETDEV            * IORT ROUTINE TO DECODE DSI FIELD
*,*                                 * IN DCB(USED BY MOST EVERYBODY).
         REF      GMBSIZ            * SIZE OF AN MPOOL BUFFER.
         REF      IOQUEUE           * IORT ENTRY TO DO IO, GOES TO
*,*                                 * COOP FOR LOGICAL STRMS(NEWQ OTHERWISE).
         REF      J:JIT             * USER'S JOB INFO TABLE BASE.
         REF      SCLINES           * STREAMS LINE COUNT
         REF      SCMINR            * STREAM'S LPP
         REF      SCMISC            * STREAM'S COPY COUNT
         REF      SCSEQ             *  STREAM'S CARD SEQ ID
         REF      GMB               * GET AN MPOOL BUFFER CENTRAL ROUTINE.
*,*                                 * CHECKS VALIDITY(SCREECH IF BAD).
         REF      MSREXIT           * MONITOR SERVICE EXIT ROUTINE.
*,*                                 * CENTRAL EXIT FROM WRTD.
         REF      MSROTHR           * MONITOR SERVICE(OR LACK OF SAME)
*,*                                 * HANDLER FOR 'OTHER' DEVICES.
         REF      PULLEXIT          * PLW,R0 TSTACK...B *R0
         REF      PULLEXIT1         * PLW,R0 TSTACK...AI,R0 1...B *R0
         REF      PUTSZBF           * PUT SIZE AND BUF FIELDS IN DCB
         REF      RECTRAN           * CORE-TO-CORE MOVE SUBROUTINE.
         REF      MODEFRM           * USE DCB MODE,FRM,ETC TO BUILD SR1
*,*                                 * BYTE 0 THE FUNCTION CODE FOR IOQUEUE
         REF      J:DCBLINK         * JIT POINTER TO USER DCB NAME TABLE.
         REF      SETBTDZ           * CLEAR DCB BTD FIELD TO ZERO.
         REF      TAPEOP            * ANOTHER NAME FOR IOQUEUE, JUST
*,*                                 * DIFFERENT ARGUMENTS.
         REF      XF                * =X'0000000F' SMALL MASK.
         REF      X7F               * =X'0000007F' MASK FOR THOSE
*,*                                 * NEARLY BYTES IN BITS8-14 DCB
         REF      XFF               * =X'000000FF' BYTE 3 MASK
         REF      Y02               * =X'02000000' VFC BIT TOGGLE IN SR1
         REF      Y04               * =X'04000000' TO CONSTRUCT SR1 FUNCT CODE.
         REF      YFFFE             * =X'FFFE0000' MASK FOR THOS DCB
*,*                                 * NEARLY HALFWORDS BITS 0-14
         REF      Y0C               * =X'0C000000' SR1 FCN CODE
         REF      TOFMESS           * =C'1   ' A TOP-OF-FORM.
         REF      Y001              * =X'00100000' DCB WAT BIT AMOUNG OTHERS
         REF      Y008              * =X'00800000' DCB MBG BIT
         REF      Y0008             * =X'00080000' SETS DCB EOP=WRITE
         REF      CDPO              * CURRENT DIAGNOSTIC PAGES OUT
*,*                                 * JIT DISP FOR ACCOUNTING(&LIMITS).
         REF      CUPO              * CURRENT USER PAGES OUT
*,*                                 * JIT DISP FOR ACCOUNTING(&LIMITS).
         REF      CPPO              * CURRENT PROCESSOR PAGES OUT
*,*                                 * JIT DISP FOR ACCOUNTING(&LIMITS).
         REF      PUF               * JIT DISP TO PROCESSOR-USER FLAG
         REF      BLANK             * =C'    ' MAINLY FOR PADDING.
         REF      INRRWS            * IORT ROUTINE TO INITIALIZE RWS,
*,*                                 * (NOTE IT DOES A FUNNY NUMBER ON R4).
         REF      ATITLE            * JIT DISP TO TEXT OF !TITLE COMMAND.
         REF      RNST              * THE RIGHT FLAG HERE (IN JIT) GETS
*,*                                 * HIM ABORTED FOR EXCEEDING A LIMIT.
         REF      DEOD              * !EOD CARD IMAGE.
         REF      XA                * =X'0000000A' (=10) FOR DIVIDING
ZBIT     EQU      Y008
         REF      SCDEVTYP          * CNTXT DISP DEVICE TYPE(&FLAGS).
BASCFLG2 EQU      2+SCDEVTYP+SCDEVTYP+SCDEVTYP+SCDEVTYP
BASCMISC EQU      SCMISC+SCMISC+SCMISC+SCMISC
METYPE   EQU      X'10'             SPECIAL CASED BECAUSE
*                                   COC HANDLER DOES MONITOR SERV.
         REF      TB:FLGS           *DEVICE ATTRIBUTE TABLE
         REF      J:USCDX           * JIT: USABLE CNTXT DATA INDEX
*,*                                 * POINTER TO COPTAB(IF THERE).
         REF      Y08               * =X'08000000' VFC SPEC IN SCDEVTYP
         REF      GETASN            * D2 GETS 7&DCB:ASN
         REF      FCONCOM           *COMMON FBCD ENTRY ROUT
         REF      XBCDTB            * OPTIONAL FBCD ROUTINE.
*,*                                 * XLATE FBCD TO EBCDIC
         REF      J:BASE            CAL PROCESSING TEMP CELLS
*,*                                 * SEE DETAIL FOR DEFINITION.
*DO*
*D*      J:BASE TEMP AREA DEFINITION.
J:TDCB   EQU      J:BASE     0      *DCB TEMP
J:TBTD   EQU      J:TDCB+1   1      *DCB BTD TEMP
J:TDBI   EQU      J:TBTD+1   2      *DATA BYTE INDEX TEMP
J:TCBP   EQU      J:TDBI+1   3      *CNTXT BUF POINT TEMP
J:TBBG   EQU      J:TCBP+1   4      *BUFFER BEGIN TEMP
J:T5%%   EQU      J:TBBG+1   5      *     TEMP
J:TMBA   EQU      J:T5%%+1   6      *MON BUF ADDRESS TEMP
J:TUBA   EQU      J:TMBA+1   7      *USER BUF ADDRESS TEMP
J:T8%%   EQU      J:TUBA+1   8      *     TEMP
J:TEUB   EQU      J:T8%%+1   9      *END USER BUFF TEMP
J:TEMB   EQU      J:TEUB+1  10      *END MON BUFF TEMP
*
*FIN*    END OF J:BASE TEMP AREA DEFINITION.
         PAGE     MSRWRT
MSRWRT   EQU      %
*        USED BY ALL WRITE ASN=3 & ANS TAPE WRITE ASN=X'A'
*
         LI,SR1   K1FFFF            SET UP WRITE OP CODE
         AND,SR1  R6
         LC       J:JIT             TEST FOR REMOTE ASSIST
         BCR,2    NOTRAS            NOPE
         LW,1     Y001              GET WAIT BIT
         STS,1    *8                AND PUT INTO DCB
NOTRAS   EQU      %
         OR,SR1   Y04
*
*                                   GO TO PROPER ROUTINE
         LI,R2    X'E0000'
         AND,R2   BLK,R6
         BEZ      MSREXIT
*                                   SET ENDING OPERATION
         LW,R0    Y0008
         LW,R1    =X'C0400'
         STS,R0   EOP,R6
CNM      EQU      1                 *******TEMP CARD
         DO       CNM
         REF      CNMLNDCB          * C N M SLAVE LINE DCB ADDR.
         LW,R1    CNMLNDCB          GET CNM SLAVE LINE DCB MASK
         CS,R1    0,R6              SEE IF THIS IS A SLAVE LINE
         BE       MSROTHR           B, IF SO; FINISHED HERE
         FIN
*                   *** FBCD CONVERSION (OUTPUT)
         LW,D3    FCON,R6
         CI,D3    X'4000'           DID USER WANT CONVERSION
         BAZ      %+4               NO, SKIP
         LI,D3    XBCDTB
         LW,R2    BUF,R6            CONVERT USER BUF
         BAL,R1   FCONCOM+1
*
*
*
*
         LI,R5    X'FF'             STREAM ID WIDTH
         AND,R5   CLK,R6            STREAM EXISTS
         BNEZ     MSRWRT1           YES, SPECIAL
         BAL,D4   GETDEV            NO, DCTX TO R3
         BEZ      MSREXIT           --'NO' DEVICE IS NOP
         LB,R1    DCT4,R3           DEV ATTRIBUTE INDEX
         CI,R1    METYPE            * IS IT'ME'
         BE       MSROTHR           * YES, SPECIAL CASED
*        NO YOU CANT CLEAR J:TCBP HERE...
*        ... YOU'LL BOMB THE MOUT MESSAGE THAT IS BEING
*        SNEAKED THROUGH IN J:BASE.
         LC       TB:FLGS,R1        * DEV ATTRIBUTES
         B        MSRWRT1B          *=*JOIN*=*
MSRWRT1  EQU      %                 * IS A STREAM DEVICE
         LW,R5    *J:USCDX,R5       * GET HIS CONTEXT
         REF      COPOLDI           * COOP TO OPNLD PATH ROUTINE.
*,*                                 * KNOWS WHAT IS NON-VOLATILE NOW
         REF      Y2                * =X'20000000' IS CNTXT BLOCK
*,*                                 * MEANINGFUL.
*
         CW,R5    Y2                STREAM MIGHT HAVE A NON-MEANINGFUL
         BANZ     %+2               CNTXT BLK(AFTER SUPCLS)
         BAL,R3   COPOLDI           INTERNAL OPN (R3-SR4 UNTOUCHED)
         STW,R5   J:TCBP            *( SAVE CNTXT POINT FOR LATER.)
         LI,R1    BASCFLG2          * AND ATTRIBUTE INDEX
         LC       *R5,R1            * CC=TYP,TYP,IN,OUT
MSRWRT1B EQU      %
         BCS,12   MSRWRT1%TDL       * IT IS T,D, OR L.
         BCR,1    MSREXIT           * OUT ILLEGAL=>NOP
         LC       J:JIT             IS REMOTE ASSIST I/O
         BCS,2    MSROTHR           YEP - LET IORT DO I/O CALLING FOR IT
         LI,11    X'20000'          THIS IS A TEST FOR WHETHER
         AND,11   0,6               BINARY OUTPUT IS LEGAL
         BEZ      MSRPUN            FOR THIS DEVICE.  THE BIN
         LW,11    5                 BIT IN THE FLAGS MUST BE
         BNEZ     %+2               SET IN TB:FLGS (TBL OR CXT)
         LI,11    TB:FLGS           IF IT IS SET IN THE DCB OR
         LB,11    *11,1             AN ABORT CODE 1F00 IS GIVEN.
         CI,11    8                 *BIN FLAG
         BANZ     MSRPUN
         LI,10    X'1F'
         REF      MSR01EXIT         * STANDARD ERROR EXIT ROUTINE
*,*                                 * SR3 HAS ERR CODE 7,15,8 SUB,0,MAJOR
         B        MSR01EXIT
*
*
*
MSRWRT1%TDL EQU   %                 * IT IS
         BCR,4    MSRTAPE           *  NOT D OR L:=>(TAPE LIKE)
         BCR,8    MSRLP             *  NOT D OR T:=>(LISTING
*                                   *             LIKE,LP,TY,ETC.)
         B        MSROTHR           *       D:=>(DISC LIKE)
*
         PAGE     MSRLP
*
*        GOT HERE ON A LISTING TYPE DEVICE(TYP,TYP=01)
MSRLP    EQU      %
         BCR,1    MSREXIT           *OUT ILLEGAL :=>NOP
         BCS,2    MSRTYPE           *IN&OUT:=>TY
*                 NOTE THE OBSCURE ASSUMPTION FOR LACK OF A BETTER
*                 ATTRIBUTE SAYING THAT USER WANTS 2 RECORDS FOR
*                 ONE WRITE ON THIS DEVICE IF WIDTH IS<BC.
*
*        WE ARE ON AN HONEST TO GOODNESS PRINTER
         AI,R5    0
         BEZ      MSRLPT-1
         LW,R1    Y08               * SCDEVTYP=1; THIS FOR DIRECT
         CW,R1    SCDEVTYP,R5       * VFC REQUESTED
         BANZ     MSRLPT            * NOPE, DON'T SET IT
         OR,SR1   Y02               VFC
*                                   R6 = DCB ADR
MSRLPT   EQU      %
         BAL,SR4  INRRWS
*                 INRRWS  I:R6;U:D4;O:R4=BTD&RWS=RWS+BTD
         LI,R2    X'EFFFF'          CLEAR TOF
         AND,R2   0,R6
         STW,R2   0,R6
         CI,R2    X'100'
         BANZ     MSRLP1
         LW,D3    SVA,R6            SPACE VALUE
         SCS,D3   15
         AND,D3   XF
         BNEZ     MSRLP08           *YEP, DCB COMES 1ST
         AI,R5    0                 * STREAM OR DIRECT
         BEZ      MSRLP09           * DIRECT AND SPACE 0
         LI,R1    BASCMISC+1        * USE STREAM SPACE DEFLT
         LB,D3    *R5,R1            * ...
         AND,D3   XF                * ...
         BEZ      MSRLP09           * (ITS SINGLE SPC)
MSRLP08  EQU      %                 *
         AI,D3    -1
MSRLP09  EQU      %                 *
         AI,D3    KC0               SPACE CHAR
         B        MSRLP33
MSRLP1   RES      0
*                                   VFC BIT IS SET
         LW,D4    BUF,R6
         LB,D3    *D4,R4
         AI,R4    1
MSRLP33  EQU      %
         STW,R4   J:TBTD            *REMEMBER UBTD TEMP'LY
         BAL,R4   INTCHAR           INTERPRET FORM CHAR
         STW,D3   J:TDCB            SAVE VFC CHAR
         LW,R1    Y04               * HASP BIT(R1=SCDEVTYP, DIR)
         CW,R1    SCDEVTYP,R5       * DIRECT OR HASP
         BANZ     MSRLP34           * YES USE MON BUFF
         LI,D4    X'1FFFF'          SET SPECIAL
         STS,D4   7,R6               BFR FLAG
         LI,SR4   BUFX              SET RTN
         B        IOQUEUE1          TRY FOR COOP
*                 R6=DCB
*                 SR1=IO FUNC / DCB
*                 SR4=LINK
*     DONT CARE   R0,R1,R3,R4,R5,R7,D1,D2,D3,D4
*
         PAGE
         REF      IOQUEUE1          * ALTERNATE PATCH TO IOQUEUE
*,*                                 * MAKES SOME BTD ETC ASSUMPTIONS
         DEF      MSRLP34           * ROUTINE TO GET AN MPOOL AND FRMIM
*,*                                 * IN IT (2 CORE 2 CORE NECCESSARY)
MSRLP34  RES      0                 NOT SYMBIOTIC
         BAL,SR4  IOGETBF
         LW,R3    J:TDCB            * RESTORE VFC CHAR
         STB,R3   *D3
         LI,R2    133
         LW,R4    J:TBTD            *UBTD
         BAL,SR4  FRMIM             FORM IMAGE
         LW,R2    R3                ACTUAL END OF BFR
MSRLP78  EQU      %
         BAL,SR4  PUTSZBF
*                 PUTSZBF  L=SR4;I=R2,D3;U=R3,D4;R2->BLK,D3->QBUF.
         BAL,SR4  IOQUEUE
BUFX     EQU      %
         LI,R0    K0
         LW,R1    Y001
         STS,R0   WAT,R6            CLEAR WAIT BIT
         B        MSREXIT
         PAGE
*
*
INTCHR   EQU      %
*                 R4=LINK
*                 R5=CONTEXT POINT
*                 R6=DCB
*                 R0,R1,D4 - USED
*                 CALLS HEADERTEST    TO OUTPUT HEADER IF APPROPO
*                 RETURNS  D3=VFC CHAR (OR 0 = NONE ALLOWED)
*
*
INTCHAR  EQU      %
         PUSH R4  SAVE RETURN
*
         SCS,D3   -6                IF X'60', X'D0', X'E0'
         SCS,D3   2                   TYPE VFC,
         BCR,8    %+2
         MTB,1    *TSTACK             SET INHIBIT UPSPACE FLAG.
         SCS,D3   4
*
         CI,D3    TOFCHAR           * SKIP TO TOF CHANNEL
         BE       INTCHAR4
         CI,D3    X'D1'
         BE       INTCHAR4
*
         BAL,R0   GLINECNT          * CURRENT LINE COUNT
         BNE      INTCHAR2
*
         LI,D3    TOFCHAR           CHANGE VFC TO TOF...THERE'S NO
         MTB,0    *TSTACK             LINES LEFT ON THIS PAGE.
         BEZ      INTCHAR4
         LI,D3    X'D1'             (USE INHIBIT UPSPACE TOF.)
         B        INTCHAR4
*
INTCHAR2 EQU      %
         LW,R0    D3                *
         SLD,R0   -4                * SEPARATE VFC CODE
         AI,R0    -4                * CHK FOR BLANK
         BEZ      INTCHAR6          * YEP, NOP VFC
         AI,R0    4-KC              * NOPE, CHK FOR SPACE
         BEZ      INTCHAR35         X'C0' TYPE.
         AI,R0    X'C'-X'E'
         BEZ      INTCHAR35         X'E0' TYPE.
*
         CI,D3    X'10'             CHANNEL VFC?.
         BAZ      PULLEXIT          NOPE.
*
INTCHAR3 EQU      %                 CHANNEL BOF VFC CHECK.
         CI,D3    7                 X'D0', X'F0'?
         BANZ     PULLEXIT          NOPE.
         LI,D4    0                 ASSUME NO INHIBIT.
         MTB,0    *TSTACK           INHIBIT VFC?
         BEZ      %+3               NO--LINE 0 IT IS.
         BAL,R4   GLPP              YES--SET MAX LPP.
         LW,D4    R0
         BAL,R0   SLINECNT          SET LINE COUNT.
         B        PULLEXIT
*
INTCHAR35 EQU     %
         SLD,R0   4                 * YEP, EETS A SPACE N LINES
         AW,D4    R0                * ADVANCE LINE COUNT BY N
INTCHAR6 EQU      %
         BAL,R4   GLPP              GET # LINES/PAGE IN R0.
INTCHAR63 EQU     %                 AND TEST
         CW,R0    D4                COMPARE LPP WITH LC.
         BL       INTCHAR4          TOF IF PAST LPP.
*
         MTB,0    *TSTACK           INCREMENT LINE COUNT
         BGZ      %+2                 IF UPSPACE
         AI,D4    1                   WILL FOLLOW PRINT LINE.
         CW,R0    D4                WILL UPSPACE TAKE US PAST
         BGE      INTCHAR5            LAST LINE?
         LI,D4    0                 YES--NOTE WITH SPECIAL 0 LC.
INTCHAR5 EQU      %
         BAL,R0   SLINECNT          * UPDATE LINE COUNT
         B        PULLEXIT          * AND  POP-UP RETURN
INTCHAR4 EQU      %
         BAL,R0   HEADERTEST        CHECK IF HEADER NEEDED.
         B        INTCHAR45         NO.
*
         LI,D3    X'40'             ASSUME NON-INHIBIT AFTER HDR.
         MTB,0    *TSTACK           INHIBIT?
         BEZ      %+2
         LI,D3    X'60'             SHO NUF.
INTCHAR45 AI,D4   1                 ADJUST LINE COUNT.
INTCHAR9 EQU      %                 *
         MTB,0    *TSTACK           WILL UPSPACE ADD A LINE?
         BGZ      %+2
         AI,D4    1                 YES.
         BAL,R0   SLINECNT          SET THE COUNT.
*
         CI,D3    X'10'             CHANNEL VFC?
         BANZ     INTCHAR3          YES.
*
         LW,R0    FVA,R6            **
         SCS,R0   +15               ** WAS TOP GIVEN
         AND,R0   XF                **
         BEZ      INTCHAR92         ** NO, CHECK STREAM TOP
INTCHAR91 EQU     %                 **
         AI,R0    -1                ** YES, ENFORCE
         AW,D4    R0                CORRECT LINE COUNT.
         LW,D3    R0                MOVE SPACE COUNT TO VFC CHAR.
         AI,D3    X'C0'             ASSUME SPACE/NON-INHIBIT VFC.
         MTB,0    *TSTACK           INHIBIT UPSPACE?
         BEZ      %+2
         AI,D3    X'20'             YES--CHANGE TO X'E0' VFC.
         BAL,R0   SLINECNT          **     COUNT
         B        PULLEXIT          ** AND LEAVE
*
INTCHAR92 EQU     %                 **
         AI,R5    0                 ** STREAM OR DIRECT
         BEZ      PULLEXIT          ** DIRECT AND NO TOP
         LW,R0    SCMISC,R5         ** STREAM, CHECK TOP DFLT
         SLS,R0   -20               ** ...
         AND,R0   XF                ** ...
         BEZ      PULLEXIT          ** NONE SO GIVE UP
         B        INTCHAR91         **
*
*
         PAGE     FRMIM             FORM IMAGE(DATA,TABS)
TABCHAR  EQU      X'05'             RECOGNIZED TAB CHAR
*
*                 FROM MSRLP4 AND PRTOTY
FRMIM    EQU      %                 FORM IMAGE FOR PRINT BUFFER
*
*                 BY DISPLACEING TO WHERE DSC SAYS FIRST LISTING
*                 COLUMN IS AND EXPANDING TAB CHARACTERS TO
*                 BLANKS AS DIRECTED BY DCB.
*
*                                   SR4 = LINK
*                                   R5 = CONTEXT POINT
*                                   R6 = DCB
*                                   R0,R1,R3,R7,D4     VOLATILE
*                                   USES RECTRAN UNLESS TABS REQ.
*                                   R4 = BTD OF USERS BUF
*                                   R3 = BTD OF MONITOR BUF
*                                   D3 =ADR OF MONITOR BUF
         LI,R3    0
         STW,R3   J:TBBG            ZAP BUFFER BEGIN
         STW,R6   J:TDCB            REMEM DCB ADDR
         LI,R3    K1
         LW,D4    BUF,R6            USERS BUFFER ADDRESS
         LW,R1    RWS,R6            GET USERS RECORD SIZE
*
         DEF      FRMIMNT           * TAPE ENTRY POINT TO FRMIM
*,*                                 * DOES TABS AND DATA SERVICES.
*                 USED BY COOP
FRMIMNT  RES      0
         LI,R7    BADSC             IS DATA OPTION SPECIFIED
         LB,R7    *J:TDCB,R7        IN HIS DCB
         AND,R7   X7F               LIMIT IT
         B        FRMIM1-1
         LI,R0    ' '
         STB,R0   *D3,R3
         AI,R3    1
         BDR,R7   %-3
FRMIM1   EQU      %
         LI,R7    4*TAB1            DID HEE
         LB,R0    *J:TDCB,R7        REQUEST TABS
         BEZ      RECTRAN           NO TABS SO MBS
         LCI      5
         STM,D3   J:TMBA   THROUGH J:TEMB     D3-R2
FRMIM2   EQU      %
         CW,R4    J:TEUB            AT OR BEYOND END USER BUFFER
         BGE      *SR4              YES
         CW,R3    J:TEMB            AT OR BEYOND END MONITOR BUF
         BGE      *SR4              YES
         LB,R0    *J:TUBA,R4        NEXT USER BYTE
         CI,R0    TABCHAR           IS IT
         BE       FRMIM3            YES
         STB,R0   *J:TMBA,R3        STORE CHAR
FRMIM4   EQU      %
         AI,R3    K1                INCREMENT DISPLACEMENTS
FRMIM2A  EQU      %
         AI,R4    K1
         B        FRMIM2
FRMIM3   EQU      %
         LI,R0    ' '
         LB,R5    *J:TDCB,R7        NO MORE TABS
         BEZ      FRMIM4-1
         AI,R7    K1
         AW,R5    J:TBBG            TAB + DEST BTD = DEST BYTE INDEX
         CW,R5    J:TEMB            OFF END OF DEST BUFFER
         BGE      *SR4              OFF THE END
FRMIM3A  CW,R3    R5
         BL       FRMIM3B
         LW,R3    R5
         B        FRMIM2A
FRMIM3B  EQU      %
         STB,R0   *J:TMBA,R3        PLANT EXPANDING BLANK
         AI,R3    1
         B        FRMIM3A
         PAGE
*
*
HEADERTEST  EQU   %
*                                   PRINT HEADER IF DESIRED
*                 R0 = LINK
*                 R5 = CONTEXT POINT
*                 R6 = DCB
*                 USES - R1,R2,R3,R4,D1,D2,D4,SR2,SR3,SR4
*                 DOES ACCOUNTING CHECK
*                 OUTPUTS - USER HEADER
*                   OR      TITLE + PAGE COUNT.
TOFCHAR  EQU      X'F1'             RECOGNIZED TOF CHAR
*
*
         PUSH     1,R0
         PUSH D3
         PSW,R5   TSTACK            * SAVE STRM/DIRECT POIN
         LI,R0    X'40'
         STB,R0   J:TCBP
*
         BAL,R0   PMAX              ACCOUNT FOR THAT PAGE
*
         LI,D1    KN1
         LI,R1    BAHSC             * DOES USER WANT
         LB,R1    *R6,R1            * A HEADER.
         BNEZ     MSRLP3B           YES
*                                   CHECK FOR TITLE CC
         LC       J:JIT             * IS HE ONLINE OR GHOST
         BCS,8+4  HD3               * YEP, TITLE UNDEFINED
         DO       0                 LEAVE IT OUT AND SEE WHO SCREAMS.
         AI,R5    0                 * STREAM
         BEZ      HD3               * NOPE, NO TITLE
         LW,D2    TITLEOPTBIT       * TITLE ON THIS STREAM
         CW,D2    SCDEVTYP,R5       * REQUESTED OR DEFAULT
         BAZ      HD3               * NOPE,
*                 NEEDS AN LDEV OPTION FOR TITLEOPTBIT
         FIN
         LI,D1    K1
         LB,D2    ATITLE+J:JIT      (DON'T LOOK AT 'UC')
         BNEZ     MSRLP3B
HD3      EQU      %
         LW,R1    LVA,R6
         SLS,R1   -17
         AI,R1    0
         BNEZ     HD31
         LI,R1    BACSC             * DOES USER WANT
         LB,R1    *R6,R1            * THE PAGE COUNT
         BNEZ     HD31              * YES, THEN DOIT
         AI,R5    0                 * STREAM OR DIRECT
         BEZ      HDX               * DIRECT,XIT
         LW,R1    SCMISC,R5         * STREAM USE COUNT
         LB,R1    R1                * ..HI BYTE
         BEZ      HDX               * NON THERE EITHER
HD31     EQU      %                 *
         LI,D1    K0
MSRLP3B  EQU      %
         STW,D1   CDA,R6
         MTW,1    SQS,R6
         BAL,SR4  IOGETBF
         LI,R2    133
         BAL,SR4  BLNKFIL
         LI,SR3   TOFCHAR           *PROPER VFC FOR TOF
         STB,SR3  *D3
         LW,D4    CDA,R6
         BEZ      MSRLP7B
         BGZ      HD1
         LI,R1    BAHSC             * FETCH UP
         LB,R3    *R6,R1            * MONITOR BTD(RECTRAN).
         AND,R3   X7F               HAVE TO LMIT(< MON BUF)
         LW,D4    HLC,R6            GET HEADER ADDRESS
HD2      EQU      %
         LI,R4    K1
         LB,R1    *D4               LENGTH OF HEADER
         AI,R1    K1
         BAL,SR4  RECTRAN           TRANSFER RECORD
MSRLP7B  EQU      %
         LI,R1    BACSC             * DOES HE WANT
         LB,R3    *R6,R1            * A PAGE COUNT.
         BEZ      HD20              NO;GO ON
         CI,R3    132               YES;CHK AGNST MAX. PRNTABL PSTN
         BLE      HD21
         LI,R3    132               HAVE TO LIMIT IT
         B        HD21
HD20     EQU      %
         LW,R5    *TSTACK           * RECTRAN BOMBED R5
         AI,R5    0                 * STREAM OR DIRECT
         BEZ      MSRLP8            * DIRECT NO COUNT
         LW,R3    SCMISC,R5         * STREAM COUNT
         LB,R3    R3                *
         BEZ      MSRLP8            * NONE, NO COUNT
HD21     EQU      %                 * DO APPROPO COUNT
         BAL,R0   CVTDTB            YES--CONVERT DECIMAL COUNT TO BCD
*                                   PUT COUNT INTO BUFFER
         LI,R4    K0                USERS BYTE DIS
         LI,D4    D1
         LI,R1    K4                LENGTH OF COUNT
*
*                                   SUPPRESS LEADING ZEROS
HD5      EQU      %
         LB,R0    D1,R4
         CI,R0    KF0
         BNE      HD4
         AI,R4    K1
         B        HD5
HD4      EQU      %
         BAL,SR4  RECTRAN
MSRLP8   EQU      %
         BAL,SR4  PUTSZBF
         LI,SR4   X'40'             ** SET TOF THIS LINE
         STB,SR4  J:TCBP            **
         BAL,SR4  IOQUEUE
         PLW,R5   TSTACK            * RESTORE STRM POINT
         LI,15    1
         BAL,R0   SLINECNT          * COUNT BACK  TO 1.
         PULL D3
         B        PULLEXIT1
HDX      EQU      %
         PLW,R5   TSTACK            * RESTORE STRM/DIR POINT
         PULL D3
         LI,D4    0
         B        PULLEXIT
*
HD1      EQU      %
         LI,D4    J:JIT+ATITLE
         LI,R3    K1
         B        HD2
*
*
         PAGE     MSRPUN
*MSRPUN-ASSUMES R6 CONTAINS DCB ADDRESS, AND THAT WE WANT TO PUNCH.
*
*
MSRPUN   EQU      %
         BAL,SR4  MODEFRM
         B        MSRPUNT
MSRPUNN  EQU      %
         BAL,R0   PUNMAX            COUNT RECORD
         B        MSROTHR
MSRPUNT  EQU      %
         AI,R5    0
         BEZ      MSRPNT1
         LW,SR4   Y002
         REF      Y002              CXT PUNCH BIT
         CW,SR4   1,R5
         BAZ      MSRPUNN
MSRPNT1  EQU      %
         AND,R0   R1
         BEZ      BCDFOR
         BAL,R0   PMAX              * COUNT THAT RECORD
         BAL,SR4  IOGETBF           OBTAIN A MONITOR (DYNAMIC) BUFFER
         LW,R2    RWS,R6            * USERS REAL BUFFER LEN IF NO SEQ.
         CI,R2    GMBSIZ+GMBSIZ+GMBSIZ+GMBSIZ  **SIZ IN BYTES OF MPOOL
         BLE      %+2               *...WILL THE DATA FIT
         LI,R2    GMBSIZ+GMBSIZ+GMBSIZ+GMBSIZ  **NOPE LIMIT IT
         BAL,SR4  PUTSZBF           PUT OUTPUT BUFFER PARAMS IN DCB
*                 PUTSZBF  L=SR4;I=R2,D3;U=R3,D4;R2->BLK,D3->QBUF.
         LI,D1    K0
         BAL,SR4  BLNKFIL2          FILL IT WITH ZEROS
         BAL,SR4  INRRWS
*                 INRRWS I:R6;U:D4;O:R4=BTD&RWS=RWS+BTD.
         LW,R1    RWS,R6            LOAD    USER BUFFER LENGTH
         LW,D4    BUF,R6            LOAD    USER BUFFER ADDRESS
         LI,R3    K0
         BAL,SR4  RECTRAN           MOVE RECORD TO MONITOR BUFFER
*
         LW,R5    J:TCBP            *(RECTRAN BOMBED R5 AGAIN
*
         LI,R2    120               * USERS LEN IS 120 BYTES IF SEQ.
         BAL,SR2  SEQR              ***CHK SEQ OPTIONS
*GRP1
         LI,R3    K6B               * BUFF INDEX FOR ID
         BAL,SR4  BCDTOB            * ID TO BIN IMAGE AND STORE
*GRP2
         LI,R3    K71               * BUFF INDEX FOR SEQ VALUE
         BAL,R0   CVTDTB            * CONV SEQ NO TO BCD VAL
         BAL,SR4  BCDTOB            * SEQ VAL TO BIN IMAGE AND STORE
         BAL,SR4  PUTSZBF           * MUST RESET BLK DUE TO SEQ.
*                 PUTSZBF  L=SR4;I=R2,D3,R6;U=R3,D4;R2->BLK,D3->QBUF,R6.
*SKIPPED IF NEITHER
         MTW,+1   SQS,R6            * SEQUENCE COUNT
*
         BAL,SR4  IOQUEUE           * DO THE OUTPUT
*
*
         B        BUFX
*                                   WANT TO WRITE IN BCD
BCDFOR   EQU      %
         LI,R0    -4                *
         LI,R2    BAPKTC            *CONTINUOUS IO(IOCONT) PACKET COUNT
         STB,R0   *R6,R2            * 2 TIMES
         LW,R0    RWS,R6
         CI,R0    K50
         BG       %+2
         MTB,2    *R6,R2
         BAL,SR4  INRRWS
BCDLOOP  EQU      %
         PUSH     1,R4              SAVE USER BYTE INDEX
*
         BAL,R0   PUNMAX
         BAL,SR4  IOGETBF           OBTAIN A MONITOR BUFFER
         LI,R2    K50
         BAL,SR4  BLNKFIL           FILL IT WITH ZEROS
*
         LI,R3    K12               *SET INDEX TO COL73-WORD 19
         BAL,SR2  SEQR              ***CHK SEQ OPTIONS
*GRP1
         AI,R2    KN4               REDUCE CARD LENGTH BY 4(MORE) BITES
         STW,D1   *D3,R3            PLANT EBCDIC ID
*GRP2
         AI,R3    1                 * INCREMENT INDEX TO COL 77
         BAL,R0   CVTDTB            * CONV SEQ NO TO BCD VAL
         STW,D1   *D3,R3            * PLANT VALUE IN CARD
         AI,R2    KN4               * REDUCE BY 4(MORE) BITES.
*SKIPPED IF NEITHER
         MTW,+1   SQS,R6            * SEQUENCE COUNT
*
*
         LI,R3    BADSC
         LB,R3    *R6,R3
         BEZ      MSRPUN4           DATA OPTION NOT WANTED
         AI,R3    KN1
MSRPUN4  EQU      %
         LW,D4    BUF,R6            GET USER BUF
         LW,R1    RWS,R6            EXTRACT USER BUFF SIZE
         PULL     1,R4
MSRPUN5  BAL,SR4  RECTRAN           MOVE (SOME OF) OUTPUT TO BUFFER
         LW,R5    J:TCBP            *(RECTRAN BOMBED R5 AGAIN)
         CI,R2    76                * SEQUENCED (AND HOW)
         BL       %+4               * ..BOTH ID AND NUM
         BE       %+4               * ..JUST NUM,
         LI,R2    -8                * .. NEITHER(SO COUNTERACT THE ADJ)
         AW,R2    R3                * .. AND SET RWS THIS PACKET.
         AI,R2    +4                * ADJUST FOR ID(4BYTES)
         AI,R2    +4                * ADJUST FOR NUMBER(4BYTES).
         BAL,SR4  PUTSZBF           * AND SET BLK AND QBUF.
*                 PUTSZBF  L=SR4;I=R2,D3,R6;U=R3,D4;R2->BLK,D3->QBUF,R6.
         LI,R0    BCDLOOP
*                                   DO IO AND SEE IF WE SHOULD CONTINUE
*
*
IOCONT   EQU      %
         PUSH     1,R0
         PUSH     2,R4              SAVE CURRENT BTD & C.B. PTR.
         BAL,SR4  IOQUEUE           WRITE OUT
         PULL     2,R4              RESTORE CURRENT BTD & C.B. PTR.
         LW,D1    RWS,6
         PULL     1,R0
         CW,R4    D1
         BGE      BUFX
         LI,R1    BAPKTC            *CONTINUOUS IO(IOCONT) PACKET COUNT
         MTB,2    *R6,R1
         BEZ      BUFX
         B        *R0
         PAGE     MSRTYPE           THIS ROUTINE HANDLES OUTPUT TO THE
*                                   TYPEWRITER
MSRTYPE  EQU      %
         AI,R5    0                   IS DCB HOOKED TO A STREAM...
         BEZ      MSROCWRT          --->NO, MUST BE OC.
         LI,R5    KN2               MAZIMUM OF TWO RECORDS
         LI,R2    BAPKTC            *CONTINUOUS IO(IOCONT) PACKET COUNT
         STB,R5   *R6,R2
         STW,R5   CDA,R6
         BAL,SR4  INRRWS
*                 INRRWS I:R6;U:D4;O:R4=BTD&RWS=RWS+BTD.
         BAL,D4   GETBTD
*                 GETBTD  DCB:BTD->R4;L=D4
PRTOTY1  EQU      %
         PUSH     1,R4
         BAL,SR4  IOGETBF
         LI,R2    81
         BAL,SR4  BLNKFIL
         PULL     1,R4
*
*                                   PUT IN CARRIAGE RETURN
         LI,R1    X'15'
         STB,R1   *D3
         BAL,SR4  FRMIM
         LW,R2    R3
         BAL,SR4  PUTSZBF
         LI,R0    PRTOTY1
         B        IOCONT            DO IO AND SEE IF MORE SHOULD BE DONE
         PAGE     MSRTAPE
*MSRTAPE - ASSIGNS OUTPUT TO TAPE OR PUNCH AS APPROPRIATE
*USES VOLATILE REQS,ASSUMING R6 POINTS TO DCB, R5 TO JIT
MSRTAPE  EQU      %
         BAL,SR4  MODEFRM           ZEE IF FORMATTING SHOULD BE DONE
         B        TAPEFRM
         B        MSROTHR
TAPEFRM  EQU      %
         BAL,R0   GETASN
         AI,D2    -3                * 3 IS IT DEVICE ASN
         BNEZ     MSROTHR           * NO MUST BE OTHER (ANS=X'A')
         INT,D2   0,R6              *FETCH UP VFC BIT
         OR,D2    SVA,R6            * + SPACE AND DATA
         OR,D2    HSC,R6            * + HEADER AND 1ST
         CW,D2    =X'FFFE0100'      * FEILD MASK FOR ABOVE THINGS
         BAZ      MSROTHR           **NONE OF EM WANTED**
         B        MSRLPT            * MAY NOT NEED PRPNCHK
         PAGE     MISCELLANEOUS I/O ROUTINES
PBT      EQU      %                 PROPER BUCKET TABLE
         GEN,16   0                 0 - NO ACCOUNTING
         GEN,16   CDPO              1 - CURRENT DIAG PAGES OUT
         GEN,16   CPO               2 - CURRENT PUNCH OUTPUT
         GEN,16   CUPO              3 - CURRENT USER PAGES OUT
         GEN,16   CPPO              4 - CURRENT PROC PAGES OUT
         BOUND    4
PMAX     RES      0
PUNMAX   RES      0
*                 MAX UO,DO,LO ENFORCER (ALSO PO)
*                   R0 = LINK
*                   R5 = CONTEXT BLOCK POINTER.
*                   R6 = DCB
*                         CLK(WORD 12) BYTE 2 IS PROPER BUCKET INDEX.
*                   D1,D2,R1 - USED
*
         LI,R1    (4*CLK)+2         WORD CLK BYTE 2
         LB,R1    *R6,R1            FETCH UP ACCOUNTING TYPE
         AND,R1   XF                (FOUR BITS WIDE.)
         BEZ      *R0               DO NO ACCOUNTING
         LH,R1    PBT,R1            XLATE INTO JIT DISP.
         LW,D1    J:JIT,R1
         LW,D2    SCMISC,R5         * CHARGE FOR EACH COPY
         AND,D2   XFF               * , I.E. THE REAL ITEM IS
         SLS,D2   +17               * THE END PRODUCT, PAPER
         AW,D1    D2                * ,CARDS, PERIPHERAL TIME,
         LW,D2    YFFFE             * ETC. AND THAT
*                                   * IS THE LIMIT.
         STW,D1   J:JIT,R1
         AI,R1    1
         CS,D2    J:JIT,R1          MAX LIMIT
         BE       *R0               YES, THAT MEANS NO LIMIT
         CS,D1    J:JIT,R1
         BLE      *R0
         LW,D2    Y0038
         REF      CPO               * CURRENT PUNCHES(CARDS) OUT, JIT
*,*                                 * DISP FOR ACCOUNTING(&LIMITS).
         REF      Y0038             * =X'00380000' MAGIC BITS IN JIT
*,*                                 * SAYS DONT ABORT FOR LIMIT.
         REF      NMPO              * CONSTANT TO CONVERT LIMIT OFFSET
*,*                                 * TO BIT OFFSET FOR FLAG.
         REF      MFL               * BIT TABLE SOMEWHAT PARALLEL TO CYYO
*,*                                 * MYYO TO FLAG WHICH LIMIT EXCEEDED.
         AND,D2   J:JIT+PUF
         BEZ      *R0
         LW,D2    Y04
         STS,D2   RNST+J:JIT
         AI,R1    NMPO
         SLS,R1   -1
         SLS,D2   -26,R1
         STS,D2   MFL+J:JIT
         B        *R0
         SPACE    5
*F*      NAME:    PUNWEOF
*F*      PURPOSE: WRITE !EOD CARD ON CARD PUNCH.  CALLED FROM
*F*               CLOSE AND WEOF.
*D*      NAME:    PUNWEOF
*D*      REGISTERS: R6 PRESERVED; ALL OTHERS VULNERABLE.
*D*      CALL:    BAL,R0  PUNWEOF
*D*      INTERFACE: PUTSZBF,SETBTDZ,CLRMBG,TAPEOP.
*D*      ENVIRONMENT: MASTER MAPPED.
*D*      INPUT:   R0 LINK REGISTER.
*D*               R5 ADDRESS OF CONTEXT BLOCK OR ZERO.
*D*               R6 ADDRESS OF DCB.
PUNWEOF  EQU      %
         PUSH     R0                SAVE LINK.
         CW,R5    Y2                SEE IF STREAM IS OPEN...
         BANZ     PUNWEOF1          --->YES.
         AI,R5    0
         BEZ      PUNWEOF1          --->NO STREAM.
         BAL,R3   COPOLDI            UNOPEN STREAM; MUST REOPEN IT.
PUNWEOF1 STW,R5   J:TCBP            NOW INITIALIZE J:TCBP.
         LI,D3    DEOD              D3=>!EOD IMAGE.
         LI,R2    K4                R2= LENGTH OF !EOD IMAGE.
         BAL,SR4  PUTSZBF           D3>QBUF,R2>BLK, U:R3,D4.
         BAL,D4   SETBTDZ           0>BTD, U:R0,R1.
         BAL,D4   CLRMBG            0>MBG, U:R0,R1.
         BAL,R0   PUNMAX            I:6>DCB,5>CCB, U:R0,R1,D1,D2.
         LI,SR3   4                 SR3= 'WRITE' FUNCTION CODE.
         BAL,SR2  TAPEOP             WRITE OUT THE !EOD RECORD.
*                       I:R6>DCB,SR3=FC, U:R0-R5,SR1-D4.
         B        PULLEXIT          ---> RETURN TO CALLER.
         PAGE
*
HACLK    EQU      CLK+CLK           *DCB W 12 HW 0
*
*        GET LINE COUNT  L=0,I=R5(0 OR CNTXT LOC),R6(DCB)
*                        O=D4(CURR LINE COUNT)
*
GLINECNT EQU      %
         AI,R5    0                 *STREAM OR DIRECT
         BNEZ     %+4               *IS STREAM NORMALLY
         LI,R1    HACLK             *NOPE, IS DIRECT
         LH,D4    *R6,R1            *GET DCB LIN COUNT
         B        *R0               * AND RETURN
         LW,D4    SCLINES,R5        *..STREAM LINE COUNT
         B        *R0               * AND RETURN
*
*        SET LINE COUNT  L=R0,I&O LIKE GET L.C.
*
SLINECNT EQU      %
         AI,R5    0                 *STREAM OR DIRECT
         BNEZ     %+4               * IS STREAM NORM.
         LI,R1    HACLK             * NOPE IS DIRECT
         STH,D4   *R6,R1            * SET CURR L. C.
         B        *R0               * AND RETURN
         STW,D4   SCLINES,R5        * ..SET STREAM L. C.
         B        *R0               * AND RETURN
*
*   GET NUMBER OF LINES/PAGE.   BAL,R4 GLPP  R0=LPP,R5=0 OR CNTXT.
*
GLPP     EQU      %
         LW,R0    LVA,R6            TRY DCB LINES
         SLS,R0   -17                  FIRST.
         AI,R0    0
         BNEZ     0,R4
         AI,R5    0                 COOP DEV?
         BEZ      0,R4              NOPE.
         LW,R0    SCMINR,R5         YES.
         B        0,R4
*
*
BLNKFIL  EQU      %                 FILL BUFFER WITH BLANKS
*                                   R2 = SIZE, D3 = ADR
         LW,D1    BLANK
BLNKFIL2 EQU      %
         LI,R3    GMBSIZ-1
         STW,D1   *D3,R3
         BDR,R3   %-1
         STW,D1   *D3
         B        *SR4
*
*
***
*   TEST FOR SEQUENCE OPTION REQUESTS
*   CALL:         BAL,SR2    ...
*                 1ST ID PLACEMENT INST.
*                 2ND ''    ''      ''
*                 1ST VALUE PLACEMENT INST.
*                 2ND   ''     ''      ''
*                 3RD   ''     ''      ''
*                 4TH   ''     ''      ''
*                 SEQUENCE COUNT INST IF EITHER
*                 ALL DONE OR NONE WANTED RETURN.
***
SEQR     EQU      %                 * CHECK FOR CARD SEQUENCING
         LW,D1    SID,R6            *  DCB SEQID OVERRIDE
         LW,R1    Y0C               * (SEQ FLAGS)
         AND,R1   SEQ,R6            * REQUEST IN DCB
         BNEZ     SEQR2             *  SOMETHING IS WANTED
         LW,D1    SCSEQ,R5          * ANY DFLT STREAM SEQ
         BNEZ     *SR2              * YEP, DO THAT
         AI,SR2   7                 *  NOTHING SO SKIP IT ALL
         B        *SR2              *=*AND RETURN*=*
SEQR2    EQU      %                 *
         CW,R1    Y04               * DOES HE WANT ID TOO
         BANZ     *SR2              * YEP, GIVEM BOTH
         AI,SR2   2                 * NOPE, VALUE ONLY
         B        *SR2              *
***
*
*
CVTDTB   EQU      %
*                                   TO EBCDIC
         LI,R1    3                 * LO ORD TO BY3
         LI,SR4   KFFFF
         AND,SR4  SQS,R6
CVTDTB1  EQU      %
         LI,SR3   K0
         DW,SR3   XA
         STB,SR3  D1,R1             * PLANT CONVERTED VALUE
         AI,R1    -1                * NEXT MOST SIGNIFICANT
         BGEZ     CVTDTB1           * FROM TOP
         OR,D1    ='0000'           * DONE,MERGE ZONE BITS
         B        *R0               *=*RETURN*=*
*
*BCDTOB  CONVERTS CONTENTS OF  D1 FROM BCD TO BINARY MAP. LINKED VIA SR4
*OUTPUT STORED AT (D3) INDEXED BY R3
*
BCDTOB   PUSH     9,D2              GET WORKING SPACE
         LI,R1    KN2               SET UP OUTER LOOP INDEX
         LI,D2    KFF               SET UP CHARACTER MASK
CHAR1    LI,R2    KN2               SET UP INNER LOOP INDEX
         LI,D4    K0                CLEAR MAP ACCUMULATOR
CHAR2    SCS,D1   +8                PLACE 1ST CHARACTER UNDER MASK
         SLS,D4   +12               SHIFT PRIOR CHARACTER MAP AWAY
         LI,R4    K0                 CLEAR A REGISTER
         STS,D1   R4                EXTRACT BCD CHARACTER
         LI,R5    KFF0              CLEAR THE REGISTER AND SET MASK
         SLD,R4   -4                SEPARATE ZONE AND NUMBERIC
         CI,R4    KC                IS CHARACTER ALPHA-NUMBERIC
         BL       CHKINRDN          NO-GET THE NEXT CHARACTER
         CI,R4    KF                IS CHARACTER NUMBERIC
         BE       SETNUM            YES-SET ONLY NUMERIC BIT IN MAP
         LW,R0    ZBIT              SET UP ZONE BIT
         LCW,R4   R4                NEGATE THE ZONE SHIFT COUNT
         LS,R5    R4                EXTRACT ONE BYTE
         SLS,R0   0,R5              SHIFT IT TO THE CORRECT LOCATION
         AW,D4    R0                ADD ZONE BIT TO MAP ACCUMULATOR
SETNUM   LI,R0    NUMBIT            SET UP NUMERIC BIT
         SLS,R5   -12               PUT NUMERIC IN RIGHT PLACE
         LCH,R4   R5                NEGATE THE NUMERIC FIELD
         LI,R5    KFF               SET UP A ONE BYTE MASK
         LS,R5    R4                EXTRACT SHIFT COUNT
         SLS,R0   0,R5              SHIFT IT TO THE CORRECT LOCATION
         EOR,D4   R0                ADD NUMERIC BIT TO MAP ACCUM.
CHKINRDN BIR,R2   CHAR2             IF WE HAVE ONLY DONE 1 CH.GET 2ND
         LI,R5    KN3               SET UP INDE
         AI,R3    K3                SET INDEX FOR 3RD BYTE
LDNXT    STB,D4   *D3,R3            STORE RIGHTMOST BYTE
         SLS,D4   -8                MOVE NEXT BYTE INTO PLACE
         AI,R3    KN1               DECREMENT STORAGE INDEX
         BIR,R5   LDNXT             IF NOT DONE, STORE NEXT BYTE BY LOOP
         AI,R3    K3                SET BUFFER INDEX AFTER 3 BYTES
         BIR,R1   CHAR1             IF WE HAVE ONLY DONE 2 CHAR.REPEAT
         PULL     9,D2              RESTORE REGISTERS
BISR4    B        *SR4              RETURN
*                 FOR CPV-A00 SLEEP IF NO MPOOLS
         PAGE
*
*        GET A MONITOR BUFFER - BUFF WILL PARK SLAVE CPU'S
*
IOGETBF  EQU      %
         PUSH     1,SR4
         BAL,SR4  GMB
         LW,D3    D3
         BEZ      %-2
         B        PULLEXIT
         SPACE    3
         SPACE    3
         REF      Y3                * =X'30000000' PBIT FAKE FOR MSRRDWRT
         REF      PULLALLEXIT       * FLUSH TO PUSHALL ENVIRON,PULL,
*,*                                 * CHECK SR3 AND EXIT APPROPRO
         REF      X1FFFF            * =X'0001FFFF' STANDARD ADDRESS MASK.
         REF      PUSHALL           * R5-SR4&STACK MARKER PUSHED,
*,*                                 * MARKER MAKES FLUSH EASY.
         REF      CHKBIT1           * INITIAL FPT PARSER ENTRY.
*,*                                 * SETS UP FPT PRESENCE&FPT INDEX.
         REF      MSRRDWT           * MONITOR SERVICE READ-WRITE ENTRY.
*,*                                 * NEEDS AN FPT AND DCB.
         REF      RESBTD            * RESTORE BTD VALUES TO DCB.
         DEF      MSROCTY           * MONITOR SERVICE OC TY: OPERATOR
*,*                                 * MESSAGE FUNNEL.
         DEF      MSRTYPR           * MONITOR SERVICE TYPE-ER:(WAS TYPE
*,*                                 * OF IOD-TYPR...NEITHER ANYMORE.
         REF      MSROCWRT          * MONITOR SERVICE OPERATOR'S
*,*                                 * CONSOLE WRITE ROUTINE.
         REF      MSRTY             * MONITOR SERVICE TYPE ROUTINE.
         PAGE
         PAGE
*F*      NAME:         MSROCTY
*F*      ENTRY:        MSRTYPR
*F*      PURPOSE:      QUEUE THE WRITE FOR M:TYPE, M:MESSAGE
*F*                    AND M:PRINT CALS.
         SPACE         1
*D*      NAME:         MSROCTY
*D*      ENTRY:        MSRTYPR
*D*      REGISTERS:    ALL VOLATILE
*D*      CALL:         SR4 IS THE LINK
*D*      INTERFACE:    MSRTY, GETBTD, RESBTD, MSRRDWT, PULLALLEXIT
*D*      INPUT:        R7 = FPT ADDRESS
*D*                    SR1 = 0  M:MESSAGE (WRITE TO OC)
*D*                        = 1  M:PRINT (WRITE THRU M:LL)
*D*                        = 2  M:TYPE (M:UC IF ONLINE, ELSE OC)
*D*      DESCRIPTION:  IF WRITING TO OC (M:MESSAGE OR M:TYPE IN
*D*                    BATCH OR GHOST) MSRTY IS CALLED.
*D*                    OTHERWISE, AN M:WRITE FPT IS BUILT IN THE
*D*                    STACK.  FOR M:TYPE ONLINE, MSRRDWT IS CALLED
*D*                    TO WRITE THRU M:UC.  FOR M:PRINT, THE
*D*                    USER'S DCB CHAIN IS SEARCHED FOR THE
*D*                    ADDRESS OF THE M:LL DCB, AND MSRRDWT IS
*D*                    CALLED TO DO THE WRITE.  NOTHING IS WRITTEN
*D*                    IF THERE IS NO M:LL DCB.
         SPACE         1
MSRTYPR  LI,R6    M:UC              M:TYPE - ASSUME ONLINE
         LC       J:JIT
         BCS,8    MSRTY0            ONLINE
MSROCTY  LI,R6    0                 SPECIAL FLAG FOR OC WRITE
*
MSRTY0   BAL,R1   PUSHALL
         BAL,R2   CHKBIT1           GET BUFFER ADDR IN D1
         AND,D1   X1FFFF            SCRUB INDIRECT BIT
         CI,SR1   1
         BE       MSRTY1            M:PRINT
         AI,R6    0
         BNEZ     MSRTY1            NOT TO OC
         BAL,SR4  MSRTY             GO WRITE TO OC
         B        PULLALLEXIT
*
MSRTY1   LW,SR4   Y3                PARAMETER PRESENCE FLAGS
         LB,D2    *D1               BYTE COUNT
         LW,R7    TSTACK            ADDR OF FPT-1
         PUSH     3,SR4             PUT FPT IN TSTACK
         REF      M:UC              * JIT USER CONSOLE DCB.
         CI,SR1   K1
         BNE      MSRTYPR2
*
*
         LW,R6    J:DCBLINK
         AI,R6    1
LOCDCB1  LW,D3    0,R6
         LB,D1    D3
         CI,D1    K4
         BNE      LOCDCB2
         LW,D4    1,R6
         SLD,D3   8
         CW,D3    M:LL
         BNE      LOCDCB2
         LW,SR2   R6
         LW,R6    2,R6
*
MSRTYPR2 EQU      %
         BAL,D4   GETBTD
         PUSH     1,R4
         LI,D1    K1
         BAL,R0   RESBTD
         LI,SR1   X'11'
         BAL,11   MSRRDWT
         PULL     1,D1              RESTORE BTD
         BAL,R0   RESBTD
MSRTYPR3 EQU      %
         B        PULLALLEXIT
LOCDCB2  EQU      %
         AI,D1    K8
         SLS,D1   -2
         AW,R6    D1                NEXT ENTRY
         LB,D1    *R6
         BNEZ     LOCDCB1
         LW,R6    0,R6
         AND,R6   X1FFFF
         BEZ      MSRTYPR3          NO M:LL :=> NOP
         AI,R6    K1
         B        LOCDCB1
M:LL     TEXT     'M:LL'
         CLOSE    BUFX  SINCE 'BUFX' IS DEFINED IN SYSTEM UTS ALSO
         END

