SPL,L,O 
!     NAME:   SP..
!     SOURCE: 92067-18229 
!     RELOC:  92067-16185 
!     PGMR:   G.A.A.
! 
!  ***************************************************************
!  * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979.  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 SP..(8) "92067-16185 REV.2026 800221"  
! 
!  MODIFICATION RECORD: 
! 
!      DATE     REASON
!  1) 780106    TO CLEAR WRITTEN-ON FLAG IN DCB SET-UP (GLM)
!  2) 780221    TO SET LAST PTN USED (ID22)=0  (GLM)
!  3) 780405    TO BYPASS ID EXTENSION SAVE FOR TYPE 5 (BL) 
!  4) 780427    TO OVERRIDE SESSION MONITOR CARTRIDGE CHECK & 
!               TO CALL IER. ON RETURN FROM CREA. (BL)
!  5) 780512    TO ACCESS NEW 256-WORD CARTRIDGE DIRECTORY (BL) 
!  6) 780810    TO USE NEW DCB FORMAT 
!  7) 790122    TO SAVE ID SEGMENT WORD 32
!  8) 790125    TO SAVE USER ID, SO TYPE 6 FILE CAN LATER BE PURGED 
!               BY THIS USER
!  9) 791016    TO ADD PROGRAM PROTECT OPTIONS FOR TYPE 6 FILES 
! 10) 800221    TO REMOVE DEFAULT OF CRN TO LU 2 (DCL)
! 
!     THE SP ROUTINE SAVES A PROGRAM
!     IN A FILE.  THE FIRST TWO SECTORS 
!     ARE SET UP TO ALLOW THE PROGRAM 
!     TO BE RESTORED TO THE SYSTEM
! 
!     THIS PROGRAM IS INVOKED BY :
!     SP,NAME[,PR/GR[,CAP]] 
!       WHERE:
!           NAME IS THE NAME OF THE PROGRAM TO BE SAVED 
!           PR, IF SPECIFIED, WILL ALLOW ONLY USERS WITH THIS 
!               PRIVATE ID TO RP OR RUN THIS TYPE 6 PGM 
!           GR, IF SPECIFIED, WILL ALLOW ONLY USERS WITH THIS 
!               GROUP ID TO RP OR RUN THIS TYPE 6 PGM 
!           CAP IS THE CAPABILITY LEVEL REQUIRED TO RP OR RUN 
!               THIS TYPE 6 PGM 
! 
!     DEFINE THE EXTERNALS
! 
      LET CREA.,                        \FMGR FILE CREATE ROUTINE 
          EXEC,                         \RTE EXEC 
          IER.,                         \FMGR ERROR PROCESSING
          OPEN.,                        \FMGR FILE OPEN ROUTINE 
          READF,                        \FMP FILE READ ROUTINE
          RWNDF,                        \FMP FILE REWIND ROUTINE
          WRITF,                        \FMP FILE WRITE ROUTINE 
          ISMVE,                        \MOVE WORDS FROM SCB
          SESSN                         \GET SCB ADDRESS IF SESSION 
               BE SUBROUTINE,EXTERNAL 
! 
      LET  ID.A                         \FETCH ID SEGMENT ADDRESS 
               BE FUNCTION,EXTERNAL 
! 
      LET .E.R.,                        \FMGR ERROR WORD
          D.SDR,                        \CARTRIDGE DIRECTORY BUFFER 
          N.OPL,                        \SUBPARAMETER ARRAY 
          O.BUF,                        \FMGR INTERNAL BUFFER 
          I.BUF,                        \FMGR INTERNAL BUFFER 
          S.CAP,                        \9P - SESSION CAPABILITY
          OVRD.                         \CARTRIDGE SEARCH OVERRIDE
               BE INTEGER,EXTERNAL
! 
      ASSEMBLE ["EXT $OPSY";"EXT $IDEX";"EXT $CL1";"EXT $CL2"]
      ASSEMBLE ["EXT $SMID";"EXT $SMGP"]
! 
!     DEFINE INTERNAL ROUTINES
! 
      LET ADS, SP.. BE SUBROUTINE 
! 
      LET MF            BE FUNCTION 
! 
!     DEFINE CONSTANTS
! 
      LET  XEQT    BE CONSTANT    (1717K) 
      LET  SECT2    BE CONSTANT  (1757K)
      LET  SECT3    BE CONSTANT  (1760K)
SP..: SUBROUTINE (N,LIS,ER)  GLOBAL 
      IFNOT N THEN [ER_50; RETURN]    !IF NO PARAMETERS, ERROR 50 
      OPT2_[TYP2_[OPT1_[PAD_@ LIS+1]+4]+3]+1 !SET PARAMETER ADDRESSES 
      ID32_[ID27_[ID_ ID.A($PAD)?[ER_14; RETURN]]+26]+5 !IDSEG ADDR 
! 
      BF,T1_@I.BUF                    !POINTERS TO BUFFER FOR IDSEG.
      FOR T_BF TO BF +127 DO $T_0     !ZERO THE ID SEGMENT BUFFER 
      FOR T_ID TO ID+25 DO [$T1_ $T;T1_T1+1] !COPY 1ST 26 WDS OF IDSEG
      T1_T1+2                         !BUMP POINTER TO BUFFER FOR IDSG
      FOR T_ID+28 TO ID+29 DO [$T1_$T;T1_T1+1] !COPY IDSEG WDS 29,30
      $(@I.BUF+31)_$ID32              !SAVE IDSEG WORD 32 
      ADS (BF+11) 
      ASSEMBLE ["LDA $OPSY";"STA OPSY";"LDA $IDEX";"STA IDEX"]
      T_$ID15 AND 7    !GET TYPE OF PGM 
      IF T>1 THEN [IF OPSY = -9 OR T#4 THEN GO TO SP2] !LEGAL CONTINUE
      ER_56   !ILLEGAL PROGRAM TYPE 
      RETURN
! 
SP2:  IF OPSY = -9 AND T#5 THEN [              \IF RTE-IV & NOT SEG.
        IF $ID22 >= 0 THEN[$ID22_ ($ID22 AND 177700K)];  \IF PTN NOT ASSIGNED 
                                               \SET LAST PTN USED=0 
                                               \  FOR DISP (780221 GLM) 
         IF $ID29 THEN [                       \AND IF EMA
            T_$(IDEX+(($ID29 AND 176000K)-<6));\THEN INDEX TO ID EXT
            T1_T1+5;                           \AND 
            $T1_($T AND 37K) OR 100000K;       \SAVE ID EXT WORD 0
            T1_T1+1;                           \AND 
            T_T+1;                             \SAVE ID EXT WORD 1
            $T1_$T AND 176000K]]
! 
      IF $ID15 AND 20K THEN[$(BF+7)_$ID12;  \ADJUST FOR SHORT ID
         T1_ID15   ;\ 
         FOR T_ID23 TO ID26 DO[\
             $T_$[T1_T1+1]];\ 
         ID27_ID20] 
      $ID16,$ID17,$(BF+8)_0 
      $ID18_($ID18 AND 167777K) 
! 
      ASSEMBLE ["LDA $SMID";"STA SMID"] 
      ASSEMBLE ["LDA $SMGP";"STA SMGP"] 
      CALL SESSN($XEQT)?[GOTO SP4]          !IN SESSION?
      SESWD_.B.                             !ID SEGMENT SESSION WORD
      CALL ISMVE(SESWD,SMID,$ID39,1)        !USER ID TO WORD 39 
      CALL ISMVE(SESWD,SMGP,$ID40,1)        !GROUP ID TO WORD 40
      IFNOT $(OPT1-1) THEN GO TO SP3        !NO PR/GR PARAMETER?
      IF $OPT1="PR" THEN                    \IF PR SPECIFIED, THEN
         $ID39_$ID39 OR 100000K, ELSE       \SET SIGN ON USER ID WORD 
            [IF $OPT1="GR" THEN             \IF GR SPECIFIED, THEN
               $ID40_$ID40 OR 100000K, ELSE \SET SIGN ON GROUP ID WD
                  [ER_56;RETURN]]           !ERR, NOT PR,GR OR NULL 
SP3:  IF $TYP2=3 THEN [ER_56;RETURN],       \IF CAP OPTION ASCII, ERR 
         ELSE $ID41_$OPT2                   !SAVE MINIMUM CAP LEVEL 
! 
SP4:  SZR_[SZ_[TY_[CR_ @N.OPL+1]+1]+1]+1
      $SZR_128                            !SET REC LENGTH TO 128
      $TY_6                               !SET TYPE TO 6
! 
!!! REMOVE DEFAULT OF CRN TO LU 2  (DCL) 800221 
!!!     IFNOT  $CR THEN $CR_-2              !DEFAULT CRN TO -2
! 
     $SZ_[XF_MF( ID23)+ MF( ID25)]+1
! 
      IF S.CAP THEN [                   \IF IN SESSION, THEN
         TEMP_OVRD.;                    \SAVE CURRENT STATE OF OVRD.
         OVRD._OVRD. OR 40000K]         !SET CARTRIDGE SEARCH OVERRIDE
      CREA. (O.BUF,$PAD,N.OPL)?[ER_-15; \ 
         IF S.CAP THEN OVRD._TEMP;RETURN] 
      IF S.CAP THEN OVRD._TEMP          !IF SESSION, RESET OVRD'S STATE 
      IER.
! 
      $(@O.BUF+2)_1  !FORCE TO TYPE 1 
      ASSEMBLE ["LDA $CL1";"STA CL1";"LDA $CL2";"STA CL2"]
      CALL EXEC(1,2,D.SDR,256,CL1,CL2)    !READ THE SET UP WORD 
! 
      $ID35_$(253+@D.SDR)               !MOVE TO ID BLOCK 
      I.BUF_ -1       !SET EOF FOR THOSE WHO DON'T KNOW BETTER
! 
      FOR T_BF TO ID33 DO[$ID34_$ID34+$T] 
! 
      WRITF(O.BUF,.E.R.,I.BUF)      !WRITE ID SEG TO 1ST BLK OF FILE
      IER.
! 
!     SET UP A DUMMY DCB FOR RWNDF CALL 
! 
      ADS (     [IBUF_@O.BUF+16]+2)   !SET UP POINTERS TO DUMMY DCB 
! 
      $IBUF_[IF[T_$ID27]<0 THEN 3,ELSE 2]            ! SET DISC LU
! 
      $ID12_1                         !TYPE (DCB WORD 2)
      $ID13_(T AND 77600K)-<9         !FILE TRACK ADDR. (DCB WORD 3)
      $ID14_( T AND 177K)             !FILE SECTOR ADDR (DCB WORD 4)
      $ID15_$SZ-<1                    !FILE SIZE        (DCB WORD 5)
      $ID16_128                       !RECORD LENGTH    (DCB WORD 6)
      $ID17_210K                      !UPDATE OPEN      (DCB WORD 7)
      $ID18_ [IF T<0 THEN $ SECT3,ELSE $SECT2]  !SEC TRK(DCB WORD 8)
      $(ID18+1)_$XEQT                 !OPEN INDICATOR   (DCB WORD 9)
      $ID23,$ID25_0                   !RECORD #,EXTENT  (DCB 13,15) 
      RWNDF($IBUF,.E.R.)
      IER.
! 
RDP:  READF ($IBUF,.E.R.,$ID26,256) 
! 
      IER.
! 
      WRITF(O.BUF,.E.R.,$ID26,[IF[XF_XF-2]<0 \
                    THEN 128, ELSE 256])
! 
      IER.
! 
      IF XF>0 THEN GO TO RDP
! 
      RETURN
! 
      END 
! 
MF:   FUNCTION(MAD)            !COMPUTE # BLOCKS OF FILE SPACE
      MFV_($(  MAD+1)-$MAD +177K) >-7 
      RETURN
      END 
! 
ADS:  SUBROUTINE (BASE) 
      ID18_[ID17_[ID16_[ID15_[ID14_[ID13_[ID12\ 
              _ BASE]+1]+1]+1]+1]+1]+1
      ID41_[ID40_[ID39_[ID35_[ID34_[ID33_[ID29_[ID26_[ID25_[ID24_[ID23 \
        _[ID22_[ID20_ID18+2]+2]+1]+1]+1]+1]+3]+4]+1]+1]+4]+1]+1 ! 
      RETURN
      END 
      END 
      END$