static bool check_usage(int nlhs, mxArray *plhs[],
int nrhs, const mxArray *prhs[])
{
/* number of parameters */
if (nrhs != 6)
return usage("wrong number of inputs");
/* number of returns */
if (nlhs != 1)
return usage("wrong number of outputs");
/* dims */
int dims_cnt = mxGetNumberOfDimensions(prhs[0]);
const mwSize *dims = mxGetDimensions(prhs[0]);
if (dims_cnt != 2 || !(dims[0] == 1 && (dims[1] == 2 || dims[1] == 3)))
return usage("dims must be row vector: [r c] or [r c d]");
const double *dim = mxGetPr(prhs[0]);
int is_3D = (dims[1] == 3) && dim[2] > 1;
if (!(dim[0] > 1 && dim[1] > 1 && (!is_3D || dim[2] > 1)))
return usage("dim [r c] or [r c d] for r,c at least 2, d positive");
/* N */
if (!is_scalar(prhs[1]))
return usage("N must be a scalar");
uint N = (uint)mxGetScalar(prhs[1]);
if (is_3D && !(N == 6 || N == 18 || N == 26))
return usage("only neighborhoods of 6,18,26 supported in 3D");
else if (!is_3D && !(N == 4 || N == 8 || N == 16))
return usage("only neighborhoods of 4,8,16 supported in 2D");
/* label_cnt */
if (!is_scalar(prhs[2]))
return usage("label_cnt must be scalar");
if (mxGetScalar(prhs[2]) <= 1)
return usage("must have at least two labels");
/* R */
if (mxGetClassID(prhs[3]) != mxFUNCTION_CLASS)
return usage("R must be a function handle");
/* B */
if (mxGetClassID(prhs[4]) != mxFUNCTION_CLASS)
return usage("B must be a function handle");
/* V */
if (!mxIsDouble(prhs[5]))
return usage("V must be of type double");
if (mxGetNumberOfDimensions(prhs[5]) != 2)
return usage("V must be a matrix of n-by-n");
const mwSize *V_dims = mxGetDimensions(prhs[5]);
if (V_dims[0] != V_dims[1])
return usage("V must be of size label_cnt x label_cnt");
return true; /* passed inspection */
}
builtin_types replace_scalar( builtin_types const& btc, builtin_types const& scalar_btc )
{
assert( is_scalar(scalar_btc) );
if( !is_scalar(scalar_btc) ) { return scalar_btc; }
if( is_vector(btc) )
{
return vector_of( scalar_btc, vector_size(btc) );
}
else if ( is_matrix(btc) )
{
return matrix_of( scalar_btc, vector_size(btc), vector_count(btc) );
}
else
{
return scalar_btc;
}
}
ex_value_t *
convert_value (ex_value_t *value, type_t *type)
{
if (!is_scalar (type) || !is_scalar (ev_types[value->type])) {
error (0, "unable to convert non-scalar value");
return value;
}
if (is_float (type)) {
float val = value_as_float (value);
return new_float_val (val);
} else if (type->type == ev_short) {
int val = value_as_int (value);
return new_short_val (val);
} else if (type->type == ev_uinteger) {
unsigned val = value_as_uint (value);
return new_uinteger_val (val);
} else {
//FIXME handle enums separately?
int val = value_as_int (value);
return new_integer_val (val);
}
}
static int try_read_float(hid_t loc, char * name, double * dest){
if(H5Lexists(loc,name,H5P_DEFAULT)){
hid_t ds = H5Dopen(loc,name,H5P_DEFAULT);
hid_t t = H5Dget_type(ds);
hid_t s = H5Dget_space(ds);
if(H5Tget_class(t) == H5T_FLOAT && is_scalar(ds)){
H5Dread(ds,H5T_NATIVE_DOUBLE,H5S_ALL,H5S_ALL,H5P_DEFAULT,dest);
}
H5Tclose(t);
H5Sclose(s);
H5Dclose(ds);
return 1;
}
return 0;
}
static int try_read_int(hid_t loc, char * name, int * dest){
if(H5Lexists(loc,name,H5P_DEFAULT)){
hid_t ds = H5Dopen(loc,name,H5P_DEFAULT);
hid_t t = H5Dget_type(ds);
hid_t s = H5Dget_space(ds);
if(H5Tget_class(t) == H5T_INTEGER && is_scalar(ds)){
H5Dread(ds,H5T_NATIVE_INT32,H5S_ALL,H5S_ALL,H5P_DEFAULT,dest);
}
H5Tclose(t);
H5Sclose(s);
H5Dclose(ds);
return 1;
}
return 0;
}
/*
* Modifies the given variable's metadata to support the data transform specified by
* orig_var->transform_spec. Also handles error conditions, such as the variable
* being a scalar (which disallows any data transform).
*/
struct adios_var_struct * adios_transform_define_var(struct adios_var_struct *orig_var) {
// First detect error conditions that prevent the transform from being applied
struct adios_transform_spec *transform_spec = orig_var->transform_spec;
if (!transform_spec) return orig_var;
// If the variable has a transform, but is a scalar: remove the transform, warn the user, and continue as usual
if (transform_spec->transform_type != adios_transform_none &&
(is_scalar(orig_var) || is_timed_scalar(orig_var))) {
log_warn("Data transforms not allowed on scalars, yet variable %s/%s is marked for transform \"%s\"; not applying data transform.\n",
orig_var->path, orig_var->name, transform_spec->transform_type_str);
orig_var->transform_type = adios_transform_none;
orig_var->transform_spec->transform_type = adios_transform_none;
return orig_var;
}
// The variable has none of the above errors; apply the transform metadata
log_debug("Transforming variable %s/%s with type %d\n", orig_var->path, orig_var->name, transform_spec->transform_type);
// Set transform type and spec
orig_var->transform_type = transform_spec->transform_type;
// If there is no transform, nothing else to do
if (transform_spec->transform_type == adios_transform_none)
return orig_var;
// If we get here, transform_type is an actual transformation, so prepare
// the variable. This entails 1) adding a new dimension variable for
// the variable (it will become a 1D byte array), and 2) making the
// variable into a 1D byte array.
// Convert variable to 1D byte array
adios_transform_convert_var_to_byte_array(orig_var);
log_debug("Data Transforms layer: Converted variable %s into byte array internally\n", orig_var->name);
// Allocate the transform-specific metadata buffer
orig_var->transform_metadata_len = adios_transform_get_metadata_size(transform_spec);
if (orig_var->transform_metadata_len)
orig_var->transform_metadata = malloc(orig_var->transform_metadata_len);
// Return the modified variable
return orig_var;
}
void analyze_iteration_statement(ExecNode *s)
{
/*
* 6.8.5
* #2 The controlling expression of an iteration statement shall have scalar type.
*/
Token ty;
/* the controlling expression of a for statement can be missing */
if (s->child[0] == NULL)
return; /* OK */
if ((ty=get_type_category(&s->child[0]->type)) == TOK_ERROR)
return;
if (!is_scalar(ty))
ERROR(s, "controlling expression of %s statement has non-scalar type",
(s->kind.stmt==WhileStmt)?"while":(s->kind.stmt==DoStmt)?"do":"for");
}
// TODO: Return the value or store it?
llvm::Value*
Generator::gen(Default_init const* e)
{
Type const* t = e->type();
llvm::Type* type = get_type(t);
// Scalar types should get a 0 value in the
// appropriate type.
if (is_scalar(t))
return llvm::ConstantInt::get(type, 0);
// Aggregate types are zero initialized.
//
// NOTE: This isn't actually correct. Aggregate types
// should be memberwise default initialized.
if (is_aggregate(t))
return llvm::ConstantAggregateZero::get(type);
throw std::runtime_error("unhahndled default initializer");
}
void analyze_selection_statement(ExecNode *s)
{
Token ty;
if ((ty=get_type_category(&s->child[0]->type)) == TOK_ERROR)
return;
if (s->kind.stmt == IfStmt) {
/*
* 6.8.4.1
* #1 The controlling expression of an if statement shall have scalar type.
*/
if (!is_scalar(ty))
ERROR(s, "controlling expression of if statement has non-scalar type");
} else /* if (s->kind.stmt == SwitchStmt) */ {
/*
* 6.8.4.2
* #1 The controlling expression of a switch statement shall have integer type.
*/
if (!is_integer(ty))
ERROR(s, "controlling expression of switch statement has non-integer type");
}
}
bool emit_zsh(const nodelist *list)
{
log_debug("zsh", "emitting...");
emit_context context =
{
.emit_mapping_item = emit_mapping_item,
.wrap_collections = false
};
return nodelist_iterate(list, emit_node, &context);
}
static bool emit_mapping_item(Node *key, Node *value, void * context __attribute__((unused)))
{
if(is_scalar(value))
{
log_trace("zsh", "emitting mapping item");
if(!emit_scalar(scalar(key)))
{
log_error("zsh", "uh oh! couldn't emit mapping key");
return false;
}
EMIT(" ");
if(!emit_scalar(scalar(value)))
{
log_error("zsh", "uh oh! couldn't emit mapping value");
return false;
}
EMIT(" ");
}
else
{
log_trace("zsh", "skipping mapping item");
}
return true;
}
NhlErrorTypes ezfftb_W( void )
{
/*
* Input array variables
*/
void *cf;
double *tmp_cf1 = NULL;
double *tmp_cf2 = NULL;
int ndims_cf;
ng_size_t dsizes_cf[NCL_MAX_DIMENSIONS];
ng_size_t dsizes_xbar[1];
void *xbar;
double *tmp_xbar = NULL;
NclBasicDataTypes type_cf, type_xbar;
NclScalar missing_cf, missing_dcf, missing_rcf, missing_x;
int has_missing_cf;
/*
* Some variables we need to retrieve the "npts" atttribute (if it exists).
*/
NclAttList *att_list;
NclAtt tmp_attobj;
NclStackEntry data;
/*
* Output array variables
*/
void *x;
double *tmp_x;
int ndims_x;
ng_size_t dsizes_x[NCL_MAX_DIMENSIONS];
NclBasicDataTypes type_x;
/*
* various
*/
double *work;
ng_size_t index_cf, index_x;
ng_size_t i, *tmp_npts, npts, npts2, lnpts2, size_x, size_leftmost;
int found_missing1, found_missing2, any_missing, scalar_xbar;
int inpts;
/*
* Retrieve parameters
*
* Note any of the pointer parameters can be set to NULL, which
* implies you don't care about its value.
*/
cf = (void*)NclGetArgValue(
0,
2,
&ndims_cf,
dsizes_cf,
&missing_cf,
&has_missing_cf,
&type_cf,
DONT_CARE);
xbar = (void*)NclGetArgValue(
1,
2,
NULL,
dsizes_xbar,
NULL,
NULL,
&type_xbar,
DONT_CARE);
/*
* Calculate number of leftmost elements.
*/
size_leftmost = 1;
for( i = 1; i < ndims_cf-1; i++ ) size_leftmost *= dsizes_cf[i];
/*
* Check xbar dimension sizes.
*/
scalar_xbar = is_scalar(1,dsizes_xbar);
if(!scalar_xbar) {
/*
* If xbar is not a scalar, it must be an array of the same dimension
* sizes as the leftmost dimensions of cf (except the first dimension
* of '2').
*/
if(dsizes_xbar[0] != size_leftmost) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ezfftb: If xbar is not a scalar, then it must be a single vector of the length of the product of the leftmost dimensions of 'cf' (not including the '2' dimension)") ;
return(NhlFATAL);
}
}
/*
* Coerce missing values.
*/
coerce_missing(type_cf,has_missing_cf,&missing_cf,&missing_dcf,&missing_rcf);
/*
* Okay, what follows here is some code for retrieving the "npts"
* attribute if it exists. This attribute is one that should have been
* set when "ezfftf" was called, and it indicates the length of the
* original series.
*/
npts2 = dsizes_cf[ndims_cf-1]; /* Calculate the length in case */
/* it is not set explicitly. */
npts = 2*npts2;
data = _NclGetArg(0,2,DONT_CARE);
switch(data.kind) {
case NclStk_VAR:
if(data.u.data_var->var.att_id != -1) {
tmp_attobj = (NclAtt)_NclGetObj(data.u.data_var->var.att_id);
if(tmp_attobj == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ezfftb: Bad attribute list, can't continue");
return(NhlFATAL);
}
if(tmp_attobj->att.n_atts == 0) {
break;
}
att_list = tmp_attobj->att.att_list;
i = 0;
while(att_list != NULL) {
if(att_list->quark == NrmStringToQuark("npts")) {
tmp_npts = get_dimensions(att_list->attvalue->multidval.val,1,
att_list->attvalue->multidval.data_type,
"ezfftb");
npts = *tmp_npts;
free(tmp_npts);
if((npts % 2) == 0) {
npts2 = npts/2;
}
else {
npts2 = (npts-1)/2;
}
break;
}
att_list = att_list->next;
}
}
break;
default:
NhlPError(NhlFATAL,NhlEUNKNOWN,"ezfftb: data.kind, can't continue");
return(NhlFATAL);
}
/*
* Test input array size
*/
if(npts > INT_MAX) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ezfftb: npts = %d is greater than INT_MAX", npts);
return(NhlFATAL);
}
inpts = (int) npts;
/*
* Calculate size of output array.
*/
lnpts2 = npts2 * size_leftmost;
size_x = size_leftmost * npts;
ndims_x = ndims_cf - 1;
for(i = 0; i < ndims_x-1; i++ ) dsizes_x[i] = dsizes_cf[i+1];
dsizes_x[ndims_x-1] = npts;
/*
* Create arrays to coerce input to double if necessary.
*/
if(type_cf != NCL_double) {
tmp_cf1 = (double*)calloc(npts2,sizeof(double));
tmp_cf2 = (double*)calloc(npts2,sizeof(double));
if(tmp_cf1 == NULL || tmp_cf2 == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ezfftb: Unable to allocate memory for coercing input array to double precision");
return(NhlFATAL);
}
}
if(type_xbar != NCL_double) {
tmp_xbar = (double*)calloc(1,sizeof(double));
if(tmp_xbar == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ezfftb: Unable to allocate memory for coercing input array to double precision");
return(NhlFATAL);
}
}
/*
* Allocate memory for output array.
*/
tmp_x = (double *)calloc(npts,sizeof(double));
if (tmp_x == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ezfftb: Cannot allocate memory for temporary output array" );
return(NhlFATAL);
}
if(type_cf == NCL_double) {
type_x = NCL_double;
x = (void*)calloc(size_x,sizeof(double));
if(has_missing_cf) missing_x = missing_dcf;
}
else {
type_x = NCL_float;
x = (void*)calloc(size_x,sizeof(float));
if(has_missing_cf) missing_x = missing_rcf;
}
if (x == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ezfftb: Cannot allocate memory for output array" );
return(NhlFATAL);
}
/*
* Allocate memory for work array
*/
work = (double*)calloc(4*npts+15,sizeof(double));
if ( work == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ezfftb: Cannot allocate memory for work array" );
return(NhlFATAL);
}
/*
* If xbar is a scalar, coerce it outside the loop.
*/
if(scalar_xbar) {
if(type_xbar != NCL_double) {
coerce_subset_input_double(xbar,tmp_xbar,0,type_xbar,1,0,NULL,NULL);
}
else {
tmp_xbar = &((double*)xbar)[0];
}
}
/*
* Call the f77 version of 'dezfftb' with the full argument list.
*/
index_x = index_cf = 0;
any_missing = 0;
for(i = 0; i < size_leftmost; i++) {
if(type_cf != NCL_double) {
coerce_subset_input_double(cf,tmp_cf1,index_cf,type_cf,npts2,0,
NULL,NULL);
coerce_subset_input_double(cf,tmp_cf2,lnpts2+index_cf,type_cf,npts2,0,
NULL,NULL);
}
else {
tmp_cf1 = &((double*)cf)[index_cf];
tmp_cf2 = &((double*)cf)[lnpts2+index_cf];
}
/*
* Check for missing values in cf. If any, then coerce that section of
* the output to missing.
*/
found_missing1 = contains_missing(tmp_cf1,npts2,has_missing_cf,
missing_dcf.doubleval);
found_missing2 = contains_missing(tmp_cf2,npts2,has_missing_cf,
missing_dcf.doubleval);
if(found_missing1 || found_missing2) {
any_missing++;
set_subset_output_missing(x,index_x,type_x,npts,missing_dcf.doubleval);
}
else {
/*
* If xbar is not a scalar, then we need to coerce each element
* to double or else just grab its value.
*/
if(!scalar_xbar) {
if(type_xbar != NCL_double) {
coerce_subset_input_double(xbar,tmp_xbar,i,type_xbar,1,0,NULL,NULL);
}
else {
tmp_xbar = &((double*)xbar)[i];
}
}
NGCALLF(dezffti,DEZFFTI)(&inpts,work);
NGCALLF(dezfftb,DEZFFTB)(&inpts,tmp_x,tmp_xbar,tmp_cf1,tmp_cf2,work);
/*
* Copy results back into x.
*/
coerce_output_float_or_double(x,tmp_x,type_cf,npts,index_x);
}
index_x += npts;
index_cf += npts2;
}
/*
* Free up memory.
*/
if(type_cf != NCL_double) {
free(tmp_cf1);
free(tmp_cf2);
}
if(type_xbar != NCL_double) free(tmp_xbar);
free(tmp_x);
free(work);
if(any_missing) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"ezfftb: %d input arrays contained missing values. No calculations performed on these arrays.",any_missing);
return(NclReturnValue(x,ndims_x,dsizes_x,&missing_x,type_x,0));
}
else {
return(NclReturnValue(x,ndims_x,dsizes_x,NULL,type_x,0));
}
}
int Dim::max_index() const {
if (is_scalar()) return 0;
else if (is_vector()) return vec_size()-1;
else if (type()==MATRIX) return dim2-1;
else return dim1-1;
}
NhlErrorTypes center_finite_diff_n_W( void )
{
/*
* Input array variables
*/
void *q, *r;
logical *cyclic;
int *opt, *dim, r_one_d;
int r_scalar = 1;
double *tmp_q, *tmp_r;
int ndims_q;
ng_size_t dsizes_q[NCL_MAX_DIMENSIONS];
int ndims_r;
ng_size_t dsizes_r[NCL_MAX_DIMENSIONS];
int has_missing_q, has_missing_r;
NclScalar missing_q, missing_dq, missing_rq;
NclScalar missing_r, missing_dr;
NclBasicDataTypes type_q, type_r, type_dqdr;
/*
* Output array variables
*/
void *dqdr;
double *tmp_dqdr;
NclScalar missing_dqdr;
/*
* Declare various variables for random purposes.
*/
ng_size_t i, j, npts, npts1, size_q, size_leftmost, size_rightmost, size_rl;
ng_size_t index_nrnpts, index_q;
int inpts, inpts1, iend, ier;
double *qq, *rr;
/*
* Retrieve parameters
*
* Note that any of the pointer parameters can be set to NULL,
* which implies you don't care about its value.
*
*/
q = (void*)NclGetArgValue(
0,
5,
&ndims_q,
dsizes_q,
&missing_q,
&has_missing_q,
&type_q,
DONT_CARE);
r = (void*)NclGetArgValue(
1,
5,
&ndims_r,
dsizes_r,
&missing_r,
&has_missing_r,
&type_r,
DONT_CARE);
cyclic = (logical*)NclGetArgValue(
2,
5,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
opt = (int*)NclGetArgValue(
3,
5,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
dim = (int*)NclGetArgValue(
4,
5,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Make sure "dim" is a valid dimension.
*/
if (*dim < 0 || *dim >= ndims_q) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"center_finite_diff_n: Invalid dimension index for calculating the center finite difference");
return(NhlFATAL);
}
/*
* Set value for cyclic.
*/
if(*cyclic) {
iend = 0;
}
else {
iend = 1;
}
/*
* Get size of input array and test dimension sizes.
*/
npts = dsizes_q[*dim];
npts1 = npts + 1;
if((npts > INT_MAX) || (npts1 > INT_MAX)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"center_finite_diff_n: npts1 = %ld is larger than INT_MAX", npts1);
return(NhlFATAL);
}
inpts = (int) npts;
inpts1 = (int) npts1;
if((ndims_r == 1 && (dsizes_r[0] != npts && dsizes_r[0] != 1)) ||
(ndims_r > 1 && ndims_r != ndims_q)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"center_finite_diff_n: r must either be a scalar, a 1D array the same length as the dim-th dimemsion of q, or the same size as q");
return(NhlFATAL);
}
if(ndims_r > 1) {
for( i = 0; i < ndims_r; i++ ) {
if(dsizes_r[i] != dsizes_q[i]) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"center_finite_diff_n: r must either be a scalar, a 1D array the same length as the dim-th dimemsion of q, or the same size as q");
return(NhlFATAL);
}
}
}
/*
* Compute the total size of the q array.
*/
size_rightmost = size_leftmost = 1;
for( i = 0; i < *dim; i++ ) size_leftmost *= dsizes_q[i];
for( i = *dim+1; i < ndims_q; i++ ) size_rightmost *= dsizes_q[i];
size_rl = size_leftmost * size_rightmost;
size_q = size_rl * npts;
/*
* Check for missing values.
*/
coerce_missing(type_q,has_missing_q,&missing_q,&missing_dq,&missing_rq);
coerce_missing(type_r,has_missing_r,&missing_r,&missing_dr,NULL);
/*
* Create arrays to hold temporary r and q values.
*/
qq = (double*)calloc(npts+2,sizeof(double));
rr = (double*)calloc(npts+2,sizeof(double));
if( qq == NULL || rr == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"center_finite_diff_n: Unable to allocate memory for temporary arrays");
return(NhlFATAL);
}
/*
* Create temporary arrays to hold double precision data.
*/
tmp_q = (double*)calloc(npts,sizeof(double));
if( tmp_q == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"center_finite_diff_n: Unable to allocate memory for coercing q to double precision");
return(NhlFATAL);
}
/*
* 'r' can be a scalar, one-dimensional, or multi-dimensional.
*
* If it is a scalar, then we need to construct an npts-sized 'r'
* that is based on the scalar value.
*
* If it is 1D, then we need to coerce it to double if necessary.
*
* If it is nD, then we need to create a temporary 1D array so we
* can coerce the potentially non-contiguous 1D subsets to double.
*/
if(ndims_r > 1) {
r_one_d = 0;
}
else {
r_one_d = 1;
r_scalar = is_scalar(ndims_r,dsizes_r);
}
/*
* Here are the three possible scenarios for "r":
*/
if(r_scalar) {
tmp_r = (double*)calloc(npts,sizeof(double));
coerce_subset_input_double(r,&tmp_r[0],0,type_r,1,0,NULL,NULL);
/*
* Copy this scalar npts-1 times to rest of the array.
*/
for(i = 1; i < npts; i++ ) tmp_r[i] = tmp_r[i-1] + tmp_r[0];
}
else if(r_one_d) {
tmp_r = coerce_input_double(r,type_r,npts,0,NULL,NULL);
}
else {
tmp_r = (double*)calloc(npts,sizeof(double));
}
if( tmp_r == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"center_finite_diff_n: Unable to allocate memory for coercing r to double precision");
return(NhlFATAL);
}
/*
* Allocate space for output array.
*/
if(type_q == NCL_double || type_r == NCL_double) {
type_dqdr = NCL_double;
dqdr = (void*)calloc(size_q,sizeof(double));
missing_dqdr = missing_dq;
}
else {
type_dqdr = NCL_float;
dqdr = (void*)calloc(size_q,sizeof(float));
missing_dqdr = missing_rq;
}
tmp_dqdr = (double*)calloc(npts,sizeof(double));
if( dqdr == NULL || tmp_dqdr == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"center_finite_diff_n: Unable to allocate memory for output array");
return(NhlFATAL);
}
/*
* Loop through dimensions and call Fortran routine.
*/
for( i = 0; i < size_leftmost; i++ ) {
index_nrnpts = i*size_rightmost * npts;
for( j = 0; j < size_rightmost; j++ ) {
index_q = index_nrnpts + j;
/*
* Coerce q (tmp_q) to double.
*/
coerce_subset_input_double_step(q,tmp_q,index_q,size_rightmost,
type_q,npts,0,NULL,NULL);
if(!r_one_d) {
/*
* Coerce r (tmp_r) to double.
*/
coerce_subset_input_double_step(r,tmp_r,index_q,size_rightmost,
type_r,npts,0,NULL,NULL);
}
/*
* Call the Fortran routine.
*/
NGCALLF(dcfindif,DCFINDIF)(tmp_q,tmp_r,&inpts,&missing_dq.doubleval,
&missing_dr.doubleval,cyclic,&iend,
qq,rr,&inpts1,tmp_dqdr,&ier);
coerce_output_float_or_double_step(dqdr,tmp_dqdr,type_dqdr,npts,index_q,
size_rightmost);
}
}
/*
* Free temp arrays.
*/
if(type_r != NCL_double || r_scalar || !r_one_d) NclFree(tmp_r);
NclFree(tmp_q);
NclFree(tmp_dqdr);
NclFree(qq);
NclFree(rr);
if(has_missing_q) {
return(NclReturnValue(dqdr,ndims_q,dsizes_q,&missing_dqdr,type_dqdr,0));
}
else {
return(NclReturnValue(dqdr,ndims_q,dsizes_q,NULL,type_dqdr,0));
}
}
NhlErrorTypes center_finite_diff_W( void )
{
/*
* Input array variables
*/
void *q, *r;
logical *cyclic;
int *opt, r_one_d, r_scalar;
double *tmp_q = NULL;
double *tmp_r = NULL;
int ndims_q;
ng_size_t dsizes_q[NCL_MAX_DIMENSIONS];
int ndims_r;
ng_size_t dsizes_r[NCL_MAX_DIMENSIONS];
int has_missing_q, has_missing_r;
NclScalar missing_q, missing_dq, missing_rq;
NclScalar missing_r, missing_dr;
NclBasicDataTypes type_q, type_r, type_dqdr;
/*
* Output array variables
*/
void *dqdr;
double *tmp_dqdr = NULL;
NclScalar missing_dqdr;
/*
* Declare various variables for random purposes.
*/
ng_size_t i, npts, npts1, size_q, size_leftmost, index_q;
int inpts, inpts1, iend, ier;
double *qq, *rr;
/*
* Retrieve parameters
*
* Note that any of the pointer parameters can be set to NULL,
* which implies you don't care about its value.
*
*/
q = (void*)NclGetArgValue(
0,
4,
&ndims_q,
dsizes_q,
&missing_q,
&has_missing_q,
&type_q,
DONT_CARE);
r = (void*)NclGetArgValue(
1,
4,
&ndims_r,
dsizes_r,
&missing_r,
&has_missing_r,
&type_r,
DONT_CARE);
cyclic = (logical*)NclGetArgValue(
2,
4,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
opt = (int*)NclGetArgValue(
3,
4,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Get size of input array and test dimension sizes.
*/
npts = dsizes_q[ndims_q-1];
npts1 = npts + 1;
if((npts > INT_MAX) || (npts1 > INT_MAX)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"center_finite_diff: npts1 = %ld is larger than INT_MAX", npts1);
return(NhlFATAL);
}
inpts = (int) npts;
inpts1 = (int) npts1;
if((ndims_r == 1 && (dsizes_r[0] != npts && dsizes_r[0] != 1)) ||
(ndims_r > 1 && ndims_r != ndims_q)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"center_finite_diff: r must either be a scalar, a 1D array the same length as the rightmost dimemsion of q, or the same size as q");
return(NhlFATAL);
}
if(ndims_r > 1) {
r_one_d = 0;
for( i = 0; i < ndims_r-1; i++ ) {
if(dsizes_r[i] != dsizes_q[i]) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"center_finite_diff: r must either be a scalar, a 1D array the same length as the rightmost dimemsion of q, or the same size as q");
return(NhlFATAL);
}
}
}
else {
r_one_d = 1;
}
/*
* Compute the total size of the q array.
*/
size_leftmost = 1;
for( i = 0; i < ndims_q-1; i++ ) size_leftmost *= dsizes_q[i];
size_q = size_leftmost * npts;
/*
* Check for missing values.
*/
coerce_missing(type_q,has_missing_q,&missing_q,&missing_dq,&missing_rq);
coerce_missing(type_r,has_missing_r,&missing_r,&missing_dr,NULL);
/*
* Create arrays to hold temporary r and q values.
*/
qq = (double*)calloc(npts+2,sizeof(double));
rr = (double*)calloc(npts+2,sizeof(double));
if( qq == NULL || rr == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"center_finite_diff: Unable to allocate memory for temporary arrays");
return(NhlFATAL);
}
/*
* Create temporary arrays to hold double precision data.
*/
if(type_q != NCL_double) {
tmp_q = (double*)calloc(npts,sizeof(double));
if( tmp_q == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"center_finite_diff: Unable to allocate memory for coercing q to double precision");
return(NhlFATAL);
}
}
/*
* 'r' can be a scalar, one-dimensional, or multi-dimensional.
* If it is a scalar, then we need to construct an npts-sized 'r'
* that is based on the scalar value.
*/
r_scalar = is_scalar(ndims_r,dsizes_r);
if(type_r != NCL_double || r_scalar) {
tmp_r = (double*)calloc(npts,sizeof(double));
if( tmp_r == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"center_finite_diff: Unable to allocate memory for coercing r to double precision");
return(NhlFATAL);
}
/*
* Coerce r (tmp_r) to double if necessary.
*/
if(r_one_d) {
coerce_subset_input_double(r,tmp_r,0,type_r,dsizes_r[0],0,NULL,NULL);
}
/*
* If r is a scalar, then copy it npts-1 times to rest of the array.
*/
if(r_scalar) {
for(i = 1; i < npts; i++ ) tmp_r[i] = tmp_r[i-1] + tmp_r[0];
}
}
if(type_r == NCL_double && !r_scalar && r_one_d) {
/*
* Point tmp_r to r.
*/
tmp_r = &((double*)r)[0];
}
/*
* Allocate space for output array.
*/
if(type_q == NCL_double || type_r == NCL_double) {
type_dqdr = NCL_double;
dqdr = (void*)calloc(size_q,sizeof(double));
missing_dqdr = missing_dq;
}
else {
type_dqdr = NCL_float;
dqdr = (void*)calloc(size_q,sizeof(float));
tmp_dqdr = coerce_output_double(dqdr,type_dqdr,npts);
if( tmp_dqdr == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"center_finite_diff: Unable to allocate memory for temporary output array");
return(NhlFATAL);
}
missing_dqdr = missing_rq;
}
if( dqdr == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"center_finite_diff: Unable to allocate memory for output array");
return(NhlFATAL);
}
if(*cyclic) {
iend = 0;
}
else {
iend = 1;
}
/*
* Loop through leftmost dimensions and call Fortran routine.
*/
index_q = 0;
for(i = 0; i < size_leftmost; i++ ) {
if(type_q != NCL_double) {
/*
* Coerce q (tmp_q) to double.
*/
coerce_subset_input_double(q,tmp_q,index_q,type_q,npts,0,NULL,NULL);
}
else {
/*
* Point tmp_q to q.
*/
tmp_q = &((double*)q)[index_q];
}
if(!r_one_d) {
if(type_r != NCL_double) {
/*
* Coerce r (tmp_r) to double.
*/
coerce_subset_input_double(r,tmp_r,index_q,type_r,npts,0,NULL,NULL);
}
else {
/*
* Point tmp_r to r.
*/
tmp_r = &((double*)r)[index_q];
}
}
if(type_dqdr == NCL_double) {
/*
* Point tmp_dqdr to dqdr.
*/
tmp_dqdr = &((double*)dqdr)[index_q];
}
/*
* Call the Fortran routine.
*/
NGCALLF(dcfindif,DCFINDIF)(tmp_q,tmp_r,&inpts,&missing_dq.doubleval,
&missing_dr.doubleval,cyclic,&iend,
qq,rr,&inpts1,tmp_dqdr,&ier);
if(type_dqdr != NCL_double) {
coerce_output_float_only(dqdr,tmp_dqdr,npts,index_q);
}
index_q += npts;
}
/*
* Free temp arrays.
*/
if(type_r != NCL_double || r_scalar) NclFree(tmp_r);
if(type_q != NCL_double) NclFree(tmp_q);
if(type_dqdr != NCL_double) NclFree(tmp_dqdr);
NclFree(qq);
NclFree(rr);
if(has_missing_q) {
return(NclReturnValue(dqdr,ndims_q,dsizes_q,&missing_dqdr,type_dqdr,0));
}
else {
return(NclReturnValue(dqdr,ndims_q,dsizes_q,NULL,type_dqdr,0));
}
}
void mexFunction(int nlhs, mxArray *plhs[],
int nrhs, const mxArray *prhs[])
{
/* check number of inputs/outputs */
if (nrhs < 2)
{
mexErrMsgIdAndTxt("opnorm:opnorm:nargin",
"At least two inputs required");
}
if (nrhs > 5)
{
mexErrMsgIdAndTxt("opnorm:opnorm:nargin",
"At most five inputs allowed");
}
if (nlhs > 3)
{
mexErrMsgIdAndTxt("opnorm:opnorm:nargout",
"At most three outputs");
}
/* check and retrieve inputs */
double *Adat, p, q;
opnorm_opt_t opt;
/* the matrix A */
if (! is_real_double(prhs[0]) )
mexErrMsgIdAndTxt("opnorm:opnorm:not_real_double",
"A must be a real double matrix");
Adat = mxGetPr(prhs[0]);
/* p */
if ( (! is_real_double(prhs[1])) || (! is_scalar(prhs[1])))
mexErrMsgIdAndTxt("opnorm:opnorm:not_real_double_scalar",
"p must be a real double scalar");
p = mxGetScalar(prhs[1]);
/* q */
if (nrhs > 2)
{
if ( (! is_real_double(prhs[2])) || (! is_scalar(prhs[2])))
mexErrMsgIdAndTxt("opnorm:opnorm:not_real_double_scalar",
"q must be a real double scalar");
q = mxGetScalar(prhs[2]);
}
else
{
q = p;
}
/* epsilon */
if (nrhs > 3)
{
if ( (! is_real_double(prhs[3])) || (! is_scalar(prhs[3])))
mexErrMsgIdAndTxt("opnorm:opnorm:not_real_double_scalar",
"epsilon must be a real double scalar");
opt.eps = mxGetScalar(prhs[3]);
}
else
{
opt.eps = 1e-10;
}
/* fifomax */
if (nrhs > 4)
{
if ( ! is_scalar(prhs[4]) )
mexErrMsgIdAndTxt("opnorm:opnorm:not_scalar",
"fifomax epsilon must be a scalar");
opt.fifomax = mxGetScalar(prhs[4]);
}
else
{
opt.fifomax = 0UL;
}
/* matrix size */
mwSize
n = mxGetN(prhs[0]),
m = mxGetM(prhs[0]);
/* prepare output data */
mxArray *N = mxCreateDoubleMatrix(1, 1, mxREAL);
double *Ndat = mxGetPr(N);
mxArray *v = NULL;
double *vdat = NULL;
if (nlhs > 1)
{
v = mxCreateDoubleMatrix(n, 1, mxREAL);
vdat = mxGetPr(v);
}
opnorm_stats_t stats = {0};
/* run opnorm */
int err = opnorm(Adat, column_major, m, n, p, q, opt,
Ndat, vdat, &stats);
/* check for error */
if (err)
mexErrMsgIdAndTxt("opnorm:opnorm:external",
opnorm_strerror(err));
/* convert stats to matlab format */
mxArray *mxstats = stats_mxArray(stats);
if (! mxstats)
mexErrMsgIdAndTxt("opnorm:opnorm:external",
"failed to create Matlab stats array");
/*
one would expect that this would not be wise to ignore
the nlhs variable in and assign tke plhs pointers anyway,
but apparently it is (and the first pointer is used for
the matlab ans)
*/
plhs[0] = N;
plhs[1] = v;
plhs[2] = mxstats;
}
inline bool is_scalar(Port *port)
{
return is_scalar(port->type);
}
NhlErrorTypes NhlGetNamedColorIndex_W( void )
{
int i, j, ii, *ci, *wks, nid, total_cname_elements, total_wks_elements;
NclHLUObj tmp_hlu_obj;
NrmQuark *cname;
int ndims_cname;
ng_size_t dsizes_cname[NCL_MAX_DIMENSIONS];
int ndims_wks;
ng_size_t dsizes_wks[NCL_MAX_DIMENSIONS];
int ndims_out;
ng_size_t dsizes_out[NCL_MAX_DIMENSIONS];
/*
* Retrieve parameters
*
* Note any of the pointer parameters can be set to NULL, which
* implies you don't care about its value. In this example
* the type parameter is set to NULL because the function
* is later registered to only accept floating point numbers.
*
* Retrieve argument #1
*/
wks = (int*)NclGetArgValue(0,2,&ndims_wks,dsizes_wks,NULL,NULL,NULL,
DONT_CARE);
/*
* Retrieve argument #2
*/
cname = (NrmQuark *) NclGetArgValue(1,2,&ndims_cname,dsizes_cname,NULL,NULL,
NULL,DONT_CARE);
/*
* Compute total number of elements in wks array.
*/
total_wks_elements = 1;
for(i = 0; i < ndims_wks; i++) {
total_wks_elements *= dsizes_wks[i];
}
/*
* Compute total number of elements in color name array.
*/
total_cname_elements = 1;
for(i = 0; i < ndims_cname; i++) {
total_cname_elements *= dsizes_cname[i];
}
ci = (int*)calloc(total_wks_elements*total_cname_elements*sizeof(int),1);
ii = 0;
for(i = 0; i < total_wks_elements; i++) {
for(j = 0; j < total_cname_elements; j++) {
/*
* Determine the NCL identifier for the graphic object.
*/
tmp_hlu_obj = (NclHLUObj) _NclGetObj(wks[i]);
nid = tmp_hlu_obj->hlu.hlu_id;
ci[ii] = NhlGetNamedColorIndex(nid,NrmQuarkToString(cname[j]));
ii++;
}
}
/*
* If only one workstation has been given, then the number of dimensions
* of the output is just equal to the dimensions of the colors inputted.
*/
if(is_scalar(ndims_wks,dsizes_wks)) {
ndims_out = ndims_cname;
for( i = 0; i < ndims_cname; i++ ) {
dsizes_out[i] = dsizes_cname[i];
}
}
else {
ndims_out = ndims_cname + ndims_wks;
for( i = 0; i < ndims_wks; i++ ) {
dsizes_out[i] = dsizes_wks[i];
}
for( i = 0; i < ndims_cname; i++ ) {
dsizes_out[i+ndims_wks] = dsizes_cname[i];
}
}
return(NclReturnValue( (void *) ci, ndims_out, dsizes_out, NULL, NCL_int, 0));
}
NhlErrorTypes potmp_insitu_ocn_W( void )
{
/*
* Input variables
*/
/*
* Argument # 0
*/
void *t;
double *tmp_t;
int ndims_t;
ng_size_t dsizes_t[NCL_MAX_DIMENSIONS];
NclBasicDataTypes type_t;
int has_missing_t;
NclScalar missing_t, missing_flt_t, missing_dbl_t;
/*
* Argument # 1
*/
void *s;
double *tmp_s;
int ndims_s;
ng_size_t dsizes_s[NCL_MAX_DIMENSIONS];
NclBasicDataTypes type_s;
int has_missing_s;
NclScalar missing_s, missing_flt_s, missing_dbl_s;
/*
* Argument # 2
*/
void *pres;
double *tmp_pres;
int ndims_pres;
ng_size_t dsizes_pres[NCL_MAX_DIMENSIONS];
NclBasicDataTypes type_pres;
int is_scalar_pres;
/*
* Argument # 3
*/
void *pref;
double *tmp_pref;
NclBasicDataTypes type_pref;
/*
* Argument # 4
*/
int *dims;
ng_size_t dsizes_dims[1];
/*
* Argument # 5
*/
logical *opt;
logical reverse = False;
/*
* Variables for retrieving attributes from "opt".
*/
NclAttList *attr_list;
NclAtt attr_obj;
NclStackEntry stack_entry;
/*
* Return variable
*/
void *pot;
double *tmp_pot;
NclBasicDataTypes type_pot;
NclScalar missing_pot;
/*
* Various
*/
ng_size_t i, total_nts, total_npres, total_nl, total_nr, nrnpres;
ng_size_t ipres;
int ret;
/*
* Retrieve parameters.
*
* Note any of the pointer parameters can be set to NULL, which
* implies you don't care about its value.
*/
/*
* Get argument # 0
*/
t = (void*)NclGetArgValue(
0,
6,
&ndims_t,
dsizes_t,
&missing_t,
&has_missing_t,
&type_t,
DONT_CARE);
/*
* Get argument # 1
*/
s = (void*)NclGetArgValue(
1,
6,
&ndims_s,
dsizes_s,
&missing_s,
&has_missing_s,
&type_s,
DONT_CARE);
/*
* Check dimension sizes.
*/
if(ndims_t != ndims_s) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"potmp_insitu_ocn: the dimensions of t and s must be the same");
return(NhlFATAL);
}
for(i = 0; i < ndims_t; i++) {
if(dsizes_t[i] != dsizes_s[i]) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"potmp_insitu_ocn: the dimensions of t and s must be the same");
return(NhlFATAL);
}
}
/*
* Get argument # 2
*/
pres = (void*)NclGetArgValue(
2,
6,
&ndims_pres,
dsizes_pres,
NULL,
NULL,
&type_pres,
DONT_CARE);
/*
* Check dimension sizes and get total # of elements.
*/
if(ndims_pres > ndims_t) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"potmp_insitu_ocn: the rank of pres must be less than or equal to the rank of t and s");
return(NhlFATAL);
}
/* Scalar pressure is a special case */
is_scalar_pres = is_scalar(ndims_pres,dsizes_pres);
/*
* Get argument # 3
*/
pref = (void*)NclGetArgValue(
3,
6,
NULL,
NULL,
NULL,
NULL,
&type_pref,
DONT_CARE);
/*
* Get argument # 4
*/
dims = (int*)NclGetArgValue(
4,
6,
NULL,
dsizes_dims,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Get argument # 5
*/
opt = (logical*)NclGetArgValue(
5,
6,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Some error checking. Make sure pressure dimensions are valid.
*/
if(!is_scalar_pres) {
if(dsizes_dims[0] != ndims_pres) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"potmp_insitu_ocn: invalid number of dimension indexes given for 'pres'");
return(NhlFATAL);
}
for(i = 0; i < dsizes_dims[0]; i++ ) {
if(dims[i] < 0 || dims[i] >= ndims_t) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"potmp_insitu_ocn: invalid dimension indexes given for 'pres'");
return(NhlFATAL);
}
if(i > 0 && dims[i] != (dims[i-1]+1)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"potmp_insitu_ocn: input dimension sizes must be monotonically increasing, can't continue");
return(NhlFATAL);
}
if(dsizes_pres[i] != dsizes_t[dims[i]]) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"potmp_insitu_ocn: dimension indexes given for 'pres' don't match dimensions of t and s");
return(NhlFATAL);
}
}
}
/*
* Coerce missing values to double if necessary.
*/
coerce_missing(type_t,has_missing_t,&missing_t,&missing_dbl_t,
&missing_flt_t);
coerce_missing(type_s,has_missing_s,&missing_s,&missing_dbl_s,
&missing_flt_s);
/*
* Compute the total number of leftmost and rightmost elements
* in t and s.
*/
if(is_scalar_pres) {
total_nl = 1;
for(i = 0; i < ndims_t; i++) total_nl *= dsizes_t[i];
total_npres = nrnpres = total_nr = 1;
total_nts = total_nl;
}
else {
total_npres = total_nl = total_nr = 1;
for(i = 0; i < dims[0]; i++) total_nl *= dsizes_t[i];
for(i = 0; i < ndims_pres; i++) total_npres *= dsizes_pres[i];
for(i = dims[dsizes_dims[0]-1]+1; i < ndims_t; i++) total_nr *= dsizes_t[i];
nrnpres = total_nr * total_npres;
total_nts = total_nl * nrnpres;
}
/*
* The output type defaults to float, unless t is double.
*/
if(type_t == NCL_double || type_s == NCL_double ||
type_pres == NCL_double || type_pref == NCL_double) {
type_pot = NCL_double;
if(has_missing_t) {
missing_pot = missing_dbl_t;
}
else if(has_missing_s) {
missing_pot = missing_dbl_s;
}
}
else {
type_pot = NCL_float;
if(has_missing_t) {
missing_pot = missing_flt_t;
}
else if(has_missing_s) {
missing_pot = missing_flt_s;
}
}
/*
* Coerce input arrays to double if necessary.
*/
tmp_t = coerce_input_double(t, type_t, total_nts,0,NULL,NULL);
tmp_s = coerce_input_double(s, type_s, total_nts,0,NULL,NULL);
tmp_pres = coerce_input_double(pres,type_pres,total_npres,0,NULL,NULL);
tmp_pref = coerce_input_double(pref,type_pref, 1,0,NULL,NULL);
if(tmp_t == NULL || tmp_s == NULL || tmp_pres == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"potmp_insitu_ocn: Unable to allocate memory for coercing input arrays to double");
return(NhlFATAL);
}
/*
* Allocate space for output array.
*/
if(type_pot != NCL_double) {
pot = (void *)calloc(total_nts, sizeof(float));
tmp_pot = (double*)calloc(1,sizeof(double));
}
else {
pot = (void *)calloc(total_nts, sizeof(double));
}
if(pot == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"potmp_insitu_ocn: Unable to allocate memory for output array");
return(NhlFATAL);
}
/*
* If "opt" is True, then check if any attributes have been set.
*/
if(*opt) {
stack_entry = _NclGetArg(5, 6, DONT_CARE);
switch (stack_entry.kind) {
case NclStk_VAR:
if (stack_entry.u.data_var->var.att_id != -1) {
attr_obj = (NclAtt) _NclGetObj(stack_entry.u.data_var->var.att_id);
if (attr_obj == NULL) {
break;
}
}
else {
/*
* att_id == -1 ==> no optional args given.
*/
break;
}
/*
* Get optional arguments.
*/
if (attr_obj->att.n_atts > 0) {
/*
* Get list of attributes.
*/
attr_list = attr_obj->att.att_list;
/*
* Loop through attributes and check them. The current ones recognized are:
* "reverse"
*/
while (attr_list != NULL) {
/*
* Check for "return_eval".
*/
if (!strcmp(attr_list->attname, "reverse")) {
if(attr_list->attvalue->multidval.data_type == NCL_logical) {
reverse = *(logical*) attr_list->attvalue->multidval.val;
}
else {
NhlPError(NhlWARNING,NhlEUNKNOWN,"potmp_insitu_ocn: The 'reverse' attribute must be a logical. Defaulting to False.");
}
}
attr_list = attr_list->next;
}
}
default:
break;
}
}
/*
* Call the Fortran routine.
*/
for(i = 0; i < total_nts; i++) {
if(type_pot == NCL_double) tmp_pot = &((double*)pot)[i];
/* Calculate index into pressure array */
ipres = (ng_size_t)((i-((ng_size_t)(i/nrnpres)*nrnpres))/total_nr);
if(has_missing_t && tmp_t[i] == missing_dbl_t.doubleval) {
*tmp_pot = missing_dbl_t.doubleval;
}
else if(has_missing_s && tmp_s[i] == missing_dbl_s.doubleval) {
*tmp_pot = missing_dbl_s.doubleval;
}
else {
if(reverse) {
NGCALLF(dpotmp,DPOTMP)(tmp_pref, &tmp_t[i], &tmp_s[i],
&tmp_pres[ipres], tmp_pot);
}
else {
NGCALLF(dpotmp,DPOTMP)(&tmp_pres[ipres], &tmp_t[i], &tmp_s[i],
tmp_pref, tmp_pot);
}
}
/*
* Coerce output back to float if necessary.
*/
if(type_pot == NCL_float) coerce_output_float_only(pot,tmp_pot,1,i);
}
/*
* Free unneeded memory.
*/
if(type_t != NCL_double) NclFree(tmp_t);
if(type_s != NCL_double) NclFree(tmp_s);
if(type_pres != NCL_double) NclFree(tmp_pres);
if(type_pref != NCL_double) NclFree(tmp_pref);
if(type_pot != NCL_double) NclFree(tmp_pot);
/*
* Return value back to NCL script.
*/
if(has_missing_t || has_missing_s) {
ret = NclReturnValue(pot,ndims_t,dsizes_t,&missing_pot,type_pot,0);
}
else {
ret = NclReturnValue(pot,ndims_t,dsizes_t,NULL,type_pot,0);
}
return(ret);
}
