SPL,L,O,M 
!     NAME:   PK..
!     SOURCE: 92067-18204 
!     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 PK..(8) "92067-16185 REV.1903 790424"
! 
!  MODIFICATION RECORD: 
! 
!  1) 750416   TO NOT MOVE EXTENTS IF THEY ALREADY RESIDE AT THE
!              DESTINATION AND TO CORRECTLY HANDLE FILES TO 32K SECTORS 
!  2) 780516   TO HANDLE LOCK. ERROR RETURN PARAMETER 
!  3) 780516   TO CHECK FOR SESSION CARTRIDGE ACCESS ERRORS 
!  4) 780516   TO CORRECTLY REPORT DISC CRN OF LOCKED DISCS 
!  5) 780721   TO USE NEW D.RTR CALLING SEQUENCE
!  6) 790113   TO MASK OFF LOCK IN LU WORD FROM DS.LU 
!  7) 790123   TO REMOVE EXCEPTION FOR TYPE 4 PGMS FROM TRAK. 
!  8) 790127   TO HANDLE PACK OF LARGE FILES (>32K SECTORS) 
! 
!     PK..  IS THE PACKING ROUTINE FOR THE
!           RTE FMGR PROGRAM. 
! 
!     IT PACKS RTE FILES AS FOLLOWS:
! 
!     1.  IF DISC IS LU2 OR 3 A  CHECK IS 
!         MADE TO INSURE NO CURRENT ID SEGMENTS 
!         POINT TO FILE TRACKS. 
! 
!     2.  EACH FILE IS MOVED DOWN (IF NECESSARY). 
!         AFTER EACH FILE IS MOVED, ITS DIRECTORY 
!         ENTRY IS UPDATED. 
!         (THUS NO MORE THAN ONE FILE IS
!         LOST BY A CRASH.) 
! 
!     3.  AFTER ALL FILES ARE MOVED, A NEW DIRECTORY
!         IS CREATED PACKING OUT ALL THE PURGED 
!         ENTRIES AND THIS IS WRITTEN ON THE DISC VIA D.RTR.
! 
!     THIS ROUTINE IS ENTERED BY THE COMMAND: 
! 
!     PK,CR 
! 
!         WHERE CR IS OPTIONAL AND RESTRICTS
!         THE PACK TO DISC CR.
! 
!     DECLARE EXTERNALS 
! 
      LET CONV.,                     \INTEGER TO ASCII CONVERSION 
          D.RIO,                     \CARTRIDGE DIRECTORY READ
          DR.RD,                     \FILE DIRECTORY READ ROUTINE 
          EXEC,                      \RTE EXEC ROUTINE
          FM.ER,                     \FMGR ERROR MESSAGE WRITE
          IER.,                      \FMGR ERROR HANDLING ROUTINE 
          LOCK.,                     \CARTRIDGE LOCKING ROUTINE 
          MSS.,                      \FMGR ERROR MESSAGE ROUTINE
          READF,                     \FMP FILE READ ROUTINE 
          RWNDF,                     \FMP FILE REWIND ROUTINE 
          WRITF                      \FMP FILE WRITE ROUTINE
             BE SUBROUTINE,EXTERNAL 
! 
      LET .DAD,                      \DOUBLE INTEGER ADD
          .DSB,                      \DOUBLE INTEGER SUBTRACT 
          .DMP,                      \DOUBLE INTEGER MULTIPLY 
          JER.                       \FMGR ERROR HANDLING ROUTINE 
             BE SUBROUTINE,EXTERNAL,DIRECT
! 
      LET NAM..                      \NAME CHECKING ROUTINE 
             BE FUNCTION,EXTERNAL 
! 
      LET COR.A                      \
             BE PSEUDO,EXTERNAL,DIRECT
! 
      LET .E.R.,                     \FMGR ERROR WORD 
          .IDAD,                     \
          .R.E.,                     \FMGR INTERNAL ERROR WORD
          CUSE.,                     \CURRENT SEGMENT 
          D.,                        \ASCII "D.RTR" 
          D.SDR,                     \CARTRIDGE DIRECTORY BUFFER
          DS.LU,                     \DISC LOCK-LU WORD FROM CL 
          I.BUF,                     \FMGR INTERNAL BUFFER
          O.BUF,                     \FMGR INTERNAL BUFFER
          OVRD.,                     \SESSION CARTRIDGE OVERRIDE FLAG 
          PK.DR                      \FILE DIRECTORY BUFFER 
             BE INTEGER,EXTERNAL
! 
!     DECLARE INTERNAL SUBROUTINES
! 
      LET BADTR,                     \
          SETAD,                     \
          TRAK.                      \CHECK ID'S POINTING TO TYPE 6'S 
             BE SUBROUTINE
! 
!     DECLARE ARRAYS
! 
      LET DW64(2),BLKMP(2),SECSZ(2),SIZ(2), \ 
          SIZ2(2),TRK.A(2),XFER(2) \
             BE INTEGER 
      LET BTL(6)        BE INTEGER
      LET MS(3),MS2,MS3,MS4 BE INTEGER
! 
      INITIALIZE MS TO "DISC =" 
      INITIALIZE BLKMP TO 0,256 
      INITIALIZE DW64 TO  0,64
! 
!     DECLARE CONSTANTS 
! 
      LET READI     BE CONSTANT(    1)
      LET WRIT      BE CONSTANT(    2)
      LET BKLWA     BE CONSTANT(1777K)
      LET XEQT      BE CONSTANT(1717K)
      LET KEYWD     BE CONSTANT(1657K)
      LET SECT2     BE CONSTANT(1757K)
      LET SECT3     BE CONSTANT(1756K)
      LET A         BE CONSTANT(   3 )
      LET B         BE CONSTANT(   1 )
! 
! 
PK..: SUBROUTINE(N,LIS,ER) GLOBAL  !ENTRY POINT 
      PACK_$(@LIS+1)               !GET THE PACK
      LUPT_@D.SDR                  !SET CL BUFFER ADDRESS 
      PAKAD_@PK.DR                 !SET FILE DIRECTORY ADDRESS
PK1:  D.RIO(READI)                 !READ CL TO D.SDR
! 
AGAIN:DIS_[IF PACK THEN PACK,ELSE -($LUPT AND 377K)]
      IFNOT DIS THEN  RETURN       !END OF DISC DIRECTORY 
      CALL JER.                    !CHECK FOR BREAK 
      LOCK.(DIS,3,LKER)?[IF LKER = -32 THEN \IF ACCESS ERROR
         [IF PACK THEN [MSS.(LKER);  \AND CRN GIVEN, WRITE ERROR
                        GO TO NXDIS],\CONTINUE TO NEXT DISC 
                  ELSE GO TO NXDIS]; \ELSE SKIP TO NEXT DISC
         MSS.(LKER);                 \PRINT ERR OTHER THAN -32
         MS2_DIS;MS3,MS4_"  ";       \BLANKS TO PAD ASCII NAME
         IF NAM..(MS2) THEN          \IFNOT VALID NAMR, CONVERT DIGITS
          [IF DIS<0 THEN [           \IF LU NEGATIVE, 
              DNO_-DIS;MS2_"- "],    \MAKE POSITIVE, PREPARE FOR WRITE
           ELSE [DNO_DIS;MS2_"  "];  \POSITIVE ALREADY
           CONV.(DNO,MS4,5)];        \CONVERT DISC NUMBER TO ASCII
         FM.ER(2,MS,6);              \WRITE NUMBER OF LOCKED DISC 
         GO TO NXDIS]                !CONTINUE TO NEXT DISC 
! 
      DR.RD(READI,DIS,0)?[ER_54;RETURN] !READ SPECIFICATION ENTRY 
! 
      FILCO_0 
      SETAD 
      LU_$$@DS.LU AND 377K           !SET LU, MASKING OFF LOCK FLAG 
! 
!     SET UP DCBS FOR PACKING 
! 
      DCB5_[NXSEC_[NXTR_[DCB2_[\
         DCB_@O.BUF]+2]+1]+1]+1 
      DCB21_[DCB20_[DCB19_[OBUF_[DCB9_[DCB8_[DCB7_[DCB6_ \
                      DCB5+1]+1]+1]+1]+7]+3]+1]+1 
      FOR T_DCB TO [TBUF_DCB+32] DO $T_0 !CLEAR THE DCB 
      $DCB_LU 
      $DCB2_1 
      $DCB6_128              !SET RECORD SIZE 
      $DCB7_100200K          !SECURITY FLAG 
      $DCB8_$PKD6            !SECTORS PER TRACK 
      $DCB9_$XEQT            !OPEN FLAG 
      FOR T_DCB TO DCB9 DO[T1_T+16;$T1_$T]
      IF LU<4 THEN TRAK.(LU)?[GO TO PK26] !IF 2 OR 3, CHECK TYPE 6'S
! 
!     THE DISC IS LOCKED AND WE MAY START 
!     PACKING - WE MUST HAVE A BUFFER 
!     AND ITS SIZE.  IF WE ARE IN THE 
!     BACKGROUND USE ALL THE REST OF
!     CORE; ELSE USE 0.BUF+32 (256 WDS) 
! 
      IF ($($XEQT+14)AND 7)#3 THEN GOTO PK3 
PK2:  IF[LN_($BKLWA-[COR.A,BUFAD_.IDAD]+1)\BUFAD GETS VALUE FROM COR.A
           AND 77600K]>256 THEN GO TO PK5 
! 
PK3:  DO[LN_256;BUFAD_TBUF] 
PK5:  SECSZ(1)_0
      SECSZ(2)_LN-<10        !NBR. OF SECTORS AVAILABLE TO USE
! 
!     BUFFER AND LENGTH ARE SET NOW 
!     START TO PACK 
! 
! 
       DO[$NXTR_$PKD4; FOR\ 
                    T_@BTL TO @BTL+5 DO[\ 
                     PKD9_PKD9+1; $T_$PKD9]]
      $NXSEC,BLK_0
NXBLK:DR.RD(READI,DIS,BLK)?[GO TO CLEAN]
! 
      FILCO_0 
! 
NXFIL:SETAD?[GO TO WRBLK] 
! 
! 
      IFNOT $PKD THEN GOTO CLEAN  !END
! 
      IF $PKD<0 THEN GOTO NXFIL  !PURGED
      IFNOT $PKD3  THEN GOTO NXFIL !TYPE0 
! 
!     IF THE FILE CONTAINS A BAD TRACK
!     PURGE IT AND CONTINUE 
! 
      BADTR($PKD4,[$DCB20_$PKD5 AND 377K],$PKD6)?[WRFL,$PKD_ -1;\ 
                    GO TO WRBLK]
! 
! 
!     COMPUTE NEW LOCATION
! 
NEWLO:BADTR($NXTR,$NXSEC,$PKD6)?[\
            $NXTR_$BT+1;$NXSEC_0;GO TO NEWLO] 
! 
!     IF NEW LOCATION SAME AS OLD THEN
!     GO TO NEXT FILE 
! 
      IF $NXTR=$PKD4 THEN [IF $NXSEC=$DCB20 THEN\ 
                     GO TO PK11]
! 
!     FAKE OPEN THE FILES 
! 
      WRFL,CO,$DCB5,$DCB21_$PKD6    !# OF SECTORS 
      IF CO<0 THEN                  \IF SIZE NEGATIVE,
         [.B._-CO;.A._0;            \ 
         CALL .DMP(BLKMP);          \MPY BY BLOCK MULTIPLIER * 2
         SIZ(1)_.A.;SIZ(2)_.B.],    \AND SAVE 
      ELSE [SIZ(1)_0;SIZ(2)_CO]     !ELSE JUST MAKE IT DOUBLE WORD
      $DCB19_$PKD4  !START TRACK
      RWNDF(O.BUF,.E.R.) !SET REST OF DCB 
      IER.
      RWNDF($OBUF,.E.R.) !FOR IN AND OUT
      IER.
PK10: .B._SIZ(2);.A._SIZ(1)         !IF FILE SIZE(SECTORS) IS 
      CALL .DSB(SECSZ)              !GREATER THAN NUMBER OF 
      IF .A. >= 0 THEN [            \AVAILABLE SECTORS TO USE,
         IF (.A. OR .B.) # 0 THEN [ \THEN USE 256 WORDS, ELSE 
            XFER(1)_0;XFER(2)_LN;   \USE FILE SIZE IN WORDS 
            GOTO PK10A]]            ! 
      .B._SIZ(2);.A._SIZ(1)         !GET FILE SIZE
      CALL .DMP(DW64)               !CONVERT TO WORDS 
      XFER(1)_.A.;XFER(2)_.B.       !NUMBER OF WORDS TO TRANSFER
PK10A:READF($OBUF,.E.R.,$BUFAD,XFER(2)) 
      IER.
      WRITF(O.BUF,.E.R.,$BUFAD,XFER(2)) 
      IER.
      XFER(2)_XFER(2) -< 10         !IF MORE WORDS, CONTINUE XFER 
      .B._SIZ(2);.A._SIZ(1)         !GET CURRENT SIZE 
      CALL .DSB(XFER)               !SUBTRACT WORDS MOVED 
      SIZ(1)_.A.;SIZ(2)_.B.;.A._SIZ(1) !UPDATE WORDS LEFT TO MOVE 
      IF (.A. OR .B.) THEN GOTO PK10 !CONTINUE IF NON-ZERO
      DO[$PKD4_$NXTR;$PKD5_$NXSEC+($PKD5 AND 177400K)]
PK11: DO[$NXTR_NTR;$NXSEC_NSEC]!UPDATE FOR NEXT FILE
! 
! POINTERS ARE UPDATED
! 
!     FILE IS MOVED - UPDATE DIRECTORY
!     THEN GO DO NEXT FILE. 
! 
WRBLK:IF WRFL THEN[DR.RD(WRIT,DIS,BLK);WRFL_0]
      IF FILCO=128 THEN[BLK_BLK+1;GOTO NXBLK],ELSE\ 
           GO TO NXFIL
CLEAN:BLK,CO_0
PK12: DR.RD(READI,DIS,BLK)?[GO TO PK25] 
      DO[FILCO_0;SETAD] 
      IF BLK THEN GO TO PK16
      DO[$PKD5_$NXSEC;$PKD9_$NXTR;$NXSEC_0] !SET NEXT SEC,TRK 
      NSEC_$SECT2 
      IF $SECT3 THEN [IF $SECT3<$SECT2 THEN NSEC_$SECT3]
      $DCB5_-$PKD8*$PKD6+2     !TRKS IN DIR * SECTORS PER TRK 
      NTR_$DCB5/NSEC
      IF $B THEN NTR_NTR+1
      EXEC(4,NTR,$NXTR,$DCB,$DCB8)  !GET TRACK(S) 
      $DCB6_16
      $DCB2_2 
      RWNDF(O.BUF,.E.R.)
      IER.
PK16: IFNOT $PKD THEN GOTO PK25 
      IF $PKD+1   THEN[WRITF(O.BUF,.E.R.,$PKD);\
                    IER.;CO_CO+1] 
      SETAD?[BLK_BLK+1;GOTO PK12] 
      GOTO PK16 
! 
PK25: FOR T_PKD TO PKD+15 DO $T_0 
      FOR T_CO TO($DCB5-2)*4 DO[\ 
                WRITF(O.BUF,.E.R.,$PKD);IER.] 
! 
PK15: TRK.A(1)_$DCB 
      TRK.A(2)_$NXTR
      RQST_OVRD. OR 7 
      EXEC(23,D.,$XEQT,RQST,DIS,$DCB8,0,TRK.A,2)
      DO[AREG_$0;BREG_$1;IF AREG THEN GOTO PK15]
      DO[.E.R._$BREG;IER.] !CHECK ERRORS
PK26: LOCK.(DIS,5)         !UNLOCK DISC 
      EXEC(5,-1)           !RETURN TRACKS 
NXDIS:I.BUF_0              !CLEAR I.BUF IN CASE WE EXIT 
      IFNOT PACK THEN [LUPT_LUPT+4;GOTO AGAIN]
      RETURN
      END 
! 
!     SETAD SETS THE ADDRESSES FOR THE NEXT FILES ENTRY 
!     IN PK.DR - IF NONE THEN AN FRETURN IS MADE. 
! 
SETAD:SUBROUTINE FEXIT
! 
      IF FILCO=128 THEN FRETURN 
      PKD9_[PKD8_[PKD6_[PKD5_[PKD4_[PKD3_[PKD_\ 
                          PAKAD+FILCO]+3]+1]+1]+1]\ 
                            +2]+1 
      FILCO_FILCO+16
      RETURN
      END 
! 
!     BADTR RETURNS FALSE IF THE CURRENT FILE 
!     AREA CONTAINS A BAD TRACK.
! 
BADTR:SUBROUTINE(TRAK,SECT,NOSEC)FEXIT
      SIZ3_$DCB8 -> 1 
      IF NOSEC<0 THEN               \COMPUTE NEXT TRACK AND SECTOR, 
         [.B._-NOSEC;.A._0;         \AVOID 32K SECTORS SIGN PROBLEM 
          CALL .DMP(BLKMP);         \IF NEGATIVE SIZE, USE MULTIPLIER 
          SIZ2(1)_.A.;SIZ2(2)_.B.], \SAVE 
      ELSE [SIZ2(1)_0;SIZ2(2)_NOSEC]!ELSE JUST MAKE IT DOUBLE WORD
      .B._SECT;.A._0
      CALL .DAD(SIZ2) 
      ASSEMBLE ["CLE,SLA";          \DIVIDE DOUBLE WORD BY 2
                "CCE";              \ 
                "ARS";              \ 
                "ERB";              \ 
                "SWP";              \DIVIDE BY BLOCKS 
                "JSB .DIV";         \ 
                "DEF SIZ3"] 
      NTR_.A.+TRAK
      NSEC_$B+$B    !NEXT TRACK & SECTOR (32K SECTORS SIGN PROB.) 
!     CHECK EACH TRACK AGAINST THE BAD LIST.
      FOR T_TRAK TO[IF NSEC THEN 0,ELSE -1]\
                              + NTR DO[\
           FOR BT_@BTL TO @BTL+5 DO[  \ 
         IF $BT THEN[IF  T=$BT THEN FRETURN]]]
      RETURN
      END 
! 
!     TRAK.  CHECKS FOR ID SEGMENTS THAT REFERENCE
!     FILE MANAGEMENT TRACKS.  IF ANY ARE FOUND, THE
!     NAME OF THE PROGRAM IS PRINTED, 
!     AND AN FEXIT IS TAKEN.
! 
TRAK.:SUBROUTINE(LOGUN) FEXIT 
      LU3_LOGUN AND 1                     !SET LU 3 FLAG
      DO[NSEC,FILCO_0;NTR_($PKD4-<7)]     !GET NEXT TRACK 
      SETAD 
      T_$KEYWD                            !SET INDEX TO KEYWD LIST
NEXT: DMAN_[NAM3_[NAM2_[NAM1_$T+12]+1]+1]+12
      IF $NAM3 AND 20K THEN DMAN_NAM3+5   !ADJUST FOR SHORT ID SEGS 
      IF [T2_$NAM3 AND 7]=1 THEN GOTO OK  !NO CHECK NEEDED FOR TYPE 1 
      IF (($DMAN-<1)AND 1)#LU3 THEN GOTO OK !COMPARE DISC LU
      IF ($DMAN AND 77600K)<NTR THEN GOTO OK
      IFNOT NSEC THEN MSS.(11)
      NSEC_1
      $@BTL_$NAM1                              !SET 1ST WD OF NAME
      $([BT_@BTL+1]+1)_($NAM3 AND 77400K)+40K  !3RD WD OF NAME, PADDED
      $BT_$NAM2                                !2ND WD OF NAME
      FM.ER(2,BTL,3)                           !WRITE THE NAME
OK:   T_T+1                                    !CHECK NEXT ID SEGMENT 
      IF $T THEN GOTO NEXT                     !IF DONE, THEN 
      IF NSEC THEN FRETURN                     !RETURN
      RETURN
      END 
      END 
      END$
                                                                                                                                                                                      