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 
C     SOURCE PART NUMBER : 92067-18360
C 
C     RELOCATABLE PART NUMBER : 92067-16361 
C 
C     PROGRAMER(S)   : J.M.N. 
C 
      PROGRAM ACCTS(20,90),92067-16361 REV.2013 800131  
C 
C 
C 
C 
C 
C  DESCRIPTION: 
C 
C 
C 
C 
C  ACCOUNT FILE STRUCTURE:
C 
C 
C  ACERR CODES: 
C       12  LU NOT IN SESSION SWITCH TABLE
C       13  TRANSFER STACK OVERFLOW 
C      -07  NOT LOGGED ON AS SYSTEM MANAGER 
C     -200  ACCOUNT NOT FOUND 
C     -201  NO FREE ACCOUNTS
C     -202  ACCOUNT WITH THIS NAME ALREADY EXISTS 
C     -203  INVALID ACCOUNT NAME
C     -204  INVALID PASSWORD
C     -205  INVALID COMMAND 
C     -206  INVALID FILE NAME 
C     -207  INVALID CAPABILITY
C     -208  INVALID DISC LIMIT
C     -209  INVALID SST ENTRY 
C     -210  CONFLICT IN SST DEFINITION
C     -211  USER OR GROUP ID NOT AVAILABLE
C     -212  INVALID NUMBER OF SST SPARES
C     -215  LIST NAMR IN TRANSFER STACK 
C     -218  SESSION NOT SHUT DOWN 
C     -219  NOT ENOUGH ROOM IN FILE FOR NEW TABLE 
C     -220  CORRUPT STATION TABLE SPARES
C     -221  NOT AN ACTIVE SESSION 
C     -222  ILLEGAL SYSTEM LU 
C     -223  ILLEGAL SHUT DOWN PARAMETER 
C     -225  SESSION MEMORY CAN NOT BE 
C           RETURNED TO SYSTEM (REBOOT) 
C 
C 
C 
C 
      LOGICAL XFTTY,LOFLG 
      DIMENSION IAB(2),LUX(2),IPARM(5)
      COMMON /ACOM1/NDCB(272),NBUF(256) 
      COMMON /ACOM2/ LRTRN,LRTR2,LGOTO,ITYPE,ITTYT,LTOSEG,NAMSG(12) 
      COMMON /ACOM3/LIST(10),LDCB(144),LLIST,LLDCB(144),ITTY,ITDCB(144) 
      COMMON /ACOM4/ICMND(40),NAMPR(3),ICLFG,NMPR3
      COMMON /ACOM5/LOWUS,IHIGR 
      COMMON /ACOM6 /LOC(6),IRN,IPFLG 
      COMMON /ACOM7/IPBUF(11),ISTRC,JPBUF(11) 
      COMMON /ACOM8/LASTP(40),LENP
      COMMON /ACOM9/IBUF(40),JBUF(96) 
      COMMON /ACOMA  /ISRCH,ISR1,ISR2 
      COMMON /ACOMB /ISTK(90),IPT 
      COMMON /ACOMC/IECHO,LULOG,ITLOG 
      COMMON /ACOMD/ICLASS,KPB,KRR,KRRR,IDSES,MYCAP,MYDIR,MYGID 
      DATA IERR / 0 / 
      DATA LUX / 0,0 /
      DATA IPARM / -1,0,0,0,0    /
      CALL RMPAR(IPBUF) 
      CALL PNAME(JBUF)
      NAMSG(1)=JBUF(1)
      NAMPR(1)=JBUF(1)
      NMPR3=JBUF(3) 
      ITYPE=IPBUF(1)-1
      ITTY=0
      IF(ITYPE.GE.0) ITTY=ITYPE+1 
      IF(ITYPE.NE.-2) GO TO 4 
C 
C     IF CLEAN UP OR INITIALIZE THEN DETACH 
C 
      CALL DTACH
      GO TO 5 
C 
C     ELSE SET TYPE TO 0
C 
    4 ITYPE=0 
C 
C     SET ORIGINAL INPUT TO LOGLU 
C 
    5 LULOG=LOGLU(LULOG)
      IF(ITTY.LE.0.OR.ITTY.GE.255) ITTY=LULOG 
      IF(XFTTY(ITTY)) LULOG=ITTY
      ITTY=LUTRU(ITTY)
      LULOG=LUTRU(LULOG)
      ISTK(1)=ITTY
C 
C     SET UP INPUT FILE 
C 
C 
C     GO GET RUN STRING 
C 
      CALL EXEC(14,1,ICMND,40)
      CALL ABREG(IA,IB) 
      DO 10 I=IB+1,40 
   10 ICMND(I)=2H 
      ISTRC=1 
      CALL NAMR(IPBUF,ICMND,80,ISTRC) 
      CALL NAMR(IPBUF,ICMND,80,ISTRC) 
      IERR=0
      CALL ACXFR(ICMND,ISTRC,IERR)
      IF(IERR.EQ.0) GO TO 20
      IF(IERR.EQ.10) IERR=00
      CALL ACERR(IERR)
C 
C     GO INITIALIZE 
C 
   20 LOFLG=.TRUE.
      KPB=0 
      ASSIGN 30 TO LRTRN
      ASSIGN 60 TO LRTR2
      CALL ACLNK (2H1 ,1) 
   30 IF(KPB.NE.-31178) GO TO 40
      CALL ACHLP(IPBUF,ISTRC) 
      GO TO 20
C 
   40 LOFLG=.FALSE. 
      IF(ITYPE.EQ.-4) GO TO 55
C 
C     CREAT ACCOUNTS
C 
      IEXIT=0 
   50 CALL ACMND(IEXIT) 
      IF(IEXIT.EQ.0) GO TO 50 
C 
C     FINISH MEMORY INITIALIZATION
C 
   55 ASSIGN 60 TO LRTR2
      CALL ACLNK (2H1 ,2) 
   60 IEXIT=-1
      IF(ITYPE.LT.0) GO TO 110
C 
C     VERIFY THE USER'S PASSWORD
C 
      IF(LOFLG.AND.IDSES.EQ.0) CALL ACPAS 
C 
C     ENTER THE COMMAND LOOP
C 
      IPCNT=0 
      IEXIT=0 
  100 CALL ACMND(IEXIT) 
C 
C     GO CLEAN UP FILE
C 
  110 ASSIGN 120 TO LRTRN 
      IF(IPFLG.EQ.0) GO TO 120
      IF(IPFLG.GT.1) GO TO 115
      CALL ACLNK(2H1  ,3) 
C 
  115 IPFLG=IPFLG-1 
C 
C     CLEAN UP CLASS BUFFERS
C 
  120 ICLFG=-1
      CALL EXEC(100025B,ICLASS,JBUF,1)
      GO TO 150 
  130 CALL ABREG(ICLFG,IB)
      IF(0.LE.ICLFG) GO TO 120
  150 IF(IEXIT.EQ.0) GO TO 100
      CALL ACTRM
C 
C     THIS INSTRUCTION IS REQUIRED
C     SO THAT ACOM5 WILL BE INCLUDED
C     INTHE MAIN WHEN ACCTS IS RELOCATED
C     AT GENERATION TIME. WE LUCKED OUT ON
C     OTHER NAMED COMMONS.
C 
  250 IH=IHIGR
      END 
      BLOCK DATA GLOBL
      LOGICAL  ISRCH
      INTEGER SETBUF(128) 
      COMPLEX SNAME(3)
      COMMON /ACOM1/NDCB(272),NBUF(256),MBUF(256) 
      COMMON /ACOM2/ LRTRN,LRTR2,LGOTO,ITYPE,ITTYT,LTOSEG,NAMSG(12) 
      COMMON /ACOM3/LIST(10),LDCB(144),LLIST,LLDCB(144),ITTY,ITDCB(144) 
      COMMON /ACOM4/ICMND(40),NAMPR(3),ICLFG,NMPR3
      COMMON /ACOM5/LOWUS,IHIGR,ITRN
      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,IERFG,KERRB(8),LLST(4)
      COMMON /ACOMD/ICLASS,KPB,KRR,KRRR,IDSES,MYCAP,MYDIR,MYGID,ICRN
      EQUIVALENCE (LDCB(17),SETBUF) 
      EQUIVALENCE (NAMSG,SNAME) 
      DATA ISRCH/.FALSE./ 
      DATA IPFLG,ICLFG /0,-1/ 
      DATA KERRB / 2HHE,2H, ,2HAC,2HCT,2H00,2H00,2H , ,2H    /
      DATA IECHO/ 0 / 
      DATA SNAME / 8H        ,8HSEGMENT ,8HMISSING    / 
      DATA KECHO/ 400B /
      DATA IPT  / 0 / 
      DATA LIST(1) / -1 / 
      DATA NAMSG /2HAC,2HCT,2HS  /
      DATA NAMPR /2HAC,2HCT,2HS  /
      DATA SETBUF /2HNE,2H,G,2HR ,0   ,2HSY,2HS ,0   ,2H/E,0   ,2HNE, 
     *   2H,G,2HR ,0,2HSU,
     1   2HPP,2HOR,2HT ,0   ,2H/E,0   ,2HNE,2H,G,2HR ,0   ,2HGE,2HNE, 
     2   2HRA,2HL ,0   ,2H/E,0   ,2HNE,2H,U,2HS ,0   ,2HMA,2HNA,2HGE, 
     3   2HR ,0   ,2HSY,2HS ,0,2HY ,0,2HPA,2HSS,2HWO,2HRD,2H  ,0,2H  ,
     4   0   ,2H63,0   ,2H10,0   ,2H/E,0   ,2H10,0   ,2H  ,0   ,2H/E, 
     5   0   ,2HNE,2H,U,2HS ,0   ,2HEN,2HGI,2HNE,2HER,0   ,2HSU,2HPP, 
     6   2HOR,2HT ,0   ,2HY ,0   ,2HHP,2H31,2H17,2H8 ,0   ,2H  ,0   , 
     7   2H63,0   ,2H10,0   ,2H/E,0   ,2H10,0   ,2H  ,0   ,2H/E,0   , 
     8   2HEX,0   ,2H  ,2H  ,2H  ,2H  ,2H  ,2H  ,2H  ,2H  ,2H  ,2H  , 
     9   2H  ,2H  ,2H  ,2H  ,2H  ,2H  ,2H  ,2H  ,2H  ,2H  ,2H  ,2H  , 
     A   2H  ,2H  ,2H  ,2H  / 
      END 
C 
C     ACCT1 - ROUTINE TO PERFORM SESSION MONITOR INITIALIZATION 
C 
C     CALLING SEQUENCE:  CALL ACLNK (2H1 ,1)
C                        FOR FILE INITIALIZATION
C     CALLING SEQUENCE:  CALL ACLNK (2H1 ,2)
C                        FOR MEMORY INITIALIZATION
C     CALLING SEQUENCE:  CALL ACLNK (2H1 ,3)
C                        FOR MEMORY RELEASE 
C 
C     IF ITYPE < 0 THEN BOOTUP
C 
C 
C     ACERRS:            FMP ACERR (ACOPN,READF,WRITF)
C 
C     SEQUENCE OF OPERATIONS: 
C       1.  OPEN THE ACCOUNT FILE 
C       2.  ALLOCATE GLOBAL RESOURCE NUMBER IF NOT YET ALLOCATED
C       3.  READ LOCATION WORDS FROM HEADER TO COMMON 
C       4.  READ LOWEST USER ID, HIGHEST GROUP ID TO COMMON 
C 
C 
      PROGRAM ACCT1(5),92067-16361 REV.2001 791020
      COMPLEX BUF13(2),MESG1(3),MESG2(3)
      DIMENSION IBF12(8)
      COMMON /ACOM1/NDCB(272),NBUF(256),MBUF(256) 
      COMMON /ACOM7/IPBUF(11),ISTRC,JPBUF(11) 
      COMMON /ACOM4/ICMND(40) 
      COMMON /ACOM9/IBUF(40),JBUF(96) 
      COMMON /ACOM3/LIST(10),LDCB(144),LLIST,LLDCB(144),ITTY,ITDCB(144) 
      COMMON /ACOM5/LOWUS,IHIGR 
      COMMON /ACOM6 /LOC(6),IRN,IPFLG,IRN2,IDSZE
      COMMON /ACOMC/ IECHO,LULOG,ITLOG
      COMMON /ACOMD/ICLASS,KPB,KRR,KRRR,IDSES,MYCAP,MYDIR,MYGID,ICRN
      COMMON /ACOM2/ LRTRN,LRTR2,LGOTO,ITYPE,ITTYT,LTOSEG,NAMSG(3)
      EQUIVALENCE (BUF13,IBF12(2)),(IPBUF,IPB)
C 
      DATA BUF13,IBF12 /8HPLEASE L ,8HOG-ON: _ ,-16 / 
C 
      DATA MESG1 / 8H        ,8HWORDS RE,8HQUESTED   /
      DATA MESG2 / 8H        ,8HWORDS AV,8HAILABLE   /
      ASSIGN 10 TO LTOSEG 
   10 GO TO (50,4995,8000,5000),LGOTO 
C 
C     OPEN ACCOUNT FILE 
C 
   50 IDSES=0 
      CALL ACOPN(IERR,IDSES)
      ITTYT=ITTY
      IF(IERR.GE.0) GO TO 5000
      IF(IERR.EQ.-6) GO TO 100
      CALL ACERR(IERR)
      CALL ACTRM
C 
C     SET IDSES TO SYSTEM MANAGER TO CREATE 
C     ACCOUNTS FILE 
C 
  100 IDSES=7777B 
      CALL ACWRI(24HSESSION NOT INITIALIZED  ,12) 
      IF(ITYPE.LT.0) CALL ACTRM 
C 
C     PROMPT FOR LOAD OR INITIALIZE 
C 
  125 CALL ACNVS(24HENTER IN,LO,HE OR /TR  _  ,12,0)
      IF(IPB.NE.2HHE) GO TO 127 
      KPB=-31178
      GO TO LRTRN 
C 
  127 IF(IPB.EQ.2HIN) GO TO 150 
      IF(IPB.EQ.2H/E.OR.IPB.EQ.2H/A) GO TO 200
      IF(IPB.NE.2HLO) GO TO 125 
      CALL NAMR(LIST,ICMND,80,ISTRC)
      LIST(4)=IAND(LIST(4),3) 
      IF(LIST(1).EQ.0.AND.LIST(4).EQ.1) GO TO 135 
      CALL ACOPL(IERR,1,0)
      IF(IERR.EQ.0) GO TO 140 
  130 CALL ACERR(IERR)
      GO TO 125 
  135 IERR=12 
      GO TO 130 
C 
C     ALLOCATE RESOURCE NUMBERS 
C 
  140 CALL RNRQ(24B,IRN,ISTAT)
      CALL RNRQ(24B,IRN2,ISTAT) 
C 
C     SET OLD SIZE OF DISC POOL TO 0
C 
      IDSZE=0 
C 
C     SET ITYPE TO LOAD 
C 
      ITYPE=-4
C 
C     GO LOAD THE ACCOUNTS FILE 
C 
      CALL ACLNK (2H2 ,3) 
C 
C 
C     GO INTERACTIVE TO INITIALIZE SESSION'S FILE 
C         PROMPT FOR CRN
C 
  150 CALL ACNVS(32HENTER DISC LU FOR ACCTS FILE : _ ,16,0) 
      ICRN=IPBUF(1) 
      IF(ICRN.EQ.2H/A ) GO TO 200 
      IF(ICRN.GT.0) ICRN=-ICRN
C 
C       PROMPT FOR SESSION LIMIT
C 
      CALL ACNVS(16HSESSION LIMIT? _,8,0) 
      IF(IPBUF(1).NE.2H/A) GO TO 300
  200 ITYPE=-1
      GO TO LRTR2 
  300 ISL=IPBUF(1)
      IF(IPBUF(4).NE.1) ISL=16
C 
C     PROMPT FOR SESSION MEMORY ALLOCATION
C 
  400 CALL ACNVS(38HSESSION MEMORY ALLOCATION? (Y OR N)  _,19,0)
      IF(IPBUF(1).EQ.2H/A) GO TO 200
      IF(IPBUF(1)/256.EQ.116B) GO TO 500
  450 MEM=70-ISL
      IF(MEM.LT.50) MEM=50
      MEM=-MEM*ISL
      GO TO 600 
  500 CALL ACNVS(28HNO. OF WORDS TO ALLOCATE?  _,14,0)
      IF(IPBUF(1).EQ.2H/A) GO TO 200
      MEM=IPBUF(1)
C 
C     IF MEMORY TO SMALL FOR 1 SESSION USE SESSION ALLOCATION 
C 
      IF(MEM.LT.50) GO TO 450 
C 
C     PROMPT FOR NUMBER OF ACCOUNTS 
C 
  600 CALL ACNVS(26HNUMBER OF USER ACCOUNTS? _,13,0)
      IF(IPBUF(1).EQ.2H/A ) GO TO 200 
      IACCTS=IPBUF(1)+IPBUF(1)/5
      CALL ACNVS(28HNUMBER OF GROUP ACCOUNTS?  _,14,0)
      IF(IPBUF(1).EQ.2H/A) GO TO 200
      IACCTS=(((IACCTS+IPBUF(1))/8)+1)*8-1
      IAST=(ISL-1)/32+2 
      IF(IAST.LT.3) IAST=3
      ICNGT=ISL/2+1 
      ISIZE=IACCTS/2+1+IACCTS/8+IAST+ISL+5
      CALL ACCRE(NDCB,2H+@,ISIZE,IERR)
      IF(IERR.GE.0) GO TO 700 
      CALL ACWRI(8HCREAT  _,4)
      CALL ACERR(IERR)
      CALL ACTRM
C 
C 
C     PROMPT FOR MESSAGE FILE NAMR
C 
  700 CALL ACNVS(22HSYSTEM MESSAGE FILE? _,11,0)
      IF(IPBUF(1).EQ.2H/A) GO TO 7000 
      J=6 
      DO 800 I=1,6
      IF(I.NE.5) J=J+1
  800 NBUF(J)=IPBUF(I)
C 
      IPBU4=IAND(IPBUF(4),3)
      IF(IPBU4.EQ.3) GO TO 820
      IF(IPBU4.EQ.0) GO TO 810
      CALL ACERR(-206)
      GO TO 700 
C 
C     SET DEFAULT 
C 
  810 NBUF(6)=2H
      NBUF(7)=2H
      NBUF(8)=2H
C 
C     PROMPT FOR NAME OF PROMPT STRING
C 
  820 CALL ACPRM(14HPROMPT STRING?  ,7) 
      CALL ACREI(NBUF(13),IERR) 
      IF(NBUF(13).EQ.2H/A) GO TO 7000 
      IF(NBUF(13).EQ.2H  .AND.ITLOG.LE.2) GO TO 850 
      IWRD=ITLOG/2
      LAROW=77B 
      IF(MOD(ITLOG,2).EQ.0) LAROW=37400B
      NBUF(13+IWRD)=NBUF(13+IWRD)+LAROW 
      IF(ITLOG.GT.19) ITLOG=19
      NBUF(12)=-ITLOG-1 
      GO TO 1000
C 
C     PUT IN DEFAULT PROMPT STRING
C 
  850 J=12
      DO 900 I=1,11 
      NBUF(J)=IBF12(I)
  900 J=J+1 
C 
C     SET UP PROMPT STRING
C 
 1000 CALL LMES(NBUF(12),NBUF(13),0)
C 
C 
C     PROMPT FOR LOCATION OF MESSAGE FILES
C 
      CALL ACNVS(28HLOCATION OF MESSAGE FILES? _,14,0)
      IF(IPBUF(1).EQ.2H/A) GO TO 7000 
      NBUF(28)=-ISL 
      NBUF(31)=-ISL 
      NBUF(29)=0
      NBUF(30)=0
      NBUF(26)=IPBUF(1) 
      NBUF(23)=4095 
      NBUF(24)=0
      NBUF(25)=0
      NBUF(27)=MEM
C 
C     CLEAR REST OF BUFFER
C 
      DO 1100 I=32,128
 1100 NBUF(I)=0 
C 
      LOC(1)=2
      LOC(2)=IAST+2 
      LOC(3)=LOC(2)+ICNGT 
C 
C 
C     WRITE MOST OF HEADER
C 
      CALL WRITF(NDCB,IERR,NBUF,128,1)
C 
C     CHECK FOR ACERR 
C 
      IF(IERR.LT.0) GO TO 6000
C 
C     DEFINE STATION CONFIGURATION
C 
 1200 CALL ACNVS(34HSTATION CONFIGURATION (Y OR N)?  _,16,0)
      IF(IPBUF(1).EQ.2H/A ) GO TO 7000
      I=1 
      IREC=LOC(2) 
      IF(IPBUF(1)/256.NE.131B) GO TO 2350 
 1300 J=2 
      CALL ACNVS(14HSTATION LU?  _,7,0) 
      IF(IPBUF(1).EQ.2H/E) GO TO 2300 
      IF(IPBUF(1).EQ.2H/A ) GO TO 1200
      LU=IPBUF(1)-1 
      IF(LU.GE.0.AND.LU.LT.99) GO TO 1400 
      CALL ACERR(-209)
      GO TO 1300
 1400 JBUF(J)=256*LU
      J=J+1 
 1500 CALL ACNVS(22HSESSION LU,SYSTEM LU?  ,11,0) 
      IF(IPBUF(1).EQ.2H/A ) GO TO 1300
      IF(IPBUF(1).EQ.2H/E) GO TO 2100 
      LU2=IPBUF(1)-1
      CALL NAMR(IPBUF,ICMND,80,ISTRC) 
      LU=IPBUF(1)-1 
      IF(LU.LT.254.AND.LU.GE.-1) GO TO 1600 
      CALL ACERR(-209)
      GO TO 1500
 1600 LU=IAND(255,LU) 
      IF(LU2.GE.3.AND.LU2.LT.63) GO TO 1700 
      CALL ACERR(-209)
      GO TO 1500
C 
C     TEST FOR CONFLICT 
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 JBUF(J)=256*LU+LU2
      J=J+1 
      GO TO 1500
C 
C     TELL ABOUT CONFLICT 
C 
 2000 CALL ACPRM(22HDUPLICATE SESSION LU  ,11)
      CALL ACNVS(38HOVERRIDE PRIOR DEFINITION (Y OR N)?  _  ,19,0)
      IF(IPBUF(1)/256.EQ.131B) JBUF(JJ)=256*LU+LU2
      GO TO 1500
 2100 JBUF(1)=J-2 
C 
C 
C     PUT IN FILE 
C 
      DO 2200 J1=1,J-1
      NBUF(I)=JBUF(J1)
      I=I+1 
      IF(I.LE.128) GO TO 2200 
      CALL WRITF(NDCB,IERR,NBUF,128,IREC) 
      IREC=IREC+1 
      I=1 
 2200 CONTINUE
      GO TO 1300
C 
C 
C     POST LAST OF CONFIGURATION TABLE
C 
 2300 IF(I.LE.1.AND.IREC.NE.LOC(2)) GO TO 2500
 2350 DO 2400 J=I,128 
 2400 NBUF(J)=0 
      CALL WRITF(NDCB,IERR,NBUF,128,IREC) 
      IREC=IREC+1 
 2500 LNGCO=IREC-LOC(2) 
      IF(IREC.LT.LOC(3)) IREC=LOC(3)
      LOC(3)=IREC 
 2600 J=1 
      GO TO 2700
 2650 CALL ACWRI(20HDISC ALREADY DEFINED ,10) 
 2700 CALL ACNVS(  16HDISC POOL LU?  _,8,0) 
      IF(IPBUF(1).NE.2H/A ) GO TO 2750
      CALL ACNVS(30HREDEFINE DISC POOL (Y OR N)? _ ,15,0) 
      IF(IPBUF(1)/256.EQ.131B) GO TO 2600 
      GO TO 7000
 2750 LU=IPBUF(1) 
      IF(LU.EQ.2H/E) GO TO 2800 
      IF(LU.GE.4.AND.LU.LE.63) GO TO 2775 
      CALLACERR(-209) 
      GO TO 2700
C 
 2775 DO 2780 JJ=1,J-1
      IF(NBUF(JJ).EQ.LU) GO TO 2650 
 2780 CONTINUE
C 
      NBUF(J)=LU
      J=J+1 
      IF(J.EQ.129) GO TO 3000 
      GO TO 2700
 2800 DO 2900 J1=J,128
 2900 NBUF(J1)=0
C 
C 
C     WRITE DISC POOL 
C 
 3000 CALL WRITF(NDCB,IERR,NBUF,128,IREC) 
      IREC=IREC+1 
      IF(LU.NE.2H/E) GO TO 2600 
      LOC(4)=IREC 
C 
C 
C     CLEAR ID TABLE
C 
      DO 3100 J1=2,256
 3100 NBUF(J1)=0
C 
C     ID=0 IS NOT ALLOWED 
C 
      NBUF(1)=1 
      CALL WRITF(NDCB,IERR,NBUF,256,IREC) 
      IREC=IREC+2 
      LOC(5)=IREC 
      LOC(6)=IREC+IACCTS/8+1
C 
C 
C     INITIALIZE THE ACCOUNT DIRECTORY
C 
      DO 3200 J1=1,113,16 
 3200 NBUF(J1)=-1 
C 
 3300 IF(IREC.GE.LOC(6)-1) GO TO 3400 
      CALL WRITF(NDCB,IERR,NBUF,128,IREC) 
      IREC=IREC+1 
      GO TO 3300
C 
C     WRITE FINAL DIRECTORY RECORD
C 
 3400 NBUF(113)=0 
      CALL WRITF(NDCB,IERR,NBUF,128,IREC) 
      IREC=IREC+1 
      LOC(6)=IREC 
C 
C 
C     UPDATE LOCATIONS IN HEADER
C 
      CALL READF(NDCB,IERR,NBUF,128,LEN,1)
      DO 3500 I=1,6 
 3500 NBUF(I)=LOC(I)
      CALL RNRQ(24B,IRN,ISTAT)
      CALL RNRQ(24B,IRN2,ISTAT) 
      NBUF(25)=IRN
      NBUF(34)=IRN2 
      NBUF(33)=LNGCO
      CALL WRITF(NDCB,IERR,NBUF,128,1)
C 
C     COMPUTE AMOUNT TO TRUNCATE
C 
      ITRN=ISIZE-5*NBUF(6)+4*NBUF(5)
C 
C     PROMPT FOR PASSWORD FOR MANAGER.SYS 
C 
      CALL ACPSN(28HPASSWORD FOR MANAGER.SYS?  _,14,IPBUF,IERR) 
      IF(IERR.NE.0) GO TO 7000
      JJ=62 
      DO 3600 I=2,6 
      LDCB(JJ)=IPBUF(I) 
 3600 JJ=JJ+1 
C     INITIALIZE ACCOUNTS:
C       (1) SYS 
C       (2) SUPPORT 
C       (3) GENERAL 
C       (4) MANAGER.SYS 
C       (5) ENGINEER.SUPPORT
C 
C 
      ITTY=-1 
C 
      LOWUS=4095
      IHIGR=0 
 3700 GO TO LRTRN 
 4995 ITTY=ITTYT
      IF(ITYPE.EQ.-4) GO TO 4996
C 
C     TRUNCATE FILE AND RENAME
C 
      CALL CLOSE(NDCB,IERR,ITRN)
      CALL NAMF(MBUF,IERR,6H++CCT!,6H+@CCT!,-31178,-2,IDUM,70707B)
      CALL ACOPN(IERR,IDSES)
C 
C     RELAESE RESOURCE NUMBER 
C 
      GO TO 4997
 4996 ITYPE=0 
C 
C     IF $DSCS NOT -1 RN'S WONT BE REASSIGNED 
C 
 4997 CALL ACINT(ISTAT) 
      IF(ISTAT.NE.-1) GO TO 5000
      CALL RNRQ(44B,IRN,ISTAT)
      CALL RNRQ(44B,IRN2,ISTAT) 
C 
C     READ ACCOUNT FILE HEADER RECORD 
C 
 5000 CALL READF(NDCB,IERR,NBUF,128,LEN,1)
C 
C     IF RN'S ALLOCATED THEN SET IRN
C     AND REREAD HEADER 
C 
      IRN=NBUF(25)
      CALL ACINT(ISTAT,JSTAT) 
      IF(ISTAT.EQ.-1) GO TO 5010
      CALL RNRQ(1,IRN,ISTT) 
      CALL READF(NDCB,IERR,NBUF,128,LEN,1)
C 
 5010 IF(LGOTO.NE.4) GO TO 5020 
      NBUF(30)=1
      NBUF(28)=NBUF(31) 
      JSTAT=0 
C 
C     SET NO WAIT AND DON'T RELEASE CLASS# BITS 
C 
 5020 CALL WRITF(NDCB,IERR,NBUF,128,1)
C 
C     MOVE LOCATION WORDS, LOWEST USER ID,HIGHEST GROUP ID, 
C     AND RESOURCE NUMBER FROM HEADER TO COMMON 
C 
      DO 5050 I=1,6 
      LOC(I)=NBUF(I)
 5050 CONTINUE
      LOWUS=NBUF(23)
      IHIGR=NBUF(24)
      IRN2=NBUF(34) 
      MEM=NBUF(27)
      IPFLG=NBUF(30)
      ICLASS=NBUF(32) 
      ISL=-NBUF(31) 
      IDSZE=NBUF(35)
C 
C     IF SHUT DOWN DONT CHANGE PROMPT STRING
C 
      IF(JSTAT.LT.0) GO TO 5051 
C 
C     SET PROMPT STRING 
C 
      CALL LMES(NBUF(12),NBUF(13),0)
      IF(IPFLG.LT.0) CALL LMES(-17,18HSESSION SHUT DOWN  ,-2) 
C 
C     ALLOCATE GLOBAL RESOURCE NUMBER IF NOT YET ALLOCATED
C 
 5051 IF(ISTAT.GE.0) GO TO 5800 
C 
C     CLEAR NUMBER OF ACTIVE SESSIONS 
C 
      NBUF(29)=0
      IF(ISTAT.EQ.-2) GO TO 5060
      CALL RNRQ(21B,NBUF(25),ISTT)
      CALL RNRQ(24B,NBUF(34),ISTT)
C 
C     GET CLASS NUMBER FOR TERMINAL WRITES
C 
      ICLASS=0
 5055 CALL EXEC(18,0,JBUF,1,JBUF,JBUF,ICLASS) 
      ICLASS=IOR(120000B,ICLASS)
      NBUF(32)=ICLASS 
 5060 CALL WRITF(NDCB,IERR,NBUF,128,1)
      IF(IERR.LT.0) CALL ACERR(IERR)
      IRN=NBUF(25)
      IRN2=NBUF(34) 
C 
C     CLEAR ACTIVE SESSION TABLE
 5070 DO 5080 I=1,128 
 5080 NBUF(I)=0 
      I1=LOC(1) 
      I2=LOC(2)-1 
      DO 5090 I=I1,I2 
 5090 CALL WRITF(NDCB,IERR,NBUF,128,I)
C 
C 
C     FIND MOUNTED POOL DISCS 
C 
      CALL ACFST(MBUF)
      CALL READF(NDCB,IERR,NBUF,128,LEN,LOC(3)) 
      DO 5300 I=1,128 
      IF(NBUF(I).EQ.0) GO TO 5400 
      DO 5100 J=1,125,4 
      LUD=LBYTE(MBUF(J))
      IF(LUD.EQ.0) GO TO 5300 
      IF(LUD.EQ.NBUF(I)) GO TO 5200 
 5100 CONTINUE
C 
C 
C     FOUND A MATCH SO MARK IT
C 
 5200 NBUF(I)=IOR(NBUF(I),100000B)
 5300 CONTINUE
C 
C 
C     GO INITIALIZE MEMORY
C 
 5400 IF(MEM.GE.0) GO TO 5450 
      MEM=-MEM
      MEMRY=70-ISL
      IF(MEMRY.LT.50) MEMRY=50
      MEMRY=ISL*MEMRY 
      IF(MEMRY.GT.MEM) MEM=MEMRY
 5450 ISIZE=MEM+I 
      NBUF(I)=-1
 5500 CONTINUE
      IF(I.EQ.1) I=0
      JSIZE=ISIZE 
      IDSZE=0 
      IF(IPFLG.GE.0) CALL ACINM(ISIZE,MAXEV,NBUF,I,IDSZE) 
      IF(ISIZE.NE.-1) GO TO 5700
      CALL ACITA(JSIZE,MESG1,3) 
      CALL ACWRI(MESG1,12)
      CALL ACITA(MAXEV,MESG2,3) 
      CALL ACWRI(MESG2,12)
      IF(ITYPE.EQ.-1) GO TO 5600
      CALL ACNVS(26HENTER NO. OF WORDS OR /E _,13,0)
      IF(IPBUF(1).EQ.2H/E) GO TO 5600 
      ISIZE=IPBUF(1)
      GO TO 5500
 5600 CALL RNRQ(4,IRN,ISTAT)
      CALL ACTRM
 5700 CALL READF(NDCB,IERR,NBUF,128,LEN,1)
      NBUF(35)=IDSZE
      CALL WRITF(NDCB,IERR,NBUF,128,1)
 5800 CALL RNRQ(4,IRN,ISTAT)
C 
C     IF NON-SESSION BYPASS CAPABILTY 
C     TESTS 
C 
      IF(IDSES.EQ.0) GO TO 5950 
C 
C     FIND MY CAPABILTY 
C 
      MYSES=LUTRU(1)
      DO 5850 IREC=LOC(1),LOC(2)-1
      CALL READF(NDCB,IERR,NBUF,128,LEN,IREC) 
      DO 5850 J=1,128,4 
      IF(MYSES.EQ.NBUF(J)) GO TO 5900 
 5850 CONTINUE
      GO TO 5950
C 
C     FOUND SESSION NOW LOOK UP 
C     GROUP ID
C 
 5900 MYDIR=NBUF(J+3)+1 
      CALL ACDIR(1,MYDIR,IBUF,IERR) 
      MYGID=IBUF(13)
C 
C     NOW GET CAPABILTY 
C 
      IOFST=0 
      IREC=IBUF(15) 
      IF(0.GT.IREC) IOFST=64
      IREC=IAND(IREC,77777B)
      CALL READF(NDCB,IERR,NBUF,128,LEN,IREC) 
      MYCAP=NBUF(22+IOFST)
C 
C 
C     RESTART SESSION 
C 
 5950 IF(ITYPE.GE.0) CALL ACSES(JSTAT)
      GO TO LRTR2 
C 
C     POST FMP ACERR
C 
 6000 CALL ACERR(IERR)
C 
C     PURGE FILE AND RETURN 
C 
 7000 CALL ACCRE(NDCB,2H+@,0,IERR)
      ITYPE=-1
      GO TO LRTR2 
C 
C     GO CLEAN UP PURGED ACCOUNTS 
C 
 8000 CALL ACACP
      GO TO LRTRN 
C 
C     DUMMY MAIN CALL 
C 
 9999 CALL ACCTS
      END 
      PROGRAM ACCT2(5),92067-16361 REV.1940 790725
      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 /ACOM7/IPBUF(11),ISTRC,JPBUF(11) 
      COMMON /ACOMD/ICLASS,KPB,KRR,KRRR,IDSES,MYCAP,MYDIR,MYGID 
      ASSIGN 100 TO LTOSEG
C 
C     CALL THE APPROPRIATE COMMAND ROUTINE
C 
  100 GO TO (200,300,300),LGOTO 
  200 CALL NAMR(IPBUF,ICMND,80,ISTRC) 
      IF(IAND(IPBUF(4),3).NE.3) GO TO LRTR2 
      ITEMP=IPBUF(1)/256
      IF(ITEMP.EQ.125B) GO TO 210 
      IF(IDSES.EQ.7777B) GO TO 205
      CALL ACERR(46)
      GO TO LRTRN 
C 
  205 IF(ITEMP.EQ.107B) GO TO 220 
      GO TO LRTR2 
  210 CALL ACNWU
      GO TO LRTRN 
  220 CALL ACNWG
      GO TO LRTRN 
  300 CALL ACLOA(LGOTO) 
      GO TO LRTRN 
C 
C     DUMMY MAIN CALL 
C 
 9999 CALL ACCTS
      END 
      PROGRAM ACCT3(5),92067-16361 REV.1940 790724
      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 /ACOM7/IPBUF(11),ISTRC,JPBUF(11) 
      ASSIGN 300 TO LTOSEG
  300 GO TO (400,400,400,400,310,320,500),LGOTO 
  310 CALL ACALU(1) 
      GO TO LRTRN 
  320 CALL ACALU(2) 
      GO TO LRTRN 
  400 CALL ACPUU(LGOTO) 
      GO TO LRTRN 
C 
C     CALL ALTER PASSWORD 
C 
  500 CALL ACAPA
      GO TO LRTRN 
C 
C     DUMMY MAIN CALL 
C 
 9999 CALL ACCTS
      END 
      PROGRAM ACCT4(5),92067-16361 REV.1940 790725
      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 /ACOM7/IPBUF(11),ISTRC,JPBUF(11) 
      ASSIGN 300 TO LTOSEG
  300 GO TO (400,450,450,450,440),LGOTO 
  400 CALL NAMR(IPBUF,ICMND,80,ISTRC) 
      ITEMP=IAND(IPBUF(4),3)
      IF(ITEMP.EQ.0) GO TO 410
      IF(ITEMP.NE.3) GO TO LRTR2
      ITEMP=IPBUF(1)/256
      IF(ITEMP.EQ.125B) GO TO 410 
      IF(ITEMP.EQ.107B) GO TO 420 
      IF(ITEMP.EQ.101B) GO TO 430 
      GO TO LRTR2 
  410 CALL ACLIU(1) 
      GO TO LRTRN 
  420 CALL ACLIU(2) 
      GO TO LRTRN 
  430 CALL ACLIA(1) 
      GO TO LRTRN 
  440 CALL ACLIA(2) 
      GO TO LRTRN 
  450 CALL ACPUA(LGOTO-1,IERR)
      IF(LGOTO.NE.4) GO TO LRTRN
      IF(IERR.NE.0) GO TO LRTR2 
      GO TO LRTRN 
 9999 CALL ACCTS
      END 
      PROGRAM ACCT5(5),92067-16361 REV.1940 781213
      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 /ACOM7/IPBUF(11),ISTRC,JPBUF(11) 
      COMMON /ACOMD/ICLASS,KPB,KRR,KRRR 
      ASSIGN 400 TO LTOSEG
  400 GO TO (500,600,900,1000),LGOTO
  500 CALL ACALT
      GO TO LRTRN 
  600 CALL ACTEL
      GO TO LRTRN 
  900 CALL ACUNL
      GO TO LRTRN 
C 
 1000 CALL ACWRH(KPB,KRR,KRRR)
      GO TO LRTRN 
C 
C     DUMMY MAIN CALL 
C 
 9999 CALL ACCTS
      END