← Back to branch summary

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

« back to all changes in this revision

Viewing changes to applic/fit/src/fitimag.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/src/fitimag.for
 
1
C===========================================================================
 
2
C Copyright (C) 1995,2004 European Southern Observatory (ESO)
 
3
C
 
4
C This program is free software; you can redistribute it and/or 
 
5
C modify it under the terms of the GNU General Public License as 
 
6
C published by the Free Software Foundation; either version 2 of 
 
7
C the License, or (at your option) any later version.
 
8
C
 
9
C This program is distributed in the hope that it will be useful,
 
10
C but WITHOUT ANY WARRANTY; without even the implied warranty of
 
11
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 
12
C GNU General Public License for more details.
 
13
C
 
14
C You should have received a copy of the GNU General Public 
 
15
C License along with this program; if not, write to the Free 
 
16
C Software Foundation, Inc., 675 Massachusetts Ave, Cambridge, 
 
17
C MA 02139, USA.
 
18
C
 
19
C Correspondence concerning ESO-MIDAS should be addressed as follows:
 
20
C       Internet e-mail: midas@eso.org
 
21
C       Postal address: European Southern Observatory
 
22
C                       Data Management Division 
 
23
C                       Karl-Schwarzschild-Strasse 2
 
24
C                       D 85748 Garching bei Muenchen 
 
25
C                       GERMANY
 
26
C===========================================================================
 
27
C
 
28
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
29
C
 
30
C.COPYRIGHT: Copyright (c) 1987,2004 European Southern Observatory,
 
31
C                                         all rights reserved
 
32
C
 
33
C.VERSION: 1.0  ESO-FORTRAN Conversion, AA  18:13 - 21 DEC 1987
 
34
C
 
35
C.LANGUAGE: F77+ESOext
 
36
C
 
37
C.AUTHOR: J.D.PONZ
 
38
C
 
39
C.IDENTIFICATION
 
40
C
 
41
C  program FITIMAG.FOR
 
42
C
 
43
C.PURPOSE
 
44
C
 
45
C  Execute the commands
 
46
C  FIT/IMA [iter[,chisq[,relax]]] image[,error] [FZname]
 
47
C  FIT/IMA [iter[,chisq[,relax]]] GCURSOR         [FZname]
 
48
C  FIT/IMA [iter[,chisq[,relax]]] CURSOR  [FZname] - NOT YET IMPLEM.
 
49
C
 
50
C  FIT/TAB [iter[,chisq[,relax]]] table dep[,err] ind.vars [FZname]
 
51
C
 
52
C.KEYWORDS
 
53
C
 
54
C  FIT
 
55
C
 
56
C.INPUT/OUTPUT
 
57
C
 
58
C  P1 - P8     contain input parameters
 
59
C
 
60
C.ALGORITHM
 
61
C
 
62
C  Use fit interface routines
 
63
C
 
64
C.VERSION
 
65
C 040521        last modif
 
66
C 
 
67
C-----------------------------------------------------------
 
68
C
 
69
C
 
70
C ... define parameters
 
71
C
 
72
      IMPLICIT NONE
 
73
C
 
74
      INTEGER IVAR(8),FIX(20),KUN,KNUL, NP
 
75
      INTEGER ISTAT, I, II, IAV, NIND, NPAR
 
76
      INTEGER NFUN,NDAT,N,J,IDVAR,NL,NACT,NAMLEN,MM,IVAL
 
77
C
 
78
      REAL CHISQ,VAL1,VAL2
 
79
C
 
80
      DOUBLE PRECISION PAR(20),ERR(20),DVAL
 
81
C
 
82
      CHARACTER*80 FNAME,NAME,FILE,MASK,LINE1
 
83
      CHARACTER    IAC*1,AUX*30,AUX1*30
 
84
      CHARACTER    LINE2*80,TYPE*4,LINE*80
 
85
      CHARACTER    LINE3*80
 
86
      CHARACTER*80 HEAD,OUT,HEADER
 
87
      CHARACTER*16 MSG
 
88
      CHARACTER*4  PPRINT
 
89
C
 
90
      INCLUDE 'MID_INCLUDE:FITI.INC/NOLIST'
 
91
      INCLUDE 'MID_INCLUDE:FITC.INC/NOLIST'
 
92
C
 
93
      DOUBLE PRECISION OURSTART(FZINDMAX),OURSTEP(FZINDMAX)
 
94
C 
 
95
      DATA NAMLEN/80/
 
96
      DATA MSG/'ERR:FITIMAGxxxx'/
 
97
      DATA HEAD/' Parameter Initial Guess      Actual Value       Error'
 
98
     +     /
 
99
C
 
100
C ... get into MIDAS
 
101
C
 
102
      CALL STSPRO('FITIMAG')
 
103
      CALL FITBL
 
104
      CALL STKRDC('P2',1,1,NAMLEN,I,LINE3,KUN,KNUL,ISTAT)
 
105
      II     = INDEX(LINE3,',')
 
106
      IF (II.EQ.0) THEN
 
107
          FILE   = LINE3
 
108
          MASK   = ' '
 
109
      ELSE
 
110
          FILE   = LINE3(1:II-1)
 
111
          MASK   = LINE3(II+1:)
 
112
      END IF
 
113
      CALL STKRDC('P3',1,1,NAMLEN,II,LINE1,KUN,KNUL,ISTAT)
 
114
      IF (LINE1(1:1).EQ.':' .OR. LINE1(1:1).EQ.'#') THEN
 
115
          IAC    = 'T'
 
116
          CALL STKRDC('P4',1,1,80,IAV,LINE2,KUN,KNUL,ISTAT)
 
117
          CALL STKRDC('P5',1,1,NAMLEN,IAV,NAME,KUN,KNUL,ISTAT)
 
118
      ELSE
 
119
          IAC    = 'I'
 
120
          NAME   = LINE1
 
121
      END IF
 
122
      IF (NAME(1:1).EQ.'?') THEN
 
123
          CALL STKRDC('FITNAME',1,1,NAMLEN,IAV,NAME,KUN,KNUL,ISTAT)
 
124
      ELSE
 
125
          CALL STKWRC('FITNAME',1,NAME,1,NAMLEN,KUN,ISTAT)
 
126
      END IF
 
127
      CALL STKRDR('INPUTR',1,9,IAV,FZMETPAR(2),KUN,KNUL,ISTAT)
 
128
      CALL STKRDC('FITCHAR',1,21,4,IAV,PPRINT,KUN,KNUL,ISTAT)
 
129
      CALL GENCNV(PPRINT,2,1,IVAL,FZMETPAR(1),DVAL,MM)
 
130
      VAL1 = 0.0
 
131
      VAL2 = 0.0
 
132
C
 
133
C ... fit for image - start, step from image => fit-function
 
134
C
 
135
      IF (IAC.EQ.'I') THEN
 
136
          CALL FTIMAG(FILE,MASK,ISTAT)
 
137
      ELSE
 
138
          CALL FTTABL(FILE,LINE1,LINE2,ISTAT)
 
139
      END IF
 
140
C 
 
141
C  FTINIT overwrites FZSTART, FZSTEP - so save them
 
142
C 
 
143
      DO 100, I = 1,FZINDMAX
 
144
         OURSTART(I) = FZSTART(I)
 
145
         OURSTEP(I) = FZSTEP(I)
 
146
100   CONTINUE
 
147
      CALL FTINIT(NAME,ISTAT)
 
148
      DO 200, I = 1,FZINDMAX
 
149
         FZSTART(I) = OURSTART(I)
 
150
         FZSTEP(I) = OURSTEP(I)
 
151
200   CONTINUE
 
152
C
 
153
      CALL FTDODO(NINT(FZMETPAR(2)),FZMETPAR(4),FZMETPAR(3),VAL1,
 
154
     +            VAL2,NACT,CHISQ,ISTAT)
 
155
C
 
156
C ... read parameters
 
157
C
 
158
      CALL FTINFO(FILE,TYPE,IDVAR,NIND,NFUN,NDAT,ISTAT)
 
159
      LINE   = ' No. of data points '
 
160
      WRITE (LINE(25:32),9030) NDAT
 
161
      CALL STTPUT(LINE,ISTAT)
 
162
C
 
163
      CALL STTPUT(' ',ISTAT)
 
164
      IF (TYPE.EQ.'TBL ') THEN
 
165
          LINE   = ' Dependent variable '
 
166
          WRITE (LINE(25:28),9000) IDVAR
 
167
          CALL STTPUT(LINE,ISTAT)
 
168
      END IF
 
169
      LINE   = ' No. of ind. variables '
 
170
      WRITE (LINE(25:28),9000) NIND
 
171
      CALL STTPUT(LINE,ISTAT)
 
172
C
 
173
C ... read fit variables
 
174
C
 
175
      IF (NIND.GT.0) THEN
 
176
          CALL FTRDIN(NIND,IVAR,N,ISTAT)
 
177
          IF (TYPE.EQ.'BDF ') THEN
 
178
              LINE   = ' variable .... is axis   ....'
 
179
          ELSE
 
180
              IF (TYPE.EQ.'TBL ') THEN
 
181
                  LINE   = ' variable .... is column ....'
 
182
              ELSE  !   DO NOT PRINT IVAR
 
183
                  NIND   = 0
 
184
              END IF
 
185
          END IF
 
186
          DO 20 I = 1,NIND
 
187
              WRITE (LINE(11:14),9000) I
 
188
              WRITE (LINE(26:29),9000) IVAR(I)
 
189
              CALL STTPUT(LINE,ISTAT)
 
190
   20     CONTINUE
 
191
      END IF
 
192
C
 
193
C ... read coeffs
 
194
C
 
195
      CALL STTPUT(' ',ISTAT)
 
196
      LINE   = ' No. of functions '
 
197
      WRITE (LINE(25:28),9000) NFUN
 
198
      CALL STTPUT(LINE,ISTAT)
 
199
      NP     = 0
 
200
      DO 40 I = 1,NFUN
 
201
          CALL STTPUT(' ',ISTAT)
 
202
          CALL FTRDFN(I,LINE,ISTAT)
 
203
          II     = INDEX(LINE,')')
 
204
          CALL STTPUT(LINE(1:II),ISTAT)
 
205
          CALL STTPUT(HEAD,ISTAT)
 
206
          CALL FTRDPR(I,FNAME,NPAR,PAR,ERR,FIX,ISTAT)
 
207
          LINE   = FZSPEC(I)
 
208
          IF (NPAR.GT.0) THEN
 
209
              DO 30 J = 1,NPAR
 
210
                  NP     = NP + 1
 
211
                  NL     = FZPLEN(NP)
 
212
                  AUX    = FZPTOKEN(NP)
 
213
                  AUX1   = AUX(1:NL)//'='
 
214
                  II     = INDEX(LINE,AUX1(1:NL+1))
 
215
                  IF (II.EQ.0) THEN
 
216
                      AUX1   = '-'
 
217
                  ELSE
 
218
                      AUX    = LINE(II+NL+1:)
 
219
                      II     = INDEX(AUX,' ') - 1
 
220
                      AUX1   = AUX(1:II)
 
221
                  END IF
 
222
                  WRITE (OUT,9010) FZPTOKEN(NP),AUX1(1:16),PAR(J),
 
223
     +              ERR(J)
 
224
                  CALL STTPUT(OUT,ISTAT)
 
225
   30         CONTINUE
 
226
          END IF
 
227
   40 CONTINUE
 
228
C
 
229
C ... end
 
230
C
 
231
      CALL STTPUT(' ',ISTAT)
 
232
      CALL STTPUT('     Red. Chisq      Act. Nr. F. Eval.',ISTAT)
 
233
      WRITE (HEADER,9020) FZCCHIS,FZNITER
 
234
      CALL STTPUT(HEADER,ISTAT)
 
235
      CALL STTPUT(' ',ISTAT)
 
236
      CALL FTEXIT(NAME,ISTAT)
 
237
      IF (ISTAT.NE.0) THEN
 
238
          WRITE (MSG(13:16),9000) ISTAT
 
239
C   CALL TDERRR(ISTAT,MSG,STATUS)
 
240
      END IF
 
241
      CALL STSEPI
 
242
 9000 FORMAT (I4)
 
243
 9010 FORMAT (1X,A,2X,A,1X,E14.6,1X,E14.6)
 
244
 9020 FORMAT (3X,1PE12.4,12X,I6)
 
245
 9030 FORMAT (I8)
 
246
      END
 
247