C @(#)fitimag.for 17.1.1.1 (ESO-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 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.MODIFICATIONS C nov 1989 M Peron. modify everything..... 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 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) C READ (PPRINT,*) FZMETPAR(1) CALL GENCNV(PPRINT,2,1,IVAL,FZMETPAR(1),DVAL,MM) C C ... fit for image C IF (IAC.EQ.'I') THEN CALL FTIMAG(FILE,MASK,ISTAT) ELSE CALL FTTABL(FILE,LINE1,LINE2,ISTAT) END IF CALL FTINIT(NAME,ISTAT) 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