void df_beta ( const int *num, int *iret ) /************************************************************************ * df_beta * * * * This subroutine computes the Coriolis acceleration at each grid * * point. The following equation is used: * * * * BETA = d (CORL) / dy * * * * This computation has no operand. * * * * df_beta ( num, iret ) * * * * Input parameter: * * *num const int Grid number * * Output parameters: * * *iret int Return code * * 0 = normal return * * -10 = Internal grid list is full* * -12 = ... must be a scalar * * -16 = Map proj. ... is invalid * * -20 = Stack is full * ** * * Log: * * D. McCann/AWC 4/01 * * K. Brill/HPC 1/02 CALL DG_SSUB, DG_ESUB; RTRN after NXTS * * R. Tian/SAIC 10/05 Recoded from Fortran * ************************************************************************/ { int ncorl, zero, ier; /*----------------------------------------------------------------------*/ *iret = 0; zero = 0; dg_ssub ( iret ); /* * Check if navigation parameters have been computed. */ dg_ltln ( iret ); if ( *iret != 0 ) return; /* * Get a new grid number for CORL. */ dg_nxts ( &ncorl, iret ); if ( *iret != 0 ) return; /* * Compute beta.. */ df_corl ( &ncorl, iret ); dg_puts ( &ncorl, iret ); df_ddy ( iret ); dg_gets ( (int *)num, iret ); dg_esub ( (int *)num, &zero, &zero, &zero, &ier ); if ( ier != 0 ) *iret = ier; return; }
void df_yav ( int *iret ) /************************************************************************ * df_yav * * * * This subroutine computes the average value of a scalar internal grid * * at all valid points along a column: * * * * YAV (S) = [ S (Y1) + S (Y2) + ... + S (KYD) ] / KNT * * * * Where: KYD = number of points in column * * KNT = number of non-missing points in column * * * * The YAV for a column is stored at every point in that column. * * * * df_yav ( iret ) * * * * Output parameters: * * *iret int Return code * * As for DG_GETS * ** * * Log: * * I. Graffman/RDS 1/87 * * M. desJardins/GSFC 7/88 Added new stack subroutines * * G. Huffman/GSC 9/88 Error messages * * T. Lee/GSC 4/96 Single dimension for dgg * * K. Tyle/GSC 5/96 Moved IGDPT outside do-loop * * K. Brill/HPC 1/02 CALL DG_SSUB and DG_ESUB * * K. Brill/HPC 11/02 Avg only on JGX/YMIN -> JGX/YMAX * * R. Tian/SAIC 12/02 Try to make loop more clear * * R. Tian/SAIC 11/05 Recoded from Fortran * ************************************************************************/ { int num1, num, jgymin, jgymax, jgxmin, jgxmax, kxd, kyd, ksub1, ksub2, knt, iy, ix, ii, ier, zero; float *gnum1, *gnum, sum, avg; /*----------------------------------------------------------------------*/ *iret = 0; zero = 0; dg_ssub ( iret ); /* * Get the scalar grid. */ dg_gets ( &num1, iret ); if ( *iret != 0 ) return; /* * Get a new grid number. */ dg_nxts ( &num, iret ); if ( *iret != 0 ) return; /* * Grid number to grid. */ dg_getg ( &num1, &gnum1, &kxd, &kyd, &ksub1, &ksub2, iret ); dg_getg ( &num, &gnum, &kxd, &kyd, &ksub1, &ksub2, iret ); /* * Compute the average for each column. */ dg_qbnd ( &jgxmin, &jgxmax, &jgymin, &jgymax, iret ); for ( ix = jgxmin; ix <= jgxmax; ix++ ) { sum = 0.0; knt = 0; for ( iy = jgymin; iy <= jgymax; iy++ ) { ii = ( iy - 1 ) * kxd + ix; if ( ! ERMISS ( gnum1[ii-1] ) ) { knt++; sum += gnum1[ii-1]; } } if ( knt == 0 ) { avg = RMISSD; } else { avg = sum / knt; } for ( iy = jgymin; iy <= jgymax; iy++ ) { ii = ( iy - 1 ) * kxd + ix ; if ( ! ERMISS ( gnum1[ii-1] ) ) { gnum[ii-1] = avg; } else { gnum[ii-1] = RMISSD; } } } /* * Make a name of the form 'YAV'//S and update header; * update stack. */ dg_updh ( "YAV", &num, &num1, &zero, iret ); dg_puts ( &num, iret ); dg_esub ( &num, &zero, &zero, &zero, &ier ); if ( ier != 0 ) *iret = ier; return; }
void dv_vasv ( int *iret ) /************************************************************************ * dv_vasv * * * * This subroutine computes the vector component of the first vector * * along the second vector. * * * * VASV ( V1, V2 ) = [ DOT (V1,V2) / MAG (V2) ** 2 ] V2 * * * * VASV generates a vector field. * * * * dv_vasv ( iret ) * * * * Output parameters: * * *iret int Return code * * As for DG_GETV * ** * * Log: * * K. Brill/NMC 1/93 * * S. Chiswell/Unidata 2/96 Redefined mag as REAL rmg * * T. Lee/GSC 4/96 Single dimension for dgg * * T. Lee/GSC 5/96 Moved IGDPT outside DO loop * * K. Brill/HPC 1/02 CALL DG_SSUB and DG_ESUB * * K. Brill/HPC 11/02 Eliminate use of the SUBA logical array * * S. Gilbert/NCEP 11/05 Translation from Fortran * ************************************************************************/ { const int zero=0; int i, ier, kxd, kyd, ksub1, ksub2 ; int numu1, numv1, numu2, numv2, nu, nv; float *gru1, *grv1, *gru2, *grv2, *gru, *grv; float du1, dv1, du2, dv2, dot, rmg; /*----------------------------------------------------------------------*/ *iret = 0; dg_ssub ( iret ); /* * Get the two vectors. */ dg_getv ( &numu1, &numv1, iret ); if ( *iret != 0 ) return; dg_getv ( &numu2, &numv2, iret ); if ( *iret != 0 ) return; /* * Get new grid numbers and compute the along stream vector. */ dg_nxtv ( &nu, &nv, iret ); if ( *iret != 0 ) return; dg_getg ( &nu, &gru, &kxd, &kyd, &ksub1, &ksub2, iret ); dg_getg ( &nv, &grv, &kxd, &kyd, &ksub1, &ksub2, iret ); dg_getg ( &numu1, &gru1, &kxd, &kyd, &ksub1, &ksub2, iret ); dg_getg ( &numv1, &grv1, &kxd, &kyd, &ksub1, &ksub2, iret ); dg_getg ( &numu2, &gru2, &kxd, &kyd, &ksub1, &ksub2, iret ); dg_getg ( &numv2, &grv2, &kxd, &kyd, &ksub1, &ksub2, iret ); for ( i = ksub1 - 1; i < ksub2; i++ ) { du1 = gru1[i]; dv1 = grv1[i]; du2 = gru2[i]; dv2 = grv2[i]; if ( ERMISS (du1) || ERMISS (dv1) || ERMISS (du2) || ERMISS (dv2) ) { gru[i] = RMISSD; grv[i] = RMISSD; } else { dot = du1 * du2 + dv1 * dv2; rmg = du2 * du2 + dv2 * dv2; if ( rmg < 1.e-20 ) { gru[i] = RMISSD; grv[i] = RMISSD; } else { gru[i] = ( dot / rmg ) * du2; grv[i] = ( dot / rmg ) * dv2; } } } /* * Make a name of the form 'VASV'//u1//u2 and update header; * update stack. */ dg_updv ( "VASV", &nu, &nv, &numu1, &numu2, iret ); dg_putv ( &nu, &nv, iret ); dg_esub ( &nu, &nv, &zero, &zero, &ier ); if ( ier != 0 ) *iret = ier; return; }
void df_tmwk ( int *iret ) /************************************************************************ * df_tmwk * * * * This subroutine computes the wet bulb temperature in Kelvin from * * the pressure, temperature and mixing ratio: * * * * TMWK (PRES, TMPK, RMIX) = PD_TMWB (PRES, TMPK, RMIX) * * * * df_tmwk ( iret ) * * * * Output parameters: * * *iret int Return code * * As for DG_GETS * ** * * Log: * * L. Williams/EAI 8/94 Modified from DF_TMWK * * T. Lee/GSC 4/96 Single dimension for dgg * * T. Lee/GSC 11/96 Fixed documentation * * K. Brill/HPC 1/02 CALL DG_SSUB and DG_ESUB * * K. Brill/HPC 11/02 Eliminate use of the SUBA logical array * * R. Tian/SAIC 11/05 Recoded from Fortran * ************************************************************************/ { int num1, num2, num3, num, kxd, kyd, kxyd, ksub1, ksub2, ier, zero; float *gnum1, *gnum2, *gnum3, *gnum; /*----------------------------------------------------------------------*/ *iret = 0; zero = 0; dg_ssub ( iret ); /* * Get the three grids from the stack. */ dg_gets ( &num1, iret ); if ( *iret != 0 ) return; dg_gets ( &num2, iret ); if ( *iret != 0 ) return; dg_gets ( &num3, iret ); if ( *iret != 0 ) return; /* * Get a new grid number and compute thetae. */ dg_nxts ( &num, iret ); if ( *iret != 0 ) return; /* * Grid number to grid. */ dg_getg ( &num1, &gnum1, &kxd, &kyd, &ksub1, &ksub2, iret ); dg_getg ( &num2, &gnum2, &kxd, &kyd, &ksub1, &ksub2, iret ); dg_getg ( &num3, &gnum3, &kxd, &kyd, &ksub1, &ksub2, iret ); dg_getg ( &num, &gnum, &kxd, &kyd, &ksub1, &ksub2, iret ); kxyd = kxd * kyd; pd_tmwb ( gnum1, gnum2, gnum3, &kxyd, gnum, &ier ); /* * Make a name of the form 'TMWK'//S1//S2 and update header; * update stack. */ dg_updh ( "TMWK", &num, &num1, &num2, iret ); dg_puts ( &num, iret ); dg_esub ( &num, &zero, &zero, &zero, &ier ); if ( ier != 0 ) *iret = ier; return; }
void df_ne ( int *iret ) /************************************************************************ * df_ne * * * * This function is invoked as NE ( S1, S2, S3 ). It returns 1 * * if |S1-S2| > S3; otherwise 0. * * * * df_ne ( iret ) * * * * Input parameters: * * * * Output parameters: * *iret int Return code * * 0 - normal return * ** * * Log: * * m.gamazaychikov/SAIC 09/05 * * R. Tian/SAIC 11/05 Recoded from Fortran * ************************************************************************/ { int num1, num2, num3, num, kxd, kyd, ksub1, ksub2, i, im1, zero, ier; float *gnum1, *gnum2, *gnum3, *gnum, dg1, dg2, dg3; /*----------------------------------------------------------------------*/ *iret = 0; dg_ssub ( iret ); /* * Get three grids from the stack. */ dg_gets ( &num1, iret ); if ( *iret != 0 ) return; dg_gets ( &num2, iret ); if ( *iret != 0 ) return; dg_gets ( &num3, iret ); if ( *iret != 0 ) return; /* * Get a new grid number and check the grids. */ dg_nxts ( &num, iret ); if ( *iret != 0 ) return; /* * Grid number to grid. */ dg_getg ( &num1, &gnum1, &kxd, &kyd, &ksub1, &ksub2, iret ); dg_getg ( &num2, &gnum2, &kxd, &kyd, &ksub1, &ksub2, iret ); dg_getg ( &num3, &gnum3, &kxd, &kyd, &ksub1, &ksub2, iret ); dg_getg ( &num, &gnum, &kxd, &kyd, &ksub1, &ksub2, iret ); for ( i = ksub1; i <= ksub2; i++ ) { im1 = i - 1; dg1 = gnum1[im1]; dg2 = gnum2[im1]; dg3 = gnum3[im1]; if ( ERMISS ( dg1 ) || ERMISS ( dg2 ) || ERMISS ( dg3 ) ) { gnum[im1] = RMISSD; } else { if ( G_ABS ( dg1 - dg2 ) > dg3 ) { gnum[im1] = 1.0; } else { gnum[im1] = 0.0; } } } /* * Get a name of the form 'NE'//S1//S2 and update header; * update stack. */ dg_updh ( "NE", &num, &num1, &num2, iret ); dg_puts ( &num, iret ); dg_esub ( &num, &zero, &zero, &zero, &ier ); if ( ier != 0 ) *iret = ier; return; }
void df_asin ( int *iret ) /************************************************************************ * df_asin * * * * This subroutine computes the arc sine of a scalar grid: * * * * ASIN (S) * * * * where S is in radians. * * * * df_asin ( iret ) * * * * Output parameters: * * *iret int Return code * * As for DG_GETS * ** * * Log: * * M. Goodman/RDS 11/85 * * W. Skillman/GSFC 5/88 Added new stack subroutines * * G. Huffman/GSC 9/88 Error messages * * K. Brill/GSC 8/89 Subsetting * * K. Brill/GSC 10/89 Subsetting * * T. Lee/GSC 4/96 Single dimension for dgg * * K. Tyle/GSC 5/96 Moved IGDPT outside do-loop * * K. Brill/HPC 1/02 CALL DG_SSUB and DG_ESUB * * K. Brill/HPC 11/02 Eliminate use of the SUBA logical array * * R. Tian/SAIC 10/05 Recoded from Fortran * ************************************************************************/ { int num1, num, kxd, kyd, ksub1, ksub2, zero, ier, fidx, cidx; float *gnum1, *gnum, dg1; /*----------------------------------------------------------------------*/ *iret = 0; zero = 0; dg_ssub ( iret ); /* * Get one grid from the stack. */ dg_gets ( &num1, iret ); if ( *iret != 0 ) return; /* * Get a new grid. */ dg_nxts ( &num, iret ); if ( *iret != 0 ) return; /* * Grid number to grid. */ dg_getg ( &num1, &gnum1, &kxd, &kyd, &ksub1, &ksub2, iret ); dg_getg ( &num, &gnum, &kxd, &kyd, &ksub1, &ksub2, iret ); /* * Compute the arc sine. */ for ( fidx = ksub1; fidx <= ksub2; fidx++ ) { cidx = fidx - 1; dg1 = gnum1[cidx]; if ( ( dg1 < -1. ) || ( dg1 > 1. ) ) { gnum[cidx] = RMISSD; } else { gnum[cidx] = asin ( dg1 ); } } /* * Get a name of the form 'ASIN'//S and update header; * update stack. */ dg_updh ( "ASIN", &num, &num1, &zero, iret ); dg_puts ( &num, iret ); dg_esub ( &num, &zero, &zero, &zero, &ier ); if ( ier != 0 ) *iret = ier; return; }
void df_log ( int *iret ) /************************************************************************ * df_log * * * * This subroutine computes the logarithm to the base 10 of a scalar * * grid: * * * * LOG (S) = LOG10 (S) * * * * using the standard FORTRAN function LOG10. * * * * df_log ( iret ) * * * * Output parameters: * * *iret int Return code * * As for DG_GETS * ** * * Log: * * M. Goodman/RDS 11/85 * * W. Skillman/GSFC 5/88 Added new stack subroutines * * G. Huffman/GSC 9/88 Error messages * * K. Brill/GSC 8/89 Subsetting * * K. Brill/GSC 10/89 Subsetting * * T. Lee/GSC 4/96 Single dimension for dgg * * K. Tyle/GSC 5/96 Moved IGDPT outside do-loop * * K. Brill/HPC 1/02 CALL DG_SSUB and DG_ESUB * * K. Brill/HPC 11/02 Eliminate use of the SUBA logical array * * R. Tian/SAIC 11/05 Recoded from Fortran * ************************************************************************/ { int num1, num, kxd, kyd, ksub1, ksub2, zero, ier, i, im1; float *gnum1, *gnum, dg1; /*----------------------------------------------------------------------*/ *iret = 0; zero = 0; dg_ssub ( iret ); /* * Get the first grid number. */ dg_gets ( &num1, iret ); if ( *iret != 0 ) return; /* * Get a new grid number and compute the log base 10. */ dg_nxts ( &num, iret ); if ( *iret != 0 ) return; /* * Grid number to grid. */ dg_getg ( &num1, &gnum1, &kxd, &kyd, &ksub1, &ksub2, iret ); dg_getg ( &num, &gnum, &kxd, &kyd, &ksub1, &ksub2, iret ); for ( i = ksub1; i <= ksub2; i++ ) { im1 = i - 1; dg1 = gnum1[im1]; if ( ( dg1 <= 0. ) || ERMISS (dg1) ) { gnum[im1] = RMISSD; } else { gnum[im1] = log10 ( dg1 ); } } /* * Make a name of the form 'LOG'//S and update header; * update stack. */ dg_updh ( "LOG", &num, &num1, &zero, iret ); dg_puts ( &num, iret ); dg_esub ( &num, &zero, &zero, &zero, &ier ); if ( ier != 0 ) *iret = ier; return; }
void df_ddt ( int *iret ) /************************************************************************ * df_ddt * * * * This subroutine computes the time derivative: * * * * DDT (S) = [ S (time1) - S (time2) ] / (time1 - time2) * * * * where the time difference is in seconds. * * * * df_ddt ( iret ) * * * * Output parameters: * * *iret int Return code * * As for DG_GETS * ** * * Log: * * M. Goodman/RDS 12/85 * * M. desJardins/GSFC 7/88 Added new stack subroutines * * G. Huffman/GSC 8/88 Revised name generation; error messages * * K. Brill/GSC 8/89 Subsetting * * K. Brill/GSC 10/89 Subsetting * * K. Brill/GSC 11/89 Call TG_DIFF instead of TI_DIFF * * M. desJardins/NMC 7/93 Changed update scheme * * T. Lee/GSC 4/96 Single dimension for dgg * * K. Tyle/GSC 5/96 Moved IGDPT outside do-loop * * K. Brill/HPC 1/02 CALL DG_SSUB and DG_ESUB * * K. Brill/HPC 11/02 Eliminate use of the SUBA logical array * * R. Tian/SAIC 10/05 Recoded from Fortran * ************************************************************************/ { char gp[13], time1[21], time2[21], parm[13], gfunc[13]; int ntdf, kxd, kyd, ksub1, ksub2, fidx, cidx; int level1, level2, ivcord, imins, zero, ier; float *gntdf; /*----------------------------------------------------------------------*/ *iret = 0; zero = 0; dg_ssub ( iret ); /* * Compute the scalar difference over time. */ df_tdf ( iret ); if ( *iret != 0 ) return; /* * Get the pointer to the time difference; save the scalar name. */ dg_tops ( gfunc, &ntdf, time1, time2, &level1, &level2, &ivcord, parm, iret ); if ( *iret != 0 ) return; /* * Convert the date/time range into seconds. */ tg_diff ( time1, time2, &imins, &ier, strlen(time1), strlen(time2) ); /* * Divide the scalar difference by the number of seconds. */ dg_getg ( &ntdf, &gntdf, &kxd, &kyd, &ksub1, &ksub2, iret ); for ( fidx = ksub1; fidx <= ksub2; fidx++ ) { cidx = fidx - 1; if ( imins == 0 || ERMISS ( gntdf[cidx] ) ) { gntdf[cidx] = RMISSD; } else { gntdf[cidx] /= ( imins * 60 ); } } /* * Make a name of the form 'DDT'//S and update header; * the stack is current. DG_UPDH is not used here because * the scalar name was buried in the TDF parameter name. */ strcpy ( gp, "DDT" ); strcat ( gp, &parm[3] ); dg_upsg ( time1, time2, &level1, &level2, &ivcord, &zero, gp, &ntdf, iret ); dg_esub ( &ntdf, &zero, &zero, &zero, &ier ); if ( ier != 0 ) *iret = ier; return; }
void df_mixr ( int *iret ) /************************************************************************ * df_mixr * * * * This subroutine computes the mixing ratio from the dewpoint * * temperature and pressure: * * * * MIXR ( DWPC, PRES ) = PD_MIXR ( DWPC, PRES ) * * * * df_mixr ( iret ) * * * * Output parameters: * * *iret int Return code * * As for DG_GETS * ** * * Log: * * M. desJardins/GSFC 10/85 * * M. desJardins/GSFC 1/87 Corrected storage of scaling factor * * M. desJardins/GSFC 5/88 Fixed scaling * * G. Huffman/GSC 9/88 Error messages * * M. desJardins/GSFC 7/89 Added PA routines * * M. desJardins/GSFC 8/89 PA to PD subroutines * * M. desJardins/GSFC 2/90 Correct calling sequence to PD_MIXR * * M. desJardins/NMC 3/92 Eliminated scaling * * T. Lee/GSC 4/96 Single dimension for dgg * * K. Brill/HPC 1/02 CALL DG_SSUB and DG_ESUB * * K. Brill/HPC 11/02 Eliminate use of the SUBA logical array * * R. Tian/SAIC 11/05 Recoded from Fortran * ************************************************************************/ { int num1, num2, num, kxd, kyd, kxyd, ksub1, ksub2, ier, zero; float *gnum1, *gnum2, *gnum; /*----------------------------------------------------------------------*/ *iret = 0; zero = 0; dg_ssub ( iret ); /* * Get the two grids from the stack. */ dg_gets ( &num1, iret ); if ( *iret != 0 ) return; dg_gets ( &num2, iret ); if ( *iret != 0 ) return; /* * Get a new grid number. */ dg_nxts ( &num, iret ); if ( *iret != 0 ) return; /* * Grid number to grid. */ dg_getg ( &num1, &gnum1, &kxd, &kyd, &ksub1, &ksub2, iret ); dg_getg ( &num2, &gnum2, &kxd, &kyd, &ksub1, &ksub2, iret ); dg_getg ( &num, &gnum, &kxd, &kyd, &ksub1, &ksub2, iret ); /* * Compute the mixing ratio. */ kxyd = kxd * kyd; pd_mixr ( gnum1, gnum2, &kxyd, gnum, &ier ); /* * Make a name of the form 'MIXR'//S1//S2 and update header; * update stack. */ dg_updh ( "MIXR", &num, &num1, &num2, iret ); dg_puts ( &num, iret ); dg_esub ( &num, &zero, &zero, &zero, &ier ); if ( ier != 0 ) *iret = ier; return; }
void dv_mrad ( int *iret ) /************************************************************************ * dv_mrad * * * * This routine computes the magnitude of the radial component of * * the wind. A unit vector between the center of the storm and the * * grid point vector is determined using oblique spherical triangles. * * The radial component of the wind is determined using the equation: * * RAD = V dot r. * * Inflow to the storm is set to be positive and outflow is set to be * * negative. * * Wind is set to 0 when grid point = storm point, using flagged value * * set in DG_AZST subroutine. * * * * dv_mrad ( iret ) * * * * Output parameters: * * *iret int Return code * * As for DG_GETV * ** * * Log: * * J. Whistler/SSAI 6/91 Modified DV_RAD * * K. Tyle/GSC 9/95 Declared level (2) as integer * * K. Tyle/GSC 9/95 Set radial wind = 0 at storm point * * T. Lee/GSC 4/96 Single dimension for dgg * * T. Lee/GSC 5/96 Moved IGDPT outside DO loop * * K. Brill/HPC 1/02 CALL DG_SSUB and DG_ESUB * * K. Brill/HPC 11/02 Eliminate use of the SUBA logical array * * S. Gilbert/NCEP 11/05 Translation from Fortran * ************************************************************************/ { int i, ier, kxd, kyd, kxyd, ksub1, ksub2, zero=0; int numu, numv, ilat, ilon, numout; float *gru, *grv, *grout; int ix, iy, iazst, idir, ispd; float *grx, *gry, *grazst, *grdir, *grspd; char grid[13], parm[13], time1[21], time2[21]; int level1, level2, ignum, ivcord; /*------------------------------------------------------------------------*/ *iret = 0; dg_ssub ( iret ); /* * Read the information from the top of the stack. */ dg_tops ( grid, &ignum, time1, time2, &level1, &level2, &ivcord, parm, iret ); /* * Get the (wind) vector. */ dg_getv ( &numu, &numv, iret ); if ( *iret != 0 ) return; /* * Get scalar grids. */ dg_gets ( &ilat, iret ); if ( *iret != 0 ) return; dg_gets ( &ilon, iret ); if ( *iret != 0 ) return; dg_gets ( &idir, iret ); if ( *iret != 0 ) return; dg_gets ( &ispd, iret ); if ( *iret != 0 ) return; /* * Get a new grid number. */ dg_nxts ( &ix, iret ); if ( *iret != 0 ) return; dg_nxts ( &iy, iret ); if ( *iret != 0 ) return; dg_nxts ( &numout, iret ); if ( *iret != 0 ) return; /* * Set the latitude and longitude of the grid points. */ dg_ltln ( iret ); /* * Calculate the azimuth angle between the storm and the grid * points. */ dg_azst ( &ilat, &ilon, &iazst, iret ); if ( *iret != 0 ) return; /* * Calculate the x and y components of the directional unit * vector. */ dg_getg ( &ix, &grx, &kxd, &kyd, &ksub1, &ksub2, iret ); dg_getg ( &iy, &gry, &kxd, &kyd, &ksub1, &ksub2, iret ); dg_getg ( &iazst, &grazst, &kxd, &kyd, &ksub1, &ksub2, iret ); for ( i = ksub1 - 1; i < ksub2; i++ ) { if ( ERMISS ( grazst[i] ) ) { grx[i] = RMISSD; gry[i] = RMISSD; } /* * Set wind = 0 at storm point. */ else if ( grazst[i] > ( 2. * PI ) ) { grx[i] = 0.0; gry[i] = 0.0; } else { grx[i] = sin ( grazst[i] ); gry[i] = cos ( grazst[i] ); } } /* * Change the x and y components of the unit vector from * North relative to Grid relative. */ dg_grel ( grx, gry, grx, gry, iret ); if ( *iret != 0 ) return; /* * Compute u and v grid fields for the storm motion then subtract * the storm motion from the wind field. */ dg_getg ( &idir, &grdir, &kxd, &kyd, &ksub1, &ksub2, iret ); dg_getg ( &ispd, &grspd, &kxd, &kyd, &ksub1, &ksub2, iret ); kxyd = kxd * kyd; pd_sduv ( grspd, grdir, &kxyd, grspd, grdir, iret ); if ( *iret != 0 ) return; /* * Change storm motion components to grid relative. */ dg_grel ( grspd, grdir, grspd, grdir, iret ); if ( *iret != 0 ) return; /* * Subtracting u-component. */ dg_puts ( &ispd, iret ); if ( *iret != 0 ) return; dg_puts ( &numu, iret ); if ( *iret != 0 ) return; df_sub ( iret ); if ( *iret != 0 ) return; dg_gets ( &numu, iret ); if ( *iret != 0 ) return; /* * Subtracting v-component. */ dg_puts ( &idir, iret ); if ( *iret != 0 ) return; dg_puts ( &numv, iret ); if ( *iret != 0 ) return; df_sub ( iret ); if ( *iret != 0 ) return; dg_gets ( &numv, iret ); if ( *iret != 0 ) return; /* * Compute the u and v components of the radial wind. */ dg_getg ( &numu, &gru, &kxd, &kyd, &ksub1, &ksub2, iret ); dg_getg ( &numv, &grv, &kxd, &kyd, &ksub1, &ksub2, iret ); dg_getg ( &numout, &grout, &kxd, &kyd, &ksub1, &ksub2, iret ); for ( i = ksub1 - 1; i < ksub2; i++ ) { if ( ERMISS ( grx[i] ) || ERMISS ( gry[i] ) || ERMISS ( gru[i] ) || ERMISS ( grv[i] ) ) grout[i] = RMISSD; else grout[i] = ( gru[i] * grx[i] ) + ( grv[i] * gry[i] ); } /* * Update grid header. Use wind type as parameter name. */ dg_updh ( "MRAD", &numout, &numu, &zero, &ier ); /* * Update stack. */ dg_puts ( &numout, iret ); dg_esub ( &numout, &zero, &zero, &zero, &ier ); if ( ier != 0 ) *iret = ier; return; }
void dv_vn ( int *iret ) /************************************************************************ * dv_vn * * * * This subroutine returns the v component of a vector in north * * relative coordinates. * * * * VN ( V ) = v * * * * dv_vn ( iret ) * * * * Output parameters: * * *iret int Return code * * As for DG_GETV * ** * * Log: * * M. desJardins/GSFC 10/85 * * M. desJardins/GSFC 5/88 Added new stack functions * * I. Graffman/RDS 7/88 Call to DG_UPDH * * G. Huffman/GSC 9/88 Error messages * * M. desJardins/GSFC 4/89 Added grid relative functions * * T. Lee/GSC 4/96 Single dimension for dgg * * K. Brill/HPC 1/02 CALL DG_SSUB and DG_ESUB * * S. Gilbert/NCEP 11/05 Translation from Fortran * ************************************************************************/ { const int zero = 0; int ier, kxd, kyd, ksub1, ksub2; int numu, numv, nunor, nvnor; float *gru, *grv, *grunor, *grvnor; /*----------------------------------------------------------------------*/ *iret = 0; dg_ssub ( iret ); /* * Get the vector from the stack. */ dg_getv ( &numu, &numv, iret ); if ( *iret != 0 ) return; /* * Get a new vector to translate from grid relative to north * relative components. */ dg_nxtv ( &nunor, &nvnor, iret ); if ( *iret != 0 ) return; /* * Internal grid are always grid relative. Translate to north rel. */ dg_getg ( &numu, &gru, &kxd, &kyd, &ksub1, &ksub2, iret ); dg_getg ( &numv, &grv, &kxd, &kyd, &ksub1, &ksub2, iret ); dg_getg ( &nunor, &grunor, &kxd, &kyd, &ksub1, &ksub2, iret ); dg_getg ( &nvnor, &grvnor, &kxd, &kyd, &ksub1, &ksub2, iret ); dg_nrel ( gru, grv, grunor, grvnor, &ier ); /* * Return the v component. Make a name of the form 'V'//v and * update the header; update the stack. */ dg_updh ( "V", &nvnor, &numv, &zero, iret ); dg_puts ( &nvnor, iret ); dg_esub ( &nvnor, &zero, &zero, &zero, &ier ); if ( ier != 0 ) *iret = ier; return; }
void dv_obs ( int *iret ) /************************************************************************ * dv_obs * * * * This subroutine gets the observed wind with conversion, if needed. * * * * dv_obs ( iret ) * * * * Output parameters: * * *iret int Return code * * 0 = normal return * * -7 = grid cannot be found * * -9 = calling sequence error * * -10 = internal grid list full * * -11 = grid must be a vector * * -21 = stack is empty * * -22 = TIME is invalid * * -23 = LEVEL is invalid * * -24 = IVCORD is invalid * ** * * Log: * * G. Huffman/GSC 9/88 Break out DG_GOBS separately from DG_OBS* * M. desJardins/NMC 3/92 Make WND and WIND same as OBS * * K. Brill/HPC 1/02 CALL DG_SSUB and DG_ESUB * * S. Gilbert/NCEP 11/05 Translation from Fortran * ************************************************************************/ { int ier, zero=0; char time1[21], time2[21], gvect[13], parm[13]; int level1, level2, ivcord; int ignumu, ignumv; /*------------------------------------------------------------------------*/ *iret = 0; dg_ssub ( iret ); /* * Get information on grid to find. */ dg_topv ( gvect, &ignumu, &ignumv, time1, time2, &level1, &level2, &ivcord, parm, iret ); if ( *iret != 0 ) return; /* * Check that correct subroutine has been called. */ if ( ( strncmp(gvect, "OBS", 3) != 0 ) && ( strncmp(gvect, "WND", 3) != 0 ) && ( strncmp(gvect, "WIND", 4) != 0 ) ) { *iret = -9; dg_cset ( "ERRST", gvect, &ier); return; } /* * Actually get the grids and replace the vector on the stack. */ dg_gobs ( time1, time2, &level1, &level2, &ivcord, &ignumu, &ignumv, iret ); if ( *iret != 0 ) return; dg_rplv ( " ", &ignumu, &ignumv, iret ); dg_esub ( &ignumu, &ignumv, &zero, &zero, &ier ); if ( ier != 0 ) *iret = ier; return; }
void df_thwc ( int *iret ) /************************************************************************ * df_thwc * * * * This subroutine computes the wet bulb potential temperature in * * Celsius from the pressure, temperature and dewpoint: * * * * THWC (PRES, TMPC, DWPC) = PD_THWC (PRES, TMPC, DWPC) * * * * df_thwc ( iret ) * * * * Output parameters: * * *iret int Return code * * As for DG_GETS * ** * * Log: * * P. Bothwell/SPC 9/97 Orig THTE changed to calculate THTW * * T. Lee/GSC 11/97 Cleaned up; renamed THTW to THWC * * K. Brill/HPC 1/02 CALL DG_SSUB and DG_ESUB * * K. Brill/HPC 11/02 Eliminate use of the SUBA logical array * * R. Tian/SAIC 11/05 Recoded from Fortran * ************************************************************************/ { int num1, num2, num3, num, kxd, kyd, kxyd, ksub1, ksub2, ier, zero; float *gnum1, *gnum2, *gnum3, *gnum; /*----------------------------------------------------------------------*/ *iret = 0; zero = 0; dg_ssub ( iret ); /* * Get the three grids from the stack. */ dg_gets ( &num1, iret ); if ( *iret != 0 ) return; dg_gets ( &num2, iret ); if ( *iret != 0 ) return; dg_gets ( &num3, iret ); if ( *iret != 0 ) return; /* * Get a new grid number and compute THWC. */ dg_nxts ( &num, iret ); if ( *iret != 0 ) return; dg_getg ( &num1, &gnum1, &kxd, &kyd, &ksub1, &ksub2, iret ); dg_getg ( &num2, &gnum2, &kxd, &kyd, &ksub1, &ksub2, iret ); dg_getg ( &num3, &gnum3, &kxd, &kyd, &ksub1, &ksub2, iret ); dg_getg ( &num, &gnum, &kxd, &kyd, &ksub1, &ksub2, iret ); kxyd = kxd * kyd; pd_thwc ( gnum1, gnum2, gnum3, &kxyd, gnum, &ier ); /* * Make a name of the form 'THWC'//S1//S2 and update header; * update stack. */ dg_updh ( "THWC", &num, &num1, &num2, iret ); dg_puts ( &num, iret ); dg_esub ( &num, &zero, &zero, &zero, &ier ); if ( ier != 0 ) *iret = ier; return; }
void dv_vavs ( int *iret ) /************************************************************************ * dv_vavs * * * * This subroutine computes the average vector for a vector field but * * only over the subset area. VAVS generates a vector with the * * average at each grid point in the subset area. * * * * dv_vavs ( iret ) * * * * Output parameters: * * *iret int Return code * * As for DG_GETV * ** * * Log: * * K. Brill/NMC 10/90 * * K. Brill/HPC 1/02 CALL DG_SSUB and DG_ESUB * * S. Gilbert/NCEP 11/05 Translation from Fortran * ************************************************************************/ { const int zero=0; int nui, nvi, nuo, nvo, ier; /*----------------------------------------------------------------------*/ *iret = 0; dg_ssub ( iret ); /* * Get the grid numbers for the input vector. */ dg_getv ( &nui, &nvi, iret ); if ( *iret != 0 ) return; /* * Put the u-component of the wind on the stack and average. */ dg_puts ( &nui, iret ); if ( *iret != 0 ) return; df_savs ( iret ); if ( *iret != 0 ) return; dg_gets ( &nuo, iret ); if ( *iret != 0 ) return; /* * Put the v-component of the wind on the stack and average. */ dg_puts ( &nvi, iret ); if ( *iret != 0 ) return; df_savs ( iret ); if ( *iret != 0 ) return; dg_gets ( &nvo, iret ); if ( *iret != 0 ) return; /* * Make a name of the form 'AVS'//u1//u2 and update header; * update the stack. */ dg_updv ( "AVS", &nuo, &nvo, &nui, &nvi, iret ); dg_putv ( &nuo, &nvo, iret ); dg_esub ( &nuo, &nvo, &zero, &zero, &ier ); if ( ier != 0 ) *iret = ier; return; }
void de_ssum ( const char *uarg, char *stprm, int *iret ) /************************************************************************ * de_ssum * * * * This subroutine computes the sum over the ensemble of a scalar. * * * * de_ssum ( uarg, stprm, iret ) * * * * Input and parameters: * * *uarg const char Function argument string * * * * Output parameters: * * *stprm char Substitution string * * *iret int Return code * * 0 = normal return * * -8 = cannot parse argument * * -9 = ensemble cannot computed * ** * * Log: * * K. Brill/HPC 08/10 Created from de_ssprd * ************************************************************************/ { char tname[13], pdum[13], time1[21], time2[21]; int ns, num, kxd, kyd, ksub1, ksub2, level1, level2, ivcord, nina, one, zero, i, j, ier; float *gns, *gnum; double *dgns, d1, d2; /*----------------------------------------------------------------------*/ *iret = 0; one = 1; zero = 0; dg_ssub ( iret ); /* * Get a new grid number. */ dg_nxts ( &ns, iret ); if ( *iret != 0 ) return; /* * Initialize the output grid. * Allocate internal double arrays. */ dg_getg ( &ns, &gns, &kxd, &kyd, &ksub1, &ksub2, iret ); G_MALLOC(dgns, double, kxd*kyd, "DE_SSUM"); for ( i = ksub1 - 1; i < ksub2; i++ ) { gns[i] = 0.; dgns[i] = 0.; } /* * Set the number of input arguments. There is only one argument * for DE_SSUM. */ nina = 1; for ( i = 0; i < MXARGS; i++ ) { _ensdiag.allarg[i][0] = '\0'; } strcpy ( _ensdiag.allarg[0], uarg ); /* * Scan the allarg array. */ de_scan ( &nina, iret ); if ( *iret != 0 ) return; /* * Loop over number of members set by DE_SCAN. */ for ( i = 0; i < _ensdiag.nummbr; i++ ) { de_mset ( &i, iret ); dg_pfun ( _ensdiag.allarg[0], iret ); if ( *iret != 0 ) { er_wmsg ( "DG", iret, " ", &ier, strlen("DG"), strlen(" ") ); *iret = -8; return; } dg_driv( &one, iret ); if ( *iret != 0 ) { er_wmsg ( "DG", iret, _ensdiag.allarg[0], &ier, strlen("DG"), strlen(_ensdiag.allarg[0]) ); *iret = -9; return; } /* * Retrieve the output grid from the stack. Check that the * output is a scalar. */ dg_tops ( tname, &num, time1, time2, &level1, &level2, &ivcord, pdum, iret ); dg_getg ( &num, &gnum, &kxd, &kyd, &ksub1, &ksub2, iret ); for ( j = ksub1 - 1; j < ksub2; j++ ) { d1 = gnum[j]; d2 = dgns[j]; if ( ERMISS ( d1 ) || ERMISS ( d2 ) ) { dgns[j] = RMISSD; } else { dgns[j] += gnum[j]; } } dg_frig ( &num, &ier ); } /* * Assign the result to the output array and free the internal arrays. */ for ( i = ksub1 - 1; i < ksub2; i++ ) { gns[i] = (float)dgns[i]; } G_FREE(dgns, double); /* * Reset DGCMN.CMN and set internal grid identifier. */ de_rset ( iret ); dg_udig ( "EXX_", &ns, &zero, &_ensdiag.idgens, stprm, iret ); dg_esub ( &ns, &zero, &zero, &zero, &ier ); if ( ier != 0 ) *iret = ier; return; }
void dv_ross ( int *iret ) /************************************************************************ * dv_ross * * * * This subroutine computes the Rossby number from two winds: * * * * ROSS ( V1, V2 ) = MAG ( INAD ( V1, V2 ) ) / ( CORL * MAG ( V1 ) )* * * * ROSS generates a scalar grid. * * * * dv_ross ( iret ) * * * * Output parameters: * * *iret int Return code * * As for DG_GETV * ** * * Log: * * M. Goodman/RDS 12/85 * * I. Graffman/RDS 7/88 Call to DG_UPDH * * G. Huffman/GSC 9/88 New stack functions * * G. Huffman/GSC 9/88 Error messages * * K. Brill/NMC 11/90 Pass grid number to DF_CORL * * K. Brill/HPC 1/02 CALL DG_SSUB and DG_ESUB * * S. Gilbert/NCEP 11/05 Translation from Fortran * ************************************************************************/ { int iret1, iret2, ier, zero=0; int num1u, num1v, num2u, num2v, numcor, nross; /*------------------------------------------------------------------------*/ *iret = 0; dg_ssub ( iret ); /* * Get the two vectors. */ dg_getv ( &num1u, &num1v, iret ); if ( *iret != 0 ) return; dg_getv ( &num2u, &num2v, iret ); if ( *iret != 0 ) return; /* * Put V1 on the stack and compute MAG; compute CORL and multiply * (creating the denominator). Leave the result on the stack. */ dg_putv ( &num1u, &num1v, iret ); if ( *iret != 0 ) return; dv_mag ( iret ); if ( *iret != 0 ) return; dg_nxts ( &numcor, &iret1 ); df_corl ( &numcor, &iret2 ); dg_puts ( &numcor, iret ); *iret = *iret + iret1 + iret2; if ( *iret != 0 ) return; df_mul ( iret ); if ( *iret != 0 ) return; /* * Put the winds on the stack (LIFO order), compute the inertial * advective wind, and take its MAG. */ dg_putv ( &num2u, &num2v, iret ); if ( *iret != 0 ) return; dg_putv ( &num1u, &num1v, iret ); if ( *iret != 0 ) return; dv_inad ( iret ); if ( *iret != 0 ) return; dv_mag (iret); if ( *iret != 0 ) return; /*magiad = istack (itop)*/ /* * Complete the calculation and get the result. */ df_quo ( iret ); if ( *iret != 0 ) return; dg_gets ( &nross, iret ); if ( *iret != 0 ) return; /* * Make a name of the form 'ROSS'//u1//u2 and update header; * update the stack. */ dg_updh ( "ROSS", &nross, &num1u, &num2u, iret ); dg_puts ( &nross, iret ); dg_esub ( &nross, &zero, &zero, &zero, &ier ); if ( ier != 0 ) *iret = ier; return; }
void df_not ( int *iret ) /************************************************************************ * df_not * * * * This function is invoked as NOT ( S ). It returns 1 if S == 0; * * otherwise 0. * * * * df_not ( iret ) * * * * Input parameters: * * * * Output parameters: * *iret int Return code * * 0 - normal return * ** * * Log: * * m.gamazaychikov/SAIC 09/05 * * R. Tian/SAIC 11/05 Recoded from Fortran * ************************************************************************/ { int num1, num, kxd, kyd, ksub1, ksub2, i, im1, zero, ier; float *gnum1, *gnum, dg1; /*----------------------------------------------------------------------*/ *iret = 0; zero = 0; dg_ssub ( iret ); /* * Get ONE grid from the stack. */ dg_gets ( &num1, iret ); if ( *iret != 0 ) return; /* * Get a new grid number for the output grid. */ dg_nxts ( &num, iret ); if ( *iret != 0 ) return; dg_getg ( &num1, &gnum1, &kxd, &kyd, &ksub1, &ksub2, iret ); dg_getg ( &num, &gnum, &kxd, &kyd, &ksub1, &ksub2, iret ); for ( i = ksub1; i <= ksub2; i++ ) { im1 = i - 1; dg1 = gnum1[im1]; if ( ERMISS ( dg1 ) ) { gnum[im1] = RMISSD; } else { if( G_DIFFT(dg1, 0.0F, GDIFFD) ) { gnum[im1] = 1.0F; } else { gnum[im1] = 0.0F; } } } /* * Get a name of the form 'NOT'//S1/ and update header; * update stack. */ dg_updh ( "NOT", &num, &num1, &zero, iret ); dg_puts ( &num, iret ); dg_esub ( &num, &zero, &zero, &zero, &ier ); if ( ier != 0 ) *iret = ier; return; }
void df_atn2 ( int *iret ) /************************************************************************ * df_atn2 * * * * This subroutine computes the arc tangent of the quotient of two * * scalar grids: * * * * ATAN2 (S1, S2) = ATAN2 ( S1 / S2 ) * * * * df_atn2 ( iret ) * * * * Output parameters: * * *iret int Return code * * As for DG_GETS * ** * * Log: * * M. Goodman/RDS 11/85 * * W. Skillman/GSFC 5/88 Added new stack subroutines * * G. Huffman/GSC 8/88 Correct answer at infinity * * G. Huffman/GSC 9/88 Error messages * * G. Huffman/GSC 4/89 Correct first infinity test to denom. * * K. Brill/GSC 8/89 Subsetting * * K. Brill/GSC 10/89 Subsetting * * T. Lee/GSC 4/96 Single dimension for dgg * * K. Tyle/GSC 5/96 Moved IGDPT outside do-loop * * T. Piper/GSC 11/98 Updated prolog * * K. Brill/HPC 1/02 CALL DG_SSUB and DG_ESUB * * K. Brill/HPC 11/02 Eliminate use of the SUBA logical array * * R. Tian/SAIC 10/05 Translated from Fortran * ************************************************************************/ { int num1, num2, num, kxd, kyd, ksub1, ksub2, fidx, cidx, zero, ier; float *gnum1, *gnum2, *gnum, dg1, dg2; /*----------------------------------------------------------------------*/ *iret = 0; zero = 0; dg_ssub ( iret ); /* * Get the two grids from the stack. */ dg_gets ( &num1, iret ); if ( *iret != 0 ) return; dg_gets ( &num2, iret ); if ( *iret != 0 ) return; /* * Get a new grid. */ dg_nxts ( &num, iret ); if ( *iret != 0 ) return; /* * Grid number to grid. */ dg_getg ( &num1, &gnum1, &kxd, &kyd, &ksub1, &ksub2, iret ); dg_getg ( &num2, &gnum2, &kxd, &kyd, &ksub1, &ksub2, iret ); dg_getg ( &num, &gnum, &kxd, &kyd, &ksub1, &ksub2, iret ); /* * Compute the arc tangent. */ for ( fidx = ksub1; fidx <= ksub2; fidx++ ) { cidx = fidx - 1; dg1 = gnum1[cidx]; dg2 = gnum2[cidx]; /* * Cases are error, non-zero denom., zero denom. with neg. * numerator, zero denom. with non-neg. numerator. */ if ( ERMISS ( dg1 ) || ERMISS ( dg2 ) ) { gnum[cidx] = RMISSD; } else if ( !G_DIFFT(dg2, 0.0F, GDIFFD) ) { gnum[cidx] = atan2 ( dg1, dg2 ); } else if ( dg1 < 0.0F ) { gnum[cidx] = -HALFPI; } else { gnum[cidx] = HALFPI; } } /* * Get a name of the form 'ATAN'//S1//S2 and update header; * update stack. */ dg_updh ( "ATAN", &num, &num1, &num2, iret ); dg_puts ( &num, iret ); dg_esub ( &num, &zero, &zero, &zero, &ier ); if ( ier != 0 ) *iret = ier; return; }
void de_prcntl ( const char *uarg, char *stprm, int *iret ) /************************************************************************ * de_prcntl * * * * This subroutine returns a value at each grid point such that the * * value returned is greater than or equal to the value found at the * * same grid point in P% of the weighted members of an ensemble. The * * value of P ranges between 0 and 100 and may vary from grid point to * * point. * * * * The relationship between the percentile value, p, and the index, k, * * in the order statistics of count N is * * * * ( k - 1 ) / ( N - 1 ) = p (1) * * * * Rewriting this in terms of equally weighted order statistics * * (multiplying both sides by (N-1)/N) yields * * * * (k-1)*(1/N) = p - p*(1/N) (2) * * * * Since k can have a fractional value, the weights may vary, and the * * (1/N) subtracted on both sides of (2) must be the first weight value * * (w(1)), the problem is one of finding integer K and residual weight * * wr such that * * * * K * * wr + SUM w(i) = p ( 1 - w(1) ) (3) * * i=2 * * * * The value of wr is easily obtained by solving (3) after summing the * * weights up to the point in the order statistics where adding on one * * more weight exceeds the value of the R.H.S of (3). The value of wr * * establishes the position in the weight summation to which to * * interpolate the values of the order statistics, x, according to the * * following linear relationship: * * * * wr / [ W(K+1) - W(K) ] = [ x - x(K) ] / [ x(K+1) - x(K) ] (4) * * * * In (4), W(K) is the summation of the weights from i=2 to K. The * * percentile value is found by solving (4) for x. Since the denom- * * inator on the L.H.S of (4) is just w(K+1), the value of x is * * * * x = x(K) + [ wr / w(K+1) ] * [ x(K+1) - x(K) ] (5) * * * * * * de_prcntl ( uarg, stprm, iret ) * * * * Input and parameters: * * *uarg const char Function argument string * * * * Output parameters: * * *stprm char Substitution string * * *iret int Return code * * +3 = Percentile < 0 * * +1 = Percentile > 100 * * 0 = normal return * * -8 = cannot parse argument * * -9 = ensemble cannot computed * * -15 = Incorrect # of arguments * ** * * Log: * * T. Lee/SAIC 01/05 * * R. Tian/SAIC 1/06 Translated from Fortran * * T. Piper/SAIC 08/06 Added G_DIFF * * K. Brill/HPC 08/06 Fix to remove low bias; document eqtns * * m.gamazaychikov/SAIC 01/08 Add ability to use weights * ************************************************************************/ { char tname[13], pdum[13], time1[21], time2[21]; char **argu; int igo, igp, num, kxd, kyd, ksub1, ksub2, nina, narg, level1, level2, ivcord, zero, one, three, ii, jj, kk, ll, ier; int wmesg, nmesg, iswflg, istop, iwpntr; int nsw, numw; float *gigo, *gigp, *gnum, data, swpbuf, pntt, psum, smw, wr, *gnumw, *gwgt, d1; /*----------------------------------------------------------------------*/ *iret = 0; zero = 0; one = 1; three = 3; dg_ssub ( iret ); /* * Get a new grid number. */ dg_nxts ( &igo, iret ); if ( *iret != 0 ) return; /* * Initialize the output grid. */ dg_getg ( &igo, &gigo, &kxd, &kyd, &ksub1, &ksub2, iret ); for ( ii = ksub1 - 1; ii < ksub2; ii++ ) { gigo[ii] = RMISSD; } /* * Set the number of input arguments. There are two arguments * for DE_PRCNTL. */ for ( ii = 0; ii < MXARGS; ii++ ) { _ensdiag.allarg[ii][0] = '\0'; } nina = 3; argu = (char **)cmm_malloc2d ( 3, MXFLSZ+1, sizeof(char), &ier ); cst_clst ( (char *)uarg, '&', " ", nina, MXFLSZ, argu, &narg, &ier ); for ( ii = 0; ii < narg; ii++ ) { strcpy ( _ensdiag.allarg[ii], argu[ii] ); } /* * If weight grid is provided get new grid number * for sum-weight grid and initialize it */ if ( narg == 3 ) { dg_nxts ( &nsw, iret ); if ( *iret != 0 ) return; dg_getg ( &nsw, &gwgt, &kxd, &kyd, &ksub1, &ksub2, iret ); for ( ii = ksub1 - 1; ii < ksub2; ii++ ) { gwgt[ii] = 0.; } } cmm_free2d ( (void **) argu, &ier ); if ( narg < 2 ) { *iret = -15; return; } /* * Scan the allarg array. */ de_scan ( &narg, iret ); if ( *iret != 0 ) return; /* * Evaluate the static argument defined by the second entry in * uarg or allarg (2). */ dg_pfun ( _ensdiag.allarg[1], iret ); if ( *iret != 0 ) { er_wmsg ( "DG", iret, " ", &ier, strlen("DG"), strlen(" ") ); *iret = -8; return; } dg_driv ( &one, iret ); if ( *iret != 0 ) { er_wmsg ( "DG", iret, _ensdiag.allarg[1], &ier, strlen("DG"), strlen(_ensdiag.allarg[1]) ); *iret = -9; return; } /* * Retrieve the output grid from the stack. Check that the * output is a scalar. */ dg_tops ( tname, &igp, time1, time2, &level1, &level2, &ivcord, pdum, iret ); dg_getg ( &igp, &gigp, &kxd, &kyd, &ksub1, &ksub2, iret ); /* * Loop over number of members set by DE_SCAN. */ for ( ii = 0; ii < _ensdiag.nummbr; ii++ ) { de_mset ( &ii, iret ); dg_pfun ( _ensdiag.allarg[0], iret ); if ( *iret != 0 ) { er_wmsg ( "DG", iret, " ", &ier, strlen("DG"), strlen(" ") ); *iret = -8; return; } dg_driv ( &one, iret ); if ( *iret != 0 ) { er_wmsg ( "DG", iret, _ensdiag.allarg[0], &ier, strlen("DG"), strlen(_ensdiag.allarg[0]) ); *iret = -9; return; } /* * Retrieve the output grid from the stack and store the * grid number. */ dg_tops ( tname, &num, time1, time2, &level1, &level2, &ivcord, pdum, iret ); _ensdiag.iglist[ii] = num; /* * If the weight grid present store the starting index * of the weight grid. */ if ( narg == 3 ) { dg_pfun ( _ensdiag.allarg[2], iret ); if ( *iret != 0 ) { er_wmsg ( "DG", iret, " ", &ier, strlen("DG"), strlen(" ") ); *iret = -8; return; } dg_driv ( &one, iret ); if ( *iret != 0 ) { er_wmsg ( "DG", iret, _ensdiag.allarg[2], &ier, strlen("DG"), strlen(_ensdiag.allarg[2]) ); *iret = -9; return; } dg_tops ( tname, &numw, time1, time2, &level1, &level2, &ivcord, pdum, iret ); dg_getg ( &numw, &gnumw, &kxd, &kyd, &ksub1, &ksub2, iret ); _ensdiag.iwlist[ii] = numw; /* * the weight summing grid */ for ( jj = ksub1 - 1; jj < ksub2; jj++ ) { d1 = gnumw[jj]; if ( ERMISS ( d1 ) || ERMISS ( gwgt[jj] ) ) { gwgt[jj] = RMISSD; } else { gwgt[jj] += gnumw[jj]; } } } } wmesg = G_FALSE; nmesg = G_FALSE; for ( ll = ksub1 - 1; ll < ksub2; ll++ ) { for ( ii = 0; ii < _ensdiag.nummbr; ii++ ) { num = _ensdiag.iglist[ii]; dg_getg ( &num, &gnum, &kxd, &kyd, &ksub1, &ksub2, iret ); data = gnum[ll]; /* * Fill out the weight array and normalize by the sum of weights */ if ( narg == 3 ) { numw = _ensdiag.iwlist[ii]; dg_getg ( &numw, &gnumw, &kxd, &kyd, &ksub1, &ksub2, iret ); _ensdiag.ewtval[ii] = gnumw[ll] / gwgt[ll]; } if ( ! ERMISS ( data ) ) { _ensdiag.emvalu[ii] = data; _ensdiag.igpntr[ii] = ii; if ( ii == _ensdiag.nummbr - 1 ) { /* * Bubble sorting the grid values in emvalu with * emvalue (1) lowest and emvalu (nummbr) highest. */ iswflg = 1; istop = _ensdiag.nummbr - 1; while ( iswflg != 0 && istop >= 0 ) { iswflg = 0; for ( kk = 0; kk < istop; kk++ ) { if ( _ensdiag.emvalu[kk] > _ensdiag.emvalu[kk+1] ) { iswflg = 1; swpbuf = _ensdiag.emvalu[kk]; iwpntr = _ensdiag.igpntr[kk]; _ensdiag.emvalu[kk] = _ensdiag.emvalu[kk+1]; _ensdiag.igpntr[kk] = _ensdiag.igpntr[kk+1]; _ensdiag.emvalu[kk+1] = swpbuf; _ensdiag.igpntr[kk+1] = iwpntr; } } istop--; } /* * Set normalized target percentile. */ pntt = gigp[ll] / 100.0F; if ( pntt >= 1. ) { gigo[ll] = _ensdiag.emvalu[_ensdiag.nummbr-1]; if ( pntt > 1.0F && wmesg == G_FALSE ) { er_wmsg ( "DE", &one, " ", &ier, strlen("DE"), strlen(" ") ); wmesg = G_TRUE; } } else if ( pntt <= 0. ) { gigo[ll] = _ensdiag.emvalu[0]; if ( pntt < 0.0F && nmesg == G_FALSE ) { er_wmsg ( "DE", &three, " ", &ier, strlen("DE"), strlen(" ") ); nmesg = G_TRUE; } } else { jj = 0; psum = 0.0; if ( narg == 3 ) { pntt = pntt * ( 1.0F - _ensdiag.ewtval[_ensdiag.igpntr[0]] ); } else { pntt = pntt * ( 1.0F - _ensdiag.enswts[_ensdiag.igpntr[0]] ); } while (jj < _ensdiag.nummbr - 1 && psum < pntt ) { jj++; /* * The 1st weight ([0]) must be omitted from the * summation. */ if ( narg == 3 ) { psum += _ensdiag.ewtval[_ensdiag.igpntr[jj]]; } else { psum += _ensdiag.enswts[_ensdiag.igpntr[jj]]; } } /* * Compute the percentile value for the output grid. */ if ( G_DIFF(psum, pntt) ) { gigo[ll] = _ensdiag.emvalu[jj]; } else { if ( narg == 3 ) { smw = psum - _ensdiag.ewtval[_ensdiag.igpntr[jj]]; wr = pntt - smw; if ( G_DIFF (_ensdiag.ewtval[_ensdiag.igpntr[jj]], 0.0F) ) { gigo[ll] = RMISSD; } else { gigo[ll] = _ensdiag.emvalu[jj-1] + ( wr / _ensdiag.ewtval[_ensdiag.igpntr[jj]] ) * (_ensdiag.emvalu[jj]-_ensdiag.emvalu[jj-1]); } } else { smw = psum - _ensdiag.enswts[_ensdiag.igpntr[jj]]; wr = pntt - smw; if ( G_DIFF (_ensdiag.enswts[_ensdiag.igpntr[jj]], 0.0F) ) { gigo[ll] = RMISSD; } else { gigo[ll] = _ensdiag.emvalu[jj-1] + ( wr / _ensdiag.enswts[_ensdiag.igpntr[jj]] ) * (_ensdiag.emvalu[jj]-_ensdiag.emvalu[jj-1]); } } } } } } } } /* * Reset DGCMN.CMN and set internal grid identifier. */ de_rset ( iret ); dg_udig ( "EXX_", &igo, &zero, &_ensdiag.idgens, stprm, iret ); dg_esub ( &igo, &zero, &zero, &zero, &ier ); if ( ier != 0 ) *iret = ier; return; }
void dv_dirr ( int *iret ) /************************************************************************ * dv_dirr * * * * This subroutine returns the direction of a vector relative to * * the grid: * * * * DIRR ( V ) = PD_DRCT ( u, v ) * * * * dv_dirr ( iret ) * * * * Output parameters: * * *iret int Return code * * As for DG_GETV * ** * * Log: * * M. desJardins/GSFC 10/85 * * I. Graffman/RDS 7/88 Call to DG_UPDH * * G. Huffman/GSC 9/88 New stack functions; Error messages * * M. desJardins/GSFC 4/89 Added grid relative functions * * M. desJardins/GSFC 7/89 Added PA subroutines * * M. desJardins/GSFC 8/89 PA to PD subroutines * * T. Lee/GSC 4/96 Single dimension for dgg * * K. Brill/HPC 1/02 CALL DG_SSUB and DG_ESUB * * K. Brill/HPC 11/02 Eliminate use of the SUBA logical array * * S. Gilbert/NCEP 11/05 Translation from Fortran * ************************************************************************/ { int ier, zero=0, kxd, kyd, kxyd, ksub1, ksub2; int numu, numv, numout; float *gru, *grv, *grout; /*------------------------------------------------------------------------*/ *iret = 0; dg_ssub ( iret ); /* * Get the vector grid. */ dg_getv ( &numu, &numv, iret ); if ( *iret != 0 ) return; /* * Get a new grid index and compute the direction from U and V. */ dg_nxts ( &numout, iret ); if ( *iret != 0 ) return; dg_getg ( &numu, &gru, &kxd, &kyd, &ksub1, &ksub2, iret ); dg_getg ( &numv, &grv, &kxd, &kyd, &ksub1, &ksub2, iret ); dg_getg ( &numout, &grout, &kxd, &kyd, &ksub1, &ksub2, iret ); kxyd = kxd * kyd; pd_drct ( gru, grv, &kxyd, grout, &ier ); /* * Make a name of the form 'DIR'//u and update header; * update the stack. */ dg_updh ( "DIR", &numout, &numu, &zero, iret ); dg_puts ( &numout, iret ); dg_esub ( &numout, &zero, &zero, &zero, &ier ); if ( ier != 0 ) *iret = ier; return; }
void dg_getv ( int *ignumu, int *ignumv, int *iret ) /************************************************************************ * dg_getv * * * * This subroutine gets the next operand on the stack. The operand * * must be a vector; otherwise, an error is returned. The internal * * grid numbers of the u and v components are returned. * * * * dg_getv ( ignumu, ignumv, iret ) * * * * Output parameters: * * *ignumu int Grid number for u-component * * *ignumv int Grid number for v-component * * *iret int Return code * * 0 = normal return * * -7 = grid cannot be found * * -8 = grid is the wrong size * * -9 = calling sequence error * * -10 = internal grid list full * * -11 = grid must be a vector * * -12 = grid must be a scalar * * -13 = grid must be in file * * -16 = map proj is invalid * * -17 = LEVEL must be a layer * * -18 = TIME must be a range * * -20 = stack is full * * -21 = stack is empty * * -22 = TIME is invalid * * -23 = LEVEL is invalid * * -24 = IVCORD is invalid * * -25 = Vector cannot be computed * ** * * Log: * * M. desJardins/GSFC 5/88 * * G. Huffman/GSC 9/88 Added retrieval of direct parm names * * G. Huffman/GSC 9/88 Error messages * * M. desJardins/GSFC 4/89 Eliminated direct parm names * * M. desJardins/NMC 3/92 WND, WIND = OBS * * K. Brill/NMC 4/93 Checked only for WND (set in DG_TOPV); * * Called DG_GOBS directly; Read any vector* * ABC as components UABC, VABC * * M. desJardins/NMC 8/93 Eliminated duplicate names * * T. Lee/GSC 5/96 Added input parameter check * * T. Lee/GSC 9/96 Removed input check; Changed error msg * * K. Brill/HPC 12/01 CALL DG_SSUB and DG_ESUB * * R. Tian/SAIC 2/06 Recoded from Fortran * C************************************************************************/ { char time1[21], time2[21], gvect[14], parm[14]; int level1, level2, ignum, ivcord, zero, ier; /*----------------------------------------------------------------------*/ *iret = 0; zero = 0; dg_ssub ( iret ); /* * Get grid information. */ dg_topv ( gvect, ignumu, ignumv, time1, time2, &level1, &level2, &ivcord, parm, iret ); if ( *iret != 0 ) return; /* * Check to see that the grid doesn't already exist in the internal * grid list. */ if ( strcmp ( gvect, "WND" ) != 0 && _dgstck.stack[_dgstck.itop][0] != '\0' ) { /* * Try to read the vector components from the file. */ strcpy ( parm, "U" ); strcat ( parm, gvect ); dg_rgrd ( time1, time2, &level1, &level2, &ivcord, parm, ignumu, &ier ); if ( ier == 0 ) { strcpy ( parm, "V" ); strcat ( parm, gvect ); dg_rgrd ( time1, time2, &level1, &level2, &ivcord, parm, ignumv, &ier ); if ( ier == 0 ) { _dgstck.stack[_dgstck.itop][0] = '\0'; } else { dg_frig ( ignumv, &ier ); } } else { dg_frig ( ignumu, &ier ); } } if ( _dgstck.stack[_dgstck.itop][0] != '\0' ) { /* * Check for various wind vectors to compute. */ if ( strcmp ( gvect, "WND" ) == 0 ) { dg_gobs ( time1, time2, &level1, &level2, &ivcord, ignumu, ignumv, iret ); if ( *iret == 0 ) { dg_rplv ( "", ignumu, ignumv, iret ); } } else if ( strcmp ( gvect, "GEO" ) == 0 ) { dv_geo ( iret ); } else if ( strcmp ( gvect, "AGE" ) == 0 ) { dv_age ( iret ); } else if ( strcmp ( gvect, "THRM" ) == 0 ) { dv_thrm ( iret ); } else if ( strcmp ( gvect, "ISAL" ) == 0 ) { dv_isal ( iret ); } else { *iret = -25; strcpy ( _dgerr.errst, gvect ); } /* * If the function was computed, get the grid numbers from * the top of the stack. */ if ( *iret == 0 ) { ignum = _dgstck.istack[_dgstck.itop]; *ignumu = ignum / 100; *ignumv = ignum % 100; } } /* * If the function was computed or already in DGG, decrement the * stack pointer. */ _dgstck.itop--; dg_esub ( ignumu, ignumv, &zero, &zero, &ier ); if ( ier != 0 ) *iret = ier; return; }
void df_le ( int *iret ) /************************************************************************ * df_le * * * * This subroutine checks if x1 is less than or equal to x2 and * * returns the result of comparison: * * 1 if x1 <= x2 * * 0 if x1 > x2 * * RMISS if either grid is missing * * * * df_le ( iret ) * * * * Input parameters: * * * * Output parameters: * * *iret int Return code * * 0 - normal return * ** * * Log: * * m.gamazaychikov/SAIC 09/05 * * R. Tian/SAIC 11/05 Recoded from Fortran * ************************************************************************/ { int num1, num2, num, kxd, kyd, ksub1, ksub2, i, im1, zero, ier; float *gnum1, *gnum2, *gnum, dg1, dg2; /*----------------------------------------------------------------------*/ *iret = 0; zero = 0; dg_ssub ( iret ); /* * Get two grids from the stack. */ dg_gets ( &num1, iret ); if ( *iret != 0 ) return; dg_gets ( &num2, iret ); if ( *iret != 0 ) return; /* * Get a new grid number and check the grids. */ dg_nxts ( &num, iret ); if ( *iret != 0 ) return; /* * Grid number to grid. */ dg_getg ( &num1, &gnum1, &kxd, &kyd, &ksub1, &ksub2, iret ); dg_getg ( &num2, &gnum2, &kxd, &kyd, &ksub1, &ksub2, iret ); dg_getg ( &num, &gnum, &kxd, &kyd, &ksub1, &ksub2, iret ); for ( i = ksub1; i <= ksub2; i++ ) { im1 = i - 1; dg1 = gnum1[im1]; dg2 = gnum2[im1]; if ( ERMISS ( dg1 ) || ERMISS ( dg2 ) ) { gnum[im1] = RMISSD; } else { if ( dg1 <= dg2 ) { gnum[im1] = 1.0; } else { gnum[im1] = 0.0; } } } /* * Get a name of the form 'LE'//S1//S2 and update header; * update stack. */ dg_updh ( "LE", &num, &num1, &num2, iret ); dg_puts ( &num, iret ); dg_esub ( &num, &zero, &zero, &zero, &ier ); if ( ier != 0 ) *iret = ier; return; }
void df_nmax ( int *iret ) /************************************************************************ * df_nmax * * * * This subroutine computes NMAX (S,ROI), the neigborhood maximum * * value of a scalar field (S) within some radius of influence * * (ROI; meters). Masking could be used [e.g., SGT(S1,S2)] to subset * * and filter the grid beforehand to allow for faster processing. * * * * df_nmax ( iret ) * * * * Output parameters: * * *iret int Return code * * As for DG_GETS * ** * * Log: * * C. Melick/SPC 06/12 * ************************************************************************/ { int num1, num2, num3, num, kxd, kyd, ksub1, ksub2, zero, indx, ier; int ixmscl, iymscl, jgymin, jgymax, jgxmin, jgxmax, idglat, idglon; int row, col, ibeg, iend, jbeg, jend, ibox, jbox, boxindx, nval; float gddx, gddy, gdspdx, gdspdy, radius; float *gnum1, *gnumn, *gkxms, *gkyms, *gnumroi, *glat, *glon, *dist; /*----------------------------------------------------------------------*/ *iret = 0; zero = 0; dg_ssub ( iret ); /* * Compute map scale factors. */ dg_mscl ( iret ); if ( *iret != 0 ) return; /* * Query DGCMN.CMN idglat/idglon. */ nval = 1; dg_iget ( "IDGLAT", &nval, &idglat, iret ); if ( *iret != 0 ) return; dg_iget ( "IDGLON", &nval, &idglon, iret ); if ( *iret != 0 ) return; /* * Get the grids from the stack. */ dg_gets ( &num1, iret ); if ( *iret != 0 ) return; dg_gets ( &num2, iret ); if ( *iret != 0 ) return; /* * Get a new grid number. */ dg_nxts ( &num3, iret ); if ( *iret != 0 ) return; dg_nxts ( &num, iret ); if ( *iret != 0 ) return; dg_qmsl ( &ixmscl, &iymscl, &gddx, &gddy, &ier ); dg_qbnd ( &jgxmin, &jgxmax, &jgymin, &jgymax, &ier ); dg_getg ( &num1, &gnum1, &kxd, &kyd, &ksub1, &ksub2, &ier ); dg_getg ( &num, &gnumn, &kxd, &kyd, &ksub1, &ksub2, &ier ); dg_getg ( &ixmscl, &gkxms, &kxd, &kyd, &ksub1, &ksub2, &ier ); dg_getg ( &iymscl, &gkyms, &kxd, &kyd, &ksub1, &ksub2, &ier ); dg_getg ( &num2, &gnumroi, &kxd, &kyd, &ksub1, &ksub2, &ier ); dg_getg ( &idglat, &glat, &kxd, &kyd, &ksub1, &ksub2, &ier ); dg_getg ( &idglon, &glon, &kxd, &kyd, &ksub1, &ksub2, &ier ); dg_getg ( &num3, &dist, &kxd, &kyd, &ksub1, &ksub2, &ier ); radius = gnumroi[0]; /* QC check on lower and upper bounds of radius of influence. */ if ( radius < 0 ) { radius = 0.0; printf ("\n WARNING : RADIUS value less than zero. " "Resetting to zero.\n"); } if ( radius > 0.5*gddx*(float)(kxd)) { radius = 0.5*gddx*(float)(kxd); printf ("\n WARNING : RADIUS value too high. " "Resetting to half the distance in X (%f meters).\n",radius); } /* * Loop over all grid points to initialize output grid. */ for ( row = jgymin; row <= jgymax; row++ ) { for ( col = jgxmin; col <= jgxmax; col++ ) { indx=(row-1)*kxd+(col-1); if ( ERMISS ( gnum1[indx] ) ) { gnumn[indx] = RMISSD; } else { gnumn[indx] = gnum1[indx]; } } } /* * Loop over all grid points to determine neighborhood maximum for each grid point. */ for ( row = jgymin; row <= jgymax; row++ ) { for ( col = jgxmin; col <= jgxmax; col++ ) { indx=(row-1)*kxd+(col-1); if ( ! ERMISS ( gnum1[indx] ) ) { gdspdx= gddx / gkxms[indx]; gdspdy= gddy / gkyms[indx]; /* Constructing box for each grid point */ ibeg = col- G_NINT(radius / gdspdx); iend = col+ G_NINT(radius / gdspdx); jbeg = row- G_NINT(radius / gdspdy); jend = row+ G_NINT(radius / gdspdy); if (ibeg < jgxmin) { ibeg = jgxmin; } if (iend > jgxmax) { iend = jgxmax; } if (jbeg < jgymin) { jbeg = jgymin; } if (jend > jgymax) { jend = jgymax; } for ( ibox = ibeg; ibox <= iend; ibox++ ) { for ( jbox = jbeg; jbox <= jend; jbox++ ) { boxindx=(jbox-1)*kxd+(ibox-1); if ((glat[indx] == glat[boxindx]) && (glon[indx] == glon[boxindx])) { dist[boxindx]=0.0; } else { /* Great Circle Distance calculation */ dist[boxindx] = acos(sin(glat[boxindx])*sin(glat[indx]) + cos(glat[boxindx])*cos(glat[indx])*cos((glon[boxindx])-(glon[indx]))); dist[boxindx] = RADIUS * dist[boxindx]; } /* Check maximum value if neighboring point is defined and within radius of influence. */ if ( (dist[boxindx] <= radius) && (! ERMISS ( gnum1[boxindx] ) ) ) { if ( gnum1[boxindx] > gnumn[indx] ) { gnumn[indx] = gnum1[boxindx]; } } } } for ( ibox = ibeg; ibox <= iend; ibox++ ) { for ( jbox = jbeg; jbox <= jend; jbox++ ) { boxindx=(jbox-1)*kxd+(ibox-1); /* Spreading the response around to surrounding undefined values */ if ( ERMISS ( gnum1[boxindx] ) ) { if (dist[boxindx] <= radius) { if ( ERMISS ( gnumn[boxindx] ) ) { gnumn[boxindx] = gnumn[indx]; } else if ( gnum1[indx] > gnumn[boxindx] ) { gnumn[boxindx] = gnum1[indx]; } } } } } } } } /* * Make a name of the form 'NMAX'//S and update header; * update stack. */ dg_updh ( "NMAX", &num, &num1, &num2, iret ); dg_puts ( &num, iret ); dg_esub ( &num, &zero, &zero, &zero, &ier ); if ( ier != 0 ) *iret = ier; return; }
void dv_squo ( int *iret ) /************************************************************************ * dv_squo * * * * This subroutine divides a scalar with each component of a vector: * * * * SQUO ( S, V ) = [ u/S, v/S ] * * * * SQUO generates a vector grid. * * * * dv_squo ( iret ) * * * * Output parameters: * * *iret int Return code * * As for DG_GETV * ** * * Log: * * J. Whistler/SSAI 3/91 Adapted from DV_SMUL * * K. Brill/HPC 1/02 CALL DG_SSUB and DG_ESUB * * S. Gilbert/NCEP 11/05 Translation from Fortran * ************************************************************************/ { const int zero=0; int num, nvecu, nvecv, noutu, noutv, ier; /*----------------------------------------------------------------------*/ *iret = 0; dg_ssub ( iret ); /* * Get the scalar and vector from the stack (grid numbers are used * in name generation). */ dg_gets ( &num, iret ); if ( *iret != 0 ) return; dg_getv ( &nvecu, &nvecv, iret ); if ( *iret != 0 ) return; /* * Put S and the u-component on the stack. */ dg_puts ( &num, iret ); if ( *iret != 0 ) return; dg_puts ( &nvecu, iret ); if ( *iret != 0 ) return; /* * Divides and get the grid off the stack. */ df_quo ( iret ); if ( *iret != 0 ) return; dg_gets ( &noutu, iret ); if ( *iret != 0 ) return; /* * Put S and the v-component on the stack. */ dg_puts ( &num, iret ); if ( *iret != 0 ) return; dg_puts ( &nvecv, iret ); if ( *iret != 0 ) return; /* * Divides and get the grid off the stack. */ df_quo ( iret ); if ( *iret != 0 ) return; dg_gets ( &noutv, iret ); if ( *iret != 0 ) return; /* * Make a name of the form 'SQUO'//S//u2 and update both grid * headers; update the stack. */ dg_updv ("SQUO", &noutu, &noutv, &num, &nvecu, iret ); dg_putv ( &noutu, &noutv, iret ); dg_esub ( &noutu, &noutv, &zero, &zero, &ier ); if ( ier != 0 ) *iret = ier; return; }
void df_lav ( int *iret ) /************************************************************************ * df_lav * * * * This subroutine computes the layer average of a scalar grid: * * * * LAV (S) = [ S (level1) + S (level2) ] / 2. * * * * df_lav ( iret ) * * * * Output parameters: * * *iret int Return code * * As for DG_GETS * ** * * Log: * * M. desJardins/GSFC 10/85 * * M. desJardins/GSFC 7/88 Added new stack subroutines * * G. Huffman/GSC 9/88 Error messages * * K. Brill/GSC 8/89 Subsetting * * K. Brill/GSC 10/89 Subsetting * * T. Lee/GSC 4/96 Single dimension for dgg * * K. Tyle/GSC 5/96 Moved IGDPT outside do-loop * * K. Brill/HPC 1/02 CALL DG_SSUB and DG_ESUB * * K. Brill/HPC 11/02 Eliminate use of the SUBA logical array * * R. Tian/SAIC 10/05 Recoded from Fortran * ************************************************************************/ { int num1, num2, num, kxd, kyd, ksub1, ksub2, zero, fidx, cidx, ier; float *gnum1, *gnum2, *gnum, dg1, dg2; /*----------------------------------------------------------------------*/ *iret = 0; zero = 0; dg_ssub ( iret ); /* * Get the two grids. */ dg_getl ( &num1, &num2, iret ); if ( *iret != 0 ) return; /* * Get a new grid. */ dg_nxts ( &num, iret ); if ( *iret != 0 ) return; /* * Grid number to grid. */ dg_getg ( &num1, &gnum1, &kxd, &kyd, &ksub1, &ksub2, iret ); dg_getg ( &num2, &gnum2, &kxd, &kyd, &ksub1, &ksub2, iret ); dg_getg ( &num, &gnum, &kxd, &kyd, &ksub1, &ksub2, iret ); /* * Average the grids. */ for ( fidx = ksub1; fidx <= ksub2; fidx++ ) { cidx = fidx - 1; dg1 = gnum1[cidx]; dg2 = gnum2[cidx]; if ( ERMISS (dg1) || ERMISS (dg2) ) { gnum[cidx] = RMISSD; } else { gnum[cidx] = ( dg1 + dg2 ) / 2.; } } /* * Make a name of the form 'LAV'//S and update header; * update stack. */ dg_updh ( "LAV", &num, &num1, &num2, iret ); dg_puts ( &num, iret ); dg_esub ( &num, &zero, &zero, &zero, &ier ); if ( ier != 0 ) *iret = ier; return; }
void de_swsprd ( const char *uarg, char *stprm, int *iret ) /************************************************************************ * de_swsprd * * * * This subroutine computes the weighted ensemble spread of its scalar * * argument. * * * * de_swsprd ( uarg, stprm, iret ) * * * * Input and parameters: * * *uarg const char Function argument string * * * * Output parameters: * * *stprm char Substitution string * * *iret int Return code * * 0 = normal return * * -8 = cannot parse argument * * -9 = ensemble cannot computed * ** * * Log: * * m.gamazaychikov/SAIC 01/08 From de_ssprd * * m.gamazaychikov/SAIC 01/08 Fixed the calculation problem * * S. Jacobs/NCEP 8/09 Use double arrays internally * * K. Brill/HPC 11/10 Set any negative sqrt argument to zero * ************************************************************************/ { char tname[13], pdum[13], time1[21], time2[21]; char **argu; int ns, ns2, num, kxd, kyd, ksub1, ksub2, level1, level2, ivcord, nina, one, zero, i, j, ier, narg, numw, nsw; float *gns, *gnum, *gwgt, *gnumw; double *dgns, *dgns2, d1, d2, d3, d4; /*----------------------------------------------------------------------*/ *iret = 0; one = 1; zero = 0; dg_ssub ( iret ); /* * Get new grid numbers. */ dg_nxts ( &ns, iret ); if ( *iret != 0 ) return; dg_nxts ( &ns2, iret ); if ( *iret != 0 ) return; /* * Initialize the output grid. */ dg_getg ( &ns, &gns, &kxd, &kyd, &ksub1, &ksub2, iret ); G_MALLOC(dgns, double, kxd*kyd, "DE_SWSPRD"); G_MALLOC(dgns2, double, kxd*kyd, "DE_SWSPRD"); for ( i = ksub1 - 1; i < ksub2; i++ ) { gns[i] = 0.; dgns[i] = 0.; dgns2[i] = 0.; } /* * Set the number of input arguments. There could be two arguments. */ for ( i = 0; i < MXARGS; i++ ) { _ensdiag.allarg[i][0] = '\0'; } nina = 2; argu = (char **)cmm_malloc2d ( 2, LLMXLN, sizeof(char), &ier ); cst_clst ( (char *)uarg, '&', " ", nina, LLMXLN, argu, &narg, &ier ); for ( i = 0; i < narg; i++ ) { strcpy ( _ensdiag.allarg[i], argu[i] ); if ( i > 0 && strcmp(argu[i], " ") == 0 ) { cst_rlch ( RMISSD, 1, _ensdiag.allarg[i], &ier ); } } cmm_free2d ( (void **) argu, &ier ); if ( narg < 1 ) { *iret = -15; return; } else if ( narg == 1 ) { cst_rlch ( RMISSD, 1, _ensdiag.allarg[1], &ier ); } else if ( narg == 2 ) { dg_nxts ( &nsw, iret ); if ( *iret != 0 ) return; dg_getg ( &nsw, &gwgt, &kxd, &kyd, &ksub1, &ksub2, iret ); for ( i = ksub1 - 1; i < ksub2; i++ ) { gwgt[i] = 0.; } } /* * Scan the allarg array. */ de_scan ( &narg, iret ); if ( *iret != 0 ) return; /* * Loop over number of members set by DE_SCAN. */ for ( i = 0; i < _ensdiag.nummbr; i++ ) { if ( narg == 2 ) { de_mset ( &i, iret ); /* * Compute weight grid and retrieve it from the stack. */ dg_pfun ( _ensdiag.allarg[1], iret ); if ( *iret != 0 ) { er_wmsg ( "DG", iret, " ", &ier, strlen("DG"), strlen(" ") ); *iret = -8; return; } dg_driv ( &one, iret ); if ( *iret != 0 ) { er_wmsg ( "DG", iret, _ensdiag.allarg[1], &ier, strlen("DG"), strlen(_ensdiag.allarg[1]) ); *iret = -9; return; } dg_tops ( tname, &numw, time1, time2, &level1, &level2, &ivcord, pdum, iret ); dg_getg ( &numw, &gnumw, &kxd, &kyd, &ksub1, &ksub2, iret ); /* * Compute field grid and retrieve it from the stack. */ dg_pfun ( _ensdiag.allarg[0], iret ); if ( *iret != 0 ) { er_wmsg ( "DG", iret, " ", &ier, strlen("DG"), strlen(" ") ); *iret = -8; return; } dg_driv( &one, iret ); if ( *iret != 0 ) { er_wmsg ( "DG", iret, _ensdiag.allarg[0], &ier, strlen("DG"), strlen(_ensdiag.allarg[0]) ); *iret = -9; return; } /* * Retrieve the output grid from the stack. Check that the * output is a scalar. */ dg_tops ( tname, &num, time1, time2, &level1, &level2, &ivcord, pdum, iret ); dg_getg ( &num, &gnum, &kxd, &kyd, &ksub1, &ksub2, iret ); for ( j = ksub1 - 1; j < ksub2; j++ ) { d1 = gnum[j]; d2 = dgns[j]; d3 = dgns2[j]; d4 = gnumw[j]; if ( ERMISS ( d1 ) || ERMISS ( d2 ) || ERMISS ( d3 ) || ERMISS ( d4 ) ) { dgns[j] = RMISSD; dgns2[j] = RMISSD; gwgt[j] = RMISSD; } else { dgns[j] += d1 * d4; dgns2[j] += d1 * d1 * d4; gwgt[j] += d4; } } dg_frig ( &numw, &ier ); dg_frig ( &num, &ier ); } else if ( narg == 1 ) { de_mset ( &i, iret ); dg_pfun ( _ensdiag.allarg[0], iret ); if ( *iret != 0 ) { er_wmsg ( "DG", iret, " ", &ier, strlen("DG"), strlen(" ") ); *iret = -8; return; } dg_driv( &one, iret ); if ( *iret != 0 ) { er_wmsg ( "DG", iret, _ensdiag.allarg[0], &ier, strlen("DG"), strlen(_ensdiag.allarg[0]) ); *iret = -9; return; } /* * Retrieve the output grid from the stack. Check that the * output is a scalar. */ dg_tops ( tname, &num, time1, time2, &level1, &level2, &ivcord, pdum, iret ); dg_getg ( &num, &gnum, &kxd, &kyd, &ksub1, &ksub2, iret ); for ( j = ksub1 - 1; j < ksub2; j++ ) { d1 = gnum[j]; d2 = dgns[j]; d3 = dgns2[j]; if ( ERMISS ( d1 ) || ERMISS ( d2 ) || ERMISS ( d3 ) ) { dgns[j] = RMISSD; dgns2[j] = RMISSD;; } else { dgns[j] += d1 * _ensdiag.enswts[i]; dgns2[j] += d1 * d1 * _ensdiag.enswts[i]; } } dg_frig ( &num, &ier ); } } /* * Compute Variance. */ for ( i = ksub1 - 1; i < ksub2; i++ ) { d2 = dgns[i]; d3 = dgns2[i]; if ( ERMISS ( d2 ) || ERMISS ( d3 ) ) { dgns[i] = RMISSD; } else { if ( narg == 2) { d1 = gwgt[i]; if ( ERMISS ( d1 ) ) { dgns[i] = RMISSD; } else { dgns[i] = dgns[i]/gwgt[i]; dgns[i] = dgns2[i]/gwgt[i] - dgns[i] * dgns[i]; } } else if ( narg == 1 ) { dgns[i] = dgns2[i] - dgns[i] * dgns[i]; } } } /* * Compute spread (standard deviation). */ for ( i = ksub1 - 1; i < ksub2; i++ ) { d2 = dgns[i]; if ( ERMISS ( d2 ) ) { dgns[i] = RMISSD; } else { if ( dgns[i] < 0.0 ) { dgns[i] = 0.0; } dgns[i] = sqrt ( dgns[i] ); } } /* * Assign the result to the output array and free the internal arrays. */ for ( i = ksub1 - 1; i < ksub2; i++ ) { gns[i] = (float)dgns[i]; } G_FREE(dgns, double); G_FREE(dgns2, double); /* * Reset DGCMN.CMN and set internal grid identifier. */ de_rset ( iret ); dg_udig ( "EXX_", &ns, &zero, &_ensdiag.idgens, stprm, iret ); dg_esub ( &ns, &zero, &zero, &zero, &ier ); if ( ier != 0 ) *iret = ier; return; }
void df_rdfs ( int *iret ) /************************************************************************ * DF_RDFS (Resolution Dependent Filter for Scalar) * * * * This subroutine smoothes a scalar grid using a moving average * * low-pass filter whose weights are determined by the normal * * (Gaussian) probability distribution function for two dimensions. * * The weight given to any grid point within the area covered by the * * moving average for a target grid point is proportional to * * * * EXP [ -( D ** 2 ) ], * * * * where D is the distance from that point to the target point divided * * by the standard deviation of the normal distribution. The value of * * the standard deviation is determined by the degree of filtering * * requested. The degree of filtering is specified by giving an * * effective resolution in km for the output grid. From this value, * * an integer required as the input for the GWFS function is computed. * * * * See the documentation for the GWFS function for more details. * * * * When this function is invoked, the first argument is the grid to be * * smoothed, the second is the effective resolution as described above: * * * * RDFS ( S, dx ) * * * * where dx > 0. If the value of dx is less than the grid spacing * * on the internal grid, no filtering is done. * * * * DF_RDFS ( IRET ) * * * * Output parameters: * * IRET INTEGER Return code * * As for DG_GETS * ** * * Log: * * K. Brill/HPC 05/12 Developed from DF_GWFS * ************************************************************************/ { int nnw, kxd, kyd, ksub1, ksub2, zero, ier; int jj, ii, indx; int ixm, iym, ni, no; float *gnnw, *gnost; float gdx, gdy, dsg, eres, swl; /*----------------------------------------------------------------------*/ *iret = 0; zero = 0; dg_ssub ( iret ); /* * Compute map scale factors and grid increments. */ dg_mscl ( iret ); if ( *iret != 0 ) return; /* * Get the grid spacing values: */ dg_qmsl ( &ixm, &iym, &gdx, &gdy, iret ); if ( *iret != 0 ) return; if ( gdx > gdy ) { dsg = gdx; } else { dsg = gdy; } dsg = dsg / 1000.0; /*printf (" dsg = %f\n", dsg ); */ /* * Get the input grid number. */ dg_gets ( &ni, iret ); if ( *iret != 0 ) return; /* * Get the user specified effective resolution (km). */ dg_gets ( &nnw, iret ); if ( *iret != 0 ) return; dg_getg ( &nnw, &gnnw, &kxd, &kyd, &ksub1, &ksub2, iret ); eres = gnnw[0]; if ( eres < dsg ) { /*printf ( " No smoothing\n" );*/ /* * Do nothing -- return original grid without smoothing. */ /* * Make a name of the form 'RDF'//S and update header; * update stack. */ dg_updh ( "RDF", &ni, &ni, &zero, iret ); dg_puts ( &ni, iret ); dg_esub ( &ni, &zero, &zero, &zero, &ier ); if ( ier != 0 ) *iret = ier; return; } else { /* * Call the GWFS program to smooth the grid. The smoother footprint is chosen so as so suppress the 2 delta X wave on the coarse grid to 1/e of the original amplitude. */ swl = (float)G_NINT ( ( eres / dsg ) * 2.0 ); /*printf (" Smooth with footprint = %f\n", swl);*/ /* * Get a new grid number for the output. */ dg_nxts ( &no, iret ); if ( *iret != 0 ) return; dg_getg ( &no, &gnost, &kxd, &kyd, &ksub1, &ksub2, iret ); for ( jj = 1; jj <= kyd; jj++ ) { for ( ii = 1; ii <= kxd; ii++ ) { indx = ( jj - 1 ) * kxd + ii; gnost[indx-1] = swl; } } /* * Put two grids on the stack for the Gaussing weighted filter. */ dg_puts ( &no, iret ); if ( *iret != 0 ) return; dg_puts ( &ni, iret ); if ( *iret != 0 ) return; df_gwfs ( iret ); } return; }
void dv_def ( int *iret ) /************************************************************************ * dv_def * * * * This subroutine computes the total deformation of a vector: * * * * DEF ( V ) = ( STR (V) ** 2 + SHR (V) ** 2 ) ** .5 * * * * DEF generates a scalar grid. * * * * dv_def ( iret ) * * * * Output parameters: * * *iret int Return code * * As for DG_GETV * ** * * Log: * * M. desJardins/GSFC 10/85 * * I. Graffman/RDS 7/88 Call to DG_UPDH * * G. Huffman/GSC 9/88 New stack functions * * G. Huffman/GSC 9/88 Error messages * * K. Brill/GSC 8/89 Subsetting * * K. Brill/GSC 10/89 Subsetting * * T. Lee/GSC 4/96 Single dimension for dgg * * T. Lee/GSC 5/96 Moved IGDPT outside DO loop * * K. Brill/HPC 1/02 CALL DG_SSUB and DG_ESUB * * K. Brill/HPC 11/02 Eliminate use of the SUBA logical array * * S. Gilbert/NCEC 11/05 Translation from Fortran * ************************************************************************/ { int i, kxd, kyd, ksub1, ksub2, ier, zero=0; int numu, numv, nstr, nshr, numout; float *grstr, *grshr, *grout; float dshr, dstr; /*------------------------------------------------------------------------*/ *iret = 0; dg_ssub ( iret ); /* * Get the vector grid. */ dg_getv ( &numu, &numv, iret ); if ( *iret != 0 ) return; /* * Put the vector on the stack, compute the stretching deformation, * and get the result. */ dg_putv ( &numu, &numv, iret ); if ( *iret != 0 ) return; dv_str ( iret ); if ( *iret != 0 ) return; dg_gets ( &nstr, iret ); if ( *iret != 0 ) return; /* * Put the vector on the stack, compute the shearing deformation, * and get the result. */ dg_putv ( &numu, &numv, iret ); if ( *iret != 0 ) return; dv_shr ( iret ); if ( *iret != 0 ) return; dg_gets ( &nshr, iret ); if ( *iret != 0 ) return; /* * Get a number for the deformation grid and compute DEF */ dg_nxts ( &numout, iret ); if ( *iret != 0 ) return; dg_getg ( &nshr, &grshr, &kxd, &kyd, &ksub1, &ksub2, iret ); dg_getg ( &nstr, &grstr, &kxd, &kyd, &ksub1, &ksub2, iret ); dg_getg ( &numout, &grout, &kxd, &kyd, &ksub1, &ksub2, iret ); for ( i = ksub1 - 1; i < ksub2; i++ ) { dshr = grshr[i]; dstr = grstr[i]; if ( ERMISS (dshr) || ERMISS (dstr) ) grout[i] = RMISSD; else grout[i] = (float) sqrt (dshr*dshr + dstr*dstr); } /* * Make a name of the form 'DEF'//u and update header; * update stack. */ dg_updh ( "DEF", &numout, &numu, &zero, iret ); dg_puts ( &numout, iret ); dg_esub ( &numout, &zero, &zero, &zero, &ier ); if ( ier != 0 ) *iret = ier; return; }
void dv_shr ( int *iret ) /************************************************************************ * dv_shr * * * * This subroutine computes the shearing deformation of a vector: * * * * SHR ( V ) = DDX ( v ) + DDY ( u ) + v * {(mx/my)*[d(my)/dx]} * * + u * {(my/mx)*[d(mx)/dy]} * * * * where mx and my are scale factors along x and y, respectively. * * The quantities in braces are assumed to exist in common arrays * * YMSDX and XMSDY, respectively. SHR generates a scalar grid. * * * * dv_shr ( iret ) * * * * Output parameters: * * *iret int Return code * * As for DG_GETV * ** * * Log: * * M. desJardins/GSFC 10/85 * * I. Graffman/RDS 7/88 Call to DG_UPDH * * G. Huffman/GSC 9/88 New stack functions * * G. Huffman/GSC 9/88 Error messages * * K. Brill/GSC 4/89 Map scale factor code * * K. Brill/GSC 8/89 Subsetting * * K. Brill/GSC 10/89 Subsetting * * T. Lee/GSC 4/96 Single dimension for dgg * * T. Lee/GSC 5/96 Moved IGDPT outside DO loop * * K. Brill/HPC 1/02 CALL DG_SSUB and DG_ESUB * * K. Brill/HPC 5/02 Eliminate LLMXGD declarations in DGCMN * * using int grds for scl fctr derivatives * * K. Brill/HPC 11/02 Eliminate use of the SUBA logical array * * S. Gilbert/NCEP 11/05 Translation from Fortran * ************************************************************************/ { const int zero=0; int i, ier, nval, kxd, kyd, ksub1, ksub2; int numu, numv, nddx, nddy, ixmsdy, iymsdx, numout; float *gru, *grv, *grddx, *grddy, *grxmdy, *grymdx, *grout; float dx, dy, vv, dd; /*----------------------------------------------------------------------*/ *iret = 0; dg_ssub ( iret ); /* * Get the vector. */ dg_getv ( &numu, &numv, iret ); if ( *iret != 0 ) return; /* * Put the v component on the stack, compute DDX, and get the result. */ dg_puts ( &numv, iret ); if ( *iret != 0 ) return; df_ddx ( iret ); if ( *iret != 0 ) return; dg_gets ( &nddx, iret ); if ( *iret != 0 ) return; /* * Put the u component on the stack, compute DDY, and get the result. */ dg_puts ( &numu, iret ); if ( *iret != 0 ) return; df_ddy ( iret ); if ( *iret != 0 ) return; dg_gets ( &nddy, iret ); if ( *iret != 0 ) return; /* * Compute map scale factor derivative coefficients. */ dg_dmsf ( iret ); if ( *iret != 0 ) return; nval = 1; dg_iget ( "IXMSDY", &nval, &ixmsdy, iret ); dg_iget ( "IYMSDX", &nval, &iymsdx, iret ); dg_getg ( &ixmsdy, &grxmdy, &kxd, &kyd, &ksub1, &ksub2, iret ); dg_getg ( &iymsdx, &grymdx, &kxd, &kyd, &ksub1, &ksub2, iret ); /* * Get a new grid and compute the shearing deformation. */ dg_nxts ( &numout, iret ); if ( *iret != 0 ) return; dg_getg ( &numu, &gru, &kxd, &kyd, &ksub1, &ksub2, iret ); dg_getg ( &numv, &grv, &kxd, &kyd, &ksub1, &ksub2, iret ); dg_getg ( &nddx, &grddx, &kxd, &kyd, &ksub1, &ksub2, iret ); dg_getg ( &nddy, &grddy, &kxd, &kyd, &ksub1, &ksub2, iret ); dg_getg ( &numout, &grout, &kxd, &kyd, &ksub1, &ksub2, iret ); for ( i = ksub1 - 1; i < ksub2; i++ ) { dx = grddx[i]; dy = grddy[i]; dd = gru[i]; vv = grv[i]; if ( ERMISS (dx) || ERMISS (dy) || ERMISS (dd) || ERMISS (vv) ) grout[i] = RMISSD; else grout[i] = dx + dy + dd * grxmdy[i] + vv * grymdx[i] ; } /* * Make a name of the form 'SHR'//u and update header; * update the stack. */ dg_updh ( "SHR", &numout, &numu, &zero, iret ); dg_puts ( &numout, iret ); dg_esub ( &numout, &zero, &zero, &zero, &ier ); if ( ier != 0 ) *iret = ier; return; }
void de_srng ( const char *uarg, char *stprm, int *iret ) /************************************************************************ * de_srng * * * * This subroutine computes the range of its scalar arguments among * * ensemble members. The range is the difference between the maximum * * and the minimum. * * * * de_srng ( uarg, stprm, iret ) * * * * Input and parameters: * * *uarg const char Function argument string * * * * Output parameters: * * *stprm char Substitution string * * *iret int Return code * * 0 = normal return * * -8 = cannot parse argument * * -9 = ensemble cannot computed * ** * * Log: * * R. Tian/SAIC 6/05 * * R. Tian/SAIC 1/06 Translated from Fortran * ************************************************************************/ { char tname[13], pdum[13], time1[21], time2[21]; int nsmax, nsmin, num, kxd, kyd, ksub1, ksub2, level1, level2, ivcord, nina, one, zero, i, j, ier; float *gnsmax, *gnsmin, *gnum, d1, d2, d3; /*----------------------------------------------------------------------*/ *iret = 0; one = 1; zero = 0; dg_ssub ( iret ); /* * Get new grid numbers for maximum and minimum fields. */ dg_nxts ( &nsmax, iret ); if ( *iret != 0 ) return; dg_nxts ( &nsmin, iret ); if ( *iret != 0 ) return; /* * Initialize the output grid. */ dg_getg ( &nsmax, &gnsmax, &kxd, &kyd, &ksub1, &ksub2, iret ); dg_getg ( &nsmin, &gnsmin, &kxd, &kyd, &ksub1, &ksub2, iret ); for ( i = ksub1 - 1; i < ksub2; i++ ) { gnsmax[i] = -FLT_MAX; gnsmin[i] = FLT_MAX; } /* * Set the number of input arguments. There is only one argument * for DE_SRNG. */ nina = 1; for ( i = 0; i < MXARGS; i++ ) { _ensdiag.allarg[i][0] = '\0'; } strcpy ( _ensdiag.allarg[0], uarg ); /* * Scan the allarg array. */ de_scan ( &nina, iret ); if ( *iret != 0 ) return; /* * Loop over number of members set by DE_SCAN. */ for ( i = 0; i < _ensdiag.nummbr; i++ ) { de_mset ( &i, iret ); dg_pfun ( _ensdiag.allarg[0], iret ); if ( *iret != 0 ) { er_wmsg ( "DG", iret, " ", &ier, strlen("DG"), strlen(" ") ); *iret = -8; return; } dg_driv ( &one, iret ); if ( *iret != 0 ) { er_wmsg ( "DG", iret, _ensdiag.allarg[0], &ier, strlen("DG"), strlen(_ensdiag.allarg[0]) ); *iret = -9; return; } /* * Retrieve the output grid from the stack. Check that the * output is a scalar. */ dg_tops ( tname, &num, time1, time2, &level1, &level2, &ivcord, pdum, iret ); dg_getg ( &num, &gnum, &kxd, &kyd, &ksub1, &ksub2, iret ); /* * Compute the maximum and minimum. */ for ( j = ksub1 - 1; j < ksub2; j++ ) { d1 = gnum[j]; d2 = gnsmax[j]; d3 = gnsmin[j]; if ( ERMISS ( d1 ) ) { gnsmax[j] = RMISSD; gnsmin[j] = RMISSD; } else { if ( ! ERMISS ( d2 ) ) { gnsmax[j] = G_MAX ( d1, d2 ); } if ( ! ERMISS ( d2 ) ) { gnsmin[j] = G_MIN ( d1, d3 ); } } } dg_frig ( &num, &ier ); } /* * Compute the range. */ for ( i = ksub1 - 1; i < ksub2; i++ ) { d1 = gnsmax[i]; d2 = gnsmin[i]; if ( ERMISS ( d1 ) || ERMISS ( d2 ) ) { gnsmax[i] = RMISSD; } else { gnsmax[i] = d1 - d2; } } dg_frig ( &nsmin, &ier ); /* * Reset DGCMN.CMN and set internal grid identifier. */ de_rset ( iret ); dg_udig ( "EXX_", &nsmax, &zero, &_ensdiag.idgens, stprm, iret ); dg_esub ( &nsmax, &zero, &zero, &zero, &ier ); if ( ier != 0 ) *iret = ier; return; }