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-18391 C C RELOCATABLE PART NUMBER : 92067-16361 C C PROGRAMER(S) : J.M.N. C C C C ACSID RESETS THE THE ID BIT MAP C AND LOWUS AND IHIGR SUBROUTINE ACSID ,92067-16361 REV.1940 790117 COMMON /ACOM6 /LOC(6),IRN COMMON /ACOM5/LOWUS,IHIGR COMMON /ACOM1/NDCB(272),NBUF(256),MBUF(256) C C CLEAR BIT MAP C DO 100 I=1,256 MBUF(I)=0 100 CONTINUE C C SET BIT FOR 0 C CALL ACSBT(0,MBUF) CALL ACSBT(7777B,MBUF) IREC=LOC(5) C C INITIALIZE IHIGR AND LOWUS C IHIGR=0 LOWUS=4095 C C LOCK OUT UNTIL BIT MAP IS BUILT C CALL RNRQ(1,IRN,ISTAT) C C LOOP THRUOGH ALL ACCOUNTS C IEND=128*(LOC(6)-IREC) DO 200 I=1,IEND,16 C C IF END OF DIRECTORY GET OUT C IF(IVBUF(I,IREC).EQ.0) GO TO 300 IF(IVBUF(I,IREC).LT.0) GO TO 200 IDU=IVBUF(I+11,IREC) IDG=IVBUF(I+12,IREC) IF(IDU.NE.0.AND.IDU.LT.LOWUS) LOWUS=IDU IF(IDG.GT.IHIGR) IHIGR=IDG CALL ACSBT(IDU,MBUF) CALL ACSBT(IDG,MBUF) 200 CONTINUE C C CLOSE IVBUF C 300 CALL IVBUF C C WRITE NEW ID BIT MAP C CALL WRITF(NDCB,IERR,MBUF,256,LOC(4)) CALL READF(NDCB,IERR,NBUF,128,LEN,1) NBUF(23)=LOWUS NBUF(24)=IHIGR CALL WRITF(NDCB,IERR,NBUF,128,1) CALL RNRQ(4,IRN,ISTAT) RETURN END