void de_cval ( const char *uarg, char *stprm, int *iret )
/************************************************************************
* de_cval *
* *
* This function determines the value of the function defined by PARM *
* for which the probability is PRB that the observed value is less *
* than or equal to that computed value based on an idealized ensemble *
* forecast. *
* *
* GFUNC syntax: ENS_CVAL ( PARM & PRB & LWRBND & UPRBND ) *
* *
* de_cval ( 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: *
* M. Li/SAIC 10/06 *
* M. Li/SAIC 10/06 Added a check for missing value *
* K. Brill/HPC 20080131 Add intrinsic weight computations; fix *
* eliminate duplicates coding error *
* K. Brill/HPC 20101118 Check for single value order stats case *
************************************************************************/
{
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, ii, jj, kk, ll, mm, nn, ier;
int iswflg, istop;
float *gigo, *gigp, *gnum, data, swpbuf, psum;
float *gilwr, *giupr, *tmpwt, wtbuf, tol;
float *zwts, *zfreq;
float zsum;
float vn, qlt, qrt, fta, cta, aa, bb, cc;
Boolean ibreak;
/*----------------------------------------------------------------------*/
*iret = 0;
zero = 0;
one = 1;
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 up to four arguments
* for DE_CVAL.
*/
for ( ii = 0; ii < MXARGS; ii++ ) {
_ensdiag.allarg[ii][0] = '\0';
}
nina = 4;
argu = (char **)cmm_malloc2d ( 4, 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 ( ii > 0 && strcmp(argu[ii], " ") == 0 ) {
cst_rlch ( RMISSD, 1, _ensdiag.allarg[ii], &ier );
}
}
if ( narg == 2 ) {
cst_rlch ( RMISSD, 1, _ensdiag.allarg[2], &ier );
cst_rlch ( RMISSD, 1, _ensdiag.allarg[3], &ier );
}
if ( narg == 3 ) {
cst_rlch ( RMISSD, 1, _ensdiag.allarg[3], &ier );
}
cmm_free2d ( (void **) argu, &ier );
if ( narg < 2 ) {
*iret = -15;
return;
}
/*
* Scan the allarg array.
*/
de_scan ( &nina, iret );
if ( *iret != 0 ) return;
/*
* Evaluate the static arguments.
*/
for ( ii = 2; ii < nina; ii++ ) {
dg_pfun ( _ensdiag.allarg[ii], iret );
dg_driv ( &one, iret );
dg_tops ( tname, &igp, time1, time2, &level1, &level2,
&ivcord, pdum, iret );
if ( ii == 2 ) {
dg_getg ( &igp, &gilwr, &kxd, &kyd, &ksub1, &ksub2, iret );
}
else {
dg_getg ( &igp, &giupr, &kxd, &kyd, &ksub1, &ksub2, iret );
}
}
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;
}
/*
* Get memory for intrinsic weights (zwts), intrinsic weight
* frequency (zfreq), and temporary weights.
*/
G_MALLOC ( zwts, float, _ensdiag.nummbr+1, "x" );
G_MALLOC ( zfreq, float, _ensdiag.nummbr+1, "x" );
G_MALLOC ( tmpwt, float, _ensdiag.nummbr+2, "x" );
for ( ll = ksub1 - 1; ll < ksub2; ll++ ) {
if ( ERMISS(gigp[ll]) ) continue;
if ( gigp[ll] < 0.0F || gigp[ll] > 1.0F ) continue;
for ( ii = 0; ii < _ensdiag.nummbr; ii++ ) {
ibreak = False;
num = _ensdiag.iglist[ii];
dg_getg ( &num, &gnum, &kxd, &kyd, &ksub1, &ksub2, iret );
data = gnum[ll];
if ( ! ERMISS ( data ) ) {
_ensdiag.emvalu[ii+1] = data;
tmpwt[ii+1] = _ensdiag.enswts[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;
while ( iswflg != 0 && istop > 0 ) {
iswflg = 0;
for ( kk = 1; kk < istop; kk++ ) {
if ( _ensdiag.emvalu[kk] > _ensdiag.emvalu[kk+1] ) {
iswflg = 1;
swpbuf = _ensdiag.emvalu[kk];
wtbuf = tmpwt[kk];
_ensdiag.emvalu[kk] = _ensdiag.emvalu[kk+1];
tmpwt[kk] = tmpwt[kk+1];
_ensdiag.emvalu[kk+1] = swpbuf;
tmpwt[kk+1] = wtbuf;
}
}
istop--;
}
/*
* Check for identical values and compute intrinsic weight
* frequency (zfreq).
*/
mm = _ensdiag.nummbr;
nn = mm;
/*
* Initialize intrinsic weight frequency array.
*/
for (kk = 1; kk <= nn; kk++){
zfreq[kk] = 1.0F;
}
tol = 0.001F * (_ensdiag.emvalu[mm]-_ensdiag.emvalu[1]) / mm;
for (kk = 1; kk < mm; kk++) {
if ( G_ABS(_ensdiag.emvalu[kk] - _ensdiag.emvalu[kk+1]) <= tol ) {
tmpwt[kk] += tmpwt[kk+1];
zfreq[kk] = zfreq[kk] + 1.0F;
mm--;
for (jj = kk+1; jj <= mm; jj++) {
_ensdiag.emvalu[jj] = _ensdiag.emvalu[jj+1];
tmpwt[jj] = tmpwt[jj+1];
}
/* This algorithm was originally coded incorrectly. The value
* of kk must also be held back to correctly eliminate three
* or more identical values.
*/
kk--;
}
}
/*
* Fabricate order statistics if it has collapsed to a single value.
*/
if ( mm == 1 ) {
if ( G_DIFF(_ensdiag.emvalu[1], 0.0F) ) {
_ensdiag.emvalu[1] = -0.00001F;
_ensdiag.emvalu[2] = 0.00001F;
}
else {
_ensdiag.emvalu[2] = _ensdiag.emvalu[1] + 0.00001F * G_ABS(_ensdiag.emvalu[1]);
_ensdiag.emvalu[1] -= 0.00001F * G_ABS(_ensdiag.emvalu[1]);
}
tmpwt[1] = 0.5F;
tmpwt[2] = 0.5F;
mm = 2;
zfreq[1] = 1.0F;
zfreq[2] = 1.0F;
}
/*
*Compute and sum intrinsic weights.
*/
zwts[1] = zfreq[1] / ( _ensdiag.emvalu[2] - _ensdiag.emvalu[1] );
zsum = zwts[1];
for (kk=2; kk < mm; kk++){
zwts[kk] = ( zfreq[kk] * 2.0F ) / ( _ensdiag.emvalu[kk+1] - _ensdiag.emvalu[kk-1] );
zsum = zsum + zwts[kk];
}
zwts[mm] = zfreq[mm] / ( _ensdiag.emvalu[mm] - _ensdiag.emvalu[mm-1] );
zsum = zsum + zwts[mm];
/*
* Scale external weights by normalized intrinsic weights and
* normalize.
*/
psum = 0.0F;
for (kk=1; kk <= mm; kk++ ){
tmpwt[kk] = ( zwts[kk] / zsum ) * tmpwt[kk];
psum = psum + tmpwt[kk];
}
for (kk=1; kk <= mm; kk++ ){
tmpwt[kk] = tmpwt[kk] / psum;
}
} /*End "if" for all members ready check.*/
}
else {
ibreak = True;
break;
} /*End "if" for check for non-missing value.*/
} /*End "for" loop over members.*/
if ( ibreak ) continue;
/*
* Compute Qun, the area; Vn, the normalized value;
* w(), normalized weight; and qlt, qrt.
*/
vn = 0.0F;
for ( kk = 2; kk <= mm; kk++ ) {
vn += 0.5 * (tmpwt[kk] + tmpwt[kk-1]) * (_ensdiag.emvalu[kk] - _ensdiag.emvalu[kk-1]);
}
/*
* If the distribution is a Dirac spike over a single value, then set the result to
* that single value.
*/
if ( G_DIFF ( vn, 0.0 ) ) {
gigo[ll] = _ensdiag.emvalu[1];
continue;
}
vn = vn / (1.0F - 2.0F / (nn+1));
for ( kk = 1; kk <= mm; kk++ ) {
tmpwt[kk] = tmpwt[kk] / vn;
}
qlt = _ensdiag.emvalu[1] - 2.0F / (tmpwt[1] * (nn + 1));
qrt = _ensdiag.emvalu[mm] + 2.0F / (tmpwt[mm] * (nn + 1));
tmpwt[0] = 0.0F;
tmpwt[mm+1] = 0.0F;
_ensdiag.emvalu[0] = qlt;
_ensdiag.emvalu[mm+1] = qrt;
psum = 0.0F;
for ( kk = 1; kk <= mm + 1; kk++ ) {
/*
* Compute CTA.
*/
cta = 0.5F * (tmpwt[kk] + tmpwt[kk-1]) * (_ensdiag.emvalu[kk] - _ensdiag.emvalu[kk-1]);
psum += cta;
if ( kk == mm + 1 ) psum = 1.0F;
/*
* If psum = PRB, assign q[i] to output grid and move on to next grid point.
* (This was coded incorrectly and fixed on 20080205 -KB.)
*/
if ( G_DIFF ( gigp[ll], psum ) ) {
gigo[ll] = _ensdiag.emvalu[kk];
break;
}
/*
* If psum > PRB. Solve the quadratic equation.
*/
if ( psum > gigp[ll] ) {
psum -= cta;
fta = gigp[ll] - psum;
aa = (tmpwt[kk] - tmpwt[kk-1]) / (_ensdiag.emvalu[kk] - _ensdiag.emvalu[kk-1]);
bb = 2.0F * tmpwt[kk-1];
cc = 2.0F * fta;
if ( G_DIFF ( aa, 0.0F ) ) {
gigo[ll] = _ensdiag.emvalu[kk-1] + cc / bb;
}
else {
gigo[ll] = _ensdiag.emvalu[kk-1] + (sqrt(bb * bb + 4 * aa * cc) - bb) / (2 * aa);
}
if ( ! ERMISS(gilwr[ll]) && gigo[ll] < gilwr[ll] ) gigo[ll] = gilwr[ll];
if ( ! ERMISS(giupr[ll]) && gigo[ll] > giupr[ll] ) gigo[ll] = giupr[ll];
break;
}
}
}
G_FREE (tmpwt, float);
G_FREE (zfreq, float);
G_FREE (zwts, float);
/*
* 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_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 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_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_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 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 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 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_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 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_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 df_mul ( int *iret )
/************************************************************************
* df_mul *
* *
* This subroutine multiplies two scalar grids: *
* *
* MUL (S1, S2) = S1 * S2 *
* *
* df_mul ( iret ) *
* *
* Output parameters: *
* *iret int Return code *
* As for DG_GETS *
** *
* Log: *
* M. desJardins/GSFC 10/85 *
* M. desJardins/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, num2, num, kxd, kyd, ksub1, ksub2, i, im1, 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 number and multiply 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 {
gnum[im1] = dg1 * dg2;
}
}
/*
* Make a name of the form 'MUL'//S1//S2 and update header;
* update stack.
*/
dg_updh ( "MUL", &num, &num1, &num2, iret );
dg_puts ( &num, iret );
dg_esub ( &num, &zero, &zero, &zero, &ier );
if ( ier != 0 ) *iret = ier;
return;
}
void dv_nrmv ( int *iret )
/************************************************************************
* dv_nrmv *
* *
* This subroutine computes the vector component of a vector field (V) *
* normal to the orientation vector whose direction is specified in *
* COMMON / DGOVEC /. *
* *
* NORMV = ( ( -k cross V ) dot ( normalized orientation vector ) ) *
* times ( normalized orientation vector ) *
* *
* NORMV generates a vector field. *
* *
* dv_nrmv ( iret ) *
* *
* Output parameters: *
* *iret int Return code *
* As for DG_GETV or DG_MSCL *
* -28 = no orientation vector *
** *
* Log: *
* K. Brill/GSC 7/89 *
* K. Brill/GSC 8/89 Subsetting *
* K. Brill/GSC 10/89 Subsetting *
* K. Brill/NMC 4/92 Nonconformal case reused ORNTV->error *
* 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 *
* by using internal grids for scl fctrs *
* K. Brill/HPC 11/02 Eliminate use of the SUBA logical array *
* S. Gilbert/NCEP 11/05 Translation from Fortran *
************************************************************************/
{
int i, ier, nval, kxd, kyd, ksub1, ksub2, zero=0;
int numu, numv, numu1, numv1, ixmscl, iymscl;
float *gru, *grv, *gru1, *grv1, *grxms, *gryms;
float orntv[2], ornang, du1, dv1, orn1, orn2;
float du2, dv2, rnm;
/*------------------------------------------------------------------------*/
*iret = 0;
dg_ssub ( iret );
dg_nxtv ( &numu, &numv, iret );
if ( *iret != 0 ) return;
dg_getg ( &numu, &gru, &kxd, &kyd, &ksub1, &ksub2, iret );
dg_getg ( &numv, &grv, &kxd, &kyd, &ksub1, &ksub2, iret );
nval = 1;
dg_fget ( "ORNANG", &nval, &ornang, iret );
if ( ERMISS ( ornang ) ) {
for ( i = ksub1 - 1; i < ksub2; i++ ) {
gru[i] = RMISSD;
grv[i] = RMISSD;
}
*iret = -28;
return;
}
/*
* Compute the unit tangent vector components.
*/
orntv [ 0 ] = - sin ( ornang );
orntv [ 1 ] = - cos ( ornang );
/*
* Compute the map scale factors just in case the grid is not
* conformal.
*/
dg_mscl ( iret );
if ( *iret != 0 ) return;
/*
* Get the vector.
*/
dg_getv ( &numu1, &numv1, iret );
if ( *iret != 0 ) return;
/*
* Compute the normal component.
*/
dg_getg ( &numu1, &gru1, &kxd, &kyd, &ksub1, &ksub2, iret );
dg_getg ( &numv1, &grv1, &kxd, &kyd, &ksub1, &ksub2, iret );
nval = 1;
dg_iget ( "IXMSCL", &nval, &ixmscl, iret );
dg_iget ( "IYMSCL", &nval, &iymscl, iret );
dg_getg ( &ixmscl, &grxms, &kxd, &kyd, &ksub1, &ksub2, iret );
dg_getg ( &iymscl, &gryms, &kxd, &kyd, &ksub1, &ksub2, iret );
for ( i = ksub1 - 1; i < ksub2; i++ ) {
du1 = gru1[i];
dv1 = grv1[i];
if ( ERMISS (du1) || ERMISS (dv1) ) {
gru[i] = RMISSD;
grv[i] = RMISSD;
}
else if ( G_DIFF(grxms[i], gryms[i]) ) {
gru[i] = ( du1 * orntv [ 1 ] -
dv1 * orntv [ 0 ] ) * orntv [ 1 ] ;
grv[i] = ( -du1 * orntv [ 1 ] +
dv1 * orntv [ 0 ] ) * orntv [ 0 ] ;
}
else {
/*
* Treat the case when the grid map projection is
* nonconformal.
*
* Scale the grid relative orientation vector and normalize
* it.
*/
du2 = orntv [ 0 ] / grxms[i];
dv2 = orntv [ 1 ] / gryms[i];
rnm = sqrt ( du2 * du2 + dv2 * dv2 );
orn1 = du2 / rnm;
orn2 = dv2 / rnm;
gru[i] = ( du1 * orn2 - dv1 * orn1 ) * orn2 ;
grv[i] = ( -du1 * orn2 + dv1 * orn1 ) * orn1;
}
}
/*
* Make a name of the form 'NORMV'//u,v and update header;
* update stack.
*/
dg_updv ( "NORMV", &numu, &numv, &numu1, &numv1, iret );
dg_putv ( &numu, &numv, iret );
dg_esub ( &numu, &numv, &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 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_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_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 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_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 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_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 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 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 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_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 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 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 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 df_tlcl ( int *iret )
/************************************************************************
* df_tlcl *
* *
* This subroutine computes the temperature of the Lifting Condensation *
* Level from the temperature and dewpoint: *
* *
* TLCL (TMPC, DWPC) = PD_TLCL (TMPC, DWPC, NPT, TLCL, IRET) *
* *
* Output parameters: *
* *iret int Return code *
* As for DG_GETS *
** *
* Log: *
* S. Chiswell/Unidata 9/03 Created *
* 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 three 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 compute tlcl.
*/
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 );
kxyd = kxd * kyd;
pd_tlcl ( gnum1, gnum2, &kxyd, gnum, &ier );
/*
* Make a name of the form 'TLCL'//S1//S2 and update header;
* update stack.
*/
dg_updh ( "TLCL", &num, &num1, &num2, iret );
dg_puts ( &num, iret );
dg_esub ( &num, &zero, &zero, &zero, &ier );
if ( ier != 0 ) *iret = ier;
return;
}
