FTN 
      PROGRAM BBLD2(5,90),92069-16001 REV.1912 790202 
C 
C 
C 
C 
C*************************************************************
C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979.  ALL RIGHTS    *
C RESERVED.  NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- *
C PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH-  *
C OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY.  *
C*************************************************************
C 
C 
C     SOURCE:    92069-18003
C     RELOC:     92069-16001
C 
C 
C************************************************************ 
C 
C 
C 
C THIS SEGMENT PROCESSES THE RUN STRING , OPENING OR LOCKING THE
C    INPUT AND LIST FILES OR DEVICES
C SETS THE OPTIONS FLAGS
C AND OPENS THE DATA BASE 
C 
      LOGICAL IFTTY 
      INTEGER IBUF(10)
      INTEGER I248
      REAL    SIZE(2) 
      INTEGER BCLOS(3),BINF(3)
      INTEGER ILEVL(10),ISTAT(10) 
      INTEGER ADD,ERR,NOLST 
      INTEGER HD(17),HDZ
      INTEGER ILLST(13) 
      INTEGER ILLU(6) 
      INTEGER ILINP(14) 
      INTEGER SEGM(9) 
      INTEGER LOCKED(13)
C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$  AUGUST 10,1978 $$$
      INTEGER ERROR,P,PLEN,CARD,LOG,COL 
      INTEGER ELECT,ITEM,LENTH,TYPE 
      INTEGER IDCB,LDCB,LIST,INPUT,PRTLM,CHECK,LST
      INTEGER IBASE 
      INTEGER SETERR
      INTEGER TRUE,FALSE,SEMI,COMMA 
      INTEGER L,CHAR
      INTEGER SETNO 
      INTEGER QTFLAG
C 
      COMMON ERROR,P(40),PLEN,CARD(256),LOG,COL 
      COMMON ELECT(129),ITEM(129),LENTH(129),TYPE(129)
      COMMON IDCB(144),LDCB(144),LIST,INPUT,PRTLM,CHECK,LST 
      COMMON IBASE(10)
      COMMON SETERR 
      COMMON L,CHAR 
      COMMON SETNO
      COMMON QTFLAG 
      COMMON/CONST/TRUE,FALSE,SEMI,COMMA
C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$  OCTOBER 16,1978 $$
      EXTERNAL IFTTY
C 
      DATA ADD/2HAD/
      DATA ERR/2HER/
      DATA NOLST/2HNO/
      DATA I248/248/
C 
      DATA SEGM/2HSE,2HGM,2HEN,2HT ,2HNO,2HT ,2HFO,2HUN,2HD / 
      DATA LOCKED/2H D,2HBB,2HLD,2H W,2HAI,2HTI,2HNG,2H O,2HN , 
     &    2HLI,2HST,2H L,2HU /
C IMAGE/1000 DATA BASE BUILD UTILITY
      DATA HD/2HIM,2HAG,2HE/,2H10,2H00,2H D,2HAT,2HA ,2HBA,2HSE,
     &2H B,2HUI,2HLD,2H U,2HTI,2HLI,2HTY/ 
      DATA ILLST/2H L,2HIS,2HT ,2HFI,2HLE,2H E,2HRR,2HOR,2H I,
     &2HS ,2HXX,2HXX,2HXX/
      DATA ILLU/2H I,2HLL,2HEG,2HAL,2H L,2HU /
      DATA ILINP/2H I,2HNP,2HUT,2H F,2HIL,2HE ,2HER,2HRO,2HR ,
     &2HIS,2H  ,2HXX,2HXX,2HXX/ 
      DATA HDZ/17/
C 
      DATA BCLOS/2HBC,2HLO,2H2 /
      DATA BINF/2HBI,2HNF,2H2 / 
      DATA I203,I218/203,218/ 
      DATA IBLNK/2H  /
C 
C 
C 
C DEFAULT PARAMETERS
C 
      PRTLM = 72
      CHECK = TRUE
      QTFLAG = FALSE
      LST = TRUE
      ERROR = 0 
C 
C PROCESS INPUT NAME
C 
      IPTR = 1
      CALL NAMR(IBUF,P,PLEN,IPTR) 
C 
C SET INPUT LU TO ZERO AND ERROR CODE TO ZERO IN CASE 
C INPUT NAMR IS AN LU 
C 
      INPUT = -1
      IERR = 0
C 
C IS INPUT NAMR A FILE? 
C 
      IF (IAND(IBUF(4),000003B) .NE. 3) GOTO 10 
C 
C YES, OPEN THE FILE
C 
      CALL OPEN(IDCB,IERR,IBUF,0,IBUF(5),IBUF(6) )
      GO TO 20
C 
C NO, THEN INPUT IS AN LU 
C 
10    CONTINUE
      INPUT = IBUF(1) 
C 
C DEFAULT LU IF NECESSARY 
C 
      IF(INPUT .EQ. 0) INPUT = 1
      IF(INPUT .GT. 0) GOTO 12
      IERR = -200 
      GOTO 20 
C 
C LOCK INPUT LU IF NOT AN INTERACTIVE DEVICE
C 
12    CONTINUE
      IF(IFTTY(INPUT)) GOTO 15
      CALL LURQ(1,INPUT,1)
C 
C SET CONTROL WORD TO ECHO COMMANDS FROM A KEYBOARD 
C 
15    CONTINUE
      INPUT = INPUT + 400B
C 
C GET THE LIST PARAMETER
C 
20    CONTINUE
      CALL NAMR(IBUF,P,PLEN,IPTR) 
C 
C IS LIST A FILE? 
C 
      LIST = -1 
      IERR2 = 0 
      IF (IAND(IBUF(4),000003B) .NE. 3) GOTO 30 
C 
C YES, OPEN THE FILE
C 
      CALL OPEN (LDCB,IERR2,IBUF,0,IBUF(5),IBUF(6) )
C 
C IF NOT FOUND THEN CREATE THE LIST FILE
C 
      IF(IERR2 .NE. -6) GOTO 25 
      SIZE = DBLEI(10)
      CALL ECREA(LDCB,IERR2,IBUF,SIZE,4,IBUF(5),IBUF(6) ) 
C 
C IF  ERROR THEN ABORT
C 
25    CONTINUE
      IF (IERR2 .GE. 0) GOTO 40 
C 
C OUTPUT ERROR MESSAGE WITH FMP ERROR CODE
C 
      LIST = 1
      CALL  CITA(IERR2,ILLST(11)) 
      CALL OUTLN(ILLST,13)
C 
C CLOSE INPUT FILE
C 
27    CONTINUE
      CALL ECLOS(IDCB)
      STOP
C 
C NO, THEN LIST IS A LU 
C 
30    CONTINUE
      LIST = IBUF(1)
C 
C DEFAULT LIST TO LU 6 IF NECESSARY 
C 
      IF (IBUF(4)  .EQ. 0) LIST = 6 
      IF(LIST .GE. 0) GOTO 34 
      LIST = 1
      CALL OUTLN(ILLU,6)
      GOTO 27 
C 
C LOCK THE LU 
C SKIP TO TOP OF PAGE 
C 
34    CONTINUE
      IF(IFTTY(LIST) ) GOTO 35
C 
C LOCK THE LU 
C 
      CALL LURQ(100001B,LIST,1) 
      CALL ABREG(IA,IB) 
      IF(IA .EQ. 0) GOTO 35 
      CALL EXEC(2,1,LOCKED,13)
341   CALL EXEC(12,0,2,0,-10) 
      CALL LURQ(100001B,LIST,1) 
      CALL ABREG(IA,IB) 
      IF(IA .NE. 0) GOTO 341
C 
C OUTPUT TOP OF PAGE
C 
35    CALL EXEC(3,1100B+LIST,-1)
C 
C OUTPUT A HEADING
C 
40    CONTINUE
      CALL OUTLN(IBLNK,1) 
      CALL OUTLN(IBLNK,1) 
      CALL OUTLN(HD,HDZ)
      CALL OUTLN(IBLNK,1) 
      CALL OUTLN(IBLNK,1) 
      CALL OUTLN(IBLNK,1) 
C 
C CHECK FOR INPUT OPEN ERROR
C 
C 
      IF (IERR .GE. 0) GOTO 50
C 
C IS THIS AN ILLEGAL LU?
C 
      IF(IERR .NE. -200) GOTO 45
      CALL OUTLN(ILLU,6)
      CALL HALT 
C 
C INPUT FILE ERROR
C 
45    CONTINUE
      CALL CITA(IERR,ILINP(12)) 
      CALL OUTLN(ILINP,14)
      CALL HALT 
C 
C OPEN OK,
C 
C 
C 
C 
C 
C 
C 
C 
C 
C    PROCESS THE OPTIONS
C 
C 
C 
C 
C 
C 
C 
50    CONTINUE
      CALL NAMR(IBUF,P,PLEN,IPTR) 
      IFLAG = IAND(IBUF(4),3B)
      IF(IFLAG .EQ. 0) GOTO 150 
      IF (IFLAG .NE. 1) GOTO 100
C 
C PROCESS THE PRINT LIMIT 
C 
      PRTLM = IBUF
      IF(PRTLM .GT. 0  .AND. PRTLM .LT. 513) GOTO 50
      CALL ERROT(I218)
      PRTLM = 72
      GOTO 50 
C 
C PROCES THE ADD OPTION 
C 
100   CONTINUE
      IF(IFLAG .NE. 3) GOTO 140 
      IF(IBUF .NE. ADD) GOTO 120
      CHECK = FALSE 
      GOTO 50 
C 
C PROCESS ERRHLT OPTION 
C 
120   CONTINUE
      IF(IBUF .NE. ERR) GOTO 130
      QTFLAG = TRUE 
      GOTO 50 
C 
C PROCESS NOLST OPTION
C 
130   CONTINUE
      IF(IBUF .NE. NOLST) GOTO 140
      LST = FALSE 
      GOTO 50 
C 
C ERROR - ILLEGAL OPTION
C 
140   CONTINUE
      CALL ERROT(I218)
      CALL OUTLN(IBUF,3)
      GOTO 50 
C 
C 
C 
C 
C 
C 
C 
C   START PROCESSING THE FILE 
C 
C 
C 
C 
C 
C 
C GET FIRST RECORD
C 
150   CONTINUE
      CALL CRDIM(IERR)
      IF(IERR .NE. 0) CALL HALT 
C 
C GET DATA BASE NAME
C 
      IBASE(1) = IBLNK
      CALL KEYWD(IBASE(2) ) 
C 
C DEFAULT LEVEL WORD
C 
      DO 160 I = 1,3
160   ILEVL(I) = IBLNK
C 
C WAS A LEVEL WORD GIVEN
C 
      IF(CHAR .EQ. SEMI) GOTO 170 
      IF (CHAR .NE. COMMA) GOTO 170 
      CALL KEYWD(ILEVL) 
C 
C OPEN THE DATA BASE
C 
170   CONTINUE
      CALL DBOPN(IBASE,ILEVL,3,ISTAT) 
      IF(ISTAT .EQ. 0) GOTO 180 
      CALL ERROT(ISTAT) 
      CALL HALT 
C 
C 
C 
C 
C IF NEXT RECORD .NE. $SET: THEN ERROR
C 
180   CONTINUE
      IVAL = 0
      CALL SETD(IVAL) 
      IF(IVAL .EQ. -1) GOTO 185 
      IF(IVAL .EQ. 0) GOTO 190
      CALL ERROT(I203)
C 
C LOAD AND EXECUTE BCLOS
C 
185   CONTINUE
      CALL SEGLD(BCLOS,IERR)
      CALL OUTLN(SEGM,9)
      CALL OUTLN(BCLOS,3) 
      CALL HALT 
C 
C 
C 
C 
C LOAD AND EXECUTE BINF 
C 
190   CONTINUE
      CALL SEGLD(BINF,IERR) 
      CALL OUTLN(SEGM,9)
      CALL OUTLN(BINF,3)
      ERROR = ERROR + 1 
      GOTO 185
      END 
      END$
      END 
      END$
                                                                                                                                                                                              