void df_beta ( const int *num, int *iret )
/************************************************************************
* df_beta *
* *
* This subroutine computes the Coriolis acceleration at each grid *
* point. The following equation is used: *
* *
* BETA = d (CORL) / dy *
* *
* This computation has no operand. *
* *
* df_beta ( num, iret ) *
* *
* Input parameter: *
* *num const int Grid number *
* Output parameters: *
* *iret int Return code *
* 0 = normal return *
* -10 = Internal grid list is full*
* -12 = ... must be a scalar *
* -16 = Map proj. ... is invalid *
* -20 = Stack is full *
** *
* Log: *
* D. McCann/AWC 4/01 *
* K. Brill/HPC 1/02 CALL DG_SSUB, DG_ESUB; RTRN after NXTS *
* R. Tian/SAIC 10/05 Recoded from Fortran *
************************************************************************/
{
int ncorl, zero, ier;
/*----------------------------------------------------------------------*/
*iret = 0;
zero = 0;
dg_ssub ( iret );
/*
* Check if navigation parameters have been computed.
*/
dg_ltln ( iret );
if ( *iret != 0 ) return;
/*
* Get a new grid number for CORL.
*/
dg_nxts ( &ncorl, iret );
if ( *iret != 0 ) return;
/*
* Compute beta..
*/
df_corl ( &ncorl, iret );
dg_puts ( &ncorl, iret );
df_ddy ( iret );
dg_gets ( (int *)num, iret );
dg_esub ( (int *)num, &zero, &zero, &zero, &ier );
if ( ier != 0 ) *iret = ier;
return;
}
void df_bool ( int *iret )
/************************************************************************
* df_bool *
* *
* This subroutine checks a scalar grid and returns 0 if the grid point *
* is missing and 1 if the grid point has data. *
* *
* df_bool ( iret ) *
* *
* Output parameters: *
* *iret int Return code *
* As for DG_GETS *
** *
* Log: *
* D.W.Plummer/NCEP 7/98 Copied from DF_MUL *
* 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, ier, fidx, cidx, zero;
float *gnum1, *gnum, dg1;
/*----------------------------------------------------------------------*/
*iret = 0;
zero = 0;
dg_ssub ( iret );
/*
* Get the 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, &ier );
dg_getg ( &num, &gnum, &kxd, &kyd, &ksub1, &ksub2, &ier );
/*
* Process the grids.
*/
for ( fidx = ksub1; fidx <= ksub2; fidx++ ) {
cidx = fidx - 1;
dg1 = gnum1[cidx];
if ( ERMISS (dg1) ) {
gnum[cidx] = 0.0;
} else {
gnum[cidx] = 1.0;
}
}
/*
* Make a name of the form 'BOOL'//S1 and update header;
* update stack.
*/
dg_updh ( "BOOL", &num, &num1, &zero, iret );
dg_puts ( &num, iret );
dg_esub ( &num, &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_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 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_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 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 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 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 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 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_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 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;
}
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_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 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 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_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_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 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 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_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_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_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 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 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 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 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_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;
}
