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-18371
C 
C     RELOCATABLE PART NUMBER : 92067-18361 
C 
C     PROGRAMER(S)   : J.M.N. 
C 
C 
      SUBROUTINE ACLOA(JP) ,92067-16362 REV.2001 791018 
      LOGICAL  ISRCH,IFBRK
      COMPLEX MESG(4) 
      COMPLEX MESG2(5)
      INTEGER ONAME(3),INAME(6) 
      DIMENSION LU2(2)
      COMMON /ACOM1/NDCB(272),NBUF(256),MBUF(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,IRN2,IDSZE
      COMMON /ACOM7/IPBUF(11),ISTRC,JPBUF(11) 
      COMMON /ACOM8/LASTP(40),LENP
      COMMON /ACOM9/IBUF(40),JBUF(96) 
      COMMON /ACOMA  /ISRCH,ISR1,ISR2,ISR3,ISR4 
      COMMON /ACOMB /ISTK(90),IPT 
      COMMON /ACOMC/IECHO,LULOG,ITLOG,KECHO 
      COMMON /ACOMD/ICLASS,KPB,KRR,KRRR,IDSES,MYCAP,MYDIR,MYGID,ICRN
      EQUIVALENCE (MESG2(4),IMES2),(IPBUF(1),IPB),(JPBUF(1),JPB)
      DATA MESG2 / 8HSTATION ,8HTABLE RE,8HQUIRES  ,
     1 8H         ,8HWORDS      / 
      DATA  ONAME / 2H++,2HCC,2HT! /
      DATA  INAME / 2H+@,2HCC,2HT!,3,-31178,-2 /
      DATA MESG /8H         ,8HTOTAL AC ,8HCOUNTS R ,8HEQUIRED      / 
      DATA LU2 /0,500B /
C 
C     SET SHUT DOWN MESSAGE 
C 
      CALL LMES(-17,18HSESSION SHUT DOWN  ,-2)
C 
C     TELL LOGON LGOFF TO CLOSE DOWN
C 
      CALL ACSES(-2)
C 
      CALL RNRQ(1,IRN,ISTAT)
      IF(LIST(1).NE.0.OR.LIST(4).EQ.0) GO TO 100
      LIST(1)=2H+@
      LIST(2)=2HCC
      LIST(3)=2HT!
      LIST(4)=3 
      LIST(5)=-31178
      LIST(6)=ICRN
      JP=3
      CALL ACOPL(IERR,1,0)
      IF(IERR.NE.0) GO TO 999 
C 
C     PROMPT FOR CRN
C 
  100 CALL ACNVS(32HENTER DISC LU FOR ACCTS FILE : _ ,16,0) 
      ICRN=IPBUF(1) 
      IF(ICRN.EQ.2H/A )GO TO 1000 
      IF(ICRN.GT.0) ICRN=-ICRN
      CALL ACREL(NBUF,128,LEN,IERR) 
      KACCTS=(NBUF(6)-NBUF(5))*8-1
      CALL ACITA(KACCTS,MESG,3 )
      CALL ACWRI(MESG,16) 
      NBF6O=NBUF(6) 
      NBF5O=NBUF(5) 
      IF(JP.GE.3) GO TO 200 
      CALL ACOPL(IERR,-1,0) 
      IF(IERR.NE.-6) GO TO 120
      JP=3
      LIST(4)=-LIST(4)
      GO TO 200 
  120 IF(IERR.NE.0) GO TO 999 
      CALL ACREL(NBUF,128,LEN,IERR) 
C 
C     PUT CURRENT RESOURCE NUMBERS
C     IN BUFFER 
C 
  200 NBUF(25)=IRN
      NBUF(34)=IRN2 
      NBUF(32)=ICLASS 
      NBUF(35)=IDSZE
      LNGCO=NBUF(33)
C 
C     PROMPT FOR NUMBER ACCOUNTS
C 
  201 CALL ACNVS(26HNUMBER OF USER ACCOUNTS? _ ,13,0) 
      IUS=IPB 
      IF(IUS.EQ.2H/A.OR.IUS.EQ.2H/E) GO TO 1000 
      CALL ACNVS(28HNUMBER OF GROUP ACCOUNTS?  _,14,0)
      IF(IPB.EQ.2H/A.OR.IPB.EQ.2H/E) GO TO 1000 
      IACCTS=(5*IUS)/4+IPB
      IACCTS=(IACCTS/8)*8+7 
      IF(KACCTS.GT.IACCTS) IACCTS=KACCTS
      IF(IACCTS.GT.6.AND.IACCTS.LE.4095) GO TO 209
      CALL ACERR(-33) 
      GO TO 201 
C 
  209 ISIZE=NBUF(5)+(5*IACCTS)/8
C 
C     TELL SIZE  REQUIRED FOR STATION TABLE 
C 
      CALL ACITA(128*LNGCO,IMES2,3) 
      CALL ACWRI(MESG2,19)
C 
C     ASK FOR NEW SIZE
C 
  210 CALL ACNVS(42HENTER <NUMBER OF STATIONS>,<AVERAGE SIZE>  ,21,0) 
      IF(IPB.EQ.2H/A.OR.IPB.EQ.2H/E) GO TO 1000 
      CALL NAMR(JPBUF,ICMND,80,ISTRC) 
C 
C     COMPUTE NEW SIZE OF STATION TABLE 
C 
      LNG=(IPB*(JPB+1))/128+1 
      IF(IAND(IPBUF(4),3).GT.1.OR.IAND(JPBUF(4),3).GT.1) GO TO 210
      IF(IAND(IPBUF(4),3).EQ.0) LNG=NBUF(3)-NBUF(2) 
      IF(LNG.LT.LNGCO) LNG=LNGCO
      IF(LNG.LT.200) GO TO 215
      CALL ACERR(-33) 
      GO TO 210 
C 
C     COMPUTE DELTA DUE TO STATION TABLE
C 
  215 LNDEL=LNG-NBUF(3)+NBUF(2) 
      IEND=NBUF(5)-1
      NB3O=NBUF(3)
C 
C     SET POINTERS
C 
      DO 220 I=3,6
  220 NBUF(I)=NBUF(I)+LNDEL 
      NB3N=NBUF(3)
C     ADJUST SIZE 
      ISIZE=ISIZE+LNDEL 
C 
C     SET SIZE OF DIRECTORY 
C 
      NBUF6=NBUF(5)+IACCTS/8+1
      NBUF(6)=NBUF6 
      NDIR=NBUF6-NBUF(5)
C 
C     CREAT NEW ++CCT!:-31178:ICRN
C     FOR ACCTS FILE
C 
      CALL ACCRE(MBUF,2H++,ISIZE,IERR)
      IF(IERR.LT.0) GO TO 999 
C 
C     READ ACCOUNTS WIDE INFORMATION
C 
      CALL WRITF(MBUF,IERR,NBUF,128)
      IF(IERR.LT.0) GO TO 999 
      DO 300 I=2,IEND 
      CALL ACREL(NBUF,128,LEN,IERR) 
      IF(IERR.LT.0) GO TO 999 
      IF(I.GE.NB3N.AND.I.LT.NB3O) GO TO 300 
      CALL WRITF(MBUF,IERR,NBUF,128)
      IF(IERR.LT.0) GO TO 999 
      IF(I+1.NE.NB3O.OR.LNDEL.LE.0) GO TO 300 
C 
C     FILL UP STATION TABLE 
C 
C           CLEAR BUFFER
C 
      DO 250 J=1,128
  250 NBUF(J)=0 
C 
      DO 260 J=1,LNDEL
      CALL WRITF(MBUF,IERR,NBUF,128)
      IF(IERR.LT.0) GO TO 999 
  260 CONTINUE
  300 CONTINUE
C 
C     COMPUTE DELTA 
C 
      JDEL=NDIR-NBF6O+NBF5O 
      IDEL=NBUF6-NBF6O
      IF(JDEL.LT.0) GO TO 999 
C 
C     IF ACCTS ONLY THEN
C     SPACE UP TO DIRECTORY 
C 
      IF(JP.GE.3) GO TO 330 
      CALL ACOPL(IERR,-1,0) 
      IEND=NBF5O-1
      DO 320 I=2,IEND 
      CALL ACREL(NBUF,128,LEN,IERR) 
      IF(IERR.LT.0) GO TO 999 
  320 CONTINUE
C 
C     UPDATE DIRECTORY
C 
  330 CALL ACREL(NBUF,128,LEN,IERR) 
      IF(IERR.LT.0) GO TO 999 
      DO 335 I=1,128,16 
      IF(NBUF(I).EQ.0) GO TO 340
      IF(NBUF(I+13).NE.0) NBUF(I+13)=NBUF(I+13)+IDEL
      IF(NBUF(I+14).NE.0) NBUF(I+14)=NBUF(I+14)+IDEL
  335 CONTINUE
      CALL WRITF(MBUF,IERR,NBUF,128)
      GO TO 330 
C 
C     BUILD REST OF DIRECTORY 
C 
  340 IF(JDEL.EQ.0) GO TO 365 
      NBUF(I)=-1
      CALL WRITF(MBUF,IERR,NBUF,128)
      DO 350 I=1,128
  350 NBUF(I)=0 
      DO 360 I=1,128,16 
  360 NBUF(I)=-1
C 
C     WRITE IT
C 
  365 DO 370 I=1,JDEL 
      IF(I.EQ.JDEL) NBUF(113)=0 
      CALL WRITF(MBUF,IERR,NBUF,128)
      IF(IERR.LT.0) GO TO 999 
  370 CONTINUE
C 
C     FIX ACCOUNT ENTRIES 
C 
      JERR=0
      DO 500 I=NBUF6,ISIZE
      CALL ACREL(NBUF,128,LEN,JERR) 
      IF(JERR.NE.0.AND.JERR.NE.-12) GO TO 998 
      IF(NBUF(1).LT.0) NBUF(64)=NBUF(64)+IDEL 
      IF(NBUF(65).LT.0) NBUF(128)=NBUF(128)+IDEL
      CALL WRITF(MBUF,IERR,NBUF,128)
      IF(IERR.LT.0)GO TO 999
  500 CONTINUE
C 
C     RENAME FILE FROM ++CCT! TO +@CCT! 
C 
      CALL CLOSE(NDCB)
      DO 900 I=1,1000 
  520 CALL PURGE(NDCB,IERR,INAME,-31178)
      IF(IERR.GE.0) GO TO 520 
      IF(IERR.EQ.-6) GO TO 925
      IF(IERR.NE.-8) GO TO 999
C 
C     TELL USER HE  IS WAITING
C 
      IF(I.EQ.2)
     1 CALL ACWRI(30HWAITING FOR FILE TO BE CLOSED  ,15)
C 
C     SUSPEND FOR 5 SEC 
C 
      CALL EXEC(12,0,2,0,-5)
      IF(IFBRK(IDUM)) GO TO 995 
  900 CONTINUE
C 
C     IF CAN'T GET IT AFTER 10 SEC'S GIVE UP
C 
      GO TO 995 
C 
C     RENAME FILE TO +@CCT!:-31178:-2 
C 
  925 CALL NAMF(MBUF,IERR,ONAME,INAME,-31178,ICRN,IDUM,70707B)
C     REWIND TAPE 
  995 LU2(1)=IOR(100000B,LIST(1)) 
      IF(LIST(4).EQ.1) CALL XLUEX(3,LU2)
C 
C     CLOSE INPUT FILE
      CALL ACCLL
      CALL ACOPN(JERR,IDSES)
      IF(JERR.GE.0) GO TO 1000
C 
C     POST ACERR
C 
  998 IERR=JERR 
  999 CALL ACERR(IERR)
C 
C     RESTART SESSION 
C 
 1000 CALL ACSES(0) 
      CALL RNRQ(40004B,IRN,ISTAT) 
      GO TO 1200
 1100 CONTINUE
 1200 RETURN
      END 
                                                                                                                                                                                                                                                          