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 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 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 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 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; }
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 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) ); )
/* Subroutine to Process the output data callback */ int outsub_c( char * outstr ) { DECLARE_CHARACTER_DYN(OUTSTR); size_t lenstr; int jstat; if (*gl_outsub == NULL) return hlp_INTERNAL_ERROR; /* Calculate the length of the string */ lenstr = strlen( outstr ); /* Copy pointers and store the length - really need a F77_COPY_CHARACTER macro */ OUTSTR = outstr; OUTSTR_length = lenstr; /* Call the fortran routine, include the length of the HLP */ jstat = (*gl_outsub)( CHARACTER_ARG(OUTSTR) TRAIL_ARG(OUTSTR) ); return jstat; }
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 ); }