← Back to branch summary

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

« back to all changes in this revision

Viewing changes to applic/fit/src/fittable.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/fittable.for
 
1
C @(#)fittable.for      19.1 (ES0-DMD) 02/25/03 13:18:46
 
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
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
30
C.COPYRIGHT: Copyright (c) 1987 European Southern Observatory,
 
31
C                                         all rights reserved
 
32
C
 
33
C.VERSION: 1.2  ESO-FORTRAN Conversion, AA  14:17 - 19 NOV 1989
 
34
C
 
35
C.LANGUAGE: F77+ESOext
 
36
C
 
37
C.AUTHOR: J.D.PONZ
 
38
C
 
39
C.IDENTIFICATION:
 
40
C         PROGRAM fittable
 
41
C
 
42
C.PURPOSE
 
43
C
 
44
C  Copy fit file into table format for editing
 
45
C
 
46
C.KEYWORDS
 
47
C
 
48
C ARITHMETIC OPERATS, TABLES.
 
49
C
 
50
C.ALGORITHM
 
51
C
 
52
C USE TABLE INTERFACE ROUTINES
 
53
C
 
54
C-----------------------------------------------------------
 
55
C
 
56
      PROGRAM FITTBL
 
57
      IMPLICIT NONE
 
58
C
 
59
C      CHARACTER*72  LINE
 
60
      CHARACTER*60  FILENA, TABLE
 
61
      CHARACTER*80 SPEC
 
62
      CHARACTER*60  FUNC, PARM
 
63
      CHARACTER*16  LABEL1, LABEL2, UNIT
 
64
      CHARACTER*10  FORM
 
65
      INTEGER       KUN, KNUL, STAT, IC, TID, NROW, I, II
 
66
      INTEGER       INDEX, NW, NC, IFILE, J
 
67
      INTEGER       MADRID(1)
 
68
C
 
69
      INCLUDE      'MID_INCLUDE:ST_DEF.INC'
 
70
      INCLUDE      'MID_INCLUDE:FITI.INC'
 
71
      INCLUDE      'MID_INCLUDE:FITC.INC'
 
72
      COMMON/VMR/MADRID
 
73
      INCLUDE      'MID_INCLUDE:ST_DAT.INC'
 
74
      DATA          FILENA/'   '/
 
75
      DATA          LABEL1/'FUNCTIONS   '/
 
76
      DATA          LABEL2/'PARAMETERS  '/
 
77
      DATA          UNIT/'             '/
 
78
      DATA          FORM/'A60    '/
 
79
C
 
80
C ... GET INTO MIDAS
 
81
C
 
82
      CALL STSPRO('TOPERTBL')
 
83
      CALL FITBL
 
84
C
 
85
C ... GET COMMAND FORM ENVIRONMENT
 
86
C
 
87
      CALL STKRDC('IN_A',1,1,60,I,FILENA,KUN,KNUL,STAT)
 
88
      CALL STKRDI('INPUTI',1,1,I,IFILE,KUN,KNUL,STAT)
 
89
C
 
90
C ... INITIALIZE FIT FILE
 
91
C
 
92
      IF (IFILE .EQ. 0) THEN
 
93
           CALL STTPUT(' Info: New fit file ', STAT)
 
94
           CALL FTINI1(STAT)
 
95
      ELSE
 
96
           CALL STTPUT(' Info: Fit file already exists ', STAT)
 
97
           CALL FTINIT(FILENA, STAT)
 
98
      ENDIF
 
99
C
 
100
C ... INITIALIZE TABLE FILE
 
101
C
 
102
      I     = INDEX(FILENA,'.')
 
103
      IF (I .EQ. 0) I = INDEX(FILENA,' ')
 
104
      I     = I - 1
 
105
      TABLE = FILENA(1:I)//'_fit '
 
106
      CALL STKWRC('OUT_A',1,TABLE,1,60,KUN,STAT)
 
107
      NC    = 60
 
108
      NROW  = 20
 
109
      NW    = NC/2
 
110
      CALL TBTINI(TABLE, F_TRANS, F_O_MODE, NW, NROW, TID, STAT)
 
111
      CALL TBCINI(TID, D_C_FORMAT, NC, FORM, UNIT, LABEL1, IC, STAT)
 
112
      CALL TBCINI(TID, D_C_FORMAT, NC, FORM, UNIT, LABEL2, IC, STAT)
 
113
C
 
114
C ... INITIALIZE TABLE DATA
 
115
C
 
116
      DO 10 I = 1, NROW
 
117
         IF (I .LE. FZNFUN ) THEN
 
118
             CALL FTRDFN(I, SPEC, STAT)
 
119
             II   = INDEX(SPEC,')')
 
120
             FUNC = SPEC(1:II)
 
121
             II   = II + 1
 
122
             DO 5 J = II, 80
 
123
                IF (SPEC(J:J) .NE. ' ') GOTO 6
 
124
5            CONTINUE
 
125
C
 
126
C ... END OF STRUCTURED CODE
 
127
C
 
128
6            PARM = SPEC(J:) 
 
129
C
 
130
C
 
131
         ELSE
 
132
             FUNC = ' '
 
133
             PARM = ' '
 
134
         ENDIF
 
135
         CALL TBEWRC(TID, I, 1, FUNC, STAT)
 
136
         CALL TBEWRC(TID, I, 2, PARM, STAT)
 
137
10    CONTINUE
 
138
      CALL TBTCLO(TID, STAT)
 
139
      FZMAPPED = 0
 
140
      IF (IFILE .EQ. 0) THEN
 
141
           CALL FTEXT1(FILENA, STAT)
 
142
      ELSE
 
143
           CALL FTEXIT(FILENA, STAT)
 
144
      ENDIF
 
145
C
 
146
C ... EXIT FROM MIDAS
 
147
C
 
148
      CALL STSEPI
 
149
      END
 
150
C      BLOCK DATA
 
151
C      INCLUDE      'MID_INCLUDE:FITI.INC'
 
152
C      INCLUDE      'MID_INCLUDE:FITC.INC'
 
153
C      INCLUDE      'MID_INCLUDE:FITD.INC'
 
154
C      END