NhlErrorTypes color_index_to_rgba_W( void )
{
int i, *ci;
float *rgba;
ng_size_t dsizes[2];
int stride;
/*
* 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
*/
ci = (int *) NclGetArgValue(0,1,NULL,dsizes,NULL,NULL,
NULL,DONT_CARE);
/* ndims must be 1, dsizes[0] can be any number */
rgba = (float *) calloc(4 * dsizes[0], sizeof(float));
stride = 4;
for(i = 0; i < dsizes[0]; i++) {
_NhlColorIndexToRGBA(ci[i], rgba + i * stride,1);
}
dsizes[1] = 4;
return(NclReturnValue( (void *) rgba, 2, dsizes, NULL, NCL_float, 0));
}
NhlErrorTypes tdsort_W( void )
{
float *rwrk;
ng_size_t nwrk;
int *iwrk, *iord, inwrk;
ng_size_t dsizes_rwrk[1];
int ret;
/*
* Retrieve parameters.
*/
rwrk = (float*)NclGetArgValue(0,2,NULL,dsizes_rwrk,NULL,NULL,NULL,DONT_CARE);
iord = (int*)NclGetArgValue(1,2,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
nwrk = dsizes_rwrk[0];
/*
* Test dimension sizes.
*/
if(nwrk > INT_MAX) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"tdsort: the length of rwrk is greater than INT_MAX");
return(NhlFATAL);
}
inwrk = (int) nwrk;
iwrk = (int*)calloc(nwrk,sizeof(int));
if(iwrk == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"tdsort: Unable to allocate memory for permutation vector");
return(NhlFATAL);
}
c_tdsort(rwrk, inwrk, *iord, iwrk);
ret = NclReturnValue(iwrk,1,dsizes_rwrk,NULL,NCL_int,0);
return(NhlNOERROR);
}
NhlErrorTypes tdotri_W( void )
{
ng_size_t mtri;
int *ntri, imtri, *iord;
ng_size_t dsizes_rtri[2];
ng_size_t dsizes_rtwk[2];
ng_size_t dsizes_itwk[1];
float *rtri;
/*
* Work arrays.
*/
float *rtwk;
int *itwk, ret;
/*
* Retrieve parameters.
*/
rtri = (float*)NclGetArgValue(0,4,NULL,dsizes_rtri,NULL,NULL,NULL,DONT_CARE);
ntri = (int*)NclGetArgValue(1,4,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
rtwk = (float*)NclGetArgValue(2,4,NULL,dsizes_rtwk,NULL,NULL,NULL,DONT_CARE);
iord = (int*)NclGetArgValue(3,4,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
mtri = dsizes_rtri[0];
if(dsizes_rtri[1] != 10) {
NhlPError(NhlFATAL, NhlEUNKNOWN, "tdotri: the second dimension of ntri must be 10");
return(NhlFATAL);
}
if(dsizes_rtwk[0] != 2 || dsizes_rtwk[1] != mtri) {
NhlPError(NhlFATAL, NhlEUNKNOWN, "tdotri: the dimensions of rtwk must be 2 x mtri");
return(NhlFATAL);
}
/*
* Test dimension sizes.
*/
if(mtri > INT_MAX) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"tdotri: mtri is greater than INT_MAX");
return(NhlFATAL);
}
imtri = (int) mtri;
itwk = (int*)calloc(mtri,sizeof(int));
if(itwk == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"tdotri: Unable to allocate memory for permutation vector");
return(NhlFATAL);
}
NGCALLF(tdotri,TDOTRI)(rtri, &imtri, ntri, rtwk, itwk, iord);
if(*ntri == mtri) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"tdotri: triangle list overflow");
return(NhlFATAL);
}
dsizes_itwk[0] = mtri;
ret = NclReturnValue(itwk,1,dsizes_itwk,NULL,NCL_int,0);
return(NhlNOERROR);
}
NhlErrorTypes tdprpi_W( void )
{
float *xy_in, xy_out[2];
ng_size_t dsizes_xy[1];
/*
* Retrieve parameter.
*/
xy_in = (float*)NclGetArgValue(0,1,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
c_tdprpi(xy_in[0], xy_in[1], &xy_out[0], &xy_out[1]);
dsizes_xy[0] = 2;
return(NclReturnValue( (void *) xy_out, 1, dsizes_xy, NULL, NCL_float, 0));
}
NhlErrorTypes tdprpt_W( void )
{
float *uvw, xy[2];
ng_size_t dsizes_xy[1];
/*
* Retrieve parameter.
*/
uvw = (float*)NclGetArgValue(0,1,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
c_tdprpt(uvw[0], uvw[1], uvw[2], &xy[0], &xy[1]);
dsizes_xy[0] = 2;
return(NclReturnValue( (void *) xy, 1, dsizes_xy, NULL, NCL_float, 0));
}
NhlErrorTypes get_ncl_version_W(void)
{
char *version;
NrmQuark *sversion;
int len;
ng_size_t ret_size = 1;
/*
* There are no input arguments to retrieve.
* Just get the version number and return it.
*/
len = strlen(GetNCLVersion());
version = (char *)calloc(len+1,sizeof(char));
strcpy(version,GetNCLVersion());
sversion = (NrmQuark *)calloc(1,sizeof(NrmQuark));
*sversion = NrmStringToQuark(version);
free(version);
return(NclReturnValue((void *)sversion, 1, &ret_size, NULL, NCL_string, 0));
}
NhlErrorTypes tdgetp_W(void)
{
/*
* Get values for tdpack parameters.
*/
char *arg1;
int numpi, numpf, i;
/*
* List the integer and float parameter names. To add new ones,
* all that needs to be done is add the names to this list.
*/
char *params_i[] = {"cs1", "cs2", "fov", "hnd", "ifc1", "ifc2",
"ifc3", "ifc4", "ilc1", "ilc2", "iltd",
"lsu", "lsv", "lsw", "set", "shd", "ste",
"CS1", "CS2", "FOV", "HND", "IFC1", "IFC2",
"IFC3", "IFC4", "ILC1", "ILC2", "ILTD",
"LSU", "LSV", "LSW", "SET", "SHD", "STE",
};
char *params_f[] = {"cs1", "cs2", "fov", "lsu", "lsv", "lsw",
"vpb", "vpl", "vpr", "vpt", "ustp", "vstp", "wstp"
"CS1", "CS2", "FOV", "LSU", "LSV", "LSW",
"VPB", "VPL", "VPR", "VPT", "USTP", "VSTP", "WSTP"
};
/*
* Input array variable
*/
NrmQuark *pname;
int ndims_pname;
ng_size_t dsizes_pname[NCL_MAX_DIMENSIONS];
float *fval;
int *ival;
ng_size_t ret_size = 1;
/*
* Retrieve argument #1
*/
pname = (NrmQuark *) NclGetArgValue(
0,
1,
&ndims_pname,
dsizes_pname,
NULL,
NULL,
NULL,
DONT_CARE);
arg1 = NrmQuarkToString(*pname);
/*
* Check to see if the parameter name is valid.
*/
numpf = sizeof(params_f)/sizeof(void *);
numpi = sizeof(params_i)/sizeof(void *);
for (i = 0; i < numpf; i++) {
if (!strncmp(arg1, params_f[i], strlen(params_f[i]))) {
goto OK_NAME;
}
}
for (i = 0; i < numpi; i++) {
if (!strncmp(arg1, params_i[i], strlen(params_i[i]))) {
goto OK_NAME;
}
}
NhlPError(NhlFATAL, NhlEUNKNOWN, "tdgetp: unrecognized parameter name");
return(NhlFATAL);
OK_NAME:
/*
* Process the parameter if it has a float value.
*/
for (i = 0; i < numpf; i++) {
if (!strncmp(arg1, params_f[i], strlen(params_f[i]))) {
fval = (float *) calloc(1,sizeof(float));
c_tdgetr(arg1, fval);
return(NclReturnValue((void *) fval, 1, &ret_size, NULL, NCL_float, 0));
}
}
/*
* Process the parameter if it has an integer value.
*/
for (i = 0; i < numpi; i++) {
if (!strncmp(arg1, params_i[i], strlen(params_i[i]))) {
ival = (int *) calloc(1,sizeof(int));
c_tdgeti(arg1, ival);
return(NclReturnValue( (void *) ival, 1, &ret_size, NULL, NCL_int, 0));
}
}
NhlPError(NhlFATAL, NhlEUNKNOWN, "tdgetp: impossible to get this message");
return(NhlFATAL);
}
NhlErrorTypes generate_2d_array_W( void )
{
/*
* Input array variables
*/
void *tmp_dsizes_data;
ng_size_t *dsizes_data;
int *mlow, *mhigh, *iseed;
void *dlow, *dhigh;
double *tmp_dlow, *tmp_dhigh;
NclBasicDataTypes type_dlow, type_dhigh, type_dsizes_data;
/*
* Output variables.
*/
void *data;
double *tmp_data;
NclBasicDataTypes type_data;
int ret, id0, id1;
/*
* Declare various variables for random purposes.
*/
ng_size_t size_data;
/*
* Retrieve arguments.
*
*
* Get number of lows and highs. These two values will be forced to
* be between 1 and 25.
*/
mlow = (int*)NclGetArgValue(
0,
6,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
mhigh = (int*)NclGetArgValue(
1,
6,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Retrieve minimum and maximum values that the data is supposed to have.
*/
dlow = (void*)NclGetArgValue(
2,
6,
NULL,
NULL,
NULL,
NULL,
&type_dlow,
DONT_CARE);
dhigh = (void*)NclGetArgValue(
3,
6,
NULL,
NULL,
NULL,
NULL,
&type_dhigh,
DONT_CARE);
/*
* Get size of output array.
*/
iseed = (int*)NclGetArgValue(
4,
6,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Get size of output array.
*/
tmp_dsizes_data = (void*)NclGetArgValue(
5,
6,
NULL,
NULL,
NULL,
NULL,
&type_dsizes_data,
DONT_CARE);
/*
* Error checking.
*/
dsizes_data = get_dimensions(tmp_dsizes_data,2,type_dsizes_data,"generate_2d_array");
if(dsizes_data == NULL)
return(NhlFATAL);
if(dsizes_data[0] <= 1 && dsizes_data[1] <= 1) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"generate_2d_array: the dimensions of the output array must be such that it has at least two elements");
return(NhlFATAL);
}
if((dsizes_data[0] > INT_MAX) ||
(dsizes_data[1] > INT_MAX)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"generate_2d_array: input dimensions are greater than INT_MAX");
return(NhlFATAL);
}
id0 = (int) dsizes_data[0];
id1 = (int) dsizes_data[1];
if(*iseed < 0 || *iseed > 100) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"generate_2d_array: iseed must be between 0 and 100. Will reset to 0.");
*iseed = 0;
}
if(*mlow < 1) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"generate_2d_array: mlow must be between 1 and 25. Will reset to 1.");
*mlow = 1;
}
if(*mlow > 25) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"generate_2d_array: mlow must be between 1 and 25. Will reset to 25.");
*mlow = 25;
}
if(*mhigh < 1) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"generate_2d_array: mhigh must be between 1 and 25. Will reset to 1.");
*mhigh = 1;
}
if(*mhigh > 25) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"generate_2d_array: mhigh must be between 1 and 25. Will reset to 25.");
*mhigh = 25;
}
/*
* Coerce dlow and dhigh to double.
*/
tmp_dlow = coerce_input_double(dlow, type_dlow, 1,0,NULL,NULL);
tmp_dhigh = coerce_input_double(dhigh,type_dhigh,1,0,NULL,NULL);
/*
* Compute the size of the 2D output array.
*/
size_data = dsizes_data[0] * dsizes_data[1];
/*
* The type of the output array depends on dlow and dhigh.
*/
if(type_dlow == NCL_double || type_dhigh == NCL_double) {
type_data = NCL_double;
}
else {
type_data = NCL_float;
}
/*
* Allocate memory for output.
*/
if(type_data == NCL_double) {
data = (void*)malloc(size_data*sizeof(double));
tmp_data = (double *)data;
if(data == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"generate_2d_array: Unable to allocate memory for output array");
return(NhlFATAL);
}
}
else {
data = (void*)malloc(size_data*sizeof(float));
tmp_data = (double*)malloc(size_data*sizeof(double));
if(tmp_data == NULL || data == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"generate_2d_array: Unable to allocate memory for output array");
return(NhlFATAL);
}
}
/*
* Call the Fortran version of this routine.
*/
NGCALLF(dgendat,DGENDAT)(tmp_data,&id1,&id1,
&id0,mlow,mhigh,tmp_dlow,tmp_dhigh,
iseed);
/*
* Figure out if we need to coerce output back to float.
*/
if(type_data == NCL_float) {
coerce_output_float_only(data,tmp_data,size_data,0);
}
/*
* Free memory.
*/
if(type_data != NCL_double) NclFree(tmp_data);
if(type_dlow != NCL_double) NclFree(tmp_dlow);
if(type_dhigh != NCL_double) NclFree(tmp_dhigh);
ret = NclReturnValue(data,2,dsizes_data,NULL,type_data,0);
NclFree(dsizes_data);
return(ret);
}
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 rgba_to_color_index_W( void )
{
int i, *ci;
float *rgba;
ng_size_t dsizes[2];
int ndims;
int has_alpha;
int stride;
int rgba_dim;
ng_size_t ncolors;
/*
* 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
*/
rgba = (float *) NclGetArgValue(0,1,&ndims,dsizes,NULL,NULL,
NULL,DONT_CARE);
/* ndims must be 1 or 2, dsizes[0] can be any number; dsizes[1] must be 3 or 4 */
if (ndims == 1) {
rgba_dim = 0;
ncolors = 1;
}
else if (ndims == 2) {
rgba_dim = 1;
ncolors = dsizes[0];
}
else {
NhlPError(NhlFATAL,NhlEUNKNOWN,
"rgba_to_color_index: the input array must have either 1 or 2 dimensions");
return(NhlFATAL);
}
if (dsizes[rgba_dim] == 3) {
has_alpha = 0;
stride = 3;
}
else if (dsizes[rgba_dim] == 4) {
has_alpha = 1;
stride = 4;
}
else {
NhlPError(NhlFATAL,NhlEUNKNOWN,
"rgba_to_color_index: the second dimension of the input array must have either three or four elements");
return(NhlFATAL);
}
ci = (int*)calloc(ncolors,sizeof(int));
for(i = 0; i < ncolors; i++) {
ci[i] = _NhlRGBAToColorIndex(rgba + i * stride,has_alpha);
}
return(NclReturnValue( (void *) ci, 1, &ncolors, NULL, NCL_int, 0));
}
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 pdfx_bin_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_dbl_x;
NclBasicDataTypes type_x;
/*
* Argument # 1
*/
void *binxbnd;
double *tmp_binxbnd;
ng_size_t dsizes_binxbnd[1];
NclBasicDataTypes type_binxbnd;
/*
* Argument # 2
*/
logical *opt;
/*
* Return variable
*/
void *pdf;
double *tmp_pdf = NULL;
ng_size_t dsizes_pdf[1];
NclBasicDataTypes type_pdf;
/*
* Various
*/
ng_size_t i, nx, mbxp1, mbx;
int ier, ret;
int inx, imbx, imbxp1;
/*
* Variables for retrieving attributes from "opt".
*/
NclAttList *attr_list;
NclAtt attr_obj;
NclStackEntry stack_entry;
logical fraction = False;
int ipcnt;
/*
* 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);
nx = 1;
for(i = 0; i < ndims_x; i++) nx *= dsizes_x[i];
/*
* Get argument # 1
*/
binxbnd = (void*)NclGetArgValue(
1,
3,
NULL,
dsizes_binxbnd,
NULL,
NULL,
&type_binxbnd,
DONT_CARE);
mbxp1 = dsizes_binxbnd[0];
mbx = mbxp1 - 1;
if(mbxp1 < 2) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"pdfx_bin: The binxbnd array must have at least two values");
return(NhlFATAL);
}
/*
* Test input dimension sizes.
*/
if((nx > INT_MAX) || (mbx > INT_MAX) || (mbxp1 > INT_MAX)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"pdfx_bin: one or more input dimension sizes is greater than INT_MAX");
return(NhlFATAL);
}
inx = (int) nx;
imbx = (int) mbx;
imbxp1 = (int) mbxp1;
/*
* Get argument # 2
*/
opt = (logical*)NclGetArgValue(
2,
3,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* If "opt" is True, then check if any attributes have been set.
*
* There's only one recognized right now:
*
* "fraction" : whether to return fraction (True) or percent (False)
* (False by default)
*/
if(*opt) {
stack_entry = _NclGetArg(2, 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 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.
*/
while (attr_list != NULL) {
/*
* Check for "fraction".
*/
if (!strcmp(attr_list->attname, "fraction")) {
if(attr_list->attvalue->multidval.data_type != NCL_logical) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"pdfx_bin: The 'fraction' attribute must be a logical; defaulting to False.");
}
else {
fraction = *(logical*) attr_list->attvalue->multidval.val;
}
}
attr_list = attr_list->next;
}
}
default:
break;
}
}
if(fraction) ipcnt = 0;
else ipcnt = 1;
/*
* Coerce missing values to double if necessary.
*/
coerce_missing(type_x,has_missing_x,&missing_x,&missing_dbl_x,NULL);
/*
* The output type defaults to float, unless any input arrays are double.
*/
if(type_x == NCL_double || type_binxbnd == NCL_double) {
type_pdf = NCL_double;
}
else {
type_pdf = NCL_float;
}
/*
* Coerce input arrays to double if necessary.
*/
tmp_x = coerce_input_double(x,type_x,nx,0,NULL,NULL);
if(tmp_x == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"pdfx_bin: Unable to allocate memory for coercing x to double");
return(NhlFATAL);
}
tmp_binxbnd = coerce_input_double(binxbnd,type_binxbnd,mbxp1,0,NULL,NULL);
if(tmp_binxbnd == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"pdfx_bin: Unable to allocate memory for coercing binxbnd to double");
return(NhlFATAL);
}
/*
* Allocate space for output array.
*/
if(type_pdf != NCL_double) {
pdf = (void *)calloc(mbx, sizeof(float));
tmp_pdf = (double *)calloc(mbx,sizeof(double));
if(tmp_pdf == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"pdfx_bin: Unable to allocate memory for temporary output array");
return(NhlFATAL);
}
}
else {
pdf = (void *)calloc(mbx, sizeof(double));
}
if(pdf == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"pdfx_bin: Unable to allocate memory for output array");
return(NhlFATAL);
}
if(type_pdf == NCL_double) tmp_pdf = &((double*)pdf)[0];
/*
* Call the Fortran routine.
*/
NGCALLF(x1pdf77,X1PDF77)(&inx, tmp_x, &missing_dbl_x.doubleval,
&imbx, tmp_pdf, &imbxp1, tmp_binxbnd,
&ipcnt, &ier);
/*
* Coerce output back to float if necessary.
*/
if(type_pdf == NCL_float) coerce_output_float_only(pdf,tmp_pdf,mbx,0);
/*
* Free unneeded memory.
*/
if(type_x != NCL_double) NclFree(tmp_x);
if(type_binxbnd != NCL_double) NclFree(tmp_binxbnd);
if(type_pdf != NCL_double) NclFree(tmp_pdf);
/*
* Return value back to NCL script.
*/
dsizes_pdf[0] = mbx;
ret = NclReturnValue(pdf,1,dsizes_pdf,NULL,type_pdf,0);
return(ret);
}
NhlErrorTypes bw_bandpass_filter_W( void )
{
/*
* Input variables
*/
/*
* Argument # 0
*/
void *xr;
double *tmp_xr;
int ndims_xr;
ng_size_t dsizes_xr[NCL_MAX_DIMENSIONS];
NclBasicDataTypes type_xr;
/*
* Argument # 1
*/
void *fca;
double *tmp_fca;
NclBasicDataTypes type_fca;
/*
* Argument # 2
*/
void *fcb;
double *tmp_fcb;
NclBasicDataTypes type_fcb;
/*
* Argument # 3
*/
logical *opt;
/*
* Argument # 4
*/
int *dims;
ng_size_t ndims;
/*
* Return variable
*/
void *bf;
int ndims_bf;
double *tmp_yr, *tmp_er;
ng_size_t *dsizes_bf;
NclBasicDataTypes type_bf;
/*
* Variables for retrieving attributes from "opt".
*/
NclAttList *attr_list;
NclAtt attr_obj;
NclStackEntry stack_entry;
logical set_dt = False, rmv_mean = True, ret_filt = True, ret_env = False;
int m=6, iflag;
void *dt;
double *tmp_dt;
NclBasicDataTypes type_dt;
/*
* Various
*/
ng_size_t i, nx, total_nl, total_nr, nrnx;
ng_size_t index_xr, index_nrx, size_xr, size_output;
int j, inx, ret, ier;
/*
* 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
*/
xr = (void*)NclGetArgValue(
0,
5,
&ndims_xr,
dsizes_xr,
NULL,
NULL,
&type_xr,
DONT_CARE);
/*
* Get argument # 1
*/
fca = (void*)NclGetArgValue(
1,
5,
NULL,
NULL,
NULL,
NULL,
&type_fca,
DONT_CARE);
/*
* Get argument # 2
*/
fcb = (void*)NclGetArgValue(
2,
5,
NULL,
NULL,
NULL,
NULL,
&type_fcb,
DONT_CARE);
/*
* Get argument # 3
*/
opt = (logical*)NclGetArgValue(
3,
5,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Get argument # 4
*/
dims = (int *)NclGetArgValue(4,5,NULL,&ndims,NULL,NULL,NULL,0);
/*
* Some error checking. Make sure input dimension is valid.
*/
if(ndims > ndims_xr) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"bw_bandpass_filter: too many dimensions in dimension argument, can't continue");
return(NhlFATAL);
}
for(i = 0; i < ndims; i++ ) {
if(dims[i] < 0 || dims[i] >= ndims_xr) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"bw_bandpass_filter: Invalid dimension argument, can't continue");
return(NhlFATAL);
}
if(i > 0 && dims[i] != (dims[i-1]+1)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"bw_bandpass_filter: Input dimension sizes must be monotonically increasing, can't continue");
return(NhlFATAL);
}
}
/*
* Check for attributes attached to "opt"
*
* "m" - 6
* "dt" - 1.0
* "remove_mean" - True
* "return_filtered" - True
* "return_envelope" - False
*/
if(*opt) {
stack_entry = _NclGetArg(3, 5, 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.
*/
while (attr_list != NULL) {
if(!strcasecmp(attr_list->attname, "remove_mean")) {
rmv_mean = *(logical *) attr_list->attvalue->multidval.val;
}
else if(!strcasecmp(attr_list->attname, "return_filtered")) {
ret_filt = *(logical *) attr_list->attvalue->multidval.val;
}
else if(!strcasecmp(attr_list->attname, "return_envelope")) {
ret_env = *(logical *) attr_list->attvalue->multidval.val;
}
else if(!strcasecmp(attr_list->attname, "dt")) {
dt = attr_list->attvalue->multidval.val;
type_dt = attr_list->attvalue->multidval.data_type;
set_dt = True;
}
else if(!strcasecmp(attr_list->attname, "m")) {
m = *(int *) attr_list->attvalue->multidval.val;
}
attr_list = attr_list->next;
}
default:
break;
}
}
}
/*
* Provide default for dt if not specified by user.
*/
if(set_dt) {
tmp_dt = coerce_input_double(dt,type_dt,1,0,NULL,NULL);
}
else {
type_dt = NCL_double;
tmp_dt = (double *)calloc(1,sizeof(double));
*tmp_dt = 1.0;
}
if(!ret_filt && !ret_env) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"bw_bandpass_filter: both return_filtered and return_envelope are False. One of these must be True");
return(NhlFATAL);
}
/*
* Calculate size and dimension sizes of output array.
*
* If both ret_filt and ret_env are True, then the
* return array will be 2 x k x ...
* Otherwise it will be k x ...
*
*/
if(ret_filt && ret_env) ndims_bf = ndims_xr + 1;
else ndims_bf = ndims_xr;
dsizes_bf = (ng_size_t*)calloc(ndims_bf,sizeof(ng_size_t));
if( dsizes_bf == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"bw_bandpass_filter: Unable to allocate memory for holding dimension sizes");
return(NhlFATAL);
}
if(ret_filt && ret_env) dsizes_bf[0] = 2;
for(i = 0; i < ndims_xr; i++)
dsizes_bf[i+(ndims_bf-ndims_xr)] = dsizes_xr[i];
/*
* Calculate number of leftmost, rightmost, and middle elements.
*/
nx = total_nl = total_nr = 1;
for(i = 0; i < ndims ; i++) nx = nx*dsizes_xr[dims[i]];
for(i = 0; i < dims[0]; i++) total_nl *= dsizes_xr[i];
for(i = dims[ndims-1]+1; i < ndims_xr; i++) total_nr *= dsizes_xr[i];
/*
* Calculate xr and output sizes.
*/
size_xr = total_nr * total_nl * nx;
if(ret_filt && ret_env) size_output = size_xr * 2;
else size_output = size_xr;
if(nx > INT_MAX) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"bw_bandpass_filter: nx = %ld is greater than INT_MAX", nx);
return(NhlFATAL);
}
inx = (int) nx;
/*
* Coerce fca, fcb to double, if needed.
*/
tmp_fca = coerce_input_double(fca,type_fca,1,0,NULL,NULL);
tmp_fcb = coerce_input_double(fcb,type_fcb,1,0,NULL,NULL);
if(tmp_fca == NULL || tmp_fcb == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"bw_bandpass_filter: Unable to allocate memory for coercing input scalars to double");
return(NhlFATAL);
}
/*
* Allocate space for input array no matter what, because it
* may not be contiguous in memory.
*/
tmp_xr = (double *)calloc(nx,sizeof(double));
if(tmp_xr == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"bw_bandpass_filter: Unable to allocate memory for coercing input array to double");
return(NhlFATAL);
}
/*
* Return type.
*/
if(type_xr != NCL_double) type_bf = NCL_float;
else type_bf = NCL_double;
/*
* Allocate space for output array.
*/
if(type_bf != NCL_double) bf = (void *)calloc(size_output, sizeof(float));
else bf = (void *)calloc(size_output, sizeof(double));
if(bf == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"bw_bandpass_filter: Unable to allocate memory for output array");
return(NhlFATAL);
}
/*
* Allocate space for subset of output array.
*/
tmp_yr = (double *)calloc(nx, sizeof(double));
tmp_er = (double *)calloc(nx, sizeof(double));
if(tmp_yr == NULL || tmp_er == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"bw_bandpass_filter: Unable to allocate memory for temporary output arrays");
return(NhlFATAL);
}
/*
* Loop across leftmost/rightmost dimensions and call
* the Fortran routine for each subsection of the
* input arrays.
*/
nrnx = total_nr * nx;
if(rmv_mean) iflag = 1;
else iflag = 0;
for(i = 0; i < total_nl; i++) {
index_nrx = i*nrnx;
for(j = 0; j < total_nr; j++) {
index_xr = index_nrx + j;
/*
* Coerce subsection of x (tmp_xr) to double if necessary.
*/
coerce_subset_input_double_step(xr,tmp_xr,index_xr,total_nr,type_xr,
nx,0,NULL,NULL);
/*
* Call the Fortran routine.
*/
NGCALLF(buttfilt,BUTTFILT)(tmp_xr, tmp_yr, tmp_er, tmp_fca, tmp_fcb,
tmp_dt, &m, &inx, &iflag, &ier);
/*
* Copy/coerce back to output array
*/
if(ret_filt && !ret_env) {
coerce_output_float_or_double_step(bf,tmp_yr,type_bf,nx,
index_xr,total_nr);
}
else if(!ret_filt && ret_env) {
coerce_output_float_or_double_step(bf,tmp_er,type_bf,nx,
index_xr,total_nr);
}
else {
coerce_output_float_or_double_step(bf,tmp_yr,type_bf,nx,
index_xr,total_nr);
coerce_output_float_or_double_step(bf,tmp_er,type_bf,nx,
index_xr+size_xr,total_nr);
}
}
}
/*
* Free unneeded memory.
*/
NclFree(tmp_xr);
NclFree(tmp_er);
NclFree(tmp_yr);
if(type_fca != NCL_double) NclFree(tmp_fca);
if(type_fcb != NCL_double) NclFree(tmp_fcb);
if(!set_dt || type_dt != NCL_double) NclFree(tmp_dt);
/*
* Return value back to NCL script.
*/
ret = NclReturnValue(bf,ndims_bf,dsizes_bf,NULL,type_bf,0);
NclFree(dsizes_bf);
return(ret);
}
NhlErrorTypes fft2db_W( void )
{
/*
* First and only input argument.
*/
void *coef;
double *tmp_coef, *tmp_r;
ng_size_t dsizes_coef[3];
NclBasicDataTypes type_coef;
/*
* Return variable
*/
void *x;
ng_size_t dsizes_x[2];
NclBasicDataTypes type_x;
NclObjClass type_obj_x;
/*
* Variables for retrieving attributes from input array.
*/
NclAttList *attr_list;
NclAtt attr_obj;
NclStackEntry stack_entry;
/*
* Various
*/
int ier;
ng_size_t l = 0;
ng_size_t i, j, m, ldim, l21, ml, mldim, ml21, lwsave, lwork;
ng_size_t ix0, ix1, ir0, ir1, ic0, ic1, size_coef;
logical calculate_lval;
double *wsave, *work;
int il, im, ildim, ilwsave, ilwork;
/*
* Retrieve input argument.
*
* Note any of the pointer parameters can be set to NULL, which
* implies you don't care about its value.
*/
coef = (void*)NclGetArgValue(
0,
1,
NULL,
dsizes_coef,
NULL,
NULL,
&type_coef,
DONT_CARE);
/*
* First dimension must be 2.
*/
if(dsizes_coef[0] != 2) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"fft2db: The first dimension of coef must be 2");
return(NhlFATAL);
}
/*
* Check if the N attribute is attached to the input array (there should
* also be an M attribute, but we don't need this).
*
* This will tell us the original size of the array passed to "fft2df".
* If N is not attached as an attribute, then we will just calculate N
* (which is "l" in the code below).
*/
calculate_lval = True;
stack_entry = _NclGetArg(0, 1, 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; will have to calculate "l".
*/
break;
}
/*
* Look for attributes.
*/
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) {
if ((strcmp(attr_list->attname, "N")) == 0) {
l = *(int *) attr_list->attvalue->multidval.val;
if (l > 0) {
calculate_lval = False;
}
}
attr_list = attr_list->next;
}
}
default:
break;
}
/*
* Allocate space for coercing input array. Since we have to copy
* the input array to a bigger array (tmp_r), we will go ahead and
* make a copy of it.
*/
m = dsizes_coef[1];
l21 = dsizes_coef[2];
if(calculate_lval) {
l = (l21-1) * 2;
NhlPError(NhlWARNING,NhlEUNKNOWN,"fft2db: 'N' was either not attached as an attribute to the input array, or it had an invalid value.\nThe size of the output array will have to be calculated based on the size of the input array.");
}
ldim = 2 * l21;
ml = m * l;
mldim = m * ldim;
ml21 = m * l21;
size_coef = 2 * ml21;
tmp_coef = (double *)calloc(size_coef, sizeof(double));
tmp_r = (double *)calloc(mldim, sizeof(double));
if(tmp_coef == NULL || tmp_r == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"fft2db: Unable to allocate memory for coercing input array to double");
return(NhlFATAL);
}
coerce_subset_input_double(coef,tmp_coef,0,type_coef,size_coef,0,NULL,NULL);
/*
* Copy tmp_coef array to a subset of tmp_r.
*/
for(i = 0; i < m; i++ ) {
for(j = 0; j < l21; j++ ) {
ic0 = i*l21 + j;
ic1 = ml21 + ic0;
ir0 = i*ldim + 2*j;
ir1 = ir0 + 1;
tmp_r[ir0] = tmp_coef[ic0];
tmp_r[ir1] = tmp_coef[ic1];
}
}
/*
* The output type defaults to float, unless the input array is double.
*/
if(type_coef != NCL_double) {
type_x = NCL_float;
type_obj_x = nclTypefloatClass;
}
else {
type_x = NCL_double;
type_obj_x = nclTypedoubleClass;
}
/*
* Calculate size of output array and allocate space for it.
*/
dsizes_x[0] = m;
dsizes_x[1] = l;
if(type_x != NCL_double) {
x = (void *)calloc(ml, sizeof(float));
}
else {
x = (void *)calloc(ml, sizeof(double));
}
if(x == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"fft2db: Unable to allocate memory for output array");
return(NhlFATAL);
}
/*
* Test dimension sizes.
*/
lwsave = 2*m + l + log(l) + log(m) + 8;
lwork = mldim;
if((l > INT_MAX) || (m > INT_MAX) || (ldim > INT_MAX) ||
(lwsave > INT_MAX) || (lwork > INT_MAX)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"fft2db: one or more input dimension sizes are greater than INT_MAX");
return(NhlFATAL);
}
il = (int) l;
im = (int) m;
ildim = (int) ldim;
ilwsave = (int) lwsave;
ilwork = (int) lwork;
/*
* Allocate space for work arrays.
*/
wsave = (double *)calloc(lwsave,sizeof(double));
work = (double *)calloc(lwork,sizeof(double));
if(work == NULL || wsave == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"fft2db: Unable to allocate memory for work arrays");
return(NhlFATAL);
}
/*
* Call the Fortran routines.
*/
ier = 0;
NGCALLF(drfft2i,DRFFT2I)(&il, &im, wsave, &ilwsave, &ier);
NGCALLF(drfft2b,DRFFT2B)(&ildim, &il, &im, tmp_r, wsave, &ilwsave, work,
&ilwork,&ier);
if(ier) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"fft2db: ier = %d", ier);
return(NhlFATAL);
}
/*
* Copy tmp_r back to the appropriate locations in coef.
*/
if(type_x == NCL_float) {
for(i = 0; i < m; i++ ) {
for(j = 0; j < l; j++ ) {
ix0 = i*l + j;
ix1 = i*ldim + j;
((float*)x)[ix0] = (float)tmp_r[ix1];
}
}
}
else {
for(i = 0; i < m; i++ ) {
for(j = 0; j < l; j++ ) {
ix0 = i*l + j;
ix1 = i*ldim + j;
((double*)x)[ix0] = tmp_r[ix1];
}
}
}
/*
* Free unneeded memory.
*/
NclFree(tmp_coef);
NclFree(tmp_r);
NclFree(wsave);
NclFree(work);
/*
* Return value back to NCL script.
*/
return(NclReturnValue(x,2,dsizes_x,NULL,type_x,0));
}
NhlErrorTypes uv2dv_cfd_W( void )
{
/*
* Input array variables
*/
void *u, *v, *lat, *lon;
int *bound_opt;
double *tmp_u = NULL;
double *tmp_v = NULL;
double *tmp_lat, *tmp_lon;
int ndims_u;
ng_size_t dsizes_u[NCL_MAX_DIMENSIONS];
int ndims_v;
ng_size_t dsizes_v[NCL_MAX_DIMENSIONS];
ng_size_t dsizes_lat[NCL_MAX_DIMENSIONS];
ng_size_t dsizes_lon[NCL_MAX_DIMENSIONS];
int has_missing_u;
NclScalar missing_u, missing_du, missing_ru;
NclBasicDataTypes type_u, type_v, type_lat, type_lon;
/*
* Output array variables
*/
void *div;
double *tmp_div = NULL;
NclBasicDataTypes type_div;
/*
* Declare various variables for random purposes.
*/
ng_size_t i, nlon, nlat, nlatnlon, size_uv, size_leftmost, index_uv;
int inlat, inlon, ier;
/*
* Retrieve parameters
*
* Note that any of the pointer parameters can be set to NULL,
* which implies you don't care about its value.
*
*/
u = (void*)NclGetArgValue(
0,
5,
&ndims_u,
dsizes_u,
&missing_u,
&has_missing_u,
&type_u,
DONT_CARE);
v = (void*)NclGetArgValue(
1,
5,
&ndims_v,
dsizes_v,
NULL,
NULL,
&type_v,
DONT_CARE);
lat = (void*)NclGetArgValue(
2,
5,
NULL,
dsizes_lat,
NULL,
NULL,
&type_lat,
DONT_CARE);
lon = (void*)NclGetArgValue(
3,
5,
NULL,
dsizes_lon,
NULL,
NULL,
&type_lon,
DONT_CARE);
bound_opt = (int*)NclGetArgValue(
4,
5,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Get size of input array.
*/
if(ndims_u < 2 || ndims_u != ndims_v) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"uv2dv_cfd: u and v must have the same numer of dimensions and have at least 2 dimensions");
return(NhlFATAL);
}
for( i=0; i < ndims_u; i++ ) {
if(dsizes_u[i] != dsizes_v[i]) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"uv2dv_cfd: u and v must have the same dimensions");
return(NhlFATAL);
}
}
nlat = dsizes_u[ndims_u-2];
nlon = dsizes_u[ndims_u-1];
nlatnlon = nlat * nlon;
/*
* Test dimension sizes.
*/
if((nlon > INT_MAX) || (nlat > INT_MAX)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"uv2dv_cfd: nlat and/or nlon is greater than INT_MAX");
return(NhlFATAL);
}
inlon = (int) nlon;
inlat = (int) nlat;
if(dsizes_lat[0] != nlat || dsizes_lon[0] != nlon) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"uv2dv_cfd: the lat,lon arrays must be dimensioned nlat and nlon, the last two dimensions of u and v");
return(NhlFATAL);
}
/*
* Compute the total size of the q array.
*/
size_leftmost = 1;
for( i = 0; i < ndims_u-2; i++ ) size_leftmost *= dsizes_u[i];
size_uv = size_leftmost * nlatnlon;
/*
* Check for missing values.
*/
coerce_missing(type_u,has_missing_u,&missing_u,&missing_du,&missing_ru);
/*
* Create temporary arrays to hold double precision data.
*/
if(type_u != NCL_double) {
tmp_u = (double*)calloc(nlatnlon,sizeof(double));
if( tmp_u == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"uv2dv_cfd: Unable to allocate memory for coercing u to double precision");
return(NhlFATAL);
}
}
if(type_v != NCL_double) {
tmp_v = (double*)calloc(nlatnlon,sizeof(double));
if( tmp_v == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"uv2dv_cfd: Unable to allocate memory for coercing v to double precision");
return(NhlFATAL);
}
}
/*
* Allocate space for output array.
*/
if(type_u == NCL_double || type_v == NCL_double) {
type_div = NCL_double;
div = (void*)calloc(size_uv,sizeof(double));
}
else {
tmp_div = (double*)calloc(nlatnlon,sizeof(double));
if(tmp_div == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"uv2dv_cfd: Unable to allocate memory for temporary output array");
return(NhlFATAL);
}
type_div = NCL_float;
div = (void*)calloc(size_uv,sizeof(float));
}
if(div == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"uv2dv_cfd: Unable to allocate memory for output array");
return(NhlFATAL);
}
/*
* Coerce lat/lon arrays to double if necessary.
*/
tmp_lat = coerce_input_double(lat,type_lat,nlat,0,NULL,NULL);
tmp_lon = coerce_input_double(lon,type_lon,nlon,0,NULL,NULL);
if(tmp_lat == NULL || tmp_lon == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"uv2dv_cfd: Unable to coerce lat/lon arrays to double precision");
return(NhlFATAL);
}
/*
* Loop through leftmost dimensions and call Fortran routine.
*/
index_uv = 0;
for(i = 0; i < size_leftmost; i++ ) {
if(type_u != NCL_double) {
/*
* Coerce u (tmp_u) to double.
*/
coerce_subset_input_double(u,tmp_u,index_uv,type_u,nlatnlon,0,NULL,NULL);
}
else {
/*
* Point tmp_u to u.
*/
tmp_u = &((double*)u)[index_uv];
}
if(type_v != NCL_double) {
/*
* Coerce v (tmp_v) to double.
*/
coerce_subset_input_double(v,tmp_v,index_uv,type_v,nlatnlon,0,NULL,NULL);
}
else {
/*
* Point tmp_v to v.
*/
tmp_v = &((double*)v)[index_uv];
}
if(type_div == NCL_double) {
/*
* Point tmp_div to div.
*/
tmp_div = &((double*)div)[index_uv];
}
/*
* Call the Fortran routine.
*/
NGCALLF(ddvfidf,DDVFIDF)(tmp_u,tmp_v,tmp_lat,tmp_lon,&inlon,&inlat,
&missing_du.doubleval,bound_opt,tmp_div,&ier);
if(type_div != NCL_double) {
coerce_output_float_only(div,tmp_div,nlatnlon,index_uv);
}
index_uv += nlatnlon;
}
/*
* Free temp arrays.
*/
if(type_u != NCL_double) NclFree(tmp_u);
if(type_v != NCL_double) NclFree(tmp_v);
if(type_lat != NCL_double) NclFree(tmp_lat);
if(type_lon != NCL_double) NclFree(tmp_lon);
if(type_div != NCL_double) NclFree(tmp_div);
if(type_div == NCL_double) {
return(NclReturnValue(div,ndims_u,dsizes_u,&missing_du,type_div,0));
}
else {
return(NclReturnValue(div,ndims_u,dsizes_u,&missing_ru,type_div,0));
}
}
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));
}
}
NhlErrorTypes round_W( void )
{
/*
* Input array variables
*/
void *x;
double *tmp_x;
int has_missing_x, ndims_x;
ng_size_t dsizes_x[NCL_MAX_DIMENSIONS];
int *iopt, isx;
NclScalar missing_x, missing_dx, missing_xout;
NclBasicDataTypes type_x;
/*
* Output array variables
*/
void *xout = NULL;
double *tmp_xout;
NclBasicDataTypes type_xout = NCL_none;
/*
* Declare various variables for random purposes.
*/
ng_size_t i, size_x;
/*
* Retrieve argument.
*/
x = (void*)NclGetArgValue(
0,
2,
&ndims_x,
dsizes_x,
&missing_x,
&has_missing_x,
&type_x,
DONT_CARE);
/*
* Retrieve iopt. Currently, the value of iopt specifies the following:
*
* 0 -> depending on input, return float or double
* 1 -> send the output back as float
* 2 -> send the output back as double
* 3 -> send the output back as integer
*/
iopt = (int*)NclGetArgValue(
1,
2,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
if(*iopt < 0 || *iopt > 3) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"round: 'iopt' can only have the values 0-3");
return(NhlFATAL);
}
/*
* Compute the total size of the input array.
*/
size_x = 1;
for( i = 0; i < ndims_x; i++ ) size_x *= dsizes_x[i];
if(size_x > INT_MAX) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"round: size_x = %ld is greater than INT_MAX", size_x);
return(NhlFATAL);
}
isx = (int) size_x;
/*
* Coerce input and missing value to double if necessary.
*/
tmp_x = coerce_input_double(x,type_x,size_x,0,NULL,NULL);
coerce_missing(type_x,has_missing_x,&missing_x,&missing_dx,NULL);
/*
* The type of the output array depends on iopt and possibly the
* type of the input.
*/
switch(*iopt) {
case 0:
if(type_x != NCL_double) {
type_xout = NCL_float;
}
else {
type_xout = NCL_double;
}
break;
case 1:
type_xout = NCL_float;
break;
case 2:
type_xout = NCL_double;
break;
case 3:
type_xout = NCL_int;
break;
}
/*
* Allocate memory for output.
*/
switch(type_xout) {
case NCL_double:
xout = (void*)calloc(size_x,sizeof(double));
break;
case NCL_float:
xout = (void*)calloc(size_x,sizeof(float));
break;
case NCL_int:
xout = (void*)calloc(size_x,sizeof(int));
break;
default:
break;
}
/*
* Allocate space for temporary output which must be double. If the output
* is already double, then just point tmp_xout to xout.
*/
if(type_xout == NCL_double) {
tmp_xout = (double*)xout;
}
else {
tmp_xout = (double*)calloc(size_x,sizeof(double));
}
if(tmp_xout == NULL || xout == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"round: Unable to allocate memory for output arrays");
return(NhlFATAL);
}
/*
* Call the Fortran version of this routine.
*/
NGCALLF(rndncl,RNDNCL)(&isx,tmp_x,&has_missing_x,
&missing_dx.doubleval,tmp_xout,iopt);
/*
* Figure out if we need to coerce output back to float or int.
*/
if(type_xout == NCL_float) {
coerce_output_float_only(xout,tmp_xout,size_x,0);
}
if(type_xout == NCL_int) {
coerce_output_int_only(xout,tmp_xout,size_x,0);
}
/*
* Return correct missing value type for output.
*/
switch(type_xout) {
case NCL_double:
missing_xout.doubleval = missing_dx.doubleval;
break;
case NCL_float:
missing_xout.floatval = (float)missing_dx.doubleval;
break;
case NCL_int:
missing_xout.intval = (int)missing_dx.doubleval;
break;
default:
break;
}
/*
* Free memory.
*/
if(type_x != NCL_double) NclFree(tmp_x);
if(type_xout != NCL_double) NclFree(tmp_xout);
/*
* Return.
*/
if(has_missing_x) {
return(NclReturnValue(xout,ndims_x,dsizes_x,&missing_xout,type_xout,0));
}
else{
return(NclReturnValue(xout,ndims_x,dsizes_x,NULL,type_xout,0));
}
}
NhlErrorTypes area_conserve_remap_W( void )
{
/*
* Input variables
*/
/*
* Argument # 0
*/
void *loni;
double *tmp_loni;
ng_size_t dsizes_loni[1];
NclBasicDataTypes type_loni;
/*
* Argument # 1
*/
void *lati;
double *tmp_lati;
ng_size_t dsizes_lati[1];
NclBasicDataTypes type_lati;
/*
* Argument # 2
*/
void *fi;
double *tmp_fi = NULL;
int ndims_fi;
ng_size_t dsizes_fi[NCL_MAX_DIMENSIONS];
int has_missing_fi;
NclScalar missing_fi, missing_flt_fi, missing_dbl_fi;
NclBasicDataTypes type_fi;
/*
* Argument # 3
*/
void *lono;
double *tmp_lono;
ng_size_t dsizes_lono[1];
NclBasicDataTypes type_lono;
/*
* Argument # 4
*/
void *lato;
double *tmp_lato;
ng_size_t dsizes_lato[1];
NclBasicDataTypes type_lato;
/*
* Argument # 5
*/
logical *opt;
/*
* Return variable
*/
void *fo;
double *tmp_fo;
ng_size_t *dsizes_fo;
NclBasicDataTypes type_fo;
/*
* Various
*/
ng_size_t nloni, nlati, nlevi, nlono, nlato, nlevnlatnloni, nlevnlatnlono;
ng_size_t NLATi, NLATo, i;
int ret;
double *bin_factor = NULL;
logical set_binf;
NclBasicDataTypes type_bin_factor;
/*
* Variables for retrieving attributes from "opt".
*/
NclAttList *attr_list;
NclAtt attr_obj;
NclStackEntry stack_entry;
/*
* Variables for coercing input dimension sizes to integer.
*/
int inlono, inlato, iNLATo, iNLATi, inloni, inlati, inlevi;
/*
* 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
*/
loni = (void*)NclGetArgValue(
0,
6,
NULL,
dsizes_loni,
NULL,
NULL,
&type_loni,
DONT_CARE);
nloni = dsizes_loni[0];
/*
* Get argument # 1
*/
lati = (void*)NclGetArgValue(
1,
6,
NULL,
dsizes_lati,
NULL,
NULL,
&type_lati,
DONT_CARE);
nlati = dsizes_lati[0];
/*
* Get argument # 2
*/
fi = (void*)NclGetArgValue(
2,
6,
&ndims_fi,
dsizes_fi,
&missing_fi,
&has_missing_fi,
&type_fi,
DONT_CARE);
/*
* Check dimension sizes.
*/
if(ndims_fi < 2) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_conserve_remap: The fi array must have at least 2 dimensions");
return(NhlFATAL);
}
/*
* Coerce missing value to double if necessary.
*/
coerce_missing(type_fi,has_missing_fi,&missing_fi,
&missing_dbl_fi,&missing_flt_fi);
if(dsizes_fi[ndims_fi-2] != nlati || dsizes_fi[ndims_fi-1] != nloni) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_conserve_remap: The rightmost two dimension of fi must be nlat x nlon");
return(NhlFATAL);
}
/*
* Get argument # 3
*/
lono = (void*)NclGetArgValue(
3,
6,
NULL,
dsizes_lono,
NULL,
NULL,
&type_lono,
DONT_CARE);
nlono = dsizes_lono[0];
/*
* Get argument # 4
*/
lato = (void*)NclGetArgValue(
4,
6,
NULL,
dsizes_lato,
NULL,
NULL,
&type_lato,
DONT_CARE);
nlato = dsizes_lato[0];
/*
* Get argument # 5
*/
opt = (logical*)NclGetArgValue(
5,
6,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Check for the following attributes attached to "opt":
* NLATi
* NLATo
* bin_factor
*
* If not found, then use default values, which are set here.
* "bin_factor" will be set later.
*/
NLATi = nlati;
NLATo = nlato;
set_binf = False;
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 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) {
/*
* NLATi
*/
if ((strcmp(attr_list->attname, "NLATi")) == 0) {
if(attr_list->attvalue->multidval.data_type != NCL_int) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"area_conserve_remap: The 'NLATi' attribute must be an integer, defaulting to nlati.");
}
else {
NLATi = *(int*) attr_list->attvalue->multidval.val;
}
}
/*
* NLATo
*/
if ((strcmp(attr_list->attname, "NLATo")) == 0) {
if(attr_list->attvalue->multidval.data_type != NCL_int) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"area_conserve_remap: The 'Nlato' attribute must be an integer, defaulting to nlato.");
}
else {
NLATo = *(int*) attr_list->attvalue->multidval.val;
}
}
/*
* bin_factor
*/
if(!strcmp(attr_list->attname, "bin_factor")) {
type_bin_factor = attr_list->attvalue->multidval.data_type;
bin_factor = coerce_input_double(attr_list->attvalue->multidval.val,
type_bin_factor,1,0,NULL,NULL);
set_binf = True;
}
attr_list = attr_list->next;
}
}
default:
break;
}
}
if(!set_binf) {
bin_factor = (double *)calloc(1,sizeof(double));
*bin_factor = 1.0;
}
/*
* Calculate size of leftmost dimensions and fi/fo.
*/
nlevi = 1;
for(i = 0; i < ndims_fi-2; i++) nlevi *= dsizes_fi[i];
/*
* Test input dimension sizes to make sure they are <= INT_MAX.
*/
if((nlono > INT_MAX) ||
(nlato > INT_MAX) ||
(NLATi > INT_MAX) ||
(NLATo > INT_MAX) ||
(nloni > INT_MAX) ||
(nlati > INT_MAX) ||
(nlevi > INT_MAX)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_conserve_remap: One of the input array dimension sizes is greater than INT_MAX");
return(NhlFATAL);
}
inlono = (int) nlono;
inlato = (int) nlato;
iNLATo = (int) NLATo;
iNLATi = (int) NLATi;
inloni = (int) nloni;
inlati = (int) nlati;
inlevi = (int) nlevi;
nlevnlatnloni = nlevi * nlati * nloni; /* input array size */
nlevnlatnlono = nlevi * nlato * nlono; /* output array size */
/*
* 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_loni.
*/
tmp_loni = coerce_input_double(loni,type_loni,nloni,0,NULL,NULL);
if(tmp_loni == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_conserve_remap: Unable to allocate memory for coercing input array to double");
return(NhlFATAL);
}
/*
* Allocate space for tmp_lati.
*/
tmp_lati = coerce_input_double(lati,type_lati,nlati,0,NULL,NULL);
if(tmp_lati == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_conserve_remap: Unable to allocate memory for coercing input array to double");
return(NhlFATAL);
}
/*
* Allocate space for tmp_fi and determine type of output.
*
* The output type defaults to float, unless fi is double.
*/
if(type_fi != NCL_double) {
type_fo = NCL_float;
}
else {
type_fo = NCL_double;
}
/*
* Coerce input to double if necessary.
*/
tmp_fi = coerce_input_double(fi,type_fi,nlevnlatnloni,0,NULL,NULL);
if(tmp_fi == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_conserve_remap: Unable to allocate memory for coercing fi to double");
return(NhlFATAL);
}
/*
* Allocate space for tmp_lono.
*/
tmp_lono = coerce_input_double(lono,type_lono,nlono,0,NULL,NULL);
if(tmp_lono == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_conserve_remap: Unable to allocate memory for coercing lono to double");
return(NhlFATAL);
}
/*
* Allocate space for tmp_lato.
*/
tmp_lato = coerce_input_double(lato,type_lato,nlato,0,NULL,NULL);
if(tmp_lato == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_conserve_remap: Unable to allocate memory for coercing lato to double");
return(NhlFATAL);
}
/*
* Allocate space for output array.
*/
if(type_fo != NCL_double) {
fo = (void *)calloc(nlevnlatnlono, sizeof(float));
tmp_fo = (double *)calloc(nlevnlatnlono,sizeof(double));
if(fo == NULL || tmp_fo == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_conserve_remap: Unable to allocate memory for output array");
return(NhlFATAL);
}
}
else {
fo = (void *)calloc(nlevnlatnlono, sizeof(double));
if(fo == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_conserve_remap: Unable to allocate memory for output array");
return(NhlFATAL);
}
tmp_fo = fo;
}
/*
* Allocate space for output dimension sizes and set them.
*/
dsizes_fo = (ng_size_t*)calloc(ndims_fi,sizeof(ng_size_t));
if( dsizes_fo == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_conserve_remap: Unable to allocate memory for holding dimension sizes");
return(NhlFATAL);
}
for(i = 0; i < ndims_fi-2; i++) dsizes_fo[i] = dsizes_fi[i];
dsizes_fo[ndims_fi-2] = nlato;
dsizes_fo[ndims_fi-1] = nlono;
/*
* Call the Fortran routine.
*/
NGCALLF(cremapbin,CREMAPBIN)(&inlevi, &inlato, &inlono, &inlati, &inloni,
tmp_fi, tmp_fo, tmp_lati, tmp_loni, tmp_lato,
tmp_lono, &iNLATi, &iNLATo, bin_factor,
&missing_dbl_fi.doubleval);
if (!set_binf || (set_binf && type_bin_factor != NCL_double)) {
free(bin_factor);
}
/*
* Coerce output back to float if necessary.
*/
if(type_fo == NCL_float) {
coerce_output_float_only(fo,tmp_fo,nlevnlatnlono,0);
}
/*
* Free unneeded memory.
*/
if(type_loni != NCL_double) NclFree(tmp_loni);
if(type_lati != NCL_double) NclFree(tmp_lati);
if(type_fi != NCL_double) NclFree(tmp_fi);
if(type_lono != NCL_double) NclFree(tmp_lono);
if(type_lato != NCL_double) NclFree(tmp_lato);
if(type_fo != NCL_double) NclFree(tmp_fo);
/*
* Return value back to NCL script.
*/
ret = NclReturnValue(fo,ndims_fi,dsizes_fo,NULL,type_fo,0);
NclFree(dsizes_fo);
return(ret);
}
NhlErrorTypes covcorm_xy_W( void )
{
/*
* Input array variables
*/
void *x, *y;
int *iopt;
double *dx, *dy;
ng_size_t dsizes_x[NCL_MAX_DIMENSIONS], dsizes_y[NCL_MAX_DIMENSIONS];
int ndims_x, has_missing_x, ndims_y, has_missing_y;
NclScalar missing_x, missing_dx, missing_y, missing_dy;
ng_size_t size_x, nvar, ntim;
int invar, intim;
NclBasicDataTypes type_x, type_y;
/*
* Output array variable
*/
void *vcm;
double *dvcm;
ng_size_t *dsizes_vcm;
int ndims_vcm, ret;
ng_size_t size_vcm;
NclBasicDataTypes type_vcm;
NclScalar missing_vcm;
/*
* Retrieve x.
*/
x = (void*)NclGetArgValue(
0,
3,
&ndims_x,
dsizes_x,
&missing_x,
&has_missing_x,
&type_x,
DONT_CARE);
y = (void*)NclGetArgValue(
1,
3,
&ndims_y,
dsizes_y,
&missing_y,
&has_missing_y,
&type_y,
DONT_CARE);
iopt = (int*)NclGetArgValue(
2,
3,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
nvar = dsizes_x[0];
ntim = dsizes_x[1];
if(dsizes_y[0] != nvar || dsizes_y[1] != ntim) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"covcorm_xy: x and y must be the same size");
return(NhlFATAL);
}
size_x = nvar * ntim;
/*
* Test dimension sizes to make sure they are <= INT_MAX.
*/
if((ntim > INT_MAX) || (nvar > INT_MAX)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"covcorm_xy: one or more dimension sizes are greater than INT_MAX");
return(NhlFATAL);
}
intim = (int) ntim;
invar = (int) nvar;
/*
* Coerce missing values, if any.
*/
coerce_missing(type_x,has_missing_x,&missing_x,&missing_dx,NULL);
coerce_missing(type_y,has_missing_y,&missing_y,&missing_dy,NULL);
/*
* Allocate space for input/output arrays.
*/
size_vcm = nvar*nvar;
ndims_vcm = 2;
dsizes_vcm = (ng_size_t*)malloc(2*sizeof(ng_size_t));
dsizes_vcm[0] = nvar;
dsizes_vcm[1] = nvar;
dx = coerce_input_double(x,type_x,size_x,0,NULL,NULL);
dy = coerce_input_double(y,type_y,size_x,0,NULL,NULL);
if(type_x == NCL_double || type_y == NCL_double) {
type_vcm = NCL_double;
vcm = (void*)malloc(size_vcm*sizeof(double));
if(vcm == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"covcorm_xy: Unable to allocate memory for output array");
return(NhlFATAL);
}
dvcm = &((double*)vcm)[0];
missing_vcm.doubleval = ((NclTypeClass)nclTypedoubleClass)->type_class.default_mis.doubleval;
}
else {
type_vcm = NCL_float;
vcm = (void*)malloc(size_vcm*sizeof(float));
dvcm = (double*)malloc(size_vcm*sizeof(double));
if(vcm == NULL || dvcm == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"covcorm_xy: Unable to allocate memory for output array");
return(NhlFATAL);
}
missing_vcm.floatval = ((NclTypeClass)nclTypefloatClass)->type_class.default_mis.floatval;
}
/*
* Call the fortran routine.
* iopt(0) --> iopt
* iopt(1) --> lag
* iopt(2) --> ncrit
*/
NGCALLF(dcovarxy,DCOVARXY)(dx,dy,&missing_dx.doubleval,
&missing_dy.doubleval,dvcm,&intim,&invar,
&iopt[1],&iopt[2],&iopt[0]);
/* Coerce to float if necessary */
if(type_vcm == NCL_float) coerce_output_float_only(vcm,dvcm,size_vcm,0);
/* Free memory */
if(type_x != NCL_double) NclFree(dx);
if(type_y != NCL_double) NclFree(dy);
if(type_vcm != NCL_double) NclFree(dvcm);
/* Return */
ret = NclReturnValue(vcm,ndims_vcm,dsizes_vcm,&missing_vcm,type_vcm,0);
NclFree(dsizes_vcm);
return(ret);
}
NhlErrorTypes dim_spi_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
*/
int *nrun;
/*
* Argument # 2
*/
logical *opt;
/*
* Variables for retrieving attributes from "opt".
*/
NclAttList *attr_list;
NclAtt attr_obj;
NclStackEntry stack_entry;
int spi_type=0;
/*
* Argument # 3
*/
int *dims;
ng_size_t dsizes_dims;
/*
* Return variable
*/
void *spi;
double *tmp_spi;
NclScalar missing_spi;
NclBasicDataTypes type_spi;
/*
* Various
*/
ng_size_t ntim;
int intim, max_years, max_years_p1, ier, ret;
ng_size_t index_x, index_nrx;
ng_size_t i, j, nrnx, total_nr, total_nl, size_output;
/*
* Various work arrays for spi_type=3 case .
*/
double *probne, *pcpacc, *spi3_y, *spi3_x, *tmparr, *dindex;
/*
* 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);
/*
* Get argument # 1
*/
nrun = (int*)NclGetArgValue(
1,
4,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Get argument # 2
*/
opt = (logical*)NclGetArgValue(
2,
4,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Check for attributes attached to "opt"
*
* "spi_type" 0
*/
if(*opt) {
stack_entry = _NclGetArg(2, 4, 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.
*/
while (attr_list != NULL) {
if(!strcasecmp(attr_list->attname, "spi_type")) {
spi_type = *(int *) attr_list->attvalue->multidval.val;
}
attr_list = attr_list->next;
}
default:
break;
}
}
}
if(spi_type != 0 && spi_type != 3) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_spi_n: spi_type can only be 0 (default) or 3 (Pearson type III distribution");
return(NhlFATAL);
}
/*
* Coerce missing value to double if necessary.
*/
coerce_missing(type_x,has_missing_x,&missing_x,
&missing_dbl_x,&missing_flt_x);
/*
* Get dimension(s) to do computation on.
*/
dims = (int*)NclGetArgValue(
3,
4,
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_spi_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_spi_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 (ntim).
*
* 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 = ntim = 1;
if(ndims_x > 1) {
for(i = 0; i < dims[0] ; i++) {
total_nl = total_nl*dsizes_x[i];
}
for(i = 0; i < dsizes_dims ; i++) {
ntim = ntim*dsizes_x[dims[i]];
}
for(i = dims[dsizes_dims-1]+1; i < ndims_x; i++) {
total_nr = total_nr*dsizes_x[i];
}
} else {
ntim = dsizes_x[dims[0]];
}
size_output = total_nl * ntim * total_nr;
if( ntim > INT_MAX) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_spi_n: ntim is greater than INT_MAX");
return(NhlFATAL);
}
intim = (int) ntim;
/*
* Allocate space for tmp_x and tmp_index.
*/
tmp_x = (double *)calloc(ntim,sizeof(double));
if(tmp_x == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_spi_n: Unable to allocate memory for coercing input array to double");
return(NhlFATAL);
}
/*
* Allocate space for output array.
*/
tmp_spi = (double *)calloc(ntim, sizeof(double));
if(type_x != NCL_double) {
type_spi = NCL_float;
spi = (void *)calloc(size_output, sizeof(float));
}
else {
type_spi = NCL_double;
spi = (void *)calloc(size_output, sizeof(double));
}
if(tmp_spi == NULL || spi == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_spi_n: Unable to allocate memory for output array");
return(NhlFATAL);
}
if(has_missing_x) {
if(type_spi == NCL_double) missing_spi = missing_dbl_x;
else missing_spi = missing_flt_x;
}
/*
* As of NCL V6.3.0, if spi_type == 3, the SPI will be calculated
* using the Pearson type III distribution. The Fortran routine
* for this requires a bunch of work arrays.
*/
if(spi_type == 3) {
if(ntim % 12) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_spi_n: if opt@spi_type= 3, then ntim must be divisable by 12");
return(NhlFATAL);
}
max_years = intim / 12;
max_years_p1 = max_years+1;
probne = (double *)calloc(ntim, sizeof(double));
pcpacc = (double *)calloc(ntim, sizeof(double));
dindex = (double *)calloc(ntim, sizeof(double));
spi3_y = (double *)calloc(ntim, sizeof(double));
spi3_x = (double *)calloc(max_years, sizeof(double));
tmparr = (double *)calloc(max_years_p1, sizeof(double));
if(probne == NULL || pcpacc == NULL || dindex == NULL ||
spi3_y == NULL || spi3_x == NULL || tmparr == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_spi_n: Unable to allocate memory for temporary work arrays");
return(NhlFATAL);
}
}
/*
* Loop across leftmost dimensions and call the Fortran routine for each
* subsection of the input arrays.
*/
nrnx = total_nr * ntim;
for(i = 0; i < total_nl; i++) {
index_nrx = i*nrnx;
for(j = 0; j < total_nr; j++) {
index_x = index_nrx + j;
/*
* Coerce subsection of x (tmp_x) to double.
*/
coerce_subset_input_double_step(x,tmp_x,index_x,total_nr,type_x,
ntim,0,NULL,NULL);
/*
* Call the Fortran routine.
*/
if(spi_type == 0) {
NGCALLF(spigamd,SPIGAMD)(&intim, tmp_x, &missing_dbl_x.doubleval,
nrun, tmp_spi);
}
else if(spi_type == 3) {
NGCALLF(spi3ncdc, SPI3NCDC)(&intim,tmp_x,&missing_dbl_x.doubleval,
nrun,tmp_spi,probne,pcpacc,dindex,
spi3_y, spi3_x, tmparr,&max_years,
&max_years_p1,&ier);
}
/*
* Coerce output back to float or double
*/
coerce_output_float_or_double_step(spi,tmp_spi,type_spi,ntim,
index_x,total_nr);
}
}
/*
* Free unneeded memory.
*/
NclFree(tmp_x);
NclFree(tmp_spi);
if(spi_type == 3) {
NclFree(probne);
NclFree(pcpacc);
NclFree(dindex);
NclFree(spi3_y);
NclFree(spi3_x);
NclFree(tmparr);
}
/*
* Return value back to NCL script.
*/
if(has_missing_x) {
ret = NclReturnValue(spi,ndims_x,dsizes_x,&missing_spi,type_spi,0);
}
else {
ret = NclReturnValue(spi,ndims_x,dsizes_x,NULL,type_spi,0);
}
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 isnan_ieee_W( void )
{
/*
* Input array variables
*/
void *x;
int ndims_x;
ng_size_t dsizes_x[NCL_MAX_DIMENSIONS];
NclBasicDataTypes type_x;
/*
* Output array variables
*/
logical *isnan;
/*
* Declare various variables for random purposes.
*/
ng_size_t i, size_x;
/*
* Retrieve argument.
*/
x = (void*)NclGetArgValue(
0,
1,
&ndims_x,
dsizes_x,
NULL,
NULL,
&type_x,
DONT_CARE);
if(type_x != NCL_float && type_x != NCL_double) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"isnan_ieee: the input must be of type float or double");
return(NhlFATAL);
}
/*
* Compute the total size of the input array.
*/
size_x = 1;
for( i = 0; i < ndims_x; i++ ) size_x *= dsizes_x[i];
isnan = (logical*)calloc(size_x,sizeof(logical));
/*
* A poor man's test for NaN: if the number is not less than or equal to
* 0 or greater than or equal to zero, then it must be NaN.
*/
if(type_x == NCL_float) {
for(i = 0; i < size_x; i++) {
if( ((float*)x)[i] <= 0. || ((float*)x)[i] >= 0. ) {
isnan[i] = False;
}
else {
isnan[i] = True;
}
}
}
else {
for(i = 0; i < size_x; i++) {
if( ((double*)x)[i] <= 0. || ((double*)x)[i] >= 0. ) {
isnan[i] = False;
}
else {
isnan[i] = True;
}
}
}
/*
* Return.
*/
return(NclReturnValue(isnan,ndims_x,dsizes_x,NULL,NCL_logical,0));
}
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 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 linint1_n_W( void )
{
/*
* Input variables
*/
void *xi, *fi, *xo;
double *tmp_xi, *tmp_xo,*tmp_fi, *tmp_fo;
int ndims_xi;
ng_size_t dsizes_xi[NCL_MAX_DIMENSIONS], dsizes_xo[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, missing_fo;
int *dim, *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, nd, nr, nl, nrnxi, nrnxo, ntotal, size_fo;
int inxi, inxi2, inxo, ier, ret;
ng_size_t i, j, index_nri, index_nro, 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,
6,
&ndims_xi,
dsizes_xi,
NULL,
NULL,
&type_xi,
DONT_CARE);
fi = (void*)NclGetArgValue(
1,
6,
&ndims_fi,
dsizes_fi,
&missing_fi,
&has_missing_fi,
&type_fi,
DONT_CARE);
wrap = (logical*)NclGetArgValue(
2,
6,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
xo = (void*)NclGetArgValue(
3,
6,
NULL,
dsizes_xo,
NULL,
NULL,
&type_xo,
DONT_CARE);
opt = (int*)NclGetArgValue(
4,
6,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
dim = (int*)NclGetArgValue(
5,
6,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Some error checking. Make sure input dimension is valid.
*/
if(*dim < 0 || *dim >= ndims_fi) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1_n: Invalid dimension to do interpolation on, can't continue");
return(NhlFATAL);
}
/*
* Compute the total number of elements in our arrays and check them.
*/
nxi = dsizes_fi[*dim];
nxo = dsizes_xo[0];
nfo = nxo;
nxi2 = nxi + 2;
if(nxi < 2) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1_n: 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_n: 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 dims-th dimension of
* fi must be equal to the length of xi.
*/
if(ndims_xi > 1) {
if(ndims_xi != ndims_fi) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1_n: 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_n: If xi is not one-dimensional, then it must be the same size as fi");
return(NhlFATAL);
}
}
}
else {
if(dsizes_xi[0] != nxi) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1_n: The dim-th dimension of fi must be the same length as xi");
return(NhlFATAL);
}
}
/*
* Calculate size of leftmost dimensions (nl) up to the dim-th
* dimension.
* Calculate size of rightmost dimensions (nr) from the
* dim-th dimension.
*
* The dimension to do the interpolation across is "dim".
*/
nl = nr = 1;
if(ndims_fi > 1) {
nd = ndims_fi-1;
for(i = 0; i < *dim ; i++) {
nl = nl*dsizes_fi[i];
}
for(i = *dim+1; i < ndims_fi; i++) {
nr = nr*dsizes_fi[i];
}
}
else {
nd = 1;
}
ntotal = nr * nl;
size_fo = ntotal * 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_n: 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_n: Unable to allocate memory for output array");
return(NhlFATAL);
}
/*
* Go ahead and copy all dimesions, but then replace the dim-th one.
*/
for(i = 0; i < ndims_fi; i++) dsizes_fo[i] = dsizes_fi[i];
dsizes_fo[*dim] = 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_n: 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_n: Unable to coerce output array to double precision");
return(NhlFATAL);
}
if(ndims_xi == 1) {
tmp_xi = coerce_input_double(xi,type_xi,nxi,0,NULL,NULL);
}
else {
tmp_xi = (double*)calloc(nxi,sizeof(double));
if(tmp_xi == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1_n: Unable to allocate memory for coercing input array to double precision");
return(NhlFATAL);
}
}
tmp_fi = (double*)calloc(nxi,sizeof(double));
if(tmp_fi == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1_n: Unable to allocate memory for coercing input array to double precision");
return(NhlFATAL);
}
/*
* Loop through leftmost and rightmost dimensions and call Fortran
* routine for each array subsection.
*/
nrnxi = nr*nxi;
nrnxo = nr*nxo;
for( i = 0; i < nl; i++ ) {
index_nri = i*nrnxi;
index_nro = i*nrnxo;
for( j = 0; j < nr; j++ ) {
index_fi = index_nri+j;
index_fo = index_nro+j;
if(ndims_xi > 1) {
coerce_subset_input_double_step(xi,tmp_xi,index_fi,nr,type_xi,
nxi,0,NULL,NULL);
}
coerce_subset_input_double_step(fi,tmp_fi,index_fi,nr,type_fi,
nxi,0,NULL,NULL);
/*
* Call Fortran routine.
*/
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_n: xi and xo must be monotonically increasing");
set_subset_output_missing_step(fo,index_fo,nr,type_fo,nfo,
missing_dfi.doubleval);
}
else {
coerce_output_float_or_double_step(fo,tmp_fo,type_fi,nfo,index_fo,nr);
}
}
}
/*
* Free temp arrays.
*/
if(ndims_xi > 1 || type_xi != NCL_double) NclFree(tmp_xi);
if(type_xo != NCL_double) NclFree(tmp_xo);
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 rdsstoi_W( void )
{
/*
* Input array variables
*/
int *nyrstrt, *nyrlast, *mlon, *nlat, *info;
/*
* Output array variables
*/
float *sstoi;
int ndims_sstoi = 2;
ng_size_t dsizes_sstoi[2] = {180,360};
/*
* Retrieve parameters
*
* Note any of the pointer parameters can be set to NULL, which
* implies you don't care about its value.
*/
nyrstrt = (int*)NclGetArgValue(
0,
5,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
nyrlast = (int*)NclGetArgValue(
1,
5,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
mlon= (int*)NclGetArgValue(
2,
5,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
nlat= (int*)NclGetArgValue(
3,
5,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
info = (int*)NclGetArgValue(
4,
5,
NULL,
NULL,
NULL,
NULL,
NULL,
1);
/*
* Allocate space for output array.
*/
sstoi = (float*)NclMalloc(360*180*sizeof(float));
if( sstoi == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"rdsstoi: Unable to allocate memory for output array");
return(NhlFATAL);
}
NGCALLF(rdsstoi,RDSSTOI)(nyrstrt,nyrlast,mlon,nlat,info,sstoi);
return(NclReturnValue((void*)sstoi,ndims_sstoi,dsizes_sstoi,NULL,NCL_float,0));
}
NhlErrorTypes ut_calendar_W( void )
{
/*
* Input array variables
*/
void *x;
double *tmp_x;
NrmQuark *sspec = NULL;
char *cspec, *cspec_orig;
int *option;
int ndims_x;
ng_size_t dsizes_x[NCL_MAX_DIMENSIONS];
int has_missing_x;
NclScalar missing_x, missing_dx;
NclBasicDataTypes type_x;
/*
* Variables for calculating fraction of year, if the option is 4.
*/
int doy, nsid, total_seconds_in_year, seconds_in_doy, seconds_in_hour;
int seconds_in_minute;
double current_seconds_in_year, fraction_of_year;
/*
* Variables for retrieving attributes from the first argument.
*/
NclAttList *attr_list;
NclAtt attr_obj;
NclStackEntry stack_entry;
NrmQuark *scal;
char *ccal = NULL;
/*
* Variables for Udunits package.
*/
ut_system *utopen_ncl(), *unit_system;
ut_unit *utunit;
/*
* Output variables.
*/
int year, month, day, hour, minute;
double second;
void *date = NULL;
int ndims_date = 0;
ng_size_t *dsizes_date;
NclScalar missing_date;
NclBasicDataTypes type_date = NCL_none;
NclObjClass type_date_t = NCL_none;
/*
* Variables for returning "calendar" attribute.
*/
int att_id;
NclQuark *calendar;
NclMultiDValData att_md, return_md;
NclVar tmp_var;
NclStackEntry return_data;
/*
* various
*/
int ret, return_missing;
ng_size_t dsizes[1];
ng_size_t i, total_size_x;
ng_size_t total_size_date = 0;
ng_size_t index_date;
int months_to_days_fix=0, years_to_days_fix=0;
extern float truncf(float);
/*
* Before we do anything, initialize the Udunits package.
*/
unit_system = utopen_ncl();
/*
* 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,
2,
&ndims_x,
dsizes_x,
&missing_x,
&has_missing_x,
&type_x,
DONT_CARE);
/*
* Get option.
*/
option = (int*)NclGetArgValue(
1,
2,
NULL,
NULL,
NULL,
NULL,
NULL,
1);
/*
* The "units" attribute of "time" must be set, otherwise missing
* values will be returned.
*
* The "calendar" option may optionally be set, but it must be equal to
* one of the recognized calendars.
*/
return_missing = 0;
stack_entry = _NclGetArg(0, 2, 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) {
return_missing = 1;
break;
}
}
else {
/*
* att_id == -1 ==> no attributes specified; return all missing.
*/
return_missing = 1;
break;
}
/*
* Check for attributes. If none are specified, then return missing values.
*/
if (attr_obj->att.n_atts == 0) {
return_missing = 1;
break;
}
else {
/*
* Get list of attributes.
*/
attr_list = attr_obj->att.att_list;
/*
* Loop through attributes and check them.
*/
while (attr_list != NULL) {
if ((strcmp(attr_list->attname, "calendar")) == 0) {
scal = (NrmQuark *) attr_list->attvalue->multidval.val;
ccal = NrmQuarkToString(*scal);
if(strcasecmp(ccal,"standard") && strcasecmp(ccal,"gregorian") &&
strcasecmp(ccal,"noleap") && strcasecmp(ccal,"365_day") &&
strcasecmp(ccal,"365") && strcasecmp(ccal,"360_day") &&
strcasecmp(ccal,"360") ) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"ut_calendar: the 'calendar' attribute is not equal to a recognized calendar. Returning all missing values.");
return_missing = 1;
}
}
if ((strcmp(attr_list->attname, "units")) == 0) {
sspec = (NrmQuark *) attr_list->attvalue->multidval.val;
}
attr_list = attr_list->next;
}
}
default:
break;
}
/*
* Convert sspec to character string.
*/
if(sspec == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ut_calendar: no 'units' attribute provided");
return(NhlFATAL);
}
cspec = NrmQuarkToString(*sspec);
/*
* There's a bug in utInvCalendar2_cal that doesn't handle the
* 360-day calendar correctly if units are "years since" or
* "months since".
*
* To fix this bug, we convert these units to "days since", do the
* calculation as "days since", and then convert back to the original
* "years since" or "months since" requested units.
*/
cspec_orig = (char*)calloc(strlen(cspec)+1,sizeof(char));
strcpy(cspec_orig,cspec);
cspec = fix_units_for_360_bug(ccal,cspec,&months_to_days_fix,
&years_to_days_fix);
/*
* Make sure cspec is a valid udunits string.
*/
utunit = ut_parse(unit_system, cspec, UT_ASCII);
if(utunit == NULL) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"ut_calendar: Invalid specification string. Missing values will be returned.");
return_missing = 1;
}
/*
* Calculate size of input array.
*/
total_size_x = 1;
for( i = 0; i < ndims_x; i++ ) total_size_x *= dsizes_x[i];
/*
* Calculate size and dimensions for output array, and allocate
* memory for output array. The output size will vary depending
* on what option the user has specified. Only options -5 to 4
* are currently recognized. (option = -4 doesn't exist.)
*/
if(*option < -5 || *option > 4 || *option == -4) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"ut_calendar: Unknown option, defaulting to 0.");
*option = 0;
}
if(*option == 0) {
type_date = NCL_float;
type_date_t = nclTypefloatClass;
total_size_date = 6 * total_size_x;
missing_date = ((NclTypeClass)nclTypefloatClass)->type_class.default_mis;
ndims_date = ndims_x + 1;
date = (float *)calloc(total_size_date,sizeof(float));
}
else if(*option == -5) {
/* identical to option=0, except returns ints */
type_date = NCL_int;
type_date_t = nclTypeintClass;
total_size_date = 6 * total_size_x;
missing_date = ((NclTypeClass)nclTypeintClass)->type_class.default_mis;
ndims_date = ndims_x + 1;
date = (int *)calloc(total_size_date,sizeof(int));
}
else if(*option >= 1 && *option <= 4) {
type_date = NCL_double;
type_date_t = nclTypedoubleClass;
total_size_date = total_size_x;
missing_date = ((NclTypeClass)nclTypedoubleClass)->type_class.default_mis;
ndims_date = ndims_x;
date = (double *)calloc(total_size_date,sizeof(double));
}
else if(*option >= -3 && *option <= -1) {
type_date = NCL_int;
type_date_t = nclTypeintClass;
total_size_date = total_size_x;
missing_date = ((NclTypeClass)nclTypeintClass)->type_class.default_mis;
ndims_date = ndims_x;
date = (int *)calloc(total_size_date,sizeof(int));
}
dsizes_date = (ng_size_t *)calloc(ndims_date,sizeof(ng_size_t));
/*
* Make sure we have enough memory for output.
*/
if( date == NULL || dsizes_date == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ut_calendar: Unable to allocate memory for output arrays");
return(NhlFATAL);
}
/*
* Calculate output dimension sizes.
*/
for( i = 0; i < ndims_x; i++ ) dsizes_date[i] = dsizes_x[i];
if(*option == 0 || *option == -5) {
dsizes_date[ndims_x] = 6;
}
/*
* Coerce missing values to double.
*/
coerce_missing(type_x,has_missing_x,&missing_x,&missing_dx,NULL);
/*
* If we reach this point and return_missing is not 0, then either
* "units" was invalid or wasn't set, or "calendar" was not a
* recoginized calendar. We return all missing values in this case.
*/
if(return_missing) {
if(*option == 0) {
for(i = 0; i < total_size_date; i++ ) {
((float*)date)[i] = missing_date.floatval;
}
}
else if(*option == -5) {
/* identical to option=0, except returns ints */
for(i = 0; i < total_size_date; i++ ) {
((int*)date)[i] = missing_date.intval;
}
}
else if(*option >= 1 && *option <= 4) {
for(i = 0; i < total_size_date; i++ ) {
((double*)date)[i] = missing_date.doubleval;
}
}
else if(*option >= -3 && *option <= -1) {
for(i = 0; i < total_size_date; i++ ) {
((int*)date)[i] = missing_date.intval;
}
}
/*
* Return all missing values.
*/
ret = NclReturnValue(date,ndims_date,dsizes_date,
&missing_date,type_date,0);
NclFree(dsizes_date);
return(ret);
}
/*
* Convert input to double if necessary.
*/
tmp_x = coerce_input_double(x,type_x,total_size_x,has_missing_x,&missing_x,
&missing_dx);
/*
* This is the bug fix for 360 day calendars and a units
* of "years since" or "months since". We have to convert
* from "years since" or "months since" to "days since".
*
* See above for more information about the bug.
*/
if(years_to_days_fix == 1) {
for(i = 0; i < total_size_x; i++ ) tmp_x[i] *= 360.;
}
if(months_to_days_fix == 1) {
for(i = 0; i < total_size_x; i++ ) tmp_x[i] *= 30.;
}
/*
* Loop through each element and get the 6 values.
*/
index_date = 0;
for( i = 0; i < total_size_x; i++ ) {
if(!has_missing_x ||
(has_missing_x && tmp_x[i] != missing_dx.doubleval)) {
(void) utCalendar2_cal(tmp_x[i],utunit,&year,&month,&day,
&hour,&minute,&second,ccal);
/*
* Calculate the return values, based on the input option.
*/
switch(*option) {
case 0:
((float*)date)[index_date] = (float)year;
((float*)date)[index_date+1] = (float)month;
((float*)date)[index_date+2] = (float)day;
((float*)date)[index_date+3] = (float)hour;
((float*)date)[index_date+4] = (float)minute;
((float*)date)[index_date+5] = second;
break;
/* identical to option=0, except returns ints */
case -5:
((int*)date)[index_date] = year;
((int*)date)[index_date+1] = month;
((int*)date)[index_date+2] = day;
((int*)date)[index_date+3] = hour;
((int*)date)[index_date+4] = minute;
((int*)date)[index_date+5] = (int)truncf(second);
break;
/*
* YYYYMM
*/
case -1:
((int*)date)[index_date] = (100*year) + month;
break;
case 1:
((double*)date)[index_date] = (double)(100*year) + (double)month;
break;
/*
* YYYYMMDD
*/
case -2:
((int*)date)[index_date] = (10000*year) + (100*month) + day;
break;
case 2:
((double*)date)[index_date] = (double)(10000*year)
+ (double)(100*month)
+ (double)day;
break;
/*
* YYYYMMDDHH
*/
case -3:
((int*)date)[index_date] = (1000000*year) + (10000*month)
+ (100*day) + hour;
break;
case 3:
((double*)date)[index_date] = (double)(1000000*year)
+ (double)(10000*month)
+ (double)(100*day)
+ (double)hour;
break;
/*
* YYYY.fraction_of_year
*/
case 4:
nsid = 86400; /* num seconds in a day */
if(ccal == NULL) {
total_seconds_in_year = seconds_in_year(year,"standard");
doy = day_of_year(year,month,day,"standard");
}
else {
total_seconds_in_year = seconds_in_year(year,ccal);
doy = day_of_year(year,month,day,ccal);
}
if(doy > 1) {
seconds_in_doy = (doy-1) * nsid;
}
else {
seconds_in_doy = 0;
}
if(hour > 1) {
seconds_in_hour = (hour-1) * 3600;
}
else {
seconds_in_hour = 0;
}
if(minute > 1) {
seconds_in_minute = (minute-1) * 60;
}
else {
seconds_in_minute = 0;
}
current_seconds_in_year = seconds_in_doy +
seconds_in_hour +
seconds_in_minute +
second;
fraction_of_year = current_seconds_in_year/(double)total_seconds_in_year;
((double*)date)[index_date] = (double)year + fraction_of_year;
break;
}
}
else {
switch(*option) {
case 0:
((float*)date)[index_date] = missing_date.floatval;
((float*)date)[index_date+1] = missing_date.floatval;
((float*)date)[index_date+2] = missing_date.floatval;
((float*)date)[index_date+3] = missing_date.floatval;
((float*)date)[index_date+4] = missing_date.floatval;
((float*)date)[index_date+5] = missing_date.floatval;
break;
/* identical to option=0, except returns ints */
case -5:
((int*)date)[index_date] = missing_date.intval;
((int*)date)[index_date+1] = missing_date.intval;
((int*)date)[index_date+2] = missing_date.intval;
((int*)date)[index_date+3] = missing_date.intval;
((int*)date)[index_date+4] = missing_date.intval;
((int*)date)[index_date+5] = missing_date.intval;
break;
case 1:
case 2:
case 3:
case 4:
((double*)date)[index_date] = missing_date.doubleval;
break;
case -1:
case -2:
case -3:
((int*)date)[index_date] = missing_date.intval;
break;
}
}
if(*option == 0 || *option == -5) {
index_date += 6;
}
else {
index_date++;
}
}
/*
* Free the work arrays.
*/
if(type_x != NCL_double) NclFree(tmp_x);
/*
* Close up Udunits.
*/
utclose_ncl(unit_system);
/*
* Free extra units
*/
NclFree(cspec_orig);
ut_free(utunit);
/*
* Set up variable to return.
*/
if(has_missing_x) {
return_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
date,
&missing_date,
ndims_date,
dsizes_date,
TEMPORARY,
NULL,
type_date_t
);
}
else {
return_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
date,
NULL,
ndims_date,
dsizes_date,
TEMPORARY,
NULL,
type_date_t
);
}
/*
* Set up attributes to return.
*/
att_id = _NclAttCreate(NULL,NULL,Ncl_Att,0,NULL);
dsizes[0] = 1;
/*
* Return "calendar" attribute.
*
* We can't just return "scal" here, because it's an NCL input
* parameter and this seems to screw things up if we try to
* return it as an attribute.
*/
calendar = (NclQuark*)NclMalloc(sizeof(NclQuark));
if(ccal != NULL) {
*calendar = NrmStringToQuark(ccal);
}
else {
*calendar = NrmStringToQuark("standard");
}
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
(void*)calendar,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
(NclObjClass)nclTypestringClass
);
_NclAddAtt(
att_id,
"calendar",
att_md,
NULL
);
tmp_var = _NclVarCreate(
NULL,
NULL,
Ncl_Var,
0,
NULL,
return_md,
NULL,
att_id,
NULL,
RETURNVAR,
NULL,
TEMPORARY
);
NclFree(dsizes_date);
/*
* 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);
}
