void hdrDelet( char *param,
char *xname,
char *item,
int comp,
int *status ) {
DECLARE_CHARACTER_DYN(fparam);
DECLARE_CHARACTER_DYN(fxname);
DECLARE_CHARACTER_DYN(fitem);
F77_CREATE_CHARACTER(fparam, strlen( param ));
cnf_exprt( param, fparam, fparam_length );
F77_CREATE_CHARACTER(fxname, strlen( xname ));
cnf_exprt( xname, fxname, fxname_length );
F77_CREATE_CHARACTER(fitem, strlen( item ));
cnf_exprt( item, fitem, fitem_length );
F77_LOCK( F77_CALL(hdr_delet)( CHARACTER_ARG(fparam),
CHARACTER_ARG(fxname),
CHARACTER_ARG(fitem),
INTEGER_ARG(&comp),
INTEGER_ARG(status)
TRAIL_ARG(fparam)
TRAIL_ARG(fxname)
TRAIL_ARG(fitem) ); )
void hdrInD( char *param,
char *xname,
char *item,
int comp,
double *value,
int *status ) {
DECLARE_CHARACTER_DYN(fparam);
DECLARE_CHARACTER_DYN(fxname);
DECLARE_CHARACTER_DYN(fitem);
F77_CREATE_CHARACTER(fparam,strlen( param ));
cnf_exprt( param, fparam, fparam_length );
F77_CREATE_CHARACTER(fxname,strlen( xname ));
cnf_exprt( xname, fxname, fxname_length );
F77_CREATE_CHARACTER(fitem,strlen( item ));
cnf_exprt( item, fitem, fitem_length );
F77_LOCK( F77_CALL(hdr_ind)( CHARACTER_ARG(fparam),
CHARACTER_ARG(fxname),
CHARACTER_ARG(fitem),
INTEGER_ARG(&comp),
DOUBLE_ARRAY_ARG(value),
INTEGER_ARG(status)
TRAIL_ARG(fparam)
TRAIL_ARG(fxname)
TRAIL_ARG(fitem) ); )
void hdrName( char *param,
char *xname,
int n,
char *item,
int item_length,
int *status ) {
DECLARE_CHARACTER_DYN(fparam);
DECLARE_CHARACTER_DYN(fxname);
DECLARE_CHARACTER_DYN(fitem);
F77_CREATE_CHARACTER(fparam,strlen( param ));
cnf_exprt( param, fparam, fparam_length );
F77_CREATE_CHARACTER(fxname,strlen( xname ));
cnf_exprt( xname, fxname, fxname_length );
F77_CREATE_CHARACTER(fitem,item_length);
F77_LOCK( F77_CALL(hdr_name)( CHARACTER_ARG(fparam),
CHARACTER_ARG(fxname),
INTEGER_ARG(&n),
CHARACTER_ARG(fitem),
INTEGER_ARG(status)
TRAIL_ARG(fparam)
TRAIL_ARG(fxname)
TRAIL_ARG(fitem) ); )
void cvgClose( fitsfile **fptr, int *status ){
DECLARE_INTEGER(FUNIT);
DECLARE_INTEGER(STATUS);
CVG_EXPORT_FITS( *fptr, FUNIT );
F77_EXPORT_INTEGER( *status, STATUS );
F77_LOCK( F77_CALL(cvg_close)( INTEGER_ARG(&FUNIT),
INTEGER_ARG(&STATUS) ); )
int main()
{
int j;
DECLARE_INTEGER(ni);
DECLARE_INTEGER(i);
DECLARE_INTEGER_ARRAY(ia,NI);
DECLARE_INTEGER(nr);
DECLARE_REAL(r);
DECLARE_REAL_ARRAY(ra,NR);
DECLARE_INTEGER(nd);
DECLARE_DOUBLE(d);
DECLARE_DOUBLE_ARRAY(da,ND);
DECLARE_INTEGER(nl);
DECLARE_LOGICAL(l);
DECLARE_LOGICAL_ARRAY(la,NL);
DECLARE_INTEGER(nb);
DECLARE_BYTE(b);
DECLARE_BYTE_ARRAY(ba,NB);
DECLARE_INTEGER(nw);
DECLARE_WORD(w);
DECLARE_WORD_ARRAY(wa,NW);
DECLARE_INTEGER(nub);
DECLARE_UBYTE(ub);
DECLARE_UBYTE_ARRAY(uba,NUB);
DECLARE_INTEGER(nuw);
DECLARE_UWORD(uw);
DECLARE_UWORD_ARRAY(uwa,NUW);
DECLARE_CHARACTER(c1f,80);
DECLARE_CHARACTER_ARRAY(caf,80,NC);
DECLARE_INTEGER(nc);
char c;
char c1c[81];
ni = NI;
nr = NR;
nd = ND;
nl = NL;
nb = NB;
nw = NW;
nub= NUB;
nuw = NUW;
printf( "--> This is a test of C calling FORTRAN\n" );
/* Initialise fortran run time library */
cnfInitRTL( 0, NULL );
/* Test the passing of int arguments */
for( j=0 ; j<ni ; j++ )
ia[j] = j+1;
F77_LOCK( F77_CALL(ti)( INTEGER_ARRAY_ARG(ia), INTEGER_ARG(&ni), INTEGER_ARG(&i) ); )
void hdrOut( char *param,
char *xname,
char *item,
char *commen,
char *value,
int value_length,
int *status ) {
DECLARE_CHARACTER_DYN(fparam);
DECLARE_CHARACTER_DYN(fxname);
DECLARE_CHARACTER_DYN(fitem);
DECLARE_CHARACTER_DYN(fcommen);
DECLARE_CHARACTER_DYN(fvalue);
int lens;
int nparam;
int i;
F77_CHARACTER_TYPE *ptr1;
char *ptr2;
F77_CREATE_CHARACTER(fparam,strlen( param ));
cnf_exprt( param, fparam, fparam_length );
F77_CREATE_CHARACTER(fxname,strlen( xname ));
cnf_exprt( xname, fxname, fxname_length );
F77_CREATE_CHARACTER(fitem,strlen( item ));
cnf_exprt( item, fitem, fitem_length );
F77_CREATE_CHARACTER(fcommen,strlen( commen ));
cnf_exprt( commen, fcommen, fcommen_length );
/* Need to copy the input strings in value into an Fortran
character array. Note if string length is zero then we must work
out the length ourselves. */
nparam = img1CountParams( param, status );
if ( value_length == 0 ) {
lens = (int) strlen( value );
} else {
lens = value_length;
}
F77_CREATE_CHARACTER( fvalue, nparam*lens );
fvalue_length = lens;
ptr1 = fvalue;
ptr2 = value;
for( i=0; i < nparam; i++ ) {
cnf_exprt( ptr2, ptr1, fvalue_length );
ptr1 += lens;
ptr2 += lens;
}
F77_LOCK( F77_CALL(hdr_out)( CHARACTER_ARG(fparam),
CHARACTER_ARG(fxname),
CHARACTER_ARG(fitem),
CHARACTER_ARG(fcommen),
CHARACTER_ARRAY_ARG(fvalue),
INTEGER_ARG(status)
TRAIL_ARG(fparam)
TRAIL_ARG(fxname)
TRAIL_ARG(fitem)
TRAIL_ARG(fcommen)
TRAIL_ARG(fvalue) ); )
void call_dgels(char *trans, int m, int n, int nrhs,
double *a, int lda, double *b, int ldb,
double *work, int lwork, int *info) {
DECLARE_CHARACTER( TRANS, 1 );
DECLARE_INTEGER(M);
DECLARE_INTEGER(N);
DECLARE_INTEGER(NRHS);
DECLARE_INTEGER(LDA);
DECLARE_INTEGER(LDB);
DECLARE_INTEGER(LWORK);
DECLARE_INTEGER(INFO);
slaStringExport(trans, TRANS, 1);
M = m;
N = n;
NRHS = nrhs;
LDA = lda;
LDB = ldb;
LWORK = lwork;
F77_CALL(dgels)( CHARACTER_ARG(TRANS),
INTEGER_ARG(&M),
INTEGER_ARG(&N),
INTEGER_ARG(&NRHS),
DOUBLE_ARRAY_ARG(a),
INTEGER_ARG(&LDA),
DOUBLE_ARRAY_ARG(b),
INTEGER_ARG(&LDB),
DOUBLE_ARRAY_ARG(work),
INTEGER_ARG(&LWORK),
INTEGER_ARG(&INFO)
TRAIL_ARG(TRANS) );
*info = INFO;
}
/* Define a function called ast_resample_ukern1 which has a suitable
interface to allow it to be passed as an interpolation function to
the C interface of astResample<X> in the case where the "interp"
parameter is set to AST__UKERN1. In turn, it invokes the equivalent
user-supplied FORTRAN 77 interpolation function, a pointer to which
should previously have been stored in the static variable
"ast_resample_FINTERP". */
static void ast_resample_ukern1( double offset, const double params[],
int flags, double *value ) {
DECLARE_INTEGER(STATUS);
int *status;
/* Obtain the C status and then invoke the FORTRAN 77 interpolation
function via the stored pointer. */
status = astGetStatusPtr;
STATUS = astStatus;
( *ast_resample_FINTERP )( DOUBLE_ARG(&offset),
DOUBLE_ARRAY_ARG(params),
INTEGER_ARG(&flags),
DOUBLE_ARG(value),
INTEGER_ARG(&STATUS) );
/* Set the C status to the returned FORTRAN 77 status. */
astSetStatus( STATUS );
}
void ndfAssoc( const char *param,
const char *mode,
int *indf,
int *status ) {
DECLARE_CHARACTER_DYN(fparam);
DECLARE_CHARACTER_DYN(fmode);
DECLARE_INTEGER(findf);
DECLARE_INTEGER(fstatus);
F77_CREATE_EXPORT_CHARACTER( param, fparam );
F77_CREATE_EXPORT_CHARACTER( mode, fmode );
F77_EXPORT_INTEGER( *status, fstatus );
F77_LOCK( F77_CALL(ndf_assoc)( CHARACTER_ARG(fparam),
CHARACTER_ARG(fmode),
INTEGER_ARG(&findf),
INTEGER_ARG(&fstatus)
TRAIL_ARG(fparam)
TRAIL_ARG(fmode) ); )
void imgDelet( char *param,
int *status ) {
DECLARE_CHARACTER_DYN(fparam);
F77_CREATE_CHARACTER(fparam,strlen( param ));
cnf_exprt( param, fparam, fparam_length );
F77_LOCK( F77_CALL(img_delet)( CHARACTER_ARG(fparam),
INTEGER_ARG(status)
TRAIL_ARG(fparam) ); )
void hdrOutL( char *param,
char *xname,
char *item,
char *commen,
int *value,
int *status ) {
DECLARE_CHARACTER_DYN(fparam);
DECLARE_CHARACTER_DYN(fxname);
DECLARE_CHARACTER_DYN(fitem);
DECLARE_CHARACTER_DYN(fcommen);
F77_LOGICAL_TYPE *fvalue;
int i;
int nparam;
/* Count the number of parameters and create a Fortran logical
array of the correct size */
nparam = img1CountParams( param, status );
fvalue = (F77_LOGICAL_TYPE *) malloc( nparam * sizeof(F77_LOGICAL_TYPE) );
/* Convert the input values into Fortran logical values */
for ( i = 0; i < nparam; i++ ) {
if ( value[i] ) {
fvalue[i] = F77_TRUE;
} else {
fvalue[i] = F77_FALSE;
}
}
F77_CREATE_CHARACTER(fparam,strlen( param ));
cnf_exprt( param, fparam, fparam_length );
F77_CREATE_CHARACTER(fxname,strlen( xname ));
cnf_exprt( xname, fxname, fxname_length );
F77_CREATE_CHARACTER(fitem,strlen( item ));
cnf_exprt( item, fitem, fitem_length );
F77_CREATE_CHARACTER(fcommen,strlen( commen ));
cnf_exprt( commen, fcommen, fcommen_length );
F77_LOCK( F77_CALL(hdr_outl)( CHARACTER_ARG(fparam),
CHARACTER_ARG(fxname),
CHARACTER_ARG(fitem),
CHARACTER_ARG(fcommen),
LOGICAL_ARRAY_ARG(fvalue),
INTEGER_ARG(status)
TRAIL_ARG(fparam)
TRAIL_ARG(fxname)
TRAIL_ARG(fitem)
TRAIL_ARG(fcommen) ); )
void datAssoc( const char *param,
const char *access,
HDSLoc **loc,
int *status ) {
DECLARE_CHARACTER_DYN(PARAM);
DECLARE_CHARACTER_DYN(ACCESS);
DECLARE_CHARACTER(LOC,DAT__SZLOC);
DECLARE_INTEGER(STATUS);
F77_CREATE_EXPORT_CHARACTER( param, PARAM );
F77_CREATE_EXPORT_CHARACTER( access, ACCESS );
F77_EXPORT_INTEGER( *status, STATUS );
F77_LOCK( F77_CALL(dat_assoc)( CHARACTER_ARG(PARAM),
CHARACTER_ARG(ACCESS),
CHARACTER_ARG(LOC),
INTEGER_ARG(&STATUS)
TRAIL_ARG(PARAM)
TRAIL_ARG(ACCESS)
TRAIL_ARG(LOC) ); )
static char *ccdTclEval( ccdTcl_Interp *cinterp, const char *cmd, int *status ) {
/*
*+
* Name:
* ccdTclEval
* Purpose:
* Evaluate a Tcl command.
* Language:
* Starlink C
* Description:
* This routine executes a command in the Tcl interpreter specified
* by the cinterp argument, and returns the interpreter's result
* as a character string. If the return code from the Tcl
* interpreter was not TCL_OK, then the status argument will be set.
*
* It does it by writing the text of the command down the pipe to
* the child process set up by a previous ccdTclStart call, and then
* reading the response sent back up the pipe from that process.
* It also watches for, and outputs appropriately, messages for
* output via the CCDPACK logging system which may come up the pipe.
*
* This function is declared static, and so not intended for use
* by external code. External routines should use ccdTclDo or one
* of the other ccdTcl* functions instead.
* Arguments:
* cinterp = ccdTcl_Interp *
* The interpreter got from a previous ccdTclStart call.
* cmd = const char *
* A string representing a Tcl command. As currently implemented
* this probably ought not to be too long; below 4096 characters
* should be all right.
* status = int *
* The global status.
* Return Value:
* A pointer to a static character string is returned, which contains
* the string result of the evaluation. This will be overwritten by
* the next call to this routine.
* Copyright:
* Copyright (C) 2006 Particle Physics & Astronomy Research Council.
* All Rights Reserved.
* Licence:
* 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., 59 Temple Place,Suite 330, Boston, MA
* 02111-1307, USA
* Authors:
* {original_author_entry}
* History:
* {enter_changes_here}
* Bugs:
* {note_any_bugs_here}
*-
*/
/* Local variables. */
int bytes;
int ifd = cinterp->upfd[ 0 ];
int ofd = cinterp->downfd[ 1 ];
int tclrtn;
void (*handler)(int);
char *c;
static char retbuf[ BUFLENG ];
DECLARE_CHARACTER( fmsg, MSG__SZMSG );
DECLARE_CHARACTER( fname, MSG__SZMSG );
/* Check inherited status. */
if ( *status != SAI__OK ) return NULL;
/* Write the text of the command to execute to the downward pipe, so that
the child process can execute it. We ignore a SIGPIPE but check for
an I/O error, so that the program deals gracefully with a broken pipe. */
handler = signal( SIGPIPE, SIG_IGN );
if ( write( ofd, cmd, strlen( cmd ) + 1 ) < 0 ) {
*status = SAI__ERROR;
msgSetc( "ERROR", strerror( errno ) );
errRep( "CCD_TCL_WRITE", "^ERROR", status );
}
signal( SIGPIPE, handler );
/* Loop until we get a return status which indicates the command has
completed (i.e. not one which just requires output through the ADAM
message system). */
do {
/* Read the Tcl return status from the upward pipe. */
tclrtn = -1;
bytes = read( ifd, &tclrtn, sizeof( int ) );
/* Read the result of the evaluation from the upward pipe. */
c = retbuf - 1;
*retbuf = '\0';
do {
if ( ++c >= retbuf + BUFLENG ) {
*status = SAI__ERROR;
errRep( "CCD_TCL_BUF", "Buffer overflow", status );
return NULL;
}
bytes = read( ifd, c, 1 );
/* If the read failed then we probably caught a signal or the child
process stopped writing in the middle of a command. Neither of these
should happen, so signal an error. It might be desirable to do
something smarter than this on receipt of a signal (like try the
read again) but I don't think that it is a very likely eventuality. */
if ( bytes != 1 ) {
strcpy( c, "\n Tcl communications error\n" );
c += strlen( c );
tclrtn = -1;
}
} while ( *c != '\0' );
/* If the Tcl return status was CCD_CCDMSG, CCD_CCDLOG or CCD_CCDERR then
what follows are two strings, separated by a carriage return, to output
via the ADAM message system. */
if ( tclrtn == CCD_CCDLOG || tclrtn == CCD_CCDERR ||
tclrtn == CCD_CCDMSG ) {
c = index( retbuf, '\n' );
*(c++) = '\0';
cnfExprt( retbuf, fname, MSG__SZMSG );
cnfExprt( c, fmsg, MSG__SZMSG );
if ( tclrtn == CCD_CCDLOG ) {
F77_CALL(ccd1_msg)( CHARACTER_ARG(fname), CHARACTER_ARG(fmsg),
INTEGER_ARG(status)
TRAIL_ARG(fname) TRAIL_ARG(fmsg) );
}
else if ( tclrtn == CCD_CCDERR ) {
F77_CALL(ccd1_errep)( CHARACTER_ARG(fname), CHARACTER_ARG(fmsg),
INTEGER_ARG(status)
TRAIL_ARG(fname) TRAIL_ARG(fmsg) );
}
else if ( tclrtn == CCD_CCDMSG ) {
F77_CALL(msg_out)( CHARACTER_ARG(fname), CHARACTER_ARG(fmsg),
INTEGER_ARG(status)
TRAIL_ARG(fname) TRAIL_ARG(fmsg) );
}
}
} while ( tclrtn == CCD_CCDLOG || tclrtn == CCD_CCDERR ||
tclrtn == CCD_CCDMSG );
/* If the Tcl return status was not TCL_OK, then flag an error and write
an error report. */
if ( tclrtn != TCL_OK ) {
int done = 0;
char *estart;
const char *fmt = ( tclrtn == TCL_ERROR ) ? "Tcl error:\n%s"
: "Unexpected Tcl return:\n%s";
snprintf( buffer, BUFLENG - strlen( fmt ), fmt, retbuf );
*status = SAI__ERROR;
for ( estart = buffer; ! done; estart = c + 1 ) {
for ( c = estart; *c != '\n' && *c != '\0'; c++ );
if ( *c == '\0' ) done = 1;
*c = '\0';
errRep( "CCD_TCL_TCLERR", estart, status );
}
}
/* Return the result. */
return retbuf;
}
void dummy_c_func_(INTEGER(i))
{
fprintf(stderr, "i = %d\n", *INTEGER_ARG(i));
F77_CALL(hellosub)(INTEGER_ARG(i)TRAIL_ARG(fline));
}
void *ccdMall( const char *type, int size, int *status ) {
/*
*+
* Name:
* ccdMall
* Purpose:
* C wrapper for fortran CCD1_MALL routine.
* Language:
* Starlink C
* Arguments:
* type = const char *
* HDS type of memory to allocate, as a null-terminated string.
* size = int
* Number of elements of type type to allocate.
* status = int
* The global status.
* Return Value:
* A pointer to a block of memory which will hold size elements of
* type type. This pointer has been registered with the CCDPACK
* memory allocation machinery (and a fortiori the CNF memory
* allocation machinery) and so must be deallocated using CCD1_MFREE.
* The pointer returned is a C pointer, and thus suitable for direct
* use by C code. If it is to be used by Fortran code it must
* be processed with the function cnfFptr.
* Copyright:
* Copyright (C) 2006 Particle Physics & Astronomy Research Council.
* All Rights Reserved.
* Licence:
* 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., 51 Franklin Street,Fifth Floor, Boston, MA
* 02110-1301, USA
* Authors:
* {original_author_entry}
* History:
* {enter_changes_here}
* Bugs:
* {note_any_bugs_here}
*-
*/
DECLARE_CHARACTER( ftype, DAT__SZTYP );
F77_POINTER_TYPE ptr;
if ( *status != SAI__OK ) return (void *) NULL;
cnfExprt( type, ftype, DAT__SZTYP );
F77_CALL(ccd1_mall)( INTEGER_ARG(&size), CHARACTER_ARG(ftype),
POINTER_ARG(&ptr), INTEGER_ARG(status)
TRAIL_ARG(ftype) );
return cnfCptr( ptr );
}
