SPL,L,O,M 
!     NAME:   PK..
!     SOURCE: 92071-18027 
!     RELOC:  92071-16027 
!     PGMR:   G.A.A.
!     MOD:    G.L.M., M.L.K., E.D.B.
! 
!  ***************************************************************
!  * (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 PK..(7) "92071-1X027 REV.2041 800629"
! 
!  MODIFIED 750416 TO NOT MOVE EXTENTS IF THEY ALREADY RESIDE AT
!  THE DESTINATION AND ALSO TO CORRECTLY HANDLE FILES TO 32K SECTORS
! 
!  MODIFIED 800627 FOR THE RTE-L/20 FMGR
! 
!     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 OR "OF".)
! 
!     2.  AFTER ALL FILES ARE MOVED, A NEW DIRECTORY
!         IS CREATED REMOVING ALL THE PURGED ENTRIES. 
!         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 EXEC      BE SUBROUTINE,EXTERNAL
      LET LIMEM     BE SUBROUTINE,EXTERNAL
! 
      LET CONV.     BE SUBROUTINE,EXTERNAL
      LET DR.RD     BE SUBROUTINE,EXTERNAL
      LET FM.ER     BE SUBROUTINE,EXTERNAL
      LET IER.      BE SUBROUTINE,EXTERNAL,DIRECT 
      LET JER.      BE SUBROUTINE,EXTERNAL,DIRECT 
      LET MSS.      BE SUBROUTINE,EXTERNAL
      LET MVW       BE SUBROUTINE,EXTERNAL
      LET SY.TR     BE SUBROUTINE,EXTERNAL
! 
      LET FSTAT     BE SUBROUTINE,EXTERNAL
      LET READF     BE SUBROUTINE,EXTERNAL
      LET RWNDF     BE SUBROUTINE,EXTERNAL
      LET WRITF     BE SUBROUTINE,EXTERNAL
! 
!  EXTERNAL FUNCTIONS 
      LET CRLK      BE FUNCTION,EXTERNAL
      LET CRULK     BE FUNCTION,EXTERNAL
      LET GTOPN     BE FUNCTION,EXTERNAL
! 
!  EXTERNAL VARIABLES 
      LET .E.R      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 VARIABLES 
      LET D.SDR(128)BE INTEGER
      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)
! 
! 
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:  FSTAT(D.SDR,128)                           !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 
      IF [T_CRLK(DIS)] THEN [                    \
          MSS.(T);                               \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 
! 
      DR.RD(READI,DIS,0)?[ER_-32;RETURN]         !READ 1ST DIR BLK
! 
      SY.TR(DIS,T,1,HITRK,HISEC)                 !GET HI DISC ADDR IN USE 
      FILCO_0                                    !CLEAR FILE COUNT
      SETAD                                      !SET PTRS TO NXT ENTRY 
! 
!     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_DS.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 SCR 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: CRULK(DIS)                                !UNLOCK DISC
NXDIS:I.BUF_ 0; O.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
! 
!     COMPUTE NEXT TRACK AND SECTOR 
! 
      NTR_((SECT+NOSEC)->1)/($DCB8->1)+TRAK      !(ROTATE TO AVOID) 
      NSEC_ .B.+.B.                              !(32K SIGN PROBLEM)
! 
!     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$
! 
                                                                                                                                                                    