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;
}
