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