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