FTN4
      PROGRAM BINF2(5,90),92069-16001 REV.1912 790115 
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-18004
C     RELOC:     92069-16001
C 
C 
C************************************************************ 
C 
C***********************************************************************
C BINF IS THE SEGMENT OF DBBLD WHICH READS THE DATA RECORDS AND 
C     PUTS THEM IN THE DATA BASE
C     INTEGERS AND REALS ARE CONVERTED FROM ASCII 
C 
      INTEGER SETNM,COLBG,RTYPE,COLED,IBLNK 
      INTEGER ISTAT 
      INTEGER XTYPE,BCLOS,BPUT
      INTEGER TTYPE 
      DIMENSION SETNM(10),INFO(110) 
      DIMENSION ISTAT(10) 
      DIMENSION M2(24),IA(3)
      DIMENSION NUM(40) 
      INTEGER SEGM(9) 
      INTEGER BCLOS(3),BPUT(3)
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 $$
      DATA SEGM/2HSE,2HGM,2HEN,2HT ,2HNO,2HT ,2HFO,2HUN,2HD / 
      DATA XTYPE/130B/
      DATA IBLNK/2H  /
      DATA I1/1/
      DATA I211/211/
      DATA ITYPE/111B/
      DATA RTYPE/122B/
      DATA M2/2H  ,2H  ,2H  ,2H  ,2H I,2HN ,2HCO,2HLU,2HMN,2HS ,2H  , 
     12H  ,2H T,2HHR,2HOU,2HGH,2H  ,2H  ,2H  ,2H I,2HS ,2HTY,2HPE,2H  / 
      DATA NUM/2H12,2H34,2H56,2H78,2H90,
     12H12,2H34,2H56,2H78,2H90, 
     12H12,2H34,2H56,2H78,2H90, 
     12H12,2H34,2H56,2H78,2H90, 
     12H12,2H34,2H56,2H78,2H90, 
     12H12,2H34,2H56,2H78,2H90, 
     12H12,2H34,2H56,2H78,2H90, 
     12H12,2H34,2H56,2H78,2H90/ 
      DATA BPUT/2HBP,2HUT,2H2 / 
      DATA BCLOS/2HBC,2HLO,2H2  / 
C 
C 
C 
C 
C 
C 
  
C     GET <SET NAME>
C 
100   COL=6 
      CALL KEYWD(SETNM) 
C 
C     GET DATA SET NUMBER 
C 
      CALL DBINF (IBASE,SETNM,201,ISTAT,SETNO)
      IF (ISTAT.EQ.0) GO TO 103 
C 
C OUTPUT ERROR CODE, SET THE SET-ERROR FLAG AND CLOSE THE DATA BASE 
C 
101   CALL ERROT(ISTAT) 
      SETERR=-1 
      GO TO 122 
C 
C     IF SETNO IS POSITIVE THE USER HAS NO WRITE ACESS
C     IF LIST OPTION ON, SKIP A LINE ON LISTING DEVICE
C 
103   CONTINUE
      ISTAT = 100 
      IF(SETNO .GE. 0) GOTO 101 
      SETNO = -SETNO
      IF(LST.EQ.TRUE) CALL OUTLN(IBLNK,1) 
C 
C     GET DATA ITEM COUNT AND DATA ITEM NUMBERS IN ITEM 
C 
      CALL DBINF(IBASE,SETNO,104,ISTAT,ITEM)
      IF(ISTAT .NE. 0) GOTO 101 
C 
C     ICNT IS DATA ITEM COUNT 
C 
      ICNT=ITEM(1)
C 
C     INITIALIZE PTR TO BEGINNING OF NEXT DATA ITEM ON RECORD 
C 
      COLBG=1 
C 
C     START LOOP TO GET TYPE AND LENGTH OF EACH ITEM AND
C     CALCULATE BEGINNING AND ENDING COLUMNS OF EACH ITEM AND 
C     PRINT THIS INFORMATION
C 
      DO 107 I=2,ICNT+1 
C 
C     GET INFO ABOUT ITEM AND PUT IN INFO (DATA ITEM NO IS ITMNO) 
C 
      IF(ITEM(I) .LT. 0) GOTO 1031
      ISTAT = I211
      GOTO 101
C 
C 
C 
1031  ITMNO = -ITEM(I)
      ITEM(I) = ITMNO 
      CALL DBINF(IBASE,ITMNO,102,ISTAT,INFO)
      IF (ISTAT .NE. 0) GOTO 101
C 
C     GET ITEM TYPE AND ITEM LENGTH 
C 
      CALL SGET(INFO,17,TYPE(I))
      LENTH(I)=INFO(10) 
      ELECT(I) = INFO(11) 
      IF (TYPE(I).EQ.ITYPE)LENTH(I)=6 
      IF (TYPE(I).EQ.RTYPE)LENTH(I)=13
C 
C     CALCULATE BEGINNING AND ENDING COLUMNS OF EACH ITEM 
C 
      IF(COLBG+LENTH(I)-1 .GT. PRTLM) COLBG = 1 
C 
C     CALCULATE NUMBER OF ELEMENT FIELDS ON CURRENT CARD
C     AND SET COLED TO LENGTH OF ELEMENTS THAT DON'T FIT
C     ON THE CURRENT CARD 
C 
      COLED = COLBG - 1 
      DO 3012 N = 1,ELECT(I)
      COLED = COLED + LENTH(I)
      IF(COLED .LE. PRTLM) GOTO 3012
      COLED = LENTH(I)
      IF(COLED .GT. PRTLM) COLED = MOD(COLED,PRTLM) 
3012  CONTINUE
C 
C     IF LIST TURNED ON WRITE ITEM NAMES AND THEIR COLUMNS
C 
104   IF(LST.EQ.FALSE) GO TO 107
      M2(2) = INFO(1) 
      M2(3)=INFO(2) 
      M2(4)=INFO(3) 
      CALL CITA(COLBG,IA) 
      M2(11)=IA(2)
      M2(12)=IA(3)
      CALL CITA(COLED,IA) 
      M2(18)=IA(2)
      M2(19)=IA(3)
      TTYPE=TYPE(I) 
      CALL SPUT(TTYPE,I1,IBLNK) 
      M2(24)=TTYPE
      CALL OUTLN(M2,24) 
      COLBG = COLED + 1 
107   CONTINUE
C 
C IF LIST ON, SKIP A LINE AND WRITE COL NO'S ACROSS THE PAGE
C 
      IF(LST .EQ. FALSE) GOTO 108 
      CALL OUTLN(IBLNK,1) 
      CALL OUTLN(NUM,40)
C 
C 
C LOAD AND EXECUTE BPUT 
C 
C 
108   CONTINUE
      CALL SEGLD(BPUT,IERR) 
      CALL OUTLN(SEGM,9)
      CALL OUTLN(BPUT,3)
      ERROR = ERROR + 1 
C 
C 
C 
C ERROR EXIT
C 
C 
122   CONTINUE
      CALL SEGLD(BCLOS,IERR)
      CALL OUTLN(SEGM,9)
      CALL OUTLN(BCLOS,3) 
      CALL HALT 
      END 
                                                