main()
{
int unit = 1;
char *string = "wooga";
NGCALLF(opnwks,OPNWKS)(&unit);
NGCALLF(wrtwks,WRTWKS)(&unit, (int *)string);
NGCALLF(clswks,CLSWKS)(&unit);
}
int c_shgetnp(float px, float py, float pz, int n,
float x[], float y[], float z[], int iflag, int *ier)
{
static float *rwk;
static int *iwk;
int np;
/*
* Allocate workspace arrays.
*/
if (iflag == 0) {
rwk = (float *) calloc(11*n+6, sizeof(float));
if (rwk == NULL) {
printf("Unable to allocate float work space in c_shgetnp\n");
*ier = 304;
return((int) NULL);
}
iwk = (int *) calloc(2*n, sizeof(int));
if (iwk == NULL) {
printf("Unable to allocate int work space in c_shgetnp\n");
*ier = 305;
return((int) NULL);
}
}
NGCALLF(shgetnp,SHGETNP)(&px, &py, &pz, &n, x, y, z, &iflag, iwk, rwk,
&np, ier);
/*
* Adjust the Fortran index for C and return.
*/
return(np-1);
}
NhlErrorTypes tditri_W( void )
{
float *u, *v, *w, *f, *fiso, *rtri;
ng_size_t nu, nv, nw, mtri;
int inu, inv, inw, *ntri, imtri, *irst;
ng_size_t dsizes_u[1];
ng_size_t dsizes_v[1];
ng_size_t dsizes_w[1];
ng_size_t dsizes_f[3];
ng_size_t dsizes_rtri[2];
/*
* Retrieve parameters.
*/
u = (float*)NclGetArgValue( 0,8,NULL,dsizes_u,NULL,NULL,NULL,DONT_CARE);
v = (float*)NclGetArgValue( 1,8,NULL,dsizes_v,NULL,NULL,NULL,DONT_CARE);
w = (float*)NclGetArgValue( 2,8,NULL,dsizes_w,NULL,NULL,NULL,DONT_CARE);
f = (float*)NclGetArgValue( 3,8,NULL,dsizes_f,NULL,NULL,NULL,DONT_CARE);
fiso = (float*)NclGetArgValue( 4,8,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
rtri = (float*)NclGetArgValue( 5,8,NULL,dsizes_rtri,NULL,NULL,NULL,DONT_CARE);
ntri = (int*)NclGetArgValue( 6,8,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
irst = (int*)NclGetArgValue( 7,8,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
mtri = dsizes_rtri[0];
if(dsizes_rtri[1] != 10) {
NhlPError(NhlFATAL, NhlEUNKNOWN, "tditri: the second dimension of ntri must be 10");
return(NhlFATAL);
}
nu = dsizes_u[0];
nv = dsizes_v[0];
nw = dsizes_w[0];
if(dsizes_f[0] != nw || dsizes_f[1] != nv || dsizes_f[2] != nu) {
NhlPError(NhlFATAL, NhlEUNKNOWN, "tditri: the dimensions of f must be nw x nv x nu");
return(NhlFATAL);
}
/*
* Test dimension sizes.
*/
if((nu > INT_MAX) || (nv > INT_MAX) || (nw > INT_MAX) || (mtri > INT_MAX)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"tditri: one or more input arrays sizes is greater than INT_MAX");
return(NhlFATAL);
}
inu = (int) nu;
inv = (int) nv;
inw = (int) nw;
imtri = (int) mtri;
NGCALLF(tditri,TDITRI)(u,&inu,v,&inv,w,&inw,f,&inu,&inv,fiso,rtri,&imtri,
ntri,irst);
if(*ntri == imtri) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"tditri: triangle list overflow");
return(NhlFATAL);
}
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);
}
void c_strset
#ifdef NeedFuncProto
(
void
)
#else
()
#endif
{
NGCALLF(strset,STRSET)();
}
void c_shseti(char *pnam, int ival)
{
NGstring pnam2;
int len;
/*
* Make sure parameter name is not NULL
*/
if ( !pnam ) {
fprintf( stderr, "c_shseti: illegal parameter name (NULL)\n");
return;
}
len = NGSTRLEN(pnam);
pnam2 = NGCstrToFstr(pnam,len);
NGCALLF(shseti,SHSETI)(pnam,&ival,len);
}
int c_shgeti(char *pnam)
{
NGstring pnam2;
int len,ivp;
/*
* Make sure parameter name is not NULL
*/
if ( !pnam ) {
fprintf( stderr, "c_shgeti: illegal parameter name (NULL)\n");
return(-1);
}
len = NGSTRLEN(pnam);
pnam2 = NGCstrToFstr(pnam,len);
NGCALLF(shgeti,SHGETI)(pnam2,&ivp,len);
return(ivp);
}
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);
}
void c_reset()
{
NGCALLF(reset,RESET)();
}
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 dim_gamfit_n_W( void )
{
/*
* Input variables
*/
/*
* Argument # 0
*/
void *x;
double *tmp_x;
int ndims_x;
ng_size_t dsizes_x[NCL_MAX_DIMENSIONS];
int has_missing_x;
NclScalar missing_x, missing_flt_x, missing_dbl_x;
NclBasicDataTypes type_x;
/*
* Argument # 1
*/
logical *optgam;
/*
* Argument # 2
*/
int *dims;
ng_size_t dsizes_dims;
/*
* Return variable
*/
void *xpar;
int ndims_xpar;
ng_size_t *dsizes_xpar;
NclScalar missing_xpar;
NclBasicDataTypes type_xpar;
/*
* Variables for retrieving attributes from "optgam";
*/
NclAttList *attr_list;
NclAtt attr_obj;
NclStackEntry stack_entry;
/*
* Various
*/
ng_size_t npts;
int inpts;
ng_size_t index_x, index_xpar, index_nrx, index_nr;
double *pcrit = NULL;
logical set_pcrit;
double alpha, scale, shape, pzero;
int inv_scale, ier, ret;
ng_size_t i, j, nrnx, total_nr, total_nl, total_nlnr, size_output;
/*
* Retrieve parameters.
*
* Note any of the pointer parameters can be set to NULL, which
* implies you don't care about its value.
*/
/*
* Get argument # 0
*/
x = (void*)NclGetArgValue(
0,
3,
&ndims_x,
dsizes_x,
&missing_x,
&has_missing_x,
&type_x,
DONT_CARE);
/*
* Get argument # 1
*/
optgam = (logical*)NclGetArgValue(
1,
3,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Get dimension(s) to do computation on.
*/
dims = (int*)NclGetArgValue(
2,
3,
NULL,
&dsizes_dims,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Some error checking. Make sure input dimensions are valid.
*/
for(i = 0; i < dsizes_dims; i++ ) {
if(dims[i] < 0 || dims[i] >= ndims_x) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_gamfit_n: Invalid dimension sizes to do calculations across, can't continue");
return(NhlFATAL);
}
if(i > 0 && dims[i] != (dims[i-1]+1)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_gamfit_n: Input dimension sizes must be monotonically increasing, can't continue");
return(NhlFATAL);
}
}
/*
* Calculate size of leftmost dimensions (nl) up to the dims[0]-th
* dimensions.
*
* Calculate number of points that will be passed to Fortran
* routine (npts).
*
* Calculate size of rightmost dimensions (nr) from the
* ndims[ndims-1]-th dimension.
*
* The dimension(s) to do the calculations across are "dims".
*/
total_nl = total_nr = npts = 1;
if(ndims_x > 1) {
ndims_xpar = ndims_x-dsizes_dims+1;
dsizes_xpar = NclMalloc(ndims_xpar * sizeof(ng_size_t));
dsizes_xpar[0] = 3;
for(i = 0; i < dims[0] ; i++) {
total_nl = total_nl*dsizes_x[i];
dsizes_xpar[i+1] = dsizes_x[i];
}
for(i = 0; i < dsizes_dims ; i++) {
npts = npts*dsizes_x[dims[i]];
}
for(i = dims[dsizes_dims-1]+1; i < ndims_x; i++) {
total_nr = total_nr*dsizes_x[i];
dsizes_xpar[i-dsizes_dims+1] = dsizes_x[i];
}
} else {
dsizes_xpar = NclMalloc(sizeof(ng_size_t));
*dsizes_xpar = 3;
ndims_xpar = 1;
npts = dsizes_x[dims[0]];
}
total_nlnr = total_nl * total_nr;
size_output = 3 * total_nlnr;
if( npts > INT_MAX) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_gamfit_n: npts is greater than INT_MAX");
return(NhlFATAL);
}
inpts = (int) npts;
/*
* Allocate space for tmp_x.
*/
tmp_x = (double *)calloc(npts,sizeof(double));
if(tmp_x == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_gamfit_n: Unable to allocate memory for coercing input array to double");
return(NhlFATAL);
}
/*
* Coerce missing value to double if necessary.
*/
coerce_missing(type_x,has_missing_x,&missing_x,
&missing_dbl_x,&missing_flt_x);
/*
* Allocate space for output array.
*/
if(type_x != NCL_double) {
type_xpar = NCL_float;
xpar = (void *)calloc(size_output, sizeof(float));
}
else {
type_xpar = NCL_double;
xpar = (void *)calloc(size_output, sizeof(double));
}
if(xpar == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_gamfit_n: Unable to allocate memory for output array");
return(NhlFATAL);
}
if(has_missing_x) {
if(type_xpar == NCL_double) missing_xpar = missing_dbl_x;
else missing_xpar = missing_flt_x;
}
/*
* Retrieve attributes from optgam, if any.
*/
set_pcrit = False;
inv_scale = 0;
if(*optgam) {
stack_entry = _NclGetArg(1, 3, DONT_CARE);
switch (stack_entry.kind) {
case NclStk_VAR:
if (stack_entry.u.data_var->var.att_id != -1) {
attr_obj = (NclAtt) _NclGetObj(stack_entry.u.data_var->var.att_id);
if (attr_obj == NULL) {
break;
}
}
else {
/*
* att_id == -1 ==> no attributes specified.
*/
break;
}
/*
* Check for attributes. If none are set, then use default values.
*/
if (attr_obj->att.n_atts == 0) {
break;
}
else {
/*
* Get list of attributes.
*/
attr_list = attr_obj->att.att_list;
/*
* Loop through attributes and check them.
*/
while (attr_list != NULL) {
/*
* pcrit
*/
if ((strcmp(attr_list->attname, "pcrit")) == 0) {
pcrit = coerce_input_double(attr_list->attvalue->multidval.val,
attr_list->attvalue->multidval.data_type,
1,0,NULL,NULL);
set_pcrit = True;
}
/*
* inv_scale
*/
if ((strcmp(attr_list->attname, "inv_scale")) == 0) {
if(attr_list->attvalue->multidval.data_type != NCL_logical) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"dim_gamfit_n: the 'inv_scale' attribute must be a logical, defaulting to False.");
}
else if(*(logical*)attr_list->attvalue->multidval.val) {
inv_scale = 1;
}
}
attr_list = attr_list->next;
}
}
default:
break;
}
}
if(!set_pcrit) {
pcrit = (double *)calloc(1,sizeof(double));
*pcrit = 0.0;
}
/*
* Loop across leftmost dimensions and call the Fortran routine for each
* subsection of the input arrays.
*/
nrnx = total_nr * npts;
for(i = 0; i < total_nl; i++) {
index_nrx = i*nrnx;
index_nr = i*total_nr;
for(j = 0; j < total_nr; j++) {
index_x = index_nrx + j;
index_xpar = index_nr + j;
/*
* Coerce subsection of x (tmp_x) to double.
*/
coerce_subset_input_double_step(x,tmp_x,index_x,total_nr,type_x,
npts,0,NULL,NULL);
/*
* Call the Fortran routine.
*/
NGCALLF(gamfitd3,GAMFITD3)(tmp_x, &inpts, &missing_dbl_x.doubleval,
pcrit, &inv_scale, &alpha, &scale,
&shape, &pzero, &ier);
/*
* Coerce output back to float or double
*/
coerce_output_float_or_double(xpar,&shape,type_xpar,1,index_xpar);
coerce_output_float_or_double(xpar,&scale,type_xpar,1,
index_xpar+total_nlnr);
coerce_output_float_or_double(xpar,&pzero,type_xpar,1,
index_xpar+(2*total_nlnr));
}
}
/*
* Free unneeded memory.
*/
NclFree(tmp_x);
/*
* Return value back to NCL script.
*/
if(has_missing_x) {
ret = NclReturnValue(xpar,ndims_xpar,dsizes_xpar,&missing_xpar,
type_xpar,0);
}
else {
ret = NclReturnValue(xpar,ndims_xpar,dsizes_xpar,NULL,type_xpar,0);
}
NclFree(dsizes_xpar);
return(ret);
}
NhlErrorTypes ezfftf_W( void )
{
/*
* Input array variables
*/
void *x;
int ndims_x;
ng_size_t dsizes_x[NCL_MAX_DIMENSIONS];
NclBasicDataTypes type_x;
NclScalar missing_x, missing_dx, missing_rx, missing_cf;
int has_missing_x;
double *tmp_x = NULL;
/*
* Output array variables
*/
void *cf, *xbar;
int ndims_cf;
ng_size_t dsizes_cf[NCL_MAX_DIMENSIONS];
double *tmp_cf1, *tmp_cf2, *tmp_xbar;
NclBasicDataTypes type_cf;
NclTypeClass type_cf_class;
/*
* Attribute variables
*/
void *N;
int att_id;
ng_size_t dsizes[1];
NclMultiDValData att_md, return_md;
NclVar tmp_var;
NclStackEntry return_data;
/*
* various
*/
double *work;
ng_size_t index_x, index_cf1, index_cf2;
ng_size_t i, npts, npts2, lnpts2, npts22;
int found_missing, any_missing;
ng_size_t size_leftmost, size_cf;
int inpts;
/*
* Retrieve parameters
*
* Note any of the pointer parameters can be set to NULL, which
* implies you don't care about its value.
*/
x = (void*)NclGetArgValue(
0,
1,
&ndims_x,
dsizes_x,
&missing_x,
&has_missing_x,
&type_x,
DONT_CARE);
/*
* Calculate number of leftmost elements.
*/
size_leftmost = 1;
for( i = 0; i < ndims_x-1; i++ ) size_leftmost *= dsizes_x[i];
/*
* Test input array size
*/
npts = dsizes_x[ndims_x-1];
if(npts > INT_MAX) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ezfftf: npts = %d is greater than INT_MAX", npts);
return(NhlFATAL);
}
inpts = (int) npts;
/*
* Calculate size of output array.
*/
if((npts % 2) == 0) {
npts2 = npts/2;
}
else {
npts2 = (npts-1)/2;
}
lnpts2 = npts2 * size_leftmost;
npts22 = 2*npts2;
size_cf = size_leftmost * npts22;
ndims_cf = ndims_x + 1;
dsizes_cf[0] = 2;
for(i = 1; i < ndims_x; i++ ) dsizes_cf[i] = dsizes_x[i-1];
dsizes_cf[ndims_x] = npts2;
/*
* Coerce missing values.
*/
coerce_missing(type_x,has_missing_x,&missing_x,&missing_dx,&missing_rx);
/*
* Create space for temporary input array if necessary.
*/
if(type_x != NCL_double) {
tmp_x = (double*)calloc(npts,sizeof(double));
if(tmp_x == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ezfftf: Unable to allocate memory for coercing input array to double precision");
return(NhlFATAL);
}
}
/*
* Allocate space for output arrays.
*/
tmp_xbar = (double*)calloc(1,sizeof(double));
tmp_cf1 = (double*)calloc(npts2,sizeof(double));
tmp_cf2 = (double*)calloc(npts2,sizeof(double));
if ( tmp_cf1 == NULL || tmp_cf2 == NULL || tmp_xbar == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ezfftf: Cannot allocate memory for temporary output arrays" );
return(NhlFATAL);
}
if(type_x == NCL_double) {
cf = (void*)calloc(size_cf,sizeof(double));
xbar = (void*)calloc(size_leftmost,sizeof(double));
type_cf = NCL_double;
if(has_missing_x) missing_cf = missing_dx;
}
else {
cf = (void*)calloc(size_cf,sizeof(float));
xbar = (void*)calloc(size_leftmost,sizeof(float));
type_cf = NCL_float;
if(has_missing_x) missing_cf = missing_rx;
}
N = (void*)calloc(1,sizeof(int));
if ( cf == NULL || xbar == NULL || N == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ezfftf: Cannot allocate memory for output arrays" );
return(NhlFATAL);
}
/*
* Allocate memory for work array
*/
work = (double*)calloc((4*npts+15),sizeof(double));
if ( work == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ezfftf: Cannot allocate memory for work array" );
return(NhlFATAL);
}
/*
* Call the f77 version of 'dezfftf' with the full argument list.
*/
index_x = 0;
index_cf1 = 0;
index_cf2 = lnpts2;
any_missing = 0;
for(i = 0; i < size_leftmost; i++) {
if(type_x != NCL_double) {
coerce_subset_input_double(x,tmp_x,index_x,type_x,npts,0,NULL,NULL);
}
else {
tmp_x = &((double*)x)[index_x];
}
/*
* Check for missing values in x. If any, then coerce that section of
* the output to missing.
*/
found_missing = contains_missing(tmp_x,npts,has_missing_x,
missing_dx.doubleval);
if(found_missing) {
any_missing++;
set_subset_output_missing(xbar,i,type_cf,1,missing_dx.doubleval);
set_subset_output_missing(cf,index_cf1,type_cf,npts2,
missing_dx.doubleval);
set_subset_output_missing(cf,index_cf2,type_cf,npts2,
missing_dx.doubleval);
}
else {
NGCALLF(dezffti,DEZFFTI)(&inpts,work);
NGCALLF(dezfftf,DEZFFTF)(&inpts,tmp_x,tmp_xbar,tmp_cf1,tmp_cf2,work);
/*
* Copy results back into xbar and cf.
*/
coerce_output_float_or_double(xbar,tmp_xbar,type_cf,1,i);
coerce_output_float_or_double(cf,tmp_cf1,type_cf,npts2,index_cf1);
coerce_output_float_or_double(cf,tmp_cf2,type_cf,npts2,index_cf2);
}
index_x += npts;
index_cf1 += npts2;
index_cf2 += npts2;
}
/*
* Free up memory.
*/
if(type_x != NCL_double) free(tmp_x);
free(work);
free(tmp_cf1);
free(tmp_cf2);
free(tmp_xbar);
/*
* Set up variable to return.
*/
type_cf_class = (NclTypeClass)_NclNameToTypeClass(NrmStringToQuark(_NclBasicDataTypeToName(type_cf)));
/*
* Set up return values.
*/
if(any_missing) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"ezfftf: %d input arrays contained missing values. No calculations performed on these arrays.",any_missing);
return_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
cf,
&missing_cf,
ndims_cf,
dsizes_cf,
TEMPORARY,
NULL,
(NclObjClass)type_cf_class
);
}
else {
return_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
cf,
NULL,
ndims_cf,
dsizes_cf,
TEMPORARY,
NULL,
(NclObjClass)type_cf_class
);
}
/*
* Attributes "xbar" and "npts".
*/
att_id = _NclAttCreate(NULL,NULL,Ncl_Att,0,NULL);
dsizes[0] = size_leftmost;
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
xbar,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
(NclObjClass)type_cf_class
);
_NclAddAtt(
att_id,
"xbar",
att_md,
NULL
);
(*(int*)N) = npts;
dsizes[0] = 1;
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
N,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
(NclObjClass)nclTypeintClass
);
_NclAddAtt(
att_id,
"npts",
att_md,
NULL
);
/*
* Set up variable to hold return array and attributes.
*/
tmp_var = _NclVarCreate(
NULL,
NULL,
Ncl_Var,
0,
NULL,
return_md,
NULL,
att_id,
NULL,
RETURNVAR,
NULL,
TEMPORARY
);
/*
* Return output grid and attributes to NCL.
*/
return_data.kind = NclStk_VAR;
return_data.u.data_var = tmp_var;
_NclPlaceReturn(return_data);
return(NhlNOERROR);
}
float *c_shgrid(int n, float x[], float y[], float z[], float f[],
int nxo, int nyo, int nzo, float xo[], float yo[], float zo[],
int *ier)
{
float *uo, *rwk, *zor;
int *iwk, i, j, k;
/*
* Allocate space for returned output array.
*/
uo = (float *) calloc(nxo*nyo*nzo, sizeof(float));
if (uo == NULL) {
printf("Unable to allocate space for output in c_shgrid\n");
*ier = 300;
return((float *)NULL);
}
/*
* Allocate workspace arrays.
*/
rwk = (float *) calloc(11*n+6, sizeof(float));
if (rwk == NULL) {
printf("Unable to allocate float work space in c_shgrid\n");
*ier = 301;
return((float *)NULL);
}
iwk = (int *) calloc(2*n, sizeof(int));
if (iwk == NULL) {
printf("Unable to allocate int work space in c_shgrid\n");
*ier = 302;
return((float *)NULL);
}
NGCALLF(shgrid,SHGRID)(&n, x, y, z, f, &nxo, &nyo, &nzo, xo, yo, zo,
uo, iwk, rwk, ier);
free(rwk);
free(iwk);
/*
* Rearrange the uo array to be row dominant.
*/
zor = (float *) calloc(nxo*nyo*nzo, sizeof(float));
if (zor == NULL) {
printf("Unable to allocate temp space in c_shgrid\n");
*ier = 303;
return((float *)NULL);
}
for (i = 0; i < nxo; i++) {
for (j = 0; j < nyo; j++) {
for (k = 0; k < nzo; k++) {
zor[i*nzo*nyo + j*nzo + k] = uo[k*nxo*nyo + j*nxo + i];
}
}
}
free(uo);
return(zor);
}
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 tdttri_W( void )
{
float *ucra, *vcra, *wcra, *uvwmin, *uvwmax;
float *rmrk, *smrk, *rtri;
ng_size_t mtri, ncra;
int *imrk, *ntri, *irst, imtri, incra;
ng_size_t dsizes_rtri[2];
ng_size_t dsizes_ucra[1];
ng_size_t dsizes_vcra[1];
ng_size_t dsizes_wcra[1];
/*
* Retrieve parameters.
*/
ucra = (float*)NclGetArgValue( 0,11,NULL,dsizes_ucra,NULL,NULL,NULL,DONT_CARE);
vcra = (float*)NclGetArgValue( 1,11,NULL,dsizes_vcra,NULL,NULL,NULL,DONT_CARE);
wcra = (float*)NclGetArgValue( 2,11,NULL,dsizes_wcra,NULL,NULL,NULL,DONT_CARE);
imrk = (int*)NclGetArgValue( 3,11,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
rmrk = (float*)NclGetArgValue( 4,11,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
smrk = (float*)NclGetArgValue( 5,11,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
rtri = (float*)NclGetArgValue( 6,11,NULL,dsizes_rtri,NULL,NULL,NULL,DONT_CARE);
ntri = (int*)NclGetArgValue( 7,11,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
irst = (int*)NclGetArgValue( 8,11,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
uvwmin = (float*)NclGetArgValue( 9,11,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
uvwmax = (float*)NclGetArgValue(10,11,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
mtri = dsizes_rtri[0];
if(dsizes_rtri[1] != 10) {
NhlPError(NhlFATAL, NhlEUNKNOWN, "tdttri: the second dimension of ntri must be 10");
return(NhlFATAL);
}
ncra = dsizes_ucra[0];
if(dsizes_vcra[0] != ncra || dsizes_wcra[0] != ncra) {
NhlPError(NhlFATAL, NhlEUNKNOWN, "tdttri: ucra, vcra, and wcra must all be the same length");
return(NhlFATAL);
}
/*
* Test dimension sizes.
*/
if((mtri > INT_MAX) || (ncra > INT_MAX)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"tddtri: one or more input arrays sizes is greater than INT_MAX");
return(NhlFATAL);
}
imtri = (int) mtri;
incra = (int) ncra;
NGCALLF(tdttri,TDTTRI)(ucra, vcra, wcra, &incra, imrk, rmrk, smrk, rtri,
&imtri, ntri, irst,
&uvwmin[0], &uvwmin[1], &uvwmin[2],
&uvwmax[0], &uvwmax[1], &uvwmax[2]);
if(*ntri == imtri) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"tdttri: triangle list overflow");
return(NhlFATAL);
}
return(NhlNOERROR);
}
void c_agback()
{
NGCALLF(agback,AGBACK)();
}
NhlErrorTypes ctwrap_W( void )
{
int *wks;
float *lat, *lon, *data;
ng_size_t nlat, nlon, nlon8, dsizes_lat[2], dsizes_lon[2], dsizes_data[2];
int inlat, inlon, idim, jdim;
logical *opt;
/*
* Variables for retrieving workstation information.
*/
int grlist, gkswid, nwks;
NclHLUObj tmp_hlu_obj;
/*
* Work arrays.
*/
float *rpnt, *rwrk, *xcra, *ycra;
int *iedg, *itri, *ippp, *ippe, *iwrk, *icra, *iama, *iaai, *iagi;
int mpnt, medg, mtri, mnop, mnoe, mnot, lrwk, liwk, lama, ncra, ngps;
int icam, ican, lopn, loen, lotn;
/*
* Variables for retrieving attributes from "opt".
*/
logical idbg = False, igrd = False, imsh = False;
logical icon = True, icol = False, icap = False;
NrmQuark *MapProjection, *fnam;
char *cMapProjection, *cnam = NULL;
int imap = 2, ilev = -1, itim = -1;
NclAttList *attr_list;
NclAtt attr_obj;
NclStackEntry stack_entry;
/*
* Retrieve parameters.
*/
wks = (int*)NclGetArgValue(0,5, NULL, NULL,NULL,NULL,NULL,DONT_CARE);
lat = (float*)NclGetArgValue(1,5, NULL, dsizes_lat, NULL,NULL,NULL,DONT_CARE);
lon = (float*)NclGetArgValue(2,5, NULL, dsizes_lon, NULL,NULL,NULL,DONT_CARE);
data = (float*)NclGetArgValue(3,5, NULL, dsizes_data, NULL,NULL,NULL,DONT_CARE);
opt = (logical*)NclGetArgValue(4,5, NULL,NULL,NULL,NULL,NULL,DONT_CARE);
/*
* Check input sizes.
*/
nlat = dsizes_lat[0];
nlon = dsizes_lat[1];
if( dsizes_lon[0] != nlat || dsizes_lon[1] != nlon ||
dsizes_data[0] != nlat || dsizes_data[1] != nlon ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ctwrap: the dimension sizes of the lat/lon arrays and the data must be same");
return(NhlFATAL);
}
/*
* Hopefully the number of longitudes is divisible by 8 (the nature of the
* SEAM grid), so get that number here.
*/
nlon8 = nlon/8;
if ((nlat > INT_MAX) || (nlon > INT_MAX) || (nlon8 > INT_MAX)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ctwrap: one or more input dimension sizes is > INT_MAX");
return(NhlFATAL);
}
inlat = (int) nlat;
inlon = (int) nlon;
idim = jdim = (int) nlon8;
/*
* Determine the NCL identifier for the graphic object.
*/
tmp_hlu_obj = (NclHLUObj) _NclGetObj(*wks);
nwks = tmp_hlu_obj->hlu.hlu_id;
/*
* Retrieve the GKS workstation id from the workstation object.
*/
grlist = NhlRLCreate(NhlGETRL);
NhlRLClear(grlist);
NhlRLGetInteger(grlist,NhlNwkGksWorkId,&gkswid);
NhlGetValues(nwks,grlist);
/*
* Activate workstation.
*/
gactivate_ws (gkswid);
/*
* Create work arrays, lots of them.
*/
lopn = 5;
loen = 5;
lotn = 4;
mnop = 7352;
mnoe = 22050;
mnot = 14700;
lrwk = 10000;
liwk = 1000;
lama = 400000;
ncra = lama/10;
icam = 512; /* could be 1024? */
ican = 512; /* could be 1024? */
ngps = 2;
mpnt = mnop*lopn; /* space for points */
medg = mnoe*loen; /* space for edges */
mtri = mnot*lotn; /* space for triangles */
rpnt = (float *)calloc(mpnt,sizeof(float));
rwrk = (float *)calloc(lrwk,sizeof(float));
xcra = (float *)calloc(ncra,sizeof(float));
ycra = (float *)calloc(ncra,sizeof(float));
iwrk = (int *)calloc(liwk,sizeof(int));
iama = (int *)calloc(lama,sizeof(int));
iaai = (int *)calloc(ngps,sizeof(int));
iagi = (int *)calloc(ngps,sizeof(int));
icra = (int *)calloc(icam*ican,sizeof(int));
iedg = (int *)calloc(medg,sizeof(int));
itri = (int *)calloc(mtri,sizeof(int));
ippp = (int *)calloc(2*mnop,sizeof(int));
ippe = (int *)calloc(2*mnoe,sizeof(int));
if(rpnt == NULL || rwrk == NULL || xcra == NULL || ycra == NULL ||
iwrk == NULL || iama == NULL || iaai == NULL || iagi == NULL ||
icra == NULL || iedg == NULL || itri == NULL || ippp == NULL ||
ippe == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ctwrap: Unable to allocate memory for work arrays");
return(NhlFATAL);
}
/*
* If "opt" is True, then check if any attributes have been set.
*/
if(*opt) {
stack_entry = _NclGetArg(4, 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) {
break;
}
/*
* Get list of attributes.
*/
attr_list = attr_obj->att.att_list;
/*
* Loop through attributes and check them. The current ones recognized are:
*
* "RectangularMesh"
* "TriangularMesh"
* "LineContours"
* "FilledContours"
* "CellArray"
* "MapProjection"
* "FieldName"
* "TimeStep"
* "Level"
* "Debug"
*/
while (attr_list != NULL) {
/*
* Check for "RectangularGrid".
*/
if (!strcmp(attr_list->attname, "RectangularGrid")) {
if(attr_list->attvalue->multidval.data_type != NCL_logical) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"ctwrap: The 'RectangularGrid' attribute must be a logical, defaulting to False.");
}
else {
igrd = *(logical*) attr_list->attvalue->multidval.val;
}
}
/*
* Check for "TriangularMesh".
*/
if (!strcmp(attr_list->attname, "TriangularMesh")) {
if(attr_list->attvalue->multidval.data_type != NCL_logical) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"ctwrap: The 'TriangularMesh' attribute must be a logical, defaulting to False.");
}
else {
imsh = *(logical*) attr_list->attvalue->multidval.val;
}
}
/*
* Check for "LineContours".
*/
if (!strcmp(attr_list->attname, "LineContours")) {
if(attr_list->attvalue->multidval.data_type != NCL_logical) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"ctwrap: The 'LineContours' attribute must be a logical, defaulting to True.");
}
else {
icon = *(logical*) attr_list->attvalue->multidval.val;
}
}
/*
* Check for "FilledContours".
*/
if (!strcmp(attr_list->attname, "FilledContours")) {
if(attr_list->attvalue->multidval.data_type != NCL_logical) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"ctwrap: The 'FilledContours' attribute must be a logical, defaulting to False.");
}
else {
icol = *(logical*) attr_list->attvalue->multidval.val;
}
}
/*
* Check for "CellArray".
*/
if (!strcmp(attr_list->attname, "CellArray")) {
if(attr_list->attvalue->multidval.data_type != NCL_logical) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"ctwrap: The 'CellArray' attribute must be a logical, defaulting to False.");
}
else {
icap = *(logical*) attr_list->attvalue->multidval.val;
}
}
/*
* Check for "FieldName".
*/
if (!strcmp(attr_list->attname, "FieldName")) {
if(attr_list->attvalue->multidval.data_type != NCL_string) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"ctwrap: The 'FieldName' attribute must be a string, ignoring...");
}
else {
fnam = (NrmQuark *) attr_list->attvalue->multidval.val;
cnam = NrmQuarkToString(*fnam);
}
}
/*
* Check for "TimeStep".
*/
if (!strcmp(attr_list->attname, "TimeStep")) {
if(attr_list->attvalue->multidval.data_type != NCL_int) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"ctwrap: The 'TimeStep' attribute must be an integer, defaulting to -1.");
}
else {
itim = *(int*) attr_list->attvalue->multidval.val;
}
}
/*
* Check for "Level".
*/
if (!strcmp(attr_list->attname, "Level")) {
if(attr_list->attvalue->multidval.data_type != NCL_int) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"ctwrap: The 'Level' attribute must be an integer, defaulting to -1.");
}
else {
ilev = *(int*) attr_list->attvalue->multidval.val;
}
}
/*
* Check for "Debug".
*/
if (!strcmp(attr_list->attname, "Debug")) {
if(attr_list->attvalue->multidval.data_type != NCL_logical) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"ctwrap: The 'Debug' attribute must be a logical, defaulting to False.");
}
else {
idbg = *(logical*) attr_list->attvalue->multidval.val;
}
}
/*
* Check for "MapProjection".
*/
if (!strcmp(attr_list->attname, "MapProjection")) {
if(attr_list->attvalue->multidval.data_type != NCL_string) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"ctwrap: The 'MapProjection' attribute must be a string, defaulting to 'CylindricalEquidistant.'");
}
else {
MapProjection = (NrmQuark *) attr_list->attvalue->multidval.val;
cMapProjection = NrmQuarkToString(*MapProjection);
if(!strcmp(cMapProjection,"Orthographic")) {
imap = 1;
}
else if(!strcmp(cMapProjection,"CylindricalEquidistant")) {
imap = 2;
}
else if(!strcmp(cMapProjection,"Robinson")) {
imap = 3;
}
else if(!strcmp(cMapProjection,"LambertEqualArea")) {
imap = 4;
}
else {
NhlPError(NhlWARNING,NhlEUNKNOWN,"ctwrap: Unrecognized value for the 'MapProjection' attribute. Defaulting to 'CylindricalEquidistant'.");
imap = 2;
}
}
}
attr_list = attr_list->next;
}
default:
break;
}
}
if(cnam == NULL) {
cnam = (char*)calloc(2,sizeof(char));
strcpy(cnam,"");
}
NGCALLF(ctdriver,CTDRIVER)(&gkswid,lat,lon,data,&inlat,&inlon,&idim,&jdim,
rpnt,&mpnt,rwrk,&lrwk,xcra,ycra,&ncra,iwrk,
&liwk,iama,&lama,iaai,iagi,&ngps,icra,&icam,
&ican,iedg,&medg,itri,&mtri,ippp,&mnop,ippe,
&mnoe,&lopn,&loen,&lotn,&igrd,&imsh,&icon,&icol,
&icap,&imap,cnam,&itim,&ilev,&idbg,
strlen(cnam));
/*
* Free work arrays.
*/
NclFree(rpnt);
NclFree(rwrk);
NclFree(xcra);
NclFree(ycra);
NclFree(iwrk);
NclFree(iama);
NclFree(iaai);
NclFree(iagi);
NclFree(icra);
NclFree(iedg);
NclFree(itri);
NclFree(ippp);
NclFree(ippe);
/*
* Deactivate workstation.
*/
gdeactivate_ws (gkswid);
return(NhlNOERROR);
}
void c_gflas2()
{
NGCALLF(gflas2,GFLAS2)();
}
PyObject *fplib_regline(PyObject *self, PyObject *args)
{
PyObject *xar = NULL;
PyObject *yar = NULL;
PyArrayObject *arr = NULL;
double *x, *y;
double fill_value_x, fill_value_y;
int return_info;
/*
* Output variables
*/
double *rcoef, tval, rstd, xave, yave, yint;
int inpts, nptxy, ier = 0;
PyObject *pdict, *rc, *result;
npy_intp npts, dsizes_x[1], dsizes_y[1], dsizes_rcoef[1];
/*
* Retrieve arguments.
*/
if (!PyArg_ParseTuple(args, "OOddi:regline", &xar, &yar,
&fill_value_x, &fill_value_y, &return_info)) {
Py_INCREF(Py_None);
return Py_None;
}
/*
* Extract array information.
*/
arr = (PyArrayObject *) PyArray_ContiguousFromAny \
(xar,PyArray_DOUBLE,0,0);
x = (double *)arr->data;
dsizes_x[0] = arr->dimensions[0];
arr = (PyArrayObject *) PyArray_ContiguousFromAny \
(yar,PyArray_DOUBLE,0,0);
y = (double *)arr->data;
dsizes_y[0] = arr->dimensions[0];
/*
* The x and y arrays coming in must have the same length.
*/
if( dsizes_x[0] != dsizes_y[0] ) {
PyErr_SetString(PyExc_StandardError, "regline: The input arrays must be the same length.");
Py_INCREF(Py_None);
return Py_None;
}
/*
* Get and check number of input points.
*/
npts = dsizes_x[0];
inpts = (int)npts; /* inpts may not be big enough to hold value of npts */
if( npts < 2 ) {
PyErr_SetString(PyExc_StandardError, "regline: The length of x and y must be at least 2.");
Py_INCREF(Py_None);
return Py_None;
}
rcoef = (double *)malloc(sizeof(double));
/*
* Call the f77 version of 'regline' with the full argument list.
*/
NGCALLF(dregcoef,DREGCOEF)(x, y, &inpts, &fill_value_x, &fill_value_y,
rcoef, &tval, &nptxy, &xave, &yave, &rstd, &ier);
if (ier == 5) {
PyErr_SetString(PyExc_StandardError, "regline: The x and/or y array contains all missing values.");
Py_INCREF(Py_None);
return Py_None;
}
if (ier == 6) {
PyErr_SetString(PyExc_StandardError, "regline: The x and/or y array contains less than 3 non-missing values.");
Py_INCREF(Py_None);
return Py_None;
}
yint = yave - *rcoef*(xave);
/*
* Return extra calculations only if return_info is True (1).
*/
if(return_info) {
/*
* Create return tuple.
*/
rc = PyFloat_FromDouble(*rcoef);
pdict = PyDict_New();
PyDict_SetItem(pdict, PyString_FromString("xave"), PyFloat_FromDouble(xave));
PyDict_SetItem(pdict, PyString_FromString("yave"), PyFloat_FromDouble(yave));
PyDict_SetItem(pdict, PyString_FromString("tval"), PyFloat_FromDouble(tval));
PyDict_SetItem(pdict, PyString_FromString("rstd"), PyFloat_FromDouble(rstd));
PyDict_SetItem(pdict, PyString_FromString("yintercept"), PyFloat_FromDouble(yint));
PyDict_SetItem(pdict, PyString_FromString("nptxy"), PyInt_FromLong((long) nptxy));
/*
* pdict = Py_BuildValue("{s:f, s:f, s:f, s:f, s:f, s:i}",
* "xave",xave,
* "yave",yave,
* "tval",tval,
* "rstd",rstd,
* "yintercept",yint,
* "nptxy",nptxy);
*/
result = Py_None;
result = t_output_helper(result,rc);
result = t_output_helper(result,pdict);
if (result == Py_None) Py_INCREF(Py_None);
return result;
}
else {
dsizes_rcoef[0] = 1;
return ((PyObject *) PyArray_SimpleNewFromData(1,dsizes_rcoef,
PyArray_DOUBLE,
(void *) rcoef));
}
}
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 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 wavelet_W( void )
{
/*
* Input array variables
*/
void *y, *dt, *param, *s0, *dj, *siglvl, *nadof;
int *mother, *jtot, *npad, *noise, *isigtest;
double *tmp_y, *tmp_dt, *tmp_param, *tmp_s0, *tmp_dj;
double *tmp_siglvl, tmp_nadof[2];
ng_size_t dsizes_y[NCL_MAX_DIMENSIONS];
NclBasicDataTypes type_y, type_dt, type_param, type_s0, type_dj;
NclBasicDataTypes type_siglvl;
/*
* Attribute variables
*/
int att_id;
ng_size_t dsizes[NCL_MAX_DIMENSIONS];
NclMultiDValData att_md, return_md;
NclVar tmp_var;
NclStackEntry return_data;
/*
* Output array variables
*/
void *wave, *scale, *period, *coi, *dof, *ffttheor, *signif, *gws;
void *power, *phase, *r1, *mean, *st_dev, *lag1, *cdelta, *psi0;
double *tmp_wave, *tmp_scale, *tmp_period, *tmp_coi, *tmp_dof;
double *tmp_ffttheor, *tmp_signif, *tmp_gws, *tmp_power, *tmp_phase;
double *tmp_r1;
double *tmp_mean, *tmp_st_dev, *tmp_lag1, *tmp_cdelta, *tmp_psi0;
int ndims_wave = 3;
ng_size_t dsizes_wave[3];
NclBasicDataTypes type_wave;
NclObjClass type_output;
/*
* Declare various variables for random purposes.
*/
ng_size_t n, size_wave, size_output;
int in;
/*
* Retrieve parameters
*
* Note that any of the pointer parameters can be set to NULL,
* which implies you don't care about its value.
*
* Retrieve argument #1
*/
y = (void*)NclGetArgValue(
0,
12,
NULL,
dsizes_y,
NULL,
NULL,
&type_y,
DONT_CARE);
mother = (int*)NclGetArgValue(
1,
12,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
dt = (void*)NclGetArgValue(
2,
12,
NULL,
NULL,
NULL,
NULL,
&type_dt,
DONT_CARE);
param = (void*)NclGetArgValue(
3,
12,
NULL,
NULL,
NULL,
NULL,
&type_param,
DONT_CARE);
s0 = (void*)NclGetArgValue(
4,
12,
NULL,
NULL,
NULL,
NULL,
&type_s0,
DONT_CARE);
dj = (void*)NclGetArgValue(
5,
12,
NULL,
NULL,
NULL,
NULL,
&type_dj,
DONT_CARE);
jtot = (int*)NclGetArgValue(
6,
12,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
npad = (int*)NclGetArgValue(
7,
12,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
noise = (int*)NclGetArgValue(
8,
12,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
isigtest = (int*)NclGetArgValue(
9,
12,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
siglvl = (void*)NclGetArgValue(
10,
12,
NULL,
NULL,
NULL,
NULL,
&type_siglvl,
DONT_CARE);
/*
* nadof is ignored for now. We'll create a dummy nadof variable and pass
* that to the wavelet function.
*/
nadof = (void*)NclGetArgValue(
11,
12,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* We haven't implemented isigtest = 2, so default to 0 if it isn't.
*/
if(*isigtest != 0 && *isigtest != 1) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"wavelet: Only isigtest = 0 or 1 has been implemented. Defaulting to 0");
*isigtest = 0;
}
/*
* Get size of input array.
*/
n = dsizes_y[0];
if(n > INT_MAX) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"wavelet: n = %ld is greater than INT_MAX", n);
return(NhlFATAL);
}
in = (int) n;
/*
* Coerce input if necessary.
*/
tmp_y = coerce_input_double(y,type_y,n,0,NULL,NULL);
tmp_dt = coerce_input_double(dt,type_dt,1,0,NULL,NULL);
tmp_param = coerce_input_double(param,type_param,1,0,NULL,NULL);
tmp_s0 = coerce_input_double(s0,type_s0,1,0,NULL,NULL);
tmp_dj = coerce_input_double(dj,type_dj,1,0,NULL,NULL);
tmp_siglvl = coerce_input_double(siglvl,type_siglvl,1,0,NULL,NULL);
if( tmp_y == NULL || tmp_dt == NULL || tmp_param == NULL ||
tmp_s0 == NULL || tmp_dj == NULL || tmp_siglvl == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"wavelet: Unable to coerce input to double precision");
return(NhlFATAL);
}
/*
* Allocate space for output array and attributes.
*
* Also, set size for output array (wave).
*/
dsizes_wave[0] = 2;
dsizes_wave[1] = *jtot;
dsizes_wave[2] = n;
size_wave = *jtot * 2 * n;
if(type_y == NCL_double) {
type_wave = NCL_double;
type_output = nclTypedoubleClass;
size_output = sizeof(double);
}
else {
type_wave = NCL_float;
type_output = nclTypefloatClass;
size_output = sizeof(float);
}
wave = (void*)calloc(size_wave,size_output);
scale = (void*)calloc(*jtot,size_output);
period = (void*)calloc(*jtot,size_output);
coi = (void*)calloc(n,size_output);
dof = (void*)calloc(*jtot,size_output);
ffttheor = (void*)calloc(*jtot,size_output);
signif = (void*)calloc(*jtot,size_output);
gws = (void*)calloc(*jtot,size_output);
power = (void*)calloc(*jtot*n,size_output);
phase = (void*)calloc(*jtot*n,size_output);
r1 = (void*)calloc(1,size_output);
mean = (void*)calloc(1,size_output);
st_dev = (void*)calloc(1,size_output);
lag1 = (void*)calloc(1,size_output);
cdelta = (void*)calloc(1,size_output);
psi0 = (void*)calloc(1,size_output);
tmp_wave = coerce_output_double(wave,type_wave,size_wave);
tmp_scale = coerce_output_double(scale,type_wave,*jtot);
tmp_period = coerce_output_double(period,type_wave,*jtot);
tmp_coi = coerce_output_double(coi,type_wave,n);
tmp_dof = coerce_output_double(dof,type_wave,*jtot);
tmp_ffttheor = coerce_output_double(ffttheor,type_wave,*jtot);
tmp_signif = coerce_output_double(signif,type_wave,*jtot);
tmp_gws = coerce_output_double(gws,type_wave,*jtot);
tmp_power = coerce_output_double(power,type_wave,*jtot*n);
tmp_phase = coerce_output_double(phase,type_wave,*jtot*n);
tmp_r1 = coerce_output_double(r1,type_wave,1);
tmp_mean = coerce_output_double(mean,type_wave,1);
tmp_st_dev = coerce_output_double(st_dev,type_wave,1);
tmp_lag1 = coerce_output_double(lag1,type_wave,1);
tmp_cdelta = coerce_output_double(cdelta,type_wave,1);
tmp_psi0 = coerce_output_double(psi0,type_wave,1);
if( tmp_wave == NULL || tmp_scale == NULL || tmp_period == NULL ||
tmp_coi == NULL || tmp_dof == NULL || tmp_ffttheor == NULL ||
tmp_signif == NULL || tmp_gws == NULL || tmp_mean == NULL ||
tmp_power == NULL || tmp_phase == NULL || tmp_st_dev == NULL ||
tmp_lag1 == NULL ||tmp_cdelta == NULL || tmp_psi0 == NULL ||
tmp_r1 == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"wavelet: Unable to allocate memory for output variables");
return(NhlFATAL);
}
/*
* Call the Fortran routine.
*/
NGCALLF(waveleti,WAVELETI)(&in,tmp_y,tmp_dt,mother,tmp_param,tmp_s0,tmp_dj,
jtot,npad,noise,isigtest,tmp_siglvl,tmp_nadof,
tmp_wave,tmp_scale,tmp_period,tmp_coi,tmp_dof,
tmp_ffttheor,tmp_signif,tmp_gws,tmp_mean,
tmp_st_dev,tmp_lag1,tmp_cdelta,tmp_psi0,
tmp_power,tmp_phase,tmp_r1);
if(type_wave == NCL_float) {
coerce_output_float_only(wave,tmp_wave,size_wave,0);
coerce_output_float_only(scale,tmp_scale,*jtot,0);
coerce_output_float_only(period,tmp_period,*jtot,0);
coerce_output_float_only(coi,tmp_coi,n,0);
coerce_output_float_only(dof,tmp_dof,*jtot,0);
coerce_output_float_only(ffttheor,tmp_ffttheor,*jtot,0);
coerce_output_float_only(signif,tmp_signif,*jtot,0);
coerce_output_float_only(gws,tmp_gws,*jtot,0);
coerce_output_float_only(power,tmp_power,*jtot*n,0);
coerce_output_float_only(phase,tmp_phase,*jtot*n,0);
coerce_output_float_only(r1,tmp_r1,1,0);
coerce_output_float_only(mean,tmp_mean,1,0);
coerce_output_float_only(st_dev,tmp_st_dev,1,0);
coerce_output_float_only(lag1,tmp_lag1,1,0);
coerce_output_float_only(cdelta,tmp_cdelta,1,0);
coerce_output_float_only(psi0,tmp_psi0,1,0);
}
/*
* Free memory.
*/
if(type_y != NCL_double) NclFree(tmp_y);
if(type_dt != NCL_double) NclFree(tmp_dt);
if(type_param != NCL_double) NclFree(tmp_param);
if(type_s0 != NCL_double) NclFree(tmp_s0);
if(type_dj != NCL_double) NclFree(tmp_dj);
if(type_siglvl != NCL_double) NclFree(tmp_siglvl);
if(type_wave != NCL_double) {
NclFree(tmp_wave);
NclFree(tmp_scale);
NclFree(tmp_period);
NclFree(tmp_coi);
NclFree(tmp_dof);
NclFree(tmp_ffttheor);
NclFree(tmp_signif);
NclFree(tmp_gws);
NclFree(tmp_power);
NclFree(tmp_phase);
NclFree(tmp_r1);
NclFree(tmp_mean);
NclFree(tmp_st_dev);
NclFree(tmp_lag1);
NclFree(tmp_cdelta);
NclFree(tmp_psi0);
}
/*
* Set up variable to return.
*/
return_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
wave,
NULL,
ndims_wave,
dsizes_wave,
TEMPORARY,
NULL,
type_output
);
/*
* Set up attributes to return.
*/
att_id = _NclAttCreate(NULL,NULL,Ncl_Att,0,NULL);
dsizes[0] = *jtot;
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
scale,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"scale",
att_md,
NULL
);
dsizes[0] = *jtot;
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
period,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"period",
att_md,
NULL
);
dsizes[0] = n;
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
coi,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"coi",
att_md,
NULL
);
dsizes[0] = *jtot;
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
dof,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"dof",
att_md,
NULL
);
dsizes[0] = *jtot;
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
ffttheor,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"fft_theor",
att_md,
NULL
);
dsizes[0] = *jtot;
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
signif,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"signif",
att_md,
NULL
);
dsizes[0] = *jtot;
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
gws,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"gws",
att_md,
NULL
);
dsizes[0] = *jtot*n;
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
power,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"power",
att_md,
NULL
);
dsizes[0] = *jtot*n;
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
phase,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"phase",
att_md,
NULL
);
dsizes[0] = 1;
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
r1,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"r1",
att_md,
NULL
);
dsizes[0] = 1;
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
mean,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"mean",
att_md,
NULL
);
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
st_dev,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"stdev",
att_md,
NULL
);
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
lag1,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"lag1",
att_md,
NULL
);
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
cdelta,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"cdelta",
att_md,
NULL
);
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
psi0,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"psi0",
att_md,
NULL
);
tmp_var = _NclVarCreate(
NULL,
NULL,
Ncl_Var,
0,
NULL,
return_md,
NULL,
att_id,
NULL,
RETURNVAR,
NULL,
TEMPORARY
);
/*
* Return output grid and attributes to NCL.
*/
return_data.kind = NclStk_VAR;
return_data.u.data_var = tmp_var;
_NclPlaceReturn(return_data);
return(NhlNOERROR);
}
NhlErrorTypes tdez1d_W( void )
{
int *nwid, *imrk, *style;
float *x, *y, *z, *rmrk, *smrk, *rmult, *theta, *phi;
ng_size_t dsizes_x[1];
ng_size_t dsizes_y[1];
ng_size_t dsizes_z[1];
/*
* Variables for retrieving workstation information.
*/
int grlist, gkswid, nid, x0;
NclHLUObj tmp_hlu_obj;
/*
* 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.
*/
nwid = (int*)NclGetArgValue( 0,11,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
x = (float*)NclGetArgValue( 1,11,NULL,dsizes_x,NULL,NULL,NULL,DONT_CARE);
y = (float*)NclGetArgValue( 2,11,NULL,dsizes_y,NULL,NULL,NULL,DONT_CARE);
z = (float*)NclGetArgValue( 3,11,NULL,dsizes_z,NULL,NULL,NULL,DONT_CARE);
imrk = (int*)NclGetArgValue( 4,11,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
rmrk = (float*)NclGetArgValue( 5,11,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
smrk = (float*)NclGetArgValue( 6,11,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
rmult = (float*)NclGetArgValue( 7,11,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
theta = (float*)NclGetArgValue( 8,11,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
phi = (float*)NclGetArgValue( 9,11,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
style = (int*)NclGetArgValue(10,11,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
/*
* Check the input sizes.
*/
if( dsizes_x[0] != dsizes_y[0] || dsizes_x[0] != dsizes_z[0] ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"tdez1d: the length of the x, y, and z arrays must be the same");
return(NhlFATAL);
}
if(dsizes_x[0] > INT_MAX) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"tdez1d: dsizes_x[0] = %ld is greater than INT_MAX", dsizes_x[0]);
return(NhlFATAL);
}
x0 = (int) dsizes_x[0];
/*
* Determine the NCL identifier for the graphic object in nid.
*/
tmp_hlu_obj = (NclHLUObj) _NclGetObj(*nwid);
nid = tmp_hlu_obj->hlu.hlu_id;
/*
* Retrieve the GKS workstation id from the workstation object.
*/
grlist = NhlRLCreate(NhlGETRL);
NhlRLClear(grlist);
NhlRLGetInteger(grlist,NhlNwkGksWorkId,&gkswid);
NhlGetValues(nid,grlist);
/*
* The following section activates the workstation, calls the
* tdez1d function, and then deactivates the workstation.
*/
gactivate_ws (gkswid);
NGCALLF(tdez1d,TDEZ1D)(&x0,x,y,z,imrk,rmrk,smrk,rmult,theta,phi,style);
gdeactivate_ws (gkswid);
return(NhlNOERROR);
}
NhlErrorTypes paleo_outline_W( void )
{
/*
* Input array variables
*/
void *oro, *lat, *lon;
float *landmask;
double *tmp_oro, *tmp_lat, *tmp_lon;
ng_size_t dsizes_oro[2], dsizes_lat[1], dsizes_lon[1];
NclBasicDataTypes type_oro, type_lat, type_lon;
NrmQuark *name;
/*
* Other variables
*/
float *zdat;
char *cname;
int *iwrk, inlon, inlat, iliwk, iim, ijm;
ng_size_t liwk, nlat, nlon, jm, im;
/*
* Retrieve arguments.
*/
oro = (void*)NclGetArgValue(
0,
5,
NULL,
dsizes_oro,
NULL,
NULL,
&type_oro,
DONT_CARE);
lat = (void*)NclGetArgValue(
1,
5,
NULL,
dsizes_lat,
NULL,
NULL,
&type_lat,
DONT_CARE);
lon = (void*)NclGetArgValue(
2,
5,
NULL,
dsizes_lon,
NULL,
NULL,
&type_lon,
DONT_CARE);
landmask = (float*)NclGetArgValue(
3,
5,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
name = (NrmQuark *)NclGetArgValue(
4,
5,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
cname = NrmQuarkToString(*name);
nlat = dsizes_oro[0];
nlon = dsizes_oro[1];
if(dsizes_lat[0] != nlat || dsizes_lon[0] != nlon) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"paleo_outline: the length of the lat array must be the same as the leftmost dimension of oro, and the length of the lon arrays must be the same as the rightmost dimension of oro");
return(NhlFATAL);
}
/*
* Convert input arrays to double if necessary.
*/
tmp_oro = coerce_input_double(oro,type_oro,nlat*nlon,0,NULL,NULL);
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_oro == NULL || tmp_lat == NULL || tmp_lon == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"paleo_outline: Unable to coerce input arrays to double precision");
return(NhlFATAL);
}
/*
* Allocate space for work arrays.
*/
jm = 2*nlat+1;
im = 2*nlon+1;
liwk = max(im * jm,2000); /* 2000 is the old value that iwrk
was hard-wired to. */
/*
* Test input dimension sizes.
*/
if((nlon > INT_MAX) || (nlat > INT_MAX) || (liwk > INT_MAX) ||
(im > INT_MAX) || (jm > INT_MAX)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"paleo_outline: one or more input dimension sizes is greater than INT_MAX");
return(NhlFATAL);
}
inlon = (int) nlon;
inlat = (int) nlat;
iliwk = (int) liwk;
iim = (int) im;
ijm = (int) jm;
/*
* Allocate work arrays.
*/
zdat = (float*)malloc(jm*im*sizeof(float));
iwrk = (int*)malloc(liwk*sizeof(int));
if(zdat == NULL || iwrk == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"paleo_outline: Unable to allocate memory for work arrays");
return(NhlFATAL);
}
/*
* Call the Fortran paleo_outline routine.
*/
NGCALLF(paleooutline,PALEOOUTLINE)(tmp_oro,zdat,tmp_lat,tmp_lon,
&inlat,&inlon,&ijm,&iim,iwrk,&iliwk,
cname,landmask,strlen(cname));
if(type_oro != NCL_double) NclFree(tmp_oro);
if(type_lat != NCL_double) NclFree(tmp_lat);
if(type_lon != NCL_double) NclFree(tmp_lon);
NclFree(zdat);
NclFree(iwrk);
return(NhlNOERROR);
}
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 tdcurv_W( void )
{
int *nwid, *iarh;
float *ucrv, *vcrv, *wcrv, *arhl, *arhw;
/*
* Variables for retrieving workstation information.
*/
int grlist, gkswid, nid;
NclHLUObj tmp_hlu_obj;
ng_size_t ncrv;
int incrv;
ng_size_t dsizes_ucrv[1];
ng_size_t dsizes_vcrv[1];
ng_size_t dsizes_wcrv[1];
/*
* Retrieve parameters.
*/
nwid = (int*)NclGetArgValue(0,7,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
ucrv = (float*)NclGetArgValue(1,7,NULL,dsizes_ucrv,NULL,NULL,NULL,DONT_CARE);
vcrv = (float*)NclGetArgValue(2,7,NULL,dsizes_vcrv,NULL,NULL,NULL,DONT_CARE);
wcrv = (float*)NclGetArgValue(3,7,NULL,dsizes_wcrv,NULL,NULL,NULL,DONT_CARE);
iarh = (int*)NclGetArgValue(4,7,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
arhl = (float*)NclGetArgValue(5,7,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
arhw = (float*)NclGetArgValue(6,7,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
if(dsizes_ucrv[0] != dsizes_vcrv[0] || dsizes_ucrv[0] != dsizes_wcrv[0]) {
NhlPError(NhlFATAL, NhlEUNKNOWN, "tdcurv: ucurv, vcurv, and wcurv must be the same length");
return(NhlFATAL);
}
ncrv = dsizes_ucrv[0];
/*
* Test dimension sizes.
*/
if(ncrv > INT_MAX) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"tdcurv: the length of the input arrays are > INT_MAX");
return(NhlFATAL);
}
incrv = (int) ncrv;
/*
* Determine the NCL identifier for the graphic object in nid.
*/
tmp_hlu_obj = (NclHLUObj) _NclGetObj(*nwid);
nid = tmp_hlu_obj->hlu.hlu_id;
/*
* Retrieve the GKS workstation id from the workstation object.
*/
grlist = NhlRLCreate(NhlGETRL);
NhlRLClear(grlist);
NhlRLGetInteger(grlist, NhlNwkGksWorkId, &gkswid);
NhlGetValues(nid, grlist);
/*
* The following section activates the workstation, calls the
* c_tdcurv function, and then deactivates the workstation.
*/
gactivate_ws (gkswid);
NGCALLF(tdcurv,TDCURV)(ucrv, vcrv, wcrv, &incrv, iarh, arhl, arhw);
gdeactivate_ws (gkswid);
return(NhlNOERROR);
}
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 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 wavelet_default_W( void )
{
/*
* Input array variables
*/
void *y;
int *mother, jtot, npad, noise, isigtest;
double *tmp_y, dt, param, s0, dj, siglvl, nadof[2];
ng_size_t dsizes_y[NCL_MAX_DIMENSIONS];
NclBasicDataTypes type_y;
/*
* Attribute variables
*/
int att_id;
ng_size_t dsizes[NCL_MAX_DIMENSIONS];
NclMultiDValData att_md, return_md;
NclVar tmp_var;
NclStackEntry return_data;
/*
* Output array variables
*/
void *wave, *scale, *period, *coi, *dof, *ffttheor, *signif, *gws;
void *power, *phase, *r1, *mean, *st_dev, *lag1, *cdelta, *psi0;
double *tmp_wave, *tmp_scale, *tmp_period, *tmp_coi, *tmp_dof;
double *tmp_ffttheor, *tmp_signif, *tmp_gws, *tmp_power, *tmp_phase;
double *tmp_r1;
double *tmp_mean, *tmp_st_dev, *tmp_lag1, *tmp_cdelta, *tmp_psi0;
int ndims_wave = 3;
ng_size_t dsizes_wave[3];
NclBasicDataTypes type_wave;
NclObjClass type_output;
/*
* Declare various variables for random purposes.
*/
ng_size_t n, size_wave, size_output;
int in;
/*
* Retrieve parameters
*
* Note that any of the pointer parameters can be set to NULL,
* which implies you don't care about its value.
*
* Retrieve argument #1
*/
y = (void*)NclGetArgValue(
0,
2,
NULL,
dsizes_y,
NULL,
NULL,
&type_y,
DONT_CARE);
mother = (int*)NclGetArgValue(
1,
2,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Get size of input array.
*/
n = dsizes_y[0];
if(n > INT_MAX) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"wavelet_default: n = %ld is greater than INT_MAX", n);
return(NhlFATAL);
}
in = (int) n;
/*
* Initialize.
*/
if (*mother <= 0 || *mother > 2) {
param = 6.0;
}
else if (*mother == 1) {
param = 4.0;
}
else if (*mother == 2) {
param = 2.0;
}
dt = 1.0;
s0 = 2.*dt;
dj = 0.25;
jtot = 1 + ((log(n*dt/s0))/dj)/log(2.);
npad = n;
noise = 1;
isigtest = 0;
siglvl = 0.05;
/*
* Coerce input if necessary.
*/
tmp_y = coerce_input_double(y,type_y,n,0,NULL,NULL);
if( tmp_y == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"wavelet_default: Unable to coerce input to double precision");
return(NhlFATAL);
}
/*
* Allocate space for output array and attributes.
*
* Also, set size for output array (wave).
*/
dsizes_wave[0] = 2;
dsizes_wave[1] = jtot;
dsizes_wave[2] = n;
size_wave = jtot * 2 * n;
if(type_y == NCL_double) {
type_wave = NCL_double;
type_output = nclTypedoubleClass;
size_output = sizeof(double);
}
else {
type_wave = NCL_float;
type_output = nclTypefloatClass;
size_output = sizeof(float);
}
wave = (void*)calloc(size_wave,size_output);
scale = (void*)calloc(jtot,size_output);
period = (void*)calloc(jtot,size_output);
coi = (void*)calloc(n,size_output);
dof = (void*)calloc(jtot,size_output);
ffttheor = (void*)calloc(jtot,size_output);
signif = (void*)calloc(jtot,size_output);
gws = (void*)calloc(jtot,size_output);
power = (void*)calloc(jtot*n,size_output);
phase = (void*)calloc(jtot*n,size_output);
r1 = (void*)calloc(1,size_output);
mean = (void*)calloc(1,size_output);
st_dev = (void*)calloc(1,size_output);
lag1 = (void*)calloc(1,size_output);
cdelta = (void*)calloc(1,size_output);
psi0 = (void*)calloc(1,size_output);
tmp_wave = coerce_output_double(wave,type_wave,size_wave);
tmp_scale = coerce_output_double(scale,type_wave,jtot);
tmp_period = coerce_output_double(period,type_wave,jtot);
tmp_coi = coerce_output_double(coi,type_wave,n);
tmp_dof = coerce_output_double(dof,type_wave,jtot);
tmp_ffttheor = coerce_output_double(ffttheor,type_wave,jtot);
tmp_signif = coerce_output_double(signif,type_wave,jtot);
tmp_gws = coerce_output_double(gws,type_wave,jtot);
tmp_power = coerce_output_double(power,type_wave,jtot*n);
tmp_phase = coerce_output_double(phase,type_wave,jtot*n);
tmp_r1 = coerce_output_double(r1,type_wave,1);
tmp_mean = coerce_output_double(mean,type_wave,1);
tmp_st_dev = coerce_output_double(st_dev,type_wave,1);
tmp_lag1 = coerce_output_double(lag1,type_wave,1);
tmp_cdelta = coerce_output_double(cdelta,type_wave,1);
tmp_psi0 = coerce_output_double(psi0,type_wave,1);
if( tmp_wave == NULL || tmp_scale == NULL || tmp_period == NULL ||
tmp_coi == NULL || tmp_dof == NULL || tmp_ffttheor == NULL ||
tmp_signif == NULL || tmp_gws == NULL || tmp_mean == NULL ||
tmp_power == NULL || tmp_phase == NULL || tmp_st_dev == NULL ||
tmp_lag1 == NULL ||tmp_cdelta == NULL || tmp_psi0 == NULL ||
tmp_r1 == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"wavelet_default: Unable to allocate memory for output variables");
return(NhlFATAL);
}
/*
* Call the Fortran routine.
*/
NGCALLF(waveleti,WAVELETI)(&in,tmp_y,&dt,mother,¶m,&s0,&dj,
&jtot,&npad,&noise,&isigtest,&siglvl,nadof,
tmp_wave,tmp_scale,tmp_period,tmp_coi,tmp_dof,
tmp_ffttheor,tmp_signif,tmp_gws,tmp_mean,
tmp_st_dev,tmp_lag1,tmp_cdelta,tmp_psi0,
tmp_power,tmp_phase,tmp_r1);
if(type_wave == NCL_float) {
coerce_output_float_only(wave,tmp_wave,size_wave,0);
coerce_output_float_only(scale,tmp_scale,jtot,0);
coerce_output_float_only(period,tmp_period,jtot,0);
coerce_output_float_only(coi,tmp_coi,n,0);
coerce_output_float_only(dof,tmp_dof,jtot,0);
coerce_output_float_only(ffttheor,tmp_ffttheor,jtot,0);
coerce_output_float_only(signif,tmp_signif,jtot,0);
coerce_output_float_only(gws,tmp_gws,jtot,0);
coerce_output_float_only(power,tmp_power,jtot*n,0);
coerce_output_float_only(phase,tmp_phase,jtot*n,0);
coerce_output_float_only(r1,tmp_r1,1,0);
coerce_output_float_only(mean,tmp_mean,1,0);
coerce_output_float_only(st_dev,tmp_st_dev,1,0);
coerce_output_float_only(lag1,tmp_lag1,1,0);
coerce_output_float_only(cdelta,tmp_cdelta,1,0);
coerce_output_float_only(psi0,tmp_psi0,1,0);
}
/*
* Free memory.
*/
if(type_y != NCL_double) NclFree(tmp_y);
if(type_wave != NCL_double) {
NclFree(tmp_wave);
NclFree(tmp_scale);
NclFree(tmp_period);
NclFree(tmp_coi);
NclFree(tmp_dof);
NclFree(tmp_ffttheor);
NclFree(tmp_signif);
NclFree(tmp_gws);
NclFree(tmp_power);
NclFree(tmp_phase);
NclFree(tmp_r1);
NclFree(tmp_mean);
NclFree(tmp_st_dev);
NclFree(tmp_lag1);
NclFree(tmp_cdelta);
NclFree(tmp_psi0);
}
/*
* Set up variable to return.
*/
return_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
wave,
NULL,
ndims_wave,
dsizes_wave,
TEMPORARY,
NULL,
type_output
);
/*
* Set up attributes to return.
*/
att_id = _NclAttCreate(NULL,NULL,Ncl_Att,0,NULL);
dsizes[0] = jtot;
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
scale,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"scale",
att_md,
NULL
);
dsizes[0] = jtot;
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
period,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"period",
att_md,
NULL
);
dsizes[0] = n;
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
coi,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"coi",
att_md,
NULL
);
dsizes[0] = jtot;
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
dof,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"dof",
att_md,
NULL
);
dsizes[0] = jtot;
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
ffttheor,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"fft_theor",
att_md,
NULL
);
dsizes[0] = jtot;
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
signif,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"signif",
att_md,
NULL
);
dsizes[0] = jtot;
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
gws,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"gws",
att_md,
NULL
);
dsizes[0] = jtot*n;
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
power,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"power",
att_md,
NULL
);
dsizes[0] = jtot*n;
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
phase,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"phase",
att_md,
NULL
);
dsizes[0] = 1;
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
r1,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"r1",
att_md,
NULL
);
dsizes[0] = 1;
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
mean,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"mean",
att_md,
NULL
);
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
st_dev,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"stdev",
att_md,
NULL
);
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
lag1,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"lag1",
att_md,
NULL
);
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
cdelta,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"cdelta",
att_md,
NULL
);
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
psi0,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"psi0",
att_md,
NULL
);
tmp_var = _NclVarCreate(
NULL,
NULL,
Ncl_Var,
0,
NULL,
return_md,
NULL,
att_id,
NULL,
RETURNVAR,
NULL,
TEMPORARY
);
/*
* Return output grid and attributes to NCL.
*/
return_data.kind = NclStk_VAR;
return_data.u.data_var = tmp_var;
_NclPlaceReturn(return_data);
return(NhlNOERROR);
}
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);
}
