PROGRAM LISTFITS
C----------------------------------------------------------------------
C   This VAX FORTRAN-77 program lists the headers of the files of a 
C   FITS tape. It also prints the number of blocks in each file, and 
C   compares the number with the number which can be predicted from 
C   the BITPIX and NAXISn values given in the first header block in
C   each file. The program terminates on double-tapemark. It uses the 
C   SYS$TRNLOG scheme to permit it to list from either tape or disk. 
C   The logical name of the input is INFIL. The program checks for
C   proper formatting of the required keywords.
C   DCW, NRAO-CV, 04Jan82.
C----------------------------------------------------------------------
      INTEGER*4         STATUS, SYS$TRNLOG, SS$_NORMAL, SS$_NOTRAN
      INTEGER*4         BITPIX, NAXIS, NAXISN(7), NB, MB, MR
      LOGICAL*2         HEADER
      CHARACTER         INNAM*63, DEVTYP*4, INCLS*4, BLOCK*2880
      CHARACTER         SIMPLE*30, NNAXIS*6
C
      DATA               SS$_NORMAL /1/, SS$_NOTRAN /'00000629'X/
C
C
      LO = 6
      OPEN (UNIT=LO, FILE='FITS.LIS', STATUS='NEW', DISPOSE='PRINT')
C                                       Is input tape, or disk?
      STATUS = SYS$TRNLOG ('INFIL', LC, INNAM, , , )
      IF (STATUS.EQ.SS$_NORMAL) GO TO 1
         IF (STATUS.EQ.SS$_NOTRAN) WRITE (LO, *)  'INFIL not ASSIGNed!'
         IF (STATUS.NE.SS$_NOTRAN) WRITE (LO, *) 
     *      'Unexpected STATUS returned by SYS$TRNLOG! STATUS=', STATUS
         GO TO 999
 1    CONTINUE
      DEVTYP = INNAM(1:2)
      IF (DEVTYP(1:1).EQ.'_') DEVTYP = INNAM(2:3)
      INCLS = 'DISK'
C                                       MF = TU78; 
C                                       MM = 6250 bpi drives @ NRAO;
C                                       MS = TS-11;
C                                       MT = TE16, TU45, or TU77:
      IF ((DEVTYP.EQ.'MF') .OR. (DEVTYP.EQ.'MM') .OR. (DEVTYP.EQ.'MS')
     *                     .OR. (DEVTYP.EQ.'MT')) INCLS = 'TAPE'
      WRITE (LO, *) 'INFIL=', ''''//INNAM(1:LC)//''',',
     *              'Device_Class=', INCLS
      IF (INCLS.EQ.'DISK') OPEN (UNIT=1, FILE=INNAM,
     *                           STATUS='OLD', READONLY)
      IF (INCLS.EQ.'TAPE') OPEN (UNIT=1, FILE=INNAM,
     *                           STATUS='OLD', READONLY,
     *                          ACCESS='SEQUENTIAL', FORM='FORMATTED',
     *                    RECORDTYPE='FIXED', RECL=2880, BUFFERCOUNT=2)
C
C
      REWIND 1
      NF = 0
C
 10   CONTINUE
      NF = NF + 1
      NR = 0
      NH = 0 
      HEADER = .TRUE.
      WRITE (LO, 1010) NF
      WRITE (LO, 1013) ((J, I = 1, 9), J+1, J = 0, 7)
      WRITE (LO, 1013) ((I, I = 1,9), 0, J = 1,8)
      WRITE (LO, 1016)
C
 20   CONTINUE
      READ (1, 1020, END=100) BLOCK
      NR = NR + 1
      IF (.NOT.HEADER) GO TO 20
      NH = NH + 1
C
      DO 30 K = 1,36
            KC = (K - 1) * 80 + 1
            WRITE (LO, 1025) NH, K, BLOCK(KC:KC+79)
 30         CONTINUE
C
      IF (NR.GT.1) GO TO 70
C                                    Analyze contents of first block:
      SIMPLE = 'SIMPLE  =                    T'
      IF (BLOCK(1:30).EQ.SIMPLE) GO TO 40
            WRITE (LO, *) ' First card of header is not of the form:'
            WRITE (LO, 1025) 1, 1, SIMPLE
            WRITE (LO, *) 
     *            ' Therefore, this is not a standard FITS header!'
            GO TO 70
C                                    Compute number blocks for matrix:
 40   CONTINUE
      IF (BLOCK(81:90).NE.'BITPIX  = ') WRITE (LO, *) 
     *                  'BITPIX keyword defective!'
      READ (BLOCK, 1040, ERR=70) BITPIX, NAXIS, (NAXISN(I), I=1,NAXIS)
      NB = BITPIX / 8
      IF ((NB.EQ.1) .OR. (NB.EQ.2) .OR. (NB.EQ.4)) GO TO 50
            WRITE (LO, *) ' Illegal BITPIX:', BITPIX
            STOP 40
 50   CONTINUE
      IF (BLOCK(161:170).NE.'NAXIS   = ') WRITE (LO, *)
     *                  'NAXIS keyword defective!'
      MB = 0
      IF (NAXIS.GT.0) MB = NB
      DO 60 I = 1,NAXIS
            KC = I * 80 + 161
            NNAXIS = 'NAXIS' // CHAR (ICHAR ('0') + I)
            IF (BLOCK(KC:KC+9).NE.(NNAXIS // '  = ')) WRITE (LO, *)
     *            NNAXIS, ' keyword defective!'
            MB = MB * NAXISN(I)
 60         CONTINUE
      MR = (MB + 2879) / 2880
C                                    Look for END card:
 70   CONTINUE
      DO 80 I = 1, 2880, 80
            IF (BLOCK(I:I+7).NE.'END     ') GO TO 80
                  HEADER = .FALSE.
                  GO TO 90
 80         CONTINUE
 90   CONTINUE
C                                    Loop back for next block:
      GO TO 20
C                                    Here on tapemarks:
 100  CONTINUE
      WRITE (LO, *) ' Tapemark number', NF, ' seen.'
      IF (NR.GT.0) GO TO 110
            WRITE (LO, *) ' No blocks seen = double-tapemark.'
            GO TO 999
 110  CONTINUE
      IF (HEADER) WRITE (LO, *) 
     *            ' This header does not contain an END card!'
      WRITE (LO, *) NR, ' data blocks seen:'
      WRITE (LO, *) NH, ' header blocks.'
      WRITE (LO, *) (NR-NH), ' binary blocks.'
      IF ((NR-NH).LT.MR) WRITE (LO, *) ' We expected to see', MR,
     *                              ' matrix blocks!'
      IF ((NR-NH).GT.MR) WRITE (LO, *) (NR-NH-MR),
     *                  ' of the binary blocks are "special records"!'
      IF ((NR-NH).EQ.MR) WRITE (LO, *) 
     *                        ' No "special records" were seen.'
      GO TO 10
C
 999  CONTINUE
      WRITE (LO, '(''1'')')
      STOP
C----------------------------------------------------------------------
 1010 FORMAT ('1Listing of header of FITS file', I4, ':', /)
 1013 FORMAT (' ', 4X, ' ', 2X, '  ', 80I1)
 1016 FORMAT (' ', 4X, ' ', 2X, '  ', 80('-'))
 1020 FORMAT (A2880)
 1025 FORMAT (' ', I4, '/', I2.2, ': ', A80)
 1040 FORMAT (80X, 9(10X, I20, 50X))
      END