void dg_qmsl ( int *ixmscl, int *iymscl, float *gddx, float *gddy,
int *iret )
/************************************************************************
* dg_qmsl *
* *
* This subroutine retrieves the grid number for map scale factors and *
* grid spacing in x, y. *
* *
* dg_qmsl ( ixmscl, iymscl, gddx, gddy, iret ) *
* *
* Input parameters: *
* *
* Output parameters: *
* *ixmscl int ixmscl in mapscl.h *
* *iymscl int iymscl in mapscl.h *
* *gddx float gddx in mapscl.h *
* *gddy float gddy in mapscl.h *
* *iret int Return code *
* 0 = normal return *
** *
* Log: *
* R. Tian/SAIC 3/06 *
************************************************************************/
{
int nval;
/*----------------------------------------------------------------------*/
*iret = 0;
nval = 1;
dg_iget ( "IXMSCL", &nval, ixmscl, iret );
dg_iget ( "IYMSCL", &nval, iymscl, iret );
dg_fget ( "GDDX", &nval, gddx, iret );
dg_fget ( "GDDY", &nval, gddy, iret );
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_nmax ( int *iret )
/************************************************************************
* df_nmax *
* *
* This subroutine computes NMAX (S,ROI), the neigborhood maximum *
* value of a scalar field (S) within some radius of influence *
* (ROI; meters). Masking could be used [e.g., SGT(S1,S2)] to subset *
* and filter the grid beforehand to allow for faster processing. *
* *
* df_nmax ( iret ) *
* *
* Output parameters: *
* *iret int Return code *
* As for DG_GETS *
** *
* Log: *
* C. Melick/SPC 06/12 *
************************************************************************/
{
int num1, num2, num3, num, kxd, kyd, ksub1, ksub2, zero, indx, ier;
int ixmscl, iymscl, jgymin, jgymax, jgxmin, jgxmax, idglat, idglon;
int row, col, ibeg, iend, jbeg, jend, ibox, jbox, boxindx, nval;
float gddx, gddy, gdspdx, gdspdy, radius;
float *gnum1, *gnumn, *gkxms, *gkyms, *gnumroi, *glat, *glon, *dist;
/*----------------------------------------------------------------------*/
*iret = 0;
zero = 0;
dg_ssub ( iret );
/*
* Compute map scale factors.
*/
dg_mscl ( iret );
if ( *iret != 0 ) return;
/*
* Query DGCMN.CMN idglat/idglon.
*/
nval = 1;
dg_iget ( "IDGLAT", &nval, &idglat, iret );
if ( *iret != 0 ) return;
dg_iget ( "IDGLON", &nval, &idglon, iret );
if ( *iret != 0 ) return;
/*
* Get the grids from the stack.
*/
dg_gets ( &num1, iret );
if ( *iret != 0 ) return;
dg_gets ( &num2, iret );
if ( *iret != 0 ) return;
/*
* Get a new grid number.
*/
dg_nxts ( &num3, iret );
if ( *iret != 0 ) return;
dg_nxts ( &num, iret );
if ( *iret != 0 ) return;
dg_qmsl ( &ixmscl, &iymscl, &gddx, &gddy, &ier );
dg_qbnd ( &jgxmin, &jgxmax, &jgymin, &jgymax, &ier );
dg_getg ( &num1, &gnum1, &kxd, &kyd, &ksub1, &ksub2, &ier );
dg_getg ( &num, &gnumn, &kxd, &kyd, &ksub1, &ksub2, &ier );
dg_getg ( &ixmscl, &gkxms, &kxd, &kyd, &ksub1, &ksub2, &ier );
dg_getg ( &iymscl, &gkyms, &kxd, &kyd, &ksub1, &ksub2, &ier );
dg_getg ( &num2, &gnumroi, &kxd, &kyd, &ksub1, &ksub2, &ier );
dg_getg ( &idglat, &glat, &kxd, &kyd, &ksub1, &ksub2, &ier );
dg_getg ( &idglon, &glon, &kxd, &kyd, &ksub1, &ksub2, &ier );
dg_getg ( &num3, &dist, &kxd, &kyd, &ksub1, &ksub2, &ier );
radius = gnumroi[0];
/* QC check on lower and upper bounds of radius of influence. */
if ( radius < 0 ) {
radius = 0.0;
printf ("\n WARNING : RADIUS value less than zero. "
"Resetting to zero.\n");
}
if ( radius > 0.5*gddx*(float)(kxd)) {
radius = 0.5*gddx*(float)(kxd);
printf ("\n WARNING : RADIUS value too high. "
"Resetting to half the distance in X (%f meters).\n",radius);
}
/*
* Loop over all grid points to initialize output grid.
*/
for ( row = jgymin; row <= jgymax; row++ ) {
for ( col = jgxmin; col <= jgxmax; col++ ) {
indx=(row-1)*kxd+(col-1);
if ( ERMISS ( gnum1[indx] ) ) {
gnumn[indx] = RMISSD;
} else {
gnumn[indx] = gnum1[indx];
}
}
}
/*
* Loop over all grid points to determine neighborhood maximum for each grid point.
*/
for ( row = jgymin; row <= jgymax; row++ ) {
for ( col = jgxmin; col <= jgxmax; col++ ) {
indx=(row-1)*kxd+(col-1);
if ( ! ERMISS ( gnum1[indx] ) ) {
gdspdx= gddx / gkxms[indx];
gdspdy= gddy / gkyms[indx];
/* Constructing box for each grid point */
ibeg = col- G_NINT(radius / gdspdx);
iend = col+ G_NINT(radius / gdspdx);
jbeg = row- G_NINT(radius / gdspdy);
jend = row+ G_NINT(radius / gdspdy);
if (ibeg < jgxmin) {
ibeg = jgxmin;
}
if (iend > jgxmax) {
iend = jgxmax;
}
if (jbeg < jgymin) {
jbeg = jgymin;
}
if (jend > jgymax) {
jend = jgymax;
}
for ( ibox = ibeg; ibox <= iend; ibox++ ) {
for ( jbox = jbeg; jbox <= jend; jbox++ ) {
boxindx=(jbox-1)*kxd+(ibox-1);
if ((glat[indx] == glat[boxindx]) && (glon[indx] == glon[boxindx])) {
dist[boxindx]=0.0;
} else {
/* Great Circle Distance calculation */
dist[boxindx] = acos(sin(glat[boxindx])*sin(glat[indx]) + cos(glat[boxindx])*cos(glat[indx])*cos((glon[boxindx])-(glon[indx])));
dist[boxindx] = RADIUS * dist[boxindx];
}
/* Check maximum value if neighboring point is defined and within radius of influence. */
if ( (dist[boxindx] <= radius) && (! ERMISS ( gnum1[boxindx] ) ) ) {
if ( gnum1[boxindx] > gnumn[indx] ) {
gnumn[indx] = gnum1[boxindx];
}
}
}
}
for ( ibox = ibeg; ibox <= iend; ibox++ ) {
for ( jbox = jbeg; jbox <= jend; jbox++ ) {
boxindx=(jbox-1)*kxd+(ibox-1);
/* Spreading the response around to surrounding undefined values */
if ( ERMISS ( gnum1[boxindx] ) ) {
if (dist[boxindx] <= radius) {
if ( ERMISS ( gnumn[boxindx] ) ) {
gnumn[boxindx] = gnumn[indx];
} else if ( gnum1[indx] > gnumn[boxindx] ) {
gnumn[boxindx] = gnum1[indx];
}
}
}
}
}
}
}
}
/*
* Make a name of the form 'NMAX'//S and update header;
* update stack.
*/
dg_updh ( "NMAX", &num, &num1, &num2, iret );
dg_puts ( &num, iret );
dg_esub ( &num, &zero, &zero, &zero, &ier );
if ( ier != 0 ) *iret = ier;
return;
}
void dv_mdiv ( int *iret )
/************************************************************************
* dv_mdiv *
* *
* This subroutine computes layer-average mass divergence: *
* *
* MDIV ( V ) = DIV ( [ MASS * LAV (u), MASS * LAV (v) ] ) *
* *
* V must be a grid parameter for LAV to work correctly. *
* MDIV generates a scalar grid. *
* *
* dv_mdiv ( iret ) *
* *
* Output parameters: *
* *iret int Return code *
* As for DG_GETV *
** *
* Log: *
* M. Goodman/RDS 11/85 *
* G. Huffman/GSC 9/88 New stack functions *
* G. Huffman/GSC 9/88 Error messages *
* M. desJardins/NMC 7/93 Changed update scheme *
* K. Brill/HPC 1/02 CALL DG_SSUB and DG_ESUB *
* S. Gilbert/NCEP 11/05 Translation from Fortran *
************************************************************************/
{
int nu, nv, nmass, nmdiv;
char gnam[13], gvect[13], gdum[13], pdum[13];
char time1[21], time2[21];
int level1, level2, ivcord, zero=0, ier, idlun, nval;
/*------------------------------------------------------------------------*/
*iret = 0;
dg_ssub ( iret );
/*
* Read the vector name on top of the stack and replace it with
* PRES (so that MASS will pick up in-line parameters).
*/
dg_topv ( gvect, &nu, &nv, time1, time2, &level1,
&level2, &ivcord, pdum, iret );
if ( *iret != 0 ) return;
dg_rpls ( "PRES", &zero, iret );
if ( *iret != 0 ) return;
/*
* Compute the mass / unit volume, and read the number of the grid.
*/
df_mass ( iret );
if ( *iret != 0 ) return;
dg_tops ( gdum, &nmass, time1, time2, &level1, &level2,
&ivcord, pdum, iret );
if ( *iret != 0 ) return;
/*
* Replace the top of the stack with the vector name, compute the
* average wind vector within the layer, and leave the result.
*/
dg_rplv ( gvect, &zero, &zero, iret );
if ( *iret != 0 ) return;
dv_vlav ( iret );
if ( *iret != 0 ) return;
/*
* Put the mass on top of the stack, compute the mass divergence,
* and read the grid number of the result.
*/
dg_puts ( &nmass, iret );
if ( *iret != 0 ) return;
dv_sdiv ( iret );
if ( *iret != 0 ) return;
dg_tops ( gdum, &nmdiv, time1, time2, &level1, &level2,
&ivcord, pdum, iret );
if ( *iret != 0 ) return;
/*
* Make a name of the form 'MDIV'//u and update header; the
* stack is current.
*/
nval = 1;
dg_iget ( "IDLUN", &nval, &idlun, iret );
dg_mnam ( "MDIV", gvect, "", gnam, &ier );
dg_upsg ( time1, time2, &level1, &level2, &ivcord,
&idlun, gnam, &nmdiv, iret );
dg_esub ( &nmdiv, &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 dv_rich ( int *iret )
/************************************************************************
* dv_rich *
* *
* This subroutine computes the Richardson stability number in a layer: *
* *
* RICH ( V ) = GRAVTY * DZ * LDF (THTA) / *
* [ LAV (THTA) * MAG ( VLDF (V) ) ** 2 ] *
* *
* Where: DZ = change in height across the layer *
* = -( RDGAS / GRAVTY ) * LAV (THTA) * *
* ( LAV (PRES) / 1000 ) ** KAPPA * *
* LDF (PRES) / LAV (PRES) *
* in THTA coordinates *
* *
* RICH generates a scalar grid. *
* *
* dv_rich ( iret ) *
* *
* Output parameters: *
* *iret int Return code *
* As for DG_GETV *
** *
* Log: *
* M. Goodman/RDS 12/85 *
* M. desJardins/GSFC 10/86 Added parameter statement for RKAPPA *
* 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 *
* K. Brill/GSC 12/89 Compute dz from p,T when HGHT is missing*
* M. desJardins/NMC 7/93 Changed update scheme *
* 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, ksub1, ksub2, nval, zero=0, tmp;
int nu, nv, nvldfu, nvldfv, nmag, idlun;
int ndz, ndp, npbar, ntbar, npav;
float *grdz, *grdp, *grpbar, *grtbar, *grpav;
int ndth, nath, nwsq, nrich;
float *grdth, *grath, *grwsq, *grrich;
float dp, tbar, pbar, avthta, cnst, dz, deltht, ath, dth;
float dwsq, pav, avtht;
char gp[13], wname[13], gdum[13], pdum[13];
char time1[21], time2[21], errst[1024];
int level1, level2, ivcord;
/*------------------------------------------------------------------------*/
*iret = 0;
dg_ssub ( iret );
/*
* Read the wind vector name, level, and vertical coordinate.
* Compute the wind shear in the layer and read the grid number
* of the result.
*/
dg_topv ( wname, &nu, &nv, time1, time2, &level1, &level2,
&ivcord, pdum, iret );
if ( *iret != 0 ) return;
dv_vldf ( iret );
if ( *iret != 0 ) return;
dg_topv ( gdum, &nvldfu, &nvldfv, time1, time2, &level1,
&level2, &ivcord, pdum, iret );
if ( *iret != 0 ) return;
/*
* Compute the magnitude of the wind shear and square it (by
* reading the grid number of the result, putting another copy
* on the stack, and multiplying). Read the grid number of the
* result.
*/
dv_mag ( iret );
if ( *iret != 0 ) return;
dg_tops ( gdum, &nmag, time1, time2, &level1, &level2,
&ivcord, pdum, iret );
if ( *iret != 0 ) return;
dg_puts ( &nmag, iret );
if ( *iret != 0 ) return;
df_mul ( iret );
if ( *iret != 0 ) return;
dg_tops ( gdum, &nwsq, time1, time2, &level1, &level2,
&ivcord, pdum, iret );
if ( *iret != 0 ) return;
/*
* Compute a grid of delta height depending upon the coordinate
* system.
*/
if ( ivcord == 1 ) {
/*
* Pressure coordinate system.
* Replace the top of the stack with HGHT (preserving in-line
* parameters), compute LDF, and read the grid number of the
* result.
*/
dg_rpls ( "HGHT", &zero, iret );
if ( *iret != 0 ) return;
df_ldf ( iret );
if ( *iret != 0 ) {
/*
* Compute dz from p and T.
*/
dg_rpls ( "PRES", &zero, iret );
if ( *iret != 0 ) return;
df_lav ( iret );
if ( *iret != 0 ) return;
dg_tops ( gdum, &npbar, time1, time2, &level1, &level2,
&ivcord, pdum, iret );
if ( *iret != 0 ) return;
dg_rpls ( "TMPK", &zero, iret );
if ( *iret != 0 ) return;
df_lav ( iret );
if ( *iret != 0 ) return;
dg_tops ( gdum, &ntbar, time1, time2, &level1, &level2,
&ivcord, pdum, iret );
if ( *iret != 0 ) return;
dg_rpls ( "PRES", &zero, iret );
if ( *iret != 0 ) return;
df_ldf ( iret );
if ( *iret != 0 ) return;
dg_tops ( gdum, &ndp, time1, time2, &level1, &level2,
&ivcord, pdum, iret );
if ( *iret != 0 ) return;
dg_nxts ( &ndz, iret );
if ( *iret != 0 ) return;
dg_getg ( &ndp, &grdp, &kxd, &kyd, &ksub1, &ksub2, iret );
dg_getg ( &ndz, &grdz, &kxd, &kyd, &ksub1, &ksub2, iret );
dg_getg ( &ntbar, &grtbar, &kxd, &kyd, &ksub1, &ksub2, iret );
dg_getg ( &npbar, &grpbar, &kxd, &kyd, &ksub1, &ksub2, iret );
for ( i = ksub1 - 1; i < ksub2; i++ ) {
dp = grdp[i];
tbar = grtbar[i];
pbar = grpbar[i];
if ( ERMISS ( dp ) || ERMISS ( tbar ) || ERMISS ( pbar ) )
grdz[i] = RMISSD;
else
grdz[i] = -RKAP * tbar * dp / pbar;
}
}
else {
dg_tops ( gdum, &ndz, time1, time2, &level1, &level2,
&ivcord, pdum, iret );
if ( *iret != 0 ) return;
}
}
else if ( ivcord == 2 ) {
/*
* Isentropic coordinate system.
* Compute the height differences as documented in the header.
* The PRES operations preserve access to in-line parameters.
*/
avthta = (level1 + level2) / 2.;
cnst = -avthta * RKAP;
dg_rpls ( "PRES", &zero, iret );
if ( *iret != 0 ) return;
df_lav ( iret );
if ( *iret != 0 ) return;
dg_tops ( gdum, &npav, time1, time2, &level1, &level2,
&ivcord, pdum, iret );
if ( *iret != 0 ) return;
dg_rpls ( "PRES", &zero, iret );
if ( *iret != 0 ) return;
df_ldf ( iret );
if ( *iret != 0 ) return;
dg_tops ( gdum, &ndp, time1, time2, &level1, &level2,
&ivcord, pdum, iret );
if ( *iret != 0 ) return;
/*
* Get a new grid number for the height field.
*/
dg_nxts ( &ndz, iret );
if ( *iret != 0 ) return;
dg_getg ( &ndp, &grdp, &kxd, &kyd, &ksub1, &ksub2, iret );
dg_getg ( &ndz, &grdz, &kxd, &kyd, &ksub1, &ksub2, iret );
dg_getg ( &npav, &grpav, &kxd, &kyd, &ksub1, &ksub2, iret );
for ( i = ksub1 - 1; i < ksub2; i++ ) {
if ( ( G_DIFFT(grpav[i], 0.0F, GDIFFD) ) ||
ERMISS ( grpav[i] ) || ERMISS ( grdp[i] ) )
grdz[i] = RMISSD;
else {
dp = grdp[i];
pav = grpav[i];
grdz[i] = cnst * pow ( ( pav / 1000. ), RKAPPA )
* ( dp / pav );
}
}
}
else if ( ivcord == 3 ) {
/*
* Height coordinate system.
* Generate a (constant) grid of height difference. No stack
* operations occur.
*/
dg_nxts ( &ndz, iret );
if ( *iret != 0 ) return;
dz = level1 - level2;
dg_real ( &dz, &ndz, iret );
}
else {
/*
* "No" or unrecognized coordinate system. This is an error.
*/
*iret = -24;
tmp = -1;
dg_merr ( "", "", "", &tmp, &tmp, &ivcord, errst, &ier );
dg_cset ( "ERRST", errst, iret );
return;
}
/*
* Compute the average THTA and THTA difference in the layer
* depending upon the coordinate system. Stack operations are
* designed to preserve access to in-line parameters.
*/
if (( ivcord == 1 ) || ( ivcord == 3)) {
/*
* Pressure or height coordinate system.
* Compute the delta THTA in the layer.
*/
dg_rpls ( "THTA", &zero, iret );
if ( *iret != 0 ) return;
df_ldf ( iret );
if ( *iret != 0 ) return;
dg_tops ( gdum, &ndth, time1, time2, &level1, &level2,
&ivcord, pdum, iret );
if ( *iret != 0 ) return;
/*
* Compute the average THTA in the layer.
*/
dg_rpls ( "THTA", &zero, iret );
if ( *iret != 0 ) return;
df_lav ( iret );
if ( *iret != 0 ) return;
dg_tops ( gdum, &nath, time1, time2, &level1, &level2,
&ivcord, pdum, iret );
if ( *iret != 0 ) return;
}
else if ( ivcord == 2 ) {
/*
* Isentropic coordinate system.
* Constant values are put into new grids (no stack operations).
* Compute the average THTA in the layer.
*/
dg_nxts ( &nath, iret );
if ( *iret != 0 ) return;
avtht = (level1 + level2) / 2.;
dg_real ( &avtht, &nath, iret );
/*
* Compute the THTA difference in the layer.
*/
dg_nxts ( &ndth, iret );
if ( *iret != 0 ) return;
deltht = level1 - level2;
dg_real ( &deltht, &ndth, iret );
}
/*
* No test for other values of IVCORD was needed because they
* were kicked out in the IF for DZ. Get a new grid for the
* Richardson number and compute it.
*/
dg_nxts ( &nrich, iret );
if ( *iret != 0 ) return;
dg_getg ( &ndz, &grdz, &kxd, &kyd, &ksub1, &ksub2, iret );
dg_getg ( &ndth, &grdth, &kxd, &kyd, &ksub1, &ksub2, iret );
dg_getg ( &nath, &grath, &kxd, &kyd, &ksub1, &ksub2, iret );
dg_getg ( &nwsq, &grwsq, &kxd, &kyd, &ksub1, &ksub2, iret );
dg_getg ( &nrich, &grrich, &kxd, &kyd, &ksub1, &ksub2, iret );
for ( i = ksub1 - 1; i < ksub2; i++ ) {
ath = grath[i];
dth = grdth[i];
dz = grdz[i];
dwsq = grwsq[i];
if ( ERMISS (ath ) || G_DIFFT(ath, 0.0F, GDIFFD) ||
ERMISS (dwsq) || G_DIFFT(dwsq, 0.0F, GDIFFD) ||
ERMISS (dth ) || ERMISS (dz ) )
grrich[i] = RMISSD;
else
grrich[i] = ( GRAVTY * dz / ath) * ( dth / dwsq );
}
/*
* Make a name of the form 'RICH'//V and update header;
* update the stack.
*/
dg_mnam ( "RICH", wname, "", gp, iret );
nval = 1;
dg_iget ( "IDLUN", &nval, &idlun, iret);
dg_upsg ( time1, time2, &level1, &level2, &ivcord, &idlun, gp,
&nrich, iret );
dg_rpls ( "", &nrich, iret );
dg_esub ( &nrich, &zero, &zero, &zero, &ier );
if ( ier != 0 ) *iret = ier;
return;
}
void dv_div ( int *iret )
/************************************************************************
* dv_div *
* *
* This subroutine computes the divergence of a vector: *
* *
* DIV ( V ) = DDX ( u ) + DDY ( v ) - u * {(mx/my)*[d(my)/dx]} *
* - v * {(my/mx)*[d(mx)/dy]} *
* *
* where my and mx are scale factors. The quantities in braces are *
* assumed to exist in common arrays YMSDX and XMSDY, respectively. *
* Divergence is a scalar field. *
* *
* dv_div ( 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. F. Brill/GSC 4/89 Added 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 Translate from Fortran *
************************************************************************/
{
int i, zero=0, nval, kxd, kyd, ksub1, ksub2, ier;
int numu, numv, numout, nddx, nddy, ixmsdy, iymsdx;
float *gru, *grv, *grout, *grddx, *grddy, *grxmsdy, *grymsdx;
/*------------------------------------------------------------------------*/
*iret = 0;
dg_ssub ( iret );
/*
* Get the (wind) vector.
*/
dg_getv ( &numu, &numv, iret );
if ( *iret != 0 ) return;
/*
* Get a new grid number.
*/
dg_nxts ( &numout, iret );
if ( *iret != 0 ) return;
/*
* Compute x derivative of u component.
*/
dg_puts ( &numu, iret );
if ( *iret != 0 ) return;
df_ddx ( iret );
if ( *iret != 0 ) return;
dg_gets ( &nddx, iret );
if ( *iret != 0 ) return;
/*
* Compute y derivative of v component.
*/
dg_puts ( &numv, iret );
if ( *iret != 0 ) return;
df_ddy ( iret );
if ( *iret != 0 ) return;
dg_gets ( &nddy, iret );
if ( *iret != 0 ) return;
/*
* Combine terms to compute divergence.
*/
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 );
dg_getg( &nddx, &grddx, &kxd, &kyd, &ksub1, &ksub2, iret );
dg_getg( &nddy, &grddy, &kxd, &kyd, &ksub1, &ksub2, iret );
/*
* 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, &grxmsdy, &kxd, &kyd, &ksub1, &ksub2, iret );
dg_getg( &iymsdx, &grymsdx, &kxd, &kyd, &ksub1, &ksub2, iret );
for ( i = ksub1 - 1; i < ksub2; i++ ) {
if ( ERMISS ( grddx[i] ) || ERMISS ( grddy[i] ) ||
ERMISS ( gru[i] ) || ERMISS ( grv[i] ) )
grout[i] = RMISSD;
else
grout[i] = grddx[i] + grddy[i] -
gru[i] * grymsdx[i] -
grv[i] * grxmsdy[i];
}
/*
* Make a name of the form 'DIV'//u and update header; update stack
*/
dg_updh ( "DIV", &numout, &numu, &zero, iret );
dg_puts ( &numout, iret );
dg_esub ( &numout, &zero, &zero, &zero, &ier );
if ( ier != 0 ) *iret = ier;
return;
}
void dv_dvdx ( int *iret )
/************************************************************************
* dv_dvdx *
* *
* This subroutine computes the x-derivative of a vector: *
* *
* DVDX ( V ) = [ DDX (u) - v * ( (my/mx) * d(mx)/dy ), *
* DDX (v) + u * ( (my/mx) * d(mx)/dy ) ] *
* *
* where mx and my are scale factors along x and y, respectively. *
* *
* dv_dvdx ( iret ) *
* *
* Output parameters: *
* *iret int Return code *
* As for DG_GETV *
** *
* Log: *
* K. Brill/NMC 1/93 *
* S. Jacobs/NMC 4/94 Clean up *
* 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 *
************************************************************************/
{
int i, kxd, kyd, ksub1, ksub2, ier, nval, zero=0;
int nu, nv, numu, numv;
float *grnu, *grnv, *grnumu, *grnumv;
int nuddx, nvddx, ixmsdy;
float *gruddx, *grvddx, *grxmsdy;
/*------------------------------------------------------------------------*/
*iret = 0;
dg_ssub ( iret );
/*
* Get the (wind) vector.
*/
dg_getv ( &numu, &numv, iret );
if ( *iret != 0 ) return;
/*
* Get a new vector grid number.
*/
dg_nxtv ( &nu, &nv, iret );
if ( *iret != 0 ) return;
/*
* Compute x derivatives of u and v components.
*/
dg_puts ( &numu, iret );
if ( *iret != 0 ) return;
df_ddx ( iret );
if ( *iret != 0 ) return;
dg_gets ( &nuddx, iret );
if ( *iret != 0 ) return;
dg_puts ( &numv, iret );
if ( *iret != 0 ) return;
df_ddx ( iret );
if ( *iret != 0 ) return;
dg_gets ( &nvddx, 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_getg ( &ixmsdy, &grxmsdy, &kxd, &kyd, &ksub1, &ksub2, iret );
/*
* Compute the output vector components.
*/
dg_getg ( &nu, &grnu, &kxd, &kyd, &ksub1, &ksub2, iret );
dg_getg ( &nv, &grnv, &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 ( &nuddx, &gruddx, &kxd, &kyd, &ksub1, &ksub2, iret );
dg_getg ( &nvddx, &grvddx, &kxd, &kyd, &ksub1, &ksub2, iret );
for ( i = ksub1 - 1; i < ksub2; i++ ) {
if ( ERMISS ( grvddx[i] ) || ERMISS ( gruddx[i] ) ||
ERMISS ( grnumu[i] ) || ERMISS ( grnumv[i] ) ) {
grnu[i] = RMISSD;
grnv[i] = RMISSD;
}
else {
grnu[i] = gruddx[i] - grnumv[i] * grxmsdy[i];
grnv[i] = grvddx[i] + grnumu[i] * grxmsdy[i];
}
}
/*
* Make a name of the form 'DVDX'//u and update header;
* update stack.
*/
dg_updv ( "DVDX", &nu, &nv, &numu, &zero, iret );
dg_putv ( &nu, &nv, iret );
dg_esub ( &nu, &nv, &zero, &zero, &ier );
if ( ier != 0 ) *iret = ier;
return;
}
