C @(#)wtape.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) 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