NhlErrorTypes linint1_W( void )
{
/*
* Input variables
*/
void *xi, *fi, *xo;
double *tmp_xi = NULL;
double *tmp_fi = NULL;
double *tmp_xo, *tmp_fo;
int ndims_xi;
int ndims_fi;
ng_size_t dsizes_xi[NCL_MAX_DIMENSIONS];
ng_size_t dsizes_xo[NCL_MAX_DIMENSIONS];
ng_size_t dsizes_fi[NCL_MAX_DIMENSIONS];
int has_missing_fi;
ng_size_t *dsizes_fo;
NclScalar missing_fi, missing_dfi, missing_rfi, missing_fo;
int *opt, iopt = 0;
logical *wrap;
NclBasicDataTypes type_xi, type_fi, type_xo, type_fo;
/*
* Output variables.
*/
void *fo;
/*
* Other variables
*/
ng_size_t nxi, nxi2, nxo, nfo, size_leftmost, size_fo;
int inxi, inxi2, inxo, ier, ret;
ng_size_t i, j, index_xi, index_fi, index_fo;
double *xiw, *fxiw;
/*
* Retrieve parameters
*
* Note that any of the pointer parameters can be set to NULL,
* which implies you don't care about its value.
*/
xi = (void*)NclGetArgValue(
0,
5,
&ndims_xi,
dsizes_xi,
NULL,
NULL,
&type_xi,
DONT_CARE);
fi = (void*)NclGetArgValue(
1,
5,
&ndims_fi,
dsizes_fi,
&missing_fi,
&has_missing_fi,
&type_fi,
DONT_CARE);
wrap = (logical*)NclGetArgValue(
2,
5,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
xo = (void*)NclGetArgValue(
3,
5,
NULL,
dsizes_xo,
NULL,
NULL,
&type_xo,
DONT_CARE);
opt = (int*)NclGetArgValue(
4,
5,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Compute the total number of elements in our arrays and check them.
*/
nxi = dsizes_xi[ndims_xi-1];
nxo = dsizes_xo[0];
nfo = nxo;
nxi2 = nxi + 2;
if(nxi < 2) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1: xi must have at least 2 elements");
return(NhlFATAL);
}
/*
* Test dimension sizes.
*/
if((nxi > INT_MAX) || (nxo > INT_MAX) || (nxi2 > INT_MAX)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1: one or more dimension sizes is greater than INT_MAX");
return(NhlFATAL);
}
inxi = (int) nxi;
inxo = (int) nxo;
inxi2 = (int) nxi2;
/*
* Check dimensions of xi and fi. If xi is not one-dimensional, then it
* must be the same size as fi. Otherwise, the rightmost dimension of
* fi must be equal to the length of xi.
*/
if(ndims_xi > 1) {
if(ndims_xi != ndims_fi) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1: If xi is not one-dimensional, then it must be the same size as fi");
return(NhlFATAL);
}
for(i = 0; i < ndims_fi; i++) {
if(dsizes_xi[i] != dsizes_fi[i]) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1: If xi is not one-dimensional, then it must be the same size as fi");
return(NhlFATAL);
}
}
}
else {
if(dsizes_fi[ndims_fi-1] != nxi) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1: The rightmost dimension of fi must be the same length as xi");
return(NhlFATAL);
}
}
/*
* Compute the total size of the output array (minus the last dimension).
*/
size_leftmost = 1;
for( i = 0; i < ndims_fi-1; i++ ) size_leftmost *= dsizes_fi[i];
size_fo = size_leftmost * nfo;
/*
* Coerce missing values.
*/
coerce_missing(type_fi,has_missing_fi,&missing_fi,&missing_dfi,
&missing_rfi);
/*
* Allocate space for temporary output array.
*/
tmp_fo = (double*)calloc(nfo,sizeof(double));
if(tmp_fo == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1: Unable to allocate memory for temporary arrays");
return(NhlFATAL);
}
/*
* Allocate space for output array.
*/
dsizes_fo = (ng_size_t*)calloc(ndims_fi,sizeof(ng_size_t));
if(type_fi == NCL_double) {
fo = (void*)calloc(size_fo,sizeof(double));
type_fo = NCL_double;
missing_fo = missing_dfi;
}
else {
fo = (void*)calloc(size_fo,sizeof(float));
type_fo = NCL_float;
missing_fo = missing_rfi;
}
if(fo == NULL || dsizes_fo == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1: Unable to allocate memory for output array");
return(NhlFATAL);
}
for(i = 0; i < ndims_fi-1; i++) dsizes_fo[i] = dsizes_fi[i];
dsizes_fo[ndims_fi-1] = nxo;
/*
* Allocate space for work arrays.
*/
xiw = (double*)calloc(nxi2,sizeof(double));
fxiw = (double*)calloc(nxi2,sizeof(double));
if(xiw == NULL || fxiw == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1: Unable to allocate memory for work arrays");
return(NhlFATAL);
}
/*
* Coerce output array to double if necessary.
*/
tmp_xo = coerce_input_double(xo,type_xo,nxo,0,NULL,NULL);
if(tmp_xo == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1: Unable to coerce output array to double precision");
return(NhlFATAL);
}
if(type_xi != NCL_double) {
tmp_xi = (double*)calloc(nxi,sizeof(double));
if(tmp_xi == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1: Unable to allocate memory for coercing input array to double precision");
return(NhlFATAL);
}
}
if(type_fi != NCL_double) {
tmp_fi = (double*)calloc(nxi,sizeof(double));
if(tmp_fi == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1: Unable to allocate memory for coercing input array to double precision");
return(NhlFATAL);
}
}
/*
* Call Fortran function.
*/
index_xi = index_fi = index_fo = 0;
for( i = 0; i < size_leftmost; i++ ) {
if(ndims_xi > 1 || i == 0) {
if(type_xi != NCL_double) {
coerce_subset_input_double(xi,tmp_xi,index_xi,type_xi,nxi,0,NULL,NULL);
}
else {
tmp_xi = &((double*)xi)[index_xi];
}
}
if(type_fi != NCL_double) {
coerce_subset_input_double(fi,tmp_fi,index_fi,type_fi,nxi,0,NULL,NULL);
}
else {
tmp_fi = &((double*)fi)[index_fi];
}
NGCALLF(dlinint1,DLININT1)(&inxi,tmp_xi,tmp_fi,wrap,&inxo,tmp_xo,tmp_fo,
xiw,fxiw,&inxi2,&missing_dfi.doubleval,
&iopt,&ier);
if(ier) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"linint1: xi and xo must be monotonically increasing");
for(j = 0; j < nfo; j++) {
if(type_fi == NCL_double) {
((double*)fo)[index_fo+j] = missing_dfi.doubleval;
}
else {
((float*)fo)[index_fo+j] = missing_rfi.floatval;
}
}
}
else {
coerce_output_float_or_double(fo,tmp_fo,type_fi,nfo,index_fo);
}
if(ndims_xi > 1) index_xi += nxi;
index_fi += nxi;
index_fo += nfo;
}
/*
* Free temp arrays.
*/
if(type_xi != NCL_double) NclFree(tmp_xi);
if(type_xo != NCL_double) NclFree(tmp_xo);
if(type_fi != NCL_double) NclFree(tmp_fi);
NclFree(tmp_fo);
NclFree(xiw);
NclFree(fxiw);
ret = NclReturnValue(fo,ndims_fi,dsizes_fo,&missing_fo,type_fo,0);
NclFree(dsizes_fo);
return(ret);
}
NhlErrorTypes linint2_points_W( void )
{
/*
* Input variables
*/
void *xi, *yi, *fi, *xo, *yo;
double *tmp_xi = NULL;
double *tmp_yi = NULL;
double *tmp_fi = NULL;
double *tmp_xo, *tmp_yo, *tmp_fo;
int ndims_xi;
ng_size_t dsizes_xi[NCL_MAX_DIMENSIONS];
int ndims_yi;
ng_size_t dsizes_yi[NCL_MAX_DIMENSIONS];
ng_size_t dsizes_xo[NCL_MAX_DIMENSIONS], dsizes_yo[NCL_MAX_DIMENSIONS];
int ndims_fi;
ng_size_t dsizes_fi[NCL_MAX_DIMENSIONS];
int has_missing_fi;
ng_size_t *dsizes_fo;
NclScalar missing_fi, missing_dfi, missing_rfi;
int *opt;
logical *wrap;
NclBasicDataTypes type_xi, type_yi, type_fi, type_xo, type_yo;
/*
* Output variables.
*/
void *fo;
/*
* Other variables
*/
double *xiw, *fxiw;
ng_size_t nxi, nxi2, nyi, nfi, nxyo, size_leftmost, size_fo;
ng_size_t i, j, index_xi, index_yi, index_fi, index_fo;
int inxi, inxi2, inyi, inxyo, ier, ret;
/*
* Retrieve parameters
*
* Note that any of the pointer parameters can be set to NULL,
* which implies you don't care about its value.
*/
xi = (void*)NclGetArgValue(
0,
7,
&ndims_xi,
dsizes_xi,
NULL,
NULL,
&type_xi,
DONT_CARE);
yi = (void*)NclGetArgValue(
1,
7,
&ndims_yi,
dsizes_yi,
NULL,
NULL,
&type_yi,
DONT_CARE);
fi = (void*)NclGetArgValue(
2,
7,
&ndims_fi,
dsizes_fi,
&missing_fi,
&has_missing_fi,
&type_fi,
DONT_CARE);
wrap = (logical*)NclGetArgValue(
3,
7,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
xo = (void*)NclGetArgValue(
4,
7,
NULL,
dsizes_xo,
NULL,
NULL,
&type_xo,
DONT_CARE);
yo = (void*)NclGetArgValue(
5,
7,
NULL,
dsizes_yo,
NULL,
NULL,
&type_yo,
DONT_CARE);
opt = (int*)NclGetArgValue(
6,
7,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Compute the total number of elements in our arrays.
*/
nxi = dsizes_xi[ndims_xi-1];
nyi = dsizes_yi[ndims_yi-1];
nxyo = dsizes_xo[0];
nxi2 = nxi+2;
if(dsizes_yo[0] != nxyo) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint2_points: xo and yo must be the same length");
return(NhlFATAL);
}
if(nxi < 2 || nyi < 2) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint2_points: xi and yi must both have at least two elements");
return(NhlFATAL);
}
nfi = nxi * nyi;
/*
* Test dimension sizes.
*/
if((nxi > INT_MAX) || (nyi > INT_MAX) || (nxyo > INT_MAX) ||
(nxi2 > INT_MAX)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint2_points: one or more dimension sizes is greater than INT_MAX");
return(NhlFATAL);
}
inxi = (int) nxi;
inyi = (int) nyi;
inxyo = (int) nxyo;
inxi2 = (int) nxi2;
/*
* Check dimensions of xi, yi, and fi. If xi/yi are not one-dimensional,
* then their leftmost dimensions must be the same size as the leftmost
* dimensions of fi. The last two dimensions of fi must be nyi x nxi.
*/
if(ndims_xi > 1) {
if(ndims_xi != ndims_fi-1) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint2_points: If xi is not one-dimensional, then it must have one less dimension than fi");
return(NhlFATAL);
}
for(i = 0; i < ndims_xi-1; i++) {
if(dsizes_xi[i] != dsizes_fi[i]) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint2_points: If xi is not one-dimensional, then its leftmost dimensions must be the same as the leftmost dimensions of fi");
return(NhlFATAL);
}
}
}
if(ndims_yi > 1) {
if(ndims_yi != ndims_fi-1) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint2_points: If yi is not one-dimensional, then it must have one less dimension than fi");
return(NhlFATAL);
}
for(i = 0; i < ndims_yi-1; i++) {
if(dsizes_yi[i] != dsizes_fi[i]) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint2_points: If yi is not one-dimensional, then its leftmost dimensions must be the same as the leftmost dimensions of fi");
return(NhlFATAL);
}
}
}
if(dsizes_fi[ndims_fi-2] != nyi || dsizes_fi[ndims_fi-1] != nxi) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint2_points: The rightmost dimensions of fi must be nyi x nxi, where nyi and nxi are the lengths of yi and xi respectively");
return(NhlFATAL);
}
/*
* Compute the total size of the output array (minus the last two dimensions).
*/
size_leftmost = 1;
for( i = 0; i < ndims_fi-2; i++ ) size_leftmost *= dsizes_fi[i];
size_fo = size_leftmost * nxyo;
/*
* Coerce missing values.
*/
coerce_missing(type_fi,has_missing_fi,&missing_fi,&missing_dfi,
&missing_rfi);
/*
* Allocate space for temporary output array.
*/
tmp_fo = (double*)calloc(nxyo,sizeof(double));
if(tmp_fo == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint2_points: Unable to allocate memory for temporary arrays");
return(NhlFATAL);
}
/*
* Allocate space for output array.
*/
dsizes_fo = (ng_size_t*)calloc(ndims_fi-1,sizeof(ng_size_t));
if(type_fi == NCL_double) {
fo = (void*)calloc(size_fo,sizeof(double));
}
else {
fo = (void*)calloc(size_fo,sizeof(float));
}
if(fo == NULL || dsizes_fo == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint2_points: Unable to allocate memory for output array");
return(NhlFATAL);
}
for(i = 0; i < ndims_fi-2; i++) dsizes_fo[i] = dsizes_fi[i];
dsizes_fo[ndims_fi-2] = nxyo;
/*
* Allocate space for work arrays.
*/
xiw = (double*)calloc(nxi2,sizeof(double));
fxiw = (double*)calloc(nyi*nxi2,sizeof(double));
if(xiw == NULL || fxiw == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint2_points: Unable to allocate memory for work arrays");
return(NhlFATAL);
}
/*
* Coerce input arrays to double if necessary.
*/
if(type_xi != NCL_double) {
tmp_xi = (double*)calloc(nxi,sizeof(double));
if(tmp_xi == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint2_points: Unable to allocate memory for coercing xi to double precision");
return(NhlFATAL);
}
}
if(type_yi != NCL_double) {
tmp_yi = (double*)calloc(nyi,sizeof(double));
if(tmp_yi == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint2_points: Unable to allocate memory for coercing yi to double precision");
return(NhlFATAL);
}
}
tmp_xo = coerce_input_double(xo,type_xo,nxyo,0,NULL,NULL);
tmp_yo = coerce_input_double(yo,type_yo,nxyo,0,NULL,NULL);
if(tmp_xo == NULL || tmp_yo == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint2_points: Unable to coerce input to double precision");
return(NhlFATAL);
}
if(type_fi != NCL_double) {
tmp_fi = (double*)calloc(nfi,sizeof(double));
if(tmp_fi == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint2_points: Unable to allocate memory for coercing input array to double precision");
return(NhlFATAL);
}
}
/*
* Call Fortran function.
*/
index_xi = index_yi = index_fi = index_fo = 0;
for( i = 0; i < size_leftmost; i++ ) {
if(ndims_xi > 1 || i == 0) {
if(type_xi != NCL_double) {
coerce_subset_input_double(xi,tmp_xi,index_xi,type_xi,nxi,0,NULL,NULL);
}
else {
tmp_xi = &((double*)xi)[index_xi];
}
}
if(ndims_yi > 1 || i == 0) {
if(type_yi != NCL_double) {
coerce_subset_input_double(yi,tmp_yi,index_yi,type_yi,nyi,0,NULL,NULL);
}
else {
tmp_yi = &((double*)yi)[index_yi];
}
}
if(type_fi != NCL_double) {
coerce_subset_input_double(fi,tmp_fi,index_fi,type_fi,nfi,0,NULL,NULL);
}
else {
tmp_fi = &((double*)fi)[index_fi];
}
NGCALLF(dlinint2pts,DLININT2PTS)(&inxi,tmp_xi,&inyi,tmp_yi,tmp_fi,wrap,
&inxyo,tmp_xo,tmp_yo,tmp_fo,xiw,fxiw,
&inxi2,&missing_dfi.doubleval,&ier);
if(ier) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"linint2_points: xi and yi must be monotonically increasing");
for(j = 0; j < nxyo; j++) {
if(type_fi == NCL_double) {
((double*)fo)[index_fo+j] = missing_dfi.doubleval;
}
else {
((float*)fo)[index_fo+j] = missing_rfi.floatval;
}
}
}
else {
coerce_output_float_or_double(fo,tmp_fo,type_fi,nxyo,index_fo);
}
if(ndims_xi > 1) index_xi += nxi;
if(ndims_yi > 1) index_yi += nyi;
index_fi += nfi;
index_fo += nxyo;
}
/*
* Free temp arrays.
*/
if(type_xi != NCL_double) NclFree(tmp_xi);
if(type_yi != NCL_double) NclFree(tmp_yi);
if(type_xo != NCL_double) NclFree(tmp_xo);
if(type_yo != NCL_double) NclFree(tmp_yo);
if(type_fi != NCL_double) NclFree(tmp_fi);
NclFree(tmp_fo);
NclFree(xiw);
NclFree(fxiw);
if(type_fi == NCL_double) {
/*
* Return double values with missing value set.
*/
ret = NclReturnValue(fo,ndims_fi-1,dsizes_fo,&missing_dfi,NCL_double,0);
}
else {
/*
* Return float values with missing value set.
*/
ret = NclReturnValue(fo,ndims_fi-1,dsizes_fo,&missing_rfi,NCL_float,0);
}
NclFree(dsizes_fo);
return(ret);
}
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));
}
}
NhlErrorTypes area_hi2lores_W( void )
{
/*
* Input variables
*/
void *xi, *yi, *fi, *wyi, *xo, *yo;
double *tmp_xi, *tmp_yi, *tmp_fi, *tmp_xo, *tmp_yo, *tmp_fo;
double *tmp1_wyi, *tmp_wyi;
ng_size_t dsizes_xi[1], dsizes_yi[1], dsizes_wyi[1], dsizes_xo[1], dsizes_yo[1];
int ndims_fi;
ng_size_t dsizes_fi[NCL_MAX_DIMENSIONS];
int has_missing_fi;
NclScalar missing_fi, missing_dfi, missing_rfi;
logical *fi_cyclic_x, *fo_option;
NclBasicDataTypes type_xi, type_yi, type_fi, type_wyi, type_xo, type_yo;
/*
* Variables to look for attributes attached to fo_option.
*/
NclStackEntry stack_entry;
NclAttList *attr_list;
NclAtt attr_obj;
/*
* Output variables.
*/
void *fo;
ng_size_t *dsizes_fo;
NclBasicDataTypes type_fo;
NclScalar missing_fo;
/*
* Other variables
*/
int ret, ncyc = 0, ier = 0, debug = 0;
ng_size_t i, mxi, nyi, nfi, mxo, nyo, nfo, ngrd, size_fi, size_fo;
int imxi, inyi, imxo, inyo, ingrd;
double *critpc = NULL, *xilft, *xirgt, *yibot, *yitop, *xolft, *xorgt;
double *wxi, *dxi, *dyi, *fracx, *fracy;
double *ziwrk, *zowrk, *yiwrk, *yowrk;
int *indx, *indy;
NclBasicDataTypes type_critpc;
/*
* Retrieve parameters
*
* Note that any of the pointer parameters can be set to NULL,
* which implies you don't care about its value.
*/
xi = (void*)NclGetArgValue(
0,
8,
NULL,
dsizes_xi,
NULL,
NULL,
&type_xi,
DONT_CARE);
yi = (void*)NclGetArgValue(
1,
8,
NULL,
dsizes_yi,
NULL,
NULL,
&type_yi,
DONT_CARE);
fi = (void*)NclGetArgValue(
2,
8,
&ndims_fi,
dsizes_fi,
&missing_fi,
&has_missing_fi,
&type_fi,
DONT_CARE);
fi_cyclic_x = (logical*)NclGetArgValue(
3,
8,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
wyi = (void*)NclGetArgValue(
4,
8,
NULL,
dsizes_wyi,
NULL,
NULL,
&type_wyi,
DONT_CARE);
xo = (void*)NclGetArgValue(
5,
8,
NULL,
dsizes_xo,
NULL,
NULL,
&type_xo,
DONT_CARE);
yo = (void*)NclGetArgValue(
6,
8,
NULL,
dsizes_yo,
NULL,
NULL,
&type_yo,
DONT_CARE);
fo_option = (logical*)NclGetArgValue(
7,
8,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Check for "critpc" attribute.
*/
if(*fo_option) {
stack_entry = _NclGetArg(7,8,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 attributes.
*/
break;
}
/*
* Check attributes for "critpc". If none, then just proceed as normal.
*/
if (attr_obj->att.n_atts == 0) {
break;
}
else {
/*
* att_n_atts > 0, retrieve optional arguments
*/
attr_list = attr_obj->att.att_list;
while (attr_list != NULL) {
if ((strcmp(attr_list->attname, "critpc")) == 0) {
type_critpc = attr_list->attvalue->multidval.data_type;
/*
* If "critpc" is already double, don't just point it to the attribute,
* because we need to return it later.
*/
if(type_critpc == NCL_double) {
critpc = (double *)calloc(1,sizeof(double));
*critpc = *(double*) attr_list->attvalue->multidval.val;
}
else if(type_critpc == NCL_int || type_critpc == NCL_float) {
/*
* Coerce to double.
*/
critpc = coerce_input_double(attr_list->attvalue->multidval.val,
type_critpc,1,0,NULL,NULL);
}
else {
NhlPError(NhlWARNING,NhlEUNKNOWN,"area_hi2lores: The 'critpc' attribute must be of type numeric. Defaulting to 100.");
}
}
attr_list = attr_list->next;
}
}
default:
break;
}
}
if(critpc == NULL) {
critpc = (double *)calloc(1,sizeof(double));
*critpc = 100.;
}
/*
* Compute the total number of elements in our arrays.
*/
mxi = dsizes_xi[0];
nyi = dsizes_yi[0];
mxo = dsizes_xo[0];
nyo = dsizes_yo[0];
nfi = mxi * nyi;
nfo = mxo * nyo;
if(mxi < 2 || nyi < 2) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_hi2lores: xi and yi must have at least two elements");
return(NhlFATAL);
}
if(dsizes_wyi[0] != nyi && dsizes_wyi[0] != 1) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_hi2lores: wyi must be a scalar or the same length as yi");
return(NhlFATAL);
}
/*
* Check dimensions of xi, yi, and fi. The last two dimensions of
* fi must be nyi x mxi.
*/
if(dsizes_fi[ndims_fi-2] != nyi && dsizes_fi[ndims_fi-1] != mxi) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_hi2lores: The rightmost dimensions of fi must be nyi x mxi, where nyi and mxi are the lengths of yi and xi respectively");
return(NhlFATAL);
}
/*
* Compute the size of the leftmost dimensions and output array.
*/
ngrd = 1;
for( i = 0; i < ndims_fi-2; i++ ) ngrd *= dsizes_fi[i];
size_fi = ngrd * nfi;
size_fo = ngrd * nfo;
/*
* Test dimension sizes.
*/
if((mxi > INT_MAX) || (nyi > INT_MAX) || (mxo > INT_MAX) ||
(nyo > INT_MAX) || (ngrd > INT_MAX)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_hi2lores: one or more dimension sizes is greater than INT_MAX");
return(NhlFATAL);
}
imxi = (int) mxi;
inyi = (int) nyi;
imxo = (int) mxo;
inyo = (int) nyo;
ingrd = (int) ngrd;
/*
* Coerce missing values for fi.
*/
coerce_missing(type_fi,has_missing_fi,&missing_fi,&missing_dfi,
&missing_rfi);
/*
* Allocate space for output array.
*/
if(type_fi == NCL_double) {
type_fo = NCL_double;
missing_fo = missing_dfi;
fo = (void*)calloc(size_fo,sizeof(double));
if(fo == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_hi2lores: Unable to allocate memory for output array");
return(NhlFATAL);
}
tmp_fo = fo;
}
else {
type_fo = NCL_float;
missing_fo = missing_rfi;
fo = (void*)calloc(size_fo,sizeof(float));
tmp_fo = (double*)calloc(size_fo,sizeof(double));
if(fo == NULL || tmp_fo == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_hi2lores: Unable to allocate memory for output array");
return(NhlFATAL);
}
}
dsizes_fo = (ng_size_t*)calloc(ndims_fi,sizeof(ng_size_t));
if(dsizes_fo == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_hi2lores: Unable to allocate memory for output array");
return(NhlFATAL);
}
for(i = 0; i < ndims_fi-2; i++) dsizes_fo[i] = dsizes_fi[i];
dsizes_fo[ndims_fi-2] = nyo;
dsizes_fo[ndims_fi-1] = mxo;
/*
* Coerce input arrays to double.
*/
tmp_xi = coerce_input_double(xi,type_xi,mxi,0,NULL,NULL);
tmp_yi = coerce_input_double(yi,type_yi,nyi,0,NULL,NULL);
tmp_fi = coerce_input_double(fi,type_fi,size_fi,0,NULL,NULL);
tmp_xo = coerce_input_double(xo,type_xo,mxo,0,NULL,NULL);
tmp_yo = coerce_input_double(yo,type_yo,nyo,0,NULL,NULL);
/*
* wyi can be a scalar, so copy it to array if necessary.
*/
tmp1_wyi = coerce_input_double(wyi,type_wyi,dsizes_wyi[0],0,NULL,NULL);
if(dsizes_wyi[0] == 1) {
tmp_wyi = copy_scalar_to_array(tmp1_wyi,1,dsizes_wyi,nyi);
}
else {
tmp_wyi = tmp1_wyi;
}
/*
* Allocate space for work arrays. There's a ton of them here.
*/
xilft = (double*)calloc(mxi,sizeof(double));
xirgt = (double*)calloc(mxi,sizeof(double));
yibot = (double*)calloc(nyi,sizeof(double));
yitop = (double*)calloc(nyi,sizeof(double));
xolft = (double*)calloc(mxo,sizeof(double));
xorgt = (double*)calloc(mxo,sizeof(double));
dxi = (double*)calloc(mxi,sizeof(double));
dyi = (double*)calloc(nyi,sizeof(double));
fracx = (double*)calloc(mxi*mxo,sizeof(double));
fracy = (double*)calloc(nyi*nyo,sizeof(double));
ziwrk = (double*)calloc(mxi*nyi,sizeof(double));
zowrk = (double*)calloc(mxo*nyo,sizeof(double));
yiwrk = (double*)calloc(nyi,sizeof(double));
yowrk = (double*)calloc(nyo,sizeof(double));
indx = (int*)calloc(2*mxo,sizeof(int));
indy = (int*)calloc(2*nyo,sizeof(int));
wxi = (double*)calloc(mxi,sizeof(double));
if(xilft == NULL || xirgt == NULL || yibot == NULL || yitop == NULL ||
xolft == NULL || xorgt == NULL || dxi == NULL || dyi == NULL ||
fracx == NULL || fracy == NULL || ziwrk == NULL || zowrk == NULL ||
yiwrk == NULL || yowrk == NULL || indx == NULL || indy == NULL ||
wxi == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_hi2lores: Unable to allocate memory for work arrays");
return(NhlFATAL);
}
for(i = 0; i < mxi; i++) wxi[i] = 1.;
/*
* Call Fortran function.
*/
NGCALLF(arealinint2da,AREALININT2DA)(&imxi,&inyi,&ingrd,tmp_xi,tmp_yi,tmp_fi,
wxi,tmp_wyi,&missing_dfi.doubleval,
fi_cyclic_x,&ncyc,&imxo,&inyo,tmp_xo,
tmp_yo,tmp_fo,critpc,&debug,&ier,
xilft,xirgt,yibot,yitop,dyi,xolft,
xorgt,yiwrk,yowrk,fracx,fracy,
ziwrk,zowrk,indx,indy);
if(ier) {
if(ier == -2) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"area_hi2lores: xi, xo must be monotonically increasing");
}
else if(ier == -5) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"area_hi2lores: both dimensions of the output grid must be of lower resolution than the input high resolution grid.");
}
else {
/*
* Note: we should never reach this point! We should always know the
* possible return values for 'ier'.
*/
NhlPError(NhlWARNING,NhlEUNKNOWN,"area_hi2lores: unknown error, returning all missing values.");
}
}
else {
coerce_output_float_or_double(fo,tmp_fo,type_fo,size_fo,0);
}
/*
* Free temp arrays.
*/
if(type_xi != NCL_double) NclFree(tmp_xi);
if(type_yi != NCL_double) NclFree(tmp_yi);
if(type_fi != NCL_double) NclFree(tmp_fi);
if(type_xo != NCL_double) NclFree(tmp_xo);
if(type_yo != NCL_double) NclFree(tmp_yo);
if(type_fo != NCL_double) NclFree(tmp_fo);
if(type_wyi != NCL_double) NclFree(tmp1_wyi);
if(dsizes_wyi[0] == 1) {
NclFree(tmp_wyi);
}
NclFree(wxi);
NclFree(xilft);
NclFree(xirgt);
NclFree(yibot);
NclFree(yitop);
NclFree(xolft);
NclFree(xorgt);
NclFree(dxi);
NclFree(dyi);
NclFree(fracx);
NclFree(fracy);
NclFree(ziwrk);
NclFree(zowrk);
NclFree(yiwrk);
NclFree(yowrk);
NclFree(indx);
NclFree(indy);
NclFree(critpc);
ret = NclReturnValue(fo,ndims_fi,dsizes_fo,&missing_fo,type_fo,0);
NclFree(dsizes_fo);
return(ret);
}
NhlErrorTypes dim_gamfit_n_W( void )
{
/*
* Input variables
*/
/*
* Argument # 0
*/
void *x;
double *tmp_x;
int ndims_x;
ng_size_t dsizes_x[NCL_MAX_DIMENSIONS];
int has_missing_x;
NclScalar missing_x, missing_flt_x, missing_dbl_x;
NclBasicDataTypes type_x;
/*
* Argument # 1
*/
logical *optgam;
/*
* Argument # 2
*/
int *dims;
ng_size_t dsizes_dims;
/*
* Return variable
*/
void *xpar;
int ndims_xpar;
ng_size_t *dsizes_xpar;
NclScalar missing_xpar;
NclBasicDataTypes type_xpar;
/*
* Variables for retrieving attributes from "optgam";
*/
NclAttList *attr_list;
NclAtt attr_obj;
NclStackEntry stack_entry;
/*
* Various
*/
ng_size_t npts;
int inpts;
ng_size_t index_x, index_xpar, index_nrx, index_nr;
double *pcrit = NULL;
logical set_pcrit;
double alpha, scale, shape, pzero;
int inv_scale, ier, ret;
ng_size_t i, j, nrnx, total_nr, total_nl, total_nlnr, size_output;
/*
* 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
*/
x = (void*)NclGetArgValue(
0,
3,
&ndims_x,
dsizes_x,
&missing_x,
&has_missing_x,
&type_x,
DONT_CARE);
/*
* Get argument # 1
*/
optgam = (logical*)NclGetArgValue(
1,
3,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Get dimension(s) to do computation on.
*/
dims = (int*)NclGetArgValue(
2,
3,
NULL,
&dsizes_dims,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Some error checking. Make sure input dimensions are valid.
*/
for(i = 0; i < dsizes_dims; i++ ) {
if(dims[i] < 0 || dims[i] >= ndims_x) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_gamfit_n: Invalid dimension sizes to do calculations across, can't continue");
return(NhlFATAL);
}
if(i > 0 && dims[i] != (dims[i-1]+1)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_gamfit_n: Input dimension sizes must be monotonically increasing, can't continue");
return(NhlFATAL);
}
}
/*
* Calculate size of leftmost dimensions (nl) up to the dims[0]-th
* dimensions.
*
* Calculate number of points that will be passed to Fortran
* routine (npts).
*
* Calculate size of rightmost dimensions (nr) from the
* ndims[ndims-1]-th dimension.
*
* The dimension(s) to do the calculations across are "dims".
*/
total_nl = total_nr = npts = 1;
if(ndims_x > 1) {
ndims_xpar = ndims_x-dsizes_dims+1;
dsizes_xpar = NclMalloc(ndims_xpar * sizeof(ng_size_t));
dsizes_xpar[0] = 3;
for(i = 0; i < dims[0] ; i++) {
total_nl = total_nl*dsizes_x[i];
dsizes_xpar[i+1] = dsizes_x[i];
}
for(i = 0; i < dsizes_dims ; i++) {
npts = npts*dsizes_x[dims[i]];
}
for(i = dims[dsizes_dims-1]+1; i < ndims_x; i++) {
total_nr = total_nr*dsizes_x[i];
dsizes_xpar[i-dsizes_dims+1] = dsizes_x[i];
}
} else {
dsizes_xpar = NclMalloc(sizeof(ng_size_t));
*dsizes_xpar = 3;
ndims_xpar = 1;
npts = dsizes_x[dims[0]];
}
total_nlnr = total_nl * total_nr;
size_output = 3 * total_nlnr;
if( npts > INT_MAX) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_gamfit_n: npts is greater than INT_MAX");
return(NhlFATAL);
}
inpts = (int) npts;
/*
* Allocate space for tmp_x.
*/
tmp_x = (double *)calloc(npts,sizeof(double));
if(tmp_x == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_gamfit_n: Unable to allocate memory for coercing input array to double");
return(NhlFATAL);
}
/*
* Coerce missing value to double if necessary.
*/
coerce_missing(type_x,has_missing_x,&missing_x,
&missing_dbl_x,&missing_flt_x);
/*
* Allocate space for output array.
*/
if(type_x != NCL_double) {
type_xpar = NCL_float;
xpar = (void *)calloc(size_output, sizeof(float));
}
else {
type_xpar = NCL_double;
xpar = (void *)calloc(size_output, sizeof(double));
}
if(xpar == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_gamfit_n: Unable to allocate memory for output array");
return(NhlFATAL);
}
if(has_missing_x) {
if(type_xpar == NCL_double) missing_xpar = missing_dbl_x;
else missing_xpar = missing_flt_x;
}
/*
* Retrieve attributes from optgam, if any.
*/
set_pcrit = False;
inv_scale = 0;
if(*optgam) {
stack_entry = _NclGetArg(1, 3, 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 attributes specified.
*/
break;
}
/*
* Check for attributes. If none are set, then use default values.
*/
if (attr_obj->att.n_atts == 0) {
break;
}
else {
/*
* Get list of attributes.
*/
attr_list = attr_obj->att.att_list;
/*
* Loop through attributes and check them.
*/
while (attr_list != NULL) {
/*
* pcrit
*/
if ((strcmp(attr_list->attname, "pcrit")) == 0) {
pcrit = coerce_input_double(attr_list->attvalue->multidval.val,
attr_list->attvalue->multidval.data_type,
1,0,NULL,NULL);
set_pcrit = True;
}
/*
* inv_scale
*/
if ((strcmp(attr_list->attname, "inv_scale")) == 0) {
if(attr_list->attvalue->multidval.data_type != NCL_logical) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"dim_gamfit_n: the 'inv_scale' attribute must be a logical, defaulting to False.");
}
else if(*(logical*)attr_list->attvalue->multidval.val) {
inv_scale = 1;
}
}
attr_list = attr_list->next;
}
}
default:
break;
}
}
if(!set_pcrit) {
pcrit = (double *)calloc(1,sizeof(double));
*pcrit = 0.0;
}
/*
* Loop across leftmost dimensions and call the Fortran routine for each
* subsection of the input arrays.
*/
nrnx = total_nr * npts;
for(i = 0; i < total_nl; i++) {
index_nrx = i*nrnx;
index_nr = i*total_nr;
for(j = 0; j < total_nr; j++) {
index_x = index_nrx + j;
index_xpar = index_nr + j;
/*
* Coerce subsection of x (tmp_x) to double.
*/
coerce_subset_input_double_step(x,tmp_x,index_x,total_nr,type_x,
npts,0,NULL,NULL);
/*
* Call the Fortran routine.
*/
NGCALLF(gamfitd3,GAMFITD3)(tmp_x, &inpts, &missing_dbl_x.doubleval,
pcrit, &inv_scale, &alpha, &scale,
&shape, &pzero, &ier);
/*
* Coerce output back to float or double
*/
coerce_output_float_or_double(xpar,&shape,type_xpar,1,index_xpar);
coerce_output_float_or_double(xpar,&scale,type_xpar,1,
index_xpar+total_nlnr);
coerce_output_float_or_double(xpar,&pzero,type_xpar,1,
index_xpar+(2*total_nlnr));
}
}
/*
* Free unneeded memory.
*/
NclFree(tmp_x);
/*
* Return value back to NCL script.
*/
if(has_missing_x) {
ret = NclReturnValue(xpar,ndims_xpar,dsizes_xpar,&missing_xpar,
type_xpar,0);
}
else {
ret = NclReturnValue(xpar,ndims_xpar,dsizes_xpar,NULL,type_xpar,0);
}
NclFree(dsizes_xpar);
return(ret);
}
NhlErrorTypes ezfftf_W( void )
{
/*
* Input array variables
*/
void *x;
int ndims_x;
ng_size_t dsizes_x[NCL_MAX_DIMENSIONS];
NclBasicDataTypes type_x;
NclScalar missing_x, missing_dx, missing_rx, missing_cf;
int has_missing_x;
double *tmp_x = NULL;
/*
* Output array variables
*/
void *cf, *xbar;
int ndims_cf;
ng_size_t dsizes_cf[NCL_MAX_DIMENSIONS];
double *tmp_cf1, *tmp_cf2, *tmp_xbar;
NclBasicDataTypes type_cf;
NclTypeClass type_cf_class;
/*
* Attribute variables
*/
void *N;
int att_id;
ng_size_t dsizes[1];
NclMultiDValData att_md, return_md;
NclVar tmp_var;
NclStackEntry return_data;
/*
* various
*/
double *work;
ng_size_t index_x, index_cf1, index_cf2;
ng_size_t i, npts, npts2, lnpts2, npts22;
int found_missing, any_missing;
ng_size_t size_leftmost, size_cf;
int inpts;
/*
* Retrieve parameters
*
* Note any of the pointer parameters can be set to NULL, which
* implies you don't care about its value.
*/
x = (void*)NclGetArgValue(
0,
1,
&ndims_x,
dsizes_x,
&missing_x,
&has_missing_x,
&type_x,
DONT_CARE);
/*
* Calculate number of leftmost elements.
*/
size_leftmost = 1;
for( i = 0; i < ndims_x-1; i++ ) size_leftmost *= dsizes_x[i];
/*
* Test input array size
*/
npts = dsizes_x[ndims_x-1];
if(npts > INT_MAX) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ezfftf: npts = %d is greater than INT_MAX", npts);
return(NhlFATAL);
}
inpts = (int) npts;
/*
* Calculate size of output array.
*/
if((npts % 2) == 0) {
npts2 = npts/2;
}
else {
npts2 = (npts-1)/2;
}
lnpts2 = npts2 * size_leftmost;
npts22 = 2*npts2;
size_cf = size_leftmost * npts22;
ndims_cf = ndims_x + 1;
dsizes_cf[0] = 2;
for(i = 1; i < ndims_x; i++ ) dsizes_cf[i] = dsizes_x[i-1];
dsizes_cf[ndims_x] = npts2;
/*
* Coerce missing values.
*/
coerce_missing(type_x,has_missing_x,&missing_x,&missing_dx,&missing_rx);
/*
* Create space for temporary input array if necessary.
*/
if(type_x != NCL_double) {
tmp_x = (double*)calloc(npts,sizeof(double));
if(tmp_x == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ezfftf: Unable to allocate memory for coercing input array to double precision");
return(NhlFATAL);
}
}
/*
* Allocate space for output arrays.
*/
tmp_xbar = (double*)calloc(1,sizeof(double));
tmp_cf1 = (double*)calloc(npts2,sizeof(double));
tmp_cf2 = (double*)calloc(npts2,sizeof(double));
if ( tmp_cf1 == NULL || tmp_cf2 == NULL || tmp_xbar == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ezfftf: Cannot allocate memory for temporary output arrays" );
return(NhlFATAL);
}
if(type_x == NCL_double) {
cf = (void*)calloc(size_cf,sizeof(double));
xbar = (void*)calloc(size_leftmost,sizeof(double));
type_cf = NCL_double;
if(has_missing_x) missing_cf = missing_dx;
}
else {
cf = (void*)calloc(size_cf,sizeof(float));
xbar = (void*)calloc(size_leftmost,sizeof(float));
type_cf = NCL_float;
if(has_missing_x) missing_cf = missing_rx;
}
N = (void*)calloc(1,sizeof(int));
if ( cf == NULL || xbar == NULL || N == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ezfftf: Cannot allocate memory for output arrays" );
return(NhlFATAL);
}
/*
* Allocate memory for work array
*/
work = (double*)calloc((4*npts+15),sizeof(double));
if ( work == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ezfftf: Cannot allocate memory for work array" );
return(NhlFATAL);
}
/*
* Call the f77 version of 'dezfftf' with the full argument list.
*/
index_x = 0;
index_cf1 = 0;
index_cf2 = lnpts2;
any_missing = 0;
for(i = 0; i < size_leftmost; i++) {
if(type_x != NCL_double) {
coerce_subset_input_double(x,tmp_x,index_x,type_x,npts,0,NULL,NULL);
}
else {
tmp_x = &((double*)x)[index_x];
}
/*
* Check for missing values in x. If any, then coerce that section of
* the output to missing.
*/
found_missing = contains_missing(tmp_x,npts,has_missing_x,
missing_dx.doubleval);
if(found_missing) {
any_missing++;
set_subset_output_missing(xbar,i,type_cf,1,missing_dx.doubleval);
set_subset_output_missing(cf,index_cf1,type_cf,npts2,
missing_dx.doubleval);
set_subset_output_missing(cf,index_cf2,type_cf,npts2,
missing_dx.doubleval);
}
else {
NGCALLF(dezffti,DEZFFTI)(&inpts,work);
NGCALLF(dezfftf,DEZFFTF)(&inpts,tmp_x,tmp_xbar,tmp_cf1,tmp_cf2,work);
/*
* Copy results back into xbar and cf.
*/
coerce_output_float_or_double(xbar,tmp_xbar,type_cf,1,i);
coerce_output_float_or_double(cf,tmp_cf1,type_cf,npts2,index_cf1);
coerce_output_float_or_double(cf,tmp_cf2,type_cf,npts2,index_cf2);
}
index_x += npts;
index_cf1 += npts2;
index_cf2 += npts2;
}
/*
* Free up memory.
*/
if(type_x != NCL_double) free(tmp_x);
free(work);
free(tmp_cf1);
free(tmp_cf2);
free(tmp_xbar);
/*
* Set up variable to return.
*/
type_cf_class = (NclTypeClass)_NclNameToTypeClass(NrmStringToQuark(_NclBasicDataTypeToName(type_cf)));
/*
* Set up return values.
*/
if(any_missing) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"ezfftf: %d input arrays contained missing values. No calculations performed on these arrays.",any_missing);
return_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
cf,
&missing_cf,
ndims_cf,
dsizes_cf,
TEMPORARY,
NULL,
(NclObjClass)type_cf_class
);
}
else {
return_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
cf,
NULL,
ndims_cf,
dsizes_cf,
TEMPORARY,
NULL,
(NclObjClass)type_cf_class
);
}
/*
* Attributes "xbar" and "npts".
*/
att_id = _NclAttCreate(NULL,NULL,Ncl_Att,0,NULL);
dsizes[0] = size_leftmost;
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
xbar,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
(NclObjClass)type_cf_class
);
_NclAddAtt(
att_id,
"xbar",
att_md,
NULL
);
(*(int*)N) = npts;
dsizes[0] = 1;
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
N,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
(NclObjClass)nclTypeintClass
);
_NclAddAtt(
att_id,
"npts",
att_md,
NULL
);
/*
* Set up variable to hold return array and attributes.
*/
tmp_var = _NclVarCreate(
NULL,
NULL,
Ncl_Var,
0,
NULL,
return_md,
NULL,
att_id,
NULL,
RETURNVAR,
NULL,
TEMPORARY
);
/*
* Return output grid and attributes to NCL.
*/
return_data.kind = NclStk_VAR;
return_data.u.data_var = tmp_var;
_NclPlaceReturn(return_data);
return(NhlNOERROR);
}
NhlErrorTypes dim_avg_wgt_W( void )
{
/*
* Input variables
*/
/*
* Argument # 0
*/
void *x;
double *tmp_x = NULL;
int ndims_x;
ng_size_t dsizes_x[NCL_MAX_DIMENSIONS];
int has_missing_x;
NclScalar missing_x, missing_flt_x, missing_dbl_x;
NclBasicDataTypes type_x;
/*
* Argument # 1
*/
void *w;
double *tmp_w;
ng_size_t dsizes_w[1];
NclBasicDataTypes type_w;
/*
* Argument # 2
*/
int *opt;
/*
* Return variable
*/
void *xavg;
double tmp_xavg[1];
int ndims_xavg;
ng_size_t *dsizes_xavg;
NclBasicDataTypes type_xavg;
/*
* Various
*/
int inx, ret, ndims_leftmost;
ng_size_t nx, index_x;
ng_size_t i, size_output;
/*
* 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
*/
x = (void*)NclGetArgValue(
0,
3,
&ndims_x,
dsizes_x,
&missing_x,
&has_missing_x,
&type_x,
DONT_CARE);
/*
* Coerce missing value to double if necessary.
*/
coerce_missing(type_x,has_missing_x,&missing_x,
&missing_dbl_x,&missing_flt_x);
/*
* Test input dimension size.
*/
nx = dsizes_x[ndims_x-1];
if(nx > INT_MAX) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_avg_wgt: nx = %ld is greater than INT_MAX", nx);
return(NhlFATAL);
}
inx = (int) nx;
/*
* Get argument # 1
*/
w = (void*)NclGetArgValue(
1,
3,
NULL,
dsizes_w,
NULL,
NULL,
&type_w,
DONT_CARE);
if(dsizes_w[0] != nx) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_avg_wgt: w must be length nx");
return(NhlFATAL);
}
/*
* Get argument # 2
*/
opt = (int*)NclGetArgValue(
2,
3,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Calculate size of leftmost dimensions.
*/
size_output = 1;
ndims_leftmost = ndims_x-1;
for(i = 0; i < ndims_leftmost; i++) {
size_output *= dsizes_x[i];
}
/*
* The output type defaults to float, unless this input array is double.
*/
type_xavg = NCL_float;
/*
* Allocate space for coercing input arrays. If any of the input
* is already double, then we don't need to allocate space for
* temporary arrays, because we'll just change the pointer into
* the void array appropriately.
*/
/*
* Allocate space for tmp_x.
*/
if(type_x != NCL_double) {
tmp_x = (double *)calloc(nx,sizeof(double));
if(tmp_x == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_avg_wgt: Unable to allocate memory for coercing input array to double");
return(NhlFATAL);
}
}
else {
type_xavg = NCL_double;
}
/*
* Allocate space for tmp_w.
*/
tmp_w = coerce_input_double(w,type_w,nx,0,NULL,NULL);
if(tmp_w == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_avg_wgt: Unable to allocate memory for coercing input array to double");
return(NhlFATAL);
}
/*
* Allocate space for output array.
*/
if(type_xavg != NCL_double) {
xavg = (void *)calloc(size_output, sizeof(float));
}
else {
xavg = (void *)calloc(size_output, sizeof(double));
}
if(xavg == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_avg_wgt: Unable to allocate memory for output array");
return(NhlFATAL);
}
/*
* Allocate space for output dimension sizes and set them.
*/
ndims_xavg = max(ndims_leftmost,1);
dsizes_xavg = (ng_size_t*)calloc(ndims_xavg,sizeof(ng_size_t));
if( dsizes_xavg == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_avg_wgt: Unable to allocate memory for holding dimension sizes");
return(NhlFATAL);
}
if(ndims_leftmost > 0) {
for(i = 0; i < ndims_leftmost; i++) dsizes_xavg[i] = dsizes_x[i];
}
else {
dsizes_xavg[0] = 1;
}
/*
* Loop across leftmost dimensions and call the Fortran routine for each
* one-dimensional subsection.
*/
index_x = 0;
for(i = 0; i < size_output; i++) {
/*
* Coerce subsection of x (tmp_x) to double if necessary.
*/
if(type_x != NCL_double) {
coerce_subset_input_double(x,tmp_x,index_x,type_x,nx,0,NULL,NULL);
}
else {
tmp_x = &((double*)x)[index_x];
}
/*
* Call the Fortran routine.
*/
NGCALLF(dimavgwgt,DIMAVGWGT)(&inx, tmp_x, &missing_dbl_x.doubleval,
tmp_w, opt, &tmp_xavg[0]);
/*
* Coerce output back to float or double.
*/
coerce_output_float_or_double(xavg,&tmp_xavg[0],type_x,1,i);
index_x += nx;
}
/*
* Free unneeded memory.
*/
if(type_x != NCL_double) NclFree(tmp_x);
if(type_w != NCL_double) NclFree(tmp_w);
/*
* Return value back to NCL script.
*/
if(has_missing_x) {
if(type_xavg == NCL_double) {
ret = NclReturnValue(xavg,ndims_xavg,dsizes_xavg,&missing_dbl_x,
type_xavg,0);
}
else {
ret = NclReturnValue(xavg,ndims_xavg,dsizes_xavg,&missing_flt_x,
type_xavg,0);
}
}
else {
ret = NclReturnValue(xavg,ndims_xavg,dsizes_xavg,NULL,type_xavg,0);
}
NclFree(dsizes_xavg);
return(ret);
}
NhlErrorTypes dim_sum_wgt_n_W( void )
{
/*
* Input variables
*/
/*
* Argument # 0
*/
void *x;
double *tmp_x;
int ndims_x;
ng_size_t dsizes_x[NCL_MAX_DIMENSIONS];
int has_missing_x;
NclScalar missing_x, missing_flt_x, missing_dbl_x;
NclBasicDataTypes type_x;
/*
* Argument # 1
*/
void *w;
double *tmp_w;
ng_size_t dsizes_w[1];
NclBasicDataTypes type_w;
/*
* Argument # 2
*/
int *opt;
/*
* Argument # 3
*/
int *narg;
/*
* Return variable
*/
void *xavg;
double tmp_xavg[1];
int ndims_xavg;
ng_size_t *dsizes_xavg;
NclBasicDataTypes type_xavg;
/*
* Various
*/
int inx, ret;
ng_size_t nx, nrnx, index_x, index_nrx, index_nr, index_out;
ng_size_t i, j, total_nl, total_nr, size_output;
/*
* 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
*/
x = (void*)NclGetArgValue(
0,
4,
&ndims_x,
dsizes_x,
&missing_x,
&has_missing_x,
&type_x,
DONT_CARE);
/*
* Coerce missing value to double if necessary.
*/
coerce_missing(type_x,has_missing_x,&missing_x,
&missing_dbl_x,&missing_flt_x);
/*
* Get argument # 1
*/
w = (void*)NclGetArgValue(
1,
4,
NULL,
dsizes_w,
NULL,
NULL,
&type_w,
DONT_CARE);
/*
* Get argument # 2
*/
opt = (int*)NclGetArgValue(
2,
4,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Get argument # 3
*/
narg = (int*)NclGetArgValue(
3,
4,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Some error checking. Make sure input dimension is valid.
*/
if(*narg < 0 || *narg >= ndims_x) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_sum_wgt_n: Invalid dimension argument, can't continue");
return(NhlFATAL);
}
/*
* Test input dimension size.
*/
nx = dsizes_x[*narg];
if(nx > INT_MAX) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_sum_wgt_n: nx = %ld is greater than INT_MAX", nx);
return(NhlFATAL);
}
inx = (int) nx;
if(dsizes_w[0] != nx) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_sum_wgt_n: w must be length nx");
return(NhlFATAL);
}
/*
* Calculate size of all but narg dimensions and
* allocate space for output dimension sizes and set them.
*/
ndims_xavg = max(ndims_x-1,1);
dsizes_xavg = (ng_size_t*)calloc(ndims_xavg,sizeof(ng_size_t));
if( dsizes_xavg == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_sum_wgt_n: Unable to allocate memory for holding dimension sizes");
return(NhlFATAL);
}
total_nl = total_nr = size_output = 1;
if(ndims_x==1) { /* Handles case where x is 1D */
dsizes_xavg[0] = 1;
}
else {
for(i = 0; i < *narg; i++) {
total_nl *= dsizes_x[i];
dsizes_xavg[i] = dsizes_x[i];
}
for(i = *narg+1; i < ndims_x; i++) {
total_nr *= dsizes_x[i];
dsizes_xavg[i-1] = dsizes_x[i];
}
}
size_output = total_nr * total_nl;
/*
* Allocate space for coercing input arrays. We need to make a copy
* here, because the x values are not necessary consecutive, and
* hence we can't just point to the original array.
*/
/*
* Allocate space for tmp_x.
*/
tmp_x = (double *)calloc(nx,sizeof(double));
if(tmp_x == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_sum_wgt_n: Unable to allocate memory for coercing input array to double");
return(NhlFATAL);
}
/*
* The output type defaults to float, unless this input array is double.
*/
if(type_x == NCL_double) {
type_xavg = NCL_double;
}
else {
type_xavg = NCL_float;
}
/*
* Allocate space for output array.
*/
if(type_xavg != NCL_double) {
xavg = (void *)calloc(size_output, sizeof(float));
}
else {
xavg = (void *)calloc(size_output, sizeof(double));
}
if(xavg == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_sum_wgt_n: Unable to allocate memory for output array");
return(NhlFATAL);
}
/*
* Allocate space for tmp_w.
*/
tmp_w = coerce_input_double(w,type_w,nx,0,NULL,NULL);
if(tmp_w == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_sum_wgt_n: Unable to allocate memory for coercing input array to double");
return(NhlFATAL);
}
/*
* Loop across all but the narg-th dimension and call the Fortran routine
* for each one-dimensional subsection.
*/
nrnx = total_nr * nx;
for(i = 0; i < total_nl; i++) {
index_nrx = i * nrnx;
index_nr = i * total_nr;
for(j = 0; j < total_nr; j++) {
index_out = index_nr + j;
index_x = index_nrx + j;
/*
* Coerce subsection of x (tmp_x) to double if necessary.
*/
coerce_subset_input_double_step(x,tmp_x,index_x,total_nr,type_x,
nx,0,NULL,NULL);
/*
* Call the Fortran routine.
*/
NGCALLF(dimsumwgt,DIMSUMWGT)(&inx, tmp_x, &missing_dbl_x.doubleval,
tmp_w, opt, &tmp_xavg[0]);
/*
* Coerce output back to float or double.
*/
coerce_output_float_or_double(xavg,&tmp_xavg[0],type_x,1,index_out);
}
}
/*
* Free unneeded memory.
*/
NclFree(tmp_x);
if(type_w != NCL_double) NclFree(tmp_w);
/*
* Return value back to NCL script.
*/
if(has_missing_x) {
if(type_xavg == NCL_double) {
ret = NclReturnValue(xavg,ndims_xavg,dsizes_xavg,&missing_dbl_x,
type_xavg,0);
}
else {
ret = NclReturnValue(xavg,ndims_xavg,dsizes_xavg,&missing_flt_x,
type_xavg,0);
}
}
else {
ret = NclReturnValue(xavg,ndims_xavg,dsizes_xavg,NULL,type_xavg,0);
}
NclFree(dsizes_xavg);
return(ret);
}
NhlErrorTypes area_poly_sphere_W( void )
{
/*
* Input variables
*/
/*
* Argument # 0
*/
void *lat;
double *tmp_lat;
ng_size_t dsizes_lat[1];
NclBasicDataTypes type_lat;
/*
* Argument # 1
*/
void *lon;
double *tmp_lon;
ng_size_t dsizes_lon[1];
NclBasicDataTypes type_lon;
/*
* Argument # 2
*/
void *rsph;
double *tmp_rsph;
NclBasicDataTypes type_rsph;
/*
* Return variable
*/
void *parea;
double *tmp_parea;
int ndims_parea;
ng_size_t dsizes_parea[1];
NclBasicDataTypes type_parea;
/*
* Various
*/
ng_size_t npts;
int inpts, 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
*/
lat = (void*)NclGetArgValue(
0,
3,
NULL,
dsizes_lat,
NULL,
NULL,
&type_lat,
DONT_CARE);
npts = dsizes_lat[0];
if(npts > INT_MAX) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_poly_sphere: npts = %ld is greater than INT_MAX", npts);
return(NhlFATAL);
}
inpts = (int) npts;
/*
* Get argument # 1
*/
lon = (void*)NclGetArgValue(
1,
3,
NULL,
dsizes_lon,
NULL,
NULL,
&type_lon,
DONT_CARE);
if(dsizes_lon[0] != npts) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_poly_sphere: The #0 dimension of lon must be length npts");
return(NhlFATAL);
}
/*
* Get argument # 2
*/
rsph = (void*)NclGetArgValue(
2,
3,
NULL,
NULL,
NULL,
NULL,
&type_rsph,
DONT_CARE);
/*
* Allocate space for coercing input arrays. If any of the input
* is already double, then we don't need to allocate space for
* temporary arrays, because we'll just change the pointer into
* the void array appropriately.
*/
tmp_lat = coerce_input_double(lat,type_lat,npts,0,NULL,NULL);
if(tmp_lat == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_poly_sphere: Unable to allocate memory for coercing lat to double");
return(NhlFATAL);
}
tmp_lon = coerce_input_double(lon,type_lon,npts,0,NULL,NULL);
if(tmp_lon == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_poly_sphere: Unable to allocate memory for coercing lon to double");
return(NhlFATAL);
}
tmp_rsph = coerce_input_double(rsph,type_rsph,1,0,NULL,NULL);
if(tmp_rsph == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_poly_sphere: Unable to allocate memory for coercing rsph to double");
return(NhlFATAL);
}
if(type_lat == NCL_double || type_lon == NCL_double || type_rsph == NCL_double) {
type_parea = NCL_double;
}
else {
type_parea = NCL_float;
}
/*
* Allocate space for output array.
*/
if(type_parea != NCL_double) {
parea = (void *)calloc(1, sizeof(float));
tmp_parea = (double *)calloc(1,sizeof(double));
if(parea == NULL || tmp_parea == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_poly_sphere: Unable to allocate memory for output array");
return(NhlFATAL);
}
}
else {
parea = (void *)calloc(1, sizeof(double));
if(parea == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_poly_sphere: Unable to allocate memory for output array");
return(NhlFATAL);
}
tmp_parea = (double*)parea;
}
/*
* Call the Fortran routine.
*/
NGCALLF(spareapolyi,SPAREAPOLYI)(tmp_lat, tmp_lon, &inpts, tmp_rsph, tmp_parea);
/*
* Coerce as necessary
*/
coerce_output_float_or_double(parea,tmp_parea,type_parea,1,0);
/*
* Free unneeded memory.
*/
if(type_lat != NCL_double) NclFree(tmp_lat);
if(type_lon != NCL_double) NclFree(tmp_lon);
if(type_rsph != NCL_double) NclFree(tmp_rsph);
if(type_parea != NCL_double) NclFree(tmp_parea);
/*
* Return value back to NCL script. Output is a scalar.
*/
ndims_parea = 1;
dsizes_parea[0] = 1;
ret = NclReturnValue(parea,ndims_parea,dsizes_parea,NULL,type_parea,0);
return(ret);
}
NhlErrorTypes specxy_anal_W( void )
{
/*
* Input array variables
*/
void *x, *y, *pct;
double *dx, *dy, *dpct;
ng_size_t dsizes[1], nx;
int *iopt, *jave;
int ndims_x;
ng_size_t dsizes_x[NCL_MAX_DIMENSIONS];
int ndims_y;
ng_size_t dsizes_y[NCL_MAX_DIMENSIONS];
int has_missing_x, has_missing_y;
NclScalar missing_x, missing_y, missing_dx, missing_dy;
NclBasicDataTypes type_x, type_y, type_pct;
ng_size_t lwork;
double scl, *work;
/*
* Output variables
*/
void *dof;
NclBasicDataTypes type_dof;
NclObjClass type_output;
/*
* Attribute variables
*/
int att_id;
NclMultiDValData att_md, return_md;
NclVar tmp_var;
NclStackEntry return_data;
double *frq_tmp, *spcx_tmp, *spcy_tmp;
double *cospc_tmp, *quspc_tmp, *coher_tmp, *phase_tmp;
double prob_tmp[4], sinfo[50];
void *bw, *frq, *spcx, *spcy, *cospc, *quspc, *coher, *phase;
void *xavei, *xvari, *xvaro, *xlag1, *xslope;
void *yavei, *yvari, *yvaro, *ylag1, *yslope;
void *prob;
/*
* Declare variables for random purposes.
*/
ng_size_t i, nspc, nspcmx, total_size_x, total_size_y;
int ier;
/*
* Retrieve arguments.
*/
x = (void*)NclGetArgValue(
0,
5,
&ndims_x,
dsizes_x,
&missing_x,
&has_missing_x,
&type_x,
DONT_CARE);
y = (void*)NclGetArgValue(
1,
5,
&ndims_y,
dsizes_y,
&missing_y,
&has_missing_y,
&type_y,
DONT_CARE);
iopt = (int*)NclGetArgValue(
2,
5,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
jave = (int*)NclGetArgValue(
3,
5,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
pct = (void*)NclGetArgValue(
4,
5,
NULL,
NULL,
NULL,
NULL,
&type_pct,
DONT_CARE);
/*
* Check input.
*/
nx = dsizes_x[0];
nspc = nspcmx = nx/2 + 1;
if( nx != dsizes_y[0]) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"specxy_anal: 'x' and 'y' must have the same number of elements");
return(NhlFATAL);
}
if( nx < 3) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"specxy_anal: 'x' and 'y' must have more than 3 elements");
return(NhlFATAL);
}
if( *iopt > 2) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"specxy_anal: 'iopt' must be <= 2");
return(NhlFATAL);
}
if( abs(*jave) > nx/2 ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"specxy_anal: 'jave' must be <= nx/2");
return(NhlFATAL);
}
/*
* Compute the total number of elements in our arrays.
*/
total_size_x = 1;
for(i = 0; i < ndims_x; i++) total_size_x *= dsizes_x[i];
total_size_y = 1;
for(i = 0; i < ndims_y; i++) total_size_y *= dsizes_y[i];
/*
* Check for missing values and coerce data if necessary.
*/
coerce_missing(type_x,has_missing_x,&missing_x,&missing_dx,NULL);
coerce_missing(type_y,has_missing_y,&missing_y,&missing_dy,NULL);
/*
* Coerce x/y to double precision if necessary.
*/
dx = coerce_input_double(x,type_x,total_size_x,has_missing_x,&missing_x,
&missing_dx);
dy = coerce_input_double(y,type_y,total_size_y,has_missing_y,&missing_y,
&missing_dy);
if(dx == NULL|| dy == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"specxy_anal: Unable to allocate memory for coercing input arrays to double precision");
return(NhlFATAL);
}
/*
* Check if x or y contains missing values.
*/
if(contains_missing(dx,total_size_x,has_missing_x,missing_dx.doubleval) ||
contains_missing(dy,total_size_y,has_missing_y,missing_dy.doubleval)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"specx_anal: x and y cannot contain any missing values");
return(NhlFATAL);
}
/*
* Coerce pct to double precision if necessary.
*/
dpct = coerce_input_double(pct,type_pct,1,0,NULL,NULL);
if( dpct == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"specxy_anal: Unable to allocate memory for coercing pct array to double precision");
return(NhlFATAL);
}
/*
* Check pct.
*/
if( *dpct < 0.0 || *dpct > 1.0 ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"specxy_anal: 'pct' must be between 0 and 1 inclusive");
return(NhlFATAL);
}
/*
* Check if any input is double.
*/
if(type_x != NCL_double && type_y != NCL_double &&
type_pct != NCL_double) {
type_dof = NCL_float;
type_output = nclTypefloatClass;
/*
* Allocate space for float output variables.
*/
dof = (void *)calloc(1,sizeof(float));
frq = (void *)calloc(nspcmx-1,sizeof(float));
spcx = (void *)calloc(nspcmx-1,sizeof(float));
spcy = (void *)calloc(nspcmx-1,sizeof(float));
cospc = (void *)calloc(nspcmx-1,sizeof(float));
quspc = (void *)calloc(nspcmx-1,sizeof(float));
coher = (void *)calloc(nspcmx-1,sizeof(float));
phase = (void *)calloc(nspcmx-1,sizeof(float));
bw = (void *)calloc(1,sizeof(float));
prob = (void *)calloc(4,sizeof(float));
xavei = (void *)calloc(1,sizeof(float));
xvari = (void *)calloc(1,sizeof(float));
xvaro = (void *)calloc(1,sizeof(float));
xlag1 = (void *)calloc(1,sizeof(float));
xslope = (void *)calloc(1,sizeof(float));
yavei = (void *)calloc(1,sizeof(float));
yvari = (void *)calloc(1,sizeof(float));
yvaro = (void *)calloc(1,sizeof(float));
ylag1 = (void *)calloc(1,sizeof(float));
yslope = (void *)calloc(1,sizeof(float));
}
else {
type_dof = NCL_double;
type_output = nclTypedoubleClass;
/*
* Allocate space for double output variables.
*/
dof = (void *)calloc(1,sizeof(double));
bw = (void *)calloc(1,sizeof(double));
prob = (void *)calloc(4,sizeof(double));
frq = (void *)calloc(nspcmx-1,sizeof(double));
spcx = (void *)calloc(nspcmx-1,sizeof(double));
spcy = (void *)calloc(nspcmx-1,sizeof(double));
cospc = (void *)calloc(nspcmx-1,sizeof(double));
quspc = (void *)calloc(nspcmx-1,sizeof(double));
coher = (void *)calloc(nspcmx-1,sizeof(double));
phase = (void *)calloc(nspcmx-1,sizeof(double));
xavei = (void *)calloc(1,sizeof(double));
xvari = (void *)calloc(1,sizeof(double));
xvaro = (void *)calloc(1,sizeof(double));
xlag1 = (void *)calloc(1,sizeof(double));
xslope = (void *)calloc(1,sizeof(double));
yavei = (void *)calloc(1,sizeof(double));
yvari = (void *)calloc(1,sizeof(double));
yvaro = (void *)calloc(1,sizeof(double));
ylag1 = (void *)calloc(1,sizeof(double));
yslope = (void *)calloc(1,sizeof(double));
}
if( dof == NULL || bw == NULL || xavei == NULL || xvari == NULL ||
frq == NULL || spcx == NULL || spcy == NULL || cospc == NULL ||
quspc == NULL || coher == NULL || phase == NULL || xvaro == NULL ||
xlag1 == NULL ||xslope == NULL || yavei == NULL || yvari == NULL ||
yvaro == NULL || ylag1 == NULL ||yslope == NULL || prob == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"specxy_anal: Unable to allocate memory for output variables");
return(NhlFATAL);
}
/*
* Allocate space for stuff to be returned by dspecx.
*/
frq_tmp = (double *)calloc(nspcmx,sizeof(double));
spcx_tmp = (double *)calloc(nspcmx,sizeof(double));
spcy_tmp = (double *)calloc(nspcmx,sizeof(double));
cospc_tmp = (double *)calloc(nspcmx,sizeof(double));
quspc_tmp = (double *)calloc(nspcmx,sizeof(double));
coher_tmp = (double *)calloc(nspcmx,sizeof(double));
phase_tmp = (double *)calloc(nspcmx,sizeof(double));
if( frq_tmp == NULL || spcx_tmp == NULL || spcy_tmp == NULL ||
cospc_tmp == NULL || quspc_tmp == NULL || coher_tmp == NULL ||
phase_tmp == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"specxy_anal: Unable to allocate memory for output variables");
return(NhlFATAL);
}
/*
* Allocate space for work array.
*/
lwork = 10 * nx;
work = (double *)calloc(lwork,sizeof(double));
if( work == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"specxy_anal: Unable to allocate memory for work array");
return(NhlFATAL);
}
/*
* Call the Fortran version of this routine.
*/
scl = 2.0;
if((nx <= INT_MAX) &&
(lwork <= INT_MAX) &&
(nspc <= INT_MAX))
{
int inx = (int) nx;
int ilwork = (int) lwork;
int inspc = (int) nspc;
NGCALLF(dspecxy,DSPECXY)(dx,dy,&inx,iopt,jave,dpct,&scl,work,&ilwork,
frq_tmp,spcx_tmp,spcy_tmp,cospc_tmp,quspc_tmp,
coher_tmp,phase_tmp,&inspc,sinfo,&ier);
}
else
{
NhlPError(NhlFATAL,NhlEUNKNOWN,"specxy_anal: one or more input dimensions is greater than INT_MAX", nx);
return(NhlFATAL);
}
if( ier > 700000 ) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"specxy_anal: 'x' and/or 'y' contains all constant values");
}
/*
* Calculate coherence corresponding to the 90, 95, 99, and 99.9% levels.
*/
prob_tmp[0] = 1.-pow((1.-0.900),(1./(sinfo[0]/2.-1.)));
prob_tmp[1] = 1.-pow((1.-0.950),(1./(sinfo[0]/2.-1.)));
prob_tmp[2] = 1.-pow((1.-0.990),(1./(sinfo[0]/2.-1.)));
prob_tmp[3] = 1.-pow((1.-0.999),(1./(sinfo[0]/2.-1.)));
coerce_output_float_or_double( dof, &sinfo[0],type_dof,1,0);
coerce_output_float_or_double( xlag1, &sinfo[1],type_dof,1,0);
coerce_output_float_or_double( ylag1, &sinfo[2],type_dof,1,0);
coerce_output_float_or_double( bw, &sinfo[5],type_dof,1,0);
coerce_output_float_or_double( prob, prob_tmp,type_dof,4,0);
coerce_output_float_or_double( xavei, &sinfo[10],type_dof,1,0);
coerce_output_float_or_double( xvari, &sinfo[11],type_dof,1,0);
coerce_output_float_or_double( xvaro, &sinfo[12],type_dof,1,0);
coerce_output_float_or_double(xslope, &sinfo[31],type_dof,1,0);
coerce_output_float_or_double( yavei, &sinfo[20],type_dof,1,0);
coerce_output_float_or_double( yvari, &sinfo[21],type_dof,1,0);
coerce_output_float_or_double( yvaro, &sinfo[22],type_dof,1,0);
coerce_output_float_or_double(yslope, &sinfo[34],type_dof,1,0);
coerce_output_float_or_double( frq, &frq_tmp[1],type_dof,nspcmx-1,0);
coerce_output_float_or_double( spcx, &spcx_tmp[1],type_dof,nspcmx-1,0);
coerce_output_float_or_double( spcy, &spcy_tmp[1],type_dof,nspcmx-1,0);
coerce_output_float_or_double( cospc,&cospc_tmp[1],type_dof,nspcmx-1,0);
coerce_output_float_or_double( quspc,&quspc_tmp[1],type_dof,nspcmx-1,0);
coerce_output_float_or_double( coher,&coher_tmp[1],type_dof,nspcmx-1,0);
coerce_output_float_or_double( phase,&phase_tmp[1],type_dof,nspcmx-1,0);
/*
* Set up variable to return.
*/
dsizes[0] = 1;
return_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
dof,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
/*
* Set up attributes to return.
*/
att_id = _NclAttCreate(NULL,NULL,Ncl_Att,0,NULL);
dsizes[0] = nspcmx-1; /* returning nx/2 points, not nx/2 + 1 */
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
spcx,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"spcx",
att_md,
NULL
);
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
spcy,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"spcy",
att_md,
NULL
);
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
frq,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"frq",
att_md,
NULL
);
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
cospc,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"cospc",
att_md,
NULL
);
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
quspc,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"quspc",
att_md,
NULL
);
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
coher,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"coher",
att_md,
NULL
);
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
phase,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"phase",
att_md,
NULL
);
dsizes[0] = 1;
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
bw,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"bw",
att_md,
NULL
);
dsizes[0] = 4;
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
prob,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"coher_probability",
att_md,
NULL
);
dsizes[0] = 1;
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
xavei,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"xavei",
att_md,
NULL
);
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
xvari,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"xvari",
att_md,
NULL
);
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
xvaro,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"xvaro",
att_md,
NULL
);
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
xlag1,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"xlag1",
att_md,
NULL
);
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
xslope,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"xslope",
att_md,
NULL
);
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
yavei,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"yavei",
att_md,
NULL
);
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
yvari,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"yvari",
att_md,
NULL
);
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
yvaro,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"yvaro",
att_md,
NULL
);
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
ylag1,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"ylag1",
att_md,
NULL
);
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
yslope,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"yslope",
att_md,
NULL
);
/*
* Free up memory.
*/
NclFree(work);
if((void*)dx != x) NclFree(dx);
if((void*)dy != y) NclFree(dy);
if((void*)dpct != pct) NclFree(dpct);
NclFree(frq_tmp);
NclFree(spcx_tmp);
NclFree(spcy_tmp);
NclFree(cospc_tmp);
NclFree(quspc_tmp);
NclFree(coher_tmp);
NclFree(phase_tmp);
/*
* Return variable.
*/
tmp_var = _NclVarCreate(
NULL,
NULL,
Ncl_Var,
0,
NULL,
return_md,
NULL,
att_id,
NULL,
RETURNVAR,
NULL,
TEMPORARY
);
/*
* Return output grid and attributes to NCL.
*/
return_data.kind = NclStk_VAR;
return_data.u.data_var = tmp_var;
_NclPlaceReturn(return_data);
return(NhlNOERROR);
}
NhlErrorTypes specx_anal_W( void )
{
/*
* Input array variables
*/
void *x, *pct;
double *dx, *dpct;
ng_size_t dsizes[1];
ng_size_t nx;
int *iopt, *jave;
int ndims_x;
ng_size_t dsizes_x[NCL_MAX_DIMENSIONS];
int has_missing_x;
NclScalar missing_x, missing_dx;
NclBasicDataTypes type_x, type_pct;
ng_size_t lwork;
double scl, *work;
/*
* Output variables
*/
void *dof;
NclBasicDataTypes type_dof;
NclObjClass type_output;
/*
* Attribute variables
*/
int att_id;
NclMultiDValData att_md, return_md;
NclVar tmp_var;
NclStackEntry return_data;
double *frq_tmp, *spcx_tmp, sinfo[50];
void *spcx, *frq, *bw, *xavei, *xvari, *xvaro, *xlag1, *xslope;
/*
* Declare variables for random purposes.
*/
ng_size_t i, nspcmx, nspc, total_size_x;
int ier;
/*
* Retrieve arguments.
*/
x = (void*)NclGetArgValue(
0,
4,
&ndims_x,
dsizes_x,
&missing_x,
&has_missing_x,
&type_x,
DONT_CARE);
iopt = (int*)NclGetArgValue(
1,
4,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
jave = (int*)NclGetArgValue(
2,
4,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
pct = (void*)NclGetArgValue(
3,
4,
NULL,
NULL,
NULL,
NULL,
&type_pct,
DONT_CARE);
/*
* Check input.
*/
if( *iopt > 2) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"specx_anal: 'iopt' must be <= 2");
return(NhlFATAL);
}
nx = dsizes_x[0];
nspc = nspcmx = nx/2 + 1;
if( nx < 3) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"specx_anal: 'x' must have more than 3 elements");
return(NhlFATAL);
}
if( abs(*jave) > nx/2 ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"specx_anal: 'jave' must be <= nx/2");
return(NhlFATAL);
}
/*
* Compute the total number of elements in our array.
*/
total_size_x = 1;
for(i = 0; i < ndims_x; i++) total_size_x *= dsizes_x[i];
/*
* Check for missing values.
*/
coerce_missing(type_x,has_missing_x,&missing_x,&missing_dx,NULL);
/*
* Coerce x to double precision if necessary.
*/
dx = coerce_input_double(x,type_x,total_size_x,has_missing_x,&missing_x,
&missing_dx);
if( dx == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"specx_anal: Unable to allocate memory for coercing x array to double precision");
return(NhlFATAL);
}
/*
* Check if x contains missing values.
*/
if(contains_missing(dx,total_size_x,has_missing_x,missing_dx.doubleval)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"specx_anal: 'x' cannot contain any missing values");
return(NhlFATAL);
}
/*
* Coerce pct to double precision if necessary.
*/
dpct = coerce_input_double(pct,type_pct,1,0,NULL,NULL);
if( dpct == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"specx_anal: Unable to allocate memory for coercing pct array to double precision");
return(NhlFATAL);
}
/*
* Check pct.
*/
if( *dpct < 0.0 || *dpct > 1.0 ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"specx_anal: 'pct' must be between 0 and 1 inclusive");
return(NhlFATAL);
}
/*
* Check if any input is double.
*/
if(type_x != NCL_double && type_pct != NCL_double) {
type_dof = NCL_float;
type_output = nclTypefloatClass;
/*
* Allocate space for float output variables.
*/
dof = (void *)calloc(1,sizeof(float));
frq = (void *)calloc(nspcmx-1,sizeof(float));
spcx = (void *)calloc(nspcmx-1,sizeof(float));
bw = (void *)calloc(1,sizeof(float));
xavei = (void *)calloc(1,sizeof(float));
xvari = (void *)calloc(1,sizeof(float));
xvaro = (void *)calloc(1,sizeof(float));
xlag1 = (void *)calloc(1,sizeof(float));
xslope = (void *)calloc(1,sizeof(float));
}
else {
type_dof = NCL_double;
type_output = nclTypedoubleClass;
/*
* Allocate space for double output variables.
*/
dof = (void *)calloc(1,sizeof(double));
frq = (void *)calloc(nspcmx-1,sizeof(double));
spcx = (void *)calloc(nspcmx-1,sizeof(double));
bw = (void *)calloc(1,sizeof(double));
xavei = (void *)calloc(1,sizeof(double));
xvari = (void *)calloc(1,sizeof(double));
xvaro = (void *)calloc(1,sizeof(double));
xlag1 = (void *)calloc(1,sizeof(double));
xslope = (void *)calloc(1,sizeof(double));
}
if( dof == NULL || bw == NULL || spcx == NULL || frq == NULL ||
xavei == NULL || xvari == NULL || xvaro == NULL || xlag1 == NULL ||
xslope == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"specx_anal: Unable to allocate memory for output variables");
return(NhlFATAL);
}
/*
* Allocate space for stuff to be returned by dspecx.
*/
frq_tmp = (double *)calloc(nspcmx,sizeof(double));
spcx_tmp = (double *)calloc(nspcmx,sizeof(double));
if( frq_tmp == NULL || spcx_tmp == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"specx_anal: Unable to allocate memory for output variables");
return(NhlFATAL);
}
/*
* Allocate space for work array.
*/
lwork = 5 * nx + 18 + abs(*jave);
work = (double *)calloc(lwork,sizeof(double));
if( work == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"specx_anal: Unable to allocate memory for work array");
return(NhlFATAL);
}
/*
* Call the Fortran version of this routine.
*/
scl = 2.0;
if((nx <= INT_MAX) &&
(lwork <= INT_MAX) &&
(nspc <= INT_MAX))
{
int inx = (int) nx;
int ilwork = (int) lwork;
int inspc = (int) nspc;
NGCALLF(dspecx,DSPECX)(dx,&inx,iopt,jave,dpct,&scl,work,&ilwork,
frq_tmp,spcx_tmp,&inspc,sinfo,&ier);
}
else
{
NhlPError(NhlFATAL,NhlEUNKNOWN,"specx_anal: one or more input dimensions is greater than INT_MAX", nx);
return(NhlFATAL);
}
if( ier > 700000 ) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"specx_anal: 'x' contains all constant values");
}
coerce_output_float_or_double( dof, &sinfo[0],type_dof,1,0);
coerce_output_float_or_double( xlag1, &sinfo[1],type_dof,1,0);
coerce_output_float_or_double( bw, &sinfo[5],type_dof,1,0);
coerce_output_float_or_double( xavei, &sinfo[10],type_dof,1,0);
coerce_output_float_or_double( xvari, &sinfo[11],type_dof,1,0);
coerce_output_float_or_double( xvaro, &sinfo[12],type_dof,1,0);
coerce_output_float_or_double(xslope, &sinfo[31],type_dof,1,0);
coerce_output_float_or_double( frq, &frq_tmp[1],type_dof,nspcmx-1,0);
coerce_output_float_or_double( spcx, &spcx_tmp[1],type_dof,nspcmx-1,0);
/*
* Free up memory.
*/
NclFree(frq_tmp);
NclFree(spcx_tmp);
NclFree(work);
if((void*)dx != x) NclFree(dx);
if((void*)dpct != pct) NclFree(dpct);
/*
* Set up variable to return.
*/
dsizes[0] = 1;
return_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
dof,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
/*
* Set up attributes to return.
*/
att_id = _NclAttCreate(NULL,NULL,Ncl_Att,0,NULL);
dsizes[0] = nspcmx-1; /* returning nx/2 points, not nx/2 + 1 */
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
spcx,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"spcx",
att_md,
NULL
);
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
frq,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"frq",
att_md,
NULL
);
dsizes[0] = 1;
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
bw,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"bw",
att_md,
NULL
);
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
xavei,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"xavei",
att_md,
NULL
);
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
xvari,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"xvari",
att_md,
NULL
);
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
xvaro,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"xvaro",
att_md,
NULL
);
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
xlag1,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"xlag1",
att_md,
NULL
);
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
xslope,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"xslope",
att_md,
NULL
);
tmp_var = _NclVarCreate(
NULL,
NULL,
Ncl_Var,
0,
NULL,
return_md,
NULL,
att_id,
NULL,
RETURNVAR,
NULL,
TEMPORARY
);
/*
* Return output grid and attributes to NCL.
*/
return_data.kind = NclStk_VAR;
return_data.u.data_var = tmp_var;
_NclPlaceReturn(return_data);
return(NhlNOERROR);
}
