SPL,L,O,M 
!     NAME:   PK..
!     SOURCE: 92070-18027 
!     RELOC:  92070-16027 
!     PGMR:   G.A.A.
!     MOD:    G.L.M.
! 
!  ***************************************************************
!  * (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..(7) "  92070-1X027  REV.1941  790911"
! 
!  MODIFIED 750416 TO NOT MOVE EXTENTS IF THEY ALREADY RESIDE AT
!  THE DESTINATION AND ALSO TO CORRECTLY HANDLE FILES TO 32K SECTORS
!     PK..  IS THE PACKING ROUTINE FOR THE
!           RTE FMGR PROGRAM. 
! 
!     IT PACKS RTE FILES AS FOLLOWS:
! 
! 
!     1.  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.) 
! 
!     2.  AFTER ALL FILES ARE MOVED  A NEW DIRECTORY
!         IS CREATED PACKING OUT ALL THE PURGED 
!         ENTRIES AND THIS IS WRITTEN ON THE DISC DIRECTLY AFTER
!         REQUESTING A LOCK VIA D.RTR 
! 
!     THIS ROUTINE IS ENTERED BY THE COMMAND: 
! 
!     PK,CR 
! 
!         WHERE CR IS OPTIONAL AND RESTRICTS
!         THE PACK TO DISC CR.
! 
! 
!  EXTERNAL SUBROUTINES 
      LET CONV.     BE SUBROUTINE,EXTERNAL
      LET D.RIO     BE SUBROUTINE,EXTERNAL
      LET DR.RD     BE SUBROUTINE,EXTERNAL
      LET EXEC      BE SUBROUTINE,EXTERNAL
      LET FM.ER     BE SUBROUTINE,EXTERNAL
      LET IER.      BE SUBROUTINE,EXTERNAL,DIRECT 
      LET JER.      BE SUBROUTINE,EXTERNAL,DIRECT 
      LET LIMEM     BE SUBROUTINE,EXTERNAL
      LET LOCK.     BE SUBROUTINE,EXTERNAL
      LET MSS.      BE SUBROUTINE,EXTERNAL
      LET MVW       BE SUBROUTINE,EXTERNAL
      LET READF     BE SUBROUTINE,EXTERNAL
      LET RWNDF     BE SUBROUTINE,EXTERNAL
      LET SY.TR     BE SUBROUTINE,EXTERNAL
      LET WRITF     BE SUBROUTINE,EXTERNAL
!  EXTERNAL FUNCTIONS 
      LET GTOPN     BE FUNCTION,EXTERNAL
!  EXTERNAL VARIBLES
      LET .E.R      BE INTEGER,EXTERNAL 
      LET D.SDR     BE INTEGER,EXTERNAL 
      LET DS.LU     BE INTEGER,EXTERNAL 
      LET I.BUF     BE INTEGER,EXTERNAL 
      LET O.BUF     BE INTEGER,EXTERNAL 
      LET PK.DR     BE INTEGER,EXTERNAL 
!  INTERNAL SUBROUTINES 
      LET BADTR     BE SUBROUTINE 
      LET SETAD     BE SUBROUTINE 
!  INTERNAL VARIBLES
      LET BTL(6)    BE INTEGER
      LET MS(3)     BE INTEGER
      LET MS2       BE INTEGER
      LET MS3       BE INTEGER
      LET MS4       BE INTEGER
          INITIALIZE MS TO "DISC =" 
!  INTERNAL CONSTANTS 
      LET READI     BE CONSTANT(    1)
      LET WRIT      BE CONSTANT(    2)
      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                                !GET ADRS OF CART DIR
      PAKAD_@PK.DR                               !SET DIREC. BUFFER ADRS
      CALL LIMEM(1,FWAM,WRDS)                    !SEE IF MEMORY AVAIL.
      WRDS_WRDS AND 77600K                       !FULL SECTOR BOUNDS
PK1:  D.RIO(READI)                               !READ CART DIR TO D.SDR
! 
AGAIN:DIS_[IF PACK THEN PACK,ELSE -$LUPT]        !PACK PARM OR CART LIST
      IFNOT DIS THEN [CALL LIMEM(-1);            \END OF DISC DIRECTORY 
                        RETURN]                  !RETURN MEMORY AND EXIT
      CALL JER.                                  !CHECK FOR BREAK 
      LOCK.(DIS,3)?[MSS.(-8);                    \LOCK DISC/PRINT THE ERROR 
                    IF DIS<0 THEN[               \IF LU NEGATIVE
                       DNO_ -DIS;                \MAKE POSITIVE 
                       MS2_ "- "],               \
                    ELSE[                        \POSITIVE ALREADY
                       DNO_ DIS;                 \
                       MS2_ "  "];               \
                    CONV.(DNO,MS4,5);            \CONVERT NUMBER TO ASCII 
                    FM.ER(2,MS,6);               \WRITE CRN 
                    GOTO NXDIS]                  !GOTO NEXT 
      SY.TR(DIS,T,1,HITRK,HISEC)                 !HI DISC ADRS IN USE BY SYSTE
! 
      DR.RD(READI,DIS,0)?[ER_-32;RETURN]         !READ 1ST DIR BLK
! 
      FILCO_0                                    !CLEAR FILE COUNT
      SETAD                                      !SET PTRS TO NXT ENTRY 
      LU_ $$@DS.LU                               !GET DISC LU 
! 
!     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           !
! 
      TBUF_ DCB+32                               !
      O.BUF_ 0                                   !
      MVW(DCB,DCB+1,31)                          !CLEAR FIRST 31 ENTRIES
      $DCB_LU                                    !SET LU INTO DCB 
      $DCB2_1                                    !SET TYPE 1 (FORCE TO 1) 
      $DCB6_128                                  !SET RECORD SIZE 
      $DCB7_100200K                              !SECURITY FLAG 
      $DCB8_$PKD6 AND 377K                       !SET #SECT TRACK 
      $DCB9_GTOPN                                !AND OPEN FLAG 
      MVW(DCB,OBUF,16)                           !COPY TO 2ND DCB 
! 
!     THE DISC IS LOCKED AND WE MAY START 
!     PACKING - WE MUST HAVE A BUFFER 
!     AND ITS SIZE.  IF LIMEM GOT MORE
!     THAN 256 WORDS USE THAT MEMORY; 
!     ELSE USE O.BUF+32 (256 WDS) 
! 
! 
!     WRDS AND FWAM WERE SET UP BY CALL TO LIMEM UPON ENTRY 
! 
      IF WRDS>256  THEN[                         \
         BUFAD_ FWAM;                            \SET POINTER TO PACK BUF 
         LN_ WRDS;                               \SET LENGTH OF BUFFER
         GOTO PK5]                               !USE LARGER BUF FOR SPEED
! 
PK3:  LN_ 256                                    !USE INTERNAL BUFFER 
      BUFAD_ TBUF                                !OF O.BUF/I.BUF
PK5:  SECSZ_ LN-<10                              !SET SECTOR COUNT
! 
!     BUFFER AND LENGTH ARE SET NOW 
!     START TO PACK 
! 
      $NXTR_ $PKD4                               !SET TO 1ST FMP TRACK
      FOR T_ @BTL TO @BTL+5  DO[                 \SET UP BAD
          PKD9_PKD9+1;                           \TRACK LIST
          $T_ $PKD9]                             !
      $NXSEC_ 0                                  !INIT SECTOR 
      BLK_ 0                                     !INIT BLOCK COUNTER
      GOTO NXFIL                                 !SKIP HEADR BLOCK
! 
NXBLK:DR.RD(READI,DIS,BLK)?[GO TO CLEAN]         !READ DIRECTORY BLOCK
      FILCO_0                                    !RESET DIRECTORY PTR 
! 
NXFIL:SETAD?[GO TO WRBLK]                        !SET PKD PTRS TO NX FILE 
! 
      IFNOT $PKD  THEN GOTO CLEAN                !TEST FOR 0 AT END OF DIRECT 
      IFNOT $PKD3 THEN GOTO NXFIL                !SKIP TYPE 0 
! 
      SEK_ $PKD5 AND 377K                        !GET SECTOR FROM DIRECTORY 
      IF $PKD4 < HITRK  THEN GOTO SKIP           !SKIP UNTIL HI TRACK 
      IF $PKD4 = HITRK  THEN[                    \IF BELOW HIGHEST BOUNDRY
         IF SEK <= HISEC  THEN[                  \CALCULATE NEW 
SKIP:       $NXTR_ ((SEK+$PKD6)->1)/($DCB8->1)+$PKD4;\NEXT TRACK
            $NXSEC_ $B + $B;                     \AND SECTOR
            GOTO NXFIL]]                         !AND GO WORK ON NEXT FILE
! 
      IF $PKD<0 THEN GOTO NXFIL                  !PURGED
! 
      IF [T_ ($PKD >-8)] >= 60K  THEN[           \IF 1ST CHAR IS NUMERIC
         IF T <= 71K  THEN[                      \THEN FILE IS A SCRATCH FILE 
            WRFL,$PKD_ -1;                       \PURGE SCRATCH FILES 
            GOTO WRBLK]]                         !AND UPDATE DIRECTORY
! 
!     IF THE FILE CONTAINS A BAD TRACK
!     PURGE IT AND CONTINUE 
! 
      BADTR($PKD4,[$DCB20_$PKD5 AND 377K],$PKD6)?[WRFL,$PKD_ -1;\IF 'FROM'
                    GO TO WRBLK]                 !HAS BAD TRK, PURGE IT 
! 
! 
!     COMPUTE NEW LOCATION
! 
NEWLO:BADTR($NXTR,$NXSEC,$PKD6)?[                \IF 'TO' FILE HAS BAD
            $NXTR_$BT+1;$NXSEC_0;GO TO NEWLO]    !TRK, SKIP TRK 
! 
!     IF NEW LOCATION SAME AS OLD THEN
!     GO TO NEXT FILE 
! 
      IF $NXTR=$PKD4  THEN[                      \IF TO & FROM TRKS 
         IF $NXSEC=$DCB20  THEN                  \AND SECTORS MATCH 
            GOTO PK11]                           !SKIP COPY 
! 
!     FAKE OPEN THE FILES 
! 
      WRFL_ -1                                   !SET 'WRITTEN-ON' FLAG 
      CO,$DCB5,$DCB21_ $PKD6                     !SET # OF SECTORS
      $DCB19_ $PKD4                              !START TRACK 
      RWNDF(O.BUF,.E.R)                          !SET REST OF FROM DCB
      IER.                                       !CHECK FOR ERRORS
      RWNDF($OBUF,.E.R)                          !SET REST OF TO DCB
      IER.                                       !CHECK FOR ERRORS
PK10: XFER_[IF CO>SECSZ THEN LN,ELSE CO-<6]      !SET # OF WRDS TO XFER 
      READF($OBUF,.E.R,$BUFAD,XFER)              !READ FROM FILE
      IER.                                       !CHECK FOR ERRORS
      WRITF(O.BUF,.E.R ,$BUFAD,XFER)             !WRITE 'TO' FILE 
      IER.                                       !CHECK FOR ERRORS
      IF [CO_CO-(XFER-<10)] THEN GOTO PK10       !SET REMAINING SIZE
      $PKD4_ $NXTR                               !SET IN NEW DIRECT ADRS
      $PKD5_ $NXSEC+($PKD5 AND 177400K)          !FOR COPIED FILE 
PK11: $NXTR_NTR                                  !UPDATE PTRS FOR 
      $NXSEC_ NSEC                               !NEXT FILE 
! 
! PONTERS ARE UPDATED 
! 
!     FILE IS MOVED - UPDATE DIRECTORY
!     THEN GO DO NEXT FILE. 
! 
WRBLK:IF WRFL THEN[                              \IF 'WRITTEN-ON' FLAG
         DR.RD(WRIT,DIS,BLK);                    \SET WRITE OUT UPDATED 
         WRFL_ 0]                                !DIRECTORY INFO
      IF FILCO=128  THEN[                        \IF DIR PTR AT 
         BLK_ BLK+1;                             \END OF DIR BLK
         GOTO NXBLK],                            \SET UP FOR NEXT 
      ELSE  GOTO NXFIL                           !ELSE UPDATE PTRS
! 
! 
! --- THIS SECTION PACKS THE DIRECTORY ---------------------------------- 
! 
! 
CLEAN:TCNT,FCNT,FBLK,TBLK_ 0                     !INITIALIZE POINTERS 
      FBF_ @PK.DR                                !SET ADDRESS OF DIR BUF
      TBF_ @O.BUF                                !SET ADRS OF OUTPUT BUF
! 
TOP:  DR.RD(READI,DIS,FBLK)?[GO TO EED]          !READ DIR BLOCK
                                                 !GOTO END IF LAST + 1
      IF FBLK THEN GOTO PCK                      !IF NOT 1ST, CONTINUE
! 
      FILCO_0                                    !CLEAR FILE COUNT FOR SETAD
      SETAD                                      !THIS IS THE DIR ID
      $PKD9_$NXTR                                !SET NEXT TRACK
      $PKD5_$NXSEC                               !SET THE NEXT SECTOR 
      GO TO MOK                                  !MOVE THIS ENTRY 
! 
! 
PCK:  IFNOT [T_$(FBF+FCNT)]  THEN GOTO EED       !GET OUT IF END OF DIR 
      IF [NXTR_ $(FBF+FCNT+4)] < HITRK THEN GOTO MOK !BELOW, MOVE IT
      IF NXTR = HITRK  THEN[                     \BELOW PACK BOUNDRY
         IF ($(FBF+FCNT+5) AND 377K) <= HISEC  THEN \OR ON IT, MOVE 
            GOTO MOK]                            !ENTRY 
      IF T<0 THEN GOTO NEX                       !IF PURGED-TRY NEXT ONE
! 
MOK:  MVW(FBF+FCNT,TBF+TCNT,16)                  !MOVE DIR ENTRY TO SAVE BUF
      IF [TCNT_TCNT+16]=128  THEN[               \BUMP OUT COUNT-IF FULL
         TCNT_0;                                 \RESET OUT COUNT 
         DR.RD(-2,DIS,TBLK);                     \WRITE THE BLOCK 
         TBLK_TBLK+1]                            !BUMP THE BLOCK CONUT
! 
NEX : IF [FCNT_FCNT+16]=128  THEN[               \BUMP IN COUNT-IF EMPTY
         FCNT_0;                                 \RESET IN COUNT
         FBLK_ FBLK+1;                           \BUMP BLOCK COUNT
         GOTO TOP],                              \GO READ NEXT BLOCK
      ELSE  GOTO PCK                             !ELSE DO NEXT ENTRY
! 
! --- CLEAR REMAINDER OF DIRECTORY ---
! 
EED:  $(TBF+TCNT)_ 0                             !CLEAR "CURRENT" FW OF BUF 
      T_(128-TCNT)-1                             !CALCULATE # WORDS TO MOVE 
                                                 !TO CLEAR REST OF BUFFER 
      MVW(TBF+TCNT,TBF+TCNT+1,T)                 !CLEAR REST OF BUFFER
WIPE: DR.RD(-2,DIS,TBLK)                         !WRITE IT OUT
      TBLK_TBLK+1                                !BUMP BLOCK COUNT
! 
! 
   IFNOT FBLK < TBLK THEN[                      \CLEAR REST OF DIRECTORY
        IFNOT TCNT THEN GOTO WIPE,              \CONT AT WIPE IF
        ELSE[                                   \ELSE CLEAR FULL BUFFER 
             TCNT_0;                            \ 
             GOTO EED]]                         ! 
! 
PK26: LOCK.(DIS,5)                              !UNLOCK DISC
NXDIS:I.BUF_ 0                                  !CLEAR FW SO CLOSE WON'T
                                                !GET SCREWED UP 
      IFNOT PACK THEN [LUPT_LUPT+4;GOTO AGAIN]
      CALL LIMEM(-1)
      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
      NTR_((SECT+NOSEC)->1)/($DCB8->1)+TRAK  !COMPUTE (ROTATE TO AVOID
      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 
      END 
      END$
! 
                                                                                                                                                                                                      