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_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_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_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_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_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_grad ( int *iret )
/************************************************************************
* dv_grad *
* *
* This subroutine computes the gradient of a scalar field: *
* *
* GRAD ( S ) = [ DDX ( S ), DDY ( S ) ] *
* *
* GRAD generates a vector field. *
* *
* dv_grad ( 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 routines *
* 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 *
************************************************************************/
{
int ier, zero=0;
int num, numu, numv;
/*------------------------------------------------------------------------*/
*iret = 0;
dg_ssub ( iret );
/*
* Get the scalar grid into grid table.
*/
dg_gets ( &num, iret );
if ( *iret != 0 ) return;
/*
* Put the scalar field on the stack, compute DDX, and get the
* result.
*/
dg_puts ( &num, iret );
if ( *iret != 0 ) return;
df_ddx ( iret );
if ( *iret != 0 ) return;
dg_gets ( &numu, iret );
if ( *iret != 0 ) return;
/*
* Put the scalar field back on the stack, compute DDY, and
* get the result.
*/
dg_puts ( &num, iret );
if ( *iret != 0 ) return;
df_ddy ( iret );
if ( *iret != 0 ) return;
dg_gets ( &numv, iret );
if ( *iret != 0 ) return;
/*
* Make a name of the form 'GRAD'//S and update the header;
* update the stack.
*/
dg_updv ( "GRAD", &numu, &numv, &num, &zero, iret );
dg_putv ( &numu, &numv, iret );
dg_esub ( &numu, &numv, &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_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;
}