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-18382 
C 
C     RELOCATABLE PART NUMBER : 92067-16363 
C 
C     PROGRAMER(S)   : J.M.N. 
C 
C 
C 
C 
C     ACACP PURGES ACCOUNTS WHICH 
C     ARE FLAGED FOR PURGING
C 
C     CALLING SEQUENCE
C      CALL ACACP 
C 
      SUBROUTINE ACACP  ,92067-16363 REV.2001 791021
      LOGICAL IFBRK 
      DIMENSION NAMEF(3),NALL(11) 
      DIMENSION LOGON(5),LGOFF(5),NAME1(5),NAME2(5) 
      COMMON /ACOM1/NDCB(272),NBUF(256),MBUF(256) 
      COMMON /ACOM4/ICMND(40),NAMPR(3),ICLFG,NMPR3
      COMMON /ACOM6 /LOC(6),IRN,IPFLG,IRN2
      COMMON /ACOM7/IPBUF(11),ISTRC,JPBUF(11) 
      COMMON /ACOM9/IBUF(128) 
      COMMON /ACOMD/ICLASS,KPB,KRR,KRRR,IDSES,MYCAP,MYDIR,MYGID 
      DATA NAMEF /2H+@,2HCC,2HT! /
      DATA NALL /257,2H@ ,2H  ,2H  ,2H  ,2H  ,
     1               2H@ ,2H  ,2H  ,2H  ,2H  /
      DATA DJNP,DSNP /4HDJNP,4HDSNP  /
      DATA LOGON / 2HOF,2H,L,2HOG,2HON,2H,1 / 
      DATA LGOFF / 2HOF,2H,L,2HGO,2HFF,2H,1 / 
      IFLG=0
C 
C     GO SEE IF SHUT DOWN OR PURGE ACCOUNTS 
C 
      CALL READF(NDCB,IERR,NBUF,128,LEN,1)
      IF(NBUF(30) .NE.0) IPFLG=NBUF(30) 
      IF(NBUF(29).NE.0.OR.NBUF(30).GE.0) GO TO 50 
      IF(IPFLG.EQ.-1.OR.IPFLG.EQ.-3) GO TO 50 
C 
C     CHECK FOR SPOOLS
C 
      CALL ACGSP(NALL,IERR,DJNP)
      CALL ACGSP(NALL,JERR,DSNP)
      IF(IERR.NE.0.OR.JERR.NE.0) GO TO 50 
C 
C     RELEASE DISC POOL 
C 
      ISIZE=0 
      CALL ACINM(ISIZE,MAXEV,IDUM,0,NBUF(35)) 
      ICLS=0
      IF(IPFLG.EQ.-2) ICLS=ICLASS 
C 
C     RELEASE MEMORY ALLOCATION 
C 
      DO 8 J=1,1000 
      CALL RLMEM(-2,ICLS) 
      GO TO 600 
    5 IF(IPFLG.NE.-2) GO TO 50
      IF(ICLS.EQ.0) GO TO 9 
      IF(J.EQ.2) CALL ACWRI(28HWAITING FOR CLASS # TO CLEAR ,14)
C 
C     WAIT 2 SEC
C 
      CALL EXEC(12,0,2,0,-2)
      IF(.NOT.IFBRK(IDUM)) GO TO 8
      CALL ACERR(0) 
      RETURN
    8 CONTINUE
      RETURN
C 
C     RELEASE RESOURCE NUMBERS
C 
    9 CALL RNRQ(44B,IRN,ISTAT)
      CALL RNRQ(44B,IRN2,ISTAT) 
      ICLS=0
      CALL RLMEM(-1,ICLS) 
      GO TO 600 
   11 DO 10 I=1,100 
      CALL CLOSE(NDCB)
      CALL ACCRE(NDCB,NAMEF,0,IERR) 
      IF(IERR.GE.0.OR.IERR.EQ.-6) GO TO 30
      DO 44 JJJ=1,5 
      NAME1(JJJ)=LOGON(JJJ) 
   44 NAME2(JJJ)=LGOFF(JJJ) 
      CALL MESSS(NAME1,10)
      CALL MESSS(NAME2,10)
      CALL EXEC(12,0,1,0,-1)
   10 CONTINUE
      CALL ACERR(IERR)
      CALL ACOPN(IERR,IDSES)
      RETURN
   30 CALL ACWRI(30HACCOUNTS FILE HAS BEEN PURGED  ,15) 
      IPFLG=-1
      ICLFG=-1
      CALL ACTRM
   50 IF(IPFLG.EQ.0) RETURN 
      LD=LOC(5) 
      IDIRN=1 
  100 CALL READF(NDCB,IERR,NBUF,256,LEN,LD) 
      DO 400 I=1,256,16 
      IF(NBUF(I).LT.0) GO TO 400
      IF(0.EQ.NBUF(I)) GO TO 450
      IF(0.LE.NBUF(I+1)) GO TO 400
C 
C     FOUND ENTRY TO BE PURGED
C 
      ID=NBUF(I+12) 
      IDU=NBUF(I+11)
C 
C     SEARCH ACTIVE SESSION BLOCK 
C     TO SEE IF ACCOUNT IS IDLE 
C 
      IRECA=LOC(1)
      IRECD=LOC(5)
      ILAST=128*(LOC(2)-IRECA)
      DO 150 IDX=1,ILAST,4
      IF(IVBUF(IDX,IRECA).EQ.0) GO TO 150 
      IDR=IVBUF(IDX+3,IRECA)+1
      IDG=IVBUF(16*IDR-3,IRECD) 
      IF(IDIRN.EQ.IDR.OR.(IDU.EQ.0.AND.IDG.EQ.ID)) GO TO 160
  150 CONTINUE
  160 CALL IVBUF
      IF(IDIRN.EQ.IDR.OR.(IDU.EQ.0.AND.IDG.EQ.ID)) GO TO 350
C 
C     IF GROUP ACCOUNT GO CHECK DISCS 
C 
      IF(IDU.EQ.0) GO TO 200
      ID=IDU
C 
C     NOT ACTIVE SESSION
C     SO GO CHECK GASP
C 
      CALL ACGSP(NBUF(I),IERR,DJNP) 
      IF(IERR.NE.0) GO TO 350 
      CALL ACGSP(NBUF(I),IERR,DSNP) 
      IF(IERR.NE.0) GO TO 350 
C 
C     SEE IF ANOUTHER ACCOUNT HAS THIS ID 
C 
      DO 170 IDR=1,10000
      CALL ACDIR(1,IDR,IBUF,IRR)
      IF(IRR.LT.0) GO TO 200
      IF(IDR.NE.IDIRN.AND.ID.EQ.IBUF(12)) GO TO 300 
C 
C     YES GO PURGE THIS ACCOUNT 
C 
  170 CONTINUE
C 
C     GET CARTRIDGE LIST
C 
  200 CALL ACFST(MBUF)
C 
C     CHECK FOR DISCS THAT BELONG TO ACCOUNT
C 
      DO 250 J=4,256,4
      IF(MBUF(J-3).EQ.0) GO TO 300
      IF(MBUF(J).EQ.ID) GO TO 340 
  250 CONTINUE
  300 CALL READF(NDCB,IERR,NBUF,256,LEN,LD) 
      IREC=NBUF(I+14) 
      IOFST=0 
      IF(IREC.LT.0) IOFST=64
      IREC=IAND(77777B,IREC)
      CALL RNRQ(1,IRN,ISTAT)
      IF(NBUF(I).LE.255) GO TO 320
      CALL READF(NDCB,IERR,IBUF,128,LEN,IREC) 
      IF(IBUF(IOFST+1).GE.0) GO TO 320
      JDIRN=IAND(IBUF(IOFST+64),77777B)-LOC(6)+1
      IF(IBUF(IOFST+64).LT.0) JDIRN=JDIRN+1 
      CALL ACPGA(-1,JDIRN,0)
  320 CALL ACPGA(-1,IDIRN,0)
      CALL RNRQ(4,IRN,ISTAT)
      GO TO 390 
C 
C     IF NOT ALREADY SET,THEN SET TO 20 FOR DISC ONLY 
C 
  340 IF(IFLG.EQ.0) IFLG=20 
      GO TO 390 
C 
C     SET IFLG=1 FOR ALL OTHER CONFLICTS
C 
  350 IFLG=1
  390 CALL READF(NDCB,IERR,NBUF,256,LEN,LD) 
  400 IDIRN=IDIRN+1 
      LD=LD+2 
      GO TO 100 
C 
C     UPDATE PURGE FLAG 
C 
  450 CALL ACSID
      CALL RNRQ(1,IRN,ISTAT)
      CALL READF(NDCB,IERR,NBUF,128,LEN,1)
      IF(NBUF(30).LT.0) GO TO 500 
      NBUF(30)=IFLG 
      IPFLG=IFLG
      CALL WRITF(NDCB,IERR,NBUF,128,1)
  500 CALL RNRQ(4,IRN,ISTAT)
      RETURN
C 
C     MEMORY ACERR RETURN 
C 
  600 CALL ACERR(-225)
      RETURN
      END 
                                                                                                                                                                                            