C @(#)fitcrea.for	17.1.1.1 (ES0-DMD) 01/25/02 17:11:04
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
C.COPYRIGHT: Copyright (c) 1987 European Southern Observatory,
C                                         all rights reserved
C
C.VERSION: 1.0  ESO-FORTRAN Conversion, AA  15:25 - 20 DEC 1987
C
C.LANGUAGE: F77+ESOext
C
C.AUTHOR: J.D.PONZ
C
C.IDENTIFICATION
C
C  program FITCREA.FOR
C
C.PURPOSE
C
C  Execute the commands
C  COMP/FIT image[,error] [= array[(refima)]]
C  COMP/FIT table dvar[,error] [= array[(in.var)]]
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-----------------------------------------------------------
C
C
C ... define parameters
C
      IMPLICIT   NONE
C
      INTEGER    STATUS,KUN,KNUL,ISTAT,IND,INDEX
      INTEGER    I, II, II1, NAMLEN
C
      CHARACTER*80 NAME,FILE,MASK
      CHARACTER    IAC*1
      CHARACTER    LINE1*34,LINE2*80,REFIMA*80
      CHARACTER*16 MSG
      CHARACTER*80 P1,P2,P3,P4
      CHARACTER*80 HISTORY,FTABLE
      CHARACTER*81 LINE
C
      INCLUDE  'MID_INCLUDE:ST_DEF.INC'
      INCLUDE  'MID_INCLUDE:FITI.INC'
      INCLUDE  'MID_INCLUDE:FITC.INC'
      INCLUDE  'MID_INCLUDE:ST_DAT.INC'
C
      DATA NAMLEN/80/
      DATA MSG/'ERR:FITCREAxxxx'/
C
C ... get into MIDAS
C
      CALL STSPRO('FITCREA')
      CALL FITBL
      CALL STKRDC('HISTORY',1,1,80,I,FTABLE,KUN,KNUL,ISTAT)
      IND    = INDEX(FTABLE,'?') - 1
      IF (IND.LE.0) IND    = 80
      HISTORY = FTABLE(1:IND)
      CALL STKRDC('P1',1,1,80,I,P1,KUN,KNUL,ISTAT)
      CALL STKRDC('P2',1,1,80,I,P2,KUN,KNUL,ISTAT)
      CALL STKRDC('P3',1,1,80,I,P3,KUN,KNUL,ISTAT)
      CALL STKRDC('P4',1,1,80,I,P4,KUN,KNUL,ISTAT)
      IF (P2(1:1).EQ.':' .OR. P2(1:1).EQ.'#') THEN
          P3     = '='
      ELSE
          P2     = '='
      END IF  !   IMAGE
      IF (P2(1:1).EQ.'=') THEN
          FTABLE = P1
          IAC    = 'I'
          II     = INDEX(P1,',')
          IF (II.EQ.0) THEN
              FILE   = P1
              MASK   = ' '
          ELSE
              FILE   = P1(1:II-1)
              MASK   = P1(II+1:)
          END IF
          II     = INDEX(P3,'(')
          IF (II.EQ.0) THEN
              NAME   = P3
              REFIMA = '?'
          ELSE
              NAME   = P3(1:II-1)
              LINE   = P3//')'
              II1    = INDEX(LINE,')')
              REFIMA = P3(II+1:II1-1)
          END IF  !   TABLE
      ELSE
          IND    = INDEX(P1,' ') - 1
          FTABLE = P1(1:IND)//'.TBL'
          IAC    = 'T'
          FILE   = P1
          LINE1  = P2
          II     = INDEX(P4,'(')
          IF (II.EQ.0) THEN
              NAME   = P4
              LINE2  = '?'
          ELSE
              NAME   = P4(1:II-1)
              LINE   = P4//')'
              II1    = INDEX(LINE,')')
              LINE2  = P4(II+1:II1-1)
          END IF
      END IF
      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 computed parameters
C
      CALL FTINIT(NAME,ISTAT)
C
C ... modify independent variables if required
C     and define dependent variables
C
      IF (IAC.EQ.'I') THEN
          IF (REFIMA(1:1).NE.'?') CALL FTDIVI(REFIMA,ISTAT)
          CALL FTDDVI(FILE,MASK,ISTAT)
      ELSE
          IF (LINE2(1:1).NE.'?') CALL FTDIVT(FILE,LINE2,ISTAT)
          CALL FTDDVT(FILE,LINE1,ISTAT)
      END IF
      CALL FTCOMP(ISTAT)
C CALL SXDPUT(FTABLE,'HISTORY','C',HISTORY,-1,80,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)
      END