C @(#)funcrea.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 16:04 - 20 DEC 1987 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----------------------------------------------------------- IMPLICIT NONE C C ... define variables C INTEGER CODE,STATUS,IAV,KUN,KNUL,I,II INTEGER INDEX,IND,ISTAT,II1,NAMLEN C CHARACTER*80 NAME,FILE,MASK,LINE CHARACTER*1 IAC CHARACTER PARS*80,LINE1*34,LINE2*80,REFIMA*80 CHARACTER*16 MSG CHARACTER*80 P1,P2,P3,P4 CHARACTER*80 HISTOR,FILENA C INCLUDE 'MID_INCLUDE:FITI.INC/NOLIST' INCLUDE 'MID_INCLUDE:FITC.INC/NOLIST' C DATA NAMLEN/80/ DATA MSG/'ERR:FUNCREAxxxx'/ C C ... get into MIDAS C CALL STSPRO('FUNCREA') CALL FITBL C C ... read parameters C CALL STKRDC('HISTORY',1,1,80,I,FILENA,KUN,KNUL,ISTAT) IND = INDEX(FILENA,'?') - 1 IF (IND.LE.0) IND = 80 HISTOR = FILENA(1:IND) 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) THEN CALL STTPUT(' Missing function arguments ',ISTAT) GO TO 20 END IF NAME = P3(1:II-1) II1 = INDEX(P3,')') IF (II1.EQ.0) THEN CALL STTPUT(' Missing right parenthesis',ISTAT) GO TO 20 END IF 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) THEN CALL STTPUT(' Missing function arguments ',ISTAT) GO TO 20 END IF NAME = P4(1:II-1) II1 = INDEX(P4,')') IF (II1.EQ.0) THEN CALL STTPUT(' Missing right parenthesis',ISTAT) GO TO 20 END IF 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) C CALL SXDPUT(FILENA,'HISTOR','C',HISTOR,-1,80,ISTAT) C C ... end C 20 IF (ISTAT.NE.0) THEN WRITE (MSG(13:16),9000) ISTAT CALL TDERRR(ISTAT,MSG,STATUS) END IF CALL STSEPI 9000 FORMAT (I4) END