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 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 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 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 *optspi; /* * 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, ret; ng_size_t index_x, index_nrx; ng_size_t i, j, nrnx, total_nr, total_nl, size_output; /* * Retrieve parameters. * * Note any of the pointer parameters can be set to NULL, which * implies you don't care about its value. */ /* * Get argument # 0 */ x = (void*)NclGetArgValue( 0, 4, &ndims_x, dsizes_x, &missing_x, &has_missing_x, &type_x, DONT_CARE); /* * Get argument # 1 */ nrun = (int*)NclGetArgValue( 1, 4, NULL, NULL, NULL, NULL, NULL, DONT_CARE); /* * Get argument # 2 */ optspi = (logical*)NclGetArgValue( 2, 4, NULL, NULL, NULL, NULL, NULL, DONT_CARE); /* * Coerce missing value to double if necessary. */ coerce_missing(type_x,has_missing_x,&missing_x, &missing_dbl_x,&missing_flt_x); /* * Get 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; } /* * 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. */ NGCALLF(spigamd,SPIGAMD)(&intim, tmp_x, &missing_dbl_x.doubleval, nrun, tmp_spi); /* * 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); /* * 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); }