/* @(#)tbr.fc 17.1.1.1 (ES0-DMD) 01/25/02 17:34:10 */ /*=========================================================================== Copyright (C) 1995 European Southern Observatory (ESO) This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Massachusetss Ave, Cambridge, MA 02139, USA. Corresponding concerning ESO-MIDAS should be addressed as follows: Internet e-mail: midas@eso.org Postal address: European Southern Observatory Data Management Division Karl-Schwarzschild-Strasse 2 D 85748 Garching bei Muenchen GERMANY ===========================================================================*/ /*++++++++++++++ .IDENTIFICATION tbr.fc .LANGUAGE C .AUTHOR J.D. Ponz, F. Ochsenbein (ESO-IPG)) .KEYWORDS Table system, FORTRAN interface .ENVIRONMENT .VERSION 1.0 1 Feb 1987 Creation .VERSION 1.1 1 Dec 1987 Modification of the calling seq. .VERSION 1.2 7 Apr 1988 Add length to the calling seq. .VERSION 1.3 16-Oct-1990: Simplified .COMMENTS FORTRAN 77 to C interface layer. ---------------*/ #include #include #include /* VMR common */ #include /* For Logical Definitions */ #include typedef int (*FUNCTION)(); static int dtype(t) /*++++++++++++++++ .PURPOSE Convert the datatype for TBRGET .RETURNS 0 for Char / 1 for Int / 2 for R*4 / 3 for Double -----------------*/ char *t; /* IN: Character Type */ { switch(*t) { case 'J': case 'I': return(1); case 'D': return(3); case 'C': case 'A': return(0); case 'R': if ((t[1] == '*') && (t[2] >= '8')) return(3); default: return(2); } } static f77log(a, n) /*++++++++++++++++ .PURPOSE Modify the logical values if required .RETURNS - -----------------*/ fint2c *a; /* IN: LOGICAL value */ int n; /* IN: How many logical numbers */ { int i; int *p; for (p=a, i=n; --i >= 0; p++) *p = (*p ? F77TRUE : F77FALSE); } ROUTINE TBRDEL(tid, row, status) /*++++++++++++++++ .PURPOSE F77 to C interface to TCRDEL: Delete all elements in the row .RETURNS - -----------------*/ fint2c *tid; /* IN : table identifier */ fint2c *row; /* IN : Row concerned */ fint2c *status; /* OUT: status return */ { *status = TCRDEL(*tid, *row); } SUBROUTINE TBRRDC(tid, row, nc, cols, value, null, status) /*++++++++++++++++ .PURPOSE F77 interface to TCRRDC (Read in Character) .RETURNS - -----------------*/ fint2c *tid; /* IN : table identifier */ fint2c *row; /* IN : Row concerned */ fint2c *nc; /* IN : Size of cols array */ fint2c *cols; /* IN : Column Selection */ CHARACTER value; /* OUT: Translated Values */ fint2c *null; /* OUT: Array of Null Flags */ fint2c *status; /* OUT: status return */ { char mybuf[TBL_ROWLEN+1]; oscfill(mybuf,TBL_ROWLEN,' '); mybuf[TBL_ROWLEN] = '\0'; *status = TCRRDC(*tid, *row, *nc, cols, mybuf, null); STRFCOPY(value, mybuf); f77log (null, *nc); /* Modify the NULL flag */ } ROUTINE TBRRDD(tid, row, nc, cols, value, null, status) /*++++++++++++++++ .PURPOSE F77 interface to TCRRDD (Read in Double) .RETURNS - -----------------*/ fint2c *tid; /* IN : table identifier */ fint2c *row; /* IN : Row concerned */ fint2c *nc; /* IN : Size of cols array */ fint2c *cols; /* IN : Column Selection */ double *value; /* OUT: Translated Values */ fint2c *null; /* OUT: Array of Null Flags */ fint2c *status; /* OUT: status return */ { *status = TCRRDD(*tid, *row, *nc, cols, value, null); f77log (null, *nc); /* Modify the NULL flag */ } ROUTINE TBRRDI(tid, row, nc, cols, value, null, status) /*++++++++++++++++ .PURPOSE F77 interface to TCRRDI (Read in Integer*4) .RETURNS - -----------------*/ fint2c *tid; /* IN : table identifier */ fint2c *row; /* IN : Row concerned */ fint2c *nc; /* IN : Size of cols array */ fint2c *cols; /* IN : Column Selection */ fint2c *value; /* OUT: Translated Values */ fint2c *null; /* OUT: Array of Null Flags */ fint2c *status; /* OUT: status return */ { *status = TCRRDI(*tid, *row, *nc, cols, value, null); f77log (null, *nc); /* Modify the NULL flag */ } ROUTINE TBRRDR(tid, row, nc, cols, value, null, status) /*++++++++++++++++ .PURPOSE F77 interface to TCRRDR (Read in Float) .RETURNS - -----------------*/ fint2c *tid; /* IN : table identifier */ fint2c *row; /* IN : Row concerned */ fint2c *nc; /* IN : Size of cols array */ fint2c *cols; /* IN : Column Selection */ float *value; /* OUT: Translated Values */ fint2c *null; /* OUT: Array of Null Flags */ fint2c *status; /* OUT: status return */ { *status = TCRRDR(*tid, *row, *nc, cols, value, null); f77log (null, *nc); /* Modify the NULL flag */ } SUBROUTINE TBRGET(tid, type, row, nc, cols, value, null, status) /*++++++++++++++++ .PURPOSE Read table element, variable type .RETURNS - -----------------*/ fint2c *tid; /* IN : table identifier */ CHARACTER type; /* IN : DataType as R D I */ fint2c *row; /* IN : Row concerned */ fint2c *nc; /* IN : Size of cols array */ fint2c *cols; /* IN : Column Selection */ fint2c *value; /* OUT: Translated Values */ fint2c *null; /* OUT: 1 if Element Null */ fint2c *status; /* OUT: status return */ { FUNCTION routine; static FUNCTION choice[] = { TBRRDC, TBRRDI, TBRRDR, TBRRDD }; routine = choice[dtype(C_STRING(type))]; (*routine)(tid, row, nc, cols, value, null, status); } SUBROUTINE TBRSEL(tid,text,nr,lbounds,ubounds,found,status) /*++++++++++++++++ .PURPOSE F77 interface to TCRSEL (Translate text containg ranges) .RETURNS - -----------------*/ fint2c *tid; /* IN : table identifier */ CHARACTER text; /* IN : Text of columns, e.g. @1..20,50 */ fint2c *nr; /* IN : Size of lower/upperbound arrays */ fint2c *lbounds; /* OUT: Lower bounds of found ranges */ fint2c *ubounds; /* OUT: Upper bounds of found ranges */ fint2c *found; /* OUT: How many ranges were found */ fint2c *status; /* OUT: status return */ { *status = TCRSEL(*tid, STRIPPED_STRING(text), *nr, lbounds, ubounds, found); } SUBROUTINE TBRWRC(tid, row, nc, cols, value, status) /*++++++++++++++++ .PURPOSE F77 interface to TCRWRC (Write in Character) .RETURNS - -----------------*/ fint2c *tid; /* IN : table identifier */ fint2c *row; /* IN : Row concerned */ fint2c *nc; /* IN : Size of cols array */ fint2c *cols; /* IN : Column Selection */ CHARACTER value; /* IN : Input Values */ fint2c *status; /* OUT: status return */ { *status = TCRWRC(*tid, *row, *nc, cols, C_STRING(value)); } ROUTINE TBRWRD(tid, row, nc, cols, value, status) /*++++++++++++++++ .PURPOSE F77 interface to TCRWRD (Write in Double) .RETURNS - -----------------*/ fint2c *tid; /* IN : table identifier */ fint2c *row; /* IN : Row concerned */ fint2c *nc; /* IN : Size of cols array */ fint2c *cols; /* IN : Column Selection */ double *value; /* IN : Input Values */ fint2c *status; /* OUT: status return */ { *status = TCRWRD(*tid, *row, *nc, cols, value); } ROUTINE TBRWRI(tid, row, nc, cols, value, status) /*++++++++++++++++ .PURPOSE F77 interface to TCRWRI (Write in Integer*4) .RETURNS - -----------------*/ fint2c *tid; /* IN : table identifier */ fint2c *row; /* IN : Row concerned */ fint2c *nc; /* IN : Size of cols array */ fint2c *cols; /* IN : Column Selection */ fint2c *value; /* IN : Input Values */ fint2c *status; /* OUT: status return */ { *status = TCRWRI(*tid, *row, *nc, cols, value); } ROUTINE TBRWRR(tid, row, nc, cols, value, status) /*++++++++++++++++ .PURPOSE F77 interface to TCRWRR (Write in Float) .RETURNS - -----------------*/ fint2c *tid; /* IN : table identifier */ fint2c *row; /* IN : Row concerned */ fint2c *nc; /* IN : Size of cols array */ fint2c *cols; /* IN : Column Selection */ float *value; /* IN : Input Values */ fint2c *status; /* OUT: status return */ { *status = TCRWRR(*tid, *row, *nc, cols, value); }