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 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