FTN4,L
C 
C  ***************************************************************
C  * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979.  ALL RIGHTS     *
C  * RESERVED.  NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED,      *
C  * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT*
C  * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY.       *
C  ***************************************************************
C 
C     SOURCE PART NUMBER :92067-18405 
C 
C     RELOCATABLE PART NUMBER : 92067-16361 
C 
C     PROGRAMER(S)   : J.M.N. 
C 
C 
C 
C     ACDIR - ROUTINE TO READ OR WRITE A DIRECTORY ENTRY
C 
C     CALLING SEQUENCE:  CALL ACDIR(ICODE,IDIRN,IBUF,IERR)
C                WHERE
C                        ICODE = 1 FOR READ, 2 FOR WRITE
C                        IDIRN = DIRECTORY ENTRY NUMBER TO READ/WRITE 
C                        IBUF  = 16-WD BUFFER WHERE ENTRY IS RETURNED 
C                        IERR  = ACERR RETURN WORD
C 
C     ACERRS:               -1 = INVALID PARAMETER
C                           -2 = DIR. ENTRY NBR. EXCEEDS DIRECTORY SIZE 
C                           FMP ACERR (READF,WRITF) 
C 
C 
      SUBROUTINE ACDIR(ICODE,IDIRN,IBUF,IERR) 
     1 ,92067-16361 REV.1940 781024 
      DIMENSION IBUF(16)
      COMMON /ACOM6 /LOC(6) 
      COMMON /ACOM1/NDCB(272),NBUF(128) 
C 
C     CHECK PARAMETERS
C 
      IF((ICODE.EQ.1).OR.(ICODE.EQ.2)) GO TO 200
  100 IERR=-1 
      RETURN
  200 IF(IDIRN.LT.1) GO TO 100
      GO TO 400 
  300 IERR=-2 
      RETURN
C 
C     COMPUTE DIRECTORY ENTRY NUMBER AND READ THIS RECORD 
C 
  400 IREC=(IDIRN-1)/8
      IENT=IDIRN-(IREC*8)-1 
      IENT=(IENT*16)+1
      IREC=IREC+LOC(5)
      IF(IREC.GE.LOC(6)) GO TO 300
      CALL READF(NDCB,IERR,NBUF,128,LEN,IREC) 
      IF(IERR.LT.0) GO TO 900 
C 
C     CHECK THAT ENTRY NOT BEYOND END OF DIRECTORY
C 
      DO 500 I=1,IENT,16
      IF(NBUF(I).EQ.0) GO TO 300
  500 CONTINUE
C 
C     IF READ REQUEST, RETURN THE ENTRY 
C 
      IERR=0
      IF(ICODE.EQ.2) GO TO 700
      DO 600 I=1,16 
      IBUF(I)=NBUF(IENT)
      IENT=IENT+1 
  600 CONTINUE
      RETURN
C 
C     WRITE THE DIRECTORY ENTRY 
C 
  700 DO 800 I=1,16 
      NBUF(IENT)=IBUF(I)
      IENT=IENT+1 
  800 CONTINUE
      CALL WRITF(NDCB,IERR,NBUF,128,IREC) 
  900 IF(IERR.LT.0) CALL ACERR(IERR)
      RETURN
      END 
                                                                                                                                                                                    