SPL,L,O,M 
!     NAME:   SA..
!     SOURCE: 92067-18211 
!     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 SA..(8) "92067-16185 REV.2026 800304"
! 
!  MODIFICATION RECORD: 
! 
!      DATE     REASON
!  1) 780427    TO MAKE IER. CALL ON RETURN FROM CREA. (BL) 
!               (IER. CALL REMOVED FROM CREA.)
!  2) 780920    TO USE EXTENDED FMP CALLS (ECREA,ELOCF,ECLOS) 
!               TO ACCEPT SIZE IN -MULTIPLE NUMBER OF BLOCKS
!  3) 800304    TO CORRECT TRUNCATION CALCULATION (SST #4732) 
! 
!     THIS ROUTINE IS THE SAVE LS/LG ROUTINE FOR THE
!     RTE FMGR PROGRAM.  IT IS ENTERED BY ENTERING
!     A COMMAND OF THE FORM:
! 
!     SA,LS/LG,NAMR 
!PRAM LOC 1     5 
! 
!     W H E R E:
! 
!     SA       IS THE COMMAND NAME. 
! 
!     LS/LG    IS LS TO SAVE THE LS FILE, 
!              OR LG TO SAVE THE LOAD & GO FILE.
! 
!     NAMR     IS TO BE THE NEW FILE'S NAME REFERENCE.
! 
! 
!     THE FOLLOWING NAMR PARAMETERS ARE OPTIONAL: 
! 
!     CR       IS THE CARTRIDGE TO BE USED TO SAVE
!              (ZERO IF NOT GIVEN). 
! 
!     SC       IS THE FILE'S SECURITY CODE
!              (ZERO IF NOT GIVEN). 
! 
!     TY       IS THE FILE'S TYPE (4 FOR LS OR
!              5 FOR LG IF NOT GIVEN).
! 
!     SZ1      IS THE FILES SIZE ESTIMATE USED FOR LS FILES ONLY
!              IF NOT GIVEN THE THE FILE IS ESTIMATED TO FILL 
!              LESS THAN HALF A TRACK. EXCESS  THEN GENERATES AN EXTENT 
!              IF LESS THAN THE ESTIMATED SIZE IS USED THE
!              EXCESS IS RETURNED TO THE SYSTEM 
! 
!     CONSTANT DECLARATIONS 
! 
      LET XEQT      BE CONSTANT (1717K) 
      LET SECT2     BE CONSTANT (1757K) 
      LET SECT3     BE CONSTANT (1760K) 
      LET LGOTK     BE CONSTANT (1765K) 
      LET LGOC      BE CONSTANT (1766K) 
      LET LG        BE CONSTANT (46107K)
      LET LS        BE CONSTANT (46123K)
! 
!     DECLARE THE ERROR WORD LOCATION 
! 
      LET .E.R.,N.OPL BE INTEGER,EXTERNAL 
! 
!     ARRAY DECLARATIONS
! 
      LET O.BUF,I.BUF,BUF.,CUSE. BE INTEGER,EXTERNAL
      LET IRBN(2),IRCN(2),ITRUN(2),ISIZ(4),JSIZ(2), \ 
          DW1(2),DW2(2),BLKMP(2) BE INTEGER 
! 
      INITIALIZE BLKMP TO 0,128 
      INITIALIZE DW1   TO 0,1 
      INITIALIZE DW2   TO 0,2 
! 
!     SUBROUTINE DECLARATIONS 
! 
      LET ECREA,OPEN.,IER.,\
          WRITF,ELOCF,ECLOS,CLOS.,\ 
          READ.,READF,RWNDF,\ 
          MSS.,EXEC,CK.SM  BE SUBROUTINE,EXTERNAL 
      LET .DDI,.DMP,.DSB   BE SUBROUTINE,EXTERNAL,DIRECT
! 
      LET LSRD,LGRD,READR,\ 
          GET                BE SUBROUTINE
! 
      LET IFBRK              BE FUNCTION,EXTERNAL 
      LET LG.S               BE FUNCTION
SA..: SUBROUTINE(NCAM,PLIST,MSNO)GLOBAL 
      LET NCAM,PLIST,MSNO BE INTEGER
      LIS5_[LIS1_@PLIST+1]+4  !SET LIST ADDRESSES 
      SZ_[RS _[SC_@N.OPL+5]+2]+1  !SET OPTION LIST ADDRESSES
! 
      IF NCAM<2 THEN[MSNO_50;RETURN]
      IF $LIS1=LG THEN GO TO SALG 
      IF $LIS1#LS THEN [MSNO_56; RETURN]  !NOT LS OR LG SO ABORT
      CUSE._0       !SHOW SEGMENT NOT IN CORE FOR NEXT TIME 
      OPFL_101000K  !SET PUNCH OPTION FLAG
      DO[T1_4;SIZE_$SECT2/4;RD_@LSRD]!SET UP DEFAULT SIZE 
SA02: IFNOT $SZ THEN $SZ_SIZE    !SET DEFAULT SIZE IF NOT SUPPLIED
      IFNOT $RS  THEN $RS _T1   !SET DEFAULT TYPE 
      TYPE_$RS   !SET TYPE FOR LATER
      CLOS.(O.BUF)
      IF $LIS5 < 64 THEN           \OPEN IF NOT A FILE NAME 
         [TYPE_0;                  \
          OPEN.(O.BUF,$LIS5,$SC,OPFL); \
          GO TO CONT1]
      IF $SZ < 0 THEN [            \IF FILE SIZE NEGATIVE, THEN 
         IF $SZ = -1 THEN          \IF SIZE = -1, THEN
            ISIZ(1),ISIZ(2)_ -1,   \MAKE DOUBLE WORD, ELSE
         ELSE [.B._ -$SZ;.A._0;    \MAKE POSITIVE AND 
          CALL .DMP(BLKMP);        \MULTIPLY BY BLK MULTIPLIER
          ISIZ(1)_.A.;ISIZ(2)_.B.]],\SAVE FOR ECREA 
      ELSE [ISIZ(1)_0;ISIZ(2)_$SZ] !ELSE CONVERT TO DOUBLE WORD 
      ISIZ(3)_0 
      ISIZ(4)_$(@N.OPL+9)          !RECORD SIZE 
      CALL ECREA(O.BUF,.E.R.,$LIS5,ISIZ,TYPE,$SC,$(SC+1),144,JSIZ)
      IER.
CONT1:FIRST_1 
LOOP: CALL $RD      !READ A RECORD
      IF IFBRK() THEN [MSS.(0);GO TO ABOR]
      L_IL
      IFNOT IL THEN[IFNOT TYPE THEN L_-1] 
      WRITF(O.BUF,.E.R.,BUF.,L)   !WRITE IT 
      IF .E.R.= -6 THEN[MSS.(.E.R.);GOTO ABOR]!PURGE FILE 
      IER.          ! ANY ERRORS? 
      IF IL=>0 THEN GO TO LOOP  ! IF NOT EOF CONTINUE 
! 
      IFNOT TYPE THEN RETURN
      ELOCF(O.BUF,.E.R.,IRCN,IRBN) !GET CURRENT POSITION
      IER.
TRUN: .B._JSIZ(2);.A._JSIZ(1)      !ACTUAL SIZE 
      CALL .DDI(DW2)               !CONVERT SECTORS TO BLKS 
      CALL .DSB(IRBN) 
      CALL .DSB(DW1)
      ITRUN(1)_.A.;ITRUN(2)_.B. 
      ECLOS(O.BUF,.E.R.,ITRUN)     !CLOSE & TRUNCATE
      IER.
EXIT: RETURN                   !DONE RETURN 
SALG: TY_0  !SET LOAD & GO FLAG 
      T1_5  !SET DEFAULT TYPE 
      OPFL_101100K  !SET THE OPTION FLAG
      SIZE  _(([T_LG.S() ?[MSNO_58;RETURN]]+3)>-1)+T/5 !SIZE ESTIMATE 
      RD_@LGRD  !SET THE READ ROUTINE ADDRESS 
      GO TO SA02  !GO DO IT 
      END 
LSRD: SUBROUTINE
      READ.(2,BUF.,70,IL) 
      RETURN
      END 
! 
LGRD: SUBROUTINE
      BUF1_[BUF_@BUF.]+1
      IFNOT FIRST THEN GOTO XFER
         IBUF4_[IBUF3_[IBUF2_[IBUF_@I.BUF]+2]+1]+1
      IBU15 _[IBUF9_[IBUF8_[IBUF7_[IBUF6_[IBUF5_ \ SET UP BUFFER ADDRESSES
      IBUF4+1    ]+1]+1]+1]+1]+6
      $IBUF_[IF $LGOTK<0 THEN 3,ELSE 2] 
      $(IBUF2 )_2 
      $(IBUF3 )_($LGOTK AND 77600K)-<9
      $IBUF4,$IBU15_0 
      $IBUF7_200K 
      $(IBUF5)_([MXRC_LG.S()]+3)
      $IBUF6_64 
      $(IBUF8 )_[IF $IBUF=3 THEN $SECT3,ELSE $SECT2]
      $(IBUF9 )_$XEQT 
      RWNDF(I.BUF,.E.R.)
      IER.
      DO[RC,FIRST,ENFLG_0;READR]
XFER: IFNOT ENFLG THEN GOTO LGRD2 
      IF ENFLG=1 THEN[ENFLG_2;IL_0;RETURN]
LGRD1:DO[ENFLG_0;IF ADD#@PLIST THEN READR;IL_-1;\ 
                 IF RC>MXRC THEN RETURN]
LGRD2:GET(BUF.,1) 
      IFNOT $BUF THEN GO TO LGRD1 
      GET ( $BUF1  ,[IL_$BUF-<8]-1) 
      CK.SM(BUF.,1)?[GOTO ABORT]
      IF ( $BUF1   AND 160000K)=120000K THEN ENFLG_1
      RETURN
ABORT:MSS.(7) 
ABOR: IFNOT TYPE THEN GO TO EXIT  ! IF TYPE ZERO THEN EXIT
      DO[$(@O.BUF+15)_0;IRBN(1),IRBN(2)_-1;GO TO TRUN]
      END 
! 
! 
GET:  SUBROUTINE(DS,NO) 
      ED_@DS+NO-1 
      FOR I_@DS TO ED DO THRU GET0
      $I_$ADD 
      ADD_ADD+1 
GET0: IF ADD=ENADD THEN READR 
      RETURN
      END 
! 
READR:SUBROUTINE
      DO[READF(I.BUF,.E.R.,PLIST);IER.] 
      ENADD_[ADD_@PLIST]+64 
      RC_RC+1 
      RETURN
      END 
! 
LG.S: FUNCTION FEXIT
      LG.SV_((($LGOC AND 77600K)-($LGOTK AND 77600K))\
            -<9)*[IF $LGOTK<0 THEN $SECT3,ELSE $SECT2]\ 
                +($LGOC AND 177K) 
      IF LG.SV THEN RETURN,ELSE FRETURN 
      END 
      END 
      END$
                                                                                              