C===========================================================================
C Copyright (C) 1995,2004 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 Massachusetts Ave, Cambridge, 
C MA 02139, USA.
C
C Correspondence 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
C.COPYRIGHT: Copyright (c) 1987,2004 European Southern Observatory,
C                                         all rights reserved
C
C.VERSION: 1.0  ESO-FORTRAN Conversion, AA  18:13 - 21 DEC 1987
C
C.LANGUAGE: F77+ESOext
C
C.AUTHOR: J.D.PONZ
C
C.IDENTIFICATION
C
C  program FITIMAG.FOR
C
C.PURPOSE
C
C  Execute the commands
C  FIT/IMA [iter[,chisq[,relax]]] image[,error] [FZname]
C  FIT/IMA [iter[,chisq[,relax]]] GCURSOR         [FZname]
C  FIT/IMA [iter[,chisq[,relax]]] CURSOR  [FZname] - NOT YET IMPLEM.
C
C  FIT/TAB [iter[,chisq[,relax]]] table dep[,err] ind.vars [FZname]
C
C.KEYWORDS
C
C  FIT
C
C.INPUT/OUTPUT
C
C  P1 - P8     contain input parameters
C
C.ALGORITHM
C
C  Use fit interface routines
C
C.VERSION
C 040521	last modif
C 
C-----------------------------------------------------------
C
C
C ... define parameters
C
      IMPLICIT NONE
C
      INTEGER IVAR(8),FIX(20),KUN,KNUL, NP
      INTEGER ISTAT, I, II, IAV, NIND, NPAR
      INTEGER NFUN,NDAT,N,J,IDVAR,NL,NACT,NAMLEN,MM,IVAL
C
      REAL CHISQ,VAL1,VAL2
C
      DOUBLE PRECISION PAR(20),ERR(20),DVAL
C
      CHARACTER*80 FNAME,NAME,FILE,MASK,LINE1
      CHARACTER    IAC*1,AUX*30,AUX1*30
      CHARACTER    LINE2*80,TYPE*4,LINE*80
      CHARACTER    LINE3*80
      CHARACTER*80 HEAD,OUT,HEADER
      CHARACTER*16 MSG
      CHARACTER*4  PPRINT
C
      INCLUDE 'MID_INCLUDE:FITI.INC/NOLIST'
      INCLUDE 'MID_INCLUDE:FITC.INC/NOLIST'
C
      DOUBLE PRECISION OURSTART(FZINDMAX),OURSTEP(FZINDMAX)
C 
      DATA NAMLEN/80/
      DATA MSG/'ERR:FITIMAGxxxx'/
      DATA HEAD/' Parameter Initial Guess      Actual Value       Error'
     +     /
C
C ... get into MIDAS
C
      CALL STSPRO('FITIMAG')
      CALL FITBL
      CALL STKRDC('P2',1,1,NAMLEN,I,LINE3,KUN,KNUL,ISTAT)
      II     = INDEX(LINE3,',')
      IF (II.EQ.0) THEN
          FILE   = LINE3
          MASK   = ' '
      ELSE
          FILE   = LINE3(1:II-1)
          MASK   = LINE3(II+1:)
      END IF
      CALL STKRDC('P3',1,1,NAMLEN,II,LINE1,KUN,KNUL,ISTAT)
      IF (LINE1(1:1).EQ.':' .OR. LINE1(1:1).EQ.'#') THEN
          IAC    = 'T'
          CALL STKRDC('P4',1,1,80,IAV,LINE2,KUN,KNUL,ISTAT)
          CALL STKRDC('P5',1,1,NAMLEN,IAV,NAME,KUN,KNUL,ISTAT)
      ELSE
          IAC    = 'I'
          NAME   = LINE1
      END IF
      IF (NAME(1:1).EQ.'?') THEN
          CALL STKRDC('FITNAME',1,1,NAMLEN,IAV,NAME,KUN,KNUL,ISTAT)
      ELSE
          CALL STKWRC('FITNAME',1,NAME,1,NAMLEN,KUN,ISTAT)
      END IF
      CALL STKRDR('INPUTR',1,9,IAV,FZMETPAR(2),KUN,KNUL,ISTAT)
      CALL STKRDC('FITCHAR',1,21,4,IAV,PPRINT,KUN,KNUL,ISTAT)
      CALL GENCNV(PPRINT,2,1,IVAL,FZMETPAR(1),DVAL,MM)
      VAL1 = 0.0
      VAL2 = 0.0
C
C ... fit for image - start, step from image => fit-function
C
      IF (IAC.EQ.'I') THEN
          CALL FTIMAG(FILE,MASK,ISTAT)
      ELSE
          CALL FTTABL(FILE,LINE1,LINE2,ISTAT)
      END IF
C 
C  FTINIT overwrites FZSTART, FZSTEP - so save them
C 
      DO 100, I = 1,FZINDMAX
         OURSTART(I) = FZSTART(I)
         OURSTEP(I) = FZSTEP(I)
100   CONTINUE
      CALL FTINIT(NAME,ISTAT)
      DO 200, I = 1,FZINDMAX
         FZSTART(I) = OURSTART(I)
         FZSTEP(I) = OURSTEP(I)
200   CONTINUE
C
      CALL FTDODO(NINT(FZMETPAR(2)),FZMETPAR(4),FZMETPAR(3),VAL1,
     +            VAL2,NACT,CHISQ,ISTAT)
C
C ... read parameters
C
      CALL FTINFO(FILE,TYPE,IDVAR,NIND,NFUN,NDAT,ISTAT)
      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 20 I = 1,NIND
              WRITE (LINE(11:14),9000) I
              WRITE (LINE(26:29),9000) IVAR(I)
              CALL STTPUT(LINE,ISTAT)
   20     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 40 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 30 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)
   30         CONTINUE
          END IF
   40 CONTINUE
C
C ... end
C
      CALL STTPUT(' ',ISTAT)
      CALL STTPUT('     Red. Chisq      Act. Nr. F. Eval.',ISTAT)
      WRITE (HEADER,9020) FZCCHIS,FZNITER
      CALL STTPUT(HEADER,ISTAT)
      CALL STTPUT(' ',ISTAT)
      CALL FTEXIT(NAME,ISTAT)
      IF (ISTAT.NE.0) THEN
          WRITE (MSG(13:16),9000) ISTAT
C   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 (3X,1PE12.4,12X,I6)
 9030 FORMAT (I8)
      END

