FTN4
      PROGRAM DBULD(4,90),92069-16127 REV.2013 790511 
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-18127
C     RELOC:     92069-16127
C 
C 
C****************************************************************:
C 
C 
C***********************************************************
C DBULD BACKS UP A DATA BASE TO MAGNETIC TAPE. IT TRANSFERS 
C ALL THE MEANINGFUL DATA OUT OF THE DATA BASE AND STORES IT
C TO TAPE.
C 
C THE MAIN PROGRAM DOES THE FOLLOWING:
C 1) DOES A GETST 
C 2) CALLS IN SEGMENT DBUL1.
C 
C DBUL1 DOES THE FOLLOWING: 
C 1) RETRIEVES ALL THE PARAMETERS FROM THE RUN STRING.
C 2) CALLS DBOPN TO OPEN THE DATA BASE. 
C 3) CALLS IN SEGMENT DBUL2.
C 
C DBUL2 DOES THE FOLLOWING: 
C 1) WRITES OUT A TAPEHEADER. 
C 2) WRITES ALL THE DATA IN ALL MANUAL AND DETAIL DATA SETS.
C 3) CALLS IN SEGMENT DBUL9.
C 
C DBUL9 DOES THE FOLLOWING: 
C 1) CLOSES THE DATA BASE.
C 2) ENDS THE PROGRAM.
C 
C 
C RUN STRING: 
C :RU,DBULD,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 PARAMETERS. 
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
C***************************************************************
C NAMED COMMON VARIABLES. 
C 
      COMMON/TPHDR/HDR,TDCB,TDSZ,P5 
C****************************************************************** 
C START PROCESSING HERE.
C 
      BUF1SZ=256
      CALL GETST(BUF1,BUF1SZ,LENGTH)
      CALL SEGLX(6HDBUL1 ,LU1)
C***************************************************************
C DUMMY CALLS TO MAKE SURE THEY GET RELOCATED WITH THE MAIN.
C 
777   CALL DBBUF(IDUMY) 
      CALL STPLU(IDUMY) 
      HDR(1)=IDUMY
C**************************************************************** 
      END 
C 
C 
C 
      SUBROUTINE SEGLX(INAME,LU1 ),92069-16127 REV.2013 790927
      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 
C 
      PROGRAM DBUL1(5,90) 
     +,92069-16127 REV.2013 790413
C*****************************************************************
C DBUL1 DOES THE FOLLOWING:
C 
C 1) RETRIEVES ALL THE PARAMETERS FROM THE RUN STRING HELD IN 
C    BUF1 IN COMMON.
C 2) SETS UP TDCB AS A DCB TO WRITE TO THE STORAGE DEVICE(EITHER A
C    A TYPE 0 FILE FOR A MAG TAPE OR A TYPE 3 FILE FOR A FILE). 
C 3) CALLS DBOPN TO OPEN THE DATA BASE. 
C 4) IF OPEN SUCCESSFUL, WRITES OUT A TAPE HEADER.
C 5) LOADS IN SEGMENT DBUL2.
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 SETNUM
C*************************************************************
C GET THE PARAMETERS. 
C 
      LU=LOGLU(IDUMY) 
      CALL STPLU(LU)
      CALL GTPRN(LU,LU1,TAPE,ROOT,LVLWD,P5,BUF1,LENGTH,IERR)
      IF (IERR .NE. 0) STOP 
C***************************************************************
C CHANGE THE LU FOR THE STOP MESSAGES, AND RUN PRELIMINARY CHECKS 
C ON THE TAPE DRIVE (ONLY IF STORAGE IS TO TAPE UNIT).
C 
      CALL STPLU(LU1) 
      IF (TAPE(4) .EQ. 1) CALL TLOCL(LU1,TAPE,IERR) 
      IF (IERR .LT. 0) STOP 
      IF (TAPE(4) .EQ. 1) CALL RING(LU1,TAPE,P5,IERR) 
      IF (IERR .LT. 0) STOP 
C************************************************************** 
C MAKE SURE ITS A ROOT FILE, AND THAT 
C HE HAS THE HIGHEST LEVEL WORD. (USE TDCB TEMPORARILY).
C 
      CALL OPEN1(LU1,ROOT,TDCB,TDSZ,IERR) 
      IF (IERR .LT. 0) STOP 
C 
      CALL EREAD(TDCB,IERR,BUF1)
      CALL DBER2(LU1,IERR,ROOT,6HDBUL1 ,2HXX) 
      IF (IERR .LT. 0) CALL ECLOS(TDCB,IERR)
      IF (IERR .LT. 0) STOP 
C 
      IF ((BUF1(1) .LT. 3) .OR. (BUF1(1) .GT. 4)) GO TO 8900
      IF ((BUF1(4) .LT. 1) .OR. (BUF1(4) .GT. 17)) GO TO 8900 
      CALL LEVEL(LU1,TDCB,ROOT,BUF1,LVLWD,IERR) 
C 
      IF (IERR .LT. 0) STOP 
      CALL ECLOS(TDCB,IERR) 
      IF(IERR .GT. 0) IERR = 0
      CALL DBER2(LU1,IERR,ROOT,6HDBUL1 ,2HAB) 
C**************************************************************** 
C BUILD UP IBASE USING DATA IN ROOT.
C 
      IBASE(1)=2H 
      IBASE(2)=ROOT(1)
      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,6HDBUL1 ,6HDBUL9 )
C*************************************************************
C DB OPENED SUCCESSFULLY. BUILD UP AND WRITE THE TAPEHEADER.
C 
C GET TOTAL NUMBER OF DATA SETS INTO TOTAL
C 
      CALL DBINF(IBASE,IDUMY,203,ISTAT,BUF1)
      CALL DBER2(LU1,ISTAT,6HXXXXXX,6HDBUL1 ,6HDBUL9 )
      TOTAL=BUF1(1) 
C*************************************************************
C GET NUMBER OF MANUALS AND DETAILS INTO SETNUM.
C DONT COUNT IT IF ITS EMPTY. 
C 
      SETNUM=0
      DO 100 J=1,TOTAL
      CALL DBINF(IBASE,J,202,ISTAT,BUF1)
      CALL DBER2(LU1,ISTAT,6HXXXXXX,6HDBUL1 ,6HDBUL9 )
      IF (BUF1(9) .EQ. 2HA ) GO TO 100
      IF ((BUF1(14) .EQ. 0) .AND. 
     +    (BUF1(15) .EQ. 0)) GO TO 100
      SETNUM=SETNUM+1 
100   CONTINUE
C************************************************************ 
C IF SETNUM=0 THERE'S NO DATA IN THE DATA BASE. 
C 
      IF (SETNUM .EQ. 0) GO TO 9000 
C************************************************************** 
C BUILD THE TAPEHEADER. 
C 
      HDR1(1)=8HDBUNLOAD
      HDR1(2)=8H21XX
      DO 200 J=1,6
      HDR(J+8)=ROOT(J)
200   CONTINUE
      HDR(20)=SETNUM
      HDR(21)=1 
      HDR(24)=2H**
C***************************************************************
C CREATE THE STORAGE FILE IF STORAGE IS TO A FILE. (DELAY TILL HERE 
C IN CASE IT HAS TO BE PURGED FOR SOME REASON.) 
C 
      IF (TAPE(4) .EQ. 3) 
     +CALL NWFIL(LU1,IERR,TDCB,TDSZ,TAPE,DBLEI(-1),3,P5(2)) 
      IF (IERR .EQ. 0) GOTO 210 
205   CALL SEGLX(6HDBUL9 ,LU1)
C**************************************************************** 
C OPEN THE DCB TO THE STORAGE DEVICE, BE IT TAPE OR FILE. 
C 
210   CONTINUE
      IOPTN=100B
      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,6HDBUL1 ,2HXX) 
      IF (IERR .NE. 0) GOTO 205 
      IERR=0
C*************************************************************
C WRITE OUT THE TAPEHEADER. 
C 
      CALL TAPEW(LU1,TAPE,HDR,24,IERR)
      IF (IERR .NE. 0) GOTO 205 
C************************************************************ 
C LOAD IN NEXT SEGMENT. 
C 
      CALL SEGLX(6HDBUL2 ,LU1)
C**************************************************************** 
C NOT A ROOT FILE.
C 
8900  CONTINUE
      CALL ECLOS(TDCB,IERR) 
      CALL REIO(2,LU1,17H NOT A ROOT FILE.,-17) 
      CALL DBER2(LU1,216,ROOT,6HDBUL1 ,2HXX)
      STOP
C********************************************************** 
C NO DATA IN THE DATA BASE. 
C 
9000  CALL REIO(2,LU1,26H NO DATA IN THE DATA BASE.,13) 
      CALL DBER2(LU1,217,6HXXXXXX,6HDBUL1 ,2HXX)
      CALL SEGLX(6HDBUL9 ,LU1)
      END 
C 
C 
C 
      PROGRAM DBUL2(5,90) 
     +,92069-16127 REV.2013 790413
C****************************************************************** 
C DBUL2 DOES THE FOLLOWING: 
C 
C 1) WRITES THE DATA FROM ALL MANUAL AND DETAIL DATA SETS TO TAPE.
C 2) LOADS IN SEGMENT DBUL9.
C 
C ASSUMPTIONS:
C 1) DATA BASE IS OPEN TO IBASE, WHICH IS STORED IN COMMON. 
C 2) BUF1 IN COMMON CAN BE USED AS A UTILITY BUFFER.
C 3) TAPEW WAS RELOCATED WITH THE MAIN, SO CALLABLE FROM HERE.
C 
C TOTAL = TOTAL NUMBER OF DATA SETS IN THE DATA BASE. 
C SETNUM= NUMBER OF MANUAL AND DETAIL DATA SETS IN THE DATA BASE. 
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 TOTAL,SETNUM
      INTEGER BUFR(2072),BUFSZ
      INTEGER ISTAT(10) 
      DATA BUFSZ/2072/
C**************************************************************** 
C GET TOTAL NUMBER OF DATA SETS INTO TOTAL. 
C 
      CALL DBINF(IBASE,IDUMY,203,ISTAT,BUF1)
      CALL DBER2(LU1,ISTAT,6HXXXXXX,6HDBUL2 ,6HDBUL9 )
      TOTAL= BUF1(1)
C***************************************************************
C SETW2 WRITES OUT THE DATA SET UNLESS ITS AUTOMATIC. 
C 
      DO 20 K=1,TOTAL 
      CALL SETW2(LU1,TAPE,IBASE,K,BUFR,BUFSZ,IERR)
      IF (IERR .NE. 0) GO TO 9000 
20    CONTINUE
C***************************************************************
C EVERYTHING'S HUNKY-DORY.
C 
      CALL REIO(2,LU1,2H  ,1) 
      CALL REIO(2,LU1,2H  ,1) 
      CALL REIO(2,LU1,28H DATA BASE UNLOAD COMPLETED.,-28)
      CALL SEGLX(6HDBUL9 ,LU1)
C*****************************************************************
C CALL DBUL9 IN SUCH A WAY AS TO PURGE THE STORAGE FILE.
C 
9000  CONTINUE
      CALL SEGLX(6HDBUL9 ,LU1)
      END 
C 
C 
C 
      SUBROUTINE SETW2(LU1,TAPE,IBASE,K,BUFR,BUFSZ,IERR)
     +,92069-16127 REV.2013 790511
C**************************************************************** 
C 11-7-78 MIGHT WNAT TO LET SETW2 DECIDE WHETHER THIS IS A
C AUTOMATIC MASTER AND THEN JUST RETURN, RATHER THAN HAVING HIGHER
C LEVEL DECIDE. 
C 
C SETW2 WRITES THE DATA FROM THE KTH DATA SET TO THE MAG TAPE.
C 
C SETW2 DOES THE FOLLOWING: 
C 
C 1) USES DB CALL TO GET NAME,SIZE, JREC ETC OF DATA SET. 
C 1.5) IF DATA SET K IS AUTOMATIC MASTER, RETURNS.
C 1.6) IF DATA SET K IS EMPTY, RETURNS. 
C 2) CALLS FLHD2 TO WRITE OUT A FILEHEADER. 
C 3) CALLS DTHD2 TO SET UP A DATA HEADER IN BUFR (NO WRITE TO TAPE).
C 4) CALL FILL2 TO FILL UP BUFR USING DB CALLS. 
C 5) CALL TAPEW TO WRITE BUFR TO TAPE.
C 6) CHECK FOR EOF, THEN LOOP OR EXIT.
C 7) SET IERR=0 FOR NORMAL RETURN, IERR= DB ERROR ON ERROR RETURN.
C 
C BUF3 = UTILITY BUFFER TO HOLD INFO RETURNED BY DBGET. 
C ISTAT= STATUS RETURN FROM DB CALLS. 
C NAME = NAME OF KTH DATA SET.
C ENTRY= DOUBLE INTEGER NUMBER OF ENTRY IN DATA SET K.
C 
C FILENO= NUMBER OF DATA SET STORED ON TAPE (K= NUMBER OF SET IN
C         DATA BASE, FILENO= NUMBER OF SET ON TAPE.)
C INDEX = MOVING POINTER OF LAST FULL WORD IN BUFR. 
C HDSZ = LENGTH OF DATA HEADER. 
C 
C******************************************************************** 
      INTEGER LU1,TAPE,IBASE(1),K,BUFR(1),BUFSZ,IERR
      INTEGER BUF3(17)
      INTEGER ISTAT(10) 
      INTEGER NAME(3) 
      INTEGER ENTRY(2)
      INTEGER FILENO
      INTEGER INDEX 
      INTEGER HDSZ
      LOGICAL EOF 
      INTEGER ZERO(2) 
C***************************************************************
C DATA STATEMENTS 
C 
      DATA ZERO/0,0/
      DATA FILENO/1/
C****************************************************************** 
C GET INFO ON DATA SET K INTO BUF3, MAKE SURE ITS NOT AUTOMATIC.
C 
      CALL DBINF(IBASE,K,202,ISTAT,BUF3)
      IF (ISTAT(1) .NE. 0) GO TO 9000 
      IF (BUF3(9) .EQ. 2HA ) RETURN 
C*****************************************************************
C EXTRACT NEEDED INFO FROM BUF3.
C 
      DO 10 L=1,3 
      NAME(L)=BUF3(L) 
10    CONTINUE
      JREC=BUF3(10) 
      ENTRY(1)=BUF3(14) 
      ENTRY(2)=BUF3(15) 
C***************************************************************
C RETURN IF THE DATA SET IS EMPTY.
C 
      IF ((ENTRY(1) .EQ. 0) .AND. (ENTRY(2) .EQ. 0)) RETURN 
C************************************************************** 
C WRITE OUT A FILEHEADER. 
C 
      CALL FLHD2(LU1,TAPE,NAME,FILENO,JREC,ENTRY,IERR)
      IF (IERR .NE. 0) RETURN 
      FILENO=FILENO+1 
C************************************************************** 
C SET UP A DATAHEADER ( NO WRITE TO TAPE), INDEX POINTS TO LAST 
C WORD IN THE HEADER. 
C 
      CALL DTHD2(LU1,NAME,BUFR,BUFSZ,HDSZ,IERR) 
      IF (IERR .NE. 0) RETURN 
C**************************************************************** 
C INITIALIZE DATA SET TO FIRST SEQUENTIAL RECORD. 
C 
      CALL DBGET(IBASE,K,4,ISTAT,0,IDUMY,ZERO)
      IF (ISTAT(1) .NE. 0) GO TO 9000 
C**************************************************************** 
C INIT SOME THINGS AND FILL UP BUFR.
C 
100   EOF=.FALSE. 
      INDEX=HDSZ
      CALL FILL2(LU1,IBASE,NAME,BUFR,BUFSZ,INDEX,JREC,EOF,IERR) 
      IF (IERR .NE. 0) RETURN 
C*************************************************************
C IF YOU DIDN'T GET ANY DATA FROM FILL2, YOURE DONE WITH THIS SET.
C 
      IF (INDEX .EQ. HDSZ) GO TO 2000 
C***************************************************************
C WRITE BUFR OUT TO TAPE. 
C 
      CALL TAPEW(LU1,TAPE,BUFR,INDEX,IERR)
      IF (IERR .NE. 0) RETURN 
      IF (EOF) GO TO 2000 
      GO TO 100 
C************************************************************ 
C FINISHED WITH THIS DATA SET.
C 
2000  CALL TAPEW(LU1,TAPE,DUMMY,0,IERR) 
      RETURN
C***************************************************************
C ERROR POINTS FOLLOW.
C 
9000  CONTINUE
      CALL REIO(2,LU1,23H ERROR FOR DATA SET # _,-23) 
      CALL CNUMD(K,ISTAT(2))
      CALL REIO(2,LU1,ISTAT(2),3) 
      CALL DBER2(LU1,ISTAT,6HXXXXXX,6HSETW2 ,2HXX)
      IERR=-ISTAT 
      RETURN
      END 
C 
C 
C 
      SUBROUTINE FILL2(LU1,IBASE,NAME,BUFR,BUFSZ,INDEX,JREC,EOF,IERR) 
     +,92069-16127 REV.2013 790228
C****************************************************************** 
C FILL2 FILLS BUFR WITH AS MUCH DATA FROM DATA SET NAME AS POSSIBLE 
C WITHOUT EXCEEDING BUFSZ.
C 11-7-78 MAKE SURE THAT JREC PASSED IN IS ONLY THE DATA LENGTH 
C AND DOESN'T INCLUDE THE MEDIA RECORD LENGTH.
C 
C INDEX=MOVING INDEX OF LAST SPOT FILLED IN BUFR. 
C JREC = RECORD LENGTH OF DATA RECORD, NOT INCLUDING MEDIA RECORD.
C EOF  = RETURNED TRUE WHEN EOF IS FOUND. 
C NAME = DATA BASE SET NAME YOURE EXTRACTING DATA FROM. 
C IERR = 0 IF NORMAL RETURN, .NE. 0 IF ERROR RETURN.
C****************************************************************** 
      INTEGER LU1,IBASE(1),K,BUFR(1),BUFSZ,INDEX,JREC,IERR
      LOGICAL EOF 
      INTEGER ISTAT(10) 
C****************************************************************** 
C CHECK IF NOT EVEN ONE RECORD FITS.
C 
D     IF (JREC .GT. BUFSZ-INDEX)
D    +CALL DBER2(LU1,7777,6HXXXXXX,6HFILL2 ,6HDBUL9 ) 
C****************************************************************** 
C START PACKING DATA FROM THE KTH DATA SET INTO BUFR USING SERIAL 
C READS. SET LIST SO THAT DBGET READS THE ENTIRE RECORD.
C 
      LIST=2H@
      IMODE=2 
100   CALL DBGET(IBASE,NAME,IMODE,ISTAT,LIST,BUFR(INDEX+1),IDUMY) 
      IF (ISTAT(1) .EQ. 12) GO TO 9000
      IF (ISTAT(1) .NE. 0) GO TO 9100 
      INDEX=INDEX+JREC
      IF (JREC .GT. BUFSZ-INDEX) RETURN 
      GO TO 100 
C****************************************************************** 
C HIT AN EOF ON ONE OF THE READS. 
C 
9000  EOF=.TRUE.
      IERR=0
      RETURN
C****************************************************************** 
C FATAL DBGET ERROR.
C 
9100  CALL DBER2(LU1,ISTAT,NAME,6HFILL2 ,2HXX)
      IERR=-ISTAT 
      RETURN
      END 
C 
C 
C 
      PROGRAM DBUL9(5,90) 
     +,92069-16127 REV.2013 790413
C*******************************************************************
C DBUL9 CLOSES THE DATA BASE. 
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) 
C**************************************************************** 
C CALL RMPAR TO GET PARAMETERS. (IF PARAMETER 1 = 1 PURGE THE STORAGE 
C FILE) 
      CALL RMPAR(ISTAT) 
      IFLAG=ISTAT(1)
C*****************************************************************
C CLOSE THE DATA BASE 
C 
      CALL DBCLS(IBASE,IDUMY,1,ISTAT) 
      CALL DBER2(LU1,ISTAT,ROOT,6HDBUL9 ,2HXX)
C*************************************************************
C SEE IF YOU SHOULD PURGE THE STORAGE FILE. 
C 
      IF (IFLAG .EQ. 1) GO TO 9000
C************************************************************** 
C CALCULATE THE NUMBER OF BLOCKS TO TRUNCATE FROM THE STORAGE FILE. 
C 
      CALL ELOCF(TDCB,IERR,REC,XIRB,IOFF,SECTRS,JLU,JTY,JREC) 
      BLOCKS=DDI(SECTRS,DBLEI(2)) 
      TRUNC=DSB(DSB(BLOCKS,XIRB),DBLEI(1))
      IF(DCO(TRUNC,DBLEI(0)))10,10,20 
10    TRUNC = DBLEI(1)
20    IF (TAPE(4) .EQ. 3) CALL ECLOS(TDCB,IERR,TRUNC) 
      IF (TAPE(4) .EQ. 1) CALL ECLOS(TDCB)
      IF (IERR .EQ. -11) GO TO 9999 
      IF(IERR .GT. 0) IERR = 0
      CALL DBER2(LU1,IERR,TAPE,6HDBUL9 ,2HXX) 
      GO TO 9999
C**************************************************************** 
C PURGE THE STORAGE FILE. 
C 
9000  CONTINUE
      IF (TAPE(4) .EQ. 3) CALL PURGE(TDCB,IERR,TAPE,TAPE(5),TAPE(6))
      GO TO 9999
9999  END