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