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;
}
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 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 *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 );
}
