NhlErrorTypes tdsort_W( void )
{
float *rwrk;
ng_size_t nwrk;
int *iwrk, *iord, inwrk;
ng_size_t dsizes_rwrk[1];
int ret;
/*
* Retrieve parameters.
*/
rwrk = (float*)NclGetArgValue(0,2,NULL,dsizes_rwrk,NULL,NULL,NULL,DONT_CARE);
iord = (int*)NclGetArgValue(1,2,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
nwrk = dsizes_rwrk[0];
/*
* Test dimension sizes.
*/
if(nwrk > INT_MAX) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"tdsort: the length of rwrk is greater than INT_MAX");
return(NhlFATAL);
}
inwrk = (int) nwrk;
iwrk = (int*)calloc(nwrk,sizeof(int));
if(iwrk == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"tdsort: Unable to allocate memory for permutation vector");
return(NhlFATAL);
}
c_tdsort(rwrk, inwrk, *iord, iwrk);
ret = NclReturnValue(iwrk,1,dsizes_rwrk,NULL,NCL_int,0);
return(NhlNOERROR);
}
NhlErrorTypes 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);
}
NhlErrorTypes tddtri_W( void )
{
int *nwid, *ntri, *itwk, imtri;
ng_size_t mtri, dsizes_rtri[2];
float *rtri;
/*
* Variables for retrieving workstation information.
*/
int grlist, gkswid, nid;
NclHLUObj tmp_hlu_obj;
/*
* Retrieve parameters.
*/
nwid = (int*)NclGetArgValue(0,4,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
rtri = (float*)NclGetArgValue(1,4,NULL,dsizes_rtri,NULL,NULL,NULL,DONT_CARE);
ntri = (int*)NclGetArgValue(2,4,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
itwk = (int*)NclGetArgValue(3,4,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
mtri = dsizes_rtri[0];
if(dsizes_rtri[1] != 10) {
NhlPError(NhlFATAL, NhlEUNKNOWN, "tddtri: the rightmost dimension of rtri must be 10");
return(NhlFATAL);
}
/*
* Test dimension sizes.
*/
if(mtri > INT_MAX) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"tddtri: the leftmost dimension of rtri is greater than INT_MAX");
return(NhlFATAL);
}
imtri = (int) mtri;
/*
* 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_tddtri function, and then deactivates the workstation.
*/
gactivate_ws (gkswid);
c_tddtri(rtri, imtri, ntri, itwk);
gdeactivate_ws (gkswid);
return(NhlNOERROR);
}
NhlErrorTypes tdmtri_W( void )
{
float *uvw, *s, *rtri;
float *uvwmin, *uvwmax;
ng_size_t mtri;
int *imrk, *ntri, imtri, *irst;
ng_size_t dsizes_rtri[2];
/*
* Retrieve parameters.
*/
imrk = (int*)NclGetArgValue( 0,8,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
uvw = (float*)NclGetArgValue( 1,8,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
s = (float*)NclGetArgValue( 2,8,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
rtri = (float*)NclGetArgValue( 3,8,NULL,dsizes_rtri,NULL,NULL,NULL,DONT_CARE);
ntri = (int*)NclGetArgValue( 4,8,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
irst = (int*)NclGetArgValue( 5,8,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
uvwmin = (float*)NclGetArgValue( 6,8,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
uvwmax = (float*)NclGetArgValue( 7,8,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
mtri = dsizes_rtri[0];
if(dsizes_rtri[1] != 10) {
NhlPError(NhlFATAL, NhlEUNKNOWN, "tdmtri: the second dimension of ntri must be 10");
return(NhlFATAL);
}
/*
* Test dimension sizes.
*/
if(mtri > INT_MAX) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"tdmtri: mtri is greater than INT_MAX");
return(NhlFATAL);
}
imtri = (int) mtri;
c_tdmtri(*imrk, uvw[0], uvw[1], uvw[2], *s, rtri, imtri, ntri, *irst,
uvwmin[0], uvwmin[1], uvwmin[2],
uvwmax[0], uvwmax[1], uvwmax[2]);
if(*ntri == imtri) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"tdmtri: triangle list overflow");
return(NhlFATAL);
}
return(NhlNOERROR);
}
NhlErrorTypes tdctri_W( void )
{
float *rtri, *rcut;
ng_size_t mtri;
int *ntri, *iaxs, imtri;
ng_size_t dsizes_rtri[2];
/*
* 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);
iaxs = (int*)NclGetArgValue(2,4,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
rcut = (float*)NclGetArgValue(3,4,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
mtri = dsizes_rtri[0];
if(dsizes_rtri[1] != 10) {
NhlPError(NhlFATAL, NhlEUNKNOWN, "tdctri: the second dimension of ntri must be 10");
return(NhlFATAL);
}
/*
* Test dimension sizes.
*/
if(mtri > INT_MAX) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"tdctri: mtri is greater than INT_MAX");
return(NhlFATAL);
}
imtri = (int) mtri;
c_tdctri(rtri, mtri, ntri, *iaxs, *rcut);
if(*ntri == imtri) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"tdctri: triangle list overflow");
return(NhlFATAL);
}
return(NhlNOERROR);
}
NhlErrorTypes NclGetWTime(double *time)
{
struct timeval wtime;
int status;
*time = 0.0;
status = gettimeofday(&wtime, NULL);
if(status == 0) {
*time = wtime.tv_sec + wtime.tv_usec / 1000000.0 ;
return NhlNOERROR;
}
else {
NhlPError(NhlWARNING, NhlEUNKNOWN,
"Unable to get time, gettimeofday() failed: %d", status);
return NhlWARNING;
}
}
NhlErrorTypes NclGetCPUTime(float *time)
{
struct rusage usage;
int status;
*time = 0.0;
status = getrusage(RUSAGE_SELF, &usage);
if (status) {
NhlPError(NhlWARNING, NhlEUNKNOWN,
"unable to get process resourse usage info: %d", status);
return(NhlWARNING);
}
*time = (usage.ru_stime.tv_sec + usage.ru_utime.tv_sec) +
(usage.ru_stime.tv_usec + usage.ru_utime.tv_usec) / 1000000.;
return NhlNOERROR;
}
NhlErrorTypes rgba_to_color_index_W( void )
{
int i, *ci;
float *rgba;
ng_size_t dsizes[2];
int ndims;
int has_alpha;
int stride;
int rgba_dim;
ng_size_t ncolors;
/*
* Retrieve parameters
*
* Note any of the pointer parameters can be set to NULL, which
* implies you don't care about its value. In this example
* the type parameter is set to NULL because the function
* is later registered to only accept floating point numbers.
*
* Retrieve argument #1
*/
rgba = (float *) NclGetArgValue(0,1,&ndims,dsizes,NULL,NULL,
NULL,DONT_CARE);
/* ndims must be 1 or 2, dsizes[0] can be any number; dsizes[1] must be 3 or 4 */
if (ndims == 1) {
rgba_dim = 0;
ncolors = 1;
}
else if (ndims == 2) {
rgba_dim = 1;
ncolors = dsizes[0];
}
else {
NhlPError(NhlFATAL,NhlEUNKNOWN,
"rgba_to_color_index: the input array must have either 1 or 2 dimensions");
return(NhlFATAL);
}
if (dsizes[rgba_dim] == 3) {
has_alpha = 0;
stride = 3;
}
else if (dsizes[rgba_dim] == 4) {
has_alpha = 1;
stride = 4;
}
else {
NhlPError(NhlFATAL,NhlEUNKNOWN,
"rgba_to_color_index: the second dimension of the input array must have either three or four elements");
return(NhlFATAL);
}
ci = (int*)calloc(ncolors,sizeof(int));
for(i = 0; i < ncolors; i++) {
ci[i] = _NhlRGBAToColorIndex(rgba + i * stride,has_alpha);
}
return(NclReturnValue( (void *) ci, 1, &ncolors, NULL, NCL_int, 0));
}
NhlErrorTypes 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_spi_n_W( void )
{
/*
* Input variables
*/
/*
* Argument # 0
*/
void *x;
double *tmp_x;
int ndims_x;
ng_size_t dsizes_x[NCL_MAX_DIMENSIONS];
int has_missing_x;
NclScalar missing_x, missing_flt_x, missing_dbl_x;
NclBasicDataTypes type_x;
/*
* Argument # 1
*/
int *nrun;
/*
* Argument # 2
*/
logical *opt;
/*
* Variables for retrieving attributes from "opt".
*/
NclAttList *attr_list;
NclAtt attr_obj;
NclStackEntry stack_entry;
int spi_type=0;
/*
* Argument # 3
*/
int *dims;
ng_size_t dsizes_dims;
/*
* Return variable
*/
void *spi;
double *tmp_spi;
NclScalar missing_spi;
NclBasicDataTypes type_spi;
/*
* Various
*/
ng_size_t ntim;
int intim, max_years, max_years_p1, ier, ret;
ng_size_t index_x, index_nrx;
ng_size_t i, j, nrnx, total_nr, total_nl, size_output;
/*
* Various work arrays for spi_type=3 case .
*/
double *probne, *pcpacc, *spi3_y, *spi3_x, *tmparr, *dindex;
/*
* Retrieve parameters.
*
* Note any of the pointer parameters can be set to NULL, which
* implies you don't care about its value.
*/
/*
* Get argument # 0
*/
x = (void*)NclGetArgValue(
0,
4,
&ndims_x,
dsizes_x,
&missing_x,
&has_missing_x,
&type_x,
DONT_CARE);
/*
* Get argument # 1
*/
nrun = (int*)NclGetArgValue(
1,
4,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Get argument # 2
*/
opt = (logical*)NclGetArgValue(
2,
4,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Check for attributes attached to "opt"
*
* "spi_type" 0
*/
if(*opt) {
stack_entry = _NclGetArg(2, 4, DONT_CARE);
switch (stack_entry.kind) {
case NclStk_VAR:
if (stack_entry.u.data_var->var.att_id != -1) {
attr_obj = (NclAtt) _NclGetObj(stack_entry.u.data_var->var.att_id);
if (attr_obj == NULL) {
break;
}
}
else {
/*
* att_id == -1 ==> no optional args given.
*/
break;
}
/*
* Get optional arguments.
*/
if (attr_obj->att.n_atts > 0) {
/*
* Get list of attributes.
*/
attr_list = attr_obj->att.att_list;
/*
* Loop through attributes and check them.
*/
while (attr_list != NULL) {
if(!strcasecmp(attr_list->attname, "spi_type")) {
spi_type = *(int *) attr_list->attvalue->multidval.val;
}
attr_list = attr_list->next;
}
default:
break;
}
}
}
if(spi_type != 0 && spi_type != 3) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_spi_n: spi_type can only be 0 (default) or 3 (Pearson type III distribution");
return(NhlFATAL);
}
/*
* Coerce missing value to double if necessary.
*/
coerce_missing(type_x,has_missing_x,&missing_x,
&missing_dbl_x,&missing_flt_x);
/*
* Get dimension(s) to do computation on.
*/
dims = (int*)NclGetArgValue(
3,
4,
NULL,
&dsizes_dims,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Some error checking. Make sure input dimensions are valid.
*/
for(i = 0; i < dsizes_dims; i++ ) {
if(dims[i] < 0 || dims[i] >= ndims_x) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_spi_n: Invalid dimension sizes to do calculations across, can't continue");
return(NhlFATAL);
}
if(i > 0 && dims[i] != (dims[i-1]+1)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_spi_n: Input dimension sizes must be monotonically increasing, can't continue");
return(NhlFATAL);
}
}
/*
* Calculate size of leftmost dimensions (nl) up to the dims[0]-th
* dimensions.
*
* Calculate number of points that will be passed to Fortran
* routine (ntim).
*
* Calculate size of rightmost dimensions (nr) from the
* ndims[ndims-1]-th dimension.
*
* The dimension(s) to do the calculations across are "dims".
*/
total_nl = total_nr = ntim = 1;
if(ndims_x > 1) {
for(i = 0; i < dims[0] ; i++) {
total_nl = total_nl*dsizes_x[i];
}
for(i = 0; i < dsizes_dims ; i++) {
ntim = ntim*dsizes_x[dims[i]];
}
for(i = dims[dsizes_dims-1]+1; i < ndims_x; i++) {
total_nr = total_nr*dsizes_x[i];
}
} else {
ntim = dsizes_x[dims[0]];
}
size_output = total_nl * ntim * total_nr;
if( ntim > INT_MAX) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_spi_n: ntim is greater than INT_MAX");
return(NhlFATAL);
}
intim = (int) ntim;
/*
* Allocate space for tmp_x and tmp_index.
*/
tmp_x = (double *)calloc(ntim,sizeof(double));
if(tmp_x == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_spi_n: Unable to allocate memory for coercing input array to double");
return(NhlFATAL);
}
/*
* Allocate space for output array.
*/
tmp_spi = (double *)calloc(ntim, sizeof(double));
if(type_x != NCL_double) {
type_spi = NCL_float;
spi = (void *)calloc(size_output, sizeof(float));
}
else {
type_spi = NCL_double;
spi = (void *)calloc(size_output, sizeof(double));
}
if(tmp_spi == NULL || spi == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_spi_n: Unable to allocate memory for output array");
return(NhlFATAL);
}
if(has_missing_x) {
if(type_spi == NCL_double) missing_spi = missing_dbl_x;
else missing_spi = missing_flt_x;
}
/*
* As of NCL V6.3.0, if spi_type == 3, the SPI will be calculated
* using the Pearson type III distribution. The Fortran routine
* for this requires a bunch of work arrays.
*/
if(spi_type == 3) {
if(ntim % 12) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_spi_n: if opt@spi_type= 3, then ntim must be divisable by 12");
return(NhlFATAL);
}
max_years = intim / 12;
max_years_p1 = max_years+1;
probne = (double *)calloc(ntim, sizeof(double));
pcpacc = (double *)calloc(ntim, sizeof(double));
dindex = (double *)calloc(ntim, sizeof(double));
spi3_y = (double *)calloc(ntim, sizeof(double));
spi3_x = (double *)calloc(max_years, sizeof(double));
tmparr = (double *)calloc(max_years_p1, sizeof(double));
if(probne == NULL || pcpacc == NULL || dindex == NULL ||
spi3_y == NULL || spi3_x == NULL || tmparr == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_spi_n: Unable to allocate memory for temporary work arrays");
return(NhlFATAL);
}
}
/*
* Loop across leftmost dimensions and call the Fortran routine for each
* subsection of the input arrays.
*/
nrnx = total_nr * ntim;
for(i = 0; i < total_nl; i++) {
index_nrx = i*nrnx;
for(j = 0; j < total_nr; j++) {
index_x = index_nrx + j;
/*
* Coerce subsection of x (tmp_x) to double.
*/
coerce_subset_input_double_step(x,tmp_x,index_x,total_nr,type_x,
ntim,0,NULL,NULL);
/*
* Call the Fortran routine.
*/
if(spi_type == 0) {
NGCALLF(spigamd,SPIGAMD)(&intim, tmp_x, &missing_dbl_x.doubleval,
nrun, tmp_spi);
}
else if(spi_type == 3) {
NGCALLF(spi3ncdc, SPI3NCDC)(&intim,tmp_x,&missing_dbl_x.doubleval,
nrun,tmp_spi,probne,pcpacc,dindex,
spi3_y, spi3_x, tmparr,&max_years,
&max_years_p1,&ier);
}
/*
* Coerce output back to float or double
*/
coerce_output_float_or_double_step(spi,tmp_spi,type_spi,ntim,
index_x,total_nr);
}
}
/*
* Free unneeded memory.
*/
NclFree(tmp_x);
NclFree(tmp_spi);
if(spi_type == 3) {
NclFree(probne);
NclFree(pcpacc);
NclFree(dindex);
NclFree(spi3_y);
NclFree(spi3_x);
NclFree(tmparr);
}
/*
* Return value back to NCL script.
*/
if(has_missing_x) {
ret = NclReturnValue(spi,ndims_x,dsizes_x,&missing_spi,type_spi,0);
}
else {
ret = NclReturnValue(spi,ndims_x,dsizes_x,NULL,type_spi,0);
}
return(ret);
}
NhlErrorTypes 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 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 ezfftf_W( void )
{
/*
* Input array variables
*/
void *x;
int ndims_x;
ng_size_t dsizes_x[NCL_MAX_DIMENSIONS];
NclBasicDataTypes type_x;
NclScalar missing_x, missing_dx, missing_rx, missing_cf;
int has_missing_x;
double *tmp_x = NULL;
/*
* Output array variables
*/
void *cf, *xbar;
int ndims_cf;
ng_size_t dsizes_cf[NCL_MAX_DIMENSIONS];
double *tmp_cf1, *tmp_cf2, *tmp_xbar;
NclBasicDataTypes type_cf;
NclTypeClass type_cf_class;
/*
* Attribute variables
*/
void *N;
int att_id;
ng_size_t dsizes[1];
NclMultiDValData att_md, return_md;
NclVar tmp_var;
NclStackEntry return_data;
/*
* various
*/
double *work;
ng_size_t index_x, index_cf1, index_cf2;
ng_size_t i, npts, npts2, lnpts2, npts22;
int found_missing, any_missing;
ng_size_t size_leftmost, size_cf;
int inpts;
/*
* Retrieve parameters
*
* Note any of the pointer parameters can be set to NULL, which
* implies you don't care about its value.
*/
x = (void*)NclGetArgValue(
0,
1,
&ndims_x,
dsizes_x,
&missing_x,
&has_missing_x,
&type_x,
DONT_CARE);
/*
* Calculate number of leftmost elements.
*/
size_leftmost = 1;
for( i = 0; i < ndims_x-1; i++ ) size_leftmost *= dsizes_x[i];
/*
* Test input array size
*/
npts = dsizes_x[ndims_x-1];
if(npts > INT_MAX) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ezfftf: npts = %d is greater than INT_MAX", npts);
return(NhlFATAL);
}
inpts = (int) npts;
/*
* Calculate size of output array.
*/
if((npts % 2) == 0) {
npts2 = npts/2;
}
else {
npts2 = (npts-1)/2;
}
lnpts2 = npts2 * size_leftmost;
npts22 = 2*npts2;
size_cf = size_leftmost * npts22;
ndims_cf = ndims_x + 1;
dsizes_cf[0] = 2;
for(i = 1; i < ndims_x; i++ ) dsizes_cf[i] = dsizes_x[i-1];
dsizes_cf[ndims_x] = npts2;
/*
* Coerce missing values.
*/
coerce_missing(type_x,has_missing_x,&missing_x,&missing_dx,&missing_rx);
/*
* Create space for temporary input array if necessary.
*/
if(type_x != NCL_double) {
tmp_x = (double*)calloc(npts,sizeof(double));
if(tmp_x == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ezfftf: Unable to allocate memory for coercing input array to double precision");
return(NhlFATAL);
}
}
/*
* Allocate space for output arrays.
*/
tmp_xbar = (double*)calloc(1,sizeof(double));
tmp_cf1 = (double*)calloc(npts2,sizeof(double));
tmp_cf2 = (double*)calloc(npts2,sizeof(double));
if ( tmp_cf1 == NULL || tmp_cf2 == NULL || tmp_xbar == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ezfftf: Cannot allocate memory for temporary output arrays" );
return(NhlFATAL);
}
if(type_x == NCL_double) {
cf = (void*)calloc(size_cf,sizeof(double));
xbar = (void*)calloc(size_leftmost,sizeof(double));
type_cf = NCL_double;
if(has_missing_x) missing_cf = missing_dx;
}
else {
cf = (void*)calloc(size_cf,sizeof(float));
xbar = (void*)calloc(size_leftmost,sizeof(float));
type_cf = NCL_float;
if(has_missing_x) missing_cf = missing_rx;
}
N = (void*)calloc(1,sizeof(int));
if ( cf == NULL || xbar == NULL || N == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ezfftf: Cannot allocate memory for output arrays" );
return(NhlFATAL);
}
/*
* Allocate memory for work array
*/
work = (double*)calloc((4*npts+15),sizeof(double));
if ( work == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ezfftf: Cannot allocate memory for work array" );
return(NhlFATAL);
}
/*
* Call the f77 version of 'dezfftf' with the full argument list.
*/
index_x = 0;
index_cf1 = 0;
index_cf2 = lnpts2;
any_missing = 0;
for(i = 0; i < size_leftmost; i++) {
if(type_x != NCL_double) {
coerce_subset_input_double(x,tmp_x,index_x,type_x,npts,0,NULL,NULL);
}
else {
tmp_x = &((double*)x)[index_x];
}
/*
* Check for missing values in x. If any, then coerce that section of
* the output to missing.
*/
found_missing = contains_missing(tmp_x,npts,has_missing_x,
missing_dx.doubleval);
if(found_missing) {
any_missing++;
set_subset_output_missing(xbar,i,type_cf,1,missing_dx.doubleval);
set_subset_output_missing(cf,index_cf1,type_cf,npts2,
missing_dx.doubleval);
set_subset_output_missing(cf,index_cf2,type_cf,npts2,
missing_dx.doubleval);
}
else {
NGCALLF(dezffti,DEZFFTI)(&inpts,work);
NGCALLF(dezfftf,DEZFFTF)(&inpts,tmp_x,tmp_xbar,tmp_cf1,tmp_cf2,work);
/*
* Copy results back into xbar and cf.
*/
coerce_output_float_or_double(xbar,tmp_xbar,type_cf,1,i);
coerce_output_float_or_double(cf,tmp_cf1,type_cf,npts2,index_cf1);
coerce_output_float_or_double(cf,tmp_cf2,type_cf,npts2,index_cf2);
}
index_x += npts;
index_cf1 += npts2;
index_cf2 += npts2;
}
/*
* Free up memory.
*/
if(type_x != NCL_double) free(tmp_x);
free(work);
free(tmp_cf1);
free(tmp_cf2);
free(tmp_xbar);
/*
* Set up variable to return.
*/
type_cf_class = (NclTypeClass)_NclNameToTypeClass(NrmStringToQuark(_NclBasicDataTypeToName(type_cf)));
/*
* Set up return values.
*/
if(any_missing) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"ezfftf: %d input arrays contained missing values. No calculations performed on these arrays.",any_missing);
return_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
cf,
&missing_cf,
ndims_cf,
dsizes_cf,
TEMPORARY,
NULL,
(NclObjClass)type_cf_class
);
}
else {
return_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
cf,
NULL,
ndims_cf,
dsizes_cf,
TEMPORARY,
NULL,
(NclObjClass)type_cf_class
);
}
/*
* Attributes "xbar" and "npts".
*/
att_id = _NclAttCreate(NULL,NULL,Ncl_Att,0,NULL);
dsizes[0] = size_leftmost;
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
xbar,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
(NclObjClass)type_cf_class
);
_NclAddAtt(
att_id,
"xbar",
att_md,
NULL
);
(*(int*)N) = npts;
dsizes[0] = 1;
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
N,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
(NclObjClass)nclTypeintClass
);
_NclAddAtt(
att_id,
"npts",
att_md,
NULL
);
/*
* Set up variable to hold return array and attributes.
*/
tmp_var = _NclVarCreate(
NULL,
NULL,
Ncl_Var,
0,
NULL,
return_md,
NULL,
att_id,
NULL,
RETURNVAR,
NULL,
TEMPORARY
);
/*
* Return output grid and attributes to NCL.
*/
return_data.kind = NclStk_VAR;
return_data.u.data_var = tmp_var;
_NclPlaceReturn(return_data);
return(NhlNOERROR);
}
NhlErrorTypes pcsetp_W(void)
{
char *arg1;
int numpi, numpf, i, j;
/*
* List the integer and float parameter names. To add new ones,
* all that needs to be done is add the names to this list.
*/
char *params_i[] = {"fn","of","FN","OF"};
char *params_f[] = {"ol","oc","OL","OC"};
/*
* Input array variables
*/
NrmQuark *pname;
int ndims_pname;
ng_size_t dsizes_pname[NCL_MAX_DIMENSIONS];
void *pvalue;
int ndims_pvalue;
ng_size_t dsizes_pvalue[NCL_MAX_DIMENSIONS];
NclBasicDataTypes type_pvalue;
/*
* Retrieve argument #1
*/
pname = (NrmQuark *) NclGetArgValue(
0,
2,
&ndims_pname,
dsizes_pname,
NULL,
NULL,
NULL,
DONT_CARE);
arg1 = NrmQuarkToString(*pname);
/*
* Check to see if the parameter name is valid.
*/
numpi = sizeof(params_i)/sizeof(void *);
numpf = sizeof(params_f)/sizeof(void *);
for (i = 0; i < numpi; i++) {
if (!strncmp(arg1, params_i[i], strlen(params_i[i]))) {
goto OK_NAME;
}
}
for (i = 0; i < numpf; i++) {
if (!strncmp(arg1, params_f[i], strlen(params_f[i]))) {
goto OK_NAME;
}
}
NhlPError(NhlFATAL, NhlEUNKNOWN, "pcsetp: unrecognized parameter name");
return(NhlFATAL);
/*
* Retrieve argument #2
*/
OK_NAME: pvalue = (void *) NclGetArgValue(
1,
2,
&ndims_pvalue,
dsizes_pvalue,
NULL,
NULL,
&type_pvalue,
DONT_CARE);
/*
* Process the parameter if it has an integer value.
*/
if (type_pvalue == NCL_int) {
for (i = 0; i < numpi; i++) {
if (!strncmp(arg1, params_i[i], strlen(params_i[i]))) {
j = *((int *) pvalue);
c_pcseti(arg1, j);
return(NhlNOERROR);
}
}
NhlPError(NhlFATAL, NhlEUNKNOWN, "pcsetp: The specified value for the parameter has an invalid type");
return(NhlFATAL);
}
else if (type_pvalue == NCL_float || type_pvalue == NCL_double) {
/*
* Process the parameter if it has a float value or double value.
*/
for (i = 0; i < numpf; i++) {
if (!strncmp(arg1, params_f[i], strlen(params_f[i]))) {
if (type_pvalue == NCL_float) {
c_pcsetr(arg1, *((float *) pvalue));
return(NhlNOERROR);
}
else if (type_pvalue == NCL_double) {
c_pcsetr(arg1, (float) *((double *) pvalue));
return(NhlNOERROR);
}
}
}
NhlPError(NhlFATAL, NhlEUNKNOWN, "pcsetp: The specified value for the parameter has an invalid type");
return(NhlFATAL);
}
else {
NhlPError(NhlFATAL, NhlEUNKNOWN, "pcsetp: The specified value for the "
"parameter has an incorrect type");
return(NhlFATAL);
}
}
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 ut_calendar_W( void )
{
/*
* Input array variables
*/
void *x;
double *tmp_x;
NrmQuark *sspec = NULL;
char *cspec, *cspec_orig;
int *option;
int ndims_x;
ng_size_t dsizes_x[NCL_MAX_DIMENSIONS];
int has_missing_x;
NclScalar missing_x, missing_dx;
NclBasicDataTypes type_x;
/*
* Variables for calculating fraction of year, if the option is 4.
*/
int doy, nsid, total_seconds_in_year, seconds_in_doy, seconds_in_hour;
int seconds_in_minute;
double current_seconds_in_year, fraction_of_year;
/*
* Variables for retrieving attributes from the first argument.
*/
NclAttList *attr_list;
NclAtt attr_obj;
NclStackEntry stack_entry;
NrmQuark *scal;
char *ccal = NULL;
/*
* Variables for Udunits package.
*/
ut_system *utopen_ncl(), *unit_system;
ut_unit *utunit;
/*
* Output variables.
*/
int year, month, day, hour, minute;
double second;
void *date = NULL;
int ndims_date = 0;
ng_size_t *dsizes_date;
NclScalar missing_date;
NclBasicDataTypes type_date = NCL_none;
NclObjClass type_date_t = NCL_none;
/*
* Variables for returning "calendar" attribute.
*/
int att_id;
NclQuark *calendar;
NclMultiDValData att_md, return_md;
NclVar tmp_var;
NclStackEntry return_data;
/*
* various
*/
int ret, return_missing;
ng_size_t dsizes[1];
ng_size_t i, total_size_x;
ng_size_t total_size_date = 0;
ng_size_t index_date;
int months_to_days_fix=0, years_to_days_fix=0;
extern float truncf(float);
/*
* Before we do anything, initialize the Udunits package.
*/
unit_system = utopen_ncl();
/*
* Retrieve parameters
*
* Note any of the pointer parameters can be set to NULL, which
* implies you don't care about its value.
*/
x = (void*)NclGetArgValue(
0,
2,
&ndims_x,
dsizes_x,
&missing_x,
&has_missing_x,
&type_x,
DONT_CARE);
/*
* Get option.
*/
option = (int*)NclGetArgValue(
1,
2,
NULL,
NULL,
NULL,
NULL,
NULL,
1);
/*
* The "units" attribute of "time" must be set, otherwise missing
* values will be returned.
*
* The "calendar" option may optionally be set, but it must be equal to
* one of the recognized calendars.
*/
return_missing = 0;
stack_entry = _NclGetArg(0, 2, DONT_CARE);
switch (stack_entry.kind) {
case NclStk_VAR:
if (stack_entry.u.data_var->var.att_id != -1) {
attr_obj = (NclAtt) _NclGetObj(stack_entry.u.data_var->var.att_id);
if (attr_obj == NULL) {
return_missing = 1;
break;
}
}
else {
/*
* att_id == -1 ==> no attributes specified; return all missing.
*/
return_missing = 1;
break;
}
/*
* Check for attributes. If none are specified, then return missing values.
*/
if (attr_obj->att.n_atts == 0) {
return_missing = 1;
break;
}
else {
/*
* Get list of attributes.
*/
attr_list = attr_obj->att.att_list;
/*
* Loop through attributes and check them.
*/
while (attr_list != NULL) {
if ((strcmp(attr_list->attname, "calendar")) == 0) {
scal = (NrmQuark *) attr_list->attvalue->multidval.val;
ccal = NrmQuarkToString(*scal);
if(strcasecmp(ccal,"standard") && strcasecmp(ccal,"gregorian") &&
strcasecmp(ccal,"noleap") && strcasecmp(ccal,"365_day") &&
strcasecmp(ccal,"365") && strcasecmp(ccal,"360_day") &&
strcasecmp(ccal,"360") ) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"ut_calendar: the 'calendar' attribute is not equal to a recognized calendar. Returning all missing values.");
return_missing = 1;
}
}
if ((strcmp(attr_list->attname, "units")) == 0) {
sspec = (NrmQuark *) attr_list->attvalue->multidval.val;
}
attr_list = attr_list->next;
}
}
default:
break;
}
/*
* Convert sspec to character string.
*/
if(sspec == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ut_calendar: no 'units' attribute provided");
return(NhlFATAL);
}
cspec = NrmQuarkToString(*sspec);
/*
* There's a bug in utInvCalendar2_cal that doesn't handle the
* 360-day calendar correctly if units are "years since" or
* "months since".
*
* To fix this bug, we convert these units to "days since", do the
* calculation as "days since", and then convert back to the original
* "years since" or "months since" requested units.
*/
cspec_orig = (char*)calloc(strlen(cspec)+1,sizeof(char));
strcpy(cspec_orig,cspec);
cspec = fix_units_for_360_bug(ccal,cspec,&months_to_days_fix,
&years_to_days_fix);
/*
* Make sure cspec is a valid udunits string.
*/
utunit = ut_parse(unit_system, cspec, UT_ASCII);
if(utunit == NULL) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"ut_calendar: Invalid specification string. Missing values will be returned.");
return_missing = 1;
}
/*
* Calculate size of input array.
*/
total_size_x = 1;
for( i = 0; i < ndims_x; i++ ) total_size_x *= dsizes_x[i];
/*
* Calculate size and dimensions for output array, and allocate
* memory for output array. The output size will vary depending
* on what option the user has specified. Only options -5 to 4
* are currently recognized. (option = -4 doesn't exist.)
*/
if(*option < -5 || *option > 4 || *option == -4) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"ut_calendar: Unknown option, defaulting to 0.");
*option = 0;
}
if(*option == 0) {
type_date = NCL_float;
type_date_t = nclTypefloatClass;
total_size_date = 6 * total_size_x;
missing_date = ((NclTypeClass)nclTypefloatClass)->type_class.default_mis;
ndims_date = ndims_x + 1;
date = (float *)calloc(total_size_date,sizeof(float));
}
else if(*option == -5) {
/* identical to option=0, except returns ints */
type_date = NCL_int;
type_date_t = nclTypeintClass;
total_size_date = 6 * total_size_x;
missing_date = ((NclTypeClass)nclTypeintClass)->type_class.default_mis;
ndims_date = ndims_x + 1;
date = (int *)calloc(total_size_date,sizeof(int));
}
else if(*option >= 1 && *option <= 4) {
type_date = NCL_double;
type_date_t = nclTypedoubleClass;
total_size_date = total_size_x;
missing_date = ((NclTypeClass)nclTypedoubleClass)->type_class.default_mis;
ndims_date = ndims_x;
date = (double *)calloc(total_size_date,sizeof(double));
}
else if(*option >= -3 && *option <= -1) {
type_date = NCL_int;
type_date_t = nclTypeintClass;
total_size_date = total_size_x;
missing_date = ((NclTypeClass)nclTypeintClass)->type_class.default_mis;
ndims_date = ndims_x;
date = (int *)calloc(total_size_date,sizeof(int));
}
dsizes_date = (ng_size_t *)calloc(ndims_date,sizeof(ng_size_t));
/*
* Make sure we have enough memory for output.
*/
if( date == NULL || dsizes_date == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ut_calendar: Unable to allocate memory for output arrays");
return(NhlFATAL);
}
/*
* Calculate output dimension sizes.
*/
for( i = 0; i < ndims_x; i++ ) dsizes_date[i] = dsizes_x[i];
if(*option == 0 || *option == -5) {
dsizes_date[ndims_x] = 6;
}
/*
* Coerce missing values to double.
*/
coerce_missing(type_x,has_missing_x,&missing_x,&missing_dx,NULL);
/*
* If we reach this point and return_missing is not 0, then either
* "units" was invalid or wasn't set, or "calendar" was not a
* recoginized calendar. We return all missing values in this case.
*/
if(return_missing) {
if(*option == 0) {
for(i = 0; i < total_size_date; i++ ) {
((float*)date)[i] = missing_date.floatval;
}
}
else if(*option == -5) {
/* identical to option=0, except returns ints */
for(i = 0; i < total_size_date; i++ ) {
((int*)date)[i] = missing_date.intval;
}
}
else if(*option >= 1 && *option <= 4) {
for(i = 0; i < total_size_date; i++ ) {
((double*)date)[i] = missing_date.doubleval;
}
}
else if(*option >= -3 && *option <= -1) {
for(i = 0; i < total_size_date; i++ ) {
((int*)date)[i] = missing_date.intval;
}
}
/*
* Return all missing values.
*/
ret = NclReturnValue(date,ndims_date,dsizes_date,
&missing_date,type_date,0);
NclFree(dsizes_date);
return(ret);
}
/*
* Convert input to double if necessary.
*/
tmp_x = coerce_input_double(x,type_x,total_size_x,has_missing_x,&missing_x,
&missing_dx);
/*
* This is the bug fix for 360 day calendars and a units
* of "years since" or "months since". We have to convert
* from "years since" or "months since" to "days since".
*
* See above for more information about the bug.
*/
if(years_to_days_fix == 1) {
for(i = 0; i < total_size_x; i++ ) tmp_x[i] *= 360.;
}
if(months_to_days_fix == 1) {
for(i = 0; i < total_size_x; i++ ) tmp_x[i] *= 30.;
}
/*
* Loop through each element and get the 6 values.
*/
index_date = 0;
for( i = 0; i < total_size_x; i++ ) {
if(!has_missing_x ||
(has_missing_x && tmp_x[i] != missing_dx.doubleval)) {
(void) utCalendar2_cal(tmp_x[i],utunit,&year,&month,&day,
&hour,&minute,&second,ccal);
/*
* Calculate the return values, based on the input option.
*/
switch(*option) {
case 0:
((float*)date)[index_date] = (float)year;
((float*)date)[index_date+1] = (float)month;
((float*)date)[index_date+2] = (float)day;
((float*)date)[index_date+3] = (float)hour;
((float*)date)[index_date+4] = (float)minute;
((float*)date)[index_date+5] = second;
break;
/* identical to option=0, except returns ints */
case -5:
((int*)date)[index_date] = year;
((int*)date)[index_date+1] = month;
((int*)date)[index_date+2] = day;
((int*)date)[index_date+3] = hour;
((int*)date)[index_date+4] = minute;
((int*)date)[index_date+5] = (int)truncf(second);
break;
/*
* YYYYMM
*/
case -1:
((int*)date)[index_date] = (100*year) + month;
break;
case 1:
((double*)date)[index_date] = (double)(100*year) + (double)month;
break;
/*
* YYYYMMDD
*/
case -2:
((int*)date)[index_date] = (10000*year) + (100*month) + day;
break;
case 2:
((double*)date)[index_date] = (double)(10000*year)
+ (double)(100*month)
+ (double)day;
break;
/*
* YYYYMMDDHH
*/
case -3:
((int*)date)[index_date] = (1000000*year) + (10000*month)
+ (100*day) + hour;
break;
case 3:
((double*)date)[index_date] = (double)(1000000*year)
+ (double)(10000*month)
+ (double)(100*day)
+ (double)hour;
break;
/*
* YYYY.fraction_of_year
*/
case 4:
nsid = 86400; /* num seconds in a day */
if(ccal == NULL) {
total_seconds_in_year = seconds_in_year(year,"standard");
doy = day_of_year(year,month,day,"standard");
}
else {
total_seconds_in_year = seconds_in_year(year,ccal);
doy = day_of_year(year,month,day,ccal);
}
if(doy > 1) {
seconds_in_doy = (doy-1) * nsid;
}
else {
seconds_in_doy = 0;
}
if(hour > 1) {
seconds_in_hour = (hour-1) * 3600;
}
else {
seconds_in_hour = 0;
}
if(minute > 1) {
seconds_in_minute = (minute-1) * 60;
}
else {
seconds_in_minute = 0;
}
current_seconds_in_year = seconds_in_doy +
seconds_in_hour +
seconds_in_minute +
second;
fraction_of_year = current_seconds_in_year/(double)total_seconds_in_year;
((double*)date)[index_date] = (double)year + fraction_of_year;
break;
}
}
else {
switch(*option) {
case 0:
((float*)date)[index_date] = missing_date.floatval;
((float*)date)[index_date+1] = missing_date.floatval;
((float*)date)[index_date+2] = missing_date.floatval;
((float*)date)[index_date+3] = missing_date.floatval;
((float*)date)[index_date+4] = missing_date.floatval;
((float*)date)[index_date+5] = missing_date.floatval;
break;
/* identical to option=0, except returns ints */
case -5:
((int*)date)[index_date] = missing_date.intval;
((int*)date)[index_date+1] = missing_date.intval;
((int*)date)[index_date+2] = missing_date.intval;
((int*)date)[index_date+3] = missing_date.intval;
((int*)date)[index_date+4] = missing_date.intval;
((int*)date)[index_date+5] = missing_date.intval;
break;
case 1:
case 2:
case 3:
case 4:
((double*)date)[index_date] = missing_date.doubleval;
break;
case -1:
case -2:
case -3:
((int*)date)[index_date] = missing_date.intval;
break;
}
}
if(*option == 0 || *option == -5) {
index_date += 6;
}
else {
index_date++;
}
}
/*
* Free the work arrays.
*/
if(type_x != NCL_double) NclFree(tmp_x);
/*
* Close up Udunits.
*/
utclose_ncl(unit_system);
/*
* Free extra units
*/
NclFree(cspec_orig);
ut_free(utunit);
/*
* Set up variable to return.
*/
if(has_missing_x) {
return_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
date,
&missing_date,
ndims_date,
dsizes_date,
TEMPORARY,
NULL,
type_date_t
);
}
else {
return_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
date,
NULL,
ndims_date,
dsizes_date,
TEMPORARY,
NULL,
type_date_t
);
}
/*
* Set up attributes to return.
*/
att_id = _NclAttCreate(NULL,NULL,Ncl_Att,0,NULL);
dsizes[0] = 1;
/*
* Return "calendar" attribute.
*
* We can't just return "scal" here, because it's an NCL input
* parameter and this seems to screw things up if we try to
* return it as an attribute.
*/
calendar = (NclQuark*)NclMalloc(sizeof(NclQuark));
if(ccal != NULL) {
*calendar = NrmStringToQuark(ccal);
}
else {
*calendar = NrmStringToQuark("standard");
}
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
(void*)calendar,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
(NclObjClass)nclTypestringClass
);
_NclAddAtt(
att_id,
"calendar",
att_md,
NULL
);
tmp_var = _NclVarCreate(
NULL,
NULL,
Ncl_Var,
0,
NULL,
return_md,
NULL,
att_id,
NULL,
RETURNVAR,
NULL,
TEMPORARY
);
NclFree(dsizes_date);
/*
* Return output grid and attributes to NCL.
*/
return_data.kind = NclStk_VAR;
return_data.u.data_var = tmp_var;
_NclPlaceReturn(return_data);
return(NhlNOERROR);
}
NhlErrorTypes 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 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 ezfftb_W( void )
{
/*
* Input array variables
*/
void *cf;
double *tmp_cf1 = NULL;
double *tmp_cf2 = NULL;
int ndims_cf;
ng_size_t dsizes_cf[NCL_MAX_DIMENSIONS];
ng_size_t dsizes_xbar[1];
void *xbar;
double *tmp_xbar = NULL;
NclBasicDataTypes type_cf, type_xbar;
NclScalar missing_cf, missing_dcf, missing_rcf, missing_x;
int has_missing_cf;
/*
* Some variables we need to retrieve the "npts" atttribute (if it exists).
*/
NclAttList *att_list;
NclAtt tmp_attobj;
NclStackEntry data;
/*
* Output array variables
*/
void *x;
double *tmp_x;
int ndims_x;
ng_size_t dsizes_x[NCL_MAX_DIMENSIONS];
NclBasicDataTypes type_x;
/*
* various
*/
double *work;
ng_size_t index_cf, index_x;
ng_size_t i, *tmp_npts, npts, npts2, lnpts2, size_x, size_leftmost;
int found_missing1, found_missing2, any_missing, scalar_xbar;
int inpts;
/*
* Retrieve parameters
*
* Note any of the pointer parameters can be set to NULL, which
* implies you don't care about its value.
*/
cf = (void*)NclGetArgValue(
0,
2,
&ndims_cf,
dsizes_cf,
&missing_cf,
&has_missing_cf,
&type_cf,
DONT_CARE);
xbar = (void*)NclGetArgValue(
1,
2,
NULL,
dsizes_xbar,
NULL,
NULL,
&type_xbar,
DONT_CARE);
/*
* Calculate number of leftmost elements.
*/
size_leftmost = 1;
for( i = 1; i < ndims_cf-1; i++ ) size_leftmost *= dsizes_cf[i];
/*
* Check xbar dimension sizes.
*/
scalar_xbar = is_scalar(1,dsizes_xbar);
if(!scalar_xbar) {
/*
* If xbar is not a scalar, it must be an array of the same dimension
* sizes as the leftmost dimensions of cf (except the first dimension
* of '2').
*/
if(dsizes_xbar[0] != size_leftmost) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ezfftb: If xbar is not a scalar, then it must be a single vector of the length of the product of the leftmost dimensions of 'cf' (not including the '2' dimension)") ;
return(NhlFATAL);
}
}
/*
* Coerce missing values.
*/
coerce_missing(type_cf,has_missing_cf,&missing_cf,&missing_dcf,&missing_rcf);
/*
* Okay, what follows here is some code for retrieving the "npts"
* attribute if it exists. This attribute is one that should have been
* set when "ezfftf" was called, and it indicates the length of the
* original series.
*/
npts2 = dsizes_cf[ndims_cf-1]; /* Calculate the length in case */
/* it is not set explicitly. */
npts = 2*npts2;
data = _NclGetArg(0,2,DONT_CARE);
switch(data.kind) {
case NclStk_VAR:
if(data.u.data_var->var.att_id != -1) {
tmp_attobj = (NclAtt)_NclGetObj(data.u.data_var->var.att_id);
if(tmp_attobj == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ezfftb: Bad attribute list, can't continue");
return(NhlFATAL);
}
if(tmp_attobj->att.n_atts == 0) {
break;
}
att_list = tmp_attobj->att.att_list;
i = 0;
while(att_list != NULL) {
if(att_list->quark == NrmStringToQuark("npts")) {
tmp_npts = get_dimensions(att_list->attvalue->multidval.val,1,
att_list->attvalue->multidval.data_type,
"ezfftb");
npts = *tmp_npts;
free(tmp_npts);
if((npts % 2) == 0) {
npts2 = npts/2;
}
else {
npts2 = (npts-1)/2;
}
break;
}
att_list = att_list->next;
}
}
break;
default:
NhlPError(NhlFATAL,NhlEUNKNOWN,"ezfftb: data.kind, can't continue");
return(NhlFATAL);
}
/*
* Test input array size
*/
if(npts > INT_MAX) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ezfftb: npts = %d is greater than INT_MAX", npts);
return(NhlFATAL);
}
inpts = (int) npts;
/*
* Calculate size of output array.
*/
lnpts2 = npts2 * size_leftmost;
size_x = size_leftmost * npts;
ndims_x = ndims_cf - 1;
for(i = 0; i < ndims_x-1; i++ ) dsizes_x[i] = dsizes_cf[i+1];
dsizes_x[ndims_x-1] = npts;
/*
* Create arrays to coerce input to double if necessary.
*/
if(type_cf != NCL_double) {
tmp_cf1 = (double*)calloc(npts2,sizeof(double));
tmp_cf2 = (double*)calloc(npts2,sizeof(double));
if(tmp_cf1 == NULL || tmp_cf2 == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ezfftb: Unable to allocate memory for coercing input array to double precision");
return(NhlFATAL);
}
}
if(type_xbar != NCL_double) {
tmp_xbar = (double*)calloc(1,sizeof(double));
if(tmp_xbar == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ezfftb: Unable to allocate memory for coercing input array to double precision");
return(NhlFATAL);
}
}
/*
* Allocate memory for output array.
*/
tmp_x = (double *)calloc(npts,sizeof(double));
if (tmp_x == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ezfftb: Cannot allocate memory for temporary output array" );
return(NhlFATAL);
}
if(type_cf == NCL_double) {
type_x = NCL_double;
x = (void*)calloc(size_x,sizeof(double));
if(has_missing_cf) missing_x = missing_dcf;
}
else {
type_x = NCL_float;
x = (void*)calloc(size_x,sizeof(float));
if(has_missing_cf) missing_x = missing_rcf;
}
if (x == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ezfftb: Cannot allocate memory for output array" );
return(NhlFATAL);
}
/*
* Allocate memory for work array
*/
work = (double*)calloc(4*npts+15,sizeof(double));
if ( work == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ezfftb: Cannot allocate memory for work array" );
return(NhlFATAL);
}
/*
* If xbar is a scalar, coerce it outside the loop.
*/
if(scalar_xbar) {
if(type_xbar != NCL_double) {
coerce_subset_input_double(xbar,tmp_xbar,0,type_xbar,1,0,NULL,NULL);
}
else {
tmp_xbar = &((double*)xbar)[0];
}
}
/*
* Call the f77 version of 'dezfftb' with the full argument list.
*/
index_x = index_cf = 0;
any_missing = 0;
for(i = 0; i < size_leftmost; i++) {
if(type_cf != NCL_double) {
coerce_subset_input_double(cf,tmp_cf1,index_cf,type_cf,npts2,0,
NULL,NULL);
coerce_subset_input_double(cf,tmp_cf2,lnpts2+index_cf,type_cf,npts2,0,
NULL,NULL);
}
else {
tmp_cf1 = &((double*)cf)[index_cf];
tmp_cf2 = &((double*)cf)[lnpts2+index_cf];
}
/*
* Check for missing values in cf. If any, then coerce that section of
* the output to missing.
*/
found_missing1 = contains_missing(tmp_cf1,npts2,has_missing_cf,
missing_dcf.doubleval);
found_missing2 = contains_missing(tmp_cf2,npts2,has_missing_cf,
missing_dcf.doubleval);
if(found_missing1 || found_missing2) {
any_missing++;
set_subset_output_missing(x,index_x,type_x,npts,missing_dcf.doubleval);
}
else {
/*
* If xbar is not a scalar, then we need to coerce each element
* to double or else just grab its value.
*/
if(!scalar_xbar) {
if(type_xbar != NCL_double) {
coerce_subset_input_double(xbar,tmp_xbar,i,type_xbar,1,0,NULL,NULL);
}
else {
tmp_xbar = &((double*)xbar)[i];
}
}
NGCALLF(dezffti,DEZFFTI)(&inpts,work);
NGCALLF(dezfftb,DEZFFTB)(&inpts,tmp_x,tmp_xbar,tmp_cf1,tmp_cf2,work);
/*
* Copy results back into x.
*/
coerce_output_float_or_double(x,tmp_x,type_cf,npts,index_x);
}
index_x += npts;
index_cf += npts2;
}
/*
* Free up memory.
*/
if(type_cf != NCL_double) {
free(tmp_cf1);
free(tmp_cf2);
}
if(type_xbar != NCL_double) free(tmp_xbar);
free(tmp_x);
free(work);
if(any_missing) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"ezfftb: %d input arrays contained missing values. No calculations performed on these arrays.",any_missing);
return(NclReturnValue(x,ndims_x,dsizes_x,&missing_x,type_x,0));
}
else {
return(NclReturnValue(x,ndims_x,dsizes_x,NULL,type_x,0));
}
}
int
main(int argc, char **argv) {
int errid = -1;
int appid;
int i, k = 0;
int reset = 1;
DIR *d;
struct dirent *ent;
#if defined(HPUX)
shl_t so_handle;
#else
void *so_handle;
#endif /* defined(HPUX) */
char buffer[4 * NCL_MAX_STRING];
void (*init_function) (void);
char *libpath;
char *scriptpath;
char *pt;
char *tmp = NULL;
/*
* Variables for command line options/arguments
*/
char *myName; /* argv[0]: program name (should be 'ncl') */
char **NCL_ARGV;
int NCL_ARGC; /* local argv/argc -- future use for NCL scripts? */
int c;
char **cargs = NULL;
int nargs = 0;
struct stat sbuf;
int sr;
FILE *tmpf = NULL; /* file variables for creating arguments */
char *tmpd = NULL;
strcpy(buffer,(char *)GetNCARGPath("tmp"));
sr = access(buffer,W_OK|X_OK|F_OK);
if(sr != 0) {
NhlPError(NhlWARNING,NhlEUNKNOWN,
"\"%s\" tmp dir does not exist or is not writable: NCL functionality may be limited -- check TMPDIR environment variable",
buffer);
}
#ifdef YYDEBUG
extern int yydebug;
yydebug = 1;
#endif /* YYDEBUG */
error_fp = stderr;
stdout_fp = stdout;
stdin_fp = stdin;
ncopts = NC_VERBOSE;
cmd_line =isatty(fileno(stdin));
myName = NclMalloc(strlen(argv[0]) + 1);
(void) strcpy(myName, argv[0]);
/*
* Save NCL argv, for command line processing later use
*/
NCL_ARGV = (char **) NclMalloc(argc * sizeof(char *));
for (i = 0; i < argc; i++) {
NCL_ARGV[i] = (char *) NclMalloc((strlen(argv[i]) + 1) * sizeof(char *));
(void) strcpy(NCL_ARGV[i], argv[i]);
}
NCL_ARGC = argc;
for(i = 0; i < _NclNumberOfFileFormats; ++i)
NCLadvancedFileStructure[i] = 0;
#ifdef NCLDEBUG
for (i = 0; i < NCL_ARGC; i++, *NCL_ARGV++)
(void) printf("NCL_ARGV[%d] = %s\n", i, *NCL_ARGV);
#endif /* NCLDEBUG */
/*
* Defined arguments
*
* -n element print: don't enumerate elements in print()
* -x echo: turns on command echo
* -V version: output NCARG/NCL version, exit
* -o old behavior: retain former behavior for backwards incompatible changes
* -h help: output options and exit
*
* -X override: echo every stmt regardless (unannounced option)
* -Q override: don't echo copyright notice (unannounced option)
*/
opterr = 0; /* turn off getopt() msgs */
while ((c = getopt (argc, argv, "fhnoxVXQp")) != -1) {
switch (c) {
case 'p':
NCLnoSysPager = 1;
break;
case 'n':
NCLnoPrintElem = 1;
break;
case 'o':
NCLoldBehavior = 1;
break;
case 'x':
NCLecho = 1;
break;
/* NOT ADVERTISED! Will override "no echo" and print EVERYTHING! */
case 'X':
NCLoverrideEcho = 1;
break;
/* NOT ADVERTISED! Will not echo copyright notice! */
case 'Q':
NCLnoCopyright = 1;
break;
case 'V':
(void) fprintf(stdout, "%s\n", GetNCLVersion());
exit(0);
break;
case 'f':
for(i = 0; i < _NclNumberOfFileFormats; ++i)
NCLadvancedFileStructure[i] = 1;
break;
case 'h':
(void) fprintf(stdout, "Usage: ncl -fhnpxV <args> <file.ncl>\n");
(void) fprintf(stdout, "\t -f: Use New File Structure, and NetCDF4 features\n");
(void) fprintf(stdout, "\t -n: don't enumerate values in print()\n");
(void) fprintf(stdout, "\t -p: don't page output from the system() command\n");
(void) fprintf(stdout, "\t -o: retain former behavior for certain backwards-incompatible changes\n");
(void) fprintf(stdout, "\t -x: echo NCL commands\n");
(void) fprintf(stdout, "\t -V: print NCL version and exit\n");
(void) fprintf(stdout, "\t -h: print this message and exit\n");
exit(0);
break;
case '?':
if (isprint(optopt))
(void) fprintf(stderr, "Unknown option `-%c'\n", optopt);
else
(void) fprintf(stderr, "Unknown option character `\\x%x'\n", optopt);
break;
default:
break;
}
}
/*
* Announce NCL copyright notice, etc.
*/
if (!NCLnoCopyright)
(void) fprintf(stdout,
" Copyright (C) 1995-2013 - All Rights Reserved\n University Corporation for Atmospheric Research\n NCAR Command Language Version %s\n The use of this software is governed by a License Agreement.\n See http://www.ncl.ucar.edu/ for more details.\n", GetNCLVersion());
/* Process any user-defined arguments */
for (i = optind; i < argc; i++) {
#ifdef NCLDEBUG
(void) printf("Non-option argument %s\n", argv[i]);
#endif /* NCLDEBUG */
/*
* Is this a file of NCL commands? Can't assume ".ncl" tag, unfortunately.
* Check for file's existence; the stat() call does not require access rights
* but does require search path rights, so if this fails, the file could exist
* but the user may not have permission to "see" it.
*/
sr = stat(argv[i], &sbuf);
if (sr == 0) {
#ifdef NCLDEBUG
(void) printf("NCL commands file: %s\n", argv[i]);
#endif /* NCLDEBUG */
nclf = argv[i];
continue;
}
if (sr < 0) {
if (!strchr(argv[i], '=')) {
/* argument is intended to be a file; can't locate it */
NhlPError(NhlFATAL, NhlEUNKNOWN, " can't find file \"%s\"\n", argv[i]);
exit(NhlFATAL);
} else {
/* user-defined argument */
if (nargs == 0)
cargs = (char **) NclMalloc(sizeof(char *));
else
cargs = (char **) NclRealloc(cargs, (nargs + 1) * sizeof(char *));
cargs[nargs] = (char *) NclMalloc((strlen(argv[i]) + 2) * sizeof(char *));
(void) sprintf(cargs[nargs], "%s\n", argv[i]);
nargs++;
}
}
}
if(nclf){
NCL_PROF_INIT(nclf);
}
else{
NCL_PROF_INIT("cmdline");
}
error_fp = stderr;
stdout_fp = stdout;
stdin_fp = stdin;
cur_line_text = NclMalloc((unsigned int) 512);
cur_line_maxsize = 512;
cur_line_text_pos = &(cur_line_text[0]);
#ifdef NCLDEBUG
thefptr = fopen("ncl.tree", "w");
theoptr = fopen("ncl.seq", "w");
#else
thefptr = NULL;
theoptr = NULL;
#endif /* NCLDEBUG */
/*
* Note: child processes should use _exit() instead of exit() to avoid calling the atexit()
* functions prematurely
*/
NhlInitialize();
NhlVACreate(&appid, "ncl", NhlappClass, NhlDEFAULT_APP,
NhlNappDefaultParent, 1, NhlNappUsrDir, "./", NULL);
NhlPalLoadColormapFiles(NhlworkstationClass,False);
errid = NhlErrGetID();
NhlVAGetValues(errid, NhlNerrFileName, &tmp, NULL);
if ((tmp == NULL) || (!strcmp(tmp, "stderr")))
NhlVASetValues(errid, NhlNerrFilePtr, stdout, NULL);
_NclInitMachine();
_NclInitSymbol();
_NclInitTypeClasses();
_NclInitDataClasses();
/* if the -o flag is specified do stuff to make NCL backwards compatible */
if (NCLoldBehavior) {
_NclSetDefaultFillValues(NCL_5_DEFAULT_FILLVALUES);
}
/* Handle default directories */
if ((libpath = getenv("NCL_DEF_LIB_DIR")) != NULL) {
d = opendir(_NGResolvePath(libpath));
if (d != NULL) {
while((ent = readdir(d)) != NULL) {
if (*ent->d_name != '.') {
(void) sprintf(buffer, "%s/%s", _NGResolvePath(libpath), ent->d_name);
#if defined (HPUX)
so_handle = shl_load(buffer, BIND_IMMEDIATE, 0L);
#else
so_handle = dlopen(buffer, RTLD_NOW);
if (so_handle == NULL) {
NhlPError(NhlFATAL, NhlEUNKNOWN,
"Could not open (%s): %s.", buffer, dlerror());
}
#endif /* HPUX */
if (so_handle != NULL) {
#if defined (HPUX)
init_function = NULL;
(void) shl_findsym(&so_handle, "Init",
TYPE_UNDEFINED, (void *) &init_function);
#else
init_function = dlsym(so_handle, "Init");
#endif /* HPUX */
if (init_function != NULL) {
(*init_function)();
} else {
#if defined (HPUX)
shl_unload(so_handle);
#else
dlclose(so_handle);
#endif /* HPUX */
NhlPError(NhlWARNING, NhlEUNKNOWN,
"Could not find Init() in external file %s, file not loaded.",
buffer);
}
}
}
}
} else {
NhlPError(NhlWARNING, NhlEUNKNOWN,
"Could not open default library path (%s), no libraries loaded.", libpath);
}
_NclResetNewSymStack();
}
if (cmd_line == 1) {
InitializeReadLine(1);
/*
* This next line is only to deal with an optimization bug with gcc
* version 4.0.1 on MacOS 10.4. It apparently saw that "cmd_line"
* was already of value 1 before it went into NclSetPromptFunc, so
* when it optimized the code, it ignored the "cmd_line = 1" line
* right after the NclSetPromptFunc call. Since NclSetPrompFunc
* was setting cmd_line =2, this meant that the value of cmd_line
* stayed 2, which is the wrong value.
*/
cmd_line = 0;
NclSetPromptFunc(nclprompt, NULL);
cmd_line = 1;
cmd_line_is_set = 1;
} else {
InitializeReadLine(0);
}
/* Load default scripts */
/* These need to be loaded in alphabetical order to ensure that users can control
* the order of loading. There is a BSD function scandir that would do it all but it
* might not be standardized enough to be uniformly available on all systems, so for
* now it must be coded just using readdir.
*/
if ((scriptpath = getenv("NCL_DEF_SCRIPTS_DIR")) != NULL) {
d = opendir(_NGResolvePath(scriptpath));
if (d!= NULL) {
int script_count = 0, alloc_count = 32;
NrmQuark *qscript_names = NclMalloc(alloc_count * sizeof(NrmQuark));
while((ent = readdir(d)) != NULL) {
if (*ent->d_name != '.') {
(void) sprintf(buffer, "%s/%s", _NGResolvePath(scriptpath), ent->d_name);
pt = strrchr(buffer, '.');
if (pt != NULL) {
pt++;
if (strncmp(pt, "ncl", 3) == 0) {
if (script_count == alloc_count) {
alloc_count *= 2;
qscript_names = NclRealloc(qscript_names,alloc_count * sizeof(NrmQuark));
}
qscript_names[script_count++] = NrmStringToQuark(ent->d_name);
}
}
}
}
if (script_count == 0) {
NhlPError(NhlWARNING, NhlEUNKNOWN,
"No scripts found: scripts must have the \".ncl\" file extension.");
}
else {
qsort(qscript_names,script_count,sizeof(NrmQuark),quark_comp);
for (i = 0; i < script_count; i++) {
(void) sprintf(buffer, "%s/%s", _NGResolvePath(scriptpath), NrmQuarkToString(qscript_names[i]));
if (_NclPreLoadScript(buffer, 1) == NhlFATAL) {
NhlPError(NhlFATAL, NhlEUNKNOWN, "Error loading default script.");
} else {
yyparse(reset);
}
}
NclFree(qscript_names);
}
} else {
NhlPError(NhlWARNING, NhlEUNKNOWN,
" Could not open default script path (%s), no scripts loaded.", scriptpath);
}
}
/*
* Create the new args
*
* Ideally this would be done using calls to the parser/stack engine but there is
* no clean interface to that process. Investigate _NclParseString() in the future.
*
* For now, create a temporary file with NCL commands and execute it.
*/
if (nargs) {
cmd_line = 0; /* non-interactive */
tmpd = (char *) _NGGetNCARGEnv("tmp"); /* defaults to: /tmp */
(void) sprintf(buffer, "%s/ncl%d.ncl", tmpd, getpid());
tmpf = fopen(buffer, "w");
for (k = 0; k < nargs; k++) {
if ((strstr(cargs[k], "=")) == (char *) NULL)
NhlPError(NhlWARNING, NhlEUNKNOWN, " Improper assignment for variable %s", cargs[k]);
else
(void) fwrite(cargs[k], strlen(cargs[k]), 1, tmpf);
}
/* don't forget last newline; NCL requires it */
(void) fwrite("\n", 1, 1, tmpf);
(void) fclose(tmpf);
if (_NclPreLoadScript(buffer, 1) == NhlFATAL) {
NhlPError(NhlFATAL, NhlEUNKNOWN, "Error initializing command line arguments.");
(void) unlink(buffer);
} else {
yyparse(reset);
}
(void) unlink(buffer);
cmd_line = 1; /* reset to default: interactive */
}
/* Load utility script */
strcpy(buffer, _NGResolvePath("$NCARG_ROOT/lib/ncarg/nclscripts/utilities.ncl"));
sr = stat(buffer, &sbuf);
if(0 == sr)
{
if(_NclPreLoadScript(buffer, 1) == NhlFATAL)
{
NclReturnStatus = NclFileNotFound;
NhlPError(NhlINFO, NhlEUNKNOWN, "Error loading NCL utility script.");
}
else
yyparse(reset);
}
/* Load any provided script */
if (nclf != (char *) NULL) {
(void) strcpy(buffer, _NGResolvePath(nclf));
if (_NclPreLoadScript(buffer, 0) == NhlFATAL)
{
NclReturnStatus = NclFileNotFound;
NhlPError(NhlFATAL, NhlEUNKNOWN, "Error loading provided NCL script.");
}
else
yyparse(reset);
} else {
yyparse(reset);
}
#ifdef NCLDEBUG
(void) fclose(thefptr);
(void) fprintf(stdout,"Number of unfreed objects %d\n",_NclNumObjs());
_NclObjsSize(stdout);
_NclNumGetObjCals(stdout);
_NclPrintUnfreedObjs(theoptr);
(void) fprintf(stdout,"Number of constants used %d\n",number_of_constants);
(void) fclose(theoptr);
#endif /* NCLDEBUG */
NclFree(myName);
_NclExit(NclReturnStatus);
return NclReturnStatus;
}
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);
}
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 tdez3d_W( void )
{
float *x, *y, *z, *u, *value, *up;
ng_size_t nx, dsizes_x[NCL_MAX_DIMENSIONS];
ng_size_t ny, dsizes_y[NCL_MAX_DIMENSIONS];
ng_size_t nz, dsizes_z[NCL_MAX_DIMENSIONS];
ng_size_t dsizes_u[NCL_MAX_DIMENSIONS];
float *rmult, *theta, *phi;
int *nwid, *style;
/*
* Variables for retrieving workstation information.
*/
int grlist, gkswid, nid;
NclHLUObj tmp_hlu_obj;
ng_size_t i, j, k, inx, iny, inz;
/*
* 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,10,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
x = (float*)NclGetArgValue(1,10, NULL, dsizes_x, NULL,NULL,NULL,DONT_CARE);
y = (float*)NclGetArgValue(2,10, NULL, dsizes_y, NULL,NULL,NULL,DONT_CARE);
z = (float*)NclGetArgValue(3,10, NULL, dsizes_z, NULL,NULL,NULL,DONT_CARE);
u = (float*)NclGetArgValue(4,10, NULL, dsizes_u, NULL,NULL,NULL,DONT_CARE);
value = (float*)NclGetArgValue(5,10,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
rmult = (float*)NclGetArgValue(6,10,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
theta = (float*)NclGetArgValue(7,10,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
phi = (float*)NclGetArgValue(8,10,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
style = (int*)NclGetArgValue(9,10,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
/*
* Test dimension sizes.
*/
nx = dsizes_x[0];
ny = dsizes_y[0];
nz = dsizes_z[0];
if((nx > INT_MAX) || (ny > INT_MAX) || (nz > INT_MAX)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"tdez3d: the length of x, y and/or z is greater than INT_MAX");
return(NhlFATAL);
}
inx = (int) nx;
iny = (int) ny;
inz = (int) nz;
/*
* Check input sizes.
*/
if( (dsizes_u[0] == nx) && (dsizes_u[1] == ny) && (dsizes_u[2] == nz) ) {
/*
* Reverse the order of the dimensions.
*/
up = (float *) calloc(nx*ny*nz,sizeof(float));
for (i = 0; i < nx; i++) {
for (j = 0; j < ny; j++) {
for (k = 0; k < nz; k++) {
up[nx*ny*k + j*nx + i] =
u[i*nz*ny + nz*j + k];
}
}
}
/*
* 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_tdez3d function, and then deactivates the workstation.
*/
gactivate_ws (gkswid);
c_tdez3d(nx,ny,nz,x,y,z,up,*value,
*rmult,*theta,*phi,*style);
gdeactivate_ws (gkswid);
free(up);
}
else {
NhlPError(NhlFATAL,NhlEUNKNOWN,"tdez3d: the dimension sizes of u must be the dimension of x by the dimension of y by the dimension of z");
return(NhlFATAL);
}
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 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 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 tdgetp_W(void)
{
/*
* Get values for tdpack parameters.
*/
char *arg1;
int numpi, numpf, i;
/*
* List the integer and float parameter names. To add new ones,
* all that needs to be done is add the names to this list.
*/
char *params_i[] = {"cs1", "cs2", "fov", "hnd", "ifc1", "ifc2",
"ifc3", "ifc4", "ilc1", "ilc2", "iltd",
"lsu", "lsv", "lsw", "set", "shd", "ste",
"CS1", "CS2", "FOV", "HND", "IFC1", "IFC2",
"IFC3", "IFC4", "ILC1", "ILC2", "ILTD",
"LSU", "LSV", "LSW", "SET", "SHD", "STE",
};
char *params_f[] = {"cs1", "cs2", "fov", "lsu", "lsv", "lsw",
"vpb", "vpl", "vpr", "vpt", "ustp", "vstp", "wstp"
"CS1", "CS2", "FOV", "LSU", "LSV", "LSW",
"VPB", "VPL", "VPR", "VPT", "USTP", "VSTP", "WSTP"
};
/*
* Input array variable
*/
NrmQuark *pname;
int ndims_pname;
ng_size_t dsizes_pname[NCL_MAX_DIMENSIONS];
float *fval;
int *ival;
ng_size_t ret_size = 1;
/*
* Retrieve argument #1
*/
pname = (NrmQuark *) NclGetArgValue(
0,
1,
&ndims_pname,
dsizes_pname,
NULL,
NULL,
NULL,
DONT_CARE);
arg1 = NrmQuarkToString(*pname);
/*
* Check to see if the parameter name is valid.
*/
numpf = sizeof(params_f)/sizeof(void *);
numpi = sizeof(params_i)/sizeof(void *);
for (i = 0; i < numpf; i++) {
if (!strncmp(arg1, params_f[i], strlen(params_f[i]))) {
goto OK_NAME;
}
}
for (i = 0; i < numpi; i++) {
if (!strncmp(arg1, params_i[i], strlen(params_i[i]))) {
goto OK_NAME;
}
}
NhlPError(NhlFATAL, NhlEUNKNOWN, "tdgetp: unrecognized parameter name");
return(NhlFATAL);
OK_NAME:
/*
* Process the parameter if it has a float value.
*/
for (i = 0; i < numpf; i++) {
if (!strncmp(arg1, params_f[i], strlen(params_f[i]))) {
fval = (float *) calloc(1,sizeof(float));
c_tdgetr(arg1, fval);
return(NclReturnValue((void *) fval, 1, &ret_size, NULL, NCL_float, 0));
}
}
/*
* Process the parameter if it has an integer value.
*/
for (i = 0; i < numpi; i++) {
if (!strncmp(arg1, params_i[i], strlen(params_i[i]))) {
ival = (int *) calloc(1,sizeof(int));
c_tdgeti(arg1, ival);
return(NclReturnValue( (void *) ival, 1, &ret_size, NULL, NCL_int, 0));
}
}
NhlPError(NhlFATAL, NhlEUNKNOWN, "tdgetp: impossible to get this message");
return(NhlFATAL);
}
NhlErrorTypes ut_inv_calendar_W( void )
{
/*
* Input array variables
*/
int *year, *month, *day, *hour, *minute;
void *second;
double *tmp_second = NULL;
NrmQuark *sspec;
int *option;
char *cspec, *cspec_orig;
int ndims_year;
ng_size_t dsizes_year[NCL_MAX_DIMENSIONS];
int has_missing_year;
int ndims_month;
ng_size_t dsizes_month[NCL_MAX_DIMENSIONS];
int has_missing_month;
int ndims_day;
ng_size_t dsizes_day[NCL_MAX_DIMENSIONS];
int has_missing_day;
int ndims_hour;
ng_size_t dsizes_hour[NCL_MAX_DIMENSIONS];
int has_missing_hour;
int ndims_minute;
ng_size_t dsizes_minute[NCL_MAX_DIMENSIONS];
int has_missing_minute;
int ndims_second;
ng_size_t dsizes_second[NCL_MAX_DIMENSIONS];
int has_missing_second;
NclScalar missing_year;
NclScalar missing_month;
NclScalar missing_day;
NclScalar missing_hour;
NclScalar missing_minute;
NclScalar missing_second;
NclBasicDataTypes type_second;
/*
* Variables for Udunits package.
*/
ut_system *utopen_ncl(), *unit_system;
ut_unit *utunit;
/*
* Variables for retrieving attributes from last argument.
*/
NclAttList *attr_list;
NclAtt attr_obj;
NclStackEntry stack_entry;
NrmQuark *scal;
char *ccal = NULL;
/*
* Output variables.
*/
double *x;
int has_missing_x;
NclScalar missing_x;
/*
* Variables for returning "units" and "calendar" attributes.
*/
NclQuark *units, *calendar;
int att_id;
NclMultiDValData att_md, return_md;
NclVar tmp_var;
NclStackEntry return_data;
/*
* various
*/
ng_size_t i, total_size_input;
ng_size_t dsizes[1], return_missing;
int months_to_days_fix=0, years_to_days_fix=0;
/*
* Before we do anything, initialize the Udunits package.
*/
unit_system = utopen_ncl();
/*
* Retrieve parameters
*
* Note any of the pointer parameters can be set to NULL, which
* implies you don't care about its value.
* The first size input arrays must be the same dimension sizes.
*/
year = (int*)NclGetArgValue(
0,
8,
&ndims_year,
dsizes_year,
&missing_year,
&has_missing_year,
NULL,
DONT_CARE);
month = (int*)NclGetArgValue(
1,
8,
&ndims_month,
dsizes_month,
&missing_month,
&has_missing_month,
NULL,
DONT_CARE);
day = (int*)NclGetArgValue(
2,
8,
&ndims_day,
dsizes_day,
&missing_day,
&has_missing_day,
NULL,
DONT_CARE);
hour = (int*)NclGetArgValue(
3,
8,
&ndims_hour,
dsizes_hour,
&missing_hour,
&has_missing_hour,
NULL,
DONT_CARE);
minute = (int*)NclGetArgValue(
4,
8,
&ndims_minute,
dsizes_minute,
&missing_minute,
&has_missing_minute,
NULL,
DONT_CARE);
second = (void*)NclGetArgValue(
5,
8,
&ndims_second,
dsizes_second,
&missing_second,
&has_missing_second,
&type_second,
DONT_CARE);
if(ndims_year != ndims_month || ndims_year != ndims_day ||
ndims_year != ndims_hour || ndims_year != ndims_minute ||
ndims_year != ndims_second) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ut_inv_calendar: The first six arguments must have the same dimensionality");
return(NhlFATAL);
}
for(i = 0; i < ndims_year; i++ ) {
if(dsizes_year[i] != dsizes_month[i] ||
dsizes_year[i] != dsizes_day[i] ||
dsizes_year[i] != dsizes_hour[i] ||
dsizes_year[i] != dsizes_minute[i] ||
dsizes_year[i] != dsizes_second[i]) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ut_inv_calendar: The first six arguments must have the same dimensionality");
return(NhlFATAL);
}
}
/*
* x will contain a _FillValue attribute if any of the input
* has a _FillValue attribute set.
*/
if(has_missing_year || has_missing_month || has_missing_day ||
has_missing_hour || has_missing_minute || has_missing_second) {
has_missing_x = 1;
/*
* Get the default missing value for a double type.
*/
missing_x = ((NclTypeClass)nclTypedoubleClass)->type_class.default_mis;
}
else {
has_missing_x = 0;
}
/*
* Get spec string.
*/
sspec = (NrmQuark *)NclGetArgValue(
6,
8,
NULL,
NULL,
NULL,
NULL,
NULL,
1);
/*
* Get option.
*/
option = (int*)NclGetArgValue(
7,
8,
NULL,
NULL,
NULL,
NULL,
NULL,
1);
/*
* Check the "option" variable to see if it contains a "calendar"
* attribute.
*/
return_missing = 0;
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 specified 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 ((strcmp(attr_list->attname, "calendar")) == 0) {
scal = (NrmQuark *) attr_list->attvalue->multidval.val;
ccal = NrmQuarkToString(*scal);
if(strcasecmp(ccal,"standard") && strcasecmp(ccal,"gregorian") &&
strcasecmp(ccal,"noleap") && strcasecmp(ccal,"365_day") &&
strcasecmp(ccal,"365") && strcasecmp(ccal,"360_day") &&
strcasecmp(ccal,"360") ) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"ut_inv_calendar: the 'calendar' attribute is not equal to a recognized calendar. Returning all missing values.");
return_missing = has_missing_x = 1;
}
}
attr_list = attr_list->next;
}
}
default:
break;
}
/*
* Convert sspec to character string.
*/
cspec = NrmQuarkToString(*sspec);
/*
* There's a bug in utInvCalendar2_cal that doesn't handle the
* 360-day calendar correctly if units are "years since" or
* "months since".
*
* To fix this bug, we convert these units to "days since", do the
* calculation as "days since", and then convert back to the original
* "years since" or "months since" requested units.
*/
cspec_orig = (char*)calloc(strlen(cspec)+1,sizeof(char));
strcpy(cspec_orig,cspec);
cspec = fix_units_for_360_bug(ccal,cspec,&months_to_days_fix,
&years_to_days_fix);
/*
* Make sure cspec is a valid udunits string.
*/
utunit = ut_parse(unit_system, cspec, UT_ASCII);
if(utunit == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ut_inv_calendar: Invalid specification string");
return(NhlFATAL);
}
/*
* Calculate total size of input arrays, and size and dimensions for
* output array, and alloc memory for output array.
*/
total_size_input = 1;
for( i = 0; i < ndims_year; i++ ) total_size_input *= dsizes_year[i];
x = (double *)calloc(total_size_input,sizeof(double));
if( x == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ut_inv_calendar: Unable to allocate memory for output array");
return(NhlFATAL);
}
/*
* Create tmp array for coercing second to double if necessary.
*/
if(type_second != NCL_double) {
tmp_second = (double*)calloc(1,sizeof(double));
if(tmp_second == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ut_inv_calendar: Unable to allocate memory for coercing second array to double precision");
return(NhlFATAL);
}
}
/*
* Loop through each data value, and call Udunits routine.
*/
for( i = 0; i < total_size_input; i++ ) {
/*
* Coerce "second" to double, since this is what the original Udunits
* routine is expecting.
*/
if(type_second != NCL_double) {
coerce_subset_input_double(second,tmp_second,i,type_second,1,
has_missing_second,&missing_second,NULL);
}
else {
tmp_second = &((double*)second)[i];
}
if(!return_missing && (!has_missing_year ||
(has_missing_year && year[i] != missing_year.intval)) &&
(!has_missing_month ||
(has_missing_month && month[i] != missing_month.intval)) &&
(!has_missing_day ||
(has_missing_day && day[i] != missing_day.intval)) &&
(!has_missing_hour ||
(has_missing_hour && hour[i] != missing_hour.intval)) &&
(!has_missing_minute ||
(has_missing_minute && minute[i] != missing_minute.intval)) &&
(!has_missing_second ||
(has_missing_second && *tmp_second != missing_second.doubleval)) ) {
(void)utInvCalendar2_cal(year[i],month[i],day[i],hour[i],
minute[i],*tmp_second,utunit,&x[i],ccal);
/*
* This is the bug fix for 360 day calendars and a units
* of "years since" or "months since". We have to convert
* from "days since" to the original requested units.
*
* See above for more information about the bug.
*/
if(years_to_days_fix == 1) x[i] /= 360.;
if(months_to_days_fix == 1) x[i] /= 30.;
}
else {
x[i] = missing_x.doubleval;
}
}
/*
* Close up Udunits.
*/
utclose_ncl(unit_system);
/*
* Set original units back if necessary.
*/
if(months_to_days_fix || years_to_days_fix) {
cspec = cspec_orig;
}
else {
NclFree(cspec_orig);
}
if(type_second != NCL_double) NclFree(tmp_second);
/*
* Set up variable to return.
*/
if(has_missing_x) {
return_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
x,
&missing_x,
ndims_year,
dsizes_year,
TEMPORARY,
NULL,
(NclObjClass)nclTypedoubleClass
);
}
else {
return_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
x,
NULL,
ndims_year,
dsizes_year,
TEMPORARY,
NULL,
(NclObjClass)nclTypedoubleClass
);
}
/*
* Set up attributes to return.
*/
att_id = _NclAttCreate(NULL,NULL,Ncl_Att,0,NULL);
dsizes[0] = 1;
/*
* Return "units" attribute.
*
* We can't just return "sspec" here, because it's an NCL input
* parameter and this seems to screw things up if we try to
* return it as an attribute.
*/
units = (NclQuark*)NclMalloc(sizeof(NclQuark));
*units = NrmStringToQuark(cspec);
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
(void*)units,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
(NclObjClass)nclTypestringClass
);
_NclAddAtt(
att_id,
"units",
att_md,
NULL
);
/*
* Return "calendar" attribute.
*
* We can't just return "sspec" here, because it's an NCL input
* parameter and this seems to screw things up if we try to
* return it as an attribute.
*/
calendar = (NclQuark*)NclMalloc(sizeof(NclQuark));
if(ccal != NULL) {
*calendar = NrmStringToQuark(ccal);
}
else {
*calendar = NrmStringToQuark("standard");
}
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
(void*)calendar,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
(NclObjClass)nclTypestringClass
);
_NclAddAtt(
att_id,
"calendar",
att_md,
NULL
);
tmp_var = _NclVarCreate(
NULL,
NULL,
Ncl_Var,
0,
NULL,
return_md,
NULL,
att_id,
NULL,
RETURNVAR,
NULL,
TEMPORARY
);
/*
* 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 tdsetp_W(void)
{
char *arg1;
int numpi, numpf, i, j;
/*
* List the integer and float parameter names. To add new ones,
* all that needs to be done is add the names to this list.
*/
char *params_i[] = {"cs1", "cs2", "fov", "hnd", "ifc1", "ifc2",
"ifc3", "ifc4", "ilc1", "ilc2", "iltd",
"lsu", "lsv", "lsw", "set", "shd", "ste",
"CS1", "CS2", "FOV", "HND", "IFC1", "IFC2",
"IFC3", "IFC4", "ILC1", "ILC2", "ILTD",
"LSU", "LSV", "LSW", "SET", "SHD", "STE",
};
char *params_f[] = {"cs1", "cs2", "fov", "lsu", "lsv", "lsw",
"vpb", "vpl", "vpr", "vpt", "ustp", "vstp", "wstp"
"CS1", "CS2", "FOV", "LSU", "LSV", "LSW",
"VPB", "VPL", "VPR", "VPT", "USTP", "VSTP", "WSTP"
};
/*
* Input array variables
*/
NrmQuark *pname;
int ndims_pname;
ng_size_t dsizes_pname[NCL_MAX_DIMENSIONS];
void *pvalue;
int ndims_pvalue;
ng_size_t dsizes_pvalue[NCL_MAX_DIMENSIONS];
NclBasicDataTypes type_pvalue;
/*
* Retrieve argument #1
*/
pname = (NrmQuark *) NclGetArgValue(
0,
2,
&ndims_pname,
dsizes_pname,
NULL,
NULL,
NULL,
DONT_CARE);
arg1 = NrmQuarkToString(*pname);
/*
* Check to see if the parameter name is valid.
*/
numpi = sizeof(params_i)/sizeof(void *);
numpf = sizeof(params_f)/sizeof(void *);
for (i = 0; i < numpi; i++) {
if (!strncmp(arg1, params_i[i], strlen(params_i[i]))) {
goto OK_NAME;
}
}
for (i = 0; i < numpf; i++) {
if (!strncmp(arg1, params_f[i], strlen(params_f[i]))) {
goto OK_NAME;
}
}
NhlPError(NhlFATAL, NhlEUNKNOWN, "tdsetp: unrecognized parameter name");
return(NhlFATAL);
/*
* Retrieve argument #2
*/
OK_NAME: pvalue = (void *) NclGetArgValue(
1,
2,
&ndims_pvalue,
dsizes_pvalue,
NULL,
NULL,
&type_pvalue,
DONT_CARE);
/*
* Process the parameter if it has an integer value.
*/
if (type_pvalue == NCL_int) {
for (i = 0; i < numpi; i++) {
if (!strncmp(arg1, params_i[i], strlen(params_i[i]))) {
j = *((int *) pvalue);
c_tdseti(arg1, j);
return(NhlNOERROR);
}
}
NhlPError(NhlFATAL, NhlEUNKNOWN, "tdsetp: The specified value for the parameter has an invalid type");
return(NhlFATAL);
}
else if (type_pvalue == NCL_float || type_pvalue == NCL_double) {
/*
* Process the parameter if it has a float value or double value.
*/
for (i = 0; i < numpf; i++) {
if (!strncmp(arg1, params_f[i], strlen(params_f[i]))) {
if (type_pvalue == NCL_float) {
c_tdsetr(arg1, *((float *) pvalue));
return(NhlNOERROR);
}
else if (type_pvalue == NCL_double) {
c_tdsetr(arg1, (float) *((double *) pvalue));
return(NhlNOERROR);
}
}
}
NhlPError(NhlFATAL, NhlEUNKNOWN, "tdsetp: The specified value for the parameter has an invalid type");
return(NhlFATAL);
}
else {
NhlPError(NhlFATAL, NhlEUNKNOWN, "tdsetp: The specified value for the "
"parameter has an incorrect type");
return(NhlFATAL);
}
}
