C @(#)tsatab.for	17.1.1.1 (ES0-DMD) 01/25/02 17:20:37
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  @(#)tsatab.for	5.1 (ESO-IPG) 4/5/93 15:58:45
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C.COPYRIGHT (c)  1992     European Southern Observatory and Warsaw Observatory
C.IDENT     tsatab.for
C.AUTHOR    Alex Schwarzenberg-Czerny, ESO and Warsaw Observatory
C.KEYWORD   MIDAS, time series, TABLE/TSA
C.LANGUAGE  FORTRAN 77
C.PURPOSE   Create a MIDAS table from an ASCII file
C           More flexible than CREATE/TABLE
C.VERSION   0.0               June 1992
C.RETURNS   None
C.ENVIRON   TSA context
C-----------------------------------------------------------------------------
C
C
      INCLUDE 'MID_REL_INCL:TSA_DEF.INC'
      INCLUDE 'MID_INCLUDE:ST_DEF.INC'
C
      CHARACTER*60 INAME                !  NAME OF ASCII TABLE
      CHARACTER*60 ONAME                !  NAME OF MIDAS TABLE
      CHARACTER*1  TYPE                 !  TYPE OF CONVERDSION (R,D,I)
      INTEGER      MXCOL                !  MAXIMUM NUMBER OF COLUMNS
      INTEGER      LENCH                !  EXTERNAL FUNCTION
C
      INTEGER      MAXCOL
      PARAMETER    (MAXCOL=99)
      INTEGER      IVAL(MAXCOL),IDCOL(MAXCOL)
      REAL*4       RVAL(MAXCOL)
      REAL*8       DVAL(MAXCOL)
      INTEGER      NROW,IROW,NCOL,ICOL,I,NCOLOLD
      INTEGER      MXPRINT,IPRINT,LENGTH,JSTAT
      INTEGER      IACTS, KUN,   KNUL, D_FORMAT
      INTEGER      OTID
      CHARACTER*132 LINE
      CHARACTER*10  FORM,LABEL
C
      INCLUDE 'MID_REL_INCL:TSA_DAT.INC'
      INCLUDE 'MID_INCLUDE:ST_DAT.INC'
C
C   Get parameters
C
      CALL STSPRO ('timtab')
      CALL STKRDC ('IN_A',  1,1,60,IACTS,INAME,KUN,KNUL,ISTAT)
      CALL STKRDC ('OUT_A', 1,1,60,IACTS,ONAME,KUN,KNUL,ISTAT)
      CALL STKRDC ('TYPE',  1,1, 1,IACTS,TYPE, KUN,KNUL,ISTAT)
      CALL STKRDI ('MXCOL', 1,1,   IACTS,MXCOL,KUN,KNUL,ISTAT)
      IF (MXCOL.GT.MAXCOL) THEN
        MXCOL=MAXCOL
        WRITE(LINE,'(a,i5)') 'Max column number trimmed to',MXCOL
        CALL STTPUT(LINE(1:LENCH(LINE)),ISTAT)
      ENDIF
C
C   Get format of input table: first open file, ...
C
      INAME=INAME(1:LENCH(INAME))//'.dat'
      OPEN(1,FILE=INAME(1:LENCH(INAME)),
     $   STATUS='OLD',ACCESS='SEQUENTIAL',FORM='FORMATTED')
      IF (ISTAT.NE.0) THEN
        CALL STETER(1,'Wrong name or other input file attributes')
      ENDIF
C
C   ... than scan each line, ...
C
      MXPRINT=10
      IPRINT=0
      NCOLOLD=0
      NROW=0
 1    CONTINUE
        READ(1,'(A)',IOSTAT=JSTAT) LINE
        LENGTH=LENCH(LINE)
C
C   ... and find number of columns by trial-and-error
C
          NCOL=0
          DO 2 ICOL=1,MXCOL
            IF (TYPE.EQ.'R') THEN
              READ(LINE(1:LENGTH),*,IOSTAT=ISTAT)
     $            (RVAL(I),I=1,ICOL)
            ELSEIF (TYPE.EQ.'D') THEN
              READ(LINE(1:LENGTH),*,IOSTAT=ISTAT)
     $            (DVAL(I),I=1,ICOL)
            ELSEIF (TYPE.EQ.'I') THEN
              READ(LINE(1:LENGTH),*,IOSTAT=ISTAT)
     $            (IVAL(I),I=1,ICOL)
            ELSE
              CALL STETER(2,'Wrong conversion type (must be R or D)')
            ENDIF
            IF (ISTAT.EQ.0) THEN
              NCOL=ICOL
            ELSE
C   Break loop 2
              GOTO 29
            ENDIF
 2        CONTINUE
C
C   Do some check on consistency of valid lines with the first valid line
C
 29       IF (NCOL.GT.0) THEN
            IF (NCOLOLD.EQ.0) THEN
              NCOLOLD=NCOL
            ENDIF
            IF (NCOLOLD.NE.NCOL) THEN
              IF (IPRINT.LE.MXPRINT) THEN
                CALL STTPUT(LINE(1:LENGTH),ISTAT)
                WRITE(LINE,'(A,I10)')
     $ 'Column inconsistency near row',NROW
                CALL STTPUT(LINE(1:LENGTH),ISTAT)
                IPRINT=IPRINT+1
              ENDIF
            ELSE
              NROW=NROW+1
            ENDIF
          ELSE
            CALL STTPUT(LINE(1:LENCH(LINE)),ISTAT)
          ENDIF
        IF (JSTAT.EQ.0) THEN
          GOTO 1
        ENDIF
      NCOL=NCOLOLD
C
C   Test for some errors
C
      IF (JSTAT.GT.0) THEN
         CALL STTPUT(LINE(1:LENGTH),ISTAT)
         WRITE(LINE,'(A,I10)') 'Fatal input error near row',NROW
         CALL STETER(3,LINE(1:LENGTH))
      ENDIF
      IF (NCOL.LE.0) THEN
         CALL STETER(4,'No valid columns found or MXCOL wrong')
      ENDIF
C
C   Define some type dependent attributes of columns
C
      IF (TYPE.EQ.'R') THEN
        LENGTH=NCOL
        D_FORMAT=D_R4_FORMAT
        FORM='E15.6'
        LABEL='RVAL'
      ELSEIF (TYPE.EQ.'D') THEN
        LENGTH=NCOL*2
        D_FORMAT=D_R8_FORMAT
        FORM='D15.6'
        LABEL='DVAL'
      ELSEIF (TYPE.EQ.'I') THEN
        LENGTH=NCOL
        D_FORMAT=D_I2_FORMAT
        FORM='I12'
        LABEL='IVAL'
      ELSE
        CALL STETER(5,'Conversion types coded inconsistently')
      ENDIF

C
C   Create and map output table
C
      CALL TBTINI (ONAME,F_TRANS,F_O_MODE,LENGTH,NROW,OTID,ISTAT)
      DO 10 ICOL=1,NCOL
        IF (NCOL.LT.10) THEN
          WRITE(LABEL(5:6),'(I1,A1)') ICOL,' '
        ELSE
          WRITE(LABEL(5:6),'(I2)') ICOL
        ENDIF
        CALL TBCINI
     $    (OTID,D_FORMAT,1,FORM,' ',LABEL(1:6),IDCOL(ICOL),ISTAT)
 10   CONTINUE
C
C   Copy data:
C
      REWIND 1
      IROW=0
 11   CONTINUE
C
C   ... Read ASCII input row and ...
C
        READ(1,'(A)',IOSTAT=JSTAT) LINE
        LENGTH=LENCH(LINE)
            IF (TYPE.EQ.'R') THEN
              READ(LINE(1:LENGTH),*, IOSTAT=ISTAT)
     $            (RVAL(I),I=1,NCOL)
            ELSEIF (TYPE.EQ.'D') THEN
              READ(LINE(1:LENGTH),*,IOSTAT=ISTAT)
     $            (DVAL(I),I=1,NCOL)
            ELSEIF (TYPE.EQ.'I') THEN
              READ(LINE(1:LENGTH),*,   IOSTAT=ISTAT)
     $            (IVAL(I),I=1,NCOL)
            ELSE
              CALL STETER(6,'WrongLy coded conversion type')
            ENDIF
C
C   ... write into MIDAS table row
C
            IF (ISTAT.EQ.0) THEN
              IROW=IROW+1
              IF (IROW.LE.NROW) THEN
                IF (TYPE.EQ.'R') THEN
                  CALL TBRWRR(OTID,IROW,NCOL,IDCOL,RVAL,ISTAT)
                ELSEIF (TYPE.EQ.'D') THEN
                  CALL TBRWRD(OTID,IROW,NCOL,IDCOL,DVAL,ISTAT)
                ELSEIF (TYPE.EQ.'I') THEN
                  CALL TBRWRI(OTID,IROW,NCOL,IDCOL,IVAL,ISTAT)
                ELSE
                  CALL STETER(7,'WrongLy coded conversion type')
                ENDIF
              ELSE
                CALL STETER(8,'Wrongly coded row count')
              ENDIF
            ENDIF
        IF (JSTAT.EQ.0) THEN
            GOTO 11
        ENDIF
C
C   Loop over file finished, test for errors
C
      IF (JSTAT.GT.0) THEN
         CALL STTPUT(LINE(1:LENGTH),ISTAT)
         WRITE(LINE,'(A,I10)') 'Fatal input error near row',NROW
         CALL STETER(10,LINE(1:LENGTH))
      ENDIF
C
C   Wind-up
C
      LINE='ASCI table '//INAME(1:LENCH(INAME))//
     $   ' converted into MIDAS table '//ONAME(1:LENCH(ONAME))//'.tbl'
      CALL STTPUT(LINE(1:LENCH(LINE)),ISTAT)
      CALL STTPUT('           ... Enjoy it!',ISTAT)
      CALL DSCUPT(OTID,OTID,' ',ISTAT)
      CALL STSEPI
C
      END
C
C
C