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-18363
C 
C     RELOCATABLE PART NUMBER : 92067-16361 
C 
C     PROGRAMER(S)   : J.M.N. 
C 
C 
C 
C     ACALT ALTERS ACCOUNT WIDE INFORMATION 
C 
      SUBROUTINE ACALT ,92067-16361 REV.1940 790404 
      COMPLEX BUF13(2),MESG(4)
      DIMENSION IBF12(8)
C 
      COMMON /ACOM1/NDCB(272),NBUF(256),MBUF(256) 
      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 /ACOM9/IBUF(40),JBUF(96) 
      COMMON /ACOMC/IECHO,LULOG,ITLOG 
C 
      EQUIVALENCE (IPBUF,IPB),(JPBUF,JPB) 
      EQUIVALENCE (BUF13,IBF12(2))
      DATA BUF13,IBF12 /8HPLEASE L ,8HOG-ON: _ ,-16/
      DATA MESG /8H       W,8HORDS CUR,8HRENTLY A,8HLLOCATED  / 
C 
C     TELL DEFAULT AN NO CHANGE ANSWERS 
C 
      CALL ACWRI(42HENTER " " FOR DEFAULT OR /  FOR NO CHANGE  ,21) 
C 
C     READ ACCOUNTS HEADER
C 
   50 CALL ACNVS(16HSESSION LIMIT? _,8,0) 
      ISL=9999
      IF(IPB.EQ.2H/A.OR.IPB.EQ.2H/E) GO TO 7000 
      IF(IPB.EQ.2H/ .OR.IAND(IPBUF(4),3).EQ.0) GO TO 55 
      IF(IAND(IPBUF(4),3).NE.1) GO TO 50
      ISL=-IPB
      IF(ISL.GT.0) GO TO 50 
   55 CALL READF(NDCB,IERR,NBUF,128,LEN,1)
      MEM=NBUF(27)
      IF(MEM.LT.0) MEM=-MEM 
   60 CALL ACNVS(36HCHANGE MEMORY ALLOCATION (Y OR N)? _,18,0)
      IF(IPB.EQ.2H/E.OR.IPB.EQ.2H/A) GO TO 7000 
      IF(IPB.EQ.2H/ ) GO TO 100 
      IPB=IAND(IPB,177400B)+40B 
      IF(IPB.EQ.2HN ) GO TO 100 
      IF(IPB.EQ.2HY ) GO TO 70
      CALL ACERR(-205)
      GO TO 60
   65 CALL ACERR(-213)
   70 CALL ACITA(MEM,MESG,3)
      CALL ACWRI(MESG,16) 
      CALL ACNVS(28HNO. OF WORDS TO ALLOCATE?  _,14,0)
      IF(IPB.EQ.2H/A.OR.IPB.EQ.2H/E) GO TO 7000 
      IF(IPB.EQ.2H/ ) GO TO 100 
      IF(IPB.LT.70.OR.IPB.GT.7000) GO TO 65 
      MEM=IPB 
      CALL ACWRI(34HFOR NEW ALLOCATION TO BE EFFECTIVE  ,17)
      CALL ACWRI(18H  REBOOT OR ENTER ,9) 
      CALL ACWRI(8H   SD,RE  ,4)
      CALL ACWRI(6H   SU  ,3) 
  100 CALL ACNVS(22HSYSTEM MESSAGE FILE? _,11,0)
      IF(IPB.EQ.2H/A.OR.IPB.EQ.2H/E) GO TO 7000 
      IF(IAND(IPBUF(4),3).NE.1) GO TO 125 
      CALL ACERR(-206)
      GO TO 100 
C 
  125 DO 150 I=1,6
  150 JPBUF(I)=IPBUF(I) 
C 
C 
C     PROMPT FOR NAME OF PROMPT STRING
C 
      CALL ACPRM(14HPROMPT STRING?  ,7) 
      CALL ACREI(NBUF(130),IERR)
      IF(NBUF(130).EQ.2H/A.OR.NBUF(130).EQ.2H/E) GO TO 7000 
      ITLG=ITLOG
C 
C     PROMPT FOR LOCATION OF MESSAGE FILES
C 
      CALL ACNVS(28HLOCATION OF MESSAGE FILES? _  ,14,0)
      IF(IPB.EQ.2H/A.OR.IPB.EQ.2H/E) GO TO 7000 
      CALL RNRQ(1,IRN,ISTAT)
      CALL READF(NDCB,IERR,NBUF,128,LEN,1)
      IF(ISL.GT.0) GO TO 211
C 
C     UPDATE SESSION LIMIT
C 
      NBUF(31)=ISL
      IF(NBUF(30).GE.0) NBUF(28)=ISL
C 
C     UPDATE MEMORY ALLOCATION
C 
  211 NBUF(27)=MEM
      IF(JPB.EQ.2H/ ) GO TO 213 
C 
C     UPDATE SYSTEM MESSAGE FILE NAME 
C 
      J=6 
      DO 212 I=1,6
      IF(I.NE.5) J=J+1
  212 NBUF(J)=JPBUF(I)
      IF(IAND(JPBUF(4),3).NE.0) GO TO 213 
      NBUF(7)=2H
      NBUF(8)=2H
      NBUF(9)=2H
  213 IF(IPB.EQ.2H/ ) GO TO 214 
      IF(IPB.EQ.2H/A.OR.IPB.EQ.2H/E) GO TO 7000 
      NBUF(26)=IPB
  214 IF(NBUF(130).EQ.2H/ ) GO TO 300 
      J=12
      IF(NBUF(130).EQ.2H  .AND.ITLG.LE.2) GO TO 215 
C 
C     UPDATE PROMPT STRING
C 
      IWRD=ITLG/2 
      LAROW=77B 
      IF(MOD(ITLG,2).EQ.0) LAROW=37400B 
      NBUF(130+IWRD)=NBUF(130+IWRD)+LAROW 
      IF(ITLG.GT.19) ITLG=19
      NBUF(129)=-ITLG-1 
      GO TO 230 
C 
C     PUT IN DEFAULT PROMPT STRING
C 
  215 DO 220 I=1,11 
      NBUF(J)=IBF12(I)
  220 J=J+1 
      GO TO 300 
C 
C     PUT STRING IN HEADER
C 
  230 DO 240 I=129,139
      NBUF(J)=NBUF(I) 
  240 J=J+1 
C 
C     POST HEADER 
C 
  300 CALL WRITF(NDCB,IERR,NBUF,128,1)
      CALL RNRQ(4,IRN,ISTAT)
C 
C     PUT PROMPT STRING IN MEMORY 
C 
      CALL LMES(NBUF(12),NBUF(13),NBUF(30)) 
C 
C     UPDATE DISC POOL
C 
      LENG=128*(LOC(4)-LOC(3))
      CALL READF(NDCB,IERR,NBUF,LENG,LEN,LOC(3))
C 
C     PROMPT TO ADD DISC LU 
C 
  350 CALL ACNVS(22HADD DISC LU(Y OR N)? _ ,11,0) 
      IF(IPB.EQ.2H/A.OR.IPB.EQ.2H/E) GO TO 7000 
      IF(IAND(IPB,177400B)+40B.NE.2HY ) GO TO 800 
C 
C     PROMPT FOR DISC LU TO ADD 
C 
  400 CALL ACNVS(10HDISC LU? _ ,5,0)
      IF(IPB.EQ.2H/E) GO TO 800 
      IF(IPB.EQ.2H/A.OR.IPB.EQ.2H/E) GO TO 7000 
      IF(IPB.GT.3.AND.IPB.LE.254) GO TO 500 
      CALL ACERR(-209)
      GO TO 400 
C 
C     SEARCH FOR LU OR END
C 
  500 DO 600 I=1,LEN-1
      NBF=NBUF(I) 
      IF(NBF.EQ.0) GO TO 650
      IF(NBF.EQ.IPB) GO TO 700
  600 CONTINUE
C 
C     MUST EXPAND THE FILE
C 
      CALL ACERR(-219)
      GO TO 7000
C 
C     PUT DISC LU IN BUFF 
C 
  650 NBUF(I+1)=0 
      NBUF(I)=IPB 
      GO TO 400 
C 
C     REPORT ACERR
C 
  700 CALL ACWRI(20HDISC ALREADY IN POOL  ,10)
      GO TO 400 
C 
C     PROMPT TO PURGE DISC LU 
C 
  800 CALL ACNVS(24HPURGE DISC LU(Y OR N)? _  ,12,0)
      IF(IPB.EQ.2H/E.OR.IPB.EQ.2H/ ) GO TO 950
      IF(IPB.EQ.2H/A.OR.IPB.EQ.2H/E) GO TO 7000 
      IF(IAND(IPB,177400B)+40B.NE.2HY ) GO TO 950 
  850 CALL ACNVS(10HDISC LU? _ ,5,0)
      IF(IPB.EQ.2H/E.OR.IPB.EQ.2H/ ) GO TO 950
      IF(IPB.EQ.2H/A.OR.IPB.EQ.2H/E) GO TO 7000 
      IF(IPB.GT.3.AND.IPB.LE.254) GO TO 900 
      CALL ACERR(-209)
      GO TO 850 
C 
C     SEARCH FOR LU TO BE DELETED 
C 
  900 DO 910 I=1,LEN-1
      IF(NBUF(I).EQ.IPB) GO TO 920
  910 CONTINUE
C 
C     REPORT ACERR
C 
      CALL ACWRI(14HDISC NOT FOUND  ,7) 
      GO TO 850 
C 
C     DELETE LU 
C 
  920 DO 930 J=I,LEN-1
      NBUF(J)=NBUF(J+1) 
      IF(NBUF(J).EQ.0) GO TO 850
  930 CONTINUE
C 
C     POST DISC POOL
C 
  950 CALL WRITF(NDCB,IERR,NBUF,LEN,LOC(3)) 
C 
C     GET LENGTH OF DISC POOL 
C 
      DO 960 LNGTH=1,LEN
      IF(NBUF(LNGTH).EQ.0) GO TO 970
  960 CONTINUE
C 
C 
C 
C     FIND MOUNTED POOL DISCS 
C 
  970 CALL ACFST(MBUF)
      DO 990 I=1,LEN
      IF(NBUF(I).EQ.0) GO TO 995
      DO 975 J=1,125,4
      LUD=LBYTE(MBUF(J))
      IF(LUD.EQ.0) GO TO 990
      IF(LUD.EQ.NBUF(I)) GO TO 980
  975 CONTINUE
C 
C 
C     FOUND A MATCH SO MARK IT
C 
  980 NBUF(I)=IOR(NBUF(I),100000B)
  990 CONTINUE
C 
C     RESET DISC POOL IN MEMORY 
C 
  995 NBUF(I)=-1
      ISIZE=0 
      CALL RNRQ(1,IRN,ISTAT)
      CALL READF(NDCB,IERR,MBUF,128,LEN,1)
      IF(IPFLG.GE.0) CALL ACINM(ISIZE,MAXEV,NBUF,LNGTH,MBUF(35))
      IDSZE=MBUF(35)
      CALL WRITF(NDCB,IERR,MBUF,128,1)
      CALL RNRQ(4,IRN,ISTAT)
C 
C     PROMPT FOR STATION CONFIGURATION
C 
 1000  CALL ACWRI(22HSTATION CONFIGURATION ,11) 
 1100 CALL ACNVS(44H(A[DD],D[ELETE],M[ODIFY] OR N[O CHANGE])?  _,22,1)
      ITMP=IPBUF(2) 
      IF(ITMP.EQ.2H/E.OR.ITMP.EQ.2H/A) GO TO 7000 
      IF(ITMP.EQ.2H/ ) GO TO 7000 
      ITMP=IAND(ITMP,177400B)+40B 
      IF(ITMP.EQ.2HN ) GO TO 7000 
      IF(ITMP.EQ.2HD ) GO TO 1200 
      IF(ITMP.EQ.2HA ) GO TO 1200 
      IF(ITMP.EQ.2HM ) GO TO 1200 
      CALL ACERR(-205)
      GO TO 1100
C 
C     FETCH CURRENT STATION CONFIGURATION 
C 
 1200 LC=LOC(2) 
 1300 CALL ACNVS(14HSTATION LU?  _,7,0) 
      IF(IPB.EQ.2H/E) GO TO 1000
      IF(IPB.EQ.2H/A.OR.IPB.EQ.2H/E ) GO TO 7000
      LU=IPB-1
      IF(LU.GE.-1.AND.LU.LT.254) GO TO 1400 
      CALL ACERR(-209)
      GO TO 1300
C 
C     GO FIND IT
C 
 1400 I=1 
      LU=256*IAND(255,LU) 
      LENG=128*(LOC(3)-LC)
 1410 IVAL=IVBUF(I,LC)
      IF(IVAL.EQ.0) GO TO 1430
      IF(IVBUF(I+1,LC).EQ.LU) GO TO 1440
      I=I+IVAL+1
      IF(I.LT.LENG) GO TO 1410
      GO TO 6900
C 
C     PUT IN DUMMY WHEN NOT FOUND 
C 
 1430 IF(ITMP.EQ.2HM .OR.ITMP.EQ.2HD )
     1 CALL ACWRI(18HSTATION NOT FOUND ,9)
      I1=I
      JBUF(1)=1 
      JBUF(2)=LU
C 
C     SET I2 FOR FLAG TO NOT DELEATE
C 
      I2=-1 
      GO TO 1490
C 
C     TRANSFER TO JBUF
C 
 1440 IF(ITMP.EQ.2HA ) CALL ACWRI(22HMODIFYING OLD STATION ,11) 
 1445 I1=I
      DO 1450 J=1,IVAL+1
      JBUF(J)=IVBUF(I,LC) 
 1450 I=I+1 
      I2=I
C 
C     IF DELETE BYPASS UPDATE 
C 
 1490 IF(ITMP.EQ.2HD ) GO TO 3000 
      J=JBUF(1)+2 
 1500 CALL ACNVS(22HSESSION LU,SYSTEM LU?  ,11,0) 
      IF(IPB.EQ.2H/A ) GO TO 7000 
      IF(IPB.EQ.2H/E) GO TO 3000
      LU2=IPB-1 
      CALL NAMR(IPBUF,ICMND,80,ISTRC) 
      LU=IPB-1
      IF(IPB.EQ.2H- ) GO TO 1610
      IF(LU.LT.254.AND.LU.GE.-1) GO TO 1600 
      CALL ACERR(-209)
      GO TO 1500
 1600 LU=IAND(LU,255) 
 1610 IF(LU2.GE.3.AND.LU2.LT.63) GO TO 1700 
      CALL ACERR(-209)
      GO TO 1500
C 
C     SEARCH FOR SESSION LU ALREADY DEFINED 
C 
 1700 IF(J.LE.2) GO TO 1900 
      DO 1800 JJ=2,J-1
      IF(LU2.EQ.IAND(JBUF(JJ),377B)) GO TO 2000 
 1800 CONTINUE
 1900 IF(LU+1.NE.2H- ) GO TO 1950 
      CALL ACWRI(12HLU NOT FOUND ,6)
      GO TO 1500
 1950 JBUF(J)=256*LU+LU2
      J=J+1 
      GO TO 1500
C 
 2000 IF(LU+1.EQ.2H- ) GO TO 2100 
      JBUF(JJ)=256*LU+LU2 
      GO TO 1500
 2100 DO 2200 JJJ=JJ,J-2
 2200 JBUF(JJJ)=JBUF(JJJ+1) 
      J=J-1 
      GO TO 1500
C 
C     PACK STATION TABLE
C 
 3000 CALL RNRQ(1,IRN,ISTAT)
C 
C     IF STATION WAS NOT THERE BEFORE BYPASS PACK 
C 
      IF(I1+1.GE.I2) GO TO 3080 
 3060 I3=I2+1+IVBUF(I2,LC)
      IF(I2+1.GE.I3) GO TO 3080 
      DO 3070 I=I2,I3-1 
      IVAL=IVBUF(I,LC)
      CALL IVBUF(I1,LC,IVAL)
 3070 I1=I1+1 
C 
      I2=I3 
      GO TO 3060
C 
C     BUFFER IS NOW PACKED
C 
C 
C     IF DELETE BYPASS UPDATE 
C 
 3080 IF(ITMP.EQ.2HD ) GO TO 4150 
C 
C     PUT STATION BACK INTO STATION TABLE 
C 
      J=J-1 
      JBUF(1)=J-1 
      IF(I1+J.LE.LENG) GO TO 4050 
      CALL ACERR(-219)
      CALL RNRQ(4,IRN,ISTAT)
      GO TO 7000
C 
C     DO IT 
C 
 4050 DO 4100 I=1,J 
      CALL IVBUF(I1,LC,JBUF(I)) 
 4100 I1=I1+1 
 4150 CALL IVBUF(I1,LC,0) 
      CALL IVBUF
      CALL READF(NDCB,IERR,NBUF,128,LEN,1)
      NBUF(33)=I1/128+1 
      CALL WRITF(NDCB,IERR,NBUF,128,1)
      CALL RNRQ(4,IRN,ISTAT)
C 
C     GO GET NEXT STATION ENTRY 
C 
      GO TO 1000
C 
C     CORRUPT STATION TABLE 
C 
 6900 CALL ACERR(-220)
C 
C     FINISHID
C 
C 
C     CLOSE VIRTUAL MEMORY ROUTINE
C 
 7000 CALL IVBUF
      RETURN
C 
      END