Пример #1
0
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;
}
Пример #2
0
void dv_div ( int *iret )
/************************************************************************
 * dv_div								*
 *									*
 * This subroutine computes the divergence of a vector:			*
 *									*
 *     DIV ( V ) = DDX ( u ) + DDY ( v ) - u * {(mx/my)*[d(my)/dx]}   	*
 *					 - v * {(my/mx)*[d(mx)/dy]}	*
 *									*
 * where my and mx are scale factors.  The quantities in braces are	*
 * assumed to exist in common arrays YMSDX and XMSDY, respectively. 	*
 * Divergence is a scalar field.					*
 *									*
 * dv_div ( iret )							*
 *									*
 * Output parameters:							*
 *	*iret		int		Return code			*
 *					As for DG_GETV			*
 **									*
 * Log:									*
 * M. desJardins/GSFC	10/85						*
 * I. Graffman/RDS	 7/88	Call to DG_UPDH				*
 * G. Huffman/GSC	 9/88	New stack functions			*
 * G. Huffman/GSC	 9/88	Error messages				*
 * K. F. Brill/GSC	 4/89   Added scale factor code			*
 * K. Brill/GSC		 8/89   Subsetting				*
 * K. Brill/GSC		10/89   Subsetting				*
 * T. Lee/GSC		 4/96   Single dimension for dgg		*
 * T. Lee/GSC		 5/96	Moved IGDPT outside DO loop		*
 * K. Brill/HPC		 1/02	CALL DG_SSUB and DG_ESUB		*
 * K. Brill/HPC		 5/02	Eliminate LLMXGD declarations in DGCMN	*
 *				using int grds for scl fctr derivatives *
 * K. Brill/HPC		11/02	Eliminate use of the SUBA logical array	*
 * S. Gilbert/NCEP	11/05	Translate from Fortran                  *
 ************************************************************************/
{
        int             i, zero=0, nval, kxd, kyd, ksub1, ksub2, ier;
	int		numu, numv, numout, nddx, nddy, ixmsdy, iymsdx;
        float           *gru, *grv, *grout, *grddx, *grddy, *grxmsdy, *grymsdx;

/*------------------------------------------------------------------------*/
	*iret = 0;
	dg_ssub ( iret );

        /*
         *	Get the (wind) vector.
         */
	dg_getv  ( &numu, &numv, iret );
	if  ( *iret != 0 ) return;

        /*
         *	Get a new grid number.
         */
	dg_nxts  ( &numout, iret );
	if  ( *iret != 0 )  return;

        /*
         *	Compute x derivative of u component.
         */
	dg_puts ( &numu, iret );
	if ( *iret != 0 ) return;
	df_ddx ( iret );
	if ( *iret != 0 ) return;
	dg_gets ( &nddx, iret );
	if ( *iret != 0 ) return;

        /*
         *	Compute y derivative of v component.
         */
	dg_puts ( &numv, iret );
	if ( *iret != 0 ) return;
	df_ddy ( iret );
	if ( *iret != 0 ) return;
	dg_gets ( &nddy, iret );
	if ( *iret != 0 ) return;

        /*
         *	Combine terms to compute divergence.
         */
        dg_getg( &numu, &gru, &kxd, &kyd, &ksub1, &ksub2, iret );
        dg_getg( &numv, &grv, &kxd, &kyd, &ksub1, &ksub2, iret );
        dg_getg( &numout, &grout, &kxd, &kyd, &ksub1, &ksub2, iret );
        dg_getg( &nddx, &grddx, &kxd, &kyd, &ksub1, &ksub2, iret );
        dg_getg( &nddy, &grddy, &kxd, &kyd, &ksub1, &ksub2, iret );

        /*
         *	Compute map scale factor derivative coefficients.
         */
	dg_dmsf ( iret );
	if ( *iret != 0 ) return;

        nval = 1;
        dg_iget ("IXMSDY", &nval, &ixmsdy, iret );
        dg_iget ("IYMSDX", &nval, &iymsdx, iret );
        dg_getg( &ixmsdy, &grxmsdy, &kxd, &kyd, &ksub1, &ksub2, iret );
        dg_getg( &iymsdx, &grymsdx, &kxd, &kyd, &ksub1, &ksub2, iret );


	 for ( i = ksub1 - 1; i < ksub2; i++ ) {
	    if ( ERMISS ( grddx[i] ) || ERMISS ( grddy[i] ) ||
     	       	 ERMISS ( gru[i] )  || ERMISS ( grv[i] ) ) 
	       grout[i] = RMISSD;
	    else
	       grout[i] = grddx[i] + grddy[i] -
     			  gru[i] * grymsdx[i] - 
     		  	  grv[i] * grxmsdy[i];
	    
	}

        /*
         *	Make a name of the form 'DIV'//u and update header; update stack
         */
	dg_updh  ( "DIV", &numout, &numu, &zero, iret );
	dg_puts  ( &numout, iret );
	dg_esub  ( &numout, &zero, &zero, &zero, &ier );
	if ( ier != 0 ) *iret = ier;

	return;
}
Пример #3
0
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;
}
Пример #4
0
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;
}
Пример #5
0
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;
}
Пример #6
0
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;
}
Пример #7
0
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;
}
Пример #8
0
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;
}
Пример #9
0
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;
}
Пример #10
0
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;
}
Пример #11
0
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;
}
Пример #12
0
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;
}
Пример #13
0
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;
}
Пример #14
0
void df_knts ( int *iret )
/************************************************************************
 * df_knts								*
 *									*
 * This subroutine converts speed in meters/second to knots:		*
 *									*
 *     KNTS (S) = PD_MSKN (S)						*
 *              = S * 1.9438						*
 *									*
 * df_knts ( 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				*
 * M. desJardins/GSFC	 7/89	Added PA subroutines			*
 * M. desJardins/GSFC	 8/89	PA to PD subroutines			*
 * M. desJardins/GSFC	 2/90	Correct call to PD_MSKN			*
 * 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, num, kxd, kyd, kxyd, ksub1, ksub2, zero, ier;
    float *gnum1, *gnum;
/*----------------------------------------------------------------------*/
    *iret = 0;
    zero = 0;

    dg_ssub ( iret );

    /*
     * Get the grid number.
     */
    dg_gets ( &num1, iret );
    if ( *iret != 0 ) return;
    dg_getg ( &num1, &gnum1, &kxd, &kyd, &ksub1, &ksub2, iret );

    /*
     * Get a new grid number and convert to knots.
     */
    dg_nxts ( &num, iret );
    if ( *iret != 0 ) return;
    dg_getg ( &num, &gnum, &kxd, &kyd, &ksub1, &ksub2, iret );

    kxyd = kxd * kyd;
    pd_mskn ( gnum1, &kxyd, gnum, &ier );

    /*
     * Make a name of the form 'KNT'//S and update header;
     * update stack.
     */
    dg_updh ( "KNT", &num, &num1, &zero, iret );
    dg_puts ( &num, iret );
    dg_esub ( &num, &zero, &zero, &zero, &ier );
    if ( ier != 0 ) *iret = ier;

    return;
}
Пример #15
0
void df_reli ( int *iret )
/************************************************************************
 * df_reli								*
 *									*
 * This subroutine computes the relative humidity with respect to ice	*
 * from the temperature	and dewpoint temperature (temperature must be 	*
 * less than 0.01C, otherwise RMISSD is assigned).			*
 *									*
 *     RELI  ( TEMP, DWPT ) = PD_RELI ( TEMP, DWPT )			*
 *									*
 * df_reli ( iret )							*
 *									*
 * Output parameters:							*
 *	*iret		int		Return code			*
 *					As for DG_GETS			*
 **									*
 * Log:									*
 * S. Chiswell/Unidata		1/07					*
 ************************************************************************/
{
    int num1, num2, num, kxd, kyd, kxyd, ksub1, ksub2, zero, ier;
    float *gnum1, *gnum2, *gnum;
/*----------------------------------------------------------------------*/
    *iret = 0;
    zero = 0;

    dg_ssub ( iret );

    /*
     * Get the two input grid numbers.
     */
    dg_gets ( &num1, iret );
    if ( *iret != 0 ) return;
    dg_gets ( &num2, iret );
    if ( *iret != 0 ) return;

    /*
     * Get a new grid number and compute the relative huminity.
     */
    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_reli ( gnum1, gnum2, &kxyd, gnum, &ier );

    /*    
     * Make a name of the form 'RELI'//S1//S2 and update header;
     * update stack.
     */
    dg_updh ( "RELI", &num, &num1, &num2, iret );
    dg_puts ( &num, iret );
    dg_esub ( &num, &zero, &zero, &zero, &ier );
    if ( ier != 0 ) *iret = ier;

    return;
}
Пример #16
0
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;
}
Пример #17
0
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;
}
Пример #18
0
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;
}
Пример #19
0
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;
}
Пример #20
0
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;
}
Пример #21
0
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;
}
Пример #22
0
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;
}
Пример #23
0
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;
}
Пример #24
0
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;
}
Пример #25
0
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;
}
Пример #26
0
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;
}
Пример #27
0
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;
}
Пример #28
0
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;
}
Пример #29
0
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;
}
Пример #30
0
void df_mask ( int *iret )
/************************************************************************
 * df_mask								*
 *									*
 * This subroutine masks a scalar grid.					*
 *									*
 * df_mask ( 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		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 process 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;
	}
    }

    /*
     * Make a name of the form 'MASK'//S1//S2 and update header;
     * update stack.
     */
    dg_updh ( "MASK", &num, &num1, &num2, iret );
    dg_puts ( &num, iret );
    dg_esub ( &num, &zero, &zero, &zero, &ier );
    if ( ier != 0 ) *iret = ier;

    return;
}