FTN4
      PROGRAM DBSTR(4,90),92069-16125 REV.2013 790514 
C***************************************************************
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-18125
C     RELOC:     92069-16125
C 
C 
C****************************************************************:
C 
C 
C DBSTR SAVES A DATA BASE FROM DISC FILES TO MAG TAPE.
C IT SAVES THE ROOT FILE AND ALL DATA SETS SECTOR BY SECTOR.
C 
C RUN SEQUENCE: 
C :RU,DBSTR,LU1,TAPE,ROOT,LVLWD,ABORT 
C 
C WHERE:
C 
C LU1 = INTERACTIVE CONSOLE LU
C TAPE= TAPE LU AT WHICH TO SAVE DATA 
C ROOT= ROOT FILE NAMR OF DATA BASE TO BE SAVED.
C LVLWD= HIGHEST LEVEL WORD DEFINED FOR DATA BASE.
C ABORT= WHETHER TO ABORT OR NOT ON EOT 
C 
C LU1, TAPE, ROOT,LVLWD AND P5 ARE ARRAYS THAT LOOK LIKE THIS:
C 1. INTEGER LU OR FIRST TWO CHARACTERS 
C 2. 0 OR SECOND TWO CHARACTERS 
C 3. 0 OR THIRD TWO CHARACTERS
C 4. TYPE. 0=NULL, 1=INTEGER, 3=ASCII NAMR
C 5. SECURITY CODE IF NAMR(FORCED TO A NEGATIVE NUMBER) 
C 6. CARTRIDGE NUMBER IF NAMR 
C 
C LU= LU THAT SCHEDULED PROGRAM(USED IF LU1 IS NONINTERACTIVE)
C 
C VARIABLES IN NAMED COMMON(DECLARED IN MAIN AND SUBROUTINE TAPEW): 
C HDR = TAPE AND REELHEADER THAT TAPEH PRINTS OUT.
C TDCB = DCB THAT TAPEW USES TO WRITE DATA. 
C TDSZ = SIZE OF TDCB.
C 
C 
C SET= NAMR OF DATA SET YOU'RE CURRENTLY SAVING 
C SETNUM = TOTAL NUMBER OF DATA SETS IN DATA BASE( NOT COUNTING ROOT) 
C 
C RTDCB=DCB USED TO READ ROOT FILE TO GET INFO AS NEEDED. 
C BUF1= BUFFER USED TO HOLD DATA FROM ROOT FILE TO LOOK AT. 
C       BUF1 IS 256 (NOT 128) IN CASE AN ELEMENT FROM THE 
C       ROOT FILE 'SPILLS OVER' FROM ONE 128-WORD RECORD
C       INTO THE NEXT 128-WORD RECORD.
C BUFR= LARGE BUFFER USED TO HOLD DATA FROM DISC FILES IN TRANSIT 
C       TO MAG TAPE.
C************************************************************** 
C COMMON DECLARATIONS.
C 
      INTEGER LU1(6),TAPE(6),ROOT(6),LVLWD(6),P5(6) 
      INTEGER HDR(24) 
      COMPLEX HDR1(6) 
      EQUIVALENCE (HDR,HDR1)
      INTEGER TDCB(144),TDSZ
C***************************************************************
      COMMON/TPHDR/HDR,TDCB,TDSZ,P5 
C***************************************************************
C LOCAL VARIABLES.
C 
      INTEGER LU,RTDCBS,BUFSZ 
      INTEGER STRING(40),LENGTH 
      INTEGER BUFR(2072),RTDCB(144) 
      INTEGER BUF1(256),BUF1SZ
      INTEGER SET(6),SETNUM 
      DATA RTDCBS/128/,BUFSZ/2072/
      DATA BUF1SZ/256/
C**************************************************************** 
C GET THE SCHEDULING LU TO USE IN CASE LU1 IS BAD.
C RETRIEVE AND-OR DEFAULT THE RUN PARAMETERS. 
C 
      LU=LOGLU(IDUMY) 
      CALL STPLU(LU)
      CALL GETST(BUF1,BUF1SZ,LENGTH)
      CALL GTPRN(LU,LU1,TAPE,ROOT,LVLWD,P5,BUF1,LENGTH,IERR)
      IF (IERR .LT. 0) STOP 
C****************************************************************** 
C CHANGE THE LU THE STOP MESSAGES WILL GO TO. 
C 
      CALL STPLU(LU1) 
C*****************************************************************
C BRANCH ON WHETHER TAPE IS A DISC FILE OR A TAPE LU. 
C 
      IF (TAPE(4) .EQ. 3) 
     +CALL NWFIL(LU1,IERR,TDCB,TDSZ,TAPE,DBLEI(-1),3,P5(2)) 
      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 ROOT FILE EXCLUSIVELY( VERIFIES QUIET DATA BASE), CHECK
C SECURITY CODE WITH CALL TO OPEN1. 
C 
      CALL OPEN1(LU1,ROOT,RTDCB,RTDCBS,IERR)
      IF (IERR .LT. 0) STOP 
C**************************************************************** 
C READ RECORD 1 AND VERIFY THAT ITS A ROOT FILE.
C 
      CALL EREAD(RTDCB,IERR,BUF1) 
      CALL DBER2(LU1,IERR,ROOT,6HDBRSX ,2HXX) 
      IF (IERR .LT. 0) GO TO 9500 
C 
      IF ((BUF1(1) .EQ. 3) .OR. (BUF1(1) .EQ. 4)) GO TO 70
      CALL DBER2(LU1,116,ROOT,6HDBRSX ,2HXX)
      GO TO 9500
C 
70    IF ((BUF1(4) .GE. 1) .AND. (BUF1(4) .LE. 17)) GO TO 80
      CALL DBER2(LU1,116,ROOT,6HDBRSX ,2HXX)
      GO TO 9500
C**************************************************************** 
C VERIFY THE LEVEL WORD 
C 
80    CALL LEVEL(LU1,RTDCB,ROOT,BUF1,LVLWD,IERR)
      IF (IERR .LT. 0) GO TO 9500 
C**************************************************************** 
C GET NUMBER OF DATA SETS INTO SETNUM 
C 
      CALL SETNO(LU1,RTDCB,ROOT,BUF1,SETNUM,IERR) 
      IF (IERR .LT. 0) GO TO 9500 
C************************************************************** 
C OPEN THE DCB TO THE TAPE DEVICE.
C TYPE 0 FILE IF TAPE = MAG TAPE LU.
C TYPE 3 FILE IF TAPE = DISC 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,6HDBST2 ,2HXX) 
      IF (IERR .LT. 0) GO TO 9500 
C*****************************************************************
C SET UP TAPE HEADER IN COMMON BEFORE WRITING IT OUT. 
C 
      HDR1(1)=8HDBSTORE 
      HDR1(2)=8H21XX
      DO 210 J=1,6
      HDR(J+8)=ROOT(J)
210   CONTINUE
C****************************************************************** 
      HDR(17)=LVLWD(1)
      HDR(18)=LVLWD(2)
      HDR(19)=LVLWD(3)
      HDR(20)=SETNUM
      HDR(21)=1 
      HDR(24)=2H**
C**************************************************************** 
C WRITE OUT TAPE HEADER.
C 
      CALL TAPEW(LU1,TAPE,HDR,24,IERR)
      IF (IERR .LT. 0) GO TO 9000 
C****************************************************************** 
C CLOSE ROOT FILE TO RTDCB, THEN WRITE IT OUT TO TAPE. (SETW DOES 
C AN EXCLUSIVE OPEN WITH ITS OWN DCB).
C 
      CALL ECLOS(RTDCB,IERR)
      IF(IERR .GT. 0) IERR = 0
      CALL DBER2(LU1,IERR,TAPE,6HDBST2 ,2HXX) 
      IF (IERR .LT. 0) GO TO 9000 
      CALL SETW(LU1,TAPE,ROOT,0,BUFR,BUFSZ,IERR)
      IF (IERR .LT. 0) GO TO 9000 
C****************************************************************** 
C OPEN UP THE ROOT FILE TO RTDCB AGAIN. 
C 
      CALL OPEN1(LU1,ROOT,RTDCB,RTDCBS,IERR)
      IF (IERR .LT. 0) GO TO 9000 
C****************************************************************** 
C GET THE NAMR FOR THE JTH DATA SET INTO SET, THEN CALL SETW TO 
C WRITE THE DATA SET OUT TO MAG TAPE. 
C 
      DO 100 J=1,SETNUM 
      CALL SETNM(LU1,RTDCB,ROOT,BUF1,J,SET,IERR)
      IF (IERR .LT. 0) GO TO 9000 
      CALL SETW(LU1,TAPE,SET,J,BUFR,BUFSZ,IERR) 
      IF (IERR .LT. 0) GO TO 9000 
100   CONTINUE
C***************************************************************
C PRINT COMPLETION MESSAGE. 
C 
      CALL REIO(2,LU1,27H DATA BASE STORE COMPLETED.,-27) 
C****************************************************************** 
C TIDY UP, AND LEAVE. 
C CALCULATE THE NUMBER OF BLOCKS TO DELETE FROM THE OUTPUT FILE 
C UPON ECLOS (TRUNC IS IGNORED IF IT'S A TYPE 0 FILE BEING CLOSED). 
C TRUNC=BLOCKS-XIRB-1.(THE SMALLER TRUNC IS, THE LARGER THE FILE.)
C 
8000  CONTINUE
      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)))8010,8010,9500 
8010  TRUNC = DBLEI(1)
C************************************************************ 
C CLOSE THE ROOT DCB, TRUNCATE THE STORAGE FILE.
C 
9500  CONTINUE
      CALL ECLOS(RTDCB,IERR)
      IF (TAPE(4) .EQ. 1) CALL ECLOS(TDCB)
      IF (TAPE(4) .EQ. 3) CALL ECLOS(TDCB,IERR,TRUNC) 
      IF(IERR .GT. 0) IERR = 0
      CALL DBER2(LU1,IERR,TAPE,6HDBST2 ,2HXX) 
      GO TO 9999
C**************************************************************** 
C ERROR POINT, PURGE THE DISC STORAGE FILE. 
C 
9000  CONTINUE
      CALL ECLOS(RTDCB,IERR)
      IF (TAPE(4) .EQ. 3) CALL PURGE(TDCB,IERR,TAPE,TAPE(5),TAPE(6))
      GO TO 9999
9999  END 
C 
C 
C 
      SUBROUTINE SETNO(LU1,DCB1,ROOT,BUF1,SETNUM,IERR)
     +,92069-16125 REV.2013 790413
C******************************************************** 
C SETNO RETURNS THE NUMBER OF DATA SETS IN THE DATA BASE
C AS RECORDED IN THE ROOT FILE. 
C DBSCT= DATA BASE SET COUNT OFFSET IN ROOT FILE. 
C START= FIRST RECORD NUMBER IN ROOT FILE PAST OVERHEAD.
C***********************************************************
      INTEGER LU1,DCB(1),ROOT(1),BUF1(1),SETNUM,IERR
      INTEGER START 
      INTEGER DBSCT 
      DATA DBSCT/10/
C***********************************************************
C GET START FROM FIRST WORD OF ROOT FILE. 
C 
      CALL EREAD(DCB1,IERR,BUF1,256,LEN,DBLEI(1)) 
      CALL DBER2(LU1,IERR,ROOT,6HSETNO ,2HAB) 
      IF (IERR .LT. 0) RETURN 
      START=BUF1(1) 
C***********************************************************
C READ THE ROOT FILE TO GET THE NUMBER OF SETS
C 
      CALL EREAD(DCB1,IERR,BUF1,256,LEN,DBLEI(START)) 
      CALL DBER2(LU1,IERR,ROOT,6HSETNO ,2HAB) 
      IF (IERR .LT. 0) RETURN 
      SETNUM=BUF1(DBSCT)
      RETURN
      END 
C 
C 
C 
      SUBROUTINE SETW(LU1,TAPE,NAMR,J,BUFR,BUFSZ,IERR)
     +,92069-16125 REV.2013 790413
C**************************************************************** 
C SETW WRITES A FILE HEADER AND THE CONTENTS OF NAMR FROM A 
C DISC FILE TO A MAG TAPE.
C 
C LU1=INTERACTIVE CONSOLE LU
C TAPE= MAG TAPE LOGICAL UNIT 
C NAMR= THE NAMR TO BE STORED.
C J   = NUMBER OF THE DATA SET YOU'RE WRITING OUT.
C BUFR= LARGE ARRAY USED TO HOLD DATA IN TRANSIT FROM DISC TO TAPE. 
C 
C SETW DOES AN EXCLUSIVE OPEN ON NAMR, USING ITS OWN DCB. AFTER 
C WRITING THE NAMR TO MAG TAPE, IT CLOSES THE DCB AND RETURNS.
C 
C HDSZ = LENGTH OF DATA HEADER. 
C INDEX= POINTER TO LAST FILLED WORD IN BUFR. 
C 
C*****************************************************************
      INTEGER LU1,TAPE(1),NAMR(1),BUFR(1),BUFSZ,IERR
      INTEGER DCB2(272),DCB2SZ
      INTEGER HDSZ
C     DOUBLE INTEGER SETSZ
      INTEGER SETSZ 
      COMPLEX TAPEH4(6) 
      INTEGER TAPEH1(24)
      EQUIVALENCE (TAPEH4(1),TAPEH1(1)) 
      LOGICAL EOF 
      DATA DCB2SZ/256/
      DATA TAPEH4/8HDBSTORE ,8H21XX     ,4*(0.,0.)/ 
C*****************************************************************
C CALL FILEH TO WRITE OUT A FILE HEADER.
C 
      CALL FILEH(LU1,TAPE,NAMR,DCB2,DCB2SZ,J,IERR)
      IF (IERR .LT. 0) RETURN 
C**************************************************************** 
C OPEN NAMR EXCLUSIVELY AS TYPE 1 FILE. 
C SET UP DATA HEADER IN FIRST 24 WORDS OF BUFR (NO WRITE TO TAPE HERE)
C 
      CALL OPEN1(LU1,NAMR,DCB2,DCB2SZ,IERR) 
      IF (IERR .LT. 0) RETURN 
      CALL DATAH(LU1,NAMR,BUFR,BUFSZ,HDSZ,IERR) 
      IF (IERR .LT. 0) CALL DBER2(LU1,7777,6HSETW  ,2HAB) 
      BUFR(17)=1
      EOF=.FALSE. 
      JREC=128
C***************************************************************
C LOOP POINT. INCR BLOCK COUNT AND FILL BUFR FROM INDEX+1.
C SINCE OPEN AS TYPE 1 FILE, RECORD SIZE=128. 
C 
20    CONTINUE
      INDEX=HDSZ
      CALL FILL1(LU1,DCB2,NAMR,BUFR,BUFSZ,INDEX,JREC,EOF,IERR)
      IF (IERR .LT. 0) RETURN 
C**************************************************************** 
C WRITE BUFR OUT TO TAPE. CHECK FOR SPECIAL CASE THAT FILL1 RETURNS 
C A DATA HEADER WITH NO MEANINGFUL INFORMATION (OCCURS IF THE PREVIOUS
C CALL GOT THE LAST RECORD BUT DIDN'T SEE EOF). 
C 
      IF (INDEX .GT. HDSZ) CALL TAPEW(LU1,TAPE,BUFR,INDEX,IERR) 
      IF (INDEX .GT. HDSZ) BUFR(17)=BUFR(17)+1
      IF (IERR .LT. 0) RETURN 
      IF (EOF) GO TO 9999 
      GO TO 20
C**************************************************************** 
C CLOSE THE DCB, WRITE EOF ON TAPE, RETURN. 
C 
9999  CALL ECLOS(DCB2,IERR) 
      CALL DBER2(LU1,IERR,NAMR,6HSETW  ,2HXX) 
      CALL TAPEW(LU1,TAPE,IDUMY,0,IERR) 
      RETURN
      END 
C 
C 
C 
      SUBROUTINE SETNM(LU1,DCB1,ROOT,BUF1,J,SET,IERR) 
     +,92069-16125 REV.2013 790313
C****************************************************** 
C SETNM RETURNS THE NAME, SECURITY CODE, AND CARTRIDGE REF
C NUMBER OF THE JTH DATA SET IN PARAMETER SET. IT ASSUMES 
C THAT DCB1 IS OPEN TO THE ROOT FILE. 
C 
C START= FIRST RECORD IN ROOT FILE PAST THE OVERHEAD. 
C DBSTP=DATA BASE SET TABLE POINTER(POINTS TO SET INFO).
C DSCRN=OFFSET FROM SET INFO THAT CONTAINS ICR FOR THAT SET.
C DSLNG= LENGTH OF ONE SET TABLE ENTRY
C DSSTRT= WORD OFFSET OF START OF DATA SET TABLE. 
C DSNME = OFFSET FOR NAME OF JTH DATA SET.
C 
C ROOT= 6 WORD ROOT FILE PASSED IN BY CALLER. 
C PROG= 3 WORD ARRAY CONTAINING NAME OF THIS SUBR.
C******************************************************** 
C FORMAL PARAMETERS AND LOCAL VARIABLES.
C 
      INTEGER LU1,DCB1(1),ROOT(1),BUF1(1),J,SET(1),IERR 
      INTEGER START 
      INTEGER DBSTP,DSCRN,DSLNG,DSSTRT,DSNME
      DATA DBSTP/11/,DSCRN/4/,DSLNG/17/ 
C*********************************************************
C PUT THE START RECORD NUMBER INTO START. 
C 
      CALL EREAD(DCB1,IERR,BUF1,256,LEN,DBLEI(1)) 
      CALL DBER2(LU1,IERR,ROOT,6HSETNM ,2HXX) 
      IF (IERR .LT. 0) RETURN 
      START=BUF1(1) 
C*********************************************************
C GET THE STARTING OFFSET OF THE SET TABLE INTO DSSTRT. 
C THEN GET THE START ADDRESS FOR THE JTH SET INTO DSNME.
C 
      CALL EREAD(DCB1,IERR,BUF1,256,LEN,DBLEI(START)) 
      CALL DBER2(LU1,IERR,ROOT,6HSETNM ,2HXX) 
      IF (IERR .LT. 0) RETURN 
      DSSTRT=BUF1(DBSTP)+1
      DSNME=DSSTRT+(J-1)*DSLNG
C*********************************************************
C CALCULATE AND READ THE RECORD POINTED AT BY DSNME.
C 
      IREC=START+(DSNME/128)
      IOFF=MOD(DSNME,128) 
      CALL EREAD(DCB1,IERR,BUF1,256,LEN,DBLEI(IREC))
      CALL DBER2(LU1,IERR,ROOT,6HSETNM ,2HXX) 
      IF (IERR .LT. 0) RETURN 
C*******************************************************
C PUT THE NAME AND ICR INTO SET. 
C 
      SET(1)=BUF1(IOFF) 
      SET(2)=BUF1(IOFF+1) 
      SET(3)=BUF1(IOFF+2) 
      SET(4)=3
      SET(6)=BUF1(IOFF+DSCRN-1) 
C*******************************************************
C GET THE SECURITY CODE FROM THE ROOT FILE. 
C 
      SET(5)=ROOT(5)
9999  RETURN
      END 
C 
C 
C 
      SUBROUTINE FILL1(LU1,DCB2,NAMR,BUFR,BUFSZ,INDEX,JREC,EOF,IERR)
     +,92069-16125 REV.2013 790413
C*************************************************************
C FILL1 FILLS BUFR STARTING AT THE NEXT WORD PAST INDEX.
C IT READS RECORDS INTO BUFR USING FILE CALLS THROUGH THE DCB.
C FILL1 ASSUMES THE DCB IS ALREADY OPEN, AND READS RECORDS
C STARTING AT THE CURRENT RECORD POSITION.
C 
C BUFSZ=TOTAL BUFR SIZE 
C INDEX=POSITION OF LAST WORD IN BUFR THATS ALREADY FULL. 
C JREC= WORD LENGTH OF A SINGLE RECORD. 
C EOF = LOGICAL FLAG RETURNED WHEN EOF IS ENCOUNTERED.
C***************************************************************
C 
      INTEGER LU1,BUFSZ,INDEX,JREC,IERR 
      INTEGER DCB2(1),NAMR(1),BUFR(1) 
      LOGICAL EOF 
C************************************************************** 
C MAKE SURE AT LEAST ONE RECORD FITS. 
C 
      IF (JREC .GT. BUFSZ-INDEX)
     +CALL DBER2(LU1,7777,6HXXXXXX,6HFILL1 ,2HAB) 
C************************************************************** 
C START PACKING INTO BUFR 
C 
10    CALL EREAD(DCB2,IERR,BUFR(INDEX+1),JREC,LEN)
      IF (IERR .EQ. -12) GO TO 2000 
      IF (LEN .EQ. -1) GO TO 2000 
C 
      IF (IERR .LT. 0) GO TO 3000 
      INDEX=INDEX+LEN 
      IF (JREC .GT. BUFSZ-INDEX) RETURN 
      GO TO 10
C************************************************************** 
C HANDLE EOF
C 
2000  EOF=.TRUE.
      IERR=0
      RETURN
C********************************************************** 
C CHECKING FOR OTHER NEGATIVE ERRORS. 
C 
3000  CONTINUE
      CALL DBER2(LU1,IERR,NAMR,6HFILL1 ,2HXX) 
      RETURN
      END