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 
                                                                                                                                                          