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 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 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 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 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 dim_sum_wgt_n_W( void )
{
/*
* Input variables
*/
/*
* Argument # 0
*/
void *x;
double *tmp_x;
int ndims_x;
ng_size_t dsizes_x[NCL_MAX_DIMENSIONS];
int has_missing_x;
NclScalar missing_x, missing_flt_x, missing_dbl_x;
NclBasicDataTypes type_x;
/*
* Argument # 1
*/
void *w;
double *tmp_w;
ng_size_t dsizes_w[1];
NclBasicDataTypes type_w;
/*
* Argument # 2
*/
int *opt;
/*
* Argument # 3
*/
int *narg;
/*
* Return variable
*/
void *xavg;
double tmp_xavg[1];
int ndims_xavg;
ng_size_t *dsizes_xavg;
NclBasicDataTypes type_xavg;
/*
* Various
*/
int inx, ret;
ng_size_t nx, nrnx, index_x, index_nrx, index_nr, index_out;
ng_size_t i, j, total_nl, total_nr, size_output;
/*
* Retrieve parameters.
*
* Note any of the pointer parameters can be set to NULL, which
* implies you don't care about its value.
*/
/*
* Get argument # 0
*/
x = (void*)NclGetArgValue(
0,
4,
&ndims_x,
dsizes_x,
&missing_x,
&has_missing_x,
&type_x,
DONT_CARE);
/*
* Coerce missing value to double if necessary.
*/
coerce_missing(type_x,has_missing_x,&missing_x,
&missing_dbl_x,&missing_flt_x);
/*
* Get argument # 1
*/
w = (void*)NclGetArgValue(
1,
4,
NULL,
dsizes_w,
NULL,
NULL,
&type_w,
DONT_CARE);
/*
* Get argument # 2
*/
opt = (int*)NclGetArgValue(
2,
4,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Get argument # 3
*/
narg = (int*)NclGetArgValue(
3,
4,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Some error checking. Make sure input dimension is valid.
*/
if(*narg < 0 || *narg >= ndims_x) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_sum_wgt_n: Invalid dimension argument, can't continue");
return(NhlFATAL);
}
/*
* Test input dimension size.
*/
nx = dsizes_x[*narg];
if(nx > INT_MAX) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_sum_wgt_n: nx = %ld is greater than INT_MAX", nx);
return(NhlFATAL);
}
inx = (int) nx;
if(dsizes_w[0] != nx) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_sum_wgt_n: w must be length nx");
return(NhlFATAL);
}
/*
* Calculate size of all but narg dimensions and
* allocate space for output dimension sizes and set them.
*/
ndims_xavg = max(ndims_x-1,1);
dsizes_xavg = (ng_size_t*)calloc(ndims_xavg,sizeof(ng_size_t));
if( dsizes_xavg == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_sum_wgt_n: Unable to allocate memory for holding dimension sizes");
return(NhlFATAL);
}
total_nl = total_nr = size_output = 1;
if(ndims_x==1) { /* Handles case where x is 1D */
dsizes_xavg[0] = 1;
}
else {
for(i = 0; i < *narg; i++) {
total_nl *= dsizes_x[i];
dsizes_xavg[i] = dsizes_x[i];
}
for(i = *narg+1; i < ndims_x; i++) {
total_nr *= dsizes_x[i];
dsizes_xavg[i-1] = dsizes_x[i];
}
}
size_output = total_nr * total_nl;
/*
* Allocate space for coercing input arrays. We need to make a copy
* here, because the x values are not necessary consecutive, and
* hence we can't just point to the original array.
*/
/*
* Allocate space for tmp_x.
*/
tmp_x = (double *)calloc(nx,sizeof(double));
if(tmp_x == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_sum_wgt_n: Unable to allocate memory for coercing input array to double");
return(NhlFATAL);
}
/*
* The output type defaults to float, unless this input array is double.
*/
if(type_x == NCL_double) {
type_xavg = NCL_double;
}
else {
type_xavg = NCL_float;
}
/*
* Allocate space for output array.
*/
if(type_xavg != NCL_double) {
xavg = (void *)calloc(size_output, sizeof(float));
}
else {
xavg = (void *)calloc(size_output, sizeof(double));
}
if(xavg == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_sum_wgt_n: Unable to allocate memory for output array");
return(NhlFATAL);
}
/*
* Allocate space for tmp_w.
*/
tmp_w = coerce_input_double(w,type_w,nx,0,NULL,NULL);
if(tmp_w == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_sum_wgt_n: Unable to allocate memory for coercing input array to double");
return(NhlFATAL);
}
/*
* Loop across all but the narg-th dimension and call the Fortran routine
* for each one-dimensional subsection.
*/
nrnx = total_nr * nx;
for(i = 0; i < total_nl; i++) {
index_nrx = i * nrnx;
index_nr = i * total_nr;
for(j = 0; j < total_nr; j++) {
index_out = index_nr + j;
index_x = index_nrx + j;
/*
* Coerce subsection of x (tmp_x) to double if necessary.
*/
coerce_subset_input_double_step(x,tmp_x,index_x,total_nr,type_x,
nx,0,NULL,NULL);
/*
* Call the Fortran routine.
*/
NGCALLF(dimsumwgt,DIMSUMWGT)(&inx, tmp_x, &missing_dbl_x.doubleval,
tmp_w, opt, &tmp_xavg[0]);
/*
* Coerce output back to float or double.
*/
coerce_output_float_or_double(xavg,&tmp_xavg[0],type_x,1,index_out);
}
}
/*
* Free unneeded memory.
*/
NclFree(tmp_x);
if(type_w != NCL_double) NclFree(tmp_w);
/*
* Return value back to NCL script.
*/
if(has_missing_x) {
if(type_xavg == NCL_double) {
ret = NclReturnValue(xavg,ndims_xavg,dsizes_xavg,&missing_dbl_x,
type_xavg,0);
}
else {
ret = NclReturnValue(xavg,ndims_xavg,dsizes_xavg,&missing_flt_x,
type_xavg,0);
}
}
else {
ret = NclReturnValue(xavg,ndims_xavg,dsizes_xavg,NULL,type_xavg,0);
}
NclFree(dsizes_xavg);
return(ret);
}
NhlErrorTypes 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 *optspi;
/*
* 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, ret;
ng_size_t index_x, index_nrx;
ng_size_t i, j, nrnx, total_nr, total_nl, size_output;
/*
* Retrieve parameters.
*
* Note any of the pointer parameters can be set to NULL, which
* implies you don't care about its value.
*/
/*
* Get argument # 0
*/
x = (void*)NclGetArgValue(
0,
4,
&ndims_x,
dsizes_x,
&missing_x,
&has_missing_x,
&type_x,
DONT_CARE);
/*
* Get argument # 1
*/
nrun = (int*)NclGetArgValue(
1,
4,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Get argument # 2
*/
optspi = (logical*)NclGetArgValue(
2,
4,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Coerce missing value to double if necessary.
*/
coerce_missing(type_x,has_missing_x,&missing_x,
&missing_dbl_x,&missing_flt_x);
/*
* Get 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;
}
/*
* 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.
*/
NGCALLF(spigamd,SPIGAMD)(&intim, tmp_x, &missing_dbl_x.doubleval,
nrun, tmp_spi);
/*
* 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);
/*
* 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);
}
