void setGroupAttributes(NclFile group_out)
{
int i, j, num_atts;
NclQuark group_name;
NclQuark *name_list;
if(group_out->file.format_funcs->get_grp_att_names != NULL)
{
for(i = 0; i < group_out->file.n_grps; i++)
{
group_name = group_out->file.grp_info[i]->grp_full_name_quark;
name_list = (*group_out->file.format_funcs->get_grp_att_names)
(group_out->file.private_rec,group_name,&num_atts);
for(j = 0; j < num_atts; j++)
{
AddAttInfoToList(&(group_out->file.grp_att_info[i]),
(*group_out->file.format_funcs->get_grp_att_info)
(group_out->file.private_rec,group_name,name_list[j]));
}
NclFree((void*)name_list);
}
}
}
void guiNhlRLSetMDFloatArray(int id, char *resname, float *data, int num_dimensions, int *len_dimensions)
{
int n;
ng_size_t *dimsizes = (ng_size_t *)NclCalloc(num_dimensions, sizeof(ng_size_t));
for(n = 0; n < num_dimensions; ++n)
dimsizes[n] = (ng_size_t)len_dimensions[n];
NhlRLSetMDFloatArray(id, (NhlString)resname, data, num_dimensions, dimsizes);
NclFree(dimsizes);
}
NclQuark *GetGrpDimNames(void *therec, int *num_dims)
{
NclFileGrpNode *grpnode = (NclFileGrpNode *) therec;
NclQuark *out_quarks = NULL;
NclQuark *tmp_quarks = NULL;
int i, n, nv;
*num_dims = 0;
if(NULL != grpnode->dim_rec)
{
if(grpnode->dim_rec->n_dims)
{
out_quarks = (NclQuark*)NclCalloc(grpnode->dim_rec->n_dims,
sizeof(NclQuark));
assert(out_quarks);
for(i = 0; i < grpnode->dim_rec->n_dims; i++)
{
out_quarks[i] = grpnode->dim_rec->dim_node[i].name;
}
*num_dims = grpnode->dim_rec->n_dims;
}
}
if(NULL != grpnode->grp_rec)
{
if(grpnode->grp_rec->n_grps)
{
for(n = 0; n < grpnode->grp_rec->n_grps; n++)
{
tmp_quarks = GetGrpDimNames((void *)grpnode->grp_rec->grp_node[n], &nv);
if(nv)
{
out_quarks = (NclQuark*)realloc(out_quarks,
(*num_dims + nv) * sizeof(NclQuark));
assert(out_quarks);
for(i = 0; i < nv; i++)
{
out_quarks[*num_dims + i] = tmp_quarks[i];
}
NclFree(tmp_quarks);
}
*num_dims += nv;
}
}
}
return(out_quarks);
}
int
main(int argc, char **argv) {
int errid = -1;
int appid;
int i, k = 0;
int reset = 1;
DIR *d;
struct dirent *ent;
#if defined(HPUX)
shl_t so_handle;
#else
void *so_handle;
#endif /* defined(HPUX) */
char buffer[4 * NCL_MAX_STRING];
void (*init_function) (void);
char *libpath;
char *scriptpath;
char *pt;
char *tmp = NULL;
/*
* Variables for command line options/arguments
*/
char *myName; /* argv[0]: program name (should be 'ncl') */
char **NCL_ARGV;
int NCL_ARGC; /* local argv/argc -- future use for NCL scripts? */
int c;
char **cargs = NULL;
int nargs = 0;
struct stat sbuf;
int sr;
FILE *tmpf = NULL; /* file variables for creating arguments */
char *tmpd = NULL;
strcpy(buffer,(char *)GetNCARGPath("tmp"));
sr = access(buffer,W_OK|X_OK|F_OK);
if(sr != 0) {
NhlPError(NhlWARNING,NhlEUNKNOWN,
"\"%s\" tmp dir does not exist or is not writable: NCL functionality may be limited -- check TMPDIR environment variable",
buffer);
}
#ifdef YYDEBUG
extern int yydebug;
yydebug = 1;
#endif /* YYDEBUG */
error_fp = stderr;
stdout_fp = stdout;
stdin_fp = stdin;
ncopts = NC_VERBOSE;
cmd_line =isatty(fileno(stdin));
myName = NclMalloc(strlen(argv[0]) + 1);
(void) strcpy(myName, argv[0]);
/*
* Save NCL argv, for command line processing later use
*/
NCL_ARGV = (char **) NclMalloc(argc * sizeof(char *));
for (i = 0; i < argc; i++) {
NCL_ARGV[i] = (char *) NclMalloc((strlen(argv[i]) + 1) * sizeof(char *));
(void) strcpy(NCL_ARGV[i], argv[i]);
}
NCL_ARGC = argc;
for(i = 0; i < _NclNumberOfFileFormats; ++i)
NCLadvancedFileStructure[i] = 0;
#ifdef NCLDEBUG
for (i = 0; i < NCL_ARGC; i++, *NCL_ARGV++)
(void) printf("NCL_ARGV[%d] = %s\n", i, *NCL_ARGV);
#endif /* NCLDEBUG */
/*
* Defined arguments
*
* -n element print: don't enumerate elements in print()
* -x echo: turns on command echo
* -V version: output NCARG/NCL version, exit
* -o old behavior: retain former behavior for backwards incompatible changes
* -h help: output options and exit
*
* -X override: echo every stmt regardless (unannounced option)
* -Q override: don't echo copyright notice (unannounced option)
*/
opterr = 0; /* turn off getopt() msgs */
while ((c = getopt (argc, argv, "fhnoxVXQp")) != -1) {
switch (c) {
case 'p':
NCLnoSysPager = 1;
break;
case 'n':
NCLnoPrintElem = 1;
break;
case 'o':
NCLoldBehavior = 1;
break;
case 'x':
NCLecho = 1;
break;
/* NOT ADVERTISED! Will override "no echo" and print EVERYTHING! */
case 'X':
NCLoverrideEcho = 1;
break;
/* NOT ADVERTISED! Will not echo copyright notice! */
case 'Q':
NCLnoCopyright = 1;
break;
case 'V':
(void) fprintf(stdout, "%s\n", GetNCLVersion());
exit(0);
break;
case 'f':
for(i = 0; i < _NclNumberOfFileFormats; ++i)
NCLadvancedFileStructure[i] = 1;
break;
case 'h':
(void) fprintf(stdout, "Usage: ncl -fhnpxV <args> <file.ncl>\n");
(void) fprintf(stdout, "\t -f: Use New File Structure, and NetCDF4 features\n");
(void) fprintf(stdout, "\t -n: don't enumerate values in print()\n");
(void) fprintf(stdout, "\t -p: don't page output from the system() command\n");
(void) fprintf(stdout, "\t -o: retain former behavior for certain backwards-incompatible changes\n");
(void) fprintf(stdout, "\t -x: echo NCL commands\n");
(void) fprintf(stdout, "\t -V: print NCL version and exit\n");
(void) fprintf(stdout, "\t -h: print this message and exit\n");
exit(0);
break;
case '?':
if (isprint(optopt))
(void) fprintf(stderr, "Unknown option `-%c'\n", optopt);
else
(void) fprintf(stderr, "Unknown option character `\\x%x'\n", optopt);
break;
default:
break;
}
}
/*
* Announce NCL copyright notice, etc.
*/
if (!NCLnoCopyright)
(void) fprintf(stdout,
" Copyright (C) 1995-2013 - All Rights Reserved\n University Corporation for Atmospheric Research\n NCAR Command Language Version %s\n The use of this software is governed by a License Agreement.\n See http://www.ncl.ucar.edu/ for more details.\n", GetNCLVersion());
/* Process any user-defined arguments */
for (i = optind; i < argc; i++) {
#ifdef NCLDEBUG
(void) printf("Non-option argument %s\n", argv[i]);
#endif /* NCLDEBUG */
/*
* Is this a file of NCL commands? Can't assume ".ncl" tag, unfortunately.
* Check for file's existence; the stat() call does not require access rights
* but does require search path rights, so if this fails, the file could exist
* but the user may not have permission to "see" it.
*/
sr = stat(argv[i], &sbuf);
if (sr == 0) {
#ifdef NCLDEBUG
(void) printf("NCL commands file: %s\n", argv[i]);
#endif /* NCLDEBUG */
nclf = argv[i];
continue;
}
if (sr < 0) {
if (!strchr(argv[i], '=')) {
/* argument is intended to be a file; can't locate it */
NhlPError(NhlFATAL, NhlEUNKNOWN, " can't find file \"%s\"\n", argv[i]);
exit(NhlFATAL);
} else {
/* user-defined argument */
if (nargs == 0)
cargs = (char **) NclMalloc(sizeof(char *));
else
cargs = (char **) NclRealloc(cargs, (nargs + 1) * sizeof(char *));
cargs[nargs] = (char *) NclMalloc((strlen(argv[i]) + 2) * sizeof(char *));
(void) sprintf(cargs[nargs], "%s\n", argv[i]);
nargs++;
}
}
}
if(nclf){
NCL_PROF_INIT(nclf);
}
else{
NCL_PROF_INIT("cmdline");
}
error_fp = stderr;
stdout_fp = stdout;
stdin_fp = stdin;
cur_line_text = NclMalloc((unsigned int) 512);
cur_line_maxsize = 512;
cur_line_text_pos = &(cur_line_text[0]);
#ifdef NCLDEBUG
thefptr = fopen("ncl.tree", "w");
theoptr = fopen("ncl.seq", "w");
#else
thefptr = NULL;
theoptr = NULL;
#endif /* NCLDEBUG */
/*
* Note: child processes should use _exit() instead of exit() to avoid calling the atexit()
* functions prematurely
*/
NhlInitialize();
NhlVACreate(&appid, "ncl", NhlappClass, NhlDEFAULT_APP,
NhlNappDefaultParent, 1, NhlNappUsrDir, "./", NULL);
NhlPalLoadColormapFiles(NhlworkstationClass,False);
errid = NhlErrGetID();
NhlVAGetValues(errid, NhlNerrFileName, &tmp, NULL);
if ((tmp == NULL) || (!strcmp(tmp, "stderr")))
NhlVASetValues(errid, NhlNerrFilePtr, stdout, NULL);
_NclInitMachine();
_NclInitSymbol();
_NclInitTypeClasses();
_NclInitDataClasses();
/* if the -o flag is specified do stuff to make NCL backwards compatible */
if (NCLoldBehavior) {
_NclSetDefaultFillValues(NCL_5_DEFAULT_FILLVALUES);
}
/* Handle default directories */
if ((libpath = getenv("NCL_DEF_LIB_DIR")) != NULL) {
d = opendir(_NGResolvePath(libpath));
if (d != NULL) {
while((ent = readdir(d)) != NULL) {
if (*ent->d_name != '.') {
(void) sprintf(buffer, "%s/%s", _NGResolvePath(libpath), ent->d_name);
#if defined (HPUX)
so_handle = shl_load(buffer, BIND_IMMEDIATE, 0L);
#else
so_handle = dlopen(buffer, RTLD_NOW);
if (so_handle == NULL) {
NhlPError(NhlFATAL, NhlEUNKNOWN,
"Could not open (%s): %s.", buffer, dlerror());
}
#endif /* HPUX */
if (so_handle != NULL) {
#if defined (HPUX)
init_function = NULL;
(void) shl_findsym(&so_handle, "Init",
TYPE_UNDEFINED, (void *) &init_function);
#else
init_function = dlsym(so_handle, "Init");
#endif /* HPUX */
if (init_function != NULL) {
(*init_function)();
} else {
#if defined (HPUX)
shl_unload(so_handle);
#else
dlclose(so_handle);
#endif /* HPUX */
NhlPError(NhlWARNING, NhlEUNKNOWN,
"Could not find Init() in external file %s, file not loaded.",
buffer);
}
}
}
}
} else {
NhlPError(NhlWARNING, NhlEUNKNOWN,
"Could not open default library path (%s), no libraries loaded.", libpath);
}
_NclResetNewSymStack();
}
if (cmd_line == 1) {
InitializeReadLine(1);
/*
* This next line is only to deal with an optimization bug with gcc
* version 4.0.1 on MacOS 10.4. It apparently saw that "cmd_line"
* was already of value 1 before it went into NclSetPromptFunc, so
* when it optimized the code, it ignored the "cmd_line = 1" line
* right after the NclSetPromptFunc call. Since NclSetPrompFunc
* was setting cmd_line =2, this meant that the value of cmd_line
* stayed 2, which is the wrong value.
*/
cmd_line = 0;
NclSetPromptFunc(nclprompt, NULL);
cmd_line = 1;
cmd_line_is_set = 1;
} else {
InitializeReadLine(0);
}
/* Load default scripts */
/* These need to be loaded in alphabetical order to ensure that users can control
* the order of loading. There is a BSD function scandir that would do it all but it
* might not be standardized enough to be uniformly available on all systems, so for
* now it must be coded just using readdir.
*/
if ((scriptpath = getenv("NCL_DEF_SCRIPTS_DIR")) != NULL) {
d = opendir(_NGResolvePath(scriptpath));
if (d!= NULL) {
int script_count = 0, alloc_count = 32;
NrmQuark *qscript_names = NclMalloc(alloc_count * sizeof(NrmQuark));
while((ent = readdir(d)) != NULL) {
if (*ent->d_name != '.') {
(void) sprintf(buffer, "%s/%s", _NGResolvePath(scriptpath), ent->d_name);
pt = strrchr(buffer, '.');
if (pt != NULL) {
pt++;
if (strncmp(pt, "ncl", 3) == 0) {
if (script_count == alloc_count) {
alloc_count *= 2;
qscript_names = NclRealloc(qscript_names,alloc_count * sizeof(NrmQuark));
}
qscript_names[script_count++] = NrmStringToQuark(ent->d_name);
}
}
}
}
if (script_count == 0) {
NhlPError(NhlWARNING, NhlEUNKNOWN,
"No scripts found: scripts must have the \".ncl\" file extension.");
}
else {
qsort(qscript_names,script_count,sizeof(NrmQuark),quark_comp);
for (i = 0; i < script_count; i++) {
(void) sprintf(buffer, "%s/%s", _NGResolvePath(scriptpath), NrmQuarkToString(qscript_names[i]));
if (_NclPreLoadScript(buffer, 1) == NhlFATAL) {
NhlPError(NhlFATAL, NhlEUNKNOWN, "Error loading default script.");
} else {
yyparse(reset);
}
}
NclFree(qscript_names);
}
} else {
NhlPError(NhlWARNING, NhlEUNKNOWN,
" Could not open default script path (%s), no scripts loaded.", scriptpath);
}
}
/*
* Create the new args
*
* Ideally this would be done using calls to the parser/stack engine but there is
* no clean interface to that process. Investigate _NclParseString() in the future.
*
* For now, create a temporary file with NCL commands and execute it.
*/
if (nargs) {
cmd_line = 0; /* non-interactive */
tmpd = (char *) _NGGetNCARGEnv("tmp"); /* defaults to: /tmp */
(void) sprintf(buffer, "%s/ncl%d.ncl", tmpd, getpid());
tmpf = fopen(buffer, "w");
for (k = 0; k < nargs; k++) {
if ((strstr(cargs[k], "=")) == (char *) NULL)
NhlPError(NhlWARNING, NhlEUNKNOWN, " Improper assignment for variable %s", cargs[k]);
else
(void) fwrite(cargs[k], strlen(cargs[k]), 1, tmpf);
}
/* don't forget last newline; NCL requires it */
(void) fwrite("\n", 1, 1, tmpf);
(void) fclose(tmpf);
if (_NclPreLoadScript(buffer, 1) == NhlFATAL) {
NhlPError(NhlFATAL, NhlEUNKNOWN, "Error initializing command line arguments.");
(void) unlink(buffer);
} else {
yyparse(reset);
}
(void) unlink(buffer);
cmd_line = 1; /* reset to default: interactive */
}
/* Load utility script */
strcpy(buffer, _NGResolvePath("$NCARG_ROOT/lib/ncarg/nclscripts/utilities.ncl"));
sr = stat(buffer, &sbuf);
if(0 == sr)
{
if(_NclPreLoadScript(buffer, 1) == NhlFATAL)
{
NclReturnStatus = NclFileNotFound;
NhlPError(NhlINFO, NhlEUNKNOWN, "Error loading NCL utility script.");
}
else
yyparse(reset);
}
/* Load any provided script */
if (nclf != (char *) NULL) {
(void) strcpy(buffer, _NGResolvePath(nclf));
if (_NclPreLoadScript(buffer, 0) == NhlFATAL)
{
NclReturnStatus = NclFileNotFound;
NhlPError(NhlFATAL, NhlEUNKNOWN, "Error loading provided NCL script.");
}
else
yyparse(reset);
} else {
yyparse(reset);
}
#ifdef NCLDEBUG
(void) fclose(thefptr);
(void) fprintf(stdout,"Number of unfreed objects %d\n",_NclNumObjs());
_NclObjsSize(stdout);
_NclNumGetObjCals(stdout);
_NclPrintUnfreedObjs(theoptr);
(void) fprintf(stdout,"Number of constants used %d\n",number_of_constants);
(void) fclose(theoptr);
#endif /* NCLDEBUG */
NclFree(myName);
_NclExit(NclReturnStatus);
return NclReturnStatus;
}
NhlErrorTypes generate_2d_array_W( void )
{
/*
* Input array variables
*/
void *tmp_dsizes_data;
ng_size_t *dsizes_data;
int *mlow, *mhigh, *iseed;
void *dlow, *dhigh;
double *tmp_dlow, *tmp_dhigh;
NclBasicDataTypes type_dlow, type_dhigh, type_dsizes_data;
/*
* Output variables.
*/
void *data;
double *tmp_data;
NclBasicDataTypes type_data;
int ret, id0, id1;
/*
* Declare various variables for random purposes.
*/
ng_size_t size_data;
/*
* Retrieve arguments.
*
*
* Get number of lows and highs. These two values will be forced to
* be between 1 and 25.
*/
mlow = (int*)NclGetArgValue(
0,
6,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
mhigh = (int*)NclGetArgValue(
1,
6,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Retrieve minimum and maximum values that the data is supposed to have.
*/
dlow = (void*)NclGetArgValue(
2,
6,
NULL,
NULL,
NULL,
NULL,
&type_dlow,
DONT_CARE);
dhigh = (void*)NclGetArgValue(
3,
6,
NULL,
NULL,
NULL,
NULL,
&type_dhigh,
DONT_CARE);
/*
* Get size of output array.
*/
iseed = (int*)NclGetArgValue(
4,
6,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Get size of output array.
*/
tmp_dsizes_data = (void*)NclGetArgValue(
5,
6,
NULL,
NULL,
NULL,
NULL,
&type_dsizes_data,
DONT_CARE);
/*
* Error checking.
*/
dsizes_data = get_dimensions(tmp_dsizes_data,2,type_dsizes_data,"generate_2d_array");
if(dsizes_data == NULL)
return(NhlFATAL);
if(dsizes_data[0] <= 1 && dsizes_data[1] <= 1) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"generate_2d_array: the dimensions of the output array must be such that it has at least two elements");
return(NhlFATAL);
}
if((dsizes_data[0] > INT_MAX) ||
(dsizes_data[1] > INT_MAX)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"generate_2d_array: input dimensions are greater than INT_MAX");
return(NhlFATAL);
}
id0 = (int) dsizes_data[0];
id1 = (int) dsizes_data[1];
if(*iseed < 0 || *iseed > 100) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"generate_2d_array: iseed must be between 0 and 100. Will reset to 0.");
*iseed = 0;
}
if(*mlow < 1) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"generate_2d_array: mlow must be between 1 and 25. Will reset to 1.");
*mlow = 1;
}
if(*mlow > 25) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"generate_2d_array: mlow must be between 1 and 25. Will reset to 25.");
*mlow = 25;
}
if(*mhigh < 1) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"generate_2d_array: mhigh must be between 1 and 25. Will reset to 1.");
*mhigh = 1;
}
if(*mhigh > 25) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"generate_2d_array: mhigh must be between 1 and 25. Will reset to 25.");
*mhigh = 25;
}
/*
* Coerce dlow and dhigh to double.
*/
tmp_dlow = coerce_input_double(dlow, type_dlow, 1,0,NULL,NULL);
tmp_dhigh = coerce_input_double(dhigh,type_dhigh,1,0,NULL,NULL);
/*
* Compute the size of the 2D output array.
*/
size_data = dsizes_data[0] * dsizes_data[1];
/*
* The type of the output array depends on dlow and dhigh.
*/
if(type_dlow == NCL_double || type_dhigh == NCL_double) {
type_data = NCL_double;
}
else {
type_data = NCL_float;
}
/*
* Allocate memory for output.
*/
if(type_data == NCL_double) {
data = (void*)malloc(size_data*sizeof(double));
tmp_data = (double *)data;
if(data == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"generate_2d_array: Unable to allocate memory for output array");
return(NhlFATAL);
}
}
else {
data = (void*)malloc(size_data*sizeof(float));
tmp_data = (double*)malloc(size_data*sizeof(double));
if(tmp_data == NULL || data == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"generate_2d_array: Unable to allocate memory for output array");
return(NhlFATAL);
}
}
/*
* Call the Fortran version of this routine.
*/
NGCALLF(dgendat,DGENDAT)(tmp_data,&id1,&id1,
&id0,mlow,mhigh,tmp_dlow,tmp_dhigh,
iseed);
/*
* Figure out if we need to coerce output back to float.
*/
if(type_data == NCL_float) {
coerce_output_float_only(data,tmp_data,size_data,0);
}
/*
* Free memory.
*/
if(type_data != NCL_double) NclFree(tmp_data);
if(type_dlow != NCL_double) NclFree(tmp_dlow);
if(type_dhigh != NCL_double) NclFree(tmp_dhigh);
ret = NclReturnValue(data,2,dsizes_data,NULL,type_data,0);
NclFree(dsizes_data);
return(ret);
}
NhlErrorTypes center_finite_diff_W( void )
{
/*
* Input array variables
*/
void *q, *r;
logical *cyclic;
int *opt, r_one_d, r_scalar;
double *tmp_q = NULL;
double *tmp_r = NULL;
int ndims_q;
ng_size_t dsizes_q[NCL_MAX_DIMENSIONS];
int ndims_r;
ng_size_t dsizes_r[NCL_MAX_DIMENSIONS];
int has_missing_q, has_missing_r;
NclScalar missing_q, missing_dq, missing_rq;
NclScalar missing_r, missing_dr;
NclBasicDataTypes type_q, type_r, type_dqdr;
/*
* Output array variables
*/
void *dqdr;
double *tmp_dqdr = NULL;
NclScalar missing_dqdr;
/*
* Declare various variables for random purposes.
*/
ng_size_t i, npts, npts1, size_q, size_leftmost, index_q;
int inpts, inpts1, iend, ier;
double *qq, *rr;
/*
* Retrieve parameters
*
* Note that any of the pointer parameters can be set to NULL,
* which implies you don't care about its value.
*
*/
q = (void*)NclGetArgValue(
0,
4,
&ndims_q,
dsizes_q,
&missing_q,
&has_missing_q,
&type_q,
DONT_CARE);
r = (void*)NclGetArgValue(
1,
4,
&ndims_r,
dsizes_r,
&missing_r,
&has_missing_r,
&type_r,
DONT_CARE);
cyclic = (logical*)NclGetArgValue(
2,
4,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
opt = (int*)NclGetArgValue(
3,
4,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Get size of input array and test dimension sizes.
*/
npts = dsizes_q[ndims_q-1];
npts1 = npts + 1;
if((npts > INT_MAX) || (npts1 > INT_MAX)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"center_finite_diff: npts1 = %ld is larger than INT_MAX", npts1);
return(NhlFATAL);
}
inpts = (int) npts;
inpts1 = (int) npts1;
if((ndims_r == 1 && (dsizes_r[0] != npts && dsizes_r[0] != 1)) ||
(ndims_r > 1 && ndims_r != ndims_q)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"center_finite_diff: r must either be a scalar, a 1D array the same length as the rightmost dimemsion of q, or the same size as q");
return(NhlFATAL);
}
if(ndims_r > 1) {
r_one_d = 0;
for( i = 0; i < ndims_r-1; i++ ) {
if(dsizes_r[i] != dsizes_q[i]) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"center_finite_diff: r must either be a scalar, a 1D array the same length as the rightmost dimemsion of q, or the same size as q");
return(NhlFATAL);
}
}
}
else {
r_one_d = 1;
}
/*
* Compute the total size of the q array.
*/
size_leftmost = 1;
for( i = 0; i < ndims_q-1; i++ ) size_leftmost *= dsizes_q[i];
size_q = size_leftmost * npts;
/*
* Check for missing values.
*/
coerce_missing(type_q,has_missing_q,&missing_q,&missing_dq,&missing_rq);
coerce_missing(type_r,has_missing_r,&missing_r,&missing_dr,NULL);
/*
* Create arrays to hold temporary r and q values.
*/
qq = (double*)calloc(npts+2,sizeof(double));
rr = (double*)calloc(npts+2,sizeof(double));
if( qq == NULL || rr == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"center_finite_diff: Unable to allocate memory for temporary arrays");
return(NhlFATAL);
}
/*
* Create temporary arrays to hold double precision data.
*/
if(type_q != NCL_double) {
tmp_q = (double*)calloc(npts,sizeof(double));
if( tmp_q == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"center_finite_diff: Unable to allocate memory for coercing q to double precision");
return(NhlFATAL);
}
}
/*
* 'r' can be a scalar, one-dimensional, or multi-dimensional.
* If it is a scalar, then we need to construct an npts-sized 'r'
* that is based on the scalar value.
*/
r_scalar = is_scalar(ndims_r,dsizes_r);
if(type_r != NCL_double || r_scalar) {
tmp_r = (double*)calloc(npts,sizeof(double));
if( tmp_r == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"center_finite_diff: Unable to allocate memory for coercing r to double precision");
return(NhlFATAL);
}
/*
* Coerce r (tmp_r) to double if necessary.
*/
if(r_one_d) {
coerce_subset_input_double(r,tmp_r,0,type_r,dsizes_r[0],0,NULL,NULL);
}
/*
* If r is a scalar, then copy it npts-1 times to rest of the array.
*/
if(r_scalar) {
for(i = 1; i < npts; i++ ) tmp_r[i] = tmp_r[i-1] + tmp_r[0];
}
}
if(type_r == NCL_double && !r_scalar && r_one_d) {
/*
* Point tmp_r to r.
*/
tmp_r = &((double*)r)[0];
}
/*
* Allocate space for output array.
*/
if(type_q == NCL_double || type_r == NCL_double) {
type_dqdr = NCL_double;
dqdr = (void*)calloc(size_q,sizeof(double));
missing_dqdr = missing_dq;
}
else {
type_dqdr = NCL_float;
dqdr = (void*)calloc(size_q,sizeof(float));
tmp_dqdr = coerce_output_double(dqdr,type_dqdr,npts);
if( tmp_dqdr == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"center_finite_diff: Unable to allocate memory for temporary output array");
return(NhlFATAL);
}
missing_dqdr = missing_rq;
}
if( dqdr == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"center_finite_diff: Unable to allocate memory for output array");
return(NhlFATAL);
}
if(*cyclic) {
iend = 0;
}
else {
iend = 1;
}
/*
* Loop through leftmost dimensions and call Fortran routine.
*/
index_q = 0;
for(i = 0; i < size_leftmost; i++ ) {
if(type_q != NCL_double) {
/*
* Coerce q (tmp_q) to double.
*/
coerce_subset_input_double(q,tmp_q,index_q,type_q,npts,0,NULL,NULL);
}
else {
/*
* Point tmp_q to q.
*/
tmp_q = &((double*)q)[index_q];
}
if(!r_one_d) {
if(type_r != NCL_double) {
/*
* Coerce r (tmp_r) to double.
*/
coerce_subset_input_double(r,tmp_r,index_q,type_r,npts,0,NULL,NULL);
}
else {
/*
* Point tmp_r to r.
*/
tmp_r = &((double*)r)[index_q];
}
}
if(type_dqdr == NCL_double) {
/*
* Point tmp_dqdr to dqdr.
*/
tmp_dqdr = &((double*)dqdr)[index_q];
}
/*
* Call the Fortran routine.
*/
NGCALLF(dcfindif,DCFINDIF)(tmp_q,tmp_r,&inpts,&missing_dq.doubleval,
&missing_dr.doubleval,cyclic,&iend,
qq,rr,&inpts1,tmp_dqdr,&ier);
if(type_dqdr != NCL_double) {
coerce_output_float_only(dqdr,tmp_dqdr,npts,index_q);
}
index_q += npts;
}
/*
* Free temp arrays.
*/
if(type_r != NCL_double || r_scalar) NclFree(tmp_r);
if(type_q != NCL_double) NclFree(tmp_q);
if(type_dqdr != NCL_double) NclFree(tmp_dqdr);
NclFree(qq);
NclFree(rr);
if(has_missing_q) {
return(NclReturnValue(dqdr,ndims_q,dsizes_q,&missing_dqdr,type_dqdr,0));
}
else {
return(NclReturnValue(dqdr,ndims_q,dsizes_q,NULL,type_dqdr,0));
}
}
NhlErrorTypes dim_avg_wgt_W( void )
{
/*
* Input variables
*/
/*
* Argument # 0
*/
void *x;
double *tmp_x = NULL;
int ndims_x;
ng_size_t dsizes_x[NCL_MAX_DIMENSIONS];
int has_missing_x;
NclScalar missing_x, missing_flt_x, missing_dbl_x;
NclBasicDataTypes type_x;
/*
* Argument # 1
*/
void *w;
double *tmp_w;
ng_size_t dsizes_w[1];
NclBasicDataTypes type_w;
/*
* Argument # 2
*/
int *opt;
/*
* Return variable
*/
void *xavg;
double tmp_xavg[1];
int ndims_xavg;
ng_size_t *dsizes_xavg;
NclBasicDataTypes type_xavg;
/*
* Various
*/
int inx, ret, ndims_leftmost;
ng_size_t nx, index_x;
ng_size_t i, size_output;
/*
* Retrieve parameters.
*
* Note any of the pointer parameters can be set to NULL, which
* implies you don't care about its value.
*/
/*
* Get argument # 0
*/
x = (void*)NclGetArgValue(
0,
3,
&ndims_x,
dsizes_x,
&missing_x,
&has_missing_x,
&type_x,
DONT_CARE);
/*
* Coerce missing value to double if necessary.
*/
coerce_missing(type_x,has_missing_x,&missing_x,
&missing_dbl_x,&missing_flt_x);
/*
* Test input dimension size.
*/
nx = dsizes_x[ndims_x-1];
if(nx > INT_MAX) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_avg_wgt: nx = %ld is greater than INT_MAX", nx);
return(NhlFATAL);
}
inx = (int) nx;
/*
* Get argument # 1
*/
w = (void*)NclGetArgValue(
1,
3,
NULL,
dsizes_w,
NULL,
NULL,
&type_w,
DONT_CARE);
if(dsizes_w[0] != nx) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_avg_wgt: w must be length nx");
return(NhlFATAL);
}
/*
* Get argument # 2
*/
opt = (int*)NclGetArgValue(
2,
3,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Calculate size of leftmost dimensions.
*/
size_output = 1;
ndims_leftmost = ndims_x-1;
for(i = 0; i < ndims_leftmost; i++) {
size_output *= dsizes_x[i];
}
/*
* The output type defaults to float, unless this input array is double.
*/
type_xavg = NCL_float;
/*
* Allocate space for coercing input arrays. If any of the input
* is already double, then we don't need to allocate space for
* temporary arrays, because we'll just change the pointer into
* the void array appropriately.
*/
/*
* Allocate space for tmp_x.
*/
if(type_x != NCL_double) {
tmp_x = (double *)calloc(nx,sizeof(double));
if(tmp_x == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_avg_wgt: Unable to allocate memory for coercing input array to double");
return(NhlFATAL);
}
}
else {
type_xavg = NCL_double;
}
/*
* Allocate space for tmp_w.
*/
tmp_w = coerce_input_double(w,type_w,nx,0,NULL,NULL);
if(tmp_w == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_avg_wgt: Unable to allocate memory for coercing input array to double");
return(NhlFATAL);
}
/*
* Allocate space for output array.
*/
if(type_xavg != NCL_double) {
xavg = (void *)calloc(size_output, sizeof(float));
}
else {
xavg = (void *)calloc(size_output, sizeof(double));
}
if(xavg == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_avg_wgt: Unable to allocate memory for output array");
return(NhlFATAL);
}
/*
* Allocate space for output dimension sizes and set them.
*/
ndims_xavg = max(ndims_leftmost,1);
dsizes_xavg = (ng_size_t*)calloc(ndims_xavg,sizeof(ng_size_t));
if( dsizes_xavg == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_avg_wgt: Unable to allocate memory for holding dimension sizes");
return(NhlFATAL);
}
if(ndims_leftmost > 0) {
for(i = 0; i < ndims_leftmost; i++) dsizes_xavg[i] = dsizes_x[i];
}
else {
dsizes_xavg[0] = 1;
}
/*
* Loop across leftmost dimensions and call the Fortran routine for each
* one-dimensional subsection.
*/
index_x = 0;
for(i = 0; i < size_output; i++) {
/*
* Coerce subsection of x (tmp_x) to double if necessary.
*/
if(type_x != NCL_double) {
coerce_subset_input_double(x,tmp_x,index_x,type_x,nx,0,NULL,NULL);
}
else {
tmp_x = &((double*)x)[index_x];
}
/*
* Call the Fortran routine.
*/
NGCALLF(dimavgwgt,DIMAVGWGT)(&inx, tmp_x, &missing_dbl_x.doubleval,
tmp_w, opt, &tmp_xavg[0]);
/*
* Coerce output back to float or double.
*/
coerce_output_float_or_double(xavg,&tmp_xavg[0],type_x,1,i);
index_x += nx;
}
/*
* Free unneeded memory.
*/
if(type_x != NCL_double) NclFree(tmp_x);
if(type_w != NCL_double) NclFree(tmp_w);
/*
* Return value back to NCL script.
*/
if(has_missing_x) {
if(type_xavg == NCL_double) {
ret = NclReturnValue(xavg,ndims_xavg,dsizes_xavg,&missing_dbl_x,
type_xavg,0);
}
else {
ret = NclReturnValue(xavg,ndims_xavg,dsizes_xavg,&missing_flt_x,
type_xavg,0);
}
}
else {
ret = NclReturnValue(xavg,ndims_xavg,dsizes_xavg,NULL,type_xavg,0);
}
NclFree(dsizes_xavg);
return(ret);
}
NhlErrorTypes linint1_W( void )
{
/*
* Input variables
*/
void *xi, *fi, *xo;
double *tmp_xi = NULL;
double *tmp_fi = NULL;
double *tmp_xo, *tmp_fo;
int ndims_xi;
int ndims_fi;
ng_size_t dsizes_xi[NCL_MAX_DIMENSIONS];
ng_size_t dsizes_xo[NCL_MAX_DIMENSIONS];
ng_size_t dsizes_fi[NCL_MAX_DIMENSIONS];
int has_missing_fi;
ng_size_t *dsizes_fo;
NclScalar missing_fi, missing_dfi, missing_rfi, missing_fo;
int *opt, iopt = 0;
logical *wrap;
NclBasicDataTypes type_xi, type_fi, type_xo, type_fo;
/*
* Output variables.
*/
void *fo;
/*
* Other variables
*/
ng_size_t nxi, nxi2, nxo, nfo, size_leftmost, size_fo;
int inxi, inxi2, inxo, ier, ret;
ng_size_t i, j, index_xi, index_fi, index_fo;
double *xiw, *fxiw;
/*
* Retrieve parameters
*
* Note that any of the pointer parameters can be set to NULL,
* which implies you don't care about its value.
*/
xi = (void*)NclGetArgValue(
0,
5,
&ndims_xi,
dsizes_xi,
NULL,
NULL,
&type_xi,
DONT_CARE);
fi = (void*)NclGetArgValue(
1,
5,
&ndims_fi,
dsizes_fi,
&missing_fi,
&has_missing_fi,
&type_fi,
DONT_CARE);
wrap = (logical*)NclGetArgValue(
2,
5,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
xo = (void*)NclGetArgValue(
3,
5,
NULL,
dsizes_xo,
NULL,
NULL,
&type_xo,
DONT_CARE);
opt = (int*)NclGetArgValue(
4,
5,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Compute the total number of elements in our arrays and check them.
*/
nxi = dsizes_xi[ndims_xi-1];
nxo = dsizes_xo[0];
nfo = nxo;
nxi2 = nxi + 2;
if(nxi < 2) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1: xi must have at least 2 elements");
return(NhlFATAL);
}
/*
* Test dimension sizes.
*/
if((nxi > INT_MAX) || (nxo > INT_MAX) || (nxi2 > INT_MAX)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1: one or more dimension sizes is greater than INT_MAX");
return(NhlFATAL);
}
inxi = (int) nxi;
inxo = (int) nxo;
inxi2 = (int) nxi2;
/*
* Check dimensions of xi and fi. If xi is not one-dimensional, then it
* must be the same size as fi. Otherwise, the rightmost dimension of
* fi must be equal to the length of xi.
*/
if(ndims_xi > 1) {
if(ndims_xi != ndims_fi) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1: If xi is not one-dimensional, then it must be the same size as fi");
return(NhlFATAL);
}
for(i = 0; i < ndims_fi; i++) {
if(dsizes_xi[i] != dsizes_fi[i]) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1: If xi is not one-dimensional, then it must be the same size as fi");
return(NhlFATAL);
}
}
}
else {
if(dsizes_fi[ndims_fi-1] != nxi) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1: The rightmost dimension of fi must be the same length as xi");
return(NhlFATAL);
}
}
/*
* Compute the total size of the output array (minus the last dimension).
*/
size_leftmost = 1;
for( i = 0; i < ndims_fi-1; i++ ) size_leftmost *= dsizes_fi[i];
size_fo = size_leftmost * nfo;
/*
* Coerce missing values.
*/
coerce_missing(type_fi,has_missing_fi,&missing_fi,&missing_dfi,
&missing_rfi);
/*
* Allocate space for temporary output array.
*/
tmp_fo = (double*)calloc(nfo,sizeof(double));
if(tmp_fo == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1: Unable to allocate memory for temporary arrays");
return(NhlFATAL);
}
/*
* Allocate space for output array.
*/
dsizes_fo = (ng_size_t*)calloc(ndims_fi,sizeof(ng_size_t));
if(type_fi == NCL_double) {
fo = (void*)calloc(size_fo,sizeof(double));
type_fo = NCL_double;
missing_fo = missing_dfi;
}
else {
fo = (void*)calloc(size_fo,sizeof(float));
type_fo = NCL_float;
missing_fo = missing_rfi;
}
if(fo == NULL || dsizes_fo == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1: Unable to allocate memory for output array");
return(NhlFATAL);
}
for(i = 0; i < ndims_fi-1; i++) dsizes_fo[i] = dsizes_fi[i];
dsizes_fo[ndims_fi-1] = nxo;
/*
* Allocate space for work arrays.
*/
xiw = (double*)calloc(nxi2,sizeof(double));
fxiw = (double*)calloc(nxi2,sizeof(double));
if(xiw == NULL || fxiw == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1: Unable to allocate memory for work arrays");
return(NhlFATAL);
}
/*
* Coerce output array to double if necessary.
*/
tmp_xo = coerce_input_double(xo,type_xo,nxo,0,NULL,NULL);
if(tmp_xo == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1: Unable to coerce output array to double precision");
return(NhlFATAL);
}
if(type_xi != NCL_double) {
tmp_xi = (double*)calloc(nxi,sizeof(double));
if(tmp_xi == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1: Unable to allocate memory for coercing input array to double precision");
return(NhlFATAL);
}
}
if(type_fi != NCL_double) {
tmp_fi = (double*)calloc(nxi,sizeof(double));
if(tmp_fi == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1: Unable to allocate memory for coercing input array to double precision");
return(NhlFATAL);
}
}
/*
* Call Fortran function.
*/
index_xi = index_fi = index_fo = 0;
for( i = 0; i < size_leftmost; i++ ) {
if(ndims_xi > 1 || i == 0) {
if(type_xi != NCL_double) {
coerce_subset_input_double(xi,tmp_xi,index_xi,type_xi,nxi,0,NULL,NULL);
}
else {
tmp_xi = &((double*)xi)[index_xi];
}
}
if(type_fi != NCL_double) {
coerce_subset_input_double(fi,tmp_fi,index_fi,type_fi,nxi,0,NULL,NULL);
}
else {
tmp_fi = &((double*)fi)[index_fi];
}
NGCALLF(dlinint1,DLININT1)(&inxi,tmp_xi,tmp_fi,wrap,&inxo,tmp_xo,tmp_fo,
xiw,fxiw,&inxi2,&missing_dfi.doubleval,
&iopt,&ier);
if(ier) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"linint1: xi and xo must be monotonically increasing");
for(j = 0; j < nfo; j++) {
if(type_fi == NCL_double) {
((double*)fo)[index_fo+j] = missing_dfi.doubleval;
}
else {
((float*)fo)[index_fo+j] = missing_rfi.floatval;
}
}
}
else {
coerce_output_float_or_double(fo,tmp_fo,type_fi,nfo,index_fo);
}
if(ndims_xi > 1) index_xi += nxi;
index_fi += nxi;
index_fo += nfo;
}
/*
* Free temp arrays.
*/
if(type_xi != NCL_double) NclFree(tmp_xi);
if(type_xo != NCL_double) NclFree(tmp_xo);
if(type_fi != NCL_double) NclFree(tmp_fi);
NclFree(tmp_fo);
NclFree(xiw);
NclFree(fxiw);
ret = NclReturnValue(fo,ndims_fi,dsizes_fo,&missing_fo,type_fo,0);
NclFree(dsizes_fo);
return(ret);
}
NhlErrorTypes linint2_points_W( void )
{
/*
* Input variables
*/
void *xi, *yi, *fi, *xo, *yo;
double *tmp_xi = NULL;
double *tmp_yi = NULL;
double *tmp_fi = NULL;
double *tmp_xo, *tmp_yo, *tmp_fo;
int ndims_xi;
ng_size_t dsizes_xi[NCL_MAX_DIMENSIONS];
int ndims_yi;
ng_size_t dsizes_yi[NCL_MAX_DIMENSIONS];
ng_size_t dsizes_xo[NCL_MAX_DIMENSIONS], dsizes_yo[NCL_MAX_DIMENSIONS];
int ndims_fi;
ng_size_t dsizes_fi[NCL_MAX_DIMENSIONS];
int has_missing_fi;
ng_size_t *dsizes_fo;
NclScalar missing_fi, missing_dfi, missing_rfi;
int *opt;
logical *wrap;
NclBasicDataTypes type_xi, type_yi, type_fi, type_xo, type_yo;
/*
* Output variables.
*/
void *fo;
/*
* Other variables
*/
double *xiw, *fxiw;
ng_size_t nxi, nxi2, nyi, nfi, nxyo, size_leftmost, size_fo;
ng_size_t i, j, index_xi, index_yi, index_fi, index_fo;
int inxi, inxi2, inyi, inxyo, ier, ret;
/*
* Retrieve parameters
*
* Note that any of the pointer parameters can be set to NULL,
* which implies you don't care about its value.
*/
xi = (void*)NclGetArgValue(
0,
7,
&ndims_xi,
dsizes_xi,
NULL,
NULL,
&type_xi,
DONT_CARE);
yi = (void*)NclGetArgValue(
1,
7,
&ndims_yi,
dsizes_yi,
NULL,
NULL,
&type_yi,
DONT_CARE);
fi = (void*)NclGetArgValue(
2,
7,
&ndims_fi,
dsizes_fi,
&missing_fi,
&has_missing_fi,
&type_fi,
DONT_CARE);
wrap = (logical*)NclGetArgValue(
3,
7,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
xo = (void*)NclGetArgValue(
4,
7,
NULL,
dsizes_xo,
NULL,
NULL,
&type_xo,
DONT_CARE);
yo = (void*)NclGetArgValue(
5,
7,
NULL,
dsizes_yo,
NULL,
NULL,
&type_yo,
DONT_CARE);
opt = (int*)NclGetArgValue(
6,
7,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Compute the total number of elements in our arrays.
*/
nxi = dsizes_xi[ndims_xi-1];
nyi = dsizes_yi[ndims_yi-1];
nxyo = dsizes_xo[0];
nxi2 = nxi+2;
if(dsizes_yo[0] != nxyo) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint2_points: xo and yo must be the same length");
return(NhlFATAL);
}
if(nxi < 2 || nyi < 2) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint2_points: xi and yi must both have at least two elements");
return(NhlFATAL);
}
nfi = nxi * nyi;
/*
* Test dimension sizes.
*/
if((nxi > INT_MAX) || (nyi > INT_MAX) || (nxyo > INT_MAX) ||
(nxi2 > INT_MAX)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint2_points: one or more dimension sizes is greater than INT_MAX");
return(NhlFATAL);
}
inxi = (int) nxi;
inyi = (int) nyi;
inxyo = (int) nxyo;
inxi2 = (int) nxi2;
/*
* Check dimensions of xi, yi, and fi. If xi/yi are not one-dimensional,
* then their leftmost dimensions must be the same size as the leftmost
* dimensions of fi. The last two dimensions of fi must be nyi x nxi.
*/
if(ndims_xi > 1) {
if(ndims_xi != ndims_fi-1) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint2_points: If xi is not one-dimensional, then it must have one less dimension than fi");
return(NhlFATAL);
}
for(i = 0; i < ndims_xi-1; i++) {
if(dsizes_xi[i] != dsizes_fi[i]) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint2_points: If xi is not one-dimensional, then its leftmost dimensions must be the same as the leftmost dimensions of fi");
return(NhlFATAL);
}
}
}
if(ndims_yi > 1) {
if(ndims_yi != ndims_fi-1) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint2_points: If yi is not one-dimensional, then it must have one less dimension than fi");
return(NhlFATAL);
}
for(i = 0; i < ndims_yi-1; i++) {
if(dsizes_yi[i] != dsizes_fi[i]) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint2_points: If yi is not one-dimensional, then its leftmost dimensions must be the same as the leftmost dimensions of fi");
return(NhlFATAL);
}
}
}
if(dsizes_fi[ndims_fi-2] != nyi || dsizes_fi[ndims_fi-1] != nxi) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint2_points: The rightmost dimensions of fi must be nyi x nxi, where nyi and nxi are the lengths of yi and xi respectively");
return(NhlFATAL);
}
/*
* Compute the total size of the output array (minus the last two dimensions).
*/
size_leftmost = 1;
for( i = 0; i < ndims_fi-2; i++ ) size_leftmost *= dsizes_fi[i];
size_fo = size_leftmost * nxyo;
/*
* Coerce missing values.
*/
coerce_missing(type_fi,has_missing_fi,&missing_fi,&missing_dfi,
&missing_rfi);
/*
* Allocate space for temporary output array.
*/
tmp_fo = (double*)calloc(nxyo,sizeof(double));
if(tmp_fo == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint2_points: Unable to allocate memory for temporary arrays");
return(NhlFATAL);
}
/*
* Allocate space for output array.
*/
dsizes_fo = (ng_size_t*)calloc(ndims_fi-1,sizeof(ng_size_t));
if(type_fi == NCL_double) {
fo = (void*)calloc(size_fo,sizeof(double));
}
else {
fo = (void*)calloc(size_fo,sizeof(float));
}
if(fo == NULL || dsizes_fo == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint2_points: Unable to allocate memory for output array");
return(NhlFATAL);
}
for(i = 0; i < ndims_fi-2; i++) dsizes_fo[i] = dsizes_fi[i];
dsizes_fo[ndims_fi-2] = nxyo;
/*
* Allocate space for work arrays.
*/
xiw = (double*)calloc(nxi2,sizeof(double));
fxiw = (double*)calloc(nyi*nxi2,sizeof(double));
if(xiw == NULL || fxiw == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint2_points: Unable to allocate memory for work arrays");
return(NhlFATAL);
}
/*
* Coerce input arrays to double if necessary.
*/
if(type_xi != NCL_double) {
tmp_xi = (double*)calloc(nxi,sizeof(double));
if(tmp_xi == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint2_points: Unable to allocate memory for coercing xi to double precision");
return(NhlFATAL);
}
}
if(type_yi != NCL_double) {
tmp_yi = (double*)calloc(nyi,sizeof(double));
if(tmp_yi == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint2_points: Unable to allocate memory for coercing yi to double precision");
return(NhlFATAL);
}
}
tmp_xo = coerce_input_double(xo,type_xo,nxyo,0,NULL,NULL);
tmp_yo = coerce_input_double(yo,type_yo,nxyo,0,NULL,NULL);
if(tmp_xo == NULL || tmp_yo == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint2_points: Unable to coerce input to double precision");
return(NhlFATAL);
}
if(type_fi != NCL_double) {
tmp_fi = (double*)calloc(nfi,sizeof(double));
if(tmp_fi == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint2_points: Unable to allocate memory for coercing input array to double precision");
return(NhlFATAL);
}
}
/*
* Call Fortran function.
*/
index_xi = index_yi = index_fi = index_fo = 0;
for( i = 0; i < size_leftmost; i++ ) {
if(ndims_xi > 1 || i == 0) {
if(type_xi != NCL_double) {
coerce_subset_input_double(xi,tmp_xi,index_xi,type_xi,nxi,0,NULL,NULL);
}
else {
tmp_xi = &((double*)xi)[index_xi];
}
}
if(ndims_yi > 1 || i == 0) {
if(type_yi != NCL_double) {
coerce_subset_input_double(yi,tmp_yi,index_yi,type_yi,nyi,0,NULL,NULL);
}
else {
tmp_yi = &((double*)yi)[index_yi];
}
}
if(type_fi != NCL_double) {
coerce_subset_input_double(fi,tmp_fi,index_fi,type_fi,nfi,0,NULL,NULL);
}
else {
tmp_fi = &((double*)fi)[index_fi];
}
NGCALLF(dlinint2pts,DLININT2PTS)(&inxi,tmp_xi,&inyi,tmp_yi,tmp_fi,wrap,
&inxyo,tmp_xo,tmp_yo,tmp_fo,xiw,fxiw,
&inxi2,&missing_dfi.doubleval,&ier);
if(ier) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"linint2_points: xi and yi must be monotonically increasing");
for(j = 0; j < nxyo; j++) {
if(type_fi == NCL_double) {
((double*)fo)[index_fo+j] = missing_dfi.doubleval;
}
else {
((float*)fo)[index_fo+j] = missing_rfi.floatval;
}
}
}
else {
coerce_output_float_or_double(fo,tmp_fo,type_fi,nxyo,index_fo);
}
if(ndims_xi > 1) index_xi += nxi;
if(ndims_yi > 1) index_yi += nyi;
index_fi += nfi;
index_fo += nxyo;
}
/*
* Free temp arrays.
*/
if(type_xi != NCL_double) NclFree(tmp_xi);
if(type_yi != NCL_double) NclFree(tmp_yi);
if(type_xo != NCL_double) NclFree(tmp_xo);
if(type_yo != NCL_double) NclFree(tmp_yo);
if(type_fi != NCL_double) NclFree(tmp_fi);
NclFree(tmp_fo);
NclFree(xiw);
NclFree(fxiw);
if(type_fi == NCL_double) {
/*
* Return double values with missing value set.
*/
ret = NclReturnValue(fo,ndims_fi-1,dsizes_fo,&missing_dfi,NCL_double,0);
}
else {
/*
* Return float values with missing value set.
*/
ret = NclReturnValue(fo,ndims_fi-1,dsizes_fo,&missing_rfi,NCL_float,0);
}
NclFree(dsizes_fo);
return(ret);
}
NhlErrorTypes bw_bandpass_filter_W( void )
{
/*
* Input variables
*/
/*
* Argument # 0
*/
void *xr;
double *tmp_xr;
int ndims_xr;
ng_size_t dsizes_xr[NCL_MAX_DIMENSIONS];
NclBasicDataTypes type_xr;
/*
* Argument # 1
*/
void *fca;
double *tmp_fca;
NclBasicDataTypes type_fca;
/*
* Argument # 2
*/
void *fcb;
double *tmp_fcb;
NclBasicDataTypes type_fcb;
/*
* Argument # 3
*/
logical *opt;
/*
* Argument # 4
*/
int *dims;
ng_size_t ndims;
/*
* Return variable
*/
void *bf;
int ndims_bf;
double *tmp_yr, *tmp_er;
ng_size_t *dsizes_bf;
NclBasicDataTypes type_bf;
/*
* Variables for retrieving attributes from "opt".
*/
NclAttList *attr_list;
NclAtt attr_obj;
NclStackEntry stack_entry;
logical set_dt = False, rmv_mean = True, ret_filt = True, ret_env = False;
int m=6, iflag;
void *dt;
double *tmp_dt;
NclBasicDataTypes type_dt;
/*
* Various
*/
ng_size_t i, nx, total_nl, total_nr, nrnx;
ng_size_t index_xr, index_nrx, size_xr, size_output;
int j, inx, ret, ier;
/*
* Retrieve parameters.
*
* Note any of the pointer parameters can be set to NULL, which
* implies you don't care about its value.
*/
/*
* Get argument # 0
*/
xr = (void*)NclGetArgValue(
0,
5,
&ndims_xr,
dsizes_xr,
NULL,
NULL,
&type_xr,
DONT_CARE);
/*
* Get argument # 1
*/
fca = (void*)NclGetArgValue(
1,
5,
NULL,
NULL,
NULL,
NULL,
&type_fca,
DONT_CARE);
/*
* Get argument # 2
*/
fcb = (void*)NclGetArgValue(
2,
5,
NULL,
NULL,
NULL,
NULL,
&type_fcb,
DONT_CARE);
/*
* Get argument # 3
*/
opt = (logical*)NclGetArgValue(
3,
5,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Get argument # 4
*/
dims = (int *)NclGetArgValue(4,5,NULL,&ndims,NULL,NULL,NULL,0);
/*
* Some error checking. Make sure input dimension is valid.
*/
if(ndims > ndims_xr) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"bw_bandpass_filter: too many dimensions in dimension argument, can't continue");
return(NhlFATAL);
}
for(i = 0; i < ndims; i++ ) {
if(dims[i] < 0 || dims[i] >= ndims_xr) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"bw_bandpass_filter: Invalid dimension argument, can't continue");
return(NhlFATAL);
}
if(i > 0 && dims[i] != (dims[i-1]+1)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"bw_bandpass_filter: Input dimension sizes must be monotonically increasing, can't continue");
return(NhlFATAL);
}
}
/*
* Check for attributes attached to "opt"
*
* "m" - 6
* "dt" - 1.0
* "remove_mean" - True
* "return_filtered" - True
* "return_envelope" - False
*/
if(*opt) {
stack_entry = _NclGetArg(3, 5, DONT_CARE);
switch (stack_entry.kind) {
case NclStk_VAR:
if (stack_entry.u.data_var->var.att_id != -1) {
attr_obj = (NclAtt) _NclGetObj(stack_entry.u.data_var->var.att_id);
if (attr_obj == NULL) {
break;
}
}
else {
/*
* att_id == -1 ==> no optional args given.
*/
break;
}
/*
* Get optional arguments.
*/
if (attr_obj->att.n_atts > 0) {
/*
* Get list of attributes.
*/
attr_list = attr_obj->att.att_list;
/*
* Loop through attributes and check them.
*/
while (attr_list != NULL) {
if(!strcasecmp(attr_list->attname, "remove_mean")) {
rmv_mean = *(logical *) attr_list->attvalue->multidval.val;
}
else if(!strcasecmp(attr_list->attname, "return_filtered")) {
ret_filt = *(logical *) attr_list->attvalue->multidval.val;
}
else if(!strcasecmp(attr_list->attname, "return_envelope")) {
ret_env = *(logical *) attr_list->attvalue->multidval.val;
}
else if(!strcasecmp(attr_list->attname, "dt")) {
dt = attr_list->attvalue->multidval.val;
type_dt = attr_list->attvalue->multidval.data_type;
set_dt = True;
}
else if(!strcasecmp(attr_list->attname, "m")) {
m = *(int *) attr_list->attvalue->multidval.val;
}
attr_list = attr_list->next;
}
default:
break;
}
}
}
/*
* Provide default for dt if not specified by user.
*/
if(set_dt) {
tmp_dt = coerce_input_double(dt,type_dt,1,0,NULL,NULL);
}
else {
type_dt = NCL_double;
tmp_dt = (double *)calloc(1,sizeof(double));
*tmp_dt = 1.0;
}
if(!ret_filt && !ret_env) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"bw_bandpass_filter: both return_filtered and return_envelope are False. One of these must be True");
return(NhlFATAL);
}
/*
* Calculate size and dimension sizes of output array.
*
* If both ret_filt and ret_env are True, then the
* return array will be 2 x k x ...
* Otherwise it will be k x ...
*
*/
if(ret_filt && ret_env) ndims_bf = ndims_xr + 1;
else ndims_bf = ndims_xr;
dsizes_bf = (ng_size_t*)calloc(ndims_bf,sizeof(ng_size_t));
if( dsizes_bf == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"bw_bandpass_filter: Unable to allocate memory for holding dimension sizes");
return(NhlFATAL);
}
if(ret_filt && ret_env) dsizes_bf[0] = 2;
for(i = 0; i < ndims_xr; i++)
dsizes_bf[i+(ndims_bf-ndims_xr)] = dsizes_xr[i];
/*
* Calculate number of leftmost, rightmost, and middle elements.
*/
nx = total_nl = total_nr = 1;
for(i = 0; i < ndims ; i++) nx = nx*dsizes_xr[dims[i]];
for(i = 0; i < dims[0]; i++) total_nl *= dsizes_xr[i];
for(i = dims[ndims-1]+1; i < ndims_xr; i++) total_nr *= dsizes_xr[i];
/*
* Calculate xr and output sizes.
*/
size_xr = total_nr * total_nl * nx;
if(ret_filt && ret_env) size_output = size_xr * 2;
else size_output = size_xr;
if(nx > INT_MAX) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"bw_bandpass_filter: nx = %ld is greater than INT_MAX", nx);
return(NhlFATAL);
}
inx = (int) nx;
/*
* Coerce fca, fcb to double, if needed.
*/
tmp_fca = coerce_input_double(fca,type_fca,1,0,NULL,NULL);
tmp_fcb = coerce_input_double(fcb,type_fcb,1,0,NULL,NULL);
if(tmp_fca == NULL || tmp_fcb == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"bw_bandpass_filter: Unable to allocate memory for coercing input scalars to double");
return(NhlFATAL);
}
/*
* Allocate space for input array no matter what, because it
* may not be contiguous in memory.
*/
tmp_xr = (double *)calloc(nx,sizeof(double));
if(tmp_xr == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"bw_bandpass_filter: Unable to allocate memory for coercing input array to double");
return(NhlFATAL);
}
/*
* Return type.
*/
if(type_xr != NCL_double) type_bf = NCL_float;
else type_bf = NCL_double;
/*
* Allocate space for output array.
*/
if(type_bf != NCL_double) bf = (void *)calloc(size_output, sizeof(float));
else bf = (void *)calloc(size_output, sizeof(double));
if(bf == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"bw_bandpass_filter: Unable to allocate memory for output array");
return(NhlFATAL);
}
/*
* Allocate space for subset of output array.
*/
tmp_yr = (double *)calloc(nx, sizeof(double));
tmp_er = (double *)calloc(nx, sizeof(double));
if(tmp_yr == NULL || tmp_er == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"bw_bandpass_filter: Unable to allocate memory for temporary output arrays");
return(NhlFATAL);
}
/*
* Loop across leftmost/rightmost dimensions and call
* the Fortran routine for each subsection of the
* input arrays.
*/
nrnx = total_nr * nx;
if(rmv_mean) iflag = 1;
else iflag = 0;
for(i = 0; i < total_nl; i++) {
index_nrx = i*nrnx;
for(j = 0; j < total_nr; j++) {
index_xr = index_nrx + j;
/*
* Coerce subsection of x (tmp_xr) to double if necessary.
*/
coerce_subset_input_double_step(xr,tmp_xr,index_xr,total_nr,type_xr,
nx,0,NULL,NULL);
/*
* Call the Fortran routine.
*/
NGCALLF(buttfilt,BUTTFILT)(tmp_xr, tmp_yr, tmp_er, tmp_fca, tmp_fcb,
tmp_dt, &m, &inx, &iflag, &ier);
/*
* Copy/coerce back to output array
*/
if(ret_filt && !ret_env) {
coerce_output_float_or_double_step(bf,tmp_yr,type_bf,nx,
index_xr,total_nr);
}
else if(!ret_filt && ret_env) {
coerce_output_float_or_double_step(bf,tmp_er,type_bf,nx,
index_xr,total_nr);
}
else {
coerce_output_float_or_double_step(bf,tmp_yr,type_bf,nx,
index_xr,total_nr);
coerce_output_float_or_double_step(bf,tmp_er,type_bf,nx,
index_xr+size_xr,total_nr);
}
}
}
/*
* Free unneeded memory.
*/
NclFree(tmp_xr);
NclFree(tmp_er);
NclFree(tmp_yr);
if(type_fca != NCL_double) NclFree(tmp_fca);
if(type_fcb != NCL_double) NclFree(tmp_fcb);
if(!set_dt || type_dt != NCL_double) NclFree(tmp_dt);
/*
* Return value back to NCL script.
*/
ret = NclReturnValue(bf,ndims_bf,dsizes_bf,NULL,type_bf,0);
NclFree(dsizes_bf);
return(ret);
}
NhlErrorTypes dim_spi_n_W( void )
{
/*
* Input variables
*/
/*
* Argument # 0
*/
void *x;
double *tmp_x;
int ndims_x;
ng_size_t dsizes_x[NCL_MAX_DIMENSIONS];
int has_missing_x;
NclScalar missing_x, missing_flt_x, missing_dbl_x;
NclBasicDataTypes type_x;
/*
* Argument # 1
*/
int *nrun;
/*
* Argument # 2
*/
logical *opt;
/*
* Variables for retrieving attributes from "opt".
*/
NclAttList *attr_list;
NclAtt attr_obj;
NclStackEntry stack_entry;
int spi_type=0;
/*
* Argument # 3
*/
int *dims;
ng_size_t dsizes_dims;
/*
* Return variable
*/
void *spi;
double *tmp_spi;
NclScalar missing_spi;
NclBasicDataTypes type_spi;
/*
* Various
*/
ng_size_t ntim;
int intim, max_years, max_years_p1, ier, ret;
ng_size_t index_x, index_nrx;
ng_size_t i, j, nrnx, total_nr, total_nl, size_output;
/*
* Various work arrays for spi_type=3 case .
*/
double *probne, *pcpacc, *spi3_y, *spi3_x, *tmparr, *dindex;
/*
* Retrieve parameters.
*
* Note any of the pointer parameters can be set to NULL, which
* implies you don't care about its value.
*/
/*
* Get argument # 0
*/
x = (void*)NclGetArgValue(
0,
4,
&ndims_x,
dsizes_x,
&missing_x,
&has_missing_x,
&type_x,
DONT_CARE);
/*
* Get argument # 1
*/
nrun = (int*)NclGetArgValue(
1,
4,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Get argument # 2
*/
opt = (logical*)NclGetArgValue(
2,
4,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Check for attributes attached to "opt"
*
* "spi_type" 0
*/
if(*opt) {
stack_entry = _NclGetArg(2, 4, DONT_CARE);
switch (stack_entry.kind) {
case NclStk_VAR:
if (stack_entry.u.data_var->var.att_id != -1) {
attr_obj = (NclAtt) _NclGetObj(stack_entry.u.data_var->var.att_id);
if (attr_obj == NULL) {
break;
}
}
else {
/*
* att_id == -1 ==> no optional args given.
*/
break;
}
/*
* Get optional arguments.
*/
if (attr_obj->att.n_atts > 0) {
/*
* Get list of attributes.
*/
attr_list = attr_obj->att.att_list;
/*
* Loop through attributes and check them.
*/
while (attr_list != NULL) {
if(!strcasecmp(attr_list->attname, "spi_type")) {
spi_type = *(int *) attr_list->attvalue->multidval.val;
}
attr_list = attr_list->next;
}
default:
break;
}
}
}
if(spi_type != 0 && spi_type != 3) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_spi_n: spi_type can only be 0 (default) or 3 (Pearson type III distribution");
return(NhlFATAL);
}
/*
* Coerce missing value to double if necessary.
*/
coerce_missing(type_x,has_missing_x,&missing_x,
&missing_dbl_x,&missing_flt_x);
/*
* Get dimension(s) to do computation on.
*/
dims = (int*)NclGetArgValue(
3,
4,
NULL,
&dsizes_dims,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Some error checking. Make sure input dimensions are valid.
*/
for(i = 0; i < dsizes_dims; i++ ) {
if(dims[i] < 0 || dims[i] >= ndims_x) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_spi_n: Invalid dimension sizes to do calculations across, can't continue");
return(NhlFATAL);
}
if(i > 0 && dims[i] != (dims[i-1]+1)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_spi_n: Input dimension sizes must be monotonically increasing, can't continue");
return(NhlFATAL);
}
}
/*
* Calculate size of leftmost dimensions (nl) up to the dims[0]-th
* dimensions.
*
* Calculate number of points that will be passed to Fortran
* routine (ntim).
*
* Calculate size of rightmost dimensions (nr) from the
* ndims[ndims-1]-th dimension.
*
* The dimension(s) to do the calculations across are "dims".
*/
total_nl = total_nr = ntim = 1;
if(ndims_x > 1) {
for(i = 0; i < dims[0] ; i++) {
total_nl = total_nl*dsizes_x[i];
}
for(i = 0; i < dsizes_dims ; i++) {
ntim = ntim*dsizes_x[dims[i]];
}
for(i = dims[dsizes_dims-1]+1; i < ndims_x; i++) {
total_nr = total_nr*dsizes_x[i];
}
} else {
ntim = dsizes_x[dims[0]];
}
size_output = total_nl * ntim * total_nr;
if( ntim > INT_MAX) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_spi_n: ntim is greater than INT_MAX");
return(NhlFATAL);
}
intim = (int) ntim;
/*
* Allocate space for tmp_x and tmp_index.
*/
tmp_x = (double *)calloc(ntim,sizeof(double));
if(tmp_x == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_spi_n: Unable to allocate memory for coercing input array to double");
return(NhlFATAL);
}
/*
* Allocate space for output array.
*/
tmp_spi = (double *)calloc(ntim, sizeof(double));
if(type_x != NCL_double) {
type_spi = NCL_float;
spi = (void *)calloc(size_output, sizeof(float));
}
else {
type_spi = NCL_double;
spi = (void *)calloc(size_output, sizeof(double));
}
if(tmp_spi == NULL || spi == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_spi_n: Unable to allocate memory for output array");
return(NhlFATAL);
}
if(has_missing_x) {
if(type_spi == NCL_double) missing_spi = missing_dbl_x;
else missing_spi = missing_flt_x;
}
/*
* As of NCL V6.3.0, if spi_type == 3, the SPI will be calculated
* using the Pearson type III distribution. The Fortran routine
* for this requires a bunch of work arrays.
*/
if(spi_type == 3) {
if(ntim % 12) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_spi_n: if opt@spi_type= 3, then ntim must be divisable by 12");
return(NhlFATAL);
}
max_years = intim / 12;
max_years_p1 = max_years+1;
probne = (double *)calloc(ntim, sizeof(double));
pcpacc = (double *)calloc(ntim, sizeof(double));
dindex = (double *)calloc(ntim, sizeof(double));
spi3_y = (double *)calloc(ntim, sizeof(double));
spi3_x = (double *)calloc(max_years, sizeof(double));
tmparr = (double *)calloc(max_years_p1, sizeof(double));
if(probne == NULL || pcpacc == NULL || dindex == NULL ||
spi3_y == NULL || spi3_x == NULL || tmparr == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_spi_n: Unable to allocate memory for temporary work arrays");
return(NhlFATAL);
}
}
/*
* Loop across leftmost dimensions and call the Fortran routine for each
* subsection of the input arrays.
*/
nrnx = total_nr * ntim;
for(i = 0; i < total_nl; i++) {
index_nrx = i*nrnx;
for(j = 0; j < total_nr; j++) {
index_x = index_nrx + j;
/*
* Coerce subsection of x (tmp_x) to double.
*/
coerce_subset_input_double_step(x,tmp_x,index_x,total_nr,type_x,
ntim,0,NULL,NULL);
/*
* Call the Fortran routine.
*/
if(spi_type == 0) {
NGCALLF(spigamd,SPIGAMD)(&intim, tmp_x, &missing_dbl_x.doubleval,
nrun, tmp_spi);
}
else if(spi_type == 3) {
NGCALLF(spi3ncdc, SPI3NCDC)(&intim,tmp_x,&missing_dbl_x.doubleval,
nrun,tmp_spi,probne,pcpacc,dindex,
spi3_y, spi3_x, tmparr,&max_years,
&max_years_p1,&ier);
}
/*
* Coerce output back to float or double
*/
coerce_output_float_or_double_step(spi,tmp_spi,type_spi,ntim,
index_x,total_nr);
}
}
/*
* Free unneeded memory.
*/
NclFree(tmp_x);
NclFree(tmp_spi);
if(spi_type == 3) {
NclFree(probne);
NclFree(pcpacc);
NclFree(dindex);
NclFree(spi3_y);
NclFree(spi3_x);
NclFree(tmparr);
}
/*
* Return value back to NCL script.
*/
if(has_missing_x) {
ret = NclReturnValue(spi,ndims_x,dsizes_x,&missing_spi,type_spi,0);
}
else {
ret = NclReturnValue(spi,ndims_x,dsizes_x,NULL,type_spi,0);
}
return(ret);
}
NhlErrorTypes fft2db_W( void )
{
/*
* First and only input argument.
*/
void *coef;
double *tmp_coef, *tmp_r;
ng_size_t dsizes_coef[3];
NclBasicDataTypes type_coef;
/*
* Return variable
*/
void *x;
ng_size_t dsizes_x[2];
NclBasicDataTypes type_x;
NclObjClass type_obj_x;
/*
* Variables for retrieving attributes from input array.
*/
NclAttList *attr_list;
NclAtt attr_obj;
NclStackEntry stack_entry;
/*
* Various
*/
int ier;
ng_size_t l = 0;
ng_size_t i, j, m, ldim, l21, ml, mldim, ml21, lwsave, lwork;
ng_size_t ix0, ix1, ir0, ir1, ic0, ic1, size_coef;
logical calculate_lval;
double *wsave, *work;
int il, im, ildim, ilwsave, ilwork;
/*
* Retrieve input argument.
*
* Note any of the pointer parameters can be set to NULL, which
* implies you don't care about its value.
*/
coef = (void*)NclGetArgValue(
0,
1,
NULL,
dsizes_coef,
NULL,
NULL,
&type_coef,
DONT_CARE);
/*
* First dimension must be 2.
*/
if(dsizes_coef[0] != 2) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"fft2db: The first dimension of coef must be 2");
return(NhlFATAL);
}
/*
* Check if the N attribute is attached to the input array (there should
* also be an M attribute, but we don't need this).
*
* This will tell us the original size of the array passed to "fft2df".
* If N is not attached as an attribute, then we will just calculate N
* (which is "l" in the code below).
*/
calculate_lval = True;
stack_entry = _NclGetArg(0, 1, DONT_CARE);
switch (stack_entry.kind) {
case NclStk_VAR:
if (stack_entry.u.data_var->var.att_id != -1) {
attr_obj = (NclAtt) _NclGetObj(stack_entry.u.data_var->var.att_id);
if (attr_obj == NULL) {
break;
}
}
else {
/*
* att_id == -1 ==> no optional args given; will have to calculate "l".
*/
break;
}
/*
* Look for attributes.
*/
if (attr_obj->att.n_atts == 0) {
break;
}
else {
/*
* Get list of attributes.
*/
attr_list = attr_obj->att.att_list;
/*
* Loop through attributes and check them.
*/
while (attr_list != NULL) {
if ((strcmp(attr_list->attname, "N")) == 0) {
l = *(int *) attr_list->attvalue->multidval.val;
if (l > 0) {
calculate_lval = False;
}
}
attr_list = attr_list->next;
}
}
default:
break;
}
/*
* Allocate space for coercing input array. Since we have to copy
* the input array to a bigger array (tmp_r), we will go ahead and
* make a copy of it.
*/
m = dsizes_coef[1];
l21 = dsizes_coef[2];
if(calculate_lval) {
l = (l21-1) * 2;
NhlPError(NhlWARNING,NhlEUNKNOWN,"fft2db: 'N' was either not attached as an attribute to the input array, or it had an invalid value.\nThe size of the output array will have to be calculated based on the size of the input array.");
}
ldim = 2 * l21;
ml = m * l;
mldim = m * ldim;
ml21 = m * l21;
size_coef = 2 * ml21;
tmp_coef = (double *)calloc(size_coef, sizeof(double));
tmp_r = (double *)calloc(mldim, sizeof(double));
if(tmp_coef == NULL || tmp_r == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"fft2db: Unable to allocate memory for coercing input array to double");
return(NhlFATAL);
}
coerce_subset_input_double(coef,tmp_coef,0,type_coef,size_coef,0,NULL,NULL);
/*
* Copy tmp_coef array to a subset of tmp_r.
*/
for(i = 0; i < m; i++ ) {
for(j = 0; j < l21; j++ ) {
ic0 = i*l21 + j;
ic1 = ml21 + ic0;
ir0 = i*ldim + 2*j;
ir1 = ir0 + 1;
tmp_r[ir0] = tmp_coef[ic0];
tmp_r[ir1] = tmp_coef[ic1];
}
}
/*
* The output type defaults to float, unless the input array is double.
*/
if(type_coef != NCL_double) {
type_x = NCL_float;
type_obj_x = nclTypefloatClass;
}
else {
type_x = NCL_double;
type_obj_x = nclTypedoubleClass;
}
/*
* Calculate size of output array and allocate space for it.
*/
dsizes_x[0] = m;
dsizes_x[1] = l;
if(type_x != NCL_double) {
x = (void *)calloc(ml, sizeof(float));
}
else {
x = (void *)calloc(ml, sizeof(double));
}
if(x == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"fft2db: Unable to allocate memory for output array");
return(NhlFATAL);
}
/*
* Test dimension sizes.
*/
lwsave = 2*m + l + log(l) + log(m) + 8;
lwork = mldim;
if((l > INT_MAX) || (m > INT_MAX) || (ldim > INT_MAX) ||
(lwsave > INT_MAX) || (lwork > INT_MAX)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"fft2db: one or more input dimension sizes are greater than INT_MAX");
return(NhlFATAL);
}
il = (int) l;
im = (int) m;
ildim = (int) ldim;
ilwsave = (int) lwsave;
ilwork = (int) lwork;
/*
* Allocate space for work arrays.
*/
wsave = (double *)calloc(lwsave,sizeof(double));
work = (double *)calloc(lwork,sizeof(double));
if(work == NULL || wsave == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"fft2db: Unable to allocate memory for work arrays");
return(NhlFATAL);
}
/*
* Call the Fortran routines.
*/
ier = 0;
NGCALLF(drfft2i,DRFFT2I)(&il, &im, wsave, &ilwsave, &ier);
NGCALLF(drfft2b,DRFFT2B)(&ildim, &il, &im, tmp_r, wsave, &ilwsave, work,
&ilwork,&ier);
if(ier) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"fft2db: ier = %d", ier);
return(NhlFATAL);
}
/*
* Copy tmp_r back to the appropriate locations in coef.
*/
if(type_x == NCL_float) {
for(i = 0; i < m; i++ ) {
for(j = 0; j < l; j++ ) {
ix0 = i*l + j;
ix1 = i*ldim + j;
((float*)x)[ix0] = (float)tmp_r[ix1];
}
}
}
else {
for(i = 0; i < m; i++ ) {
for(j = 0; j < l; j++ ) {
ix0 = i*l + j;
ix1 = i*ldim + j;
((double*)x)[ix0] = tmp_r[ix1];
}
}
}
/*
* Free unneeded memory.
*/
NclFree(tmp_coef);
NclFree(tmp_r);
NclFree(wsave);
NclFree(work);
/*
* Return value back to NCL script.
*/
return(NclReturnValue(x,2,dsizes_x,NULL,type_x,0));
}
NhlErrorTypes poisson_grid_fill_W( void )
{
/*
* Input variables
*/
/*
* Argument # 0
*/
void *x;
double *tmp_x = NULL;
int ndims_x;
ng_size_t dsizes_x[NCL_MAX_DIMENSIONS];
int has_missing_x;
NclScalar missing_x, missing_dx;
NclBasicDataTypes type_x;
/*
* Argument # 1
*/
logical *is_cyclic;
/*
* Arguments # 2 & 3
*/
int *guess_type, *nscan;
/*
* Arguments # 4 & 5
*/
void *epsx, *relc;
double *tmp_epsx, *tmp_relc;
NclBasicDataTypes type_epsx, type_relc;
/*
* Argument # 6
*/
int *opt;
/*
* Various
*/
int ndims_leftmost;
ng_size_t i, size_leftmost;
ng_size_t ny, mx, nymx, index_x;
int mscan, ier, iny, imx;
/*
* Retrieve parameters.
*
* Note any of the pointer parameters can be set to NULL, which
* implies you don't care about its value.
*/
/*
* Get argument # 0
*/
x = (void*)NclGetArgValue(
0,
7,
&ndims_x,
dsizes_x,
&missing_x,
&has_missing_x,
&type_x,
1);
/*
* Check the input type.
*/
if(type_x != NCL_float && type_x != NCL_double) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"poisson_grid_fill: The first input argument must be float or double");
return(NhlFATAL);
}
/*
* Check dimension sizes.
*/
if(ndims_x < 2) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"poisson_grid_fill: The first argument must have at least two dimensions");
return(NhlFATAL);
}
/*
* Coerce missing value to double if necessary.
*/
coerce_missing(type_x,has_missing_x,&missing_x,&missing_dx,NULL);
ny = dsizes_x[ndims_x-2];
mx = dsizes_x[ndims_x-1];
nymx = ny * mx;
/*
* Test input dimension sizes.
*/
if((mx > INT_MAX) || (ny > INT_MAX)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"poisson_grid_fill: one or more input dimension sizes is greater than INT_MAX");
return(NhlFATAL);
}
imx = (int) mx;
iny = (int) ny;
/*
* Get argument # 1
*/
is_cyclic = (logical*)NclGetArgValue(
1,
7,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Get argument # 2
*/
guess_type = (int*)NclGetArgValue(
2,
7,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Get argument # 3
*/
nscan = (int*)NclGetArgValue(
3,
7,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Get argument # 4
*/
epsx = (void*)NclGetArgValue(
4,
7,
NULL,
NULL,
NULL,
NULL,
&type_epsx,
DONT_CARE);
/*
* Get argument # 4
*/
relc = (void*)NclGetArgValue(
5,
7,
NULL,
NULL,
NULL,
NULL,
&type_relc,
DONT_CARE);
/*
* Get argument # 6
*/
opt = (int*)NclGetArgValue(
6,
7,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Calculate size of leftmost dimensions.
*/
size_leftmost = 1;
ndims_leftmost = ndims_x-2;
for(i = 0; i < ndims_leftmost; i++) {
size_leftmost *= dsizes_x[i];
}
/*
* Coerce the numeric input values to double.
*/
tmp_epsx = coerce_input_double(epsx, type_epsx, 1, 0, NULL, NULL);
tmp_relc = coerce_input_double(relc, type_relc, 1, 0, NULL, NULL);
/*
* Allocate space for tmp_x.
*/
if(type_x != NCL_double) {
tmp_x = (double *)calloc(nymx,sizeof(double));
if(tmp_x == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"poisson_grid_fill: Unable to allocate memory for coercing input array to double");
return(NhlFATAL);
}
}
/*
* Loop across leftmost dimensions and call the Fortran routine for each
* subsection of the input arrays.
*/
index_x = 0;
for(i = 0; i < size_leftmost; i++) {
/*
* Coerce subsection of x (tmp_x) to double if necessary.
*/
if(type_x != NCL_double) {
coerce_subset_input_double(x,tmp_x,index_x,type_x,nymx,0,NULL,NULL);
}
else {
tmp_x = &((double*)x)[index_x];
}
/*
* Call the Fortran routine.
*/
NGCALLF(poisxy1,POISXY1)(tmp_x, &imx, &iny, &missing_dx.doubleval,
guess_type, is_cyclic, nscan, tmp_epsx,
tmp_relc, &mscan, &ier);
/*
* Coerce back to float, if not double.
*/
if(type_x == NCL_float) {
coerce_output_float_only(x,tmp_x,nymx,index_x);
}
index_x += nymx; /* Increment pointer. */
}
/*
* Free unneeded memory.
*/
if(type_x != NCL_double) NclFree(tmp_x);
if(type_epsx != NCL_double) NclFree(tmp_epsx);
if(type_relc != NCL_double) NclFree(tmp_relc);
/*
* This is a procedure, so no values are returned.
*/
return(NhlNOERROR);
}
NhlErrorTypes 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 uv2dv_cfd_W( void )
{
/*
* Input array variables
*/
void *u, *v, *lat, *lon;
int *bound_opt;
double *tmp_u = NULL;
double *tmp_v = NULL;
double *tmp_lat, *tmp_lon;
int ndims_u;
ng_size_t dsizes_u[NCL_MAX_DIMENSIONS];
int ndims_v;
ng_size_t dsizes_v[NCL_MAX_DIMENSIONS];
ng_size_t dsizes_lat[NCL_MAX_DIMENSIONS];
ng_size_t dsizes_lon[NCL_MAX_DIMENSIONS];
int has_missing_u;
NclScalar missing_u, missing_du, missing_ru;
NclBasicDataTypes type_u, type_v, type_lat, type_lon;
/*
* Output array variables
*/
void *div;
double *tmp_div = NULL;
NclBasicDataTypes type_div;
/*
* Declare various variables for random purposes.
*/
ng_size_t i, nlon, nlat, nlatnlon, size_uv, size_leftmost, index_uv;
int inlat, inlon, ier;
/*
* Retrieve parameters
*
* Note that any of the pointer parameters can be set to NULL,
* which implies you don't care about its value.
*
*/
u = (void*)NclGetArgValue(
0,
5,
&ndims_u,
dsizes_u,
&missing_u,
&has_missing_u,
&type_u,
DONT_CARE);
v = (void*)NclGetArgValue(
1,
5,
&ndims_v,
dsizes_v,
NULL,
NULL,
&type_v,
DONT_CARE);
lat = (void*)NclGetArgValue(
2,
5,
NULL,
dsizes_lat,
NULL,
NULL,
&type_lat,
DONT_CARE);
lon = (void*)NclGetArgValue(
3,
5,
NULL,
dsizes_lon,
NULL,
NULL,
&type_lon,
DONT_CARE);
bound_opt = (int*)NclGetArgValue(
4,
5,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Get size of input array.
*/
if(ndims_u < 2 || ndims_u != ndims_v) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"uv2dv_cfd: u and v must have the same numer of dimensions and have at least 2 dimensions");
return(NhlFATAL);
}
for( i=0; i < ndims_u; i++ ) {
if(dsizes_u[i] != dsizes_v[i]) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"uv2dv_cfd: u and v must have the same dimensions");
return(NhlFATAL);
}
}
nlat = dsizes_u[ndims_u-2];
nlon = dsizes_u[ndims_u-1];
nlatnlon = nlat * nlon;
/*
* Test dimension sizes.
*/
if((nlon > INT_MAX) || (nlat > INT_MAX)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"uv2dv_cfd: nlat and/or nlon is greater than INT_MAX");
return(NhlFATAL);
}
inlon = (int) nlon;
inlat = (int) nlat;
if(dsizes_lat[0] != nlat || dsizes_lon[0] != nlon) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"uv2dv_cfd: the lat,lon arrays must be dimensioned nlat and nlon, the last two dimensions of u and v");
return(NhlFATAL);
}
/*
* Compute the total size of the q array.
*/
size_leftmost = 1;
for( i = 0; i < ndims_u-2; i++ ) size_leftmost *= dsizes_u[i];
size_uv = size_leftmost * nlatnlon;
/*
* Check for missing values.
*/
coerce_missing(type_u,has_missing_u,&missing_u,&missing_du,&missing_ru);
/*
* Create temporary arrays to hold double precision data.
*/
if(type_u != NCL_double) {
tmp_u = (double*)calloc(nlatnlon,sizeof(double));
if( tmp_u == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"uv2dv_cfd: Unable to allocate memory for coercing u to double precision");
return(NhlFATAL);
}
}
if(type_v != NCL_double) {
tmp_v = (double*)calloc(nlatnlon,sizeof(double));
if( tmp_v == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"uv2dv_cfd: Unable to allocate memory for coercing v to double precision");
return(NhlFATAL);
}
}
/*
* Allocate space for output array.
*/
if(type_u == NCL_double || type_v == NCL_double) {
type_div = NCL_double;
div = (void*)calloc(size_uv,sizeof(double));
}
else {
tmp_div = (double*)calloc(nlatnlon,sizeof(double));
if(tmp_div == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"uv2dv_cfd: Unable to allocate memory for temporary output array");
return(NhlFATAL);
}
type_div = NCL_float;
div = (void*)calloc(size_uv,sizeof(float));
}
if(div == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"uv2dv_cfd: Unable to allocate memory for output array");
return(NhlFATAL);
}
/*
* Coerce lat/lon arrays to double if necessary.
*/
tmp_lat = coerce_input_double(lat,type_lat,nlat,0,NULL,NULL);
tmp_lon = coerce_input_double(lon,type_lon,nlon,0,NULL,NULL);
if(tmp_lat == NULL || tmp_lon == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"uv2dv_cfd: Unable to coerce lat/lon arrays to double precision");
return(NhlFATAL);
}
/*
* Loop through leftmost dimensions and call Fortran routine.
*/
index_uv = 0;
for(i = 0; i < size_leftmost; i++ ) {
if(type_u != NCL_double) {
/*
* Coerce u (tmp_u) to double.
*/
coerce_subset_input_double(u,tmp_u,index_uv,type_u,nlatnlon,0,NULL,NULL);
}
else {
/*
* Point tmp_u to u.
*/
tmp_u = &((double*)u)[index_uv];
}
if(type_v != NCL_double) {
/*
* Coerce v (tmp_v) to double.
*/
coerce_subset_input_double(v,tmp_v,index_uv,type_v,nlatnlon,0,NULL,NULL);
}
else {
/*
* Point tmp_v to v.
*/
tmp_v = &((double*)v)[index_uv];
}
if(type_div == NCL_double) {
/*
* Point tmp_div to div.
*/
tmp_div = &((double*)div)[index_uv];
}
/*
* Call the Fortran routine.
*/
NGCALLF(ddvfidf,DDVFIDF)(tmp_u,tmp_v,tmp_lat,tmp_lon,&inlon,&inlat,
&missing_du.doubleval,bound_opt,tmp_div,&ier);
if(type_div != NCL_double) {
coerce_output_float_only(div,tmp_div,nlatnlon,index_uv);
}
index_uv += nlatnlon;
}
/*
* Free temp arrays.
*/
if(type_u != NCL_double) NclFree(tmp_u);
if(type_v != NCL_double) NclFree(tmp_v);
if(type_lat != NCL_double) NclFree(tmp_lat);
if(type_lon != NCL_double) NclFree(tmp_lon);
if(type_div != NCL_double) NclFree(tmp_div);
if(type_div == NCL_double) {
return(NclReturnValue(div,ndims_u,dsizes_u,&missing_du,type_div,0));
}
else {
return(NclReturnValue(div,ndims_u,dsizes_u,&missing_ru,type_div,0));
}
}
NhlErrorTypes center_finite_diff_n_W( void )
{
/*
* Input array variables
*/
void *q, *r;
logical *cyclic;
int *opt, *dim, r_one_d;
int r_scalar = 1;
double *tmp_q, *tmp_r;
int ndims_q;
ng_size_t dsizes_q[NCL_MAX_DIMENSIONS];
int ndims_r;
ng_size_t dsizes_r[NCL_MAX_DIMENSIONS];
int has_missing_q, has_missing_r;
NclScalar missing_q, missing_dq, missing_rq;
NclScalar missing_r, missing_dr;
NclBasicDataTypes type_q, type_r, type_dqdr;
/*
* Output array variables
*/
void *dqdr;
double *tmp_dqdr;
NclScalar missing_dqdr;
/*
* Declare various variables for random purposes.
*/
ng_size_t i, j, npts, npts1, size_q, size_leftmost, size_rightmost, size_rl;
ng_size_t index_nrnpts, index_q;
int inpts, inpts1, iend, ier;
double *qq, *rr;
/*
* Retrieve parameters
*
* Note that any of the pointer parameters can be set to NULL,
* which implies you don't care about its value.
*
*/
q = (void*)NclGetArgValue(
0,
5,
&ndims_q,
dsizes_q,
&missing_q,
&has_missing_q,
&type_q,
DONT_CARE);
r = (void*)NclGetArgValue(
1,
5,
&ndims_r,
dsizes_r,
&missing_r,
&has_missing_r,
&type_r,
DONT_CARE);
cyclic = (logical*)NclGetArgValue(
2,
5,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
opt = (int*)NclGetArgValue(
3,
5,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
dim = (int*)NclGetArgValue(
4,
5,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Make sure "dim" is a valid dimension.
*/
if (*dim < 0 || *dim >= ndims_q) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"center_finite_diff_n: Invalid dimension index for calculating the center finite difference");
return(NhlFATAL);
}
/*
* Set value for cyclic.
*/
if(*cyclic) {
iend = 0;
}
else {
iend = 1;
}
/*
* Get size of input array and test dimension sizes.
*/
npts = dsizes_q[*dim];
npts1 = npts + 1;
if((npts > INT_MAX) || (npts1 > INT_MAX)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"center_finite_diff_n: npts1 = %ld is larger than INT_MAX", npts1);
return(NhlFATAL);
}
inpts = (int) npts;
inpts1 = (int) npts1;
if((ndims_r == 1 && (dsizes_r[0] != npts && dsizes_r[0] != 1)) ||
(ndims_r > 1 && ndims_r != ndims_q)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"center_finite_diff_n: r must either be a scalar, a 1D array the same length as the dim-th dimemsion of q, or the same size as q");
return(NhlFATAL);
}
if(ndims_r > 1) {
for( i = 0; i < ndims_r; i++ ) {
if(dsizes_r[i] != dsizes_q[i]) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"center_finite_diff_n: r must either be a scalar, a 1D array the same length as the dim-th dimemsion of q, or the same size as q");
return(NhlFATAL);
}
}
}
/*
* Compute the total size of the q array.
*/
size_rightmost = size_leftmost = 1;
for( i = 0; i < *dim; i++ ) size_leftmost *= dsizes_q[i];
for( i = *dim+1; i < ndims_q; i++ ) size_rightmost *= dsizes_q[i];
size_rl = size_leftmost * size_rightmost;
size_q = size_rl * npts;
/*
* Check for missing values.
*/
coerce_missing(type_q,has_missing_q,&missing_q,&missing_dq,&missing_rq);
coerce_missing(type_r,has_missing_r,&missing_r,&missing_dr,NULL);
/*
* Create arrays to hold temporary r and q values.
*/
qq = (double*)calloc(npts+2,sizeof(double));
rr = (double*)calloc(npts+2,sizeof(double));
if( qq == NULL || rr == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"center_finite_diff_n: Unable to allocate memory for temporary arrays");
return(NhlFATAL);
}
/*
* Create temporary arrays to hold double precision data.
*/
tmp_q = (double*)calloc(npts,sizeof(double));
if( tmp_q == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"center_finite_diff_n: Unable to allocate memory for coercing q to double precision");
return(NhlFATAL);
}
/*
* 'r' can be a scalar, one-dimensional, or multi-dimensional.
*
* If it is a scalar, then we need to construct an npts-sized 'r'
* that is based on the scalar value.
*
* If it is 1D, then we need to coerce it to double if necessary.
*
* If it is nD, then we need to create a temporary 1D array so we
* can coerce the potentially non-contiguous 1D subsets to double.
*/
if(ndims_r > 1) {
r_one_d = 0;
}
else {
r_one_d = 1;
r_scalar = is_scalar(ndims_r,dsizes_r);
}
/*
* Here are the three possible scenarios for "r":
*/
if(r_scalar) {
tmp_r = (double*)calloc(npts,sizeof(double));
coerce_subset_input_double(r,&tmp_r[0],0,type_r,1,0,NULL,NULL);
/*
* Copy this scalar npts-1 times to rest of the array.
*/
for(i = 1; i < npts; i++ ) tmp_r[i] = tmp_r[i-1] + tmp_r[0];
}
else if(r_one_d) {
tmp_r = coerce_input_double(r,type_r,npts,0,NULL,NULL);
}
else {
tmp_r = (double*)calloc(npts,sizeof(double));
}
if( tmp_r == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"center_finite_diff_n: Unable to allocate memory for coercing r to double precision");
return(NhlFATAL);
}
/*
* Allocate space for output array.
*/
if(type_q == NCL_double || type_r == NCL_double) {
type_dqdr = NCL_double;
dqdr = (void*)calloc(size_q,sizeof(double));
missing_dqdr = missing_dq;
}
else {
type_dqdr = NCL_float;
dqdr = (void*)calloc(size_q,sizeof(float));
missing_dqdr = missing_rq;
}
tmp_dqdr = (double*)calloc(npts,sizeof(double));
if( dqdr == NULL || tmp_dqdr == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"center_finite_diff_n: Unable to allocate memory for output array");
return(NhlFATAL);
}
/*
* Loop through dimensions and call Fortran routine.
*/
for( i = 0; i < size_leftmost; i++ ) {
index_nrnpts = i*size_rightmost * npts;
for( j = 0; j < size_rightmost; j++ ) {
index_q = index_nrnpts + j;
/*
* Coerce q (tmp_q) to double.
*/
coerce_subset_input_double_step(q,tmp_q,index_q,size_rightmost,
type_q,npts,0,NULL,NULL);
if(!r_one_d) {
/*
* Coerce r (tmp_r) to double.
*/
coerce_subset_input_double_step(r,tmp_r,index_q,size_rightmost,
type_r,npts,0,NULL,NULL);
}
/*
* Call the Fortran routine.
*/
NGCALLF(dcfindif,DCFINDIF)(tmp_q,tmp_r,&inpts,&missing_dq.doubleval,
&missing_dr.doubleval,cyclic,&iend,
qq,rr,&inpts1,tmp_dqdr,&ier);
coerce_output_float_or_double_step(dqdr,tmp_dqdr,type_dqdr,npts,index_q,
size_rightmost);
}
}
/*
* Free temp arrays.
*/
if(type_r != NCL_double || r_scalar || !r_one_d) NclFree(tmp_r);
NclFree(tmp_q);
NclFree(tmp_dqdr);
NclFree(qq);
NclFree(rr);
if(has_missing_q) {
return(NclReturnValue(dqdr,ndims_q,dsizes_q,&missing_dqdr,type_dqdr,0));
}
else {
return(NclReturnValue(dqdr,ndims_q,dsizes_q,NULL,type_dqdr,0));
}
}
NhlErrorTypes area_conserve_remap_W( void )
{
/*
* Input variables
*/
/*
* Argument # 0
*/
void *loni;
double *tmp_loni;
ng_size_t dsizes_loni[1];
NclBasicDataTypes type_loni;
/*
* Argument # 1
*/
void *lati;
double *tmp_lati;
ng_size_t dsizes_lati[1];
NclBasicDataTypes type_lati;
/*
* Argument # 2
*/
void *fi;
double *tmp_fi = NULL;
int ndims_fi;
ng_size_t dsizes_fi[NCL_MAX_DIMENSIONS];
int has_missing_fi;
NclScalar missing_fi, missing_flt_fi, missing_dbl_fi;
NclBasicDataTypes type_fi;
/*
* Argument # 3
*/
void *lono;
double *tmp_lono;
ng_size_t dsizes_lono[1];
NclBasicDataTypes type_lono;
/*
* Argument # 4
*/
void *lato;
double *tmp_lato;
ng_size_t dsizes_lato[1];
NclBasicDataTypes type_lato;
/*
* Argument # 5
*/
logical *opt;
/*
* Return variable
*/
void *fo;
double *tmp_fo;
ng_size_t *dsizes_fo;
NclBasicDataTypes type_fo;
/*
* Various
*/
ng_size_t nloni, nlati, nlevi, nlono, nlato, nlevnlatnloni, nlevnlatnlono;
ng_size_t NLATi, NLATo, i;
int ret;
double *bin_factor = NULL;
logical set_binf;
NclBasicDataTypes type_bin_factor;
/*
* Variables for retrieving attributes from "opt".
*/
NclAttList *attr_list;
NclAtt attr_obj;
NclStackEntry stack_entry;
/*
* Variables for coercing input dimension sizes to integer.
*/
int inlono, inlato, iNLATo, iNLATi, inloni, inlati, inlevi;
/*
* Retrieve parameters.
*
* Note any of the pointer parameters can be set to NULL, which
* implies you don't care about its value.
*/
/*
* Get argument # 0
*/
loni = (void*)NclGetArgValue(
0,
6,
NULL,
dsizes_loni,
NULL,
NULL,
&type_loni,
DONT_CARE);
nloni = dsizes_loni[0];
/*
* Get argument # 1
*/
lati = (void*)NclGetArgValue(
1,
6,
NULL,
dsizes_lati,
NULL,
NULL,
&type_lati,
DONT_CARE);
nlati = dsizes_lati[0];
/*
* Get argument # 2
*/
fi = (void*)NclGetArgValue(
2,
6,
&ndims_fi,
dsizes_fi,
&missing_fi,
&has_missing_fi,
&type_fi,
DONT_CARE);
/*
* Check dimension sizes.
*/
if(ndims_fi < 2) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_conserve_remap: The fi array must have at least 2 dimensions");
return(NhlFATAL);
}
/*
* Coerce missing value to double if necessary.
*/
coerce_missing(type_fi,has_missing_fi,&missing_fi,
&missing_dbl_fi,&missing_flt_fi);
if(dsizes_fi[ndims_fi-2] != nlati || dsizes_fi[ndims_fi-1] != nloni) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_conserve_remap: The rightmost two dimension of fi must be nlat x nlon");
return(NhlFATAL);
}
/*
* Get argument # 3
*/
lono = (void*)NclGetArgValue(
3,
6,
NULL,
dsizes_lono,
NULL,
NULL,
&type_lono,
DONT_CARE);
nlono = dsizes_lono[0];
/*
* Get argument # 4
*/
lato = (void*)NclGetArgValue(
4,
6,
NULL,
dsizes_lato,
NULL,
NULL,
&type_lato,
DONT_CARE);
nlato = dsizes_lato[0];
/*
* Get argument # 5
*/
opt = (logical*)NclGetArgValue(
5,
6,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Check for the following attributes attached to "opt":
* NLATi
* NLATo
* bin_factor
*
* If not found, then use default values, which are set here.
* "bin_factor" will be set later.
*/
NLATi = nlati;
NLATo = nlato;
set_binf = False;
if(*opt) {
stack_entry = _NclGetArg(5, 6, DONT_CARE);
switch (stack_entry.kind) {
case NclStk_VAR:
if (stack_entry.u.data_var->var.att_id != -1) {
attr_obj = (NclAtt) _NclGetObj(stack_entry.u.data_var->var.att_id);
if (attr_obj == NULL) {
break;
}
}
else {
/*
* att_id == -1 ==> no attributes specified.
*/
break;
}
/*
* Check for attributes. If none are set, then use default values.
*/
if (attr_obj->att.n_atts == 0) {
break;
}
else {
/*
* Get list of attributes.
*/
attr_list = attr_obj->att.att_list;
/*
* Loop through attributes and check them.
*/
while (attr_list != NULL) {
/*
* NLATi
*/
if ((strcmp(attr_list->attname, "NLATi")) == 0) {
if(attr_list->attvalue->multidval.data_type != NCL_int) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"area_conserve_remap: The 'NLATi' attribute must be an integer, defaulting to nlati.");
}
else {
NLATi = *(int*) attr_list->attvalue->multidval.val;
}
}
/*
* NLATo
*/
if ((strcmp(attr_list->attname, "NLATo")) == 0) {
if(attr_list->attvalue->multidval.data_type != NCL_int) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"area_conserve_remap: The 'Nlato' attribute must be an integer, defaulting to nlato.");
}
else {
NLATo = *(int*) attr_list->attvalue->multidval.val;
}
}
/*
* bin_factor
*/
if(!strcmp(attr_list->attname, "bin_factor")) {
type_bin_factor = attr_list->attvalue->multidval.data_type;
bin_factor = coerce_input_double(attr_list->attvalue->multidval.val,
type_bin_factor,1,0,NULL,NULL);
set_binf = True;
}
attr_list = attr_list->next;
}
}
default:
break;
}
}
if(!set_binf) {
bin_factor = (double *)calloc(1,sizeof(double));
*bin_factor = 1.0;
}
/*
* Calculate size of leftmost dimensions and fi/fo.
*/
nlevi = 1;
for(i = 0; i < ndims_fi-2; i++) nlevi *= dsizes_fi[i];
/*
* Test input dimension sizes to make sure they are <= INT_MAX.
*/
if((nlono > INT_MAX) ||
(nlato > INT_MAX) ||
(NLATi > INT_MAX) ||
(NLATo > INT_MAX) ||
(nloni > INT_MAX) ||
(nlati > INT_MAX) ||
(nlevi > INT_MAX)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_conserve_remap: One of the input array dimension sizes is greater than INT_MAX");
return(NhlFATAL);
}
inlono = (int) nlono;
inlato = (int) nlato;
iNLATo = (int) NLATo;
iNLATi = (int) NLATi;
inloni = (int) nloni;
inlati = (int) nlati;
inlevi = (int) nlevi;
nlevnlatnloni = nlevi * nlati * nloni; /* input array size */
nlevnlatnlono = nlevi * nlato * nlono; /* output array size */
/*
* Allocate space for coercing input arrays. If any of the input
* is already double, then we don't need to allocate space for
* temporary arrays, because we'll just change the pointer into
* the void array appropriately.
*/
/*
* Allocate space for tmp_loni.
*/
tmp_loni = coerce_input_double(loni,type_loni,nloni,0,NULL,NULL);
if(tmp_loni == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_conserve_remap: Unable to allocate memory for coercing input array to double");
return(NhlFATAL);
}
/*
* Allocate space for tmp_lati.
*/
tmp_lati = coerce_input_double(lati,type_lati,nlati,0,NULL,NULL);
if(tmp_lati == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_conserve_remap: Unable to allocate memory for coercing input array to double");
return(NhlFATAL);
}
/*
* Allocate space for tmp_fi and determine type of output.
*
* The output type defaults to float, unless fi is double.
*/
if(type_fi != NCL_double) {
type_fo = NCL_float;
}
else {
type_fo = NCL_double;
}
/*
* Coerce input to double if necessary.
*/
tmp_fi = coerce_input_double(fi,type_fi,nlevnlatnloni,0,NULL,NULL);
if(tmp_fi == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_conserve_remap: Unable to allocate memory for coercing fi to double");
return(NhlFATAL);
}
/*
* Allocate space for tmp_lono.
*/
tmp_lono = coerce_input_double(lono,type_lono,nlono,0,NULL,NULL);
if(tmp_lono == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_conserve_remap: Unable to allocate memory for coercing lono to double");
return(NhlFATAL);
}
/*
* Allocate space for tmp_lato.
*/
tmp_lato = coerce_input_double(lato,type_lato,nlato,0,NULL,NULL);
if(tmp_lato == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_conserve_remap: Unable to allocate memory for coercing lato to double");
return(NhlFATAL);
}
/*
* Allocate space for output array.
*/
if(type_fo != NCL_double) {
fo = (void *)calloc(nlevnlatnlono, sizeof(float));
tmp_fo = (double *)calloc(nlevnlatnlono,sizeof(double));
if(fo == NULL || tmp_fo == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_conserve_remap: Unable to allocate memory for output array");
return(NhlFATAL);
}
}
else {
fo = (void *)calloc(nlevnlatnlono, sizeof(double));
if(fo == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_conserve_remap: Unable to allocate memory for output array");
return(NhlFATAL);
}
tmp_fo = fo;
}
/*
* Allocate space for output dimension sizes and set them.
*/
dsizes_fo = (ng_size_t*)calloc(ndims_fi,sizeof(ng_size_t));
if( dsizes_fo == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_conserve_remap: Unable to allocate memory for holding dimension sizes");
return(NhlFATAL);
}
for(i = 0; i < ndims_fi-2; i++) dsizes_fo[i] = dsizes_fi[i];
dsizes_fo[ndims_fi-2] = nlato;
dsizes_fo[ndims_fi-1] = nlono;
/*
* Call the Fortran routine.
*/
NGCALLF(cremapbin,CREMAPBIN)(&inlevi, &inlato, &inlono, &inlati, &inloni,
tmp_fi, tmp_fo, tmp_lati, tmp_loni, tmp_lato,
tmp_lono, &iNLATi, &iNLATo, bin_factor,
&missing_dbl_fi.doubleval);
if (!set_binf || (set_binf && type_bin_factor != NCL_double)) {
free(bin_factor);
}
/*
* Coerce output back to float if necessary.
*/
if(type_fo == NCL_float) {
coerce_output_float_only(fo,tmp_fo,nlevnlatnlono,0);
}
/*
* Free unneeded memory.
*/
if(type_loni != NCL_double) NclFree(tmp_loni);
if(type_lati != NCL_double) NclFree(tmp_lati);
if(type_fi != NCL_double) NclFree(tmp_fi);
if(type_lono != NCL_double) NclFree(tmp_lono);
if(type_lato != NCL_double) NclFree(tmp_lato);
if(type_fo != NCL_double) NclFree(tmp_fo);
/*
* Return value back to NCL script.
*/
ret = NclReturnValue(fo,ndims_fi,dsizes_fo,NULL,type_fo,0);
NclFree(dsizes_fo);
return(ret);
}
NhlErrorTypes 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 pdfx_bin_W( void )
{
/*
* Input variables
*/
/*
* Argument # 0
*/
void *x;
double *tmp_x;
int ndims_x;
ng_size_t dsizes_x[NCL_MAX_DIMENSIONS];
int has_missing_x;
NclScalar missing_x, missing_dbl_x;
NclBasicDataTypes type_x;
/*
* Argument # 1
*/
void *binxbnd;
double *tmp_binxbnd;
ng_size_t dsizes_binxbnd[1];
NclBasicDataTypes type_binxbnd;
/*
* Argument # 2
*/
logical *opt;
/*
* Return variable
*/
void *pdf;
double *tmp_pdf = NULL;
ng_size_t dsizes_pdf[1];
NclBasicDataTypes type_pdf;
/*
* Various
*/
ng_size_t i, nx, mbxp1, mbx;
int ier, ret;
int inx, imbx, imbxp1;
/*
* Variables for retrieving attributes from "opt".
*/
NclAttList *attr_list;
NclAtt attr_obj;
NclStackEntry stack_entry;
logical fraction = False;
int ipcnt;
/*
* Retrieve parameters.
*
* Note any of the pointer parameters can be set to NULL, which
* implies you don't care about its value.
*/
/*
* Get argument # 0
*/
x = (void*)NclGetArgValue(
0,
3,
&ndims_x,
dsizes_x,
&missing_x,
&has_missing_x,
&type_x,
DONT_CARE);
nx = 1;
for(i = 0; i < ndims_x; i++) nx *= dsizes_x[i];
/*
* Get argument # 1
*/
binxbnd = (void*)NclGetArgValue(
1,
3,
NULL,
dsizes_binxbnd,
NULL,
NULL,
&type_binxbnd,
DONT_CARE);
mbxp1 = dsizes_binxbnd[0];
mbx = mbxp1 - 1;
if(mbxp1 < 2) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"pdfx_bin: The binxbnd array must have at least two values");
return(NhlFATAL);
}
/*
* Test input dimension sizes.
*/
if((nx > INT_MAX) || (mbx > INT_MAX) || (mbxp1 > INT_MAX)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"pdfx_bin: one or more input dimension sizes is greater than INT_MAX");
return(NhlFATAL);
}
inx = (int) nx;
imbx = (int) mbx;
imbxp1 = (int) mbxp1;
/*
* Get argument # 2
*/
opt = (logical*)NclGetArgValue(
2,
3,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* If "opt" is True, then check if any attributes have been set.
*
* There's only one recognized right now:
*
* "fraction" : whether to return fraction (True) or percent (False)
* (False by default)
*/
if(*opt) {
stack_entry = _NclGetArg(2, 3, DONT_CARE);
switch (stack_entry.kind) {
case NclStk_VAR:
if (stack_entry.u.data_var->var.att_id != -1) {
attr_obj = (NclAtt) _NclGetObj(stack_entry.u.data_var->var.att_id);
if (attr_obj == NULL) {
break;
}
}
else {
/*
* att_id == -1 ==> no optional args given.
*/
break;
}
/*
* Get optional arguments.
*/
if (attr_obj->att.n_atts > 0) {
/*
* Get list of attributes.
*/
attr_list = attr_obj->att.att_list;
/*
* Loop through attributes and check them.
*/
while (attr_list != NULL) {
/*
* Check for "fraction".
*/
if (!strcmp(attr_list->attname, "fraction")) {
if(attr_list->attvalue->multidval.data_type != NCL_logical) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"pdfx_bin: The 'fraction' attribute must be a logical; defaulting to False.");
}
else {
fraction = *(logical*) attr_list->attvalue->multidval.val;
}
}
attr_list = attr_list->next;
}
}
default:
break;
}
}
if(fraction) ipcnt = 0;
else ipcnt = 1;
/*
* Coerce missing values to double if necessary.
*/
coerce_missing(type_x,has_missing_x,&missing_x,&missing_dbl_x,NULL);
/*
* The output type defaults to float, unless any input arrays are double.
*/
if(type_x == NCL_double || type_binxbnd == NCL_double) {
type_pdf = NCL_double;
}
else {
type_pdf = NCL_float;
}
/*
* Coerce input arrays to double if necessary.
*/
tmp_x = coerce_input_double(x,type_x,nx,0,NULL,NULL);
if(tmp_x == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"pdfx_bin: Unable to allocate memory for coercing x to double");
return(NhlFATAL);
}
tmp_binxbnd = coerce_input_double(binxbnd,type_binxbnd,mbxp1,0,NULL,NULL);
if(tmp_binxbnd == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"pdfx_bin: Unable to allocate memory for coercing binxbnd to double");
return(NhlFATAL);
}
/*
* Allocate space for output array.
*/
if(type_pdf != NCL_double) {
pdf = (void *)calloc(mbx, sizeof(float));
tmp_pdf = (double *)calloc(mbx,sizeof(double));
if(tmp_pdf == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"pdfx_bin: Unable to allocate memory for temporary output array");
return(NhlFATAL);
}
}
else {
pdf = (void *)calloc(mbx, sizeof(double));
}
if(pdf == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"pdfx_bin: Unable to allocate memory for output array");
return(NhlFATAL);
}
if(type_pdf == NCL_double) tmp_pdf = &((double*)pdf)[0];
/*
* Call the Fortran routine.
*/
NGCALLF(x1pdf77,X1PDF77)(&inx, tmp_x, &missing_dbl_x.doubleval,
&imbx, tmp_pdf, &imbxp1, tmp_binxbnd,
&ipcnt, &ier);
/*
* Coerce output back to float if necessary.
*/
if(type_pdf == NCL_float) coerce_output_float_only(pdf,tmp_pdf,mbx,0);
/*
* Free unneeded memory.
*/
if(type_x != NCL_double) NclFree(tmp_x);
if(type_binxbnd != NCL_double) NclFree(tmp_binxbnd);
if(type_pdf != NCL_double) NclFree(tmp_pdf);
/*
* Return value back to NCL script.
*/
dsizes_pdf[0] = mbx;
ret = NclReturnValue(pdf,1,dsizes_pdf,NULL,type_pdf,0);
return(ret);
}
NhlErrorTypes covcorm_xy_W( void )
{
/*
* Input array variables
*/
void *x, *y;
int *iopt;
double *dx, *dy;
ng_size_t dsizes_x[NCL_MAX_DIMENSIONS], dsizes_y[NCL_MAX_DIMENSIONS];
int ndims_x, has_missing_x, ndims_y, has_missing_y;
NclScalar missing_x, missing_dx, missing_y, missing_dy;
ng_size_t size_x, nvar, ntim;
int invar, intim;
NclBasicDataTypes type_x, type_y;
/*
* Output array variable
*/
void *vcm;
double *dvcm;
ng_size_t *dsizes_vcm;
int ndims_vcm, ret;
ng_size_t size_vcm;
NclBasicDataTypes type_vcm;
NclScalar missing_vcm;
/*
* Retrieve x.
*/
x = (void*)NclGetArgValue(
0,
3,
&ndims_x,
dsizes_x,
&missing_x,
&has_missing_x,
&type_x,
DONT_CARE);
y = (void*)NclGetArgValue(
1,
3,
&ndims_y,
dsizes_y,
&missing_y,
&has_missing_y,
&type_y,
DONT_CARE);
iopt = (int*)NclGetArgValue(
2,
3,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
nvar = dsizes_x[0];
ntim = dsizes_x[1];
if(dsizes_y[0] != nvar || dsizes_y[1] != ntim) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"covcorm_xy: x and y must be the same size");
return(NhlFATAL);
}
size_x = nvar * ntim;
/*
* Test dimension sizes to make sure they are <= INT_MAX.
*/
if((ntim > INT_MAX) || (nvar > INT_MAX)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"covcorm_xy: one or more dimension sizes are greater than INT_MAX");
return(NhlFATAL);
}
intim = (int) ntim;
invar = (int) nvar;
/*
* Coerce missing values, if any.
*/
coerce_missing(type_x,has_missing_x,&missing_x,&missing_dx,NULL);
coerce_missing(type_y,has_missing_y,&missing_y,&missing_dy,NULL);
/*
* Allocate space for input/output arrays.
*/
size_vcm = nvar*nvar;
ndims_vcm = 2;
dsizes_vcm = (ng_size_t*)malloc(2*sizeof(ng_size_t));
dsizes_vcm[0] = nvar;
dsizes_vcm[1] = nvar;
dx = coerce_input_double(x,type_x,size_x,0,NULL,NULL);
dy = coerce_input_double(y,type_y,size_x,0,NULL,NULL);
if(type_x == NCL_double || type_y == NCL_double) {
type_vcm = NCL_double;
vcm = (void*)malloc(size_vcm*sizeof(double));
if(vcm == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"covcorm_xy: Unable to allocate memory for output array");
return(NhlFATAL);
}
dvcm = &((double*)vcm)[0];
missing_vcm.doubleval = ((NclTypeClass)nclTypedoubleClass)->type_class.default_mis.doubleval;
}
else {
type_vcm = NCL_float;
vcm = (void*)malloc(size_vcm*sizeof(float));
dvcm = (double*)malloc(size_vcm*sizeof(double));
if(vcm == NULL || dvcm == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"covcorm_xy: Unable to allocate memory for output array");
return(NhlFATAL);
}
missing_vcm.floatval = ((NclTypeClass)nclTypefloatClass)->type_class.default_mis.floatval;
}
/*
* Call the fortran routine.
* iopt(0) --> iopt
* iopt(1) --> lag
* iopt(2) --> ncrit
*/
NGCALLF(dcovarxy,DCOVARXY)(dx,dy,&missing_dx.doubleval,
&missing_dy.doubleval,dvcm,&intim,&invar,
&iopt[1],&iopt[2],&iopt[0]);
/* Coerce to float if necessary */
if(type_vcm == NCL_float) coerce_output_float_only(vcm,dvcm,size_vcm,0);
/* Free memory */
if(type_x != NCL_double) NclFree(dx);
if(type_y != NCL_double) NclFree(dy);
if(type_vcm != NCL_double) NclFree(dvcm);
/* Return */
ret = NclReturnValue(vcm,ndims_vcm,dsizes_vcm,&missing_vcm,type_vcm,0);
NclFree(dsizes_vcm);
return(ret);
}
NhlErrorTypes area_hi2lores_W( void )
{
/*
* Input variables
*/
void *xi, *yi, *fi, *wyi, *xo, *yo;
double *tmp_xi, *tmp_yi, *tmp_fi, *tmp_xo, *tmp_yo, *tmp_fo;
double *tmp1_wyi, *tmp_wyi;
ng_size_t dsizes_xi[1], dsizes_yi[1], dsizes_wyi[1], dsizes_xo[1], dsizes_yo[1];
int ndims_fi;
ng_size_t dsizes_fi[NCL_MAX_DIMENSIONS];
int has_missing_fi;
NclScalar missing_fi, missing_dfi, missing_rfi;
logical *fi_cyclic_x, *fo_option;
NclBasicDataTypes type_xi, type_yi, type_fi, type_wyi, type_xo, type_yo;
/*
* Variables to look for attributes attached to fo_option.
*/
NclStackEntry stack_entry;
NclAttList *attr_list;
NclAtt attr_obj;
/*
* Output variables.
*/
void *fo;
ng_size_t *dsizes_fo;
NclBasicDataTypes type_fo;
NclScalar missing_fo;
/*
* Other variables
*/
int ret, ncyc = 0, ier = 0, debug = 0;
ng_size_t i, mxi, nyi, nfi, mxo, nyo, nfo, ngrd, size_fi, size_fo;
int imxi, inyi, imxo, inyo, ingrd;
double *critpc = NULL, *xilft, *xirgt, *yibot, *yitop, *xolft, *xorgt;
double *wxi, *dxi, *dyi, *fracx, *fracy;
double *ziwrk, *zowrk, *yiwrk, *yowrk;
int *indx, *indy;
NclBasicDataTypes type_critpc;
/*
* Retrieve parameters
*
* Note that any of the pointer parameters can be set to NULL,
* which implies you don't care about its value.
*/
xi = (void*)NclGetArgValue(
0,
8,
NULL,
dsizes_xi,
NULL,
NULL,
&type_xi,
DONT_CARE);
yi = (void*)NclGetArgValue(
1,
8,
NULL,
dsizes_yi,
NULL,
NULL,
&type_yi,
DONT_CARE);
fi = (void*)NclGetArgValue(
2,
8,
&ndims_fi,
dsizes_fi,
&missing_fi,
&has_missing_fi,
&type_fi,
DONT_CARE);
fi_cyclic_x = (logical*)NclGetArgValue(
3,
8,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
wyi = (void*)NclGetArgValue(
4,
8,
NULL,
dsizes_wyi,
NULL,
NULL,
&type_wyi,
DONT_CARE);
xo = (void*)NclGetArgValue(
5,
8,
NULL,
dsizes_xo,
NULL,
NULL,
&type_xo,
DONT_CARE);
yo = (void*)NclGetArgValue(
6,
8,
NULL,
dsizes_yo,
NULL,
NULL,
&type_yo,
DONT_CARE);
fo_option = (logical*)NclGetArgValue(
7,
8,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Check for "critpc" attribute.
*/
if(*fo_option) {
stack_entry = _NclGetArg(7,8,DONT_CARE);
switch(stack_entry.kind) {
case NclStk_VAR:
if (stack_entry.u.data_var->var.att_id != -1) {
attr_obj = (NclAtt) _NclGetObj(stack_entry.u.data_var->var.att_id);
if (attr_obj == NULL) {
break;
}
}
else {
/*
* att_id == -1, no attributes.
*/
break;
}
/*
* Check attributes for "critpc". If none, then just proceed as normal.
*/
if (attr_obj->att.n_atts == 0) {
break;
}
else {
/*
* att_n_atts > 0, retrieve optional arguments
*/
attr_list = attr_obj->att.att_list;
while (attr_list != NULL) {
if ((strcmp(attr_list->attname, "critpc")) == 0) {
type_critpc = attr_list->attvalue->multidval.data_type;
/*
* If "critpc" is already double, don't just point it to the attribute,
* because we need to return it later.
*/
if(type_critpc == NCL_double) {
critpc = (double *)calloc(1,sizeof(double));
*critpc = *(double*) attr_list->attvalue->multidval.val;
}
else if(type_critpc == NCL_int || type_critpc == NCL_float) {
/*
* Coerce to double.
*/
critpc = coerce_input_double(attr_list->attvalue->multidval.val,
type_critpc,1,0,NULL,NULL);
}
else {
NhlPError(NhlWARNING,NhlEUNKNOWN,"area_hi2lores: The 'critpc' attribute must be of type numeric. Defaulting to 100.");
}
}
attr_list = attr_list->next;
}
}
default:
break;
}
}
if(critpc == NULL) {
critpc = (double *)calloc(1,sizeof(double));
*critpc = 100.;
}
/*
* Compute the total number of elements in our arrays.
*/
mxi = dsizes_xi[0];
nyi = dsizes_yi[0];
mxo = dsizes_xo[0];
nyo = dsizes_yo[0];
nfi = mxi * nyi;
nfo = mxo * nyo;
if(mxi < 2 || nyi < 2) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_hi2lores: xi and yi must have at least two elements");
return(NhlFATAL);
}
if(dsizes_wyi[0] != nyi && dsizes_wyi[0] != 1) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_hi2lores: wyi must be a scalar or the same length as yi");
return(NhlFATAL);
}
/*
* Check dimensions of xi, yi, and fi. The last two dimensions of
* fi must be nyi x mxi.
*/
if(dsizes_fi[ndims_fi-2] != nyi && dsizes_fi[ndims_fi-1] != mxi) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_hi2lores: The rightmost dimensions of fi must be nyi x mxi, where nyi and mxi are the lengths of yi and xi respectively");
return(NhlFATAL);
}
/*
* Compute the size of the leftmost dimensions and output array.
*/
ngrd = 1;
for( i = 0; i < ndims_fi-2; i++ ) ngrd *= dsizes_fi[i];
size_fi = ngrd * nfi;
size_fo = ngrd * nfo;
/*
* Test dimension sizes.
*/
if((mxi > INT_MAX) || (nyi > INT_MAX) || (mxo > INT_MAX) ||
(nyo > INT_MAX) || (ngrd > INT_MAX)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_hi2lores: one or more dimension sizes is greater than INT_MAX");
return(NhlFATAL);
}
imxi = (int) mxi;
inyi = (int) nyi;
imxo = (int) mxo;
inyo = (int) nyo;
ingrd = (int) ngrd;
/*
* Coerce missing values for fi.
*/
coerce_missing(type_fi,has_missing_fi,&missing_fi,&missing_dfi,
&missing_rfi);
/*
* Allocate space for output array.
*/
if(type_fi == NCL_double) {
type_fo = NCL_double;
missing_fo = missing_dfi;
fo = (void*)calloc(size_fo,sizeof(double));
if(fo == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_hi2lores: Unable to allocate memory for output array");
return(NhlFATAL);
}
tmp_fo = fo;
}
else {
type_fo = NCL_float;
missing_fo = missing_rfi;
fo = (void*)calloc(size_fo,sizeof(float));
tmp_fo = (double*)calloc(size_fo,sizeof(double));
if(fo == NULL || tmp_fo == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_hi2lores: Unable to allocate memory for output array");
return(NhlFATAL);
}
}
dsizes_fo = (ng_size_t*)calloc(ndims_fi,sizeof(ng_size_t));
if(dsizes_fo == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_hi2lores: Unable to allocate memory for output array");
return(NhlFATAL);
}
for(i = 0; i < ndims_fi-2; i++) dsizes_fo[i] = dsizes_fi[i];
dsizes_fo[ndims_fi-2] = nyo;
dsizes_fo[ndims_fi-1] = mxo;
/*
* Coerce input arrays to double.
*/
tmp_xi = coerce_input_double(xi,type_xi,mxi,0,NULL,NULL);
tmp_yi = coerce_input_double(yi,type_yi,nyi,0,NULL,NULL);
tmp_fi = coerce_input_double(fi,type_fi,size_fi,0,NULL,NULL);
tmp_xo = coerce_input_double(xo,type_xo,mxo,0,NULL,NULL);
tmp_yo = coerce_input_double(yo,type_yo,nyo,0,NULL,NULL);
/*
* wyi can be a scalar, so copy it to array if necessary.
*/
tmp1_wyi = coerce_input_double(wyi,type_wyi,dsizes_wyi[0],0,NULL,NULL);
if(dsizes_wyi[0] == 1) {
tmp_wyi = copy_scalar_to_array(tmp1_wyi,1,dsizes_wyi,nyi);
}
else {
tmp_wyi = tmp1_wyi;
}
/*
* Allocate space for work arrays. There's a ton of them here.
*/
xilft = (double*)calloc(mxi,sizeof(double));
xirgt = (double*)calloc(mxi,sizeof(double));
yibot = (double*)calloc(nyi,sizeof(double));
yitop = (double*)calloc(nyi,sizeof(double));
xolft = (double*)calloc(mxo,sizeof(double));
xorgt = (double*)calloc(mxo,sizeof(double));
dxi = (double*)calloc(mxi,sizeof(double));
dyi = (double*)calloc(nyi,sizeof(double));
fracx = (double*)calloc(mxi*mxo,sizeof(double));
fracy = (double*)calloc(nyi*nyo,sizeof(double));
ziwrk = (double*)calloc(mxi*nyi,sizeof(double));
zowrk = (double*)calloc(mxo*nyo,sizeof(double));
yiwrk = (double*)calloc(nyi,sizeof(double));
yowrk = (double*)calloc(nyo,sizeof(double));
indx = (int*)calloc(2*mxo,sizeof(int));
indy = (int*)calloc(2*nyo,sizeof(int));
wxi = (double*)calloc(mxi,sizeof(double));
if(xilft == NULL || xirgt == NULL || yibot == NULL || yitop == NULL ||
xolft == NULL || xorgt == NULL || dxi == NULL || dyi == NULL ||
fracx == NULL || fracy == NULL || ziwrk == NULL || zowrk == NULL ||
yiwrk == NULL || yowrk == NULL || indx == NULL || indy == NULL ||
wxi == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"area_hi2lores: Unable to allocate memory for work arrays");
return(NhlFATAL);
}
for(i = 0; i < mxi; i++) wxi[i] = 1.;
/*
* Call Fortran function.
*/
NGCALLF(arealinint2da,AREALININT2DA)(&imxi,&inyi,&ingrd,tmp_xi,tmp_yi,tmp_fi,
wxi,tmp_wyi,&missing_dfi.doubleval,
fi_cyclic_x,&ncyc,&imxo,&inyo,tmp_xo,
tmp_yo,tmp_fo,critpc,&debug,&ier,
xilft,xirgt,yibot,yitop,dyi,xolft,
xorgt,yiwrk,yowrk,fracx,fracy,
ziwrk,zowrk,indx,indy);
if(ier) {
if(ier == -2) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"area_hi2lores: xi, xo must be monotonically increasing");
}
else if(ier == -5) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"area_hi2lores: both dimensions of the output grid must be of lower resolution than the input high resolution grid.");
}
else {
/*
* Note: we should never reach this point! We should always know the
* possible return values for 'ier'.
*/
NhlPError(NhlWARNING,NhlEUNKNOWN,"area_hi2lores: unknown error, returning all missing values.");
}
}
else {
coerce_output_float_or_double(fo,tmp_fo,type_fo,size_fo,0);
}
/*
* Free temp arrays.
*/
if(type_xi != NCL_double) NclFree(tmp_xi);
if(type_yi != NCL_double) NclFree(tmp_yi);
if(type_fi != NCL_double) NclFree(tmp_fi);
if(type_xo != NCL_double) NclFree(tmp_xo);
if(type_yo != NCL_double) NclFree(tmp_yo);
if(type_fo != NCL_double) NclFree(tmp_fo);
if(type_wyi != NCL_double) NclFree(tmp1_wyi);
if(dsizes_wyi[0] == 1) {
NclFree(tmp_wyi);
}
NclFree(wxi);
NclFree(xilft);
NclFree(xirgt);
NclFree(yibot);
NclFree(yitop);
NclFree(xolft);
NclFree(xorgt);
NclFree(dxi);
NclFree(dyi);
NclFree(fracx);
NclFree(fracy);
NclFree(ziwrk);
NclFree(zowrk);
NclFree(yiwrk);
NclFree(yowrk);
NclFree(indx);
NclFree(indy);
NclFree(critpc);
ret = NclReturnValue(fo,ndims_fi,dsizes_fo,&missing_fo,type_fo,0);
NclFree(dsizes_fo);
return(ret);
}
NhlErrorTypes 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 linint1_n_W( void )
{
/*
* Input variables
*/
void *xi, *fi, *xo;
double *tmp_xi, *tmp_xo,*tmp_fi, *tmp_fo;
int ndims_xi;
ng_size_t dsizes_xi[NCL_MAX_DIMENSIONS], dsizes_xo[NCL_MAX_DIMENSIONS];
int ndims_fi;
ng_size_t dsizes_fi[NCL_MAX_DIMENSIONS];
int has_missing_fi;
ng_size_t *dsizes_fo;
NclScalar missing_fi, missing_dfi, missing_rfi, missing_fo;
int *dim, *opt, iopt = 0;
logical *wrap;
NclBasicDataTypes type_xi, type_fi, type_xo, type_fo;
/*
* Output variables.
*/
void *fo;
/*
* Other variables
*/
ng_size_t nxi, nxi2, nxo, nfo, nd, nr, nl, nrnxi, nrnxo, ntotal, size_fo;
int inxi, inxi2, inxo, ier, ret;
ng_size_t i, j, index_nri, index_nro, index_fi, index_fo;
double *xiw, *fxiw;
/*
* Retrieve parameters
*
* Note that any of the pointer parameters can be set to NULL,
* which implies you don't care about its value.
*/
xi = (void*)NclGetArgValue(
0,
6,
&ndims_xi,
dsizes_xi,
NULL,
NULL,
&type_xi,
DONT_CARE);
fi = (void*)NclGetArgValue(
1,
6,
&ndims_fi,
dsizes_fi,
&missing_fi,
&has_missing_fi,
&type_fi,
DONT_CARE);
wrap = (logical*)NclGetArgValue(
2,
6,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
xo = (void*)NclGetArgValue(
3,
6,
NULL,
dsizes_xo,
NULL,
NULL,
&type_xo,
DONT_CARE);
opt = (int*)NclGetArgValue(
4,
6,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
dim = (int*)NclGetArgValue(
5,
6,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Some error checking. Make sure input dimension is valid.
*/
if(*dim < 0 || *dim >= ndims_fi) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1_n: Invalid dimension to do interpolation on, can't continue");
return(NhlFATAL);
}
/*
* Compute the total number of elements in our arrays and check them.
*/
nxi = dsizes_fi[*dim];
nxo = dsizes_xo[0];
nfo = nxo;
nxi2 = nxi + 2;
if(nxi < 2) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1_n: xi must have at least 2 elements");
return(NhlFATAL);
}
/*
* Test dimension sizes.
*/
if((nxi > INT_MAX) || (nxo > INT_MAX) || (nxi2 > INT_MAX)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1_n: one or more dimension sizes is greater than INT_MAX");
return(NhlFATAL);
}
inxi = (int) nxi;
inxo = (int) nxo;
inxi2 = (int) nxi2;
/*
* Check dimensions of xi and fi. If xi is not one-dimensional, then it
* must be the same size as fi. Otherwise, the dims-th dimension of
* fi must be equal to the length of xi.
*/
if(ndims_xi > 1) {
if(ndims_xi != ndims_fi) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1_n: If xi is not one-dimensional, then it must be the same size as fi");
return(NhlFATAL);
}
for(i = 0; i < ndims_fi; i++) {
if(dsizes_xi[i] != dsizes_fi[i]) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1_n: If xi is not one-dimensional, then it must be the same size as fi");
return(NhlFATAL);
}
}
}
else {
if(dsizes_xi[0] != nxi) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1_n: The dim-th dimension of fi must be the same length as xi");
return(NhlFATAL);
}
}
/*
* Calculate size of leftmost dimensions (nl) up to the dim-th
* dimension.
* Calculate size of rightmost dimensions (nr) from the
* dim-th dimension.
*
* The dimension to do the interpolation across is "dim".
*/
nl = nr = 1;
if(ndims_fi > 1) {
nd = ndims_fi-1;
for(i = 0; i < *dim ; i++) {
nl = nl*dsizes_fi[i];
}
for(i = *dim+1; i < ndims_fi; i++) {
nr = nr*dsizes_fi[i];
}
}
else {
nd = 1;
}
ntotal = nr * nl;
size_fo = ntotal * nfo;
/*
* Coerce missing values.
*/
coerce_missing(type_fi,has_missing_fi,&missing_fi,&missing_dfi,
&missing_rfi);
/*
* Allocate space for temporary output array.
*/
tmp_fo = (double*)calloc(nfo,sizeof(double));
if(tmp_fo == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1_n: Unable to allocate memory for temporary arrays");
return(NhlFATAL);
}
/*
* Allocate space for output array.
*/
dsizes_fo = (ng_size_t*)calloc(ndims_fi,sizeof(ng_size_t));
if(type_fi == NCL_double) {
fo = (void*)calloc(size_fo,sizeof(double));
type_fo = NCL_double;
missing_fo = missing_dfi;
}
else {
fo = (void*)calloc(size_fo,sizeof(float));
type_fo = NCL_float;
missing_fo = missing_rfi;
}
if(fo == NULL || dsizes_fo == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1_n: Unable to allocate memory for output array");
return(NhlFATAL);
}
/*
* Go ahead and copy all dimesions, but then replace the dim-th one.
*/
for(i = 0; i < ndims_fi; i++) dsizes_fo[i] = dsizes_fi[i];
dsizes_fo[*dim] = nxo;
/*
* Allocate space for work arrays.
*/
xiw = (double*)calloc(nxi2,sizeof(double));
fxiw = (double*)calloc(nxi2,sizeof(double));
if(xiw == NULL || fxiw == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1_n: Unable to allocate memory for work arrays");
return(NhlFATAL);
}
/*
* Coerce output array to double if necessary.
*/
tmp_xo = coerce_input_double(xo,type_xo,nxo,0,NULL,NULL);
if(tmp_xo == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1_n: Unable to coerce output array to double precision");
return(NhlFATAL);
}
if(ndims_xi == 1) {
tmp_xi = coerce_input_double(xi,type_xi,nxi,0,NULL,NULL);
}
else {
tmp_xi = (double*)calloc(nxi,sizeof(double));
if(tmp_xi == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1_n: Unable to allocate memory for coercing input array to double precision");
return(NhlFATAL);
}
}
tmp_fi = (double*)calloc(nxi,sizeof(double));
if(tmp_fi == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1_n: Unable to allocate memory for coercing input array to double precision");
return(NhlFATAL);
}
/*
* Loop through leftmost and rightmost dimensions and call Fortran
* routine for each array subsection.
*/
nrnxi = nr*nxi;
nrnxo = nr*nxo;
for( i = 0; i < nl; i++ ) {
index_nri = i*nrnxi;
index_nro = i*nrnxo;
for( j = 0; j < nr; j++ ) {
index_fi = index_nri+j;
index_fo = index_nro+j;
if(ndims_xi > 1) {
coerce_subset_input_double_step(xi,tmp_xi,index_fi,nr,type_xi,
nxi,0,NULL,NULL);
}
coerce_subset_input_double_step(fi,tmp_fi,index_fi,nr,type_fi,
nxi,0,NULL,NULL);
/*
* Call Fortran routine.
*/
NGCALLF(dlinint1,DLININT1)(&inxi,tmp_xi,tmp_fi,wrap,&inxo,tmp_xo,tmp_fo,
xiw,fxiw,&inxi2,&missing_dfi.doubleval,
&iopt,&ier);
if(ier) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"linint1_n: xi and xo must be monotonically increasing");
set_subset_output_missing_step(fo,index_fo,nr,type_fo,nfo,
missing_dfi.doubleval);
}
else {
coerce_output_float_or_double_step(fo,tmp_fo,type_fi,nfo,index_fo,nr);
}
}
}
/*
* Free temp arrays.
*/
if(ndims_xi > 1 || type_xi != NCL_double) NclFree(tmp_xi);
if(type_xo != NCL_double) NclFree(tmp_xo);
NclFree(tmp_fi);
NclFree(tmp_fo);
NclFree(xiw);
NclFree(fxiw);
ret = NclReturnValue(fo,ndims_fi,dsizes_fo,&missing_fo,type_fo,0);
NclFree(dsizes_fo);
return(ret);
}
NhlErrorTypes 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 dim_gamfit_n_W( void )
{
/*
* Input variables
*/
/*
* Argument # 0
*/
void *x;
double *tmp_x;
int ndims_x;
ng_size_t dsizes_x[NCL_MAX_DIMENSIONS];
int has_missing_x;
NclScalar missing_x, missing_flt_x, missing_dbl_x;
NclBasicDataTypes type_x;
/*
* Argument # 1
*/
logical *optgam;
/*
* Argument # 2
*/
int *dims;
ng_size_t dsizes_dims;
/*
* Return variable
*/
void *xpar;
int ndims_xpar;
ng_size_t *dsizes_xpar;
NclScalar missing_xpar;
NclBasicDataTypes type_xpar;
/*
* Variables for retrieving attributes from "optgam";
*/
NclAttList *attr_list;
NclAtt attr_obj;
NclStackEntry stack_entry;
/*
* Various
*/
ng_size_t npts;
int inpts;
ng_size_t index_x, index_xpar, index_nrx, index_nr;
double *pcrit = NULL;
logical set_pcrit;
double alpha, scale, shape, pzero;
int inv_scale, ier, ret;
ng_size_t i, j, nrnx, total_nr, total_nl, total_nlnr, size_output;
/*
* Retrieve parameters.
*
* Note any of the pointer parameters can be set to NULL, which
* implies you don't care about its value.
*/
/*
* Get argument # 0
*/
x = (void*)NclGetArgValue(
0,
3,
&ndims_x,
dsizes_x,
&missing_x,
&has_missing_x,
&type_x,
DONT_CARE);
/*
* Get argument # 1
*/
optgam = (logical*)NclGetArgValue(
1,
3,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Get dimension(s) to do computation on.
*/
dims = (int*)NclGetArgValue(
2,
3,
NULL,
&dsizes_dims,
NULL,
NULL,
NULL,
DONT_CARE);
/*
* Some error checking. Make sure input dimensions are valid.
*/
for(i = 0; i < dsizes_dims; i++ ) {
if(dims[i] < 0 || dims[i] >= ndims_x) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_gamfit_n: Invalid dimension sizes to do calculations across, can't continue");
return(NhlFATAL);
}
if(i > 0 && dims[i] != (dims[i-1]+1)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_gamfit_n: Input dimension sizes must be monotonically increasing, can't continue");
return(NhlFATAL);
}
}
/*
* Calculate size of leftmost dimensions (nl) up to the dims[0]-th
* dimensions.
*
* Calculate number of points that will be passed to Fortran
* routine (npts).
*
* Calculate size of rightmost dimensions (nr) from the
* ndims[ndims-1]-th dimension.
*
* The dimension(s) to do the calculations across are "dims".
*/
total_nl = total_nr = npts = 1;
if(ndims_x > 1) {
ndims_xpar = ndims_x-dsizes_dims+1;
dsizes_xpar = NclMalloc(ndims_xpar * sizeof(ng_size_t));
dsizes_xpar[0] = 3;
for(i = 0; i < dims[0] ; i++) {
total_nl = total_nl*dsizes_x[i];
dsizes_xpar[i+1] = dsizes_x[i];
}
for(i = 0; i < dsizes_dims ; i++) {
npts = npts*dsizes_x[dims[i]];
}
for(i = dims[dsizes_dims-1]+1; i < ndims_x; i++) {
total_nr = total_nr*dsizes_x[i];
dsizes_xpar[i-dsizes_dims+1] = dsizes_x[i];
}
} else {
dsizes_xpar = NclMalloc(sizeof(ng_size_t));
*dsizes_xpar = 3;
ndims_xpar = 1;
npts = dsizes_x[dims[0]];
}
total_nlnr = total_nl * total_nr;
size_output = 3 * total_nlnr;
if( npts > INT_MAX) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_gamfit_n: npts is greater than INT_MAX");
return(NhlFATAL);
}
inpts = (int) npts;
/*
* Allocate space for tmp_x.
*/
tmp_x = (double *)calloc(npts,sizeof(double));
if(tmp_x == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_gamfit_n: Unable to allocate memory for coercing input array to double");
return(NhlFATAL);
}
/*
* Coerce missing value to double if necessary.
*/
coerce_missing(type_x,has_missing_x,&missing_x,
&missing_dbl_x,&missing_flt_x);
/*
* Allocate space for output array.
*/
if(type_x != NCL_double) {
type_xpar = NCL_float;
xpar = (void *)calloc(size_output, sizeof(float));
}
else {
type_xpar = NCL_double;
xpar = (void *)calloc(size_output, sizeof(double));
}
if(xpar == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_gamfit_n: Unable to allocate memory for output array");
return(NhlFATAL);
}
if(has_missing_x) {
if(type_xpar == NCL_double) missing_xpar = missing_dbl_x;
else missing_xpar = missing_flt_x;
}
/*
* Retrieve attributes from optgam, if any.
*/
set_pcrit = False;
inv_scale = 0;
if(*optgam) {
stack_entry = _NclGetArg(1, 3, DONT_CARE);
switch (stack_entry.kind) {
case NclStk_VAR:
if (stack_entry.u.data_var->var.att_id != -1) {
attr_obj = (NclAtt) _NclGetObj(stack_entry.u.data_var->var.att_id);
if (attr_obj == NULL) {
break;
}
}
else {
/*
* att_id == -1 ==> no attributes specified.
*/
break;
}
/*
* Check for attributes. If none are set, then use default values.
*/
if (attr_obj->att.n_atts == 0) {
break;
}
else {
/*
* Get list of attributes.
*/
attr_list = attr_obj->att.att_list;
/*
* Loop through attributes and check them.
*/
while (attr_list != NULL) {
/*
* pcrit
*/
if ((strcmp(attr_list->attname, "pcrit")) == 0) {
pcrit = coerce_input_double(attr_list->attvalue->multidval.val,
attr_list->attvalue->multidval.data_type,
1,0,NULL,NULL);
set_pcrit = True;
}
/*
* inv_scale
*/
if ((strcmp(attr_list->attname, "inv_scale")) == 0) {
if(attr_list->attvalue->multidval.data_type != NCL_logical) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"dim_gamfit_n: the 'inv_scale' attribute must be a logical, defaulting to False.");
}
else if(*(logical*)attr_list->attvalue->multidval.val) {
inv_scale = 1;
}
}
attr_list = attr_list->next;
}
}
default:
break;
}
}
if(!set_pcrit) {
pcrit = (double *)calloc(1,sizeof(double));
*pcrit = 0.0;
}
/*
* Loop across leftmost dimensions and call the Fortran routine for each
* subsection of the input arrays.
*/
nrnx = total_nr * npts;
for(i = 0; i < total_nl; i++) {
index_nrx = i*nrnx;
index_nr = i*total_nr;
for(j = 0; j < total_nr; j++) {
index_x = index_nrx + j;
index_xpar = index_nr + j;
/*
* Coerce subsection of x (tmp_x) to double.
*/
coerce_subset_input_double_step(x,tmp_x,index_x,total_nr,type_x,
npts,0,NULL,NULL);
/*
* Call the Fortran routine.
*/
NGCALLF(gamfitd3,GAMFITD3)(tmp_x, &inpts, &missing_dbl_x.doubleval,
pcrit, &inv_scale, &alpha, &scale,
&shape, &pzero, &ier);
/*
* Coerce output back to float or double
*/
coerce_output_float_or_double(xpar,&shape,type_xpar,1,index_xpar);
coerce_output_float_or_double(xpar,&scale,type_xpar,1,
index_xpar+total_nlnr);
coerce_output_float_or_double(xpar,&pzero,type_xpar,1,
index_xpar+(2*total_nlnr));
}
}
/*
* Free unneeded memory.
*/
NclFree(tmp_x);
/*
* Return value back to NCL script.
*/
if(has_missing_x) {
ret = NclReturnValue(xpar,ndims_xpar,dsizes_xpar,&missing_xpar,
type_xpar,0);
}
else {
ret = NclReturnValue(xpar,ndims_xpar,dsizes_xpar,NULL,type_xpar,0);
}
NclFree(dsizes_xpar);
return(ret);
}
NhlErrorTypes round_W( void )
{
/*
* Input array variables
*/
void *x;
double *tmp_x;
int has_missing_x, ndims_x;
ng_size_t dsizes_x[NCL_MAX_DIMENSIONS];
int *iopt, isx;
NclScalar missing_x, missing_dx, missing_xout;
NclBasicDataTypes type_x;
/*
* Output array variables
*/
void *xout = NULL;
double *tmp_xout;
NclBasicDataTypes type_xout = NCL_none;
/*
* Declare various variables for random purposes.
*/
ng_size_t i, size_x;
/*
* Retrieve argument.
*/
x = (void*)NclGetArgValue(
0,
2,
&ndims_x,
dsizes_x,
&missing_x,
&has_missing_x,
&type_x,
DONT_CARE);
/*
* Retrieve iopt. Currently, the value of iopt specifies the following:
*
* 0 -> depending on input, return float or double
* 1 -> send the output back as float
* 2 -> send the output back as double
* 3 -> send the output back as integer
*/
iopt = (int*)NclGetArgValue(
1,
2,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
if(*iopt < 0 || *iopt > 3) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"round: 'iopt' can only have the values 0-3");
return(NhlFATAL);
}
/*
* Compute the total size of the input array.
*/
size_x = 1;
for( i = 0; i < ndims_x; i++ ) size_x *= dsizes_x[i];
if(size_x > INT_MAX) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"round: size_x = %ld is greater than INT_MAX", size_x);
return(NhlFATAL);
}
isx = (int) size_x;
/*
* Coerce input and missing value to double if necessary.
*/
tmp_x = coerce_input_double(x,type_x,size_x,0,NULL,NULL);
coerce_missing(type_x,has_missing_x,&missing_x,&missing_dx,NULL);
/*
* The type of the output array depends on iopt and possibly the
* type of the input.
*/
switch(*iopt) {
case 0:
if(type_x != NCL_double) {
type_xout = NCL_float;
}
else {
type_xout = NCL_double;
}
break;
case 1:
type_xout = NCL_float;
break;
case 2:
type_xout = NCL_double;
break;
case 3:
type_xout = NCL_int;
break;
}
/*
* Allocate memory for output.
*/
switch(type_xout) {
case NCL_double:
xout = (void*)calloc(size_x,sizeof(double));
break;
case NCL_float:
xout = (void*)calloc(size_x,sizeof(float));
break;
case NCL_int:
xout = (void*)calloc(size_x,sizeof(int));
break;
default:
break;
}
/*
* Allocate space for temporary output which must be double. If the output
* is already double, then just point tmp_xout to xout.
*/
if(type_xout == NCL_double) {
tmp_xout = (double*)xout;
}
else {
tmp_xout = (double*)calloc(size_x,sizeof(double));
}
if(tmp_xout == NULL || xout == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"round: Unable to allocate memory for output arrays");
return(NhlFATAL);
}
/*
* Call the Fortran version of this routine.
*/
NGCALLF(rndncl,RNDNCL)(&isx,tmp_x,&has_missing_x,
&missing_dx.doubleval,tmp_xout,iopt);
/*
* Figure out if we need to coerce output back to float or int.
*/
if(type_xout == NCL_float) {
coerce_output_float_only(xout,tmp_xout,size_x,0);
}
if(type_xout == NCL_int) {
coerce_output_int_only(xout,tmp_xout,size_x,0);
}
/*
* Return correct missing value type for output.
*/
switch(type_xout) {
case NCL_double:
missing_xout.doubleval = missing_dx.doubleval;
break;
case NCL_float:
missing_xout.floatval = (float)missing_dx.doubleval;
break;
case NCL_int:
missing_xout.intval = (int)missing_dx.doubleval;
break;
default:
break;
}
/*
* Free memory.
*/
if(type_x != NCL_double) NclFree(tmp_x);
if(type_xout != NCL_double) NclFree(tmp_xout);
/*
* Return.
*/
if(has_missing_x) {
return(NclReturnValue(xout,ndims_x,dsizes_x,&missing_xout,type_xout,0));
}
else{
return(NclReturnValue(xout,ndims_x,dsizes_x,NULL,type_xout,0));
}
}
NhlErrorTypes 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 ctwrap_W( void )
{
int *wks;
float *lat, *lon, *data;
ng_size_t nlat, nlon, nlon8, dsizes_lat[2], dsizes_lon[2], dsizes_data[2];
int inlat, inlon, idim, jdim;
logical *opt;
/*
* Variables for retrieving workstation information.
*/
int grlist, gkswid, nwks;
NclHLUObj tmp_hlu_obj;
/*
* Work arrays.
*/
float *rpnt, *rwrk, *xcra, *ycra;
int *iedg, *itri, *ippp, *ippe, *iwrk, *icra, *iama, *iaai, *iagi;
int mpnt, medg, mtri, mnop, mnoe, mnot, lrwk, liwk, lama, ncra, ngps;
int icam, ican, lopn, loen, lotn;
/*
* Variables for retrieving attributes from "opt".
*/
logical idbg = False, igrd = False, imsh = False;
logical icon = True, icol = False, icap = False;
NrmQuark *MapProjection, *fnam;
char *cMapProjection, *cnam = NULL;
int imap = 2, ilev = -1, itim = -1;
NclAttList *attr_list;
NclAtt attr_obj;
NclStackEntry stack_entry;
/*
* Retrieve parameters.
*/
wks = (int*)NclGetArgValue(0,5, NULL, NULL,NULL,NULL,NULL,DONT_CARE);
lat = (float*)NclGetArgValue(1,5, NULL, dsizes_lat, NULL,NULL,NULL,DONT_CARE);
lon = (float*)NclGetArgValue(2,5, NULL, dsizes_lon, NULL,NULL,NULL,DONT_CARE);
data = (float*)NclGetArgValue(3,5, NULL, dsizes_data, NULL,NULL,NULL,DONT_CARE);
opt = (logical*)NclGetArgValue(4,5, NULL,NULL,NULL,NULL,NULL,DONT_CARE);
/*
* Check input sizes.
*/
nlat = dsizes_lat[0];
nlon = dsizes_lat[1];
if( dsizes_lon[0] != nlat || dsizes_lon[1] != nlon ||
dsizes_data[0] != nlat || dsizes_data[1] != nlon ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ctwrap: the dimension sizes of the lat/lon arrays and the data must be same");
return(NhlFATAL);
}
/*
* Hopefully the number of longitudes is divisible by 8 (the nature of the
* SEAM grid), so get that number here.
*/
nlon8 = nlon/8;
if ((nlat > INT_MAX) || (nlon > INT_MAX) || (nlon8 > INT_MAX)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ctwrap: one or more input dimension sizes is > INT_MAX");
return(NhlFATAL);
}
inlat = (int) nlat;
inlon = (int) nlon;
idim = jdim = (int) nlon8;
/*
* Determine the NCL identifier for the graphic object.
*/
tmp_hlu_obj = (NclHLUObj) _NclGetObj(*wks);
nwks = tmp_hlu_obj->hlu.hlu_id;
/*
* Retrieve the GKS workstation id from the workstation object.
*/
grlist = NhlRLCreate(NhlGETRL);
NhlRLClear(grlist);
NhlRLGetInteger(grlist,NhlNwkGksWorkId,&gkswid);
NhlGetValues(nwks,grlist);
/*
* Activate workstation.
*/
gactivate_ws (gkswid);
/*
* Create work arrays, lots of them.
*/
lopn = 5;
loen = 5;
lotn = 4;
mnop = 7352;
mnoe = 22050;
mnot = 14700;
lrwk = 10000;
liwk = 1000;
lama = 400000;
ncra = lama/10;
icam = 512; /* could be 1024? */
ican = 512; /* could be 1024? */
ngps = 2;
mpnt = mnop*lopn; /* space for points */
medg = mnoe*loen; /* space for edges */
mtri = mnot*lotn; /* space for triangles */
rpnt = (float *)calloc(mpnt,sizeof(float));
rwrk = (float *)calloc(lrwk,sizeof(float));
xcra = (float *)calloc(ncra,sizeof(float));
ycra = (float *)calloc(ncra,sizeof(float));
iwrk = (int *)calloc(liwk,sizeof(int));
iama = (int *)calloc(lama,sizeof(int));
iaai = (int *)calloc(ngps,sizeof(int));
iagi = (int *)calloc(ngps,sizeof(int));
icra = (int *)calloc(icam*ican,sizeof(int));
iedg = (int *)calloc(medg,sizeof(int));
itri = (int *)calloc(mtri,sizeof(int));
ippp = (int *)calloc(2*mnop,sizeof(int));
ippe = (int *)calloc(2*mnoe,sizeof(int));
if(rpnt == NULL || rwrk == NULL || xcra == NULL || ycra == NULL ||
iwrk == NULL || iama == NULL || iaai == NULL || iagi == NULL ||
icra == NULL || iedg == NULL || itri == NULL || ippp == NULL ||
ippe == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ctwrap: Unable to allocate memory for work arrays");
return(NhlFATAL);
}
/*
* If "opt" is True, then check if any attributes have been set.
*/
if(*opt) {
stack_entry = _NclGetArg(4, 5, DONT_CARE);
switch (stack_entry.kind) {
case NclStk_VAR:
if (stack_entry.u.data_var->var.att_id != -1) {
attr_obj = (NclAtt) _NclGetObj(stack_entry.u.data_var->var.att_id);
if (attr_obj == NULL) {
break;
}
}
else {
/*
* att_id == -1 ==> no optional args given.
*/
break;
}
/*
* Get optional arguments.
*/
if (attr_obj->att.n_atts <= 0) {
break;
}
/*
* Get list of attributes.
*/
attr_list = attr_obj->att.att_list;
/*
* Loop through attributes and check them. The current ones recognized are:
*
* "RectangularMesh"
* "TriangularMesh"
* "LineContours"
* "FilledContours"
* "CellArray"
* "MapProjection"
* "FieldName"
* "TimeStep"
* "Level"
* "Debug"
*/
while (attr_list != NULL) {
/*
* Check for "RectangularGrid".
*/
if (!strcmp(attr_list->attname, "RectangularGrid")) {
if(attr_list->attvalue->multidval.data_type != NCL_logical) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"ctwrap: The 'RectangularGrid' attribute must be a logical, defaulting to False.");
}
else {
igrd = *(logical*) attr_list->attvalue->multidval.val;
}
}
/*
* Check for "TriangularMesh".
*/
if (!strcmp(attr_list->attname, "TriangularMesh")) {
if(attr_list->attvalue->multidval.data_type != NCL_logical) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"ctwrap: The 'TriangularMesh' attribute must be a logical, defaulting to False.");
}
else {
imsh = *(logical*) attr_list->attvalue->multidval.val;
}
}
/*
* Check for "LineContours".
*/
if (!strcmp(attr_list->attname, "LineContours")) {
if(attr_list->attvalue->multidval.data_type != NCL_logical) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"ctwrap: The 'LineContours' attribute must be a logical, defaulting to True.");
}
else {
icon = *(logical*) attr_list->attvalue->multidval.val;
}
}
/*
* Check for "FilledContours".
*/
if (!strcmp(attr_list->attname, "FilledContours")) {
if(attr_list->attvalue->multidval.data_type != NCL_logical) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"ctwrap: The 'FilledContours' attribute must be a logical, defaulting to False.");
}
else {
icol = *(logical*) attr_list->attvalue->multidval.val;
}
}
/*
* Check for "CellArray".
*/
if (!strcmp(attr_list->attname, "CellArray")) {
if(attr_list->attvalue->multidval.data_type != NCL_logical) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"ctwrap: The 'CellArray' attribute must be a logical, defaulting to False.");
}
else {
icap = *(logical*) attr_list->attvalue->multidval.val;
}
}
/*
* Check for "FieldName".
*/
if (!strcmp(attr_list->attname, "FieldName")) {
if(attr_list->attvalue->multidval.data_type != NCL_string) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"ctwrap: The 'FieldName' attribute must be a string, ignoring...");
}
else {
fnam = (NrmQuark *) attr_list->attvalue->multidval.val;
cnam = NrmQuarkToString(*fnam);
}
}
/*
* Check for "TimeStep".
*/
if (!strcmp(attr_list->attname, "TimeStep")) {
if(attr_list->attvalue->multidval.data_type != NCL_int) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"ctwrap: The 'TimeStep' attribute must be an integer, defaulting to -1.");
}
else {
itim = *(int*) attr_list->attvalue->multidval.val;
}
}
/*
* Check for "Level".
*/
if (!strcmp(attr_list->attname, "Level")) {
if(attr_list->attvalue->multidval.data_type != NCL_int) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"ctwrap: The 'Level' attribute must be an integer, defaulting to -1.");
}
else {
ilev = *(int*) attr_list->attvalue->multidval.val;
}
}
/*
* Check for "Debug".
*/
if (!strcmp(attr_list->attname, "Debug")) {
if(attr_list->attvalue->multidval.data_type != NCL_logical) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"ctwrap: The 'Debug' attribute must be a logical, defaulting to False.");
}
else {
idbg = *(logical*) attr_list->attvalue->multidval.val;
}
}
/*
* Check for "MapProjection".
*/
if (!strcmp(attr_list->attname, "MapProjection")) {
if(attr_list->attvalue->multidval.data_type != NCL_string) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"ctwrap: The 'MapProjection' attribute must be a string, defaulting to 'CylindricalEquidistant.'");
}
else {
MapProjection = (NrmQuark *) attr_list->attvalue->multidval.val;
cMapProjection = NrmQuarkToString(*MapProjection);
if(!strcmp(cMapProjection,"Orthographic")) {
imap = 1;
}
else if(!strcmp(cMapProjection,"CylindricalEquidistant")) {
imap = 2;
}
else if(!strcmp(cMapProjection,"Robinson")) {
imap = 3;
}
else if(!strcmp(cMapProjection,"LambertEqualArea")) {
imap = 4;
}
else {
NhlPError(NhlWARNING,NhlEUNKNOWN,"ctwrap: Unrecognized value for the 'MapProjection' attribute. Defaulting to 'CylindricalEquidistant'.");
imap = 2;
}
}
}
attr_list = attr_list->next;
}
default:
break;
}
}
if(cnam == NULL) {
cnam = (char*)calloc(2,sizeof(char));
strcpy(cnam,"");
}
NGCALLF(ctdriver,CTDRIVER)(&gkswid,lat,lon,data,&inlat,&inlon,&idim,&jdim,
rpnt,&mpnt,rwrk,&lrwk,xcra,ycra,&ncra,iwrk,
&liwk,iama,&lama,iaai,iagi,&ngps,icra,&icam,
&ican,iedg,&medg,itri,&mtri,ippp,&mnop,ippe,
&mnoe,&lopn,&loen,&lotn,&igrd,&imsh,&icon,&icol,
&icap,&imap,cnam,&itim,&ilev,&idbg,
strlen(cnam));
/*
* Free work arrays.
*/
NclFree(rpnt);
NclFree(rwrk);
NclFree(xcra);
NclFree(ycra);
NclFree(iwrk);
NclFree(iama);
NclFree(iaai);
NclFree(iagi);
NclFree(icra);
NclFree(iedg);
NclFree(itri);
NclFree(ippp);
NclFree(ippe);
/*
* Deactivate workstation.
*/
gdeactivate_ws (gkswid);
return(NhlNOERROR);
}
NhlErrorTypes ut_inv_calendar_W( void )
{
/*
* Input array variables
*/
int *year, *month, *day, *hour, *minute;
void *second;
double *tmp_second = NULL;
NrmQuark *sspec;
int *option;
char *cspec, *cspec_orig;
int ndims_year;
ng_size_t dsizes_year[NCL_MAX_DIMENSIONS];
int has_missing_year;
int ndims_month;
ng_size_t dsizes_month[NCL_MAX_DIMENSIONS];
int has_missing_month;
int ndims_day;
ng_size_t dsizes_day[NCL_MAX_DIMENSIONS];
int has_missing_day;
int ndims_hour;
ng_size_t dsizes_hour[NCL_MAX_DIMENSIONS];
int has_missing_hour;
int ndims_minute;
ng_size_t dsizes_minute[NCL_MAX_DIMENSIONS];
int has_missing_minute;
int ndims_second;
ng_size_t dsizes_second[NCL_MAX_DIMENSIONS];
int has_missing_second;
NclScalar missing_year;
NclScalar missing_month;
NclScalar missing_day;
NclScalar missing_hour;
NclScalar missing_minute;
NclScalar missing_second;
NclBasicDataTypes type_second;
/*
* Variables for Udunits package.
*/
ut_system *utopen_ncl(), *unit_system;
ut_unit *utunit;
/*
* Variables for retrieving attributes from last argument.
*/
NclAttList *attr_list;
NclAtt attr_obj;
NclStackEntry stack_entry;
NrmQuark *scal;
char *ccal = NULL;
/*
* Output variables.
*/
double *x;
int has_missing_x;
NclScalar missing_x;
/*
* Variables for returning "units" and "calendar" attributes.
*/
NclQuark *units, *calendar;
int att_id;
NclMultiDValData att_md, return_md;
NclVar tmp_var;
NclStackEntry return_data;
/*
* various
*/
ng_size_t i, total_size_input;
ng_size_t dsizes[1], return_missing;
int months_to_days_fix=0, years_to_days_fix=0;
/*
* Before we do anything, initialize the Udunits package.
*/
unit_system = utopen_ncl();
/*
* Retrieve parameters
*
* Note any of the pointer parameters can be set to NULL, which
* implies you don't care about its value.
* The first size input arrays must be the same dimension sizes.
*/
year = (int*)NclGetArgValue(
0,
8,
&ndims_year,
dsizes_year,
&missing_year,
&has_missing_year,
NULL,
DONT_CARE);
month = (int*)NclGetArgValue(
1,
8,
&ndims_month,
dsizes_month,
&missing_month,
&has_missing_month,
NULL,
DONT_CARE);
day = (int*)NclGetArgValue(
2,
8,
&ndims_day,
dsizes_day,
&missing_day,
&has_missing_day,
NULL,
DONT_CARE);
hour = (int*)NclGetArgValue(
3,
8,
&ndims_hour,
dsizes_hour,
&missing_hour,
&has_missing_hour,
NULL,
DONT_CARE);
minute = (int*)NclGetArgValue(
4,
8,
&ndims_minute,
dsizes_minute,
&missing_minute,
&has_missing_minute,
NULL,
DONT_CARE);
second = (void*)NclGetArgValue(
5,
8,
&ndims_second,
dsizes_second,
&missing_second,
&has_missing_second,
&type_second,
DONT_CARE);
if(ndims_year != ndims_month || ndims_year != ndims_day ||
ndims_year != ndims_hour || ndims_year != ndims_minute ||
ndims_year != ndims_second) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ut_inv_calendar: The first six arguments must have the same dimensionality");
return(NhlFATAL);
}
for(i = 0; i < ndims_year; i++ ) {
if(dsizes_year[i] != dsizes_month[i] ||
dsizes_year[i] != dsizes_day[i] ||
dsizes_year[i] != dsizes_hour[i] ||
dsizes_year[i] != dsizes_minute[i] ||
dsizes_year[i] != dsizes_second[i]) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ut_inv_calendar: The first six arguments must have the same dimensionality");
return(NhlFATAL);
}
}
/*
* x will contain a _FillValue attribute if any of the input
* has a _FillValue attribute set.
*/
if(has_missing_year || has_missing_month || has_missing_day ||
has_missing_hour || has_missing_minute || has_missing_second) {
has_missing_x = 1;
/*
* Get the default missing value for a double type.
*/
missing_x = ((NclTypeClass)nclTypedoubleClass)->type_class.default_mis;
}
else {
has_missing_x = 0;
}
/*
* Get spec string.
*/
sspec = (NrmQuark *)NclGetArgValue(
6,
8,
NULL,
NULL,
NULL,
NULL,
NULL,
1);
/*
* Get option.
*/
option = (int*)NclGetArgValue(
7,
8,
NULL,
NULL,
NULL,
NULL,
NULL,
1);
/*
* Check the "option" variable to see if it contains a "calendar"
* attribute.
*/
return_missing = 0;
stack_entry = _NclGetArg(7, 8, DONT_CARE);
switch (stack_entry.kind) {
case NclStk_VAR:
if (stack_entry.u.data_var->var.att_id != -1) {
attr_obj = (NclAtt) _NclGetObj(stack_entry.u.data_var->var.att_id);
if (attr_obj == NULL) {
break;
}
}
else {
/*
* att_id == -1 ==> no attributes specified args given.
*/
break;
}
/*
* Get optional arguments.
*/
if (attr_obj->att.n_atts > 0) {
/*
* Get list of attributes.
*/
attr_list = attr_obj->att.att_list;
/*
* Loop through attributes and check them.
*/
while (attr_list != NULL) {
if ((strcmp(attr_list->attname, "calendar")) == 0) {
scal = (NrmQuark *) attr_list->attvalue->multidval.val;
ccal = NrmQuarkToString(*scal);
if(strcasecmp(ccal,"standard") && strcasecmp(ccal,"gregorian") &&
strcasecmp(ccal,"noleap") && strcasecmp(ccal,"365_day") &&
strcasecmp(ccal,"365") && strcasecmp(ccal,"360_day") &&
strcasecmp(ccal,"360") ) {
NhlPError(NhlWARNING,NhlEUNKNOWN,"ut_inv_calendar: the 'calendar' attribute is not equal to a recognized calendar. Returning all missing values.");
return_missing = has_missing_x = 1;
}
}
attr_list = attr_list->next;
}
}
default:
break;
}
/*
* Convert sspec to character string.
*/
cspec = NrmQuarkToString(*sspec);
/*
* There's a bug in utInvCalendar2_cal that doesn't handle the
* 360-day calendar correctly if units are "years since" or
* "months since".
*
* To fix this bug, we convert these units to "days since", do the
* calculation as "days since", and then convert back to the original
* "years since" or "months since" requested units.
*/
cspec_orig = (char*)calloc(strlen(cspec)+1,sizeof(char));
strcpy(cspec_orig,cspec);
cspec = fix_units_for_360_bug(ccal,cspec,&months_to_days_fix,
&years_to_days_fix);
/*
* Make sure cspec is a valid udunits string.
*/
utunit = ut_parse(unit_system, cspec, UT_ASCII);
if(utunit == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ut_inv_calendar: Invalid specification string");
return(NhlFATAL);
}
/*
* Calculate total size of input arrays, and size and dimensions for
* output array, and alloc memory for output array.
*/
total_size_input = 1;
for( i = 0; i < ndims_year; i++ ) total_size_input *= dsizes_year[i];
x = (double *)calloc(total_size_input,sizeof(double));
if( x == NULL ) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ut_inv_calendar: Unable to allocate memory for output array");
return(NhlFATAL);
}
/*
* Create tmp array for coercing second to double if necessary.
*/
if(type_second != NCL_double) {
tmp_second = (double*)calloc(1,sizeof(double));
if(tmp_second == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"ut_inv_calendar: Unable to allocate memory for coercing second array to double precision");
return(NhlFATAL);
}
}
/*
* Loop through each data value, and call Udunits routine.
*/
for( i = 0; i < total_size_input; i++ ) {
/*
* Coerce "second" to double, since this is what the original Udunits
* routine is expecting.
*/
if(type_second != NCL_double) {
coerce_subset_input_double(second,tmp_second,i,type_second,1,
has_missing_second,&missing_second,NULL);
}
else {
tmp_second = &((double*)second)[i];
}
if(!return_missing && (!has_missing_year ||
(has_missing_year && year[i] != missing_year.intval)) &&
(!has_missing_month ||
(has_missing_month && month[i] != missing_month.intval)) &&
(!has_missing_day ||
(has_missing_day && day[i] != missing_day.intval)) &&
(!has_missing_hour ||
(has_missing_hour && hour[i] != missing_hour.intval)) &&
(!has_missing_minute ||
(has_missing_minute && minute[i] != missing_minute.intval)) &&
(!has_missing_second ||
(has_missing_second && *tmp_second != missing_second.doubleval)) ) {
(void)utInvCalendar2_cal(year[i],month[i],day[i],hour[i],
minute[i],*tmp_second,utunit,&x[i],ccal);
/*
* This is the bug fix for 360 day calendars and a units
* of "years since" or "months since". We have to convert
* from "days since" to the original requested units.
*
* See above for more information about the bug.
*/
if(years_to_days_fix == 1) x[i] /= 360.;
if(months_to_days_fix == 1) x[i] /= 30.;
}
else {
x[i] = missing_x.doubleval;
}
}
/*
* Close up Udunits.
*/
utclose_ncl(unit_system);
/*
* Set original units back if necessary.
*/
if(months_to_days_fix || years_to_days_fix) {
cspec = cspec_orig;
}
else {
NclFree(cspec_orig);
}
if(type_second != NCL_double) NclFree(tmp_second);
/*
* Set up variable to return.
*/
if(has_missing_x) {
return_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
x,
&missing_x,
ndims_year,
dsizes_year,
TEMPORARY,
NULL,
(NclObjClass)nclTypedoubleClass
);
}
else {
return_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
x,
NULL,
ndims_year,
dsizes_year,
TEMPORARY,
NULL,
(NclObjClass)nclTypedoubleClass
);
}
/*
* Set up attributes to return.
*/
att_id = _NclAttCreate(NULL,NULL,Ncl_Att,0,NULL);
dsizes[0] = 1;
/*
* Return "units" attribute.
*
* We can't just return "sspec" here, because it's an NCL input
* parameter and this seems to screw things up if we try to
* return it as an attribute.
*/
units = (NclQuark*)NclMalloc(sizeof(NclQuark));
*units = NrmStringToQuark(cspec);
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
(void*)units,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
(NclObjClass)nclTypestringClass
);
_NclAddAtt(
att_id,
"units",
att_md,
NULL
);
/*
* Return "calendar" attribute.
*
* We can't just return "sspec" here, because it's an NCL input
* parameter and this seems to screw things up if we try to
* return it as an attribute.
*/
calendar = (NclQuark*)NclMalloc(sizeof(NclQuark));
if(ccal != NULL) {
*calendar = NrmStringToQuark(ccal);
}
else {
*calendar = NrmStringToQuark("standard");
}
att_md = _NclCreateVal(
NULL,
NULL,
Ncl_MultiDValData,
0,
(void*)calendar,
NULL,
1,
dsizes,
TEMPORARY,
NULL,
(NclObjClass)nclTypestringClass
);
_NclAddAtt(
att_id,
"calendar",
att_md,
NULL
);
tmp_var = _NclVarCreate(
NULL,
NULL,
Ncl_Var,
0,
NULL,
return_md,
NULL,
att_id,
NULL,
RETURNVAR,
NULL,
TEMPORARY
);
/*
* Return output grid and attributes to NCL.
*/
return_data.kind = NclStk_VAR;
return_data.u.data_var = tmp_var;
_NclPlaceReturn(return_data);
return(NhlNOERROR);
}
NhlErrorTypes paleo_outline_W( void )
{
/*
* Input array variables
*/
void *oro, *lat, *lon;
float *landmask;
double *tmp_oro, *tmp_lat, *tmp_lon;
ng_size_t dsizes_oro[2], dsizes_lat[1], dsizes_lon[1];
NclBasicDataTypes type_oro, type_lat, type_lon;
NrmQuark *name;
/*
* Other variables
*/
float *zdat;
char *cname;
int *iwrk, inlon, inlat, iliwk, iim, ijm;
ng_size_t liwk, nlat, nlon, jm, im;
/*
* Retrieve arguments.
*/
oro = (void*)NclGetArgValue(
0,
5,
NULL,
dsizes_oro,
NULL,
NULL,
&type_oro,
DONT_CARE);
lat = (void*)NclGetArgValue(
1,
5,
NULL,
dsizes_lat,
NULL,
NULL,
&type_lat,
DONT_CARE);
lon = (void*)NclGetArgValue(
2,
5,
NULL,
dsizes_lon,
NULL,
NULL,
&type_lon,
DONT_CARE);
landmask = (float*)NclGetArgValue(
3,
5,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
name = (NrmQuark *)NclGetArgValue(
4,
5,
NULL,
NULL,
NULL,
NULL,
NULL,
DONT_CARE);
cname = NrmQuarkToString(*name);
nlat = dsizes_oro[0];
nlon = dsizes_oro[1];
if(dsizes_lat[0] != nlat || dsizes_lon[0] != nlon) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"paleo_outline: the length of the lat array must be the same as the leftmost dimension of oro, and the length of the lon arrays must be the same as the rightmost dimension of oro");
return(NhlFATAL);
}
/*
* Convert input arrays to double if necessary.
*/
tmp_oro = coerce_input_double(oro,type_oro,nlat*nlon,0,NULL,NULL);
tmp_lat = coerce_input_double(lat,type_lat,nlat,0,NULL,NULL);
tmp_lon = coerce_input_double(lon,type_lon,nlon,0,NULL,NULL);
if(tmp_oro == NULL || tmp_lat == NULL || tmp_lon == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"paleo_outline: Unable to coerce input arrays to double precision");
return(NhlFATAL);
}
/*
* Allocate space for work arrays.
*/
jm = 2*nlat+1;
im = 2*nlon+1;
liwk = max(im * jm,2000); /* 2000 is the old value that iwrk
was hard-wired to. */
/*
* Test input dimension sizes.
*/
if((nlon > INT_MAX) || (nlat > INT_MAX) || (liwk > INT_MAX) ||
(im > INT_MAX) || (jm > INT_MAX)) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"paleo_outline: one or more input dimension sizes is greater than INT_MAX");
return(NhlFATAL);
}
inlon = (int) nlon;
inlat = (int) nlat;
iliwk = (int) liwk;
iim = (int) im;
ijm = (int) jm;
/*
* Allocate work arrays.
*/
zdat = (float*)malloc(jm*im*sizeof(float));
iwrk = (int*)malloc(liwk*sizeof(int));
if(zdat == NULL || iwrk == NULL) {
NhlPError(NhlFATAL,NhlEUNKNOWN,"paleo_outline: Unable to allocate memory for work arrays");
return(NhlFATAL);
}
/*
* Call the Fortran paleo_outline routine.
*/
NGCALLF(paleooutline,PALEOOUTLINE)(tmp_oro,zdat,tmp_lat,tmp_lon,
&inlat,&inlon,&ijm,&iim,iwrk,&iliwk,
cname,landmask,strlen(cname));
if(type_oro != NCL_double) NclFree(tmp_oro);
if(type_lat != NCL_double) NclFree(tmp_lat);
if(type_lon != NCL_double) NclFree(tmp_lon);
NclFree(zdat);
NclFree(iwrk);
return(NhlNOERROR);
}