FTN,C,Q 
      SUBROUTINE TRACE(IBUF,IFLG,IRBUF,IERFG),09580-16068 REV.2001 79101
     C7 
C-------------------------------------------------------------------
C 
C      RELOC.       09580-16068 
C      SOURCE       09580-18068 
C 
C      C. LEATH     REV.A   770519
C 
C      HP 92425A TEST SYSTEM SOFTWARE IS THE PROPRIETARY
C      MATERIAL OF THE HEWLETT-PACKARD COMPANY.  USE AND
C      DISCLOSURE THEREOF ARE RESTRICTED BY WRITTEN AGREEMENT.
C 
C      (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1977.
C      ALL RIGHTS RESERVED.  NO PART OF THIS PROGRAM
C      MAY BE PHOTOCOPIED, REPRODUCED OR TRANSLATED 
C      TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR
C      WRITTEN CONSENT OF THE HEWLETT-PACKARD COMPANY.
C 
C-------------------------------------------------------------------
      DIMENSION IBUF(40)
      DIMENSION IRBUF(10) 
      INTEGER STATE 
      DATA IAST,IA,IR,IBLNK,IU/ 52B,101B,122B,40B,125B/ 
      DATA ISPC/20000B/,STATE/0/
      DATA IE/105B/ 
      DATA IB/41000B/ 
C 
C  THIS SUBROUTINE IS RESPONSIBLE FOR TRACING THROUGH 
C  THE CONTENTS OF IBUF, AND BASED ON THE CHARACTER IN
C  FIRST COLUMN, AND DETERMINES WHICH PORTION OF TRACE
C  WILL ANALYZE THE STRING.  THIS ROUTINE ALSO USE THE STRING 
C  PROCESSING ROUTINES: 
C     LJUST - LEFT JUSTIFY STRING DELETING LEADING BLANKS 
C     SCAN - PUTS A TOKEN INTO LOCATION DESIGNATED. 
C  THE VALUES RETURNED IN "IFLG"HAVE THE FOLLOWING MEANINGS 
C 
C             FLG = 0   COMMENT (* IN THE FIRST COLUMN) 
C             FLG = 1   RECORD  (R  "  "    "      "  ) 
C              "  = 2   INTEGER (   "  "    "      "  ) 
C              "  = 2   FLOAT 
C              "  = 4   ASCII   (A IN THE FIRST COLUMN) 
C              "  = 5   END OF FILE 
C              "  = 6   UNIT #  (U IN THE FIRST COLUMN) 
C********** 
C    THE VARIBLE 'STATE' IS USED TO CHECK FOR ILLEGAL STATE TRANSITIONS 
C 
C    STATE = 0  INITIAL STATE.  RETURN TO THIS STATE ON CONTEXT ERROR.
C            1  RECORD HEADER RECEIVED. LEGAL ENTRANCES FROM STATES 
C               0 (INIT) AND 3 (DATA RECEIVED). 
C            2  UNIT HEADER RECEIVED.  LEGAL ENTRANCES FROM STATES
C               1 (RECORD) AND 3 (DATA RECEIVED)
C            3  DATA RECEIVED.  LEGAL ENTRANCES FROM STATES 2 (UNIT)
C               AND 3 (DATA RECEIVED).
C            4  END.  LEGAL ENTRANCES FROM 0 (INIT) AND 3 (DATA). 
C 
C    AN ILLEGAL ENTRANCE CAUSES ERROR -16, 'MISSING REC OR UNIT HEADER' 
C********** 
C 
C      COMMENTS   SUBROUTINE # 6 FOR DBUG 
C 
C*******1    EAXMININE THE FIRST WORD OF IBUF (INPUT BUFFER)
C  TO DETERMINE WHAT THE ASCII CHARACTER IS.  THIS CHARACTER
C  IS REPLACED WITH A BLANK AND THE WHOLE IS LEFT JUSTIFIED.
C  THE VARIABLE "ITST" IS EXAMINED TO DETERMINE WHERE TO GO.
C 
C 
C*******2 
C     THIS SECTION PROCESSES AN ASCII STRING. THE NUMBER
C  OF CHARACTERS IS ASCERTAINED, AND THEN THE FIRST 
C  WORD OF IRBUF IS FILLED WITH THE CHARACTER COUNT 
C  AND THE REMAINDER IS FILLED WITH THE STRING STARTING 
C  FROM COLUMN 7. 
C 
C 
C*******4 
C            THIS IS A NEW RECORD HEADER FIELD SO TRANSFER
C    RECORD HEADER INFORMATION (DEVICE TYPE,# OF UNITS, AND 
C    THE NUMBER OF ENTRIES PER UNIT). THE FIRST WORD OF THE 
C    RETURN BUFFER (IRBUF) CONTAINS THE WORD LENGTH 3.
C 
C*******5 
C     THE SUBROUTINE NUMB IS INVOKED TO ANALYZE A NUMERIC FIELD.
C 
      IFLG = 0
      IFL = 0 
      IRBUF(1) = 1
C 
C*******1 COLUMN 1 ANALYSIS 
C 
      ITST = (IAND(IBUF(2),177400B))/400B 
      IBUF(2) = IOR((IAND(IBUF(2),177B)),ISPC)
      IF(ITST.EQ.IA)GO TO 200 
      CALL LJUST(IBUF)
10    CALL DBUG(6,10,ITST)
      CALL DBUG(6,11,STATE) 
      IF(ITST.EQ.IAST) RETURN 
      IF(ITST   .EQ.IE)GO TO 500
      IF(ITST   .EQ.IR)GO TO 300
      IF(ITST.EQ.IBLNK)GO TO 400
      IF(ITST.EQ.IU)GO TO 450 
C 
      IERFG = -9
      RETURN
C 
C 
C*******2 ASCII STRING
C 
200   IF ((STATE.NE.2).AND.(STATE.NE.3)) GOTO 700 
      CALL DBUG(6,200,STATE)
      STATE = 3 
      IFLG = 4
      NIN = 0 
      CALL SCAN(IBUF,IRBUF,NIN,Q) 
      ICHR = INTV(IRBUF,IFL)
      IF(IFL.EQ.-1)GO TO 800
      IF((IAND(ICHR,1)).NE.0)ICHR = ICHR  + 1 
      IRBUF(1) =(ICHR/2)
      LL = IRBUF(1) + 4 
      DO 250 J = 5,LL 
250   IRBUF(J-3) = IBUF(J)
      RETURN
C 
C*******4  NEW RECORD SET 
C 
300   IF ((STATE.NE.0).AND.(STATE.NE.3)) GOTO 700 
      CALL DBUG(6,300,STATE)
      STATE = 1 
      IFLG =1 
      NIN = 0 
      DO 350 J = 2,4
      CALL SCAN(IBUF,IRBUF(J),NIN,Q)
      IRBUF(J) = INTV(IRBUF(J),IFL) 
      IF(IFL.EQ.-1)GO TO 800
350   CONTINUE
      IRBUF(1) = 3
      RETURN
C 
C*******5 NUMERIC FIELD 
C 
400   IF ((STATE.NE.2).AND.(STATE.NE.3)) GOTO 700 
      CALL DBUG(6,400,STATE)
      STATE = 3 
      CALL NUMB(IBUF,IRBUF,IFLG,IERFG)
      RETURN
C 
C********#6 UNIT NUMBER 
C 
450   IF ((STATE.NE.1).AND.(STATE.NE.3)) GOTO 700 
      CALL DBUG(6,450,STATE)
      STATE = 2 
      IFLG = 6
      NIN = 0 
      CALL SCAN(IBUF,IRBUF,NIN,Q) 
      IRBUF(2) = INTV(IRBUF,IFL)
      IF(IFL.EQ.-1.OR.IRBUF(1).EQ.-1)GO TO 800
      IRBUF(1) = 1
      RETURN
C 
C******* CHECK CONTEXT
C 
700   IERFG = -16 
      STATE = 0 
      CALL DBUG(6,700,STATE)
      RETURN
C 
C******* ERRORS -NEGATE IFLG
C 
800   IERFG= -IFLG-6
      CALL DBUG(6,800,IERFG)
      RETURN
C 
C*******8 END OF FILE 
C 
500   IF ((STATE.NE.0).AND.(STATE.NE.3)) GOTO 700 
      CALL DBUG(6,500,STATE)
      IFLG = 5
      RETURN
      END 
      SUBROUTINE KPCNT(IFLG,IECNT,IUCNT,IERFG)
C 
C     SUBROUTINE # 7 FOR DBUG 
C 
      DATA INIT/0/
C 
C 
C     THIS ROUTINE IS RESPONSIBLE FOR SAVING AND COUNTING 
C  THE NUMBER OF ENTRIES FOR EACH RECORD SET THAT 
C  GOES INTO THE BINARY FILE IN SAM.
C     THE PARAMETERS IN THE CALLING SEQUENCE HAVE THE FOLLOWING 
C  MEANINGS:
C       IFLG= GLOBAL VARIABLE WHICH IS USED TO INDICATE 
C         THE TYPE OF FIELD BEING ANALYZED. 
C 
C       IUCNT = UNIT COUNT FOR THE CURRENT RECORD SET BEING 
C           CRACKED TO BINARY.
C           THIS VARIABLE IS USED FOR ERROR CHECKING, TO
C           VERIFY THAT THE NUMBER OF UNITS DESIGNATED
C           IN THE RECORD SET ACTUALLY CONFORM TO THE 
C           NUMBER STORED IN THE TABLE FOR A PARTICULAR 
C           RECORD SET. 
C 
C     IERFG = ERROR FLG 
C     WHERE:
C           -10 = UNIT COUNT > UNIT DESIGNATION IN CONFIG. TABLE
C           -11 =   "    "   <  "       "        "   "       "
C           -13 = # ENTRIES NOT CONSISTENT WITH CONFIG. TABLE 
C 
C 
C*** #1   DETERMINE WHERE TO BRANCH 
C 
10    CALL DBUG(7,10,IFLG)
C     THE FIRST TIME THRU HERE MUST BE FOR A RECORD.
      IF (INIT.EQ.0 .AND. IFLG.NE.1) IERFG = -16
      IF(IFLG.EQ.1)GO TO 100
      IF(IFLG.EQ.6)GO TO 200
      IF(IFLG.EQ.5)GO TO 150
      IECTR = IECTR + 1 
      RETURN
C 
C*** #2 INITIALIZE POINTERS (FIRST TIME THRU) 
C 
100   IF(INIT.NE.0)GO TO 150
      INIT =  1 
      IUCHK = 0 
      IECHK = 0 
      IECTR = 0 
      IUCTR = 0 
C 
C*******# 3 ERROR CHECKS FOR NEW RECORD.
C 
150   CONTINUE
C 
C     CHECK THE ENTRY COUNT OF THE LAST UNIT OF THE LAST RECORD.
      IF (IECHK.NE.IECTR)IERFG= -13 
C 
C     CHECK THE UNIT COUNT OF THE LAST RECORD.
C     IS UNIT COUNT > UNIT DESIG.?
      IF(IUCTR.GT.IUCHK)IERFG = -10 
C     IS UNIT COUNT < UNIT DESIG.?
      IF(IUCTR.LT.IUCHK)IERFG = -11 
C 
C     SET THE UNIT AND ENTRY CHECK VALUES OF THE NEW RECORD.
      IUCHK = IUCNT 
      IECHK = IECNT 
C     SET THE COUNTS OF ENTRIES AND UNITS FOR THIS RECORD TO ZERO.
      IUCTR = 0 
      IECTR = 0 
C     REJECT ILLEGAL VALUES OF UNITS, ENTRIES.
      IF (IUCNT.LE.0.OR.IUCNT.GT.15)IERFG = -7
      IF (IECNT.LE.0)IERFG = -7 
      RETURN
C 
C*** #5 UNIT FLAG 
C 
200   CONTINUE
C     IF THIS IS FIRST UNIT LINE FOR THIS RECORD, 
C      THEN THE ENTRY COUNT MUST BE ZERO. 
      IF (IUCTR.EQ.0 .AND. IECTR.NE.0) IERFG = -16
C     CHECK LAST ENTRY COUNT OF LAST UNIT (IF ANY) OF THIS RECORD.
      IF (IECHK.NE.IECTR .AND. IUCTR.GT.0) IERFG = -13
C     COUNT THE NEW UNIT. 
      IUCTR =   IUCTR + 1 
C     SET THE COUNT OF ENTRIES FOR THIS NEW UNIT TO ZERO. 
      IECTR = 0 
      RETURN
      END 
      SUBROUTINE SAM(I,IFLG,IC,ICLAS,ICLTB,IBC,IDPTR) 
C 
C     SUBROUTINE # 8 FOR DBUG 
C 
      DIMENSION ICLTB(30),IBC(130)
      DIMENSION IREG(2) 
C 
C     THIS IS THE ROUTINE THAT HANDLES CLASS I/O
C  FOR THE CONFIGURATION TABLES.
C 
C************************ 
C************************ 
C***#1 CLASS READ WRITE - A NEGATIVE ICLAS # MEANS
C      NO RECORD SET HEADER IN THE BUFFER PERTAINING
C      TO THAT PARTICULAR CLASS NUMBER. 
C     IBC(2) WILL CONTAIN IDPTR (BUFFER LENGTH) 
C 
C     BIT 15 OF ICLAS IS SET TO 1 (NO WAIT BIT) -THIS IS
C     SO THAT IS CASE THERE IS NO MEMORY AVAILABLE OR 
C     NO CLASS NUMBER ALLOC WILL NOT GO INTO A WAIT STATE 
C     AND WE CAN EMIT MESSAGES TO THE OPERATOR. 
C 
C 
C 
10    CALL DBUG(8,10,ICLAS) 
      II = 1
      IF(ICLAS.LT.0)ICLAS = -ICLAS
      IF(IFLG.EQ.5)GO TO 100
      IBC(2) = IDPTR
      ICLAS = 100000B 
      CALL EXEC(20,0,IBC,IDPTR,IDMY,JDMY,ICLAS) 
      CALL ABREG(IREG,IREG(2))
      IF(IREG.LT.0)GO TO 800
      ICLAS = IAND(ICLAS,77777B)
      IF(IC.NE.1)GO TO 50 
      ISTN = ISN(DUMMY) 
      CALL STCLN(ISTN,ICLAS)
50    IF(ICLTB(IC).LT.0)ICLAS = -ICLAS
      ICLTB(IC) = ICLAS 
      RETURN
C 
C*** #2 CLASS GET - BIT 13 IS ET TO SAVE CLASS #, WITH
C        BIT 14 = 0 TO RELEASE BUFFER.
C 
C 
100   ICL = IOR(ICLAS,20000B) 
      IREG = EXEC(21,ICL,IBC,130) 
      IF(ICLTB( I ).LT.0)GO TO 150
C 
C*** #3 PUT CLASS # FOR NEXT BUFFER INTO FIRST WORD OF IBC
C 
150   IF(I.EQ.IC)GO TO 300
      CALL STORE(ICLTB(I+1),IBC,ICLAS,IERR) 
      IF (IERR.EQ.-1) GOTO 800
      RETURN
C 
300   CALL STORE(ICLTB(1),IBC,ICLAS,IERR) 
      IF (IERR.EQ.-1) GOTO 800
      RETURN
C 
C     PURGE TABLE, REPORT ERROR (NO SAM/NO CLASS #), TERMINATE
C 
800   CALL DALOC(ISTN)
      CALL ALERR(17,ISTN) 
      CALL PRTN(-1) 
      CALL EXEC(6)
      END 
      SUBROUTINE DBUG(ISUB,LINE,IVALU)
      DATA INIT/0/
C 
C   THIS ROUTINE IS USED TO DISPLAY DE-BUG INFORMATION WHEN THE OPERATOR
C   HAS ENTERED "ZX" (55130B) AFTER THE ERROR OUTPUT PARAMETER IN THE 
C   SCHEDULING STRING, EG.  :RU,ALLOC,&CONFG::80,6,55130B 
C 
C   EACH ROUTINE IN ALLOC HAS AN IDENTIFING NUMBER: 
C        ALLOC  =  1
C        TRFER  =  2
C        DALOC  =  3
C        ERCNT  =  4
C        STORE  =  5
C        TRACE  =  6
C        KPCNT  =  7
C        SAM    =  8
C        NUMB   =  9
C        FLCNT  =  10  DELETED FROM &TRACE REV. 2001
C        CNTR   =  11 
C        ALERR  =  12 
C 
C   THIS ROUTINE ALWAYS PRINTS ON LU 6.  IT ALSO PRINTS THE VALUE 
C   IN DECIMAL, OCTAL, AND ASCII. 
C 
      IF (ISUB-55130B) 10,300,10
10    IF (INIT) 100,200 
100   WRITE(6,110) ISUB,LINE,IVALU,IVALU,IVALU
110   FORMAT(" SUBR "I2"  LINE "I4"  DEC "I5"  OCT "K6"  ASC "A2) 
200   RETURN
C 
300   INIT = -1 
      RETURN
      END 
      END$