C @(#)ftsval.for	19.1 (ES0-DMD) 02/25/03 13:17:36
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                                                                       
