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