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 tdinit_W( void )
{
/*
* Input variables
*/
float *mid, *orig, *third, *otep;
/*
* Retrieve parameters.
*
* Note that any of the pointer parameters can be set to NULL,
* which implies you don't care about its value.
*/
mid = (float*)NclGetArgValue(
0,
4,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
orig = (float*)NclGetArgValue(
1,
4,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
third = (float*)NclGetArgValue(
2,
4,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
otep = (float*)NclGetArgValue(
3,
4,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
c_tdinit(mid[0],mid[1],mid[2],orig[0],orig[1],orig[2],
third[0],third[1],third[2],*otep);
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 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 color_index_to_rgba_W( void )
{
int i, *ci;
float *rgba;
ng_size_t dsizes[2];
int stride;
/*
* Retrieve parameters
*
* Note any of the pointer parameters can be set to NULL, which
* implies you don't care about its value. In this example
* the type parameter is set to NULL because the function
* is later registered to only accept floating point numbers.
*
* Retrieve argument #1
*/
ci = (int *) NclGetArgValue(0,1,NULL,dsizes,NULL,NULL,
NULL,DONT_CARE);
/* ndims must be 1, dsizes[0] can be any number */
rgba = (float *) calloc(4 * dsizes[0], sizeof(float));
stride = 4;
for(i = 0; i < dsizes[0]; i++) {
_NhlColorIndexToRGBA(ci[i], rgba + i * stride,1);
}
dsizes[1] = 4;
return(NclReturnValue( (void *) rgba, 2, dsizes, NULL, NCL_float, 0));
}
NhlErrorTypes tdpara_W( void )
{
/*
* Input variables
*/
float *a00, *v10, *v01;
/*
* Retrieve parameters.
*
* Note that any of the pointer parameters can be set to NULL,
* which implies you don't care about its value.
*/
a00 = (float*)NclGetArgValue(
0,
3,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
v10 = (float*)NclGetArgValue(
1,
3,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
v01 = (float*)NclGetArgValue(
2,
3,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
c_tdpara(a00[0],a00[1],a00[2],v10[0],v10[1],v10[2],v01[0],v01[1],v01[2]);
return(NhlNOERROR);
}
NhlErrorTypes tdlnpa_W( void )
{
int *nwid;
float *uvw1, *uvw2;
/*
* Variables for retrieving workstation information.
*/
int grlist, gkswid, nid;
NclHLUObj tmp_hlu_obj;
/*
* Retrieve parameters.
*/
nwid = (int*)NclGetArgValue(0,3,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
uvw1 = (float*)NclGetArgValue(1,3,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
uvw2 = (float*)NclGetArgValue(2,3,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
/*
* 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_tdlnpa function, and then deactivates the workstation.
*/
gactivate_ws (gkswid);
c_tdlnpa(uvw1[0], uvw1[1], uvw2[0], uvw2[1]);
gdeactivate_ws (gkswid);
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 tdgrid_W( void )
{
int *nwid, *noxs, *noys, *igrd;
float *xbeg, *xstp, *ybeg, *ystp;
/*
* Variables for retrieving workstation information.
*/
int grlist, gkswid, nid;
NclHLUObj tmp_hlu_obj;
/*
* Retrieve parameters.
*/
nwid = (int*)NclGetArgValue(0,8,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
xbeg = (float*)NclGetArgValue(1,8,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
xstp = (float*)NclGetArgValue(2,8,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
noxs = (int*)NclGetArgValue(3,8,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
ybeg = (float*)NclGetArgValue(4,8,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
ystp = (float*)NclGetArgValue(5,8,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
noys = (int*)NclGetArgValue(6,8,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
igrd = (int*)NclGetArgValue(7,8,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
/*
* 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_tdgrid function, and then deactivates the workstation.
*/
gactivate_ws (gkswid);
c_tdgrid(*xbeg, *xstp, *noxs, *ybeg, *ystp, *noys, *igrd);
gdeactivate_ws (gkswid);
return(NhlNOERROR);
}
NhlErrorTypes tdprpi_W( void )
{
float *xy_in, xy_out[2];
ng_size_t dsizes_xy[1];
/*
* Retrieve parameter.
*/
xy_in = (float*)NclGetArgValue(0,1,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
c_tdprpi(xy_in[0], xy_in[1], &xy_out[0], &xy_out[1]);
dsizes_xy[0] = 2;
return(NclReturnValue( (void *) xy_out, 1, dsizes_xy, NULL, NCL_float, 0));
}
NhlErrorTypes tdprpt_W( void )
{
float *uvw, xy[2];
ng_size_t dsizes_xy[1];
/*
* Retrieve parameter.
*/
uvw = (float*)NclGetArgValue(0,1,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
c_tdprpt(uvw[0], uvw[1], uvw[2], &xy[0], &xy[1]);
dsizes_xy[0] = 2;
return(NclReturnValue( (void *) xy, 1, dsizes_xy, NULL, NCL_float, 0));
}
NhlErrorTypes 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 tdlbla_W( void )
{
int *nwid, *iaxs;
float *xat, *yat, *angd;
NrmQuark *ilbl, *nlbl;
char *cilbl, *cnlbl;
/*
* Variables for retrieving workstation information.
*/
int grlist, gkswid, nid;
NclHLUObj tmp_hlu_obj;
/*
* Retrieve parameters.
*/
nwid = (int*)NclGetArgValue(0,7,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
iaxs = (int*)NclGetArgValue(1,7,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
ilbl = (NrmQuark*)NclGetArgValue(2,7,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
nlbl = (NrmQuark*)NclGetArgValue(3,7,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
xat = (float*)NclGetArgValue(4,7,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
yat = (float*)NclGetArgValue(5,7,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
angd = (float*)NclGetArgValue(6,7,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
cilbl = NrmQuarkToString(*ilbl);
cnlbl = NrmQuarkToString(*nlbl);
/*
* 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_tdlbla function, and then deactivates the workstation.
*/
gactivate_ws (gkswid);
c_tdlbla(*iaxs, cilbl, cnlbl, xat[0], xat[1], yat[0], yat[1], *angd);
gdeactivate_ws (gkswid);
return(NhlNOERROR);
}
NhlErrorTypes tdplch_W( void )
{
int *nwid;
float *xpos, *ypos, *size, *angd, *cntr;
NrmQuark *chrs;
char *cchrs;
/*
* Variables for retrieving workstation information.
*/
int grlist, gkswid, nid;
NclHLUObj tmp_hlu_obj;
/*
* Retrieve parameters.
*/
nwid = (int*)NclGetArgValue(0,7,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
xpos = (float*)NclGetArgValue(1,7,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
ypos = (float*)NclGetArgValue(2,7,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
chrs = (NrmQuark*)NclGetArgValue(3,7,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
size = (float*)NclGetArgValue(4,7,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
angd = (float*)NclGetArgValue(5,7,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
cntr = (float*)NclGetArgValue(6,7,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
cchrs = NrmQuarkToString(*chrs);
/*
* 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_tdplch function, and then deactivates the workstation.
*/
gactivate_ws (gkswid);
c_tdplch(*xpos, *ypos, cchrs, *size, *angd, *cntr);
gdeactivate_ws (gkswid);
return(NhlNOERROR);
}
NhlErrorTypes tdlbls_W( void )
{
int *nwid, *ipck;
float *uvwmn, *uvwmx;
NrmQuark *uvwn, *uvwi;
char *cuvwn0, *cuvwi0, *cuvwn1, *cuvwi1, *cuvwn2, *cuvwi2;
/*
* Variables for retrieving workstation information.
*/
int grlist, gkswid, nid;
NclHLUObj tmp_hlu_obj;
/*
* Retrieve parameters.
*/
nwid = (int*)NclGetArgValue(0,6,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
uvwmn = (float*)NclGetArgValue(1,6,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
uvwmx = (float*)NclGetArgValue(2,6,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
uvwn = (NrmQuark*)NclGetArgValue(3,6,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
uvwi = (NrmQuark*)NclGetArgValue(4,6,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
ipck = (int*)NclGetArgValue(5,6,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
cuvwn0 = NrmQuarkToString(uvwn[0]);
cuvwi0 = NrmQuarkToString(uvwi[0]);
cuvwn1 = NrmQuarkToString(uvwn[1]);
cuvwi1 = NrmQuarkToString(uvwi[1]);
cuvwn2 = NrmQuarkToString(uvwn[2]);
cuvwi2 = NrmQuarkToString(uvwi[2]);
/*
* 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_tdlbls function, and then deactivates the workstation.
*/
gactivate_ws (gkswid);
c_tdlbls(uvwmn[0], uvwmn[1], uvwmn[2], uvwmx[0], uvwmx[1], uvwmx[2],
cuvwn0, cuvwn1, cuvwn2, cuvwi0, cuvwi1, cuvwi2, *ipck);
gdeactivate_ws (gkswid);
return(NhlNOERROR);
}
NhlErrorTypes tdclrs_W( void )
{
/*
* Definte a variable to store the HLU object identifier.
*/
NclHLUObj tmp_hlu_obj;
int *nwid, *ibow, *iofc, *iolc, *ilmt;
float *shde, *shdr;
int gkswid, grlist, nid;
/*
* 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,7,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
ibow = (int*)NclGetArgValue(1,7,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
shde = (float*)NclGetArgValue(2,7,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
shdr = (float*)NclGetArgValue(3,7,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
iofc = (int*)NclGetArgValue(4,7,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
iolc = (int*)NclGetArgValue(5,7,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
ilmt = (int*)NclGetArgValue(6,7,NULL,NULL,NULL,NULL,NULL,DONT_CARE);
/*
* 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);
gactivate_ws (gkswid);
c_tdclrs(gkswid, *ibow, *shde, *shdr, *iofc, *iolc, *ilmt);
gdeactivate_ws (gkswid);
return(NhlNOERROR);
}
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 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 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 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 linint2_points_W( void )
{
/*
* Input variables
*/
void *xi, *yi, *fi, *xo, *yo;
double *tmp_xi = NULL;
double *tmp_yi = NULL;
double *tmp_fi = NULL;
double *tmp_xo, *tmp_yo, *tmp_fo;
int ndims_xi;
ng_size_t dsizes_xi[NCL_MAX_DIMENSIONS];
int ndims_yi;
ng_size_t dsizes_yi[NCL_MAX_DIMENSIONS];
ng_size_t dsizes_xo[NCL_MAX_DIMENSIONS], dsizes_yo[NCL_MAX_DIMENSIONS];
int ndims_fi;
ng_size_t dsizes_fi[NCL_MAX_DIMENSIONS];
int has_missing_fi;
ng_size_t *dsizes_fo;
NclScalar missing_fi, missing_dfi, missing_rfi;
int *opt;
logical *wrap;
NclBasicDataTypes type_xi, type_yi, type_fi, type_xo, type_yo;
/*
* Output variables.
*/
void *fo;
/*
* Other variables
*/
double *xiw, *fxiw;
ng_size_t nxi, nxi2, nyi, nfi, nxyo, size_leftmost, size_fo;
ng_size_t i, j, index_xi, index_yi, index_fi, index_fo;
int inxi, inxi2, inyi, inxyo, ier, ret;
/*
* Retrieve parameters
*
* Note that any of the pointer parameters can be set to NULL,
* which implies you don't care about its value.
*/
xi = (void*)NclGetArgValue(
0,
7,
&ndims_xi,
dsizes_xi,
NULL,
NULL,
&type_xi,
DONT_CARE);
yi = (void*)NclGetArgValue(
1,
7,
&ndims_yi,
dsizes_yi,
NULL,
NULL,
&type_yi,
DONT_CARE);
fi = (void*)NclGetArgValue(
2,
7,
&ndims_fi,
dsizes_fi,
&missing_fi,
&has_missing_fi,
&type_fi,
DONT_CARE);
wrap = (logical*)NclGetArgValue(
3,
7,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
xo = (void*)NclGetArgValue(
4,
7,
NULL,
dsizes_xo,
NULL,
NULL,
&type_xo,
DONT_CARE);
yo = (void*)NclGetArgValue(
5,
7,
NULL,
dsizes_yo,
NULL,
NULL,
&type_yo,
DONT_CARE);
opt = (int*)NclGetArgValue(
6,
7,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Compute the total number of elements in our arrays.
*/
nxi = dsizes_xi[ndims_xi-1];
nyi = dsizes_yi[ndims_yi-1];
nxyo = dsizes_xo[0];
nxi2 = nxi+2;
if(dsizes_yo[0] != nxyo) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint2_points: xo and yo must be the same length");
return(NhlFATAL);
}
if(nxi < 2 || nyi < 2) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint2_points: xi and yi must both have at least two elements");
return(NhlFATAL);
}
nfi = nxi * nyi;
/*
* Test dimension sizes.
*/
if((nxi > INT_MAX) || (nyi > INT_MAX) || (nxyo > INT_MAX) ||
(nxi2 > INT_MAX)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint2_points: one or more dimension sizes is greater than INT_MAX");
return(NhlFATAL);
}
inxi = (int) nxi;
inyi = (int) nyi;
inxyo = (int) nxyo;
inxi2 = (int) nxi2;
/*
* Check dimensions of xi, yi, and fi. If xi/yi are not one-dimensional,
* then their leftmost dimensions must be the same size as the leftmost
* dimensions of fi. The last two dimensions of fi must be nyi x nxi.
*/
if(ndims_xi > 1) {
if(ndims_xi != ndims_fi-1) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint2_points: If xi is not one-dimensional, then it must have one less dimension than fi");
return(NhlFATAL);
}
for(i = 0; i < ndims_xi-1; i++) {
if(dsizes_xi[i] != dsizes_fi[i]) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint2_points: If xi is not one-dimensional, then its leftmost dimensions must be the same as the leftmost dimensions of fi");
return(NhlFATAL);
}
}
}
if(ndims_yi > 1) {
if(ndims_yi != ndims_fi-1) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint2_points: If yi is not one-dimensional, then it must have one less dimension than fi");
return(NhlFATAL);
}
for(i = 0; i < ndims_yi-1; i++) {
if(dsizes_yi[i] != dsizes_fi[i]) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint2_points: If yi is not one-dimensional, then its leftmost dimensions must be the same as the leftmost dimensions of fi");
return(NhlFATAL);
}
}
}
if(dsizes_fi[ndims_fi-2] != nyi || dsizes_fi[ndims_fi-1] != nxi) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint2_points: The rightmost dimensions of fi must be nyi x nxi, where nyi and nxi are the lengths of yi and xi respectively");
return(NhlFATAL);
}
/*
* Compute the total size of the output array (minus the last two dimensions).
*/
size_leftmost = 1;
for( i = 0; i < ndims_fi-2; i++ ) size_leftmost *= dsizes_fi[i];
size_fo = size_leftmost * nxyo;
/*
* Coerce missing values.
*/
coerce_missing(type_fi,has_missing_fi,&missing_fi,&missing_dfi,
&missing_rfi);
/*
* Allocate space for temporary output array.
*/
tmp_fo = (double*)calloc(nxyo,sizeof(double));
if(tmp_fo == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint2_points: Unable to allocate memory for temporary arrays");
return(NhlFATAL);
}
/*
* Allocate space for output array.
*/
dsizes_fo = (ng_size_t*)calloc(ndims_fi-1,sizeof(ng_size_t));
if(type_fi == NCL_double) {
fo = (void*)calloc(size_fo,sizeof(double));
}
else {
fo = (void*)calloc(size_fo,sizeof(float));
}
if(fo == NULL || dsizes_fo == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint2_points: Unable to allocate memory for output array");
return(NhlFATAL);
}
for(i = 0; i < ndims_fi-2; i++) dsizes_fo[i] = dsizes_fi[i];
dsizes_fo[ndims_fi-2] = nxyo;
/*
* Allocate space for work arrays.
*/
xiw = (double*)calloc(nxi2,sizeof(double));
fxiw = (double*)calloc(nyi*nxi2,sizeof(double));
if(xiw == NULL || fxiw == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint2_points: Unable to allocate memory for work arrays");
return(NhlFATAL);
}
/*
* Coerce input arrays to double if necessary.
*/
if(type_xi != NCL_double) {
tmp_xi = (double*)calloc(nxi,sizeof(double));
if(tmp_xi == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint2_points: Unable to allocate memory for coercing xi to double precision");
return(NhlFATAL);
}
}
if(type_yi != NCL_double) {
tmp_yi = (double*)calloc(nyi,sizeof(double));
if(tmp_yi == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint2_points: Unable to allocate memory for coercing yi to double precision");
return(NhlFATAL);
}
}
tmp_xo = coerce_input_double(xo,type_xo,nxyo,0,NULL,NULL);
tmp_yo = coerce_input_double(yo,type_yo,nxyo,0,NULL,NULL);
if(tmp_xo == NULL || tmp_yo == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint2_points: Unable to coerce input to double precision");
return(NhlFATAL);
}
if(type_fi != NCL_double) {
tmp_fi = (double*)calloc(nfi,sizeof(double));
if(tmp_fi == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint2_points: Unable to allocate memory for coercing input array to double precision");
return(NhlFATAL);
}
}
/*
* Call Fortran function.
*/
index_xi = index_yi = index_fi = index_fo = 0;
for( i = 0; i < size_leftmost; i++ ) {
if(ndims_xi > 1 || i == 0) {
if(type_xi != NCL_double) {
coerce_subset_input_double(xi,tmp_xi,index_xi,type_xi,nxi,0,NULL,NULL);
}
else {
tmp_xi = &((double*)xi)[index_xi];
}
}
if(ndims_yi > 1 || i == 0) {
if(type_yi != NCL_double) {
coerce_subset_input_double(yi,tmp_yi,index_yi,type_yi,nyi,0,NULL,NULL);
}
else {
tmp_yi = &((double*)yi)[index_yi];
}
}
if(type_fi != NCL_double) {
coerce_subset_input_double(fi,tmp_fi,index_fi,type_fi,nfi,0,NULL,NULL);
}
else {
tmp_fi = &((double*)fi)[index_fi];
}
NGCALLF(dlinint2pts,DLININT2PTS)(&inxi,tmp_xi,&inyi,tmp_yi,tmp_fi,wrap,
&inxyo,tmp_xo,tmp_yo,tmp_fo,xiw,fxiw,
&inxi2,&missing_dfi.doubleval,&ier);
if(ier) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"linint2_points: xi and yi must be monotonically increasing");
for(j = 0; j < nxyo; j++) {
if(type_fi == NCL_double) {
((double*)fo)[index_fo+j] = missing_dfi.doubleval;
}
else {
((float*)fo)[index_fo+j] = missing_rfi.floatval;
}
}
}
else {
coerce_output_float_or_double(fo,tmp_fo,type_fi,nxyo,index_fo);
}
if(ndims_xi > 1) index_xi += nxi;
if(ndims_yi > 1) index_yi += nyi;
index_fi += nfi;
index_fo += nxyo;
}
/*
* Free temp arrays.
*/
if(type_xi != NCL_double) NclFree(tmp_xi);
if(type_yi != NCL_double) NclFree(tmp_yi);
if(type_xo != NCL_double) NclFree(tmp_xo);
if(type_yo != NCL_double) NclFree(tmp_yo);
if(type_fi != NCL_double) NclFree(tmp_fi);
NclFree(tmp_fo);
NclFree(xiw);
NclFree(fxiw);
if(type_fi == NCL_double) {
/*
* Return double values with missing value set.
*/
ret = NclReturnValue(fo,ndims_fi-1,dsizes_fo,&missing_dfi,NCL_double,0);
}
else {
/*
* Return float values with missing value set.
*/
ret = NclReturnValue(fo,ndims_fi-1,dsizes_fo,&missing_rfi,NCL_float,0);
}
NclFree(dsizes_fo);
return(ret);
}
NhlErrorTypes linint1_n_W( void )
{
/*
* Input variables
*/
void *xi, *fi, *xo;
double *tmp_xi, *tmp_xo,*tmp_fi, *tmp_fo;
int ndims_xi;
ng_size_t dsizes_xi[NCL_MAX_DIMENSIONS], dsizes_xo[NCL_MAX_DIMENSIONS];
int ndims_fi;
ng_size_t dsizes_fi[NCL_MAX_DIMENSIONS];
int has_missing_fi;
ng_size_t *dsizes_fo;
NclScalar missing_fi, missing_dfi, missing_rfi, missing_fo;
int *dim, *opt, iopt = 0;
logical *wrap;
NclBasicDataTypes type_xi, type_fi, type_xo, type_fo;
/*
* Output variables.
*/
void *fo;
/*
* Other variables
*/
ng_size_t nxi, nxi2, nxo, nfo, nd, nr, nl, nrnxi, nrnxo, ntotal, size_fo;
int inxi, inxi2, inxo, ier, ret;
ng_size_t i, j, index_nri, index_nro, index_fi, index_fo;
double *xiw, *fxiw;
/*
* Retrieve parameters
*
* Note that any of the pointer parameters can be set to NULL,
* which implies you don't care about its value.
*/
xi = (void*)NclGetArgValue(
0,
6,
&ndims_xi,
dsizes_xi,
NULL,
NULL,
&type_xi,
DONT_CARE);
fi = (void*)NclGetArgValue(
1,
6,
&ndims_fi,
dsizes_fi,
&missing_fi,
&has_missing_fi,
&type_fi,
DONT_CARE);
wrap = (logical*)NclGetArgValue(
2,
6,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
xo = (void*)NclGetArgValue(
3,
6,
NULL,
dsizes_xo,
NULL,
NULL,
&type_xo,
DONT_CARE);
opt = (int*)NclGetArgValue(
4,
6,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
dim = (int*)NclGetArgValue(
5,
6,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Some error checking. Make sure input dimension is valid.
*/
if(*dim < 0 || *dim >= ndims_fi) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1_n: Invalid dimension to do interpolation on, can't continue");
return(NhlFATAL);
}
/*
* Compute the total number of elements in our arrays and check them.
*/
nxi = dsizes_fi[*dim];
nxo = dsizes_xo[0];
nfo = nxo;
nxi2 = nxi + 2;
if(nxi < 2) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1_n: xi must have at least 2 elements");
return(NhlFATAL);
}
/*
* Test dimension sizes.
*/
if((nxi > INT_MAX) || (nxo > INT_MAX) || (nxi2 > INT_MAX)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1_n: one or more dimension sizes is greater than INT_MAX");
return(NhlFATAL);
}
inxi = (int) nxi;
inxo = (int) nxo;
inxi2 = (int) nxi2;
/*
* Check dimensions of xi and fi. If xi is not one-dimensional, then it
* must be the same size as fi. Otherwise, the dims-th dimension of
* fi must be equal to the length of xi.
*/
if(ndims_xi > 1) {
if(ndims_xi != ndims_fi) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1_n: If xi is not one-dimensional, then it must be the same size as fi");
return(NhlFATAL);
}
for(i = 0; i < ndims_fi; i++) {
if(dsizes_xi[i] != dsizes_fi[i]) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1_n: If xi is not one-dimensional, then it must be the same size as fi");
return(NhlFATAL);
}
}
}
else {
if(dsizes_xi[0] != nxi) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1_n: The dim-th dimension of fi must be the same length as xi");
return(NhlFATAL);
}
}
/*
* Calculate size of leftmost dimensions (nl) up to the dim-th
* dimension.
* Calculate size of rightmost dimensions (nr) from the
* dim-th dimension.
*
* The dimension to do the interpolation across is "dim".
*/
nl = nr = 1;
if(ndims_fi > 1) {
nd = ndims_fi-1;
for(i = 0; i < *dim ; i++) {
nl = nl*dsizes_fi[i];
}
for(i = *dim+1; i < ndims_fi; i++) {
nr = nr*dsizes_fi[i];
}
}
else {
nd = 1;
}
ntotal = nr * nl;
size_fo = ntotal * nfo;
/*
* Coerce missing values.
*/
coerce_missing(type_fi,has_missing_fi,&missing_fi,&missing_dfi,
&missing_rfi);
/*
* Allocate space for temporary output array.
*/
tmp_fo = (double*)calloc(nfo,sizeof(double));
if(tmp_fo == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1_n: Unable to allocate memory for temporary arrays");
return(NhlFATAL);
}
/*
* Allocate space for output array.
*/
dsizes_fo = (ng_size_t*)calloc(ndims_fi,sizeof(ng_size_t));
if(type_fi == NCL_double) {
fo = (void*)calloc(size_fo,sizeof(double));
type_fo = NCL_double;
missing_fo = missing_dfi;
}
else {
fo = (void*)calloc(size_fo,sizeof(float));
type_fo = NCL_float;
missing_fo = missing_rfi;
}
if(fo == NULL || dsizes_fo == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1_n: Unable to allocate memory for output array");
return(NhlFATAL);
}
/*
* Go ahead and copy all dimesions, but then replace the dim-th one.
*/
for(i = 0; i < ndims_fi; i++) dsizes_fo[i] = dsizes_fi[i];
dsizes_fo[*dim] = nxo;
/*
* Allocate space for work arrays.
*/
xiw = (double*)calloc(nxi2,sizeof(double));
fxiw = (double*)calloc(nxi2,sizeof(double));
if(xiw == NULL || fxiw == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1_n: Unable to allocate memory for work arrays");
return(NhlFATAL);
}
/*
* Coerce output array to double if necessary.
*/
tmp_xo = coerce_input_double(xo,type_xo,nxo,0,NULL,NULL);
if(tmp_xo == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1_n: Unable to coerce output array to double precision");
return(NhlFATAL);
}
if(ndims_xi == 1) {
tmp_xi = coerce_input_double(xi,type_xi,nxi,0,NULL,NULL);
}
else {
tmp_xi = (double*)calloc(nxi,sizeof(double));
if(tmp_xi == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1_n: Unable to allocate memory for coercing input array to double precision");
return(NhlFATAL);
}
}
tmp_fi = (double*)calloc(nxi,sizeof(double));
if(tmp_fi == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1_n: Unable to allocate memory for coercing input array to double precision");
return(NhlFATAL);
}
/*
* Loop through leftmost and rightmost dimensions and call Fortran
* routine for each array subsection.
*/
nrnxi = nr*nxi;
nrnxo = nr*nxo;
for( i = 0; i < nl; i++ ) {
index_nri = i*nrnxi;
index_nro = i*nrnxo;
for( j = 0; j < nr; j++ ) {
index_fi = index_nri+j;
index_fo = index_nro+j;
if(ndims_xi > 1) {
coerce_subset_input_double_step(xi,tmp_xi,index_fi,nr,type_xi,
nxi,0,NULL,NULL);
}
coerce_subset_input_double_step(fi,tmp_fi,index_fi,nr,type_fi,
nxi,0,NULL,NULL);
/*
* Call Fortran routine.
*/
NGCALLF(dlinint1,DLININT1)(&inxi,tmp_xi,tmp_fi,wrap,&inxo,tmp_xo,tmp_fo,
xiw,fxiw,&inxi2,&missing_dfi.doubleval,
&iopt,&ier);
if(ier) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"linint1_n: xi and xo must be monotonically increasing");
set_subset_output_missing_step(fo,index_fo,nr,type_fo,nfo,
missing_dfi.doubleval);
}
else {
coerce_output_float_or_double_step(fo,tmp_fo,type_fi,nfo,index_fo,nr);
}
}
}
/*
* Free temp arrays.
*/
if(ndims_xi > 1 || type_xi != NCL_double) NclFree(tmp_xi);
if(type_xo != NCL_double) NclFree(tmp_xo);
NclFree(tmp_fi);
NclFree(tmp_fo);
NclFree(xiw);
NclFree(fxiw);
ret = NclReturnValue(fo,ndims_fi,dsizes_fo,&missing_fo,type_fo,0);
NclFree(dsizes_fo);
return(ret);
}
NhlErrorTypes 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 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 rgba_to_color_index_W( void )
{
int i, *ci;
float *rgba;
ng_size_t dsizes[2];
int ndims;
int has_alpha;
int stride;
int rgba_dim;
ng_size_t ncolors;
/*
* Retrieve parameters
*
* Note any of the pointer parameters can be set to NULL, which
* implies you don't care about its value. In this example
* the type parameter is set to NULL because the function
* is later registered to only accept floating point numbers.
*
* Retrieve argument #1
*/
rgba = (float *) NclGetArgValue(0,1,&ndims,dsizes,NULL,NULL,
NULL,DONT_CARE);
/* ndims must be 1 or 2, dsizes[0] can be any number; dsizes[1] must be 3 or 4 */
if (ndims == 1) {
rgba_dim = 0;
ncolors = 1;
}
else if (ndims == 2) {
rgba_dim = 1;
ncolors = dsizes[0];
}
else {
NhlPError(NhlFATAL,NhlEUNKNOWN,
"rgba_to_color_index: the input array must have either 1 or 2 dimensions");
return(NhlFATAL);
}
if (dsizes[rgba_dim] == 3) {
has_alpha = 0;
stride = 3;
}
else if (dsizes[rgba_dim] == 4) {
has_alpha = 1;
stride = 4;
}
else {
NhlPError(NhlFATAL,NhlEUNKNOWN,
"rgba_to_color_index: the second dimension of the input array must have either three or four elements");
return(NhlFATAL);
}
ci = (int*)calloc(ncolors,sizeof(int));
for(i = 0; i < ncolors; i++) {
ci[i] = _NhlRGBAToColorIndex(rgba + i * stride,has_alpha);
}
return(NclReturnValue( (void *) ci, 1, &ncolors, NULL, NCL_int, 0));
}
NhlErrorTypes NhlGetNamedColorIndex_W( void )
{
int i, j, ii, *ci, *wks, nid, total_cname_elements, total_wks_elements;
NclHLUObj tmp_hlu_obj;
NrmQuark *cname;
int ndims_cname;
ng_size_t dsizes_cname[NCL_MAX_DIMENSIONS];
int ndims_wks;
ng_size_t dsizes_wks[NCL_MAX_DIMENSIONS];
int ndims_out;
ng_size_t dsizes_out[NCL_MAX_DIMENSIONS];
/*
* Retrieve parameters
*
* Note any of the pointer parameters can be set to NULL, which
* implies you don't care about its value. In this example
* the type parameter is set to NULL because the function
* is later registered to only accept floating point numbers.
*
* Retrieve argument #1
*/
wks = (int*)NclGetArgValue(0,2,&ndims_wks,dsizes_wks,NULL,NULL,NULL,
DONT_CARE);
/*
* Retrieve argument #2
*/
cname = (NrmQuark *) NclGetArgValue(1,2,&ndims_cname,dsizes_cname,NULL,NULL,
NULL,DONT_CARE);
/*
* Compute total number of elements in wks array.
*/
total_wks_elements = 1;
for(i = 0; i < ndims_wks; i++) {
total_wks_elements *= dsizes_wks[i];
}
/*
* Compute total number of elements in color name array.
*/
total_cname_elements = 1;
for(i = 0; i < ndims_cname; i++) {
total_cname_elements *= dsizes_cname[i];
}
ci = (int*)calloc(total_wks_elements*total_cname_elements*sizeof(int),1);
ii = 0;
for(i = 0; i < total_wks_elements; i++) {
for(j = 0; j < total_cname_elements; j++) {
/*
* Determine the NCL identifier for the graphic object.
*/
tmp_hlu_obj = (NclHLUObj) _NclGetObj(wks[i]);
nid = tmp_hlu_obj->hlu.hlu_id;
ci[ii] = NhlGetNamedColorIndex(nid,NrmQuarkToString(cname[j]));
ii++;
}
}
/*
* If only one workstation has been given, then the number of dimensions
* of the output is just equal to the dimensions of the colors inputted.
*/
if(is_scalar(ndims_wks,dsizes_wks)) {
ndims_out = ndims_cname;
for( i = 0; i < ndims_cname; i++ ) {
dsizes_out[i] = dsizes_cname[i];
}
}
else {
ndims_out = ndims_cname + ndims_wks;
for( i = 0; i < ndims_wks; i++ ) {
dsizes_out[i] = dsizes_wks[i];
}
for( i = 0; i < ndims_cname; i++ ) {
dsizes_out[i+ndims_wks] = dsizes_cname[i];
}
}
return(NclReturnValue( (void *) ci, ndims_out, dsizes_out, NULL, NCL_int, 0));
}
NhlErrorTypes 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 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 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);
}