C @(#)wtape.for	19.1 (ES0-DMD) 02/25/03 14:32:28
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) 1989  European Southern Observatory
C.LANGUAGE     VAX/VMS FORTRAN
C.IDENT        wtape.for
C.AUTHOR       P.Grosbol   ESO/IPG
C.KEYWORDS     copy file to tape, write tape
C.ENVIRON      VAX/VMS
C.PURPOSE      copy FITS file in byte stream format to mag. tape
C.VERSION      1.0  1989-Mar-12 : Creation,   PJG
C--------------------------------------------------------------------
      PARAMETER     (MBUF=31680,NFLR=2880)
C
      LOGICAL*1     BUF(MBUF)
C
      LOGICAL       FITS
      INTEGER       NO,NOF,N,REC,NR,DEN
      INTEGER       MB,IDX,NB,I,BF,FDO
      INTEGER       DEFLIST,GETLIST,IOWRITE,IOOPEN,IOWEOF
      CHARACTER*9   SIMPLE
      CHARACTER*64  LIST,APP,OUTPUT,PREFIX,INPUT
C
      SIMPLE(1:9) = 'SIMPLE  ='
C
C     READ PARAMETERS
C
      WRITE(6,601)
  601 FORMAT(' Name of output tape unit   : ',$)
      READ(5,500) OUTPUT
  500 FORMAT(A)
      WRITE(6,602)
  602 FORMAT(' Prefix on FITS filename    : ',$)
      READ(5,500) PREFIX
      IPF = INDEX(PREFIX,' ') - 1
      WRITE(6,603)
  603 FORMAT(' List of file no. to copy   : ',$)
      READ(5,500) LIST
      IF (DEFLIST(LIST).NE.0)  THEN
         WRITE(6,690)
  690    FORMAT(' Error: Invalid list specification')
         GOTO 90000
      ENDIF
      WRITE(6,604)
  604 FORMAT(' Append file to tape (Y/N)  : ',$)
      READ(5,500) APP
      WRITE(6,605)
  605 FORMAT(' Tape density in bpi        : ',$)
      READ(5,*) DEN
C
C     GET BLOCKING FACTOR AND CHECK IT
C
      WRITE(6,606)
  606 FORMAT(' FITS blocking factor (1-10): ',$)
      READ(5,*) BF
      BF = MAX( 1 , MIN( 10, BF ) ) * NFLR
C
C     OPEN MAG. TAPE UNIT
C
      FDO = IOOPEN(OUTPUT,1,DEN)
      IF (FDO.LE.0) THEN
         WRITE(6,691)
  691    FORMAT(' Error: Cannot open mag. tape unit')
         GOTO 90000
      ENDIF
C
C     POSITION TAPE
C
      IF (APP(1:1).NE.'n'.AND.APP(1:1).NE.'N') THEN ! move to end of tape
         WRITE(6,692)
  692    FORMAT(' Files will be appended to tape!')
         N = IOREAD(FDO,BUF,BF)
         IF (N.LE.0) THEN
            WRITE(6,693)
  693       FORMAT(' Warning: Tape was empty!')
            CALL IOBSF(FDO,1)
         ELSE                                     ! not empty - skip to end
  300       CONTINUE
            CALL IOFSF(FDO,1)
            N = IOREAD(FDO,BUF,BF)
            IF (N.GT.0) GOTO 300
            CALL IOBSF(FDO,1)                     ! position between EOF's
         ENDIF
      ENDIF
C
C     COPY FILE BY FILE
C
 1000 IF (GETLIST(NOF).EQ.0) GOTO 5000
         WRITE(INPUT,610) PREFIX(1:IPF),NOF
  610    FORMAT(A,I4.4,'.mt')
         IIP = INDEX(INPUT,' ') - 1
         OPEN(UNIT=10,FILE=INPUT(1:IIP),RECORDTYPE='FIXED',
     ,        ACCESS='SEQUENTIAL',FORM='UNFORMATTED',
     ,        STATUS='OLD',IOSTAT=IOS)
         IF (IOS.NE.0) GOTO 1000
         INQUIRE(UNIT=10,RECL=MNO)
         MNO = 4 * MNO
         REC = 0
         IDX = 1
         NR = 0
         MB = MBUF - NFLR
 2000    CONTINUE                                 ! copy block by block
           LIDX = IDX + MNO - 1
           READ(10,END=2005) (BUF(I),I=IDX,LIDX)
           NO = MNO
           GOTO 2010
 2005      NO = 0
 2010      CONTINUE
           NR = NR + 1
      print *,'Block read ',NR,IDX,NO
           IF (NR.EQ.1.AND.NO.GT.0) THEN          ! check if FITS file
              FITS = .TRUE.
              DO 2100, I = 1,9
                 FITS = FITS .AND. BUF(I).EQ.ICHAR(SIMPLE(I:I))
 2100         CONTINUE
              IF (.NOT.FITS) THEN                 ! no FITS file - skip
                 WRITE(6,695) INPUT(1:IIP)
  695            FORMAT(' Error: >',A,'< not FITS format - skipped!')
                 CLOSE(10)
                 GOTO 1000
              ENDIF
           ENDIF
           IF (NO.GT.0) IDX = IDX + NO
           IF (BF.LT.IDX .OR. NO.LE.0) THEN     ! write block to tape
              NB = 1
              N = ((IDX-1)/NFLR) * NFLR
              N = MIN( BF, N )
 3000         IF (N.LT.1.OR.N.GT.IDX-NB) GOTO 4000
                 I = IOWRITE(FDO,BUF(NB),N)
      print *,'Block to tape ',REC,I,NB
                 IF (I.LT.0) THEN               ! End of tape reached
                    CALL IOBSF(FDO,1)
                    CALL IOWEOF(FDO)
                    CLOSE(10)
                    WRITE(6,696)
  696               FORMAT(' Warning: End of tape MARK detected!')
                    CALL IOCLOSE(FDO)
                    GOTO 90000
                 ENDIF
                 NB = NB + I
                 REC = REC + 1
              GOTO 3000
 4000         CONTINUE
              N = IDX - 1
              IDX = 1
              DO 2300, I = NB,N
                 BUF(IDX) = BUF(I)
                 IDX = IDX + 1
 2300         CONTINUE
           ENDIF
         IF (NO.GT.0) GOTO 2000
         CLOSE(10)
         IF (REC.GT.0) THEN
            I = IOWEOF(FDO)
            WRITE(6,630) INPUT(1:IIP),REC
  630       FORMAT(' File >',A,'< written to tape with ',I5,' records')
         ENDIF
      GOTO 1000
C
C     FINISHED - CLOSE FILES AND EXIT
C
 5000 CONTINUE
      CALL IOWEOF(FDO)
      CALL IOBSF(FDO,1)
90000 CONTINUE
      END
