FTN,Q,C 
      PROGRAM ALLOC (3,99),09580-16067 REV.2026 800415
C-------------------------------------------------------------------
C 
C      RELOC.       09580-16067 
C      SOURCE       09580-18067 
C 
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 1979.
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-------------------------------------------------------------------
C 
C      TO BUILD ALLOC, THE FOLLOWING ARE REQUIRED:
C 
C      ALLOC        09580-16067 
C      TRACE        09580-16068 
C      NUMB         09580-16072 
C      ALERR        09580-16116 
C 
C------------------------------------------------------------------ 
      DIMENSION NAME(20) ,IDCB(144),IBUF(42)
      DIMENSION IREG(2) 
      DIMENSION NAME1(10) 
      DIMENSION IRBUF(82) 
      DIMENSION ICLTB(30) 
      EQUIVALENCE(IREG,REG) 
      DATA IBLNK/20040B/
      DATA IOUT/1/
      DATA IOPTN/0/ 
C 
C******************************************************** 
C********COMMENTS***** ROUTINE # 1 FOR DBUG ************* 
C******************************************************** 
C*************************
C 
C***** #1 
C     USE EXEC 14 TO RETRIEVE PARAMETER STRING ASSOCIATED 
C  WITH ...... RU,ALLOC,FILNAM,[IOUT] 
C  WHERE: FILNAM IS THE ASCII CONFIGURATION TABLE (NAMR)
C         IOUT OPTIONAL IS OUTPUT DEVICE FOR ERORRS 
C 
C****** #2
C      CHECK TO TO SEE IF ANY SAM HAS ALREADY BEEN ALLOCATED
C FOR THE PARTICULAR STATION AND IF SO DEALLOCATE IT
C AND PUT OUT WARNING MESSAGE.
C 
C******** #3
C     OPEN UP THE DEVICE TABLE FILE WITH A FILE MANAGER 
C CALL AND IF THE FILE DOES NOT EXIST OR IT IS MISNAMED 
C INFORM THE OPERATOR.
C     STATEMENTS 100 AND 200 FILLS THE BUFFER USED FOR
C READING RECORDS WITH BLANKS.
C 
C******** #4
C     READ A RECORD, AND CHECK FOR EOF MARK (LEN = -#)
C OR FILE OVERFLOW (LEN = IL).
C THE SUBROUTINE TRACE IS CALLED TO DETERMINE THE TYPE
C OF FIELD AND TO PARSE THE CHARACTERS INTO IRBUF. THE
C VARIABLE "IFLG" IS SET BY TRACE WITH THE CODE INDICATING
C THE TYPE OF FIELD ENCOUNTERED.
C 
C******** #5
C     SUBROUTINE TRFER (TRANSFER) IS INVOKED TO PERFORM THE 
C TRANSFERRING OF THE ASCII DATA FROM "IRBUF" TO THE CLASS I/O
C BUFFERS.
C     AT STATEMENT 500 AFTER THE CALL TO TRFER THE FILE IS
C  CLOSED AND THE NUMBER OF RECORD SETS REPORTED. 
C***************************************************************/ 
C 
C***** #1 SET UP STATION AND DEFAULTS, THEN RETRIEVE PARAMETER STRING 
      IER = 2 
      ISTN = ISN(DUMY)
      IF (ISTN.LE.0) GOTO 800 
      IOUT = ISTN 
C 
      CALL EXEC(14,1,NAME(2),19)
      CALL ABREG (IREG,IREG(2)) 
      NCHR = 1
C 
C     NAME(1) = NUMBER OF CHARACTERS. WE LOOP THREE TIMES 
C   IN CALLING NAMR TO GET TO FILE NAME.
C 
      NAME(1) = IREG(2)*2 
      DO 20 I=1,3 
20    CALL NAMR(NAME1,NAME(2),NAME,NCHR)
C 
C     NOW SEE IF A FILE NAME HAS BEEN ENTERED IF NOT REQUEST ONE
C 
      IF(IAND(NAME1(4),3).EQ.3) GOTO 40 
30    WRITE(ISTN,31)
31    FORMAT(2X,"   ENTER CONFIGURATION FILE NAME _") 
      READ(ISTN,35) (NAME(J),J=2,11)
35    FORMAT(10A2)
      NCHR = 1
      NAME = 20 
      CALL NAMR(NAME1,NAME(2),NAME,NCHR)
C 
C 
40    ISECU = NAME1(5)
      ICR = NAME1(6)
      IERFG = 0 
      LINE = 0
C 
C************#2 CHECK FOR ALLOCATED SAM 
C 
      CALL RTCLN(ISTN,IRBUF)
      IF(IRBUF.EQ.0) GOTO 50
      CALL DALOC(ISTN)
C 
C*********#3 OPEN CNFG FILE 
C 
50    IER = 4 
      CALL OPEN(IDCB,IERR,NAME1,IOPTN,ISECU,ICR)
      CALL NAMR(NAME1,NAME(2),NAME,NCHR)
      IF(NAME1(4).EQ.1)IOUT = NAME1 
      CALL NAMR(NAME1,NAME(2),NAME,NCHR)
      CALL DBUG(NAME1(1),0,0) 
      IF(IERR.LT.0) GOTO 800
C 
C********#4 CLEAR BUFFER AND READ A LINE FROM FILE AND PARSE STRING 
C 
100   DO 200 I=1,40 
200   IBUF(I) = IBLNK 
      IER = 5 
      CALL READF(IDCB,IERR,IBUF(2),41,LEN)
      LINE = LINE + 1 
      CALL DBUG(1,200,LINE) 
      IF(LEN.LT.0) GOTO 500 
      IBUF(1) = LEN * 2 
      IF(LEN.EQ.41)GO TO 800
250   CALL TRACE(IBUF,IFLG,IRBUF,IERFG) 
      CALL DBUG(1,250,IFLG) 
      CALL DBUG(1,250,IERFG)
C 
C******* #5 CHECK IFLG TO SEE WHERE TO BRANCH 
C 
      IF (IERFG.LT.0) GOTO 300
      IF (IFLG.EQ.0)  GOTO 100
      IF (IFLG.EQ.5)  GOTO 500
C 
C********* #6 INVOKE TRFER TO TRANSFER DATA 
C 
      CALL TRFER(IFLG,IRBUF,ICLTB,IERFG)
      CALL DBUG(1,299,IERFG)
300   CALL ERCNT(LINE,IERFG,ISTN,IOUT)
      GOTO 100
C 
C********#7 END OF FILE TRANSFER LAST DATA AND CLOSE
C 
500   IFLG = 5
      CALL TRFER(IFLG,IRBUF,ICLTB,IERFG)
      CALL CLOSE(IDCB,IERR) 
      CALL ERCNT(LINE,IFLG,ISTN,IOUT) 
      CALL PRTN(0)
      CALL EXEC(6,0)
800   CALL DALOC(ISTN)
      CALL ALERR(IER,IOUT,LINE) 
      CALL PRTN(-1) 
      CALL EXEC(6,0)
      END 
      SUBROUTINE TRFER(IFLG,IRBUF,ICLTB,IERFG)
C 
C 
      DIMENSION IRBUF(82),IDBUF(130)
      DIMENSION ICLTB(10),IREG(2) 
      EQUIVALENCE (IREG,REG)
      DATA INIT/0/
      DATA IVF/10/
      DATA IX/2HXX/ 
C 
C 
C*******************************************************
C**********      COMMENTS   SUBROUTINE # 2 FOR DBUG ****
C*******************************************************
C 
C******** #1
C     INITIALIZE VARIABLES THE FIRST TIME THRU (WHEN
C INIT = 0). IDPTR: THIS IS THE POINTER FOR THE BUFFER
C WHERE THE BINARY DEVICE DATA GOES.
C            IC: THIS IS THE INDEX FOR THE TABLE (ICLTB) WHERE
C THE POINTERS FOR THE CLASS NUMBERS ARE STORED.
C     IUCNT KEEPS TRACK OF THE NUMBER OF UNITS FOR EACH IDTN
C 
C******** #2
C 
C     IFLG IS CHECKED TO SEE IF IT INDICATES A NEW RECORD (IFLG 
C =1),END OF FILE (IFLG = 5), OR A NEW UNIT (IFLG=6). 
C 
C********** #3
C 
C TRANSFER DATA FROM IRBUF TO IDBUF USING THE FIRST WORD
C  OF IRBUF TO INDICATE HOW MANY WORDS TO TRANSFER. 
C 
C 
C********** #4
C 
C     NOTIFY SUBROUTINE KPCNT THAT A NEW UNIT NUMBER HAS
C  BEEN ENCOUNTERED. KPCNT WILL DO SOME ERROR CHECKING
C  AND CHANGE IELG TO NEGATIVE NUMBER IF AN ERROR 
C  OCCURS.
C     SUBROUTINE "CNTR" LOOKS FOR DUPLICATE UNIT AND DEVICE TYPE
C   NUMBERS.
C 
C 
C********* #5 
C 
C     A NEW RECORD SET (IFLG =1),CHECK UNIT COUNT AND SET ICLTB 
C  ICLTB(IC) POSITIVE TO INDICATE THAT A RECORD SET HEADER
C  DOES EXIST IN THE PRESENT BUFFER.
C 
C********* #6 
C 
C     OUTPUT FILLED BUFFER TO SAM AND SET THE NEXT ICLTB(IC)
C  NEGATIVE, AND RESET IDPTR TO POINT TO THIRD WORD OF IDBUF. 
C 
C********* #7 
C 
C     DAS EST ALLES (FINISHED) SO DO CLEANUP. TRANSFER
C  THE REMAINING BUFFER TO SAM. 
C 
C**************************************************************** 
C 
C********** #1
C 
      IF(INIT.NE.0)GO TO 50 
      IDPTR = 2 
      IUCNT = 0 
      IECNT = 0 
      I = 0 
      IC = 1
      ICLTB(IC) = -1
      INIT = 1
C 
C********* #2  DETERMINE WHERE TO BRANCH
C 
50    CALL DBUG(2,50,IFLG)
      IF(IFLG.EQ.1)GO TO 200
      IF(IFLG.EQ.5)GO TO 500
      IF(IFLG.EQ.6)GO TO 150
C 
C********* #3 STORE DATA
C 
100   K =2
      IWCTR =  IRBUF(1)+1 
110   DO 120 JJ = K,IWCTR 
      IDPTR = IDPTR + 1 
      IF(IDPTR.GT.130)GO TO 300 
      IF(IFLG.EQ.1.OR.IFLG.EQ.6)GO TO 120 
      CALL KPCNT(IFLG,IECNT,IUCNT,IERFG)
120   IDBUF(IDPTR) = IRBUF(JJ)
      RETURN
C 
C********* #4  NEW UNIT NUMBER
C 
150   CALL KPCNT(IFLG,IECNT,IUCNT,IERFG)
      CALL CNTR(IRBUF(2),IERFG,1) 
      GO TO 100 
C 
C 
C********** #5 NEW RECORD SET HEADER
C 
200   IUCNT = IRBUF(3)
      IECNT = IRBUF(4)
      CALL CNTR(IRBUF(2),IERFG,2) 
      CALL KPCNT(IFLG,IECNT,IUCNT,IERFG)
      IF(ICLTB(IC).LT.0)ICLTB(IC) = -ICLTB(IC)
      GO TO 100 
C 
C*********6  OUTPUT FILLED BUFFER TO SAM
C 
300   ICLAS = 0 
      K = JJ
      IDPTR = 2 
      CALL SAM(I,IFLG,IC,ICLAS,ICLTB,IDBUF,130) 
      IC = IC + 1 
      ICLTB(IC) = -1
      GO TO 110 
C 
C 
C******** #7 END OF FILE -TRANSFER LAST BUFFER TO SAM 
C 
500   CALL KPCNT(IFLG ,IECNT,IUCNT,IERFG) 
      I = 0 
      ICLAS = 0 
      IDBUF(IDPTR+1) = IX 
      CALL SAM(I,INIT,IC,ICLAS,ICLTB,IDBUF,IDPTR+1) 
      DO 520 I = 1,IC 
      ICLAS = ICLTB(I)
      CALL SAM(I,IFLG,IC,ICLAS,ICLTB,IDBUF,IDPTR) 
520   CONTINUE
      RETURN
      END 
      SUBROUTINE DALOC(ISTN)
C 
C     SUBROUTINE # 3 FOR DBUG 
C 
      DIMENSION IBUF(2),IREG(2) 
      EQUIVALENCE(REG,IREG) 
C 
C***********
C     THIS PROGRAM IS RESPONSIBLE FOR DEALLOCATING
C  CLASS BUFFERS. IT OPERATES BY FIRST RETRIEVING 
C  THE CLASS NUMBER OF THE FIRST BUFFER FROM
C  THE CORE RESIDENT SVTBL AND USING THE SUB- 
C  SEQUENT LAST WORD OF EACH BUFFER TO DEALLOCATE 
C  EACH SUCCEEDING BUFFER.
C     AN ERROR MESSAGE IS EMITTED IF FOR SOME 
C  STRANGE REASON A BUFFER BCOMES POLLUTED AND
C  AND THE IMPROPER CLASS NUMBER IS USED. 
C 
C*** #1 GET THE STATION NUMBER AND FIRST CLASS# 
C 
10    CALL DBUG(3,10,ISTN)
      CALL RTCLN(ISTN,IBUF(1))
      IFCLS = IBUF(1) 
      IF(IBUF(1).EQ.0)RETURN
C 
C*** #2 START DEALLOCATING (BITS 13&14 = 0) 
C 
100   ICL = IAND(IBUF(1),17777B)
      CALL DBUG(3,100,ICL)
      CALL EXEC(21,ICL,IBUF,2)
      IF(IBUF(1).NE.IFCLS)GO TO 100 
      IF(IBUF(1).EQ.0)GO TO 200 
      ICL = 0 
      CALL STCLN(ISTN,ICL)
      RETURN
C 
C*** #3 ERROR MESSAGE, CORRUPT TABLE IN SAM 
C 
200   CALL ALERR(6,ISTN)
      RETURN
      END 
      SUBROUTINE ERCNT(LINE,IFLAG,ISTN,IOUT)
C 
C 
C*********************************************************************
C*
C*       **** ERROR COUNT ****  SUBROUTINE # 4 FOR DBUG 
C*
C*       COUNTS NUMBER OF ERRORS
C*
C*       IF ANY ERRORS ARE FOUND DE-ALLOCATES SPACE USED TO STORE 
C*       CONFIGURATION TABLE
C*
C*       PUTS ERROR CODES AND LINE NUMBERS IN ERBUF 
C*
C*********************************************************************
      INTEGER ERBUF(64,2),ERPTR 
      DATA LASTL/0/ 
C 
C*       CHECK FOR END OF FILE
C 
5     CALL DBUG(4,5,IFLAG)
      CALL DBUG(4,5,LINE) 
      IF(IFLAG.EQ.5) GO TO 10 
C 
C*       CHECK TO SEE IF THERE IS AN ERROR
C 
      IF(IFLAG.GE.0) RETURN 
C 
C*       THERE IS AN ERROR
C*
C*       CHECK IF AN ERROR ALREADY FOUND ON THAT LINE 
C 
      IF(IFLAG.EQ.LASTL) RETURN 
C 
C*         INCREMENT ERROR COUNTER
C*         PUT CODEWORD IN ERBUF
C 
      ERPTR=ERPTR+1 
15    CALL DBUG(4,15,ERPTR) 
      ERBUF(ERPTR,1) = -IFLAG 
      ERBUF(ERPTR,2) = LINE 
C 
C*         SET IFLAG EQUAL TO ZERO
C 
      IFLAG=0 
C 
C*       IF SIXTY-FOUR ERRORS OR ANY ERRORS AT END OF FILE- 
C*         DE-ALLOCATION OF BUFFERS CONTAINING CONFIGUARATION TABLES
C*         STORE ERBUF USING CLASS I/O
C 
      IF(ERPTR.LT.64) RETURN
20    CALL DALOC(ISTN)
      WRITE(IOUT,25)
25    FORMAT("1",17X,"CONFIGURATION TABLE GENERATION ERRORS"//) 
      DO 50 I=1,64
      IF (ERBUF(I,1).EQ.0) GOTO 60
      CALL ALERR(ERBUF(I,1),IOUT,ERBUF(I,2))
50    CONTINUE
60    CALL PRTN(-1) 
      CALL EXEC(6)
C 
C*       CHECKS TO SEE IF ANY ERRORS WERE FOUND IN FILE 
C 
 10   IF(ERPTR.GT.0) GO TO 20 
      RETURN
      END 
      SUBROUTINE STORE(ICLS,IBC,ICLAS,IERR) 
C 
C     SUBROUTINE #5 FOR DBUG
C 
      DIMENSION IBC(130)
      DIMENSION IREG(2) 
      EQUIVALENCE(REG,IREG) 
C 
C     THIS ROUTINE IS RESPONSIBLE FOR STORING 
C  THE VARIABLE IST2(CLASS #) INTO WORD ONE 
C  OF THE CLASS BUFFER IBC
C  AN THEN REWRITE THE BUFFER OUT TO SAM. 
C 
C*** #1 
C 
10    CALL DBUG(5,10,ICLS)
      IERR = 0
      IF(ICLS.LT.0)ICLS = -ICLS 
C 
C*** #2 
C 
20    IBC(1) = ICLS 
      ICLAS = IAND(ICLAS,17777B)
      CALL DBUG(5,20,ICLAS) 
      CALL EXEC(20,0,IBC,IBC(2),IDMY,JDMY,ICLAS)
      CALL ABREG (IREG,IREG(2)) 
      IF(IREG.EQ.-2) IERR = -1
      RETURN
      END 
      END$