C @(#)fitread.for	17.1.1.1 (ES0-DMD) 01/25/02 17:11:05
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  15:59 - 20 DEC 1987
C
C.LANGUAGE: F77+ESOext
C
C.AUTHOR: J.D.PONZ
C
C.IDENTIFICATION
C
C  program FITREAD.FOR
C
C.PURPOSE
C
C  Execute the commands
C  READ/FIT  [fitname]
C  PRINT/FIT [fitname]
C
C.KEYWORDS
C
C  FIT, READ, PRINT
C
C.INPUT/OUTPUT
C
C  P1 - P8     contain input parameters
C
C
C.ALGORITHM
C
C  Use fit interface routines
C
C-----------------------------------------------------------
C
      IMPLICIT NONE
C
C ... define parameters
C
      INTEGER IVAR(16),FIX(20),STATUS,I,II,ISTAT,N,NP,J
      INTEGER NL,NPAR,NFUN,NDAT,NIND,KUN,KNUL,IDVAR
      INTEGER ITER,MADRID(1),NAMLEN
C
      REAL    CHISQ,RELAX
C
      DOUBLE PRECISION ERR(20),PAR(20)
C
      CHARACTER*80 LINE,HEAD,OUT
      CHARACTER*80 NAME,FILE,FNAME
      CHARACTER*4  TYPE
      CHARACTER*30 AUX,AUX1
      CHARACTER*16 MSG
C
       INCLUDE 'MID_INCLUDE:FITI.INC/NOLIST'
       INCLUDE 'MID_INCLUDE:FITC.INC/NOLIST'
C
      COMMON/VMR/MADRID
C
      DATA NAMLEN/80/
      DATA MSG/'ERR:FITREADxxxx'/
      DATA HEAD/
     +     ' Parameter Initial Guess      Actual Value       Error '/
C
C ... get into MIDAS
C
      CALL STSPRO('FITREAD')
      CALL FITBL
C      CALL STKRDC('MID$CMND',1,1,1,I,I,KUN,KNUL,ISTAT)
      FZTYPE = ' '
C
C ... list fit
C
C IF (IAC.EQ.'P') CALL MIDOUT
C
C ... read params
C
      CALL STKRDC('P1',1,1,NAMLEN,I,NAME,KUN,KNUL,ISTAT)
      IF (NAME(1:1).EQ.'?') THEN
          CALL STKRDC('FITNAME',1,1,NAMLEN,I,NAME,KUN,KNUL,ISTAT)
      ELSE
          CALL STKWRC('FITNAME',1,NAME,1,NAMLEN,KUN,ISTAT)
      END IF
C
C ... read fit information
C
      CALL FTINIT(NAME,ISTAT)
      CALL FTINFO(FILE,TYPE,IDVAR,NIND,NFUN,NDAT,ISTAT)
      IF (TYPE.EQ.'BDF ') THEN
          LINE   = ' Fit on image '//FILE
          CALL STTPUT(LINE,ISTAT)
      ELSE
          IF (TYPE.EQ.'TBL ') THEN
              LINE   = ' Fit on table '//FILE
              CALL STTPUT(LINE,ISTAT)
          ELSE
              CALL STTPUT(' Fit on one dep. variable',ISTAT)
          END IF
      END IF
      LINE   = ' No. of data points '
      WRITE (LINE(25:32),9030) NDAT
      CALL STTPUT(LINE,ISTAT)
C
      CALL STTPUT(' ',ISTAT)
      IF (TYPE.EQ.'TBL ') THEN
          LINE   = ' Dependent variable '
          WRITE (LINE(25:28),9000) IDVAR
          CALL STTPUT(LINE,ISTAT)
      END IF
      LINE   = ' No. of ind. variables '
      WRITE (LINE(25:28),9000) NIND
      CALL STTPUT(LINE,ISTAT)
C
C ... read fit variables
C
      IF (NIND.GT.0) THEN
          CALL FTRDIN(NIND,IVAR,N,ISTAT)
          IF (TYPE.EQ.'BDF ') THEN
              LINE   = ' variable .... is axis   ....'
          ELSE
              IF (TYPE.EQ.'TBL ') THEN
                  LINE   = ' variable .... is column ....'
              ELSE  !   DO NOT PRINT IVAR
                  NIND   = 0
              END IF
          END IF
          DO 10 I = 1,NIND
              WRITE (LINE(11:14),9000) I
              WRITE (LINE(26:29),9000) IVAR(I)
              CALL STTPUT(LINE,ISTAT)
   10     CONTINUE
      END IF
C
C ... read coeffs
C
      CALL STTPUT(' ',ISTAT)
      LINE   = ' No. of functions '
      WRITE (LINE(25:28),9000) NFUN
      CALL STTPUT(LINE,ISTAT)
      NP     = 0
      DO 30 I = 1,NFUN
          CALL STTPUT(' ',ISTAT)
          CALL FTRDFN(I,LINE,ISTAT)
          II     = INDEX(LINE,')')
          CALL STTPUT(LINE(1:II),ISTAT)
          CALL STTPUT(HEAD,ISTAT)
          CALL FTRDPR(I,FNAME,NPAR,PAR,ERR,FIX,ISTAT)
          LINE   = FZSPEC(I)
          IF (NPAR.GT.0) THEN
              DO 20 J = 1,NPAR
                  NP     = NP + 1
                  NL     = FZPLEN(NP)
                  AUX    = FZPTOKEN(NP)
                  AUX1   = AUX(1:NL)//'='
                  II     = INDEX(LINE,AUX1(1:NL+1))
                  IF (II.EQ.0) THEN
                      AUX1   = '-'
                  ELSE
                      AUX    = LINE(II+NL+1:)
                      II     = INDEX(AUX,' ') - 1
                      AUX1   = AUX(1:II)
                  END IF
                  WRITE (OUT,9010) FZPTOKEN(NP),AUX1(1:16),PAR(J),
     +              ERR(J)
                  CALL STTPUT(OUT,ISTAT)
   20         CONTINUE
          END IF
   30 CONTINUE
C
C ... read fit results
C
      CALL STTPUT(' ',ISTAT)
      CALL FTSTAT(CHISQ,RELAX,ITER,ISTAT)
      WRITE (LINE,9020) CHISQ,RELAX,ITER
      CALL STTPUT(LINE,ISTAT)
C
C ... end
C
      IF (ISTAT.NE.0) THEN
          WRITE (MSG(13:16),9000) ISTAT
          CALL TDERRR(ISTAT,MSG,STATUS)
      END IF
      CALL STSEPI
 9000 FORMAT (I4)
 9010 FORMAT (1X,A,2X,A,1X,E14.6,1X,E14.6)
 9020 FORMAT (' Chi sq. = ',E13.4,' relaxation factor = ',F7.3,' itera',
     +       'tions = ',I4)
 9030 FORMAT (I8)
      END