← Back to branch summary

~ubuntu-branches/ubuntu/wily/eso-midas/wily-proposed

« back to all changes in this revision

Viewing changes to libsrc/ftoc-new/tbd.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-new/tbd.fc
 
1
/*===========================================================================
 
2
  Copyright (C) 1995-2009 European Southern Observatory (ESO)
 
3
 
 
4
  This program is free software; you can redistribute it and/or 
 
5
  modify it under the terms of the GNU General Public License as 
 
6
  published by the Free Software Foundation; either version 2 of 
 
7
  the License, or (at your option) any later version.
 
8
 
 
9
  This program is distributed in the hope that it will be useful,
 
10
  but WITHOUT ANY WARRANTY; without even the implied warranty of
 
11
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 
12
  GNU General Public License for more details.
 
13
 
 
14
  You should have received a copy of the GNU General Public 
 
15
  License along with this program; if not, write to the Free 
 
16
  Software Foundation, Inc., 675 Massachusetts Ave, Cambridge, 
 
17
  MA 02139, USA.
 
18
 
 
19
  Correspondence concerning ESO-MIDAS should be addressed as follows:
 
20
        Internet e-mail: midas@eso.org
 
21
        Postal address: European Southern Observatory
 
22
                        Data Management Division 
 
23
                        Karl-Schwarzschild-Strasse 2
 
24
                        D 85748 Garching bei Muenchen 
 
25
                        GERMANY
 
26
===========================================================================*/
 
27
 
 
28
/*++++++++++++++++++++++++  tbd.fc +++++++++++++++++++++++++++++++++++++++
 
29
.LANGUAGE C
 
30
.IDENTIFICATION Module tbd.fc
 
31
.COMMENTS
 
32
Module contains layer between the frame related FORTRAN STxxxx interfaces
 
33
and the SC_interfaces written in (hopefully independent) C
 
34
.AUTHOR         K. Banse        ESO - Garching
 
35
.KEYWORDS       standard interfaces.
 
36
.ENVIRONMENT    FORTRAN and C standards
 
37
.VERSION  [1.00] 871207:  created from SXFTOC.C
 
38
.VERSION  [2.60] 880415:  modified new version - the last one
 
39
.VERSION  [2.70] 890119:  add SZCFRNM
 
40
.VERSION  [2.80] 900316:  fix problem with FNAME_LEN+2 ...
 
41
.VERSION  [3.00] 901213:  Master file. CG.
 
42
 
 
43
 090611         last modif
 
44
-----------------------------------------------------------------------------*/
 
45
 
 
46
#include <ftoc_log.h>           /* LOGICAL    */
 
47
#include <tblsys.h>
 
48
#include <tbldef.h>
 
49
#include <midas_def.h>
 
50
 
 
51
#include <stdlib.h>
 
52
 
 
53
static int one  = 1;
 
54
static int zero = 0;
 
55
 
 
56
int   n, mm;
 
57
 
 
58
char *ptr1, *ptr2, *ptr3, *ptr4;
 
59
char *loc_pntr();
 
60
char *strp_pntr();
 
61
 
 
62
/*
 
63
 
 
64
*/
 
65
 
 
66
/*==========================================================================*/
 
67
 
 
68
/*** stat = TCFGET(tid col,form,len,dtype) ***/
 
69
 
 
70
ROUTINE TBF1(tid, col, len, dtype, status)
 
71
int *tid;     /* IN : table identifier */
 
72
int *col;     /* IN: Column       */
 
73
int  *len;    /* OUT: Bytes required for edited elemen */
 
74
int  *dtype;  /* OUT: data type */
 
75
int *status;  /* OUT: status return */
 
76
 
 
77
{
 
78
ptr1 = loc_pntr(1,&mm);            /* get location of "form" */
 
79
 
 
80
if (mm <= TBL_FORLEN)
 
81
   {
 
82
   char  myform[TBL_FORLEN+1];
 
83
 
 
84
   *status = TCFGET(*tid, *col, myform, len, dtype);
 
85
   n = (int) strlen(myform);
 
86
   if ((n > 0) && (n < (TBL_FORLEN+1)))
 
87
      {
 
88
      (void) strncpy (ptr1,myform,(size_t)n);
 
89
      }
 
90
   }
 
91
 
 
92
else
 
93
   {
 
94
   *status = TCFGET(*tid, *col, ptr1, len, dtype);
 
95
   n = (int) strlen(ptr1);
 
96
   if ((n > 0) && (n < mm)) 
 
97
      {
 
98
      *(ptr1+n) = ' ';
 
99
      }
 
100
   }
 
101
 
 
102
return 0;
 
103
}
 
104
 
 
105
/*==========================================================================*/
 
106
 
 
107
/*** stat = TCFPUT(tid, col, form) ***/
 
108
 
 
109
ROUTINE TBF2(tid, col, status)
 
110
int *tid;       /* IN : table identifier */
 
111
int *col;     /* IN : column */
 
112
int *status;    /* OUT: status return */
 
113
 
 
114
{
 
115
ptr1 = strp_pntr(1);            /* get stripped string of "form" */
 
116
 
 
117
*status = TCFPUT(*tid, *col, ptr1);
 
118
 
 
119
return 0;
 
120
}
 
121
 
 
122
/*==========================================================================*/
 
123
 
 
124
/*** stat = TCIGET(tid, cols, rows, nsort, acols, arows) ***/
 
125
 
 
126
ROUTINE TBIGET(tid, cols, rows, nsort, acols, arows, status)
 
127
int *tid;     /* IN : table identifier */
 
128
int*cols;     /* OUT: Number of Columns       */
 
129
int  *rows;   /* OUT: Number of Rows          */
 
130
int  *nsort;  /* OUT: Sorted Column Number    */
 
131
int  *acols;  /* OUT: Number of Alloc.Columns */
 
132
int  *arows;  /* OUT: Number of Alloc. Rows   */
 
133
int *status;  /* OUT: status return */
 
134
 
 
135
{
 
136
*status = TCIGET(*tid, cols, rows, nsort, acols, arows);
 
137
 
 
138
return 0;
 
139
}
 
140
 
 
141
/*==========================================================================*/
 
142
 
 
143
/*** stat = TCIPUT(tid, cols, rows) ***/
 
144
 
 
145
ROUTINE TBIPUT(tid, cols, rows, status)
 
146
int *tid;       /* IN : table identifier */
 
147
int *cols;     /* IN : no. of  columns */
 
148
int *rows;     /* IN : no. of  rows */
 
149
int *status;    /* OUT: status return */
 
150
 
 
151
{
 
152
*status = TCIPUT(*tid, *cols, *rows);
 
153
 
 
154
return 0;
 
155
}
 
156
 
 
157
/*==========================================================================*/
 
158
 
 
159
/*** stat = TCKGET(tid, col) ***/
 
160
 
 
161
ROUTINE TBKGET(tid, col, status)
 
162
int *tid;       /* IN : table identifier */
 
163
int *col;     /* OUT : reference column */
 
164
int *status;    /* OUT: status return */
 
165
 
 
166
{
 
167
*status = TCKGET(*tid, col);
 
168
 
 
169
return 0;
 
170
}
 
171
 
 
172
/*==========================================================================*/
 
173
 
 
174
/*** stat = TCKPUT(tid, col) ***/
 
175
 
 
176
ROUTINE TBKPUT(tid, col, status)
 
177
int *tid;       /* IN : table identifier */
 
178
int *col;     /* IN : reference column */
 
179
int *status;    /* OUT: status return */
 
180
 
 
181
{
 
182
*status = TCKPUT(*tid, *col);
 
183
 
 
184
return 0;
 
185
}
 
186
 
 
187
/*==========================================================================*/
 
188
 
 
189
/*** stat = TCLGET(tid, col, label) ***/
 
190
 
 
191
ROUTINE TBL1(tid, col, status)
 
192
int *tid;       /* IN : table identifier */
 
193
int *col;     /* IN : column no. */
 
194
int *status;    /* OUT: status return */
 
195
 
 
196
{
 
197
ptr1 = loc_pntr(1,&mm);            /* get location of "label" */
 
198
 
 
199
if (mm <= TBL_LABLEN)
 
200
   {
 
201
   char  mylabel[TBL_LABLEN+1];
 
202
 
 
203
   *status = TCLGET(*tid,*col,mylabel);
 
204
 
 
205
   n = (int) strlen(mylabel);
 
206
   if ((n > 0) && (n < (TBL_LABLEN+1)))
 
207
      {
 
208
      (void) strncpy (ptr1,mylabel,(size_t)n);
 
209
      }
 
210
   }
 
211
 
 
212
else
 
213
   {
 
214
   *status = TCLGET(*tid, *col, ptr1);
 
215
 
 
216
   n = (int) strlen(ptr1);
 
217
   if ((n > 0) && (n < mm))
 
218
      {
 
219
      *(ptr1+n) = ' ';
 
220
      }
 
221
   }
 
222
 
 
223
return 0;
 
224
}
 
225
 
 
226
 
 
227
/*==========================================================================*/
 
228
 
 
229
/*** stat = TCLPUT(tid, col, label) ***/
 
230
 
 
231
ROUTINE TBL2(tid, col, status)
 
232
int *tid;       /* IN : table identifier */
 
233
int *col;     /* IN : column no. */
 
234
int *status;    /* OUT: status return */
 
235
 
 
236
{
 
237
ptr1 = strp_pntr(1);            /* get stripped string of "label" */
 
238
 
 
239
*status = TCLPUT(*tid, *col, ptr1);
 
240
 
 
241
return 0;
 
242
}
 
243
 
 
244
/*==========================================================================*/
 
245
 
 
246
/*** stat = TCLSER(tid, label, col) ***/
 
247
 
 
248
ROUTINE TBL3(tid, col, status)
 
249
int *tid;       /* IN : table identifier */
 
250
int *col;     /* OUT : column no. */
 
251
int *status;    /* OUT: status return */
 
252
 
 
253
{
 
254
ptr1 = strp_pntr(1);            /* get stripped string of "label" */
 
255
 
 
256
*status = TCLSER(*tid, ptr1, col);
 
257
 
 
258
return 0;
 
259
}
 
260
 
 
261
/*==========================================================================*/
 
262
 
 
263
/*** stat = TCSGET(tid, row, value) ***/
 
264
 
 
265
ROUTINE TBSGET(tid, row, value, status)
 
266
int *tid;       /* IN : table identifier */
 
267
int *row;       /* IN : Row concerned    */
 
268
int *value;     /* OUT : Selection Flag   */
 
269
int *status;    /* OUT: status return */
 
270
 
 
271
{
 
272
*status = TCSGET(*tid, *row, value);
 
273
 
 
274
*value = (*value ? F77TRUE : F77FALSE);
 
275
 
 
276
return 0;
 
277
}
 
278
 
 
279
/*==========================================================================*/
 
280
 
 
281
/*** stat = TCSPUT(tid, row, value) ***/
 
282
 
 
283
ROUTINE TBSPUT(tid, row, value, status)
 
284
int *tid;       /* IN : table identifier */
 
285
int *row;       /* IN : Row concerned    */
 
286
int *value;     /* IN : Selection Flag   */
 
287
int *status;    /* OUT: status return */
 
288
 
 
289
{
 
290
*status = TCSPUT(*tid, *row, *value == F77FALSE ? &zero : &one);
 
291
 
 
292
return 0;
 
293
}
 
294
 
 
295
/*==========================================================================*/
 
296
 
 
297
/*** stat = TCSINI(tid) ***/
 
298
 
 
299
ROUTINE TBSINI(tid, status)
 
300
int *tid;       /* IN : table identifier */
 
301
int *status;    /* OUT: status return */
 
302
 
 
303
{
 
304
*status = TCSINI(*tid);
 
305
 
 
306
return 0;
 
307
}
 
308
 
 
309
/*==========================================================================*/
 
310
 
 
311
/*** stat = TCUGET(tid,col,tunit) ***/
 
312
 
 
313
ROUTINE TBU1(tid,col,status)
 
314
int *tid;       /* IN : table identifier */
 
315
int *col;       /* IN: column number */
 
316
int *status;    /* OUT: status return */
 
317
 
 
318
{
 
319
ptr1 = loc_pntr(1,&mm);            /* get location of "tunit" */
 
320
 
 
321
if (mm <= TBL_UNILEN)
 
322
   {
 
323
   char  myunit[TBL_UNILEN+1];
 
324
 
 
325
   *status = TCUGET(*tid,*col,myunit);
 
326
 
 
327
   n = (int) strlen(myunit);
 
328
   if ((n > 0) && (n < (TBL_UNILEN+1)))
 
329
      {
 
330
      (void) strncpy (ptr1,myunit,(size_t)n);
 
331
      }
 
332
   }
 
333
 else
 
334
   {
 
335
   *status = TCUGET(*tid, *col, ptr1);
 
336
 
 
337
   n = (int) strlen(ptr1);
 
338
   if ((n > 0) && (n < mm)) 
 
339
      {
 
340
      *(ptr1+n) = ' ';
 
341
      }
 
342
   }
 
343
 
 
344
return 0;
 
345
}
 
346
 
 
347
/*==========================================================================*/
 
348
 
 
349
/*** stat = TCUPUT(tid,col,tunit) ***/
 
350
 
 
351
ROUTINE TBU2(tid,col,status)
 
352
int *tid;       /* IN : table identifier */
 
353
int *col;       /* IN: column number */
 
354
int *status;    /* OUT: status return */
 
355
 
 
356
{
 
357
ptr1 = strp_pntr(1);            /* get stripped string of "tunit" */
 
358
 
 
359
*status = TCUPUT(*tid,*col,ptr1);
 
360
 
 
361
return 0;
 
362
}
 
363
 
 
364
/*==========================================================================*/
 
365
 
 
366
/*** stat = TCDGET(tid,store) ***/
 
367
 
 
368
ROUTINE TBDGET(tid,store,status)
 
369
int *tid;       /* IN : table identifier */
 
370
int *store;     /* OUT: physical format (0 for columnwise) */
 
371
int *status;    /* OUT: status return */
 
372
 
 
373
{
 
374
*status = TCDGET(*tid,store);
 
375
 
 
376
return 0;
 
377
}
 
378