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-18410 C C RELOCATABLE PART NUMBER : 92067-16361 C C PROGRAMER(S) : J.M.N. C C C C ACREI - ROUTINE TO READ A RESPONSE FROM THE INPUT DEVICE/FILE C C CALLING SEQUENCE: CALL ACREI(IBUF,IERR) C WHERE C IBUF = BUFFER INTO WHICH TO READ C IERR = ACERR RETURN WORD C C SUBROUTINE ACREI(IBUF,IERR) ,92067-16361 REV.1940 790309 DIMENSION LU(2) COMMON /ACOM3/LIST(10),LDCB(144),LLIST,LLDCB(144),ITTY,ITDCB(144) COMMON /ACOMC/IECHO,LULOG,ITLOG,KECHO,IERFG DIMENSION IBUF(40),IPBUF(11) DATA IPNTR / 17 / DATA LU /0,0 / IERR=0 C C RESET ERROR FLAG C C C READING FROM? C C MEMORY (LDCB) 50 IF(ITTY.LE.0) GO TO 400 C FILE:SC:CR IF(ITTY.GT.255) GO TO 300 C C LU C LU(1)=IOR(ITTY,100000B) LU(2)=KECHO CALL XLUEX(1,LU,IBUF,-80) CALL ABREG(IA,ITLOG) IB=(ITLOG+1)/2 C C ECHO IF REQUIRED C 100 IF(IB.NE.0) GO TO 120 CALL ACWRI(2HTR,1) GO TO 130 120 CALL ACWRI(IBUF,-IB) C C FILL END OF BUFFER WITH BLANKS C 130 IF(IB.GE.40) RETURN DO 200 J=IB+1,40 200 IBUF(J)=2H C C CHECK FOR "/TR" OR CONTROL "D" C ISTRC=1 IF(IB.EQ.0) GO TO 250 CALL NAMR(IPBUF,IBUF,80,ISTRC) IF(IPBUF(1).NE.2H/T.OR.MBYTE(IPBUF(2)).NE.122B) GO TO 275 250 IERR=0 CALL ACXFR(IBUF,ISTRC,IERR) IF(IERR.EQ.0) GO TO 280 IF(IERR.EQ.10) IERR=0 CALL ACERR(IERR) GO TO 280 C C TEST FOR "/HE" C 275 IF(IPBUF(1).NE.2H/H.OR.MBYTE(IPBUF(2)).NE.105B) RETURN IERFG=-1 CALL ACHLP (IBUF,ISTRC) IERFG=0 280 CALL ACPRM(IBUF,-1) GO TO 50 C C READ FROM FILE C 300 CALL READF(ITDCB,IERR,IBUF,40,IB) IF(IERR.LT.0.OR.IB.LT.0) IB=0 GO TO 700 C C READ FROM MEMORY (LDCB) FOR INITIALIZATION C 400 DO 500 IB=1,41 IBUF(IB)=LDCB(IPNTR) IPNTR=IPNTR+1 IF(IBUF(IB).EQ.0) GO TO 600 500 CONTINUE C C ADJUST IB C 600 IB=IB-1 700 ITLOG=2*IB GO TO 100 END