FTN4
      PROGRAM DBLOD(4,90),92069-16128 REV.2013 790927 
C 
C 
C*****************************************************************
C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS RESERVED.
C NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, REPRODUCED, OR
C TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR
C WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. 
C****************************************************************** 
C 
C 
C     SOURCE:    92069-18128
C     RELOC:     92069-16128
C 
C 
C****************************************************************:
C 
C 
C***********************************************************
C DBLOD LOADS DATA FROM A MAGNETIC TAPE INTO AN IMAGE DATA BASE 
C ACCORDING TO A SCHEMA STORED IN A ROOT FILE ON THE DISC.
C 
C THE MAIN PROGRAM DOES THE FOLLOWING:
C 1) DOES A GETST 
C 2) CALLS IN SEGMENT DBLO1.
C 
C DBLO1 DOES THE FOLLOWING: 
C 1) RETRIEVES ALL THE PARAMETERS FROM THE RUN STRING.
C 2) CALLS DBOPN TO OPEN THE DATA BASE. 
C 3) CHECKS THE TAPE HEADER.
C 4) CALLS IN SEGMENT DBLO2.
C 
C DBLO2 DOES THE FOLLOWING: 
C 1) WRITES ALL THE DATA IN ALL MANUAL AND DETAIL DATA SETS 
C    FROM THE MAG TAPE TO THE APPROPRIATE DAA SET.
C 2) CALLS IN SEGMENT DBLO9.
C 
C DBLO9 DOES THE FOLLOWING: 
C 1) CLOSES THE DATA BASE.
C 2) ENDS THE PROGRAM.
C 
C ASSUMPTIONS:
C DBLOD ASSUMES THAT THE DATA FOR A MANUAL MASTER PRECEDES THE DATA 
C FOR ALL ASSOCIATED DETAILS. THIS IS A REASONABLE ASSUMPTION SINCE 
C IN ALL IMAGE SCHEMAS A MANUAL MASTER MUST BE DEFINED PRIOR TO ALL 
C OF ITS ASSOCIATED DETAILS). 
C 
C 
C RUN STRING: 
C :RU,DBLOD,CONSOLE,TAPE,ROOT,LEVEL,ABORT 
C 
C WHERE:
C 
C CONSOLE= INTERACTIVE LU AT WHICH USER ENTERS COMMANDS.
C TAPE   = LU OF MAGNETIC TAPE UNIT ON WHICH DATA BASE IS SAVED.
C ROOT   = ROOT FILE NAMR ON THE DISC.
C LVLWD  = HIGHEST LEVEL WORD DEFINED FOR THE DATA BASE.
C ABORT  = AB TO ABORT PROGRAM AT END OF REEL 
C        = XX TO ALLOW MULTIPLE TAPE REELS. 
C 
C THE ABOVE PARAMETERS ARE STORED INTERNALLY AS 
C 6-WORD ARRAYS AS FOLLOWS: 
C 
C 1) LU OR FIRST TWO  CHARACTERS
C 2) 0  OR SECOND TWO CHARACTERS. 
C 3) 0 OR THIRD TWO CHARACTERS. 
C 4) 0 IF NULL, 1 IF INTEGER, 3 IF ASCII PARAMETER. 
C 5) NEGATIVE SECURITY CODE IF NAMR PARAMETER.
C 6) CARTRIDGE REF NUMBER IF NAMR PARAMETER.
C 
C LENGTH = LENGTH IN WORDS OF THE PARAMETER STRING. 
C HDR    = TAPE AND REEL HEADER INFORMATION TO BE WRITTEN TO TAPE.
C 
C****************************************************************** 
C COMMON VARIABLES. THESE VARIABLES ARE DECLARED SIMILARLY IN ALL 
C THE OTHER SEGMENTS (IF YOU CHANGE THEM, YOU MUST CHANGE THEM ALL).
C ALSO CHECK &TPWR2 FOR COMMON DECLARATIONS.
C 
C 
      INTEGER LU1(6),TAPE(6),ROOT(6),LVLWD(6),P5(6) 
      INTEGER BUF1(256),BUF1SZ
      INTEGER LENGTH
      INTEGER IBASE(12) 
      INTEGER HDR(24) 
      COMPLEX HDR1(6) 
      EQUIVALENCE (HDR,HDR1)
      INTEGER TDCB(144),TDSZ
      COMMON LU1,TAPE,ROOT,LVLWD
      COMMON BUF1,BUF1SZ
      COMMON LENGTH 
      COMMON IBASE
      COMMON/TPHDR/HDR,TDCB,TDSZ,P5 
C****************************************************************** 
C START PROCESSING HERE.
C 
      BUF1SZ=256
      CALL GETST(BUF1,BUF1SZ,LENGTH)
      CALL SEGLX(6HDBLO1 ,LU1)
      STOP 77 
C***************************************************************
C DUMMY CALLS TO MAKE SURE THEY GET RELOCATED WITH THE MAIN.
C 
10    CALL DBBUF(IDUMY) 
      CALL STPLU(IDUMY) 
      HDR=IDUMY 
C**************************************************************** 
      END 
C 
C 
C 
      SUBROUTINE SEGLX(INAME,LU1 ),92069-16128 REV.2013 790927
C 
C 
C 
C 
C ABSTRACT: 
C 
C  SEGLX LOADS A SEGMENT USING SEGLD.  IF AN ERROR OCCURS THE 
C  NAME OF THE SEGMENT IS PRINTED AND THE PROGRAM IS TERMINATED.
C 
C CALLING SEQUENCE: 
C 
C       CALL SEGLX(INAME,LU1) 
C 
C          WHERE: 
C 
C              INAME IS THE NAME OF THE SEGMENT.  IT MUST BE
C              6 CHARACTERS LONG. 
C 
C              LU1 IS THE LOG LU.  ON ERROR THE NAME OF THE 
C              SEGMENT WILL BE PRINTED ON THIS LU.
C 
C 
C 
C 
C 
      INTEGER INAME(3),LU1
      INTEGER IERR
      INTEGER NOSEG(8 ),NOSGL 
      DATA NOSEG/2H S,2HEG,2HME,2HNT,2H M,2HIS,2HSI,2HNG/ 
      DATA NOSGL/8 /
C 
C 
C 
C 
      CALL SEGLD(INAME,IERR)
      CALL REIO(2,LU1,NOSEG,NOSGL)
      CALL REIO(2,LU1,INAME,3)
      STOP
      END 
C 
C 
      PROGRAM DBLO1(5,90) 
     +,92069-16128 REV.2013 790927
C*****************************************************************
C DBLO1 DOES THE FOLLOWING:
C 
C 1) RETRIEVES ALL THE PARAMETERS FROM THE RUN STRING HELD IN 
C    BUF1 IN COMMON.
C 2) CALLS DBOPN TO OPEN THE DATA BASE. 
C 3) CALLS DBCRT IN ONE OF TWO WAYS DEPENDING ON P5(THE ABORT WORD).
C    1) IF P5=ABORT, CALLS DBCRT WITH NO PURGE OPTION.
C    2) IF (P5 .NE. AB),CALLS DBCRT SO IT PURGES AND CREATES NEW FILES. 
C 4) LOADS IN SEGMENT DBLO2.
C 
C**************************************************************** 
C COMMON DECLARATIONS.
C 
      INTEGER LU1(6),TAPE(6),ROOT(6),LVLWD(6),P5(6) 
      INTEGER BUF1(256),BUF1SZ
      INTEGER LENGTH
      INTEGER IBASE(12) 
      INTEGER HDR(24) 
      COMPLEX HDR1(6) 
      EQUIVALENCE (HDR,HDR1)
      INTEGER TDCB(144),TDSZ
      COMMON LU1,TAPE,ROOT,LVLWD
      COMMON BUF1,BUF1SZ
      COMMON LENGTH 
      COMMON IBASE
      COMMON/TPHDR/HDR,TDCB,TDSZ,P5 
C************************************************************** 
C LOCAL VARIABLES.
C 
      INTEGER ISTAT(10) 
      INTEGER IDCB(144) 
      INTEGER IHEAD(24) 
      EQUIVALENCE (IHEAD,TPHEAD)
C*************************************************************
C GET THE PARAMETERS. 
C 
      LU=LOGLU(IDUMY) 
      CALL GTPRM(LU,LU1,TAPE,ROOT,LVLWD,P5,BUF1,LENGTH,IERR)
      IF (IERR .NE. 0) STOP 
C**************************************************************** 
C PRELIMINARY CHECKS ON THE STORAGE DEVICE. 
C 
      IF (TAPE(4) .EQ. 1) CALL TLOCL(LU1,TAPE,IERR) 
      IF (IERR .LT. 0) STOP 
C***************************************************************
C OPEN THE STORAGE DEVICE.
C 
      IOPTN=0 
      ISECU=TAPE(5) 
      ICR=TAPE(6) 
      CALL OPENF(TDCB,IERR,TAPE,IOPTN,ISECU,ICR,TDSZ) 
      IF (IERR .GT. 0) IERR=0 
      CALL DBER2(LU1,IERR,TAPE,6HDBLO1 ,2HAB) 
C************************************************************ 
C BUILD UP IBASE USING DATA IN ROOT.
C 
      IBASE=2H
      IBASE(2)=ROOT 
      IBASE(3)=ROOT(2)
      IBASE(4)=ROOT(3)
      IBASE(5)=2H : 
      ISECU=IABS(ROOT(5)) 
      CALL CNUMD(ISECU,IBASE(6))
      IBASE(9)=2H : 
      ICR=IABS(ROOT(6)) 
      CALL CNUMD(ICR,IBASE(10)) 
C************************************************************ 
C CALL SQUSH TO DELETE BLANKS FROM IBASE. 
C 
499   CONTINUE
      CALL SQUSH(IBASE(2),11) 
C************************************************************ 
C OPEN THE DATA BASE. 
C 
      IMODE=3 
      CALL DBOPN(IBASE,LVLWD,IMODE,ISTAT) 
      CALL DBER2(LU1,ISTAT,ROOT,6HDBLO1 ,2HAB)
C*************************************************************
C SET IMODE FOR DBCRT CALL. 
C IMODE = 0 FOR NO PURGE. 
C IMODE = 1 TO PURGE FILES AND CREATE NEW ONES. 
C 
      IMODE = 1 
      IF (P5 .EQ. 2HAB) IMODE=0 
      CALL NEWFL(LU1,IDCB,IMODE,ISTAT)
      IF (ISTAT .NE. 0) GO TO 9500
C*****************************************************************
C CHECK THE TAPE HEADER.
C 
C*******************************************************************
C READ IN THE TAPE HEADER.
C 
      CALL TAPER(LU1,TAPE,IHEAD,24,LEN,EOF,IERR)
      IF(IERR) 500,510,510
500   CALL SEGLX(6HDBLO9 ,LU1)
      STOP 77 
C*******************************************************************
C SET UP THE TAPE HEADER TO COMPARE AGAINST ONE OUT OF STORAGE DEVICE.
C FORCE THE ROOT FILE PARTS TO BE THE SAME ( NEED THIS INFO IN HDR
C BECAUSE SUBRS EOFRE AND EOTRE EXPECT IT THERE.) 
C 
510   HDR=2HDB
      HDR(2)=2HUN 
      HDR(3)=2HLO 
      HDR(4)=2HAD 
      HDR(5)=2H21 
      HDR(6)=2HXX 
C 
      DO 600 J=9,14 
      HDR(J)=IHEAD(J) 
600   CONTINUE
C 
      HDR(21)=1 
C****************************************************************** 
C CHECK THE TAPE HEADER. GET NUMBER OF SETS TO RESTORE FROM INFO
C OFF THE TAPE. 
C 
      CALL CKTHD(LU1,HDR,IHEAD,IERR)
      IF (IERR .EQ. 0) GOTO 520 
      CALL SEGLX(6HDBLO9 ,LU1)
      STOP 77 
520   HDR(20)=IHEAD(20) 
C************************************************************ 
C LOAD IN NEXT SEGMENT. 
C 
      CALL SEGLX(6HDBLO2 ,LU1)
      STOP 77 
C*************************************************************
C DBCRT RETURNED AN ERROR.
C 
9500  CONTINUE
      CALL DBER2(LU1,ISTAT,ISTAT(2),6HDBLO1 ,6HDBLO9 )
      END 
C 
C 
C 
      PROGRAM DBLO2(5,90) 
     +,92069-16128 REV.2013 790927
C****************************************************************** 
C DBLO2 READS AND CHECKS THE TAPE HEADER, GETS NUMBER OF DATA 
C SETS TO RESTORE OUT OF THE TAPE HEADER. 
C THEN DBLO2 LOADS THE DATA FROM THE TAPE INTO THE DATA BASE
C ACCORDING TO THE ROOT FILE ON THE DISC. 
C 
C********************************************************************** 
C COMMON DECLARATIONS.
C 
      INTEGER LU1(6),TAPE(6),ROOT(6),LVLWD(6),P5(6) 
      INTEGER BUF1(256),BUF1SZ
      INTEGER LENGTH
      INTEGER IBASE(12) 
      INTEGER HDR(24) 
      COMPLEX HDR1(6) 
      EQUIVALENCE (HDR,HDR1)
      INTEGER TDCB(144),TDSZ
C****************************************************************** 
C 
      COMMON LU1,TAPE,ROOT,LVLWD
      COMMON BUF1,BUF1SZ
      COMMON LENGTH 
      COMMON IBASE
      COMMON/TPHDR/HDR,TDCB,TDSZ,P5 
C****************************************************************** 
C LOCAL DECLARATIONS. 
C 
      INTEGER BUFR(2072),BUFSZ
      INTEGER SETNUM
C***********************************************************
C DATA STATEMENTS 
C 
      DATA BUFSZ/2072/
C*****************************************************************
C GET THE NUMBER OF SETS INTO SETNUM FROM THE TAPE HEADER.
C 
      SETNUM=HDR(20)
C*****************************************************************
C RESTORE ALL THE DATA SETS FROM TAPE TO DISC.
C SETN2 ALWAYS RETURNS POSITIONED AT THE BEGINNING OF THE NEXT
C FILE. IF IT RETURNS AN ERROR, IT ALWAYS RETURNS A DB ERROR. 
C 
      DO 10 J=1,SETNUM
      CALL SETN2(LU1,TAPE,IBASE,J,BUFR,BUFSZ,BUF1,IERR) 
      IF (IERR .NE. 0) GOTO 20
10    CONTINUE
C*****************************************************************
C WRITE MESSAGE AND CALL DBLO9 TO CLOSE UP. 
C 
      CALL REIO(2,LU1,26H DATA BASE LOAD COMPLETED.,13) 
20    CALL SEGLX(6HDBLO9 ,LU1)
      STOP 77 
      END 
C 
C 
C 
      SUBROUTINE SETN2(LU1,TAPE,IBASE,J,BUFR,BUFSZ,BUF1,IERR) 
     +,92069-16128 REV.1912 790126
C***************************************************************
C SETN2 TRANSFERS DATA FROM THE STORAGE DEVICE INTO THE DATA SET NAMED
C IN THE TAPE HEADER ON THE TAPE. 
C 
C IF A DATA SET OF THAT NAME IS NOT DEFINED IN THE NEW SCHEMA,
C SETN2 SKIP OVER ALL THE DATA FOR THAT SET ON THE TAPE.
C 
C THERE ARE THREE CASES THAT SETN2 HANDLES AS FOLLOWS:
C 1) IF THE DATA RECORDS ON THE TAPE ARE THE SAME LENGTH AS AN
C    ENTRY IN THE NEW DATA SET, THE ENTIRE RECORD FROM THE TAPE 
C    IS LOADED INTO THE DATA ENTRY. 
C 2) IF THE DATA RECORDS ON THE TAPE ARE LONGER THAN AN ENTRY IN
C    THE NEW DATA SET, EACH TAPE RECORD IS TRUNCATED AND THE
C    SHORTENED RECORD IS LOADED INTO THE NEW DATA SET.
C 3) IF THE DATA RECORDS ON THE TAPE ARE SHORTER THAN AN ENTRY IN 
C    THE NEW DATA SET, N WORDS FROM THE TAPE RECORD ARE USED, WHERE 
C    N IS CHOSEN SUCH THAT: 
C    A) N <= TAPE RECORD LENGTH.
C    B) N=SUM OF THE LENGTHS OF THE FIRST SEVERAL ITEMS IN THE DATA SET.
C    A AND B TOGETHER ENSURE THAT ONLY MEANINGFUL DATA IS PUT FROM THE
C    TAPE INTO COMPLETE ITEMS IN THE DATA SET.
C 
C ASSUMPTIONS:
C 1) TAPE IS POSITIONED AT A FILE HEADER. 
C 2) BUFR AND BUF1 CAN BE USED FREELY.
C 
C 
C VARIABLES:
C J     = THE NUMBER OF THE FILE ON THE TAPE. 
C NAMR  = THE NAME OF THE DATA SET AS RECORDED ON THE FILE HEADER.
C EOF   = LOGICAL VALUE RETURNED BY TAPER AT EOF. 
C LEN   = LENGTH OF TAPE RECORD RETURNED BY TAPER(TAPE READ). 
C ENTRY = DOUBLE WORD NUMBER OF ENTRIES STORED ON THE TAPE
C         (I.E. NUMBER OF ENTRIES IN DATA SET IN OLD DATA BASE).
C JREC1 = LENGTH OF DATA RECORD ON THE TAPE (I.E. IN OLD DATA BASE).
C         (JREC1 IS READ IN FROM THE FILE HEADER ON TAPE) 
C JREC2 = LENGTH OF DATA RECORD IN THE NEW DATA SET (IN NEW DATA BASE). 
C         (JREC2 IS DERIVED USING A CALL TO DBINF IN NEW DATA BASE) 
C HDSZ  = LENGTH OF DATA HEADER( LOCAL VARIABLE). 
C INDEX = INDEX INTO BUFR USED WHEN DBPUTTING TO GET SUCCESSIVE 
C         RECORDS OUT OF BUFR (EFFECTIVELY UNPACKS BUFR). 
C 
C***********************************************************************
C PARAMETER DECLARATIONS
C 
      INTEGER LU1,TAPE,IBASE(1),J,BUFR(1),BUFSZ,BUF1(1),IERR
C*******************************************************************
C LOCAL VARIABLES.
C 
      INTEGER NAMR(6) 
      LOGICAL EOF 
      INTEGER LEN 
      INTEGER ENTRY(2)
      INTEGER JREC1,JREC2 
      INTEGER ISTAT(10) 
      INTEGER HDSZ
      INTEGER BLKNO 
      INTEGER INDEX 
C*************************************************************
C DATA STATEMENTS.
C 
      DATA HDSZ/24/ 
C*****************************************************************
C READ AND CHECK THE FILE HEADER. 
C 
      CALL TAPER(LU1,TAPE,BUFR,BUFSZ,LEN,EOF,IERR)
      IF (IERR .LT. 0) RETURN 
      CALL COMP(LU1,BUFR,12HFILEHEAD21XX,6,IERR)
      IF (IERR .NE. 0) GO TO 4000 
C 
      NAMR=BUFR(9)
      NAMR(2)=BUFR(10)
      NAMR(3)=BUFR(11)
C 
      JREC1=BUFR(19)
      ENTRY=BUFR(21)
      ENTRY(2)=BUFR(22) 
C*******************************************************************
C MAKE SURE NAMR EXISTS IN NEW DATA BASE ,AND IS NOT AUTOMATIC MASTER.
C 
      CALL DBINF(IBASE,NAMR,202,ISTAT,BUF1) 
      CALL DBER2(LU1,ISTAT,NAMR,6HSETN2 ,2HXX)
      IF (ISTAT .NE. 0) GO TO 3000
      IF (BUF1(9) .EQ. 2HA ) GO TO 2000 
C****************************************************************** 
C GET ENTRY LENGTH INTO JREC2.
C 
      JREC2=BUF1(10)
C****************************************************************** 
C ADJST LOOKS AT JREC1 AND JREC2 TO SET UP BUF1 SUCH THAT:
C BUF1(1)=N (NUMBER OF ITEMS TO DBPUT). 
C BUF1(2) THROUGH BUF1(N+1) = ITEM NUMBERS TO USE IN DBPUT. 
C ADJST PICKS N SUCH THAT THE LENGTHS OF THE FIRST N ITEMS SUM TO LESS
C THAN OR EQUAL TO THE LENGTH OF A TAPE RECORD. 
C 
      CALL ADJST(LU1,IBASE,NAMR,JREC1,JREC2,BUF1,IERR)
      IF (IERR .NE. 0) GO TO 3000 
C****************************************************************** 
C BY HERE, BUF1 IS SET UP FOR DBPUTS.READ RECORDS FROM TAPE, USE
C DBPUTS TO PUT DATA INTO THE DATA SET. 
C 
1000  CONTINUE
      EOF=.FALSE. 
      CALL TAPER(LU1,TAPE,BUFR,BUFSZ,LEN,EOF,IERR)
      IF (IERR .NE. 0) RETURN 
      IF (EOF) RETURN 
C*****************************************************************
C CHECK THE DATA HEADER.
C 
      CALL CKDHD(LU1,NAMR,BLKNO,BUFR,IERR)
      IF (IERR .NE. 0) GO TO 3000 
C****************************************************************** 
C CHECK THAT THE DATA RECORD FROM TAPE CONTAINS AN INTEGRAL NUMBER
C OF JREC1'S. 
C 
      IMOD=MOD(LEN-HDSZ,JREC1)
      IF (IMOD .EQ. 0) GO TO 1499 
      CALL DBER2(LU1,7777,NAMR,6HSETN2 ,2HXX) 
      GO TO 3000
C****************************************************************** 
C DO DBPUTS FROM THE BUFR. BY INCREMENTING INDEX, YOU'RE
C EFFECTIVELY UNPACKING THE DATA SINCE DBPUT TAKES ITS DATA FROM
C SUCCESSIVELY HIGHER LOCATIONS IN THE BUFR.
C 
1499  INDEX=HDSZ+1
1500  CALL DBPUT(IBASE,NAMR,1,ISTAT,BUF1,BUFR(INDEX)) 
      CALL DBER2(LU1,ISTAT,NAMR,6HSETN2 ,6HDBLO9 )
      INDEX=INDEX+JREC1 
      IF (INDEX .EQ. LEN+1) GO TO 1000
      IF (INDEX .GT. LEN) 
     +CALL DBER2(LU1,7777,NAMR,6HSETN2 ,6HDBLO9 ) 
      GO TO 1500
C******************************************************************** 
C DATA SET IS AUTOMATIC IN THE NEW SCHEMA.
C 
2000  CONTINUE
      CALL REIO(2,LU1,32H DATA SET IS AUTOMATIC MASTER: _,16) 
      CALL REIO(2,LU1,NAMR,3) 
C********************************************************************** 
C DO A FORWARD FILE ON TAPE.
C 
3000  CALL REIO(2,LU1,21H SKIPPING DATA SET: _,-21) 
      CALL REIO(2,LU1,NAMR,3) 
      GO TO 9000
C*****************************************************************
C HAD A BAD FILEHEAD. 
C 
4000  CONTINUE
      CALL REIO(2,LU1,36H SKIPPING AN IRRECOVERABLE DATA SET.,18) 
      GO TO 9000
C**************************************************************** 
C SKIP THE DATA SET.
C 
9000  CONTINUE
      IERR=0
      CALL FF(LU1,TAPE,BUFR,BUFSZ,IERR) 
      RETURN
      END 
C 
C 
C 
      SUBROUTINE ADJST(LU1,IBASE,NAMR,JREC1,JREC2,BUF1,IERR)
     +,92069-16128 REV.1912 790126
C***************************************************************
C ADJST RETURNS BUF1 AS FOLLOWS:
C 1) N (MAX NUMBER OF ITEMS FROM DATA SET NAMR WHOSE LENGTHS SUM
C      TO LESS THAN OR EQUAL JREC1) 
C 2) ABSOLUTE VALUE OF FIRST ITEM NUMBER. 
C 3) ABSOLUTE VALUE OF SECOND ITEM NUMBER.
C : 
C N+1) ABSOLUTE VALUE OF NTH ITEM NUMBER. 
C 
C JREC1 = LENGTH OF ONE RECORD FROM TAPE. 
C JREC2 = LENGTH OF AN ENTRY IN THE DATA SET NAMED NAMR.
C 
C LENGTH = RUNNING LENGTH OF ITEMS
C INDEX  = WHICH CONSECUTIVE ITEM IN NAMR YOU'RE CURRENTLY ON.
C ITEMLN = LENGTH OF ONE SUBITEM. 
C ITEMCT = NUMBER OF SUBITEMS MAKING UP ONE ITEM. 
C TEMPLN = TOTAL LENGTH OF THIS ITEM (ITEMLN*ITEMCT)
C**************************************************************** 
C PARAMETER DECLARATIONS. 
C 
      INTEGER LU1,IBASE(1),NAMR(1),JREC1,JREC2,BUF1(1),IERR 
C****************************************************************** 
C LOCAL VARIABLES.
C 
      INTEGER ISTAT(10),TEMP(13)
      INTEGER LENGTH,INDEX,ITEMLN,ITEMCT,TEMPLN 
C*****************************************************************
C GET ITEM NUMBERS FOR ENTIRE SET INTO BUF1.
C 
      CALL DBINF(IBASE,NAMR,104,ISTAT,BUF1) 
      IF (ISTAT .NE. 0) GO TO 2000
C*************************************************************
C TAKE ABSOLUTE VALUES OF ALL ITEM NUMBERS. 
C 
      DO 50 L=2,BUF1+1
      BUF1(L)=IABS(BUF1(L)) 
50    CONTINUE
C*************************************************************
C BRANCH ACCORDING TO RELATION OF JREC1 TO JREC2. 
C 
      IF (JREC1 .EQ. JREC2) RETURN
      IF (JREC1 .GT. JREC2) GO TO 1000
      IF (JREC1 .LT. JREC2) GO TO 1500
      CALL DBER2(LU1,7777,NAMR,6HADJST ,6HDBLO9 ) 
C*************************************************************
C TAPE RECORD .GT. DATA ENTRY.
C 
1000  CONTINUE
      CALL REIO(2,LU1,39H TRUNCATING DATA RECORDS FOR DATA SET _,-39) 
      CALL REIO(2,LU1,NAMR,3) 
      RETURN
C***************************************************************
C TAPE RECORD .LT. DATA ENTRY. WANT TO USE AS MUCH OF TAPE RECORD AS
C POSSIBLE, SO SET BUF1(1) TO USE AS MANY ITEMS AS  POSSIBLE
C WITHOUT EXCEEDING THE LENGTH OF A TAPE RECORD.
C 
1500  CONTINUE
      CALL REIO(2,LU1,41H DATA RECORD SMALLER THAN ENTRY FOR SET _,-41) 
      CALL REIO(2,LU1,NAMR,3) 
      LENGTH=0
      INDEX=2 
1550  CONTINUE
      CALL DBINF(IBASE,BUF1(INDEX),102,ISTAT,TEMP)
      IF (ISTAT .NE. 0) GO TO 2000
      TEMPLN=TEMP(10)*TEMP(11)
C*************************************************************
C IF ASCII ITEM, ITS BYTE LENGTH SO DIVIDE BY 2 
C 
      IF (TEMP(9) .EQ. 2HX ) TEMPLN=TEMPLN/2
      IF (LENGTH + TEMPLN .GT. JREC1) GO TO 1600
C***********************************************************
C NOT DONE YET, SO INCR AND LOOP. 
C 
      LENGTH = LENGTH +TEMPLN 
      INDEX=INDEX+1 
      GO TO 1550
C************************************************************ 
C HIT HERE YOU KNOW INDEX IS ONE TOO MANY.
C 
1600  CONTINUE
      BUF1=INDEX-1
      IF (BUF1 .GT. 0) RETURN 
C***********************************************************
C ERROR IN THAT EVEN THE FIRST ITEM IS BIGGER THAN THE TAPE RECORD. 
C 
      CALL REIO(2,LU1,33H DATA RECORD SMALLER THAN ITEM 1_,-33) 
      CALL REIO(2,LU1,14H IN DATA SET _,7)
      CALL REIO(2,LU1,NAMR,3) 
      IERR=-243 
      CALL DBER2(LU1,IERR,NAMR,6HADJST ,2HXX) 
      RETURN
C***************************************************************
C ERROR POINTS
C 
2000  CONTINUE
      CALL DBER2(LU1,ISTAT,NAMR,6HADJST ,2HXX)
      IERR=-ISTAT 
      RETURN
      END 
C 
C 
C 
      PROGRAM DBLO9(5,90) 
     +,92069-16128 REV.2013 790927
C******************************************************************** 
C DBLO9 CLOSES THE DATA BASE AND STOPS. 
C******************************************************************** 
C COMMON DECLARATIONS.
C 
C 
      INTEGER LU1(6),TAPE(6),ROOT(6),LVLWD(6),P5(6) 
      INTEGER BUF1(256),BUF1SZ
      INTEGER LENGTH
      INTEGER IBASE(12) 
      INTEGER HDR(24) 
      COMPLEX HDR1(6) 
      EQUIVALENCE (HDR,HDR1)
      INTEGER TDCB(144),TDSZ
      COMMON LU1,TAPE,ROOT,LVLWD
      COMMON BUF1,BUF1SZ
      COMMON LENGTH 
      COMMON IBASE
      COMMON/TPHDR/HDR,TDCB,TDSZ,P5 
C*****************************************************************
C LOCAL VARIABLES 
C 
      INTEGER ISTAT(10) 
C****************************************************************** 
C CLOSE THE DATA BASE.
C 
      CALL DBCLS(IBASE,IDUMY,1,ISTAT) 
      CALL DBER2(LU1,ISTAT,ROOT,6HDBLO9 ,2HXX)
      CALL ECLOS(TDCB)
9999  END