ASMB,Q,C,Z
*USE 'ASMB,N' FOR DS/1000 ONLY, AND 'ASMB,Z' FOR DS/1000 & DS/3000
      IFN 
      NAM POPEN,7 91750-1X148 REV.2013 800710 ALL RTE-RTE 
      XIF 
      IFZ 
      NAM POPEN,7 91750-1X148 REV.2013 800710 MEF RTE-RTE-MPE 
      XIF 
      UNL 
      IFN 
      HED POPEN (DS/1000) 91750-1X148 * (C) HEWLETT-PACKARD CO 1980 
      XIF 
      IFZ 
      HED POPEN (DS/1000 & DS/3000) 91750-1X148 * (C) HEWLETT-PACKARD CO 1980 
      XIF 
      LST 
* 
*     IFN OPTION
*     NAME:   POPEN 
*     SOURCE: 91750-18148 
*     RELOC:  91750-1X148 
*     PRGMR:  CHUCK WHELAN
*     MODIF'D: GAB [790206] TO REPLACE EXTENDED INSTR'S W/ JSB'S
*     MODIF'D: JDH [790220] FOR DS REQUEST EQUATED OFFSETS
*     MODIF'D: DWT [790531] FOR PHASE FOUR (RELOCATION OF RQB)
*     MODIF'D: JDH [791010] FOR REMOTE SESSION POPEN "ICLON" PARAM
*     MODIF'D: DMT [800709] TO CHECK FOR SLAVE NAME = 0 
* 
*     IFZ OPTION
*     NAME:   POPEN 
*     SOURCE: 91750-18148 
*     RELOC:  91750-1X148 
*     PRGMR:  CHUCK WHELAN & JIM HARTSELL 
*     MODIFIED BY DMT [790327] FOR DS/1000 ENHANCEMENTS (NEW D3KMS) 
* 
      SPC 1 
******************************************************************
*  * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980.  ALL RIGHTS     *
*  * RESERVED.  NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED,      *
*  * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT*
*  * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY.       *
******************************************************************
      SPC 1 
      ENT POPEN,PREAD,PWRIT,PCONT,PCLOS,PNRPY 
      EXT #MAST,#MSTC,#TTOV,#NODE 
      EXT .MVW
      EXT .ENTR 
      EXT #RQB
RQB   EQU #RQB
      IFZ 
      EXT #LU3K 
      EXT D3KMS,D$INI,D$STW,D$ASC,D$3BF,D$TAG 
      EXT D$RQB,D$NWD,D$ZRO 
      XIF 
A     EQU 0 
B     EQU 1 
      SUP 
* 
      SPC 1 
*   THIS PROGRAM PERFORMS ALL MASTER PROGRAM TO PROGRAM FUNCTOIONS
*   IN THE DISTRIBUTED SYSTEM.  ON EACH REQUEST IT DOES THE FOLLOWING:
* 
*      1.  MOVES PCB FROM USER AREA TO REQUEST (EXCEPT POPEN) 
*      2.  VERIFIES SUFFICIENT PARAMETERS PASSED IN CALL
*      3.  MOVES 20 WORD TAG FIELD INTO REQUEST (EXCEPT PCLOS)
*      4.  SETS STREAM, FUNCTION, AND ORIGINATOR NODE INTO REQUEST
*      5.  CALLS "#MAST" TO SEND REQUEST (& DATA) AND GET REPLY 
*      6.  IF NO SYSTEM ERROR, MOVES TAG FIELD INTO USER AREA (EXCEPT PCLOS)
*      7.  EXAMINES STATUS & GIVES "ACEPT", "REJCT", OR ERROR CODE BACK TO CALLER 
      SKP 
* GLBLK-START 
* 
******************************************************************
*                                                                *
*     G L O B A L   B L O C K               REV XXXX 790531      *
*                                                                *
*     GLOBAL OFFSETS INTO DS/1000 MESSAGE BUFFERS, USED BY:      *
*                                                                *
*         REMAT, RFMST, DEXEC, DMESS, FLOAD, POPEN, #MAST        *
*         GET,   #SLAV, RQCNV, RPCNV, GRPM,  LSTEN, PTOPM        *
*         EXECM, EXECW, OPERM, RFAM1, RFAM2, DLIST, DLIS3        *
*                                                                *
******************************************************************
* 
***!!!!! THE FIRST 7 WORDS (#STR THRU #ENO) MUST BE FIXED !!!!!***
#STR  EQU 0         STREAM WORD.
#SEQ  EQU #STR+1    SEQUENCE NUMBER.
#SRC  EQU #SEQ+1    SOURCE NODE #.
#DST  EQU #SRC+1    DEST. NODE #. 
#EC1  EQU #DST+1    REPLY ECOD1.
#EC2  EQU #EC1+1    REPLY ECOD2.
#ENO  EQU #EC2+1    NUMBER OF NODE REPORTING ERROR. 
* 
#ECQ  EQU #ENO+1    ERROR CODE QUALIFIER (BITS 4 TO 7)
#LVL  EQU #ECQ      MESSAGE FORMAT LEVEL (BITS 0 TO 3)
#MAS  EQU #LVL+1    MA "SEND" SEQ. #
#MAR  EQU #MAS+1    MA "RECV" SEQ. #
#MAC  EQU #MAR+1    MA "CANCEL" FLAGS 
#HCT  EQU #MAC+1    HOP COUNT 
#SID  EQU #HCT+1    SESSION ID WORD 
* 
#EHD  EQU #SID      LAST ITEM OF HEADER 
#MHD  EQU #EHD+1    MINIMUM HEADER SIZE 
#REQ  EQU #MHD      START OF REQUEST SPECIFIC AREA
#REP  EQU #MHD      START OF REPLY SPECIFIC AREA
* 
#MXR  EQU #MHD+24   <<< MAXIMUM DS REQ/REPLY BUFFER SIZE >>>
#LSZ  EQU 2         <<< SIZE OF LOCAL APPENDAGE AREA >>>
* 
******************************************************************
* 
* GLBLK-END 
      SKP 
* PPBLK-START 
* 
******************************************************************
*                                                                *
*      P T O P   B L O C K                 REV XXXX 790420       *
*                                                                *
*      OFFSETS INTO DS/1000 PTOP MESSAGE BUFFERS, USED BY:       *
*                                                                *
*   POPEN, PTOPM, GET/ACEPT/REJCT, RQCNV, RPCNV, LSTEN, REMAT    *
*                                                                *
******************************************************************
* 
* OFFSETS INTO PTOP REQUEST AND REPLY BUFFERS.
* 
#FCD  EQU #REP      FUNCTION CODE.
#PCB  EQU #FCD+1    PCB AREA (3 WORDS). 
#TAG  EQU #PCB+3    TAG AREA (20 WORDS).
* 
* MAXIMUM SIZE OF PTOP REQUEST/REPLY BUFFER.
* 
#PLW  EQU #MXR      M A X I M U M   S I Z E    ! ! !
* 
* PPBLK-END 
      SKP 
IPCB  NOP 
IERR  NOP 
INAM  NOP 
INODE NOP 
ITAG  NOP 
ICLON NOP 
ENAM  EQU ICLON     DS/3000: ENTRY NAME 
      IFZ 
      NOP           DS/3000: CONTROL INFORMATION. 
      NOP                    LOADING OPTIONS. 
BUFSZ NOP                    MAX DATA RECORD LENGTH 
      XIF 
      SPC 3 
POPEN NOP 
* 
* MASTER REQUESTS FOR POPEN COME HERE 
* 
*     CALL POPEN(IPCB,IERR,INAM,INODE,ITAG [,ICLON])
* 
      JSB .ENTR     PICK UP THE USER PARAMETERS 
      DEF IPCB
* 
*   MAKE SURE POPEN NAME ISN'T NUMERIC 0. 
* 
      LDA POPEN     SET ERROR RETURN. 
      STA RTRN
      LDA IERR
      STA ERRAD 
      LDA N41       PRE-SET ERROR TO -41. 
      LDB INAM      GET NAME PARAMETER. 
      SZB,RSS       IF NOT PROVIDED,
      JMP ERR2       REPORT -40.
      LDB B,I       GET VALUE.
      SZB,RSS       IF ZERO,
      JMP SETER      REPORT -41.
* 
      LDB IPCB      USER'S PCB ADDRESS
      LDA INODE,I   DESTINATION NODE
      ADB K3        4TH WORD OF PCB HAS NODE
      STA 1,I       PUT IT THERE
      STA RQB+#DST  SAVE IT 
* 
      CLA,INA       INITIALIZE POPEN FUNCTION CODE = 1. 
      STA POFCN 
* 
      LDA ICLON     CLONING/ENAM PARAMETER SPECIFIED? 
      SZA,RSS 
      JMP BUILD     NO. 
      LDB ICLON,I   YES. DO THEY WANT CLONING?
      LDA POFCN       (ENAM IS AN ASCII PARAMETER)
      CPB K1
      IOR BIT13     YES. SET BIT 13 OF FUNCTION WORD. 
      STA POFCN 
* 
BUILD LDB POPEN     SET UP ERROR RETURN 
      LDA IERR
      JSB BLDRQ     SET UP BASIC REQST
IPRAM DEF ITAG
POFCN NOP           FCN = 1 
      IFZ 
      JMP QOPEN     DO POPEN TO 3000
      XIF 
* 
      LDA BIT15     MAKE SURE POPEN ALWAYS
      STA CONWD      BYPASS NO-REPLY OPTION 
      LDA INAM      ADDR OF NAME FIELD
      LDB RPCBA     ADDR OF PCB IN REQ BUFFER 
      JSB .MVW      MOVE NAME INTO PCB FIELD
      DEF K3
      NOP 
* 
      LDA IPCB
* 
NODAT LDB DUMAD     USE DUMMY AS DATA POINTER 
      STB DBUF
      CLB 
      STB WRLEN     SET WRITE DATA LENGTH = 0 
* 
* 
*  THIS CODE IS USED IN COMMON BY ALL P TO P CALLS
* 
MAIN  STB RDLEN     SET READ DATA LENGTH
      STA PCBAD     SAVE PCB ADDRESS
* 
      LDA K4
      STA RQB+#STR  SET P TO P STREAM IN REQ
* 
      LDA CONWD     GET CONTROL WORD
      SLA,RSS       IS NO-REPLY OPTION SET? 
      JMP CMAST     .NO, JUST CALL #MAST
      LDB BIT15 
      STB #MSTC     .YES, SET NO-WAIT OPTION IN #MAST 
      LDB TTOV
      STB #TTOV     ALSO, SET TRANSACTION T/O VALUE IN #MAST
* 
* THE CALL TO #MAST WILL: 
*  1) GET AN I/O CLASS
*  2) INSERT SEQ # & ORIGIN NODE
*  3) BUILD MASTER TCB
*  4) SEND REQUEST (& DATA) 
*  5) CALL "#GET" TO AWAIT AND GET REPLY
*  6) RETURN REPLY (& DATA) 
*  7) RETURN CONTROL
CMAST EQU * 
      JSB #MAST     ISSUE REQUEST CALL
      DEF *+7 
      DEF CONWD 
      DEF IRBFL     REQUEST LENGTH
DBUF  NOP           DATA BUFFER ADDRESS 
      DEF WRLEN     DATA WRITE LENGTH 
      DEF RDLEN     DATA READ LENGTH
      DEF IRBFL     MAX EXPECTED REPLY LENGTH 
* 
      JMP ERR       ERROR DETECTED
      LDA RQB+#FCD  FUNCTION CODE 
      CPA K5        IS THIS A PCLOS?
      JMP NOMOV     YES, WE'RE DONE 
* 
RPCBA EQU *+1 
      DLD RQB+#PCB  GET PCB 
PCBAD EQU *+1 
      DST *         SAVE 1ST 2 PCB WORDS IN USER AREA 
* 
      LDA RTAGA     ADDR OF TAG FIELD IN REQUEST
      LDB TAGAD     ADDR OF TAG FIELD IN USER AREA
      JSB .MVW      MOVE 20 WORDS TO USER TAG FIELD 
      DEF K20 
      NOP 
* 
NOMOV LDA RQB+#EC2
      SZA           WAS ERROR DETECTED? 
      JMP EXIT      YES, IERR SET 
      LDB RQB+#FCD
      SSB           WAS REQUEST REJECTED? 
      CLA,INA       YES, SET REJECT IERR
EXIT  STA ERRAD,I   RETURN IT TO CALLER 
      CLB 
      STB CLEAR,I   CLEAR PARAM CHECK LOC 
      STB #MSTC     CLEAR NO-WAIT FLAG
      STB #TTOV     CLEAR XACT T/O VALUE
      LDA BIT15 
      LDB MODE      GET MODE WORD 
      SSB           IS NO-REPLY SET FOR ONE TIME ONLY?
      IOR K1        .NO, CONWD WILL BE SET FOR NO-REPLY 
      STA CONWD     SET CONWD 
      JMP RTRN,I    RETURN
      SKP 
* 
*  MOVE PCB INTO REQUEST BUFFER 
MVPCB NOP 
      LDB N2
      ADB MVPCB     POINT TO ADDR OF PCB ADDR 
      LDB 1,I       GET ADDR OF PCB ADDR
      LDA 1,I       GET PCB ADDR
      LDB RPCBA     GET ADDR OF PCB IN BUFFER 
      JSB .MVW      MOVE 1ST TWO WORDS TO REQUEST 
      DEF K2
      NOP 
      INA           POINT TO 4TH PCB WORD 
      LDB 0,I       GET DESTINATION NODE
      STB RQB+#DST  SAVE IT 
      JMP MVPCB,I   RETURN
      SPC 2 
* 
*  COMMON PARAMETER SET-UP AND TAG FIELD MOVE FOR ALL BUT "PCLOS" 
BLDRQ NOP 
      STB RTRN      RETURN ADDRESS FOR ALL
      STA ERRAD     ADDR OF ERROR PARAMETER 
* 
      DLD BLDRQ,I   GET TAG ADDR, AND FUNC CODE 
      STA CLEAR     SAVE LAST PARAM ADDR
      LDA 0,I       GET ADDR OF USER'S TAG FIELD
      SZA,RSS       WAS LAST PARAM SPECIFIED
      JMP ERR2      TOO FEW PARAMETERS IN CALL
      STB RQB+#FCD  SET FUNCTION CODE 
      IFZ 
      LDB #LU3K     GET DS/3000 LU
      CMB,INB,SZB,RSS NEGATE
      JMP *+3       NO 3000 
      CPB RQB+#DST  IS IT NEGATIVE LU OF 3000?
      JMP RQEX      YES, PERFORM DS/3000 P-TO-P 
      XIF 
      LDB C#PLW     REQUEST LENGTH
      STB IRBFL 
* 
      STA TAGAD 
      LDB RTAGA     ADDR OF TAG FIELD IN REQUEST
      JSB .MVW      MOVE TAG FIELD INTO REQ 
      DEF K20 
      NOP 
      IFZ 
      ISZ BLDRQ 
      XIF 
RQEX  ISZ BLDRQ 
      ISZ BLDRQ 
      JMP BLDRQ,I   RETURN
      SPC 3 
*  ERROR PROCESSING SECTION 
ERR   ADB NEG00     SUBTRACT ASCII "00" 
      CPA "DS"      IS IT A "DSXX" ERROR? 
      SSB            AND >= "00"? 
      JMP ERR47     NO, GIVE -47
      LDA 1 
      ADA N9        NUMERIC PART - 9
      CMA,SSA       SKIP IF DS00 - DS08 
ERR47 LDA K11       MAKE A -47 ERROR
      ADA N58       A = -47 OR -50 THRU -58 
      JMP EXIT
* 
ERR2  LDA N40 
* 
*  INTERNAL ERROR OCCURRED. SET UP DS/1000 REQUEST BUFFER IN CASE USER
*  WANTS TO CALL DSERR. (NUMERIC ERROR CODE IS IN A-REGISTER.)
* 
SETER STA RQB+#EC2  STORE ERROR.
      CLB 
      STB RQB+#EC1
      STB RQB+#ECQ
      LDB #NODE     SET ERROR NODE
      STB RQB+#ENO   TO LOCAL.
      JMP EXIT      RETURN WITH IERR. 
      SKP 
* 
*  SET NO-REPLY OPTION:  CALL PNRPY[(IMODE[,ITTOV])]
* 
*    IMODE = 0 OR DEFAULT => ONE TIME ONLY
*    IMODE < 0 => ALL FOLLOWING PTOP CALLS
*    IMODE > 0 => TURN OFF NO-REPLY OPTION
*    ITTOV => TRANSACTION TIME-OUT OVERRIDE 
* 
IMODE NOP 
ITTOV NOP 
PNRPY NOP 
      JSB .ENTR 
       DEF IMODE
      LDB IMODE     IMODE PASSED? 
      SZB 
      LDB IMODE,I   .YES, PICK UP MODE PARAMETER
      STB MODE      STORE IT IN MODE
      LDA BIT15     GET BIT 15 FOR CONWD
      SZB,RSS       MODE = 0? 
      IOR K1        .YES, OR IN NO-REPLY BIT
      SSB           MODE < 0? 
      IOR K1        .YES
      STA CONWD 
      LDA ITTOV     ITTOV PASSED? 
      SZA           .NO 
      LDA ITTOV,I   .YES, PICK UP TTOV PARAMETER
      CMA,INA 
      AND =B377     IGNORE ALL BUT THE RIGHT BYTE 
      STA TTOV      STORE IT AWAY 
      CLA 
      STA IMODE     CLEAR IMODE FOR NEXT CALL 
      STA ITTOV 
      JMP PNRPY,I   RETURN
* 
MODE  NOP 
TTOV  NOP 
      SKP 
* 
*  READ REQUESTS
* 
RIPCB NOP 
RIERR NOP 
RIBUF NOP 
RIL   NOP 
RITAG NOP 
* 
PREAD NOP 
      JSB .ENTR     GET USER PARAMETERS 
      DEF RIPCB 
      JSB MVPCB     MOVE 2 WORD PCB INTO REQUEST
* 
      LDB PREAD     RETURN ADDRESS
      LDA RIERR 
      JSB BLDRQ     BASIC REQUEST PROCESSING
RPRAM DEF RITAG 
K2    DEC 2 
      IFZ 
      JMP QREAD     PERFORM PREAD TO 3000 
      XIF 
* 
      LDA BIT15 
      STA CONWD     MAKE SURE PREAD WILL ALWAYS WAIT
      LDA RIBUF     SAVE BUFFER ADDRESS 
      STA DBUF
      LDB RIL,I     SAVE DATA LENGTH
      STB RQB+#PCB+2
* 
      CLA 
      STA WRLEN     CLEAR WRITE DATA LENGTH 
      LDA RIPCB     PCB ADDRESS 
      JMP MAIN      NOW DO LINE COMM & RETURN 
      SKP 
* 
*  WRITE REQUESTS 
* 
PIPCB NOP 
PIERR NOP 
PIBUF NOP 
PIL   NOP 
PITAG NOP 
* 
* 
PWRIT NOP           PWRITE REQUESTS HERE
      JSB .ENTR     PICK UP PARAMETERS
      DEF PIPCB 
      JSB MVPCB     MOVE 2 WORD PCB INTO REQUEST BUFR 
* 
      LDB PWRIT     SET UP ERROR RETURN 
      LDA PIERR 
      JSB BLDRQ     BUILD BASIC REQST 
PPRAM DEF PITAG 
K3    DEC 3 
      IFZ 
      JMP QWRIT     PERFORM PWRIT TO 3000 
      XIF 
* 
      LDA PIBUF     GET DATA ADDRESS
      STA DBUF
      LDA PIL,I     GET DATA LENGTH 
      STA RQB+#PCB+2
      STA WRLEN 
* 
      LDA PIPCB 
      CLB 
      JMP MAIN      NOW DO LINE COMM & RETURN 
      SKP 
* 
*  CONTROL REQUESTS 
* 
CIPCB NOP 
CIERR NOP 
CITAG NOP 
* 
* 
PCONT NOP 
      JSB .ENTR     GET PARAMETERS
      DEF CIPCB 
      JSB MVPCB     MOVE 2 WORD PCB INTO REQUEST BUFR 
* 
      LDB PCONT     SET UP RETURN ADDR
      LDA CIERR 
      JSB BLDRQ     BUILD BASIC REQST 
CPRAM DEF CITAG 
K4    DEC 4 
      IFZ 
      JMP QCONT     PERFORM PCONT TO 3000 
      XIF 
* 
      LDA CIPCB     PCB ADDRESS 
      JMP NODAT     DO LINE COMM & RETURN 
      SKP 
* 
*  CLOSE REQUESTS 
* 
FIPCB NOP 
FIERR NOP 
* 
* 
RTRN  EQU * 
PCLOS NOP 
      JSB .ENTR     GET PARAMETERS
      DEF FIPCB 
      JSB MVPCB     MOVE 2 WORD PCB INTO REQUEST BUFR 
* 
      LDA DFIEA 
      STA CLEAR     SAVE LAST PARAM ADDR
      LDA FIERR 
      SZA,RSS       ERROR ADDR SPECIFIED? 
      JMP ERR2      NO, GIVE ERROR
      STA ERRAD     SET ERROR ADDRESS 
      IFZ 
      LDA #LU3K     GET 3000 LU 
      CMA,INA,SZA,RSS NEGATE IT 
      JMP *+3       JUMP IF NO 3000 LINK
      CPA RQB+#DST  WAS NEGATIVE LU OF 3000 SPECIFIED?
      JMP QCLOS     YES, DO PCLOS TO 3000 
      XIF 
* 
      LDA L#PCB 
      STA IRBFL     11 WORD REQUEST 
      LDA K5
      STA RQB+#FCD  FUNCTION CODE = 5 
* 
      LDA FIPCB     PCB ADDRESS 
      JMP NODAT     DO COMMUNICATION & RETURN 
      SKP 
* 
*  DATA AREA
* 
IRBFL NOP 
WRLEN NOP 
RDLEN NOP 
K1    OCT 1 
K5    DEC 5 
K11   DEC 11
K20   DEC 20
N2    DEC -2
N9    DEC -9
N40   DEC -40 
N41   DEC -41 
N58   DEC -58 
NEG00 OCT 147720
BIT13 OCT 20000 
BIT15 OCT 100000
"DS"  ASC 1,DS
CONWD OCT 100000
ERRAD NOP 
TAGAD NOP 
CLEAR NOP 
DFIEA DEF FIERR 
RTAGA DEF RQB+#TAG  ADDR OF REQ TAG FIELD 
DUMAD DEF * 
* 
*  DEFINE REQUEST 
L#PCB ABS #PCB+3
C#PLW ABS #PLW
      IFN 
      UNL 
      XIF 
      IFZ 
      SKP 
* 
* GENERATE POPEN REQUEST FOR REMOTE DS/3000 COMPUTER. 
* 
QOPEN LDA ITAG
      STA TAGAD 
* 
      LDA ITAG
      SZA,RSS 
      JMP ERR2      ILLEGAL NUMBER OF PARAMETERS. 
* 
      LDA IPRAM     POINT TO ADDR OF FIRST PARAM. 
      JSB D$INI     INITIALIZE BUFFER STUFFERS. 
* 
      JSB SETOC     SET STREAM, CLASS, AND "RFA ".
* 
      LDA B25 
      JSB D$STW     FUNCTION CODE = 25 OCTAL. 
* 
      LDA INAM      MOVE PROGRAM NAME (UP TO 28 BYTES). 
      LDB N14       (DELIMITER = BLANK) 
      JSB D$ASC 
* 
      INA           (A) = TOTAL BYTES IN REQUEST. 
      ARS           NEED TO INSERT TRAILING BLANKS
      ADA N17        IN PROGRAM NAME FIELD? 
      STA TEMP
      SSA,RSS 
      JMP MVENT     NO. 
* 
LOOP2 LDA BLNKS     YES. ADD TRAILING BLANKS
      JSB D$STW          TO FILL OUT 14-WORD FIELD. 
      ISZ TEMP
      JMP LOOP2 
* 
MVENT LDA ENAM      MOVE ENTRY NAME (UP TO 8 BYTES).
      LDB N4        DELIMITER = BLANK.
      JSB D$ASC 
* 
      INA           (A) = TOTAL BYTES IN REQUEST. 
      ARS 
      ADA N21       NEED TO INSERT TRAILING BLANKS
      STA TEMP      IN ENTRY NAME FIELD?
      SSA,RSS 
      JMP MVTAG     NO. 
* 
LOOP3 LDA BLNKS     YES. ADD TRAILING BLANKS TO FILL
      JSB D$STW      OUT 4-WORD FIELD.
      ISZ TEMP
      JMP LOOP3 
* 
MVTAG LDA N20       MOVE TAG FIELD. 
      JSB D$NWD 
* 
      CLA           MOVE 2 PARAMETERS.
      LDA ENAM+1,I
      JSB D$STW 
      CLA 
      LDA ENAM+2,I
      JSB D$STW 
      LDA N3        ZERO 3 WORDS. 
      JSB D$ZRO 
      CLA 
      LDA BUFSZ,I   GET USER'S MAX BLOCK SIZE.
      SZA           IF NOT SUPPLIED, ZERO, OR 
      SSA            NEGATIVE, USE MAXSZ. 
      LDA MAXSZ 
      JSB D$STW 
* 
* SET UP PARAMETER MASK AS FOLLOWS: 
*       BIT 9 = PROGRAM NAME
*       BIT 8 = ENTRY NAME
*       BIT 7 = 0 
*       BIT 6 = CONTROL INFO (PARAMS) 
*       BIT 5 = LOADING OPTIONS (FLAGS) 
*       BIT 4 = 0 (STACKSIZE) 
*       BIT 3 = 0 (DLSIZE)
*       BIT 2 = 0 (MAXDATA) 
*       BIT 1 = 0 
*       BIT 0 = 0 
* 
      LDA DPARM     FWA PARAM ADDR LIST.
      STA TEMP
      LDA N5        COUNTER.
      STA CONTR 
      CLA           INITIALIZE PARAMETER MASK.
* 
LOOP4 LDB TEMP,I    GET ADDR OF NEXT PARAM. 
      LDB B,I 
      SZB 
      IOR B1        SET BIT IF PARAM SPECIFIED. 
      RAL           MOVE IT OVER. 
      ISZ TEMP
      ISZ CONTR 
      JMP LOOP4     LOOP TILL DONE. 
      ALF           BITS 0-4 = 0. 
      JSB D$STW 
* 
* REQUEST BUFFER READY. D3KMS WILL WRITE IT TO QUEX'S I/O 
* CLASS. USER WILL BE SUSPENDED UNTIL D3KMS'S CLASS GET 
* IS COMPLETED WHEN THE REPLY ARRIVES.
* 
      JSB D3KMS     SEND REQUEST AND WAIT FOR REPLY.
      DEF *+2 
      DEF BIT15 
      JMP E3K       ERROR RETURN. 
* 
      JSB PASSP     RETURN ERROR CODE AND TAG FIELD.
* 
      LDA D$RQB     RETURN PCB FROM REPLY.
      ADA K10        (CURRENTLY NOT USED - ALL ZEROES)
      LDB IPCB
      JSB .MVW
      DEF K3
      NOP 
* 
      LDA ERRAD,I 
      JMP RTRN,I    RETURN TO CALLER. 
* 
* 
DPARM DEF *+1       TABLE OF POPEN PARAMETER
      DEF INAM       ADDRESSES FOR BIT MASK.
      DEF ENAM
      DEF B0
      DEF ENAM+1
      DEF ENAM+2
      SPC 1 
* 
* SUBROUTINE TO PASS RETURNED ERROR CODE AND TAG
* FIELD TO THE USER PROGRAM.
* 
PASSP NOP 
      JSB CLER      CLEAR DS/1000 ERROR INDICATOR.
      LDB D$3BF+8   RETURN ERROR CODE.
      CLA           MAP DS/3000 TO DS/1000 ERROR CODES. 
      CPB CG211 
      INA           CCG & 211 = 1 (REJECT). 
      CPB CL209 
      LDA N41       CCL & 209 = -41.
      CPB CL205 
      LDA N42       CCL & 205 = -42.
      CPB CG210 
      LDA N44       CCG & 210 = -44.
      CPB CL213 
      LDA N44       CCL & 213 = -44.
      STA ERRAD,I 
      STA RQB+#EC2  SET DS/1000 ERROR.
* 
      LDA D$RQB 
      ADA K13       RETURN TAG FIELD. 
      LDB TAGAD 
      JSB .MVW
      DEF K20 
      NOP 
      JMP PASSP,I 
      SPC 1 
*   CLEAR DS/1000 ERROR CODES.
CLER  NOP 
      CLA 
      STA RQB+#EC1
      STA RQB+#EC2
      STA RQB+#ENO
      STA RQB+#ECQ
      JMP CLER,I
      SKP 
* 
* GENERATE PREAD REQUEST FOR REMOTE DS/3000 COMPUTER. 
* 
QREAD LDA RITAG 
      STA TAGAD 
      SZA,RSS 
      JMP ERR2      ILLEGAL # PARAMETERS. 
* 
      LDA RPRAM     POINT TO ADDR OF 1ST PARAM (TAG). 
      JSB D$INI     INITIALIZE BUFFER STUFFERS. 
* 
      LDA K4        SET CLASS TO 4
      STA D$3BF 
      LDA B22        AND STREAM TO 22.
      STA D$3BF+2 
* 
      CLA 
      JSB D$STW 
* 
      LDA RIL,I     GET USER BUFFER LENGTH. 
      SSA,RSS       IF NEGATIVE,
      JMP *+4 
      CMA,INA         MAKE POSITIVE AND 
      INA              CONVERT FROM BYTES 
      CLE,ERA           TO WORDS. 
      JSB D$STW     STORE IN REQUEST BUFFER.
* 
      LDA RIPCB     MOVE PCB TO REQUEST.
      JSB MVPC       (EMPTY AT PRESENT) 
      LDA N20       MOVE TAG FIELD. 
      JSB D$NWD 
* 
* SEND REQUEST TO THE 3000 AND WAIT FOR REPLIES.
* 
      JSB D3KMS     SEND REQUEST AND GET REPLY. 
      DEF *+6 
      DEF BIT15 
      DEF 0 
      DEF 0 
      DEF RIBUF,I 
      DEF RIL,I 
      JMP E3K       ERROR RETURN. 
* 
      JSB PASSP     SET ERROR CODE. 
* 
      LDA D$TAG     MOVE TAG FIELD. 
      LDB TAGAD 
      JSB .MVW
      DEF K20 
      NOP 
* 
      LDA ERRAD,I 
      JMP RTRN,I    RETURN TO USER. 
      SPC 2 
      SKP 
* 
* GENERATE PWRIT REQUEST FOR REMOTE DS/3000 COMPUTER. 
* 
QWRIT LDA PITAG 
      STA TAGAD 
* 
      SZA,RSS 
      JMP ERR2      ILLEGAL # PARAMETERS. 
* 
      LDA PPRAM     POINT TO ADDR OF 1ST PARAM (TAG). 
      JSB D$INI     INITIALIZE BUFFER STUFFERS. 
* 
      LDA K4        SET CLASS TO 4
      STA D$3BF 
      LDA B23        AND CLASS TO 23. 
      STA D$3BF+2 
* 
      CLA 
      JSB D$STW 
* 
      LDA PIL,I     GET USER BUFFER LENGTH. 
      JSB D$STW     STORE IN REQUEST BUFFER (TCOUNT). 
* 
      LDA PIPCB     MOVE PCB TO REQUEST.
      JSB MVPC       (EMPTY AT PRESENT) 
      LDA N20       MOVE TAG FIELD. 
      JSB D$NWD 
* 
* SEND REQUESTS TO THE 3000 AND GET THE REPLY.
* 
      JSB D3KMS 
      DEF *+4 
      DEF BIT15 
      DEF PIBUF,I 
      DEF PIL,I 
      JMP E3K       ERROR RETURN. 
* 
      JSB PASSP      RETURN ERROR CODE & TAG TO USER. 
      LDA ERRAD,I 
      JMP RTRN,I     RETURN TO CALLER.
      SKP 
* 
* GENERATE PCONT REQUEST FOR REMOTE DS/3000 COMPUTER. 
* 
QCONT LDA CITAG 
      STA TAGAD 
* 
      SZA,RSS 
      JMP ERR2      ILLEGAL # PARAMETERS. 
* 
      LDA CPRAM     ADDR OF 1ST PARAM (TAG).
      JSB D$INI     INITIALIZE BUFFER STUFFERS. 
* 
      LDA K4        SET CLASS TO 4
      STA D$3BF 
      LDA B24        AND STREAM TO 24.
      STA D$3BF+2 
* 
      LDA N2        CLEAR FIRST 2 APPENDAGE WORDS.
      JSB D$ZRO 
* 
      LDA CIPCB     MOVE PCB TO REQUEST.
      JSB MVPC       (EMPTY AT PRESENT) 
      LDA N20       MOVE TAG FIELD. 
      JSB D$NWD 
* 
* SEND REQUEST TO THE 3000 AND WAIT FOR THE REPLY.
* 
      JSB D3KMS 
      DEF *+2 
      DEF BIT15 
      JMP E3K       ERROR RETURN. 
* 
      JSB PASSP     RETURN ERROR CODE & TAG FIELD.
* 
      LDA ERRAD,I 
      JMP RTRN,I    RETURN. 
      SKP 
* 
* GENERATE PCLOS REQUEST FOR REMOTE DS/3000 COMPUTER. 
* 
QCLOS LDA B6        SET CLASS TO 6
      STA D$3BF 
      LDA B22        AND STREAM TO 22 
      STA D$3BF+2 
      CLA             AND APPENDAGE LEN TO 0. 
      STA D$3BF+7 
* 
      JSB D3KMS     SEND BREAK REQ TO 3000, 
      DEF *+2        AND GET THE REPLY. 
      DEF BIT15 
      JMP E3K       ERR RETURN
* 
      LDA FIERR     ADDR OF 1ST PARAM (DUMMY).
      JSB D$INI     INITIALIZE BUFFER STUFFERS. 
* 
      JSB SETOC     SET CLASS, STREAM, AND "RFA ".
      LDA B26       STORE FCN CODE = 26 OCTAL.
      JSB D$STW 
* 
      LDA FIPCB     MOVE PCB TO REQUEST.
      JSB MVPC       (EMPTY AT PRESENT) 
* 
* SEND REQUEST TO THE 3000 AND WAIT FOR THE REPLY.
      JSB D3KMS     SEND REQUEST AND GET REPLY. 
      DEF *+2 
      DEF BIT15 
      JMP E3K       ERROR RETURN. 
* 
      JSB CLER      CLEAR DS/1000 ERROR INDICATOR.
      CLA           RETURN ERROR CODE ZERO. 
      STA ERRAD,I 
      JMP RTRN,I    RETURN. 
      SKP 
* 
* MOVE PCB FROM USER ARRAY TO REQUEST BUFFER. 
* 
MVPC  NOP 
      STA TAGPR     POINTER TO PCB. 
      LDA N3
      STA CONTR 
MVP1  LDA TAGPR,I 
      JSB D$STW 
      ISZ TAGPR 
      ISZ CONTR 
      JMP MVP1
      JMP MVPC,I
      SPC 3 
* 
* SET UP FOR POPEN/PCLOSE.
* 
SETOC NOP 
      LDA B7        SET CLASS TO 7
      STA D$3BF 
      LDA B21        AND STREAM TO 21.
      STA D$3BF+2 
* 
      LDA "RF"      STORE "RFA ". 
      JSB D$STW 
      LDA "A" 
      JSB D$STW 
* 
      JMP SETOC,I   RETURN. 
      SPC 3 
*  D3KMS REPORTED AN ERROR. SET UP DS/1000 HEADER IN CASE USED CALL DSERR.
* 
E3K   DST RQB+#EC1  SAVE ASCII ERROR CODE.
      LDA #NODE     STORE NODE #
      IOR BIT15      AND "ASCII" BIT. 
      STA RQB+#ENO
      CLA           CLEAR QUALIFIER.
      STA RQB+#ECQ
      LDA RQB+#EC1  RESTORE ASCII CODE. 
      JMP ERR       CONVERT TO NUMERIC. 
      SKP 
* 
* CONSTANTS AND WORKING STORAGE.
* 
B0    OCT 0 
B1    OCT 1 
B6    OCT 6 
B7    OCT 7 
B21   OCT 21
B22   OCT 22
B23   OCT 23
B24   OCT 24
B25   OCT 25
B26   OCT 26
K10   DEC 10
K13   DEC 13
N3    DEC -3
N4    DEC -4
N5    DEC -5
N14   DEC -14 
N17   DEC -17 
N20   DEC -20 
N21   DEC -21 
N42   DEC -42 
N44   DEC -44 
CL205 OCT 040315
CL209 OCT 040321
CG210 OCT 000322
CG211 OCT 000323
CL213 OCT 040325
MAXSZ DEC 4096      MAXIMUM USER BUFFER SIZE. 
"RF"  ASC 1,RF
"A"   ASC 1,A 
BLNKS ASC 1,
TEMP  NOP 
* 
TAGPR NOP 
CONTR NOP 
      XIF 
* 
      LST 
* 
      BSS 0         SIZE OF POPEN 
* 
      END