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-18377 
C 
C     RELOCATABLE PART NUMBER : 92067-16361 
C 
C     PROGRAMER(S)   : J.M.N. 
C 
C 
C 
C 
C 
C     PURGE,USER
C     PURGE,GROUP 
C     RESET 
C     CALLING SEQUENCE: 
C        CALL ACPUU(ITYPE)
C 
C        WHERE: ITYPE=1 FOR PURGE,USER
C               ITYPE=2 FOR PURGE,GROUP 
C               ITYPE=3,4  FOR RESET
C                   ITYPE=3 FOR RESET,USER
C                   ITYPE=4 FOR RESET,GROUP 
C 
C     PURGE,USER
C     RESET,USER
C 
C     ACCOUNT NAME                FUNCTION
C 
C 
C      USER.GROUP          PURGE OR RESET ONE ENTRY FOR ACCOUNT 
C 
C      USER.@              PURGE OR RESET ALL ENTRIES IN ALL GROUPS 
C                           WITH NAME USER
C 
C      @.GROUP             PURGE OR RESET ALL USERS OF GROUP
C 
C 
C      @.@                 PURGE OR RESET ALL USERS 
C 
C     PURGE,GROUP 
C     RESET,.GROUP
C 
C     GROUP                PURGE OR RESET "GROUP" 
C 
C     @                    PURGE OR RESET ALL GROUPS
C 
C 
C     ACERRS:            -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                        -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                         FMP ACERR (READF,WRITF) 
C 
C 
      SUBROUTINE ACPUU(ITYPE) ,92067-16361 REV.1940 790725  
      LOGICAL ISRCH 
      COMPLEX QUES(3) 
      DIMENSION MSNAM(5),MSGNM(6),MSGST(12),MSUPW(7),MSHFL(8) 
      DIMENSION MSCAP(8),MSMXD(12),MSSST(29),MSSPR(11),MSLNK(31)
      DIMENSION MSGNX(6),LUMS1(27),LUMS2(32)
      DIMENSION IUSER(5),IDMY(2),IRECG(2),IRECU(2)
      DIMENSION NAME(11),IQUES(12),ITPS(4,4),NAMEP(10)
      COMMON /ACOM1/NDCB(272),NBUF(128) 
      COMMON /ACOM6 /LOC(6),IRN,IPFLG 
      COMMON /ACOM7/IPBUF(11),ISTRC,JPBUF(11) 
      COMMON /ACOM9/IBUF(40),JBUF(96) 
      COMMON /ACOMA /ISRCH
      COMMON /ACOM4/ ICMND(40)
      COMMON /ACOM3/LIST(10),LDCB(144),LLIST,LLDCB(144),ITTY,ITDCB(144) 
      COMMON /ACOMD/ICLASS,KPB,KRR,KRRR,IDSES,MYCAP,MYDIR,MYGID 
      EQUIVALENCE (IPB,IPBUF) 
      EQUIVALENCE (IQUES,QUES)
      DATA IAT/2H@  / 
      DATA ITPS /2HUS,2HER,2H  ,2H  ,2HGR,2HOU,2HP ,2H    , 
     1           2HUS,2HER,2HS ,2H  ,2HGR,2HOU,2HPS,2H    / 
      DATA QUES /8HTO BE PU,8HRGED (Y ,8HOR N)? _  /
      DATA NAMEP /3007B,125052B,2HAC,2HCT,2H  ,2H 
     1,125120B,2HUR,2HGE,2HD  / 
C 
C     PARSE ACCOUNT NAME
C 
      JERR=0
      CALL PARSN(NAME,ICMND,80,ISTRC,JERR)
      IF(JERR.NE.0) GO TO 2800
C 
C     PARSE FOR CPU OR CONNECT
C 
      IF(ITYPE.GE.3) CALL NAMR(IPBUF,ICMND,80,ISTRC)
C 
C     IF GROUP MOVE NAME(2) TO NAME(7)
C 
      GO TO (1100,1000,1100,1000),ITYPE 
 1000 DO 1010 I=2,6 
      NAME(I+5)=NAME(I) 
 1010 NAME(I)=2H
      NAME(2)=0 
      NAME(1)=MBYTE(NAME(1))
      IU=IAT
      GO TO 1125
C 
C     TEST FOR USER.GROUP FORMAT
C 
 1100 IF(MBYTE(NAME(1)).EQ.0) GO TO 2900
      IU=NAME(2)
 1125 IF(LBYTE(NAME(1)).NE.0) GO TO 1150
      NAME(7 )=2HGE 
      NAME(8 )=2HNE 
      NAME(9 )=2HRA 
      NAME(10)=2HL
      NAME(11)=2H 
      NAME(1)=IAND(177400B,NAME(1))+7 
C 
C     SAVE RESET VALUES FOR LOOP
C 
 1150 IG=NAME(7)
C 
C     CHECK TO SEE IF ACCOUNT EXISTS
C 
      CALL ACFDA(NAME(2),NAME(7),IDIRN,IDMY,IDMY,JERR)
      IF(JERR.NE.0) GO TO 2900
      IF(IDSES.EQ.7777B) GO TO 1200 
C 
C     IF GROUP MANAGER CHECK IF HIS GROUP 
C 
      CALL ACDIR(1,IDIRN,IBUF,IERR) 
      IF(MYGID.EQ.IBUF(13).AND.IG.NE.IAT) GO TO 1200
C 
C     TELL THE BAD BOY
C 
      JERR=46 
      GO TO 2900
C 
 1200 NAME(2)=IU
      NAME(7)=IG
      ITP=ITYPE 
      GO TO (1250,1300,1640,1640),ITYPE 
C 
C     COMPUTE MESSAGE 
C 
 1250 IF(IU.EQ.IAT.OR.IG.EQ.IAT) ITP=3
      GO TO 1350
 1300 IF(IG.EQ.IAT) ITP=4 
 1350 DO 1400 I=1,4 
 1400 IBUF(I)=ITPS(I,ITP) 
      IDX=8 
      CALL IPRSN(NAME,IBUF,IDX) 
      IDX=IDX+1 
      IF(MOD(IDX,2).EQ.1) IDX=IDX+1 
      CALL ZPUT(IQUES,1,24) 
 1500 CALL ACNVS(IBUF,IDX/2,0)
      IF(IPB.EQ.2HN ) RETURN
      IF(IPB.NE.2HY ) GO TO 1500
C 
C     GET GROUP ACCOUNT 
C 
 1640 IUSER(1)=0
      CALL RNRQ(1,IRN,ISTAT)
      CALL ACFDA(IUSER,NAME(7),JDIRN,IRECU,IRECG,JERR)
      IF(JERR.NE.0) GO TO 2950
      GO TO (1690,1650,1690,1650),ITYPE 
 1650 CALL READF(NDCB,JERR,NBUF,128,LEN,IRECG)
      IOFST=IRECG(2)
      IF(ITYPE.NE.4) GO TO 1690 
      IF(IPB.EQ.2HCP ) GO TO 1660 
      NBUF(IOFST+2)=0 
      NBUF(IOFST+3)=0 
 1660 IF(IPB.EQ.2HCO) GO TO 1680
      NBUF(IOFST+4)=0 
      NBUF(IOFST+5)=0 
 1680 CALL WRITF(NDCB,JERR,NBUF,128,IRECG)
C 
C     SET TO SEARCH ALL USERS OF GROUP
C 
      NAME(2)=IAT 
      IU=IAT
C 
C     RELEASE RESOURCE NUMBER 
C 
 1690 CALL RNRQ(4,IRN,ISTAT)
      ISRCH=.FALSE. 
C 
C     GET USER ACCOUNT
C 
 1700 CONTINUE
      CALL ACFDA(NAME(2),NAME(7),IDIRN,IRECU,IRECG,JERR)
      IF(JERR.NE.0) GO TO 2500
      CALL RNRQ(1,IRN,ISTAT)
      ISRCH=.FALSE. 
      CALL ACFDA(NAME(2),NAME(7),IDIRN,IRECU,IRECG,JERR)
      IF(JERR.LT.0) GO TO 2950
      IOFST=IRECU(2)
      CALL READF(NDCB,JERR,NBUF,128,LEN,IRECU)
      ID=NBUF(IOFST+29) 
      IF(ID.GE.4094.OR.ITYPE.GT.2) GO TO 2000 
C 
C     FLAG ACCOUNT TO PURGE 
C 
      CALL ACDIR(1,IDIRN,IBUF,IERR) 
      DO 1800 JJ=1,10 
 1800 IBUF(JJ)=NAMEP(JJ)
      CALL ACDIR(2,IDIRN,IBUF,IERR) 
C 
C     SET PURGE FLAG IN HEADER
C 
      CALL READF(NDCB,IERR,NBUF,128,LEN,1)
      NBUF(30)=1
      CALL WRITF(NDCB,IERR,NBUF,128,1)
      IPFLG=1 
C 
C     IF RESET
C 
 2000 IF(ITYPE.NE.3) GO TO 2400 
      IF(IPB.EQ.2HCP) GO TO 2100
      NBUF(IOFST+25)=0
      NBUF(IOFST+26)=0
 2100 IF(IPB.EQ.2HCO) GO TO 2200
      NBUF(IOFST+27)=0
      NBUF(IOFST+28)=0
 2200 CALL WRITF(NDCB,JERR,NBUF,128,IRECU)
C 
C     GO BACK AND SEARCH REST OF DIRECTORY
C 
 2400 CALL RNRQ(4,IRN,ISTAT)
      ISRCH=.TRUE.
      NAME(2)=IU
      IF(IU.EQ.IAT) GO TO 1700
 2500 IF(ITYPE.NE.2) GO TO 2550 
      IUSER(1)=0
      ISRCH=.FALSE. 
      CALL RNRQ(1,IRN,ISTAT)
      CALL ACFDA(IUSER,NAME(7),JDIRN,IRECU,IRECG,JERR)
      IF(JERR.NE.0) GO TO 2950
      CALL ACDIR(1,JDIRN,IBUF,IERR) 
      IF(IBUF(13).LE.3) GO TO 2525
      DO 2510 JJ=1,10 
 2510 IBUF(JJ)=NAMEP(JJ)
      CALL ACDIR(2,JDIRN,IBUF,IERR) 
      IPFLG=1 
 2525 CALL RNRQ(4,IRN,ISTAT)
 2550 NAME(7)=IG
      IF(IG.NE.IAT) GO TO 3000
      ISRCH=.TRUE.
      GO TO 1640
C 
C     ACERR RETURN
C 
 2800 JERR=-203 
 2900 CALL ACERR(JERR)
      GO TO 3000
C 
C     UNLOCK RESOURCE NUMBER
C 
 2950 CALL RNRQ(4,IRN,ISTAT)
C 
C     FINISHED
C        SO CLEAN UP
C 
 3000 ISRCH=.FALSE. 
      RETURN
      END 
                                                                                            