SPL,L,O,M,C 
!     NAME:   CO.PK 
!     SOURCE: 92064-18045 
!     RELOC:  92064-16017 
!     PGMR:   G.L.M.
! 
!  ***************************************************************
!  * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1977.  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 CO.PK(7) " 92064-16017  REV.1650  761104"
! 
! 
! 
      LET OPEN.,FCONT,READF,WRITF,MSS. BE SUBROUTINE,EXTERNAL 
      LET .P1,.P2,IDCB1,IDCB2,I.BUF \ 
                      BE INTEGER,EXTERNAL 
      LET CLD.R BE SUBROUTINE,DIRECT,EXTERNAL 
! 
! 
      LET IFBRK            BE FUNCTION,EXTERNAL 
! 
      LET PK..                 BE SUBROUTINE
      LET WRIT,DCHCK BE SUBROUTINE,DIRECT 
! 
      LET DIR BE INTEGER
      LET BL.S      BE CONSTANT (20123K) !BLANK B 
      LET A         BE CONSTANT (0) 
      LET B         BE CONSTANT (1) 
! 
! 
! 
! 
      PK..: SUBROUTINE(NO,LIS,ER) GLOBAL
      CO..: ASSEMBLE "EQU PK.." 
            ASSEMBLE "ENT CO.." 
! 
! 
      DIR2_0                   !THIS PREVENTS WRITING OVER SOME 
                               !WHERE UNKNOWN IN THE KILL SECT. 
! 
! 
!  SETUP  CMND ADDRESSES AND USE RESULT BUFFER(LIS) 
!  AS FILE# & TYPE TABLE
! 
      C2_[C2T_[C1_[C1T,FTAB_ @LIS]+1]+3]+1
! 
!   SET ADDRESS OF FILE TYPE WORD AND I.BUF 
! 
      TYPE_[I,IBUF_@I.BUF]+3
! 
!  DETERMINE "FROM,TO, OR DEFAULT LU'S" 
!  CHECK FOR BAD PARM,IF SO EXIT-ERR 56 
!  ALLOW POS AND NEG LU 
! 
! 
      IF $C1T=3 THEN  GO TO ER56  ,\
                ELSE [IFNOT $C1T THEN  C1_4 ,\ !DEFAULT TO 4
                       ELSE [IF [C1_ $C1] < 0  THEN  C1_ -  C1]]
! 
! 
      IF $C2T=3 THEN [\ 
ER56:                  ER_56 ;RETURN] , \ 
                ELSE [IFNOT $C2T THEN  C2_5 , \ !DEFAULT TO 5 
                          ELSE [IF [C2_ $C2] < 0 THEN  C2_ -  C2]]
! 
! 
      IF C1=C2 THEN GO TO ER56       !FROM AND TO MUST BE DIFFERENT 
! 
! 
! 
! 
! 
!   LOCK FROM UNIT
!       VIA A CALL TO D.R 
! 
     .P2_ -  C1 !SET NEG LU FOR CALL
     .P1_ 3   !FUNCTION CODE FOR LOCK 
      CLD.R   ! GO SCHED D.R
! 
! 
! CHECK  FOR D.R ERRORS 
! 
      IF [ER_ $[TEMP_ $B]] THEN RETURN !ERROR CHECK AND SAVE B
! 
! 
! CALCULATE DIRECTORY ADDRESS 
!            FOR THIS UNIT
!               AND REJECT IF DIRECTORY NOT VALID 
! 
! 
      IF ($$[T2_$(TEMP+2)-3]) THEN [ER_24;GOTO KILL]
      DIR_$(T2+1) 
! 
! 
! 
! 
! 
! 
! 
! 
! 
! 
!  LOCK "TO" UNIT 
!     CHECK FOR LOCK ERRORS 
! 
PK.2:     .P2_ -  C2 !   SET NEG LU FOR CALL
      CLD.R !  CALL D.R 
! 
      IF[ER_ $[TEMP_ $B]] THEN GO TO KILL 
 !
! SET CARTRIDGE DIR ADDRESS 
! 
      DIR2_ $ ( TEMP+2 )
! 
! OPEN BOTH UNITS IN ASCII MODE 
! 
      CALL OPEN.(IDCB1, C1,0,400K)
      CALL OPEN.(IDCB2, C2,0,400K)
! 
!  REWIND BOTH UNITS
! 
      CALL FCONT(IDCB1,ER,400K) 
      CALL FCONT(IDCB2,ER,400K) ! ERROR CHECK NEEDED HERE?
! 
! 
      FILEX_ 1      !PRESET FILE# PAST DIR
! 
! 
      STP_ $(DIR-1) 
      DIR_DIR-4   !ADJUST FOR PACK LOOP 
! 
!  START LOOP FOR PACK DIRECTORY UPDATE 
!  THIS ROUTINE ALSO BUILDS  A FILE# AND TYPE TABLE 
!  FOR ALL NON PURGED FILES 
! 
!    SIGN SET=BINARY,LOW 4 BITS GIVE FILE # ON FROM DEVICE
!    0=END OF TABLE 
! 
! 
! 
! 
AGAIN: $FTAB_0  !SET END OF TABLE 
AG2:   DIR_DIR+4
      FILEX_FILEX+1 
! 
      CALL READF(IDCB1,ER,I.BUF,128,LEN) !READ DIRECTORY ENTRY
      IF ER  THEN GO TO KILL
      IFNOT (LEN= -1) THEN GO TO MORE !IF NOT EOF,CONTINUE
! 
!  FOUND EOF--MUST BE AT END OF DIRECTORY 
! 
      IF  ($DIR=0) OR (DIR=STP)   THEN \
              [WRIT ;GO TO CPY],\  OK-WRITE EOF 
                          ELSE [ER_ 24 ;GO TO KILL] 
! 
! 
! 
MORE:  CALL DCHCK                !GO CHECK DIRECTORY JUST READ
       IF $DIR=0 THEN [ ER_ 24 ; GO TO KILL] !CHECK MEM COPY
      IF $DIR < 0 THEN GO TO AG2  !  PURGED SO SKIP IT
      $FTAB_ [IF  [I_ $(DIR+3)]= BL.S THEN \
                    FILEX,\ 
               ELSE  FILEX OR 100000K ] 
! 
! 
      FTAB_FTAB+1    !BUMP TABLE POINTER
! 
!   TYPES MUST COMPARE
! 
      IF I # $TYPE THEN [ER_ 24 ; GO TO KILL] 
! 
!  MOVE IN MEMORY RESIDENT PORTION OF ENTRY 
! 
! 
      TEMP_ DIR 
      FOR I_@I.BUF TO @I.BUF+3  DO\ 
           [ $I_ $TEMP;TEMP_ TEMP+1]
! 
      CALL WRIT !WRITE NEW ENTRY
!  ERROR CHECK??
! 
      GO TO AGAIN 
! 
! 
! 
! 
! 
CPY: FTAB_ @LIS  !RESET TABLE POINTER 
      OUT_ @IDCB2 +3
      IN1_ @IDCB1 +3
! 
CPY2: IFNOT $FTAB THEN GO TO KILL 
! 
!  SET OR CLEAR BINARY(M) BIT IN DCB--SUB FUNCTION
! 
      $IN1_ [IF $FTAB < 0 THEN   $IN1 OR 100K ,\
                         ELSE  $IN1 AND 177677K ] 
! 
      $OUT_ [IF $FTAB < 0 THEN   $OUT OR 100K ,\
                          ELSE  $OUT AND 177677K] 
! 
!   LOCATE ABS FILE# ON FROM DEVICE 
! 
      CALL FCONT(IDCB1,ER,2700K,($FTAB AND 17K))
! 
CPY3: CALL READF(IDCB1,ER,I.BUF,128,LEN)
      CALL WRIT 
      IF ER THEN  GO TO KILL
! 
      IF IFBRK THEN [MSS.(0);GO TO KILL]
      IF LEN= -1 THEN [FTAB_ FTAB+1;GO TO CPY2],\ 
                 ELSE GO TO CPY3
! 
! 
! 
! 
KILL: .P1_5  !FUNCTION CODE FOR LOCK CLEAR
     .P2_-  C1
      CLD.R  !GO CLEAR LOCK ON FROM DEVICE
! 
     .P2_-  C2
! 
!      MARK "TO"    UNIT INVALID
      ASSEMBLE "LDA DIR2  FETCH CRDIR POINTER"
      ASSEMBLE "SZA,RSS   IF ZERO-- " 
      ASSEMBLE "JMP ALMST          THE WORK WAS ABORTED"
      ASSEMBLE "ADA N3    BACK UP TO VALIDITY ADDRESS"
      ASSEMBLE "LDB 0,I   FETCH IT" 
! 
      ASSEMBLE "LDA DEFX  ADDRESS OF NON-ZERO WORD" 
      ASSEMBLE "EXT PMOVE"
      ASSEMBLE "JSB PMOVE"
      ASSEMBLE "OCT 1"
ALMST: CLD.R  !GO CLEAR "TO" DEVICE LOCK
      RETURN
! 
! 
! 
! 
! 
! 
DEFX: ASSEMBLE "DEF *"
N3:   ASSEMBLE "OCT -3" 
      END 
! 
! 
WRIT: SUBROUTINE DIRECT 
      CALL WRITF(IDCB2,ER,I.BUF,LEN)
      RETURN
      END 
! 
DCHCK: SUBROUTINE DIRECT
      IF LEN<4 THEN GO TO BDIR    !MUST HAVE AT LEAST 4 WORDS 
      IF ($( @ I.BUF+3) AND 177400K) # 20000K \   !CHAR 7 MUST BE 
                          THEN [\             !ASCII BLANK
BDIR:                           ER_24;GO TO KILL] 
      RETURN
      END 
! 
! 
      END 
      END$
                                                                                                                                                                    