C @(#)rtape.for	17.1.1.1 (ES0-DMD) 01/25/02 17:57:38
C===========================================================================
C Copyright (C) 1995 European Southern Observatory (ESO)
C
C This program is free software; you can redistribute it and/or 
C modify it under the terms of the GNU General Public License as 
C published by the Free Software Foundation; either version 2 of 
C the License, or (at your option) any later version.
C
C This program is distributed in the hope that it will be useful,
C but WITHOUT ANY WARRANTY; without even the implied warranty of
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public 
C License along with this program; if not, write to the Free 
C Software Foundation, Inc., 675 Massachusetss Ave, Cambridge, 
C MA 02139, USA.
C
C Corresponding concerning ESO-MIDAS should be addressed as follows:
C	Internet e-mail: midas@eso.org
C	Postal address: European Southern Observatory
C			Data Management Division 
C			Karl-Schwarzschild-Strasse 2
C			D 85748 Garching bei Muenchen 
C			GERMANY
C===========================================================================
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C.COPYRIGHT    (c) 1988  European Southern Observatory
C.LANGUAGE     VAX/VMS FORTRAN
C.IDENT        rtape.for
C.AUTHOR       P.Grosbol   ESO/IPG
C.KEYWORDS     read tape, copy tape to disk
C.ENVIRON      VAX/VMS
C.PURPOSE      copy tape to disk files in fix block format
C.COMMENT      Fix block file format is used only because it is more
C              efficient on a VAX/VMS system!!
C              Size could be increased from 512 to 1024 or larger.
C.VERSION      1.0  1989-Mar-16 : Creation,   PJG
C--------------------------------------------------------------------
      PARAMETER     (MBUF=32000,IBZ=1024,NBZ=IBZ/4)
C
      LOGICAL*1     BUF(MBUF)
C
      INTEGER       NO,NOF,N,REC,NOL,NPF
      INTEGER       MB,IDX,NB,I,FDI
      INTEGER       DEFLIST,GETLIST
      INTEGER       IOOPEN,IOCLOSE,IOREAD,IOREW,IOFSF
      CHARACTER*80  INPUT,PREFIX,LIST,OUTPUT
C
C     READ INPUT PARAMETERS
C
      WRITE(6,600)
  600 FORMAT(' Name of input tape unit   : ',$)
      READ(5,500) INPUT
  500 FORMAT(A)
      WRITE(6,602)
  602 FORMAT(' Prefix on output filename : ',$)
      READ(5,500) PREFIX
      NPF = INDEX(PREFIX,' ') - 1
      WRITE(6,604)
  604 FORMAT(' List of file no. to copy  : ',$)
      READ(5,500) LIST
C
C     CHECK IF LIST VALID
C
      IF (DEFLIST(LIST).NE.0) THEN
         WRITE(6,690)
  690    FORMAT(' Error: Invalid list of file no''s')
         GOTO 90000
      ENDIF
C
C     OPEN AND POSITION TAPE DRIVE
C
      FDI = IOOPEN(INPUT,0,1600)
      IF (FDI.LE.0) THEN
         WRITE(6,691)
  691    FORMAT(' Error: cannot open mag. tape')
         GOTO 90000
      ENDIF
      CALL IOREW(FDI)
      NOL = 1
 1000 IF (GETLIST(NOF).EQ.0) GOTO 4000
        IF (NOL.LT.NOF) THEN
           NO = NOF - NOL
           DO 1100, I = 1,NO
              N = IOREAD(FDI,BUF,IBZ)
              IF (N.LE.0) THEN
                 WRITE(6,692)
  692            FORMAT(' Warning: End of Information detected')
                 CALL IOREW(FDI)
                 GOTO 90000
              ENDIF
              CALL IOFSF(FDI,1)
 1100      CONTINUE
        ELSE IF (NOF.LT.NOL) THEN
           WRITE(6,693)
  693      FORMAT(' Error: List NOT ascending')
           GOTO 90000
        ENDIF
C
C     GET NEW FILE NAME
C
        WRITE(OUTPUT,610) PREFIX(1:NPF),NOF
  610   FORMAT(A,I4.4,'.mt')
C
C     INITIATE COUNTERS FOR REDING FILE
C
        REC = 0
        IDX = 1
        MB = MBUF - IBZ
C
C     READ BLOCK BY BLOCK
C
 2000   CONTINUE
          NO = IOREAD(FDI,BUF(IDX),MB)
C
C     NO MORE DATA IN THIS FILE - EOF
C
          IF (NO.LE.0) THEN
             IF (REC.NE.0) GOTO 3000
             WRITE(6,694)
  694        FORMAT(' Warning: End of Information detected on tape')
             GOTO 4000
          ENDIF
C
C     CREATE FILE FOR DATA
C
          IF (REC.EQ.0) THEN
             NBYTE = 0
             OPEN(UNIT=10,FILE=OUTPUT,FORM='UNFORMATTED',
     ,            ORGANIZATION='SEQUENTIAL',ACCESS='SEQUENTIAL',
     ,            RECL=NBZ,RECORDTYPE='FIXED',
     ,            STATUS='UNKNOWN',ERR=2900)
             GOTO 2100
 2900        WRITE(6,695)
  695        FORMAT(' Error: Output file cannot be created!')
             GOTO 90000
          ENDIF
C
 2100     CONTINUE
          REC = REC + 1
          NBYTE = NBYTE + NO
          IDX = IDX + NO
          DO 2200, N = 1,IDX,IBZ
             NB = N + IBZ - 1
             IF (NB.LT.IDX) THEN
                WRITE(10) (BUF(I),I=N,NB)
                NEXT = NB + 1
             ENDIF
 2200     CONTINUE
C
C     MOVE THE REST OF BUFFER TO THE START
C
          NO = IDX - 1
          IDX = 1
          DO 2300, I = NEXT,NO
             BUF(IDX) = BUF(I)
             IDX = IDX + 1
 2300     CONTINUE
        GOTO 2000
C
C     EOF DETECTED - WRITE REMAINING DATA TO DISK
C
 3000   CONTINUE
        IF (IDX.GT.1) THEN 
          DO 3100, N = 1,IDX,IBZ
             NB = MIN(N+IBZ-1,IDX-1)
             WRITE(10) (BUF(I),I=N,NB)
 3100     CONTINUE
        ENDIF
        NOL = NOF + 1
        CLOSE(10)
        BYTE = FLOAT(NBYTE)/(1024.0*1024.0)
        WRITE(6,630) BYTE,REC,OUTPUT(1:32)
  630   FORMAT(1X,F7.2,' Mbyte in ',I4,' records copied to file: ',A)
      GOTO 1000
C
C     FINISH READING - CLOSE AND EXIT
C
 4000 CONTINUE
90000 CONTINUE
      CALL IOCLOSE(FDI)
      END