FTN 
      SUBROUTINE GTPRC(ITEST,ISIZE,IERR),92069-16061 REV.1912 781206
      INTEGER ITEST(3),IERR,ISIZE 
C 
C 
C*****************************************************************
C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED 
C NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR
C TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR
C WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. 
C****************************************************************** 
C 
C 
C     SOURCE:    92069-18093
C     RELOC:     92069-16060
C 
C 
C****************************************************************:
C 
C 
C 
C 
C 
C ABSTRACT: 
C 
C THIS SUBROUTINE GETS THE NAME OF A PROCEDURE FILE IF ONE
C IS DECLARED AND OPENS IT AND SCANS THE PROCEDURE FILE 
C FOR THE 6 CHARACTER KEYWORD IN ITEST. 
C 
C CALLING SEQUENCE: 
C 
C       CALL GTPRC(ITEST,IERR)
C 
C       WHERE:
C 
C       ITEST 
C       IS A KEYWORD NO LONGER THAN SIX CHARACTERS
C 
C       ISIZE 
C       IS THE SIZE IN BYTES OF THE KEYWORD 
C 
C       IERR
C       IS AN ERROR INDICATOR, 0 IMPLIES NO ERROR 
C                              -1 IMPLIES ERROR 
C 
C ON EXIT:
C 
C      IDCB IS OPENED TO THE PROCEDURE FILE 
C      IERR CONTAINS AN ERROR CODE
C        WHEN THERE IS AN ERROR THE PROPER ERROR MESSAGE
C        IS WRITTEN TO THE LIST DEVICE BY GTPRC 
C      IPFLAG IS SET TO 3 WHEN THERE IS A SUCESSFUL OPEN
C        OTHERWISE IPFLAG IS SET TO 0 
C 
C 
C 
      INTEGER ERR14(12),ERR15(8),ERR17(11)
C$$$$$$$$$$$$$$$$$$$ NOVEMBER 3,1978   $$$$$$$$$$$$$$$$$$$$$
      INTEGER INLU,ITTY,ILP,IDCB,JDCB,XEQ 
      INTEGER DBNAM,DBLEV,DSNAM,DINAM,SELECT,SNAM 
      INTEGER DSNUM,DINUM,PARM,LPARM,ECHO,QSERR 
      INTEGER IMA,IB,IBSZ,SECNO,IEND,ISCAN
      LOGICAL BREAK 
      INTEGER IPFLAG,IOFLAG,RMOTE 
      LOGICAL BATCH,XQBCH 
      INTEGER PAGCNT,LNCNT
      INTEGER PAGLEN,COLLIM 
      REAL    RRCNT 
      REAL    SELT,RSEC 
      INTEGER IPTR
      REAL    RCOUNT
      INTEGER S,R3,TRKNM,IDILU
      INTEGER R6
      REAL    ATOTAL
      INTEGER LIST,L,T,U
      INTEGER LEVSTR,LEVLEN 
      INTEGER IBUFF 
      INTEGER SS(7,100) 
C 
      COMMON INLU(145),ITTY(145),ILP(145),IDCB(145),JDCB(144),XEQ(145)
      COMMON DBNAM(10),DBLEV(3),DSNAM(3),DINAM(3),SELECT(6),SNAM(3) 
      COMMON DSNUM,DINUM,PARM(40),LPARM,ECHO,QSERR
      COMMON IMA(37),IB(896),IBSZ,SECNO,IEND,ISCAN
      COMMON BREAK
      COMMON IPFLAG,IOFLAG,RMOTE
      COMMON BATCH,XQBCH
      COMMON PAGCNT,LNCNT 
      COMMON PAGLEN,COLLIM
      COMMON RRCNT
      COMMON SELT(64),RSEC
      COMMON IPTR 
      COMMON RCOUNT 
      COMMON S(15,50),R3,TRKNM,IDILU
      COMMON R6 
      COMMON ATOTAL(6,5)
      COMMON LIST(101,6),L(7),T(5),U(7,5) 
      COMMON LEVSTR(66,5),LEVLEN(5) 
      COMMON IBUFF(2048)
C 
      EQUIVALENCE (S,SS)
C$$$$$$$$$$$$$$$$$$$ NOVEMBER 3,1978   $$$$$$$$$$$$$$$$$$$$$
      DATA ERR14/2H I,2HNV,2HAL,2HID,2H P,2HRO,2HCE,2HDU,2HRE,
     &2H N,2HAM,2HE / 
      DATA ERR15/2H X,2HXX,2HXX,2HX ,2HEX,2HPE,2HCT,2HED/ 
      DATA ERR17/2H P,2HRO,2HCE,2HDU,2HRE,2H N,2HOT,2H D, 
     &2HEF,2HIN,2HED/ 
C 
C 
C 
C 
C BEGIN 
C 
C 
C GET THE PROCEDURE 
C 
      IERR = 0
      IPFLAG = 3
      CALL LSCAN(IB,I,J,K)
      IF(K .EQ. 2) GOTO 20
C 
C ERROR - INVALID PROCEDURE NAME
C 
      CALL ERIO(2,ITTY,ERR14,12)
      GOTO 70 
20    CONTINUE
      IPTR = I
      CALL GTPRM(IMA,IB,J,IPTR,IDCB,IDCB(2),.FALSE.,IERR2)
      IF(IDCB .GE. 0) GOTO 25 
      IF(IERR2 .NE. -6) GOTO 30 
C 
C OUTPUT "PROCEDURE NOT DEFINED"
C 
25    CONTINUE
      CALL ERIO(2,ITTY,ERR17,11)
      GOTO 70 
C 
C MAKE SURE THERE WERE NOT FMP ERRORS 
C 
30    CONTINUE
      IF(IERR2 .GE. 0) GOTO 50
      CALL FMERR(IERR2,ITTY)
      GOTO 70 
C 
C SCAN ACROSS TO THE KEYWORD
C 
50    CONTINUE
      CALL INPUT
      CALL LSCAN(IB,I,J,K)
      IF(J-I+1 .NE. ISIZE) GOTO 60
      IF(JSCOM (ITEST,1,ISIZE,IB,I,IERR2) .EQ. 0) GOTO 80 
C 
C ERROR - KEYWORD NOT FOUND 
C 
60    CONTINUE
      CALL SFILL(ERR15,2,7,40B) 
      IF(ISIZE .GT. 6) ISIZE = 6
      CALL SMOVE(ITEST,1,ISIZE,ERR15,2) 
      CALL ERIO(2,ITTY,ERR15,8) 
      CALL ECLOS(IDCB(2)) 
70    CONTINUE
      IPFLAG = 0
      IERR = -1 
80    CONTINUE
      RETURN
      END 
                                                                                                                                                                                                                                                        