FTN4
      PROGRAM BPUT2(5,90),92069-16001 REV.1912 790115 
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-18005
C     RELOC:     92069-16001
C 
C 
C************************************************************ 
C 
C***********************************************************************
C BPUT 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 RTYPE,COLED,IBLNK,BUF,BPTR
      INTEGER ISTAT 
      INTEGER XTYPE,BCLOS,BINF
      DIMENSION ISTAT(10) 
      DIMENSION BCLOS(3)
      DIMENSION BINF(3) 
      DIMENSION BUF(2048) 
      INTEGER SEGM(9) 
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,I2,I4/1,2,4/
      DATA I204,I206,I207/204,206,207/
      DATA ITYPE/111B/
      DATA RTYPE/122B/
      DATA BCLOS/2HBC,2HLO,2H2 /
      DATA BINF/2HBI,2HNF,2H2 / 
C 
C 
C 
C 
C 
C 
C 
C 
C     GET NEXT  CARD
C 
      IVAL=2
      CALL SETD(IVAL) 
      IF(IVAL .EQ. -1) GOTO 122 
C 
C     IF $SET: OR $END WRITE ERR NO 204 
C      "CARD PRESENT WHERE RECORD EXPECTED" 
      IF (IVAL.EQ.2) GO TO 110
109   CALL ERROT(I204)
      GO TO 121 
C     INITIALIZE DBPUT BUFFER PTR 
110   BPTR=1
      IEFLG=0 
C 
C 
C 
C 
C 
C 
C 
C 
C         START LOOP TO ENTER EACH ITEM IN DBPUT BUFFER,BUF 
C 
C 
C 
C 
C 
C 
      DO 119 I=2,ITEM(1)+1
      DO 119 J = 1,ELECT(I) 
C     CALCULATE LAST COLUMN OF ITEM 
      COLED=COL+LENTH(I)-1
C 
C     IF ITEM STARTS ON A NEW CARD,READ NEXT CARD AND CALCULATE 
C     NEW ENDING COLUMN. IF ITEM>PRTLM COLS,MOVE THE WHOLE CARD 
C     INTO DBPUT BUFFER,BUF,(AND NEXT CARD) 
C 
      LEN=LENTH(I)
      IF (COLED.LE.PRTLM) GO TO 113 
      IF (BPTR .EQ. 1) GOTO 112 
      IVAL=2
111   CALL SETD(IVAL) 
      IF(IVAL .EQ. -1) GOTO 122 
      IF (IVAL.NE.2) GO TO 109
      IF (LEN.GT.PRTLM) GO TO 112 
      COLED=LEN 
      GO TO 113 
112   CALL SMOVE(CARD,I1,PRTLM,BUF,BPTR)
      BPTR=BPTR+PRTLM 
      LEN=LEN-PRTLM 
      GO TO 111 
C 
C     IF ITEM TYPE IS X MOVE ITEM TO BUF AND UPDATE BPTR (BUF PTR)
C 
113   IF (TYPE(I).NE.XTYPE) GO TO 114 
      CALL SMOVE(CARD,COL,COLED,BUF,BPTR) 
      BPTR=BPTR+LEN 
      GO TO 118 
C 
C     IF ITEM TYPE IS INTEGER,CONVERT TO INTEGER,MOVE TO BUF, 
C           AND INCREMENT BPTR
C 
114   IF (TYPE(I).NE.ITYPE) GO TO 116 
      CALL CATI(CARD,COL,COLED-COL+1,INT,ISTAT) 
      IF (ISTAT.GE.0) GO TO 115 
C 
C     IF ILLEGAL WRITE ERROR NO 206 
C            "NON-NUMERIC INTEGER IN FIELD" 
C 
      CALL ERROT(I206)
      IF (QTFLAG.EQ. TRUE) GO TO 122
      IEFLG=1 
C 
C 
C 
115   CONTINUE
      CALL SMOVE(INT,I1,I2,BUF,BPTR)
      BPTR=BPTR+2 
      GO TO 118 
C 
C     CONVERT TYPE REAL TO A REAL NUMBER,MOVE TO BUF,INCREMENT BPTR 
C     SCREEN FIELDS THAT ARE ALL BLANK BECAUSE CATR DOESN'T HANDLE IT 
C 
116   CONTINUE
      DO 1161 K = COL,COLED 
      CALL SGET(CARD,K,ICHAR) 
      IF(ICHAR .NE. 40B) GOTO 1162
1161  CONTINUE
      REAL = 0
      GOTO 117
C 
C CONVERT REAL NUMBER 
C 
1162  CONTINUE
      REAL=CATR(CARD,COL,COLED,ISTAT) 
      IF (ISTAT.GE.0) GO TO 117 
C 
C     IF ILLEGAL REAL, WRITE ERROR NO. 207
C            "NON-NUMERIC IN REAL FIELD"
C 
      CALL ERROT(I207)
      IF (QTFLAG.EQ. TRUE) GO TO 122
      IEFLG=1 
C 
C MOVE THE VALUE INTO THE BUFFER
C 
117   CALL SMOVE(REAL,I1,I4,BUF,BPTR) 
      BPTR=BPTR+4 
C 
C     SET UP BEGINNING COLUMN OF NEXT ITEM
C 
118   COL=COLED+1 
119   CONTINUE
C 
C 
C*****IF UPDATE OR CREATE IS SPECIFIED AND THERE ARE NO ERRORS, 
C*****PUT RECORD IN DATA BASE 
C 
C 
      IF (CHECK.EQ. TRUE) GO TO 120 
      IF (IEFLG.EQ.1) GO TO 120 
      CALL DBPUT(IBASE,SETNO,1,ISTAT,ITEM,BUF)
C 
C     IF ERROR IN PUTTING WRITE DBPUT ERROR NO. 
C 
      IF (ISTAT.EQ.0) GO TO 120 
      CALL ERROT(ISTAT) 
      IF (QTFLAG.EQ.0) GO TO 122
C 
C     GET NEXT CARD. IF NOT $SET: OR $END GO TO ENTER NEXT RECORD 
C 
120   IVAL=2
      CALL SETD(IVAL) 
      IF (IVAL.EQ.2) GO TO 110
C 
C     IF  $SET: GO TO PROCESS NEXT SET
C 
121   IF (IVAL.EQ.0) GO TO 200
C 
C     IF $END OR AN ERROR WAS ENCOUNTERED 
C     CALL NEXT SEGMENT TO CLOSE DATA SET 
C 
122   CONTINUE
      CALL SEGLD(BCLOS,IERR)
      CALL OUTLN(SEGM,9)
      CALL OUTLN(BCLOS,3) 
      CALL HALT 
C 
C 
C LOAD AND EXECUTE BINF 
C 
C 
C 
200   CONTINUE
      CALL SEGLD(BINF,IERR) 
      CALL OUTLN(SEGM,9)
      CALL OUTLN(BINF,3)
      ERROR = ERROR + 1 
      GOTO 122
      END 
      END$
                                                                                                          