/* @(#)tbe.fc 17.1.1.1 (ESO-IPG) 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 tbe.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 19-Dec-1990: Simplified .COMMENTS FORTRAN 77 to C interface layer. ---------------*/ #include #include #include /* VMR common */ #include /* LOGICAL */ #include typedef int (*FUNCTION)(); static int dtype(t) /*++++++++++++++++ .PURPOSE Convert the datatype for TBEGET / TBEPUT .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); } } ROUTINE TBEDEL(tid, row, col, status) /*++++++++++++++++ .PURPOSE F77 to C interface used to delete an element in a table. .RETURNS - -----------------*/ fint2c *tid; /* IN : table identifier */ fint2c *row; /* IN : Row concerned */ fint2c *col; /* IN : Column Concerned */ fint2c *status; /* OUT: status return */ { *status = TCEDEL(*tid, *row, *col); } ROUTINE TBEMAP(tid, row, col, index, null, status) /*++++++++++++++++ .PURPOSE F77 interface to map a table element. .RETURNS - -----------------*/ fint2c *tid; /* IN : table identifier */ fint2c *row; /* IN : Row concerned */ fint2c *col; /* IN : column number */ flong2c *index; /* OUT: column address in VMR */ fint2c *null; /* OUT: 1 if Element Null */ fint2c *status; /* OUT: status return */ { char *mypntr; *status = TCEMAP(*tid,*row,*col,&mypntr,null); *index = COMMON_INDEX(mypntr); /* Convert to VMR index */ *null = (*null ? F77TRUE : F77FALSE); } SUBROUTINE TBERDC(tid, row, col, value, null, status) /*++++++++++++++++ .PURPOSE F77 interface to TCERDC (Read in Character) .RETURNS - -----------------*/ fint2c *tid; /* IN : table identifier */ fint2c *row; /* IN : Row concerned */ fint2c *col; /* IN : column number */ CHARACTER value; /* OUT: Translated Values */ fint2c *null; /* OUT: 1 if Element Null */ fint2c *status; /* OUT: status return */ { char mybuf[TBL_ROWLEN+1]; *status = TCERDC(*tid, *row, *col, mybuf, null); STRFCOPY(value, mybuf); *null = (*null ? F77TRUE : F77FALSE); } ROUTINE TBERDD(tid, row, col, value, null, status) /*++++++++++++++++ .PURPOSE F77 interface to TCERDD (Read in Double Precision) .RETURNS - -----------------*/ fint2c *tid; /* IN : table identifier */ fint2c *row; /* IN : Row concerned */ fint2c *col; /* IN : column number */ double *value; /* OUT: Translated Values */ fint2c *null; /* OUT: 1 if Element Null */ fint2c *status; /* OUT: status return */ { *status = TCERDD(*tid, *row, *col, value, null); *null = (*null ? F77TRUE : F77FALSE); } ROUTINE TBERDI(tid, row, col, value, null, status) /*++++++++++++++++ .PURPOSE F77 interface to TCERDI (Read in Integer*4) .RETURNS - -----------------*/ fint2c *tid; /* IN : table identifier */ fint2c *row; /* IN : Row concerned */ fint2c *col; /* IN : column number */ fint2c *value; /* OUT: Translated Values */ fint2c *null; /* OUT: 1 if Element Null */ fint2c *status; /* OUT: status return */ { *status = TCERDI(*tid, *row, *col, value, null); *null = (*null ? F77TRUE : F77FALSE); } ROUTINE TBERDR(tid, row, col, value, null, status) /*++++++++++++++++ .PURPOSE F77 interface to TCERDR (Read in REAL*4) .RETURNS - -----------------*/ fint2c *tid; /* IN : table identifier */ fint2c *row; /* IN : Row concerned */ fint2c *col; /* IN : column number */ float *value; /* OUT: Translated Values */ fint2c *null; /* OUT: 1 if Element Null */ fint2c *status; /* OUT: status return */ { *status = TCERDR(*tid, *row, *col, value, null); *null = (*null ? F77TRUE : F77FALSE); } SUBROUTINE TBEGET(tid, type, row, col, 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 *col; /* IN : column number */ fint2c *value; /* OUT: Translated Values */ fint2c *null; /* OUT: 1 if Element Null */ fint2c *status; /* OUT: status return */ { FUNCTION routine; static FUNCTION choice[] = { TBERDC, TBERDI, TBERDR, TBERDD }; routine = choice[dtype(C_STRING(type))]; (*routine)(tid, row, col, value, null, status); } SUBROUTINE TBETRC(tid, col, text, value, status) /*++++++++++++++++ .PURPOSE F77 interface to TCETRC (Interpret text to binary) .RETURNS - -----------------*/ fint2c *tid; /* IN : table identifier */ fint2c *col; /* IN : column number */ CHARACTER text; /* IN : Text to interpret */ CHARACTER *value; /* OUT: Translated Values */ fint2c *status; /* OUT: status return */ { char myvalue[TBL_ROWLEN+1]; *status = TCETRC(*tid, myvalue, *col, STRIPPED_STRING(text)); STRFCOPY(value, myvalue); } SUBROUTINE TBEWRC(tid, row, col, value, status) /*++++++++++++++++ .PURPOSE F77 interface to TCEWRC (Write in Character) .RETURNS - -----------------*/ fint2c *tid; /* IN : table identifier */ fint2c *row; /* IN : Row concerned */ fint2c *col; /* IN : column number */ CHARACTER value; /* IN : Values to write */ fint2c *status; /* OUT: status return */ { *status = TCEWRC(*tid, *row, *col, C_STRING(value)); } ROUTINE TBEWRD(tid, row, col, value, status) /*++++++++++++++++ .PURPOSE F77 interface to TCEWRD (Write in Double) .RETURNS - -----------------*/ fint2c *tid; /* IN : table identifier */ fint2c *row; /* IN : Row concerned */ fint2c *col; /* IN : column number */ double *value; /* IN : Values to write */ fint2c *status; /* OUT: status return */ { *status = TCEWRD(*tid, *row, *col, value); } ROUTINE TBEWRI(tid, row, col, value, status) /*++++++++++++++++ .PURPOSE F77 interface to TCEWRI (Write in Integer*4) .RETURNS - -----------------*/ fint2c *tid; /* IN : table identifier */ fint2c *row; /* IN : Row concerned */ fint2c *col; /* IN : column number */ fint2c *value; /* IN : Values to write */ fint2c *status; /* OUT: status return */ { *status = TCEWRI(*tid, *row, *col, value); } ROUTINE TBEWRR(tid, row, col, value, status) /*++++++++++++++++ .PURPOSE F77 interface to TCEWRR (Write in Double) .RETURNS - -----------------*/ fint2c *tid; /* IN : table identifier */ fint2c *row; /* IN : Row concerned */ fint2c *col; /* IN : column number */ float *value; /* IN : Values to write */ fint2c *status; /* OUT: status return */ { *status = TCEWRR(*tid, *row, *col, value); } SUBROUTINE TBEPUT(tid, type, row, col, value, status) /*++++++++++++++++ .PURPOSE Write Table Element, variable type .RETURNS - -----------------*/ fint2c *tid; /* IN : table identifier */ CHARACTER type; /* IN : DataType as R D I */ fint2c *row; /* IN : Row concerned */ fint2c *col; /* IN : column number */ fint2c *value; /* IN : What to write */ fint2c *status; /* OUT: status return */ { FUNCTION routine; static FUNCTION choice[] = { TBEWRC, TBEWRI, TBEWRR, TBEWRD }; routine = choice[dtype(C_STRING(type))]; (*routine)(tid, row, col, value, status); } SUBROUTINE TBESRC(tid, col, value, start, len, first, next, status) /*++++++++++++++++ .PURPOSE F77 interface to TCESRC (Search in Character) .RETURNS - -----------------*/ fint2c *tid; /* IN : table identifier */ fint2c *col; /* IN : column number */ CHARACTER value; /* IN : Value to search */ fint2c *start; /* IN : Starting position=index */ fint2c *len; /* IN : Number of bytes to compare */ fint2c *first; /* IN : First row to examine */ fint2c *next; /* OUT: Found row number */ fint2c *status; /* OUT: status return */ { *status = TCESRC(*tid, *col, C_STRING(value), *start, *len, *first, next); } ROUTINE TBESRD(tid, col, value, tolerance, first, next, status) /*++++++++++++++++ .PURPOSE F77 interface to TCESRD (Search in Double) .RETURNS - -----------------*/ fint2c *tid; /* IN : table identifier */ fint2c *col; /* IN : column number */ double *value; /* IN : Value to search */ double *tolerance; /* IN : Acceptable tolerance */ fint2c *first; /* IN : First row to examine */ fint2c *next; /* OUT: Found row number */ fint2c *status; /* OUT: status return */ { *status = TCESRD(*tid, *col, *value, *tolerance, *first, next); } ROUTINE TBESRI(tid, col, value, tolerance, first, next, status) /*++++++++++++++++ .PURPOSE F77 interface to TCESRI (Search in Integer) .RETURNS - -----------------*/ fint2c *tid; /* IN : table identifier */ fint2c *col; /* IN : column number */ fint2c *value; /* IN : Value to search */ fint2c *tolerance; /* IN : Acceptable tolerance */ fint2c *first; /* IN : First row to examine */ fint2c *next; /* OUT: Found row number */ fint2c *status; /* OUT: status return */ { *status = TCESRI(*tid, *col, *value, *tolerance, *first, next); } ROUTINE TBESRR(tid, col, value, tolerance, first, next, status) /*++++++++++++++++ .PURPOSE F77 interface to TCESRR (Search in Float) .RETURNS - -----------------*/ fint2c *tid; /* IN : table identifier */ fint2c *col; /* IN : column number */ float *value; /* IN : Value to search */ float *tolerance; /* IN : Acceptable tolerance */ fint2c *first; /* IN : First row to examine */ fint2c *next; /* OUT: Found row number */ fint2c *status; /* OUT: status return */ { *status = TCESRD(*tid, *col, *value, *tolerance, *first, next); } ROUTINE TBEUNM(tid, index, status) /*++++++++++++++++ .PURPOSE F77 interface to TCEUNM (Unmap an Element) .RETURNS - -----------------*/ fint2c *tid; /* IN : table identifier */ fint2c *index; /* IN : Value returned by TBEMAP */ fint2c *status; /* OUT: status return */ { *status = TCEUNM(*tid, (char *)&((&vmr.addr)[*index-1])); }