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 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,2004 European Southern Observatory,
C                                         all rights reserved
C
C.LANGUAGE: F77+ESOext
C
C.AUTHOR: J.D.PONZ
C
C.IDENTIFICATION
C
C  program FUNCREA.FOR
C
C.PURPOSE
C
C  Execute the commands
C  COMPUTE/FUNCTION image = function(refima[;pars])
C  COMPUTE/FUNCTION table dvar = function(in.var[;pars])
C
C  The first format corresponds to images, the second to tables
C
C  The functional specification can be as:
C   function(reference)      -- where function is function file
C                               edited via EDIT/FUNCTION
C  or
C  function(reference;pars) -- where function is en explicit function
C                              name, including parameters
C
C.KEYWORDS
C
C  FUNCTIONS, FIT
C
C.INPUT/OUTPUT
C
C  P1 - P8     contain input parameters
C
C.ALGORITHM
C
C  Use fit interface routines
C
C.VERSION: 1.0  ESO-FORTRAN Conversion, AA  16:04 - 20 DEC 1987
C 041129	last modif
C
C-----------------------------------------------------------
C 
      IMPLICIT NONE
C
C ... define variables
C
      INTEGER CODE,IAV,KUN,KNUL,I,II
      INTEGER INDEX,IND,ISTAT,II1,NAMLEN
      INTEGER IMNOA,IMNOC
C
      CHARACTER*80 NAME,FILE,MASK,LINE
      CHARACTER*1  IAC
      CHARACTER    PARS*80,LINE1*34,LINE2*80,REFIMA*80
      CHARACTER*80 P1,P2,P3,P4,FILENA
C
      INCLUDE 'MID_INCLUDE:ST_DEF.INC/NOLIST'
C
      INCLUDE 'MID_INCLUDE:FITI.INC/NOLIST'
      INCLUDE 'MID_INCLUDE:FITC.INC/NOLIST'
C
      INCLUDE 'MID_INCLUDE:ST_DAT.INC/NOLIST'
C
      DATA NAMLEN/80/
C
C ... get into MIDAS
C
      CALL STSPRO('FUNCREA')
      CALL FITBL
C
C ... read parameters
C
      CALL STKRDC('P1',1,1,80,IAV,P1,KUN,KNUL,ISTAT)
      CALL STKRDC('P2',1,1,80,IAV,P2,KUN,KNUL,ISTAT)
      CALL STKRDC('P3',1,1,80,IAV,P3,KUN,KNUL,ISTAT)
      CALL STKRDC('P4',1,1,80,IAV,P4,KUN,KNUL,ISTAT)
C
C ... decode if image or table format
C                                                    IMAGE
      IF (P2(1:1).EQ.'=') THEN
          FILENA = P1
          IAC    = 'I'
          FILE   = P1
          II     = INDEX(P3,'(')
          IF (II.EQ.0) 
     +       CALL STETER(11,'FUNCREA: Missing function arguments ')
          NAME   = P3(1:II-1)
          II1    = INDEX(P3,')')
          IF (II1.EQ.0) 
     +       CALL STETER(12,'FUNCREA: Missing right parenthesis')
          LINE2  = P3(II+1:II1-1)
          LINE   = P3
      ELSE
C                                                  TABLE
          IND    = INDEX(P1//' ',' ') - 1
          FILENA = P1(1:IND)//'.tbl'
          IAC    = 'T'
          FILE   = P1
          LINE1  = P2
          II     = INDEX(P4,'(')
          IF (II.EQ.0)
     +       CALL STETER(11,'FUNCREA: Missing function arguments ')
          NAME   = P4(1:II-1)
          II1    = INDEX(P4,')')
          IF (II1.EQ.0) 
     +       CALL STETER(12,'FUNCREA: Missing right parenthesis')
          LINE2  = P4(II+1:II1-1)
          LINE   = P4
      END IF
C
C ... decode function arguments
C
      II1    = INDEX(LINE2,';')
      IF (II1.EQ.0) THEN
          REFIMA = LINE2
          PARS   = ' '
      ELSE
          REFIMA = LINE2(1:II1-1)
          PARS   = LINE2(II1+1:)
      END IF
C
C ... read function file or initialize parameters
C
      CALL FTDCFN(NAME,CODE)
      IF (CODE.GT.0 .OR. PARS(1:1).NE.' ') THEN
          CALL FTINIF(LINE,ISTAT)
          DO 10 I = 1,20
              FZSELE(I) = 1
   10     CONTINUE
      ELSE
          CALL FTINIT(NAME,ISTAT)
      END IF
C
C ... copy parameter guesses to actual values
C
      CALL FTCPGV(ISTAT)
C
C ... modify independent variables if required
C     and define dependent variables
C
      IF (IAC.EQ.'I') THEN
          MASK   = ' '
          CALL FTDIVI(REFIMA,ISTAT)
          CALL FTDDVI(FILE,MASK,ISTAT)
      ELSE
          CALL FTDIVT(FILE,REFIMA,ISTAT)
          CALL FTDDVT(FILE,LINE1,ISTAT)
      END IF
C
C ... compute functional values
C
      CALL FTCOMP(ISTAT)
      IF (IAC.EQ.'I') THEN
         CALL STFOPN(REFIMA,D_OLD_FORMAT,0,F_OLD_TYPE,IMNOA,ISTAT)
         CALL STFOPN(FILE,D_OLD_FORMAT,0,F_OLD_TYPE,IMNOC,ISTAT)
         CALL DSCUPT(IMNOA,IMNOC,' ',ISTAT)
      ENDIF
C
      CALL STSEPI
9000  FORMAT (I4)
      END
