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 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_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 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 dv_squo ( int *iret )
/************************************************************************
* dv_squo *
* *
* This subroutine divides a scalar with each component of a vector: *
* *
* SQUO ( S, V ) = [ u/S, v/S ] *
* *
* SQUO generates a vector grid. *
* *
* dv_squo ( iret ) *
* *
* Output parameters: *
* *iret int Return code *
* As for DG_GETV *
** *
* Log: *
* J. Whistler/SSAI 3/91 Adapted from DV_SMUL *
* K. Brill/HPC 1/02 CALL DG_SSUB and DG_ESUB *
* S. Gilbert/NCEP 11/05 Translation from Fortran *
************************************************************************/
{
const int zero=0;
int num, nvecu, nvecv, noutu, noutv, ier;
/*----------------------------------------------------------------------*/
*iret = 0;
dg_ssub ( iret );
/*
* Get the scalar and vector from the stack (grid numbers are used
* in name generation).
*/
dg_gets ( &num, iret );
if ( *iret != 0 ) return;
dg_getv ( &nvecu, &nvecv, iret );
if ( *iret != 0 ) return;
/*
* Put S and the u-component on the stack.
*/
dg_puts ( &num, iret );
if ( *iret != 0 ) return;
dg_puts ( &nvecu, iret );
if ( *iret != 0 ) return;
/*
* Divides and get the grid off the stack.
*/
df_quo ( iret );
if ( *iret != 0 ) return;
dg_gets ( &noutu, iret );
if ( *iret != 0 ) return;
/*
* Put S and the v-component on the stack.
*/
dg_puts ( &num, iret );
if ( *iret != 0 ) return;
dg_puts ( &nvecv, iret );
if ( *iret != 0 ) return;
/*
* Divides and get the grid off the stack.
*/
df_quo ( iret );
if ( *iret != 0 ) return;
dg_gets ( &noutv, iret );
if ( *iret != 0 ) return;
/*
* Make a name of the form 'SQUO'//S//u2 and update both grid
* headers; update the stack.
*/
dg_updv ("SQUO", &noutu, &noutv, &num, &nvecu, iret );
dg_putv ( &noutu, &noutv, iret );
dg_esub ( &noutu, &noutv, &zero, &zero, &ier );
if ( ier != 0 ) *iret = ier;
return;
}
void dv_vn ( int *iret )
/************************************************************************
* dv_vn *
* *
* This subroutine returns the v component of a vector in north *
* relative coordinates. *
* *
* VN ( V ) = v *
* *
* dv_vn ( iret ) *
* *
* Output parameters: *
* *iret int Return code *
* As for DG_GETV *
** *
* Log: *
* M. desJardins/GSFC 10/85 *
* M. desJardins/GSFC 5/88 Added new stack functions *
* I. Graffman/RDS 7/88 Call to DG_UPDH *
* G. Huffman/GSC 9/88 Error messages *
* M. desJardins/GSFC 4/89 Added grid relative functions *
* T. Lee/GSC 4/96 Single dimension for dgg *
* K. Brill/HPC 1/02 CALL DG_SSUB and DG_ESUB *
* S. Gilbert/NCEP 11/05 Translation from Fortran *
************************************************************************/
{
const int zero = 0;
int ier, kxd, kyd, ksub1, ksub2;
int numu, numv, nunor, nvnor;
float *gru, *grv, *grunor, *grvnor;
/*----------------------------------------------------------------------*/
*iret = 0;
dg_ssub ( iret );
/*
* Get the vector from the stack.
*/
dg_getv ( &numu, &numv, iret );
if ( *iret != 0 ) return;
/*
* Get a new vector to translate from grid relative to north
* relative components.
*/
dg_nxtv ( &nunor, &nvnor, iret );
if ( *iret != 0 ) return;
/*
* Internal grid are always grid relative. Translate to north rel.
*/
dg_getg ( &numu, &gru, &kxd, &kyd, &ksub1, &ksub2, iret );
dg_getg ( &numv, &grv, &kxd, &kyd, &ksub1, &ksub2, iret );
dg_getg ( &nunor, &grunor, &kxd, &kyd, &ksub1, &ksub2, iret );
dg_getg ( &nvnor, &grvnor, &kxd, &kyd, &ksub1, &ksub2, iret );
dg_nrel ( gru, grv, grunor, grvnor, &ier );
/*
* Return the v component. Make a name of the form 'V'//v and
* update the header; update the stack.
*/
dg_updh ( "V", &nvnor, &numv, &zero, iret );
dg_puts ( &nvnor, iret );
dg_esub ( &nvnor, &zero, &zero, &zero, &ier );
if ( ier != 0 ) *iret = ier;
return;
}
void dv_ross ( int *iret )
/************************************************************************
* dv_ross *
* *
* This subroutine computes the Rossby number from two winds: *
* *
* ROSS ( V1, V2 ) = MAG ( INAD ( V1, V2 ) ) / ( CORL * MAG ( V1 ) )*
* *
* ROSS generates a scalar grid. *
* *
* dv_ross ( iret ) *
* *
* Output parameters: *
* *iret int Return code *
* As for DG_GETV *
** *
* Log: *
* M. Goodman/RDS 12/85 *
* I. Graffman/RDS 7/88 Call to DG_UPDH *
* G. Huffman/GSC 9/88 New stack functions *
* G. Huffman/GSC 9/88 Error messages *
* K. Brill/NMC 11/90 Pass grid number to DF_CORL *
* K. Brill/HPC 1/02 CALL DG_SSUB and DG_ESUB *
* S. Gilbert/NCEP 11/05 Translation from Fortran *
************************************************************************/
{
int iret1, iret2, ier, zero=0;
int num1u, num1v, num2u, num2v, numcor, nross;
/*------------------------------------------------------------------------*/
*iret = 0;
dg_ssub ( iret );
/*
* Get the two vectors.
*/
dg_getv ( &num1u, &num1v, iret );
if ( *iret != 0 ) return;
dg_getv ( &num2u, &num2v, iret );
if ( *iret != 0 ) return;
/*
* Put V1 on the stack and compute MAG; compute CORL and multiply
* (creating the denominator). Leave the result on the stack.
*/
dg_putv ( &num1u, &num1v, iret );
if ( *iret != 0 ) return;
dv_mag ( iret );
if ( *iret != 0 ) return;
dg_nxts ( &numcor, &iret1 );
df_corl ( &numcor, &iret2 );
dg_puts ( &numcor, iret );
*iret = *iret + iret1 + iret2;
if ( *iret != 0 ) return;
df_mul ( iret );
if ( *iret != 0 ) return;
/*
* Put the winds on the stack (LIFO order), compute the inertial
* advective wind, and take its MAG.
*/
dg_putv ( &num2u, &num2v, iret );
if ( *iret != 0 ) return;
dg_putv ( &num1u, &num1v, iret );
if ( *iret != 0 ) return;
dv_inad ( iret );
if ( *iret != 0 ) return;
dv_mag (iret);
if ( *iret != 0 ) return;
/*magiad = istack (itop)*/
/*
* Complete the calculation and get the result.
*/
df_quo ( iret );
if ( *iret != 0 ) return;
dg_gets ( &nross, iret );
if ( *iret != 0 ) return;
/*
* Make a name of the form 'ROSS'//u1//u2 and update header;
* update the stack.
*/
dg_updh ( "ROSS", &nross, &num1u, &num2u, iret );
dg_puts ( &nross, iret );
dg_esub ( &nross, &zero, &zero, &zero, &ier );
if ( ier != 0 ) *iret = ier;
return;
}
void dv_vavs ( int *iret )
/************************************************************************
* dv_vavs *
* *
* This subroutine computes the average vector for a vector field but *
* only over the subset area. VAVS generates a vector with the *
* average at each grid point in the subset area. *
* *
* dv_vavs ( iret ) *
* *
* Output parameters: *
* *iret int Return code *
* As for DG_GETV *
** *
* Log: *
* K. Brill/NMC 10/90 *
* K. Brill/HPC 1/02 CALL DG_SSUB and DG_ESUB *
* S. Gilbert/NCEP 11/05 Translation from Fortran *
************************************************************************/
{
const int zero=0;
int nui, nvi, nuo, nvo, ier;
/*----------------------------------------------------------------------*/
*iret = 0;
dg_ssub ( iret );
/*
* Get the grid numbers for the input vector.
*/
dg_getv ( &nui, &nvi, iret );
if ( *iret != 0 ) return;
/*
* Put the u-component of the wind on the stack and average.
*/
dg_puts ( &nui, iret );
if ( *iret != 0 ) return;
df_savs ( iret );
if ( *iret != 0 ) return;
dg_gets ( &nuo, iret );
if ( *iret != 0 ) return;
/*
* Put the v-component of the wind on the stack and average.
*/
dg_puts ( &nvi, iret );
if ( *iret != 0 ) return;
df_savs ( iret );
if ( *iret != 0 ) return;
dg_gets ( &nvo, iret );
if ( *iret != 0 ) return;
/*
* Make a name of the form 'AVS'//u1//u2 and update header;
* update the stack.
*/
dg_updv ( "AVS", &nuo, &nvo, &nui, &nvi, iret );
dg_putv ( &nuo, &nvo, iret );
dg_esub ( &nuo, &nvo, &zero, &zero, &ier );
if ( ier != 0 ) *iret = ier;
return;
}
void 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_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 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_vquo ( int *iret )
/************************************************************************
* dv_vquo *
* *
* This subroutine divides the components of two vectors: *
* *
* VQUO ( V1, V2 ) = [ u1/u2, v1/v2 ] *
* *
* VQUO generates a vector grid. *
* *
* dv_vquo ( iret ) *
* *
* Output parameters: *
* *iret int Return code *
* As for DG_GETV *
** *
* Log: *
* M. Goodman/RDS 10/85 *
* M. desJardins/GSFC 5/88 Added new stack functions *
* G. Huffman/GSC 9/88 Error messages *
* 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;
int nvec1u, nvec1v, nvec2u, nvec2v, nvec3u, nvec3v;
/*----------------------------------------------------------------------*/
*iret = 0;
dg_ssub ( iret );
/*
* Get the two vectors from the stack (grid numbers are used for
* name generation).
*/
dg_getv ( &nvec1u, &nvec1v, iret );
if ( *iret != 0 ) return;
dg_getv ( &nvec2u, &nvec2v, iret );
if ( *iret != 0 ) return;
/*
* Put the u-component of vector 2 and vector 1 on the stack.
*/
dg_puts ( &nvec2u, iret );
if ( *iret != 0 ) return;
dg_puts ( &nvec1u, iret );
if ( *iret != 0 ) return;
/*
* Divide the u-components and get the grid number.
*/
df_quo ( iret );
if ( *iret != 0 ) return;
dg_gets ( &nvec3u, iret );
if ( *iret != 0 ) return;
/*
* Put the v-component of vector 2 and vector 1 on the stack.
*/
dg_puts ( &nvec2v, iret );
if ( *iret != 0 ) return;
dg_puts ( &nvec1v, iret );
if ( *iret != 0 ) return;
/*
* Divide the v-components and get the grid number.
*/
df_quo ( iret );
if ( *iret != 0 ) return;
dg_gets ( &nvec3v, iret );
if ( *iret != 0 ) return;
/*
* Make a name of the form 'VQUO'//u1//u2 and update both grid
* headers; update the stack.
*/
dg_updv ( "VQUO", &nvec3u, &nvec3v, &nvec1u, &nvec2u, iret );
dg_putv ( &nvec3u, &nvec3v, iret );
dg_esub ( &nvec3u, &nvec3v, &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;
}
