*
*
*M*      OPNLD     OPEN LOGICAL DEVICE STREAM(COOP CONTEXT INIT)
*
*
*
*
*P*      NAME:     OPNLD
*,*
*,*      PURPOSE:            THIS MODULE IS THE MAIN PACKAGE CONTAINING
*,*           MOST OF THE SOFTWARE PERTINENT TO COOP-CONTEXT-BLOCK
*,*           OPENING AND CLOSING(SUPCLS IS THE SECONDARY PACKAGE).
*,*           IT IS OVERLAID (IN MULOV) BECAUSE THESE ACTIVITIES ARE
*,*           RELATIVELY RARE IN A SESSION OR JOB.  THE ROUTINES ARE ENTERED
*,*           MAPPED AS A RESULT OF SOME USER CAL ON A COOP DEVICE DCB.
*,*
*,*
*,*      METHOD:             A COOP-CONTEXT-BLOCK IS IMPLICITLY
*,*           OPENED BY THE FIRST OPEN CAL ON A DCB POINTING TO THE
*,*           STREAM.  ENTRY OPNLD IS USED FOR THIS PURPOSE.  IT IS
*,*           EXPLICITLY CLOSED AND REOPENED (OR OPTIONALLY LEFT CLOSED)
*,*           BY AN M:LDEV CAL.  ENTRY T:LDEV IS USED FOR THIS.  FINALLY
*,*           ALL CONTEXT BLOCKS ARE CLOSED BY THE SUPERCLOSE CAL1,9 6
*,*           WHICH IS HANDLED BY MODULE SUPCLS.  THE ENTRY COPOPNLD
*,*           IS USED WHEN A DCB IS FOUND POINTING TO A CLOSED COOP-
*,*           CONTEXT-BLOCK BECAUSE THE COOP-CONTEXT-BLOCK MAY BE
*,*           CLOSED WITHOUT CLOSING THE DEVICE DCB.  ASIDE FROM THESE
*,*           MAIN ENTRIES THE FOLLOWING ARE THE SIGNIFICANT ROUTINES
*,*           HEREIN:
*,*
*,*                OPNMAIN   CALLED BY OPNLD OR COPOPNLD
*,*                CHKLDCF   CHECK USERS LOGICAL DEVICE CONTROL FLAG
*,*                          TO SEE IF HE HAS PERMISSION TO USE THE
*,*                          DEVICE.
*,*                FINDDSC   FIND THE CONTEXT BLOCK AND ACQUIRE IT IF
*,*                          ITS NOT THERE(THERE ARE NONE).
*,*                SCINIT    INITIALIZE THE CONTEXT BLOCK WITH DEFAULT
*,*                          VALUES
*,*                ALLSBSB   ACQUIRE THE DATA BUFFER FOR THE CONTEXT BLOCK
*,*                FPTMRG    MOVE M:LDEV FPT INFO TO CONTEXT BLOCK
*,*                CHKBIT    PARSE THE M:LDEV FPT
*,*                COPDCB    SETUP THE NEWQ ARGUMENTS IN THE CONTEXT BLOCK
*,*                COOPHDOP  PRODUCE ANS TAPE LIKE HEADER RECORDS FOR
*,*                          AN OCP(X1200 SHAMROCK) STREAM.
*,*                COOPHDR   PRODUCE BANNER (AND LACE) RECORDS APPROPRIATE
*,*                          FOR THE STREAM
*,*                CNVTINDX  CONVERT THE USERS JIT WORD 0 SYSID
*,*                GETDCBN   LOOKUP THE DCB NAME IN DCBNAME TABLE TO
*,*                          DETERMINE ACCOUNTING(IF M:DO).
*,*
*,*
*,*      REFERENCE:          MODULES COOP AND SUPCLS ALSO CONTAIN
*,*           INFORMATION PERTINENT TO THE FUNCTION OF THIS MODULE.
*,*
*,*
         DEF      OPNLD:            * MODULE BASE UDEFED FOR XDELTA
*,*                                 *   PATCHING EASE.
OPNLD:   EQU      %
MONPROC  SET      1
UFLAGS   SET      1                 UH:FLG EQU'S
BITS     SET      1                 GET DEFINITIONS OF XN,YN,MN.
         SYSTEM   UTS
         DEF      OPNLD             * MAIN ROUTINE ENTRY POINT OF MODULE.
*,*                                 * OPEN LOGICAL DEVICE STREAM FOR DCB.
         DEF      COPOPNLD          * SECONDARY ENTRY TO OPNLD FROM COOP.
*,*                                 * WRTD,IOD,POS SOMETIMES FIND CLSD STRM.
         DEF      T:LDEV            * M:LDEV CAL HANDLER. IMPLIED CLOSE.
*,*                                 * THEN EXPLICIT REOPEN OF STREAM.
         DEF      COOPHDR           * WRITE BANNER TO STREAM.
         PAGE
         REF      YFF               * MASK
         REF      SCDEVTYP          * CNTXT DISP TO DEV.TYP AND FLAG CELL.
         REF      SCMINR            * CNTXT TO MINIMUM REC SIZE.
         REF      SCMAXR            * CNTXT TO MAXIMUM REC SIZE.
         REF      SCMISC            * CNTXT TO MISC DATA AREA.
         REF      SCFPC             * CNTXT TO FORM PROJECTOR CNTRL.
         REF      SCFORM            * CNTXT FORM NAME.
         REF      SCFQARGS          * CNTXT FILE NEWQ ARGUMENTS.
         REF      SCFFORM           * CNTXT FUTURE FORM NAME.
         REF      SCSVDGI           * CNTXT SAVED GHOST INFO.
         REF      SBSIZE            * COOP DATA BUFFER SIZE.
         REF      COPEA00           * COOP END ACTION HANDLER.
         REF      1STDBI            * FIRST DATA BYTE INDEX VALUE.
*,*                                 * PARAMETERIZED BLOCK PREAMBLE LEN.
         REF      SCSEQ             * CNTXT SEQUENCE SPECIFICATION.
         REF      SCFLDA            * CNTXT FLINK DISC ADDR.
         REF      SCBESTDA          * CNTXT BEST DISC ADDR.
*,*                                 * FILES OLDEST BLOCK.
         REF      SCCDA             * CNTXT CURRENT DISC ADDR.
         REF      SCFBUF            * CNTXT FILE BUFFER ADDR.
         REF      SCBLDA            * CNTXT BLINK DISC ADDR.
*,*                                 * PREVIOUS BLOCK.
         REF      SCDBI             * CNTXT DATA BYTE INDEX.
*,*                                 * CURRENT BLOCK BLOCKING POSITION.
         REF      SCCUN             * CNTXT CURRENT USER NUMBER.
*,*                                 * HE GETS THE IO COMPLETE EVENT(UNMAPPED).
         REF      SCRPDA            * CNTXT RELEASE PREVIOUS DISC ADDR.
*,*                                 * INCOOP EA CUDNT REL THIS D.A.
         REF      COP05             * SUPCLS ROUTINE TO CLOSE A SINGLE
*,*                                 * STREAM(CONTEXT BLOCK).
         REF      J:ACCN            * JIT WORDS CONTAINING ACCOUNT
*,*                                 * USED FOR BANNER.
         REF      PUF               * PROCESSOR USER FLAG USED TO SET
*,*                                 * DCB ACCOUNTING TYPE.
         REF      CC1SET            * EXIT TO USER WITH CC1 SET.
*,*                                 * SAYS M:LDEV CAL BAD.
         REF      JB:PRIV           * USER'S PRIVILEGE LEVEL.
*,*                                 * IS HE AUTHORIZED??.
         REF      Y00FF             * =X'00FF0000' BYTE 1 MASK.
         REF      BL:IFS            CHECK IF ENOUGH SPACE  28871-F00
         REF      BL:OFS            IN SYMBIONT FOR SPILL  28871-F00
         REF      SNDDXSIZ          FILL OPERATIONS        28871-F00
         REF      SCBSIZ            FILL TERMINATE         28871-F00
         REF      COP17AP5          FORCE WRITE LAST GRAN  28871-F00
         REF      HEX               * TABLE OF VALUES TO MAKE SYSID
*,*                                 * PRINTABLE.
         REF      TB:SZ             * DEVICE MINIMUM WIDTH OTABLE OR
*,*                                 * NUMBER OF LINES-PER-PAGE DEFAULT.
         REF      TB:MAX            * DEVICE WIDTH TABLE.
         REF      TB:FLGS           * FLAG TABLE DEFINES THE DEVICE.
         REF      J:USCDX           * COPTAB POINTER(ADDR OF CNTXT PAGE)
*,*                                 * 0 MEANS NONE THERE YET.
         REF      J:JIT             * USER'S JOB INFORMATION TABLE BASE.
         REF,2    JH:LDCF           * HALFWORD BIT TABLE(LOGICAL DEVICE
*,*                                 * CONTROL FLAGS), AUTHORIZATION FOR DEVS.
         REF      J:BASE            * 12 WORD TEMP AREA SEE WRTD FOR DEFN.
         REF      SV:RSIZ           * SYSTEM VALUE(NUMBER OF RESOURCE TYPS).
         REF      SV:LSIZ           * SYSTEM VALUE(NUMBER OF LOGICAL STRMS).
         REF      SH:LNM            * HW TABLE OF LOGICAL STREAM NAMES.
         REF      TYPMNSZ           * NUMBER OF DEV NAMES IN SYSTEM.
         REF      SB:LTY            * DEFAULT DEV TYPE BY STREAM TABLE.
         REF      SH:SYMT           * NAMES OF SYMBIONT LOCAL DEVICES.
         REF      SV:TYM            * SYSTEM VALUE: NUMBER OF SYMBIONT DEVS.
         REF      XFF               * =X'000000FF' BYTE 3 MASK.
         REF      DCTSIZ            * SIZE OF DEVICE TABLES(DCTS).
         REF      Y00FE             * =X'00FE0000' MASK FOR DCB FUN.
         REF      OH:NM             * TABLE OF DEVICE TYPE NAMES(TYPMNE)..
         REF      JCOVPA            * MAP DISP(PGE#) OVP(MM ARG).
         REF      JCO2VPA           * MAP DISP(PGE#) 2ND OVP(MM ARG).
         REF      T:GBUF            * ALLOCAT A WINDOWABLE PAGE ROUTINE.
         REF      COPGSB            * FETCH A DATA BLOCK FROM POOL ROUTINE.
         REF      COPGSG            * FETCH A DISC GRANULE FOR COOP ROUTINE.
         REF      CBSIZE            * CNTXT BLOCK SIZE.
         REF      SCRCO             * CNTXT RECORD COUNT CELL.
         REF      SCPCO             * CNTXT PAGE COUNT CELL.
         REF      SCLINES           * CNTXT BLOCK LINE COUNT.
         REF      SCGCO             * CNTXT GRANULE COUNT CELL.
         SREF     HASPIO            * NAME OF PARENT MODULE FOR IRBT.
*,*                                 * IRBT PRESENCE IN SYSTEM.
         REF      COP20B            * COMMON COOP FILE IO ROUTINE.
         REF      COP08A            * COMMON COOP IO WAIT ROUTINE.
         REF      SCDCDA            * USED BY H%CMP AS A VFC MARKER
*,*                                 * SPACE SUPPRESSION FLAG.
         REF      SCCOMID           CNTXT DISP TO COMODE ID
         REF      SCCOMFLG          CNTXT DISP TO COMODE FLAGS
         REF      SH:COMID          SEED FOR COMODE ID'S
         REF      INHIB             FLAG BIT IN SCCOMFLG TO INHIBIT
*,*                                 BANNER PRINTOUT BETWEEN 'CHUNKS'
         REF      JB:FBUL           * FPOOL SPARE UPPER LIMIT-RESET WHEN
*,*                                 *  COOP SPARE IS NOT AVAILABLE
         REF      JX:CMAP           * USERS MAP-SEARCHED FOR FREE PAGE
         REF      FPMC              * USED TO FIND FREE PAGE
         REF      MSTRUNC           * TRUNCATE FPOOL BUFFERS SO WE CAN
*,*                                 *  GET COOP BUFFER
         REF      T:RVSPI           * RELEASE VIRTUAL, SAVE PHYSICAL PAGE
         REF      T:GVGPI           * GET VIRTUAL, GIVEN PHYSICAL PAGE
         REF      RBBSPCL           * GHOST FUNCTION CODE FOR RBBAT
*,*                                   SPECIAL FUNCTIONS
         REF      RSTSFC            * RBBAT'S SPECIAL FUNCTION SUBCODE
*,*                                   FOR RESETTING RBBAT'S DATA
         REF      S:SGCSAV          *IN/OUT : CELL FOR SAVING SGCHD HEADS
         REF      SGCBUF            *INPUT : START OF COM BUFFS
         REF      SGCHD             *INPUT : HDS & TLS OF COM BUFF
*,*                                           CHAINS FOR RBBAT COMM
         REF      SGCQA3            *CALLED : ROUTINE TO LINK IN A
*,*                                   COMM BUFF ON RBBAT'S CHAIN
         PAGE
*                 SYMBOLIC REGISTER DEFINITIONS.
R0       EQU      0
R1       EQU      1
R2       EQU      2
R3       EQU      3
R4       EQU      4
R5       EQU      5
R6       EQU      6
R7       EQU      7
R8       EQU      8
SR1      EQU      8
R9       EQU      9
SR2      EQU      9
R10      EQU      10
SR3      EQU      10
R11      EQU      11
SR4      EQU      11
R12      EQU      12
D1       EQU      12
R13      EQU      13
D2       EQU      13
R14      EQU      14
D3       EQU      14
R15      EQU      15
D4       EQU      15
*
*
C1LDEVX  EQU      1                 INDEX INTO SH:LNM FOR LDEV 'C1'
HASPBIT  EQU      Y04               HASP BIT IN CONTEXT BLOCK.
OCPBIT   EQU      Y0008             OCP BIT IN CONTEXT BLOCK.
         PAGE
*F*      NAME:     COPOPNLD
*,*
*,*      PURPOSE:            TO REINITIALIZE A CLOSED CONTEXT BLOCK
*,*           DISCOVERED AT WRITE TIME CONNECTED TO AN OPEN DCB.
*,*
*,*      DESCRIPTION:        COOP/WRTD/IOD OR POS WAS ENTERED TO PERFORM
*,*           A SERVICE WHICH REQUIRED A WRITE TO A CLOSED CONTEXT
*,*           BLOCK WHEREUPON THAT ROUTINE ENTERD HERE TO OPEN THE
*,*           CONTEXT BLOCK.  THIS IS SPECIAL IN THAT THE STATE OF
*,*           THE STACK AND THE ERROR REPORTING MECHANISM ARE DIFFERENT
*,*           OTHERWISE THE PROCEDURE IS AS DESCRIBED FOR OPNLD.
*,*
*
COPOPNLD EQU      %
         PUSH     7,R5
         BAL,SR4  OPNLD
         LI,SR3   0                 NORMAL RETURN
         LW,D1    SR3               IF ERROR, OPNMAIN RETURNS HERE
         PULL     7,R5
         LW,SR3   D1                ERROR CODE(IF ANY)
         B        *SR4
         PAGE
*F*      NAME:    OPNLD
*F*      PURPOSE: TO ATTACH A LOGICAL STREAM (REPRESENTED BY A COOP
*F*               CONTEXT BLOCK) TO A DCB. THE STREAM IS INITIALIZED
*F*               IF IT IS UNOPEN.
*D*      NAME:    OPNLD
*D*      CALL:    BAL,SR4 OPNLD
*D*               <NORMAL RETURN>
*D*               <ERROR RETURN; SR3 CONTAINS ERROR CODE & SUBCODE>
*D*      ENVIRONMENT: MASTER MAPPED.
*D*      INPUT:   R6= DCB ADDRESS. PUSHALL IN STACK.
*D*      DESCRIPTION: IF THE STREAM IS ALREADY OPEN, THE DCB IS SET
*D*               UP WITH DCB:FUN FROM SCDEVTYP BITS AND ACCOUNTING
*D*               TYPE IS DETERMINED AND STORED INTO DCB:CLK.
*D*               IF THE STREAM IS NOT OPEN, IT IS OPENED..
*D*               THE CONTEXT BLOCK IS INITIALIZED.
*D*               IF INPUT, THE APPROPRIATE SYMBIONT INPUT FILE IS
*D*                 GOTTEN AND ITS FIRST DISKADDR PLACED IN THE C.B.
*D*               IF OUTPUT, A BANNER LINE IS BUILT IF NEEDED.
*D*
OPNLD    EQU      %
         PUSH     SR4
         LW,R3    DSI,R6
         AND,R3   XFF               LOGICAL DEVICE INDEX IN DCB
         AI,R3    -(DCTSIZ+1+SV:RSIZ+1)  LDEVX AS COOP KNOWS IT
         LB,R2    SB:LTY,R3         DEFAULT DEV TYP
         BAL,R4   FINDSC            FETCH CONTXT BLOCK ADDR FOR THIS LDEV
         B        %+2
         B        OPNLD0
         BAL,SR2  CBINIT              NEW STREAM; GET C.B. & INIT.
*
* AT THIS POINT WE HAVE A CONTEXT BLOCK WITH ADDR IN SR3.
*
         BAL,SR4  CHKLDCF             CHECK SYMBIONT DEV. AUTH.
         B        OPNLD0            ---> IT'S GOOD.
         LC       J:JIT               NO GOOD, BUT A BATCH COMMAND
         BCS,12   NONAUT              PROCESSOR CAN OPEN ANY
         LW,R4    S:CUN             THING HE WANTS -- THIS IS
         LH,R4    UH:FLG,R4         BECAUSE CCI NEEDS CR AND
         CI,R4    TIC               LP TO TELL THE GUY HE
         BANZ     OPNLD0            IS ABORTED
NONAUT   EQU      %
         LI,SR3   X'48'             *** USER NOT AUTHORIZED
*E*      ERROR:   48-00.
*E*      MESSAGE: PERIPHERAL USE FLAG NOT SET FOR THIS DEVICE.
         B        ABORT%HIM         TELL HIM
OPNLD0   LI,D1    0
         LW,D2    Y8                RESET BIT 0 IN STREAM POINTER
         STS,D1   *J:USCDX,R3       TO SIGNAL STREAM IS OPEN
*
*   NOW SET UP DSI FIELD OF DCB WITH INFO FROM CONTEXT BLOCK.
*
         LW,R3    SR3               CNTXT BLK ADDR
         LW,D1    SCDEVTYP,R3       TAKE FUNCTION FROM CNTXT BLK
         SLS,D1   -14               ADJUST AND MAKE
         AI,D1    X'20000'          IN=1,OUT=2
         AND,D1   Y00FE             ISOLATE FUN; CLEAR OTHERS.
         LW,R2    SCDEVTYP,R3       GET FLAGS, DEV TYPE.
         LW,D2    SCSVDGI,R3        IF RBID
         AND,D2   Y00FF               IS NOT THERE,
         BEZ      LCLSTRM             SET UP DSI FOR LOCAL STREAM.
*
RBSTRM   EQU      %                 * SET UP DSI FOR NON-LOCAL STREAM *
         SLS,R2   16                SHIFT FLAGS BYTE TO BYTE 0.
         LC       R2                SET CCS WITH FLAGS (LIKE TB:FLGS).
         BCS,8    %+3               IF X'01XX' (LISTING),
         BCR,4    %+2                 SET 'L' AND ASSUME LP (DEV 6).
         AI,D1    X'4200'           (NOTE: POSITIVE RESULT SETS CC2.)
         BCS,2    %+2               IF X'XX0X' (NOT IN),
         AI,D1    X'100'              ASSUME CP (DEV 5).
         AI,D1    X'400'            ELSE ASSUME CR (DEV 4).
         B        RSETDSI           SET DSI WITH ACTUAL STRM ATTRIBUTES.
*
*
LCLSTRM  EQU      %                 * SET UP DSI FOR LOCAL STREAM *
         AND,R2   M8                ISOLATE DEV TYPE.
         LC       TB:FLGS,R2        SET 'L' BIT
         BCS,8    %+3                 IF THIS
         BCR,4    %+2                 DEVICE IS
         AI,D1    X'4000'             LISTING TYPE.
         SLS,R2   8                 SHIFT DEV TYPE FOR DSI STORE.
         AW,D1    R2                CREATE DSI FROM FUN, L, DEV TYPE.
*
RSETDSI  EQU      %                 * SET DSI FIELD *
         LW,D2    XFFFF00           MASK LEAVES STREAM ID ALONE.
         STS,D1   DSI,R6            OF THIS DCB
         MTW,0    SCBESTDA,R3       IS STREAM OPEN TO A FILE
         BNEZ     OPNLD2A           *
         LW,D2    SCCOMFLG,R3       * ARE WE FILLING
         CI,D2    X'40'             *  SOME THINGS
         BAZ      OPNLD2            * NO, AND NO FILE OPEN
         LI,2     6                 * SET UP STREAM
         LI,D2    X'53'             *  LIKE A GOOD OUTPUT
         STB,D2   *3,R2             *   STREAM
         B        OPNLD2            * AND GO GET DISK ADDRESS
OPNLD2A  EQU      %
         LW,D2    SCCOMFLG,R3
         CI,D2    X'20'              IF OPEN, IS IT SPILL...
         BAZ      OPNLDXIT           NO. DONE.
         LI,R2    X'1FFFF'
         AND,R2   FPARAM,R6
         BEZ      OPNLDXIT           ALSO DONE IF NOWHERE TO REPORT.
*
*
*
*
*
*
*
*
         LW,D1    L(X'1A000000')    W0: M:LDEV
         LW,D2    L(X'F1BE0810')    W1:  PPW.
         INT,R1   0,R3
         LH,D3    SH:LNM,R1
         AND,D3   M16               P1:  (STREAM)
         LI,R1    X'FF'
         AND,R1   SCFPC,R3          GET THE DEVICE CODE FIRST
         LW,D4    L(X'00FF0000')
         CW,D4    SCSVDGI,R3        IS IT LOCAL OR REMOTE
         BANZ     OPNLD2B            IT LOOKS LIKE REMOTE
         LH,R1    OH:NM,R1          GET TEXT NAME
         AND,R1   M16                WITH EXTRA BIT OFF
OPNLD2B  STW,R1   D4                  READY FOR FPT
         LCI      4
         STM,D1   0,R2
         INT,D1   SCSVDGI,R3
         AND,D1   M8                P3:  RBID
         LI,D2    3                 P4:  'FILL'
         LW,D3    SCMISC,R3
         SLD,D3   -8
         AND,D3   M8                P8:  JDE
         SLS,D4   -24               P9:  COPIES
         LCI      4
         STM,D1   4,R2
         LW,D1    SCFPC,R3          P11: RBBATS FLAGS AND DEV TYPE
         LW,D2    SCFORM,R3         P12: FORM NAME HERE
         LW,D3    SCSVDGI,R3
         SLS,D3   -24               P13: PRIORITY
         LI,D4    0                 P14: RESERVED
         LCI      4
         STM,D1   8,R2              INTO THE FPT
         LI,D1    0                 P15: RESERVED
         INT,D2   SCSVDGI,R3        GET SYSID
         LW,D3    SCFFORM,R3        GET GRANULE COUNT
         SLS,D3   -16
         STH,D3   D2                P21: GRAN COUNT/SYSID
         LCI      2
         STM,D1   12,R2             FPT COMPLETE
         B        OPNLDXIT          ---->  DONE
OPNLD2   EQU      %
*
* WE ASSUME THIS IS THE FIRST OPEN TO THIS STREAM SINCE IT DOES NOT
* HAVE A STARTING DISC ADDRESS.
*
         BAL,SR4  COPDCB            INITIALIZE CNTXT DCBS
         LI,SR4   -1
         STW,SR4  SCBLDA,R3         SIGNAL NEW FILE FOR COOP.
         LW,SR4   S:CUN
         STW,SR4  SCCUN,R3          STORE USER NO.
         MTW,0    SCDEVTYP,R3
         BGEZ     GETIF             INPUT STREAM
*
* FINAL INITIALIZATION OF AN OUTPUT CONTEXT BLOCK
*
         BAL,SR4  COPGSG            GET DISC GRANULE
         STW,R0   SCBESTDA,R3       STARTING DISC ADDR
         STW,R0   SCCDA,R3          CUR DISC ADDR
         BAL,SR4  COPGSB            GET COOP BLKNG BUFFER &MAP WNDW
         LW,D1    SCDEVTYP,R3
         CW,D1    LGLHDR            PUNCH OR LISTING DEVICE
         BAZ      OPNLDXIT          NOPE
         LC       J:JIT
         BCS,8    %+3               SKIP TEST IF ON-LINE
         MTW,0    J:ACCN            DON'T ISSUE HEADER 1ST TIME
         BEZ      OPNLDXIT
         BAL,SR4  COOPHDR           OUTPUT HEADER FOR NEW FILES.
         B        OPNLDXIT
*
*        GET AN INPUT FILE
*
         REF      GETI              * RBBAT TO COOP CONTROL STREAM ARGUMENT
*,*                                 * PASSER, SETS JIT AND PASSES D.A.
         REF      GIFNC             * RBBAT GHOST FUNCTION CODE-GET
*,*                                 * INPUT FILE NON-CONTROL.
         REF      S:CUN             * CURRENT USER'S SYSTEM NUMBER.
         REF      SGC:NCB           * PARK USER FOR SYMB GHOST COMMUNICATION
*,*                                 * -REASON: NO COMMUNICATION BUFFER.
         REF      E:QA              * PARK EVENT: QUEUED FOR ACCESS.
*,*                                 * THAT'S ACCESS TO RBBAT.
         REF      T:REG             * SCHED ROUTINE TO PARK A USER.
         REF      SGCR              * RELEASE RBBAT COMMUNICATION BUFFER.
         REF      SGCQ              * ACQUIRE AND FILL A RBBAT COMMUNICATION
*,*                                 * BUFFER(SYMB GHO COMM QUE).
         REF      SGCQ2             * ACQUIRE/FILL 2 RBBAT COMMBUFFS.
GETIF    EQU      %
         INT,R1   0,R3                (CB HAS STREAM# IN W0)
         CI,R1    C1LDEVX           CONTROL INPUT STREAM
         BNE      GETIF1            NO
         LC       J:JIT             ACCESS ALLOWED ONLY
         BCS,12   NONCIF            FOR BATCH USERS
         BAL,SR4  GETI
*        GETI     USES R1,R5,R14,R15, AND RETURNS THE
*                 DISC ADDR IN SR1. IF NONE AVAILABLE, GETI WILL HAVE
*                 TRIGGERED A S. C. BY NOW.
         B        GETIF3
*
*        G I F N C - GET NON-CONTROL INPUT STREAM
*
GETIF1   EQU      %
         LI,SR4   X'20'
         CW,SR4   SCCOMFLG,R3       * DID WE GET HERE FOR A SPILLFILE?
         BANZ     NONCIF            --->YES. MUST BE FILE NONEXIST.
*                                   * BUILD RBBAT COMM BUFFER:
         LW,D2    SCSVDGI,R3        *
         SLS,D2   -16               * W2B4= RBID IF ANY.
         LW,D3    S:CUN             *
         STB,D3   D2                * W2B1= USER#.
         LI,R4    2
         LI,D3    X'22'             ASK FOR NCCTL PRIORITY
         STB,D3   D2,R4             IN COM BUFFER
         LI,D1    X'FF'             NOW GET DEVICE TYPE
         AND,D1   SCDEVTYP,R3       FROM CONTEXT BLOCK
         SLS,D1   8
         AI,D1    GIFNC             SO RBBAT KNOWS WHAT WE WANT
         LW,D3    SCFORM,R3         GET FORM NAME FORM CNTX BLK
         BAL,4    SGCQ
         B        SGC:NCB
         PUSH     R6
GETIF2   LI,R6    E:QA
         BAL,11   T:REG
         AI,1     1                 POINT AT COM WORD 1
         MTB,0    *1                S:CUN STILL THERE
         BEZ      %+2               NO, GHO FILLED IN DISC ADDR
         BDR,R1   GETIF2
         AI,R1    -1                POINT BACK TO COMBUF START
         PULL     R6
         LW,SR1   1,R1              DISC ADDR
         BAL,4    SGCR              RELEASE GHO COM BUF
         CI,SR1   0
         BNE      GETIF3            GOT A GOOD DISC ADDR
*                                   RBBAT UNSUCCESSFUL...
*                                   UNDO THE DAMAGE
*                                   AND EXIT ABNORMALLY
NONCIF   LI,SR3   X'03'             *** NO INPUT FILE.
         LW,R3    0,R3
*E*      ERROR:   03-00.
*E*      MESSAGE: FILE DOES NOT EXIST.
         B        ABORT%HIM
GETIF3   LW,R3    SR3
         STW,SR1  SCBESTDA,R3       STARTING DISC ADDR
         STW,SR1  SCCDA,R3          CUR DISC ADDR
OPNLDXIT EQU      %
*
* UPDATE STREAM ACCOUNTING TYPE IN WD 12, BITS 20-23 OF DCB.
*        (R3) = CONTEXT BLK ADDR
*
         LW,R2    0,R3              R2= LDEVX.
         LW,14    Y002
         CW,14    FCD,R6              IF DCB OPEN,
         BAZ      ACCTCLS
         LI,14    X'F00'
         AND,14   CLK,R6
         CI,14    X'100'              AND NAMED M:DO,
         BE       ACCTDO            ---> KEEP IT SO.
         B        ACCTT             ---> NOT M:DO; LOOK IT UP.
ACCTCLS  LW,R1    TSTACK
         LW,R1    -5,R1               IF CLOSED, M:OPEN. THUS R8 OF
         CI,R1    X'10'
         BANZ     ACCTDO
ACCTT    EQU      %
         LW,D1    SCDEVTYP,R3
         CW,D1    Y002              PUNCH DEVICE
         BANZ     ACCTPO            YES
         CI,D1    X'4000'           LISTING DEVICE
         BAZ      ACCTNO            NO: MEANS NO ACCT'ING
         LW,D1    J:JIT+PUF
         CW,D1    Y001              USER RUNNING...
         BANZ     ACCTUO
*
*        FALL THROUGH TO LO-TYPE ACCOUNTING...
*
ACCTLO   AI,2     X'100'            ACCT TYP = 4
ACCTUO   AI,2     X'100'            '     '  = 3
ACCTPO   AI,2     X'100'            '     '  = 2
ACCTDO   AI,2     X'100'            '     '  = 1
ACCTNO   EQU      %                 '     '  = 0
         LI,R3    X'FFF'
         STS,R2   CLK,R6              PUT INTO CLK.
         PULL     SR4
         B        *SR4              NORMAL EXIT
*
*        ABNORMAL EXIT
*        ERROR/ABNORMAL CODE RIGHT-JUSTIFIED IN SR3
*
ABORT%HIM EQU     %
         LI,R0    0
         LW,R1    Y2
         STS,R0   *J:USCDX,R3         MARK C.B. AS NOT IN USE.
         PULL     SR4
         AI,SR4   1                 AND TAKE ABNORMAL
         B        *SR4              EXIT
         PAGE
*F*      NAME:     T:LDEV
*,*
*,*      PURPOSE:            TO HANDLE THE M:LDEV CAL1,8 .
*,*
*,*      DESCRIPTION:        THE STREAM ID IS VALIDATED AND CONVERTED
*,*           TO A CONTEXT NUMBER USED TO LOCATE THE CONTEXT BLOCK.
*,*           THE STREAM DEVICE TYPE IS DETERMINED AND THE USER IS
*,*           CHECKED FOR DEVICE AUTHORIZATION AND REMOTE AUTHORIZATION
*,*           IF THE DEVICE IS REMOTE.  THE PREVIOUS STREAM ON THE
*,*           CONTEXT BLOCK IS CLOSED, THE CONTEXT BLOCK REINITIALIZED
*,*           IF REQUESTED, AND THE OTHER FPT PARAMETERS ARE MERGED.
*,*           IF EVERYTHING IS OK THE SELFDESTRUCT EXIT IS TAKEN,
*,*           OTHERWISE THE ABN CODE IS PLACED IN THE USERS SR3 AND
*,*           T:LDEV EXITS WITH CC1 SET TO WARN HIM OF THE ABNORMALITY.
*,*
T:LDEV   EQU      %
* ENTERED VIA CAL1,8 BY LDEV PROCESSOR
*(R7)=ADDR PLIST+1
*
         PUSH     11                SAVE RETURN
*C*
*C*      VALIDATE CALLER'S REQUEST FOR SPILL FILL          F00
*C*      FUNCTIONS.  MUST HAVE PROPER FPT AND PRIVELEDGE   F00
*C*      CALLER MUST SET SR1 TO FUNCTION REQUESTED         F00
*C*      I.E. SR1  =  X'0000E2D7' FOR SPILL                F00
*C*           SR1  =  X'0000C6C9' FOR FILL                 F00
*C*
*C*                                                        F00
*C*      SR1 WILL BE USED TO PASS INFO BACK TO USER        F00
*C*          AND WE NEED TO BE SURE USER KNOW'S THIS       F00
*C*
         INT,R11  0,R7              GET P1-P4 PAR BITS.
         BCS,8    SPFI1             OK, SO FAR
         B        %+2               NO STREAM, FORGET IT.
SPFIEP1  PLW,D2   TSTACK            DONT LOSE STACK
SPFIE    LI,SR1   BADFCN            NO STREAM, CAN'T DO.
         B        LDEVERR
SPFI1    BCR,1    RBB%SPL           CHECK FOR THIS NEXT
*
         LI,4     2                 GOT THIS MANY NOW
         INT,D3   0,R7              HOW ABOUT P2 AND P3
         BCR,4    %+2
         AI,4     1
         INT,D3   0,R7
         BCR,2    %+2
         AI,4     1
         LW,D2    *R7,R4            GET DIRECTION CONTROL
         LB,D3    JB:PRIV           MAY NEED IT.
         LI,R3    -8                POINT TO USERS SR1
         LW,D1    *TSTACK,R3         AND GET IT IN.
         LW,D4    0,R7              GET PARAM PRES WORD
         PSW,D2   TSTACK            DON'T KEEP DECODING IT
         CI,D2    3                  IS IT FILL
         BE       FILL1             VALIDATE IT
         CI,D2    2                 HOW ABOUT SPILL
         BNE      LDEV0             DO THE OTHER TYPE THINGSS
         CI,D1    C'SP'              IS THE CONTROL REG RIGHT
         BNE      SPFIEP1             NO, NOT ALLOWED
         CI,D4    X'AF'             OPTIONS?
         BANZ     SPFIEP1            NO OTHERS ALLOWED
         CI,D4    X'50'               AND NOT BOTH
         BE       SPFIEP1             AS IT'S ILLOGICAL, BUT COULD BE
         CW,D4    NSPILLFPT
         BANZ     SPFIEP1           AND NO EXTRA PARAMETERS
SPILL3   CW,D4    Y001              LOOK FOR PRIORITY
         BAZ      %+2               FORM NAME IS OPTIONAL
         AI,4     1
         CW,D4    Y0008             IS PRIORITY WORD HERE
         BAZ      SPFIEP1           GOT TO SPECIFY PRIORITY.
         CI,D4    X'40'             DELETE MODE OPEN
         BAZ      SPILL3A            NO, PRIORITY CHECK NEXT
         CI,D3    X'C0'             YES, BEST BE C0 OR BETTER
         BL       SPFIEP1           OR REQUEST DENIED
SPILL3A  EQU      %
         AI,4 1
         LW,D1    *R7,R4            GET IT
         CI,D1    X'F000'           LOW PRIORITY
         BAZ      SPILL5            JCL SPILL NEED B0
         CI,D1    X'F0'             HIGH PRIORITY
         BAZ      SPILL5             JCL SPILL NEED B0
         CH,D1    SPCNT1            X'1010'
         BE       SPFIEP1           CAN'T DO RUNNING
SPILL4   CI,D3    X'A0'             PRIVELEDGE OK?
         BGE      LDEV0              YEP
         B        SPFIEP1              NOPE
SPILL5   CI,D3    X'B0'             HIGH ENOUGH?
         BGE      LDEV0             OK
         B        SPFIEP1           NOPE
FILL1    CI,D1    C'FI'             IS IT RIGHT CONTROL
         BNE      SPFIEP1           NOPE
         CW,D4    L(X'0E41F7AF')    FPT MUST BE EXACT
         BANZ     SPFIEP1            OR IT GETS ERRORED
         LW,D1    D4                NO EXTRA BITS ON
         SLS,D1   -8                ANY ONES OFF
         CW,D1    L(X'F1BE08')      SINCE ALL INFO IS REQUIRED
         BNE      SPFIEP1           ALSO IS BAD NEWS
         LI,R4    9
         LW,R12   *R7,R4            VALIDATE REQUEST
         CI,R12   X'F0'               JCL
         BANZ     FILL101              NOPE
         CI,D3    X'C0'             NEED HIGH PRIVILEDGE
         BL       SPFIEP1            TO DO THIS
         LW,D1    BL:IFS              PROVIDING ENOUGH ROOM
         CI,D1    SNDDXSIZ+3
         BLE      FILL2ER              IN SYMBIONT TABLES
FILL101  CI,D1    X'10'             RUNNING PRIORITY
         BE       SPFIEP1            NO CAN DO
FILL2A   LW,D1    BL:OFS            NOW CHECK THIS
         CI,R12   SNDDXSIZ+3         THIS IS LOW THRESHOLD
         BG       SPILL4            OK, DO IT
FILL2ER  LI,4     -9                POINT TO USERS SR1
         LI,R8    -1
         STW,R8   *TSTACK,R4         TELL HIM TOO LOW ON SPACE
         B        SPFIEP1           AND EXIT
LDEV0    EQU      %
         LI,R4    1
         LW,D1    *R7,R4            USE STREAM ID IN PLIST
         LI,D2    X'FFFF'           TO FIND CORRESPONDING
         LI,R3    SV:LSIZ           INDEX INTO SH:LNM
LDEV1    LH,D3    SH:LNM,R3         (HEREIN CALLED LDEVX)
         CS,D1    D3
         BE       LDEV2             GOT A MATCH
         BDR,R3   LDEV1
LDEV1AA  PLW,D2   TSTACK            KEEP STACK RIGHT
LDEV1A   LI,SR1   BADSID
         B        LDEVERR           BAD STREAM ID
LDEV2    CI,R3    C1LDEVX           CONTROL INPUT STREAM
         BE       LDEV1AA
         LW,D4    0,R7
         PLW,D1   TSTACK            NOW SEE IF IT'S SPILL/FILL
         CI,D1    2
         BAZ      LDEV20A           2=SPILL 3=FILL
         CI,D1    3
         BNE      %+3               SPILL MAKE LIKE A READER
         LI,R2    6                  FILL MAKE LIKE A WRITER
         B        %+2
         LI,R2    4
         BAL,R4   FINDSC            GOT A CONTEXT BLOCK
         B        LDEV6              NOPE, GO GET IT
         PUSH     2,R2
         BAL,SR4  COP05             FLUSH STREAM
         PULL     2,R2
         B        LDEV6             AND GET NEW STREAM
LDEV20A  EQU      %
         CW,D4    Y4                IS TYP SPECIFIED
         BAZ      LDEV2C            NO: FETCH DEFAULT
         AI,R4    1                 YES: USE IT TO FIND TYPNME
         CW,D4    Y2                RBID SPECIFIED
         BANZ     LDEV21            * YEP, USE WHAT IS SUPPLIED
         PSW,R5   TSTACK
         LW,R5    J:USCDX           DOES USER HAVE CONTEXT PAGE
         BEZ      LDEV20B            NO DON'T TRY THIS
         LW,R5    *J:USCDX,R3         IS STREAM SET UP
         CW,R5    Y2                   FROM BEFORE
         BAZ      LDEV20B                NO, DON'T TRY
         CI,D4    ASAVFLG+ARELFLG
         BAZ      LDEV20B            NO, DON'T TRY IT
         CW,D4    Y2                GOT A NEW ONE
         BANZ     LDEV20             YES, USE IT
         LW,D1    L(X'00FF0000')
         CW,D1    SCSVDGI,R5        A PREVIOUS ONE
         BAZ      LDEV20B            NO, DON'T TRY
         LI,R2    X'FF'
         AND,R2   SCDEVTYP,R5       GET PREVIOUS DEVTYPE
         PLW,R5   TSTACK
         B        LDEV3A            OK GUY GO AHEAD
LDEV20B  PLW,R5   TSTACK
         B        LDEV2A            DO AS WE ARE LOCAL
LDEV20   PLW,R5   TSTACK             DO SPECIFIC NEW RBID TYPE
LDEV21   EQU      %
         LW,R2    R4                YEP
         AI,R2    1
         LW,D1    *R7,R2            PICK IT UP
         BEZ      LDEV2A            LOCAL - NOTHING SPECIAL
         LW,R2    *R7,R4            REMOTE: USE DEV TYP AS IS
         B        LDEV4             BUT CHECK IF REMOTE OK
LDEV2A   LW,D1    *R7,R4            INDEX  (DEV TYP)
         LI,R2    TYPMNSZ
LDEV2B   LH,D3    OH:NM,R2
         CS,D1    D3
         BE       LDEV3             FOUND DEV TYP
         BDR,R2   LDEV2B
         LI,SR1   BADTYP
         B        LDEVERR           BAD TYP
LDEV2C   LB,R2    SB:LTY,R3         DEFAULT DEV TYP
*C*
*C*      AT THIS TIME (R2)=DEV TYP, (R3)=LDEVX
*C*
*C*      NEED TO CHECK FOR SPILL/FILL TERMINATE NOW
*C*
*C*      OR ELSE LDEV IS DIRECTED TO A CENTRAL SITE
*C*       DEVICE, SO WE CHECK DEV & FUNCTION PARAMETERS
*C*
         CI,D4    X'AF'             ANY OTHER BITS NOT SPILL FILL
         BANZ     LDEV3             SO I DON'T GET TRAPPED
         LW,D1    J:USCDX           USER HAVE CONTEXT PAGE
         BEZ      LDEV3              NO, NORMAL FUNCTION
         LW,SR3   *D1,R3            GET CONTEXT ADDRESS
         CW,SR3   Y2                 IS IT SET UP
         BAZ      LDEV3               NOPE, OUT
         XW,R3    SR3               USE INDEX REGISTER NOW
         LW,SR1   SCCOMFLG,R3       IS IT SPILL FILL
         CI,SR1   X'60'              TYPE CONTEXT BLOCK
         BAZ      LDEV03              NO, NOT YET ANYWAY.
         CW,SR1   L(X'50000000')
         BAZ      LDEV03            NOTHING TO REALLY DO
         PUSH     4,R5
         CB,R15   R8                LETS LOOK AT THIS
         BE       CASE0103
         CI,R15   X'10'             DELETE OPEN SAVE CLOSE
         BNE      CASE0004           NOPE, IS OK
CASE0002 PULL     4,R5
         B        SPFIE             IGNORE THIS BAD REQUEST
CASE0004 LI,R7    X'C0'             CHECK PRIVILEDGE
         CB,R7    JB:PRIV           FOR THIS DANGEROUS REQUEST
         BL       CASE0103          IGNORE, IF < C0
         LI,R15   X'50'             SUPER CLOSE RESOLVES
         STB,R15  R8                 THIS AMBIGUITY
         STW,R8   SCCOMFLG,R3         A LITTLE LATER
CASE0103 LB,R5    R8
         BNEZ     CASE0001
CASE000  PULL     4,R5              THE NULL CASE
         B        LDEV03            WHICH COUL HAPPEN
CASE0001 CI,R5    X'10'             AND THE ALREADY DONE
         BAZ      CASE000            CASE
         LI,R5    X'A0'
         LI,R7    SCDEVTYP+SCDEVTYP+SCDEVTYP+SCDEVTYP
         STB,R5   *R3,R7            OUTPUT NOT FAKE
         LI,R5    SCRPDA            DONT RELASE ANY GRANS
         LI,R7    0
         STW,R7   *R3,R5            IN THIS FILE
         CI,R8    X'40'               ARE WE FILLINNG
         BANZ     CLOSE2               YES
         XW,R3    R10               NEED IT BACK NOW.
         PULL     4,R5              SPILLING THEN
CLOSE1A  BAL,SR4  COP05              FLUSH STREAM OUT
         B        LDEVXIT             AND GET OUT
CLOSE2   LW,SR3   R3                SET UP TO WRITE LAST GRANULE
         LW,R5    SCDBI,R3           AFTER SETTIN EOF CODE
         LW,R1    SCFBUF,R3         IN THIS DATA BUFFER
         AI,R5    2                  POSITION AT RCC
         LI,R0    X'40'                SET EOF
         STB,R0   *R1,R5                 IN BUFFER
         LI,R0    0
         STW,R0   0,R1              ZAP FLINK
         LW,R0    SCBLDA,R3          SET FLINK
         BGEZ     %+2                  IF THERE
         LI,R0    0                 CLEAR ANY FLAGS IF NOT
         LW,R12   SCBSIZ,R3          GET BUFFER SIZE
         AI,R12   -4
         SLS,R12  -2
         STW,R0   *12,R1            SET BLINK IN DATA
         LW,R13   SCFPC,R3          STAY COMPATABLE
         AI,R12   -1
         STW,R13  *R12,R1           WITH RBBAT & COOP
         PULL     4,R5
         LI,R11   CLOSE1A           AFTER NEWQ CALL
         LW,SR3   R3                CONTEXT BLOCK ADDRESS NEEDED
         PUSH     4,R8              FOR LATER PULL
         B        COP17AP5          IN ROOT
LDEV03   XW,R3    SR3               PUT DATA BACK NOW
LDEV3    EQU      %
         BAL,SR4  CHKLDCF           CHECK SYMB. DEVICE AUTH.
         B        LDEV3A            AOK
         LI,SR1   BADFLGS           NOT AUTHORIZED...
         LC       D4                PROBABLY BAD NEWS FOR USER.
         BCS,7    LDEVERR             ..BAD NEWS IF NEW DEV TYPE,
         CI,D4    ASAVFLG+ARELFLG     OR
         BAZ      LDEVERR             ..IF WANT TO RE-DEFAULT IT,
         BAL,R4   FINDSC              OR
         B        LDEVERR             ..IF STREAM UNOPEN.
         B        LDEV5AA           --> BUT OK IF SAVING OLD STREAM.
LDEV3A   CW,D4    Y1                IN/OUT SPECIFIED
         BAZ      LDEV5             NO
*        CHECK FOR LEGAL FCN SPECIFICATION.
         CW,D4    Y2                * WSN SET?
         BAZ      %+2               * NOPE, SKIP INDEX INCR.
         AI,4     1                 * ADD AN EXTRA FOR WSN = 0
         AI,R4    1
         LW,R4    *R7,R4            IN/OUT FCN
         AND,R4   X1                MAKE SURE THAT'S ALL
         LB,D3    TB:FLGS,R2        DEVICE FLAGS FOR THIS DEV TYP
         EXU      IOCMPR,R4
         BANZ     LDEV5             FCN LEGAL FOR THIS DEVICE
         LI,SR1   BADFCN
         B        LDEVERR
*
*        ***LDEV IS DIRECTED TO A REMOTE SITE***
*           CHECK IF USER HAS REMOTE PRIVILEGE
*
LDEV4    EQU      %
         LB,R4    J:UNAME
         CI,R4    ' '               * HAS THE PRINTABLE NAME BEEN ENTERED YET.
         BLE      LDEV4B
         REF      SV:FTYM           * SYSTEM VALUE: NUMBER OF FEATURE ITEMS
*,*                                 * IN SH:SYMT(JE,RB,EQ,ETC).
         LI,R4    JH:LDCF           CHECK IF RP IS FATH AND
         LH,12    0,4               CHECK BIT IF IT IS
         LI,13    X'FD9D7'          'RP' SIGN EXTENDED
         LI,R4    SV:FTYM
LDEV4C   CI,R4    SV:TYM
         BLE      LDEV4B
         CH,13    SH:SYMT,R4
         BE       %+2
         BDR,R4   LDEV4C
         SLS,12   0,R4
         CI,12    X'8000'
         BAZ      LDEV4A
LDEV4B   EQU      %
         CI,D4    4                 IS HASP SPECIFIED
         BAZ      %+3               NO
         LI,D2    HASPIO            YES: IS HASP IN CONFIGURATION
         BEZ      LDEV4A            NO: STOP THIS USER FAST
         REF      UH:FLG            * USER'S FLAGS(JIT ACCESS ETC.).
         LW,4     S:CUN
         LI,13    SJAC
         CH,13    UH:FLG,4
         BANZ     LDEV5             PROCESSOR RUNNING - OK
         LB,D2    JB:PRIV
         CI,D2    X'C0'
         BGE      LDEV5             PRIV LEVEL HIGH ENOUGH
LDEV4A   LI,SR1   BADWSN
         B        LDEVERR
*
*        VALIDITY & AUTHORIZATION CHECKS COMPLETE...
*        NOW UPDATE THE STREAM ATTRIBUTES WITH THE LDEV VALUES.
*
LDEV5    EQU      %
         BAL,R4   FINDSC            FETCH CNTXT BLK ADDR
         B        LDEV6             NOT THERE
LDEV5AA  EQU      %
         LW,R1    SR3               CNTXT BLK POINTER TO R1
         LI,D2    OUTPUTFLG**1+1
         SCS,D2   -1
         CW,D2    0,7               IS 'OUTPUT' ONLY OPTION
         BNE      LDEV5A            NOPE
         BAL,R2   COMODSET          START CONCURRENT OUTPUT IF LEGAL.
         B        LDEVERR           ---> NOT LEGAL. ERROR.
         B        LDEVXIT           ---> OKAY. COMODE STARTED.
LDEV5A   EQU      %
         LI,D2    ASAVFLG+DELFLG+ARELFLG
         AND,D2   0,R7              ISOLATE ASAVE & DELETE OPT'S
         CI,D2    ARELFLG           IF AREL SPECIFIED,
         BAZ      %+2
         AND,D2   X40               IGNORE ASAVE OPTION
         SLS,D2   25-1              POSITION TO BITS 1 & 3
         STS,D2   SCDEVTYP,R1       AND PUT AWAY IN CNTXT FOR COP05
         LW,D2    FORMLST           M:LDEV ASAVE,FORM PLIST WD1
         CW,D2    0,7               IS THIS A FORM CHANGE ONLY
         BNE      CLSSTRM           NO, SO DO SUPERCLOSE
         LI,D2    4                 LETS SEE... HAVE WE DONE ONE
         CW,D2    SCCOMFLG,R1       FORM CHANGE ALREADY??
         BANZ     CLSSTRM           YES: SO DO A SUPERCLOSE THIS TIME
         STS,D2   SCCOMFLG,R1       SET FLAG FOR 1ST FORM CHANGE
         B        NOCLOSE           AND SKIP SUPERCLOSE THIS TIME
CLSSTRM  EQU      %
         PUSH     2,2               SAVE DEV TYP, LDEVX
         BAL,SR4  COP05             CLOSE CURRENT STREAM
         PULL     2,2
         LW,D2    0,R7
         CI,D2    ARELFLG
         BANZ     LDEVXIT           AREL SPECIFIED: LEAVE
         CI,D2    ASAVFLG
         BAZ      LDEV6             START NEW STREAM FROM SCRATCH
*
*        PROCESS LDEV 'SAVE' OPTION. RESET INTERNAL COOP
*        FIELDS IN CNTXT BLK; LEAVE FIELDS MODIFIED BY LDEV INTACT.
*
         LW,R3    SR3               CNTXT BLK ADDR
         LW,R1    SR3
         AND,R1   M17               HI BYTE CNTNS CNTX-BLK-IN-USE INDTR
         LI,R0    0
         AI,R1    SCFLDA            DEST
         SLS,R1   2
         OR,R1    CNT1BYTES
         LW,R2    SCFBUF,R3             <PRESERVE BUFFADDR>
         MBS,0    0
         STW,R2   SCFBUF,R3             <RESTORE BUFFADDR>
         LI,R2    SCCOMID+SCCOMID+1
         LI,R1    X'FFFE0'          PRESERVE BANNER FLAGS  30171-F00
         MTH,0    *R3,R2
         BGZ      %+3                 (PRESERVE ORIG. BANNER IF
         LI,R1    X'FFFE8'          PRESERVE BANNER FLAGS  30171-F00
         STW,R0   SCPCO,R3            CLEAR # FILE PAGES NOW.
         STS,R0   SCCOMFLG,R3
         STW,0    SCRCO,R3
         STW,R0   SCGCO,R3
         STW,R0   SCRPDA,R3
         LW,R1    DEL%SAV           ERASE DELETE AND ASAVE
         STS,R0   SCDEVTYP,R3       OPTIONS IN CONTXT BLK
         LW,R0    Y00FF
         AND,0    SCSVDGI,R3        SAVE RBID FIELD
         STW,0    SCSVDGI,R3        IN CNTXT BLK
         LI,R2    X'FF'
         AND,R2   SCDEVTYP,R3       RESTORE DEV TYP IN R2
         B        LDEV7
LDEV6    BAL,SR2  CBINIT              GET NEW C.B. & ADD DEFAULTS.
LDEV7    EQU      %
         LW,R3    *SR3              RETRIEVE LDEVX
         LW,SR4   Y8                AND SET BIT 0 IN STREAM PNTR
         STS,SR4  *J:USCDX,R3       TO SIGNAL UNOPENED STREAM
NOCLOSE  EQU      %
         BAL,SR4  FPTMRG            ADD NEW LDEV VALUES TO CB
         LW,R3    R1
         LW,R8    SCRPDA+1,R1       'LABEL' SPEIFIED?
         BEZ      LDEV9             ---> NO.
         BAL,SR4  COPGSB              SO WE PRESERVE
         LW,R1    R3                  <COPGSB ZAPPED R1>
         LW,R9    SCFBUF,R3           LABEL CONTENTS IN SYMBUFF
         AI,R9    X'80'               UNTIL NEEDED.
         LB,R11   *R8
         AI,R11   +1
         STW,R9   SCRPDA+1,R3
         SLD,R8   +2
         STB,R11  R9
         MBS,R8   0
LDEV9    EQU      %
         LI,SR4   X'20'
         CW,SR4   SCCOMFLG,R1       * IS IT A SPILL REQUEST...
         BAZ      LDEVXIT           ---> NO.
         LI,D1    X'FF'
         AND,D1   SCFPC,R1          GET TRUE DEVICE TYPE
         SLS,D1   8
         AI,D1    GIFNC
         LW,D2    SCFFORM,R1
         LW,D4    S:CUN
         STH,D4   D2
         LW,D4    SCSVDGI,R1
         SLS,D4   -16
         STB,D4   D2
         SCS,D2   +8
         LW,D3    SCFORM,R1
         LW,R2    SCSVDGI,R1
         LW,D4    SCCOMFLG,R1
         STH,D4   R2
         BAL,R4   SGCQ2
         B        SGC:NCB
         PUSH     R1                  (C.B. ADDRESS)
         LW,R1    R6                  (SGCBUF ADDRESS)
SPILL1   LI,R6    E:QA
         BAL,11   T:REG
         AI,1     1
         MTB,0    *1
         BEZ      %+2
         BDR,1    SPILL1
         AI,R1    -1
         LI,R2    -1
         STW,R2   SCBLDA,R3          (NO FILE READ YET)
         LW,R2    S:CUN
         STW,R2   SCCUN,R3            (WE ARE USER)
         BAL,SR4  COPDCB              (SET UP C.B. DCBS)
         LW,R2    R1
         PULL     R1
         LW,R4    0,R2
         SLS,R4   -24
         AI,R4    SGCBUF
         LW,SR2   1,R4
         STW,SR2  SCFORM,R1
         LW,SR3   2,R2
         LI,SR4   X'FFFF'
         STS,SR3  SCSVDGI,R1
         SLS,SR3  -8
         LW,SR4   L(X'00FF0000')
         STS,SR3  SCSVDGI,R1
         SLS,SR3  -8
         LI,SR4   X'FF'
         STS,SR3  SCMISC,R1
         LW,SR3   3,R2
         LW,SR4   L(X'FF000000')
         STS,SR3  SCSVDGI,R1
         AND,SR3  M16
         STW,SR3  SCGCO,R1
         LW,SR4   SCFFORM,R1        ADD GRANULE COUNT
         STH,SR3  SR4                FOR USERS FPT AND CLOSE
         STW,SR4  SCFFORM,R1          AT ASAVE TIME
         LW,SR3   0,R2
         SLS,SR3  -8                  ALIGN DEV TYPE.
         LI,SR4   X'FF'
         STS,SR3  SCFPC,R1          * KEEP OBJECT DEVICE TYPE
         LW,SR4   YFF               * AND RBBATS FLAGS
         LW,SR3   2,R4              * FROM GETTING LOST
         STS,SR3  SCFPC,R1          *  FROM FILL
         LW,SR2   R4
         XW,R1    R2
         LW,SR1   1,R1
         BAL,R4   SGCR
         STW,SR1  SCBESTDA,R2
         STW,SR1  SCCDA,R2
         AI,SR1   0
         BEZ      LDEVXIT
         LW,R1    0,R7              GET FPT CONTROL WORD
         CI,R1    X'40'             IS DELETE BIT SET
         BANZ     %+3                PRIORITY CHECKED ALREADY
         LW,R1    Y1                  OTHERWISE SET SAVE BIT
         B        %+2                  FOR THIS STREAM
         LW,R1    Y4                TRUELY DELETE AS WE GO
         STS,R1   SCCOMFLG,R2        VIA THE CONTEXT BLOCK
         LW,R1    SR2
         BAL,R4   SGCR
LDEVXIT  EQU      %
         PULL     11                RETURN ADDRESS
         B        T:SELFDESTRUCT    EXIT ERASING THIS OVERLAY
*
LDEVERR  PULL     11
         LW,R4    TSTACK
         SLS,SR1  16                ADJUST ABN CODE
         STW,SR1  -5,R4             STORE IN USER'S SR3
         DESTRUCT CC1SET            SET CC1
*
*
CNT1     EQU      13*4
*
CNT1BYTES GEN,8,24  CNT1,0
*
FORMLST  DATA     X'80100010'       M:LDEV ASAVE,FORM FPT WD 1
*
*                          FLAG BITS IN PLIST
OUTPUTFLG EQU     8
ASAVFLG  EQU      X'10'
ARELFLG  EQU      X'20'
DELFLG   EQU      X'40'
*
*
DEL%SAV  DATA     X'50000000'
*
*
IOCMPR   CI,D3    X'20'             CHECK IF INPUT IS LEGAL
         CI,D3    X'10'             ''    '' OUTPUT ''   ''
*
*
*        LDEV ERROR CODES
BADSID   EQU      X'B700'           SUBCODE=00
BADTYP   EQU      X'B702'           ''   ''=01
BADFCN   EQU      X'B704'           ''   ''=02
BADWSN   EQU      X'B706'           ''   ''=03
BADFLGS  EQU      X'B708'           JH:LDCF PERIPHERAL FLG NOT SET
BADCOM   EQU      X'B70A'           COPIES>1 FOR COMODE STREAM
BADCOM2  EQU      X'B70C'           COMODE RBT NOT ALLOWED
NOTAUTH  EQU      X'B70E'           COMODE NOT AUTHORIZED
         PAGE
*
* ROUTINE TO CHECK USER'S SYMBIONT DEVICE AUTHORIZATION.
*        ENTRY: BAL,SR4   CHKLDCF
*               (R2) = DEV TYP(TYPMNE INDEX)
*        EXIT : BAL+1 - ALL IS WELL
*               BAL+2 - NOT AUTHORIZED FOR GIVEN DEVICE
*        R1,D1,D2,D3 VOLATILE
*
CHKLDCF  EQU      %
         LH,D3    OH:NM,R2          DEV TYP TEXT MNEUMONIC
         LI,R1    JH:LDCF
         LH,D2    0,R1              D2= USER'S AUTHORIZATION FLAGS.
         LI,R1    SV:TYM            SIZE OF SH:SYMT TABLE.
         CH,D3    SH:SYMT,R1        FIND INDEX INTO SYMB DEV TABLE.
         BE       LDCF1             --->GOT IT.
         BDR,R1   %-2               --->KEEP TRYING.
         B        LDCF2             --->NOT A SYMB DEVICE; ERROR.
LDCF1    SLS,D2   0,R1                LINE UP AUTHORIZATION FLAGS.
         CI,D2    X'8000'           THIS USER AUTH FOR THIS DEVICE...
         BANZ     *SR4              --->YES. OK.
LDCF2    AI,SR4   1                   NO.
         B        *SR4              --->BAD NEWS.
         PAGE
*ROUTINE TO FETCH THE CONTEXT BLOCK ADDR FOR A GIVEN LDEV
*        ENTRY : BAL,R4 FINDSC
*        INPUT : (R3)=LDEVX
*        EXIT :: BAL+1  IF NEW STRM(NEEDS INITIALIZATION)
*                BAL+2  NOT A NEW STRM--CNTXT BLK ADDR RETNED IN R10
*
FINDSC   EQU      %
         LW,D1    J:USCDX           POINTER TO CB0
         BEZ      FINDSC1           N0 MEANS USERS HAS NO COOP CNTXT AT ALL
         LW,SR3   *D1,R3
         CW,SR3   Y2
         BAZ      0,R4              STREAM NEEDS INIT.
         B        1,R4              OK
FINDSC1  EQU      %
         PULL     SR4
         PUSH     16,0
         LI,D3    JCOVPA            MAP THE COOP CNTXT WINDOW #1
         BAL,R2   T:GBUF            (AND STAY MAPPED THROUGHOUT)
*THAT BUFFER SHOULD ALWAY BE AVAILBLE
*        MTW,0    SR3
*        BEZ      %-3
         STW,D3   J:USCDX           NOW,AT LEAST HAVE 1 PG FOR CNTXT
         ANLZ,R1  BA@D3
         OR,R1    CBBYTCLR            CLEAR C.B.0 TO
         MBS,R0   BA(LACECLR)         ALL ZEROS.
* NOW SET UP C.B.0 TO POINT TO THE REAL C.B.'S.
* ALSO ZERO OUT ALL C.B.'S.
         LW,R7    J:USCDX
         LI,R2    1
ALLCBS   AI,R7    CBSIZE
         STW,R7   *D3,R2
         OR,R1    CBBYTCLR
         MBS,R0   BA(LACECLR)
         AI,R2    1
         CI,R2    SV:LSIZ             THERE ARE SV:LSIZ STREAMS.
         BLE      ALLCBS
         PULL     16,0
         PUSH     SR4
         B        0,R4
         PAGE
* ROUTINE TO INITIALIZE A COOP CONTEXT BLOCK AND FILL IN DEFAULTS.
*        RETURN WITH (SR3)=CONTEXT BLOCK ADDRESS
* (R2)=DEVICE TYPE(TYPNME INDEX)
* (R3)=LDEVX
*(SR2)=RETURN ADDR
*        PRESERVES R2,R3,R6,R7.
CBINIT   EQU      %
         LW,SR3   *J:USCDX,R3       SR3=> C.B. FOR STREAM.
         OR,SR3   Y2                  (SET FOR OPENING IT)
         LW,R1    SR3               R1=>C.B. (NOW GOT IN XREG)
         LW,D3    SCFBUF,R1           GOT A FILE BUFFER YET...
         BNEZ     CBIN9             --->YUP. KEEP IT.
         LI,D1    SV:LSIZ             NOPE.
         LW,R4    J:USCDX             LOOK THRU ALL (SV:LSIZ)
         LW,D4    YFF                 CONTEXT BLOCKS FOR A
CBIN1    EQU      %                   FILE BUFFER PAGE USED
         AI,R4    CBSIZE              ONLY ONCE.
         LW,D3    SCFBUF,R4           PAGE # IS LEFTHAND 8 BITS
         BEZ      CBIN4               OF SCFBUF.
         LW,R5    J:USCDX
         LI,D2    SV:LSIZ+1
         LI,SR4   2
CBIN2    EQU      %
         AI,R5    CBSIZE
         BDR,D2   CBIN3             --->LOOKING FOR 2ND USE.
         EOR,D3   X100                NO 2ND USE; TAKE OTHER
         B        CBIN9               HALF OF PAGE FOR US.
CBIN3    EQU      %
         CS,D3    SCFBUF,R5
         BNE      CBIN2             --->LOOKING FOR 2ND USE.
         BDR,SR4  CBIN2
CBIN4    EQU      %                   FOUND 0 OR 2 TIMES BUFFER;
         BDR,D1   CBIN1             --->LOOK AT MORE C.B.'S.
         BAL,R0   ALLSBSB             NO HALFBUFFS; MUST GET PAGE.
CBIN9    EQU      %                 D3= BUFX, WA(BUF)  8,24
         ANLZ,R1  BA@SR3
         OR,R1    CBBYTCLR            CLEAR C.B. TO
         MBS,R0   BA(LACECLR)         ALL ZEROS.
         LW,R1    SR3               R1=>C.B. (NOW GOT IN XREG)
         STW,D3   SCFBUF,R1           INITIALIZE SCFBUF.
         STW,R3   0,R1                INITIALIZE W0 (STREAM#).
         STW,SR3  *J:USCDX,R3         SAY STREAM IS OPEN.
         LB,D1    TB:SZ,2           DEFAULT LINES OR MINIMUM
         STW,D1   SCMINR,1          RECORD LENGTH
         LI,D1    1
         STW,D1   SCMISC,1          1 COPY
         LB,D1    TB:MAX,2          MAX RECORD LENGTH
         STW,D1   SCMAXR,1
         LB,D1    TB:FLGS,2         DEVICE FLAGS
         CI,R2    5
         BNE      %+2
         AI,D1    X'2000'           X'20' IN FLAG1 IF CP
         SLS,D1   8
         CI,D1    X'2000'           IS THIS AN INPUT DEVICE
         BANZ     %+2               YES
         OR,D1    Y8                OUTPUT: SET OUT FLAG
         OR,D1    R2                DEVICE TYPE
         STW,D1   SCDEVTYP,R1       FCN,FLAG1,FLAG2,DEVTYP 1,15,8,8
         LW,SR3   R1
         B        *SR2
         PAGE
*COOP DATA BUFFER ALLOCATION
*        ENTRY : BAL,R0  ALLSBSB
*           (R1)=ADDR OF COOP WNDW #1
*        OUTPUT:  NEW BUFFER PAGE ACQUIRED.
*           (D3)= SPARE PAGE INDEX, WA(PAGE WHEN MAPPED).  8,24
ALLSBSB  EQU      %
         PUSH     11,R0               SAVE R0...SR3.
ALS00    LI,D3    JCO2VPA           COOP WINDOW #2
         BAL,2    T:GBUF            GET A SPARE BUFFER
         LW,SR3   SR3               WAS ONE AVAILABLE
         BNEZ     ALS10             YES
         LB,7     JB:FBUL           HIGHEST FPOOL VP
         LOAD,6   JX:CMAP,7         IS HIGHEST FPOOL ALLOCATED
         CI,6     FPMC
         BE       ALS0              NO-USE IT
         PUSH     7                 YES-
         BAL,11   MSTRUNC            TRUNCATE ALL BUFFERS
         PULL     7
         LOAD,6   JX:CMAP,7
         CI,6     FPMC              IS HIGHEST FPOOL STILL ALLOCATED
         BE       ALS0              NO-USE IT
         LOAD,8   JX:CMAP,7         YES-REMEMBER PP BEING USED AS SPECIAAL
         BAL,11   T:RVSPI            BUFFER AND GET THE VIRTUAL SPACE
         AI,7     -1                NEXT HIGHEST FPOOL SPARE
         LOAD,6   JX:CMAP,7
         CI,6     FPMC              IS IT FREE
         BNE      %-3               NO-KEEP LOOKING FOR UNUSED SLOT
         LW,3     8                 PP# OF SPECIAL BUFFER
         BAL,11   T:GVGPI           MAP IT INTO UNUSED SLOT
ALS0     MTB,-1   JB:FBUL           RELEASE HIGHEST FPOOL SPARE
         B        ALS00             IT WILL BE AVAILABLE NOW
ALS10    STB,SR3  D3                D3= BUFX, WA(BUF).  8,24
         PULL     11,R0               RESTORE R0...SR3.
         B        *R0                 RETURN.
         PAGE
* ROUTINE TO MERGE LDEV FPT FIELDS INTO A COOP CONTEXT BLOCK.
*  (SR3)=CONTEXT BLOCK ADDR
*  (R2)=DEV TYP
*  (R7)=ADDR OF FPT+1
*  (SR4)=RETURN ADDR
*
FPTMRG   EQU      %
         LW,R1    SR3
         LW,R0    SCDEVTYP,R1       FETCH DFLT DEV FLGS IN CNTXT BLK
* HOLD SCDEVTYP STUFF IN R0 & UPDATE AS PARAMETERS ARE ENCOUNTERED.
         LW,SR1   R2                SAVE DEV TYP
         LI,SR2   X'FF'             MASK FOR DEV TYP
         BAL,R2   CHKBIT1
         B        %+2
         B        %+4
         STS,SR1  R0
         LI,D2    X'1000'
         STS,D2   SCCOMFLG,R1
         BAL,R2   CHKBIT
         BAL,R3   SETRBID           STORE RBID
         BAL,R2   CHKBIT
         BAL,R3   SETFCN            SET IN/OUT FLAG AS SPECIFIED
         LI,D2    X'FF'
         BAL,R2   CHKBIT            *P5*
         STS,D1   SCMINR,R1           LINES OR MIN RECORD LENGTH.
         LI,R3    4
         LW,SR1   SCMISC,1          FETCH DEFAULT VALUES
         BAL,R2   CHKBIT
         STB,D1   SR1               OVERWRITE WITH FPT PARAMETER IF ITS THERE
         SCS,SR1  8                 POSITION FOR NEXT
         BDR,R3   %-3
         STW,SR1  SCMISC,1
         BAL,R2   CHKBIT%
         STW,D1   SCSEQ,1           SEQ ID
         BAL,R2   CHKBIT%
         NOP      1                 * RESERVED
         BAL,R2   CHKBIT%
         B        %+2
         B        %+4
         STW,D1   SCFORM,R1
         LI,D2    X'4000'
         STS,D2   SCCOMFLG,R1
         BAL,R2   CHKBIT%
         STW,D1   SCFFORM,1         FFORM
         LW,D2    Y00FF
         CW,D2    SCSVDGI,1         ZERO WSN
         BAZ      RBSKIP            YES: SKIP OVER FLG1&2,MAXR
         SCS,R0   8                 (DEFAULT FLAGS FROM SCDEVTYP IN R0)
         BAL,R2   CHKBIT
         STB,D1   R0                UPDATE FLAG1(IF SPECIFIED)
         SCS,R0   8
         BAL,R2   CHKBIT
         STB,D1   R0                UPDATE FLAG2
         SCS,R0   16                0,FLAG1,FLAG2,DEV TYP 8,8,8,8
         BAL,R2   CHKBIT            TIME OUT FOR
         STW,D1   SCMAXR,1          MAX RECORD LENGTH
*        NOW GATHER BIT FLAGS AND VFC FLAG AND POSITION IN R0
FPTMRG1  LI,SR1   7                 ISOLATE  HASP,DIRECT,DRC    BITS
         AND,SR1  0,R7              IN WORD 1 OF FPT
         LI,D1    0
         BAL,R2   CHKBIT
         SLS,D1   3                 POSITION VFC-NOVFC BIT
         OR,SR1   D1
         SCS,SR1  -8                VFC,HASP,DIRECT,DRC IN BITS 4-7
         OR,R0    SR1
         STW,R0   SCDEVTYP,1
         LW,SR1   0,R7
         CI,SR1   X'100'              NOBANNER SPECIFIED...
         BAZ      FPTMRG2           --->NO.
         MTW,0    SCFORM,1            YES. IT'S ONLY OPERATIVE WITH
         BEZ      FPTMRG2           --->A FORM NAME.
         LI,D2    X'10'               NOBANNER + FORM NAME  MEANS
         STS,D2   SCCOMFLG,1          SET NOBANNER FLAG FOR COOPHDR
FPTMRG2  EQU      %
*
         BAL,R2   CHKBIT            IS RBB SPCL FUNCTION SET
         NOP      1                 RESERVED ENTRY
*
         LW,D1    SCMISC,R1
         LW,D2    L(X'00F00000')
         BAL,R2   CHKBIT            *P19*
         SLS,D1   +20                 SPACE(2) IN BITS 8-11.
         STS,D1   SCMISC,R1
*
         BAL,R2   CHKBIT            *P20*
         STW,D1   SCRPDA+1,R1         LABEL ADDR HERE UNTIL DEFED.
*
         LI,D2    X'60'
         CW,D2    SCCOMFLG,R1
         BAZ      FPTMRG3
         BAL,R2   CHKBIT
         B        %+2
         B        %+4
         LI,D2    X'2000'
         STS,D2   SCCOMFLG,R1
         B        %+2
FPTMRG3  LW,D1    J:JIT
         LI,D2    X'FFFF'
         STS,D1   SCSVDGI,R1
         LW,D1    Y00FF
         AND,D1   SCSVDGI,1         ISOLATE RBID
         BNEZ     OUTPUTCK          CHECK FOR COMODE-ING AN RBT
         LW,D2    HASPBIT           ZERO: CLEAR HASPBIT
         STS,D1   SCDEVTYP,1        IN CNTXT BLK
OUTPUTCK EQU      %
         LI,SR1   OUTPUTFLG
         AND,SR1  0,7               OUTPUT SPECIFIED?
         BEZ      *SR4              NO
         BAL,R2   COMODSET          YES. START COMODE IF LEGAL.
         B        LDEVERR           ---> NOT LEGAL. ERROR.
         B        *SR4              ---> OKAY. COMODE STARTED.
*
SETFCN   SCS,D1   -1                MOVE IN-OUT FLG TO BIT 0
         LW,D2    Y8
         STS,D1   R0
         CI,D1    1                   2 SPILL  3 FILL
         BAZ      0,R3
         AI,D1    0                 WHICH IS IT
         BGEZ     SETFCNS            SET SPILL UP
SETFCNF  LW,D2    7,R7              SET UP RBBATS FLAGS, DEVTYPE
         STW,D2   SCFPC,R1           IN CONTEXT BLOCK
         LW,D2    9,R7              GET FILLING PRIORITY
         SLS,D2   8                 MOVE IT OVER
         OR,D2    3,R7               ADD THE RBID
         LW,SR1   12,R7             GET GRANULES AND SYSID
         STW,SR1  SCFFORM,R1         SAVED FOR RBBAT
         SLS,SR1  16
         OR,D2    SR1               AND FOR US
         SCS,D2   16
         STW,D2   SCSVDGI,R1        IN THE CONTEXT BLOCK
         LW,D2    Y1                 SET ASAVENESS NOW
         AI,D2    X'50'             FILL FUNCTION CODE I.E. NBANNER
         STS,D2   SCCOMFLG,R1       INTO CONTROL WORD
         LW,D2    6,R7              SET UP
         STW,D2   SCMISC,R1         NUMBER OF COPIES
         LW,D2    8,R7              SET UP
         STW,D2   SCFORM,R1         FORM NAME TO USE
         B        *SR4              DONE WITH FPT MERGE FOR US
SETFCNS  PUSH     5,R3              FIGURE OUT REAL DEVICE TYPE
         LI,5     2                  LOCAL OR IRBT'S
         LW,R6    *R7,R5            THIS MAY BE LP, OR CR LOCAL
         INT,R5   0,R7               CHECK FPT AGAIN
         BCR,4    NODEVFN             NO DEVICE CODE
         BCR,2    LOCALDEV             NO RBID
         B        SETFCNSE           AND GET OUT
NODEVFN  LI,R6    0                 GENERAL SEARCH
         B        SETFCNSE           ON DEVICES
LOCALDEV LI,R3    SV:TYM
         LI,R5    X'FFFF'
         LH,R4    SH:SYMT,R3
         CS,R4    R6
         BE       %+3
         BDR,3    %-3
         B        NODEVFN
         LB,R6    SB:LTY,R3
SETFCNSE LI,R7    X'FF'             MASK
         STS,R6   SCFPC,R1
         LI,D2    X'20'             SPILL CODE
         PULL     5,R3
SETFCNE  STS,D2   SCCOMFLG,R1       SET IT UP
         B        0,3               RETURN
*
SETRBID  SLS,D1   16                POSITION RBID TO BYTE 1
         LW,D2    Y00FF
         STS,D1   SCSVDGI,1         AND PUT AWAY IN CNTXT
         LI,D2    X'8000'
         STS,D2   SCCOMFLG,R1
         B        *R3
         SPACE      5
CHKBIT1  LW,D3    0,R7
         SLS,D3   1                 SKIP STREAM ID
         LI,R4    X'80002'
CHKBIT   SLS,D3   1                 GET PARAMETER, INDIRECT OK
         BEV      1,R2
         LW,D1    *R7,R4
         BGEZ     CHKBIT2           NOT INDIRECT
         CI,D1    X'1FFF0'
         BANZ     %+2
         AW,D1    J:BASE            REGISTER: COMPUTE LOCATION
         LW,D1    *D1
CHKBIT2  EQU      %
         BIR,R4   0,R2
*
*
*
CHKBIT%  EQU      %                 GET PARAMETER, INDIRECT ILLEGAL
         SLS,D3   1
         BEV      1,R2
         LW,D1    *R7,R4
         BIR,R4   0,R2
*
*
*
RBSKIP   LI,R3    3
RBSKIP1  SLS,D3   1
         BEV      %+2
         BIR,R4   %+1
         BDR,R3   RBSKIP1
         B        FPTMRG1
*
*
*
COMODSET EQU      %
         LI,R0    X'FF'
         AND,R0   SCMISC,R1         GET # OF COPIES
         CI,R0    1
         BE       COMOD1            OK
*E*      ERROR:   B7-05
*E*      DESCRIPTION:  >1 COPIES ILLEGAL IN CONCURRENT OUTPUT MODE
         LI,SR1   BADCOM            >1 COPIES ILLEGAL IN COMODE
         B        0,R2
COMOD1   EQU      %
         LW,R0    Y00FF
         AND,R0   SCSVDGI,R1        IS THIS AN RBT/IRBT
         BEZ      COMOD2            NOPE; OK.
*E*      ERROR:   B7-06
*E*      DESCRIPTION:  CONCURRENT OUTPUT MODE ILLEGAL FOR RBT/IRBT
         LI,SR1   BADCOM2           ...YOU CANT COMODE AN RBT
         B        0,R2
COMOD2   EQU      %
         LI,R4    SV:FTYM           LENGTH OF SH:SYMT(INCL. FAUTHS)
         LI,R0    X'FE6C3'          FAUTH MNEM. FOR COMODE (HAHAHA)
         CH,R0    SH:SYMT,R4        IS 'WC' THERE
         BE       %+3               YUP
         BDR,R4   %-2
         B        COMOD3            NOPE; OK.
         LI,5     JH:LDCF           COMODE IS AUTHORIZABLE;
         LH,0     0,5               LET'S SEE IF WE ARE
         SLS,0    0,4               AUTHORIZED.
         CI,0     X'8000'
         BANZ     COMOD3            --->WE ARE.
         LI,SR1   NOTAUTH           HE ISN'T...
*E*      ERROR:   B7-07
*E*      DESCRIPTION:  CONCURRENT OUTPUT MODE NOT AUTHORIZED FOR USER
         B        0,R2
COMOD3   EQU      %
         LH,R0    SH:COMID          GET A COMID FOR THIS STREAM.
         STW,R0   SCCOMID,R1        TUCK IT AWAY.
         MTH,1    SH:COMID          INCREMENT TO NEXT ID.
         BNOV     1,R2              --->RETURN IF NO OVERFLOW.
         LI,R0    1                 ELSE RESET TO 1.
         STH,R0   SH:COMID
         B        1,R2              --->THEN RETURN.
         PAGE
RBB%SPL  EQU      %
         LW,R12   *R7               * GET FPT WORD
         CW,R12   =X'80004000'      *  RBBAT MAGIC REQUEST
         BE       RBB%SPL2          *  GO CHECK PRIVILEDGES
         LI,4     0                 * STACK COMPATABILITY
         PSW,4    TSTACK            * FOR LDEV NORMAL
         B        LDEV0             * PHONY PARAMETER
RBB%SPL2 EQU      %
         LI,R0    X'C0'             *    PRIVILEDGE FUNCTION
         CB,R0    JB:PRIV           *
         BG       SPFIE             *  REQUEST DENIED
         LI,R2    2
         LW,R2    *R7,R2            * CHECK REQUEST
         CI,R2    1
         BNE      SPFIE             *  ONLY ONE ALLOWED
         LI,R12   X'11D'            *   DUMP RBBATS DATA
         LI,R14   0                 * DON'T GO QUIESCENT
         LI,R13   LDEVXIT           *  EXIT WHEN DUMPED
         PSW,R13  TSTACK            *   VIA TSTACKK
         LW,R13   S:CUN             *  GOING TO PARK WHILE
         SLS,R13  24                *   WAITING ON RBBAT
         BAL,R4   SGCQ              *  ASK RBBAT
         B        SGC:NCB           *   MAY HAVE TO QUEUE
         PUSH     R6                * OKAY NOW PARK
         PUSH     SR4               *(T:REG-R6,R11 VOLATILE)
         REF      XFFFF00           * =X'00FFFF00' A MASK
         LI,R6    E:QA              *...TIL RBBAT DONE
         BAL,SR4  T:REG             *. . .
         AI,R1    1                 *  IS HE DONE YET
         MTB,0    *R1               *...IF SO OUR USER NUMBER IS GONE
         BEZ      %+2               *HES DONE
         BDR,R1   %-5               *  WAIT SOME MORE
         AI,R1    -1                * DECR COMBUF ADDR
         PULL     SR4               *
         PULL     R6                *  RESTORE NONVOLATILE
         LW,SR1   1,R1              * HIS ERROR CODE IF ANY
         LW,SR3   2,R1              * GET HIM WORD 3 OF COMBUF.
         BAL,R4   SGCR              * RELEASE THE BUFFER
         PULL     R2                * RESTORE THE LINK
         LW,R4    TSTACK            * GIVE THE USER SR1.
         STW,SR3  -8,R4             * ( HAVE OUR EXIT ON STACK ).
         CI,SR1   0                 * ANY ERRORS
         BEZ      0,R2              * NONE SO CONTINUE
         B        LDEVERR           * CAN HANDLE THE ERR CODE.
         PAGE
*
*        THIS ROUTINE RESETS COOP'S NEWQ ARGS
*        ENTER WITH (R3) = CNTXT BLK ADDR
*
COPDCB   EQU      %
         LI,D1    DCBSKEL
         ANLZ,D2  SETRD             DEST.
         SLD,D1   2                 BA
         OR,D2    DCBRNG
         LW,R0    SCFBUF,R3             <PRESERVE BUFFADDR>
         MBS,D1   0                   SET UP ARGS
         STW,R0   SCFBUF,R3             <RESTORE BUFFADDR>
         MTW,0    SCDEVTYP,R3
         BGEZ     *SR4              DONE IF INPUT
         LW,D2    Y01
SETRD    STS,D2   SCFQARGS,R3       OUTPUT: FCN CODE=WRITE
         B        *SR4
*
DCBSKEL  GEN,8,8,8,8  0,X'FF',3,0   DISC WRITE ARGS
         DATA     0                 BUF ADDR
         DATA     SBSIZE+SBSIZE+SBSIZE+SBSIZE   BUFF SIZE
         DATA     0                 DISC ADDR
         DATA     COPEA00           FILE END ACTION
         DATA     0                 DEV ARGS
         DATA     1STDBI            INITIAL BLOCK INDEX
         DATA     0,0,0             REST OF DEV ARGS
DCBCNT   EQU      BA(%)-BA(DCBSKEL)
DCBRNG   GEN,8,24  DCBCNT,0
         PAGE
*
*
*        ENTRY: BAL,11  COOPHDR
*               (R3)= CNTXT BLK ADDR
*
COOPHDR  EQU      %                 BUILD COOP BANNER RECORD
         LW,R5    SCDEVTYP,R3       R5= STREAM DEVTYPE FLAGS.
         CW,R5    LGLHDR              BANNER ONLY IF LIST OR PUNCH.
         BAZ      *SR4              ---> EXIT IF NOT LIST OR PUNCH.
         LW,R4    SCFORM,R3         ***  TO SUPPRESS BANNER ON OUTPUT
         NOP      1                 ***  WITH FORMS, CHANGE NOP 1 TO
*                                   ***  BNEZ *11.
         LW,R4    SCCOMFLG,R3         DON'T BUILD A BANNER IF
         CI,R4    INHIB+X'10'         INHIB SET IN SCCOMFLG.
         BANZ     *SR4              --->EXIT INSTEAD.
         PUSH     16,R0
         LW,14    SCFBUF,R3         14= WA(COOP BLOCKING BUFFER).
         LW,R4    SCDBI,R3
         ANLZ,R4  BA@14:4
         AI,R4    6                 R4= BA(WHERE TO BUILD RECORD).
         CW,R5    HASPBIT             BUT IF IT'S HASP, MUST BUILD
         BAZ      %+2                 FARTHER ALONG & MOVE LATER.
         AI,R4    12                R4= BA(REMOTE BUILDBUFFER).
         LW,R7    R4                R7 =>CURRENT POSN IN BUILDBUFFER.
         CI,R5    X'4000'             IS IT PUNCH OR IS IT PRINTER...
         BANZ     CPHDLP            --->PRINTER.
         LI,SR2   X'2403'           SR2= CTL BYTES. PUNCH;SKIP 2.
         XW,R1    R7
         LI,R0    20
         STB,R0   R1
         MBS,R0   BA(LACEFF)          START BANNER WITH 20 COL. OF -1.
         LI,R0    4
         STB,R0   R1
         MBS,R0   BA(BLNKS)           ADD '    ' TO BANNER.
         XW,R1    R7
         B        CPHDSID
CPHDLP   EQU      %
         LI,SR2   1                 COUNT FIRST PAGE USED BY 1ST LINE.
         STW,SR2  SCLINES,R3
         LI,SR2   X'0603'           SR2= CTL BYTES. PRTVFC; SKIP 2.
         LC       J:JIT
         BCS,12   %+3
         MTH,0    J:CPPO              IF BATCH & FIRST STREAM,
         BEZ      CPHDLP2           ---> NO FANCY STUFF.
         LI,SR2   X'8603'           SR2= CTL BYTES. BANNERVFC; SKIP 2.
         LI,SR3   X'C1'               NOW GET SECONDARY VFC BYTE.
         CW,R5    HASPBIT             IF NOT HASP,
         BAZ      CPHDLP1           ---> STANDARD DSP (1 +AUTO).
         LI,SR3   X'81'
         CI,R5    CMPP                IF HASP SRCB = 'C' OR 'U',
         BAZ      CPHDLP1           ---> HASP SSP AFTER (+AUTO BEFORE)
         LI,SR3   X'A2'
         CI,R5    CMPC                IF HASP SRCB = 'P',
         BAZ      CPHDLP1           ---> HASP DSP BEFORE (NO AUTO)
         LI,SR3   X'82'               ELSE HASP DSP AFTER (NO AUTO).
CPHDLP1  LW,R1    SCMINR,R3
         CI,R1    100                 GET # BANNER LINES:
         BLE      %+3                 PAGE SIZE IF SIZE <= 100
         LI,R1    6                   ELSE PAGE SIZE DEFAULT
         LB,R1    TB:SZ,R1            FOR 'LP'.
         MTW,0    SCFORM,R3           IF NO FORM NAME SPECIFIED, DO
         BEZ      CPHDLP1A              PAGE + LINE DOUBLESPACED.
         AI,R1    +1                  IF FORM NAME, DO PAGE (OUTSYM
         AI,SR3   -1                    NEEDS +1 FUDGE) SINGLESPACED.
         B        CPHDLP1B
CPHDLP1A MTW,0    SCRCO,R3            FRONT BANNER (SCRCO=0) GETS
         BNEZ     %+4                   PAGE + 1 LINE; REAR BANNER
         AI,R1    +1                    GETS PAGE.
         LI,SR4   2                   SET LINE COUNT FOR FRONT.
         STW,SR4  SCLINES,R3
         SCS,R1   -1                  DOUBLESPACE, SO USE #LINES/2.
         AI,R1    2                   +2 WORKS, TRUST ME.
         BLZ      %+2                 IF ODD #LINES NEEDED, HOWEVER,
         AI,SR2   X'10'                 TELL OUTSYM TO SSP LAST LINE.
         LI,SR4   8                   AND SET FLAG TO DO ANOTHER
         STS,SR4  SCCOMFLG,R3         WHEN FILE IS CLOSED.
CPHDLP1B SLS,SR3  +16
         STB,R1   SR3
CPHDLP2  LI,R0    '1'
         STB,R0   0,R7                START LP BANNER WITH '1' VFC.
         AI,R7    1
CPHDSID  EQU      %
         LW,R0    J:JIT
         SLS,R0   +16                 GET SYSID OF JOB.
         LI,R6    4
CPHDSID1 LI,R1    0
         SCD,R0   +4
         LB,R1    HEX,R1              MOVE SYSID INTO BANNERBUFF.
         STB,R1   0,R7
         AI,R7    +1
         BDR,R6   CPHDSID1
         LI,R6    4
         STB,R6   R7
         MBS,R6   BA(:BLNK)-4         ADD ':   ' TO BANNER.
         LC       J:JIT
         BCR,4    CPHDNG
         LW,R1    S:CUN               IF GHOST,
         LI,R6    MAXG                FIND IN GHOST TABLES.
         CB,R1    SB:GJOBUN,R6
         BE       %+3
         BDR,R6   %-2
         B        CPHDNG            --->NOT IN TABLES; ERR BUT SOWHAT.
         SLS,R6   +3                  GET BYTE INDEX.
         LB,R1    S:GJOBTBL,R6
         STB,R1   R7
         MBS,R6   BA(S:GJOBTBL)+1     ADD GHOST NAME TO BANNER.
         B        CPHDG
CPHDNG   LI,R6    12
         STB,R6   R7
         MBS,R6   BA(J:UNAME)-12      ADD USER NAME TO BANNER.
CPHDG    BAL,R0   DLTBLNK               (STRIP TRAILING BLANKS)
         LI,R6    ','
         STB,R6   0,R7                ADD ',' TO BANNER.
         AI,R7    1
         LI,R6    8
         STB,R6   R7
         MBS,R6   BA(J:ACCN)-8        ADD USER ACCT # TO BANNER.
         BAL,R0   DLTBLNK               (STRIP TRAILING BLANKS)
         LI,R6    4
         STB,R6   R7
         MBS,R6   BA(BLNKS)-4         ADD '    ' TO BANNER.
         LI,R6    2
         STB,R6   R7
         MBS,R6   BA(DATE)-2          ADD  MM     TO BANNER.
         LI,R6    '/'
         STB,R6   0,R7                ADD  '/'    TO BANNER.
         AI,R7    1
         LI,R6    2
         STB,R6   R7
         MBS,R6   BA(DATE)+2-2        ADD    DD   TO BANNER.
         LI,R6    '/'
         STB,R6   0,R7                ADD    '/'  TO BANNER.
         AI,R7    1
         LI,R6    2
         STB,R6   R7
         MBS,R6   BA(DATE)+6-2        ADD      YY TO BANNER.
         LI,R6    4
         STB,R6   R7
         MBS,R6   BA(BLNKS)-4         ADD '    ' TO BANNER.
         LI,R6    2
         STB,R6   R7
         MBS,R6   BA(TIME)-2          ADD  HH    TO BANNER.
         LI,R6    ':'
         STB,R6   0,R7                ADD  ':' TO BANNER.
         AI,R7    1
         LI,R6    2
         STB,R6   R7
         MBS,R6   BA(TIME)+2-2        ADD    MM  TO BANNER.
         LW,R0    SCPCO,R3            ANY PAGES IN FILE...
         MTW,0    SCRCO,R3          FRONT BANNER (SCRCO=0)?
         BEZ      CPHDFRST          YES--DON'T PRINT PAGE COUNT.
         LI,R6    4                   YES.
         STB,R6   R7
         MBS,R6   BA(BLNKS)-4         ADD '    ' TO BANNER.
         LI,R6    10
         CW,R0    TENTBL,R6
         BGE      CPHDPG01            STRIP LEADING ZEROS.
         BDR,R6   %-2
CPHDPG01 SLD,R0   -32
         DW,R0    TENTBL,R6
         AI,R1    '0'                 MAKE PRINTABLE.
         STB,R1   0,R7                ADD # PAGES TO BANNER.
         AI,R7    +1
         BDR,R6   CPHDPG01
         LI,R6    7
         STB,R6   R7
         MBS,R6   BA(PAGEPRT)-7       ADD ' PAGES.' TO BANNER.
CPHDFRST LI,R6    0
         XW,R6    SCRPDA+1,R3         DID USER SAY 'LABEL'...
         BEZ      %+5               ---> NO.
         SLS,R6   2
         LB,R1    0,R6
         STB,R1   R7
         MBS,R6   1                   ADD USER LABEL TO BANNER.
*  NOW   R3>CB, R4=BA(BANNER),R7=BA(BANNEREND)+1,R5=SCDEVTYP,
*                 SR2/3=CTLBYTES,14=WA(SCFBUF).
         LW,R1    R7
         SW,R1    R4                R1= BC(BANNER).
         CW,R1    SCMAXR,R3
         BLE      %+2
         LW,R1    SCMAXR,R3           TRUNC TO SCMAXR IF LONGER.
         CI,R5    X'4000'
         BANZ     CPHDMV
         LW,R0    SCMINR,R3           IF NOT PRINTER,
         SW,R0    R1                  AND BANNER SMALLER
         BLEZ     CPHDMV              THAN MINREC,
         AW,R1    R4
         STB,R0   R1                  PAD TO MINREC
         MBS,R0   BA(BLNKS)           WITH BLANKS.
         SW,R1    R4
CPHDMV   EQU      %
         STH,R1   SR2                 ADD BC TO CONTROL BYTES.
         CW,R5    HASPBIT
         BAZ      CPHDD             ---> DONE WITH RECORD IF NOT HASP.
* WE HAVE:        H%CMP1 NEEDS:
* R1 BC(SOURCE)   R1 BC(SOURCE)
*                 R2 MAX DEST     X'10000'
* R3 >C.B.        R3 BD(DEST)     SCDBI+6
* R4 BA(SOURCE)   R4 BA(SOURCE)
* R5 SCDEVTYP     R5 SCDEVTYP
* 14 SCFBUF       14 WA(DEST)     SCFBUF
*                 15   0   (WA(SOURCE))
         STW,R3   J:BASE+3          ** SAVE CB POINTER FOR H%CMP1.
         LI,15    0                   FIX
         LW,R3    SCDBI,R3            REGS
         AI,R3    6                   FOR
         LI,R2    X'10000'            H%CMP1.
         STH,SR2  SR1                 (VFC FLAG FROM CTL BYTES).
         CI,R5    CMPP                CAN'T ALL OW 'X' SRCB;
         BAZ      %+2                 CHANGE IT TO 'P'.
         AND,R5   NCMPC
         LW,R7    R10               SAVE R10
         BAL,SR4  H%CMP1              COMPRESS THE BANNER.
         LW,R10   R7                RESTORE R10
         STH,R2   SR2               R2= COMPRESSED SIZE.
         LW,R3    J:BASE+3            RESTORE CB POINTER
         LW,R5    SCDEVTYP,R3         AND SCDEVTYP.
CPHDD    EQU      %
         LW,R4    SCDBI,R3
         ANLZ,R7  BA@14:4           R7= BA(WHERE THE CTL BYTES GO).
         LI,R6    6
         STB,R6   R7
         MBS,R6   SR2*4-6             MOVE CTL BYTES IN PRECEDING BUF.
         AI,R4    6
         AH,R4    SR2               R4= UPDATED BUFFER DATA INDEX.
         STW,R4   SCDBI,R3
         CI,R5    X'4000'             AND IF NOT PUNCH,
         BANZ     CPHDDONE          --->BANNER IS DONE.
         CI,R5    X'800'              ALSO IF DEVICE DOESN'T KNOW BIN,
         BAZ      CPHDDONE          --->BANNER IS DONE.
***   FOR EACH FILE PRODUCED ON A PUNCH THAT CAN PUNCH BINARY,
***   GENERATE A FREE LACE CARD IN ADDITION TO THE BANNER.
         ANLZ,R4  BA@14:4
         AI,R4    4                 R4= BA(RECORD).
         CW,R5    HASPBIT             BUT OFFSET IT
         BAZ      %+2                 IF HASP COMPRESSION
         AI,R4    12                  WILL BE NECESSARY.
         LW,R1    R4                R1=>CURRENT POSITION IN RECORD.
         MTB,6    R1
         MBS,R0   BA(LACEFF)          FIRST 4 COL.(6 BYTES) LACED.
         MTB,6    R1
         MBS,R0   BA(LACECLR)         NEXT 4 COL.(6 BYTES) BLANK.
         LW,R7    R1
         LW,R0    J:JIT
         SLS,R0   +16                 THEN DO USER ID:
         LI,R2    4                   FOUR BLOCKS OF 16 COL.(24 BYTES)
LACE     LI,R1    0
         SCD,R0   4
         MI,R1    18                  EACH BLOCK HAS AN 11 COL.(16-1/2
         LI,R6    18                    BYTE) BLOCK LETTER,
         STB,R6   R7
         LW,R6    R1
         MBS,R6   BA(LACEBIN)
         LI,R6    6                   THEN 5 COL.(7-1/2 BYTES)
         STB,R6   R7                    BLANK.
         MBS,R6   BA(LACECLR)-6       BUT IT'S EASIER TO DO 18 & 6
         BDR,R2   LACE                  THAN 16-1/2 & 7-1/2.
         LW,R1    R7
         LI,R0    9
         STB,R0   R1
         MBS,R0   BA(LACEFF)          THEN 6 COL.(9 BYTES) LACED.
         MTB,3    R1
         MBS,R0   BA(LACECLR)         THEN 2 COL.(3 BYTES) BLANK.
         LI,SR2   X'2601'           SR2=CTL BYTES. PUNCHBIN; SKIP 0.
         LI,R1    120               R1= BC(BUFFER).
         STH,R1   SR2
         CW,R5    HASPBIT
         BAZ      ALLSET            --->DONE IF NOT HASP.
         LI,R2    X'10000'            ELSE
         LW,R3    SCDBI,R3            COMPRESS
         AI,R3    4                   RECORD.
         LW,SR1   Y02                 ( CLAIM RECORD HAS VFC)
         LI,R5    CMPC                (CLAIM SRCB OF 'C' FORM)
         BAL,SR4  H%CMP1
         STH,R2   SR2               R2= COMPRESSED SIZE.
         LW,R3    J:BASE+3            RESTORE CB POINTER.
ALLSET   EQU      %
         LW,R4    SCDBI,R3
         ANLZ,R7  BA@14:4           R7=BA(WHERE CTLBYTES GO).
         LI,R6    4
         STB,R6   R7
         MBS,R6   SR2*4-4             MOVE CTL BYTES TO BUFFER.
         AI,R4    4
         AH,R4    SR2               R4= UPDATED DATA BUFFER INDEX.
         STW,R4   SCDBI,R3
CPHDDONE EQU      %
         PULL     16,R0
*
         B        *SR4              ---> ALL DONE WITH HEADER.
*
*
DLTBLNK  EQU      %
         AI,R7    -1
         LI,R1    ' '
         CB,R1    0,R7
         BNE      %+2
         BDR,R7   %-2
         AI,R7    1
         B        *R0
*
*
         SREF     H%CMP1            * IRBT HASP COMPRESSOR(RECORD IN-
*,*                                 * STRINGS OUT), AT COOP TIME!!!
         REF      J:UNAME           * JIT ITEM USER NAME(FOR BANNER).
         REF      DATE              * CURRENT DATE FOR BANNERS.
         REF      TIME              * CURRENT TIME-OF-DAY FOR BANNERS.
         REF      J:CPPO            * OVERRIDE TO GET NO BANNER FOR
*,*                                 * BATCH FIRST TIME(CCI DID IT).
         REF      MAXG              * SIZE OF GJOB TABLES, TO FIND GHOST
*,*                                 * NAME FOR GHOST BANNER.
         REF      S:GJOBTBL         * NAME TABLE OF RUNNING GHOST'S
*,*                                 * WE'RE HERE SOMEWHERE.
         REF      SB:GJOBUN         * RUNNING GHOST USER NUMBER TABLE.
*,*                                 * AND OUR NUMBER IS HERE TO FIND.
SPCNT1   DATA     X'01010101'
NSPILLFPT DATA    X'0FE7F700'
LGLHDR   DATA     X'00204000'
:BLNK    TEXT     ':   '
BLNKS    TEXT     ' '
*
CMPP     EQU      X'10000'
CMPC     EQU      X'20000'
NCMPC    DATA     -1-CMPC
*
BA@14:4  LB,0     *14,4             FOR ANLZ'ING ONLY.
BA@D3    LB,0     *D3               FOR ANLZ'ING ONLY.
CBBYTCLR GEN,6,26 CBSIZE,0          # BYTES IN C.B. (FOR CLEARING).
BA@SR3   LB,0     *SR3              FOR ANLZ'ING ONLY.
TENTBL   DATA     1                   TABLE FOR CONVERTING BIN TO DEC.
         DATA     1
         DATA     10
         DATA     100
         DATA     1000
         DATA     10000
         DATA     100000
         DATA     1000000             MILLION.
         DATA     10000000
         DATA     100000000
         DATA     1000000000          BILLION.
*
LACECLR  DATA,6   0
LACEFF   DATA,1   X'FF'
PAGEPRT  DATA,7   ' PAGES.'
*  LACE CONVERSION TABLE.  18 BYTES (12 COLUMNS) PER ENTRY.
LACEBIN  EQU      %
 DATA,3  X'3FC204',X'204204',X'204204',X'204204',X'204204',X'3FC000'
 DATA,3  X'000000',X'000084',X'184184',X'3FC004',X'004004',X'000000'
 DATA,3  X'304204',X'20C204',X'204214',X'204204',X'224204',X'3C4000'
 DATA,3  X'30C204',X'204204',X'204204',X'204264',X'264264',X'3FC000'
 DATA,3  X'3C0040',X'040040',X'040040',X'040040',X'3FC040',X'040000'
 DATA,3  X'3CC244',X'244244',X'244244',X'244244',X'244244',X'27C000'
 DATA,3  X'3FC224',X'224224',X'224224',X'224224',X'224224',X'23C000'
 DATA,3  X'300200',X'200200',X'204208',X'210220',X'240280',X'300000'
 DATA,3  X'3FC244',X'244244',X'244244',X'244244',X'244244',X'3FC000'
 DATA,3  X'3C4244',X'244244',X'244244',X'244244',X'244244',X'3FC000'
 DATA,3  X'07C0C0',X'140240',X'240240',X'240240',X'1400C0',X'07C000'
 DATA,3  X'3FC244',X'244244',X'244244',X'244244',X'244148',X'0B0000'
 DATA,3  X'1F8204',X'204204',X'204204',X'204204',X'204204',X'108000'
 DATA,3  X'3FC204',X'204204',X'204204',X'204204',X'204108',X'0F0000'
 DATA,3  X'3FC244',X'244244',X'244244',X'244204',X'204204',X'204000'
 DATA,3  X'3FC240',X'240240',X'240240',X'240200',X'200200',X'200000'
         BOUND    4
         END

