FTN4,L
      PROGRAM TRACE(19,90),91780-16016 REV 1840 780725  
C 
C  **************************************************************** 
C 
C     NAME:         TRACE 
C     SOURCE:       91780-18016 
C     RELOC:        91780-16016 (PART OF) 
C     PGMR:         D. BOLIERE  ( 07/24/78 )
C 
C  **************************************************************** 
C  * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978.  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     TRACE IMPLEMENTS A DIAGNOSTIC CAPABILITY FOR RJE/1000.
C 
C     :RU,TRACE [,LU OR NAME:SC:CRN]
C 
C 
      INTEGER AREG,BREG,IREG(2),IBUF(128),IDCB(144) 
      EQUIVALENCE (AREG,REG,IREG(1)),(BREG,IREG(2)) 
C 
C INITIALIZE THE CONSOLE PTR AND THE OUTPUT DEVICE TO MAG TAPE
C 
      LUC=LOGLU(ISES) 
      LUO=8 
C 
C FETCH PARAMETER STRING.  IF NONE, JUST USE DEFAULT DEVICE 
C 
      CALL GETST(IBUF(11),-80,LOG)
      IF(LOG.EQ.0) GO TO 40 
C 
C FETCH FIRST PARAMETER. IF NULL, USE DEFAULT.
C                           +NUM, SET LU TO IT
C                           ELSE, TREAT AS FILE NAMR
      ISTRC=1 
      IF(NAMR(IBUF,IBUF(11),LOG,ISTRC)) 40,20 
20    IF(IBUF(4).EQ.0) GO TO 40 
      IF(IBUF(4).NE.1) GO TO 30 
      IF(IBUF(1).GE.0) LUO=IBUF(1)
      GO TO 40
C 
C MUST BE A FILE NAME! TRY TO OPEN. 
C 
30    LUO=-1
      CALL OPEN(IDCB,IERR,IBUF,0,IBUF(5),IBUF(6)) 
      IF(IERR.GE.0) GO TO 50
      IF(IERR.EQ.-6) GO TO 35 
      WRITE(LUC,910) IERR 
      GO TO 99
C 
C FILE NON-EXISTENT! TRY TO CREATE. 
C 
35    CALL CREAT(IDCB,IERR,IBUF,24,3,IBUF(5),IBUF(6)) 
      IF(IERR.GE.0) GO TO 50
      WRITE(LUC,920) IERR 
      GO TO 99
C 
C MUST BE A LU! TRY TO LOCK.
C 
40    IF(LUO.LE.0) GO TO 50 
      REG=LURQ(1,LUO,1) 
      IF(AREG.EQ.0) GO TO 50
      WRITE(LUC,930)
      GO TO 99
C 
C INITIALZE SUBROUTINE BY SETTING OVERRUN COUNT TO POSITIVE.
C 
50    IOVER=0 
C 
C REQUEST SUBROUTINE TO FILL BUFFER WITH NEXT BLOCK OF DATA.
C ICNT=LENGTH OF BLOCK UPON RETURN. IOVER=+ IF LAST BLOCK.
C 
60    CALL RETRV(IBUF,ICNT,IOVER) 
      IF(ICNT.EQ.0) GO TO 70
      IF(LUO.GE.0) GO TO 65 
C 
C OUTPUT DEVICE= FILE!
C 
      CALL WRITF(IDCB,IERR,IBUF,ICNT) 
      IF(IERR.GE.0) GO TO 70
      WRITE(LUC,940) IERR 
      GO TO 80
C 
C OUTPUT DEVICE= LU!
C 
65    IF(LUO.GT.0) CALL REIO(2,LUO,IBUF,ICNT) 
C 
C IF DONE, REPORT OVERRUN COUNT.
C 
70    IF(IOVER.LT.0) GO TO 60 
      WRITE(LUC,950)IOVER 
C 
C IF OUTPUT TO LU, WRITE EOF
C 
      IF(LUO.LE.0) GO TO 80 
      CALL EXEC(3,100B+LUO) 
C 
C IF OUTPUT TO FILE, CLOSE IT.
C 
80    IF(LUO.LT.0) CALL CLOSE(IDCB) 
90    CONTINUE
910   FORMAT(" TRACE ABORTED WITH FILE OPEN ERROR ",I4) 
920   FORMAT(" TRACE ABORTED WITH FILE CREATE ERROR ",I4) 
930   FORMAT(" TRACE ABORTED DUE TO LOGICAL UNIT LOCK FAILURE") 
940   FORMAT(" TRACE ABORTED DUE TO FILE WRITE ERROR ",I4)
950   FORMAT(" TRACE COMPLETED WITH",I4," OVERRUN ERRORS")
99    END 
      END$
                                                                                      