#define vmr vmr_ /* parameter for Name Translation is l_ */ #define ROUTINE int /* @(#)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); } #define TBRDEL tbrdel_ 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); } #if 0 /* ==== Original Code ==== */ 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 */ #else /* ==== Generated Code === */ #define TBRRDC tbrrdc_ TBRRDC(va_alist) va_dcl { va_list Cargs; #endif /* ======================= */ int FORmark; /* */ char mybuf[TBL_ROWLEN+1]; va_start(Cargs); /* */ FORmark = ftoc_mark(); /* */ oscfill(mybuf,TBL_ROWLEN,' '); mybuf[TBL_ROWLEN] = '\0'; *PARAM(7,7,1,fint2c *) = TCRRDC(*PARAM(1,7,0,fint2c *), *PARAM(2,7,0,fint2c *), *PARAM(3,7,0,fint2c *),PARAM(4,7,0,fint2c *), mybuf,PARAM(6,7,1,fint2c *)); STRFCOPY(5,7,0, mybuf); f77log (PARAM(6,7,1,fint2c *), *PARAM(3,7,0,fint2c *)); /* Modify the NULL flag */ ftoc_free(FORmark); /* */ } #define TBRRDD tbrrdd_ 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 */ } #define TBRRDI tbrrdi_ 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 */ } #define TBRRDR tbrrdr_ 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 */ } #if 0 /* ==== Original Code ==== */ 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 */ #else /* ==== Generated Code === */ #define TBRGET tbrget_ TBRGET(va_alist) va_dcl { va_list Cargs; #endif /* ======================= */ int FORmark; /* */ FUNCTION routine; static FUNCTION choice[] = { TBRRDC, TBRRDI, TBRRDR, TBRRDD }; va_start(Cargs); /* */ FORmark = ftoc_mark(); /* */ routine = choice[dtype(C_STRING(2,8,0))]; (*routine)(PARAM(1,8,0,fint2c *),PARAM(3,8,1,fint2c *),PARAM(4,8,1,fint2c *),PARAM(5,8,1,fint2c *),PARAM(6,8,1,fint2c *),PARAM(7,8,1,fint2c *),PARAM(8,8,1,fint2c *)); ftoc_free(FORmark); /* */ } #if 0 /* ==== Original Code ==== */ 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 */ #else /* ==== Generated Code === */ #define TBRSEL tbrsel_ TBRSEL(va_alist) va_dcl { va_list Cargs; #endif /* ======================= */ int FORmark; /* */ va_start(Cargs); /* */ FORmark = ftoc_mark(); /* */ *PARAM(7,7,1,fint2c *) = TCRSEL(*PARAM(1,7,0,fint2c *), STRIPPED_STRING(2,7,0), *PARAM(3,7,1,fint2c *),PARAM(4,7,1,fint2c *),PARAM(5,7,1,fint2c *),PARAM(6,7,1,fint2c *)); ftoc_free(FORmark); /* */ } #if 0 /* ==== Original Code ==== */ 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 */ #else /* ==== Generated Code === */ #define TBRWRC tbrwrc_ TBRWRC(va_alist) va_dcl { va_list Cargs; #endif /* ======================= */ int FORmark; /* */ va_start(Cargs); /* */ FORmark = ftoc_mark(); /* */ *PARAM(6,6,1,fint2c *) = TCRWRC(*PARAM(1,6,0,fint2c *), *PARAM(2,6,0,fint2c *), *PARAM(3,6,0,fint2c *),PARAM(4,6,0,fint2c *), C_STRING(5,6,0)); ftoc_free(FORmark); /* */ } #define TBRWRD tbrwrd_ 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); } #define TBRWRI tbrwri_ 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); } #define TBRWRR tbrwrr_ 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); }