*
*
*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      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      SCGCO             * CNTXT GRANULE COUNT CELL.
         SREF     HASPIO            * NAME OF PARENT MODULE FOR IRBT.
*,*                                 * IRBT PRESENCE IN SYSTEM.
         SREF     OCPTYP            * NAME OF PARENT VALUE FOR X1200.
*,*                                 * X1200 PRESENCE IN SYSTEM.
         SREF     OCPHDR            * IF PRESENT THE ANS HDR1 RECORD.
OCP%IN%CPV   EQU   0                * OCP IS NOT NOW A PRODUCT
         DO       OCP%IN%CPV        * ONLY IF OCP IS A PRODUCT
*,*                                 * ONLY FOR OCP(X1200)-7480-
         SREF     OCPVOL            * IF PRESENT THE ANS VOL1 RECORD.
*,*                                 * ONLY FOR OCP(X1200)-7480-.
         FIN
         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
         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
         LW,D2    Y00FE             PUT IN FUN FIELD
         STS,D1   DSI,R6            OF THIS DCB
         MTW,0    SCBESTDA,R3       IS STREAM OPEN TO A FILE
         BEZ      OPNLD2            NO.
         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'F1BE0800')    W1: PPW.
         INT,R1   0,R3
         LH,D3    SH:LNM,R1
         AND,D3   M16               P1:  (STREAM)
         LI,R1    X'FF'
         AND,R1   SCDEVTYP,R3
         LH,D4    OH:NM,R1
         AND,D4   M16               P2:  DEV
         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
         LI,D1    0                 P11: FPC
         LW,D2    SCFORM,R3         P12: FORM
         LW,D3    SCSVDGI,R3
         SLS,D3   -24               P13: PRIORITY
         LW,D4    SCDEVTYP,R3
         SLS,D4   -16               P14: FLAG1
         LCI      4
         STM,D1   8,R2
         LW,D1    SCDEVTYP,R3
         SLS,D1   -8                P15: FLAG2
         INT,D2   SCSVDGI,R3        P21: SYSID
         LCI      2
         STM,D1   12,R2
         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
         DO       OCP%IN%CPV        * ONLY IF OCP IS A PRODUCT
         CW,D1    OCPBIT              IS IT THE OCP...
         BAZ      OPNOF1            ---> NOPE.
         BAL,SR4  COOPHDOP            BUILD OCP HEADER.
         B        OPNLDXIT          GO
OPNOF1   EQU      %
         FIN
         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#.
         LW,D3    SCFORM,R3         * W3 = FORM NAME.
         BEZ      GETIF1A           : --> REAL FORM.
         MTB,0    D3
         BNEZ     GETIF1A           * --> REAL FORM.
         LI,R2    0                 * OLD SPILL.  D3=0,DEV,LO,HI.
         LH,D1    D3
         BEZ      %+2               * -->NO DEV SPEC.
         LW,R2    Y1                * W4B1= DEV SPEC FLAG.
         SLS,D3   8                 * POSITION LOPRI,HIPRI.
         B        GETIF1B
GETIF1A  EQU      %
         LI,D1    X'FF'
         AND,D1   SCDEVTYP,R3
         LW,D3    L(X'00222200')    * NCTL PRI IS LO & HI.
         LW,R2    L(X'D0000000')    * SEL ON RBID,FORM,DEVTYP.
GETIF1B  EQU      %
         SLS,D1   8                 * W1B3= DEV TYPE.
         AI,D1    GIFNC             * W1B4= GFC (GET INFILE NCTL).
         LW,D4    L(X'00FFFF00')    *
         STS,D3   D2                * W2B23= LOPRI, HIPRI FOR SEL.
         LW,D3    SCFORM,R3         *
         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
         LCI      2                   PUSHALL IS ADDRESS OF
         LM,R0    0,R1                DCB NAME.
         SLD,R0   -24
         CI,R0    4
         BNE      ACCTT             ---> NOT M:DO.
         CW,R1    L('M:DO')
         BE       ACCTDO            ---> M:DO.
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
         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
LDEV1A   LI,SR1   BADSID
         B        LDEVERR           BAD STREAM ID
LDEV2    CI,R3    C1LDEVX           CONTROL INPUT STREAM
         BE       LDEV1A            CAN'T BE LDEV'ED
         LW,D4    0,R7
         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
         BAZ      LDEV2A            NOPE
         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
*
* AT THIS POINT (R2)=DEV TYP, (R3)=LDEVX
*
*        ***LDEV IS DIRECTED TO A CENTRAL SITE DEVICE****
*           CHECK VALIDITY OF DEV & FUNCTION PARAMETERS
*
LDEV3    EQU      %
         BAL,SR4  CHKLDCF           CHECK SYMB. DEVICE AUTH.
         B        LDEV3A            AOK
         LI,SR1   BADFLGS           NOT AUTHORIZED...
         B        LDEVERR           BAD NEWS FOR THIS USER
LDEV3A   CW,D4    Y1                IN/OUT SPECIFIED
         BAZ      LDEV5             NO
*        CHECK FOR LEGAL FCN SPECIFICATION.
         AI,R4    1
         LW,R4    *R7,R4            IN/OUT FCN
         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
         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    -16                 ERASE BANNER FLAGS.
         MTH,0    *R3,R2
         BGZ      %+3                 (PRESERVE ORIG. BANNER IF
         LI,R1    -8                   STILL IN COMODE)
         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,R8    SCRPDA+1,R1       'LABEL' SPECIFIED?
         BEZ      LDEV9             ---> NO.
         LW,R3    R1                  YES. FIX IT UP
         BAL,SR4  COPGSB              SO WE PRESERVE
         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
         SLS,R8   +2
         SLS,R9   +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   SCDEVTYP,R1
         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     R6
         PUSH     R1
SPILL1   LI,R6    E:QA
         BAL,11   T:REG
         AI,1     1
         MTB,0    *1
         BEZ      %+2
         BDR,1    SPILL1
         AI,R1    -1
         PULL     R6
         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,SR3   0,R2
         LI,SR4   X'FF'
         STS,SR3  SCDEVTYP,R1
         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,SR2   Y4
         STS,SR2  SCDEVTYP,R2
         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
         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
         CI,R2    OCPTYP            IS THIS THE OCP
         DO       OCP%IN%CPV        * ONLY IF OCP IS A PRODUCT
         BNE      %+2               NOPE
         OR,D1    OCPBIT            YES- SET OCP FLAG
         FIN
*
*        ONLY ONE FUNCTION IS POSSIBLE FOR LOCAL DEVICES. REMOTE
*        DEVICES HAVE THE IN/OUT PARAMETER SET IN THE LDEV FPT
*        WHICH NULLIFIES WHAT IS DONE HERE.
*
         OR,D1    R2                DEVICE TYPE
         STW,D1   SCDEVTYP,1        FCN,FLAG1,FLAG2,DEVTYP 1,15,8,8
         LI,R4    J:ACCN+J:ACCN+J:ACCN+J:ACCN
*                                   * USER'S ACCOUNT IS HASH START
         LI,D2    0                 * INITIALIZE HASH ACCUM
         LI,D1    8                 * 8 BYTE ACCOUNT IS USED
         LB,SR3   0,R4              * NEXT BYTE
         AW,D2    SR3               * ACCUM
         SCS,D2   +6                *  . SPIN THE HASH
         AI,R4    +1                *
         BDR,D1   %-4               *
         AW,D2    R3                * STREAM INDEX IS HASH 2ND ITEM
         SCS,D2   +6                * SPIN IT
         LI,R4    J:JIT+J:JIT+J:JIT+J:JIT+2  *  SYSID IS 3RD ITEM
         LI,D1    2                 * 2 BYTES
         LB,SR3   0,R4              * NEXT BYTE
         AW,D2    SR3               * . ACCUM
         SCS,D2   +6                * . . SPIN IT
         AI,R4    +1                * . . . NEXT
         BDR,D1   %-4               *
         DW,D1    HASHPRIM          * A REDUCING FACTOR
         STW,D1   SCFPC,R1          * USE THIS HOLE FOR NOW
*
*
         REF      HASHPRIM          * =16777213 ( A LARGE PRIME NUMBER
         LW,SR3   R1
         B        *SR2
*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%
         DO       OCP%IN%CPV        * ONLY IF OCP IS A PRODUCT
         STW,D1   SCFPC,1           FPC
         ELSE                       * OTHERWISE
         NOP                        * ...DONT TOUCH SCFPC
         FIN
         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
         BAL,R2   RBB%SPL           IF SO GO PROCESS IT.
*
         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
         LB,SR1   JB:PRIV
         CI,SR1   X'A0'
         BL       0,R3
         LI,D2    X'20'               20 = SPILL
         AI,D1    0
         BGEZ     %+2
         LI,D2    X'40'               40 = FILL
         STS,D2   SCCOMFLG,R1
         B        *R3
*
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      %
         PUSH     R2                SAVE LINK REG
         LI,R2    X'C0'             * C0 PRIVILEGE REQUIRED
         CB,R2    JB:PRIV           * SO CHECK IT RIGHT AWAY.
         BL       LDEV4A            * NIX ON REQ.
         LW,R0    D1                * SAVE SUBCODE.
         SLS,D1   +8                * REPOSITION THE SPCL CODE
         AI,D1    RBBSPCL           * MAGIC RBBAT CODE
         LW,D2    SCSVDGI,R3        * FETCH UP RBID
         SLS,D2   -16               *
         AND,D2   XFF               *
         LW,D3    S:CUN             *
         STB,D3   D2                * PLACE OUR USER NUMBER
         LW,D3    SCMISC,R3         * MISCELLANEOUS STUFF
         AND,D3   XFFFF00           * THE MIDDLE BYTES
         OR,D2    D3                * ...
         LW,D3    SCFORM,R3         *  SOME MORE ARGUMENTS
         LW,R2    SCFFORM,R3        * ... AND YET MORE
         BAL,R4   SGCQ              *  ASK RBBAT
         B        SPCL:NCB          * CHECK CB AVAILABILITY.
         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.
*
*        THIS ROUTINE HANDLES THE INAVAILABILITY OF A GHOST
*        COMMUNICATION BUFFER. IF THIS IS A RESET STATIC DATA
*        SUBCODE REQUEST, A BUFFER IS TAKEN FROM THE SAVED
*        HEADS ( SO THAT THE QUIET MODE CAN BE TERMINATED ).
*
SPCL:NCB EQU      %                 * CHECK FOR RSTSFC : IF NOT THEN
         CI,R0    RSTSFC            * QUEUE FOR COMBUF. OTHERWISE WE
         BNE      SGC:NCB           * SNEAK ONE FROM THE 'EMPTY' FREE
         LI,R4    SPCL3-1           * CHAIN.
         PUSH     15,2              *
         WD,0     X'37'             **********DISABLE**********
         LB,R6    S:SGCSAV          *
         BNEZ     SPCL1             *
         WD,0     X'27'             **********ENABLE**********
         PULL     15,2              *
         LI,SR1   X'0300'           *
         B        LDEVERR           * NO COMBUFFS AVAIL.
SPCL1    EQU      %                 *GOT ONE NOW.
         LW,R8    R6                *
         AI,R6    SGCBUF            *
         LB,R2    *R6               *GET FLINK.
         STB,R2   S:SGCSAV          *THIS IS NEW HEAD.
         BNEZ     SPCL2             *IF ZERO, TAIL MUST BE ZEROED.
         LI,R3    2                 *
         STB,R2   SGCHD,R3          *
SPCL2    EQU      %                 *
         LI,R7    0                 *
         STB,R7   *R6               *
         LI,R9    X'FF'             *
         STS,R8   SGCHD             *
         B        SGCQA3            * JOIN SGCQ IN PROGRESS.
SPCL3    EQU      %                 *
         B        0,R2              *ON RETURN, REGS ARE PULLED.
*                                   *AND WE ARE ENABLED.
         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
         DO       OCP%IN%CPV        * ONLY IF OCP IS A PRODUCT.
*
*  WRITE THE HEADER FOR THE OCP.
*
COOPHDOP EQU      %
         PUSH     16,R0             SAVE REGS.
         LW,R5    SCFBUF,R3         R3= BUFFER ADDRESS.
         LW,R4    RCCNTL
         STW,R4   1,R5                PUT IN RECORD CONTROL BYTES.
         AI,R5    2
         SLS,R5   2                 R5= BA(LINEBUFFER).
         LI,R4    80
         STB,R4   R5
         MBS,R4   BA(OCPVOL)-80       PUT VOLUME LABEL IN.
         LI,R4    4
         STB,R4   R5
         MBS,R4   BA(RCCNTL)-4        PUT IN NEXT RCD CTL BYTES.
         LI,R4    80
         STB,R4   R5
         MBS,R4   BA(OCPHDR)-80       PUT IN OCP HEADER RECORD.
         SLS,R5   -2                R5= WA(NEXT BUFF WORD).
         LW,R4    OCPTM
         STW,R4   0,R5                PUT TAPE MARK IN.
         LI,R4    X'4000'
         STW,R4   1,R3                PUT END-OF-BLOCK IN.
         BAL,SR4  COPGSG            R0<- NEXT DISK ADDRESS.
         LW,R1    SCFBUF,R3         R1= BUFFER ADDRESS.
         LI,SR4   0
         STW,SR4  SCDBI,R3            SIGNAL COOP TO EXIT.
         LI,SR4   CPHDOP0
         PUSH     SR4                 (RETURN FROM COOP)
         LI,SR4   COP08A              (RETURN FROM COP20B)
         B        COP20B            --->GO WRITE OUT BUFFER.
CPHDOP0  LI,R2    1STDBI
         STW,R2   SCDBI,R3            RE-INIT SCDBI.
         PULL     16,R0             RESTORE REGS.
         B        *SR4              --->RETURN.
*
RCCNTL   DATA     X'00500601'
OCPTM    DATA     X'00000601'
         FIN
         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   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'.
         AI,R1    2                   + TWO MORE LINES.
         MTW,0    SCFORM,R3           BUT IF 'FORM' NAME SPECIFIED,
         BNEZ     CPHDLP1A
         SLS,R1   -1                  NO FORM NAME. DO ONE PAGE NOW
         LI,SR4   8                   AND SET FLAG TO DO ANOTHER
         STS,SR4  SCCOMFLG,R3         WHEN FILE IS CLOSED.
         B        CPHDLP1B
CPHDLP1A AI,SR3   -1                  SINGLE SPACE BANNER AND
         AI,R1    -1                  PRINT ONE LESS LINE OF IT.
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...
         BEZ      CPHDFRST          ---> NO.
         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
         BAL,SR4  H%CMP1              COMPRESS THE BANNER.
         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.
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

