C @(#)tdformat.for	17.1.1.1 (ES0-DMD) 01/25/02 17:47:14
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: Copyright (c) 1987 European Southern Observatory,
C                                         all rights reserved
C
C.VERSION: 1.0  ESO-FORTRAN Conversion, AA  12:01 - 15 DEC 1987
C
C.LANGUAGE: F77+ESOext
C
C.AUTHOR: J.D.PONZ
C  900219  KB, throw out SX calls...
C
C
C.IDENTIFICATION        TDFORMAT.FOR
C.KEYWORDS           TABLE, APPLICATIONS
C.ENVIRONMENT  MIDAS
C.PURPOSE
C  READ FORMAT FILE AND BUILD INTERNAL FORMAT CONTROL.
C  THE CONTROL INFORMATION IS DESCRIBED IN TABLES.INC
C
C
C------------------------------------------------------------------
      SUBROUTINE TDFFRM(FILE,STATUS)
      IMPLICIT NONE
      CHARACTER*(*) FILE  ! IN  : format file
      INTEGER STATUS      ! OUT : status
C
      INTEGER I,IST,IDOUBL,NCHAR,NCHAN, II
C
      CHARACTER*80 LINE,FILENA
      CHARACTER*8  FORM,FTYPE
      CHARACTER*1  C
      CHARACTER*16 C1
      CHARACTER*3  NN
       INCLUDE 'MID_INCLUDE:TABLES.INC/NOLIST'
       INCLUDE 'MID_INCLUDE:TABLEF.INC/NOLIST'
       INCLUDE 'MID_INCLUDE:TABLED.INC/NOLIST'
C
      DATA NCHAN/13/
C
      FTYPE  = 'fmt '
      CALL TDNAME(FILE,FTYPE,FILENA)
      OPEN (UNIT=NCHAN,FILE=FILENA,ERR=40,STATUS='OLD')
C
      I      = 0
   10 CONTINUE
      I      = I + 1
   20 READ (NCHAN,9010,ERR=50,END=30) LINE
      IF (LINE(1:3).EQ.'END'.OR.LINE(1:3).EQ.'end') GO TO 30
      IF (LINE(1:1).EQ.'C' .OR. LINE(1:1).EQ.'!'.OR.
     .    LINE(1:1).EQ.'c') GO TO 20
      IF (LINE(1:3).NE.'DEF'.AND.LINE(1:3).EQ.'def') GO TO 20
C          STATUS = ERRFMT
C          RETURN
C      END IF
      CALL TDFDEC(LINE,FMFIRS(I),FMLAST(I),C1,FORM,FMLABE(I),FMUNIT(I),
     +            STATUS)
      IF (STATUS.NE.0) THEN
          STATUS = ERRFMT
          RETURN
      END IF
      C      = C1(1:1)
      IF (INDEX('CRDIcrdi',C).EQ.0) THEN
          STATUS = ERRFMT
          RETURN
      END IF
      IDOUBL = INDEX(C1,'8')
      IF (FORM(1:5).EQ.'     ') THEN
          NCHAR  = FMLAST(I) - FMFIRS(I) + 1
          IST    = 3
          IF (NCHAR.GE.10) IST    = 2
          IF (NCHAR.GE.100) IST    = 1
          WRITE (NN,9000) NCHAR
          IF (C.EQ.'C' .OR. C.EQ.'c') THEN
              FMFORM(I) = '(A'//NN(IST:3)//')'
              FMTYPE(I) = 'C*'//NN(IST:3)
          ELSE
              IF (C.EQ.'I' .OR. C.EQ.'i') THEN
                  FMFORM(I) = '(I'//NN(IST:3)//')'
                  FMTYPE(I) = 'I*4'
              ELSE
                  FMFORM(I) = '(G'//NN(IST:3)//'.1)'
                  IF ((C.EQ.'R'.OR.C.EQ.'r').AND. IDOUBL.EQ.0) THEN
                      FMTYPE(I) = 'R*4'
                  ELSE
                      FMTYPE(I) = 'R*8'
                      C      = 'D'
                  END IF
              END IF
          END IF
      ELSE
          II        = INDEX(FORM,' ') - 1
          FMFORM(I) = '('//FORM(1:II)//')'
          IF (C.EQ.'C'.OR.C.EQ.'c') THEN
              IF (FORM(1:1).NE.'A') THEN
                  STATUS = ERRFMT
                  RETURN
              ELSE
                  FMTYPE(I) = 'C*'//FORM(2:)
              END IF

          ELSE
              IF (C.EQ.'I'.OR.C.EQ.'i') THEN
                  IF (FORM(1:1).NE.'I' .AND. FORM(1:1).NE.'O' .AND.
     +                FORM(1:1).NE.'Z' .AND. FORM(1:1).NE.'i' .AND.
     +                FORM(1:1).NE.'o' .AND. FORM(1:1).NE.'z' ) THEN
                      STATUS = ERRFMT
                      RETURN

                  ELSE
                      FMTYPE(I) = 'I*4'
                  END IF

              ELSE
                  IF (FORM(1:1).NE.'F' .AND. FORM(1:1).NE.'G' .AND.
     +                FORM(1:1).NE.'E' .AND. FORM(1:1).NE.'f' .AND.
     +                FORM(1:1).NE.'g' .AND. FORM(1:1).NE.'e' ) THEN
                      STATUS = ERRFMT
                      RETURN
                  ELSE
                      IF (C.EQ.'R'.OR.C.EQ.'r') THEN
                          FMTYPE(I) = 'R*4'

                      ELSE
                          FMTYPE(I) = 'R*8'
                      END IF

                  END IF

              END IF

          END IF

      END IF

      GO TO 10

   30 FMNCOL = I - 1
      FMLLEN = FMLAST(FMNCOL)
      RETURN
   40 CONTINUE
C   40 CALL STTPUT('Error opening format file',STATUS)
   50 STATUS = ERRFMT
      RETURN

 9000 FORMAT (I3)
 9010 FORMAT (A)
      END