NhlErrorTypes area_poly_sphere_W( void )
{
/*
* Input variables
*/
/*
* Argument # 0
*/
void *lat;
double *tmp_lat;
ng_size_t dsizes_lat[1];
NclBasicDataTypes type_lat;
/*
* Argument # 1
*/
void *lon;
double *tmp_lon;
ng_size_t dsizes_lon[1];
NclBasicDataTypes type_lon;
/*
* Argument # 2
*/
void *rsph;
double *tmp_rsph;
NclBasicDataTypes type_rsph;
/*
* Return variable
*/
void *parea;
double *tmp_parea;
int ndims_parea;
ng_size_t dsizes_parea[1];
NclBasicDataTypes type_parea;
/*
* Various
*/
ng_size_t npts;
int inpts, ret;
/*
* 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
*/
lat = (void*)NclGetArgValue(
0,
3,
NULL,
dsizes_lat,
NULL,
NULL,
&type_lat,
DONT_CARE);
npts = dsizes_lat[0];
if(npts > INT_MAX) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_poly_sphere: npts = %ld is greater than INT_MAX", npts);
return(NhlFATAL);
}
inpts = (int) npts;
/*
* Get argument # 1
*/
lon = (void*)NclGetArgValue(
1,
3,
NULL,
dsizes_lon,
NULL,
NULL,
&type_lon,
DONT_CARE);
if(dsizes_lon[0] != npts) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_poly_sphere: The #0 dimension of lon must be length npts");
return(NhlFATAL);
}
/*
* Get argument # 2
*/
rsph = (void*)NclGetArgValue(
2,
3,
NULL,
NULL,
NULL,
NULL,
&type_rsph,
DONT_CARE);
/*
* 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.
*/
tmp_lat = coerce_input_double(lat,type_lat,npts,0,NULL,NULL);
if(tmp_lat == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_poly_sphere: Unable to allocate memory for coercing lat to double");
return(NhlFATAL);
}
tmp_lon = coerce_input_double(lon,type_lon,npts,0,NULL,NULL);
if(tmp_lon == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_poly_sphere: Unable to allocate memory for coercing lon to double");
return(NhlFATAL);
}
tmp_rsph = coerce_input_double(rsph,type_rsph,1,0,NULL,NULL);
if(tmp_rsph == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_poly_sphere: Unable to allocate memory for coercing rsph to double");
return(NhlFATAL);
}
if(type_lat == NCL_double || type_lon == NCL_double || type_rsph == NCL_double) {
type_parea = NCL_double;
}
else {
type_parea = NCL_float;
}
/*
* Allocate space for output array.
*/
if(type_parea != NCL_double) {
parea = (void *)calloc(1, sizeof(float));
tmp_parea = (double *)calloc(1,sizeof(double));
if(parea == NULL || tmp_parea == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_poly_sphere: Unable to allocate memory for output array");
return(NhlFATAL);
}
}
else {
parea = (void *)calloc(1, sizeof(double));
if(parea == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_poly_sphere: Unable to allocate memory for output array");
return(NhlFATAL);
}
tmp_parea = (double*)parea;
}
/*
* Call the Fortran routine.
*/
NGCALLF(spareapolyi,SPAREAPOLYI)(tmp_lat, tmp_lon, &inpts, tmp_rsph, tmp_parea);
/*
* Coerce as necessary
*/
coerce_output_float_or_double(parea,tmp_parea,type_parea,1,0);
/*
* Free unneeded memory.
*/
if(type_lat != NCL_double) NclFree(tmp_lat);
if(type_lon != NCL_double) NclFree(tmp_lon);
if(type_rsph != NCL_double) NclFree(tmp_rsph);
if(type_parea != NCL_double) NclFree(tmp_parea);
/*
* Return value back to NCL script. Output is a scalar.
*/
ndims_parea = 1;
dsizes_parea[0] = 1;
ret = NclReturnValue(parea,ndims_parea,dsizes_parea,NULL,type_parea,0);
return(ret);
}
NhlErrorTypes linint2_points_W( void )
{
/*
* Input variables
*/
void *xi, *yi, *fi, *xo, *yo;
double *tmp_xi = NULL;
double *tmp_yi = NULL;
double *tmp_fi = NULL;
double *tmp_xo, *tmp_yo, *tmp_fo;
int ndims_xi;
ng_size_t dsizes_xi[NCL_MAX_DIMENSIONS];
int ndims_yi;
ng_size_t dsizes_yi[NCL_MAX_DIMENSIONS];
ng_size_t dsizes_xo[NCL_MAX_DIMENSIONS], dsizes_yo[NCL_MAX_DIMENSIONS];
int ndims_fi;
ng_size_t dsizes_fi[NCL_MAX_DIMENSIONS];
int has_missing_fi;
ng_size_t *dsizes_fo;
NclScalar missing_fi, missing_dfi, missing_rfi;
int *opt;
logical *wrap;
NclBasicDataTypes type_xi, type_yi, type_fi, type_xo, type_yo;
/*
* Output variables.
*/
void *fo;
/*
* Other variables
*/
double *xiw, *fxiw;
ng_size_t nxi, nxi2, nyi, nfi, nxyo, size_leftmost, size_fo;
ng_size_t i, j, index_xi, index_yi, index_fi, index_fo;
int inxi, inxi2, inyi, inxyo, ier, ret;
/*
* Retrieve parameters
*
* Note that any of the pointer parameters can be set to NULL,
* which implies you don't care about its value.
*/
xi = (void*)NclGetArgValue(
0,
7,
&ndims_xi,
dsizes_xi,
NULL,
NULL,
&type_xi,
DONT_CARE);
yi = (void*)NclGetArgValue(
1,
7,
&ndims_yi,
dsizes_yi,
NULL,
NULL,
&type_yi,
DONT_CARE);
fi = (void*)NclGetArgValue(
2,
7,
&ndims_fi,
dsizes_fi,
&missing_fi,
&has_missing_fi,
&type_fi,
DONT_CARE);
wrap = (logical*)NclGetArgValue(
3,
7,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
xo = (void*)NclGetArgValue(
4,
7,
NULL,
dsizes_xo,
NULL,
NULL,
&type_xo,
DONT_CARE);
yo = (void*)NclGetArgValue(
5,
7,
NULL,
dsizes_yo,
NULL,
NULL,
&type_yo,
DONT_CARE);
opt = (int*)NclGetArgValue(
6,
7,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Compute the total number of elements in our arrays.
*/
nxi = dsizes_xi[ndims_xi-1];
nyi = dsizes_yi[ndims_yi-1];
nxyo = dsizes_xo[0];
nxi2 = nxi+2;
if(dsizes_yo[0] != nxyo) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint2_points: xo and yo must be the same length");
return(NhlFATAL);
}
if(nxi < 2 || nyi < 2) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint2_points: xi and yi must both have at least two elements");
return(NhlFATAL);
}
nfi = nxi * nyi;
/*
* Test dimension sizes.
*/
if((nxi > INT_MAX) || (nyi > INT_MAX) || (nxyo > INT_MAX) ||
(nxi2 > INT_MAX)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint2_points: one or more dimension sizes is greater than INT_MAX");
return(NhlFATAL);
}
inxi = (int) nxi;
inyi = (int) nyi;
inxyo = (int) nxyo;
inxi2 = (int) nxi2;
/*
* Check dimensions of xi, yi, and fi. If xi/yi are not one-dimensional,
* then their leftmost dimensions must be the same size as the leftmost
* dimensions of fi. The last two dimensions of fi must be nyi x nxi.
*/
if(ndims_xi > 1) {
if(ndims_xi != ndims_fi-1) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint2_points: If xi is not one-dimensional, then it must have one less dimension than fi");
return(NhlFATAL);
}
for(i = 0; i < ndims_xi-1; i++) {
if(dsizes_xi[i] != dsizes_fi[i]) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint2_points: If xi is not one-dimensional, then its leftmost dimensions must be the same as the leftmost dimensions of fi");
return(NhlFATAL);
}
}
}
if(ndims_yi > 1) {
if(ndims_yi != ndims_fi-1) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint2_points: If yi is not one-dimensional, then it must have one less dimension than fi");
return(NhlFATAL);
}
for(i = 0; i < ndims_yi-1; i++) {
if(dsizes_yi[i] != dsizes_fi[i]) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint2_points: If yi is not one-dimensional, then its leftmost dimensions must be the same as the leftmost dimensions of fi");
return(NhlFATAL);
}
}
}
if(dsizes_fi[ndims_fi-2] != nyi || dsizes_fi[ndims_fi-1] != nxi) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint2_points: The rightmost dimensions of fi must be nyi x nxi, where nyi and nxi are the lengths of yi and xi respectively");
return(NhlFATAL);
}
/*
* Compute the total size of the output array (minus the last two dimensions).
*/
size_leftmost = 1;
for( i = 0; i < ndims_fi-2; i++ ) size_leftmost *= dsizes_fi[i];
size_fo = size_leftmost * nxyo;
/*
* Coerce missing values.
*/
coerce_missing(type_fi,has_missing_fi,&missing_fi,&missing_dfi,
&missing_rfi);
/*
* Allocate space for temporary output array.
*/
tmp_fo = (double*)calloc(nxyo,sizeof(double));
if(tmp_fo == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint2_points: Unable to allocate memory for temporary arrays");
return(NhlFATAL);
}
/*
* Allocate space for output array.
*/
dsizes_fo = (ng_size_t*)calloc(ndims_fi-1,sizeof(ng_size_t));
if(type_fi == NCL_double) {
fo = (void*)calloc(size_fo,sizeof(double));
}
else {
fo = (void*)calloc(size_fo,sizeof(float));
}
if(fo == NULL || dsizes_fo == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint2_points: Unable to allocate memory for output array");
return(NhlFATAL);
}
for(i = 0; i < ndims_fi-2; i++) dsizes_fo[i] = dsizes_fi[i];
dsizes_fo[ndims_fi-2] = nxyo;
/*
* Allocate space for work arrays.
*/
xiw = (double*)calloc(nxi2,sizeof(double));
fxiw = (double*)calloc(nyi*nxi2,sizeof(double));
if(xiw == NULL || fxiw == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint2_points: Unable to allocate memory for work arrays");
return(NhlFATAL);
}
/*
* Coerce input arrays to double if necessary.
*/
if(type_xi != NCL_double) {
tmp_xi = (double*)calloc(nxi,sizeof(double));
if(tmp_xi == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint2_points: Unable to allocate memory for coercing xi to double precision");
return(NhlFATAL);
}
}
if(type_yi != NCL_double) {
tmp_yi = (double*)calloc(nyi,sizeof(double));
if(tmp_yi == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint2_points: Unable to allocate memory for coercing yi to double precision");
return(NhlFATAL);
}
}
tmp_xo = coerce_input_double(xo,type_xo,nxyo,0,NULL,NULL);
tmp_yo = coerce_input_double(yo,type_yo,nxyo,0,NULL,NULL);
if(tmp_xo == NULL || tmp_yo == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint2_points: Unable to coerce input to double precision");
return(NhlFATAL);
}
if(type_fi != NCL_double) {
tmp_fi = (double*)calloc(nfi,sizeof(double));
if(tmp_fi == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint2_points: Unable to allocate memory for coercing input array to double precision");
return(NhlFATAL);
}
}
/*
* Call Fortran function.
*/
index_xi = index_yi = index_fi = index_fo = 0;
for( i = 0; i < size_leftmost; i++ ) {
if(ndims_xi > 1 || i == 0) {
if(type_xi != NCL_double) {
coerce_subset_input_double(xi,tmp_xi,index_xi,type_xi,nxi,0,NULL,NULL);
}
else {
tmp_xi = &((double*)xi)[index_xi];
}
}
if(ndims_yi > 1 || i == 0) {
if(type_yi != NCL_double) {
coerce_subset_input_double(yi,tmp_yi,index_yi,type_yi,nyi,0,NULL,NULL);
}
else {
tmp_yi = &((double*)yi)[index_yi];
}
}
if(type_fi != NCL_double) {
coerce_subset_input_double(fi,tmp_fi,index_fi,type_fi,nfi,0,NULL,NULL);
}
else {
tmp_fi = &((double*)fi)[index_fi];
}
NGCALLF(dlinint2pts,DLININT2PTS)(&inxi,tmp_xi,&inyi,tmp_yi,tmp_fi,wrap,
&inxyo,tmp_xo,tmp_yo,tmp_fo,xiw,fxiw,
&inxi2,&missing_dfi.doubleval,&ier);
if(ier) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"linint2_points: xi and yi must be monotonically increasing");
for(j = 0; j < nxyo; j++) {
if(type_fi == NCL_double) {
((double*)fo)[index_fo+j] = missing_dfi.doubleval;
}
else {
((float*)fo)[index_fo+j] = missing_rfi.floatval;
}
}
}
else {
coerce_output_float_or_double(fo,tmp_fo,type_fi,nxyo,index_fo);
}
if(ndims_xi > 1) index_xi += nxi;
if(ndims_yi > 1) index_yi += nyi;
index_fi += nfi;
index_fo += nxyo;
}
/*
* Free temp arrays.
*/
if(type_xi != NCL_double) NclFree(tmp_xi);
if(type_yi != NCL_double) NclFree(tmp_yi);
if(type_xo != NCL_double) NclFree(tmp_xo);
if(type_yo != NCL_double) NclFree(tmp_yo);
if(type_fi != NCL_double) NclFree(tmp_fi);
NclFree(tmp_fo);
NclFree(xiw);
NclFree(fxiw);
if(type_fi == NCL_double) {
/*
* Return double values with missing value set.
*/
ret = NclReturnValue(fo,ndims_fi-1,dsizes_fo,&missing_dfi,NCL_double,0);
}
else {
/*
* Return float values with missing value set.
*/
ret = NclReturnValue(fo,ndims_fi-1,dsizes_fo,&missing_rfi,NCL_float,0);
}
NclFree(dsizes_fo);
return(ret);
}
NhlErrorTypes 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 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 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 covcorm_xy_W( void )
{
/*
* Input array variables
*/
void *x, *y;
int *iopt;
double *dx, *dy;
ng_size_t dsizes_x[NCL_MAX_DIMENSIONS], dsizes_y[NCL_MAX_DIMENSIONS];
int ndims_x, has_missing_x, ndims_y, has_missing_y;
NclScalar missing_x, missing_dx, missing_y, missing_dy;
ng_size_t size_x, nvar, ntim;
int invar, intim;
NclBasicDataTypes type_x, type_y;
/*
* Output array variable
*/
void *vcm;
double *dvcm;
ng_size_t *dsizes_vcm;
int ndims_vcm, ret;
ng_size_t size_vcm;
NclBasicDataTypes type_vcm;
NclScalar missing_vcm;
/*
* Retrieve x.
*/
x = (void*)NclGetArgValue(
0,
3,
&ndims_x,
dsizes_x,
&missing_x,
&has_missing_x,
&type_x,
DONT_CARE);
y = (void*)NclGetArgValue(
1,
3,
&ndims_y,
dsizes_y,
&missing_y,
&has_missing_y,
&type_y,
DONT_CARE);
iopt = (int*)NclGetArgValue(
2,
3,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
nvar = dsizes_x[0];
ntim = dsizes_x[1];
if(dsizes_y[0] != nvar || dsizes_y[1] != ntim) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"covcorm_xy: x and y must be the same size");
return(NhlFATAL);
}
size_x = nvar * ntim;
/*
* Test dimension sizes to make sure they are <= INT_MAX.
*/
if((ntim > INT_MAX) || (nvar > INT_MAX)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"covcorm_xy: one or more dimension sizes are greater than INT_MAX");
return(NhlFATAL);
}
intim = (int) ntim;
invar = (int) nvar;
/*
* Coerce missing values, if any.
*/
coerce_missing(type_x,has_missing_x,&missing_x,&missing_dx,NULL);
coerce_missing(type_y,has_missing_y,&missing_y,&missing_dy,NULL);
/*
* Allocate space for input/output arrays.
*/
size_vcm = nvar*nvar;
ndims_vcm = 2;
dsizes_vcm = (ng_size_t*)malloc(2*sizeof(ng_size_t));
dsizes_vcm[0] = nvar;
dsizes_vcm[1] = nvar;
dx = coerce_input_double(x,type_x,size_x,0,NULL,NULL);
dy = coerce_input_double(y,type_y,size_x,0,NULL,NULL);
if(type_x == NCL_double || type_y == NCL_double) {
type_vcm = NCL_double;
vcm = (void*)malloc(size_vcm*sizeof(double));
if(vcm == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"covcorm_xy: Unable to allocate memory for output array");
return(NhlFATAL);
}
dvcm = &((double*)vcm)[0];
missing_vcm.doubleval = ((NclTypeClass)nclTypedoubleClass)->type_class.default_mis.doubleval;
}
else {
type_vcm = NCL_float;
vcm = (void*)malloc(size_vcm*sizeof(float));
dvcm = (double*)malloc(size_vcm*sizeof(double));
if(vcm == NULL || dvcm == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"covcorm_xy: Unable to allocate memory for output array");
return(NhlFATAL);
}
missing_vcm.floatval = ((NclTypeClass)nclTypefloatClass)->type_class.default_mis.floatval;
}
/*
* Call the fortran routine.
* iopt(0) --> iopt
* iopt(1) --> lag
* iopt(2) --> ncrit
*/
NGCALLF(dcovarxy,DCOVARXY)(dx,dy,&missing_dx.doubleval,
&missing_dy.doubleval,dvcm,&intim,&invar,
&iopt[1],&iopt[2],&iopt[0]);
/* Coerce to float if necessary */
if(type_vcm == NCL_float) coerce_output_float_only(vcm,dvcm,size_vcm,0);
/* Free memory */
if(type_x != NCL_double) NclFree(dx);
if(type_y != NCL_double) NclFree(dy);
if(type_vcm != NCL_double) NclFree(dvcm);
/* Return */
ret = NclReturnValue(vcm,ndims_vcm,dsizes_vcm,&missing_vcm,type_vcm,0);
NclFree(dsizes_vcm);
return(ret);
}
NhlErrorTypes paleo_outline_W( void )
{
/*
* Input array variables
*/
void *oro, *lat, *lon;
float *landmask;
double *tmp_oro, *tmp_lat, *tmp_lon;
ng_size_t dsizes_oro[2], dsizes_lat[1], dsizes_lon[1];
NclBasicDataTypes type_oro, type_lat, type_lon;
NrmQuark *name;
/*
* Other variables
*/
float *zdat;
char *cname;
int *iwrk, inlon, inlat, iliwk, iim, ijm;
ng_size_t liwk, nlat, nlon, jm, im;
/*
* Retrieve arguments.
*/
oro = (void*)NclGetArgValue(
0,
5,
NULL,
dsizes_oro,
NULL,
NULL,
&type_oro,
DONT_CARE);
lat = (void*)NclGetArgValue(
1,
5,
NULL,
dsizes_lat,
NULL,
NULL,
&type_lat,
DONT_CARE);
lon = (void*)NclGetArgValue(
2,
5,
NULL,
dsizes_lon,
NULL,
NULL,
&type_lon,
DONT_CARE);
landmask = (float*)NclGetArgValue(
3,
5,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
name = (NrmQuark *)NclGetArgValue(
4,
5,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
cname = NrmQuarkToString(*name);
nlat = dsizes_oro[0];
nlon = dsizes_oro[1];
if(dsizes_lat[0] != nlat || dsizes_lon[0] != nlon) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"paleo_outline: the length of the lat array must be the same as the leftmost dimension of oro, and the length of the lon arrays must be the same as the rightmost dimension of oro");
return(NhlFATAL);
}
/*
* Convert input arrays to double if necessary.
*/
tmp_oro = coerce_input_double(oro,type_oro,nlat*nlon,0,NULL,NULL);
tmp_lat = coerce_input_double(lat,type_lat,nlat,0,NULL,NULL);
tmp_lon = coerce_input_double(lon,type_lon,nlon,0,NULL,NULL);
if(tmp_oro == NULL || tmp_lat == NULL || tmp_lon == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"paleo_outline: Unable to coerce input arrays to double precision");
return(NhlFATAL);
}
/*
* Allocate space for work arrays.
*/
jm = 2*nlat+1;
im = 2*nlon+1;
liwk = max(im * jm,2000); /* 2000 is the old value that iwrk
was hard-wired to. */
/*
* Test input dimension sizes.
*/
if((nlon > INT_MAX) || (nlat > INT_MAX) || (liwk > INT_MAX) ||
(im > INT_MAX) || (jm > INT_MAX)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"paleo_outline: one or more input dimension sizes is greater than INT_MAX");
return(NhlFATAL);
}
inlon = (int) nlon;
inlat = (int) nlat;
iliwk = (int) liwk;
iim = (int) im;
ijm = (int) jm;
/*
* Allocate work arrays.
*/
zdat = (float*)malloc(jm*im*sizeof(float));
iwrk = (int*)malloc(liwk*sizeof(int));
if(zdat == NULL || iwrk == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"paleo_outline: Unable to allocate memory for work arrays");
return(NhlFATAL);
}
/*
* Call the Fortran paleo_outline routine.
*/
NGCALLF(paleooutline,PALEOOUTLINE)(tmp_oro,zdat,tmp_lat,tmp_lon,
&inlat,&inlon,&ijm,&iim,iwrk,&iliwk,
cname,landmask,strlen(cname));
if(type_oro != NCL_double) NclFree(tmp_oro);
if(type_lat != NCL_double) NclFree(tmp_lat);
if(type_lon != NCL_double) NclFree(tmp_lon);
NclFree(zdat);
NclFree(iwrk);
return(NhlNOERROR);
}
NhlErrorTypes pop_remap_W( void )
{
/*
* Input variables
*/
void *dst_array, *map_wts, *src_array;
double *dst, *map, *src;
int has_missing_src_array, *dst_add, *src_add;
ng_size_t ndst, nlink, nw, nsrc;
ng_size_t dsizes_dst_array[1];
ng_size_t dsizes_map_wts[2];
ng_size_t dsizes_src_array[1];
ng_size_t dsizes_dst_add[1];
ng_size_t dsizes_src_add[1];
NclBasicDataTypes type_dst_array, type_map_wts, type_src_array;
NclScalar missing_src_array, missing_dsrc_array;
int indst, inlink, inw, insrc;
/*
* Retrieve parameters
*
* Note that any of the pointer parameters can be set to NULL,
* which implies you don't care about its value.
*/
dst_array = (void*)NclGetArgValue(
0,
5,
NULL,
dsizes_dst_array,
NULL,
NULL,
&type_dst_array,
DONT_CARE);
map_wts = (void*)NclGetArgValue(
1,
5,
NULL,
dsizes_map_wts,
NULL,
NULL,
&type_map_wts,
DONT_CARE);
dst_add = (int*)NclGetArgValue(
2,
5,
NULL,
dsizes_dst_add,
NULL,
NULL,
NULL,
DONT_CARE);
src_add = (int*)NclGetArgValue(
3,
5,
NULL,
dsizes_src_add,
NULL,
NULL,
NULL,
DONT_CARE);
src_array = (void*)NclGetArgValue(
4,
5,
NULL,
dsizes_src_array,
&missing_src_array,
&has_missing_src_array,
&type_src_array,
DONT_CARE);
/*
* Check type of dst_array.
*/
if(type_dst_array != NCL_float && type_dst_array != NCL_double) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"pop_remap: dst_array must be of type float or double");
return(NhlFATAL);
}
/*
* Check dimensions and calculate total size of arrays.
*/
nlink = dsizes_map_wts[0];
nw = dsizes_map_wts[1];
ndst = dsizes_dst_array[0];
nsrc = dsizes_src_array[0];
if( dsizes_dst_add[0] != nlink || dsizes_src_add[0] != nlink ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"pop_remap: The size of the dst_add and src_add arrays must be the same as the first dimension of map_wts");
return(NhlFATAL);
}
if((ndst > INT_MAX) || (nlink > INT_MAX) || (nw > INT_MAX) || (nsrc > INT_MAX)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"pop_remap: one or more input dimension sizes is greater than INT_MAX");
return(NhlFATAL);
}
indst = (int) ndst;
inlink = (int) nlink;
inw = (int) nw;
insrc = (int) nsrc;
/*
* Check that src_array has a missing value set.
*/
if(!has_missing_src_array) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"pop_remap: No missing values are being set.\nDefault missing values will be used.\nBe careful of results.");
}
coerce_missing(type_src_array,has_missing_src_array,&missing_src_array,
&missing_dsrc_array,NULL);
/*
* Coerce input to double.
*/
map = coerce_input_double(map_wts,type_map_wts,nlink*nw,0,NULL,NULL);
src = coerce_input_double(src_array,type_src_array,nsrc,
has_missing_src_array,&missing_src_array,NULL);
if(map == NULL || src == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"pop_remap: Unable to allocate memory for coercing input arrays to double precision");
return(NhlFATAL);
}
/*
* Calloc space for output array if necessary.
*/
if(type_dst_array == NCL_float) {
dst = (double*)calloc(ndst,sizeof(double));
if(dst == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"pop_remap: Unable to allocate memory for output array");
return(NhlFATAL);
}
}
else {
dst = (double*)dst_array;
}
/*
* Call Fortran popremap.
*/
NGCALLF(dpopremap,DPOPREMAP)(dst,map,dst_add,src_add,src,&indst,&inlink,&inw,
&insrc,&missing_dsrc_array.doubleval);
if(type_dst_array == NCL_float) {
coerce_output_float_only(dst_array,dst,ndst,0);
NclFree(dst);
}
if(type_map_wts != NCL_double) NclFree(map);
if(type_src_array != NCL_double) NclFree(src);
return(NhlNOERROR);
}
NhlErrorTypes dim_sum_wgt_n_W( void )
{
/*
* Input variables
*/
/*
* Argument # 0
*/
void *x;
double *tmp_x;
int ndims_x;
ng_size_t dsizes_x[NCL_MAX_DIMENSIONS];
int has_missing_x;
NclScalar missing_x, missing_flt_x, missing_dbl_x;
NclBasicDataTypes type_x;
/*
* Argument # 1
*/
void *w;
double *tmp_w;
ng_size_t dsizes_w[1];
NclBasicDataTypes type_w;
/*
* Argument # 2
*/
int *opt;
/*
* Argument # 3
*/
int *narg;
/*
* Return variable
*/
void *xavg;
double tmp_xavg[1];
int ndims_xavg;
ng_size_t *dsizes_xavg;
NclBasicDataTypes type_xavg;
/*
* Various
*/
int inx, ret;
ng_size_t nx, nrnx, index_x, index_nrx, index_nr, index_out;
ng_size_t i, j, total_nl, total_nr, size_output;
/*
* Retrieve parameters.
*
* Note any of the pointer parameters can be set to NULL, which
* implies you don't care about its value.
*/
/*
* Get argument # 0
*/
x = (void*)NclGetArgValue(
0,
4,
&ndims_x,
dsizes_x,
&missing_x,
&has_missing_x,
&type_x,
DONT_CARE);
/*
* Coerce missing value to double if necessary.
*/
coerce_missing(type_x,has_missing_x,&missing_x,
&missing_dbl_x,&missing_flt_x);
/*
* Get argument # 1
*/
w = (void*)NclGetArgValue(
1,
4,
NULL,
dsizes_w,
NULL,
NULL,
&type_w,
DONT_CARE);
/*
* Get argument # 2
*/
opt = (int*)NclGetArgValue(
2,
4,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Get argument # 3
*/
narg = (int*)NclGetArgValue(
3,
4,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Some error checking. Make sure input dimension is valid.
*/
if(*narg < 0 || *narg >= ndims_x) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_sum_wgt_n: Invalid dimension argument, can't continue");
return(NhlFATAL);
}
/*
* Test input dimension size.
*/
nx = dsizes_x[*narg];
if(nx > INT_MAX) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_sum_wgt_n: nx = %ld is greater than INT_MAX", nx);
return(NhlFATAL);
}
inx = (int) nx;
if(dsizes_w[0] != nx) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_sum_wgt_n: w must be length nx");
return(NhlFATAL);
}
/*
* Calculate size of all but narg dimensions and
* allocate space for output dimension sizes and set them.
*/
ndims_xavg = max(ndims_x-1,1);
dsizes_xavg = (ng_size_t*)calloc(ndims_xavg,sizeof(ng_size_t));
if( dsizes_xavg == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_sum_wgt_n: Unable to allocate memory for holding dimension sizes");
return(NhlFATAL);
}
total_nl = total_nr = size_output = 1;
if(ndims_x==1) { /* Handles case where x is 1D */
dsizes_xavg[0] = 1;
}
else {
for(i = 0; i < *narg; i++) {
total_nl *= dsizes_x[i];
dsizes_xavg[i] = dsizes_x[i];
}
for(i = *narg+1; i < ndims_x; i++) {
total_nr *= dsizes_x[i];
dsizes_xavg[i-1] = dsizes_x[i];
}
}
size_output = total_nr * total_nl;
/*
* Allocate space for coercing input arrays. We need to make a copy
* here, because the x values are not necessary consecutive, and
* hence we can't just point to the original array.
*/
/*
* Allocate space for tmp_x.
*/
tmp_x = (double *)calloc(nx,sizeof(double));
if(tmp_x == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_sum_wgt_n: Unable to allocate memory for coercing input array to double");
return(NhlFATAL);
}
/*
* The output type defaults to float, unless this input array is double.
*/
if(type_x == NCL_double) {
type_xavg = NCL_double;
}
else {
type_xavg = NCL_float;
}
/*
* Allocate space for output array.
*/
if(type_xavg != NCL_double) {
xavg = (void *)calloc(size_output, sizeof(float));
}
else {
xavg = (void *)calloc(size_output, sizeof(double));
}
if(xavg == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_sum_wgt_n: Unable to allocate memory for output array");
return(NhlFATAL);
}
/*
* Allocate space for tmp_w.
*/
tmp_w = coerce_input_double(w,type_w,nx,0,NULL,NULL);
if(tmp_w == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_sum_wgt_n: Unable to allocate memory for coercing input array to double");
return(NhlFATAL);
}
/*
* Loop across all but the narg-th dimension and call the Fortran routine
* for each one-dimensional subsection.
*/
nrnx = total_nr * nx;
for(i = 0; i < total_nl; i++) {
index_nrx = i * nrnx;
index_nr = i * total_nr;
for(j = 0; j < total_nr; j++) {
index_out = index_nr + j;
index_x = index_nrx + j;
/*
* Coerce subsection of x (tmp_x) to double if necessary.
*/
coerce_subset_input_double_step(x,tmp_x,index_x,total_nr,type_x,
nx,0,NULL,NULL);
/*
* Call the Fortran routine.
*/
NGCALLF(dimsumwgt,DIMSUMWGT)(&inx, tmp_x, &missing_dbl_x.doubleval,
tmp_w, opt, &tmp_xavg[0]);
/*
* Coerce output back to float or double.
*/
coerce_output_float_or_double(xavg,&tmp_xavg[0],type_x,1,index_out);
}
}
/*
* Free unneeded memory.
*/
NclFree(tmp_x);
if(type_w != NCL_double) NclFree(tmp_w);
/*
* Return value back to NCL script.
*/
if(has_missing_x) {
if(type_xavg == NCL_double) {
ret = NclReturnValue(xavg,ndims_xavg,dsizes_xavg,&missing_dbl_x,
type_xavg,0);
}
else {
ret = NclReturnValue(xavg,ndims_xavg,dsizes_xavg,&missing_flt_x,
type_xavg,0);
}
}
else {
ret = NclReturnValue(xavg,ndims_xavg,dsizes_xavg,NULL,type_xavg,0);
}
NclFree(dsizes_xavg);
return(ret);
}
NhlErrorTypes mixed_layer_depth_W( void )
{
/*
* Input variables
*/
/*
* Argument # 0
*/
void *pot_density;
double *tmp_pot_density;
int ndims_pot_density;
ng_size_t dsizes_pot_density[NCL_MAX_DIMENSIONS];
int has_missing_pot_density;
NclScalar missing_pot_density, missing_flt_pot_density, missing_dbl_pot_density;
NclBasicDataTypes type_pot_density;
/*
* Argument # 1
*/
int *kmt;
ng_size_t dsizes_kmt[2];
/*
* Argument # 2
*/
void *ht;
double *tmp_ht;
ng_size_t dsizes_ht[2];
NclBasicDataTypes type_ht;
/*
* Argument # 3
*/
void *depth;
double *tmp_depth;
ng_size_t dsizes_depth[1];
NclBasicDataTypes type_depth;
/*
* Argument # 4
*/
void *offset;
double *tmp_offset;
NclBasicDataTypes type_offset;
/*
* Return variable
*/
void *mld;
double *tmp_mld;
int ndims_mld;
ng_size_t *dsizes_mld;
ng_size_t index_mld;
NclScalar missing_mld, missing_flt_mld, missing_dbl_mld;
NclBasicDataTypes type_mld;
/*
* Various
*/
int nz, ny, nx, nznynx, nynx ;
int index_pot_density;
int i, ndims_leftmost, size_leftmost, size_output, ret;
/*
* 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
*/
pot_density = (void*)NclGetArgValue(
0,
5,
&ndims_pot_density,
dsizes_pot_density,
&missing_pot_density,
&has_missing_pot_density,
&type_pot_density,
DONT_CARE);
/*
* Check dimension sizes.
*/
if(ndims_pot_density < 3) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"mixed_layer_depth: The pot_density array must have at least 3 dimensions");
return(NhlFATAL);
}
/*
* Coerce missing value to double if necessary.
*/
coerce_missing(type_pot_density,has_missing_pot_density,&missing_pot_density,
&missing_dbl_pot_density,&missing_flt_pot_density);
nz = (int)dsizes_pot_density[ndims_pot_density-3];
ny = (int)dsizes_pot_density[ndims_pot_density-2];
nx = (int)dsizes_pot_density[ndims_pot_density-1];
nznynx = nz * ny * nx;
/*
* Get argument # 1
*/
kmt = (int*)NclGetArgValue(
1,
5,
NULL,
dsizes_kmt,
NULL,
NULL,
NULL,
DONT_CARE);
if(dsizes_kmt[0] != ny) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"mixed_layer_depth: The #0 dimension of kmt must be length ny");
return(NhlFATAL);
}
if(dsizes_kmt[1] != nx) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"mixed_layer_depth: The #1 dimension of kmt must be length nx");
return(NhlFATAL);
}
nynx = ny * nx;
/*
* Get argument # 2
*/
ht = (void*)NclGetArgValue(
2,
5,
NULL,
dsizes_ht,
NULL,
NULL,
&type_ht,
DONT_CARE);
if(dsizes_ht[0] != ny) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"mixed_layer_depth: The #0 dimension of ht must be length ny");
return(NhlFATAL);
}
if(dsizes_ht[1] != nx) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"mixed_layer_depth: The #1 dimension of ht must be length nx");
return(NhlFATAL);
}
nynx = ny * nx;
/*
* Get argument # 3
*/
depth = (void*)NclGetArgValue(
3,
5,
NULL,
dsizes_depth,
NULL,
NULL,
&type_depth,
DONT_CARE);
if(dsizes_depth[0] != nz) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"mixed_layer_depth: The #0 dimension of depth must be length nz");
return(NhlFATAL);
}
/*
* Get argument # 4
*/
offset = (void*)NclGetArgValue(
4,
5,
NULL,
NULL,
NULL,
NULL,
&type_offset,
DONT_CARE);
/*
* Calculate size of leftmost dimensions.
*/
size_leftmost = 1;
ndims_leftmost = ndims_pot_density-3;
for(i = 0; i < ndims_leftmost; i++) {
size_leftmost *= (int)dsizes_pot_density[i];
}
/*
* The output type defaults to float, unless this input array is double.
*/
type_mld = NCL_float;
/*
* Allocate space for coercing input arrays. If any of the input
* is already double, then we don't need to allocate space for
* temporary arrays, because we'll just change the pointer into
* the void array appropriately.
*/
/*
* Allocate space for tmp_pot_density.
*/
if(type_pot_density != NCL_double) {
tmp_pot_density = (double *)calloc(nznynx,sizeof(double));
if(tmp_pot_density == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"mixed_layer_depth: Unable to allocate memory for coercing input array to double");
return(NhlFATAL);
}
}
else {
type_mld = NCL_double;
}
/*
* Allocate space for tmp_ht.
*/
tmp_ht = coerce_input_double(ht,type_ht,nynx,0,NULL,NULL);
if(tmp_ht == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"mixed_layer_depth: Unable to allocate memory for coercing input array to double");
return(NhlFATAL);
}
/*
* Allocate space for tmp_depth.
*/
tmp_depth = coerce_input_double(depth,type_depth,nz,0,NULL,NULL);
if(tmp_depth == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"mixed_layer_depth: Unable to allocate memory for coercing input array to double");
return(NhlFATAL);
}
/*
* Allocate space for tmp_offset.
*/
tmp_offset = coerce_input_double(offset,type_offset,1,0,NULL,NULL);
if(tmp_offset == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"mixed_layer_depth: Unable to allocate memory for coercing input array to double");
return(NhlFATAL);
}
/*
* Calculate size of output array.
*/
nynx = ny * nx;
size_output = size_leftmost * nynx;
/*
* Allocate space for output array.
*/
if(type_mld != NCL_double) {
mld = (void *)calloc(size_output, sizeof(float));
tmp_mld = (double *)calloc(nynx,sizeof(double));
if(tmp_mld == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"mixed_layer_depth: Unable to allocate memory for temporary output array");
return(NhlFATAL);
}
}
else {
mld = (void *)calloc(size_output, sizeof(double));
tmp_mld = (double *)mld;
}
if(mld == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"mixed_layer_depth: Unable to allocate memory for output array");
return(NhlFATAL);
}
if(has_missing_pot_density) {
if(type_mld == NCL_double) missing_mld = missing_dbl_pot_density;
else missing_mld = missing_flt_pot_density;
missing_dbl_mld = missing_dbl_pot_density;
}
/*
* Allocate space for output dimension sizes and set them.
*/
ndims_mld = ndims_leftmost + 2;
dsizes_mld = (ng_size_t*)calloc(ndims_mld,sizeof(ng_size_t));
if( dsizes_mld == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"mixed_layer_depth: Unable to allocate memory for holding dimension sizes");
return(NhlFATAL);
}
for(i = 0; i < ndims_mld; i++) {
if (i < ndims_leftmost) {
dsizes_mld[i] = dsizes_pot_density[i];
}
else {
dsizes_mld[i] = dsizes_pot_density[i+1];
}
}
/*
* Loop across leftmost dimensions and call the Fortran routine for each
* subsection of the input arrays.
*/
index_pot_density = 0;
index_mld = 0;
for(i = 0; i < size_leftmost; i++) {
/*
* Coerce subsection of pot_density (tmp_pot_density) to double if necessary.
*/
if(type_pot_density != NCL_double) {
coerce_subset_input_double(pot_density,tmp_pot_density,index_pot_density,type_pot_density,nznynx,0,NULL,NULL);
}
else {
tmp_pot_density = &((double*)pot_density)[index_pot_density];
}
/*
* Call the Fortran routine.
*/
NGCALLF(mixed_layer_depth,MIXED_LAYER_DEPTH)(tmp_pot_density, kmt, tmp_ht, tmp_depth, tmp_mld + index_mld,
&nx, &ny, &nz, tmp_offset, &missing_dbl_pot_density.doubleval);
/*
* Coerce output back to float if necessary.
*/
if(type_mld == NCL_float) {
coerce_output_float_only(mld,tmp_mld,nynx,index_mld);
}
index_pot_density += nznynx;
index_mld += nynx;
}
/*
* Free unneeded memory.
*/
if(type_pot_density != NCL_double) NclFree(tmp_pot_density);
if(type_ht != NCL_double) NclFree(tmp_ht);
if(type_depth != NCL_double) NclFree(tmp_depth);
if(type_offset != NCL_double) NclFree(tmp_offset);
if(type_mld != NCL_double) NclFree(tmp_mld);
/*
* Return value back to NCL script.
*/
if(type_mld != NCL_double) {
ret = NclReturnValue(mld,ndims_mld,dsizes_mld,&missing_flt_mld,type_mld,0);
}
else {
ret = NclReturnValue(mld,ndims_mld,dsizes_mld,&missing_dbl_mld,type_mld,0);
}
NclFree(dsizes_mld);
return(ret);
}
NhlErrorTypes cd_calendar_W( void )
{
/*
* Input array variables
*/
void *x;
double *tmp_x;
NrmQuark *sspec = NULL;
char *cspec;
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;
const char *ccal = NULL;
cdCalenType ctype;
/*
* Output variables.
*/
cdCompTime comptime;
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;
extern float truncf(float);
/* initialize error flag */
cuErrorOccurred = 0;
/*
* 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,"proleptic_gregorian") &&
strcasecmp(ccal,"noleap") && strcasecmp(ccal,"no_leap") &&
strcasecmp(ccal,"allleap") && strcasecmp(ccal,"all_leap") &&
strcasecmp(ccal,"365_day") && strcasecmp(ccal,"365") &&
strcasecmp(ccal,"366_day") && strcasecmp(ccal,"366") &&
strcasecmp(ccal,"360_day") && strcasecmp(ccal,"360") &&
strcasecmp(ccal,"julian") && strcasecmp(ccal,"none")) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"cd_calendar: the 'calendar' attribute (%s) is not equal to a recognized calendar. Returning all missing values.",ccal);
return_missing = 1;
}
}
if ((strcmp(attr_list->attname, "units")) == 0) {
sspec = (NrmQuark *) attr_list->attvalue->multidval.val;
}
attr_list = attr_list->next;
}
}
default:
break;
}
/*
* If no calendar attribute set, or "none" was selected, then use
* the default "standard".
*/
if(ccal == NULL || !strcasecmp(ccal,"none")) {
ctype = calendar_type("standard");
}
else {
ctype = calendar_type(ccal);
}
/*
* Convert sspec to character string.
*/
if(sspec == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"cd_calendar: no 'units' attribute provided");
return(NhlFATAL);
}
cspec = NrmQuarkToString(*sspec);
/*
* 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,"cd_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,"cd_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) {
set_all_missing(date, total_size_date, missing_date, *option);
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);
/*
* 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)cdRel2Iso_minsec(ctype,cspec,tmp_x[i],&comptime,&minute,&second);
/*
* Return all missing values if we encounter a fatal error.
* Only check this once.
*/
if(i == 0 && (cuErrorOccurred && (cuErrOpts & CU_FATAL))) {
set_all_missing(date, total_size_date, missing_date, *option);
ret = NclReturnValue(date,ndims_date,dsizes_date,
&missing_date,type_date,0);
NclFree(dsizes_date);
return(ret);
}
year = (int)comptime.year;
month = (int)comptime.month;
day = (int)comptime.day;
/*
* comptime.hour is a double, and fractional. The "minute" and "second"
* above are calculated from the fractional part of the hour.
*/
hour = (int)comptime.hour;
/*
* 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);
/*
* 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 wgt_area_smooth_W (void)
{
/*
* Input variables
*/
/*
* Argument # 0
*/
void *field;
double *tmp_field;
int ndims_field;
ng_size_t dsizes_field[NCL_MAX_DIMENSIONS];
NclBasicDataTypes type_field;
int has_missing_field;
NclScalar missing_field, missing_flt_field, missing_dbl_field;
/*
* Argument # 1
*/
void *area;
double *tmp_area;
int ndims_area;
ng_size_t dsizes_area[NCL_MAX_DIMENSIONS];
NclBasicDataTypes type_area;
int has_missing_area;
NclScalar missing_area;
/*
* Argument # 2
*/
logical *opt;
int cyclic = 1;
/*
* Variables for retrieving attributes from "opt".
*/
NclAttList *attr_list;
NclAtt attr_obj;
NclStackEntry stack_entry;
/*
* Return variable
*/
void *smooth_ret;
double *tmp_smooth;
NclBasicDataTypes type_smooth;
NclScalar missing_smooth;
/*
* Various
*/
ng_size_t i, size_other,total_size,area_size;
int dims[3];
int ret;
/*
* 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
*/
field = (void*)NclGetArgValue(
0,
3,
&ndims_field,
dsizes_field,
&missing_field,
&has_missing_field,
&type_field,
DONT_CARE);
/*
* Get argument # 1
*/
area = (void*)NclGetArgValue(
1,
3,
&ndims_area,
dsizes_area,
&missing_area,
&has_missing_area,
&type_area,
DONT_CARE);
/*
* 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.
*/
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 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. The current ones recognized are:
* "cyclic"
*/
while (attr_list != NULL) {
/*
* Check for "cyclic".
*/
if (!strcmp(attr_list->attname, "cyclic")) {
if(attr_list->attvalue->multidval.data_type == NCL_logical) {
cyclic = *(logical*) attr_list->attvalue->multidval.val == False ? 0 : 1;
}
else {
NhlPError(NhlWARNING,NhlEUNKNOWN,
"wgt_area_smooth: The 'cyclic' attribute must be a logical. Defaulting to True.");
}
}
attr_list = attr_list->next;
}
}
default:
break;
}
}
/*
* Check dimension sizes.
*/
if(ndims_field < ndims_area) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"wgt_area_smooth: field must have at least 2 dimensions");
return(NhlFATAL);
}
if (dsizes_field[ndims_field - 2] != dsizes_area[0] ||
dsizes_field[ndims_field - 1] != dsizes_area[1]) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"wgt_area_smooth: the last two dimensions of field must be the same size as area");
return(NhlFATAL);
}
/*
* compute total elements in remaining dimensions of field
*/
size_other = 1;
total_size = 1;
area_size = 1;
for (i = 0; i < ndims_field - 2; i++) {
size_other *= dsizes_field[i];
total_size *= dsizes_field[i];
}
for (i = ndims_field - 2; i < ndims_field; i++) {
total_size *= dsizes_field[i];
area_size *= dsizes_field[i];
}
dims[0] = (int) dsizes_area[1];
dims[1] = (int) dsizes_area[0];
dims[2] = (int)size_other;
/*
* Coerce missing values to double if necessary.
*/
coerce_missing(type_field,has_missing_field,&missing_field,&missing_dbl_field,
&missing_flt_field);
/*
* The output type defaults to float, unless t is double.
*/
if(type_field == NCL_double) {
type_smooth = NCL_double;
if(has_missing_field) {
missing_smooth = missing_dbl_field;
}
}
else {
type_smooth = NCL_float;
if(has_missing_field) {
missing_smooth = missing_flt_field;
}
}
/*
* Coerce input arrays to double if necessary.
*/
tmp_field = coerce_input_double(field, type_field, total_size,0,NULL,NULL);
tmp_area = coerce_input_double(area, type_area, area_size,0,NULL,NULL);
if(tmp_field == NULL || tmp_area == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"wgt_area_smooth: Unable to allocate memory for coercing input arrays to double");
return(NhlFATAL);
}
/*
* Allocate space for output array.
*/
tmp_smooth = (void *)calloc(total_size, sizeof(double));
if(tmp_smooth == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"wgt_area_smooth: Unable to allocate memory for output array");
return(NhlFATAL);
}
NGCALLF(wgt_area_smooth,WGT_AREA_SMOOTH)(tmp_field,tmp_area,tmp_smooth,
&(dims[0]),&(dims[1]),&(dims[2]),&(missing_dbl_field.doubleval),&cyclic);
if (type_smooth == NCL_float) {
smooth_ret = (void *) coerce_output_float(tmp_smooth,NULL,total_size,0);
}
else {
smooth_ret = (void *) tmp_smooth;
}
if (type_field == NCL_float) {
NclFree(tmp_field);
}
if (type_area == NCL_float) {
NclFree(tmp_area);
}
if(has_missing_field) {
ret = NclReturnValue(smooth_ret,ndims_field,dsizes_field,&missing_smooth,type_smooth,0);
}
else {
ret = NclReturnValue(smooth_ret,ndims_field,dsizes_field,NULL,type_smooth,0);
}
return(ret);
}
NhlErrorTypes potmp_insitu_ocn_W( void )
{
/*
* Input variables
*/
/*
* Argument # 0
*/
void *t;
double *tmp_t;
int ndims_t;
ng_size_t dsizes_t[NCL_MAX_DIMENSIONS];
NclBasicDataTypes type_t;
int has_missing_t;
NclScalar missing_t, missing_flt_t, missing_dbl_t;
/*
* Argument # 1
*/
void *s;
double *tmp_s;
int ndims_s;
ng_size_t dsizes_s[NCL_MAX_DIMENSIONS];
NclBasicDataTypes type_s;
int has_missing_s;
NclScalar missing_s, missing_flt_s, missing_dbl_s;
/*
* Argument # 2
*/
void *pres;
double *tmp_pres;
int ndims_pres;
ng_size_t dsizes_pres[NCL_MAX_DIMENSIONS];
NclBasicDataTypes type_pres;
int is_scalar_pres;
/*
* Argument # 3
*/
void *pref;
double *tmp_pref;
NclBasicDataTypes type_pref;
/*
* Argument # 4
*/
int *dims;
ng_size_t dsizes_dims[1];
/*
* Argument # 5
*/
logical *opt;
logical reverse = False;
/*
* Variables for retrieving attributes from "opt".
*/
NclAttList *attr_list;
NclAtt attr_obj;
NclStackEntry stack_entry;
/*
* Return variable
*/
void *pot;
double *tmp_pot;
NclBasicDataTypes type_pot;
NclScalar missing_pot;
/*
* Various
*/
ng_size_t i, total_nts, total_npres, total_nl, total_nr, nrnpres;
ng_size_t ipres;
int ret;
/*
* 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
*/
t = (void*)NclGetArgValue(
0,
6,
&ndims_t,
dsizes_t,
&missing_t,
&has_missing_t,
&type_t,
DONT_CARE);
/*
* Get argument # 1
*/
s = (void*)NclGetArgValue(
1,
6,
&ndims_s,
dsizes_s,
&missing_s,
&has_missing_s,
&type_s,
DONT_CARE);
/*
* Check dimension sizes.
*/
if(ndims_t != ndims_s) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"potmp_insitu_ocn: the dimensions of t and s must be the same");
return(NhlFATAL);
}
for(i = 0; i < ndims_t; i++) {
if(dsizes_t[i] != dsizes_s[i]) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"potmp_insitu_ocn: the dimensions of t and s must be the same");
return(NhlFATAL);
}
}
/*
* Get argument # 2
*/
pres = (void*)NclGetArgValue(
2,
6,
&ndims_pres,
dsizes_pres,
NULL,
NULL,
&type_pres,
DONT_CARE);
/*
* Check dimension sizes and get total # of elements.
*/
if(ndims_pres > ndims_t) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"potmp_insitu_ocn: the rank of pres must be less than or equal to the rank of t and s");
return(NhlFATAL);
}
/* Scalar pressure is a special case */
is_scalar_pres = is_scalar(ndims_pres,dsizes_pres);
/*
* Get argument # 3
*/
pref = (void*)NclGetArgValue(
3,
6,
NULL,
NULL,
NULL,
NULL,
&type_pref,
DONT_CARE);
/*
* Get argument # 4
*/
dims = (int*)NclGetArgValue(
4,
6,
NULL,
dsizes_dims,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Get argument # 5
*/
opt = (logical*)NclGetArgValue(
5,
6,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Some error checking. Make sure pressure dimensions are valid.
*/
if(!is_scalar_pres) {
if(dsizes_dims[0] != ndims_pres) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"potmp_insitu_ocn: invalid number of dimension indexes given for 'pres'");
return(NhlFATAL);
}
for(i = 0; i < dsizes_dims[0]; i++ ) {
if(dims[i] < 0 || dims[i] >= ndims_t) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"potmp_insitu_ocn: invalid dimension indexes given for 'pres'");
return(NhlFATAL);
}
if(i > 0 && dims[i] != (dims[i-1]+1)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"potmp_insitu_ocn: input dimension sizes must be monotonically increasing, can't continue");
return(NhlFATAL);
}
if(dsizes_pres[i] != dsizes_t[dims[i]]) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"potmp_insitu_ocn: dimension indexes given for 'pres' don't match dimensions of t and s");
return(NhlFATAL);
}
}
}
/*
* Coerce missing values to double if necessary.
*/
coerce_missing(type_t,has_missing_t,&missing_t,&missing_dbl_t,
&missing_flt_t);
coerce_missing(type_s,has_missing_s,&missing_s,&missing_dbl_s,
&missing_flt_s);
/*
* Compute the total number of leftmost and rightmost elements
* in t and s.
*/
if(is_scalar_pres) {
total_nl = 1;
for(i = 0; i < ndims_t; i++) total_nl *= dsizes_t[i];
total_npres = nrnpres = total_nr = 1;
total_nts = total_nl;
}
else {
total_npres = total_nl = total_nr = 1;
for(i = 0; i < dims[0]; i++) total_nl *= dsizes_t[i];
for(i = 0; i < ndims_pres; i++) total_npres *= dsizes_pres[i];
for(i = dims[dsizes_dims[0]-1]+1; i < ndims_t; i++) total_nr *= dsizes_t[i];
nrnpres = total_nr * total_npres;
total_nts = total_nl * nrnpres;
}
/*
* The output type defaults to float, unless t is double.
*/
if(type_t == NCL_double || type_s == NCL_double ||
type_pres == NCL_double || type_pref == NCL_double) {
type_pot = NCL_double;
if(has_missing_t) {
missing_pot = missing_dbl_t;
}
else if(has_missing_s) {
missing_pot = missing_dbl_s;
}
}
else {
type_pot = NCL_float;
if(has_missing_t) {
missing_pot = missing_flt_t;
}
else if(has_missing_s) {
missing_pot = missing_flt_s;
}
}
/*
* Coerce input arrays to double if necessary.
*/
tmp_t = coerce_input_double(t, type_t, total_nts,0,NULL,NULL);
tmp_s = coerce_input_double(s, type_s, total_nts,0,NULL,NULL);
tmp_pres = coerce_input_double(pres,type_pres,total_npres,0,NULL,NULL);
tmp_pref = coerce_input_double(pref,type_pref, 1,0,NULL,NULL);
if(tmp_t == NULL || tmp_s == NULL || tmp_pres == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"potmp_insitu_ocn: Unable to allocate memory for coercing input arrays to double");
return(NhlFATAL);
}
/*
* Allocate space for output array.
*/
if(type_pot != NCL_double) {
pot = (void *)calloc(total_nts, sizeof(float));
tmp_pot = (double*)calloc(1,sizeof(double));
}
else {
pot = (void *)calloc(total_nts, sizeof(double));
}
if(pot == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"potmp_insitu_ocn: Unable to allocate memory for output array");
return(NhlFATAL);
}
/*
* If "opt" is True, then check if any attributes have been set.
*/
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 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. The current ones recognized are:
* "reverse"
*/
while (attr_list != NULL) {
/*
* Check for "return_eval".
*/
if (!strcmp(attr_list->attname, "reverse")) {
if(attr_list->attvalue->multidval.data_type == NCL_logical) {
reverse = *(logical*) attr_list->attvalue->multidval.val;
}
else {
NhlPError(NhlWARNING,NhlEUNKNOWN,"potmp_insitu_ocn: The 'reverse' attribute must be a logical. Defaulting to False.");
}
}
attr_list = attr_list->next;
}
}
default:
break;
}
}
/*
* Call the Fortran routine.
*/
for(i = 0; i < total_nts; i++) {
if(type_pot == NCL_double) tmp_pot = &((double*)pot)[i];
/* Calculate index into pressure array */
ipres = (ng_size_t)((i-((ng_size_t)(i/nrnpres)*nrnpres))/total_nr);
if(has_missing_t && tmp_t[i] == missing_dbl_t.doubleval) {
*tmp_pot = missing_dbl_t.doubleval;
}
else if(has_missing_s && tmp_s[i] == missing_dbl_s.doubleval) {
*tmp_pot = missing_dbl_s.doubleval;
}
else {
if(reverse) {
NGCALLF(dpotmp,DPOTMP)(tmp_pref, &tmp_t[i], &tmp_s[i],
&tmp_pres[ipres], tmp_pot);
}
else {
NGCALLF(dpotmp,DPOTMP)(&tmp_pres[ipres], &tmp_t[i], &tmp_s[i],
tmp_pref, tmp_pot);
}
}
/*
* Coerce output back to float if necessary.
*/
if(type_pot == NCL_float) coerce_output_float_only(pot,tmp_pot,1,i);
}
/*
* Free unneeded memory.
*/
if(type_t != NCL_double) NclFree(tmp_t);
if(type_s != NCL_double) NclFree(tmp_s);
if(type_pres != NCL_double) NclFree(tmp_pres);
if(type_pref != NCL_double) NclFree(tmp_pref);
if(type_pot != NCL_double) NclFree(tmp_pot);
/*
* Return value back to NCL script.
*/
if(has_missing_t || has_missing_s) {
ret = NclReturnValue(pot,ndims_t,dsizes_t,&missing_pot,type_pot,0);
}
else {
ret = NclReturnValue(pot,ndims_t,dsizes_t,NULL,type_pot,0);
}
return(ret);
}
NhlErrorTypes depth_to_pres_W( void )
{
/*
* Input variables
*/
/*
* Argument # 0
*/
void *z;
double *tmp_z;
int ndims_z;
ng_size_t dsizes_z[NCL_MAX_DIMENSIONS];
int has_missing_z;
NclScalar missing_z, missing_dbl_z, missing_flt_z;
NclBasicDataTypes type_z;
/*
* Argument # 1
*/
logical *opt;
/*
* Return variable
*/
void *pres;
double *tmp_pres = NULL;
NclBasicDataTypes type_pres;
NclScalar missing_pres;
/*
* Various
*/
ng_size_t i, nd;
int ind, ret;
double zmsg;
/*
* 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
*/
z = (void*)NclGetArgValue(
0,
2,
&ndims_z,
dsizes_z,
&missing_z,
&has_missing_z,
&type_z,
DONT_CARE);
/*
* Get argument # 1
*/
opt = (logical*)NclGetArgValue(
1,
2,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
nd = 1;
for(i = 0; i < ndims_z; i++) nd *= dsizes_z[i];
/*
* Test input dimension sizes.
*/
if(nd > INT_MAX) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"depth_to_pres: the size of z is greater than INT_MAX");
return(NhlFATAL);
}
ind = (int) nd;
/*
* Coerce missing values to double if necessary.
* Currently, missing values are not checked for.
*/
coerce_missing(type_z,has_missing_z,&missing_z,&missing_dbl_z,
&missing_flt_z);
/*
* The output type defaults to float, unless z is double.
*/
if(type_z == NCL_double) type_pres = NCL_double;
else type_pres = NCL_float;
if(has_missing_z) {
if(type_z == NCL_double) missing_pres = missing_dbl_z;
else missing_pres = missing_flt_z;
zmsg = missing_dbl_z.doubleval;
}
else {
zmsg = 0.0; /* Won't be used. */
}
/*
* Coerce input array to double if necessary.
*/
tmp_z = coerce_input_double(z,type_z,nd,0,NULL,NULL);
if(tmp_z == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"depth_to_pres: Unable to allocate memory for coercing z to double");
return(NhlFATAL);
}
/*
* Allocate space for output array.
*/
if(type_pres != NCL_double) {
pres = (void *)calloc(nd, sizeof(float));
tmp_pres = (double *)calloc(nd,sizeof(double));
if(tmp_pres == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"depth_to_pres: Unable to allocate memory for temporary output array");
return(NhlFATAL);
}
}
else {
pres = (void *)calloc(nd, sizeof(double));
}
if(pres == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"depth_to_pres: Unable to allocate memory for output array");
return(NhlFATAL);
}
if(type_pres == NCL_double) tmp_pres = &((double*)pres)[0];
/*
* Call the Fortran routine.
*/
NGCALLF(dpth2pres,DPTH2PRES)(&ind, tmp_z, &has_missing_z, &zmsg, tmp_pres);
/*
* Coerce output back to float if necessary.
*/
if(type_pres == NCL_float) coerce_output_float_only(pres,tmp_pres,nd,0);
/*
* Free unneeded memory.
*/
if(type_z != NCL_double) NclFree(tmp_z);
if(type_pres != NCL_double) NclFree(tmp_pres);
/*
* Return value back to NCL script.
*/
if(has_missing_z) {
ret = NclReturnValue(pres,ndims_z,dsizes_z,&missing_pres,type_pres,0);
}
else {
ret = NclReturnValue(pres,ndims_z,dsizes_z,NULL,type_pres,0);
}
return(ret);
}
NhlErrorTypes bw_bandpass_filter_W( void )
{
/*
* Input variables
*/
/*
* Argument # 0
*/
void *xr;
double *tmp_xr;
int ndims_xr;
ng_size_t dsizes_xr[NCL_MAX_DIMENSIONS];
NclBasicDataTypes type_xr;
/*
* Argument # 1
*/
void *fca;
double *tmp_fca;
NclBasicDataTypes type_fca;
/*
* Argument # 2
*/
void *fcb;
double *tmp_fcb;
NclBasicDataTypes type_fcb;
/*
* Argument # 3
*/
logical *opt;
/*
* Argument # 4
*/
int *dims;
ng_size_t ndims;
/*
* Return variable
*/
void *bf;
int ndims_bf;
double *tmp_yr, *tmp_er;
ng_size_t *dsizes_bf;
NclBasicDataTypes type_bf;
/*
* Variables for retrieving attributes from "opt".
*/
NclAttList *attr_list;
NclAtt attr_obj;
NclStackEntry stack_entry;
logical set_dt = False, rmv_mean = True, ret_filt = True, ret_env = False;
int m=6, iflag;
void *dt;
double *tmp_dt;
NclBasicDataTypes type_dt;
/*
* Various
*/
ng_size_t i, nx, total_nl, total_nr, nrnx;
ng_size_t index_xr, index_nrx, size_xr, size_output;
int j, inx, ret, ier;
/*
* Retrieve parameters.
*
* Note any of the pointer parameters can be set to NULL, which
* implies you don't care about its value.
*/
/*
* Get argument # 0
*/
xr = (void*)NclGetArgValue(
0,
5,
&ndims_xr,
dsizes_xr,
NULL,
NULL,
&type_xr,
DONT_CARE);
/*
* Get argument # 1
*/
fca = (void*)NclGetArgValue(
1,
5,
NULL,
NULL,
NULL,
NULL,
&type_fca,
DONT_CARE);
/*
* Get argument # 2
*/
fcb = (void*)NclGetArgValue(
2,
5,
NULL,
NULL,
NULL,
NULL,
&type_fcb,
DONT_CARE);
/*
* Get argument # 3
*/
opt = (logical*)NclGetArgValue(
3,
5,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Get argument # 4
*/
dims = (int *)NclGetArgValue(4,5,NULL,&ndims,NULL,NULL,NULL,0);
/*
* Some error checking. Make sure input dimension is valid.
*/
if(ndims > ndims_xr) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"bw_bandpass_filter: too many dimensions in dimension argument, can't continue");
return(NhlFATAL);
}
for(i = 0; i < ndims; i++ ) {
if(dims[i] < 0 || dims[i] >= ndims_xr) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"bw_bandpass_filter: Invalid dimension argument, can't continue");
return(NhlFATAL);
}
if(i > 0 && dims[i] != (dims[i-1]+1)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"bw_bandpass_filter: Input dimension sizes must be monotonically increasing, can't continue");
return(NhlFATAL);
}
}
/*
* Check for attributes attached to "opt"
*
* "m" - 6
* "dt" - 1.0
* "remove_mean" - True
* "return_filtered" - True
* "return_envelope" - False
*/
if(*opt) {
stack_entry = _NclGetArg(3, 5, DONT_CARE);
switch (stack_entry.kind) {
case NclStk_VAR:
if (stack_entry.u.data_var->var.att_id != -1) {
attr_obj = (NclAtt) _NclGetObj(stack_entry.u.data_var->var.att_id);
if (attr_obj == NULL) {
break;
}
}
else {
/*
* att_id == -1 ==> no optional args given.
*/
break;
}
/*
* Get optional arguments.
*/
if (attr_obj->att.n_atts > 0) {
/*
* Get list of attributes.
*/
attr_list = attr_obj->att.att_list;
/*
* Loop through attributes and check them.
*/
while (attr_list != NULL) {
if(!strcasecmp(attr_list->attname, "remove_mean")) {
rmv_mean = *(logical *) attr_list->attvalue->multidval.val;
}
else if(!strcasecmp(attr_list->attname, "return_filtered")) {
ret_filt = *(logical *) attr_list->attvalue->multidval.val;
}
else if(!strcasecmp(attr_list->attname, "return_envelope")) {
ret_env = *(logical *) attr_list->attvalue->multidval.val;
}
else if(!strcasecmp(attr_list->attname, "dt")) {
dt = attr_list->attvalue->multidval.val;
type_dt = attr_list->attvalue->multidval.data_type;
set_dt = True;
}
else if(!strcasecmp(attr_list->attname, "m")) {
m = *(int *) attr_list->attvalue->multidval.val;
}
attr_list = attr_list->next;
}
default:
break;
}
}
}
/*
* Provide default for dt if not specified by user.
*/
if(set_dt) {
tmp_dt = coerce_input_double(dt,type_dt,1,0,NULL,NULL);
}
else {
type_dt = NCL_double;
tmp_dt = (double *)calloc(1,sizeof(double));
*tmp_dt = 1.0;
}
if(!ret_filt && !ret_env) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"bw_bandpass_filter: both return_filtered and return_envelope are False. One of these must be True");
return(NhlFATAL);
}
/*
* Calculate size and dimension sizes of output array.
*
* If both ret_filt and ret_env are True, then the
* return array will be 2 x k x ...
* Otherwise it will be k x ...
*
*/
if(ret_filt && ret_env) ndims_bf = ndims_xr + 1;
else ndims_bf = ndims_xr;
dsizes_bf = (ng_size_t*)calloc(ndims_bf,sizeof(ng_size_t));
if( dsizes_bf == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"bw_bandpass_filter: Unable to allocate memory for holding dimension sizes");
return(NhlFATAL);
}
if(ret_filt && ret_env) dsizes_bf[0] = 2;
for(i = 0; i < ndims_xr; i++)
dsizes_bf[i+(ndims_bf-ndims_xr)] = dsizes_xr[i];
/*
* Calculate number of leftmost, rightmost, and middle elements.
*/
nx = total_nl = total_nr = 1;
for(i = 0; i < ndims ; i++) nx = nx*dsizes_xr[dims[i]];
for(i = 0; i < dims[0]; i++) total_nl *= dsizes_xr[i];
for(i = dims[ndims-1]+1; i < ndims_xr; i++) total_nr *= dsizes_xr[i];
/*
* Calculate xr and output sizes.
*/
size_xr = total_nr * total_nl * nx;
if(ret_filt && ret_env) size_output = size_xr * 2;
else size_output = size_xr;
if(nx > INT_MAX) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"bw_bandpass_filter: nx = %ld is greater than INT_MAX", nx);
return(NhlFATAL);
}
inx = (int) nx;
/*
* Coerce fca, fcb to double, if needed.
*/
tmp_fca = coerce_input_double(fca,type_fca,1,0,NULL,NULL);
tmp_fcb = coerce_input_double(fcb,type_fcb,1,0,NULL,NULL);
if(tmp_fca == NULL || tmp_fcb == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"bw_bandpass_filter: Unable to allocate memory for coercing input scalars to double");
return(NhlFATAL);
}
/*
* Allocate space for input array no matter what, because it
* may not be contiguous in memory.
*/
tmp_xr = (double *)calloc(nx,sizeof(double));
if(tmp_xr == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"bw_bandpass_filter: Unable to allocate memory for coercing input array to double");
return(NhlFATAL);
}
/*
* Return type.
*/
if(type_xr != NCL_double) type_bf = NCL_float;
else type_bf = NCL_double;
/*
* Allocate space for output array.
*/
if(type_bf != NCL_double) bf = (void *)calloc(size_output, sizeof(float));
else bf = (void *)calloc(size_output, sizeof(double));
if(bf == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"bw_bandpass_filter: Unable to allocate memory for output array");
return(NhlFATAL);
}
/*
* Allocate space for subset of output array.
*/
tmp_yr = (double *)calloc(nx, sizeof(double));
tmp_er = (double *)calloc(nx, sizeof(double));
if(tmp_yr == NULL || tmp_er == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"bw_bandpass_filter: Unable to allocate memory for temporary output arrays");
return(NhlFATAL);
}
/*
* Loop across leftmost/rightmost dimensions and call
* the Fortran routine for each subsection of the
* input arrays.
*/
nrnx = total_nr * nx;
if(rmv_mean) iflag = 1;
else iflag = 0;
for(i = 0; i < total_nl; i++) {
index_nrx = i*nrnx;
for(j = 0; j < total_nr; j++) {
index_xr = index_nrx + j;
/*
* Coerce subsection of x (tmp_xr) to double if necessary.
*/
coerce_subset_input_double_step(xr,tmp_xr,index_xr,total_nr,type_xr,
nx,0,NULL,NULL);
/*
* Call the Fortran routine.
*/
NGCALLF(buttfilt,BUTTFILT)(tmp_xr, tmp_yr, tmp_er, tmp_fca, tmp_fcb,
tmp_dt, &m, &inx, &iflag, &ier);
/*
* Copy/coerce back to output array
*/
if(ret_filt && !ret_env) {
coerce_output_float_or_double_step(bf,tmp_yr,type_bf,nx,
index_xr,total_nr);
}
else if(!ret_filt && ret_env) {
coerce_output_float_or_double_step(bf,tmp_er,type_bf,nx,
index_xr,total_nr);
}
else {
coerce_output_float_or_double_step(bf,tmp_yr,type_bf,nx,
index_xr,total_nr);
coerce_output_float_or_double_step(bf,tmp_er,type_bf,nx,
index_xr+size_xr,total_nr);
}
}
}
/*
* Free unneeded memory.
*/
NclFree(tmp_xr);
NclFree(tmp_er);
NclFree(tmp_yr);
if(type_fca != NCL_double) NclFree(tmp_fca);
if(type_fcb != NCL_double) NclFree(tmp_fcb);
if(!set_dt || type_dt != NCL_double) NclFree(tmp_dt);
/*
* Return value back to NCL script.
*/
ret = NclReturnValue(bf,ndims_bf,dsizes_bf,NULL,type_bf,0);
NclFree(dsizes_bf);
return(ret);
}
NhlErrorTypes dim_avg_wgt_W( void )
{
/*
* Input variables
*/
/*
* Argument # 0
*/
void *x;
double *tmp_x = NULL;
int ndims_x;
ng_size_t dsizes_x[NCL_MAX_DIMENSIONS];
int has_missing_x;
NclScalar missing_x, missing_flt_x, missing_dbl_x;
NclBasicDataTypes type_x;
/*
* Argument # 1
*/
void *w;
double *tmp_w;
ng_size_t dsizes_w[1];
NclBasicDataTypes type_w;
/*
* Argument # 2
*/
int *opt;
/*
* Return variable
*/
void *xavg;
double tmp_xavg[1];
int ndims_xavg;
ng_size_t *dsizes_xavg;
NclBasicDataTypes type_xavg;
/*
* Various
*/
int inx, ret, ndims_leftmost;
ng_size_t nx, index_x;
ng_size_t i, size_output;
/*
* Retrieve parameters.
*
* Note any of the pointer parameters can be set to NULL, which
* implies you don't care about its value.
*/
/*
* Get argument # 0
*/
x = (void*)NclGetArgValue(
0,
3,
&ndims_x,
dsizes_x,
&missing_x,
&has_missing_x,
&type_x,
DONT_CARE);
/*
* Coerce missing value to double if necessary.
*/
coerce_missing(type_x,has_missing_x,&missing_x,
&missing_dbl_x,&missing_flt_x);
/*
* Test input dimension size.
*/
nx = dsizes_x[ndims_x-1];
if(nx > INT_MAX) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_avg_wgt: nx = %ld is greater than INT_MAX", nx);
return(NhlFATAL);
}
inx = (int) nx;
/*
* Get argument # 1
*/
w = (void*)NclGetArgValue(
1,
3,
NULL,
dsizes_w,
NULL,
NULL,
&type_w,
DONT_CARE);
if(dsizes_w[0] != nx) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_avg_wgt: w must be length nx");
return(NhlFATAL);
}
/*
* Get argument # 2
*/
opt = (int*)NclGetArgValue(
2,
3,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Calculate size of leftmost dimensions.
*/
size_output = 1;
ndims_leftmost = ndims_x-1;
for(i = 0; i < ndims_leftmost; i++) {
size_output *= dsizes_x[i];
}
/*
* The output type defaults to float, unless this input array is double.
*/
type_xavg = NCL_float;
/*
* Allocate space for coercing input arrays. If any of the input
* is already double, then we don't need to allocate space for
* temporary arrays, because we'll just change the pointer into
* the void array appropriately.
*/
/*
* Allocate space for tmp_x.
*/
if(type_x != NCL_double) {
tmp_x = (double *)calloc(nx,sizeof(double));
if(tmp_x == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_avg_wgt: Unable to allocate memory for coercing input array to double");
return(NhlFATAL);
}
}
else {
type_xavg = NCL_double;
}
/*
* Allocate space for tmp_w.
*/
tmp_w = coerce_input_double(w,type_w,nx,0,NULL,NULL);
if(tmp_w == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_avg_wgt: Unable to allocate memory for coercing input array to double");
return(NhlFATAL);
}
/*
* Allocate space for output array.
*/
if(type_xavg != NCL_double) {
xavg = (void *)calloc(size_output, sizeof(float));
}
else {
xavg = (void *)calloc(size_output, sizeof(double));
}
if(xavg == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_avg_wgt: Unable to allocate memory for output array");
return(NhlFATAL);
}
/*
* Allocate space for output dimension sizes and set them.
*/
ndims_xavg = max(ndims_leftmost,1);
dsizes_xavg = (ng_size_t*)calloc(ndims_xavg,sizeof(ng_size_t));
if( dsizes_xavg == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_avg_wgt: Unable to allocate memory for holding dimension sizes");
return(NhlFATAL);
}
if(ndims_leftmost > 0) {
for(i = 0; i < ndims_leftmost; i++) dsizes_xavg[i] = dsizes_x[i];
}
else {
dsizes_xavg[0] = 1;
}
/*
* Loop across leftmost dimensions and call the Fortran routine for each
* one-dimensional subsection.
*/
index_x = 0;
for(i = 0; i < size_output; i++) {
/*
* Coerce subsection of x (tmp_x) to double if necessary.
*/
if(type_x != NCL_double) {
coerce_subset_input_double(x,tmp_x,index_x,type_x,nx,0,NULL,NULL);
}
else {
tmp_x = &((double*)x)[index_x];
}
/*
* Call the Fortran routine.
*/
NGCALLF(dimavgwgt,DIMAVGWGT)(&inx, tmp_x, &missing_dbl_x.doubleval,
tmp_w, opt, &tmp_xavg[0]);
/*
* Coerce output back to float or double.
*/
coerce_output_float_or_double(xavg,&tmp_xavg[0],type_x,1,i);
index_x += nx;
}
/*
* Free unneeded memory.
*/
if(type_x != NCL_double) NclFree(tmp_x);
if(type_w != NCL_double) NclFree(tmp_w);
/*
* Return value back to NCL script.
*/
if(has_missing_x) {
if(type_xavg == NCL_double) {
ret = NclReturnValue(xavg,ndims_xavg,dsizes_xavg,&missing_dbl_x,
type_xavg,0);
}
else {
ret = NclReturnValue(xavg,ndims_xavg,dsizes_xavg,&missing_flt_x,
type_xavg,0);
}
}
else {
ret = NclReturnValue(xavg,ndims_xavg,dsizes_xavg,NULL,type_xavg,0);
}
NclFree(dsizes_xavg);
return(ret);
}
NhlErrorTypes covcorm_W( void )
{
/*
* Input array variables
*/
void *x, *trace;
int *iopt;
double *dx, *dtrace;
ng_size_t dsizes_x[NCL_MAX_DIMENSIONS];
int ndims_x, has_missing_x;
NclScalar missing_x, missing_dx;
ng_size_t size_x, nvar, ntim, lvcm;
int ier;
NclBasicDataTypes type_x;
/*
* Output array variable
*/
void *vcm;
double *dvcm;
ng_size_t *dsizes_vcm;
int ndims_vcm;
ng_size_t size_vcm;
NclBasicDataTypes type_vcm;
NclTypeClass type_vcm_class;
NclScalar missing_vcm;
/*
* Variables for returning attributes.
*/
int att_id;
ng_size_t dsizes[1];
NclMultiDValData att_md, return_md;
NclVar tmp_var;
NclStackEntry return_data;
int intim, invar, ilvcm;
/*
* Retrieve x.
*/
x = (void*)NclGetArgValue(
0,
2,
&ndims_x,
dsizes_x,
&missing_x,
&has_missing_x,
&type_x,
DONT_CARE);
iopt = (int*)NclGetArgValue(
1,
2,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
nvar = dsizes_x[0];
ntim = dsizes_x[1];
size_x = nvar * ntim;
lvcm = (nvar*(nvar+1))/2;
/*
* Test dimension sizes to make sure they are <= INT_MAX.
*/
if((ntim > INT_MAX) ||
(nvar > INT_MAX) ||
(lvcm > INT_MAX)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"covcorm: one or more dimension sizes are greater than INT_MAX");
return(NhlFATAL);
}
intim = (int) ntim;
invar = (int) nvar;
ilvcm = (int) lvcm;
/*
* Coerce missing values, if any.
*/
coerce_missing(type_x,has_missing_x,&missing_x,&missing_dx,NULL);
/*
* Allocate space for input/output arrays.
*/
if(!iopt[1]) {
size_vcm = lvcm;
ndims_vcm = 1;
dsizes_vcm = (ng_size_t*)malloc(sizeof(ng_size_t));
dsizes_vcm[0] = size_vcm;
}
else {
size_vcm = nvar*nvar;
ndims_vcm = 2;
dsizes_vcm = (ng_size_t*)malloc(2*sizeof(ng_size_t));
dsizes_vcm[0] = nvar;
dsizes_vcm[1] = nvar;
}
dx = coerce_input_double(x,type_x,size_x,0,NULL,NULL);
if(type_x == NCL_double) {
type_vcm = NCL_double;
vcm = (void*)malloc(size_vcm*sizeof(double));
trace = (void*)malloc(sizeof(double));
if(vcm == NULL || trace == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"covcorm: Unable to allocate memory for output array");
return(NhlFATAL);
}
dvcm = &((double*)vcm)[0];
dtrace = &((double*)trace)[0];
missing_vcm.doubleval = missing_dx.doubleval;
}
else {
type_vcm = NCL_float;
vcm = (void*)malloc(size_vcm*sizeof(float));
trace = (void*)malloc(sizeof(float));
dvcm = (double*)malloc(size_vcm*sizeof(double));
dtrace = (double*)malloc(sizeof(double));
missing_vcm.floatval = (float)missing_dx.doubleval;
if(vcm == NULL || trace == NULL || dvcm == NULL || dtrace == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"covcorm: Unable to allocate memory for output array");
return(NhlFATAL);
}
}
/*
* Depending on iopt[1], call one of two Fortran routines.
* iopt[0]=0 --> covariance
* iopt[0]=1 --> correlation
* iopt[1]=0 --> 1D array (symmetric storage)
* iopt[1]=1 --> 2D array
*/
if(!iopt[1]) {
NGCALLF(dcovcormssm,DCOVCORMSSM)(&intim,&invar,dx,&missing_dx.doubleval,
&iopt[0],dvcm,&ilvcm,dtrace,&ier);
}
else {
NGCALLF(dcovcorm,DCOVCORM)(&intim,&invar,dx,&missing_dx.doubleval,
&iopt[0],dvcm,&ilvcm,dtrace,&ier);
}
if(type_vcm == NCL_float) {
/*
* Need to coerce output array back to float before we return it.
*/
coerce_output_float_only(vcm,dvcm,size_vcm,0);
coerce_output_float_only(trace,dtrace,1,0);
NclFree(dx);
if(type_x != NCL_double) NclFree(dvcm);
NclFree(dtrace);
}
/*
* Set up return value.
*/
type_vcm_class = (NclTypeClass)(_NclNameToTypeClass(NrmStringToQuark(_NclBasicDataTypeToName(type_vcm))));
return_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
vcm,
&missing_vcm,
ndims_vcm,
dsizes_vcm,
TEMPORARY,
NULL,
(NclObjClass)type_vcm_class
);
/*
* Initialize att_id so we can return some attributes.
*/
att_id = _NclAttCreate(NULL,NULL,Ncl_Att,0,NULL);
dsizes[0] = 1;
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
trace,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
(NclObjClass)type_vcm_class
);
_NclAddAtt(
att_id,
"trace",
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 replace_ieeenan_W( void )
{
/*
* Input array variables
*/
void *x, *value;
double *dvalue = NULL;
int *iopt, has_missing_x;
int ndims_x;
ng_size_t dsizes_x[NCL_MAX_DIMENSIONS];
NclBasicDataTypes type_x, type_value;
NclScalar missing_x;
/*
* Declare various variables for random purposes.
*/
ng_size_t i, size_x;
/*
* Retrieve argument.
*/
x = (void*)NclGetArgValue(
0,
3,
&ndims_x,
dsizes_x,
&missing_x,
&has_missing_x,
&type_x,
DONT_CARE);
if(type_x != NCL_float && type_x != NCL_double) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"replace_ieeenan: the first argument must be of type float or double");
return(NhlFATAL);
}
value = (void*)NclGetArgValue(
1,
3,
NULL,
NULL,
NULL,
NULL,
&type_value,
DONT_CARE);
if(type_value != NCL_float && type_value != NCL_double) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"replace_ieeenan: the second argument must be of type float or double");
return(NhlFATAL);
}
/*
* iopt isn't used for anything yet.
*/
iopt = (int*)NclGetArgValue(
2,
3,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Compute the total size of the input array.
*/
size_x = 1;
for( i = 0; i < ndims_x; i++ ) size_x *= dsizes_x[i];
/*
* Coerce value to double if necessary.
*/
if(type_x == NCL_double) {
dvalue = coerce_input_double(value,type_value,1,0,NULL,NULL);
}
/*
* A poor man's test for NaN: if the number is not less than or equal to
* 0 or greater than or equal to zero, then it must be NaN.
*/
if(type_x == NCL_float) {
for(i = 0; i < size_x; i++) {
if(((float*)x)[i] <= 0. || ((float*)x)[i] >= 0.) {
continue;
}
else {
((float*)x)[i] = ((float*)value)[0];
}
}
}
else {
for(i = 0; i < size_x; i++) {
if(((double*)x)[i] <= 0. || ((double*)x)[i] >= 0.) {
continue;
}
else {
((double*)x)[i] = *dvalue;
}
}
}
/*
* Return.
*/
return(NhlNOERROR);
}
NhlErrorTypes dim_gamfit_n_W( void )
{
/*
* Input variables
*/
/*
* Argument # 0
*/
void *x;
double *tmp_x;
int ndims_x;
ng_size_t dsizes_x[NCL_MAX_DIMENSIONS];
int has_missing_x;
NclScalar missing_x, missing_flt_x, missing_dbl_x;
NclBasicDataTypes type_x;
/*
* Argument # 1
*/
logical *optgam;
/*
* Argument # 2
*/
int *dims;
ng_size_t dsizes_dims;
/*
* Return variable
*/
void *xpar;
int ndims_xpar;
ng_size_t *dsizes_xpar;
NclScalar missing_xpar;
NclBasicDataTypes type_xpar;
/*
* Variables for retrieving attributes from "optgam";
*/
NclAttList *attr_list;
NclAtt attr_obj;
NclStackEntry stack_entry;
/*
* Various
*/
ng_size_t npts;
int inpts;
ng_size_t index_x, index_xpar, index_nrx, index_nr;
double *pcrit = NULL;
logical set_pcrit;
double alpha, scale, shape, pzero;
int inv_scale, ier, ret;
ng_size_t i, j, nrnx, total_nr, total_nl, total_nlnr, size_output;
/*
* Retrieve parameters.
*
* Note any of the pointer parameters can be set to NULL, which
* implies you don't care about its value.
*/
/*
* Get argument # 0
*/
x = (void*)NclGetArgValue(
0,
3,
&ndims_x,
dsizes_x,
&missing_x,
&has_missing_x,
&type_x,
DONT_CARE);
/*
* Get argument # 1
*/
optgam = (logical*)NclGetArgValue(
1,
3,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Get dimension(s) to do computation on.
*/
dims = (int*)NclGetArgValue(
2,
3,
NULL,
&dsizes_dims,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Some error checking. Make sure input dimensions are valid.
*/
for(i = 0; i < dsizes_dims; i++ ) {
if(dims[i] < 0 || dims[i] >= ndims_x) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_gamfit_n: Invalid dimension sizes to do calculations across, can't continue");
return(NhlFATAL);
}
if(i > 0 && dims[i] != (dims[i-1]+1)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_gamfit_n: Input dimension sizes must be monotonically increasing, can't continue");
return(NhlFATAL);
}
}
/*
* Calculate size of leftmost dimensions (nl) up to the dims[0]-th
* dimensions.
*
* Calculate number of points that will be passed to Fortran
* routine (npts).
*
* Calculate size of rightmost dimensions (nr) from the
* ndims[ndims-1]-th dimension.
*
* The dimension(s) to do the calculations across are "dims".
*/
total_nl = total_nr = npts = 1;
if(ndims_x > 1) {
ndims_xpar = ndims_x-dsizes_dims+1;
dsizes_xpar = NclMalloc(ndims_xpar * sizeof(ng_size_t));
dsizes_xpar[0] = 3;
for(i = 0; i < dims[0] ; i++) {
total_nl = total_nl*dsizes_x[i];
dsizes_xpar[i+1] = dsizes_x[i];
}
for(i = 0; i < dsizes_dims ; i++) {
npts = npts*dsizes_x[dims[i]];
}
for(i = dims[dsizes_dims-1]+1; i < ndims_x; i++) {
total_nr = total_nr*dsizes_x[i];
dsizes_xpar[i-dsizes_dims+1] = dsizes_x[i];
}
} else {
dsizes_xpar = NclMalloc(sizeof(ng_size_t));
*dsizes_xpar = 3;
ndims_xpar = 1;
npts = dsizes_x[dims[0]];
}
total_nlnr = total_nl * total_nr;
size_output = 3 * total_nlnr;
if( npts > INT_MAX) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_gamfit_n: npts is greater than INT_MAX");
return(NhlFATAL);
}
inpts = (int) npts;
/*
* Allocate space for tmp_x.
*/
tmp_x = (double *)calloc(npts,sizeof(double));
if(tmp_x == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_gamfit_n: Unable to allocate memory for coercing input array to double");
return(NhlFATAL);
}
/*
* Coerce missing value to double if necessary.
*/
coerce_missing(type_x,has_missing_x,&missing_x,
&missing_dbl_x,&missing_flt_x);
/*
* Allocate space for output array.
*/
if(type_x != NCL_double) {
type_xpar = NCL_float;
xpar = (void *)calloc(size_output, sizeof(float));
}
else {
type_xpar = NCL_double;
xpar = (void *)calloc(size_output, sizeof(double));
}
if(xpar == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_gamfit_n: Unable to allocate memory for output array");
return(NhlFATAL);
}
if(has_missing_x) {
if(type_xpar == NCL_double) missing_xpar = missing_dbl_x;
else missing_xpar = missing_flt_x;
}
/*
* Retrieve attributes from optgam, if any.
*/
set_pcrit = False;
inv_scale = 0;
if(*optgam) {
stack_entry = _NclGetArg(1, 3, DONT_CARE);
switch (stack_entry.kind) {
case NclStk_VAR:
if (stack_entry.u.data_var->var.att_id != -1) {
attr_obj = (NclAtt) _NclGetObj(stack_entry.u.data_var->var.att_id);
if (attr_obj == NULL) {
break;
}
}
else {
/*
* att_id == -1 ==> no attributes specified.
*/
break;
}
/*
* Check for attributes. If none are set, then use default values.
*/
if (attr_obj->att.n_atts == 0) {
break;
}
else {
/*
* Get list of attributes.
*/
attr_list = attr_obj->att.att_list;
/*
* Loop through attributes and check them.
*/
while (attr_list != NULL) {
/*
* pcrit
*/
if ((strcmp(attr_list->attname, "pcrit")) == 0) {
pcrit = coerce_input_double(attr_list->attvalue->multidval.val,
attr_list->attvalue->multidval.data_type,
1,0,NULL,NULL);
set_pcrit = True;
}
/*
* inv_scale
*/
if ((strcmp(attr_list->attname, "inv_scale")) == 0) {
if(attr_list->attvalue->multidval.data_type != NCL_logical) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"dim_gamfit_n: the 'inv_scale' attribute must be a logical, defaulting to False.");
}
else if(*(logical*)attr_list->attvalue->multidval.val) {
inv_scale = 1;
}
}
attr_list = attr_list->next;
}
}
default:
break;
}
}
if(!set_pcrit) {
pcrit = (double *)calloc(1,sizeof(double));
*pcrit = 0.0;
}
/*
* Loop across leftmost dimensions and call the Fortran routine for each
* subsection of the input arrays.
*/
nrnx = total_nr * npts;
for(i = 0; i < total_nl; i++) {
index_nrx = i*nrnx;
index_nr = i*total_nr;
for(j = 0; j < total_nr; j++) {
index_x = index_nrx + j;
index_xpar = index_nr + j;
/*
* Coerce subsection of x (tmp_x) to double.
*/
coerce_subset_input_double_step(x,tmp_x,index_x,total_nr,type_x,
npts,0,NULL,NULL);
/*
* Call the Fortran routine.
*/
NGCALLF(gamfitd3,GAMFITD3)(tmp_x, &inpts, &missing_dbl_x.doubleval,
pcrit, &inv_scale, &alpha, &scale,
&shape, &pzero, &ier);
/*
* Coerce output back to float or double
*/
coerce_output_float_or_double(xpar,&shape,type_xpar,1,index_xpar);
coerce_output_float_or_double(xpar,&scale,type_xpar,1,
index_xpar+total_nlnr);
coerce_output_float_or_double(xpar,&pzero,type_xpar,1,
index_xpar+(2*total_nlnr));
}
}
/*
* Free unneeded memory.
*/
NclFree(tmp_x);
/*
* Return value back to NCL script.
*/
if(has_missing_x) {
ret = NclReturnValue(xpar,ndims_xpar,dsizes_xpar,&missing_xpar,
type_xpar,0);
}
else {
ret = NclReturnValue(xpar,ndims_xpar,dsizes_xpar,NULL,type_xpar,0);
}
NclFree(dsizes_xpar);
return(ret);
}
NhlErrorTypes generate_2d_array_W( void )
{
/*
* Input array variables
*/
void *tmp_dsizes_data;
ng_size_t *dsizes_data;
int *mlow, *mhigh, *iseed;
void *dlow, *dhigh;
double *tmp_dlow, *tmp_dhigh;
NclBasicDataTypes type_dlow, type_dhigh, type_dsizes_data;
/*
* Output variables.
*/
void *data;
double *tmp_data;
NclBasicDataTypes type_data;
int ret, id0, id1;
/*
* Declare various variables for random purposes.
*/
ng_size_t size_data;
/*
* Retrieve arguments.
*
*
* Get number of lows and highs. These two values will be forced to
* be between 1 and 25.
*/
mlow = (int*)NclGetArgValue(
0,
6,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
mhigh = (int*)NclGetArgValue(
1,
6,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Retrieve minimum and maximum values that the data is supposed to have.
*/
dlow = (void*)NclGetArgValue(
2,
6,
NULL,
NULL,
NULL,
NULL,
&type_dlow,
DONT_CARE);
dhigh = (void*)NclGetArgValue(
3,
6,
NULL,
NULL,
NULL,
NULL,
&type_dhigh,
DONT_CARE);
/*
* Get size of output array.
*/
iseed = (int*)NclGetArgValue(
4,
6,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Get size of output array.
*/
tmp_dsizes_data = (void*)NclGetArgValue(
5,
6,
NULL,
NULL,
NULL,
NULL,
&type_dsizes_data,
DONT_CARE);
/*
* Error checking.
*/
dsizes_data = get_dimensions(tmp_dsizes_data,2,type_dsizes_data,"generate_2d_array");
if(dsizes_data == NULL)
return(NhlFATAL);
if(dsizes_data[0] <= 1 && dsizes_data[1] <= 1) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"generate_2d_array: the dimensions of the output array must be such that it has at least two elements");
return(NhlFATAL);
}
if((dsizes_data[0] > INT_MAX) ||
(dsizes_data[1] > INT_MAX)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"generate_2d_array: input dimensions are greater than INT_MAX");
return(NhlFATAL);
}
id0 = (int) dsizes_data[0];
id1 = (int) dsizes_data[1];
if(*iseed < 0 || *iseed > 100) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"generate_2d_array: iseed must be between 0 and 100. Will reset to 0.");
*iseed = 0;
}
if(*mlow < 1) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"generate_2d_array: mlow must be between 1 and 25. Will reset to 1.");
*mlow = 1;
}
if(*mlow > 25) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"generate_2d_array: mlow must be between 1 and 25. Will reset to 25.");
*mlow = 25;
}
if(*mhigh < 1) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"generate_2d_array: mhigh must be between 1 and 25. Will reset to 1.");
*mhigh = 1;
}
if(*mhigh > 25) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"generate_2d_array: mhigh must be between 1 and 25. Will reset to 25.");
*mhigh = 25;
}
/*
* Coerce dlow and dhigh to double.
*/
tmp_dlow = coerce_input_double(dlow, type_dlow, 1,0,NULL,NULL);
tmp_dhigh = coerce_input_double(dhigh,type_dhigh,1,0,NULL,NULL);
/*
* Compute the size of the 2D output array.
*/
size_data = dsizes_data[0] * dsizes_data[1];
/*
* The type of the output array depends on dlow and dhigh.
*/
if(type_dlow == NCL_double || type_dhigh == NCL_double) {
type_data = NCL_double;
}
else {
type_data = NCL_float;
}
/*
* Allocate memory for output.
*/
if(type_data == NCL_double) {
data = (void*)malloc(size_data*sizeof(double));
tmp_data = (double *)data;
if(data == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"generate_2d_array: Unable to allocate memory for output array");
return(NhlFATAL);
}
}
else {
data = (void*)malloc(size_data*sizeof(float));
tmp_data = (double*)malloc(size_data*sizeof(double));
if(tmp_data == NULL || data == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"generate_2d_array: Unable to allocate memory for output array");
return(NhlFATAL);
}
}
/*
* Call the Fortran version of this routine.
*/
NGCALLF(dgendat,DGENDAT)(tmp_data,&id1,&id1,
&id0,mlow,mhigh,tmp_dlow,tmp_dhigh,
iseed);
/*
* Figure out if we need to coerce output back to float.
*/
if(type_data == NCL_float) {
coerce_output_float_only(data,tmp_data,size_data,0);
}
/*
* Free memory.
*/
if(type_data != NCL_double) NclFree(tmp_data);
if(type_dlow != NCL_double) NclFree(tmp_dlow);
if(type_dhigh != NCL_double) NclFree(tmp_dhigh);
ret = NclReturnValue(data,2,dsizes_data,NULL,type_data,0);
NclFree(dsizes_data);
return(ret);
}
NhlErrorTypes area_conserve_remap_W( void )
{
/*
* Input variables
*/
/*
* Argument # 0
*/
void *loni;
double *tmp_loni;
ng_size_t dsizes_loni[1];
NclBasicDataTypes type_loni;
/*
* Argument # 1
*/
void *lati;
double *tmp_lati;
ng_size_t dsizes_lati[1];
NclBasicDataTypes type_lati;
/*
* Argument # 2
*/
void *fi;
double *tmp_fi = NULL;
int ndims_fi;
ng_size_t dsizes_fi[NCL_MAX_DIMENSIONS];
int has_missing_fi;
NclScalar missing_fi, missing_flt_fi, missing_dbl_fi;
NclBasicDataTypes type_fi;
/*
* Argument # 3
*/
void *lono;
double *tmp_lono;
ng_size_t dsizes_lono[1];
NclBasicDataTypes type_lono;
/*
* Argument # 4
*/
void *lato;
double *tmp_lato;
ng_size_t dsizes_lato[1];
NclBasicDataTypes type_lato;
/*
* Argument # 5
*/
logical *opt;
/*
* Return variable
*/
void *fo;
double *tmp_fo;
ng_size_t *dsizes_fo;
NclBasicDataTypes type_fo;
/*
* Various
*/
ng_size_t nloni, nlati, nlevi, nlono, nlato, nlevnlatnloni, nlevnlatnlono;
ng_size_t NLATi, NLATo, i;
int ret;
double *bin_factor = NULL;
logical set_binf;
NclBasicDataTypes type_bin_factor;
/*
* Variables for retrieving attributes from "opt".
*/
NclAttList *attr_list;
NclAtt attr_obj;
NclStackEntry stack_entry;
/*
* Variables for coercing input dimension sizes to integer.
*/
int inlono, inlato, iNLATo, iNLATi, inloni, inlati, inlevi;
/*
* Retrieve parameters.
*
* Note any of the pointer parameters can be set to NULL, which
* implies you don't care about its value.
*/
/*
* Get argument # 0
*/
loni = (void*)NclGetArgValue(
0,
6,
NULL,
dsizes_loni,
NULL,
NULL,
&type_loni,
DONT_CARE);
nloni = dsizes_loni[0];
/*
* Get argument # 1
*/
lati = (void*)NclGetArgValue(
1,
6,
NULL,
dsizes_lati,
NULL,
NULL,
&type_lati,
DONT_CARE);
nlati = dsizes_lati[0];
/*
* Get argument # 2
*/
fi = (void*)NclGetArgValue(
2,
6,
&ndims_fi,
dsizes_fi,
&missing_fi,
&has_missing_fi,
&type_fi,
DONT_CARE);
/*
* Check dimension sizes.
*/
if(ndims_fi < 2) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_conserve_remap: The fi array must have at least 2 dimensions");
return(NhlFATAL);
}
/*
* Coerce missing value to double if necessary.
*/
coerce_missing(type_fi,has_missing_fi,&missing_fi,
&missing_dbl_fi,&missing_flt_fi);
if(dsizes_fi[ndims_fi-2] != nlati || dsizes_fi[ndims_fi-1] != nloni) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_conserve_remap: The rightmost two dimension of fi must be nlat x nlon");
return(NhlFATAL);
}
/*
* Get argument # 3
*/
lono = (void*)NclGetArgValue(
3,
6,
NULL,
dsizes_lono,
NULL,
NULL,
&type_lono,
DONT_CARE);
nlono = dsizes_lono[0];
/*
* Get argument # 4
*/
lato = (void*)NclGetArgValue(
4,
6,
NULL,
dsizes_lato,
NULL,
NULL,
&type_lato,
DONT_CARE);
nlato = dsizes_lato[0];
/*
* Get argument # 5
*/
opt = (logical*)NclGetArgValue(
5,
6,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Check for the following attributes attached to "opt":
* NLATi
* NLATo
* bin_factor
*
* If not found, then use default values, which are set here.
* "bin_factor" will be set later.
*/
NLATi = nlati;
NLATo = nlato;
set_binf = False;
if(*opt) {
stack_entry = _NclGetArg(5, 6, DONT_CARE);
switch (stack_entry.kind) {
case NclStk_VAR:
if (stack_entry.u.data_var->var.att_id != -1) {
attr_obj = (NclAtt) _NclGetObj(stack_entry.u.data_var->var.att_id);
if (attr_obj == NULL) {
break;
}
}
else {
/*
* att_id == -1 ==> no attributes specified.
*/
break;
}
/*
* Check for attributes. If none are set, then use default values.
*/
if (attr_obj->att.n_atts == 0) {
break;
}
else {
/*
* Get list of attributes.
*/
attr_list = attr_obj->att.att_list;
/*
* Loop through attributes and check them.
*/
while (attr_list != NULL) {
/*
* NLATi
*/
if ((strcmp(attr_list->attname, "NLATi")) == 0) {
if(attr_list->attvalue->multidval.data_type != NCL_int) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"area_conserve_remap: The 'NLATi' attribute must be an integer, defaulting to nlati.");
}
else {
NLATi = *(int*) attr_list->attvalue->multidval.val;
}
}
/*
* NLATo
*/
if ((strcmp(attr_list->attname, "NLATo")) == 0) {
if(attr_list->attvalue->multidval.data_type != NCL_int) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"area_conserve_remap: The 'Nlato' attribute must be an integer, defaulting to nlato.");
}
else {
NLATo = *(int*) attr_list->attvalue->multidval.val;
}
}
/*
* bin_factor
*/
if(!strcmp(attr_list->attname, "bin_factor")) {
type_bin_factor = attr_list->attvalue->multidval.data_type;
bin_factor = coerce_input_double(attr_list->attvalue->multidval.val,
type_bin_factor,1,0,NULL,NULL);
set_binf = True;
}
attr_list = attr_list->next;
}
}
default:
break;
}
}
if(!set_binf) {
bin_factor = (double *)calloc(1,sizeof(double));
*bin_factor = 1.0;
}
/*
* Calculate size of leftmost dimensions and fi/fo.
*/
nlevi = 1;
for(i = 0; i < ndims_fi-2; i++) nlevi *= dsizes_fi[i];
/*
* Test input dimension sizes to make sure they are <= INT_MAX.
*/
if((nlono > INT_MAX) ||
(nlato > INT_MAX) ||
(NLATi > INT_MAX) ||
(NLATo > INT_MAX) ||
(nloni > INT_MAX) ||
(nlati > INT_MAX) ||
(nlevi > INT_MAX)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_conserve_remap: One of the input array dimension sizes is greater than INT_MAX");
return(NhlFATAL);
}
inlono = (int) nlono;
inlato = (int) nlato;
iNLATo = (int) NLATo;
iNLATi = (int) NLATi;
inloni = (int) nloni;
inlati = (int) nlati;
inlevi = (int) nlevi;
nlevnlatnloni = nlevi * nlati * nloni; /* input array size */
nlevnlatnlono = nlevi * nlato * nlono; /* output array size */
/*
* Allocate space for coercing input arrays. If any of the input
* is already double, then we don't need to allocate space for
* temporary arrays, because we'll just change the pointer into
* the void array appropriately.
*/
/*
* Allocate space for tmp_loni.
*/
tmp_loni = coerce_input_double(loni,type_loni,nloni,0,NULL,NULL);
if(tmp_loni == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_conserve_remap: Unable to allocate memory for coercing input array to double");
return(NhlFATAL);
}
/*
* Allocate space for tmp_lati.
*/
tmp_lati = coerce_input_double(lati,type_lati,nlati,0,NULL,NULL);
if(tmp_lati == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_conserve_remap: Unable to allocate memory for coercing input array to double");
return(NhlFATAL);
}
/*
* Allocate space for tmp_fi and determine type of output.
*
* The output type defaults to float, unless fi is double.
*/
if(type_fi != NCL_double) {
type_fo = NCL_float;
}
else {
type_fo = NCL_double;
}
/*
* Coerce input to double if necessary.
*/
tmp_fi = coerce_input_double(fi,type_fi,nlevnlatnloni,0,NULL,NULL);
if(tmp_fi == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_conserve_remap: Unable to allocate memory for coercing fi to double");
return(NhlFATAL);
}
/*
* Allocate space for tmp_lono.
*/
tmp_lono = coerce_input_double(lono,type_lono,nlono,0,NULL,NULL);
if(tmp_lono == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_conserve_remap: Unable to allocate memory for coercing lono to double");
return(NhlFATAL);
}
/*
* Allocate space for tmp_lato.
*/
tmp_lato = coerce_input_double(lato,type_lato,nlato,0,NULL,NULL);
if(tmp_lato == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_conserve_remap: Unable to allocate memory for coercing lato to double");
return(NhlFATAL);
}
/*
* Allocate space for output array.
*/
if(type_fo != NCL_double) {
fo = (void *)calloc(nlevnlatnlono, sizeof(float));
tmp_fo = (double *)calloc(nlevnlatnlono,sizeof(double));
if(fo == NULL || tmp_fo == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_conserve_remap: Unable to allocate memory for output array");
return(NhlFATAL);
}
}
else {
fo = (void *)calloc(nlevnlatnlono, sizeof(double));
if(fo == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_conserve_remap: Unable to allocate memory for output array");
return(NhlFATAL);
}
tmp_fo = fo;
}
/*
* Allocate space for output dimension sizes and set them.
*/
dsizes_fo = (ng_size_t*)calloc(ndims_fi,sizeof(ng_size_t));
if( dsizes_fo == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_conserve_remap: Unable to allocate memory for holding dimension sizes");
return(NhlFATAL);
}
for(i = 0; i < ndims_fi-2; i++) dsizes_fo[i] = dsizes_fi[i];
dsizes_fo[ndims_fi-2] = nlato;
dsizes_fo[ndims_fi-1] = nlono;
/*
* Call the Fortran routine.
*/
NGCALLF(cremapbin,CREMAPBIN)(&inlevi, &inlato, &inlono, &inlati, &inloni,
tmp_fi, tmp_fo, tmp_lati, tmp_loni, tmp_lato,
tmp_lono, &iNLATi, &iNLATo, bin_factor,
&missing_dbl_fi.doubleval);
if (!set_binf || (set_binf && type_bin_factor != NCL_double)) {
free(bin_factor);
}
/*
* Coerce output back to float if necessary.
*/
if(type_fo == NCL_float) {
coerce_output_float_only(fo,tmp_fo,nlevnlatnlono,0);
}
/*
* Free unneeded memory.
*/
if(type_loni != NCL_double) NclFree(tmp_loni);
if(type_lati != NCL_double) NclFree(tmp_lati);
if(type_fi != NCL_double) NclFree(tmp_fi);
if(type_lono != NCL_double) NclFree(tmp_lono);
if(type_lato != NCL_double) NclFree(tmp_lato);
if(type_fo != NCL_double) NclFree(tmp_fo);
/*
* Return value back to NCL script.
*/
ret = NclReturnValue(fo,ndims_fi,dsizes_fo,NULL,type_fo,0);
NclFree(dsizes_fo);
return(ret);
}
NhlErrorTypes round_W( void )
{
/*
* Input array variables
*/
void *x;
double *tmp_x;
int has_missing_x, ndims_x;
ng_size_t dsizes_x[NCL_MAX_DIMENSIONS];
int *iopt, isx;
NclScalar missing_x, missing_dx, missing_xout;
NclBasicDataTypes type_x;
/*
* Output array variables
*/
void *xout = NULL;
double *tmp_xout;
NclBasicDataTypes type_xout = NCL_none;
/*
* Declare various variables for random purposes.
*/
ng_size_t i, size_x;
/*
* Retrieve argument.
*/
x = (void*)NclGetArgValue(
0,
2,
&ndims_x,
dsizes_x,
&missing_x,
&has_missing_x,
&type_x,
DONT_CARE);
/*
* Retrieve iopt. Currently, the value of iopt specifies the following:
*
* 0 -> depending on input, return float or double
* 1 -> send the output back as float
* 2 -> send the output back as double
* 3 -> send the output back as integer
*/
iopt = (int*)NclGetArgValue(
1,
2,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
if(*iopt < 0 || *iopt > 3) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"round: 'iopt' can only have the values 0-3");
return(NhlFATAL);
}
/*
* Compute the total size of the input array.
*/
size_x = 1;
for( i = 0; i < ndims_x; i++ ) size_x *= dsizes_x[i];
if(size_x > INT_MAX) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"round: size_x = %ld is greater than INT_MAX", size_x);
return(NhlFATAL);
}
isx = (int) size_x;
/*
* Coerce input and missing value to double if necessary.
*/
tmp_x = coerce_input_double(x,type_x,size_x,0,NULL,NULL);
coerce_missing(type_x,has_missing_x,&missing_x,&missing_dx,NULL);
/*
* The type of the output array depends on iopt and possibly the
* type of the input.
*/
switch(*iopt) {
case 0:
if(type_x != NCL_double) {
type_xout = NCL_float;
}
else {
type_xout = NCL_double;
}
break;
case 1:
type_xout = NCL_float;
break;
case 2:
type_xout = NCL_double;
break;
case 3:
type_xout = NCL_int;
break;
}
/*
* Allocate memory for output.
*/
switch(type_xout) {
case NCL_double:
xout = (void*)calloc(size_x,sizeof(double));
break;
case NCL_float:
xout = (void*)calloc(size_x,sizeof(float));
break;
case NCL_int:
xout = (void*)calloc(size_x,sizeof(int));
break;
default:
break;
}
/*
* Allocate space for temporary output which must be double. If the output
* is already double, then just point tmp_xout to xout.
*/
if(type_xout == NCL_double) {
tmp_xout = (double*)xout;
}
else {
tmp_xout = (double*)calloc(size_x,sizeof(double));
}
if(tmp_xout == NULL || xout == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"round: Unable to allocate memory for output arrays");
return(NhlFATAL);
}
/*
* Call the Fortran version of this routine.
*/
NGCALLF(rndncl,RNDNCL)(&isx,tmp_x,&has_missing_x,
&missing_dx.doubleval,tmp_xout,iopt);
/*
* Figure out if we need to coerce output back to float or int.
*/
if(type_xout == NCL_float) {
coerce_output_float_only(xout,tmp_xout,size_x,0);
}
if(type_xout == NCL_int) {
coerce_output_int_only(xout,tmp_xout,size_x,0);
}
/*
* Return correct missing value type for output.
*/
switch(type_xout) {
case NCL_double:
missing_xout.doubleval = missing_dx.doubleval;
break;
case NCL_float:
missing_xout.floatval = (float)missing_dx.doubleval;
break;
case NCL_int:
missing_xout.intval = (int)missing_dx.doubleval;
break;
default:
break;
}
/*
* Free memory.
*/
if(type_x != NCL_double) NclFree(tmp_x);
if(type_xout != NCL_double) NclFree(tmp_xout);
/*
* Return.
*/
if(has_missing_x) {
return(NclReturnValue(xout,ndims_x,dsizes_x,&missing_xout,type_xout,0));
}
else{
return(NclReturnValue(xout,ndims_x,dsizes_x,NULL,type_xout,0));
}
}
NhlErrorTypes area_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 center_finite_diff_n_W( void )
{
/*
* Input array variables
*/
void *q, *r;
logical *cyclic;
int *opt, *dim, r_one_d;
int r_scalar = 1;
double *tmp_q, *tmp_r;
int ndims_q;
ng_size_t dsizes_q[NCL_MAX_DIMENSIONS];
int ndims_r;
ng_size_t dsizes_r[NCL_MAX_DIMENSIONS];
int has_missing_q, has_missing_r;
NclScalar missing_q, missing_dq, missing_rq;
NclScalar missing_r, missing_dr;
NclBasicDataTypes type_q, type_r, type_dqdr;
/*
* Output array variables
*/
void *dqdr;
double *tmp_dqdr;
NclScalar missing_dqdr;
/*
* Declare various variables for random purposes.
*/
ng_size_t i, j, npts, npts1, size_q, size_leftmost, size_rightmost, size_rl;
ng_size_t index_nrnpts, index_q;
int inpts, inpts1, iend, ier;
double *qq, *rr;
/*
* Retrieve parameters
*
* Note that any of the pointer parameters can be set to NULL,
* which implies you don't care about its value.
*
*/
q = (void*)NclGetArgValue(
0,
5,
&ndims_q,
dsizes_q,
&missing_q,
&has_missing_q,
&type_q,
DONT_CARE);
r = (void*)NclGetArgValue(
1,
5,
&ndims_r,
dsizes_r,
&missing_r,
&has_missing_r,
&type_r,
DONT_CARE);
cyclic = (logical*)NclGetArgValue(
2,
5,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
opt = (int*)NclGetArgValue(
3,
5,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
dim = (int*)NclGetArgValue(
4,
5,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Make sure "dim" is a valid dimension.
*/
if (*dim < 0 || *dim >= ndims_q) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"center_finite_diff_n: Invalid dimension index for calculating the center finite difference");
return(NhlFATAL);
}
/*
* Set value for cyclic.
*/
if(*cyclic) {
iend = 0;
}
else {
iend = 1;
}
/*
* Get size of input array and test dimension sizes.
*/
npts = dsizes_q[*dim];
npts1 = npts + 1;
if((npts > INT_MAX) || (npts1 > INT_MAX)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"center_finite_diff_n: npts1 = %ld is larger than INT_MAX", npts1);
return(NhlFATAL);
}
inpts = (int) npts;
inpts1 = (int) npts1;
if((ndims_r == 1 && (dsizes_r[0] != npts && dsizes_r[0] != 1)) ||
(ndims_r > 1 && ndims_r != ndims_q)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"center_finite_diff_n: r must either be a scalar, a 1D array the same length as the dim-th dimemsion of q, or the same size as q");
return(NhlFATAL);
}
if(ndims_r > 1) {
for( i = 0; i < ndims_r; i++ ) {
if(dsizes_r[i] != dsizes_q[i]) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"center_finite_diff_n: r must either be a scalar, a 1D array the same length as the dim-th dimemsion of q, or the same size as q");
return(NhlFATAL);
}
}
}
/*
* Compute the total size of the q array.
*/
size_rightmost = size_leftmost = 1;
for( i = 0; i < *dim; i++ ) size_leftmost *= dsizes_q[i];
for( i = *dim+1; i < ndims_q; i++ ) size_rightmost *= dsizes_q[i];
size_rl = size_leftmost * size_rightmost;
size_q = size_rl * npts;
/*
* Check for missing values.
*/
coerce_missing(type_q,has_missing_q,&missing_q,&missing_dq,&missing_rq);
coerce_missing(type_r,has_missing_r,&missing_r,&missing_dr,NULL);
/*
* Create arrays to hold temporary r and q values.
*/
qq = (double*)calloc(npts+2,sizeof(double));
rr = (double*)calloc(npts+2,sizeof(double));
if( qq == NULL || rr == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"center_finite_diff_n: Unable to allocate memory for temporary arrays");
return(NhlFATAL);
}
/*
* Create temporary arrays to hold double precision data.
*/
tmp_q = (double*)calloc(npts,sizeof(double));
if( tmp_q == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"center_finite_diff_n: Unable to allocate memory for coercing q to double precision");
return(NhlFATAL);
}
/*
* 'r' can be a scalar, one-dimensional, or multi-dimensional.
*
* If it is a scalar, then we need to construct an npts-sized 'r'
* that is based on the scalar value.
*
* If it is 1D, then we need to coerce it to double if necessary.
*
* If it is nD, then we need to create a temporary 1D array so we
* can coerce the potentially non-contiguous 1D subsets to double.
*/
if(ndims_r > 1) {
r_one_d = 0;
}
else {
r_one_d = 1;
r_scalar = is_scalar(ndims_r,dsizes_r);
}
/*
* Here are the three possible scenarios for "r":
*/
if(r_scalar) {
tmp_r = (double*)calloc(npts,sizeof(double));
coerce_subset_input_double(r,&tmp_r[0],0,type_r,1,0,NULL,NULL);
/*
* Copy this scalar npts-1 times to rest of the array.
*/
for(i = 1; i < npts; i++ ) tmp_r[i] = tmp_r[i-1] + tmp_r[0];
}
else if(r_one_d) {
tmp_r = coerce_input_double(r,type_r,npts,0,NULL,NULL);
}
else {
tmp_r = (double*)calloc(npts,sizeof(double));
}
if( tmp_r == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"center_finite_diff_n: Unable to allocate memory for coercing r to double precision");
return(NhlFATAL);
}
/*
* Allocate space for output array.
*/
if(type_q == NCL_double || type_r == NCL_double) {
type_dqdr = NCL_double;
dqdr = (void*)calloc(size_q,sizeof(double));
missing_dqdr = missing_dq;
}
else {
type_dqdr = NCL_float;
dqdr = (void*)calloc(size_q,sizeof(float));
missing_dqdr = missing_rq;
}
tmp_dqdr = (double*)calloc(npts,sizeof(double));
if( dqdr == NULL || tmp_dqdr == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"center_finite_diff_n: Unable to allocate memory for output array");
return(NhlFATAL);
}
/*
* Loop through dimensions and call Fortran routine.
*/
for( i = 0; i < size_leftmost; i++ ) {
index_nrnpts = i*size_rightmost * npts;
for( j = 0; j < size_rightmost; j++ ) {
index_q = index_nrnpts + j;
/*
* Coerce q (tmp_q) to double.
*/
coerce_subset_input_double_step(q,tmp_q,index_q,size_rightmost,
type_q,npts,0,NULL,NULL);
if(!r_one_d) {
/*
* Coerce r (tmp_r) to double.
*/
coerce_subset_input_double_step(r,tmp_r,index_q,size_rightmost,
type_r,npts,0,NULL,NULL);
}
/*
* Call the Fortran routine.
*/
NGCALLF(dcfindif,DCFINDIF)(tmp_q,tmp_r,&inpts,&missing_dq.doubleval,
&missing_dr.doubleval,cyclic,&iend,
qq,rr,&inpts1,tmp_dqdr,&ier);
coerce_output_float_or_double_step(dqdr,tmp_dqdr,type_dqdr,npts,index_q,
size_rightmost);
}
}
/*
* Free temp arrays.
*/
if(type_r != NCL_double || r_scalar || !r_one_d) NclFree(tmp_r);
NclFree(tmp_q);
NclFree(tmp_dqdr);
NclFree(qq);
NclFree(rr);
if(has_missing_q) {
return(NclReturnValue(dqdr,ndims_q,dsizes_q,&missing_dqdr,type_dqdr,0));
}
else {
return(NclReturnValue(dqdr,ndims_q,dsizes_q,NULL,type_dqdr,0));
}
}
NhlErrorTypes 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 uv2dv_cfd_W( void )
{
/*
* Input array variables
*/
void *u, *v, *lat, *lon;
int *bound_opt;
double *tmp_u = NULL;
double *tmp_v = NULL;
double *tmp_lat, *tmp_lon;
int ndims_u;
ng_size_t dsizes_u[NCL_MAX_DIMENSIONS];
int ndims_v;
ng_size_t dsizes_v[NCL_MAX_DIMENSIONS];
ng_size_t dsizes_lat[NCL_MAX_DIMENSIONS];
ng_size_t dsizes_lon[NCL_MAX_DIMENSIONS];
int has_missing_u;
NclScalar missing_u, missing_du, missing_ru;
NclBasicDataTypes type_u, type_v, type_lat, type_lon;
/*
* Output array variables
*/
void *div;
double *tmp_div = NULL;
NclBasicDataTypes type_div;
/*
* Declare various variables for random purposes.
*/
ng_size_t i, nlon, nlat, nlatnlon, size_uv, size_leftmost, index_uv;
int inlat, inlon, ier;
/*
* Retrieve parameters
*
* Note that any of the pointer parameters can be set to NULL,
* which implies you don't care about its value.
*
*/
u = (void*)NclGetArgValue(
0,
5,
&ndims_u,
dsizes_u,
&missing_u,
&has_missing_u,
&type_u,
DONT_CARE);
v = (void*)NclGetArgValue(
1,
5,
&ndims_v,
dsizes_v,
NULL,
NULL,
&type_v,
DONT_CARE);
lat = (void*)NclGetArgValue(
2,
5,
NULL,
dsizes_lat,
NULL,
NULL,
&type_lat,
DONT_CARE);
lon = (void*)NclGetArgValue(
3,
5,
NULL,
dsizes_lon,
NULL,
NULL,
&type_lon,
DONT_CARE);
bound_opt = (int*)NclGetArgValue(
4,
5,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Get size of input array.
*/
if(ndims_u < 2 || ndims_u != ndims_v) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"uv2dv_cfd: u and v must have the same numer of dimensions and have at least 2 dimensions");
return(NhlFATAL);
}
for( i=0; i < ndims_u; i++ ) {
if(dsizes_u[i] != dsizes_v[i]) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"uv2dv_cfd: u and v must have the same dimensions");
return(NhlFATAL);
}
}
nlat = dsizes_u[ndims_u-2];
nlon = dsizes_u[ndims_u-1];
nlatnlon = nlat * nlon;
/*
* Test dimension sizes.
*/
if((nlon > INT_MAX) || (nlat > INT_MAX)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"uv2dv_cfd: nlat and/or nlon is greater than INT_MAX");
return(NhlFATAL);
}
inlon = (int) nlon;
inlat = (int) nlat;
if(dsizes_lat[0] != nlat || dsizes_lon[0] != nlon) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"uv2dv_cfd: the lat,lon arrays must be dimensioned nlat and nlon, the last two dimensions of u and v");
return(NhlFATAL);
}
/*
* Compute the total size of the q array.
*/
size_leftmost = 1;
for( i = 0; i < ndims_u-2; i++ ) size_leftmost *= dsizes_u[i];
size_uv = size_leftmost * nlatnlon;
/*
* Check for missing values.
*/
coerce_missing(type_u,has_missing_u,&missing_u,&missing_du,&missing_ru);
/*
* Create temporary arrays to hold double precision data.
*/
if(type_u != NCL_double) {
tmp_u = (double*)calloc(nlatnlon,sizeof(double));
if( tmp_u == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"uv2dv_cfd: Unable to allocate memory for coercing u to double precision");
return(NhlFATAL);
}
}
if(type_v != NCL_double) {
tmp_v = (double*)calloc(nlatnlon,sizeof(double));
if( tmp_v == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"uv2dv_cfd: Unable to allocate memory for coercing v to double precision");
return(NhlFATAL);
}
}
/*
* Allocate space for output array.
*/
if(type_u == NCL_double || type_v == NCL_double) {
type_div = NCL_double;
div = (void*)calloc(size_uv,sizeof(double));
}
else {
tmp_div = (double*)calloc(nlatnlon,sizeof(double));
if(tmp_div == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"uv2dv_cfd: Unable to allocate memory for temporary output array");
return(NhlFATAL);
}
type_div = NCL_float;
div = (void*)calloc(size_uv,sizeof(float));
}
if(div == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"uv2dv_cfd: Unable to allocate memory for output array");
return(NhlFATAL);
}
/*
* Coerce lat/lon arrays to double if necessary.
*/
tmp_lat = coerce_input_double(lat,type_lat,nlat,0,NULL,NULL);
tmp_lon = coerce_input_double(lon,type_lon,nlon,0,NULL,NULL);
if(tmp_lat == NULL || tmp_lon == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"uv2dv_cfd: Unable to coerce lat/lon arrays to double precision");
return(NhlFATAL);
}
/*
* Loop through leftmost dimensions and call Fortran routine.
*/
index_uv = 0;
for(i = 0; i < size_leftmost; i++ ) {
if(type_u != NCL_double) {
/*
* Coerce u (tmp_u) to double.
*/
coerce_subset_input_double(u,tmp_u,index_uv,type_u,nlatnlon,0,NULL,NULL);
}
else {
/*
* Point tmp_u to u.
*/
tmp_u = &((double*)u)[index_uv];
}
if(type_v != NCL_double) {
/*
* Coerce v (tmp_v) to double.
*/
coerce_subset_input_double(v,tmp_v,index_uv,type_v,nlatnlon,0,NULL,NULL);
}
else {
/*
* Point tmp_v to v.
*/
tmp_v = &((double*)v)[index_uv];
}
if(type_div == NCL_double) {
/*
* Point tmp_div to div.
*/
tmp_div = &((double*)div)[index_uv];
}
/*
* Call the Fortran routine.
*/
NGCALLF(ddvfidf,DDVFIDF)(tmp_u,tmp_v,tmp_lat,tmp_lon,&inlon,&inlat,
&missing_du.doubleval,bound_opt,tmp_div,&ier);
if(type_div != NCL_double) {
coerce_output_float_only(div,tmp_div,nlatnlon,index_uv);
}
index_uv += nlatnlon;
}
/*
* Free temp arrays.
*/
if(type_u != NCL_double) NclFree(tmp_u);
if(type_v != NCL_double) NclFree(tmp_v);
if(type_lat != NCL_double) NclFree(tmp_lat);
if(type_lon != NCL_double) NclFree(tmp_lon);
if(type_div != NCL_double) NclFree(tmp_div);
if(type_div == NCL_double) {
return(NclReturnValue(div,ndims_u,dsizes_u,&missing_du,type_div,0));
}
else {
return(NclReturnValue(div,ndims_u,dsizes_u,&missing_ru,type_div,0));
}
}
NhlErrorTypes 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 poisson_grid_fill_W( void )
{
/*
* Input variables
*/
/*
* Argument # 0
*/
void *x;
double *tmp_x = NULL;
int ndims_x;
ng_size_t dsizes_x[NCL_MAX_DIMENSIONS];
int has_missing_x;
NclScalar missing_x, missing_dx;
NclBasicDataTypes type_x;
/*
* Argument # 1
*/
logical *is_cyclic;
/*
* Arguments # 2 & 3
*/
int *guess_type, *nscan;
/*
* Arguments # 4 & 5
*/
void *epsx, *relc;
double *tmp_epsx, *tmp_relc;
NclBasicDataTypes type_epsx, type_relc;
/*
* Argument # 6
*/
int *opt;
/*
* Various
*/
int ndims_leftmost;
ng_size_t i, size_leftmost;
ng_size_t ny, mx, nymx, index_x;
int mscan, ier, iny, imx;
/*
* 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,
7,
&ndims_x,
dsizes_x,
&missing_x,
&has_missing_x,
&type_x,
1);
/*
* Check the input type.
*/
if(type_x != NCL_float && type_x != NCL_double) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"poisson_grid_fill: The first input argument must be float or double");
return(NhlFATAL);
}
/*
* Check dimension sizes.
*/
if(ndims_x < 2) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"poisson_grid_fill: The first argument must have at least two dimensions");
return(NhlFATAL);
}
/*
* Coerce missing value to double if necessary.
*/
coerce_missing(type_x,has_missing_x,&missing_x,&missing_dx,NULL);
ny = dsizes_x[ndims_x-2];
mx = dsizes_x[ndims_x-1];
nymx = ny * mx;
/*
* Test input dimension sizes.
*/
if((mx > INT_MAX) || (ny > INT_MAX)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"poisson_grid_fill: one or more input dimension sizes is greater than INT_MAX");
return(NhlFATAL);
}
imx = (int) mx;
iny = (int) ny;
/*
* Get argument # 1
*/
is_cyclic = (logical*)NclGetArgValue(
1,
7,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Get argument # 2
*/
guess_type = (int*)NclGetArgValue(
2,
7,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Get argument # 3
*/
nscan = (int*)NclGetArgValue(
3,
7,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Get argument # 4
*/
epsx = (void*)NclGetArgValue(
4,
7,
NULL,
NULL,
NULL,
NULL,
&type_epsx,
DONT_CARE);
/*
* Get argument # 4
*/
relc = (void*)NclGetArgValue(
5,
7,
NULL,
NULL,
NULL,
NULL,
&type_relc,
DONT_CARE);
/*
* Get argument # 6
*/
opt = (int*)NclGetArgValue(
6,
7,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Calculate size of leftmost dimensions.
*/
size_leftmost = 1;
ndims_leftmost = ndims_x-2;
for(i = 0; i < ndims_leftmost; i++) {
size_leftmost *= dsizes_x[i];
}
/*
* Coerce the numeric input values to double.
*/
tmp_epsx = coerce_input_double(epsx, type_epsx, 1, 0, NULL, NULL);
tmp_relc = coerce_input_double(relc, type_relc, 1, 0, NULL, NULL);
/*
* Allocate space for tmp_x.
*/
if(type_x != NCL_double) {
tmp_x = (double *)calloc(nymx,sizeof(double));
if(tmp_x == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"poisson_grid_fill: Unable to allocate memory for coercing input array to double");
return(NhlFATAL);
}
}
/*
* Loop across leftmost dimensions and call the Fortran routine for each
* subsection of the input arrays.
*/
index_x = 0;
for(i = 0; i < size_leftmost; i++) {
/*
* Coerce subsection of x (tmp_x) to double if necessary.
*/
if(type_x != NCL_double) {
coerce_subset_input_double(x,tmp_x,index_x,type_x,nymx,0,NULL,NULL);
}
else {
tmp_x = &((double*)x)[index_x];
}
/*
* Call the Fortran routine.
*/
NGCALLF(poisxy1,POISXY1)(tmp_x, &imx, &iny, &missing_dx.doubleval,
guess_type, is_cyclic, nscan, tmp_epsx,
tmp_relc, &mscan, &ier);
/*
* Coerce back to float, if not double.
*/
if(type_x == NCL_float) {
coerce_output_float_only(x,tmp_x,nymx,index_x);
}
index_x += nymx; /* Increment pointer. */
}
/*
* Free unneeded memory.
*/
if(type_x != NCL_double) NclFree(tmp_x);
if(type_epsx != NCL_double) NclFree(tmp_epsx);
if(type_relc != NCL_double) NclFree(tmp_relc);
/*
* This is a procedure, so no values are returned.
*/
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 specxy_anal_W( void )
{
/*
* Input array variables
*/
void *x, *y, *pct;
double *dx, *dy, *dpct;
ng_size_t dsizes[1], nx;
int *iopt, *jave;
int ndims_x;
ng_size_t dsizes_x[NCL_MAX_DIMENSIONS];
int ndims_y;
ng_size_t dsizes_y[NCL_MAX_DIMENSIONS];
int has_missing_x, has_missing_y;
NclScalar missing_x, missing_y, missing_dx, missing_dy;
NclBasicDataTypes type_x, type_y, type_pct;
ng_size_t lwork;
double scl, *work;
/*
* Output variables
*/
void *dof;
NclBasicDataTypes type_dof;
NclObjClass type_output;
/*
* Attribute variables
*/
int att_id;
NclMultiDValData att_md, return_md;
NclVar tmp_var;
NclStackEntry return_data;
double *frq_tmp, *spcx_tmp, *spcy_tmp;
double *cospc_tmp, *quspc_tmp, *coher_tmp, *phase_tmp;
double prob_tmp[4], sinfo[50];
void *bw, *frq, *spcx, *spcy, *cospc, *quspc, *coher, *phase;
void *xavei, *xvari, *xvaro, *xlag1, *xslope;
void *yavei, *yvari, *yvaro, *ylag1, *yslope;
void *prob;
/*
* Declare variables for random purposes.
*/
ng_size_t i, nspc, nspcmx, total_size_x, total_size_y;
int ier;
/*
* Retrieve arguments.
*/
x = (void*)NclGetArgValue(
0,
5,
&ndims_x,
dsizes_x,
&missing_x,
&has_missing_x,
&type_x,
DONT_CARE);
y = (void*)NclGetArgValue(
1,
5,
&ndims_y,
dsizes_y,
&missing_y,
&has_missing_y,
&type_y,
DONT_CARE);
iopt = (int*)NclGetArgValue(
2,
5,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
jave = (int*)NclGetArgValue(
3,
5,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
pct = (void*)NclGetArgValue(
4,
5,
NULL,
NULL,
NULL,
NULL,
&type_pct,
DONT_CARE);
/*
* Check input.
*/
nx = dsizes_x[0];
nspc = nspcmx = nx/2 + 1;
if( nx != dsizes_y[0]) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"specxy_anal: 'x' and 'y' must have the same number of elements");
return(NhlFATAL);
}
if( nx < 3) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"specxy_anal: 'x' and 'y' must have more than 3 elements");
return(NhlFATAL);
}
if( *iopt > 2) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"specxy_anal: 'iopt' must be <= 2");
return(NhlFATAL);
}
if( abs(*jave) > nx/2 ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"specxy_anal: 'jave' must be <= nx/2");
return(NhlFATAL);
}
/*
* Compute the total number of elements in our arrays.
*/
total_size_x = 1;
for(i = 0; i < ndims_x; i++) total_size_x *= dsizes_x[i];
total_size_y = 1;
for(i = 0; i < ndims_y; i++) total_size_y *= dsizes_y[i];
/*
* Check for missing values and coerce data if necessary.
*/
coerce_missing(type_x,has_missing_x,&missing_x,&missing_dx,NULL);
coerce_missing(type_y,has_missing_y,&missing_y,&missing_dy,NULL);
/*
* Coerce x/y to double precision if necessary.
*/
dx = coerce_input_double(x,type_x,total_size_x,has_missing_x,&missing_x,
&missing_dx);
dy = coerce_input_double(y,type_y,total_size_y,has_missing_y,&missing_y,
&missing_dy);
if(dx == NULL|| dy == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"specxy_anal: Unable to allocate memory for coercing input arrays to double precision");
return(NhlFATAL);
}
/*
* Check if x or y contains missing values.
*/
if(contains_missing(dx,total_size_x,has_missing_x,missing_dx.doubleval) ||
contains_missing(dy,total_size_y,has_missing_y,missing_dy.doubleval)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"specx_anal: x and y cannot contain any missing values");
return(NhlFATAL);
}
/*
* Coerce pct to double precision if necessary.
*/
dpct = coerce_input_double(pct,type_pct,1,0,NULL,NULL);
if( dpct == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"specxy_anal: Unable to allocate memory for coercing pct array to double precision");
return(NhlFATAL);
}
/*
* Check pct.
*/
if( *dpct < 0.0 || *dpct > 1.0 ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"specxy_anal: 'pct' must be between 0 and 1 inclusive");
return(NhlFATAL);
}
/*
* Check if any input is double.
*/
if(type_x != NCL_double && type_y != NCL_double &&
type_pct != NCL_double) {
type_dof = NCL_float;
type_output = nclTypefloatClass;
/*
* Allocate space for float output variables.
*/
dof = (void *)calloc(1,sizeof(float));
frq = (void *)calloc(nspcmx-1,sizeof(float));
spcx = (void *)calloc(nspcmx-1,sizeof(float));
spcy = (void *)calloc(nspcmx-1,sizeof(float));
cospc = (void *)calloc(nspcmx-1,sizeof(float));
quspc = (void *)calloc(nspcmx-1,sizeof(float));
coher = (void *)calloc(nspcmx-1,sizeof(float));
phase = (void *)calloc(nspcmx-1,sizeof(float));
bw = (void *)calloc(1,sizeof(float));
prob = (void *)calloc(4,sizeof(float));
xavei = (void *)calloc(1,sizeof(float));
xvari = (void *)calloc(1,sizeof(float));
xvaro = (void *)calloc(1,sizeof(float));
xlag1 = (void *)calloc(1,sizeof(float));
xslope = (void *)calloc(1,sizeof(float));
yavei = (void *)calloc(1,sizeof(float));
yvari = (void *)calloc(1,sizeof(float));
yvaro = (void *)calloc(1,sizeof(float));
ylag1 = (void *)calloc(1,sizeof(float));
yslope = (void *)calloc(1,sizeof(float));
}
else {
type_dof = NCL_double;
type_output = nclTypedoubleClass;
/*
* Allocate space for double output variables.
*/
dof = (void *)calloc(1,sizeof(double));
bw = (void *)calloc(1,sizeof(double));
prob = (void *)calloc(4,sizeof(double));
frq = (void *)calloc(nspcmx-1,sizeof(double));
spcx = (void *)calloc(nspcmx-1,sizeof(double));
spcy = (void *)calloc(nspcmx-1,sizeof(double));
cospc = (void *)calloc(nspcmx-1,sizeof(double));
quspc = (void *)calloc(nspcmx-1,sizeof(double));
coher = (void *)calloc(nspcmx-1,sizeof(double));
phase = (void *)calloc(nspcmx-1,sizeof(double));
xavei = (void *)calloc(1,sizeof(double));
xvari = (void *)calloc(1,sizeof(double));
xvaro = (void *)calloc(1,sizeof(double));
xlag1 = (void *)calloc(1,sizeof(double));
xslope = (void *)calloc(1,sizeof(double));
yavei = (void *)calloc(1,sizeof(double));
yvari = (void *)calloc(1,sizeof(double));
yvaro = (void *)calloc(1,sizeof(double));
ylag1 = (void *)calloc(1,sizeof(double));
yslope = (void *)calloc(1,sizeof(double));
}
if( dof == NULL || bw == NULL || xavei == NULL || xvari == NULL ||
frq == NULL || spcx == NULL || spcy == NULL || cospc == NULL ||
quspc == NULL || coher == NULL || phase == NULL || xvaro == NULL ||
xlag1 == NULL ||xslope == NULL || yavei == NULL || yvari == NULL ||
yvaro == NULL || ylag1 == NULL ||yslope == NULL || prob == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"specxy_anal: Unable to allocate memory for output variables");
return(NhlFATAL);
}
/*
* Allocate space for stuff to be returned by dspecx.
*/
frq_tmp = (double *)calloc(nspcmx,sizeof(double));
spcx_tmp = (double *)calloc(nspcmx,sizeof(double));
spcy_tmp = (double *)calloc(nspcmx,sizeof(double));
cospc_tmp = (double *)calloc(nspcmx,sizeof(double));
quspc_tmp = (double *)calloc(nspcmx,sizeof(double));
coher_tmp = (double *)calloc(nspcmx,sizeof(double));
phase_tmp = (double *)calloc(nspcmx,sizeof(double));
if( frq_tmp == NULL || spcx_tmp == NULL || spcy_tmp == NULL ||
cospc_tmp == NULL || quspc_tmp == NULL || coher_tmp == NULL ||
phase_tmp == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"specxy_anal: Unable to allocate memory for output variables");
return(NhlFATAL);
}
/*
* Allocate space for work array.
*/
lwork = 10 * nx;
work = (double *)calloc(lwork,sizeof(double));
if( work == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"specxy_anal: Unable to allocate memory for work array");
return(NhlFATAL);
}
/*
* Call the Fortran version of this routine.
*/
scl = 2.0;
if((nx <= INT_MAX) &&
(lwork <= INT_MAX) &&
(nspc <= INT_MAX))
{
int inx = (int) nx;
int ilwork = (int) lwork;
int inspc = (int) nspc;
NGCALLF(dspecxy,DSPECXY)(dx,dy,&inx,iopt,jave,dpct,&scl,work,&ilwork,
frq_tmp,spcx_tmp,spcy_tmp,cospc_tmp,quspc_tmp,
coher_tmp,phase_tmp,&inspc,sinfo,&ier);
}
else
{
NhlPError(NhlFATAL,NhlEUNKNOWN,"specxy_anal: one or more input dimensions is greater than INT_MAX", nx);
return(NhlFATAL);
}
if( ier > 700000 ) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"specxy_anal: 'x' and/or 'y' contains all constant values");
}
/*
* Calculate coherence corresponding to the 90, 95, 99, and 99.9% levels.
*/
prob_tmp[0] = 1.-pow((1.-0.900),(1./(sinfo[0]/2.-1.)));
prob_tmp[1] = 1.-pow((1.-0.950),(1./(sinfo[0]/2.-1.)));
prob_tmp[2] = 1.-pow((1.-0.990),(1./(sinfo[0]/2.-1.)));
prob_tmp[3] = 1.-pow((1.-0.999),(1./(sinfo[0]/2.-1.)));
coerce_output_float_or_double( dof, &sinfo[0],type_dof,1,0);
coerce_output_float_or_double( xlag1, &sinfo[1],type_dof,1,0);
coerce_output_float_or_double( ylag1, &sinfo[2],type_dof,1,0);
coerce_output_float_or_double( bw, &sinfo[5],type_dof,1,0);
coerce_output_float_or_double( prob, prob_tmp,type_dof,4,0);
coerce_output_float_or_double( xavei, &sinfo[10],type_dof,1,0);
coerce_output_float_or_double( xvari, &sinfo[11],type_dof,1,0);
coerce_output_float_or_double( xvaro, &sinfo[12],type_dof,1,0);
coerce_output_float_or_double(xslope, &sinfo[31],type_dof,1,0);
coerce_output_float_or_double( yavei, &sinfo[20],type_dof,1,0);
coerce_output_float_or_double( yvari, &sinfo[21],type_dof,1,0);
coerce_output_float_or_double( yvaro, &sinfo[22],type_dof,1,0);
coerce_output_float_or_double(yslope, &sinfo[34],type_dof,1,0);
coerce_output_float_or_double( frq, &frq_tmp[1],type_dof,nspcmx-1,0);
coerce_output_float_or_double( spcx, &spcx_tmp[1],type_dof,nspcmx-1,0);
coerce_output_float_or_double( spcy, &spcy_tmp[1],type_dof,nspcmx-1,0);
coerce_output_float_or_double( cospc,&cospc_tmp[1],type_dof,nspcmx-1,0);
coerce_output_float_or_double( quspc,&quspc_tmp[1],type_dof,nspcmx-1,0);
coerce_output_float_or_double( coher,&coher_tmp[1],type_dof,nspcmx-1,0);
coerce_output_float_or_double( phase,&phase_tmp[1],type_dof,nspcmx-1,0);
/*
* Set up variable to return.
*/
dsizes[0] = 1;
return_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
dof,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
/*
* Set up attributes to return.
*/
att_id = _NclAttCreate(NULL,NULL,Ncl_Att,0,NULL);
dsizes[0] = nspcmx-1; /* returning nx/2 points, not nx/2 + 1 */
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
spcx,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"spcx",
att_md,
NULL
);
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
spcy,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"spcy",
att_md,
NULL
);
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
frq,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"frq",
att_md,
NULL
);
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
cospc,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"cospc",
att_md,
NULL
);
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
quspc,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"quspc",
att_md,
NULL
);
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
coher,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"coher",
att_md,
NULL
);
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,
bw,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"bw",
att_md,
NULL
);
dsizes[0] = 4;
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
prob,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"coher_probability",
att_md,
NULL
);
dsizes[0] = 1;
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
xavei,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"xavei",
att_md,
NULL
);
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
xvari,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"xvari",
att_md,
NULL
);
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
xvaro,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"xvaro",
att_md,
NULL
);
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
xlag1,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"xlag1",
att_md,
NULL
);
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
xslope,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"xslope",
att_md,
NULL
);
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
yavei,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"yavei",
att_md,
NULL
);
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
yvari,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"yvari",
att_md,
NULL
);
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
yvaro,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"yvaro",
att_md,
NULL
);
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
ylag1,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"ylag1",
att_md,
NULL
);
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
yslope,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"yslope",
att_md,
NULL
);
/*
* Free up memory.
*/
NclFree(work);
if((void*)dx != x) NclFree(dx);
if((void*)dy != y) NclFree(dy);
if((void*)dpct != pct) NclFree(dpct);
NclFree(frq_tmp);
NclFree(spcx_tmp);
NclFree(spcy_tmp);
NclFree(cospc_tmp);
NclFree(quspc_tmp);
NclFree(coher_tmp);
NclFree(phase_tmp);
/*
* Return variable.
*/
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);
}
