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-18372 
C 
C     RELOCATABLE PART NUMBER : 92067-16361 
C 
C     PROGRAMER(S)   : J.M.N. 
C 
C 
C 
C     ACNWG - NEW GROUP COMMAND ROUTINE 
C 
C     CALLING SEQUENCE:  CALL ACNWG 
C 
C     ACERRS:            -201  NO FREE ACCOUNTS 
C                        -202  ACCOUNT WITH THIS NAME ALREADY EXISTS
C                        -203  INVALID ACCOUNT NAME 
C                        -209  INVALID SST ENTRY
C                        -211  USER OR GROUP ID NOT AVAILABLE 
C                         FMP ACERR (READF,WRITF) 
C 
C 
      SUBROUTINE ACNWG ,92067-16361 REV.1940 790227 
      DIMENSION MSGNM(6),MSGST(29),IUSER(5),IDMY(2) 
      COMMON /ACOM1/NDCB(272),NBUF(128) 
      COMMON /ACOM6 /LOC(6),IRN 
      COMMON /ACOM7/IPBUF(11),ISTRC,JPBUF(11) 
      COMMON /ACOM9/IBUF(40),JBUF(96) 
      DATA MSGNM/2HGR,2HOU,2HP ,2HNA,2HME,2H? / 
      DATA MSGST/2HSS,2HT ,2HDE,2HFI,2HNI,2HTI,2HON,2H? ,2H(E,
     1     2HNT,2HER,2H S,2HES,2HSI,2HON,2H L,2HU,,2H S,2HYS, 
     2     2HTE,2HM ,2HLU,2H, ,2HOR,2H E,2HNT,2HER,2H /,2HE)/ 
C 
C 
      INDX=6
C 
C     CHECK IF A FREE ACCOUNT OF 64 WORDS EXISTS
C 
      CALL ACFDF(IDIRN,IRECN,IOFST,IERR,1)
      IF(IERR.EQ.0) GO TO 100 
      CALL ACERR(IERR)
      RETURN
C 
C     PROMPT FOR THE GROUP NAME 
C 
  100 CALL ACPRM(MSGNM,6) 
C 
C     READ AND PARSE THE GROUP NAME 
C 
      CALL ACREI(IBUF,IERR) 
      ICHAR=1 
      CALL PARSN(IPBUF,IBUF,80,ICHAR,IERR)
C 
C     CHECK FOR REQUEST TO ABORT COMMAND
C 
      IF(IPBUF(2).EQ.2H/E.OR.IPBUF(2).EQ.2H/A) RETURN 
C 
C     IF NAME IS INVALID, REPORT ACERR AND RE-PROMPT
C 
      IF(IERR.EQ.0) GO TO 300 
  200 CALL ACERR(-203)
      GO TO 100 
C 
C     CHECK THAT NAME IS NOT IN USER.GROUP FORMAT,
C     THAT NAME IS NOT "@", AND THAT NAME IS NOT NULL 
C 
  300 IF(IAND(IPBUF(1),255).NE.0) GO TO 200 
      IF(IPBUF(2).EQ.2H@ ) GO TO 200
      IF(IPBUF(1).EQ.0) GO TO 200 
C 
C     CHECK IF GROUP ALREADY EXISTS 
C 
      IUSER(1)=0
      CALL ACFDA(IUSER,IPBUF(2),IDMY,IDMY,IDMY,IERR)
      IF(IERR.EQ.-200) GO TO 350
C 
C     ACERR - GROUP ACCOUNT ALREADY EXISTS
C 
      CALL ACERR(-202)
      GO TO 100 
C 
C     PROMPT FOR GROUP SST DEFINITION 
C 
  350 ICL=29
  400 CALL ACPRM(MSGST,ICL) 
      ICL=8 
      CALL ACREI(IBUF,IERR) 
      ICHAR=1 
      CALL NAMR(JPBUF,IBUF,80,ICHAR)
C 
C     CHECK FOR REQUEST TO END SST DEFINITION 
C     ALSO CHECK FOR NULL OR BLANK (DEFAULT TO NO GROUP SST)
C 
      IF(JPBUF(1).EQ.2H/E) GO TO 500
      ITEMP=IAND(JPBUF(4),3)
      IF((ITEMP.EQ.0).AND.(INDX.EQ.6)) GO TO 500
C 
C     CHECK FOR REQUEST TO ABORT COMMAND
C 
      IF(JPBUF(1).EQ.2H/A) RETURN 
C 
C     READ, PARSE AND VALIDATE SST ENTRY
C     SYSTEM LU MUST BE NUMERIC, 0-254
C     SESSION LU MUST BE NUMERIC, 4-63
C 
      IF(IAND(JPBUF(4),3).NE.1) GO TO 430 
      ISES=JPBUF(1) 
      CALL NAMR(JPBUF,IBUF,80,ICHAR)
      ISYS=JPBUF(1) 
      IF((ISYS.LT.0).OR.(ISYS.GT.254)) GO TO 430
      IF(IAND(JPBUF(4),3).NE.1) GO TO 430 
      IF((ISES.LT.4).OR.(ISES.GT.63)) GO TO 430 
C 
C     CHECK IF SESSION LU HAS ALREADY BEEN DEFINED
C 
      IF(INDX.EQ.6) GO TO 420 
      DO 410 I=7,INDX 
      IDMY=IAND(JBUF(I),255)+1
      IF(IDMY.EQ.ISES) GO TO 430
  410 CONTINUE
  420 INDX=INDX+1 
      JBUF(INDX)=(IAND(255,ISYS-1)*256)+ISES-1
      GO TO 400 
  430 CALL ACERR(-209)
      GO TO 400 
C 
C     GET A FREE ACCOUNT ENTRY
C 
  500 ISIZE=INDX
      LEN=6-INDX
      CALL ACFDF(IDIRN,IRECN,IOFST,IERR,1)
      IF(IERR.GE.0) GO TO 600 
      CALL ACERR(IERR)
      RETURN
C 
C     GET A GROUP ID
C 
  600 CALL ACGID(-1,ID,IERR)
      IF(IERR.NE.-2) GO TO 700
      CALL ACERR(-211)
      RETURN
C 
C     BUILD THE DIRECTORY ENTRY 
C 
  700 IBUF(1)=IPBUF(1)/256
      DO 800 I=2,6
      IBUF(I)=2H
  800 CONTINUE
      DO 900 I=7,11 
      IBUF(I)=IPBUF(I-5)
  900 CONTINUE
      IBUF(12)=0
      IBUF(13)=ID 
      IBUF(14)=IRECN
      IF(IOFST.NE.0) IBUF(14)=IOR(IRECN,100000B)
      IBUF(15)=0
      IBUF(16)=0
      CALL RNRQ(1,IRN,ISTAT)
      CALL ACDIR(2,IDIRN,IBUF,IERR) 
C 
C     BUILD THE GROUP ACCOUNT ENTRY 
C 
      CALL READF(NDCB,IERR,NBUF,128,IDMY,IRECN) 
      IF(ISIZE.GT.64) ID=IOR(ID,100000B)
      NBUF(IOFST+1)=ID
      DO 1000 I=2,5 
      NBUF(IOFST+I)=0 
 1000 CONTINUE
      NBUF(IOFST+6)=LEN 
      IF(ISIZE.EQ.6) GO TO 1200 
      DO 1100 I=7,INDX
      NBUF(IOFST+I)=JBUF(I) 
 1100 CONTINUE
 1200 CALL WRITF(NDCB,IERR,NBUF,128,IRECN)
      IF(IERR.LT.0) CALL ACERR(IERR)
      CALL RNRQ(4,IRN,ISTAT)
      RETURN
      END 
                              