SPL,L,O,M,C 
!     NAME:   ST.DU 
!     SOURCE: 92064-18153 
!     RELOC:  92064-16055 
!     PGMR:   G.A.A.
!     MOD:    G.L.M.
! 
!  ***************************************************************
!  * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1977.  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.       *
!  ***************************************************************
! 
! 
      NAME ST.DU(7) " 92064-16055  REV.1650  761029"
! 
!     THIS IS THE RTE FMP FMGR ROUTINE TO STORE 
!     AND DUMP FILES. 
! 
!     DU,NAME,LU,OP1,OP2,OP3
! 
!        O R
! 
!     ST,LU,NAME,OP1,OP2,OP3,OP4
! 
! 
!     W H E R E:
! 
!     ST            IS STORE. 
!     DU            IS DUMP.
! 
!     NAME
!     NAME          IS THE FILE TO BE STORED OR DUMPED. 
! 
!     LU            IS EITHER THE SOURCE OR DESTINATION 
!                   DEVICE AND MAY BE A FILE REFERENCE. 
! 
!     OP1           IS A MEDIUM ASC CODE AS FOLLOWS:
!                     AS   ASCII DATA 
!                     BR   BINARY RELOCATABLE DATA
!                     BA   BINARY ABSOLUTE DATA 
!                     MT   MAG TAPE NORMAL FORMAT 
!                     MS   MAG TAPE SIO FORMAT
! 
!     OP2           IS AN END OF FILE OPTION
!                   FLAG -- TWO ASC CHARACTERS: 
!                     SA   SAVE END OF FILES IN THE 
!                          NEW FILE.
!                     IN   INHIBIT ALL LEADER, TRAILER, 
!                          END OF FILE TRANSFERS; 
!                          DOES NOT APPLY TO FINAL
!                          EOF ON A DISC FILE.
! 
!     OP3           IS THE NUMBER OF THE FIRST FILE 
!                   TO BE TRANSFERRED (APPLIES TO 
!                   FILES OF TYPE ZERO) (DEFAULT=1) 
! 
!     OP4           IS THE NUMBER OF FILES TO BE
!                   TRANSFERRED (APPLIES TO FILES 
!                   OF TYPE ZERO) (DEFAULT= ) 
! 
!     N O T E:      OP3 AND OP4 ARE RELATIVE TO CURRENT POSITION. 
! 
!     DEFINE EXTERNALS
! 
      LET IDCB1,IDCB2,BUF. BE INTEGER,EXTERNAL
! 
      LET N.OPL,.E.R       BE INTEGER,EXTERNAL
! 
      LET CREA.,OPEN.,LOCF,\
          EXEC,READF,WRITF,\
          MSS.,RWNDF,\
               CK.SM,CLOSE BE SUBROUTINE,EXTERNAL 
      LET IER.    BE SUBROUTINE,EXTERNAL,DIRECT 
! 
      LET IFBRK            BE FUNCTION,EXTERNAL 
! 
      LET DU..,ST..        BE SUBROUTINE
! 
      LET AS        BE CONSTANT (40523K)
      LET BR        BE CONSTANT (41122K)
      LET BN        BE CONSTANT (41116K)
      LET BA        BE CONSTANT (41101K)
      LET MT        BE CONSTANT (46524K)
      LET MS        BE CONSTANT (46523K)
      LET IH        BE CONSTANT (44510K)
      LET SA        BE CONSTANT (51501K)
! 
ST..: SUBROUTINE(NPD,LISTO,ERD)  GLOBAL 
      ERD_ -1  !SET DUMP FLAG 
      DU..(NPD,LISTO,ERD) 
      RETURN
      END 
! 
DU..: SUBROUTINE(NPS,LISTS,ERS)  GLOBAL 
      LI12_[LIS8_[LIS4_@LISTS+4]+4]+4 
! 
      LIS21_[LIS17_[LIS13_[LIS9_[LIS5_[LIS1_\ 
        @LISTS+1]+4]+4]+4]+4]+4 
! 
!     PRESET DEFAULT OPTIONS
! 
      OBUF,SPDCB_@IDCB2      !SET DCB ADDRESS FOR SPACING 
      IBUF_@IDCB1       !SET INPUT DCB ADDRESS
      BUFF,BUFA,BF_@BUF.
      DO[F1,SIOI,EOFF,CK,SIO,FLG,LDR_0]         
      DO[SUBF_400K;F2,TYP,DUMP_1] 
      IFNOT ERS+1 THEN [ERS,DUMP_0;SPDCB_IBUF] !SET STORE OPTIONS 
      IF NPS<2 THEN [ERS_55;RETURN] 
      DT_3   !SET DEFAULT TYPE
! 
!     ANALYZE OPTIONS 
! 
!       FIRST THE TYPE FLAG 
! 
      IFNOT $LIS8 THEN GO TO ST3 !OPTION IS NULL GO TO CHECK NEXT 
      IF $LIS9 = MS THEN [SIO_1;BUFA_BF+1;\ 
                             LIS9_LIS9+1] 
      IF $LIS9="  " THEN GO TO ST3
         IF $LIS9 = AS THEN [SUBF_410K;GO TO ST3] 
         IF $LIS9 = BR THEN[CK,SUBF_310K;\
                       DT_5; GO TO ST3] 
         IF $LIS9 = BN THEN[SUBF_310K;   \
                             GO TO ST3] 
      IF $LIS9 = BA THEN[CK,SUBF_2310K;TYP_0;\
                        DT_7;GO TO ST3] 
      IF $LIS9 = MT THEN GO TO ST3
      IF $LIS9 = SA THEN[EOFF_1;GO TO ST2]
      IF $LIS9 = IH THEN[LDR_20000K;GO TO ST2]  
! 
STER1:DO[ERS_56; RETURN]
! 
!     CHECK FOR OP2 
! 
ST3:  IF $LI12#3 THEN GO TO ST2 
! 
      IF $LIS13 = SA THEN[EOFF_1;GO TO ST5] 
      IF $LIS13 = IH THEN[LDR_20000K;GO TO ST5] 
! 
      GO TO STER1   !ILLEGAL OPTION 
!     OPT2          WAS FOUND IN OP1 LOCATION SO
!                   ADJUST ADDRESSES AND SKIP 
!                   OPT2 CHECK. 
! 
! 
ST2:  DO[LIS21_[LIS17_LIS13]+4] 
ST5:  OPEN.(IDCB1,$LIS1,N.OPL  ,SUBF+1) 
      LOCF(IDCB1,.E.R ,ID,ID,ID,ISZ,ILU,INTY,ISZ2)
      IER.
      IF $LIS17>0 THEN F1_$LIS17-1
      IF $LIS21>0 THEN F2_$LIS21, ELSE \
         [IFNOT $LIS21 THEN [IF$LIS17>0 THEN GOTO ST6,ELSE[\
                             IF    INTY THEN F2_9999]]] 
! 
ST6:  SUBF_(SUBF AND 100K)+LDR     \SET OUTPUT FUNCTION 
         OR[IF (INTY AND 177775K)=5 THEN 100K,ELSE 0] 
      IF $LIS9=AS THEN SUBF_SUBF AND 177677K
!     IF A STORE OPERATION CREAT THE FILE 
! 
      SZ1_[SZ_[TY_[OPLS_@N.OPL+5]+2]+1]+1 
! 
      IFNOT ERS+2 THEN[ERS_0;GO TO ST12] !COPY CALL THE FILE IS OPEN
      IF DUMP THEN GO TO ST10 
! 
!     SET DEFAULTS
! 
      IFNOT $TY THEN $TY_[IF INTY THEN INTY,\ 
         ELSE DT] 
      IFNOT $SZ THEN $SZ_[IF INTY THEN ISZ->1,\ 
                           ELSE 15 ]       !NOTE THIS DEFAULT 
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      IFNOT $SZ1 THEN[IF INTY THEN $SZ1_ISZ2] 
! 
!     CREAT THE FILE
! 
      CREA.(IDCB2,$LIS5,$OPLS)?[GO TO ST10] 
      GO TO ST12
ST10:      OPEN.(IDCB2,$LIS5,$OPLS,SUBF)
ST12: LOCF(IDCB2,.E.R ,ID,ID,ID,ISZ,OLU,OUTY) 
      IER.
      IF INTY=6 THEN $(IBUF+2),INTY_1 
      IF OUTY=6 THEN $(OBUF+2),OUTY_1 
! 
!     BOTH IN AND OUT ARE OPEN -- 
!     LEADER HAS BEEN PUNCHED IF NOT SUPPRESSED.
! 
!     IF SIO STORE THEN SET IT UP 
! 
      IF SIO THEN [IFNOT DUMP THEN[\
         SIO_0; SIOI_1;BUFF_[BUFA_BF]+1]] 
! 
      UNTIL F1=0 DO[READF($SPDCB,.E.R ,$BUFA,128,ALN);IER.;\
         IF ALN<1 THEN[F1_F1- 1; IF IFBRK() THEN GO TO BRK]]
ST15: READF(IDCB1,.E.R ,$BUFA,128,ALN)
      IF IFBRK() THEN[\  IF BREAK THEN
BRK:  MSS.(0);GO TO KILL]    ! SEND BREAK ERROR AND GO FLUSH THE FILE 
      IF .E.R = -12 THEN [ALN_ -1;GO TO ST16] 
      IER.
      IF ALN>0 THEN GO TO ST20 ! DATA?
! 
!     NO DATA -- EITHER EOF OR ZERO REG 
! 
! 
!     END OF XFER?
! 
ST16: IFNOT ALN+1 THEN[IF INTY THEN[F2_0;\
                GO TO ST18]]!TRUE EOF-QUIT
! 
      IF [F2_F2-1] THEN [IF EOFF THEN[ALN_-1;\
                GO TO ST22],ELSE GO TO ST25]
ST18: ALN_-1
      IFNOT LDR  THEN GO TO ST22       !IF INHIBIT NOT REQUESTED--EOF 
! 
      GO TO EXIT   !DONE - NO EOF REQUIRED
! 
ST20: DO            [IF SIOI THEN [ALN_[\ 
          IF $BUFA<0 THEN-$BUFA,ELSE\ 
           ($BUFA+1)>-1];ID_BUFA+1],ELSE\ 
             ID_BUFA ;IF CK THEN[\
                CK.SM($ID,TYP)?[GO TO ABO];ALN_($ID-<8)+(1-TYP)*3]] 
      FLG_1  !SET FLAG TO SAY WE WROTE A RECORD 
ST22: IF ALN>0 THEN[IF SIO THEN[$BUFF_-ALN;ALN_ALN+1]],\
        ELSE[IF F2 THEN[IF OUTY THEN ALN_0]]
      WRITF(IDCB2,.E.R ,$BUFF,ALN)
      IF .E.R  = -6 THEN[MSS.(.E.R );GO TO KILL]
      IER.
      IF ALN= -1 THEN[IFNOT F2 THEN GOTO EXIT,\ 
                ELSE GO TO ST25  ]
      IF ALN THEN GO TO ST15
ST25: EXEC (13, ILU,EQT5) 
      IF(EQT5 AND 37400K)=400K THEN [MSS.(2006);\ 
           EXEC(7)] 
      GO TO ST15
! 
ABO:  MSS.(7)       !SEND CHECK SUM ERROR 
KILL: ID_-1      !SET TO ABORT THE FILE 
ENDIT:IF DUMP THEN RETURN 
      IFNOT OUTY THEN RETURN
      IF ID<0 THEN RWNDF(IDCB2)  !REWIND TO BE SURE OF PURGE
      CLOSE(IDCB2,.E.R ,$SZ-ID-1)  !CLOSE AND 
      IER.
      RETURN
! 
EXIT: LOCF(IDCB2,.E.R ,T,ID)
      IER.
      IFNOT FLG THEN ID_-1
      GO TO ENDIT 
      END 
! 
! 
      END 
      END$
                                                      