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