← Back to branch summary

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

« back to all changes in this revision

Viewing changes to applic/fit/libsrc/ftinit.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/ftinit.for
 
1
C===========================================================================
 
2
C Copyright (C) 1995-2005 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
      SUBROUTINE FTINIT(NAME,ISTAT)                                             
 
29
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++                   
 
30
C                                                                               
 
31
C.VERSION: 1.0  ESO-FORTRAN Conversion, AA  17:25 - 13 JAN 1988                 
 
32
C                                                                               
 
33
C.LANGUAGE: F77+ESOext                                                          
 
34
C                                                                               
 
35
C.AUTHOR: J.D.PONZ                                                              
 
36
C                                                                               
 
37
C.IDENTIFICATION                                                                
 
38
C                                                                               
 
39
C  FITLIB.FOR   VERSION 1.0  27 MAR 1984                                        
 
40
C                                                                               
 
41
C.PURPOSE                                                                       
 
42
C                                                                               
 
43
C  INTERFACE ROUTINES FOR THE FITTING STRUCTURES                                
 
44
C INIT FIT SESSION                                                              
 
45
C READ FIT FILE NAME.FIT                                                        
 
46
C                                                                               
 
47
C.ALGORITHM                                                                     
 
48
C  use MIDAS I/O interfaces to frames and tables                                
 
49
C                                                                               
 
50
C.KEYWORDS                                                                      
 
51
C  non linear fitting                                                           
 
52
C                                                                               
 
53
C.VERSION
 
54
C 051109        last modif
 
55
C 
 
56
C----------------------------------------------------------------               
 
57
C                                                                               
 
58
C                                                                               
 
59
C INPUT PARAMETERS                                                              
 
60
C NAME CHAR FIT DATA FILE NAME                                                  
 
61
C                                                                               
 
62
C OUTPUT PARAMETERS                                                             
 
63
C ISTAT INTG STATUS RETURN                                                      
 
64
C                                                                               
 
65
      IMPLICIT NONE
 
66
C 
 
67
      INTEGER ISTAT,II,IP,NACT,NI,NR,N1,I1
 
68
      INTEGER EUC,EUL,EUD,I,DNUL,DUN,ACT
 
69
C 
 
70
      CHARACTER*(*) NAME                                                        
 
71
      CHARACTER WS*5,FITSPEC*7
 
72
      CHARACTER*60 FITNAME                                                      
 
73
C 
 
74
      INCLUDE 'MID_INCLUDE:ST_DEF.INC/NOLIST'
 
75
      INCLUDE 'MID_INCLUDE:FITI.INC/NOLIST'                                     
 
76
C
 
77
      DOUBLE PRECISION STASTEP(2*FZINDMAX)
 
78
C
 
79
      INCLUDE 'MID_INCLUDE:FITC.INC/NOLIST'                                     
 
80
      INCLUDE 'MID_INCLUDE:ST_DAT.INC/NOLIST'
 
81
      DATA FITSPEC/'FIT....'/                                       
 
82
C                                                                               
 
83
C READ DATA                                                                     
 
84
C                                                                               
 
85
      II     = INDEX(NAME,' ') - 1                                         
 
86
      FITNAME = NAME(1:II)//'.fit'                                              
 
87
      CALL STFOPN(FITNAME,D_R4_FORMAT,0,F_FIT_TYPE,IP,ISTAT)
 
88
      IF (FZTYPE(1:1).EQ.' ') THEN                                            
 
89
          CALL STDRDC(IP,'FITCHAR',1,1, 
 
90
     +         FZNCHAR,NACT,FZCHAR,DNUL,DUN,ISTAT) 
 
91
          NI     = FZNINTG                                                    
 
92
          NR     = FZNREAL                                                    
 
93
      ELSE                                                                      
 
94
          NI     = FZCINTG                                                    
 
95
          NR     = FZCREAL                                                    
 
96
      END IF                                                                    
 
97
      CALL STDRDI(IP,'FITINTG',1,NI,ACT,FZINTG,DUN,DNUL,ISTAT)                  
 
98
      CALL STDRDR(IP,'FITREAL',1,NR,ACT,FZREAL,DUN,DNUL,ISTAT)                
 
99
C 
 
100
      IF (FZNPTOT.EQ.0) THEN
 
101
         N1 = 128
 
102
      ELSE
 
103
         N1 = FZNPTOT
 
104
      ENDIF
 
105
      CALL STDRDD(IP,'FITPARAM',1,N1,ACT,FZVALUE,DUN,DNUL,ISTAT)
 
106
      CALL STDRDD(IP,'FITERROR',1,N1,ACT,FZERROR,DUN,DNUL,ISTAT)
 
107
C 
 
108
      CALL STECNT('GET',EUC,EUL,EUD)                                            
 
109
      CALL STECNT('PUT',1,0,0)                                                  
 
110
      N1 = 2 * FZINDMAX
 
111
      CALL STDRDD(IP,'FITDOUBLE',1,N1,ACT,STASTEP,DUN,DNUL,ISTAT)
 
112
      IF (ISTAT.NE.0) THEN                                                
 
113
         DO 90,II=1,FZINDMAX 
 
114
            FZSTART(II) = 0.D0
 
115
            FZSTEP(II) = 1.D0
 
116
90       CONTINUE                                                              
 
117
      ELSE
 
118
         DO 100,II=1,FZINDMAX                  !get start, step from FITDOUBLE
 
119
            FZSTART(II) = STASTEP(II)
 
120
            FZSTEP(II) = STASTEP(II+FZINDMAX)
 
121
100      CONTINUE
 
122
      END IF                                                                    
 
123
C 
 
124
      CALL STDRDI(IP,'FITSELE',1,FZFUNMAX,ACT,FZSELE,DUN,DNUL,ISTAT) 
 
125
      CALL STECNT('PUT',EUC,EUL,EUD)                                            
 
126
      IF (ISTAT.NE.0) THEN                                                
 
127
         DO 1000,I = 1,FZFUNMAX 
 
128
            FZSELE(I) = 1                                                   
 
129
1000     CONTINUE                                                              
 
130
      END IF                                                                    
 
131
C                                                                               
 
132
C ASSIGN FUNCTION NAMES                                                         
 
133
C                                                                               
 
134
      DO 2000,I = FZNFUN + 1,FZFUNMAX                                         
 
135
         FZSPEC(I) = ' '                                                     
 
136
2000  CONTINUE                                                                  
 
137
      FZNPTOT = 0                                                             
 
138
      I1     = FZNFUN                                                         
 
139
      FZNFUN = 0                                                              
 
140
      DO 3000,I = 1,I1  
 
141
         WRITE (WS,9000) 10000 + I                                             
 
142
         FITSPEC(4:7) = WS(2:5)                                                
 
143
         CALL STDRDC(IP,FITSPEC,1,1,80,ACT,FZSPEC(I),DNUL,
 
144
     +               DUN,ISTAT)            
 
145
         CALL FTDFUN(I,FZSPEC(I),ISTAT)                                      
 
146
3000  CONTINUE                                                                  
 
147
      CALL FTPARV(ISTAT)                                                        
 
148
      RETURN                                                                    
 
149
C 
 
150
9000  FORMAT (I5)                                                               
 
151
      END