Esempio n. 1
0
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);
}
Esempio n. 2
0
NhlErrorTypes specx_anal_W( void )
{
/*
 * Input array variables
 */
  void *x, *pct;
  double *dx, *dpct;
  ng_size_t dsizes[1];
  ng_size_t nx;
  int *iopt, *jave;
  int ndims_x;
  ng_size_t dsizes_x[NCL_MAX_DIMENSIONS];
  int has_missing_x;
  NclScalar missing_x, missing_dx;
  NclBasicDataTypes type_x, type_pct;
  ng_size_t lwork;
  double scl, *work;
/*
 * Output variables
 */
  void *dof;
  NclBasicDataTypes type_dof;
  NclObjClass type_output;
/*
 * Attribute variables
 */
  int att_id;
  NclMultiDValData att_md, return_md;
  NclVar tmp_var;
  NclStackEntry return_data;
  double *frq_tmp, *spcx_tmp, sinfo[50];
  void *spcx, *frq, *bw, *xavei, *xvari, *xvaro, *xlag1, *xslope;
/*
 * Declare variables for random purposes.
 */
  ng_size_t i, nspcmx, nspc, total_size_x;
  int ier;

/*
 * Retrieve arguments.
 */
  x = (void*)NclGetArgValue(
          0,
          4,
          &ndims_x,
          dsizes_x,
          &missing_x,
          &has_missing_x,
          &type_x,
          DONT_CARE);

  iopt = (int*)NclGetArgValue(
          1,
          4,
          NULL,
          NULL,
          NULL,
          NULL,
          NULL,
          DONT_CARE);
  
  jave = (int*)NclGetArgValue(
          2,
          4,
          NULL,
          NULL,
          NULL,
          NULL,
          NULL,
          DONT_CARE);


  pct = (void*)NclGetArgValue(
          3,
          4,
          NULL,
          NULL,
          NULL,
          NULL,
          &type_pct,
          DONT_CARE);
/*
 * Check input.
 */
  if( *iopt > 2) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"specx_anal: 'iopt' must be <= 2");
    return(NhlFATAL);
  }

  nx = dsizes_x[0];
  nspc = nspcmx = nx/2 + 1;
  if( nx < 3) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"specx_anal: 'x' must have more than 3 elements");
    return(NhlFATAL);
  }

  if( abs(*jave) > nx/2 ) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"specx_anal: 'jave' must be <= nx/2");
    return(NhlFATAL);
  }

/*
 * Compute the total number of elements in our array.
 */
  total_size_x = 1;
  for(i = 0; i < ndims_x; i++) total_size_x *= dsizes_x[i];
/*
 * Check for missing values.
 */
  coerce_missing(type_x,has_missing_x,&missing_x,&missing_dx,NULL);
/*
 * Coerce x to double precision if necessary.
 */
  dx = coerce_input_double(x,type_x,total_size_x,has_missing_x,&missing_x,
                           &missing_dx);
  if( dx == NULL ) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"specx_anal: Unable to allocate memory for coercing x array to double precision");
    return(NhlFATAL);
  }
/*  
 * Check if x contains missing values.
 */
  if(contains_missing(dx,total_size_x,has_missing_x,missing_dx.doubleval)) {
     NhlPError(NhlFATAL,NhlEUNKNOWN,"specx_anal: 'x' cannot contain any missing values");
     return(NhlFATAL);
  }
/*
 * Coerce pct to double precision if necessary.
 */
  dpct = coerce_input_double(pct,type_pct,1,0,NULL,NULL);
  if( dpct == NULL ) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"specx_anal: Unable to allocate memory for coercing pct array to double precision");
    return(NhlFATAL);
  }
/*
 * Check pct.
 */
  if( *dpct < 0.0 || *dpct > 1.0 ) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"specx_anal: 'pct' must be between 0 and 1 inclusive");
    return(NhlFATAL);
  }
/*
 * Check if any input is double.
 */
  if(type_x != NCL_double && type_pct != NCL_double) {
    type_dof    = NCL_float;
    type_output = nclTypefloatClass;
/*
 * Allocate space for float output variables.
 */
    dof     = (void *)calloc(1,sizeof(float));
    frq     = (void *)calloc(nspcmx-1,sizeof(float));
    spcx    = (void *)calloc(nspcmx-1,sizeof(float));
    bw      = (void *)calloc(1,sizeof(float));
    xavei   = (void *)calloc(1,sizeof(float));
    xvari   = (void *)calloc(1,sizeof(float));
    xvaro   = (void *)calloc(1,sizeof(float));
    xlag1   = (void *)calloc(1,sizeof(float));
    xslope  = (void *)calloc(1,sizeof(float));
  }
  else {
    type_dof    = NCL_double;
    type_output = nclTypedoubleClass;
/*
 * Allocate space for double output variables.
 */
    dof     = (void *)calloc(1,sizeof(double));
    frq     = (void *)calloc(nspcmx-1,sizeof(double));
    spcx    = (void *)calloc(nspcmx-1,sizeof(double));
    bw      = (void *)calloc(1,sizeof(double));
    xavei   = (void *)calloc(1,sizeof(double));
    xvari   = (void *)calloc(1,sizeof(double));
    xvaro   = (void *)calloc(1,sizeof(double));
    xlag1   = (void *)calloc(1,sizeof(double));
    xslope  = (void *)calloc(1,sizeof(double));
  }
  if(   dof == NULL ||    bw == NULL ||  spcx == NULL ||   frq == NULL ||
      xavei == NULL || xvari == NULL || xvaro == NULL || xlag1 == NULL ||
     xslope == NULL) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"specx_anal: Unable to allocate memory for output variables");
    return(NhlFATAL);
  }
/*
 * Allocate space for stuff to be returned by dspecx.
 */
  frq_tmp  = (double *)calloc(nspcmx,sizeof(double));
  spcx_tmp = (double *)calloc(nspcmx,sizeof(double));
  if( frq_tmp == NULL || spcx_tmp == NULL) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"specx_anal: Unable to allocate memory for output variables");
    return(NhlFATAL);
  }

/*
 * Allocate space for work array.
 */
  lwork = 5 * nx + 18 + abs(*jave);
  work  = (double *)calloc(lwork,sizeof(double));
  if( work == NULL ) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"specx_anal: Unable to allocate memory for work array");
    return(NhlFATAL);
  }
/*
 * Call the Fortran version of this routine.
 */
  scl = 2.0;
  if((nx <= INT_MAX) &&
     (lwork <= INT_MAX) &&
     (nspc <= INT_MAX))
  {
      int inx = (int) nx;
      int ilwork = (int) lwork;
      int inspc = (int) nspc;
      NGCALLF(dspecx,DSPECX)(dx,&inx,iopt,jave,dpct,&scl,work,&ilwork,
                             frq_tmp,spcx_tmp,&inspc,sinfo,&ier);
  }
  else
  {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"specx_anal: one or more input dimensions is greater than INT_MAX", nx);
    return(NhlFATAL);
  }


  if( ier > 700000 ) {
    NhlPError(NhlWARNING,NhlEUNKNOWN,"specx_anal: 'x' contains all constant values");
  }

  coerce_output_float_or_double(   dof,    &sinfo[0],type_dof,1,0);
  coerce_output_float_or_double( xlag1,    &sinfo[1],type_dof,1,0);
  coerce_output_float_or_double(    bw,    &sinfo[5],type_dof,1,0);
  coerce_output_float_or_double( xavei,   &sinfo[10],type_dof,1,0);
  coerce_output_float_or_double( xvari,   &sinfo[11],type_dof,1,0);
  coerce_output_float_or_double( xvaro,   &sinfo[12],type_dof,1,0);
  coerce_output_float_or_double(xslope,   &sinfo[31],type_dof,1,0);
  coerce_output_float_or_double(   frq,  &frq_tmp[1],type_dof,nspcmx-1,0);
  coerce_output_float_or_double(  spcx, &spcx_tmp[1],type_dof,nspcmx-1,0);

/*
 * Free up memory.
 */
  NclFree(frq_tmp);
  NclFree(spcx_tmp);
  NclFree(work);
  if((void*)dx   != x) NclFree(dx);
  if((void*)dpct != pct) NclFree(dpct);

/*
 * Set up variable to return.
 */
  dsizes[0] = 1;
  return_md = _NclCreateVal(
                            NULL,
                            NULL,
                            Ncl_MultiDValData,
                            0,
                            dof,
                            NULL,
                            1,
                            dsizes,
                            TEMPORARY,
                            NULL,
                            type_output
                            );
/*
 * Set up attributes to return.
 */
  att_id = _NclAttCreate(NULL,NULL,Ncl_Att,0,NULL);
    
  dsizes[0] = nspcmx-1;      /* returning nx/2 points, not nx/2 + 1 */
  att_md = _NclCreateVal(
                         NULL,
                         NULL,
                         Ncl_MultiDValData,
                         0,
                         spcx,
                         NULL,
                         1,
                         dsizes,
                         TEMPORARY,
                         NULL,
                         type_output
                         );
  _NclAddAtt(
             att_id,
             "spcx",
             att_md,
             NULL
             );
    
  att_md = _NclCreateVal(
                         NULL,
                         NULL,
                         Ncl_MultiDValData,
                         0,
                         frq,
                         NULL,
                         1,
                         dsizes,
                         TEMPORARY,
                         NULL,
                         type_output
                         );
  _NclAddAtt(
             att_id,
             "frq",
             att_md,
             NULL
             );
    
  dsizes[0] = 1;
  att_md = _NclCreateVal(
                         NULL,
                         NULL,
                         Ncl_MultiDValData,
                         0,
                         bw,
                         NULL,
                         1,
                         dsizes,
                         TEMPORARY,
                         NULL,
                         type_output
                         );
  _NclAddAtt(
             att_id,
             "bw",
             att_md,
             NULL
             );
    
  att_md = _NclCreateVal(
                         NULL,
                         NULL,
                         Ncl_MultiDValData,
                         0,
                         xavei,
                         NULL,
                         1,
                         dsizes,
                         TEMPORARY,
                         NULL,
                         type_output
                         );
  _NclAddAtt(
             att_id,
             "xavei",
             att_md,
             NULL
             );
    
  att_md = _NclCreateVal(
                         NULL,
                         NULL,
                         Ncl_MultiDValData,
                         0,
                         xvari,
                         NULL,
                         1,
                         dsizes,
                         TEMPORARY,
                         NULL,
                         type_output
                         );
  _NclAddAtt(
             att_id,
             "xvari",
             att_md,
             NULL
             );
    
  att_md = _NclCreateVal(
                         NULL,
                         NULL,
                         Ncl_MultiDValData,
                         0,
                         xvaro,
                         NULL,
                         1,
                         dsizes,
                         TEMPORARY,
                         NULL,
                         type_output
                         );
  _NclAddAtt(
             att_id,
             "xvaro",
             att_md,
             NULL
             );
    
  att_md = _NclCreateVal(
                         NULL,
                         NULL,
                         Ncl_MultiDValData,
                         0,
                         xlag1,
                         NULL,
                         1,
                         dsizes,
                         TEMPORARY,
                         NULL,
                         type_output
                         );
  _NclAddAtt(
             att_id,
             "xlag1",
             att_md,
             NULL
             );

  att_md = _NclCreateVal(
                         NULL,
                         NULL,
                         Ncl_MultiDValData,
                         0,
                         xslope,
                         NULL,
                         1,
                         dsizes,
                         TEMPORARY,
                         NULL,
                         type_output
                         );
  _NclAddAtt(
             att_id,
             "xslope",
             att_md,
             NULL
             );
  tmp_var = _NclVarCreate(
                          NULL,
                          NULL,
                          Ncl_Var,
                          0,
                          NULL,
                          return_md,
                          NULL,
                          att_id,
                          NULL,
                          RETURNVAR,
                          NULL,
                          TEMPORARY
                          );
/*
 * Return output grid and attributes to NCL.
 */
  return_data.kind = NclStk_VAR;
  return_data.u.data_var = tmp_var;
  _NclPlaceReturn(return_data);
  return(NhlNOERROR);
}
Esempio n. 3
0
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);
}
Esempio n. 4
0
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);
}
Esempio n. 5
0
NhlErrorTypes ezfftf_W( void )
{
/*
 * Input array variables
 */
  void *x;
  int ndims_x;
  ng_size_t dsizes_x[NCL_MAX_DIMENSIONS];
  NclBasicDataTypes type_x;
  NclScalar missing_x, missing_dx, missing_rx, missing_cf;
  int has_missing_x;
  double *tmp_x = NULL;
/*
 * Output array variables
 */
  void *cf, *xbar;
  int ndims_cf;
  ng_size_t dsizes_cf[NCL_MAX_DIMENSIONS];
  double *tmp_cf1, *tmp_cf2, *tmp_xbar;
  NclBasicDataTypes type_cf;
  NclTypeClass type_cf_class;
/*
 * Attribute variables
 */
  void *N;
  int att_id;
  ng_size_t dsizes[1];
  NclMultiDValData att_md, return_md;
  NclVar tmp_var;
  NclStackEntry return_data;
/*
 * various
 */
  double *work;
  ng_size_t index_x, index_cf1, index_cf2;
  ng_size_t i, npts, npts2, lnpts2, npts22;
  int found_missing, any_missing;
  ng_size_t size_leftmost, size_cf;
  int inpts;

/*
 * Retrieve parameters
 *
 * Note any of the pointer parameters can be set to NULL, which
 * implies you don't care about its value.
 */
  x = (void*)NclGetArgValue(
           0,
           1,
           &ndims_x, 
           dsizes_x,
           &missing_x,
           &has_missing_x,
           &type_x,
           DONT_CARE);
/*
 * Calculate number of leftmost elements.
 */
  size_leftmost = 1;
  for( i = 0; i < ndims_x-1; i++ ) size_leftmost *= dsizes_x[i];
/*
 * Test input array size
 */
  npts = dsizes_x[ndims_x-1];

  if(npts > INT_MAX) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"ezfftf: npts = %d is greater than INT_MAX", npts);
    return(NhlFATAL);
  }
  inpts = (int) npts;

/*
 * Calculate size of output array.
 */
  if((npts % 2) == 0) {
    npts2 = npts/2;
  }
  else {
    npts2 = (npts-1)/2;
  }
  lnpts2 = npts2 * size_leftmost;
  npts22 = 2*npts2;
  size_cf = size_leftmost * npts22;

  ndims_cf           = ndims_x + 1;
  dsizes_cf[0]       = 2;
  for(i = 1; i < ndims_x; i++ ) dsizes_cf[i] = dsizes_x[i-1];
  dsizes_cf[ndims_x] = npts2;
/*
 * Coerce missing values.
 */
  coerce_missing(type_x,has_missing_x,&missing_x,&missing_dx,&missing_rx);
/*
 * Create space for temporary input array if necessary.
 */
  if(type_x != NCL_double) {
    tmp_x = (double*)calloc(npts,sizeof(double));
    if(tmp_x == NULL) {
      NhlPError(NhlFATAL,NhlEUNKNOWN,"ezfftf: Unable to allocate memory for coercing input array to double precision");
      return(NhlFATAL);
    }
  }
/*
 * Allocate space for output arrays.
 */
  tmp_xbar = (double*)calloc(1,sizeof(double));
  tmp_cf1  = (double*)calloc(npts2,sizeof(double));
  tmp_cf2  = (double*)calloc(npts2,sizeof(double));
  if ( tmp_cf1 == NULL || tmp_cf2 == NULL || tmp_xbar == NULL ) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"ezfftf: Cannot allocate memory for temporary output arrays" );
    return(NhlFATAL);
  }
  if(type_x == NCL_double) {
    cf   = (void*)calloc(size_cf,sizeof(double));
    xbar = (void*)calloc(size_leftmost,sizeof(double));
    type_cf = NCL_double;
    if(has_missing_x) missing_cf = missing_dx;
  }
  else {
    cf   = (void*)calloc(size_cf,sizeof(float));
    xbar = (void*)calloc(size_leftmost,sizeof(float));
    type_cf = NCL_float;
    if(has_missing_x) missing_cf = missing_rx;
  }
  N = (void*)calloc(1,sizeof(int));
  if ( cf == NULL || xbar == NULL || N == NULL ) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"ezfftf: Cannot allocate memory for output arrays" );
    return(NhlFATAL);
  }

/*
 * Allocate memory for work array
 */
  work = (double*)calloc((4*npts+15),sizeof(double));
  if ( work == NULL ) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"ezfftf: Cannot allocate memory for work array" );
    return(NhlFATAL);
  }
/*
 * Call the f77 version of 'dezfftf' with the full argument list.
 */
  index_x   = 0;
  index_cf1 = 0;
  index_cf2 = lnpts2;
  any_missing = 0;
  for(i = 0; i < size_leftmost; i++) {
    if(type_x != NCL_double) { 
      coerce_subset_input_double(x,tmp_x,index_x,type_x,npts,0,NULL,NULL);
    }
    else {
      tmp_x = &((double*)x)[index_x];
    }
/*
 * Check for missing values in x.  If any, then coerce that section of
 * the output to missing.
 */
    found_missing = contains_missing(tmp_x,npts,has_missing_x,
                                     missing_dx.doubleval);
    if(found_missing) {
      any_missing++;
      set_subset_output_missing(xbar,i,type_cf,1,missing_dx.doubleval);
      set_subset_output_missing(cf,index_cf1,type_cf,npts2,
                                missing_dx.doubleval);
      set_subset_output_missing(cf,index_cf2,type_cf,npts2,
                                missing_dx.doubleval);
    }
    else {
      NGCALLF(dezffti,DEZFFTI)(&inpts,work);
      NGCALLF(dezfftf,DEZFFTF)(&inpts,tmp_x,tmp_xbar,tmp_cf1,tmp_cf2,work);
/*
 * Copy results back into xbar and cf.
 */
      coerce_output_float_or_double(xbar,tmp_xbar,type_cf,1,i);
      coerce_output_float_or_double(cf,tmp_cf1,type_cf,npts2,index_cf1);
      coerce_output_float_or_double(cf,tmp_cf2,type_cf,npts2,index_cf2);
    }
    index_x   += npts;
    index_cf1 += npts2;
    index_cf2 += npts2;
  }

/*
 * Free up memory.
 */
  if(type_x != NCL_double) free(tmp_x);
  free(work);
  free(tmp_cf1);
  free(tmp_cf2);
  free(tmp_xbar);
/*
 * Set up variable to return.
 */
  type_cf_class = (NclTypeClass)_NclNameToTypeClass(NrmStringToQuark(_NclBasicDataTypeToName(type_cf)));

/*
 * Set up return values.
 */
  if(any_missing) {
    NhlPError(NhlWARNING,NhlEUNKNOWN,"ezfftf: %d input arrays contained missing values. No calculations performed on these arrays.",any_missing);

    return_md = _NclCreateVal(
                              NULL,
                              NULL,
                              Ncl_MultiDValData,
                              0,
                              cf,
                              &missing_cf,
                              ndims_cf,
                              dsizes_cf,
                              TEMPORARY,
                              NULL,
                              (NclObjClass)type_cf_class
                              );
  }
  else {
    return_md = _NclCreateVal(
                              NULL,
                              NULL,
                              Ncl_MultiDValData,
                              0,
                              cf,
                              NULL,
                              ndims_cf,
                              dsizes_cf,
                              TEMPORARY,
                              NULL,
                              (NclObjClass)type_cf_class
                              );
  }
/*
 * Attributes "xbar" and "npts".
 */
  att_id = _NclAttCreate(NULL,NULL,Ncl_Att,0,NULL);

  dsizes[0] = size_leftmost;
  att_md = _NclCreateVal(
                         NULL,
                         NULL,
                         Ncl_MultiDValData,
                         0,
                         xbar,
                         NULL,
                         1,
                         dsizes,
                         TEMPORARY,
                         NULL,
                         (NclObjClass)type_cf_class
                         );
  _NclAddAtt(
             att_id,
             "xbar",
             att_md,
             NULL
             );

  (*(int*)N) = npts;
  dsizes[0] = 1;
  att_md = _NclCreateVal(
                         NULL,
                         NULL,
                         Ncl_MultiDValData,
                         0,
                         N,
                         NULL,
                         1,
                         dsizes,
                         TEMPORARY,
                         NULL,
                         (NclObjClass)nclTypeintClass
                         );
  _NclAddAtt(
             att_id,
             "npts",
             att_md,
             NULL
             );

/*
 * Set up variable to hold return array and attributes.
 */
  tmp_var = _NclVarCreate(
                          NULL,
                          NULL,
                          Ncl_Var,
                          0,
                          NULL,
                          return_md,
                          NULL,
                          att_id,
                          NULL,
                          RETURNVAR,
                          NULL,
                          TEMPORARY
                          );
/*
 * Return output grid and attributes to NCL.
 */
  return_data.kind = NclStk_VAR;
  return_data.u.data_var = tmp_var;
  _NclPlaceReturn(return_data);
  return(NhlNOERROR);
}
Esempio n. 6
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);
}
Esempio n. 7
0
NhlErrorTypes cd_calendar_W( void )
{
/*
 * Input array variables
 */
  void *x;
  double *tmp_x;
  NrmQuark *sspec = NULL;
  char *cspec;
  int *option;
  int ndims_x;
  ng_size_t dsizes_x[NCL_MAX_DIMENSIONS];
  int has_missing_x;
  NclScalar missing_x, missing_dx;
  NclBasicDataTypes type_x;
/* 
 * Variables for calculating fraction of year,  if the option is 4.
 */
  int doy, nsid, total_seconds_in_year, seconds_in_doy, seconds_in_hour;
  int seconds_in_minute; 
  double current_seconds_in_year, fraction_of_year;

/*
 * Variables for retrieving attributes from the first argument.
 */
  NclAttList  *attr_list;
  NclAtt  attr_obj;
  NclStackEntry   stack_entry;
  NrmQuark *scal;
  const char   *ccal = NULL;
  cdCalenType ctype;
/*
 * Output variables.
 */
  cdCompTime comptime;
  int year, month, day, hour, minute;
  double second;
  void *date = NULL;
  int ndims_date = 0;
  ng_size_t *dsizes_date;
  NclScalar missing_date;
  NclBasicDataTypes type_date = NCL_none;
  NclObjClass type_date_t = NCL_none;
/*
 * Variables for returning "calendar" attribute.
 */
  int att_id;
  NclQuark *calendar;
  NclMultiDValData att_md, return_md;
  NclVar tmp_var;
  NclStackEntry return_data;

/*
 * various
 */
  int ret, return_missing;
  ng_size_t dsizes[1];
  ng_size_t i, total_size_x;
  ng_size_t total_size_date = 0;
  ng_size_t index_date;
  extern float truncf(float);

  /* initialize error flag */
  cuErrorOccurred = 0;
/*
 * Retrieve parameters
 *
 * Note any of the pointer parameters can be set to NULL, which
 * implies you don't care about its value.
 */
  x = (void*)NclGetArgValue(
           0,
           2,
           &ndims_x, 
           dsizes_x,
           &missing_x,
           &has_missing_x,
           &type_x,
           DONT_CARE);
/*
 * Get option.
 */

  option = (int*)NclGetArgValue(
           1,
           2,
           NULL,
           NULL,
           NULL,
           NULL,
           NULL,
           1);

/* 
 * The "units" attribute of "time" must be set, otherwise missing
 * values will be returned.
 *
 * The "calendar" option may optionally be set, but it must be equal to
 * one of the recognized calendars.
 */
  return_missing = 0;

  stack_entry = _NclGetArg(0, 2, DONT_CARE);
  switch (stack_entry.kind) {
  case NclStk_VAR:
    if (stack_entry.u.data_var->var.att_id != -1) {
      attr_obj = (NclAtt) _NclGetObj(stack_entry.u.data_var->var.att_id);
      if (attr_obj == NULL) {
        return_missing = 1;
        break;
      }
    }
    else {
/*
 * att_id == -1 ==> no attributes specified; return all missing.
 */
      return_missing = 1;
      break;
    }
/* 
 * Check for attributes. If none are specified, then return missing values.
 */
    if (attr_obj->att.n_atts == 0) {
      return_missing = 1;
      break;
    }
    else {
/*
 * Get list of attributes.
 */
      attr_list = attr_obj->att.att_list;
/*
 * Loop through attributes and check them.
 */
      while (attr_list != NULL) {
        if ((strcmp(attr_list->attname, "calendar")) == 0) {
          scal = (NrmQuark *) attr_list->attvalue->multidval.val;
          ccal = NrmQuarkToString(*scal);
          if(strcasecmp(ccal,"standard") && strcasecmp(ccal,"gregorian") &&
             strcasecmp(ccal,"proleptic_gregorian") &&
             strcasecmp(ccal,"noleap")  && strcasecmp(ccal,"no_leap") &&
             strcasecmp(ccal,"allleap") && strcasecmp(ccal,"all_leap") &&
             strcasecmp(ccal,"365_day") && strcasecmp(ccal,"365") &&
             strcasecmp(ccal,"366_day") && strcasecmp(ccal,"366") &&
             strcasecmp(ccal,"360_day") && strcasecmp(ccal,"360") &&
             strcasecmp(ccal,"julian")  && strcasecmp(ccal,"none")) {
            NhlPError(NhlWARNING,NhlEUNKNOWN,"cd_calendar: the 'calendar' attribute (%s) is not equal to a recognized calendar. Returning all missing values.",ccal);
            return_missing = 1;
          }
        }
        if ((strcmp(attr_list->attname, "units")) == 0) {
          sspec = (NrmQuark *) attr_list->attvalue->multidval.val;
        }
        attr_list = attr_list->next;
      }
    }
  default:
    break;
  }

/*
 * If no calendar attribute set, or "none" was selected, then use 
 * the default "standard".
 */
  if(ccal == NULL || !strcasecmp(ccal,"none")) {
    ctype = calendar_type("standard");
  }
  else {
    ctype = calendar_type(ccal);
  }

/*
 * Convert sspec to character string.
 */
  if(sspec == NULL) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"cd_calendar: no 'units' attribute provided");
    return(NhlFATAL);
  }
  cspec = NrmQuarkToString(*sspec);

/*
 * Calculate size of input array.
 */
  total_size_x = 1;
  for( i = 0; i < ndims_x; i++ ) total_size_x *= dsizes_x[i];

/*
 * Calculate size and dimensions for output array, and allocate
 * memory for output array.  The output size will vary depending
 * on what option the user has specified.  Only options -5 to 4
 * are currently recognized. (option = -4 doesn't exist.)
 */

  if(*option < -5 || *option > 4 || *option == -4) {
        NhlPError(NhlWARNING,NhlEUNKNOWN,"cd_calendar: Unknown option, defaulting to 0.");
        *option = 0;
  }

  if(*option == 0) {
        type_date   = NCL_float;
        type_date_t = nclTypefloatClass;
        total_size_date = 6 * total_size_x;
        missing_date    = ((NclTypeClass)nclTypefloatClass)->type_class.default_mis;
        ndims_date      = ndims_x + 1;
        date            = (float *)calloc(total_size_date,sizeof(float));
  }
  else if(*option == -5) {
/* identical to option=0, except returns ints */
        type_date       = NCL_int;
        type_date_t     = nclTypeintClass;
        total_size_date = 6 * total_size_x;
        missing_date    = ((NclTypeClass)nclTypeintClass)->type_class.default_mis;
        ndims_date      = ndims_x + 1;
        date            = (int *)calloc(total_size_date,sizeof(int));
  }
  else if(*option >= 1 && *option <= 4) {
        type_date       = NCL_double;
        type_date_t     = nclTypedoubleClass;
        total_size_date = total_size_x;
        missing_date    = ((NclTypeClass)nclTypedoubleClass)->type_class.default_mis;
        ndims_date      = ndims_x;
        date            = (double *)calloc(total_size_date,sizeof(double));
  }
  else if(*option >= -3 && *option <= -1) {
        type_date       = NCL_int;
        type_date_t     = nclTypeintClass;
        total_size_date = total_size_x;
        missing_date    = ((NclTypeClass)nclTypeintClass)->type_class.default_mis;
        ndims_date      = ndims_x;
        date            = (int *)calloc(total_size_date,sizeof(int));
  }
  dsizes_date = (ng_size_t *)calloc(ndims_date,sizeof(ng_size_t));

/*
 * Make sure we have enough memory for output.
 */
  if( date == NULL || dsizes_date == NULL) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"cd_calendar: Unable to allocate memory for output arrays");
    return(NhlFATAL);
  }

/*
 * Calculate output dimension sizes.
 */
  for( i = 0; i < ndims_x; i++ ) dsizes_date[i] = dsizes_x[i];
  if(*option == 0 || *option == -5) {
        dsizes_date[ndims_x] = 6;
  }

/*
 * Coerce missing values to double.
 */
  coerce_missing(type_x,has_missing_x,&missing_x,&missing_dx,NULL);

/* 
 * If we reach this point and return_missing is not 0, then either
 * "units" was invalid or wasn't set, or "calendar" was not a
 * recoginized calendar. We return all missing values in this case.
 */
  if(return_missing) {
    set_all_missing(date, total_size_date, missing_date, *option);
    ret = NclReturnValue(date,ndims_date,dsizes_date,
                          &missing_date,type_date,0);
    NclFree(dsizes_date);
    return(ret);
  }
            
/*
 * Convert input to double if necessary.
 */
  tmp_x = coerce_input_double(x,type_x,total_size_x,has_missing_x,&missing_x,
                  &missing_dx);

/* 
 * Loop through each element and get the 6 values.
 */
  index_date = 0;
  for( i = 0; i < total_size_x; i++ ) {
    if(!has_missing_x ||
       (has_missing_x && tmp_x[i] != missing_dx.doubleval)) {
      (void)cdRel2Iso_minsec(ctype,cspec,tmp_x[i],&comptime,&minute,&second);
/*
 * Return all missing values if we encounter a fatal error. 
 * Only check this once.
 */
      if(i == 0 && (cuErrorOccurred && (cuErrOpts & CU_FATAL))) {
        set_all_missing(date, total_size_date, missing_date, *option);
        ret = NclReturnValue(date,ndims_date,dsizes_date,
                             &missing_date,type_date,0);
        NclFree(dsizes_date);
        return(ret);
      }
      year  = (int)comptime.year;
      month = (int)comptime.month;
      day   = (int)comptime.day;
/*
 * comptime.hour is a double, and fractional. The "minute" and "second"
 * above are calculated from the fractional part of the hour.
 */
      hour  = (int)comptime.hour;
/*
 * Calculate the return values, based on the input option.
 */
      switch(*option) {

      case 0:
        ((float*)date)[index_date]   = (float)year;
        ((float*)date)[index_date+1] = (float)month;
        ((float*)date)[index_date+2] = (float)day;
        ((float*)date)[index_date+3] = (float)hour;
        ((float*)date)[index_date+4] = (float)minute;
        ((float*)date)[index_date+5] = second;
        break;

/* identical to option=0, except returns ints */
      case -5:
        ((int*)date)[index_date]   = year;
        ((int*)date)[index_date+1] = month;
        ((int*)date)[index_date+2] = day;
        ((int*)date)[index_date+3] = hour;
        ((int*)date)[index_date+4] = minute;
        ((int*)date)[index_date+5] = (int)truncf(second);
        break;

/*
 * YYYYMM
 */
      case -1:
        ((int*)date)[index_date] = (100*year) + month;
        break;

      case 1:
        ((double*)date)[index_date] = (double)(100*year) + (double)month;
        break;
/*
 * YYYYMMDD
 */
      case -2:
        ((int*)date)[index_date] = (10000*year) + (100*month) + day;
        break;

      case 2:
        ((double*)date)[index_date] = (double)(10000*year)
          + (double)(100*month) 
          + (double)day;
        break;

/*
 * YYYYMMDDHH
 */
      case -3:
        ((int*)date)[index_date] = (1000000*year) + (10000*month) 
          + (100*day) + hour;                
        break;
                
      case 3:
        ((double*)date)[index_date] = (double)(1000000*year) 
          + (double)(10000*month) 
          + (double)(100*day)
          + (double)hour;             
        break;
                
/*
 *  YYYY.fraction_of_year
 */
      case 4:
	nsid = 86400;      /* num seconds in a day */
        if(ccal == NULL) {
          total_seconds_in_year = seconds_in_year(year,"standard");
          doy = day_of_year(year,month,day,"standard");
        }
        else {
          total_seconds_in_year = seconds_in_year(year,ccal);
          doy = day_of_year(year,month,day,ccal);
        }
        if(doy > 1) {
          seconds_in_doy = (doy-1) * nsid;
        }
        else {
          seconds_in_doy = 0;
        }
        if(hour > 1) {
          seconds_in_hour  = (hour-1) * 3600;
        }
        else {
          seconds_in_hour  = 0;
        }
        if(minute > 1) {
          seconds_in_minute  = (minute-1) * 60;
        }
        else {
          seconds_in_minute  = 0;
        }
        current_seconds_in_year = seconds_in_doy + 
          seconds_in_hour + 
          seconds_in_minute + 
          second;
        fraction_of_year = current_seconds_in_year/(double)total_seconds_in_year;
        ((double*)date)[index_date] = (double)year + fraction_of_year;
        break;
      }
    }
    else {
      switch(*option) {

      case 0:
        ((float*)date)[index_date]   = missing_date.floatval;
        ((float*)date)[index_date+1] = missing_date.floatval;
        ((float*)date)[index_date+2] = missing_date.floatval;
        ((float*)date)[index_date+3] = missing_date.floatval;
        ((float*)date)[index_date+4] = missing_date.floatval;
        ((float*)date)[index_date+5] = missing_date.floatval;
        break;

/* identical to option=0, except returns ints */
      case -5:
        ((int*)date)[index_date]   = missing_date.intval;
        ((int*)date)[index_date+1] = missing_date.intval;
        ((int*)date)[index_date+2] = missing_date.intval;
        ((int*)date)[index_date+3] = missing_date.intval;
        ((int*)date)[index_date+4] = missing_date.intval;
        ((int*)date)[index_date+5] = missing_date.intval;
        break;

      case 1:
      case 2:
      case 3:
      case 4:
        ((double*)date)[index_date] = missing_date.doubleval;
        break;

      case -1:
      case -2:
      case -3:
        ((int*)date)[index_date] = missing_date.intval;
        break;
      }
    }
    if(*option == 0 || *option == -5) {
      index_date += 6;
    }
    else {
      index_date++;
    }
  }

/*
 * Free the work arrays.
 */

  if(type_x != NCL_double) NclFree(tmp_x);

/*
 * Set up variable to return.
 */
  if(has_missing_x) {
        return_md = _NclCreateVal(
                            NULL,
                            NULL,
                            Ncl_MultiDValData,
                            0,
                            date,
                            &missing_date,
                            ndims_date,
                            dsizes_date,
                            TEMPORARY,
                            NULL,
                            type_date_t
                            );
  }
  else {
        return_md = _NclCreateVal(
                            NULL,
                            NULL,
                            Ncl_MultiDValData,
                            0,
                            date,
                            NULL,
                            ndims_date,
                            dsizes_date,
                            TEMPORARY,
                            NULL,
                            type_date_t
                            );
  }

/*
 * Set up attributes to return.
 */
  att_id = _NclAttCreate(NULL,NULL,Ncl_Att,0,NULL);
  dsizes[0] = 1;

/*
 * Return "calendar" attribute.
 *
 * We can't just return "scal" here, because it's an NCL input
 * parameter and this seems to screw things up if we try to
 * return it as an attribute.
 */
  calendar = (NclQuark*)NclMalloc(sizeof(NclQuark));
  if(ccal != NULL) {
    *calendar = NrmStringToQuark(ccal);
  }
  else {
    *calendar = NrmStringToQuark("standard");
  }
  att_md = _NclCreateVal(
                         NULL,
                         NULL,
                         Ncl_MultiDValData,
                         0,
                         (void*)calendar,
                         NULL,
                         1,
                         dsizes,
                         TEMPORARY,
                         NULL,
                         (NclObjClass)nclTypestringClass
                         );
  _NclAddAtt(
             att_id,
             "calendar",
             att_md,
             NULL
             );

  tmp_var = _NclVarCreate(
                          NULL,
                          NULL,
                          Ncl_Var,
                          0,
                          NULL,
                          return_md,
                          NULL,
                          att_id,
                          NULL,
                          RETURNVAR,
                          NULL,
                          TEMPORARY
                          );

    NclFree(dsizes_date);
/*
 * Return output grid and attributes to NCL.
 */
  return_data.kind = NclStk_VAR;
  return_data.u.data_var = tmp_var;
  _NclPlaceReturn(return_data);
  return(NhlNOERROR);
}
Esempio n. 8
0
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);
}
Esempio n. 9
0
NhlErrorTypes wgt_area_smooth_W (void)
{
/*
 * Input variables
 */
/*
 * Argument # 0
 */
	void *field;
	double *tmp_field;
	int ndims_field;
	ng_size_t dsizes_field[NCL_MAX_DIMENSIONS];
	NclBasicDataTypes type_field;
	int has_missing_field;
	NclScalar missing_field, missing_flt_field, missing_dbl_field;

/*
 * Argument # 1
 */
	void *area;
	double *tmp_area;
	int ndims_area;
	ng_size_t dsizes_area[NCL_MAX_DIMENSIONS];
	NclBasicDataTypes type_area;
	int has_missing_area;
	NclScalar missing_area;

/*
 * Argument # 2
 */

  logical *opt;
  int cyclic = 1;

/*
 * Variables for retrieving attributes from "opt".
 */
  NclAttList  *attr_list;
  NclAtt  attr_obj;
  NclStackEntry   stack_entry;


/*
 * Return variable
 */
	void *smooth_ret;
	double *tmp_smooth;
	NclBasicDataTypes type_smooth;
	NclScalar missing_smooth;

/*
 * Various
 */
	ng_size_t i, size_other,total_size,area_size;
	int dims[3];
	int ret;


/*
 * Retrieve parameters.
 *
 * Note any of the pointer parameters can be set to NULL, which
 * implies you don't care about its value.
 */
/*
 * Get argument # 0
 */
	field = (void*)NclGetArgValue(
		0,
		3,
		&ndims_field,
		dsizes_field,
		&missing_field,
		&has_missing_field,
		&type_field,
		DONT_CARE);


/*
 * Get argument # 1
 */
	area = (void*)NclGetArgValue(
		1,
		3,
		&ndims_area,
		dsizes_area,
		&missing_area,
		&has_missing_area,
		&type_area,
		DONT_CARE);

/*
 * Get argument # 2
 */
	opt = (logical*)NclGetArgValue(
		2,
		3,
		NULL,
		NULL,
		NULL,
		NULL,
		NULL,
		DONT_CARE);

/* 
 * If "opt" is True, then check if any attributes have been set.
 */
	if(*opt) {
		stack_entry = _NclGetArg(5, 6, DONT_CARE);
		switch (stack_entry.kind) {
		case NclStk_VAR:
			if (stack_entry.u.data_var->var.att_id != -1) {
				attr_obj = (NclAtt) _NclGetObj(stack_entry.u.data_var->var.att_id);
				if (attr_obj == NULL) {
					break;
				}
			}
			else {
/*
 * att_id == -1 ==> no optional args given.
 */
				break;
			}
/* 
 * Get optional arguments.
 */
			if (attr_obj->att.n_atts > 0) {
/*
 * Get list of attributes.
 */
				attr_list = attr_obj->att.att_list;
/*
 * Loop through attributes and check them. The current ones recognized are:
 *   "cyclic"
 */
				while (attr_list != NULL) {
/*
 * Check for "cyclic".
 */
					if (!strcmp(attr_list->attname, "cyclic")) {
						if(attr_list->attvalue->multidval.data_type == NCL_logical) {
							cyclic = *(logical*) attr_list->attvalue->multidval.val == False ? 0 : 1;
						}
						else {
							NhlPError(NhlWARNING,NhlEUNKNOWN,
						  "wgt_area_smooth: The 'cyclic' attribute must be a logical. Defaulting to True.");
						}
					}
					attr_list = attr_list->next;
				}
			}
		default:
			break;
		}
	}

/*
 * Check dimension sizes.
 */
	if(ndims_field <  ndims_area) {
		NhlPError(NhlFATAL,NhlEUNKNOWN,"wgt_area_smooth: field must have at least 2 dimensions");
		return(NhlFATAL);
	}
	if (dsizes_field[ndims_field - 2] != dsizes_area[0] ||
	    dsizes_field[ndims_field - 1] != dsizes_area[1]) {
		NhlPError(NhlFATAL,NhlEUNKNOWN,"wgt_area_smooth: the last two dimensions of field must be the same size as area");
		return(NhlFATAL);
	}
/* 
 * compute total elements in remaining dimensions of field
 */
	size_other = 1;
        total_size = 1;
	area_size = 1;
	for (i = 0; i < ndims_field - 2; i++) {
		size_other *= dsizes_field[i];
		total_size *= dsizes_field[i];
	}
	for (i = ndims_field - 2; i < ndims_field; i++) {
		total_size *= dsizes_field[i];
		area_size *= dsizes_field[i];
	}
	dims[0] = (int) dsizes_area[1];
	dims[1] = (int) dsizes_area[0];
	dims[2] = (int)size_other;


/*
 * Coerce missing values to double if necessary.
 */
	coerce_missing(type_field,has_missing_field,&missing_field,&missing_dbl_field,
		       &missing_flt_field);

/*
 * The output type defaults to float, unless t is double.
 */
	if(type_field == NCL_double) {
		type_smooth = NCL_double;
		if(has_missing_field) {
			missing_smooth = missing_dbl_field;
		}
	}
	else {
		type_smooth = NCL_float;
		if(has_missing_field) {
			missing_smooth = missing_flt_field;
		}
	}
/* 
 * Coerce input arrays to double if necessary.
 */
	tmp_field  = coerce_input_double(field,  type_field, total_size,0,NULL,NULL);
	tmp_area   = coerce_input_double(area,   type_area,   area_size,0,NULL,NULL);
	if(tmp_field == NULL || tmp_area == NULL) {
		NhlPError(NhlFATAL,NhlEUNKNOWN,"wgt_area_smooth: Unable to allocate memory for coercing input arrays to double");
		return(NhlFATAL);
	}
/* 
 * Allocate space for output array.
 */
	tmp_smooth = (void *)calloc(total_size, sizeof(double));
	if(tmp_smooth == NULL) {
		NhlPError(NhlFATAL,NhlEUNKNOWN,"wgt_area_smooth: Unable to allocate memory for output array");
		return(NhlFATAL);
	}

	NGCALLF(wgt_area_smooth,WGT_AREA_SMOOTH)(tmp_field,tmp_area,tmp_smooth,
						 &(dims[0]),&(dims[1]),&(dims[2]),&(missing_dbl_field.doubleval),&cyclic);
	if (type_smooth == NCL_float) {
		smooth_ret = (void *) coerce_output_float(tmp_smooth,NULL,total_size,0);
	}
	else {
		smooth_ret = (void *) tmp_smooth;
	}
	
	if (type_field == NCL_float) {
		NclFree(tmp_field);
	}
	if (type_area == NCL_float) {
		NclFree(tmp_area);
	}
	if(has_missing_field) {
		ret = NclReturnValue(smooth_ret,ndims_field,dsizes_field,&missing_smooth,type_smooth,0);
	}
	else {
		ret = NclReturnValue(smooth_ret,ndims_field,dsizes_field,NULL,type_smooth,0);
	}
	return(ret);

}
Esempio n. 10
0
NhlErrorTypes mixed_layer_depth_W( void )
{

/*
 * Input variables
 */
/*
 * Argument # 0
 */
  void *pot_density;
  double *tmp_pot_density;
  int ndims_pot_density; 
  ng_size_t dsizes_pot_density[NCL_MAX_DIMENSIONS];
  int has_missing_pot_density;
  NclScalar missing_pot_density, missing_flt_pot_density, missing_dbl_pot_density;
  NclBasicDataTypes type_pot_density;

/*
 * Argument # 1
 */
  int *kmt;
  ng_size_t dsizes_kmt[2];
/*
 * Argument # 2
 */
  void *ht;
  double *tmp_ht;
  ng_size_t dsizes_ht[2];
  NclBasicDataTypes type_ht;

/*
 * Argument # 3
 */
  void *depth;
  double *tmp_depth;
  ng_size_t dsizes_depth[1];
  NclBasicDataTypes type_depth;

/*
 * Argument # 4
 */
  void *offset;
  double *tmp_offset;
  NclBasicDataTypes type_offset;

/*
 * Return variable
 */
  void *mld;
  double *tmp_mld;
  int ndims_mld; 
  ng_size_t *dsizes_mld;
  ng_size_t index_mld;
  NclScalar missing_mld, missing_flt_mld, missing_dbl_mld;
  NclBasicDataTypes type_mld;


/*
 * Various
 */
  int nz, ny, nx, nznynx, nynx ;
  int index_pot_density;
  int i, ndims_leftmost, size_leftmost, size_output, ret;

/*
 * Retrieve parameters.
 *
 * Note any of the pointer parameters can be set to NULL, which
 * implies you don't care about its value.
 */
/*
 * Get argument # 0
 */
  pot_density = (void*)NclGetArgValue(
           0,
           5,
           &ndims_pot_density,
           dsizes_pot_density,
           &missing_pot_density,
           &has_missing_pot_density,
           &type_pot_density,
           DONT_CARE);

/*
 * Check dimension sizes.
 */
  if(ndims_pot_density < 3) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"mixed_layer_depth: The pot_density array must have at least 3 dimensions");
    return(NhlFATAL);
  }

/*
 * Coerce missing value to double if necessary.
 */
  coerce_missing(type_pot_density,has_missing_pot_density,&missing_pot_density,
                 &missing_dbl_pot_density,&missing_flt_pot_density);

  nz = (int)dsizes_pot_density[ndims_pot_density-3];
  ny = (int)dsizes_pot_density[ndims_pot_density-2];
  nx = (int)dsizes_pot_density[ndims_pot_density-1];
  nznynx = nz * ny * nx;

/*
 * Get argument # 1
 */
  kmt = (int*)NclGetArgValue(
           1,
           5,
           NULL,
           dsizes_kmt,
           NULL,
           NULL,
           NULL,
           DONT_CARE);
  if(dsizes_kmt[0] != ny) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"mixed_layer_depth: The #0 dimension of kmt must be length ny");
    return(NhlFATAL);
  }
  if(dsizes_kmt[1] != nx) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"mixed_layer_depth: The #1 dimension of kmt must be length nx");
    return(NhlFATAL);
  }
  nynx = ny * nx;

/*
 * Get argument # 2
 */
  ht = (void*)NclGetArgValue(
           2,
           5,
           NULL,
           dsizes_ht,
           NULL,
           NULL,
           &type_ht,
           DONT_CARE);
  if(dsizes_ht[0] != ny) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"mixed_layer_depth: The #0 dimension of ht must be length ny");
    return(NhlFATAL);
  }
  if(dsizes_ht[1] != nx) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"mixed_layer_depth: The #1 dimension of ht must be length nx");
    return(NhlFATAL);
  }
  nynx = ny * nx;

/*
 * Get argument # 3
 */
  depth = (void*)NclGetArgValue(
           3,
           5,
           NULL,
           dsizes_depth,
           NULL,
           NULL,
           &type_depth,
           DONT_CARE);
  if(dsizes_depth[0] != nz) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"mixed_layer_depth: The #0 dimension of depth must be length nz");
    return(NhlFATAL);
  }
/*
 * Get argument # 4
 */
  offset = (void*)NclGetArgValue(
           4,
           5,
           NULL,
           NULL,
           NULL,
           NULL,
           &type_offset,
           DONT_CARE);

/*
 * Calculate size of leftmost dimensions.
 */
  size_leftmost  = 1;
  ndims_leftmost = ndims_pot_density-3;
  for(i = 0; i < ndims_leftmost; i++) {
	  size_leftmost *= (int)dsizes_pot_density[i];
  }


/*
 * The output type defaults to float, unless this input array is double.
 */
  type_mld = NCL_float;

/* 
 * Allocate space for coercing input arrays.  If any of the input
 * is already double, then we don't need to allocate space for
 * temporary arrays, because we'll just change the pointer into
 * the void array appropriately.
 */
/*
 * Allocate space for tmp_pot_density.
 */
  if(type_pot_density != NCL_double) {
    tmp_pot_density = (double *)calloc(nznynx,sizeof(double));
    if(tmp_pot_density == NULL) {
      NhlPError(NhlFATAL,NhlEUNKNOWN,"mixed_layer_depth: Unable to allocate memory for coercing input array to double");
      return(NhlFATAL);
    }
  }
  else {
    type_mld = NCL_double;
  }
/*
 * Allocate space for tmp_ht.
 */
  tmp_ht = coerce_input_double(ht,type_ht,nynx,0,NULL,NULL);
  if(tmp_ht == NULL) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"mixed_layer_depth: Unable to allocate memory for coercing input array to double");
    return(NhlFATAL);
  }
/*
 * Allocate space for tmp_depth.
 */
  tmp_depth = coerce_input_double(depth,type_depth,nz,0,NULL,NULL);
  if(tmp_depth == NULL) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"mixed_layer_depth: Unable to allocate memory for coercing input array to double");
    return(NhlFATAL);
  }
/*
 * Allocate space for tmp_offset.
 */
  tmp_offset = coerce_input_double(offset,type_offset,1,0,NULL,NULL);
  if(tmp_offset == NULL) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"mixed_layer_depth: Unable to allocate memory for coercing input array to double");
    return(NhlFATAL);
  }

/*
 * Calculate size of output array.
 */
  nynx  = ny * nx;
  size_output = size_leftmost * nynx;

/* 
 * Allocate space for output array.
 */
  if(type_mld != NCL_double) {
    mld = (void *)calloc(size_output, sizeof(float));
    tmp_mld = (double *)calloc(nynx,sizeof(double));
    if(tmp_mld == NULL) {
      NhlPError(NhlFATAL,NhlEUNKNOWN,"mixed_layer_depth: Unable to allocate memory for temporary output array");
      return(NhlFATAL);
    }
  }
  else {
    mld = (void *)calloc(size_output, sizeof(double));
    tmp_mld = (double *)mld;
  }
  if(mld == NULL) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"mixed_layer_depth: Unable to allocate memory for output array");
    return(NhlFATAL);
  }
  if(has_missing_pot_density) {
    if(type_mld == NCL_double) missing_mld = missing_dbl_pot_density;
    else                 missing_mld = missing_flt_pot_density;
    missing_dbl_mld = missing_dbl_pot_density;
  }

/* 
 * Allocate space for output dimension sizes and set them.
 */
  ndims_mld = ndims_leftmost + 2;
  dsizes_mld = (ng_size_t*)calloc(ndims_mld,sizeof(ng_size_t));  
  if( dsizes_mld == NULL ) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"mixed_layer_depth: Unable to allocate memory for holding dimension sizes");
    return(NhlFATAL);
  }
  for(i = 0; i < ndims_mld; i++) {
	  if (i < ndims_leftmost) {
		  dsizes_mld[i] = dsizes_pot_density[i];
	  }
	  else {
		  dsizes_mld[i] = dsizes_pot_density[i+1];
	  }
  }

/*
 * Loop across leftmost dimensions and call the Fortran routine for each
 * subsection of the input arrays.
 */
  index_pot_density = 0;
  index_mld = 0;

  for(i = 0; i < size_leftmost; i++) {
/*
 * Coerce subsection of pot_density (tmp_pot_density) to double if necessary.
 */
    if(type_pot_density != NCL_double) {
      coerce_subset_input_double(pot_density,tmp_pot_density,index_pot_density,type_pot_density,nznynx,0,NULL,NULL);
    }
    else {
      tmp_pot_density = &((double*)pot_density)[index_pot_density];
    }

/*
 * Call the Fortran routine.
 */
    NGCALLF(mixed_layer_depth,MIXED_LAYER_DEPTH)(tmp_pot_density, kmt, tmp_ht, tmp_depth, tmp_mld + index_mld, 
						 &nx, &ny, &nz, tmp_offset, &missing_dbl_pot_density.doubleval);

/*
 * Coerce output back to float if necessary.
 */
    if(type_mld == NCL_float) {
      coerce_output_float_only(mld,tmp_mld,nynx,index_mld);
    }
    index_pot_density += nznynx;
    index_mld += nynx;
  }

/*
 * Free unneeded memory.
 */
  if(type_pot_density != NCL_double) NclFree(tmp_pot_density);
  if(type_ht != NCL_double) NclFree(tmp_ht);
  if(type_depth != NCL_double) NclFree(tmp_depth);
  if(type_offset != NCL_double) NclFree(tmp_offset);
  if(type_mld != NCL_double) NclFree(tmp_mld);

/*
 * Return value back to NCL script.
 */
  if(type_mld != NCL_double) {
    ret = NclReturnValue(mld,ndims_mld,dsizes_mld,&missing_flt_mld,type_mld,0);
  }
  else {
    ret = NclReturnValue(mld,ndims_mld,dsizes_mld,&missing_dbl_mld,type_mld,0);
  }
  NclFree(dsizes_mld);
  return(ret);
}
Esempio n. 11
0
NhlErrorTypes potmp_insitu_ocn_W( void )
{

/*
 * Input variables
 */
/*
 * Argument # 0
 */
  void *t;
  double *tmp_t;
  int ndims_t;
  ng_size_t dsizes_t[NCL_MAX_DIMENSIONS];
  NclBasicDataTypes type_t;
  int has_missing_t;
  NclScalar missing_t, missing_flt_t, missing_dbl_t;

/*
 * Argument # 1
 */
  void *s;
  double *tmp_s;
  int ndims_s;
  ng_size_t dsizes_s[NCL_MAX_DIMENSIONS];
  NclBasicDataTypes type_s;
  int has_missing_s;
  NclScalar missing_s, missing_flt_s, missing_dbl_s;

/*
 * Argument # 2
 */
  void *pres;
  double *tmp_pres;
  int ndims_pres;
  ng_size_t dsizes_pres[NCL_MAX_DIMENSIONS];
  NclBasicDataTypes type_pres;
  int is_scalar_pres;

/*
 * Argument # 3
 */
  void *pref;
  double *tmp_pref;
  NclBasicDataTypes type_pref;

/*
 * Argument # 4
 */
  int *dims;
  ng_size_t dsizes_dims[1];

/*
 * Argument # 5
 */
  logical *opt;
  logical reverse = False;

/*
 * Variables for retrieving attributes from "opt".
 */
  NclAttList  *attr_list;
  NclAtt  attr_obj;
  NclStackEntry   stack_entry;

/*
 * Return variable
 */
  void *pot;
  double *tmp_pot;
  NclBasicDataTypes type_pot;
  NclScalar missing_pot;

/*
 * Various
 */
  ng_size_t i, total_nts, total_npres, total_nl, total_nr, nrnpres;
  ng_size_t ipres;
  int ret;

/*
 * Retrieve parameters.
 *
 * Note any of the pointer parameters can be set to NULL, which
 * implies you don't care about its value.
 */
/*
 * Get argument # 0
 */
  t = (void*)NclGetArgValue(
           0,
           6,
           &ndims_t,
           dsizes_t,
           &missing_t,
           &has_missing_t,
           &type_t,
           DONT_CARE);


/*
 * Get argument # 1
 */
  s = (void*)NclGetArgValue(
           1,
           6,
           &ndims_s,
           dsizes_s,
           &missing_s,
           &has_missing_s,
           &type_s,
           DONT_CARE);

/*
 * Check dimension sizes.
 */
  if(ndims_t != ndims_s) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"potmp_insitu_ocn: the dimensions of t and s must be the same");
    return(NhlFATAL);
  }
  for(i = 0; i < ndims_t; i++) {
    if(dsizes_t[i] != dsizes_s[i]) {
      NhlPError(NhlFATAL,NhlEUNKNOWN,"potmp_insitu_ocn: the dimensions of t and s must be the same");
      return(NhlFATAL);
    }
  }

/*
 * Get argument # 2
 */
  pres = (void*)NclGetArgValue(
           2,
           6,
           &ndims_pres,
           dsizes_pres,
           NULL,
           NULL,
           &type_pres,
           DONT_CARE);

/*
 * Check dimension sizes and get total # of elements.
 */
  if(ndims_pres > ndims_t) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"potmp_insitu_ocn: the rank of pres must be less than or equal to the rank of t and s");
    return(NhlFATAL);
  }

/* Scalar pressure is a special case */
  is_scalar_pres = is_scalar(ndims_pres,dsizes_pres);

/*
 * Get argument # 3
 */
  pref = (void*)NclGetArgValue(
           3,
           6,
           NULL,
           NULL,
           NULL,
           NULL,
           &type_pref,
           DONT_CARE);

/*
 * Get argument # 4
 */
  dims = (int*)NclGetArgValue(
           4,
           6,
           NULL,
           dsizes_dims,
           NULL,
           NULL,
           NULL,
           DONT_CARE);

/*
 * Get argument # 5
 */
  opt = (logical*)NclGetArgValue(
           5,
           6,
           NULL,
           NULL,
           NULL,
           NULL,
           NULL,
           DONT_CARE);

/*
 * Some error checking. Make sure pressure dimensions are valid.
 */

  if(!is_scalar_pres) {
    if(dsizes_dims[0] != ndims_pres) {
      NhlPError(NhlFATAL,NhlEUNKNOWN,"potmp_insitu_ocn: invalid number of dimension indexes given for 'pres'");
      return(NhlFATAL);
    }
    for(i = 0; i < dsizes_dims[0]; i++ ) {
      if(dims[i] < 0 || dims[i] >= ndims_t) {
        NhlPError(NhlFATAL,NhlEUNKNOWN,"potmp_insitu_ocn: invalid dimension indexes given for 'pres'");
        return(NhlFATAL);
      }
      if(i > 0 && dims[i] != (dims[i-1]+1)) {
        NhlPError(NhlFATAL,NhlEUNKNOWN,"potmp_insitu_ocn: input dimension sizes must be monotonically increasing, can't continue");
        return(NhlFATAL);
      }
      if(dsizes_pres[i] != dsizes_t[dims[i]]) {
        NhlPError(NhlFATAL,NhlEUNKNOWN,"potmp_insitu_ocn: dimension indexes given for 'pres' don't match dimensions of t and s");
        return(NhlFATAL);
      }
    }
  }


/*
 * Coerce missing values to double if necessary.
 */
  coerce_missing(type_t,has_missing_t,&missing_t,&missing_dbl_t,
                 &missing_flt_t);
  coerce_missing(type_s,has_missing_s,&missing_s,&missing_dbl_s,
                 &missing_flt_s);

/*
 * Compute the total number of leftmost and rightmost elements
 * in t and s.
 */
  if(is_scalar_pres) {
    total_nl = 1;
    for(i = 0; i < ndims_t; i++) total_nl *= dsizes_t[i];
    total_npres = nrnpres = total_nr = 1;
    total_nts  = total_nl;
  }
  else {
    total_npres = total_nl = total_nr = 1;
    for(i = 0; i < dims[0]; i++) total_nl *= dsizes_t[i];
    for(i = 0; i < ndims_pres; i++) total_npres *= dsizes_pres[i];
    for(i = dims[dsizes_dims[0]-1]+1; i < ndims_t; i++) total_nr *= dsizes_t[i];

    nrnpres    = total_nr * total_npres;
    total_nts  = total_nl * nrnpres;
  }
/*
 * The output type defaults to float, unless t is double.
 */
  if(type_t == NCL_double || type_s == NCL_double || 
     type_pres == NCL_double || type_pref == NCL_double) {
    type_pot = NCL_double;
    if(has_missing_t) {
      missing_pot = missing_dbl_t;
    }
    else if(has_missing_s) {
      missing_pot = missing_dbl_s;
    }
  }
  else {
    type_pot = NCL_float;
    if(has_missing_t) {
      missing_pot = missing_flt_t;
    }
    else if(has_missing_s) {
      missing_pot = missing_flt_s;
    }
  }

/* 
 * Coerce input arrays to double if necessary.
 */
  tmp_t    = coerce_input_double(t,   type_t,   total_nts,0,NULL,NULL);
  tmp_s    = coerce_input_double(s,   type_s,   total_nts,0,NULL,NULL);
  tmp_pres = coerce_input_double(pres,type_pres,total_npres,0,NULL,NULL);
  tmp_pref = coerce_input_double(pref,type_pref, 1,0,NULL,NULL);
  if(tmp_t == NULL || tmp_s == NULL || tmp_pres == NULL) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"potmp_insitu_ocn: Unable to allocate memory for coercing input arrays to double");
    return(NhlFATAL);
  }

/* 
 * Allocate space for output array.
 */
  if(type_pot != NCL_double) {
    pot = (void *)calloc(total_nts, sizeof(float));
    tmp_pot = (double*)calloc(1,sizeof(double));
  }
  else {
    pot = (void *)calloc(total_nts, sizeof(double));
  }
  if(pot == NULL) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"potmp_insitu_ocn: Unable to allocate memory for output array");
    return(NhlFATAL);
  }

/* 
 * If "opt" is True, then check if any attributes have been set.
 */
  if(*opt) {
    stack_entry = _NclGetArg(5, 6, DONT_CARE);
    switch (stack_entry.kind) {
    case NclStk_VAR:
      if (stack_entry.u.data_var->var.att_id != -1) {
        attr_obj = (NclAtt) _NclGetObj(stack_entry.u.data_var->var.att_id);
        if (attr_obj == NULL) {
          break;
        }
      }
      else {
/*
 * att_id == -1 ==> no optional args given.
 */
        break;
      }
/* 
 * Get optional arguments.
 */
      if (attr_obj->att.n_atts > 0) {
/*
 * Get list of attributes.
 */
        attr_list = attr_obj->att.att_list;
/*
 * Loop through attributes and check them. The current ones recognized are:
 *   "reverse"
 */
        while (attr_list != NULL) {
/*
 * Check for "return_eval".
 */
          if (!strcmp(attr_list->attname, "reverse")) {
            if(attr_list->attvalue->multidval.data_type == NCL_logical) {
              reverse = *(logical*) attr_list->attvalue->multidval.val;
            }
            else {
              NhlPError(NhlWARNING,NhlEUNKNOWN,"potmp_insitu_ocn: The 'reverse' attribute must be a logical. Defaulting to False.");
            }
          }
          attr_list = attr_list->next;
        }
      }
    default:
      break;
    }
  }

/*
 * Call the Fortran routine.
 */
  for(i = 0; i < total_nts; i++) {
    if(type_pot == NCL_double) tmp_pot = &((double*)pot)[i];

/* Calculate index into pressure array */
    ipres = (ng_size_t)((i-((ng_size_t)(i/nrnpres)*nrnpres))/total_nr);

    if(has_missing_t && tmp_t[i] == missing_dbl_t.doubleval) {
      *tmp_pot = missing_dbl_t.doubleval;
    }
    else if(has_missing_s && tmp_s[i] == missing_dbl_s.doubleval) {
      *tmp_pot = missing_dbl_s.doubleval;
    }
    else {
      if(reverse) {
        NGCALLF(dpotmp,DPOTMP)(tmp_pref, &tmp_t[i], &tmp_s[i],
                               &tmp_pres[ipres], tmp_pot);
      }
      else {
        NGCALLF(dpotmp,DPOTMP)(&tmp_pres[ipres], &tmp_t[i], &tmp_s[i],
                               tmp_pref, tmp_pot);
      }
    }
/*
 * Coerce output back to float if necessary.
 */
    if(type_pot == NCL_float) coerce_output_float_only(pot,tmp_pot,1,i);
  }

/*
 * Free unneeded memory.
 */
  if(type_t    != NCL_double) NclFree(tmp_t);
  if(type_s    != NCL_double) NclFree(tmp_s);
  if(type_pres != NCL_double) NclFree(tmp_pres);
  if(type_pref != NCL_double) NclFree(tmp_pref);
  if(type_pot  != NCL_double) NclFree(tmp_pot);

/*
 * Return value back to NCL script.
 */
  if(has_missing_t || has_missing_s) {
    ret = NclReturnValue(pot,ndims_t,dsizes_t,&missing_pot,type_pot,0);
  }
  else {
    ret = NclReturnValue(pot,ndims_t,dsizes_t,NULL,type_pot,0);
  }
  return(ret);
}
Esempio n. 12
0
NhlErrorTypes depth_to_pres_W( void )
{

/*
 * Input variables
 */
/*
 * Argument # 0
 */
  void *z;
  double *tmp_z;
  int ndims_z;
  ng_size_t dsizes_z[NCL_MAX_DIMENSIONS];
  int has_missing_z;
  NclScalar missing_z, missing_dbl_z, missing_flt_z;
  NclBasicDataTypes type_z;

/*
 * Argument # 1
 */
  logical *opt;

/*
 * Return variable
 */
  void *pres;
  double *tmp_pres = NULL;
  NclBasicDataTypes type_pres;
  NclScalar missing_pres;

/*
 * Various
 */
  ng_size_t i, nd;
  int ind, ret;
  double zmsg;

/*
 * Retrieve parameters.
 *
 * Note any of the pointer parameters can be set to NULL, which
 * implies you don't care about its value.
 */
/*
 * Get argument # 0
 */
  z = (void*)NclGetArgValue(
           0,
           2,
           &ndims_z,
           dsizes_z,
           &missing_z,
           &has_missing_z,
           &type_z,
           DONT_CARE);

/*
 * Get argument # 1
 */
  opt = (logical*)NclGetArgValue(
           1,
           2,
           NULL,
           NULL,
           NULL,
           NULL,
           NULL,
           DONT_CARE);
  nd = 1;
  for(i = 0; i < ndims_z; i++) nd *= dsizes_z[i];

/*
 * Test input dimension sizes.
 */
  if(nd > INT_MAX) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"depth_to_pres: the size of z is greater than INT_MAX");
    return(NhlFATAL);
  }
  ind = (int) nd;

/*
 * Coerce missing values to double if necessary.
 * Currently, missing values are not checked for.
 */
  coerce_missing(type_z,has_missing_z,&missing_z,&missing_dbl_z,
                 &missing_flt_z);

/*
 * The output type defaults to float, unless z is double.
 */
  if(type_z == NCL_double) type_pres = NCL_double;
  else                     type_pres = NCL_float;

  if(has_missing_z) {
    if(type_z == NCL_double) missing_pres = missing_dbl_z;
    else                     missing_pres = missing_flt_z;
    zmsg = missing_dbl_z.doubleval;
  }
  else {
    zmsg = 0.0;   /* Won't be used. */
  }

/* 
 * Coerce input array to double if necessary.
 */
  tmp_z = coerce_input_double(z,type_z,nd,0,NULL,NULL);
  if(tmp_z == NULL) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"depth_to_pres: Unable to allocate memory for coercing z to double");
    return(NhlFATAL);
  }

/* 
 * Allocate space for output array.
 */
  if(type_pres != NCL_double) {
    pres     = (void *)calloc(nd, sizeof(float));
    tmp_pres = (double *)calloc(nd,sizeof(double));
    if(tmp_pres == NULL) {
      NhlPError(NhlFATAL,NhlEUNKNOWN,"depth_to_pres: Unable to allocate memory for temporary output array");
      return(NhlFATAL);
    }
  }
  else {
    pres = (void *)calloc(nd, sizeof(double));
  }
  if(pres == NULL) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"depth_to_pres: Unable to allocate memory for output array");
    return(NhlFATAL);
  }
  if(type_pres == NCL_double) tmp_pres = &((double*)pres)[0];

/*
 * Call the Fortran routine.
 */
  NGCALLF(dpth2pres,DPTH2PRES)(&ind, tmp_z, &has_missing_z, &zmsg, tmp_pres);

/*
 * Coerce output back to float if necessary.
 */
  if(type_pres == NCL_float) coerce_output_float_only(pres,tmp_pres,nd,0);

/*
 * Free unneeded memory.
 */
  if(type_z    != NCL_double) NclFree(tmp_z);
  if(type_pres != NCL_double) NclFree(tmp_pres);

/*
 * Return value back to NCL script.
 */
  if(has_missing_z) {
    ret = NclReturnValue(pres,ndims_z,dsizes_z,&missing_pres,type_pres,0);
  }
  else {
    ret = NclReturnValue(pres,ndims_z,dsizes_z,NULL,type_pres,0);
  }
  return(ret);
}
Esempio n. 13
0
NhlErrorTypes specxy_anal_W( void )
{
/*
 * Input array variables
 */
  void *x, *y, *pct;
  double *dx, *dy, *dpct;
  ng_size_t dsizes[1], nx;
  int *iopt, *jave;
  int ndims_x;
  ng_size_t dsizes_x[NCL_MAX_DIMENSIONS];
  int ndims_y;
  ng_size_t dsizes_y[NCL_MAX_DIMENSIONS];
  int has_missing_x, has_missing_y;
  NclScalar missing_x, missing_y, missing_dx, missing_dy;
  NclBasicDataTypes type_x, type_y, type_pct;
  ng_size_t lwork;
  double scl, *work;
/*
 * Output variables
 */
  void *dof;
  NclBasicDataTypes type_dof;
  NclObjClass type_output;
/*
 * Attribute variables
 */
  int att_id;
  NclMultiDValData att_md, return_md;
  NclVar tmp_var;
  NclStackEntry return_data;
  double *frq_tmp, *spcx_tmp, *spcy_tmp;
  double *cospc_tmp, *quspc_tmp, *coher_tmp, *phase_tmp;
  double prob_tmp[4], sinfo[50];
  void *bw, *frq, *spcx, *spcy, *cospc, *quspc, *coher, *phase;
  void *xavei, *xvari, *xvaro, *xlag1, *xslope;
  void *yavei, *yvari, *yvaro, *ylag1, *yslope; 
  void *prob;
/*
 * Declare variables for random purposes.
 */
  ng_size_t i, nspc, nspcmx, total_size_x, total_size_y;
  int ier;
/*
 * Retrieve arguments.
 */
  x = (void*)NclGetArgValue(
          0,
          5,
          &ndims_x,
          dsizes_x,
          &missing_x,
          &has_missing_x,
          &type_x,
          DONT_CARE);

  y = (void*)NclGetArgValue(
          1,
          5,
          &ndims_y,
          dsizes_y,
          &missing_y,
          &has_missing_y,
          &type_y,
          DONT_CARE);

  iopt = (int*)NclGetArgValue(
          2,
          5,
          NULL,
          NULL,
          NULL,
          NULL,
          NULL,
          DONT_CARE);

  jave = (int*)NclGetArgValue(
          3,
          5,
          NULL,
          NULL,
          NULL,
          NULL,
          NULL,
          DONT_CARE);

  pct = (void*)NclGetArgValue(
          4,
          5,
          NULL,
          NULL,
          NULL,
          NULL,
          &type_pct,
          DONT_CARE);
/*
 * Check input.
 */
  nx   = dsizes_x[0];
  nspc = nspcmx = nx/2 + 1;

  if( nx != dsizes_y[0]) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"specxy_anal: 'x' and 'y' must have the same number of elements");
    return(NhlFATAL);
  }
  if( nx < 3) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"specxy_anal: 'x' and 'y' must have more than 3 elements");
    return(NhlFATAL);
  }

  if( *iopt > 2) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"specxy_anal: 'iopt' must be <= 2");
    return(NhlFATAL);
  }

  if( abs(*jave) > nx/2 ) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"specxy_anal: 'jave' must be <= nx/2");
    return(NhlFATAL);
  }

/*
 * Compute the total number of elements in our arrays.
 */
  total_size_x = 1;
  for(i = 0; i < ndims_x; i++) total_size_x *= dsizes_x[i];

  total_size_y = 1;
  for(i = 0; i < ndims_y; i++) total_size_y *= dsizes_y[i];
/*
 * Check for missing values and coerce data if necessary.
 */
  coerce_missing(type_x,has_missing_x,&missing_x,&missing_dx,NULL);
  coerce_missing(type_y,has_missing_y,&missing_y,&missing_dy,NULL);
/*
 * Coerce x/y to double precision if necessary.
 */
  dx = coerce_input_double(x,type_x,total_size_x,has_missing_x,&missing_x,
                           &missing_dx);
  dy = coerce_input_double(y,type_y,total_size_y,has_missing_y,&missing_y,
                           &missing_dy);
  if(dx == NULL|| dy == NULL) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"specxy_anal: Unable to allocate memory for coercing input arrays to double precision");
    return(NhlFATAL);
  }
/*  
 * Check if x or y contains missing values.
 */
  if(contains_missing(dx,total_size_x,has_missing_x,missing_dx.doubleval) ||
     contains_missing(dy,total_size_y,has_missing_y,missing_dy.doubleval)) {
     NhlPError(NhlFATAL,NhlEUNKNOWN,"specx_anal: x and y cannot contain any missing values");
     return(NhlFATAL);
  }
/*
 * Coerce pct to double precision if necessary.
 */
  dpct = coerce_input_double(pct,type_pct,1,0,NULL,NULL);
  if( dpct == NULL ) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"specxy_anal: Unable to allocate memory for coercing pct array to double precision");
    return(NhlFATAL);
  }
/*
 * Check pct.
 */
  if( *dpct < 0.0 || *dpct > 1.0 ) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"specxy_anal: 'pct' must be between 0 and 1 inclusive");
    return(NhlFATAL);
  }
/*
 * Check if any input is double.
 */
  if(type_x != NCL_double && type_y != NCL_double && 
     type_pct != NCL_double) {

    type_dof = NCL_float;
    type_output = nclTypefloatClass;
/* 
 * Allocate space for float output variables.
 */
    dof      = (void *)calloc(1,sizeof(float));
    frq      = (void *)calloc(nspcmx-1,sizeof(float));
    spcx     = (void *)calloc(nspcmx-1,sizeof(float));
    spcy     = (void *)calloc(nspcmx-1,sizeof(float));
    cospc    = (void *)calloc(nspcmx-1,sizeof(float));
    quspc    = (void *)calloc(nspcmx-1,sizeof(float));
    coher    = (void *)calloc(nspcmx-1,sizeof(float));
    phase    = (void *)calloc(nspcmx-1,sizeof(float));
    bw       = (void *)calloc(1,sizeof(float));
    prob     = (void *)calloc(4,sizeof(float));
    xavei    = (void *)calloc(1,sizeof(float));
    xvari    = (void *)calloc(1,sizeof(float));
    xvaro    = (void *)calloc(1,sizeof(float));
    xlag1    = (void *)calloc(1,sizeof(float));
    xslope   = (void *)calloc(1,sizeof(float));
    yavei    = (void *)calloc(1,sizeof(float));
    yvari    = (void *)calloc(1,sizeof(float));
    yvaro    = (void *)calloc(1,sizeof(float));
    ylag1    = (void *)calloc(1,sizeof(float));
    yslope   = (void *)calloc(1,sizeof(float));
  }
  else {
    type_dof = NCL_double;
    type_output = nclTypedoubleClass;
/*
 * Allocate space for double output variables.
 */
    dof     = (void *)calloc(1,sizeof(double));
    bw      = (void *)calloc(1,sizeof(double));
    prob    = (void *)calloc(4,sizeof(double));
    frq     = (void *)calloc(nspcmx-1,sizeof(double));
    spcx    = (void *)calloc(nspcmx-1,sizeof(double));
    spcy    = (void *)calloc(nspcmx-1,sizeof(double));
    cospc   = (void *)calloc(nspcmx-1,sizeof(double));
    quspc   = (void *)calloc(nspcmx-1,sizeof(double));
    coher   = (void *)calloc(nspcmx-1,sizeof(double));
    phase   = (void *)calloc(nspcmx-1,sizeof(double));
    xavei   = (void *)calloc(1,sizeof(double));
    xvari   = (void *)calloc(1,sizeof(double));
    xvaro   = (void *)calloc(1,sizeof(double));
    xlag1   = (void *)calloc(1,sizeof(double));
    xslope  = (void *)calloc(1,sizeof(double));
    yavei   = (void *)calloc(1,sizeof(double));
    yvari   = (void *)calloc(1,sizeof(double));
    yvaro   = (void *)calloc(1,sizeof(double));
    ylag1   = (void *)calloc(1,sizeof(double));
    yslope  = (void *)calloc(1,sizeof(double));
  }
  if(   dof == NULL ||    bw == NULL || xavei == NULL || xvari == NULL ||
        frq == NULL ||  spcx == NULL ||  spcy == NULL || cospc == NULL ||
      quspc == NULL || coher == NULL || phase == NULL || xvaro == NULL ||
      xlag1 == NULL ||xslope == NULL || yavei == NULL || yvari == NULL ||
      yvaro == NULL || ylag1 == NULL ||yslope == NULL ||  prob == NULL) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"specxy_anal: Unable to allocate memory for output variables");
    return(NhlFATAL);
  }

/*
 * Allocate space for stuff to be returned by dspecx.
 */
  frq_tmp   = (double *)calloc(nspcmx,sizeof(double));
  spcx_tmp  = (double *)calloc(nspcmx,sizeof(double));
  spcy_tmp  = (double *)calloc(nspcmx,sizeof(double));
  cospc_tmp = (double *)calloc(nspcmx,sizeof(double));
  quspc_tmp = (double *)calloc(nspcmx,sizeof(double));
  coher_tmp = (double *)calloc(nspcmx,sizeof(double));
  phase_tmp = (double *)calloc(nspcmx,sizeof(double));
  if(    frq_tmp == NULL ||  spcx_tmp == NULL ||  spcy_tmp == NULL || 
       cospc_tmp == NULL || quspc_tmp == NULL || coher_tmp == NULL || 
       phase_tmp == NULL) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"specxy_anal: Unable to allocate memory for output variables");
    return(NhlFATAL);
  }

/*
 * Allocate space for work array.
 */
  lwork = 10 * nx;
  work  = (double *)calloc(lwork,sizeof(double));
  if( work == NULL ) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"specxy_anal: Unable to allocate memory for work array");
    return(NhlFATAL);
  }
/*
 * Call the Fortran version of this routine.
 */
  scl = 2.0;
  if((nx <= INT_MAX) &&
     (lwork <= INT_MAX) &&
     (nspc <= INT_MAX))
  {
      int inx = (int) nx;
      int ilwork = (int) lwork;
      int inspc = (int) nspc;
      NGCALLF(dspecxy,DSPECXY)(dx,dy,&inx,iopt,jave,dpct,&scl,work,&ilwork,
                               frq_tmp,spcx_tmp,spcy_tmp,cospc_tmp,quspc_tmp,
                               coher_tmp,phase_tmp,&inspc,sinfo,&ier);
  }
  else
  {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"specxy_anal: one or more input dimensions is greater than INT_MAX", nx);
    return(NhlFATAL);
  }

  if( ier > 700000 ) {
    NhlPError(NhlWARNING,NhlEUNKNOWN,"specxy_anal: 'x' and/or 'y' contains all constant values");
  }
/*
 * Calculate coherence corresponding to the 90, 95, 99, and 99.9% levels.
 */
  prob_tmp[0] = 1.-pow((1.-0.900),(1./(sinfo[0]/2.-1.)));
  prob_tmp[1] = 1.-pow((1.-0.950),(1./(sinfo[0]/2.-1.)));
  prob_tmp[2] = 1.-pow((1.-0.990),(1./(sinfo[0]/2.-1.)));
  prob_tmp[3] = 1.-pow((1.-0.999),(1./(sinfo[0]/2.-1.)));


  coerce_output_float_or_double(   dof,    &sinfo[0],type_dof,1,0);
  coerce_output_float_or_double( xlag1,    &sinfo[1],type_dof,1,0);
  coerce_output_float_or_double( ylag1,    &sinfo[2],type_dof,1,0);
  coerce_output_float_or_double(    bw,    &sinfo[5],type_dof,1,0);
  coerce_output_float_or_double(  prob,     prob_tmp,type_dof,4,0);
  coerce_output_float_or_double( xavei,   &sinfo[10],type_dof,1,0);
  coerce_output_float_or_double( xvari,   &sinfo[11],type_dof,1,0);
  coerce_output_float_or_double( xvaro,   &sinfo[12],type_dof,1,0);
  coerce_output_float_or_double(xslope,   &sinfo[31],type_dof,1,0);
  coerce_output_float_or_double( yavei,   &sinfo[20],type_dof,1,0);
  coerce_output_float_or_double( yvari,   &sinfo[21],type_dof,1,0);
  coerce_output_float_or_double( yvaro,   &sinfo[22],type_dof,1,0);
  coerce_output_float_or_double(yslope,   &sinfo[34],type_dof,1,0);

  coerce_output_float_or_double(   frq,  &frq_tmp[1],type_dof,nspcmx-1,0);
  coerce_output_float_or_double(  spcx, &spcx_tmp[1],type_dof,nspcmx-1,0);
  coerce_output_float_or_double(  spcy, &spcy_tmp[1],type_dof,nspcmx-1,0);
  coerce_output_float_or_double( cospc,&cospc_tmp[1],type_dof,nspcmx-1,0);
  coerce_output_float_or_double( quspc,&quspc_tmp[1],type_dof,nspcmx-1,0);
  coerce_output_float_or_double( coher,&coher_tmp[1],type_dof,nspcmx-1,0);
  coerce_output_float_or_double( phase,&phase_tmp[1],type_dof,nspcmx-1,0);

/*
 * Set up variable to return.
 */
  dsizes[0] = 1;
  return_md = _NclCreateVal(
                            NULL,
                            NULL,
                            Ncl_MultiDValData,
                            0,
                            dof,
                            NULL,
                            1,
                            dsizes,
                            TEMPORARY,
                            NULL,
                            type_output
                            );
  /*
   * Set up attributes to return.
   */
  att_id = _NclAttCreate(NULL,NULL,Ncl_Att,0,NULL);
  
  dsizes[0] = nspcmx-1;      /* returning nx/2 points, not nx/2 + 1 */
  att_md = _NclCreateVal(
                         NULL,
                         NULL,
                         Ncl_MultiDValData,
                         0,
                         spcx,
                         NULL,
                         1,
                         dsizes,
                         TEMPORARY,
                         NULL,
                         type_output
                         );
  _NclAddAtt(
             att_id,
             "spcx",
             att_md,
             NULL
             );
  
  att_md = _NclCreateVal(
                         NULL,
                         NULL,
                         Ncl_MultiDValData,
                         0,
                         spcy,
                         NULL,
                         1,
                         dsizes,
                         TEMPORARY,
                         NULL,
                         type_output
                         );
  _NclAddAtt(
             att_id,
             "spcy",
             att_md,
             NULL
             );
  
  att_md = _NclCreateVal(
                         NULL,
                         NULL,
                         Ncl_MultiDValData,
                         0,
                         frq,
                         NULL,
                         1,
                         dsizes,
                         TEMPORARY,
                         NULL,
                         type_output
                         );
  _NclAddAtt(
             att_id,
             "frq",
             att_md,
             NULL
             );
  
  att_md = _NclCreateVal(
                         NULL,
                         NULL,
                         Ncl_MultiDValData,
                         0,
                         cospc,
                         NULL,
                         1,
                         dsizes,
                         TEMPORARY,
                         NULL,
                         type_output
                         );
  _NclAddAtt(
             att_id,
             "cospc",
             att_md,
             NULL
             );
  
  att_md = _NclCreateVal(
                         NULL,
                         NULL,
                         Ncl_MultiDValData,
                         0,
                         quspc,
                         NULL,
                         1,
                         dsizes,
                         TEMPORARY,
                         NULL,
                         type_output
                         );
  _NclAddAtt(
             att_id,
             "quspc",
             att_md,
             NULL
             );
  
  att_md = _NclCreateVal(
                         NULL,
                         NULL,
                         Ncl_MultiDValData,
                         0,
                         coher,
                         NULL,
                         1,
                         dsizes,
                         TEMPORARY,
                         NULL,
                         type_output
                         );
  _NclAddAtt(
             att_id,
             "coher",
             att_md,
             NULL
             );
  
  att_md = _NclCreateVal(
                         NULL,
                         NULL,
                         Ncl_MultiDValData,
                         0,
                         phase,
                         NULL,
                         1,
                         dsizes,
                         TEMPORARY,
                         NULL,
                         type_output
                         );
  _NclAddAtt(
             att_id,
             "phase",
             att_md,
             NULL
             );
  
  dsizes[0] = 1;
  att_md = _NclCreateVal(
                         NULL,
                         NULL,
                         Ncl_MultiDValData,
                         0,
                         bw,
                         NULL,
                         1,
                         dsizes,
                         TEMPORARY,
                         NULL,
                         type_output
                         );
  _NclAddAtt(
             att_id,
             "bw",
             att_md,
             NULL
             );
  
  dsizes[0] = 4;
  att_md = _NclCreateVal(
                         NULL,
                         NULL,
                         Ncl_MultiDValData,
                         0,
                         prob,
                         NULL,
                         1,
                         dsizes,
                         TEMPORARY,
                         NULL,
                         type_output
                         );
  _NclAddAtt(
             att_id,
             "coher_probability",
             att_md,
             NULL
             );
  
  dsizes[0] = 1;
  att_md = _NclCreateVal(
                         NULL,
                         NULL,
                         Ncl_MultiDValData,
                         0,
                         xavei,
                         NULL,
                         1,
                         dsizes,
                         TEMPORARY,
                         NULL,
                         type_output
                         );
  _NclAddAtt(
             att_id,
             "xavei",
             att_md,
             NULL
             );
  
  att_md = _NclCreateVal(
                         NULL,
                         NULL,
                         Ncl_MultiDValData,
                         0,
                         xvari,
                         NULL,
                         1,
                         dsizes,
                         TEMPORARY,
                         NULL,
                         type_output
                         );
  _NclAddAtt(
             att_id,
             "xvari",
             att_md,
             NULL
             );
  
  att_md = _NclCreateVal(
                         NULL,
                         NULL,
                         Ncl_MultiDValData,
                         0,
                         xvaro,
                         NULL,
                         1,
                         dsizes,
                         TEMPORARY,
                         NULL,
                         type_output
                         );
  _NclAddAtt(
             att_id,
             "xvaro",
             att_md,
             NULL
             );
  
  att_md = _NclCreateVal(
                         NULL,
                         NULL,
                         Ncl_MultiDValData,
                         0,
                         xlag1,
                         NULL,
                         1,
                         dsizes,
                         TEMPORARY,
                         NULL,
                         type_output
                         );
  _NclAddAtt(
             att_id,
             "xlag1",
             att_md,
             NULL
             );
  
  att_md = _NclCreateVal(
                         NULL,
                         NULL,
                         Ncl_MultiDValData,
                         0,
                         xslope,
                         NULL,
                         1,
                         dsizes,
                         TEMPORARY,
                         NULL,
                         type_output
                         );
  _NclAddAtt(
             att_id,
             "xslope",
             att_md,
             NULL
             );
  
  att_md = _NclCreateVal(
                         NULL,
                         NULL,
                         Ncl_MultiDValData,
                         0,
                         yavei,
                         NULL,
                         1,
                         dsizes,
                         TEMPORARY,
                         NULL,
                         type_output
                         );
  
  _NclAddAtt(
             att_id,
             "yavei",
             att_md,
             NULL
             );
  
  att_md = _NclCreateVal(
                         NULL,
                         NULL,
                         Ncl_MultiDValData,
                         0,
                         yvari,
                         NULL,
                         1,
                         dsizes,
                         TEMPORARY,
                         NULL,
                         type_output
                         );
  _NclAddAtt(
             att_id,
             "yvari",
             att_md,
             NULL
             );
  
  att_md = _NclCreateVal(
                         NULL,
                         NULL,
                         Ncl_MultiDValData,
                         0,
                         yvaro,
                         NULL,
                         1,
                         dsizes,
                         TEMPORARY,
                         NULL,
                         type_output
                         );
  _NclAddAtt(
             att_id,
             "yvaro",
             att_md,
             NULL
             );
  
  att_md = _NclCreateVal(
                         NULL,
                         NULL,
                         Ncl_MultiDValData,
                         0,
                         ylag1,
                         NULL,
                         1,
                         dsizes,
                         TEMPORARY,
                         NULL,
                         type_output
                         );
  _NclAddAtt(
             att_id,
             "ylag1",
             att_md,
             NULL
             );
  
  att_md = _NclCreateVal(
                         NULL,
                         NULL,
                         Ncl_MultiDValData,
                         0,
                         yslope,
                         NULL,
                         1,
                         dsizes,
                         TEMPORARY,
                         NULL,
                         type_output
                         );
  _NclAddAtt(
             att_id,
             "yslope",
             att_md,
             NULL
             );
/*
 * Free up memory.
 */
  NclFree(work);
  if((void*)dx   != x) NclFree(dx);
  if((void*)dy   != y) NclFree(dy);
  if((void*)dpct != pct) NclFree(dpct);

  NclFree(frq_tmp);
  NclFree(spcx_tmp);
  NclFree(spcy_tmp);
  NclFree(cospc_tmp);
  NclFree(quspc_tmp);
  NclFree(coher_tmp);
  NclFree(phase_tmp);
/*
 * Return variable.
 */
  tmp_var = _NclVarCreate(
                          NULL,
                          NULL,
                          Ncl_Var,
                          0,
                          NULL,
                          return_md,
                          NULL,
                          att_id,
                          NULL,
                          RETURNVAR,
                          NULL,
                          TEMPORARY
                          );
/*
 * Return output grid and attributes to NCL.
 */
  return_data.kind = NclStk_VAR;
  return_data.u.data_var = tmp_var;
  _NclPlaceReturn(return_data);
  return(NhlNOERROR);
}
Esempio n. 14
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);
}
Esempio n. 15
0
NhlErrorTypes pop_remap_W( void )
{
/*
 * Input variables
 */
  void *dst_array, *map_wts, *src_array;
  double *dst, *map, *src;
  int has_missing_src_array, *dst_add, *src_add;
  ng_size_t ndst, nlink, nw, nsrc;
  ng_size_t dsizes_dst_array[1];
  ng_size_t dsizes_map_wts[2];
  ng_size_t dsizes_src_array[1];
  ng_size_t dsizes_dst_add[1];
  ng_size_t dsizes_src_add[1];
  NclBasicDataTypes type_dst_array, type_map_wts, type_src_array;
  NclScalar missing_src_array, missing_dsrc_array;
  int indst, inlink, inw, insrc;

/*
 * Retrieve parameters
 *
 * Note that any of the pointer parameters can be set to NULL,
 * which implies you don't care about its value.
 */
  dst_array = (void*)NclGetArgValue(
          0,
          5,
          NULL,
          dsizes_dst_array,
          NULL,
          NULL,
          &type_dst_array,
          DONT_CARE);

  map_wts = (void*)NclGetArgValue(
          1,
          5,
          NULL,
          dsizes_map_wts,
          NULL,
          NULL,
          &type_map_wts,
          DONT_CARE);

  dst_add = (int*)NclGetArgValue(
          2,
          5,
          NULL,
          dsizes_dst_add,
          NULL,
          NULL,
          NULL,
          DONT_CARE);

  src_add = (int*)NclGetArgValue(
          3,
          5,
          NULL,
          dsizes_src_add,
          NULL,
          NULL,
          NULL,
          DONT_CARE);

  src_array = (void*)NclGetArgValue(
          4,
          5,
          NULL,
          dsizes_src_array,
          &missing_src_array,
          &has_missing_src_array,
          &type_src_array,
          DONT_CARE);
/*
 * Check type of dst_array.
 */
  if(type_dst_array != NCL_float && type_dst_array != NCL_double) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"pop_remap: dst_array must be of type float or double");
    return(NhlFATAL);
  }
/*
 * Check dimensions and calculate total size of arrays.
 */
  nlink = dsizes_map_wts[0];
  nw    = dsizes_map_wts[1];
  ndst  = dsizes_dst_array[0];
  nsrc  = dsizes_src_array[0];

  if( dsizes_dst_add[0] != nlink || dsizes_src_add[0] != nlink ) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"pop_remap: The size of the dst_add and src_add arrays must be the same as the first dimension of map_wts");
    return(NhlFATAL);
  }
  if((ndst > INT_MAX) || (nlink > INT_MAX) || (nw > INT_MAX) || (nsrc > INT_MAX)) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"pop_remap: one or more input dimension sizes is greater than INT_MAX");
    return(NhlFATAL);
  }
  indst = (int) ndst;
  inlink = (int) nlink;
  inw = (int) nw;
  insrc = (int) nsrc;

/*
 * Check that src_array has a missing value set.
 */
  if(!has_missing_src_array) {
    NhlPError(NhlWARNING,NhlEUNKNOWN,"pop_remap: No missing values are being set.\nDefault missing values will be used.\nBe careful of results.");
  }
  coerce_missing(type_src_array,has_missing_src_array,&missing_src_array,
                 &missing_dsrc_array,NULL);
/*
 * Coerce input to double.
 */
  map = coerce_input_double(map_wts,type_map_wts,nlink*nw,0,NULL,NULL);
  src = coerce_input_double(src_array,type_src_array,nsrc,
                            has_missing_src_array,&missing_src_array,NULL);

  if(map == NULL || src == NULL) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"pop_remap: Unable to allocate memory for coercing input arrays to double precision");
    return(NhlFATAL);
  }
/*
 * Calloc space for output array if necessary.
 */
  if(type_dst_array == NCL_float) {
    dst = (double*)calloc(ndst,sizeof(double));
    if(dst == NULL) {
      NhlPError(NhlFATAL,NhlEUNKNOWN,"pop_remap: Unable to allocate memory for output array"); 
      return(NhlFATAL);
    }
  }
  else {
    dst = (double*)dst_array;
  }

/*
 * Call Fortran popremap.
 */
  NGCALLF(dpopremap,DPOPREMAP)(dst,map,dst_add,src_add,src,&indst,&inlink,&inw,
                               &insrc,&missing_dsrc_array.doubleval);

  if(type_dst_array == NCL_float) {
    coerce_output_float_only(dst_array,dst,ndst,0);
    NclFree(dst);
  }
  if(type_map_wts   != NCL_double) NclFree(map);
  if(type_src_array != NCL_double) NclFree(src);

  return(NhlNOERROR);
}
Esempio n. 16
0
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);

}
Esempio n. 17
0
NhlErrorTypes dim_sum_wgt_n_W( void )
{

/*
 * Input variables
 */
/*
 * Argument # 0
 */
  void *x;
  double *tmp_x;
  int ndims_x;
  ng_size_t dsizes_x[NCL_MAX_DIMENSIONS];
  int has_missing_x;
  NclScalar missing_x, missing_flt_x, missing_dbl_x;
  NclBasicDataTypes type_x;

/*
 * Argument # 1
 */
  void *w;
  double *tmp_w;
  ng_size_t dsizes_w[1];
  NclBasicDataTypes type_w;

/*
 * Argument # 2
 */
  int *opt;

/*
 * Argument # 3
 */
  int *narg;
/*
 * Return variable
 */
  void *xavg;
  double tmp_xavg[1];
  int ndims_xavg;
  ng_size_t *dsizes_xavg;
  NclBasicDataTypes type_xavg;

/*
 * Various
 */
  int inx, ret;
  ng_size_t nx, nrnx, index_x, index_nrx, index_nr, index_out;
  ng_size_t i, j, total_nl, total_nr, size_output;

/*
 * Retrieve parameters.
 *
 * Note any of the pointer parameters can be set to NULL, which
 * implies you don't care about its value.
 */
/*
 * Get argument # 0
 */
  x = (void*)NclGetArgValue(
           0,
           4,
           &ndims_x,
           dsizes_x,
           &missing_x,
           &has_missing_x,
           &type_x,
           DONT_CARE);

/*
 * Coerce missing value to double if necessary.
 */
  coerce_missing(type_x,has_missing_x,&missing_x,
                 &missing_dbl_x,&missing_flt_x);

/*
 * Get argument # 1
 */
  w = (void*)NclGetArgValue(
           1,
           4,
           NULL,
           dsizes_w,
           NULL,
           NULL,
           &type_w,
           DONT_CARE);

/*
 * Get argument # 2
 */
  opt = (int*)NclGetArgValue(
           2,
           4,
           NULL,
           NULL,
           NULL,
           NULL,
           NULL,
           DONT_CARE);

/*
 * Get argument # 3
 */
  narg = (int*)NclGetArgValue(
           3,
           4,
           NULL,
           NULL,
           NULL,
           NULL,
           NULL,
           DONT_CARE);

/*
 * Some error checking. Make sure input dimension is valid.
 */
  if(*narg < 0 || *narg >= ndims_x) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_sum_wgt_n: Invalid dimension argument, can't continue");
    return(NhlFATAL);
  }

/*
 * Test input dimension size.
 */
  nx = dsizes_x[*narg];
  if(nx > INT_MAX) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_sum_wgt_n: nx = %ld is greater than INT_MAX", nx);
    return(NhlFATAL);
  }
  inx = (int) nx;

  if(dsizes_w[0] != nx) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_sum_wgt_n: w must be length nx");
    return(NhlFATAL);
  }

/*
 * Calculate size of all but narg dimensions and 
 * allocate space for output dimension sizes and set them.
 */
  ndims_xavg  = max(ndims_x-1,1);
  dsizes_xavg = (ng_size_t*)calloc(ndims_xavg,sizeof(ng_size_t));  
  if( dsizes_xavg == NULL ) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_sum_wgt_n: Unable to allocate memory for holding dimension sizes");
    return(NhlFATAL);
  }

  total_nl = total_nr = size_output  = 1;
  if(ndims_x==1) {    /* Handles case where x is 1D */
    dsizes_xavg[0] = 1;
  }
  else {
    for(i = 0; i < *narg;   i++) {
      total_nl *= dsizes_x[i];
      dsizes_xavg[i] = dsizes_x[i];
    }
    for(i = *narg+1; i < ndims_x; i++) {
      total_nr *= dsizes_x[i];
      dsizes_xavg[i-1] = dsizes_x[i];
    }
  }
  size_output = total_nr * total_nl;

/*
 * Allocate space for coercing input arrays. We need to make a copy
 * here, because the x values are not necessary consecutive, and
 * hence we can't just point to the original array.
 */
/*
 * Allocate space for tmp_x.
 */
  tmp_x = (double *)calloc(nx,sizeof(double));
  if(tmp_x == NULL) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_sum_wgt_n: Unable to allocate memory for coercing input array to double");
    return(NhlFATAL);
  }
/*
 * The output type defaults to float, unless this input array is double.
 */
  if(type_x == NCL_double) {
    type_xavg = NCL_double;
  }
  else {
    type_xavg = NCL_float;
  }
/* 
 * Allocate space for output array.
 */
  if(type_xavg != NCL_double) {
    xavg = (void *)calloc(size_output, sizeof(float));
  }
  else {
    xavg = (void *)calloc(size_output, sizeof(double));
  }
  if(xavg == NULL) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_sum_wgt_n: Unable to allocate memory for output array");
    return(NhlFATAL);
  }

/*
 * Allocate space for tmp_w.
 */
  tmp_w = coerce_input_double(w,type_w,nx,0,NULL,NULL);
  if(tmp_w == NULL) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"dim_sum_wgt_n: Unable to allocate memory for coercing input array to double");
    return(NhlFATAL);
  }

/*
 * Loop across all but the narg-th dimension and call the Fortran routine
 * for each one-dimensional subsection.
 */
  nrnx = total_nr * nx;
  for(i = 0; i < total_nl; i++) {
    index_nrx = i * nrnx;
    index_nr  = i * total_nr;
    for(j = 0; j < total_nr; j++) {
      index_out = index_nr + j;
      index_x   = index_nrx + j;
/*
 * Coerce subsection of x (tmp_x) to double if necessary.
 */
      coerce_subset_input_double_step(x,tmp_x,index_x,total_nr,type_x,
                                      nx,0,NULL,NULL);
/*
 * Call the Fortran routine.
 */
      NGCALLF(dimsumwgt,DIMSUMWGT)(&inx, tmp_x, &missing_dbl_x.doubleval, 
                                   tmp_w, opt, &tmp_xavg[0]);
/*
 * Coerce output back to float or double.
 */
      coerce_output_float_or_double(xavg,&tmp_xavg[0],type_x,1,index_out);
    }
  }

/*
 * Free unneeded memory.
 */
  NclFree(tmp_x);
  if(type_w != NCL_double) NclFree(tmp_w);

/*
 * Return value back to NCL script.
 */
  if(has_missing_x) {
    if(type_xavg == NCL_double) {
      ret = NclReturnValue(xavg,ndims_xavg,dsizes_xavg,&missing_dbl_x,
                            type_xavg,0);
    }
    else {
      ret = NclReturnValue(xavg,ndims_xavg,dsizes_xavg,&missing_flt_x,
                            type_xavg,0);
    }
  }
  else {
    ret = NclReturnValue(xavg,ndims_xavg,dsizes_xavg,NULL,type_xavg,0);
  }
  NclFree(dsizes_xavg);
  return(ret);
}
Esempio n. 18
0
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);
}
Esempio n. 19
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);
}
Esempio n. 20
0
NhlErrorTypes ezfftb_W( void )
{
/*
 * Input array variables
 */
  void *cf;
  double *tmp_cf1 = NULL;
  double *tmp_cf2 = NULL;
  int ndims_cf;
  ng_size_t dsizes_cf[NCL_MAX_DIMENSIONS];
  ng_size_t dsizes_xbar[1];
  void *xbar;
  double *tmp_xbar = NULL;
  NclBasicDataTypes type_cf, type_xbar;
  NclScalar missing_cf, missing_dcf, missing_rcf, missing_x;
  int has_missing_cf;
/*
 * Some variables we need to retrieve the "npts" atttribute (if it exists).
 */
  NclAttList *att_list;
  NclAtt tmp_attobj;
  NclStackEntry data;
/*
 * Output array variables
 */
  void *x;
  double *tmp_x;
  int ndims_x;
  ng_size_t dsizes_x[NCL_MAX_DIMENSIONS];
  NclBasicDataTypes type_x;
/*
 * various
 */
  double *work;
  ng_size_t index_cf, index_x;
  ng_size_t i, *tmp_npts, npts, npts2, lnpts2, size_x, size_leftmost;
  int found_missing1, found_missing2, any_missing, scalar_xbar;
  int inpts;
/*
 * Retrieve parameters
 *
 * Note any of the pointer parameters can be set to NULL, which
 * implies you don't care about its value.
 */
  cf = (void*)NclGetArgValue(
           0,
           2,
           &ndims_cf, 
           dsizes_cf,
           &missing_cf,
           &has_missing_cf,
           &type_cf,
           DONT_CARE);
  xbar = (void*)NclGetArgValue(
           1,
           2,
           NULL,
           dsizes_xbar,
           NULL,
           NULL,
           &type_xbar,
           DONT_CARE);
/*
 * Calculate number of leftmost elements.
 */
  size_leftmost = 1;
  for( i = 1; i < ndims_cf-1; i++ ) size_leftmost *= dsizes_cf[i];
/*
 * Check xbar dimension sizes.
 */
  scalar_xbar = is_scalar(1,dsizes_xbar);

  if(!scalar_xbar) {
/*
 * If xbar is not a scalar, it must be an array of the same dimension
 * sizes as the leftmost dimensions of cf (except the first dimension
 * of '2').
 */ 
    if(dsizes_xbar[0] != size_leftmost) {
      NhlPError(NhlFATAL,NhlEUNKNOWN,"ezfftb: If xbar is not a scalar, then it must be a single vector of the length of the product of the leftmost dimensions of 'cf' (not including the '2' dimension)") ;
      return(NhlFATAL);
    }
  }

/*
 * Coerce missing values.
 */
  coerce_missing(type_cf,has_missing_cf,&missing_cf,&missing_dcf,&missing_rcf);
/*
 * Okay, what follows here is some code for retrieving the "npts"
 * attribute if it exists. This attribute is one that should have been
 * set when "ezfftf" was called, and it indicates the length of the
 * original series.
 */
  npts2  = dsizes_cf[ndims_cf-1];     /* Calculate the length in case  */
                                      /* it is not set explicitly. */
  npts = 2*npts2;

  data = _NclGetArg(0,2,DONT_CARE);
  switch(data.kind) {
  case NclStk_VAR:
    if(data.u.data_var->var.att_id != -1) {
      tmp_attobj = (NclAtt)_NclGetObj(data.u.data_var->var.att_id);
      if(tmp_attobj == NULL) {
        NhlPError(NhlFATAL,NhlEUNKNOWN,"ezfftb: Bad attribute list, can't continue");
        return(NhlFATAL);
      }
      if(tmp_attobj->att.n_atts == 0) {
        break;
      }
      att_list = tmp_attobj->att.att_list;
      i = 0;
      while(att_list != NULL) {
        if(att_list->quark == NrmStringToQuark("npts")) {
          tmp_npts = get_dimensions(att_list->attvalue->multidval.val,1,
                                    att_list->attvalue->multidval.data_type,
                                    "ezfftb");
          npts = *tmp_npts;
          free(tmp_npts);
	  if((npts % 2) == 0) {
	    npts2 = npts/2;
	  }
	  else {
	    npts2 = (npts-1)/2;
	  }
          break;
        }
        att_list = att_list->next;
      }
    }
    break;
  default:
        NhlPError(NhlFATAL,NhlEUNKNOWN,"ezfftb: data.kind, can't continue");
        return(NhlFATAL);
  }
/*
 * Test input array size
 */
  if(npts > INT_MAX) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"ezfftb: npts = %d is greater than INT_MAX", npts);
    return(NhlFATAL);
  }
  inpts = (int) npts;

/*
 * Calculate size of output array.
 */
  lnpts2 = npts2 * size_leftmost;
  size_x = size_leftmost * npts;

  ndims_x = ndims_cf - 1;
  for(i = 0; i < ndims_x-1; i++ ) dsizes_x[i] = dsizes_cf[i+1];
  dsizes_x[ndims_x-1] = npts;
/*
 * Create arrays to coerce input to double if necessary.
 */
  if(type_cf != NCL_double) {
    tmp_cf1 = (double*)calloc(npts2,sizeof(double));
    tmp_cf2 = (double*)calloc(npts2,sizeof(double));
    if(tmp_cf1 == NULL || tmp_cf2 == NULL) {
      NhlPError(NhlFATAL,NhlEUNKNOWN,"ezfftb: Unable to allocate memory for coercing input array to double precision");
      return(NhlFATAL);
    }
  }

  if(type_xbar != NCL_double) {
    tmp_xbar = (double*)calloc(1,sizeof(double));
    if(tmp_xbar == NULL) {
      NhlPError(NhlFATAL,NhlEUNKNOWN,"ezfftb: Unable to allocate memory for coercing input array to double precision");
      return(NhlFATAL);
    }
  }

/*
 * Allocate memory for output array.
 */
  tmp_x = (double *)calloc(npts,sizeof(double));
  if (tmp_x == NULL) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"ezfftb: Cannot allocate memory for temporary output array" );
    return(NhlFATAL);
  }
  if(type_cf == NCL_double) {
    type_x = NCL_double;
    x = (void*)calloc(size_x,sizeof(double));
    if(has_missing_cf) missing_x = missing_dcf;
  }
  else {
    type_x = NCL_float;
    x = (void*)calloc(size_x,sizeof(float));
    if(has_missing_cf) missing_x = missing_rcf;
  }
  if (x == NULL) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"ezfftb: Cannot allocate memory for output array" );
    return(NhlFATAL);
  }
/*
 * Allocate memory for work array
 */
  work = (double*)calloc(4*npts+15,sizeof(double));
  if ( work == NULL ) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"ezfftb: Cannot allocate memory for work array" );
    return(NhlFATAL);
  }
/*
 * If xbar is a scalar, coerce it outside the loop.
 */
  if(scalar_xbar) {
    if(type_xbar != NCL_double) { 
      coerce_subset_input_double(xbar,tmp_xbar,0,type_xbar,1,0,NULL,NULL);
    }
    else {
      tmp_xbar = &((double*)xbar)[0];
    }
  }

/*
 * Call the f77 version of 'dezfftb' with the full argument list.
 */
  index_x = index_cf = 0;
  any_missing = 0;
  for(i = 0; i < size_leftmost; i++) {
    if(type_cf != NCL_double) { 
      coerce_subset_input_double(cf,tmp_cf1,index_cf,type_cf,npts2,0,
                                 NULL,NULL);
      coerce_subset_input_double(cf,tmp_cf2,lnpts2+index_cf,type_cf,npts2,0,
                                 NULL,NULL);
    }
    else {
      tmp_cf1 = &((double*)cf)[index_cf];
      tmp_cf2 = &((double*)cf)[lnpts2+index_cf];
    }
/*
 * Check for missing values in cf.  If any, then coerce that section of
 * the output to missing.
 */
    found_missing1 = contains_missing(tmp_cf1,npts2,has_missing_cf,
                                      missing_dcf.doubleval);
    found_missing2 = contains_missing(tmp_cf2,npts2,has_missing_cf,
                                      missing_dcf.doubleval);
    if(found_missing1 || found_missing2) {
      any_missing++;
      set_subset_output_missing(x,index_x,type_x,npts,missing_dcf.doubleval);
    }
    else {
/*
 * If xbar is not a scalar, then we need to coerce each element
 * to double or else just grab its value.
 */
      if(!scalar_xbar) {
        if(type_xbar != NCL_double) { 
          coerce_subset_input_double(xbar,tmp_xbar,i,type_xbar,1,0,NULL,NULL);
        }
        else {
          tmp_xbar = &((double*)xbar)[i];
        }
      }

      NGCALLF(dezffti,DEZFFTI)(&inpts,work);
      NGCALLF(dezfftb,DEZFFTB)(&inpts,tmp_x,tmp_xbar,tmp_cf1,tmp_cf2,work);
/*
 * Copy results back into x.
 */
      coerce_output_float_or_double(x,tmp_x,type_cf,npts,index_x);
    }
    index_x  += npts;
    index_cf += npts2;
  }

/*
 * Free up memory.
 */
  if(type_cf != NCL_double) {
    free(tmp_cf1);
    free(tmp_cf2);
  }
  if(type_xbar != NCL_double) free(tmp_xbar);
  free(tmp_x);
  free(work);

  if(any_missing) {
    NhlPError(NhlWARNING,NhlEUNKNOWN,"ezfftb: %d input arrays contained missing values. No calculations performed on these arrays.",any_missing);

    return(NclReturnValue(x,ndims_x,dsizes_x,&missing_x,type_x,0));
  }
  else {
    return(NclReturnValue(x,ndims_x,dsizes_x,NULL,type_x,0));
  }
}
Esempio n. 21
0
File: utilW.c Progetto: gavin971/ncl
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));
  }
}
Esempio n. 22
0
File: pdfW.c Progetto: gavin971/ncl
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);
}
Esempio n. 23
0
NhlErrorTypes center_finite_diff_W( void )
{
    /*
     * Input array variables
     */
    void *q, *r;
    logical *cyclic;
    int *opt, r_one_d, r_scalar;
    double *tmp_q = NULL;
    double *tmp_r = NULL;
    int ndims_q;
    ng_size_t dsizes_q[NCL_MAX_DIMENSIONS];
    int ndims_r;
    ng_size_t dsizes_r[NCL_MAX_DIMENSIONS];
    int has_missing_q, has_missing_r;
    NclScalar missing_q, missing_dq, missing_rq;
    NclScalar missing_r, missing_dr;
    NclBasicDataTypes type_q, type_r, type_dqdr;
    /*
     * Output array variables
     */
    void *dqdr;
    double *tmp_dqdr = NULL;
    NclScalar missing_dqdr;
    /*
     * Declare various variables for random purposes.
     */
    ng_size_t i, npts, npts1, size_q, size_leftmost, index_q;
    int inpts, inpts1, iend, ier;
    double *qq, *rr;
    /*
     * Retrieve parameters
     *
     * Note that any of the pointer parameters can be set to NULL,
     * which implies you don't care about its value.
     *
     */
    q = (void*)NclGetArgValue(
            0,
            4,
            &ndims_q,
            dsizes_q,
            &missing_q,
            &has_missing_q,
            &type_q,
            DONT_CARE);

    r = (void*)NclGetArgValue(
            1,
            4,
            &ndims_r,
            dsizes_r,
            &missing_r,
            &has_missing_r,
            &type_r,
            DONT_CARE);

    cyclic = (logical*)NclGetArgValue(
                 2,
                 4,
                 NULL,
                 NULL,
                 NULL,
                 NULL,
                 NULL,
                 DONT_CARE);

    opt = (int*)NclGetArgValue(
              3,
              4,
              NULL,
              NULL,
              NULL,
              NULL,
              NULL,
              DONT_CARE);
    /*
     * Get size of input array and test dimension sizes.
     */
    npts  = dsizes_q[ndims_q-1];
    npts1 = npts + 1;

    if((npts > INT_MAX) || (npts1 > INT_MAX)) {
        NhlPError(NhlFATAL,NhlEUNKNOWN,"center_finite_diff: npts1 = %ld is larger than INT_MAX", npts1);
        return(NhlFATAL);
    }
    inpts = (int) npts;
    inpts1 = (int) npts1;

    if((ndims_r == 1 && (dsizes_r[0] != npts && dsizes_r[0] != 1)) ||
            (ndims_r > 1 && ndims_r != ndims_q)) {
        NhlPError(NhlFATAL,NhlEUNKNOWN,"center_finite_diff: r must either be a scalar, a 1D array the same length as the rightmost dimemsion of q, or the same size as q");
        return(NhlFATAL);
    }

    if(ndims_r > 1) {
        r_one_d = 0;
        for( i = 0; i < ndims_r-1; i++ ) {
            if(dsizes_r[i] != dsizes_q[i]) {
                NhlPError(NhlFATAL,NhlEUNKNOWN,"center_finite_diff: r must either be a scalar, a 1D array the same length as the rightmost dimemsion of q, or the same size as q");
                return(NhlFATAL);
            }
        }
    }
    else {
        r_one_d = 1;
    }
    /*
     * Compute the total size of the q array.
     */
    size_leftmost = 1;
    for( i = 0; i < ndims_q-1; i++ ) size_leftmost *= dsizes_q[i];
    size_q = size_leftmost * npts;

    /*
     * Check for missing values.
     */
    coerce_missing(type_q,has_missing_q,&missing_q,&missing_dq,&missing_rq);
    coerce_missing(type_r,has_missing_r,&missing_r,&missing_dr,NULL);
    /*
     * Create arrays to hold temporary r and q values.
     */
    qq    = (double*)calloc(npts+2,sizeof(double));
    rr    = (double*)calloc(npts+2,sizeof(double));
    if( qq == NULL || rr == NULL) {
        NhlPError(NhlFATAL,NhlEUNKNOWN,"center_finite_diff: Unable to allocate memory for temporary arrays");
        return(NhlFATAL);
    }
    /*
     * Create temporary arrays to hold double precision data.
     */
    if(type_q != NCL_double) {
        tmp_q = (double*)calloc(npts,sizeof(double));
        if( tmp_q == NULL ) {
            NhlPError(NhlFATAL,NhlEUNKNOWN,"center_finite_diff: Unable to allocate memory for coercing q to double precision");
            return(NhlFATAL);
        }
    }
    /*
     * 'r' can be a scalar, one-dimensional, or multi-dimensional.
     * If it is a scalar, then we need to construct an npts-sized 'r'
     * that is based on the scalar value.
     */
    r_scalar = is_scalar(ndims_r,dsizes_r);
    if(type_r != NCL_double || r_scalar) {
        tmp_r = (double*)calloc(npts,sizeof(double));
        if( tmp_r == NULL ) {
            NhlPError(NhlFATAL,NhlEUNKNOWN,"center_finite_diff: Unable to allocate memory for coercing r to double precision");
            return(NhlFATAL);
        }
        /*
         * Coerce r (tmp_r) to double if necessary.
         */
        if(r_one_d) {
            coerce_subset_input_double(r,tmp_r,0,type_r,dsizes_r[0],0,NULL,NULL);
        }
        /*
         * If r is a scalar, then copy it npts-1 times to rest of the array.
         */
        if(r_scalar) {
            for(i = 1; i < npts; i++ ) tmp_r[i] = tmp_r[i-1] + tmp_r[0];
        }
    }
    if(type_r == NCL_double && !r_scalar && r_one_d) {
        /*
         * Point tmp_r to r.
         */
        tmp_r = &((double*)r)[0];
    }
    /*
     * Allocate space for output array.
     */
    if(type_q == NCL_double || type_r == NCL_double) {
        type_dqdr = NCL_double;
        dqdr      = (void*)calloc(size_q,sizeof(double));
        missing_dqdr = missing_dq;
    }
    else {
        type_dqdr = NCL_float;
        dqdr      = (void*)calloc(size_q,sizeof(float));
        tmp_dqdr  = coerce_output_double(dqdr,type_dqdr,npts);
        if( tmp_dqdr == NULL ) {
            NhlPError(NhlFATAL,NhlEUNKNOWN,"center_finite_diff: Unable to allocate memory for temporary output array");
            return(NhlFATAL);
        }
        missing_dqdr = missing_rq;
    }
    if( dqdr == NULL ) {
        NhlPError(NhlFATAL,NhlEUNKNOWN,"center_finite_diff: Unable to allocate memory for output array");
        return(NhlFATAL);
    }


    if(*cyclic) {
        iend = 0;
    }
    else {
        iend = 1;
    }

    /*
     * Loop through leftmost dimensions and call Fortran routine.
     */
    index_q = 0;
    for(i = 0; i < size_leftmost; i++ ) {
        if(type_q != NCL_double) {
            /*
             * Coerce q (tmp_q) to double.
             */
            coerce_subset_input_double(q,tmp_q,index_q,type_q,npts,0,NULL,NULL);
        }
        else {
            /*
             * Point tmp_q to q.
             */
            tmp_q = &((double*)q)[index_q];
        }
        if(!r_one_d) {
            if(type_r != NCL_double) {
                /*
                 * Coerce r (tmp_r) to double.
                 */
                coerce_subset_input_double(r,tmp_r,index_q,type_r,npts,0,NULL,NULL);
            }
            else {
                /*
                 * Point tmp_r to r.
                 */
                tmp_r = &((double*)r)[index_q];
            }
        }
        if(type_dqdr == NCL_double) {
            /*
             * Point tmp_dqdr to dqdr.
             */
            tmp_dqdr = &((double*)dqdr)[index_q];
        }

        /*
         * Call the Fortran routine.
         */
        NGCALLF(dcfindif,DCFINDIF)(tmp_q,tmp_r,&inpts,&missing_dq.doubleval,
                                   &missing_dr.doubleval,cyclic,&iend,
                                   qq,rr,&inpts1,tmp_dqdr,&ier);

        if(type_dqdr != NCL_double) {
            coerce_output_float_only(dqdr,tmp_dqdr,npts,index_q);
        }
        index_q += npts;
    }
    /*
     * Free temp arrays.
     */
    if(type_r != NCL_double || r_scalar) NclFree(tmp_r);
    if(type_q != NCL_double)             NclFree(tmp_q);
    if(type_dqdr != NCL_double)          NclFree(tmp_dqdr);
    NclFree(qq);
    NclFree(rr);

    if(has_missing_q) {
        return(NclReturnValue(dqdr,ndims_q,dsizes_q,&missing_dqdr,type_dqdr,0));
    }
    else {
        return(NclReturnValue(dqdr,ndims_q,dsizes_q,NULL,type_dqdr,0));
    }
}
Esempio n. 24
0
NhlErrorTypes area_hi2lores_W( void )
{
/*
 * Input variables
 */
  void *xi, *yi, *fi, *wyi, *xo, *yo;
  double *tmp_xi, *tmp_yi, *tmp_fi, *tmp_xo, *tmp_yo, *tmp_fo;
  double *tmp1_wyi, *tmp_wyi;
  ng_size_t dsizes_xi[1], dsizes_yi[1], dsizes_wyi[1], dsizes_xo[1], dsizes_yo[1];
  int ndims_fi;
  ng_size_t dsizes_fi[NCL_MAX_DIMENSIONS];
  int has_missing_fi; 
  NclScalar missing_fi, missing_dfi, missing_rfi;
  logical *fi_cyclic_x, *fo_option;
  NclBasicDataTypes type_xi, type_yi, type_fi, type_wyi, type_xo, type_yo;
/*
 * Variables to look for attributes attached to fo_option.
 */
  NclStackEntry stack_entry;
  NclAttList  *attr_list;
  NclAtt  attr_obj;
/*
 * Output variables.
 */
  void *fo;
  ng_size_t *dsizes_fo;
  NclBasicDataTypes type_fo;
  NclScalar missing_fo;
/*
 * Other variables
 */
  int ret, ncyc = 0, ier = 0, debug = 0;
  ng_size_t i, mxi, nyi, nfi, mxo, nyo, nfo, ngrd,  size_fi, size_fo;
  int imxi, inyi, imxo, inyo, ingrd;
  double *critpc = NULL, *xilft, *xirgt, *yibot, *yitop, *xolft, *xorgt;
  double *wxi, *dxi, *dyi, *fracx, *fracy;
  double *ziwrk, *zowrk, *yiwrk, *yowrk;
  int *indx, *indy;
  NclBasicDataTypes type_critpc;
/*
 * Retrieve parameters
 *
 * Note that any of the pointer parameters can be set to NULL,
 * which implies you don't care about its value.
 */
  xi = (void*)NclGetArgValue(
          0,
          8,
          NULL,
          dsizes_xi,
          NULL,
          NULL,
          &type_xi,
          DONT_CARE);

  yi = (void*)NclGetArgValue(
          1,
          8,
          NULL,
          dsizes_yi,
          NULL,
          NULL,
          &type_yi,
          DONT_CARE);

  fi = (void*)NclGetArgValue(
          2,
          8,
          &ndims_fi,
          dsizes_fi,
          &missing_fi,
          &has_missing_fi,
          &type_fi,
          DONT_CARE);

  fi_cyclic_x = (logical*)NclGetArgValue(
          3,
          8,
          NULL,
          NULL,
          NULL,
          NULL,
          NULL,
          DONT_CARE);

  wyi = (void*)NclGetArgValue(
          4,
          8,
          NULL,
          dsizes_wyi,
          NULL,
          NULL,
          &type_wyi,
          DONT_CARE);

  xo = (void*)NclGetArgValue(
          5,
          8,
          NULL,
          dsizes_xo,
          NULL,
          NULL,
          &type_xo,
          DONT_CARE);

  yo = (void*)NclGetArgValue(
          6,
          8,
          NULL,
          dsizes_yo,
          NULL,
          NULL,
          &type_yo,
          DONT_CARE);

  fo_option = (logical*)NclGetArgValue(
          7,
          8,
          NULL,
          NULL,
          NULL,
          NULL,
          NULL,
          DONT_CARE);
/*
 * Check for "critpc" attribute.
 */
  if(*fo_option) {
    stack_entry = _NclGetArg(7,8,DONT_CARE);
    switch(stack_entry.kind) {
    case NclStk_VAR:
      if (stack_entry.u.data_var->var.att_id != -1) {
        attr_obj = (NclAtt) _NclGetObj(stack_entry.u.data_var->var.att_id);
        if (attr_obj == NULL) {
          break;
        }
      }
      else {
/*
 * att_id == -1, no attributes.
 */
        break;
      }
/* 
 * Check attributes for "critpc". If none, then just proceed as normal.
 */
      if (attr_obj->att.n_atts == 0) {
        break;
      }
      else {
/* 
 * att_n_atts > 0, retrieve optional arguments 
 */
        attr_list = attr_obj->att.att_list;
        while (attr_list != NULL) {
          if ((strcmp(attr_list->attname, "critpc")) == 0) {
            type_critpc = attr_list->attvalue->multidval.data_type;
/*
 * If "critpc" is already double, don't just point it to the attribute,
 * because we need to return it later.
 */
            if(type_critpc == NCL_double) {
              critpc  = (double *)calloc(1,sizeof(double));
              *critpc = *(double*) attr_list->attvalue->multidval.val;
            }
            else if(type_critpc == NCL_int || type_critpc == NCL_float) {
/*
 * Coerce to double.
 */
              critpc = coerce_input_double(attr_list->attvalue->multidval.val,
                                          type_critpc,1,0,NULL,NULL);
            }
            else {
              NhlPError(NhlWARNING,NhlEUNKNOWN,"area_hi2lores: The 'critpc' attribute must be of type numeric. Defaulting to 100.");
            }
          }
          attr_list = attr_list->next;
        }
      }
    default:
      break;
    }
  }
  if(critpc == NULL) {
    critpc  = (double *)calloc(1,sizeof(double));
    *critpc = 100.;
  }

/*
 * Compute the total number of elements in our arrays.
 */
  mxi  = dsizes_xi[0];
  nyi  = dsizes_yi[0];
  mxo  = dsizes_xo[0];
  nyo  = dsizes_yo[0];
  nfi  = mxi * nyi;
  nfo  = mxo * nyo;
  if(mxi < 2 || nyi < 2) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"area_hi2lores: xi and yi must have at least two elements");
    return(NhlFATAL);
  }

  if(dsizes_wyi[0] != nyi && dsizes_wyi[0] != 1) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"area_hi2lores: wyi must be a scalar or the same length as yi");
    return(NhlFATAL);
  }
/*
 * Check dimensions of xi, yi, and fi. The last two dimensions of 
 * fi must be nyi x mxi.
 */
  if(dsizes_fi[ndims_fi-2] != nyi && dsizes_fi[ndims_fi-1] != mxi) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"area_hi2lores: The rightmost dimensions of fi must be nyi x mxi, where nyi and mxi are the lengths of yi and xi respectively");
    return(NhlFATAL);
  }

/*
 * Compute the size of the leftmost dimensions and output array.
 */
  ngrd = 1;
  for( i = 0; i < ndims_fi-2; i++ ) ngrd *= dsizes_fi[i];
  size_fi = ngrd * nfi;
  size_fo = ngrd * nfo;

/*
 * Test dimension sizes.
 */
  if((mxi > INT_MAX) || (nyi > INT_MAX) || (mxo > INT_MAX) || 
     (nyo > INT_MAX) || (ngrd > INT_MAX)) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"area_hi2lores: one or more dimension sizes is greater than INT_MAX");
    return(NhlFATAL);
  }
  imxi  = (int) mxi;
  inyi  = (int) nyi;
  imxo  = (int) mxo;
  inyo  = (int) nyo;
  ingrd = (int) ngrd;

/*
 * Coerce missing values for fi.
 */
  coerce_missing(type_fi,has_missing_fi,&missing_fi,&missing_dfi,
                 &missing_rfi);
/*
 * Allocate space for output array.
 */
  if(type_fi == NCL_double) {
    type_fo    = NCL_double;
    missing_fo = missing_dfi;
    fo         = (void*)calloc(size_fo,sizeof(double));
    if(fo == NULL) {
      NhlPError(NhlFATAL,NhlEUNKNOWN,"area_hi2lores: Unable to allocate memory for output array");
      return(NhlFATAL);
    }
    tmp_fo = fo;
  }
  else {
    type_fo    = NCL_float;
    missing_fo = missing_rfi;
    fo         = (void*)calloc(size_fo,sizeof(float));
    tmp_fo     = (double*)calloc(size_fo,sizeof(double));
    if(fo == NULL || tmp_fo == NULL) {
      NhlPError(NhlFATAL,NhlEUNKNOWN,"area_hi2lores: Unable to allocate memory for output array");
      return(NhlFATAL);
    }
  }
  dsizes_fo = (ng_size_t*)calloc(ndims_fi,sizeof(ng_size_t));
  if(dsizes_fo == NULL) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"area_hi2lores: Unable to allocate memory for output array");
    return(NhlFATAL);
  }
  for(i = 0; i < ndims_fi-2; i++) dsizes_fo[i] = dsizes_fi[i];
  dsizes_fo[ndims_fi-2] = nyo;
  dsizes_fo[ndims_fi-1] = mxo;
/*
 * Coerce input arrays to double.
 */
  tmp_xi = coerce_input_double(xi,type_xi,mxi,0,NULL,NULL);
  tmp_yi = coerce_input_double(yi,type_yi,nyi,0,NULL,NULL);
  tmp_fi = coerce_input_double(fi,type_fi,size_fi,0,NULL,NULL);
  tmp_xo = coerce_input_double(xo,type_xo,mxo,0,NULL,NULL);
  tmp_yo = coerce_input_double(yo,type_yo,nyo,0,NULL,NULL);
/*
 * wyi can be a scalar, so copy it to array if necessary.
 */
  tmp1_wyi = coerce_input_double(wyi,type_wyi,dsizes_wyi[0],0,NULL,NULL);
  if(dsizes_wyi[0] == 1) {
    tmp_wyi = copy_scalar_to_array(tmp1_wyi,1,dsizes_wyi,nyi);
  }
  else {
    tmp_wyi = tmp1_wyi;
  }
  

/*
 * Allocate space for work arrays. There's a ton of them here.
 */
  xilft = (double*)calloc(mxi,sizeof(double));
  xirgt = (double*)calloc(mxi,sizeof(double));
  yibot = (double*)calloc(nyi,sizeof(double));
  yitop = (double*)calloc(nyi,sizeof(double));
  xolft = (double*)calloc(mxo,sizeof(double));
  xorgt = (double*)calloc(mxo,sizeof(double));
  dxi   = (double*)calloc(mxi,sizeof(double));
  dyi   = (double*)calloc(nyi,sizeof(double));
  fracx = (double*)calloc(mxi*mxo,sizeof(double));
  fracy = (double*)calloc(nyi*nyo,sizeof(double));
  ziwrk = (double*)calloc(mxi*nyi,sizeof(double));
  zowrk = (double*)calloc(mxo*nyo,sizeof(double));
  yiwrk = (double*)calloc(nyi,sizeof(double));
  yowrk = (double*)calloc(nyo,sizeof(double));
  indx  = (int*)calloc(2*mxo,sizeof(int));
  indy  = (int*)calloc(2*nyo,sizeof(int));
  wxi   = (double*)calloc(mxi,sizeof(double));

  if(xilft == NULL || xirgt == NULL || yibot == NULL || yitop == NULL || 
     xolft == NULL || xorgt == NULL || dxi   == NULL || dyi   == NULL || 
     fracx == NULL || fracy == NULL || ziwrk == NULL || zowrk == NULL || 
     yiwrk == NULL || yowrk == NULL || indx  == NULL || indy  == NULL || 
     wxi == NULL) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"area_hi2lores: Unable to allocate memory for work arrays");
    return(NhlFATAL);
  }

  for(i = 0; i < mxi; i++) wxi[i] = 1.;

/*
 * Call Fortran function.
 */
  NGCALLF(arealinint2da,AREALININT2DA)(&imxi,&inyi,&ingrd,tmp_xi,tmp_yi,tmp_fi,
                                       wxi,tmp_wyi,&missing_dfi.doubleval,
                                       fi_cyclic_x,&ncyc,&imxo,&inyo,tmp_xo,
                                       tmp_yo,tmp_fo,critpc,&debug,&ier,
                                       xilft,xirgt,yibot,yitop,dyi,xolft,
                                       xorgt,yiwrk,yowrk,fracx,fracy,
                                       ziwrk,zowrk,indx,indy);

  if(ier) {
    if(ier == -2) {
      NhlPError(NhlWARNING,NhlEUNKNOWN,"area_hi2lores: xi, xo must be monotonically increasing");
    }
    else if(ier == -5) {
      NhlPError(NhlWARNING,NhlEUNKNOWN,"area_hi2lores: both dimensions of the output grid must be of lower resolution than the input high resolution grid.");
    }
    else {
/*
 * Note: we should never reach this point!  We should always know the
 * possible return values for 'ier'.
 */
      NhlPError(NhlWARNING,NhlEUNKNOWN,"area_hi2lores: unknown error, returning all missing values.");
    }
  }
  else {
    coerce_output_float_or_double(fo,tmp_fo,type_fo,size_fo,0);
  }
/*
 * Free temp arrays.
 */
  if(type_xi != NCL_double) NclFree(tmp_xi);
  if(type_yi != NCL_double) NclFree(tmp_yi);
  if(type_fi != NCL_double) NclFree(tmp_fi);
  if(type_xo != NCL_double) NclFree(tmp_xo);
  if(type_yo != NCL_double) NclFree(tmp_yo);
  if(type_fo != NCL_double) NclFree(tmp_fo);
  if(type_wyi != NCL_double) NclFree(tmp1_wyi);
  if(dsizes_wyi[0] == 1) {
    NclFree(tmp_wyi);
  }
  NclFree(wxi);
  NclFree(xilft);
  NclFree(xirgt);
  NclFree(yibot);
  NclFree(yitop);
  NclFree(xolft);
  NclFree(xorgt);
  NclFree(dxi);
  NclFree(dyi);
  NclFree(fracx);
  NclFree(fracy);
  NclFree(ziwrk);
  NclFree(zowrk);
  NclFree(yiwrk);
  NclFree(yowrk);
  NclFree(indx);
  NclFree(indy);
  NclFree(critpc);

  ret = NclReturnValue(fo,ndims_fi,dsizes_fo,&missing_fo,type_fo,0);
  NclFree(dsizes_fo);
  return(ret);
}
Esempio n. 25
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));
    }
}
Esempio n. 26
0
NhlErrorTypes linint1_n_W( void )
{
/*
 * Input variables
 */
  void *xi, *fi, *xo;
  double *tmp_xi, *tmp_xo,*tmp_fi, *tmp_fo;
  int ndims_xi;
  ng_size_t dsizes_xi[NCL_MAX_DIMENSIONS], dsizes_xo[NCL_MAX_DIMENSIONS];
  int ndims_fi;
  ng_size_t dsizes_fi[NCL_MAX_DIMENSIONS];
  int has_missing_fi;
  ng_size_t *dsizes_fo;
  NclScalar missing_fi, missing_dfi, missing_rfi, missing_fo;
  int *dim, *opt, iopt = 0;
  logical *wrap;
  NclBasicDataTypes type_xi, type_fi, type_xo, type_fo;
/*
 * Output variables.
 */
  void *fo;
/*
 * Other variables
 */
  ng_size_t nxi, nxi2, nxo, nfo, nd, nr, nl, nrnxi, nrnxo, ntotal, size_fo;
  int inxi, inxi2, inxo, ier, ret;
  ng_size_t i, j, index_nri, index_nro, index_fi, index_fo;
  double *xiw, *fxiw;
/*
 * Retrieve parameters
 *
 * Note that any of the pointer parameters can be set to NULL,
 * which implies you don't care about its value.
 */
  xi = (void*)NclGetArgValue(
          0,
          6,
          &ndims_xi,
          dsizes_xi,
          NULL,
          NULL,
          &type_xi,
          DONT_CARE);

  fi = (void*)NclGetArgValue(
          1,
          6,
          &ndims_fi,
          dsizes_fi,
          &missing_fi,
          &has_missing_fi,
          &type_fi,
          DONT_CARE);

  wrap = (logical*)NclGetArgValue(
          2,
          6,
          NULL,
          NULL,
          NULL,
          NULL,
          NULL,
          DONT_CARE);

  xo = (void*)NclGetArgValue(
          3,
          6,
          NULL,
          dsizes_xo,
          NULL,
          NULL,
          &type_xo,
          DONT_CARE);

  opt = (int*)NclGetArgValue(
          4,
          6,
          NULL,
          NULL,
          NULL,
          NULL,
          NULL,
          DONT_CARE);

  dim = (int*)NclGetArgValue(
          5,
          6,
          NULL,
          NULL,
          NULL,
          NULL,
          NULL,
          DONT_CARE);
/*
 * Some error checking. Make sure input dimension is valid.
 */
  if(*dim < 0 || *dim >= ndims_fi) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1_n: Invalid dimension to do interpolation on, can't continue");
    return(NhlFATAL);
  }

/*
 * Compute the total number of elements in our arrays and check them.
 */
  nxi  = dsizes_fi[*dim];
  nxo  = dsizes_xo[0];
  nfo  = nxo;
  nxi2 = nxi + 2;

  if(nxi < 2) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1_n: xi must have at least 2 elements");
    return(NhlFATAL);
  }

/*
 * Test dimension sizes.
 */
  if((nxi > INT_MAX) || (nxo > INT_MAX) || (nxi2 > INT_MAX)) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1_n: one or more dimension sizes is greater than INT_MAX");
    return(NhlFATAL);
  }
  inxi  = (int) nxi;
  inxo  = (int) nxo;
  inxi2 = (int) nxi2;

/*
 * Check dimensions of xi and fi. If xi is not one-dimensional, then it 
 * must be the same size as fi. Otherwise, the dims-th dimension of
 * fi must be equal to the length of xi.
 */
  if(ndims_xi > 1) {
    if(ndims_xi != ndims_fi) {
      NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1_n: If xi is not one-dimensional, then it must be the same size as fi");
      return(NhlFATAL);
    }
    for(i = 0; i < ndims_fi; i++) {
      if(dsizes_xi[i] != dsizes_fi[i]) {
        NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1_n: If xi is not one-dimensional, then it must be the same size as fi");
        return(NhlFATAL);
      }
    }
  }
  else {
    if(dsizes_xi[0] != nxi) {
      NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1_n: The dim-th dimension of fi must be the same length as xi");
      return(NhlFATAL);
    }
  }
/*
 * Calculate size of leftmost dimensions (nl) up to the dim-th
 *   dimension.
 * Calculate size of rightmost dimensions (nr) from the
 *   dim-th dimension.
 *
 * The dimension to do the interpolation across is "dim".
 */
  nl = nr = 1;
  if(ndims_fi > 1) {
    nd = ndims_fi-1;
    for(i = 0; i < *dim ; i++) {
      nl = nl*dsizes_fi[i];
    }
    for(i = *dim+1; i < ndims_fi; i++) {
      nr = nr*dsizes_fi[i];
    }
  }
  else {
    nd = 1;
  }
  ntotal  = nr * nl;
  size_fo = ntotal * nfo;

/*
 * Coerce missing values.
 */
  coerce_missing(type_fi,has_missing_fi,&missing_fi,&missing_dfi,
                 &missing_rfi);
/*
 * Allocate space for temporary output array.
 */
  tmp_fo = (double*)calloc(nfo,sizeof(double));
  if(tmp_fo == NULL) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1_n: Unable to allocate memory for temporary arrays");
    return(NhlFATAL);
  }

/*
 * Allocate space for output array.
 */
  dsizes_fo = (ng_size_t*)calloc(ndims_fi,sizeof(ng_size_t));
  if(type_fi == NCL_double) {
    fo         = (void*)calloc(size_fo,sizeof(double));
    type_fo    = NCL_double;
    missing_fo = missing_dfi;
  }
  else {
    fo         = (void*)calloc(size_fo,sizeof(float));
    type_fo    = NCL_float;
    missing_fo = missing_rfi;
  }
  if(fo == NULL || dsizes_fo == NULL) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1_n: Unable to allocate memory for output array");
    return(NhlFATAL);
  }
/* 
 * Go ahead and copy all dimesions, but then replace the dim-th one.
 */
  for(i = 0; i < ndims_fi; i++) dsizes_fo[i] = dsizes_fi[i];
  dsizes_fo[*dim] = nxo;

/*
 * Allocate space for work arrays.
 */
  xiw  = (double*)calloc(nxi2,sizeof(double));
  fxiw = (double*)calloc(nxi2,sizeof(double));
  if(xiw == NULL || fxiw == NULL) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1_n: Unable to allocate memory for work arrays");
    return(NhlFATAL);
  }

/*
 * Coerce output array to double if necessary.
 */
  tmp_xo = coerce_input_double(xo,type_xo,nxo,0,NULL,NULL);
  if(tmp_xo == NULL) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1_n: Unable to coerce output array to double precision");
    return(NhlFATAL);
  }

  if(ndims_xi == 1) {
    tmp_xi = coerce_input_double(xi,type_xi,nxi,0,NULL,NULL);
  }
  else {
    tmp_xi = (double*)calloc(nxi,sizeof(double));
    if(tmp_xi == NULL) {
      NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1_n: Unable to allocate memory for coercing input array to double precision");
      return(NhlFATAL);
    }
  }

  tmp_fi = (double*)calloc(nxi,sizeof(double));
  if(tmp_fi == NULL) {
    NhlPError(NhlFATAL,NhlEUNKNOWN,"linint1_n: Unable to allocate memory for coercing input array to double precision");
    return(NhlFATAL);
  }

/*
 * Loop through leftmost and rightmost dimensions and call Fortran
 * routine for each array subsection.
 */
  nrnxi = nr*nxi;
  nrnxo = nr*nxo;
  for( i = 0; i < nl; i++ ) {
    index_nri = i*nrnxi;
    index_nro = i*nrnxo;
    for( j = 0; j < nr; j++ ) {
      index_fi = index_nri+j;
      index_fo = index_nro+j;

      if(ndims_xi > 1) {
        coerce_subset_input_double_step(xi,tmp_xi,index_fi,nr,type_xi,
                                        nxi,0,NULL,NULL);
      }
      coerce_subset_input_double_step(fi,tmp_fi,index_fi,nr,type_fi,
                                      nxi,0,NULL,NULL);
/*
 * Call Fortran routine.
 */
      NGCALLF(dlinint1,DLININT1)(&inxi,tmp_xi,tmp_fi,wrap,&inxo,tmp_xo,tmp_fo,
                                 xiw,fxiw,&inxi2,&missing_dfi.doubleval,
                                 &iopt,&ier);

      if(ier) {
        NhlPError(NhlWARNING,NhlEUNKNOWN,"linint1_n: xi and xo must be monotonically increasing");
        set_subset_output_missing_step(fo,index_fo,nr,type_fo,nfo,
                                       missing_dfi.doubleval);
      }
      else {
        coerce_output_float_or_double_step(fo,tmp_fo,type_fi,nfo,index_fo,nr);
      }
    }
  }
/*
 * Free temp arrays.
 */
  if(ndims_xi > 1 || type_xi != NCL_double) NclFree(tmp_xi);
  if(type_xo != NCL_double) NclFree(tmp_xo);
  NclFree(tmp_fi);
  NclFree(tmp_fo);
  NclFree(xiw);
  NclFree(fxiw);

  ret = NclReturnValue(fo,ndims_fi,dsizes_fo,&missing_fo,type_fo,0);

  NclFree(dsizes_fo);
  return(ret);
}
Esempio n. 27
0
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));
    }
}
Esempio n. 28
0
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);
}
Esempio n. 29
0
File: spiW.c Progetto: gavin971/ncl
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);
}