void pd_sped ( const float *uwnd, const float *vwnd, const int *np,
float *sped, int *iret )
/************************************************************************
* pd_sped *
* *
* This subroutine computes SPED from UWND and VWND. The following *
* equation is used: *
* *
* SPED = SQRT ( (UWND**2) + (VWND**2) ) *
* *
* pd_sped ( uwnd, vwnd, np, sped, iret ) *
* *
* Input parameters: *
* *uwnd const float U component *
* *vwnd const float V component *
* *np const int Number of points *
* *
* Output parameters: *
* *sped float Wind speed *
* *iret int Return code *
* 0 = normal return *
** *
* Log: *
* M. desJardins/GSFC 7/89 GEMPAK 5 *
* K. Brill/HPC 11/02 Remove SUBFLG input logical array *
* R. Tian/SAIC 9/05 Translated from FORTRAN *
************************************************************************/
{
float uuu, vvv;
int npt, i;
/*----------------------------------------------------------------------*/
*iret = 0;
npt = *np;
/*
* Loop through all the points.
*/
for ( i = 0; i < npt; i++ ) {
uuu = uwnd [i];
vvv = vwnd [i];
/*
* Check for missing data.
*/
if ( ERMISS ( uuu ) || ERMISS ( vvv ) ) {
sped [i] = RMISSD;
} else {
sped [i] = sqrt ( uuu * uuu + vvv * vvv );
}
}
return;
}
void pd_totl ( const float *t850, const float *td850, const float *t500,
const int *np, float *totl, int *iret )
/************************************************************************
* pd_totl *
* *
* This subroutine computes TOTL from t850, td850, and t500. *
* The following equation is used: *
* *
* TOTL = the total totals index *
* = (t850 - t500) + (td850 - t500) *
* *
* pd_totll( t850, td850, t500, np, totl, iret ) *
* *
* Input parameters: *
* *t850 const float 850 mb temperature in Celsius *
* *td850 const float 850 mb dewpoint in Celsius *
* *t500 const float 500 mb temperature in Celsius *
* *np const int Number of points *
* *
* Output parameters: *
* *totl float The Total Totals Index *
* *iret int Return code *
* 0 = normal return *
** *
* Log: *
* D. Keiser/GSC 7/95 *
* K. Brill/HPC 11/02 Remove SUBFLG input logical array *
* R. Tian/SAIC 9/05 Translated from FORTRAN *
************************************************************************/
{
int npt, i;
/*----------------------------------------------------------------------*/
*iret = 0;
npt = *np;
/*
* Loop through all the points.
*/
for ( i = 0; i < npt; i++ ) {
/*
* Check for missing data.
*/
if ( ( ERMISS ( t850 [i] ) ) || ( ERMISS ( td850 [i] ) ) ||
( ERMISS ( t500 [i] ) ) ) {
totl [i] = RMISSD;
} else {
/*
* Find the total totals index.
*/
totl [i] = ( t850 [i] - t500 [i] ) + ( td850 [i] - t500 [i] );
}
}
}
void pd_shmr ( const float *spfh, const int *np, float *mixr, int *iret )
/************************************************************************
* pd_shmr *
* *
* This subroutine computes MIXR from SPFH. The following equation is *
* used: *
* *
* MIXR = SPFC / ( 1 - SPFH ) . *
* *
* pd_shmr ( spfh, np, mixr, iret ) *
* *
* Input parameters: *
* *spfh const float Specific humidity in g/g *
* *np const int Number of points *
* *
* Output parameters: *
* *mixr float Mixing ratio in g/g *
* *iret int Return code *
* 0 = normal return *
** *
* Log: *
* J. Whistler/SSAI 5/91 *
* K. Brill/HPC 11/02 Remove SUBFLG input logical array *
* R. Tian/SAIC 9/05 Translated from FORTRAN *
************************************************************************/
{
int npt, i;
/*----------------------------------------------------------------------*/
*iret = 0;
npt = *np;
/*
* Loop through all the points.
*/
for ( i = 0; i < npt; i++ ) {
/*
* Check for missing data.
*/
if ( ERMISS ( spfh [i] ) ) {
mixr [i] = RMISSD;
} else {
/*
* Calculate mixing ratio.
*/
mixr [i] = spfh [i] / ( 1.0F - spfh [i] );
}
}
return;
}
void pd_knms ( const float *sknt, const int *np, float *sped, int *iret )
/************************************************************************
* pd_knms *
* *
* This subroutine computes SPED from SKNT. The following equation is *
* used: *
* *
* SPED = SKNT / 1.9425 *
* *
* pd_knms ( sknt, np, sped, iret ) *
* *
* Input parameters: *
* *sknt const float Speed in knots *
* *np const int Number of points *
* *
* Output parameters: *
* *sped float Speed in meters/second *
* iret int Return code *
* 0 = normal return *
** *
*Log: *
* M. desJardins/GSFC 7/89 GEMPAK 5 *
* L. Sager/NCEP 4/96 Updated value of knots to m/sec *
* conversion *
* K. Brill/HPC 11/02 Remove SUBFLG input logical array *
* R. Tian/SAIC 9/05 Translated from FORTRAN *
************************************************************************/
{
int npt, i;
/*----------------------------------------------------------------------*/
*iret = 0;
npt = *np;
/*
* Loop through all the points.
*/
for ( i = 0; i < npt; i++ ) {
/*
* Check for missing data.
*/
if ( ERMISS ( sknt [i] ) ) {
sped [i] = RMISSD;
} else {
sped [i] = sknt [i] / 1.9425F;
}
}
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 df_gele ( int *iret )
/************************************************************************
* df_gele *
* *
* This subroutine checks if x1 is greater than or equal to x2 and *
* less than or equal to x3 and returns the result of comparison: *
* 1 if x1 >= x2 and x1 <= x3 *
* 0 otherwise *
* RMISS if either grid is missing *
* *
* df_gele ( 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, fidx, cidx,
zero, ier;
float *gnum1, *gnum2, *gnum3, *gnum, dg1, dg2, dg3;
/*----------------------------------------------------------------------*/
*iret = 0;
zero = 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 ( fidx = ksub1; fidx <= ksub2; fidx++ ) {
cidx = fidx - 1;
dg1 = gnum1[cidx];
dg2 = gnum2[cidx];
dg3 = gnum3[cidx];
if ( ERMISS ( dg1 ) || ERMISS ( dg2 ) || ERMISS ( dg3 ) ) {
gnum[cidx] = RMISSD;
} else {
if ( ( dg1 >= dg2 ) && ( dg1 <= dg3 ) ) {
gnum[cidx] = 1.0;
} else {
gnum[cidx] = 0.0;
}
}
}
/*
* Get a name of the form 'GELE'//S1//S2//S3 and update header;
* update stack.
*/
dg_updh ( "GELE", &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_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 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_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 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 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 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 pd_thta ( const float *tmpc, const float *pres, const int *np,
float *thta, int *iret )
/************************************************************************
* pd_thta *
* *
* This subroutine computes THTA from TMPC and PRES using Poisson's *
* equation: *
* *
* THTA = TMPK * ( 1000 / PRES ) ** RKAPPA *
* *
* It can also be used to compute STHA from TMPC and PALT, THTV from *
* TVRC and PRES, and THTV from TVRC and PALT. *
* *
* pd_thta ( tmpc, pres, np, thta, iret ) *
* *
* Input parameters: *
* *tmpc const float Temperature in Celsius *
* *pres const float Pressure in millibars *
* *np const int Number of points *
* *
* Output parameters: *
* *thta float Potential temperature in K *
* *iret int Return code *
* 0 = normal return *
** *
* Log: *
* M. desJardins/GSFC 7/89 GEMPAK 5 *
* G. Krueger/EAI 4/96 Replaced C->K constant with TMCK *
* K. Brill/HPC 11/02 Remove SUBFLG input logical array *
* R. Tian/SAIC 9/05 Translated from FORTRAN *
************************************************************************/
{
float tmpk;
int npt, i;
/*----------------------------------------------------------------------*/
*iret = 0;
npt = *np;
/*
* Loop through all the points.
*/
for ( i = 0; i < npt; i++ ) {
/*
* Check for missing data.
*/
if ( ( ERMISS ( tmpc [i] ) ) || ( ERMISS ( pres [i] ) ) ||
( pres [i] <= 0.0F ) ) {
thta [i] = RMISSD;
} else {
/*
* Change temperature in Celsius to Kelvin.
*/
tmpk = tmpc [i] + TMCK;
/*
* Calculate theta.
*/
thta [i] = tmpk * pow ( 1000.0F / pres [i], RKAPPA ) ;
}
}
return;
}
void dv_vge ( int *iret )
/************************************************************************
* dv_vge *
* *
* This subroutine finds values of the magnitude of V which are greater *
* than or equal to S. *
* *
* VGE (V, S) IF |V| >= S THEN V ELSE RMISSD *
* *
* dv_vge ( iret ) *
* *
* Output parameters: *
* *iret int Return code *
* As for DG_GETS *
** *
* Log: *
* S. Maxwell/GSC 8/97 *
* S. Maxwell/GSC 8/97 Corrected header documentation *
* K. Brill/HPC 1/02 CALL DG_SSUB, DG_ESUB; CHK iret & RTRN *
* 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 numu, numv, num1, nmag, nu, nv;
float *grnumu, *grnumv, *grnum1, *grmag, *gru, *grv;
/*----------------------------------------------------------------------*/
*iret = 0;
dg_ssub ( iret );
/*
* Get the vector and the scalar.
*/
dg_getv ( &numu, &numv, iret );
if ( *iret != 0 ) return;
dg_gets ( &num1, iret );
if ( *iret != 0 ) return;
/*
* Compute the magnitude of the vector.
*/
dg_putv ( &numu, &numv, iret );
if ( *iret != 0 ) return;
dv_mag ( iret );
if ( *iret != 0 ) return;
/*
* Get the magnitude.
*/
dg_gets ( &nmag, iret );
if ( *iret != 0 ) return;
/*
* Get a new 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 ( &numu, &grnumu, &kxd, &kyd, &ksub1, &ksub2, iret );
dg_getg ( &numv, &grnumv, &kxd, &kyd, &ksub1, &ksub2, iret );
dg_getg ( &num1, &grnum1, &kxd, &kyd, &ksub1, &ksub2, iret );
dg_getg ( &nmag, &grmag, &kxd, &kyd, &ksub1, &ksub2, iret );
/*
* Check all of the grid points.
*/
for ( i= ksub1 - 1; i < ksub2; i++ ) {
if ( ERMISS ( grmag[i]) || ERMISS ( grnum1[i]) ) {
gru[i] = RMISSD;
grv[i] = RMISSD;
}
else {
if ( grmag[i] >= grnum1[i] ) {
gru[i] = grnumu[i];
grv[i] = grnumv[i];
}
else {
gru[i] = RMISSD;
grv[i] = RMISSD;
}
}
}
/*
* Make a name of the form 'VGE'//V//S and
* update both grid headers; update the stack.
*/
dg_updv ( "VGE", &nu, &nv, &numu, &num1, iret );
dg_putv ( &nu, &nv, iret );
dg_esub ( &nu, &nv, &zero, &zero, &ier );
if ( ier != 0 ) *iret = ier;
return;
}
void pd_kinx ( const float *t850, const float *t700, const float *t500,
const float *td850, const float *td700, const int *np,
float *rkinx, int *iret )
/************************************************************************
* pd_kinx *
* *
* This subroutine computes KINX from t850, t700, t500, td850, and *
* td850. The following equation is used: *
* *
* *
* RKINX = the 'K' index *
* = (t850 - t500) + td850 - (t700 - td700 ) *
* *
* pd_kinx ( t850, t700, t500, td850, td700, np, rkinx, iret ) *
* *
* Input parameters: *
* *t850 const float 850 mb temperature in Celsius *
* *t700 const float 700 mb temperature in Celsius *
* *t500 const float 500 mb temperature in Celsius *
* *td850 const float 850 mb dewpoint in Celsius *
* *td700 const float 700 mb dewpoint in Celsius *
* *np const int Number of points *
* *
* Output parameters: *
* *rkinx float The 'K' Index *
* *iret int Return code *
* 0 = normal return *
** *
* Log: *
* D. Keiser/GSC 6/95 *
* T. Piper/GSC 3/99 Corrected prolog *
* K. Brill/HPC 11/02 Remove SUBFLG input logical array *
* R. Tian/SAIC 9/05 Translated from FORTRAN *
************************************************************************/
{
int npt, i;
/*----------------------------------------------------------------------*/
*iret = 0;
npt = *np;
/*
* Loop through all the points.
*/
for ( i = 0; i < npt; i++ ) {
/*
* Check for missing data.
*/
if ( ( ERMISS ( t850 [i] ) ) || ( ERMISS ( t700 [i] ) ) ||
( ERMISS ( t500 [i] ) ) || ( ERMISS ( td850 [i] ) ) ||
( ERMISS ( td700 [i] ) ) ) {
rkinx [i] = RMISSD;
} else {
/*
* Find the 'K' index.
*/
rkinx [i] = ( t850 [i] - t500 [i] ) + td850 [i] -
( t700 [i] - td700 [i] );
}
}
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 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;
}
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 pd_prcp ( const float *prc1, const float *prc2, const float *rmult,
const int *np, float *total, int *iret )
/************************************************************************
* pd_prcp *
* *
* This subroutine is used to add or subtract two precipitation *
* amounts. *
* *
* The total precipitation is computed as: *
* *
* TOTAL = PRC1 + RMULT * PRC2 *
* *
* pd_prcp ( prc1, prc2, rmult, np, total, iret ) *
* *
* Input parameters: *
* *prc1 const float First precipitation amount *
* *prc2 const float Second precipitation amount *
* *rmult const float Multiplier *
* *np const int Number of points *
* *
* Output parameters: *
* *total float Total precipitation *
* *iret int Return code *
* 0 = normal return *
** *
* Log: *
* M. desJardins/NMC 3/94 *
* K. Brill/HPC 11/02 Remove SUBFLG input logical array *
* R. Tian/SAIC 9/05 Translated from FORTRAN *
************************************************************************/
{
float zerov, fvalue;
int npt, first, ii;
/*----------------------------------------------------------------------*/
*iret = 0;
npt = *np;
first = G_TRUE;
/*
* Set a default value for 0. Change if a negative number is found.
*/
zerov = VALUE0;
fvalue = VALUE0;
/*
* Loop through all the points.
*/
for ( ii = 0; ii < npt; ii++ ) {
/*
* Check for missing data.
*/
if ( ( ERMISS ( prc1[ii] ) ) || ( ERMISS ( prc2[ii] ) ) ) {
total[ii] = RMISSD;
/*
* Check for amounts less than 0. These values are used
* for the 0 value so that 0 can be used as a contour level.
*/
} else if ( ( prc1[ii] < 0.0F ) && ( prc2[ii] < 0.0F ) ) {
zerov = prc1[ii];
total[ii] = prc1 [ii];
} else if ( ( prc1[ii] < 0.0F ) ) {
zerov = prc1[ii];
total[ii] = prc2[ii];
} else if ( ( prc2[ii] < 0.0F ) ) {
zerov = prc2[ii];
total[ii] = prc1[ii];
/*
* Add the two values together using the multiplier.
*/
} else {
total[ii] = prc1[ii] + (*rmult) * prc2[ii];
if ( total[ii] <= 0.0F ) {
total[ii] = zerov;
if ( first ) {
fvalue = zerov;
first = G_FALSE;
}
}
}
}
/*
* Check that the first missing value is correct.
*/
if ( ( !G_DIFF(zerov, VALUE0) ) && ( !G_DIFF(fvalue, zerov) ) ) {
for ( ii = 0; ii < npt; ii++ ) {
if ( ( total[ii] <= 0.0F ) && ( ! ERMISS ( total[ii] ) ) ) {
total[ii] = zerov;
}
}
}
return;
}
void dg_scal ( const char *parm, const int *num, int *iret )
/************************************************************************
* dg_scal *
* *
* This subroutine scales grids to store them in MKS units. This *
* is necessary for MIXR, SMXR and PSYM since the standard GEMPAK *
* units are not MKS units. Whenever these parameters are returned *
* directly to the user, they will be rescaled to standard GEMPAK *
* units. *
* *
* dg_scal ( parm, num, iret ) *
* *
* Input parameters: *
* *parm const char Parameter name *
* *num const int Number of internal grid *
* *
* Output parameters: *
* *iret int Return code *
* 0 = normal return *
** *
* Log: *
* M. desJardins/GSFC 5/88 *
* M. desJardins/NMC 3/92 Add check for MIXS and SMXS *
* 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 11/02 Eliminate use of the SUBA logical array *
* R. Tian/SAIC 2/06 Recoded from Fortran *
************************************************************************/
{
float scale;
int gidx, i;
/*----------------------------------------------------------------------*/
*iret = 0;
/*
* Check that grid number is valid.
*/
if ( *num <= 0 ) return;
/*
* Get scaling factor.
*/
if ( ( strcmp ( parm, "MIXR" ) == 0 ) ||
( strcmp ( parm, "SMXR" ) == 0 ) ||
( strcmp ( parm, "MIXS" ) == 0 ) ||
( strcmp ( parm, "SMXS" ) == 0 ) ) {
scale = .001;
} else if ( strcmp ( parm, "PSYM" ) == 0 ) {
scale = 100.;
} else {
return;
}
/*
* Scale the data.
*/
gidx = (*num) - 1;
for ( i = _dgarea.ksub1; i <= _dgarea.ksub2; i++ ) {
if ( ! ERMISS ( _dggrid.dgg[gidx].grid[i-1] ) ) {
_dggrid.dgg[gidx].grid[i-1] *= scale;
}
}
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 pd_heat ( const float *tmpf, const float *relh, const int *np,
float *heat, int *iret )
/************************************************************************
* pd_heat *
* *
* This subroutine computes HEAT, the Southern Region/CPC Rothfusz heat *
* index, from TMPF and RELH. The output will be calculated in degrees *
* Fahrenheit. *
* *
* Source: NWS Southern Region SSD Technical Attachment SR 90-23 *
* 7/1/90. Heat Index was originally known as the *
* apparent temperature index (Steadman, JAM, July, 1979).*
* *
* The Rothfusz regression is optimal for TMPF > ~80 and RELH > ~40%. *
* This code applies a simple heat index formula and then resorts to *
* the Rothfusz regression only if the simple heat index exceeds 80, *
* implying temperatures near, but slightly below 80. To make the *
* simple calculation continuous with the values obtained from the *
* Rothfusz regression, the simple result is averaged with TMPF in *
* computing the simple heat index value. *
* *
* This code includes adjustments made by the CPC for low RELH at high *
* TMPF and high RELH for TMPF in the mid 80's. *
* *
* pd_heat ( tmpf, relh, np, heat, iret ) *
* *
* Input parameters: *
* *tmpf const float Temperature in Fahrenheit *
* *relh const float Relative humidity in percent *
* *np const int Number of points *
* *
* Output parameters: *
* *heat float Heat Index in Fahrenheit *
* *iret int Return code *
* 0 = normal return *
** *
* Log: *
* S. Jacobs/NCEP 3/02 Initial coding *
* K. Brill/HPC 11/02 Remove SUBFLG input logical array *
* K. Brill/HPC 1/03 Fix discontinuity around 77 F *
* R. Tian/SAIC 9/05 Translated from FORTRAN *
************************************************************************/
{
float t2, r2, adj1, tval, adj2, adj;
int npt, i;
/*----------------------------------------------------------------------*/
*iret = 0;
npt = *np;
/*
* Loop through all the points.
*/
for ( i = 0; i < npt; i++ ) {
/*
* If either the Temperature or Relative Humidity are missing,
* then set the result to missing.
*/
if ( ERMISS (tmpf[i]) || ERMISS (relh[i]) ) {
heat[i] = RMISSD;
} else {
/*
* If the temperature is less than 40 degrees, then set the
* heat index to the temperature.
*/
if ( tmpf[i] <= 40.0F ) {
heat[i] = tmpf[i];
} else {
/*
* Compute a simple heat index. If the value is less
* than 80 degrees, use it.
*/
heat[i] = 61.0F + (tmpf[i]-68.0F) * 1.2F + relh[i] * .094F;
heat[i] = .5F * ( tmpf[i] + heat[i] );
if ( heat[i] >= 80.0F ) {
/*
* Otherwise, compute the full regression value
* of the heat index.
*/
t2 = tmpf[i] * tmpf[i];
r2 = relh[i] * relh[i];
heat[i] = -42.379F
+ 2.04901523F * tmpf[i]
+ 10.14333127F * relh[i]
- 0.22475541F * tmpf[i] * relh[i]
- 0.00683783F * t2
- 0.05481717F * r2
+ 0.00122874F * t2 * relh[i]
+ 0.00085282F * tmpf[i] *r2
- 0.00000199F * t2 * r2;
/*
* Adjust for high regression at low RH for temps
* above 80 degrees F.
*/
if ( ( relh[i] <= 13.0F ) &&
( ( tmpf[i] >= 80.0F ) &&
( tmpf[i] <= 112.0F ) ) ) {
adj1 = ( 13.0F - relh[i] ) / 4.0F;
tval = 17.0F - fabs ( tmpf[i] - 95.0F );
adj2 = sqrt ( tval / 17.0F );
adj = adj1 * adj2;
heat[i] -= adj;
/*
* Adjust for low regression at high RH and temps
* in the mid 80s.
*/
} else if ( ( relh[i] > 85.0F ) &&
( ( tmpf[i] >= 80.0F ) &&
( tmpf[i] <= 87.0F ) ) ) {
adj1 = ( ( relh[i] - 85.0F ) / 10.0F );
adj2 = ( ( 87.0F - tmpf[i] ) / 5.0F );
adj = adj1 * adj2;
heat[i] += adj;
}
}
}
}
}
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_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 rsdatt ( char *pname, float *xsz, float *ysz,
int *ileft, int *ibot, int *iright, int *itop,
int *numclr, int *iret )
/************************************************************************
* rsdatt *
* *
* This subroutine defines the device attributes. *
* *
* rsdatt ( pname, xsz, ysz, ileft, ibot, iright, itop, numclr, iret ) *
* *
* Input parameters: *
* *pname char Name of file as output *
* *xsz float X size in inches or pixels *
* *ysz float Y size in inches or pixels *
* *
* Output parameters: *
* *ileft int Left device coordinate *
* *ibot int Bottom device coordinate *
* *iright int Right device coordinate *
* *itop int Top device coordinate *
* *numclr int Max number of colors for device *
* *iret int Return code *
** *
* Log: *
* E. Wehner/EAi 3/96 Adopted from hsdatt.f *
* S. Jacobs/NCEP 4/96 Added ileft,ibot,iright,itop,nncolr *
* to calling sequence; added calculation *
* of paper and device size *
* E. Wehner/EAi 1/97 Use wheel to index fax products *
* E. Wehner/Eai 3/97 Set x and ysize based on rotation *
* S. Jacobs/NCEP 7/97 Rewrote and reorganized code *
* S. Jacobs/NCEP 7/97 Cleaned up header and global variables *
* S. Jacobs/NCEP 7/97 Added indent value from product table *
* S. Jacobs/NCEP 7/97 Added check for 180 and 270 rotation *
* S. Jacobs/NCEP 8/97 Added reserved value from prod table *
* G. Krueger/EAI 10/97 CST_xLST: Removed RSPTB; Add str limit *
* S. Jacobs/NCEP 5/98 Changed to allow for multiple subsets *
* T. Piper/SAIC 02/04 Removed lenf parameter *
***********************************************************************/
{
int ier, num, ii, fxfg;
char tmpfil[133], **aryptr, twhl[5], tsub[5];
/*---------------------------------------------------------------------*/
*iret = G_NORMAL;
if ( strchr ( pname, ';' ) != NULL ) {
/*
* If the product/file name contains a semi-colon, then parse
* the name for the "wheel" and "subset" values. The wheel and
* subset are then used to get the product information from the
* FAX product table.
*
* The parsing searches for either a semi-colon or a space to
* terminate each string.
*/
aryptr = (char **) malloc ( 2 * sizeof(char *) );
for ( ii = 0; ii < 2; ii++ ) {
aryptr[ii] = (char *) malloc ( 80 * sizeof(char) );
}
cst_clst ( pname, ';', " ", 2, 80, aryptr, &num, &ier );
strcpy ( twhl, aryptr[0] );
strcpy ( tsub, aryptr[1] );
for ( ii = 0; ii < 2; ii++ ) {
free ( aryptr[ii] );
}
free ( (char **) aryptr );
fxfg = G_TRUE;
}
else {
/*
* This is not a FAX product. However, still create a raster
* image of the product.
*/
fxfg = G_FALSE;
}
/*
* Save the file name.
*/
if ( fxfg ) {
sprintf ( tmpfil, "%s.ras", twhl );
}
else {
strcpy ( tmpfil, pname );
}
/*
* If the passed in filename is different from the global filename,
* change the name after closing the old file.
*/
if ( strcmp ( filnam, tmpfil ) != 0 ) {
rclosp ( &ier );
if ( fxfg ) {
/*
* Find the requested product in the FAX product
* definition table.
*/
strcpy ( wheel, twhl );
ctb_prod ( wheel, tsub, MAXSUB, &nsub, subset, descr,
kbit, klin, krot, kind, krsv, &ier );
if ( ier != G_NORMAL ) {
*iret = G_NOPROD;
return;
}
faxflg = G_TRUE;
}
else {
/*
* Set the dimensions of the raster only output.
*/
if ( ERMISS ( *xsz ) || ERMISS ( *ysz ) ) {
kbit[0] = 800;
klin[0] = 800;
}
else {
if ( *ysz > *xsz ) {
kbit[0] = (int) *ysz;
klin[0] = (int) *xsz;
krot[0] = 90;
}
else {
kbit[0] = (int) *xsz;
klin[0] = (int) *ysz;
krot[0] = 0;
}
}
nsub = 1;
faxflg = G_FALSE;
}
/*
* Make sure that there are enough bytes per raster line. If the
* number of bits is not divisible by 8 then add enough bits to
* make the number divisible by 8.
*/
if ( kbit[0] % 8 != 0 ) {
kbit[0] = kbit[0] + (8 - kbit[0]%8);
}
/*
* If this is a FAX product and the number of bits per line is
* greater than 1728, set the number to 1728.
*/
if ( kbit[0] > 1728 && faxflg ) {
kbit[0] = 1728;
}
/*
* Compute the number of bytes for this raster image.
* If the size is larger than the maximum, return with an error.
*/
msize = (kbit[0]/8) * klin[0];
if ( msize > MAXSIZ ) {
*iret = G_NIDSIZ;
return;
}
/*
* Clear the entire image.
*/
rclear ( &ier );
/*
* Set the device bounds.
*/
if ( ( krot[0] == 0 ) || ( krot[0] == 180 ) ) {
*ileft = 1;
*ibot = klin[0];
*iright = kbit[0];
*itop = 1;
}
else if ( ( krot[0] == 90 ) || ( krot[0] == 270 ) ) {
*ileft = 1;
*ibot = kbit[0];
*iright = klin[0];
*itop = 1;
}
/*
* Set file to initially closed.
*/
opnfil = G_FALSE;
/*
* If the new file name is not empty, set the current file name.
*/
if ( tmpfil[0] != CHNULL ) {
strcpy ( filnam, tmpfil );
*iret = G_NEWWIN;
}
/*
* Set the number of colors to be returned to DEVCHR.
*
* nncolr (numclr) = number of device colors
* ( A maximum of MXCLNM = 32 may be initialized. )
*/
nncolr = 1;
*numclr = nncolr;
}
}
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_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 clo_closest ( float *lat, float *lon, int npts, float plat,
float plon, int nclose, int *order, int *iret )
/************************************************************************
* clo_closest *
* *
* This function returns the order of the lat/lon arrays in terms of *
* their geographical closeness to the point in question, ie., the pair *
* (lat[order[0]],lon[order[0]]) is closest to point (plat,plon). *
* Only the closest nclose pairs will be determined. *
* *
* clo_closest ( lat, lon, npts, plat, plon, nclose, order, iret ) *
* *
* Input parameters: *
* *lat float Latitude array *
* *lon float Longitude array *
* npts int Number of lat/lon pairs *
* plat float Latitude of point *
* plon float Longitude of point *
* nclose int Return this number of indices *
* *
* Output parameters: *
* *order int Index into lat/lon arrays *
* *iret int Return code *
** *
* Log: *
* D.W.Plummer/NCEP 1/99 Add nclose to calling sequence; *
* re-write algorithm to use clo_dist. *
* D.W.Plummer/NCEP 4/99 Added check for npts == 0 *
* M. Li/GSC 10/99 Modified clo_dist code *
* M. Li/GSC 10/99 Added multi-points cal. to clo_dist *
* D.W.Plummer/NCEP 1/00 bug fix when some lat/lons are invalid *
***********************************************************************/
{
int i, j, which, ier;
float *dist, mindist;
/*---------------------------------------------------------------------*/
*iret = 0;
if ( npts == 0 ) {
*iret = -1;
return;
}
dist = (float *) malloc ( (size_t)npts * sizeof(float) );
clo_dist( &plat, &plon, &npts, lat, lon, dist, &ier );
for ( i = 0 ; i < nclose ; i++ ) {
mindist = FLT_MAX;
which = IMISSD;
for ( j = 0 ; j < npts ; j++ ) {
if ( !ERMISS(dist[j]) && dist[j] <= mindist ) {
which = j;
order[i] = which;
mindist = dist[which];
}
}
if ( which != IMISSD ) {
dist[which] = RMISSD;
}
else {
order[i] = IMISSD;
}
}
free ( dist );
}
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;
}
