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-18378 
C 
C     RELOCATABLE PART NUMBER : 92067-16361 
C 
C     PROGRAMER(S)   : J.M.N. 
C 
C 
      SUBROUTINE ACTEL ,92067-16361 REV.1940 790412 
      LOGICAL  ISRCH,XFTTY,IFBRK
      COMMON /ACOM1/NDCB(272),NBUF(256) 
      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 /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,ISR3,ISR4 
      COMMON /ACOMB /ISTK(90),IPT 
      COMMON /ACOMC/IECHO,LULOG,ITLOG,KECHO 
      COMMON /ACOMD/ICLASS
      DIMENSION LU(2),IDMY(2) 
      DATA LU(2) / 0 /
C 
C     SET CLASS WITH WAIT 
C 
      ICLS=IAND(17777B,ICLASS)
C 
C     CHECK FOR LU
C 
      ILU=-1
      IC=ISTRC
      CALL NAMR(IPBUF,ICMND,80,IC)
      IF(IAND(IPBUF(4),3).NE.1) GO TO 10
C 
C     TELL LU INSTEAD ACCOUNT 
C 
      ISTRC=IC
      ILU=IPBUF(1)
      IF(ILU.LT.0.OR.ILU.GT.255) GO TO 398
      LU(1)=IOR(100000B,ILU)
      GO TO 25
C 
C     PARSE FOR USER NAME 
C 
   10 CALL PARSN(IPBUF,ICMND,80,ISTRC,IERR) 
C 
C     TEST FOR USER.GROUP FORMAT
C 
      IF(LBYTE(IPBUF(1)).NE.0) GO TO 25 
      IPBUF(7 )=2HGE
      IPBUF(8 )=2HNE
      IPBUF(9 )=2HRA
      IPBUF(10)=2HL 
      IPBUF(11)=2H
C 
C     PARSE FOR NAMR
C 
   25 CALL NAMR(JPBUF,ICMND,80,ISTRC) 
      IFILE=IAND(JPBUF(4),3)
      IF(IFILE.NE.3) GO TO 30 
      CALL OPEN(LDCB,JERR,JPBUF,0,JPBUF(5),JPBUF(6))
      IF(JERR.LT.0) GO TO 400 
   30 I=MOD(ISTRC-1,2)
      IDX=(ISTRC-1)/2+1 
      IF(I.NE.0) ICMND(IDX)=IOR(IAND(377B,ICMND(IDX)),20000B) 
      LNGTH=ISTRC-I-1-ITLOG 
      IF(ISTRC.GE.ITLOG) LNGTH=0
      IF(ILU.GE.0) GO TO 105
      IU=IPBUF(2) 
      IG=IPBUF(7) 
      IFLG=0
      ISRCH=.FALSE. 
C 
C     GO FIND ACOUNT(S) 
C 
   50 CALL ACFDA(IPBUF(2),IPBUF(7),IDIRN,IDMY,IDMY,IERR)
      IF(IERR.LT.0) GO TO 300 
      IF(IFLG.EQ.0) IFLG=-1 
      IDIRX=1 
  100 CALL ACASB(IDIRN,ISTAT,IDIRX) 
      IF(ISTAT.EQ.0) GO TO 200
      LU(1)=IOR(100000B,ISTAT)
      IF(.NOT.XFTTY(LU)) GO TO 100
  105 IFLG=1
C 
C     WRITE FILE
C 
      IF(IFILE.NE.3) GO TO 140
C 
C     OUTPUT FILE 
C 
  110 LIM=-10 
      CALL READF(LDCB,IERR,JBUF,96,IB)
      IF(IERR.LT.0.OR.IB.LE.0) GO TO 130
      CALL XLUEX(100022B,LU,JBUF,IB,ID,ID,ICLS) 
      GO TO 399 
C 
C     GO DO CLASS GETS TO CLEAR CLASS BUFFERS 
C 
  115 CALL ACCGT(LIM,JERR)
      IF(JERR.NE.0) GO TO 110 
      GO TO 400 
C 
  130 CALL RWNDF(LDCB)
C 
C     GO WRITE MESSAGE
C 
  140 IF(LNGTH.GE.0) GO TO 100
      CALL XLUEX(100022B,LU,ICMND(IDX),LNGTH,ID,ID,ICLS)
      GO TO 399 
C 
C     CLEAR CLASS BUFFERS 
C 
  145 CALL ACCGT(LIM,JERR)
      IF(JERR.EQ.0) GO TO 400 
  150 IF(ILU.GE.0) GO TO 300
      GO TO 100 
  200 ISRCH=.TRUE.
      IPBUF(2)=IU 
      IPBUF(7)=IG 
      IF(IU.EQ.2H@ .OR.IG.EQ.2H@ ) GO TO 50 
C 
C     WE ARE FINISED
C 
  300 ISRCH=.FALSE. 
      IF(IFLG.EQ.0) CALL ACERR(-200)
      IF(IFLG.LT.0) CALL ACERR(-221)
      IF(IFILE.EQ.3) CALL CLOSE(LDCB) 
      RETURN
  398 JERR=-222 
      GO TO 400 
  399 JERR=10 
  400 CALL ACERR(JERR)
      RETURN
      END 
      SUBROUTINE ACCGT(LIM,JERR) ,92067-16361 REV.1940 790412 
      LOGICAL  IFBRK
      COMMON /ACOMD/ICLASS
C 
C     SET JERR
C 
      JERR=1
C 
C     DO GETS TO RELEASE CLASS BUFFERS
C 
  120 CALL EXEC(100025B,ICLASS,JBUF,1)
      RETURN
  125 CALL ABREG(IA,IB) 
C 
C     IF ONE REQUEST WAS COMPLETE GO TRY TO GET ANOUTHER
C 
      IF(0.LE.IA) GO TO 120 
C 
C     IF TOTAL OUTSTANDING BUFFERS LESS THAN LIMIT GO DO NEXT WRITE 
C 
      IF(IA.GT.LIM) RETURN
C     ELSE SET LIMIT DOWN AN GO TO SLEEP FOR 0.5 SEC
      LIM=-5
      CALL EXEC(12,0,1,0,-50) 
      IF(.NOT.IFBRK(ID)) GO TO 120
      JERR=0
      RETURN
      END 
                                                                                                                      