← Back to branch summary

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

« back to all changes in this revision

Viewing changes to libsrc/ftoc-old/tba.fc

  • 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:
libsrc/ftoc-old/tba.fc
 
1
/* @(#)tba.fc   19.1 (ESO-IPG) 02/25/03 13:54:16 */
 
2
/*===========================================================================
 
3
  Copyright (C) 1995 European Southern Observatory (ESO)
 
4
 
 
5
  This program is free software; you can redistribute it and/or 
 
6
  modify it under the terms of the GNU General Public License as 
 
7
  published by the Free Software Foundation; either version 2 of 
 
8
  the License, or (at your option) any later version.
 
9
 
 
10
  This program is distributed in the hope that it will be useful,
 
11
  but WITHOUT ANY WARRANTY; without even the implied warranty of
 
12
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 
13
  GNU General Public License for more details.
 
14
 
 
15
  You should have received a copy of the GNU General Public 
 
16
  License along with this program; if not, write to the Free 
 
17
  Software Foundation, Inc., 675 Massachusetss Ave, Cambridge, 
 
18
  MA 02139, USA.
 
19
 
 
20
  Corresponding concerning ESO-MIDAS should be addressed as follows:
 
21
        Internet e-mail: midas@eso.org
 
22
        Postal address: European Southern Observatory
 
23
                        Data Management Division 
 
24
                        Karl-Schwarzschild-Strasse 2
 
25
                        D 85748 Garching bei Muenchen 
 
26
                        GERMANY
 
27
===========================================================================*/
 
28
 
 
29
/*+++++++++++++
 
30
.IDENTIFICATION tba.fc
 
31
.LANGUAGE       C
 
32
.AUTHOR         M. Peron (ESO-IPG))
 
33
.KEYWORDS       Table system, FORTRAN interface
 
34
.ENVIRONMENT
 
35
.VERSION  1.0   22-dec-1992: first version
 
36
.COMMENTS       FORTRAN 77 to C interface layer.
 
37
---------------*/
 
38
#include <tbldef.h>
 
39
#include <ftoc.h>
 
40
#include <ftoc_comm.h>          /* VMR common */
 
41
#include <ftoc_log.h>           /* LOGICAL    */
 
42
#include <midas_def.h>
 
43
 
 
44
ROUTINE TBAMAP(tid,row,col,index,status)
 
45
/*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
46
.PURPOSE Return the address of the COMPLETE element array
 
47
.RETURNS status
 
48
------------------------------------------------------------------*/
 
49
fint2c       *tid;
 
50
fint2c       *row;
 
51
fint2c       *col;
 
52
flong2c      *index;
 
53
fint2c       *status;
 
54
{
 
55
      char  *mypntr;
 
56
      *status = TCAMAP(*tid,*row,*col,&mypntr);
 
57
      *index  = COMMON_INDEX(mypntr);
 
58
}
 
59
 
 
60
ROUTINE TBAUNM(tid,index,status)
 
61
/*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
62
.PURPOSE Unmap a part of the file that was mapped.
 
63
.RETURNS status (-1 if not mapped)
 
64
-------------------------------------------------------------*/
 
65
fint2c       *tid;
 
66
fint2c       *index;
 
67
fint2c       *status;
 
68
{
 
69
      *status = TCAUNM(*tid,(char *)&((&vmr.addr)[*index-1]));
 
70
}
 
71
 
 
72
ROUTINE TBADEL(tid,row,col,index,items,status)
 
73
/*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
74
.PURPOSE Deletes  table elements.
 
75
.METHOD  Writes a NULL value in the table.
 
76
.RETURNS status
 
77
-------------------------------------------------------------*/
 
78
fint2c        *tid;
 
79
fint2c        *row;
 
80
fint2c        *col;
 
81
fint2c        *index;
 
82
fint2c        *items;
 
83
fint2c        *status;
 
84
{
 
85
      *status  = TCADEL(*tid,*row,*col,*index,*items);
 
86
}
 
87
    
 
88
 
 
89
SUBROUTINE TBAWRC(tid, row, col, index, items, value,status)
 
90
/*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
91
.PURPOSE Writes table element, character string format.
 
92
.RETURNS status
 
93
-------------------------------------------------------------*/
 
94
fint2c        *tid;
 
95
fint2c        *row;
 
96
fint2c        *col;
 
97
fint2c        *index; 
 
98
fint2c        *items;
 
99
CHARACTER   value;
 
100
fint2c        *status;
 
101
{
 
102
      *status = TCAWRC(*tid,*row,*col,*index,*items,C_STRING(value)); 
 
103
}
 
104
 
 
105
ROUTINE TBAWRD(tid, row, col, index, items, value,status)
 
106
/*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
107
.PURPOSE Writes table element, double precision argument.
 
108
.RETURNS status
 
109
-------------------------------------------------------------*/
 
110
fint2c        *tid;
 
111
fint2c        *row;
 
112
fint2c        *col;
 
113
fint2c        *index;
 
114
fint2c        *items;
 
115
double      *value;
 
116
fint2c        *status;
 
117
{
 
118
      *status = TCAWRD(*tid,*row,*col,*index,*items,value); 
 
119
}
 
120
 
 
121
ROUTINE TBAWRI(tid, row, col, index, items, value,status)
 
122
/*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
123
.PURPOSE Writes table element, double precision argument.
 
124
.RETURNS status
 
125
-------------------------------------------------------------*/
 
126
fint2c        *tid;
 
127
fint2c        *row;
 
128
fint2c        *col;
 
129
fint2c        *index;
 
130
fint2c        *items;
 
131
fint2c        *value;
 
132
fint2c        *status;
 
133
{
 
134
      *status = TCAWRI(*tid,*row,*col,*index,*items,value);
 
135
}
 
136
 
 
137
ROUTINE TBAWRR(tid, row, col, index, items, value,status)
 
138
/*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
139
.PURPOSE Writes table element, double precision argument.
 
140
.RETURNS status
 
141
-------------------------------------------------------------*/
 
142
fint2c        *tid;
 
143
fint2c        *row;
 
144
fint2c        *col;
 
145
fint2c        *index;
 
146
fint2c        *items;
 
147
float       *value;
 
148
fint2c        *status;
 
149
{
 
150
      *status = TCAWRR(*tid,*row,*col,*index,*items,value);
 
151
}
 
152
 
 
153
SUBROUTINE TBARDC(tid, row, col, index, items, value,status)
 
154
/*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
155
.PURPOSE Reads table element as a character string.
 
156
         Arrays are edited with a comma between elements.
 
157
.RETURNS        status (error and non-selected)
 
158
-------------------------------------------------------------*/
 
159
fint2c        *tid;
 
160
fint2c        *row;
 
161
fint2c        *col;
 
162
fint2c        *index;
 
163
fint2c        *items;
 
164
CHARACTER   value;
 
165
fint2c        *status;
 
166
{
 
167
      char myvalue[TBL_ROWLEN+1];
 
168
      *status = TCARDC(*tid,*row,*col,*index,*items,myvalue);
 
169
      STRFCOPY(value, myvalue);
 
170
 
 
171
}
 
172
 
 
173
 
 
174
ROUTINE TBARDD(tid, row, col, index, items, value,status)
 
175
/*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
176
.PURPOSE Reads table element as a double precision number.
 
177
         Arrays are edited with a comma between elements.
 
178
.RETURNS        status (error and non-selected)
 
179
-------------------------------------------------------------*/
 
180
fint2c        *tid;
 
181
fint2c        *row;
 
182
fint2c        *col;
 
183
fint2c        *index;
 
184
fint2c        *items;
 
185
double      *value;
 
186
fint2c        *status;
 
187
{
 
188
      *status = TCARDD(*tid,*row,*col,*index,*items,value);
 
189
}
 
190
 
 
191
ROUTINE TBARDI(tid, row, col, index, items, value,status)
 
192
/*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
193
.PURPOSE Reads table element as an integer
 
194
         Arrays are edited with a comma between elements.
 
195
.RETURNS        status (error and non-selected)
 
196
-------------------------------------------------------------*/
 
197
fint2c        *tid;
 
198
fint2c        *row;
 
199
fint2c        *col;
 
200
fint2c        *index;
 
201
fint2c        *items;
 
202
fint2c        *value; 
 
203
fint2c        *status;
 
204
{
 
205
      *status = TCARDI(*tid,*row,*col,*index,*items,value);
 
206
}
 
207
 
 
208
 
 
209
ROUTINE TBARDR(tid, row, col, index, items, value,status)
 
210
/*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
211
.PURPOSE Reads table element as a  floating point number
 
212
         Arrays are edited with a comma between elements.
 
213
.RETURNS        status (error and non-selected)
 
214
-------------------------------------------------------------*/
 
215
fint2c        *tid;
 
216
fint2c        *row;
 
217
fint2c        *col;
 
218
fint2c        *index;
 
219
fint2c        *items;
 
220
float       *value;
 
221
fint2c        *status;
 
222
{
 
223
      *status = TCARDR(*tid,*row,*col,*index,*items,value);
 
224
}
 
225
 
 
226
SUBROUTINE TBASCC(tid,row,col,index,items,value,next,status)
 
227
/*++++++++++++++++++
 
228
.PURPOSE F77 interface to TCASRC (search in character)
 
229
.RETURNS -
 
230
-------------------*/
 
231
fint2c        *tid;
 
232
fint2c        *row;
 
233
fint2c        *col;
 
234
fint2c        *index;
 
235
fint2c        *items;
 
236
CHARACTER   value;
 
237
fint2c        *next;
 
238
fint2c        *status;
 
239
{
 
240
      *status  = TCASRC(*tid,*row,*col,*index,*items,C_STRING(value),next);
 
241
}
 
242
 
 
243
 
 
244
ROUTINE TBASCD(tid,row,col,index,items,value,next,status)
 
245
/*++++++++++++++++++
 
246
.PURPOSE F77 interface to TCASRD 
 
247
.RETURNS -
 
248
-------------------*/
 
249
fint2c        *tid;
 
250
fint2c        *row;
 
251
fint2c        *col;
 
252
fint2c        *index;
 
253
fint2c        *items;
 
254
double      *value;
 
255
fint2c        *next;
 
256
fint2c        *status;
 
257
{
 
258
      *status  = TCASRD(*tid,*row,*col,*index,*items,value,next);
 
259
}
 
260
 
 
261
ROUTINE TBASCI(tid,row,col,index,items,value,next,status)
 
262
/*++++++++++++++++++
 
263
.PURPOSE F77 interface to TCASRI
 
264
.RETURNS -
 
265
-------------------*/
 
266
fint2c        *tid;
 
267
fint2c        *row;
 
268
fint2c        *col;
 
269
fint2c        *index;
 
270
fint2c        *items;
 
271
fint2c        *value;
 
272
fint2c        *next;
 
273
fint2c        *status;
 
274
{
 
275
      *status  = TCASRI(*tid,*row,*col,*index,*items,value,next);
 
276
}
 
277
 
 
278
ROUTINE TBASCR(tid,row,col,index,items,value,next,status)
 
279
/*++++++++++++++++++
 
280
.PURPOSE F77 interface to TCASRR
 
281
.RETURNS -
 
282
-------------------*/
 
283
fint2c        *tid;
 
284
fint2c        *row;
 
285
fint2c        *col;
 
286
fint2c        *index;
 
287
fint2c        *items;
 
288
float       *value;
 
289
fint2c        *next;
 
290
fint2c        *status;
 
291
{
 
292
      *status  = TCASRR(*tid,*row,*col,*index,*items,value,next);
 
293
}