← Back to branch summary

~ubuntu-branches/debian/jessie/eso-midas/jessie

« back to all changes in this revision

Viewing changes to applic/fit/libsrc/ftsval.for

  • Committer: Package Import Robot
  • Author(s): Ole Streicher
  • Date: 2014-04-22 14:44:58 UTC
  • Revision ID: package-import@ubuntu.com-20140422144458-okiwi1assxkkiz39
Tags: upstream-13.09pl1.2+dfsg
Import upstream version 13.09pl1.2+dfsg

Show diffs side-by-side

added added

removed removed

Lines of Context:
applic/fit/libsrc/ftsval.for
 
1
C @(#)ftsval.for        19.1 (ES0-DMD) 02/25/03 13:17:36
 
2
C===========================================================================
 
3
C Copyright (C) 1995 European Southern Observatory (ESO)
 
4
C
 
5
C This program is free software; you can redistribute it and/or 
 
6
C modify it under the terms of the GNU General Public License as 
 
7
C published by the Free Software Foundation; either version 2 of 
 
8
C the License, or (at your option) any later version.
 
9
C
 
10
C This program is distributed in the hope that it will be useful,
 
11
C but WITHOUT ANY WARRANTY; without even the implied warranty of
 
12
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 
13
C GNU General Public License for more details.
 
14
C
 
15
C You should have received a copy of the GNU General Public 
 
16
C License along with this program; if not, write to the Free 
 
17
C Software Foundation, Inc., 675 Massachusetss Ave, Cambridge, 
 
18
C MA 02139, USA.
 
19
C
 
20
C Corresponding concerning ESO-MIDAS should be addressed as follows:
 
21
C       Internet e-mail: midas@eso.org
 
22
C       Postal address: European Southern Observatory
 
23
C                       Data Management Division 
 
24
C                       Karl-Schwarzschild-Strasse 2
 
25
C                       D 85748 Garching bei Muenchen 
 
26
C                       GERMANY
 
27
C===========================================================================
 
28
C
 
29
      SUBROUTINE FTSVAL(NAME,LEN,FLAG,GUESS,ERROR,FACTOR,ISTAT)                 
 
30
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++                   
 
31
C.COPYRIGHT: Copyright (c) 1987 European Southern Observatory,                  
 
32
C                                         all rights reserved                   
 
33
C                                                                               
 
34
C.VERSION: 1.0  ESO-FORTRAN Conversion, AA  17:25 - 13 JAN 1988                 
 
35
C                                                                               
 
36
C.LANGUAGE: F77+ESOext                                                          
 
37
C                                                                               
 
38
C.AUTHOR: J.D.PONZ                                                              
 
39
C                                                                               
 
40
C.IDENTIFICATION                                                                
 
41
C                                                                               
 
42
C  FITLIB.FOR   VERSION 1.0  27 MAR 1984                                        
 
43
C                                                                               
 
44
C.PURPOSE                                                                       
 
45
C                                                                               
 
46
C  INTERFACE ROUTINES FOR THE FITTING STRUCTURES                                
 
47
C SEARCH INITIAL VALUES OF THE PARAMETER                                        
 
48
C                                                                               
 
49
C.ALGORITHM                                                                     
 
50
C                                                                               
 
51
C  USE MIDAS I/O INTERFACES TO FRAMES AND TABLES                                
 
52
C                                                                               
 
53
C.KEYWORDS                                                                      
 
54
C                                                                               
 
55
C  NON LINEAR FITTING                                                           
 
56
C                                                                               
 
57
C                                                                               
 
58
C----------------------------------------------------------------               
 
59
C                                                                               
 
60
C                                                                               
 
61
C INPUT ARGUMENTS                                                               
 
62
C NAME CHAR PARAMETER NAME                                                      
 
63
C LEN INTG NUMBER OF BYTES IN NAME                                              
 
64
C                                                                               
 
65
C OUTPUT PARAMETERS                                                             
 
66
C FLAG INTG CONSTRAIN FLAG AS                                                   
 
67
C   <0 FREE PARAMETER                                                           
 
68
C    0 FIXED PARAMETER                                                          
 
69
C   >0 POINTER TO THE PROPORTIONAL PARAMETER                                    
 
70
C GUESS DBLE GUESS                                                              
 
71
C ERROR REAL OPTIONAL ERROR WEIGHT                                              
 
72
C FACTOR REAL OPTIONAL FACTOR FOR PROPORTIONAL PARAMETERS                       
 
73
C ISTAT INTG STATUS RETURN                                                      
 
74
C                                                                               
 
75
      CHARACTER*(*) NAME                                                        
 
76
      INTEGER FLAG,LEN,ISTAT,LEN1,I,II,II1,II2,ICASE                            
 
77
      INTEGER IAC,L2,J,IB,L1
 
78
      REAL ERROR,FACTOR,VALUE
 
79
      DOUBLE PRECISION DB,GUESS                                                 
 
80
      CHARACTER*20 TOKEN1,TOKEN2,TEST1,TEST2
 
81
      CHARACTER LINE*80,LINE1*80,C*1,NAME1*10                                   
 
82
       INCLUDE 'MID_INCLUDE:FITI.INC/NOLIST'                                     
 
83
       INCLUDE 'MID_INCLUDE:FITC.INC/NOLIST'                                     
 
84
C                                                                               
 
85
C ITERATION ON THE FUNCTION SPECIFICATION                                       
 
86
C                                                                               
 
87
      LEN1   = LEN + 1                                                          
 
88
      NAME1  = NAME(1:LEN)//'='                                                 
 
89
      DO 10 I = 1,FZNFUN                                                      
 
90
          LINE   = FZSPEC(I)                                                  
 
91
          II     = INDEX(LINE,NAME1(1:LEN1))                                    
 
92
          IF (II.NE.0) GO TO 20                                                 
 
93
   10 CONTINUE                                                                  
 
94
C                                                                               
 
95
C PARAMETER NOT INITIALIZED                                                     
 
96
C                                                                               
 
97
      FLAG   = -1                                                               
 
98
      GUESS  = 0.D0                                                             
 
99
      ERROR  = 0.                                                               
 
100
      FACTOR = 0.                                                               
 
101
      RETURN                                                                    
 
102
C                                                                               
 
103
C DECODE THE PARAMETER VALUE OR CONSTRAIN                                       
 
104
C                                                                               
 
105
   20 II     = II + LEN1                                                        
 
106
      LINE1  = LINE(II:)                                                        
 
107
      DO 30 I = 1,80                                                            
 
108
          C      = LINE1(I:I)                                                   
 
109
          IF (C.EQ.' ') GO TO 40                                                
 
110
   30 CONTINUE                                                                  
 
111
   40 II     = I - 1                                                            
 
112
C                                                                               
 
113
C CHECK ONE OF THE FOLLOWING RULES                                              
 
114
C LINE1(1:II) = value                                                           
 
115
C        value@                                                                 
 
116
C        value*param                                                            
 
117
C        param*value                                                            
 
118
C        param/value                                                            
 
119
C        param                                                                  
 
120
C  !   value@                                                                   
 
121
      IF (LINE1(II:II).EQ.'@') THEN                                             
 
122
          TOKEN1 = LINE1(1:II-1)                                                
 
123
          L1     = II - 1                                                       
 
124
          ICASE  = 1                                                            
 
125
      ELSE                                                                      
 
126
          II1    = INDEX(LINE1(1:II),'*')  !   value*param or param*value       
 
127
          IF (II1.NE.0) THEN                                                    
 
128
              TOKEN1 = LINE1(1:II1-1)                                           
 
129
              L1     = II1 - 1                                                  
 
130
              TOKEN2 = LINE1(II1+1:II)                                          
 
131
              L2     = II - II1                                                 
 
132
              ICASE  = 3                                                        
 
133
          ELSE                                                                  
 
134
              II2    = INDEX(LINE1(1:II),'/')  !   param/value                  
 
135
              IF (II2.NE.0) THEN                                                
 
136
                  TOKEN1 = LINE1(1:II2-1)                                       
 
137
                  L1     = II2 - 1                                              
 
138
                  TOKEN2 = LINE1(II2+1:II)                                      
 
139
                  L2     = II - II2                                             
 
140
                  ICASE  = 4                                                    
 
141
              ELSE                                                              
 
142
                  II1    = INDEX('-+.0123456789',LINE1(1:1))  !   param         
 
143
                  IF (II1.EQ.0) THEN                                            
 
144
                      ICASE  = 5                                                
 
145
                      VALUE  = 1.                                               
 
146
                  ELSE  !   value                                               
 
147
                      ICASE  = 2                                                
 
148
                  END IF                                                        
 
149
                  TOKEN1 = LINE1                                                
 
150
                  L1     = II                                                   
 
151
              END IF                                                            
 
152
          END IF                                                                
 
153
      END IF                                                                    
 
154
      IF (ICASE.LE.2) THEN                                                      
 
155
          CALL GENCNV(TOKEN1(1:L1),2,1,IB,VALUE,DB,IAC)                         
 
156
          GUESS  = VALUE                                                        
 
157
          IF (IAC.LT.0) GO TO 60                                                
 
158
          ERROR  = 0.                                                           
 
159
          FLAG   = -1                                                           
 
160
          FACTOR = 0.                                                           
 
161
          IF (ICASE.EQ.1) FLAG   = 0                                            
 
162
      ELSE                                                                      
 
163
          II     = INDEX('+-1234567890.',TOKEN1(1:1))  !   TOKEN1 is parameter  
 
164
          IF (II.EQ.0) THEN                                                     
 
165
              IF (ICASE.NE.5) 
 
166
     .           CALL GENCNV(TOKEN2(1:L2),2,1,IB,VALUE,DB,IAC)
 
167
              IF (IAC.LT.0) GO TO 60                                            
 
168
              ERROR  = 0.                                                       
 
169
              IF (ICASE.EQ.3 .OR. ICASE.EQ.5) THEN                              
 
170
                  FACTOR = VALUE                                                
 
171
              ELSE                                                              
 
172
                  IF (VALUE.EQ.0.) GO TO 60                                     
 
173
                  FACTOR = 1./VALUE                                             
 
174
              END IF                                                            
 
175
          ELSE  !   value/param not supported                                   
 
176
              IF (ICASE.EQ.4) GO TO 60                                          
 
177
              CALL GENCNV(TOKEN1(1:L1),2,1,IB,VALUE,DB,IAC)                     
 
178
              IF (IAC.LT.0) GO TO 60                                            
 
179
              FACTOR = VALUE                                                    
 
180
              TOKEN1 = TOKEN2                                                   
 
181
              L1     = L2                                                       
 
182
          END IF                                                                
 
183
C                                                                               
 
184
C SEARCH FOR PARAMETER TOKEN1                                                   
 
185
C                                                                               
 
186
          TEST1 = TOKEN1
 
187
          CALL FORUPC(TEST1, TEST1)
 
188
          DO 50 J = 1,FZNPTOT                      
 
189
              TEST2 = FZPTOKEN(J)
 
190
              CALL FORUPC(TEST2, TEST2)                           
 
191
              IF (TEST2(1:FZPLEN(J)).EQ.TEST1(1:L1)) THEN           
 
192
                  IF (FZFIXED(J).GT.0) GO TO 60                               
 
193
                  FLAG   = J                                                    
 
194
                  RETURN                                                        
 
195
              END IF                                                            
 
196
   50     CONTINUE                                                              
 
197
          ISTAT  = FERCON                                                   
 
198
      END IF                                                                    
 
199
      RETURN                                                                    
 
200
   60 ISTAT  = FERCON                                                       
 
201
      RETURN                                                                    
 
202
      END