SPL,L,O,M 
!     NAME:   PU..
!     SOURCE: 92070-18028 
!     RELOC:  92070-16028 
!     PGMR:   G.A.A.            MOD. M.L.K. 
! 
!  ***************************************************************
!  * (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 PU..(7) "  92070-1X028  REV.1941  790906"
! 
! 
!     PURGE FILE ROUTINE FOR THE RTE FILE MANAGER 
! 
!     ENTERED AFTER A:
! 
!     PU,NAMR 
! 
!     W H E R E:
! 
!     NAMR     IS THE FILE'S NAMR WHICH CAN CONTAIN:
! 
!     CR       (OPTIONAL) IS THE CARTRIDGE ID.
! 
!     SC       (OPTIONAL) IS THE FILE SECURITY CODE.
! 
! 
!  EXTERNAL SUBROUTINES 
      LET CLOSE     BE SUBROUTINE,EXTERNAL
      LET EXEC      BE SUBROUTINE,EXTERNAL
      LET IER.      BE SUBROUTINE,EXTERNAL,DIRECT 
      LET LOCK.     BE SUBROUTINE,EXTERNAL
      LET MSS.      BE SUBROUTINE,EXTERNAL
      LET OPEN      BE SUBROUTINE,EXTERNAL
      LET PURGE     BE SUBROUTINE,EXTERNAL
!  EXTERNAL VARIBLES
      LET .E.R      BE INTEGER,EXTERNAL 
      LET %IDA      BE INTEGER,EXTERNAL 
      LET %IDNM     BE INTEGER,EXTERNAL 
      LET %IDSZ     BE INTEGER,EXTERNAL 
      LET %SWLU     BE INTEGER,EXTERNAL 
      LET O.BUF     BE INTEGER,EXTERNAL 
      LET N.OPL     BE INTEGER,EXTERNAL 
!  INTERNAL SUBROUTINES 
      LET PUIT      BE SUBROUTINE,DIRECT
!  INTERNAL CONSTANTS 
      LET READI     BE CONSTANT (1) 
      LET WRIT      BE CONSTANT (2) 
! 
! 
PU..: SUBROUTINE(NCAM,PLIST,ER) GLOBAL           !ENTRY POINT 
! 
      LET ER        BE INTEGER
      LET NCAM      BE INTEGER
      LET PLIST     BE INTEGER
! 
      DCB8_[DCB7_[DCB5_[DCB4_[DCB3_[DCB1_[DCB0_@O.BUF]+1]+2]+1]+1]+2]+1 
! 
      T_@N.OPL+1
      BLK_ @PLIST+1 
! 
      PUIT                                       !GO PURGE IT 
! 
      LU _ $DCB0 AND 77K                         !SAVE LU OF DISC 
      IF .E.R  = -6  THEN .E.R_ -2006            !SET UNDEFINED ERROR 
      IF .E.R  = -16 THEN GOTO ZPURG             !TYPE 0 PURGE
      IF .E.R  = -37 THEN GOTO TYPE6             !TYPE 6 PURGE
      IER.
      RETURN
! 
!     PURGE TYPE 0 FILE 
! 
ZPURG:LOCK.(-LU,3)?[RETURN]                      !SET LOCK ON DISC
      PUIT                                       !FORCE CURRENT DIR. ADDRESS
                                                 !TO BE SET INTO DCB0,1 
! 
      DSLU_ LU + 7700K                           !PROTECTED DISC LU 
      TR_(($DCB0 AND 177700K) -> 6)              !ISOLATE TRACK 
      SECT_$DCB1 AND 377K                        !SECTOR
      OFFSET_(($DCB1 AND 177400K) -> 8)          !AND OFFSET OF DIR ENT 
! 
      EXEC(READI,DSLU,O.BUF,128,TR,SECT)         !READ BLOCK HOLDING ENTRY
      IF $1 #128 THEN \                          !MUST GET FULL BLOCK 
          [MSS.(1,LU); RETURN  ]
      $(DCB0+OFFSET)_-1                          !SET THE ENTRY AS PURGED 
      EXEC(WRIT,DSLU,O.BUF,128,TR,SECT)          !WRITE IT BACK OUT 
! 
      O.BUF_0                                    !CLEAR FOR CLOSE 
      LOCK.(-LU,5)                               !CLEAR THE LOCK
      RETURN
! 
!     PURGE TYPE 6 FILES
! 
TYPE6:OPEN(O.BUF,ER,$BLK,0,N.OPL,$T)             !OPEN EXCLUSIVELY
      IF ER < 0   THEN RETURN, ELSE ER_ 0        !IF OPEN ERROR, RETURN 
      IF $DCB7 >= 0  THEN[                       \IF SECURITY CODES DON'T 
         ER_ -7;                                 \MATCH, SET ERROR -7 
         RETURN]                                 !AND RETURN
      TRAK_ $DCB3                                !SET UP TRACK
      IF LU = $%SWLU  THEN[                      \SAME AS SWAP LU?
         IF TRAK = $(%SWLU+1)  THEN[             \SAME AS SWAP TRACK? 
            IF $DCB4 = $(%SWLU+2) THEN GOTO ER38]] ! SAME SECT, ERROR!
      IF [SECT_ $DCB4+2] = $DCB8  THEN[          \SET & INCREMENT SECTOR
         TRAK_ TRAK+1;                           \IF TRACK OVERFLOW, INCREMENT
         SECT_ 0]                                !AND SET SECTOR TO 0 
! 
      IDPTR_ $%IDA + 27 - $%IDSZ                 !SET POINTER TO ID SEGMENTS
      FOR I_1 TO $%IDNM   DO[                    \SCAN ID SEGMENTS
         IDPTR_ IDPTR + $%IDSZ;                  \POINT TO NEXT ID
         IFNOT $(IDPTR-15) THEN GOTO NDLP;       \IF ID DORMANT, SKIP 
         IF ($IDPTR AND 377K)= LU  THEN[         \LU'S MATCH? 
            IF $(IDPTR-1)= TRAK  THEN[           \TRACKS MATCH? 
               SEK_ ($(IDPTR-2) AND 377K) <- 1;  \GET LOGCL SECTOR FROM ID
               IF SEK = SECT THEN[               \SECTORS MATCH?
ER38:             MSS.(38);                      \ERROR, ITS ACTIVE!
                  RETURN]]];NDLP:]               !EXIT
      CLOSE(O.BUF,.E.R,($DCB5)/2)                !CLOSE AND TRUNCATE
      RETURN
      END 
! 
! 
PUIT:SUBROUTINE DIRECT
     PURGE(O.BUF,.E.R,$BLK,N.OPL,$T)
     RETURN 
     END
      END 
      END$
                                                                                                                                                                                