#define vmr vmr_ /* parameter for Name Translation is l_ */ #define ROUTINE int /* @(#)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); } } #define TBEDEL tbedel_ 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); } #define TBEMAP tbemap_ 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); } #if 0 /* ==== Original Code ==== */ 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 */ #else /* ==== Generated Code === */ #define TBERDC tberdc_ TBERDC(va_alist) va_dcl { va_list Cargs; #endif /* ======================= */ int FORmark; /* */ char mybuf[TBL_ROWLEN+1]; va_start(Cargs); /* */ FORmark = ftoc_mark(); /* */ *PARAM(6,6,1,fint2c *) = TCERDC(*PARAM(1,6,0,fint2c *), *PARAM(2,6,0,fint2c *), *PARAM(3,6,0,fint2c *), mybuf,PARAM(5,6,1,fint2c *)); STRFCOPY(4,6,0, mybuf); *PARAM(5,6,1,fint2c *) = (*PARAM(5,6,1,fint2c *) ? F77TRUE : F77FALSE); ftoc_free(FORmark); /* */ } #define TBERDD tberdd_ 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); } #define TBERDI tberdi_ 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); } #define TBERDR tberdr_ 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); } #if 0 /* ==== Original Code ==== */ 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 */ #else /* ==== Generated Code === */ #define TBEGET tbeget_ TBEGET(va_alist) va_dcl { va_list Cargs; #endif /* ======================= */ int FORmark; /* */ FUNCTION routine; static FUNCTION choice[] = { TBERDC, TBERDI, TBERDR, TBERDD }; va_start(Cargs); /* */ FORmark = ftoc_mark(); /* */ routine = choice[dtype(C_STRING(2,7,0))]; (*routine)(PARAM(1,7,0,fint2c *),PARAM(3,7,1,fint2c *),PARAM(4,7,1,fint2c *),PARAM(5,7,1,fint2c *),PARAM(6,7,1,fint2c *),PARAM(7,7,1,fint2c *)); ftoc_free(FORmark); /* */ } #if 0 /* ==== Original Code ==== */ 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 */ #else /* ==== Generated Code === */ #define TBETRC tbetrc_ TBETRC(va_alist) va_dcl { va_list Cargs; #endif /* ======================= */ int FORmark; /* */ char myvalue[TBL_ROWLEN+1]; va_start(Cargs); /* */ FORmark = ftoc_mark(); /* */ *PARAM(5,5,2,fint2c *) = TCETRC(*PARAM(1,5,0,fint2c *), myvalue, *PARAM(2,5,0,fint2c *), STRIPPED_STRING(3,5,0)); STRFCOPY(4,5,1, myvalue); ftoc_free(FORmark); /* */ } #if 0 /* ==== Original Code ==== */ 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 */ #else /* ==== Generated Code === */ #define TBEWRC tbewrc_ TBEWRC(va_alist) va_dcl { va_list Cargs; #endif /* ======================= */ int FORmark; /* */ va_start(Cargs); /* */ FORmark = ftoc_mark(); /* */ *PARAM(5,5,1,fint2c *) = TCEWRC(*PARAM(1,5,0,fint2c *), *PARAM(2,5,0,fint2c *), *PARAM(3,5,0,fint2c *), C_STRING(4,5,0)); ftoc_free(FORmark); /* */ } #define TBEWRD tbewrd_ 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); } #define TBEWRI tbewri_ 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); } #define TBEWRR tbewrr_ 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); } #if 0 /* ==== Original Code ==== */ 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 */ #else /* ==== Generated Code === */ #define TBEPUT tbeput_ TBEPUT(va_alist) va_dcl { va_list Cargs; #endif /* ======================= */ int FORmark; /* */ FUNCTION routine; static FUNCTION choice[] = { TBEWRC, TBEWRI, TBEWRR, TBEWRD }; va_start(Cargs); /* */ FORmark = ftoc_mark(); /* */ routine = choice[dtype(C_STRING(2,6,0))]; (*routine)(PARAM(1,6,0,fint2c *),PARAM(3,6,1,fint2c *),PARAM(4,6,1,fint2c *),PARAM(5,6,1,fint2c *),PARAM(6,6,1,fint2c *)); ftoc_free(FORmark); /* */ } #if 0 /* ==== Original Code ==== */ 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 */ #else /* ==== Generated Code === */ #define TBESRC tbesrc_ TBESRC(va_alist) va_dcl { va_list Cargs; #endif /* ======================= */ int FORmark; /* */ va_start(Cargs); /* */ FORmark = ftoc_mark(); /* */ *PARAM(8,8,1,fint2c *) = TCESRC(*PARAM(1,8,0,fint2c *), *PARAM(2,8,0,fint2c *), C_STRING(3,8,0), *PARAM(4,8,1,fint2c *), *PARAM(5,8,1,fint2c *), *PARAM(6,8,1,fint2c *),PARAM(7,8,1,fint2c *)); ftoc_free(FORmark); /* */ } #define TBESRD tbesrd_ 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); } #define TBESRI tbesri_ 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); } #define TBESRR tbesrr_ 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); } #define TBEUNM tbeunm_ 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])); }