C @(#)ftsval.for 17.1.1.1 (ES0-DMD) 01/25/02 17:10:47 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 SUBROUTINE FTSVAL(NAME,LEN,FLAG,GUESS,ERROR,FACTOR,ISTAT) C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C.COPYRIGHT: Copyright (c) 1987 European Southern Observatory, C all rights reserved C C.VERSION: 1.0 ESO-FORTRAN Conversion, AA 17:25 - 13 JAN 1988 C C.LANGUAGE: F77+ESOext C C.AUTHOR: J.D.PONZ C C.IDENTIFICATION C C FITLIB.FOR VERSION 1.0 27 MAR 1984 C C.PURPOSE C C INTERFACE ROUTINES FOR THE FITTING STRUCTURES C SEARCH INITIAL VALUES OF THE PARAMETER C C.ALGORITHM C C USE MIDAS I/O INTERFACES TO FRAMES AND TABLES C C.KEYWORDS C C NON LINEAR FITTING C C C---------------------------------------------------------------- C C C INPUT ARGUMENTS C NAME CHAR PARAMETER NAME C LEN INTG NUMBER OF BYTES IN NAME C C OUTPUT PARAMETERS C FLAG INTG CONSTRAIN FLAG AS C <0 FREE PARAMETER C 0 FIXED PARAMETER C >0 POINTER TO THE PROPORTIONAL PARAMETER C GUESS DBLE GUESS C ERROR REAL OPTIONAL ERROR WEIGHT C FACTOR REAL OPTIONAL FACTOR FOR PROPORTIONAL PARAMETERS C ISTAT INTG STATUS RETURN C CHARACTER*(*) NAME INTEGER FLAG,LEN,ISTAT,LEN1,I,II,II1,II2,ICASE INTEGER IAC,L2,J,IB,L1 REAL ERROR,FACTOR,VALUE DOUBLE PRECISION DB,GUESS CHARACTER*20 TOKEN1,TOKEN2,TEST1,TEST2 CHARACTER LINE*80,LINE1*80,C*1,NAME1*10 INCLUDE 'MID_INCLUDE:FITI.INC/NOLIST' INCLUDE 'MID_INCLUDE:FITC.INC/NOLIST' C C ITERATION ON THE FUNCTION SPECIFICATION C LEN1 = LEN + 1 NAME1 = NAME(1:LEN)//'=' DO 10 I = 1,FZNFUN LINE = FZSPEC(I) II = INDEX(LINE,NAME1(1:LEN1)) IF (II.NE.0) GO TO 20 10 CONTINUE C C PARAMETER NOT INITIALIZED C FLAG = -1 GUESS = 0.D0 ERROR = 0. FACTOR = 0. RETURN C C DECODE THE PARAMETER VALUE OR CONSTRAIN C 20 II = II + LEN1 LINE1 = LINE(II:) DO 30 I = 1,80 C = LINE1(I:I) IF (C.EQ.' ') GO TO 40 30 CONTINUE 40 II = I - 1 C C CHECK ONE OF THE FOLLOWING RULES C LINE1(1:II) = value C value@ C value*param C param*value C param/value C param C ! value@ IF (LINE1(II:II).EQ.'@') THEN TOKEN1 = LINE1(1:II-1) L1 = II - 1 ICASE = 1 ELSE II1 = INDEX(LINE1(1:II),'*') ! value*param or param*value IF (II1.NE.0) THEN TOKEN1 = LINE1(1:II1-1) L1 = II1 - 1 TOKEN2 = LINE1(II1+1:II) L2 = II - II1 ICASE = 3 ELSE II2 = INDEX(LINE1(1:II),'/') ! param/value IF (II2.NE.0) THEN TOKEN1 = LINE1(1:II2-1) L1 = II2 - 1 TOKEN2 = LINE1(II2+1:II) L2 = II - II2 ICASE = 4 ELSE II1 = INDEX('-+.0123456789',LINE1(1:1)) ! param IF (II1.EQ.0) THEN ICASE = 5 VALUE = 1. ELSE ! value ICASE = 2 END IF TOKEN1 = LINE1 L1 = II END IF END IF END IF IF (ICASE.LE.2) THEN CALL GENCNV(TOKEN1(1:L1),2,1,IB,VALUE,DB,IAC) GUESS = VALUE IF (IAC.LT.0) GO TO 60 ERROR = 0. FLAG = -1 FACTOR = 0. IF (ICASE.EQ.1) FLAG = 0 ELSE II = INDEX('+-1234567890.',TOKEN1(1:1)) ! TOKEN1 is parameter IF (II.EQ.0) THEN IF (ICASE.NE.5) . CALL GENCNV(TOKEN2(1:L2),2,1,IB,VALUE,DB,IAC) IF (IAC.LT.0) GO TO 60 ERROR = 0. IF (ICASE.EQ.3 .OR. ICASE.EQ.5) THEN FACTOR = VALUE ELSE IF (VALUE.EQ.0.) GO TO 60 FACTOR = 1./VALUE END IF ELSE ! value/param not supported IF (ICASE.EQ.4) GO TO 60 CALL GENCNV(TOKEN1(1:L1),2,1,IB,VALUE,DB,IAC) IF (IAC.LT.0) GO TO 60 FACTOR = VALUE TOKEN1 = TOKEN2 L1 = L2 END IF C C SEARCH FOR PARAMETER TOKEN1 C TEST1 = TOKEN1 CALL FORUPC(TEST1, TEST1) DO 50 J = 1,FZNPTOT TEST2 = FZPTOKEN(J) CALL FORUPC(TEST2, TEST2) IF (TEST2(1:FZPLEN(J)).EQ.TEST1(1:L1)) THEN IF (FZFIXED(J).GT.0) GO TO 60 FLAG = J RETURN END IF 50 CONTINUE ISTAT = FERCON END IF RETURN 60 ISTAT = FERCON RETURN END