FTN4,L
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-18130
C     RELOC:     92069-16130
C 
C 
C****************************************************************:
C 
C 
      PROGRAM DBUP()
     +,92069-16130 REV.1912 790425
C***********************************************************
C DBUP BACKS UP A 92063 DATA BASE TO A STORAGE DEVICE.
C IT TRANSFERS ALL THE MEANINGFUL DATA FROM A 92063 DATA BASE TO
C A STORAGE DEVICE IN A FORMAT SUITABLE FOR THE 92069 DBLOX PROGRAM 
C TO LOAD IT INTO A 92069 DATA BASE. THIS IS THE PROCESS USED TO
C UPGRADE FROM A 92063 DATA BASE TO A 92069 DATA BASE.
C 
C 1.FILE &DBUP CONTAINS ALL THE CODE SPECIFIC TO THE DBUP PROGRAM.
C 2.FILE %DBUP CONTAINS THE COMPILED VERSION OF &DBUP.
C 3.FILE *DBUP CONTAINS %DBUP PLUS CERTAIN RELOCATABLE SUBROUTINES
C       FROM THE IMAGE LIBRARY THAT DBUP USES. IN THIS WAY, THE USER
C       ONLY HAS TO SEARCH THE 92063 IMAGE LIBRARY WHEN HES LOADING 
C       THE PROGRAM, AND DOESNT HAVE TO SEARCH THE 92069 IMAGE LIBRARY. 
C 
C THE MAIN PROGRAM DOES THE FOLLOWING:
C 1) DOES A GETST 
C 2) CALLS IN SEGMENT DBUP1.
C 
C DBUP1 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 DBUP2.
C 
C DBUP2 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 DBUP3.
C 
C DBUP3 DOES THE FOLLOWING: 
C 1) CLOSES THE DATA BASE.
C 2) ENDS THE PROGRAM.
C 
C 
C RUN STRING: 
C :RU,DBUP,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 DATA STATEMENTS.
C 
C******************************************************************** 
C START PROCESSING HERE.
C 
      BUF1SZ=256
      CALL GETST(BUF1,BUF1SZ,LENGTH)
C************************************************************** 
C LOAD IN SEGMENT 1.
C 
      CALL EXEC(8,6HDBUP1 ) 
C***************************************************************
C DUMMY CALLS TO MAKE SURE THEY GET RELOCATED WITH THE MAIN.
C 
      CALL DBINT(IDUMY) 
      CALL STPLU(IDUMY) 
      HDR(1)=IDUMY
      CALL OPENF(IDUMY) 
      CALL REIO(IDUMY)
C**************************************************************** 
      END 
C 
C 
C 
C 
      SUBROUTINE OPENF(TDCB,IERR,TAPE,IOPTN,ISECU,ICR,TDSZ) 
     +,92069-16130 REV.1912 790126
C*************************************************************
C OPENF IS USED TO SIMULATE THE SESSION MONITOR OPENF ROUTINE.
C IF THE STORAGE DEVICE IS ACTUALLY A TAPE DRIVE (NOT A TYPE 3 FILE), 
C OPENF OPENS THE TYPE 0 FILE NAMED MT THAT SHOULD EXIST ON 
C A CARTRIDGE ACCESSIBLE TO THE USER. 
C*****************************************************************
      INTEGER TDCB,IERR,TAPE(1),IOPTN,ISECU,ICR,TDSZ
      IF (TAPE(4) .EQ. 1) GO TO 1000
      IF (TAPE(4) .EQ. 3) GO TO 3000
C**************************************************************** 
C OPEN UP THE TYPE 0 FILE TO THE TAPE DRIVE.
C 
1000  CONTINUE
      CALL OPEN(TDCB,IERR,6HMT    ,IOPTN) 
      IF (IERR .GT. 0) IERR=0 
      CALL DBER2(LU1,IERR,6HMT    ,6HOPENF ,2HXX) 
      RETURN
C****************************************************************** 
C OPEN UP THE TYPE 3 FILE.
C 
3000  CONTINUE
      CALL OPEN(TDCB,IERR,TAPE,IOPTN,ISECU,ICR,TDSZ)
      IF (IERR .GT. 0) IERR=0 
      CALL DBER2(LU1,IERR,TAPE,6HOPENF ,2HXX) 
      RETURN
      END 
C 
C 
C 
C 
      PROGRAM DBUP1(5,90) 
     +,92069-16130 REV.1912 790324
C*****************************************************************
C DBUP1 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 DBUP2.
C 
C**************************************************************** 
C COMMON DECLARATIONS.
C 
      INTEGER LU1(6),TAPE(6),ROOT(6),LVLWD(6),P5(6) 
      INTEGER BUF1(256),BUF1SZ
      INTEGER LENGTH
      INTEGER TOTAL 
      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 ILIST(13) 
      INTEGER ISTAT(10) 
      INTEGER SETNUM
C*************************************************************
C DATA STATEMENTS.
C 
      DATA ILIST/4,2HDB,2HUP,2H  ,
     +             2HDB,2HUP,2H1 ,
     +             2HDB,2HUP,2H2 ,
     +             2HDB,2HUP,2H9 /
C*************************************************************
C GET THE PARAMETERS. 
C 
      LU=LOGLU(IDUMY) 
      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 (IF STORAGE IS TAPE UNIT).
C 
      CALL STPLU(LU1) 
      IF (IERR .LT. 0) STOP 
      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 OPEN THE DATA BASE. 
C 
      CALL DBINT(ROOT,IABS(ROOT(5)),ILIST,ISTAT)
      CALL DBER2(LU1,ISTAT,ROOT,6HDBUP1 ,2HAB)
      IMODE=3 
      ISECU=IABS(ROOT(5)) 
      CALL DBOPN(ROOT,LVLWD,ISECU,IMODE,ISTAT)
      CALL DBER2(LU1,ISTAT,ROOT,6HDBUP1 ,6HDBUP9 )
C*************************************************************
C DB OPENED SUCCESSFULLY. BUILD UP AND WRITE THE TAPEHEADER.
C 
C GET TOTAL NUMBER OF DATA SETS INTO TOTAL
C 
      CALL TOTL3(LU1,IERR,TOTAL,BUF1) 
      IF (IERR .LT. 0) CALL EXEC(8,6HDBUP9 )
C*************************************************************
C GET NUMBER OF MANUALS AND DETAILS INTO SETNUM.
C 
      SETNUM=0
      DO 100 J=1,TOTAL
      CALL DBINF(2HS ,2,J,BUF1) 
      CALL DBER2(LU1,ISTAT,6HXXXXXX,6HDBUP1 ,6HDBUP9 )
      IF (BUF1(5) .EQ. 101B) GO TO 100
      SETNUM=SETNUM+1 
100   CONTINUE
C************************************************************ 
C IF SETNUM=0 THERE ARE NO MANUALS OR DETAILS.
C 
      IF (SETNUM .EQ. 0) GO TO 9000 
C************************************************************** 
C BUILD THE TAPEHEADER. (SAME FORMAT AS FOR DBULX. SEE TECH SPECS)
C 
      HDR1(1)=8HDBUNLOAD
      HDR1(2)=8H21XX
C 
      DO 10 J=1,6 
      HDR(J+8)=ROOT(J)
10    CONTINUE
C 
      HDR(20)=SETNUM
      HDR(21)=1 
      HDR(24)=2H**
C***********************************************************
C CREATE THE STORAGE FILE (IF STORAGE IS TO FILE) (DELAY
C CREATION TILL HERE IN CASE IT HAS TO BE PURGED.)
C 
      IF (TAPE(4) .EQ. 3) 
     +CALL NWFIL(LU1,IERR,TDCB,TDSZ,TAPE,-1,3,P5(2))
      IF (IERR .NE. 0) CALL EXEC(8,6HDBUP9 ,1)
C******************************************************** 
C OPEN THE STORAGE FILE, BE IT TAPE OR FILE.
C 
      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,6HDBUP1 ,2HXX) 
      IF (IERR .NE. 0) CALL EXEC(8,6HDBUP9 ,1)
C*************************************************************
C WRITE OUT THE TAPEHEADER. 
C 
      CALL TAPEW(LU1,TAPE,HDR,24,IERR)
      IF (IERR .NE. 0) CALL EXEC(8,6HDBUP9 ,1)
C************************************************************ 
C LOAD IN NEXT SEGMENT. 
C 
      CALL EXEC(8,6HDBUP2 ) 
C********************************************************** 
C NO DATA IN THE DATA BASE. 
C 
9000  CALL EXEC(2,LU1,26HNO DATA IN THE DATA BASE. ,13) 
      CALL DBER2(LU1,217,ROOT,6HDBUP1 ,2HXX)
      CALL EXEC(8,6HDBUL9 ,1) 
      END 
C 
C 
C 
C 
      SUBROUTINE NWFIL(LU1,IERR,IDCB,IDCBSZ,NAMR,JBLK,ITYPE,IABORT) 
     +,92069-16130 REV.1912 790126
C*********************************************************************
C NWFIL CREATES A NEW FILE NAMED NAMR, OF SIZE ISIZE, AND TYPE ITYPE. 
C 
C IABORT = 'AB' TO RETURN NEGATIVE ERROR ON DUPLICATE FILE. 
C        = ANYTHING ELSE TO ATTEMPT PURGE OF DUPLICATE FILE BEFORE CREATE.
C 
C NAMR =
C 1)1ST TWO CHARACTERS OF NAMR
C 2)2ND TWO CHARS 
C 3)3RD TWO CHARS 
C 4)3 
C 5)SECURITY CODE 
C 6)CARTRIDGE NUMBER
C 
C BLK  = DOUBLE INTEGER SIZE OF THE NEW FILE ON DISC. 
C JBLK = DOUBLE INTEGER SIZE OF FILE REQUESTED BY CALLING PROGRAM.
C********************************************************************** 
C PARAMETER DECLARATIONS
C 
      INTEGER LU1,IERR,IDCB(1),IDCBSZ,NAMR(1),JBLK,ITYPE,IABORT 
      REAL BLK
C     DOUBLE INTEGER BLK
C******************************************************************** 
C MAKE SURE ITS A NAMR PARAMETER, GET ISECU AND ICR 
C 
      IF (NAMR(4) .NE. 3) CALL DBER2(LU1,7777,NAMR,6HNWFIL ,2HAB) 
      ISECU=NAMR(5) 
      ICR=NAMR (6)
C****************************************************************** 
C SEE IF YOU SHOULD SKIP THE PURGE. 
C 
      IF (IABORT .EQ. 2HAB) GO TO 100 
      CALL PURGE(IDCB,IERR,NAMR,ISECU,ICR)
      IF (IERR .GE. 0) IERR=0 
      IF (IERR .EQ. -6) GO TO 100 
      CALL DBER2(LU1,IERR,NAMR,6HNWFIL ,2HXX) 
      IF (IERR .LT. 0) RETURN 
C*****************************************************************
C CREATE THE NEW FILE WITH INFO PASSED IN.
C 
100   CALL CREAT(IDCB,IERR,NAMR,JBLK,ITYPE,ISECU,ICR,IDCBSZ,BLK)
      IF (IERR .GE. 0) IERR=0 
      CALL DBER2(LU1,IERR,NAMR,6HNWFIL ,2HXX) 
      RETURN
      END 
C 
C 
C 
C 
      SUBROUTINE TOTL3(LU1,ISTAT,TOTAL,BUF1)
     +,92069-16130 REV.1912 790126
C**************************************************************** 
C TOTL3 RETURNS THE TOTAL NUMBER OF DATA SETS AN THE DATA BASE
C IN PARAMETER TOTAL. IT USES BUF1 AS A UTILITY BUFFER. 
C**************************************************************** 
      INTEGER LU1,ISTAT(1),TOTAL,BUF1(1)
      DO 10 J=1,51
      CALL DBINF(2HS ,2,J,BUF1) 
      IF (BUF1(1) .NE. 0) GO TO 1000
10    CONTINUE
C******************************************************** 
C ERROR OCCURRED ON JTH DATA SET, SO TOTAL=J-1
C 
1000  TOTAL=J-1 
D     WRITE(LU1,1005) TOTAL 
D1005 FORMAT(/"TOTL3: TOTAL DATA SETS = ",I6) 
      ISTAT=0 
      RETURN
      END 
C 
C 
C 
C 
      PROGRAM DBUP2(5,90) 
     +,92069-16130 REV.1912 790228
C****************************************************************** 
C DBUP2 DOES THE FOLLOWING: 
C 
C 1) WRITES THE DATA FROM ALL MANUAL AND DETAIL DATA SETS TO TAPE.
C 2) LOADS IN SEGMENT DBUP9.
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 TOTL3(LU1,ISTAT,TOTAL,BUF1)
      IF (ISTAT .NE. 0) CALL EXEC(8,DBUP9 ,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,ISTAT) 
      IF (ISTAT .NE. 0) CALL EXEC(8,6HDBUP9 ,1) 
20    CONTINUE
C***************************************************************
C EVERYTHING'S HUNKY-DORY.
C 
      WRITE(LU1,1000) 
1000  FORMAT(//"DBUP: DATA BASE UNLOAD COMPLETE."//)
      CALL EXEC(8,6HDBUP9 ) 
      END 
C 
C 
C 
C 
C**************************************************************** 
C SPECIAL SETW2 ONLY USED BY DBUP 
C**************************************************************** 
      SUBROUTINE SETW2(LU1,TAPE,IBASE,K,BUFR,BUFSZ,ISTAT) 
     +,92069-16130 REV.1912 790425
C**************************************************************** 
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 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 
C NOTE 4-25-79. BUFR IS NOW PASSED IN AS A PARAMETER TO THE LNGTH 
C SUBROUTINE. SINCE LNGTH DESTROYS ANY INFO THAT MIGHT BE IN BUFR,
C THE CALL TO LNGTH MUST OCCUR IN THE BEGINNING OF SETW2, BEFORE
C ANY IMPORTANT INFO IS PLACED IN BUFR. 
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,ISTAT(1)
      INTEGER BUF3(17)
      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 ISTAT, MAKE SURE ITS NOT AUTOMATIC. 
C NOTE: 101B = 0 IN BITS 15-8 AND AN ASCII A IN BITS 7-0. 
C 
      CALL DBINF(2HS ,2,K,BUF3) 
      IF (BUF3(1) .NE. 0) GO TO 8900
      IF (BUF3(5) .EQ. 101B) RETURN 
C*****************************************************************
C EXTRACT NEEDED INFO FROM BUF3.
C 
      DO 10 L=1,3 
      NAME(L)=BUF3(L+1) 
10    CONTINUE
C********************************************************************** 
C JREC2 CONTAINS BOTH THE MEDIA RECORD LENGTH AND THE DATA RECORD LENGTH. 
C 
      JREC2=BUF3(7) 
      CALL LNGTH(LU1,ISTAT,JREC2,JREC,K,BUFR) 
      IF (ISTAT .NE. 0) RETURN
      ENTRY(1)=2H** 
      ENTRY(2)=2H** 
C************************************************************** 
C WRITE OUT A FILEHEADER. 
C 
      CALL FLHD2(LU1,TAPE,NAME,FILENO,JREC,ENTRY,ISTAT) 
      IF (ISTAT .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,ISTAT)
      IF (ISTAT .NE. 0) RETURN
C**************************************************************** 
C INITIALIZE DATA SET TO FIRST SEQUENTIAL RECORD. 
C 
      CALL DBGET(NAME,3,ISTAT,IDUMY,0)
      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,K,BUFR,BUFSZ,INDEX,JREC,EOF,ISTAT) 
      IF (ISTAT .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,ISTAT) 
      IF (ISTAT .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,ISTAT)
      RETURN
C***************************************************************
C ERROR POINTS FOLLOW.
C 
C ERROR ON DBINF CALL.
C 
8900  CONTINUE
      ISTAT=BUF3(1) 
9000  CALL DBER2(LU1,ISTAT,6HXXXXXX,6HSETW2 ,2HXX)
      IERR=-ISTAT 
      RETURN
      END 
C 
C 
C 
C 
C***********************************************************
C THIS VERSION IS FOR THE DBUP PROGRAM. 1-3-79. 
C***********************************************************
      SUBROUTINE FILL2(LU1,IBASE,K,BUFR,BUFSZ,INDEX,JREC,EOF,IERR)
     +,92069-16130 REV.1912 790126
C****************************************************************** 
C FILL2 FILLS BUFR WITH AS MUCH DATA FROM DATA SET K 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 JREC2= TOTAL LENGTH OF RECORD INCLUDING MEDIA RECORD. 
C EOF  = RETURNED TRUE WHEN EOF IS FOUND. 
C K    = DATA BASE SET NUMBER 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) 
      INTEGER NAME(3) 
C*****************************************************************
C GET TOTAL RECORD LENGTH INTO JREC2. 
C 
      CALL DBINF(2HS ,2,K,ISTAT)
      IF (ISTAT(1) .NE. 0) GO TO 9100 
      NAME(1)=ISTAT(2)
      NAME(2)=ISTAT(3)
      NAME(3)=ISTAT(4)
      JREC2=ISTAT(7)
      IOFF=JREC2-JREC 
C****************************************************************** 
C CHECK IF NOT EVEN ONE RECORD FITS.
C 
D     IF (JREC2 .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 
100   CONTINUE
      CALL DBGET(NAME,2,ISTAT,BUFR(INDEX+1))
      IF (ISTAT(2) .EQ. 0) GO TO 9000 
      IF (ISTAT(1) .NE. 0) GO TO 9100 
C*************************************************************
C MOVE THE DATA RECORD DOWN TO COVER THE MEDIA RECORD.
C 
      DO 200 L=1,JREC 
      BUFR(INDEX+L)=BUFR(INDEX+L+IOFF)
200   CONTINUE
C*****************************************************************
C BUMP INDEX. 
C 
      INDEX=INDEX+JREC
      IF (JREC2 .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,6HXXXXXX,6HFILL2 ,2HXX)
      IERR=-ISTAT 
      RETURN
      END 
C 
C 
C 
C 
      SUBROUTINE LNGTH(LU1,ISTAT,JREC2,JREC,K,BUF3) 
     +,92069-16130 REV.1912 790126
C***************************************************************
C LNGTH RETURNS THE LENGTH OF THE DATA RECORD FOR DATA SET K IN 
C PARAMETER JREC. BUF3 IS A UTILITY BUFFER AND JREC2 IS PASSED
C IN AS THE LENGTH OF THE ENTIRE DATA RECORD (MEDIA + DATA RECORD)
C***************************************************************
      INTEGER LU1,ISTAT(1),JREC2,JREC,K,BUF3(1) 
C************************************************************ 
C GET THE DATA ITEM NUMBERS OF ITEMS IN SET K.
C 
      CALL DBINF(2HI ,1,K,BUF3) 
      IF (BUF3(1) .NE. 0) GO TO 9000
      ITEM1=IABS(BUF3(3)) 
C*********************************************************
C FIND THE OFFSET OF THE FIRST ITEM.
C 
      CALL DBINF(2HI ,2,ITEM1,BUF3) 
      IF (BUF3(1) .NE. 0) GO TO 9000
      IOFF=BUF3(8)
      JREC=JREC2-IOFF+1 
      RETURN
C******************************************************** 
C ERROR POINT 
C 
9000  CONTINUE
      ISTAT=BUF3(1) 
      CALL DBER2(LU1,ISTAT,6HXXXXXX,6HLNGTH ,2HXX)
      RETURN
      END 
C 
C 
C 
C 
C*********************************************************
C IMPORTANT NOTE: THIS IS A SPECIALIZED TAPEW THAT SHOULD ONLY
C BE RELOCATED WITH DBUP. IT IS NOT THE SAME TAPEW THAT APPEARS 
C IN THE 92069 IMAGE LIBRARY. 
C****************************************************** 
      SUBROUTINE TAPEW(LU1,TAPE,BUFR,BUF1,IERR) 
     +,92069-16130 REV.1912 790305
C******************************************************************** 
C TAPEW WRITES DATA TO TAPE FROM BUFR. TAPEW ASSUMES THAT TDCB
C (IN NAMED COMMON) IS OPEN TO TAPE AS A TYPE 0 FILE IF TAPE IS A MAG 
C TAPE LU, OR AS A TYPE 1 FILE IF TAPE IS A DISC FILE.
C 
C TAPEW CHECKS FOR AN EOF AT THE END OF EACH WRITE, AND PROMPTS THE 
C USER TO MOUNT A NEW TAPE AT EOT, OR ABORTS AT THE END OF A TYPE 1 
C FILE. 
C IF AN EOT OCCURS, THE RECORD IS WRITTEN ON THIS TAPE, NOT THE 
C NEW TAPE. THEN TAPEW WRITES AN EOF ON THE TAPE AND CALLS EOTWR
C TO PROMPT FOR A NEW TAPE. 
C*********************************************************************
C NAMED COMMON DECLARATIONS 
C 
      INTEGER HDR(24),TDCB(144),TDSZ,P5(6)
      COMMON/TPHDR/HDR,TDCB,TDSZ,P5 
C******************************************************************** 
C FORMAL PARAMETERS.
C 
      INTEGER LU1,TAPE(1),BUFR(1),BUF1,IERR 
C*********************************************************************
C 
      INTEGER BUFL
C 
      BUFL=BUF1 
C 
      IF (IFBRK(IDUMY)) 9876,300
C*********************************************************************
C FOR A 0-LENGTH RECORD TO A TAPE LU, HAVE TO WRITE AN EOF(LENGTH -1) 
C 
300   IF ((BUFL .EQ. 0) .AND. (TAPE(4) .EQ. 1)) BUFL=-1 
C*****************************************************************
C WRITE BUFR TO TAPE USING TDCB.
C 
D     WRITE(LU1,400) BUFL,(BUFR(L),L=1,30)
D400  FORMAT(//"TAPEW: LEN=",I6,4X,12A2,/,18O8) 
      CALL WRITF(TDCB,IERR,BUFR,BUFL) 
C******************************************************** 
C TRAP OUT AN EOF ON A TYPE 3 FILE. 
C 
      IF ((IERR .EQ. -6) .OR. (IERR .EQ. -33)) GO TO 4000 
      CALL DBER2(LU1,IERR,TAPE,6HTAPEW ,2HXX) 
      IF (TAPE(4) .NE. 1) RETURN
C*****************************************************************
C SPECIAL CHECK FOR AN EOT ON THE TAPE DEVICE.
C 
2000  IA=IEOT(TAPE) 
      IF (IA .GE. 0) RETURN 
C************************************************************ 
C END OF TAPE ON A TAPE DEVICE. 
C WRITE EOF ON THIS TAPE(THE RECORD HAS BEEN WRITTEN OVER THE EOT MARK).
C CALL EOTWR TO REQUEST NEW TAPE. 
C RETURN,KNOWING THAT THE NEW TAPE IS READY FOR NEXT WRITE. 
C 
      CONTINUE
      CALL WRITF(TDCB,IERR,IDUMY,-1)
      CALL DBER2(LU1,IERR,TAPE,6HTAPEW ,2HXX) 
      IF (IERR .LT. 0) RETURN 
      CALL EOTWR(LU1,TAPE,HDR,TDCB,TDSZ,P5,IERR)
      RETURN
C*********************************************************
C TRAP FOR THE EOF ON A TYPE 3 FILE.
C PERFORM THESE STEPS:
C 1) CALL EOFWR TO CLOSE THE CURRENT FILE, THEN REQUEST AND OPEN
C THE NEW FILE, WRITE A TAPE HEADER.
C 2) GO TO THE TOP TO WRITE THE DATA RECORD INTO THE NEW FILE.
C 
4000  CONTINUE
      IF (TAPE(4) .NE. 3) CALL DBER2(LU1,7777,6HXXXXXX,6HTAPEW ,2HAB) 
      CALL EOFWR(LU1,TAPE,HDR,TDCB,TDSZ,P5,IERR)
      IF (IERR .NE. 0) RETURN 
      GO TO 300 
C*****************************************************************
C USER ENTERED BREAK COMMAND. 
C 
9876  CONTINUE
      IERR=-247 
      CALL DBER2(LU1,IERR,6HXXXXXX,6HTAPEW ,2HXX) 
      RETURN
      END 
C 
C 
C 
C 
      SUBROUTINE EOTWR(LU1,TAPE,HDR,TDCB,TDSZ,P5,IERR)
     +,92069-16130 REV.1912 790126
C*************************************************************
C EOTWR HANDLES AN EOT FOR A MAG TAPE LU.
C 
C EOTWR ASSUMES THAT THE HEADER PASSED IN IN HDR STILL HAS THE
C REEL NUMBER OF THE OLD TAPE REEL IN HDR(21).
C 
C IF P5=AB, A NEGATIVE ERROR IS RETURNED IN IERR. 
C IF P5 .NE. AB, THE USER IS PROMPTED ON LU1 TO MOUNT A NEW TAPE. 
C************************************************************** 
C FORMAL PARAMETERS 
C 
      INTEGER LU1,TAPE(1),HDR(1),TDCB(1),TDSZ,P5,IERR 
C******************************************************** 
C LOCAL VARIABLES.
C 
      INTEGER RESPON
C************************************************************** 
C 
      IF (TAPE(4) .NE. 1) CALL DBER2(LU1,7777,6HXXXXXX,6HEOTWR ,2HAB) 
      IF (P5 .EQ. 2HAB) GO TO 9000
C************************************************************ 
C REQUEST NEW TAPE BE MOUNTED.
C 
      WRITE(LU1,2510) TAPE,(HDR(L),L=9,11),HDR(21)
2510  FORMAT(//"SAVE TAPE ON LOGICAL DEVICE ",I3," AS ",3A2,1X,I3)
2525  WRITE(LU1,2520) TAPE
2520  FORMAT(/"MOUNT NEXT REEL ON LOGICAL DEVICE ",I3)
      CALL READY(LU1,RESPON,IERR) 
      IF (IERR .LT. 0) GO TO 9000 
C*************************************************************
C BY HERE, YOU KNOW THE USER HAS MOUNTED NEW TAPE AND TYPED YES.
C CHECK THAT THE NEW TAPE IS ALL SET TO GO. 
C 
      CALL TLOCL(LU1,TAPE,IERR) 
      IF (IERR .LT. 0) RETURN 
      CALL RING(LU1,TAPE,2HXX,IERR) 
      IF (IERR .LT. 0) RETURN 
C***********************************************************
C CHECK THAT YOU'RE AT LOAD POINT.
C 
      CALL SOT(LU1,TAPE,P5,IERR)
      IF (IERR .LT. 0) GO TO 9000 
C***************************************************
C BY HERE, YOU KNOW THAT NEW TAPE HAS BEEN MOUNTED. 
C 
3000  CONTINUE
      IERR=0
      HDR(21)=HDR(21)+1 
      CALL WRITF(TDCB,IERR,HDR,24)
      CALL DBER2(LU1,IERR,TAPE,6HEOTWR ,2HXX) 
D     WRITE(LU1,3005)(HDR(L),L=1,24)
D3005 FORMAT(/"EOTWR:",12A2,/,12O8) 
      RETURN
C************************************************************ 
C ABORT AT EOT. 
C 
9000  WRITE(LU1,9005) 
9005  FORMAT(/"ABORTING AT END OF TAPE.") 
      CALL DBER2(LU1,236,6HXXXXXX,6HEOTWR ,2HXX)
C     REWIND THE TAPE AND DESTROY IT.(USER MAY HAVE REMOVED IT.)
      IERR=-236 
      RETURN
      END 
C 
C 
C 
C 
      SUBROUTINE EOFWR(LU1,TAPE,HDR,TDCB,TDSZ,P5,IERR)
     +,92069-16130 REV.1912 790126
C**************************************************************** 
C EOFWR HANDLES AN EOF ON A WRITE TO A TYPE 3 FILE. 
C EOFWR DOES THESE STEPS: 
C 1) CALLS LOCF TO DETERMINE THE NEXT AVAILABLE RECORD (EOFWR 
C    ASSUMES THAT LOCF RETURNS THE NEXT AVAILABLE RECORD IF THE 
C    LAST WRITE RETURNED AN ERROR I.E. THAT THE LAST THING EWRIT DOES 
C    IS UPDATE THE INFORMATION ON THE RECORD NUMBER). 
C 2) POSITIONS THE FILE TO THE NEXT AVAILABLE RECORD NUMBER.
C 3) WRITES AN EOF MARK IN THIS POSITION, AND CLOSES THE FILE.
C 4) PROMPTS THE USER FOR ANOTHER FILE NAME.
C 5) CREATES A NEW FILE WITH THE NAME AND CARTRIDGE SPECIFIED THAT
C    TAKES UP THE ENTIRE REST OF THE CARTRIDGE (A DIFFERENT CARTRIDGE 
C    THAN THE PREVIOUS ONE SINCE THERE'S NO ROOM LEFT ON THAT ONE.) 
C 6) OPENS THE FILE AND WRITES A TAPE HEADER INTO THE FILE. 
C*****************************************************************
      INTEGER LU1,TAPE(1),HDR(1),TDCB(1),TDSZ,P5,IERR 
C*****************************************************************
C LOCAL VARIABLES.
C 
      INTEGER IREC(2) 
      INTEGER FILE(20)
      DOUBLE PRECISION MESS1(6) 
      INTEGER MESS2(18) 
      EQUIVALENCE(MESS1,MESS2)
C****************************************************************** 
C DATA STATEMENTS 
      DATA MESS1/6H SAVE ,6HFILE  ,6H      ,6H  AS  ,6H      ,6H      / 
C****************************************************************** 
      IF (TAPE(4) .NE. 3) CALL DBER2(LU1,7777,6HXXXXXX,6HEOFWR ,2HXX) 
C*******************************************************************
C CALL LOCF TO GET WHERE THE LAST WRITE WAS ATTEMPTED.
C 
      CALL LOCF(TDCB,IERR,IREC) 
      CALL DBER2(LU1,IERR,TAPE,6HEOFWR ,2HXX) 
C*****************************************************************
C POSITION THE FILE TO WHERE THE WRITE SHOULD HAVE OCCURRED.
C 
      CALL RWNDF(TDCB,IERR) 
      CALL POSNT(TDCB,IERR,IREC,1)
      CALL DBER2(LU1,IERR,TAPE,6HEOFWR ,2HXX) 
C************************************************************ 
C WRITE OUT AN EOF. 
C 
      CALL WRITF(TDCB,IERR,IDUMMY,-1) 
      CALL DBER2(LU1,IERR,TAPE,6HEOFWR ,2HXX) 
      CALL POST(TDCB,IERR)
      CALL CLOSE(TDCB,IERR) 
      CALL DBER2(LU1,IERR,TAPE,6HEOFWR ,2HXX) 
      IF (IERR .LT. 0) RETURN 
C****************************************************************** 
C TELL USER TO REMEMBER THE OLD FILE. 
C 
      MESS2(7)=TAPE(1)
      MESS2(8)=TAPE(2)
      MESS2(9)=TAPE(3)
      MESS2(13)=HDR(9)
      MESS2(14)=HDR(10) 
      MESS2(15)=HDR(11) 
      CALL CNUMD(HDR(21),MESS2(16)) 
      CALL EXEC(2,LU1,MESS1,18) 
C*******************************************************************
C REQUEST THE NEXT FILE NAME. 
C 
1000  CALL EXEC(2,LU1,34HNEXT STORAGE FILE(AB TO ABORT) ? _,17) 
      CALL REIO(1,LU1+400B,FILE,20) 
      CALL ABREG(IA,IB) 
      LNGTH2=2*IB 
      IF ((LNGTH2 .EQ. 2) .AND. (FILE(1) .EQ. 2HAB)) GO TO 9000 
      ISTRC1=1
      CALL PRAM(LU1,FILE,LNGTH2,ISTRC1,TAPE)
      IF (TAPE(4) .EQ. 3) GO TO 2000
      CALL EXEC(2,LU1,28HPLEASE SPECIFY A FILE NAME. ,14) 
      GO TO 1000
C************************************************************** 
C HAVE A GOOD FILE NAME. MAKE A NEW FILE AND OPEN IT. 
C 
2000  CONTINUE
      CALL NWFIL(LU1,IERR,TDCB,TDSZ,TAPE,-1,3,P5) 
      IF (IERR .LT. 0) GO TO 1000 
      IOPTN=100B
      CALL OPENF(TDCB,IERR,TAPE,IOPTN,TAPE(5),TAPE(6),TDSZ) 
      IF (IERR .GT. 0) IERR=0 
      CALL DBER2(LU1,IERR,TAPE,6HEOFWR ,2HXX) 
      IF (IERR .LT. 0) GO TO 1000 
C***************************************************************
C WRITE OUT A TAPE HEADER ON THE NEW FILE.
C 
      HDR(21)=HDR(21)+1 
      CALL WRITF(TDCB,IERR,HDR,24)
      CALL DBER2(LU1,IERR,TAPE,6HEOFWR ,2HXX) 
      RETURN
C*****************************************************************
C ABORT POINT.
C 
9000  CONTINUE
      IERR=-235 
      CALL EXEC(2,LU1,24HABORTING AT END OF FILE.,12) 
      CALL DBER2(LU1,235,TAPE,6HEOFWR ,2HXX)
      RETURN
      END 
C 
C 
C 
C 
      PROGRAM DBUP9(5,90) 
     +,92069-16130 REV.1912 790317
C*******************************************************************
C DBUP9 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) 
      INTEGER REC,XIRB,IOFF,SECTRS,JLU,JTY,JREC,ITRUNC
C************************************************************ 
C IF THE SCHEDULING PARAMETER IS 1, PURGE THE STORAGE FILE. 
C 
      CALL RMPAR(ISTAT) 
      IFLAG=ISTAT(1)
      ISTAT=0 
C*****************************************************************
C CLOSE THE DATA BASE 
C 
      CALL DBCLS(0,ISTAT) 
      CALL DBER2(LU1,ISTAT,ROOT,6HDBUP9 ,2HXX)
      IF (IFLAG .EQ. 1) GO TO 9000
C*************************************************************
C CALCULATE THE NUMBER OF BLOCKS TO ITRUNCATE FROM THE STORAGE FILE.
C FOR A TYPE 0 FILE, ITRUNC IS IGNORED. 
C 
      CALL LOCF(TDCB,IERR,REC,XIRB,IOFF,SECTRS,JLU,JTY,JREC)
      ITRUNC=SECTRS/2-XIRB-1
      IF (TAPE(4) .EQ. 3) CALL CLOSE(TDCB,IERR,ITRUNC)
      IF (TAPE(4) .EQ. 1) CALL CLOSE(TDCB)
      IF (IERR .GE. 0) IERR=0 
      IF (IERR .EQ. -11) GO TO 9999 
      CALL DBER2(LU1,IERR,TAPE,6HDBUP9 ,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