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 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 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 wavelet_default_W( void )
{
/*
* Input array variables
*/
void *y;
int *mother, jtot, npad, noise, isigtest;
double *tmp_y, dt, param, s0, dj, siglvl, nadof[2];
ng_size_t dsizes_y[NCL_MAX_DIMENSIONS];
NclBasicDataTypes type_y;
/*
* Attribute variables
*/
int att_id;
ng_size_t dsizes[NCL_MAX_DIMENSIONS];
NclMultiDValData att_md, return_md;
NclVar tmp_var;
NclStackEntry return_data;
/*
* Output array variables
*/
void *wave, *scale, *period, *coi, *dof, *ffttheor, *signif, *gws;
void *power, *phase, *r1, *mean, *st_dev, *lag1, *cdelta, *psi0;
double *tmp_wave, *tmp_scale, *tmp_period, *tmp_coi, *tmp_dof;
double *tmp_ffttheor, *tmp_signif, *tmp_gws, *tmp_power, *tmp_phase;
double *tmp_r1;
double *tmp_mean, *tmp_st_dev, *tmp_lag1, *tmp_cdelta, *tmp_psi0;
int ndims_wave = 3;
ng_size_t dsizes_wave[3];
NclBasicDataTypes type_wave;
NclObjClass type_output;
/*
* Declare various variables for random purposes.
*/
ng_size_t n, size_wave, size_output;
int in;
/*
* Retrieve parameters
*
* Note that any of the pointer parameters can be set to NULL,
* which implies you don't care about its value.
*
* Retrieve argument #1
*/
y = (void*)NclGetArgValue(
0,
2,
NULL,
dsizes_y,
NULL,
NULL,
&type_y,
DONT_CARE);
mother = (int*)NclGetArgValue(
1,
2,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Get size of input array.
*/
n = dsizes_y[0];
if(n > INT_MAX) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"wavelet_default: n = %ld is greater than INT_MAX", n);
return(NhlFATAL);
}
in = (int) n;
/*
* Initialize.
*/
if (*mother <= 0 || *mother > 2) {
param = 6.0;
}
else if (*mother == 1) {
param = 4.0;
}
else if (*mother == 2) {
param = 2.0;
}
dt = 1.0;
s0 = 2.*dt;
dj = 0.25;
jtot = 1 + ((log(n*dt/s0))/dj)/log(2.);
npad = n;
noise = 1;
isigtest = 0;
siglvl = 0.05;
/*
* Coerce input if necessary.
*/
tmp_y = coerce_input_double(y,type_y,n,0,NULL,NULL);
if( tmp_y == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"wavelet_default: Unable to coerce input to double precision");
return(NhlFATAL);
}
/*
* Allocate space for output array and attributes.
*
* Also, set size for output array (wave).
*/
dsizes_wave[0] = 2;
dsizes_wave[1] = jtot;
dsizes_wave[2] = n;
size_wave = jtot * 2 * n;
if(type_y == NCL_double) {
type_wave = NCL_double;
type_output = nclTypedoubleClass;
size_output = sizeof(double);
}
else {
type_wave = NCL_float;
type_output = nclTypefloatClass;
size_output = sizeof(float);
}
wave = (void*)calloc(size_wave,size_output);
scale = (void*)calloc(jtot,size_output);
period = (void*)calloc(jtot,size_output);
coi = (void*)calloc(n,size_output);
dof = (void*)calloc(jtot,size_output);
ffttheor = (void*)calloc(jtot,size_output);
signif = (void*)calloc(jtot,size_output);
gws = (void*)calloc(jtot,size_output);
power = (void*)calloc(jtot*n,size_output);
phase = (void*)calloc(jtot*n,size_output);
r1 = (void*)calloc(1,size_output);
mean = (void*)calloc(1,size_output);
st_dev = (void*)calloc(1,size_output);
lag1 = (void*)calloc(1,size_output);
cdelta = (void*)calloc(1,size_output);
psi0 = (void*)calloc(1,size_output);
tmp_wave = coerce_output_double(wave,type_wave,size_wave);
tmp_scale = coerce_output_double(scale,type_wave,jtot);
tmp_period = coerce_output_double(period,type_wave,jtot);
tmp_coi = coerce_output_double(coi,type_wave,n);
tmp_dof = coerce_output_double(dof,type_wave,jtot);
tmp_ffttheor = coerce_output_double(ffttheor,type_wave,jtot);
tmp_signif = coerce_output_double(signif,type_wave,jtot);
tmp_gws = coerce_output_double(gws,type_wave,jtot);
tmp_power = coerce_output_double(power,type_wave,jtot*n);
tmp_phase = coerce_output_double(phase,type_wave,jtot*n);
tmp_r1 = coerce_output_double(r1,type_wave,1);
tmp_mean = coerce_output_double(mean,type_wave,1);
tmp_st_dev = coerce_output_double(st_dev,type_wave,1);
tmp_lag1 = coerce_output_double(lag1,type_wave,1);
tmp_cdelta = coerce_output_double(cdelta,type_wave,1);
tmp_psi0 = coerce_output_double(psi0,type_wave,1);
if( tmp_wave == NULL || tmp_scale == NULL || tmp_period == NULL ||
tmp_coi == NULL || tmp_dof == NULL || tmp_ffttheor == NULL ||
tmp_signif == NULL || tmp_gws == NULL || tmp_mean == NULL ||
tmp_power == NULL || tmp_phase == NULL || tmp_st_dev == NULL ||
tmp_lag1 == NULL ||tmp_cdelta == NULL || tmp_psi0 == NULL ||
tmp_r1 == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"wavelet_default: Unable to allocate memory for output variables");
return(NhlFATAL);
}
/*
* Call the Fortran routine.
*/
NGCALLF(waveleti,WAVELETI)(&in,tmp_y,&dt,mother,¶m,&s0,&dj,
&jtot,&npad,&noise,&isigtest,&siglvl,nadof,
tmp_wave,tmp_scale,tmp_period,tmp_coi,tmp_dof,
tmp_ffttheor,tmp_signif,tmp_gws,tmp_mean,
tmp_st_dev,tmp_lag1,tmp_cdelta,tmp_psi0,
tmp_power,tmp_phase,tmp_r1);
if(type_wave == NCL_float) {
coerce_output_float_only(wave,tmp_wave,size_wave,0);
coerce_output_float_only(scale,tmp_scale,jtot,0);
coerce_output_float_only(period,tmp_period,jtot,0);
coerce_output_float_only(coi,tmp_coi,n,0);
coerce_output_float_only(dof,tmp_dof,jtot,0);
coerce_output_float_only(ffttheor,tmp_ffttheor,jtot,0);
coerce_output_float_only(signif,tmp_signif,jtot,0);
coerce_output_float_only(gws,tmp_gws,jtot,0);
coerce_output_float_only(power,tmp_power,jtot*n,0);
coerce_output_float_only(phase,tmp_phase,jtot*n,0);
coerce_output_float_only(r1,tmp_r1,1,0);
coerce_output_float_only(mean,tmp_mean,1,0);
coerce_output_float_only(st_dev,tmp_st_dev,1,0);
coerce_output_float_only(lag1,tmp_lag1,1,0);
coerce_output_float_only(cdelta,tmp_cdelta,1,0);
coerce_output_float_only(psi0,tmp_psi0,1,0);
}
/*
* Free memory.
*/
if(type_y != NCL_double) NclFree(tmp_y);
if(type_wave != NCL_double) {
NclFree(tmp_wave);
NclFree(tmp_scale);
NclFree(tmp_period);
NclFree(tmp_coi);
NclFree(tmp_dof);
NclFree(tmp_ffttheor);
NclFree(tmp_signif);
NclFree(tmp_gws);
NclFree(tmp_power);
NclFree(tmp_phase);
NclFree(tmp_r1);
NclFree(tmp_mean);
NclFree(tmp_st_dev);
NclFree(tmp_lag1);
NclFree(tmp_cdelta);
NclFree(tmp_psi0);
}
/*
* Set up variable to return.
*/
return_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
wave,
NULL,
ndims_wave,
dsizes_wave,
TEMPORARY,
NULL,
type_output
);
/*
* Set up attributes to return.
*/
att_id = _NclAttCreate(NULL,NULL,Ncl_Att,0,NULL);
dsizes[0] = jtot;
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
scale,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"scale",
att_md,
NULL
);
dsizes[0] = jtot;
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
period,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"period",
att_md,
NULL
);
dsizes[0] = n;
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
coi,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"coi",
att_md,
NULL
);
dsizes[0] = jtot;
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
dof,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"dof",
att_md,
NULL
);
dsizes[0] = jtot;
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
ffttheor,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"fft_theor",
att_md,
NULL
);
dsizes[0] = jtot;
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
signif,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"signif",
att_md,
NULL
);
dsizes[0] = jtot;
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
gws,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"gws",
att_md,
NULL
);
dsizes[0] = jtot*n;
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
power,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"power",
att_md,
NULL
);
dsizes[0] = jtot*n;
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
phase,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"phase",
att_md,
NULL
);
dsizes[0] = 1;
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
r1,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"r1",
att_md,
NULL
);
dsizes[0] = 1;
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
mean,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"mean",
att_md,
NULL
);
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
st_dev,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"stdev",
att_md,
NULL
);
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
lag1,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"lag1",
att_md,
NULL
);
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
cdelta,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"cdelta",
att_md,
NULL
);
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
psi0,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"psi0",
att_md,
NULL
);
tmp_var = _NclVarCreate(
NULL,
NULL,
Ncl_Var,
0,
NULL,
return_md,
NULL,
att_id,
NULL,
RETURNVAR,
NULL,
TEMPORARY
);
/*
* Return output grid and attributes to NCL.
*/
return_data.kind = NclStk_VAR;
return_data.u.data_var = tmp_var;
_NclPlaceReturn(return_data);
return(NhlNOERROR);
}
NhlErrorTypes covcorm_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 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 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 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 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 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);
}
NhlErrorTypes specx_anal_W( void )
{
/*
* Input array variables
*/
void *x, *pct;
double *dx, *dpct;
ng_size_t dsizes[1];
ng_size_t nx;
int *iopt, *jave;
int ndims_x;
ng_size_t dsizes_x[NCL_MAX_DIMENSIONS];
int has_missing_x;
NclScalar missing_x, missing_dx;
NclBasicDataTypes type_x, 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, sinfo[50];
void *spcx, *frq, *bw, *xavei, *xvari, *xvaro, *xlag1, *xslope;
/*
* Declare variables for random purposes.
*/
ng_size_t i, nspcmx, nspc, total_size_x;
int ier;
/*
* Retrieve arguments.
*/
x = (void*)NclGetArgValue(
0,
4,
&ndims_x,
dsizes_x,
&missing_x,
&has_missing_x,
&type_x,
DONT_CARE);
iopt = (int*)NclGetArgValue(
1,
4,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
jave = (int*)NclGetArgValue(
2,
4,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
pct = (void*)NclGetArgValue(
3,
4,
NULL,
NULL,
NULL,
NULL,
&type_pct,
DONT_CARE);
/*
* Check input.
*/
if( *iopt > 2) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"specx_anal: 'iopt' must be <= 2");
return(NhlFATAL);
}
nx = dsizes_x[0];
nspc = nspcmx = nx/2 + 1;
if( nx < 3) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"specx_anal: 'x' must have more than 3 elements");
return(NhlFATAL);
}
if( abs(*jave) > nx/2 ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"specx_anal: 'jave' must be <= nx/2");
return(NhlFATAL);
}
/*
* Compute the total number of elements in our array.
*/
total_size_x = 1;
for(i = 0; i < ndims_x; i++) total_size_x *= dsizes_x[i];
/*
* Check for missing values.
*/
coerce_missing(type_x,has_missing_x,&missing_x,&missing_dx,NULL);
/*
* Coerce x to double precision if necessary.
*/
dx = coerce_input_double(x,type_x,total_size_x,has_missing_x,&missing_x,
&missing_dx);
if( dx == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"specx_anal: Unable to allocate memory for coercing x array to double precision");
return(NhlFATAL);
}
/*
* Check if x contains missing values.
*/
if(contains_missing(dx,total_size_x,has_missing_x,missing_dx.doubleval)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"specx_anal: 'x' 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,"specx_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,"specx_anal: 'pct' must be between 0 and 1 inclusive");
return(NhlFATAL);
}
/*
* Check if any input is double.
*/
if(type_x != 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));
bw = (void *)calloc(1,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));
}
else {
type_dof = NCL_double;
type_output = nclTypedoubleClass;
/*
* Allocate space for double output variables.
*/
dof = (void *)calloc(1,sizeof(double));
frq = (void *)calloc(nspcmx-1,sizeof(double));
spcx = (void *)calloc(nspcmx-1,sizeof(double));
bw = (void *)calloc(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));
}
if( dof == NULL || bw == NULL || spcx == NULL || frq == NULL ||
xavei == NULL || xvari == NULL || xvaro == NULL || xlag1 == NULL ||
xslope == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"specx_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));
if( frq_tmp == NULL || spcx_tmp == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"specx_anal: Unable to allocate memory for output variables");
return(NhlFATAL);
}
/*
* Allocate space for work array.
*/
lwork = 5 * nx + 18 + abs(*jave);
work = (double *)calloc(lwork,sizeof(double));
if( work == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"specx_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(dspecx,DSPECX)(dx,&inx,iopt,jave,dpct,&scl,work,&ilwork,
frq_tmp,spcx_tmp,&inspc,sinfo,&ier);
}
else
{
NhlPError(NhlFATAL,NhlEUNKNOWN,"specx_anal: one or more input dimensions is greater than INT_MAX", nx);
return(NhlFATAL);
}
if( ier > 700000 ) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"specx_anal: 'x' contains all constant values");
}
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( bw, &sinfo[5],type_dof,1,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( frq, &frq_tmp[1],type_dof,nspcmx-1,0);
coerce_output_float_or_double( spcx, &spcx_tmp[1],type_dof,nspcmx-1,0);
/*
* Free up memory.
*/
NclFree(frq_tmp);
NclFree(spcx_tmp);
NclFree(work);
if((void*)dx != x) NclFree(dx);
if((void*)dpct != pct) NclFree(dpct);
/*
* 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,
frq,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
type_output
);
_NclAddAtt(
att_id,
"frq",
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
);
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
);
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);
}
