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-18379 
C 
C     RELOCATABLE PART NUMBER : 92067-16361 
C 
C     PROGRAMER(S)   : J.M.N. 
C 
C 
      SUBROUTINE ACUNL  ,92067-16361 REV.1940 790625  
      LOGICAL  ISRCH
      INTEGER ODCB,ONAME(3),INAME(6),NAMSV(6) 
      DIMENSION LU2(2)
      COMMON /ACOM1/NDCB(272),NBUF(256) 
      COMMON /ACOM2/ LRTRN,LRTR2,LGOTO,ITYPE,ITTYT,LTOSEG,NAMSG(3)
      COMMON /ACOM3/LIST(10),LDCB(144),LLIST,LLDCB(144),ITTY,ITDCB(144) 
      COMMON /ACOM4/ICMND(40) 
      COMMON /ACOM5/LOWUS,IHIGR 
      COMMON /ACOM6 /LOC(6),IRN,IPFLG 
      COMMON /ACOM7/IPBUF(11),ISTRC,JPBUF(11) 
      COMMON /ACOM8/LASTP(40),LENP
      COMMON /ACOM9/JBUF(136) 
      COMMON /ACOMA  /ISRCH,ISR1,ISR2,ISR3,ISR4 
      COMMON /ACOMB /ISTK(90),IPT 
      COMMON /ACOMC/IECHO,LULOG,ITLOG,KECHO 
      DIMENSION KDEL(202) 
      LU2(2)=100B 
C 
C     PARSE INPUT NAMR
C 
      CALL NAMR(LIST,ICMND,80,ISTRC)
      LIST(4)=IAND(LIST(4),3) 
C 
C     LOCK RN 
C 
      CALL RNRQ(1,IRN,ISTAT)
C 
C     COMPUTE REQUIRED SIZE 
C 
      J=-1
      IDELO=0 
      KDEL(1)=1 
      IACCTS=8*(LOC(6)-LOC(5))
      DO 100 I=1,IACCTS 
      CALL ACNXA(J,IREC,IDEL,KOUNT,IDIR,IDELX)
C 
C     INITIALIZE DELTA ARRAY
C 
      IF(IDELO.EQ.IDEL) GO TO 90
C 
C     MAKE RECORD NUMBER(64 WORD) NEGATIVE
C 
      KDEL(IDELX)=-IDIR 
C 
C     USE OLD DELTA 
C 
      KDEL(IDELX+1)=IDELO 
      KDEL(IDELX+3)=IDEL
C 
C     SET END OF TABLE
C 
      KDEL(IDELX+2)=1 
      IDELO=IDEL
   90 IF(JBUF(J).EQ.0) GO TO 110
  100 CONTINUE
C 
C     READ HEADER 
C 
  110 CALL READF(NDCB,IERR,NBUF,128,LEN,1)
      JACCTS=8*(KOUNT/8)+7
      NBUF(6)=NBUF(5)+(JACCTS+1)/8
      IDELI=(NBUF(6)-LOC(6))*2
      JSIZE=NBUF(6)+(JACCTS+1)/2
      NBUF(29)=0
C 
C     OPEN SAVE FILE
C 
      CALL ACOPL(IERR,2,JSIZE)
      IF(IERR.NE.0) GO TO 999 
C 
C     CHECK IF PUNCH
C     AND GENERATE LEADER 
C 
      LU2(1)=IOR(LIST,100000B)
      CALL XLUEX(100015B,LU2,IEQ5,IEQ4) 
      GO TO 120 
  115 IDVRT=IAND(IEQ5,37400B)/256 
      IF(IDVRT.NE.2) GO TO 120
      LU2(2)=1000B
      CALL XLUEX(3,LU2) 
C 
C     POST TO SAVE FILE 
C 
  120 CALL ACWRL(NBUF,128,IERR) 
      IF(IERR.NE.0) GO TO 999 
C 
C     CLEAR ACTIVE SESSION TABLE
C 
      DO 125 I=1,128
  125 NBUF(I)=0 
C 
C     WRITE REST OF SESSION WIDE INFORMATION
C 
      IEND=LOC(5)-1 
      DO 150 I=2,IEND 
      IF(I.LT.LOC(2)) GO TO 130 
      CALL READF(NDCB,IERR,NBUF,128,LEN,I)
      IF(IERR.LT.0) GO TO 999 
  130 CALL ACWRL(NBUF,128,IERR) 
      IF(IERR.NE.0) GO TO 999 
  150 CONTINUE
C 
C     BUILD DIRECTORY THAT HAS HOLES
C     REMOVED 
C 
      J=-1
  200 DO 500 I=1,128,16 
      CALL ACNXA(J,IREC,IDEL,KOUNT,IDIR,IDELX)
      CALL ACFID (JBUF(J+14),IDELI,KDEL)
      CALL ACFID (JBUF(J+13),IDELI,KDEL)
      JJ=J
C 
C     MOVE TO OUPUT BUFFER
C 
      DO 400 II=I,I+15
      NBUF(II)=JBUF(JJ) 
  400 JJ=JJ+1 
      IF(NBUF(I).EQ.0.AND.I.LT.113) NBUF(I)=-1
  500 CONTINUE
C 
C     WRITE DIRECTORY RECORD
C 
      CALL ACWRL(NBUF,128,IERR) 
      IF(IERR.NE.0) GO TO 999 
      IF(JBUF(J).NE.O) GO TO 200
C 
C     NOW WRITE THE ACCOUNT ENTRIES 
C 
      II=1
      J=-1
      DO 1000 I=1,IACCTS
      CALL ACNXA(J,IDREC,IDEL,KOUNT,L,IDELX)
      IREC=L/2
      IOFST=129+64*MOD(L,2) 
      CALL READF(NDCB,IERR,NBUF(129),128,LEN,IREC)
C 
C     MOVE TO OUTPUT BUFFER 
C 
  800 DO 900 JJ=IOFST,IOFST+63
      NBUF(II)=NBUF(JJ) 
  900 II=II+1 
C 
C     FIX EXTENSION ACLNK 
C 
      IF(NBUF(IOFST)+1.LT.0) CALL ACFID (NBUF(IOFST+63),IDELI,KDEL) 
      IF(255.GE.JBUF(J)) GO TO 950
C 
C     SET MESSAGE FILE NAME 
C 
      CALL ACMSN(I,NBUF(II-48)) 
  950 IF(II.LT.128.AND.JBUF(J).NE.0) GO TO 1000 
      CALL ACWRL(NBUF,128,IERR) 
      IF(IERR.NE.0) GO TO 999 
      II=1
      IF(JBUF(J).EQ.0) GO TO 1100 
 1000 CONTINUE
C 
C     PRINT ACERR 
C 
  999 CALL ACERR(IERR)
C 
C     CLOSE SAVE FILE AND UNLOCK RN 
C 
 1100 CALL RNRQ(4,IRN,ISTAT)
      IF(LIST(4).NE.1.OR.IERR.EQ.12) GO TO 1200 
C 
C     WRITE EOF AND REWIND
C 
      CALL XLUEX(3,LU2) 
      LU2(2)=500B 
      CALL XLUEX(3,LU2) 
C 
 1200 CALL ACCLL
      RETURN
      END 
                                                                                                                                                                                          