SPL,L,O,M 
!     NAME:   ST.DU 
!     SOURCE: 92067-18227 
!     RELOC:  92067-16185 
!     PGMR:   G.A.A.
! 
!  ***************************************************************
!  * (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.       *
!  ***************************************************************
! 
      NAME   ST.DU(8) "92067-16185 REV.2040 800731" 
! 
!  MODIFICATION RECORD: 
! 
!      DATE     REASON
!  1) 780427    TO CALL IER. ON RETURN FROM CREA. (BL)
!               (IER. CALL REMOVED FROM CREA.)
!  2) 780920    TO USE EXTENDED FMP ROUTINES (ECREA,ELOCF,ECLOS)
!  3) 790222    TO KILL DESTINATION FILE IF -5 ERROR ON READ, OR
!               -33 ERROR ON WRITE
!  4) 790314    TO CHANGE TYPE 0 TEST FROM < 64 TO <= 20000K
!  5) 800311    TO REPORT WARNING ON TRUNCATION OF RECORDS TO 
!               128 WORDS FOR TYPE 2
!  6) 800731    IF REC FMT=MS, ALLOW ONLY AS,BR,BN,BA AS
!               SECONDARY REC FMT (SST #4878) 
! 
!     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          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.
!                     IH   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 I.BUF,O.BUF,BUF. BE INTEGER,EXTERNAL
! 
      LET N.OPL,.E.R.      BE INTEGER,EXTERNAL
! 
      LET ECREA,OPEN.,ELOCF,ECLOS,CLOS.,\ 
          EXEC,READF,WRITF,\
          MSS.,RWNDF,\
          IER.,CK.SM       BE SUBROUTINE,EXTERNAL 
      LET .DDI,.DMP,.DSB   BE SUBROUTINE,EXTERNAL,DIRECT
! 
      LET IFBRK            BE FUNCTION,EXTERNAL 
! 
      LET DU..,ST..        BE SUBROUTINE
! 
      LET IDMY(2),ISZ(2),JSZ(4),RSIZ(2),ID1(2), \ 
          BLKMP(2),DW1(2),DW2(2),DW4(2) BE INTEGER
! 
      LET SECT2     BE CONSTANT(1757K)
      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)
! 
      INITIALIZE BLKMP TO 0,128 
      INITIALIZE DW1   TO 0,1 
      INITIALIZE DW2   TO 0,2 
      INITIALIZE DW4   TO 0,4 
! 
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_@O.BUF      !SET DCB ADDRESS FOR SPACING 
      IBUF_@I.BUF       !SET INPUT DCB ADDRESS
      BUFF,BUFA,BF_@BUF.
      DO[F1,SIOI,EOFF,CK,SIO,FLG_0;LDR_100000K] 
      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] 
      IFNOT SIO THEN                           \
         [IF $LIS9 = MT THEN GO TO ST3;        \
          IF $LIS9 = SA THEN[EOFF_1;GO TO ST2];\
          IF $LIS9 = IH THEN[LDR_0;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_0;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.(I.BUF,$LIS1,N.OPL  ,SUBF+1)    !OPEN SOURCE NAMR
      ELOCF(I.BUF,.E.R.,IDMY,IDMY,ID,ISZ,ILU,INTY,ISZ2) 
      IER.
      IF INTY=2 THEN [                     \IF TYPE 2 AND RECLEN >  
         IF ISZ2 > 128 THEN MSS.(79)]      !128 WDS, PRINT WARNING
      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 110K)+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, CREATE 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] 
      IF $SZ THEN [                \IF SIZE SPECIFIED, THEN 
         IF $SZ < 0 THEN           \IF SIZE NEGATIVE, THEN
            [IF $SZ = -1 THEN      \IF SIZE = -1, THEN
               JSZ(1),JSZ(2) _ -1, \MAKE DOUBLE WORD, ELSE
             ELSE [.B._ -$SZ;.A._0; \MAKE POSITIVE AND
             CALL .DMP(BLKMP);     \MULTIPLY BY BLK MULTIPLIER
             JSZ(1)_.A.;JSZ(2)_.B.]], \SAVE FOR ECREA 
         ELSE [JSZ(1)_0;JSZ(2)_$SZ]], \SZ POSITIVE, MAKE DOUBLE WD
      ELSE                         \SIZE NOT SPECIFIED, SO
         [IF INTY THEN             \IF NOT TYPE 0, DEFAULT SIZE 
           [.B._ISZ(2);.A._ISZ(1); \TO SIZE FROM "FROM" FILE
            CALL .DDI(DW2)],       \CONVERTING SECTORS TO BLOCKS
          ELSE [.B._ $SECT2;.A._0; \TYPE 0, SO DEFAULT SIZE TO
                CALL .DDI(DW4)];   \SECTORS PER TRACK/4 
          JSZ(1)_.A.;JSZ(2)_.B.]   !SAVE FOR ECREA
      JSZ(3)_0
      IF $SZ1 THEN JSZ(4)_$SZ1,    \IF RECD SIZE, USE IT
         ELSE [IF INTY THEN $SZ1,JSZ(4)_ISZ2] 
! 
!     CREAT THE FILE
! 
      CLOS.(O.BUF)
      IF $LIS5 <= 20000K THEN GOTO ST10 
      ECREA(O.BUF,.E.R.,$LIS5,JSZ,$TY,$OPLS,$(OPLS+1),144,RSIZ) 
      IER.
      GO TO ST12
ST10:      OPEN.(O.BUF,$LIS5,$OPLS,SUBF)
ST12: ELOCF(O.BUF,.E.R.,IDMY,IDMY,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(I.BUF,.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] 
      IF .E.R.= -5 THEN [MSS.(.E.R.);GO TO KILL] !PURGE DESTINATION FL
      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
      IF LDR  THEN GO TO ST22 
! 
      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(O.BUF,.E.R.,$BUFF,ALN)
      IF .E.R. = -33 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: ID1(1),ID1(2)_-1                 !SET TO ABORT THE FILE 
ENDIT:IF DUMP THEN RETURN 
      IFNOT OUTY THEN RETURN
      IF ID1(1) < 0 THEN RWNDF(O.BUF)  !REWIND TO BE SURE OF PURGE
      .B._RSIZ(2);.A._RSIZ(1)          !ACTUAL FILE SIZE
      CALL .DDI(DW2)                   !CONVERT SECTORS TO BLOCKS 
      CALL .DSB(ID1)
      CALL .DSB(DW1)
      IDMY(1)_.A.;IDMY(2)_.B. 
      ECLOS(O.BUF,.E.R.,IDMY)          !CLOSE AND TRUNCATE
      IER.
      RETURN
! 
EXIT: ELOCF(O.BUF,.E.R.,IDMY,ID1,IOF) 
      IER.
      IF OUTY < 3 THEN[                \IF TYPE 2 OR 1  
         IFNOT IOF THEN                \ADJUST RB FOR ZERO OFFSET 
            [.B._ID1(2);.A._ID1(1);    \  
             CALL .DSB(DW1);           \  
             ID1(1)_.A.;ID1(2)_.B.]]
      IFNOT FLG THEN ID1(1),ID1(2)_-1 
      GO TO ENDIT 
      END 
! 
! 
      END 
      END$
                                                