ASMB,Q,C
      HED FWRIT: HP 3000 RFA SUBROUTINE * (C) HEWLETT-PACKARD CO. 
      NAM FWRIT,7 91750-1X121 REV.2013 790328 MEF 
      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 THE HEWLETT-PACKARD COMPANY.   *
******************************************************************
      SPC 2 
      ENT FWRIT,FWDIR,FUPDT 
* 
      EXT .ENTR,D3KMS,D$INI,D$RFH,D$STW,D$PRM,D$ERR 
      SPC 2 
      UNL           NEXT 5 LINES ARE FOR PRODUCTION ENGINEERING 
*  NAME: FWRIT
*SOURCE: 91750-18121
* RELOC: 91750-1X121
*  PGMR: DMT
      LST 
*************************  FWRIT  ************************* 
*                                                         * 
*      SOURCE: 91750-18121                                * 
*                                                         * 
*      BINARY: 91750-1X121                                * 
*                                                         * 
*      PROGRAMMER: JIM HARTSELL                           * 
*                                                         * 
*      AUGUST 13, 1975                                    * 
*                                                         * 
*---------------------------------------------------------* 
*                                                         * 
*   MODIFIED FOR DS/1000 ENHANCEMENTS BY DMT BEGINNING    * 
*   MARCH 26, 1979.                                       * 
*                                                         * 
*********************************************************** 
      SPC 2 
A     EQU 0 
B     EQU 1 
      SUP 
      SPC 2 
FWRIT NOP           FWRITE. 
      JSB ENTRY 
B6    OCT 6 
* 
FWDIR NOP           FWRITEDIR.
      JSB ENTRY 
      OCT 7 
* 
FUPDT NOP           FUPDATE.
      JSB ENTRY 
B12   OCT 12
* 
ENTRY NOP 
      LDA ENTRY,I   SAVE FUNCTION CODE. 
      STA FCN 
      CLA           CLEAR OLD PARAM ADDRESSES.
      STA PRAMS 
      STA PRAMS+1 
      STA PRAMS+2 
      STA PRAMS+3 
      LDA ENTRY     SET UP FOR .ENTR CALL.
      ADA N2
      LDA A,I 
      STA RETRN 
      JMP BEGIN 
* 
PRAMS NOP           FILE NUMBER 
      NOP           BUFFER ADDRESS
      NOP           BUFFER LENGTH 
      NOP           CONTROL WORD OR RECNUM. 
* 
RETRN NOP           ENTRY POINT.
BEGIN JSB .ENTR     GET ADDRS OF USER PARAMS. 
DPRAM DEF PRAMS 
* 
      CLA           CLEAR ERROR CODE FOR FCHECK.
      CLB 
      DST D$ERR 
* 
* BUILD FRONT END OF REQUEST BUFFER.
* 
      LDA DPRAM     ADDR OF 1ST PARAM TO SEND.
      JSB D$INI     INITIALIZE BUFFER STUFFERS. 
* 
      JSB D$RFH     SET UP FIXED FORMAT.
* 
      LDA FCN 
      JSB D$STW     FWRIT = 6, FWDIR = 7, FUPDT = 12. 
* 
* MOVE USER PARAMS TO REQUEST BUFFER. 
* 
      CCA 
      JSB D$PRM     MOVE FNUM.
* 
      LDA PRAMS+1   IF NO TARGET ADDR,
      SZA,RSS 
      STA PRAMS+2    CLEAR TCOUNT ADDR. 
      CLA 
      LDA PRAMS+2,I 
      JSB D$STW     STORE TCOUNT. 
* 
      LDA FCN       IF UPDATE, NO MORE PARAMS.
      CPA B12 
      JMP SEND
* 
      CLA           CLEAR (A) IN CASE NO PARAM. 
      LDA PRAMS+3,I 
      JSB D$STW     MOVE CONTROL WORD OR RECNUM.
* 
      LDB FCN       IF FWRITE,
      CPB B6
      JMP SEND        DONE WITH APPENDAGE.
* 
      LDA PRAMS+3   FOR FWRITEDIR, STORE
      SZA            WORD TWO OF RECNUM.
      INA 
      LDA A,I 
      JSB D$STW 
* 
* 
* SEND REQ AND DATA TO 3000 BY WRITING TO QUEX'S CLASS. 
* 
SEND  JSB D3KMS     SHIP REQUEST BUFFER TO QUEX,
      DEF *+4        AND WAIT FOR REPLY.
      DEF BIT15 
      DEF PRAMS+1,I 
      DEF PRAMS+2,I 
      JMP ABERR     ERROR RETURN. 
      JMP RETRN,I   NORMAL RETURN.
* 
ABERR DST D$ERR     STORE CODE FOR FCHEK RETRIEVAL. 
      CLA 
      JMP RETRN,I   RETURN. 
      SPC 3 
* 
N2    DEC -2
BIT15 OCT 100000
FCN   NOP 
* 
      BSS 0         SIZE OF FOPEN 
* 
      END 
                                                                                                                                            