NhlErrorTypes ut_inv_calendar_W( void )
{
/*
* Input array variables
*/
int *year, *month, *day, *hour, *minute;
void *second;
double *tmp_second = NULL;
NrmQuark *sspec;
int *option;
char *cspec, *cspec_orig;
int ndims_year;
ng_size_t dsizes_year[NCL_MAX_DIMENSIONS];
int has_missing_year;
int ndims_month;
ng_size_t dsizes_month[NCL_MAX_DIMENSIONS];
int has_missing_month;
int ndims_day;
ng_size_t dsizes_day[NCL_MAX_DIMENSIONS];
int has_missing_day;
int ndims_hour;
ng_size_t dsizes_hour[NCL_MAX_DIMENSIONS];
int has_missing_hour;
int ndims_minute;
ng_size_t dsizes_minute[NCL_MAX_DIMENSIONS];
int has_missing_minute;
int ndims_second;
ng_size_t dsizes_second[NCL_MAX_DIMENSIONS];
int has_missing_second;
NclScalar missing_year;
NclScalar missing_month;
NclScalar missing_day;
NclScalar missing_hour;
NclScalar missing_minute;
NclScalar missing_second;
NclBasicDataTypes type_second;
/*
* Variables for Udunits package.
*/
ut_system *utopen_ncl(), *unit_system;
ut_unit *utunit;
/*
* Variables for retrieving attributes from last argument.
*/
NclAttList *attr_list;
NclAtt attr_obj;
NclStackEntry stack_entry;
NrmQuark *scal;
char *ccal = NULL;
/*
* Output variables.
*/
double *x;
int has_missing_x;
NclScalar missing_x;
/*
* Variables for returning "units" and "calendar" attributes.
*/
NclQuark *units, *calendar;
int att_id;
NclMultiDValData att_md, return_md;
NclVar tmp_var;
NclStackEntry return_data;
/*
* various
*/
ng_size_t i, total_size_input;
ng_size_t dsizes[1], return_missing;
int months_to_days_fix=0, years_to_days_fix=0;
/*
* Before we do anything, initialize the Udunits package.
*/
unit_system = utopen_ncl();
/*
* Retrieve parameters
*
* Note any of the pointer parameters can be set to NULL, which
* implies you don't care about its value.
* The first size input arrays must be the same dimension sizes.
*/
year = (int*)NclGetArgValue(
0,
8,
&ndims_year,
dsizes_year,
&missing_year,
&has_missing_year,
NULL,
DONT_CARE);
month = (int*)NclGetArgValue(
1,
8,
&ndims_month,
dsizes_month,
&missing_month,
&has_missing_month,
NULL,
DONT_CARE);
day = (int*)NclGetArgValue(
2,
8,
&ndims_day,
dsizes_day,
&missing_day,
&has_missing_day,
NULL,
DONT_CARE);
hour = (int*)NclGetArgValue(
3,
8,
&ndims_hour,
dsizes_hour,
&missing_hour,
&has_missing_hour,
NULL,
DONT_CARE);
minute = (int*)NclGetArgValue(
4,
8,
&ndims_minute,
dsizes_minute,
&missing_minute,
&has_missing_minute,
NULL,
DONT_CARE);
second = (void*)NclGetArgValue(
5,
8,
&ndims_second,
dsizes_second,
&missing_second,
&has_missing_second,
&type_second,
DONT_CARE);
if(ndims_year != ndims_month || ndims_year != ndims_day ||
ndims_year != ndims_hour || ndims_year != ndims_minute ||
ndims_year != ndims_second) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ut_inv_calendar: The first six arguments must have the same dimensionality");
return(NhlFATAL);
}
for(i = 0; i < ndims_year; i++ ) {
if(dsizes_year[i] != dsizes_month[i] ||
dsizes_year[i] != dsizes_day[i] ||
dsizes_year[i] != dsizes_hour[i] ||
dsizes_year[i] != dsizes_minute[i] ||
dsizes_year[i] != dsizes_second[i]) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ut_inv_calendar: The first six arguments must have the same dimensionality");
return(NhlFATAL);
}
}
/*
* x will contain a _FillValue attribute if any of the input
* has a _FillValue attribute set.
*/
if(has_missing_year || has_missing_month || has_missing_day ||
has_missing_hour || has_missing_minute || has_missing_second) {
has_missing_x = 1;
/*
* Get the default missing value for a double type.
*/
missing_x = ((NclTypeClass)nclTypedoubleClass)->type_class.default_mis;
}
else {
has_missing_x = 0;
}
/*
* Get spec string.
*/
sspec = (NrmQuark *)NclGetArgValue(
6,
8,
NULL,
NULL,
NULL,
NULL,
NULL,
1);
/*
* Get option.
*/
option = (int*)NclGetArgValue(
7,
8,
NULL,
NULL,
NULL,
NULL,
NULL,
1);
/*
* Check the "option" variable to see if it contains a "calendar"
* attribute.
*/
return_missing = 0;
stack_entry = _NclGetArg(7, 8, DONT_CARE);
switch (stack_entry.kind) {
case NclStk_VAR:
if (stack_entry.u.data_var->var.att_id != -1) {
attr_obj = (NclAtt) _NclGetObj(stack_entry.u.data_var->var.att_id);
if (attr_obj == NULL) {
break;
}
}
else {
/*
* att_id == -1 ==> no attributes specified args given.
*/
break;
}
/*
* Get optional arguments.
*/
if (attr_obj->att.n_atts > 0) {
/*
* Get list of attributes.
*/
attr_list = attr_obj->att.att_list;
/*
* Loop through attributes and check them.
*/
while (attr_list != NULL) {
if ((strcmp(attr_list->attname, "calendar")) == 0) {
scal = (NrmQuark *) attr_list->attvalue->multidval.val;
ccal = NrmQuarkToString(*scal);
if(strcasecmp(ccal,"standard") && strcasecmp(ccal,"gregorian") &&
strcasecmp(ccal,"noleap") && strcasecmp(ccal,"365_day") &&
strcasecmp(ccal,"365") && strcasecmp(ccal,"360_day") &&
strcasecmp(ccal,"360") ) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"ut_inv_calendar: the 'calendar' attribute is not equal to a recognized calendar. Returning all missing values.");
return_missing = has_missing_x = 1;
}
}
attr_list = attr_list->next;
}
}
default:
break;
}
/*
* Convert sspec to character string.
*/
cspec = NrmQuarkToString(*sspec);
/*
* There's a bug in utInvCalendar2_cal that doesn't handle the
* 360-day calendar correctly if units are "years since" or
* "months since".
*
* To fix this bug, we convert these units to "days since", do the
* calculation as "days since", and then convert back to the original
* "years since" or "months since" requested units.
*/
cspec_orig = (char*)calloc(strlen(cspec)+1,sizeof(char));
strcpy(cspec_orig,cspec);
cspec = fix_units_for_360_bug(ccal,cspec,&months_to_days_fix,
&years_to_days_fix);
/*
* Make sure cspec is a valid udunits string.
*/
utunit = ut_parse(unit_system, cspec, UT_ASCII);
if(utunit == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ut_inv_calendar: Invalid specification string");
return(NhlFATAL);
}
/*
* Calculate total size of input arrays, and size and dimensions for
* output array, and alloc memory for output array.
*/
total_size_input = 1;
for( i = 0; i < ndims_year; i++ ) total_size_input *= dsizes_year[i];
x = (double *)calloc(total_size_input,sizeof(double));
if( x == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ut_inv_calendar: Unable to allocate memory for output array");
return(NhlFATAL);
}
/*
* Create tmp array for coercing second to double if necessary.
*/
if(type_second != NCL_double) {
tmp_second = (double*)calloc(1,sizeof(double));
if(tmp_second == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ut_inv_calendar: Unable to allocate memory for coercing second array to double precision");
return(NhlFATAL);
}
}
/*
* Loop through each data value, and call Udunits routine.
*/
for( i = 0; i < total_size_input; i++ ) {
/*
* Coerce "second" to double, since this is what the original Udunits
* routine is expecting.
*/
if(type_second != NCL_double) {
coerce_subset_input_double(second,tmp_second,i,type_second,1,
has_missing_second,&missing_second,NULL);
}
else {
tmp_second = &((double*)second)[i];
}
if(!return_missing && (!has_missing_year ||
(has_missing_year && year[i] != missing_year.intval)) &&
(!has_missing_month ||
(has_missing_month && month[i] != missing_month.intval)) &&
(!has_missing_day ||
(has_missing_day && day[i] != missing_day.intval)) &&
(!has_missing_hour ||
(has_missing_hour && hour[i] != missing_hour.intval)) &&
(!has_missing_minute ||
(has_missing_minute && minute[i] != missing_minute.intval)) &&
(!has_missing_second ||
(has_missing_second && *tmp_second != missing_second.doubleval)) ) {
(void)utInvCalendar2_cal(year[i],month[i],day[i],hour[i],
minute[i],*tmp_second,utunit,&x[i],ccal);
/*
* This is the bug fix for 360 day calendars and a units
* of "years since" or "months since". We have to convert
* from "days since" to the original requested units.
*
* See above for more information about the bug.
*/
if(years_to_days_fix == 1) x[i] /= 360.;
if(months_to_days_fix == 1) x[i] /= 30.;
}
else {
x[i] = missing_x.doubleval;
}
}
/*
* Close up Udunits.
*/
utclose_ncl(unit_system);
/*
* Set original units back if necessary.
*/
if(months_to_days_fix || years_to_days_fix) {
cspec = cspec_orig;
}
else {
NclFree(cspec_orig);
}
if(type_second != NCL_double) NclFree(tmp_second);
/*
* Set up variable to return.
*/
if(has_missing_x) {
return_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
x,
&missing_x,
ndims_year,
dsizes_year,
TEMPORARY,
NULL,
(NclObjClass)nclTypedoubleClass
);
}
else {
return_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
x,
NULL,
ndims_year,
dsizes_year,
TEMPORARY,
NULL,
(NclObjClass)nclTypedoubleClass
);
}
/*
* Set up attributes to return.
*/
att_id = _NclAttCreate(NULL,NULL,Ncl_Att,0,NULL);
dsizes[0] = 1;
/*
* Return "units" attribute.
*
* We can't just return "sspec" here, because it's an NCL input
* parameter and this seems to screw things up if we try to
* return it as an attribute.
*/
units = (NclQuark*)NclMalloc(sizeof(NclQuark));
*units = NrmStringToQuark(cspec);
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
(void*)units,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
(NclObjClass)nclTypestringClass
);
_NclAddAtt(
att_id,
"units",
att_md,
NULL
);
/*
* Return "calendar" attribute.
*
* We can't just return "sspec" here, because it's an NCL input
* parameter and this seems to screw things up if we try to
* return it as an attribute.
*/
calendar = (NclQuark*)NclMalloc(sizeof(NclQuark));
if(ccal != NULL) {
*calendar = NrmStringToQuark(ccal);
}
else {
*calendar = NrmStringToQuark("standard");
}
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
(void*)calendar,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
(NclObjClass)nclTypestringClass
);
_NclAddAtt(
att_id,
"calendar",
att_md,
NULL
);
tmp_var = _NclVarCreate(
NULL,
NULL,
Ncl_Var,
0,
NULL,
return_md,
NULL,
att_id,
NULL,
RETURNVAR,
NULL,
TEMPORARY
);
/*
* Return output grid and attributes to NCL.
*/
return_data.kind = NclStk_VAR;
return_data.u.data_var = tmp_var;
_NclPlaceReturn(return_data);
return(NhlNOERROR);
}
NhlErrorTypes 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 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 ezfftf_W( void )
{
/*
* Input array variables
*/
void *x;
int ndims_x;
ng_size_t dsizes_x[NCL_MAX_DIMENSIONS];
NclBasicDataTypes type_x;
NclScalar missing_x, missing_dx, missing_rx, missing_cf;
int has_missing_x;
double *tmp_x = NULL;
/*
* Output array variables
*/
void *cf, *xbar;
int ndims_cf;
ng_size_t dsizes_cf[NCL_MAX_DIMENSIONS];
double *tmp_cf1, *tmp_cf2, *tmp_xbar;
NclBasicDataTypes type_cf;
NclTypeClass type_cf_class;
/*
* Attribute variables
*/
void *N;
int att_id;
ng_size_t dsizes[1];
NclMultiDValData att_md, return_md;
NclVar tmp_var;
NclStackEntry return_data;
/*
* various
*/
double *work;
ng_size_t index_x, index_cf1, index_cf2;
ng_size_t i, npts, npts2, lnpts2, npts22;
int found_missing, any_missing;
ng_size_t size_leftmost, size_cf;
int inpts;
/*
* Retrieve parameters
*
* Note any of the pointer parameters can be set to NULL, which
* implies you don't care about its value.
*/
x = (void*)NclGetArgValue(
0,
1,
&ndims_x,
dsizes_x,
&missing_x,
&has_missing_x,
&type_x,
DONT_CARE);
/*
* Calculate number of leftmost elements.
*/
size_leftmost = 1;
for( i = 0; i < ndims_x-1; i++ ) size_leftmost *= dsizes_x[i];
/*
* Test input array size
*/
npts = dsizes_x[ndims_x-1];
if(npts > INT_MAX) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ezfftf: npts = %d is greater than INT_MAX", npts);
return(NhlFATAL);
}
inpts = (int) npts;
/*
* Calculate size of output array.
*/
if((npts % 2) == 0) {
npts2 = npts/2;
}
else {
npts2 = (npts-1)/2;
}
lnpts2 = npts2 * size_leftmost;
npts22 = 2*npts2;
size_cf = size_leftmost * npts22;
ndims_cf = ndims_x + 1;
dsizes_cf[0] = 2;
for(i = 1; i < ndims_x; i++ ) dsizes_cf[i] = dsizes_x[i-1];
dsizes_cf[ndims_x] = npts2;
/*
* Coerce missing values.
*/
coerce_missing(type_x,has_missing_x,&missing_x,&missing_dx,&missing_rx);
/*
* Create space for temporary input array if necessary.
*/
if(type_x != NCL_double) {
tmp_x = (double*)calloc(npts,sizeof(double));
if(tmp_x == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ezfftf: Unable to allocate memory for coercing input array to double precision");
return(NhlFATAL);
}
}
/*
* Allocate space for output arrays.
*/
tmp_xbar = (double*)calloc(1,sizeof(double));
tmp_cf1 = (double*)calloc(npts2,sizeof(double));
tmp_cf2 = (double*)calloc(npts2,sizeof(double));
if ( tmp_cf1 == NULL || tmp_cf2 == NULL || tmp_xbar == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ezfftf: Cannot allocate memory for temporary output arrays" );
return(NhlFATAL);
}
if(type_x == NCL_double) {
cf = (void*)calloc(size_cf,sizeof(double));
xbar = (void*)calloc(size_leftmost,sizeof(double));
type_cf = NCL_double;
if(has_missing_x) missing_cf = missing_dx;
}
else {
cf = (void*)calloc(size_cf,sizeof(float));
xbar = (void*)calloc(size_leftmost,sizeof(float));
type_cf = NCL_float;
if(has_missing_x) missing_cf = missing_rx;
}
N = (void*)calloc(1,sizeof(int));
if ( cf == NULL || xbar == NULL || N == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ezfftf: Cannot allocate memory for output arrays" );
return(NhlFATAL);
}
/*
* Allocate memory for work array
*/
work = (double*)calloc((4*npts+15),sizeof(double));
if ( work == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ezfftf: Cannot allocate memory for work array" );
return(NhlFATAL);
}
/*
* Call the f77 version of 'dezfftf' with the full argument list.
*/
index_x = 0;
index_cf1 = 0;
index_cf2 = lnpts2;
any_missing = 0;
for(i = 0; i < size_leftmost; i++) {
if(type_x != NCL_double) {
coerce_subset_input_double(x,tmp_x,index_x,type_x,npts,0,NULL,NULL);
}
else {
tmp_x = &((double*)x)[index_x];
}
/*
* Check for missing values in x. If any, then coerce that section of
* the output to missing.
*/
found_missing = contains_missing(tmp_x,npts,has_missing_x,
missing_dx.doubleval);
if(found_missing) {
any_missing++;
set_subset_output_missing(xbar,i,type_cf,1,missing_dx.doubleval);
set_subset_output_missing(cf,index_cf1,type_cf,npts2,
missing_dx.doubleval);
set_subset_output_missing(cf,index_cf2,type_cf,npts2,
missing_dx.doubleval);
}
else {
NGCALLF(dezffti,DEZFFTI)(&inpts,work);
NGCALLF(dezfftf,DEZFFTF)(&inpts,tmp_x,tmp_xbar,tmp_cf1,tmp_cf2,work);
/*
* Copy results back into xbar and cf.
*/
coerce_output_float_or_double(xbar,tmp_xbar,type_cf,1,i);
coerce_output_float_or_double(cf,tmp_cf1,type_cf,npts2,index_cf1);
coerce_output_float_or_double(cf,tmp_cf2,type_cf,npts2,index_cf2);
}
index_x += npts;
index_cf1 += npts2;
index_cf2 += npts2;
}
/*
* Free up memory.
*/
if(type_x != NCL_double) free(tmp_x);
free(work);
free(tmp_cf1);
free(tmp_cf2);
free(tmp_xbar);
/*
* Set up variable to return.
*/
type_cf_class = (NclTypeClass)_NclNameToTypeClass(NrmStringToQuark(_NclBasicDataTypeToName(type_cf)));
/*
* Set up return values.
*/
if(any_missing) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"ezfftf: %d input arrays contained missing values. No calculations performed on these arrays.",any_missing);
return_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
cf,
&missing_cf,
ndims_cf,
dsizes_cf,
TEMPORARY,
NULL,
(NclObjClass)type_cf_class
);
}
else {
return_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
cf,
NULL,
ndims_cf,
dsizes_cf,
TEMPORARY,
NULL,
(NclObjClass)type_cf_class
);
}
/*
* Attributes "xbar" and "npts".
*/
att_id = _NclAttCreate(NULL,NULL,Ncl_Att,0,NULL);
dsizes[0] = size_leftmost;
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
xbar,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
(NclObjClass)type_cf_class
);
_NclAddAtt(
att_id,
"xbar",
att_md,
NULL
);
(*(int*)N) = npts;
dsizes[0] = 1;
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
N,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
(NclObjClass)nclTypeintClass
);
_NclAddAtt(
att_id,
"npts",
att_md,
NULL
);
/*
* Set up variable to hold return array and attributes.
*/
tmp_var = _NclVarCreate(
NULL,
NULL,
Ncl_Var,
0,
NULL,
return_md,
NULL,
att_id,
NULL,
RETURNVAR,
NULL,
TEMPORARY
);
/*
* Return output grid and attributes to NCL.
*/
return_data.kind = NclStk_VAR;
return_data.u.data_var = tmp_var;
_NclPlaceReturn(return_data);
return(NhlNOERROR);
}
NhlErrorTypes ezfftb_W( void )
{
/*
* Input array variables
*/
void *cf;
double *tmp_cf1 = NULL;
double *tmp_cf2 = NULL;
int ndims_cf;
ng_size_t dsizes_cf[NCL_MAX_DIMENSIONS];
ng_size_t dsizes_xbar[1];
void *xbar;
double *tmp_xbar = NULL;
NclBasicDataTypes type_cf, type_xbar;
NclScalar missing_cf, missing_dcf, missing_rcf, missing_x;
int has_missing_cf;
/*
* Some variables we need to retrieve the "npts" atttribute (if it exists).
*/
NclAttList *att_list;
NclAtt tmp_attobj;
NclStackEntry data;
/*
* Output array variables
*/
void *x;
double *tmp_x;
int ndims_x;
ng_size_t dsizes_x[NCL_MAX_DIMENSIONS];
NclBasicDataTypes type_x;
/*
* various
*/
double *work;
ng_size_t index_cf, index_x;
ng_size_t i, *tmp_npts, npts, npts2, lnpts2, size_x, size_leftmost;
int found_missing1, found_missing2, any_missing, scalar_xbar;
int inpts;
/*
* Retrieve parameters
*
* Note any of the pointer parameters can be set to NULL, which
* implies you don't care about its value.
*/
cf = (void*)NclGetArgValue(
0,
2,
&ndims_cf,
dsizes_cf,
&missing_cf,
&has_missing_cf,
&type_cf,
DONT_CARE);
xbar = (void*)NclGetArgValue(
1,
2,
NULL,
dsizes_xbar,
NULL,
NULL,
&type_xbar,
DONT_CARE);
/*
* Calculate number of leftmost elements.
*/
size_leftmost = 1;
for( i = 1; i < ndims_cf-1; i++ ) size_leftmost *= dsizes_cf[i];
/*
* Check xbar dimension sizes.
*/
scalar_xbar = is_scalar(1,dsizes_xbar);
if(!scalar_xbar) {
/*
* If xbar is not a scalar, it must be an array of the same dimension
* sizes as the leftmost dimensions of cf (except the first dimension
* of '2').
*/
if(dsizes_xbar[0] != size_leftmost) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ezfftb: If xbar is not a scalar, then it must be a single vector of the length of the product of the leftmost dimensions of 'cf' (not including the '2' dimension)") ;
return(NhlFATAL);
}
}
/*
* Coerce missing values.
*/
coerce_missing(type_cf,has_missing_cf,&missing_cf,&missing_dcf,&missing_rcf);
/*
* Okay, what follows here is some code for retrieving the "npts"
* attribute if it exists. This attribute is one that should have been
* set when "ezfftf" was called, and it indicates the length of the
* original series.
*/
npts2 = dsizes_cf[ndims_cf-1]; /* Calculate the length in case */
/* it is not set explicitly. */
npts = 2*npts2;
data = _NclGetArg(0,2,DONT_CARE);
switch(data.kind) {
case NclStk_VAR:
if(data.u.data_var->var.att_id != -1) {
tmp_attobj = (NclAtt)_NclGetObj(data.u.data_var->var.att_id);
if(tmp_attobj == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ezfftb: Bad attribute list, can't continue");
return(NhlFATAL);
}
if(tmp_attobj->att.n_atts == 0) {
break;
}
att_list = tmp_attobj->att.att_list;
i = 0;
while(att_list != NULL) {
if(att_list->quark == NrmStringToQuark("npts")) {
tmp_npts = get_dimensions(att_list->attvalue->multidval.val,1,
att_list->attvalue->multidval.data_type,
"ezfftb");
npts = *tmp_npts;
free(tmp_npts);
if((npts % 2) == 0) {
npts2 = npts/2;
}
else {
npts2 = (npts-1)/2;
}
break;
}
att_list = att_list->next;
}
}
break;
default:
NhlPError(NhlFATAL,NhlEUNKNOWN,"ezfftb: data.kind, can't continue");
return(NhlFATAL);
}
/*
* Test input array size
*/
if(npts > INT_MAX) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ezfftb: npts = %d is greater than INT_MAX", npts);
return(NhlFATAL);
}
inpts = (int) npts;
/*
* Calculate size of output array.
*/
lnpts2 = npts2 * size_leftmost;
size_x = size_leftmost * npts;
ndims_x = ndims_cf - 1;
for(i = 0; i < ndims_x-1; i++ ) dsizes_x[i] = dsizes_cf[i+1];
dsizes_x[ndims_x-1] = npts;
/*
* Create arrays to coerce input to double if necessary.
*/
if(type_cf != NCL_double) {
tmp_cf1 = (double*)calloc(npts2,sizeof(double));
tmp_cf2 = (double*)calloc(npts2,sizeof(double));
if(tmp_cf1 == NULL || tmp_cf2 == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ezfftb: Unable to allocate memory for coercing input array to double precision");
return(NhlFATAL);
}
}
if(type_xbar != NCL_double) {
tmp_xbar = (double*)calloc(1,sizeof(double));
if(tmp_xbar == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ezfftb: Unable to allocate memory for coercing input array to double precision");
return(NhlFATAL);
}
}
/*
* Allocate memory for output array.
*/
tmp_x = (double *)calloc(npts,sizeof(double));
if (tmp_x == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ezfftb: Cannot allocate memory for temporary output array" );
return(NhlFATAL);
}
if(type_cf == NCL_double) {
type_x = NCL_double;
x = (void*)calloc(size_x,sizeof(double));
if(has_missing_cf) missing_x = missing_dcf;
}
else {
type_x = NCL_float;
x = (void*)calloc(size_x,sizeof(float));
if(has_missing_cf) missing_x = missing_rcf;
}
if (x == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ezfftb: Cannot allocate memory for output array" );
return(NhlFATAL);
}
/*
* Allocate memory for work array
*/
work = (double*)calloc(4*npts+15,sizeof(double));
if ( work == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ezfftb: Cannot allocate memory for work array" );
return(NhlFATAL);
}
/*
* If xbar is a scalar, coerce it outside the loop.
*/
if(scalar_xbar) {
if(type_xbar != NCL_double) {
coerce_subset_input_double(xbar,tmp_xbar,0,type_xbar,1,0,NULL,NULL);
}
else {
tmp_xbar = &((double*)xbar)[0];
}
}
/*
* Call the f77 version of 'dezfftb' with the full argument list.
*/
index_x = index_cf = 0;
any_missing = 0;
for(i = 0; i < size_leftmost; i++) {
if(type_cf != NCL_double) {
coerce_subset_input_double(cf,tmp_cf1,index_cf,type_cf,npts2,0,
NULL,NULL);
coerce_subset_input_double(cf,tmp_cf2,lnpts2+index_cf,type_cf,npts2,0,
NULL,NULL);
}
else {
tmp_cf1 = &((double*)cf)[index_cf];
tmp_cf2 = &((double*)cf)[lnpts2+index_cf];
}
/*
* Check for missing values in cf. If any, then coerce that section of
* the output to missing.
*/
found_missing1 = contains_missing(tmp_cf1,npts2,has_missing_cf,
missing_dcf.doubleval);
found_missing2 = contains_missing(tmp_cf2,npts2,has_missing_cf,
missing_dcf.doubleval);
if(found_missing1 || found_missing2) {
any_missing++;
set_subset_output_missing(x,index_x,type_x,npts,missing_dcf.doubleval);
}
else {
/*
* If xbar is not a scalar, then we need to coerce each element
* to double or else just grab its value.
*/
if(!scalar_xbar) {
if(type_xbar != NCL_double) {
coerce_subset_input_double(xbar,tmp_xbar,i,type_xbar,1,0,NULL,NULL);
}
else {
tmp_xbar = &((double*)xbar)[i];
}
}
NGCALLF(dezffti,DEZFFTI)(&inpts,work);
NGCALLF(dezfftb,DEZFFTB)(&inpts,tmp_x,tmp_xbar,tmp_cf1,tmp_cf2,work);
/*
* Copy results back into x.
*/
coerce_output_float_or_double(x,tmp_x,type_cf,npts,index_x);
}
index_x += npts;
index_cf += npts2;
}
/*
* Free up memory.
*/
if(type_cf != NCL_double) {
free(tmp_cf1);
free(tmp_cf2);
}
if(type_xbar != NCL_double) free(tmp_xbar);
free(tmp_x);
free(work);
if(any_missing) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"ezfftb: %d input arrays contained missing values. No calculations performed on these arrays.",any_missing);
return(NclReturnValue(x,ndims_x,dsizes_x,&missing_x,type_x,0));
}
else {
return(NclReturnValue(x,ndims_x,dsizes_x,NULL,type_x,0));
}
}
NhlErrorTypes fft2db_W( void )
{
/*
* First and only input argument.
*/
void *coef;
double *tmp_coef, *tmp_r;
ng_size_t dsizes_coef[3];
NclBasicDataTypes type_coef;
/*
* Return variable
*/
void *x;
ng_size_t dsizes_x[2];
NclBasicDataTypes type_x;
NclObjClass type_obj_x;
/*
* Variables for retrieving attributes from input array.
*/
NclAttList *attr_list;
NclAtt attr_obj;
NclStackEntry stack_entry;
/*
* Various
*/
int ier;
ng_size_t l = 0;
ng_size_t i, j, m, ldim, l21, ml, mldim, ml21, lwsave, lwork;
ng_size_t ix0, ix1, ir0, ir1, ic0, ic1, size_coef;
logical calculate_lval;
double *wsave, *work;
int il, im, ildim, ilwsave, ilwork;
/*
* Retrieve input argument.
*
* Note any of the pointer parameters can be set to NULL, which
* implies you don't care about its value.
*/
coef = (void*)NclGetArgValue(
0,
1,
NULL,
dsizes_coef,
NULL,
NULL,
&type_coef,
DONT_CARE);
/*
* First dimension must be 2.
*/
if(dsizes_coef[0] != 2) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"fft2db: The first dimension of coef must be 2");
return(NhlFATAL);
}
/*
* Check if the N attribute is attached to the input array (there should
* also be an M attribute, but we don't need this).
*
* This will tell us the original size of the array passed to "fft2df".
* If N is not attached as an attribute, then we will just calculate N
* (which is "l" in the code below).
*/
calculate_lval = True;
stack_entry = _NclGetArg(0, 1, 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; will have to calculate "l".
*/
break;
}
/*
* Look for attributes.
*/
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) {
if ((strcmp(attr_list->attname, "N")) == 0) {
l = *(int *) attr_list->attvalue->multidval.val;
if (l > 0) {
calculate_lval = False;
}
}
attr_list = attr_list->next;
}
}
default:
break;
}
/*
* Allocate space for coercing input array. Since we have to copy
* the input array to a bigger array (tmp_r), we will go ahead and
* make a copy of it.
*/
m = dsizes_coef[1];
l21 = dsizes_coef[2];
if(calculate_lval) {
l = (l21-1) * 2;
NhlPError(NhlWARNING,NhlEUNKNOWN,"fft2db: 'N' was either not attached as an attribute to the input array, or it had an invalid value.\nThe size of the output array will have to be calculated based on the size of the input array.");
}
ldim = 2 * l21;
ml = m * l;
mldim = m * ldim;
ml21 = m * l21;
size_coef = 2 * ml21;
tmp_coef = (double *)calloc(size_coef, sizeof(double));
tmp_r = (double *)calloc(mldim, sizeof(double));
if(tmp_coef == NULL || tmp_r == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"fft2db: Unable to allocate memory for coercing input array to double");
return(NhlFATAL);
}
coerce_subset_input_double(coef,tmp_coef,0,type_coef,size_coef,0,NULL,NULL);
/*
* Copy tmp_coef array to a subset of tmp_r.
*/
for(i = 0; i < m; i++ ) {
for(j = 0; j < l21; j++ ) {
ic0 = i*l21 + j;
ic1 = ml21 + ic0;
ir0 = i*ldim + 2*j;
ir1 = ir0 + 1;
tmp_r[ir0] = tmp_coef[ic0];
tmp_r[ir1] = tmp_coef[ic1];
}
}
/*
* The output type defaults to float, unless the input array is double.
*/
if(type_coef != NCL_double) {
type_x = NCL_float;
type_obj_x = nclTypefloatClass;
}
else {
type_x = NCL_double;
type_obj_x = nclTypedoubleClass;
}
/*
* Calculate size of output array and allocate space for it.
*/
dsizes_x[0] = m;
dsizes_x[1] = l;
if(type_x != NCL_double) {
x = (void *)calloc(ml, sizeof(float));
}
else {
x = (void *)calloc(ml, sizeof(double));
}
if(x == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"fft2db: Unable to allocate memory for output array");
return(NhlFATAL);
}
/*
* Test dimension sizes.
*/
lwsave = 2*m + l + log(l) + log(m) + 8;
lwork = mldim;
if((l > INT_MAX) || (m > INT_MAX) || (ldim > INT_MAX) ||
(lwsave > INT_MAX) || (lwork > INT_MAX)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"fft2db: one or more input dimension sizes are greater than INT_MAX");
return(NhlFATAL);
}
il = (int) l;
im = (int) m;
ildim = (int) ldim;
ilwsave = (int) lwsave;
ilwork = (int) lwork;
/*
* Allocate space for work arrays.
*/
wsave = (double *)calloc(lwsave,sizeof(double));
work = (double *)calloc(lwork,sizeof(double));
if(work == NULL || wsave == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"fft2db: Unable to allocate memory for work arrays");
return(NhlFATAL);
}
/*
* Call the Fortran routines.
*/
ier = 0;
NGCALLF(drfft2i,DRFFT2I)(&il, &im, wsave, &ilwsave, &ier);
NGCALLF(drfft2b,DRFFT2B)(&ildim, &il, &im, tmp_r, wsave, &ilwsave, work,
&ilwork,&ier);
if(ier) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"fft2db: ier = %d", ier);
return(NhlFATAL);
}
/*
* Copy tmp_r back to the appropriate locations in coef.
*/
if(type_x == NCL_float) {
for(i = 0; i < m; i++ ) {
for(j = 0; j < l; j++ ) {
ix0 = i*l + j;
ix1 = i*ldim + j;
((float*)x)[ix0] = (float)tmp_r[ix1];
}
}
}
else {
for(i = 0; i < m; i++ ) {
for(j = 0; j < l; j++ ) {
ix0 = i*l + j;
ix1 = i*ldim + j;
((double*)x)[ix0] = tmp_r[ix1];
}
}
}
/*
* Free unneeded memory.
*/
NclFree(tmp_coef);
NclFree(tmp_r);
NclFree(wsave);
NclFree(work);
/*
* Return value back to NCL script.
*/
return(NclReturnValue(x,2,dsizes_x,NULL,type_x,0));
}
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 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 fft2df_W( void )
{
/*
* First and only input argument.
*/
void *x;
double *tmp_x, *tmp_r;
ng_size_t dsizes_x[2];
NclBasicDataTypes type_x;
/*
* Return variable
*/
void *coef;
ng_size_t dsizes_coef[3];
NclBasicDataTypes type_coef;
NclObjClass type_obj_coef;
/*
* Variables for returning the output array with attributes attached.
*/
int att_id;
ng_size_t dsizes[1];
int *nattr, *mattr;
NclMultiDValData att_md, return_md;
NclVar tmp_var;
NclStackEntry return_data;
/*
* Various
*/
int ier;
ng_size_t i, j, m, l, ldim, l21, ml, mldim, ml21, lwsave, lwork, size_coef;
ng_size_t ic0, ic1, ir0, ir1, ix0, ix1;
double *wsave, *work;
int il, im, ildim, ilwsave, ilwork;
/*
* Retrieve input argument.
*
* Note any of the pointer parameters can be set to NULL, which
* implies you don't care about its value.
*/
x = (void*)NclGetArgValue(
0,
1,
NULL,
dsizes_x,
NULL,
NULL,
&type_x,
DONT_CARE);
/*
* Allocate space for coercing input array. Since we have to copy
* the input array to a bigger array (tmp_r), we will go ahead and
* make a copy of it.
*/
m = dsizes_x[0];
l = dsizes_x[1];
l21 = (l/2) + 1;
ldim = 2 * l21;
ml = m * l;
ml21 = m * l21;
mldim = m * ldim;
tmp_x = (double *)calloc(ml, sizeof(double));
tmp_r = (double *)calloc(mldim, sizeof(double));
if(tmp_x == NULL || tmp_r == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"fft2df: Unable to allocate memory for coercing input array to double");
return(NhlFATAL);
}
coerce_subset_input_double(x,tmp_x,0,type_x,ml,0,NULL,NULL);
/*
* Copy tmp_x to a subset of tmp_r.
*/
for(i = 0; i < m; i++ ) {
for(j = 0; j < l; j++ ) {
ix0 = i*l + j;
ix1 = i*ldim + j;
tmp_r[ix1] = tmp_x[ix0];
}
}
/*
* The output type defaults to float, unless the input array is double.
*/
if(type_x != NCL_double) {
type_coef = NCL_float;
type_obj_coef = nclTypefloatClass;
}
else {
type_coef = NCL_double;
type_obj_coef = nclTypedoubleClass;
}
/*
* Calculate size of output array and allocate space for it.
*/
dsizes_coef[0] = 2;
dsizes_coef[1] = m;
dsizes_coef[2] = l21;
size_coef = 2 * ml21;
if(type_coef != NCL_double) {
coef = (void *)calloc(size_coef, sizeof(float));
}
else {
coef = (void *)calloc(size_coef, sizeof(double));
}
if(coef == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"fft2df: Unable to allocate memory for output array");
return(NhlFATAL);
}
/*
* Test dimension sizes.
*/
lwsave = 2*m + l + (int)log((double)l) + (int)log((double)m) + 8;
lwork = mldim;
if((l > INT_MAX) || (m > INT_MAX) || (ldim > INT_MAX) ||
(lwsave > INT_MAX) || (lwork > INT_MAX)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"fft2df: one or more input dimension sizes are greater than INT_MAX");
return(NhlFATAL);
}
il = (int) l;
im = (int) m;
ildim = (int) ldim;
ilwsave = (int) lwsave;
ilwork = (int) lwork;
/*
* Allocate space for work arrays.
*/
wsave = (double *)calloc(lwsave,sizeof(double));
work = (double *)calloc(lwork,sizeof(double));
if(work == NULL || wsave == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"fft2df: Unable to allocate memory for work arrays");
return(NhlFATAL);
}
/*
* Call the Fortran routines.
*/
ier = 0;
NGCALLF(drfft2i,DRFFT2I)(&il, &im, wsave, &ilwsave, &ier);
NGCALLF(drfft2f,DRFFT2F)(&ildim, &il, &im, tmp_r, wsave, &ilwsave, work, &ilwork,
&ier);
if(ier) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"fft2df: ier = %d", ier);
return(NhlFATAL);
}
/*
* Copy tmp_r back to the appropriate locations in coef.
*/
if(type_coef == NCL_float) {
for(i = 0; i < m; i++ ) {
for(j = 0; j < l21; j++ ) {
ic0 = i*l21 + j;
ic1 = ml21 + ic0;
ir0 = i*ldim + 2*j;
ir1 = ir0 + 1;
((float*)coef)[ic0] = (float)tmp_r[ir0];
((float*)coef)[ic1] = (float)tmp_r[ir1];
}
}
}
else {
for(i = 0; i < m; i++ ) {
for(j = 0; j < l21; j++ ) {
ic0 = i*l21 + j;
ic1 = ml21 + ic0;
ir0 = i*ldim + 2*j;
ir1 = ir0 + 1;
((double*)coef)[ic0] = tmp_r[ir0];
((double*)coef)[ic1] = tmp_r[ir1];
}
}
}
/*
* Free unneeded memory.
*/
NclFree(tmp_x);
NclFree(tmp_r);
NclFree(wsave);
NclFree(work);
/*
* Set up return value.
*/
return_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
(void*)coef,
NULL,
3,
dsizes_coef,
TEMPORARY,
NULL,
type_obj_coef
);
/*
* Set up attributes to return.
*/
nattr = (int *)malloc(sizeof(int));
mattr = (int *)malloc(sizeof(int));
*nattr = l;
*mattr = m;
att_id = _NclAttCreate(NULL,NULL,Ncl_Att,0,NULL);
dsizes[0] = 1;
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
(void*)nattr,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
(NclObjClass)nclTypeintClass
);
_NclAddAtt(
att_id,
"N",
att_md,
NULL
);
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
(void*)mattr,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
(NclObjClass)nclTypeintClass
);
_NclAddAtt(
att_id,
"M",
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 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 center_finite_diff_W( void )
{
/*
* Input array variables
*/
void *q, *r;
logical *cyclic;
int *opt, r_one_d, r_scalar;
double *tmp_q = NULL;
double *tmp_r = NULL;
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 = NULL;
NclScalar missing_dqdr;
/*
* Declare various variables for random purposes.
*/
ng_size_t i, npts, npts1, size_q, size_leftmost, 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,
4,
&ndims_q,
dsizes_q,
&missing_q,
&has_missing_q,
&type_q,
DONT_CARE);
r = (void*)NclGetArgValue(
1,
4,
&ndims_r,
dsizes_r,
&missing_r,
&has_missing_r,
&type_r,
DONT_CARE);
cyclic = (logical*)NclGetArgValue(
2,
4,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
opt = (int*)NclGetArgValue(
3,
4,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Get size of input array and test dimension sizes.
*/
npts = dsizes_q[ndims_q-1];
npts1 = npts + 1;
if((npts > INT_MAX) || (npts1 > INT_MAX)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"center_finite_diff: 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: r must either be a scalar, a 1D array the same length as the rightmost dimemsion of q, or the same size as q");
return(NhlFATAL);
}
if(ndims_r > 1) {
r_one_d = 0;
for( i = 0; i < ndims_r-1; i++ ) {
if(dsizes_r[i] != dsizes_q[i]) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"center_finite_diff: r must either be a scalar, a 1D array the same length as the rightmost dimemsion of q, or the same size as q");
return(NhlFATAL);
}
}
}
else {
r_one_d = 1;
}
/*
* Compute the total size of the q array.
*/
size_leftmost = 1;
for( i = 0; i < ndims_q-1; i++ ) size_leftmost *= dsizes_q[i];
size_q = size_leftmost * 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: Unable to allocate memory for temporary arrays");
return(NhlFATAL);
}
/*
* Create temporary arrays to hold double precision data.
*/
if(type_q != NCL_double) {
tmp_q = (double*)calloc(npts,sizeof(double));
if( tmp_q == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"center_finite_diff: 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.
*/
r_scalar = is_scalar(ndims_r,dsizes_r);
if(type_r != NCL_double || r_scalar) {
tmp_r = (double*)calloc(npts,sizeof(double));
if( tmp_r == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"center_finite_diff: Unable to allocate memory for coercing r to double precision");
return(NhlFATAL);
}
/*
* Coerce r (tmp_r) to double if necessary.
*/
if(r_one_d) {
coerce_subset_input_double(r,tmp_r,0,type_r,dsizes_r[0],0,NULL,NULL);
}
/*
* If r is a scalar, then copy it npts-1 times to rest of the array.
*/
if(r_scalar) {
for(i = 1; i < npts; i++ ) tmp_r[i] = tmp_r[i-1] + tmp_r[0];
}
}
if(type_r == NCL_double && !r_scalar && r_one_d) {
/*
* Point tmp_r to r.
*/
tmp_r = &((double*)r)[0];
}
/*
* 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));
tmp_dqdr = coerce_output_double(dqdr,type_dqdr,npts);
if( tmp_dqdr == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"center_finite_diff: Unable to allocate memory for temporary output array");
return(NhlFATAL);
}
missing_dqdr = missing_rq;
}
if( dqdr == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"center_finite_diff: Unable to allocate memory for output array");
return(NhlFATAL);
}
if(*cyclic) {
iend = 0;
}
else {
iend = 1;
}
/*
* Loop through leftmost dimensions and call Fortran routine.
*/
index_q = 0;
for(i = 0; i < size_leftmost; i++ ) {
if(type_q != NCL_double) {
/*
* Coerce q (tmp_q) to double.
*/
coerce_subset_input_double(q,tmp_q,index_q,type_q,npts,0,NULL,NULL);
}
else {
/*
* Point tmp_q to q.
*/
tmp_q = &((double*)q)[index_q];
}
if(!r_one_d) {
if(type_r != NCL_double) {
/*
* Coerce r (tmp_r) to double.
*/
coerce_subset_input_double(r,tmp_r,index_q,type_r,npts,0,NULL,NULL);
}
else {
/*
* Point tmp_r to r.
*/
tmp_r = &((double*)r)[index_q];
}
}
if(type_dqdr == NCL_double) {
/*
* Point tmp_dqdr to dqdr.
*/
tmp_dqdr = &((double*)dqdr)[index_q];
}
/*
* 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);
if(type_dqdr != NCL_double) {
coerce_output_float_only(dqdr,tmp_dqdr,npts,index_q);
}
index_q += npts;
}
/*
* Free temp arrays.
*/
if(type_r != NCL_double || r_scalar) NclFree(tmp_r);
if(type_q != NCL_double) NclFree(tmp_q);
if(type_dqdr != NCL_double) NclFree(tmp_dqdr);
NclFree(qq);
NclFree(rr);
if(has_missing_q) {
return(NclReturnValue(dqdr,ndims_q,dsizes_q,&missing_dqdr,type_dqdr,0));
}
else {
return(NclReturnValue(dqdr,ndims_q,dsizes_q,NULL,type_dqdr,0));
}
}
NhlErrorTypes dim_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 cd_inv_calendar_W( void )
{
/*
* Input array variables
*/
int *year, *month, *day, *hour, *minute;
void *second;
double *tmp_second = NULL;
NrmQuark *sspec;
int *option;
char *cspec;
int ndims_year;
ng_size_t dsizes_year[NCL_MAX_DIMENSIONS];
int has_missing_year;
int ndims_month;
ng_size_t dsizes_month[NCL_MAX_DIMENSIONS];
int has_missing_month;
int ndims_day;
ng_size_t dsizes_day[NCL_MAX_DIMENSIONS];
int has_missing_day;
int ndims_hour;
ng_size_t dsizes_hour[NCL_MAX_DIMENSIONS];
int has_missing_hour;
int ndims_minute;
ng_size_t dsizes_minute[NCL_MAX_DIMENSIONS];
int has_missing_minute;
int ndims_second;
ng_size_t dsizes_second[NCL_MAX_DIMENSIONS];
int has_missing_second;
NclScalar missing_year;
NclScalar missing_month;
NclScalar missing_day;
NclScalar missing_hour;
NclScalar missing_minute;
NclScalar missing_second;
NclBasicDataTypes type_second;
cdCompTime comptime;
/*
* Variables for retrieving attributes from last argument.
*/
NclAttList *attr_list;
NclAtt attr_obj;
NclStackEntry stack_entry;
NrmQuark *scal;
char *ccal = NULL;
/*
* Output variables.
*/
double *x;
int has_missing_x;
NclScalar missing_x;
/*
* Variables for returning "units" and "calendar" attributes.
*/
NclQuark *units, *calendar;
int att_id;
NclMultiDValData att_md, return_md;
NclVar tmp_var;
NclStackEntry return_data;
/*
* various
*/
int ret;
ng_size_t i, total_size_input;
ng_size_t dsizes[1], return_missing;
cdCalenType ctype;
double fraction;
/* 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.
* The first size input arrays must be the same dimension sizes.
*/
year = (int*)NclGetArgValue(
0,
8,
&ndims_year,
dsizes_year,
&missing_year,
&has_missing_year,
NULL,
DONT_CARE);
month = (int*)NclGetArgValue(
1,
8,
&ndims_month,
dsizes_month,
&missing_month,
&has_missing_month,
NULL,
DONT_CARE);
day = (int*)NclGetArgValue(
2,
8,
&ndims_day,
dsizes_day,
&missing_day,
&has_missing_day,
NULL,
DONT_CARE);
hour = (int*)NclGetArgValue(
3,
8,
&ndims_hour,
dsizes_hour,
&missing_hour,
&has_missing_hour,
NULL,
DONT_CARE);
minute = (int*)NclGetArgValue(
4,
8,
&ndims_minute,
dsizes_minute,
&missing_minute,
&has_missing_minute,
NULL,
DONT_CARE);
second = (void*)NclGetArgValue(
5,
8,
&ndims_second,
dsizes_second,
&missing_second,
&has_missing_second,
&type_second,
DONT_CARE);
if(ndims_year != ndims_month || ndims_year != ndims_day ||
ndims_year != ndims_hour || ndims_year != ndims_minute ||
ndims_year != ndims_second) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"cd_inv_calendar: The first six arguments must have the same dimensionality");
return(NhlFATAL);
}
for(i = 0; i < ndims_year; i++ ) {
if(dsizes_year[i] != dsizes_month[i] ||
dsizes_year[i] != dsizes_day[i] ||
dsizes_year[i] != dsizes_hour[i] ||
dsizes_year[i] != dsizes_minute[i] ||
dsizes_year[i] != dsizes_second[i]) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"cd_inv_calendar: The first six arguments must have the same dimensionality");
return(NhlFATAL);
}
}
/*
* x will contain a _FillValue attribute if any of the input
* has a _FillValue attribute set.
*/
if(has_missing_year || has_missing_month || has_missing_day ||
has_missing_hour || has_missing_minute || has_missing_second) {
has_missing_x = 1;
/*
* Get the default missing value for a double type.
*/
missing_x = ((NclTypeClass)nclTypedoubleClass)->type_class.default_mis;
}
else {
has_missing_x = 0;
}
/*
* Get spec string.
*/
sspec = (NrmQuark *)NclGetArgValue(
6,
8,
NULL,
NULL,
NULL,
NULL,
NULL,
1);
/*
* Get option.
*/
option = (int*)NclGetArgValue(
7,
8,
NULL,
NULL,
NULL,
NULL,
NULL,
1);
/*
* Check the "option" variable to see if it contains a "calendar"
* attribute.
*/
return_missing = 0;
stack_entry = _NclGetArg(7, 8, DONT_CARE);
switch (stack_entry.kind) {
case NclStk_VAR:
if (stack_entry.u.data_var->var.att_id != -1) {
attr_obj = (NclAtt) _NclGetObj(stack_entry.u.data_var->var.att_id);
if (attr_obj == NULL) {
break;
}
}
else {
/*
* att_id == -1 ==> no attributes specified args given.
*/
break;
}
/*
* Get optional arguments.
*/
if (attr_obj->att.n_atts > 0) {
/*
* Get list of attributes.
*/
attr_list = attr_obj->att.att_list;
/*
* Loop through attributes and check them.
*/
while (attr_list != NULL) {
if ((strcmp(attr_list->attname, "calendar")) == 0) {
scal = (NrmQuark *) attr_list->attvalue->multidval.val;
ccal = NrmQuarkToString(*scal);
if(strcasecmp(ccal,"standard") && strcasecmp(ccal,"gregorian") &&
strcasecmp(ccal,"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_inv_calendar: the 'calendar' attribute is not equal to a recognized calendar. Returning all missing values.");
return_missing = has_missing_x = 1;
}
}
attr_list = attr_list->next;
}
}
default:
break;
}
/*
* 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.
*/
cspec = NrmQuarkToString(*sspec);
/*
* Calculate total size of input arrays, and size and dimensions for
* output array, and alloc memory for output array.
*/
total_size_input = 1;
for( i = 0; i < ndims_year; i++ ) total_size_input *= dsizes_year[i];
x = (double *)calloc(total_size_input,sizeof(double));
if( x == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"cd_inv_calendar: Unable to allocate memory for output array");
return(NhlFATAL);
}
/*
* Create tmp array for coercing second to double if necessary.
*/
if(type_second != NCL_double) {
tmp_second = (double*)calloc(1,sizeof(double));
if(tmp_second == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"cd_inv_calendar: Unable to allocate memory for coercing second array to double precision");
return(NhlFATAL);
}
}
/*
* Loop through each data value, and call Udunits routine.
*/
for( i = 0; i < total_size_input; i++ ) {
/*
* Coerce "second" to double, since this is what the original Udunits
* routine is expecting.
*/
if(type_second != NCL_double) {
coerce_subset_input_double(second,tmp_second,i,type_second,1,
has_missing_second,&missing_second,NULL);
}
else {
tmp_second = &((double*)second)[i];
}
if(!return_missing && (!has_missing_year ||
(has_missing_year && year[i] != missing_year.intval)) &&
(!has_missing_month ||
(has_missing_month && month[i] != missing_month.intval)) &&
(!has_missing_day ||
(has_missing_day && day[i] != missing_day.intval)) &&
(!has_missing_hour ||
(has_missing_hour && hour[i] != missing_hour.intval)) &&
(!has_missing_minute ||
(has_missing_minute && minute[i] != missing_minute.intval)) &&
(!has_missing_second ||
(has_missing_second && *tmp_second != missing_second.doubleval)) ) {
fraction = (double)minute[i]/60. + *tmp_second/3600.;
comptime.year = (long)year[i];
comptime.month = (short)month[i];
comptime.day = (short)day[i];
comptime.hour = (double)hour[i] + fraction;
(void)cdComp2Rel(ctype,comptime,cspec,&x[i]);
/*
* Return all missing values if we encounter a fatal error.
*/
if(i == 0 && (cuErrorOccurred && (cuErrOpts & CU_FATAL))) {
set_all_missing(x, total_size_input, missing_x, 1);
ret = NclReturnValue(x,ndims_year,dsizes_year,&missing_x,
NCL_double,0);
if(type_second != NCL_double) NclFree(tmp_second);
return(ret);
}
}
else {
x[i] = missing_x.doubleval;
}
}
if(type_second != NCL_double) NclFree(tmp_second);
/*
* Set up variable to return.
*/
if(has_missing_x) {
return_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
x,
&missing_x,
ndims_year,
dsizes_year,
TEMPORARY,
NULL,
(NclObjClass)nclTypedoubleClass
);
}
else {
return_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
x,
NULL,
ndims_year,
dsizes_year,
TEMPORARY,
NULL,
(NclObjClass)nclTypedoubleClass
);
}
/*
* Set up attributes to return.
*/
att_id = _NclAttCreate(NULL,NULL,Ncl_Att,0,NULL);
dsizes[0] = 1;
/*
* Return "units" attribute.
*
* We can't just return "sspec" here, because it's an NCL input
* parameter and this seems to screw things up if we try to
* return it as an attribute.
*/
units = (NclQuark*)NclMalloc(sizeof(NclQuark));
*units = NrmStringToQuark(cspec);
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
(void*)units,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
(NclObjClass)nclTypestringClass
);
_NclAddAtt(
att_id,
"units",
att_md,
NULL
);
/*
* Return "calendar" attribute.
*
* We can't just return "sspec" here, because it's an NCL input
* parameter and this seems to screw things up if we try to
* return it as an attribute.
*/
calendar = (NclQuark*)NclMalloc(sizeof(NclQuark));
if(ccal != NULL) {
*calendar = NrmStringToQuark(ccal);
}
else {
*calendar = NrmStringToQuark("standard");
}
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
(void*)calendar,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
(NclObjClass)nclTypestringClass
);
_NclAddAtt(
att_id,
"calendar",
att_md,
NULL
);
tmp_var = _NclVarCreate(
NULL,
NULL,
Ncl_Var,
0,
NULL,
return_md,
NULL,
att_id,
NULL,
RETURNVAR,
NULL,
TEMPORARY
);
/*
* Return output grid and attributes to NCL.
*/
return_data.kind = NclStk_VAR;
return_data.u.data_var = tmp_var;
_NclPlaceReturn(return_data);
return(NhlNOERROR);
}
NhlErrorTypes 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);
}