コード例 #1
0
ファイル: decval.c プロジェクト: ArielleBassanelli/gempak
void de_cval ( const char *uarg, char *stprm, int *iret )
/************************************************************************
 * de_cval								*
 *									*
 * This function determines the value of the function defined by PARM 	*
 * for which the probability is PRB that the observed value is less 	*
 * than or equal to that computed value based on an idealized ensemble 	*
 * forecast.								*
 *									*
 * GFUNC syntax: ENS_CVAL ( PARM & PRB & LWRBND & UPRBND )		*
 *									*
 * de_cval ( uarg, stprm, iret )					*
 *									*
 * Input and parameters:						*
 *	*uarg		const char	Function argument string	*
 *									*
 * Output parameters:							*
 *	*stprm		char		Substitution string		*
 *	*iret		int		Return code			*
 *					 +3 = Percentile < 0		*
 *					 +1 = Percentile > 100		*
 *					  0 = normal return		*
 *					 -8 = cannot parse argument	*
 *					 -9 = ensemble cannot computed	*
 * 					-15 = Incorrect # of arguments	*
 **									*
 * Log:									*
 * M. Li/SAIC 		10/06						*
 * M. Li/SAIC 		10/06 	Added a check for missing value		*
 * K. Brill/HPC      20080131   Add intrinsic weight computations; fix	*
 *   				eliminate duplicates coding error	*
 * K. Brill/HPC      20101118   Check for single value order stats case *
 ************************************************************************/
{
    char tname[13], pdum[13], time1[21], time2[21];
    char **argu;
    int igo, igp, num, kxd, kyd, ksub1, ksub2, nina, narg, level1, level2,
        ivcord, zero, one, ii, jj, kk, ll, mm, nn, ier;
    int iswflg, istop;
    float *gigo, *gigp, *gnum, data, swpbuf, psum;
    float *gilwr, *giupr, *tmpwt, wtbuf, tol;
    float *zwts, *zfreq;
    float zsum;
    float vn, qlt, qrt, fta, cta, aa, bb, cc;
    Boolean ibreak;
/*----------------------------------------------------------------------*/
    *iret = 0;
    zero = 0;
    one = 1;

    dg_ssub ( iret );

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

    /*
     * Initialize the output grid.
     */
    dg_getg ( &igo, &gigo, &kxd, &kyd, &ksub1, &ksub2, iret );
    for ( ii = ksub1 - 1; ii < ksub2; ii++ ) {
	gigo[ii] = RMISSD;
    }

    /*
     * Set the number of input arguments.  There are up to four arguments
     * for DE_CVAL.
     */
    for ( ii = 0; ii < MXARGS; ii++ ) {
	_ensdiag.allarg[ii][0] = '\0';
    }
    nina = 4;
    argu = (char **)cmm_malloc2d ( 4, MXFLSZ+1, sizeof(char), &ier );
    cst_clst ( (char *)uarg, '&', " ", nina, MXFLSZ, argu, &narg, &ier );
    for ( ii = 0; ii < narg; ii++ ) {
        strcpy ( _ensdiag.allarg[ii], argu[ii] );
	if ( ii > 0 && strcmp(argu[ii], " ") == 0 ) {
	    cst_rlch ( RMISSD, 1, _ensdiag.allarg[ii], &ier );
	}
    }

    if ( narg == 2 ) {
	cst_rlch ( RMISSD, 1, _ensdiag.allarg[2], &ier );
	cst_rlch ( RMISSD, 1, _ensdiag.allarg[3], &ier );
    }
    if ( narg == 3 ) {
        cst_rlch ( RMISSD, 1, _ensdiag.allarg[3], &ier );
    }

    cmm_free2d ( (void **) argu, &ier );
    if ( narg < 2 ) {
	*iret = -15;
	return;
    }

    /*
     * Scan the allarg array.
     */
    de_scan ( &nina, iret );
    if ( *iret != 0 ) return;

    /*
     * Evaluate the static arguments.
     */
    for ( ii = 2; ii < nina; ii++ ) {
	dg_pfun ( _ensdiag.allarg[ii], iret );
        dg_driv ( &one, iret );
	dg_tops ( tname, &igp, time1, time2, &level1, &level2,
                  &ivcord, pdum, iret );
	if ( ii == 2 ) {
            dg_getg ( &igp, &gilwr, &kxd, &kyd, &ksub1, &ksub2, iret );
	}
 	else {
            dg_getg ( &igp, &giupr, &kxd, &kyd, &ksub1, &ksub2, iret );
	}
    }
    
    dg_pfun ( _ensdiag.allarg[1], iret );
    if ( *iret != 0 ) {
	er_wmsg ( "DG", iret, " ", &ier, strlen("DG"), strlen(" ") );
	*iret = -8;
	return;
    }
    dg_driv ( &one, iret );
    if ( *iret != 0 ) {
	er_wmsg ( "DG", iret, _ensdiag.allarg[1], &ier,
	    strlen("DG"), strlen(_ensdiag.allarg[1]) );
	*iret = -9;
	return;
    }

    /*
     * Retrieve the output grid from the stack.  Check that the 
     * output is a scalar.
     */	
    dg_tops ( tname, &igp, time1, time2, &level1, &level2,
        &ivcord, pdum, iret );
    dg_getg ( &igp, &gigp, &kxd, &kyd, &ksub1, &ksub2, iret );

    /*
     * Loop over number of members set by DE_SCAN.
     */
    for ( ii = 0; ii < _ensdiag.nummbr; ii++ ) {
	de_mset ( &ii, iret );
	dg_pfun ( _ensdiag.allarg[0], iret );
	if ( *iret != 0 ) {
	    er_wmsg ( "DG", iret, " ", &ier, strlen("DG"), strlen(" ") );
	    *iret = -8;
	    return;
	}
	dg_driv ( &one, iret );
	if ( *iret != 0 ) {
	    er_wmsg ( "DG", iret, _ensdiag.allarg[0], &ier,
	        strlen("DG"), strlen(_ensdiag.allarg[0]) );
	    *iret = -9;
	    return;
	}

	/*
	 * Retrieve the output grid from the stack and store the
	 * grid number.
	 */
	dg_tops ( tname, &num, time1, time2, &level1, &level2,
	    &ivcord, pdum, iret );
	_ensdiag.iglist[ii] = num;
    }

    /*
     * Get memory for intrinsic weights (zwts), intrinsic weight
     * frequency (zfreq), and temporary weights.
     */
    G_MALLOC ( zwts, float, _ensdiag.nummbr+1, "x" );
    G_MALLOC ( zfreq, float, _ensdiag.nummbr+1, "x" );
    G_MALLOC ( tmpwt, float, _ensdiag.nummbr+2, "x" );

    for ( ll = ksub1 - 1; ll < ksub2; ll++ ) {

	if ( ERMISS(gigp[ll]) ) continue;	

        if ( gigp[ll] < 0.0F || gigp[ll] > 1.0F ) continue;

	for ( ii = 0; ii < _ensdiag.nummbr; ii++ ) {
	    ibreak = False;
	    num = _ensdiag.iglist[ii];
	    dg_getg ( &num, &gnum, &kxd, &kyd, &ksub1, &ksub2, iret );
	    data = gnum[ll];
	    if ( ! ERMISS ( data ) ) {
	        _ensdiag.emvalu[ii+1] = data;
		tmpwt[ii+1] = _ensdiag.enswts[ii];

	        if ( ii == _ensdiag.nummbr - 1 ) {
	            /*
		     * Bubble sorting the grid values in emvalu with 
		     * emvalue (1) lowest and emvalu (nummbr) highest.
		     */
	            iswflg = 1;
	            istop = _ensdiag.nummbr;
		    while ( iswflg != 0 && istop > 0 ) {
		        iswflg = 0;
		        for ( kk = 1; kk < istop; kk++ ) {
		            if ( _ensdiag.emvalu[kk] > _ensdiag.emvalu[kk+1] ) {
		                iswflg = 1;
			        swpbuf = _ensdiag.emvalu[kk];
				wtbuf = tmpwt[kk];
			        _ensdiag.emvalu[kk] = _ensdiag.emvalu[kk+1];
				tmpwt[kk] = tmpwt[kk+1];
			        _ensdiag.emvalu[kk+1] = swpbuf;
			        tmpwt[kk+1] = wtbuf;
		            }
		        }
		        istop--;
		    }

		    /*
		     * Check for identical values and compute intrinsic weight
      		     * frequency (zfreq).
		     */
		    mm = _ensdiag.nummbr;
		    nn = mm;
		    /*
                     * Initialize intrinsic weight frequency array.
                     */
                    for (kk = 1; kk <= nn; kk++){
                        zfreq[kk] = 1.0F;
                    }
		    tol = 0.001F * (_ensdiag.emvalu[mm]-_ensdiag.emvalu[1]) / mm;
		    for (kk = 1; kk < mm; kk++) {
			if ( G_ABS(_ensdiag.emvalu[kk] - _ensdiag.emvalu[kk+1]) <= tol ) {
			    tmpwt[kk] += tmpwt[kk+1];
			    zfreq[kk] = zfreq[kk] + 1.0F;
			    mm--;
			    for (jj = kk+1; jj <= mm; jj++) {
				_ensdiag.emvalu[jj] = _ensdiag.emvalu[jj+1];
				tmpwt[jj] = tmpwt[jj+1];
			    } 
			    /* This algorithm was originally coded incorrectly.  The value
			     * of kk must also be held back to correctly eliminate three
			     * or more identical values.
			     */
			    kk--;
			}
		    } 

		    /*
		     * Fabricate order statistics if it has collapsed to a single value.            
		     */
		    if ( mm == 1 ) {
		    	if ( G_DIFF(_ensdiag.emvalu[1], 0.0F) ) {
			    _ensdiag.emvalu[1] = -0.00001F;
			    _ensdiag.emvalu[2] = 0.00001F;
			}
			else {
                            _ensdiag.emvalu[2] = _ensdiag.emvalu[1] + 0.00001F * G_ABS(_ensdiag.emvalu[1]);
			    _ensdiag.emvalu[1] -= 0.00001F * G_ABS(_ensdiag.emvalu[1]);
			}

			tmpwt[1] = 0.5F;
		        tmpwt[2] = 0.5F;
			mm = 2;
			zfreq[1] = 1.0F;
			zfreq[2] = 1.0F;
		    }
		    /*
		     *Compute and sum intrinsic weights.
		    */
		    zwts[1] = zfreq[1] / ( _ensdiag.emvalu[2] - _ensdiag.emvalu[1] );
		    zsum = zwts[1];
		    for (kk=2; kk < mm; kk++){
			zwts[kk] = ( zfreq[kk] * 2.0F ) / ( _ensdiag.emvalu[kk+1] - _ensdiag.emvalu[kk-1] );
			zsum = zsum + zwts[kk];
		    }
		    zwts[mm] = zfreq[mm] / ( _ensdiag.emvalu[mm] - _ensdiag.emvalu[mm-1] );
		    zsum = zsum + zwts[mm];
		    /*
		     * Scale external weights by normalized intrinsic weights and
		     * normalize.
		     */
 		    psum = 0.0F;
		    for (kk=1; kk <= mm; kk++ ){
			tmpwt[kk] = ( zwts[kk] / zsum ) * tmpwt[kk];
			psum = psum + tmpwt[kk];
		    }
		    for (kk=1; kk <= mm; kk++ ){
			tmpwt[kk] = tmpwt[kk] / psum;
		    }
	        } /*End "if" for all members ready check.*/
	    }
	    else {
		ibreak = True;
		break;
	    } /*End "if" for check for non-missing value.*/
	} /*End "for" loop over members.*/

	if ( ibreak ) continue;

	/*
         * Compute Qun, the area; Vn, the normalized value; 
	 * w(), normalized weight; and qlt, qrt.
         */
        vn = 0.0F;
        for ( kk = 2; kk <= mm; kk++ ) {
            vn += 0.5 * (tmpwt[kk] + tmpwt[kk-1]) * (_ensdiag.emvalu[kk] - _ensdiag.emvalu[kk-1]);
        }
	/*
	 * If the distribution is a Dirac spike over a single value, then set the result to
         * that single value.
	 */
	if ( G_DIFF ( vn, 0.0 ) ) {
	    gigo[ll] = _ensdiag.emvalu[1];
	    continue;
	}
        vn = vn / (1.0F - 2.0F / (nn+1));

        for ( kk = 1; kk <= mm; kk++ ) {
            tmpwt[kk] = tmpwt[kk] / vn;
        }

        qlt = _ensdiag.emvalu[1] - 2.0F / (tmpwt[1] * (nn + 1));
        qrt = _ensdiag.emvalu[mm] + 2.0F / (tmpwt[mm] * (nn + 1));

        tmpwt[0] = 0.0F;
        tmpwt[mm+1] = 0.0F;
        _ensdiag.emvalu[0] = qlt;
        _ensdiag.emvalu[mm+1] = qrt;

 	psum = 0.0F;
	for ( kk = 1; kk <= mm + 1; kk++ ) {

	    /*
	     * Compute CTA.
	     */
	    cta = 0.5F * (tmpwt[kk] + tmpwt[kk-1]) * (_ensdiag.emvalu[kk] - _ensdiag.emvalu[kk-1]);
	    psum += cta;
	    if ( kk == mm + 1 ) psum = 1.0F;

	    /*
	     * If psum = PRB, assign q[i] to output grid and move on to next grid point.
	     * (This was coded incorrectly and fixed on 20080205 -KB.)
	     */
	    if ( G_DIFF ( gigp[ll], psum ) ) {
		gigo[ll] = _ensdiag.emvalu[kk];
		break;
	    }

	    /*
	     * If psum > PRB. Solve the quadratic equation.
	     */
	    if ( psum > gigp[ll] ) {
	    	psum -= cta;
	    	fta = gigp[ll] - psum;
	    	aa = (tmpwt[kk] - tmpwt[kk-1]) / (_ensdiag.emvalu[kk] - _ensdiag.emvalu[kk-1]); 
	    	bb = 2.0F * tmpwt[kk-1];
	    	cc = 2.0F * fta;

	    	if ( G_DIFF ( aa, 0.0F ) ) {
	   	    gigo[ll] = _ensdiag.emvalu[kk-1] + cc / bb;
	    	}
 	    	else {
		    gigo[ll] = _ensdiag.emvalu[kk-1] + (sqrt(bb * bb + 4 * aa * cc) - bb) / (2 * aa);
	        }
	        
		if ( ! ERMISS(gilwr[ll]) && gigo[ll] < gilwr[ll] ) gigo[ll] = gilwr[ll];
		if ( ! ERMISS(giupr[ll]) && gigo[ll] > giupr[ll] ) gigo[ll] = giupr[ll];
	        
	        break;
	    }

	}

    }

    G_FREE (tmpwt, float);
    G_FREE (zfreq, float);
    G_FREE (zwts, float);
    /*
     * Reset DGCMN.CMN and set internal grid identifier.
     */
    de_rset ( iret );
    dg_udig ( "EXX_", &igo, &zero, &_ensdiag.idgens, stprm, iret );
    dg_esub ( &igo, &zero, &zero, &zero, &ier );
    if ( ier != 0 ) *iret = ier;

    return;
}
コード例 #2
0
ファイル: dftmwk.c プロジェクト: ArielleBassanelli/gempak
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;
}
コード例 #3
0
ファイル: dvvasv.c プロジェクト: ArielleBassanelli/gempak
void dv_vasv ( int *iret )
/************************************************************************
 * dv_vasv								*
 *									*
 * This subroutine computes the vector component of the first vector	*
 * along the second vector.						*
 *									*
 *     VASV ( V1, V2 ) = [ DOT (V1,V2) / MAG (V2) ** 2 ] V2		*
 *									*
 * VASV generates a vector field.					*
 *									*
 * dv_vasv  ( iret )							*
 *									*
 * Output parameters:							*
 *	*iret		int		Return code			*
 *					As for DG_GETV			*
 **									*
 * Log:									*
 * K. Brill/NMC		 1/93 						* 
 * S. Chiswell/Unidata	 2/96	Redefined mag as REAL rmg		*
 * T. Lee/GSC		 4/96   Single dimension for dgg		*
 * T. Lee/GSC		 5/96   Moved IGDPT outside DO loop		*
 * K. Brill/HPC		 1/02	CALL DG_SSUB and DG_ESUB		*
 * K. Brill/HPC		11/02	Eliminate use of the SUBA logical array	*
 * S. Gilbert/NCEP	11/05	Translation from Fortran                *
 ************************************************************************/
{
        const int       zero=0;
        int             i, ier, kxd, kyd, ksub1, ksub2 ;
	int		numu1, numv1, numu2, numv2, nu, nv;
	float		*gru1, *grv1, *gru2, *grv2, *gru, *grv;
        float           du1, dv1, du2, dv2, dot, rmg;

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

        /*
         *	Get the two vectors.
         */
	dg_getv  ( &numu1, &numv1, iret );
	if  ( *iret != 0 ) return;
	dg_getv  ( &numu2, &numv2, iret );
	if  ( *iret != 0 ) return;

        /*
         *	Get new grid numbers and compute the along stream vector.
         */
	dg_nxtv ( &nu, &nv, iret );
	if  ( *iret != 0 ) return;

        dg_getg ( &nu, &gru, &kxd, &kyd, &ksub1, &ksub2, iret );
        dg_getg ( &nv, &grv, &kxd, &kyd, &ksub1, &ksub2, iret );
        dg_getg ( &numu1, &gru1, &kxd, &kyd, &ksub1, &ksub2, iret );
        dg_getg ( &numv1, &grv1, &kxd, &kyd, &ksub1, &ksub2, iret );
        dg_getg ( &numu2, &gru2, &kxd, &kyd, &ksub1, &ksub2, iret );
        dg_getg ( &numv2, &grv2, &kxd, &kyd, &ksub1, &ksub2, iret );

	for ( i = ksub1 - 1; i < ksub2; i++ ) {
	    du1 = gru1[i];
	    dv1 = grv1[i];
	    du2 = gru2[i];
	    dv2 = grv2[i];
	    if  ( ERMISS (du1) || ERMISS (dv1) ||
     		  ERMISS (du2) || ERMISS (dv2) ) {
		gru[i] = RMISSD;
		grv[i] = RMISSD;
            }
	    else {
		dot = du1 * du2  +  dv1 * dv2;
		rmg = du2 * du2  +  dv2 * dv2;
		if ( rmg < 1.e-20 ) {
		    gru[i] = RMISSD;
		    grv[i] = RMISSD;
		}
		else {
		    gru[i] = ( dot / rmg ) * du2;
		    grv[i] = ( dot / rmg ) * dv2;
		}
            }
	}

        /*
         *	Make a name of the form 'VASV'//u1//u2 and update header;
         *	update stack.
         */
	dg_updv  ( "VASV", &nu, &nv, &numu1, &numu2, iret );
	dg_putv  ( &nu, &nv, iret );
	dg_esub  ( &nu, &nv, &zero, &zero, &ier );
	if ( ier != 0 ) *iret = ier;

	return;
}
コード例 #4
0
ファイル: dfasin.c プロジェクト: ArielleBassanelli/gempak
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;
}
コード例 #5
0
ファイル: dfne.c プロジェクト: ArielleBassanelli/gempak
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;
}
コード例 #6
0
ファイル: dessum.c プロジェクト: ArielleBassanelli/gempak
void de_ssum ( const char *uarg, char *stprm, int *iret )
/************************************************************************
 * de_ssum								*
 *									*
 * This subroutine computes the sum over the ensemble of a scalar.	*
 *									*
 * de_ssum ( uarg, stprm, iret )					*
 *									*
 * Input and parameters:						*
 *	*uarg		const char	Function argument string	*
 *									*
 * Output parameters:							*
 *	*stprm		char		Substitution string		*
 *	*iret		int		Return code			*
 *					  0 = normal return		*
 *					 -8 = cannot parse argument	*
 *					 -9 = ensemble cannot computed	*
 **									*
 * Log:									*
 * K. Brill/HPC         08/10	Created from de_ssprd			*
 ************************************************************************/
{
    char tname[13], pdum[13], time1[21], time2[21];
    int ns, num, kxd, kyd, ksub1, ksub2, level1, level2, ivcord,
        nina, one, zero, i, j, ier;
    float *gns, *gnum;
    double *dgns, d1, d2;
/*----------------------------------------------------------------------*/
    *iret = 0;
    one = 1;
    zero = 0;

    dg_ssub ( iret );

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

    /*
     * Initialize the output grid.
     * Allocate internal double arrays.
     */
    dg_getg ( &ns,  &gns,  &kxd, &kyd, &ksub1, &ksub2, iret );
    G_MALLOC(dgns, double, kxd*kyd, "DE_SSUM");
    for ( i = ksub1 - 1; i < ksub2; i++ ) {
        gns[i] = 0.;
        dgns[i] = 0.;
    }

    /*
     * Set the number of input arguments.  There is only one argument
     * for DE_SSUM.
     */
    nina = 1;
    for ( i = 0; i < MXARGS; i++ ) {
	_ensdiag.allarg[i][0] = '\0';
    }
    strcpy ( _ensdiag.allarg[0], uarg );

    /*
     * Scan the allarg array.
     */
    de_scan ( &nina, iret );
    if ( *iret != 0 ) return;

    /*
     * Loop over number of members set by DE_SCAN.
     */
    for ( i = 0; i < _ensdiag.nummbr; i++ ) {
	de_mset ( &i, iret );
	dg_pfun ( _ensdiag.allarg[0], iret );
	if ( *iret != 0 ) {
	    er_wmsg ( "DG", iret, " ", &ier, strlen("DG"), strlen(" ") );
	    *iret = -8;
	    return;
	}
	dg_driv( &one, iret );
	if ( *iret != 0 ) {
	    er_wmsg ( "DG", iret, _ensdiag.allarg[0], &ier,
	        strlen("DG"), strlen(_ensdiag.allarg[0]) );
	    *iret = -9;
	    return;
	}

	/*
	 * Retrieve the output grid from the stack.  Check that the 
	 * output is a scalar.
	 */	
	dg_tops ( tname, &num, time1, time2, &level1, &level2,
	    &ivcord, pdum, iret );
	dg_getg ( &num, &gnum, &kxd, &kyd, &ksub1, &ksub2, iret );

	for ( j = ksub1 - 1; j < ksub2; j++ ) {
	    d1 = gnum[j];
	    d2 = dgns[j];
	    if ( ERMISS ( d1 ) || ERMISS ( d2 ) ) {
		dgns[j] = RMISSD;
	    } else {
		dgns[j] += gnum[j];
	    }
	}
	dg_frig ( &num, &ier );
    }

    /*
     * Assign the result to the output array and free the internal arrays.
     */
    for ( i = ksub1 - 1; i < ksub2; i++ ) {
        gns[i] = (float)dgns[i];
    }
    G_FREE(dgns, double);

    /*
     * Reset DGCMN.CMN and set internal grid identifier.
     */
    de_rset ( iret );
    dg_udig ( "EXX_", &ns, &zero, &_ensdiag.idgens, stprm, iret );
    dg_esub ( &ns, &zero, &zero, &zero, &ier );
    if ( ier != 0 )  *iret = ier;

    return;
}
コード例 #7
0
ファイル: dflog.c プロジェクト: ArielleBassanelli/gempak
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;
}
コード例 #8
0
ファイル: dfyav.c プロジェクト: ArielleBassanelli/gempak
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;
}
コード例 #9
0
ファイル: dfthwc.c プロジェクト: ArielleBassanelli/gempak
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;
}
コード例 #10
0
ファイル: dvvge.c プロジェクト: ArielleBassanelli/gempak
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;
}
コード例 #11
0
ファイル: desrng.c プロジェクト: ArielleBassanelli/gempak
void de_srng ( const char *uarg, char *stprm, int *iret )
/************************************************************************
 * de_srng								*
 *									*
 * This subroutine computes the range of its scalar arguments among	*
 * ensemble members. The range is the difference between the maximum	*
 * and the minimum.							*
 *									*
 * de_srng ( uarg, stprm, iret )					*
 *									*
 * Input and parameters:						*
 *	*uarg		const char	Function argument string	*
 *									*
 * Output parameters:							*
 *	*stprm		char		Substitution string		*
 *	*iret		int		Return code			*
 *					  0 = normal return		*
 *					 -8 = cannot parse argument	*
 *					 -9 = ensemble cannot computed	*
 **									*
 * Log:									*
 * R. Tian/SAIC 	 6/05						*
 * R. Tian/SAIC		 1/06	Translated from Fortran			*
 ************************************************************************/
{
    char tname[13], pdum[13], time1[21], time2[21];
    int nsmax, nsmin, num, kxd, kyd, ksub1, ksub2, level1, level2,
        ivcord, nina, one, zero, i, j, ier;
    float *gnsmax, *gnsmin, *gnum, d1, d2, d3;
/*----------------------------------------------------------------------*/
    *iret = 0;
    one = 1;
    zero = 0;

    dg_ssub ( iret );

    /*
     * Get new grid numbers for maximum and minimum fields.
     */
    dg_nxts ( &nsmax, iret );
    if ( *iret != 0 ) return;
    dg_nxts ( &nsmin, iret );
    if ( *iret != 0 ) return;

    /*
     * Initialize the output grid.
     */
    dg_getg ( &nsmax, &gnsmax, &kxd, &kyd, &ksub1, &ksub2, iret );
    dg_getg ( &nsmin, &gnsmin, &kxd, &kyd, &ksub1, &ksub2, iret );
    for ( i = ksub1 - 1; i < ksub2; i++ ) {
	gnsmax[i] = -FLT_MAX;
	gnsmin[i] =  FLT_MAX;
    }

    /*
     * Set the number of input arguments.  There is only one argument
     * for DE_SRNG.
     */
    nina = 1;
    for ( i = 0; i < MXARGS; i++ ) {
	_ensdiag.allarg[i][0] = '\0';
    }
    strcpy ( _ensdiag.allarg[0], uarg );

    /*
     * Scan the allarg array.
     */
    de_scan ( &nina, iret );
    if ( *iret != 0 ) return;

    /*
     * Loop over number of members set by DE_SCAN.
     */
    for ( i = 0; i < _ensdiag.nummbr; i++ ) {
	de_mset ( &i, iret );
	dg_pfun ( _ensdiag.allarg[0], iret );
	if ( *iret != 0 ) {
	    er_wmsg ( "DG", iret, " ", &ier, strlen("DG"), strlen(" ") );
	    *iret = -8;
	    return;
	}
	dg_driv ( &one, iret );
	if ( *iret != 0 ) {
	    er_wmsg ( "DG", iret, _ensdiag.allarg[0], &ier,
	        strlen("DG"), strlen(_ensdiag.allarg[0]) );
	    *iret = -9;
	    return;
	}

	/*
	 * Retrieve the output grid from the stack.  Check that the 
	 * output is a scalar.
	 */
	dg_tops ( tname, &num, time1, time2, &level1, &level2,
	    &ivcord, pdum, iret );
	dg_getg ( &num, &gnum, &kxd, &kyd, &ksub1, &ksub2, iret );

	/*
	 * Compute the maximum and minimum.
	 */
	for ( j = ksub1 - 1; j < ksub2; j++ ) {
	    d1 = gnum[j];
	    d2 = gnsmax[j];
	    d3 = gnsmin[j];
	    if ( ERMISS ( d1 ) ) {
		gnsmax[j] = RMISSD;
		gnsmin[j] = RMISSD;
	    } else {
		if ( ! ERMISS ( d2 ) ) {
		    gnsmax[j] = G_MAX ( d1, d2 );
		}
		if ( ! ERMISS ( d2 ) ) {
		    gnsmin[j] = G_MIN ( d1, d3 );
		}
	    }
	}
	dg_frig ( &num, &ier );
    }

    /*
     * Compute the range.
     */
    for ( i = ksub1 - 1; i < ksub2; i++ ) {
	d1 = gnsmax[i];
	d2 = gnsmin[i];
	if ( ERMISS ( d1 ) || ERMISS ( d2 ) ) {
	    gnsmax[i] = RMISSD;
	} else {
	    gnsmax[i] = d1 - d2;
	}
    }
    dg_frig ( &nsmin, &ier );

    /*
     * Reset DGCMN.CMN and set internal grid identifier.
     */
    de_rset ( iret );
    dg_udig ( "EXX_", &nsmax, &zero, &_ensdiag.idgens, stprm, iret );
    dg_esub ( &nsmax, &zero, &zero, &zero, &ier );
    if ( ier != 0 )  *iret = ier;

    return;
}
コード例 #12
0
ファイル: dfgele.c プロジェクト: ArielleBassanelli/gempak
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;
}
コード例 #13
0
ファイル: dfmul.c プロジェクト: ArielleBassanelli/gempak
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;
}
コード例 #14
0
ファイル: dvnrmv.c プロジェクト: ArielleBassanelli/gempak
void dv_nrmv ( int *iret )
/************************************************************************
 * dv_nrmv								*
 *									*
 * This subroutine computes the vector component of a vector field (V)	*
 * normal to the orientation vector whose direction is specified in	*
 * COMMON / DGOVEC /.							*
 *									*
 *     NORMV = ( ( -k cross V ) dot ( normalized orientation vector ) )	*
 *		     times ( normalized orientation vector )		*
 *									*
 * NORMV generates a vector field.					*
 *									*
 * dv_nrmv  ( iret )							*
 *									*
 * Output parameters:							*
 *	*iret		int		Return code			*
 *					As for DG_GETV or DG_MSCL	*
 *					-28 = no orientation vector	*
 **									*
 * Log:									*
 * K. Brill/GSC		 7/89    					*
 * K. Brill/GSC		 8/89 	Subsetting				*
 * K. Brill/GSC	        10/89	Subsetting				*
 * K. Brill/NMC		 4/92	Nonconformal case reused ORNTV->error	*
 * T. Lee/GSC		 4/96   Single dimension for dgg		*
 * T. Lee/GSC		 5/96   Moved IGDPT outside DO loop		*
 * K. Brill/HPC		 1/02	CALL DG_SSUB and DG_ESUB		*
 * K. Brill/HPC		 5/02	Eliminate LLMXGD declarations in DGCMN	*
 *				by using internal grids for scl fctrs	*
 * K. Brill/HPC		11/02	Eliminate use of the SUBA logical array	*
 * S. Gilbert/NCEP	11/05	Translation from Fortran                *
 ************************************************************************/
{
	int		i, ier, nval, kxd, kyd, ksub1, ksub2, zero=0;
        int             numu, numv, numu1, numv1, ixmscl, iymscl;
        float           *gru, *grv, *gru1, *grv1, *grxms, *gryms;
	float 		orntv[2], ornang, du1, dv1, orn1, orn2;
        float           du2, dv2, rnm;

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

	dg_nxtv ( &numu, &numv, iret );
	if  ( *iret != 0 ) return;

        dg_getg ( &numu, &gru, &kxd, &kyd, &ksub1, &ksub2, iret );
        dg_getg ( &numv, &grv, &kxd, &kyd, &ksub1, &ksub2, iret );

        nval = 1;
        dg_fget ( "ORNANG", &nval, &ornang, iret );

	if ( ERMISS ( ornang ) ) {
	  for ( i = ksub1 - 1; i < ksub2; i++ ) {
	      gru[i] = RMISSD;
	      grv[i] = RMISSD;
	  }
	  *iret = -28;
	  return;
	}

        /*
         *	Compute the unit tangent vector components.
         */
	orntv [ 0 ] = - sin ( ornang );
	orntv [ 1 ] = - cos ( ornang );

        /*
         *	Compute the map scale factors just in case the grid is not
         *	conformal.
         */
	dg_mscl ( iret );
	if ( *iret != 0 ) return;

        /*
         *	Get the vector.
         */
	dg_getv  ( &numu1, &numv1, iret );
	if  ( *iret != 0 ) return;

        /*
         *	Compute the normal component.
         */
        dg_getg ( &numu1, &gru1, &kxd, &kyd, &ksub1, &ksub2, iret );
        dg_getg ( &numv1, &grv1, &kxd, &kyd, &ksub1, &ksub2, iret );

        nval = 1;
        dg_iget ( "IXMSCL", &nval, &ixmscl, iret );
        dg_iget ( "IYMSCL", &nval, &iymscl, iret );
        dg_getg ( &ixmscl, &grxms, &kxd, &kyd, &ksub1, &ksub2, iret );
        dg_getg ( &iymscl, &gryms, &kxd, &kyd, &ksub1, &ksub2, iret );

	for ( i = ksub1 - 1; i < ksub2; i++ ) {
	    du1 = gru1[i];
	    dv1 = grv1[i];
	    if  ( ERMISS (du1) || ERMISS (dv1) ) {
		gru[i] = RMISSD;
	        grv[i] = RMISSD;
            }
	    else if ( G_DIFF(grxms[i], gryms[i]) ) {
		gru[i] =  ( du1 * orntv [ 1 ] -
     				    dv1 * orntv [ 0 ] ) * orntv [ 1 ] ;
		grv[i] =  ( -du1 * orntv [ 1 ] +
     				    dv1 * orntv [ 0 ] ) * orntv [ 0 ] ;
            }
            else {

                /*
                 *	Treat the case when the grid map projection is
                 *  	nonconformal.
                 * 
                 *	Scale the grid relative orientation vector and normalize
                 *	it.
                 */
                du2 = orntv [ 0 ] / grxms[i];
	        dv2 = orntv [ 1 ] / gryms[i];
		rnm =  sqrt ( du2 * du2 + dv2 * dv2 );
	        orn1 = du2 / rnm;
	        orn2 = dv2 / rnm;
		gru[i] =  ( du1 * orn2 - dv1 * orn1 ) * orn2 ;
		grv[i] =  ( -du1 * orn2 + dv1 * orn1 ) * orn1;
	    }
	}

        /*
         *	Make a name of the form 'NORMV'//u,v and update header;
         *	update stack.
         */
	dg_updv  ( "NORMV", &numu, &numv, &numu1, &numv1, iret );
	dg_putv  ( &numu, &numv, iret );
	dg_esub  ( &numu, &numv, &zero, &zero, &ier );
	if ( ier != 0 ) *iret = ier;

	return;
}
コード例 #15
0
ファイル: deswsprd.c プロジェクト: ArielleBassanelli/gempak
void de_swsprd ( const char *uarg, char *stprm, int *iret )
/************************************************************************
 * de_swsprd								*
 *									*
 * This subroutine computes the weighted ensemble spread of its scalar  *
 * argument.								*
 *									*
 * de_swsprd ( uarg, stprm, iret )					*
 *									*
 * Input and parameters:						*
 *	*uarg		const char	Function argument string	*
 *									*
 * Output parameters:							*
 *	*stprm		char		Substitution string		*
 *	*iret		int		Return code			*
 *					  0 = normal return		*
 *					 -8 = cannot parse argument	*
 *					 -9 = ensemble cannot computed	*
 **									*
 * Log:									*
 * m.gamazaychikov/SAIC	01/08	From de_ssprd				*
 * m.gamazaychikov/SAIC	01/08	Fixed the calculation problem		*
 * S. Jacobs/NCEP	 8/09	Use double arrays internally		*
 * K. Brill/HPC         11/10   Set any negative sqrt argument to zero	*
 ************************************************************************/
{
    char tname[13], pdum[13], time1[21], time2[21];
    char **argu;
    int ns, ns2, num, kxd, kyd, ksub1, ksub2, level1, level2, ivcord,
        nina, one, zero, i, j, ier, narg, numw, nsw;
    float *gns, *gnum, *gwgt, *gnumw;
    double *dgns, *dgns2, d1, d2, d3, d4;
/*----------------------------------------------------------------------*/
    *iret = 0;
    one = 1;
    zero = 0;

    dg_ssub ( iret );

    /*
     * Get new grid numbers.
     */
    dg_nxts ( &ns, iret );
    if ( *iret != 0 ) return;
    dg_nxts ( &ns2, iret );
    if ( *iret != 0 ) return;

    /*
     * Initialize the output grid.
     */
    dg_getg ( &ns,  &gns,  &kxd, &kyd, &ksub1, &ksub2, iret );
    G_MALLOC(dgns, double, kxd*kyd, "DE_SWSPRD");
    G_MALLOC(dgns2, double, kxd*kyd, "DE_SWSPRD");
    for ( i = ksub1 - 1; i < ksub2; i++ ) {
        gns[i] = 0.;
        dgns[i] = 0.;
	dgns2[i] = 0.;
    }

    /*
     * Set the number of input arguments.  There could be two arguments.
     */
    for ( i = 0; i < MXARGS; i++ ) {
	_ensdiag.allarg[i][0] = '\0';
    }
    nina = 2;
    argu = (char **)cmm_malloc2d ( 2, LLMXLN, sizeof(char), &ier );
    cst_clst ( (char *)uarg, '&', " ", nina, LLMXLN, argu, &narg, &ier );
    for ( i = 0; i < narg; i++ ) {
        strcpy ( _ensdiag.allarg[i], argu[i] );
        if ( i > 0 && strcmp(argu[i], " ") == 0 ) {
            cst_rlch ( RMISSD, 1, _ensdiag.allarg[i], &ier );
        }
    }

    cmm_free2d ( (void **) argu, &ier );
                                                                                       
    if ( narg < 1 ) {
        *iret = -15;
        return;
    }
      else if ( narg == 1 ) {
        cst_rlch ( RMISSD, 1, _ensdiag.allarg[1], &ier );
    }
      else if ( narg == 2 ) {
        dg_nxts ( &nsw, iret );
        if ( *iret != 0 ) return;
        dg_getg ( &nsw, &gwgt, &kxd, &kyd, &ksub1, &ksub2, iret );
        for ( i = ksub1 - 1; i < ksub2; i++ ) {
            gwgt[i] = 0.;
        } 
    }


    /*
     * Scan the allarg array.
     */
    de_scan ( &narg, iret );
    if ( *iret != 0 ) return;

    /*
     * Loop over number of members set by DE_SCAN.
     */
    for ( i = 0; i < _ensdiag.nummbr; i++ ) {
        if ( narg == 2 ) {
           de_mset ( &i, iret );
          /*
           * Compute weight grid and retrieve it from the stack.
           */
           dg_pfun ( _ensdiag.allarg[1], iret );
           if ( *iret != 0 ) {
               er_wmsg ( "DG", iret, " ", &ier, strlen("DG"), strlen(" ") );
              *iret = -8;
               return;
           }
                                                                                       
           dg_driv ( &one, iret );
           if ( *iret != 0 ) {
               er_wmsg ( "DG", iret, _ensdiag.allarg[1], &ier,
                         strlen("DG"), strlen(_ensdiag.allarg[1]) );
               *iret = -9;
               return;
           }
                                                                                       
           dg_tops ( tname, &numw, time1, time2, &level1, &level2,
                     &ivcord, pdum, iret );
           dg_getg ( &numw, &gnumw, &kxd, &kyd, &ksub1, &ksub2, iret );

          /*
           * Compute field grid and retrieve it from the stack.
           */
           dg_pfun ( _ensdiag.allarg[0], iret );
           if ( *iret != 0 ) {
              er_wmsg ( "DG", iret, " ", &ier, strlen("DG"), strlen(" ") );
              *iret = -8;
              return;
           }
           dg_driv( &one, iret );
           if ( *iret != 0 ) {
              er_wmsg ( "DG", iret, _ensdiag.allarg[0], &ier,
                   strlen("DG"), strlen(_ensdiag.allarg[0]) );
              *iret = -9;
              return;
           }
                                                                                                               
          /*
           * Retrieve the output grid from the stack.  Check that the
           * output is a scalar.
           */
           dg_tops ( tname, &num, time1, time2, &level1, &level2,
                    &ivcord, pdum, iret );
           dg_getg ( &num, &gnum, &kxd, &kyd, &ksub1, &ksub2, iret );
                                                                                                               
           for ( j = ksub1 - 1; j < ksub2; j++ ) {
              d1 = gnum[j];
              d2 = dgns[j];
              d3 = dgns2[j];
              d4 = gnumw[j];
              if ( ERMISS ( d1 ) || ERMISS ( d2 ) || 
                   ERMISS ( d3 ) || ERMISS ( d4 ) ) {
                 dgns[j]  = RMISSD;
                 dgns2[j] = RMISSD;
                 gwgt[j] = RMISSD;
              } else {
                 dgns[j]  += d1 * d4;
                 dgns2[j] += d1 * d1 * d4;
                 gwgt[j] += d4;
              }
           }
           dg_frig ( &numw, &ier );
           dg_frig ( &num, &ier );
        } else if ( narg == 1 ) {
	   de_mset ( &i, iret );
	   dg_pfun ( _ensdiag.allarg[0], iret );
	   if ( *iret != 0 ) {
	      er_wmsg ( "DG", iret, " ", &ier, strlen("DG"), strlen(" ") );
	      *iret = -8;
	      return;
	   }
	   dg_driv( &one, iret );
	   if ( *iret != 0 ) {
	       er_wmsg ( "DG", iret, _ensdiag.allarg[0], &ier,
	             strlen("DG"), strlen(_ensdiag.allarg[0]) );
	       *iret = -9;
	       return;
	   }

	  /*
	   * Retrieve the output grid from the stack.  Check that the 
	   * output is a scalar.
	   */	
	   dg_tops ( tname, &num, time1, time2, &level1, &level2,
	             &ivcord, pdum, iret );
	   dg_getg ( &num, &gnum, &kxd, &kyd, &ksub1, &ksub2, iret );

	   for ( j = ksub1 - 1; j < ksub2; j++ ) {
	      d1 = gnum[j];
	      d2 = dgns[j];
	      d3 = dgns2[j];
	      if ( ERMISS ( d1 ) || ERMISS ( d2 ) || ERMISS ( d3 ) ) {
	  	 dgns[j] = RMISSD;
		 dgns2[j] = RMISSD;;
	      } else {
	 	 dgns[j] += d1 * _ensdiag.enswts[i];
		 dgns2[j] += d1 * d1 * _ensdiag.enswts[i];
	      }
	   }
	   dg_frig ( &num, &ier );
        }
    }

    /*
     * Compute Variance.
     */
    for ( i = ksub1 - 1; i < ksub2; i++ ) {
	d2 = dgns[i];
	d3 = dgns2[i];
	if ( ERMISS ( d2 ) || ERMISS ( d3 ) ) {
	    dgns[i] = RMISSD;
	} else {
            if ( narg == 2) {
                 d1 = gwgt[i];
	       if ( ERMISS ( d1 ) ) {
	          dgns[i] = RMISSD;
               } else {
	         dgns[i] = dgns[i]/gwgt[i];
	         dgns[i] = dgns2[i]/gwgt[i] - dgns[i] * dgns[i];
               }
            } else if ( narg == 1 ) {
	       dgns[i] = dgns2[i] - dgns[i] * dgns[i];
            }
	}
    }

    /*
     * Compute spread (standard deviation).
     */
    for ( i = ksub1 - 1; i < ksub2; i++ ) {
	d2 = dgns[i];
	if ( ERMISS ( d2 ) ) {
	    dgns[i] = RMISSD;
	} else {
            if ( dgns[i] < 0.0 ) {
		dgns[i] = 0.0;
	    }
	    dgns[i] = sqrt ( dgns[i] );
	}
    }

    /*
     * Assign the result to the output array and free the internal arrays.
     */
    for ( i = ksub1 - 1; i < ksub2; i++ ) {
	gns[i] = (float)dgns[i];
    }
    G_FREE(dgns, double);
    G_FREE(dgns2, double);


    /*
     * Reset DGCMN.CMN and set internal grid identifier.
     */
    de_rset ( iret );
    dg_udig ( "EXX_", &ns, &zero, &_ensdiag.idgens, stprm, iret );
    dg_esub ( &ns, &zero, &zero, &zero, &ier );
    if ( ier != 0 )  *iret = ier;

    return;
}
コード例 #16
0
ファイル: dvmrad.c プロジェクト: ArielleBassanelli/gempak
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;
}
コード例 #17
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;
}
コード例 #18
0
ファイル: dvvn.c プロジェクト: ArielleBassanelli/gempak
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;
}
コード例 #19
0
ファイル: dfnot.c プロジェクト: ArielleBassanelli/gempak
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;
}
コード例 #20
0
ファイル: dfddt.c プロジェクト: ArielleBassanelli/gempak
void df_ddt ( int *iret )
/************************************************************************
 * df_ddt								*
 *									*
 * This subroutine computes the time derivative:			*
 *									*
 *     DDT (S) = [ S (time1) - S (time2) ] / (time1 - time2)		*
 *									*
 * where the time difference is in seconds.				*
 *									*
 * df_ddt ( iret )							*
 *									*
 * Output parameters:							*
 *	*iret		int		Return code			*
 *					As for DG_GETS			*
 **									*
 * Log:									*
 * M. Goodman/RDS	12/85						*
 * M. desJardins/GSFC	 7/88	Added new stack subroutines		*
 * G. Huffman/GSC	 8/88	Revised name generation; error messages	*
 * K. Brill/GSC		 8/89	Subsetting				*
 * K. Brill/GSC         10/89   Subsetting				*
 * K. Brill/GSC         11/89   Call TG_DIFF instead of TI_DIFF		*
 * M. desJardins/NMC	 7/93	Changed update scheme			*
 * 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			*
 ************************************************************************/
{
    char gp[13], time1[21], time2[21], parm[13], gfunc[13];
    int ntdf, kxd, kyd, ksub1, ksub2, fidx, cidx; 
    int level1, level2, ivcord, imins, zero, ier;
    float *gntdf;
/*----------------------------------------------------------------------*/
    *iret = 0;
    zero = 0;

    dg_ssub ( iret );

    /*
     * Compute the scalar difference over time.
     */
    df_tdf ( iret );
    if ( *iret != 0 ) return;

    /*
     * Get the pointer to the time difference; save the scalar name.
     */
    dg_tops ( gfunc, &ntdf, time1, time2, &level1, &level2, &ivcord,
	      parm, iret );
    if ( *iret != 0 ) return;

    /*
     * Convert the date/time range into seconds.
     */
    tg_diff ( time1, time2, &imins, &ier, strlen(time1), strlen(time2) );

    /*
     * Divide the scalar difference by the number of seconds.
     */
    dg_getg ( &ntdf, &gntdf, &kxd, &kyd, &ksub1, &ksub2, iret );
    for ( fidx = ksub1; fidx <= ksub2; fidx++ ) {
        cidx = fidx - 1;
	if ( imins == 0 || ERMISS ( gntdf[cidx] ) ) {
	    gntdf[cidx] = RMISSD;
	} else {
            gntdf[cidx] /= ( imins * 60 );
	}
    }

    /*
     * Make a name of the form 'DDT'//S and update header;
     * the stack is current.  DG_UPDH is not used here because
     * the scalar name was buried in the TDF parameter name.
     */
    strcpy ( gp, "DDT" );
    strcat ( gp, &parm[3] );
    dg_upsg ( time1, time2, &level1, &level2, &ivcord, &zero, gp,
	      &ntdf, iret );
    dg_esub ( &ntdf, &zero, &zero, &zero, &ier );
    if ( ier != 0 ) *iret = ier;

    return;
}
コード例 #21
0
ファイル: deprcntl.c プロジェクト: ArielleBassanelli/gempak
void de_prcntl ( const char *uarg, char *stprm, int *iret )
/************************************************************************
 * de_prcntl								*
 *									*
 * This subroutine returns a value at each grid point such that the 	*
 * value returned is greater than or equal to the value found at the	*
 * same grid point in P% of the weighted members of an ensemble.  The	*
 * value of P ranges between 0 and 100 and may vary from grid point to	*
 * point.								*
 *									*
 * The relationship between the percentile value, p, and the index, k,	*
 * in the order statistics of count N is				*
 *									*
 *                   ( k - 1 ) / ( N - 1 ) = p		(1)		*
 *									*
 * Rewriting this in terms of equally weighted order statistics 	*
 * (multiplying both sides by (N-1)/N) yields				*
 *									*
 *                   (k-1)*(1/N) = p - p*(1/N)	 	(2)		*
 *									*
 * Since k can have a fractional value, the weights may vary, and the	*
 * (1/N) subtracted on both sides of (2) must be the first weight value *
 * (w(1)), the problem is one of finding integer K and residual weight	*
 * wr such that								*
 *									*
 *                    K							*
 *              wr + SUM w(i) = p ( 1 - w(1) )          (3)		*
 *                   i=2						*
 *									*
 * The value of wr is easily obtained by solving (3) after summing the	*
 * weights up to the point in the order statistics where adding on one	*
 * more weight exceeds the value of the R.H.S of (3).  The value of wr  *
 * establishes the position in the weight summation to which to		*
 * interpolate the values of the order statistics, x, according to the	*
 * following linear relationship:					*
 *									*
 *    wr / [ W(K+1) - W(K) ] = [ x - x(K) ] / [ x(K+1) - x(K) ]  (4)    *
 *									*
 * In (4), W(K) is the summation of the weights from i=2 to K.  The	*
 * percentile value is found by solving (4) for x.  Since the denom-	*
 * inator on the L.H.S of (4) is just w(K+1), the value of x is		*
 *									*
 *      x = x(K) + [ wr / w(K+1) ] * [ x(K+1) - x(K) ]         (5)	*
 *									*
 *									*
 * de_prcntl ( uarg, stprm, iret )					*
 *									*
 * Input and parameters:						*
 *	*uarg		const char	Function argument string	*
 *									*
 * Output parameters:							*
 *	*stprm		char		Substitution string		*
 *	*iret		int		Return code			*
 *					 +3 = Percentile < 0		*
 *					 +1 = Percentile > 100		*
 *					  0 = normal return		*
 *					 -8 = cannot parse argument	*
 *					 -9 = ensemble cannot computed	*
 * 					-15 = Incorrect # of arguments	*
 **									*
 * Log:									*
 * T. Lee/SAIC		01/05						*
 * R. Tian/SAIC		 1/06	Translated from Fortran			*
 * T. Piper/SAIC	08/06	Added G_DIFF				*
 * K. Brill/HPC		08/06   Fix to remove low bias; document eqtns	*
 * m.gamazaychikov/SAIC 01/08   Add ability to use weights              *
 ************************************************************************/
{
    char tname[13], pdum[13], time1[21], time2[21];
    char **argu;
    int igo, igp, num, kxd, kyd, ksub1, ksub2, nina, narg, level1, level2,
        ivcord, zero, one, three, ii, jj, kk, ll, ier;
    int wmesg, nmesg, iswflg, istop, iwpntr;
    int nsw, numw;
    float *gigo, *gigp, *gnum, data, swpbuf, pntt, psum, smw, wr,
          *gnumw, *gwgt, d1;
/*----------------------------------------------------------------------*/
    *iret = 0;
    zero = 0;
    one = 1;
    three = 3;

    dg_ssub ( iret );

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

    /*
     * Initialize the output grid.
     */
    dg_getg ( &igo, &gigo, &kxd, &kyd, &ksub1, &ksub2, iret );
    for ( ii = ksub1 - 1; ii < ksub2; ii++ ) {
	gigo[ii] = RMISSD;
    }

    /*
     * Set the number of input arguments.  There are two arguments
     * for DE_PRCNTL.
     */
    for ( ii = 0; ii < MXARGS; ii++ ) {
	_ensdiag.allarg[ii][0] = '\0';
    }
    nina = 3;
    argu = (char **)cmm_malloc2d ( 3, MXFLSZ+1, sizeof(char), &ier );
    cst_clst ( (char *)uarg, '&', " ", nina, MXFLSZ, argu, &narg, &ier );
    for ( ii = 0; ii < narg; ii++ ) {
        strcpy ( _ensdiag.allarg[ii], argu[ii] );
    }

    /*
     * If weight grid is provided get new grid number
     * for sum-weight grid and initialize it
     */
    if ( narg == 3 ) {
       dg_nxts ( &nsw, iret );
       if ( *iret != 0 ) return;
       dg_getg ( &nsw, &gwgt, &kxd, &kyd, &ksub1, &ksub2, iret );
       for ( ii = ksub1 - 1; ii < ksub2; ii++ ) {
         gwgt[ii] = 0.;
       }
    }
    cmm_free2d ( (void **) argu, &ier );
    if ( narg < 2 ) {
	*iret = -15;
	return;
    }

    /*
     * Scan the allarg array.
     */
    de_scan ( &narg, iret );
    if ( *iret != 0 ) return;

    /*
     * Evaluate the static argument defined by the second entry in
     * uarg or allarg (2).
     */
    dg_pfun ( _ensdiag.allarg[1], iret );
    if ( *iret != 0 ) {
	er_wmsg ( "DG", iret, " ", &ier, strlen("DG"), strlen(" ") );
	*iret = -8;
	return;
    }
    dg_driv ( &one, iret );
    if ( *iret != 0 ) {
	er_wmsg ( "DG", iret, _ensdiag.allarg[1], &ier,
	    strlen("DG"), strlen(_ensdiag.allarg[1]) );
	*iret = -9;
	return;
    }

    /*
     * Retrieve the output grid from the stack.  Check that the 
     * output is a scalar.
     */	
    dg_tops ( tname, &igp, time1, time2, &level1, &level2,
        &ivcord, pdum, iret );
    dg_getg ( &igp, &gigp, &kxd, &kyd, &ksub1, &ksub2, iret );

    /*
     * Loop over number of members set by DE_SCAN.
     */
    for ( ii = 0; ii < _ensdiag.nummbr; ii++ ) {
	de_mset ( &ii, iret );
	dg_pfun ( _ensdiag.allarg[0], iret );
	if ( *iret != 0 ) {
	    er_wmsg ( "DG", iret, " ", &ier, strlen("DG"), strlen(" ") );
	    *iret = -8;
	    return;
	}
	dg_driv ( &one, iret );
	if ( *iret != 0 ) {
	    er_wmsg ( "DG", iret, _ensdiag.allarg[0], &ier,
	        strlen("DG"), strlen(_ensdiag.allarg[0]) );
	    *iret = -9;
	    return;
	}

	/*
	 * Retrieve the output grid from the stack and store the
	 * grid number.
	 */
	dg_tops ( tname, &num, time1, time2, &level1, &level2,
	    &ivcord, pdum, iret );
	_ensdiag.iglist[ii] = num;

        /*
         * If the weight grid present store the starting index
         * of the weight grid.
         */
        if ( narg == 3 ) {
           dg_pfun ( _ensdiag.allarg[2], iret );
           if ( *iret != 0 ) {
              er_wmsg ( "DG", iret, " ", &ier, strlen("DG"), strlen(" ") );
              *iret = -8;
              return;
           }
           dg_driv ( &one, iret );
           if ( *iret != 0 ) {
              er_wmsg ( "DG", iret, _ensdiag.allarg[2], &ier,
                   strlen("DG"), strlen(_ensdiag.allarg[2]) );
              *iret = -9;
              return;
           }

           dg_tops ( tname, &numw, time1, time2, &level1, &level2,
                &ivcord, pdum, iret );
           dg_getg ( &numw, &gnumw, &kxd, &kyd, &ksub1, &ksub2, iret );
           _ensdiag.iwlist[ii] = numw;
           /*
            * the weight summing grid
            */
           for ( jj = ksub1 - 1; jj < ksub2; jj++ ) {
                d1 = gnumw[jj];
                if ( ERMISS ( d1 ) || ERMISS ( gwgt[jj] ) ) {
                    gwgt[jj]  = RMISSD;
                } else {
                    gwgt[jj] += gnumw[jj];
                }
           }
        }
    }

    wmesg = G_FALSE;
    nmesg = G_FALSE;
    for ( ll = ksub1 - 1; ll < ksub2; ll++ ) {
	for ( ii = 0; ii < _ensdiag.nummbr; ii++ ) {
	    num = _ensdiag.iglist[ii];
	    dg_getg ( &num, &gnum, &kxd, &kyd, &ksub1, &ksub2, iret );
	    data = gnum[ll];
            /*
            * Fill out the weight array and normalize by the sum of weights
            */
            if ( narg == 3 ) {
               numw = _ensdiag.iwlist[ii];
               dg_getg ( &numw, &gnumw, &kxd, &kyd, &ksub1, &ksub2, iret );
               _ensdiag.ewtval[ii] = gnumw[ll] / gwgt[ll];
            } 
	    if ( ! ERMISS ( data ) ) {
	        _ensdiag.emvalu[ii] = data;
	        _ensdiag.igpntr[ii] = ii;
	        if ( ii == _ensdiag.nummbr - 1 ) {
	            /*
		     * Bubble sorting the grid values in emvalu with 
		     * emvalue (1) lowest and emvalu (nummbr) highest.
		     */
	            iswflg = 1;
	            istop = _ensdiag.nummbr - 1;
		    while ( iswflg != 0 && istop >= 0 ) {
		        iswflg = 0;
		        for ( kk = 0; kk < istop; kk++ ) {
		            if ( _ensdiag.emvalu[kk] > _ensdiag.emvalu[kk+1] ) {
		                iswflg = 1;
			        swpbuf = _ensdiag.emvalu[kk];
			        iwpntr = _ensdiag.igpntr[kk];
			        _ensdiag.emvalu[kk] = _ensdiag.emvalu[kk+1];
			        _ensdiag.igpntr[kk] = _ensdiag.igpntr[kk+1];
			        _ensdiag.emvalu[kk+1] = swpbuf;
			        _ensdiag.igpntr[kk+1] = iwpntr;
		            }
		        }
		        istop--;
		    }

		    /*
		     * Set normalized target percentile.
		     */
		    pntt = gigp[ll] / 100.0F;
		    if ( pntt >= 1. ) {
		        gigo[ll] = _ensdiag.emvalu[_ensdiag.nummbr-1];
		        if ( pntt > 1.0F && wmesg == G_FALSE ) {
		            er_wmsg ( "DE", &one, " ", &ier,
		                strlen("DE"), strlen(" ") );
			    wmesg = G_TRUE;
		        }
		    } else if ( pntt <= 0. ) {
		        gigo[ll] = _ensdiag.emvalu[0];
		        if ( pntt < 0.0F &&  nmesg == G_FALSE ) {
		            er_wmsg ( "DE", &three, " ", &ier,
			        strlen("DE"), strlen(" ") );
			    nmesg = G_TRUE;
		        }
		    } else {
		        jj = 0;
		        psum = 0.0;
                        if ( narg == 3 ) {
			   pntt = pntt * ( 1.0F - _ensdiag.ewtval[_ensdiag.igpntr[0]] );
                        }
                         else {
			   pntt = pntt * ( 1.0F - _ensdiag.enswts[_ensdiag.igpntr[0]] );
                        } 
		        while (jj < _ensdiag.nummbr - 1 && psum < pntt ) {
		            jj++;
                            /*
                             *  The 1st weight ([0]) must be omitted from the
                             *  summation.
			     */
                             if ( narg == 3 ) {
		                psum += _ensdiag.ewtval[_ensdiag.igpntr[jj]];
                             }
                              else {
		                psum += _ensdiag.enswts[_ensdiag.igpntr[jj]];
                             } 
		        }

		        /*
		         * Compute the percentile value for the output grid.
		         */
		        if ( G_DIFF(psum, pntt) ) {
		            gigo[ll] = _ensdiag.emvalu[jj];
		        } else {
                            if ( narg == 3 ) {
		                smw = psum - _ensdiag.ewtval[_ensdiag.igpntr[jj]];
			        wr = pntt - smw;
			        if ( G_DIFF (_ensdiag.ewtval[_ensdiag.igpntr[jj]], 0.0F) ) {
		                   gigo[ll] =  RMISSD;
			        } else {
		                   gigo[ll] =  _ensdiag.emvalu[jj-1] + 
                                            ( wr / _ensdiag.ewtval[_ensdiag.igpntr[jj]] ) *
			                    (_ensdiag.emvalu[jj]-_ensdiag.emvalu[jj-1]);
                                }
                            }
                              else {
		                smw = psum - _ensdiag.enswts[_ensdiag.igpntr[jj]];
			        wr = pntt - smw;
			        if ( G_DIFF (_ensdiag.enswts[_ensdiag.igpntr[jj]], 0.0F) ) {
		                   gigo[ll] =  RMISSD;
			        } else {
		                   gigo[ll] =  _ensdiag.emvalu[jj-1] + 
                                            ( wr / _ensdiag.enswts[_ensdiag.igpntr[jj]] ) *
			                    (_ensdiag.emvalu[jj]-_ensdiag.emvalu[jj-1]);
			        }
                            }
		        }
		    }
	        }
	    }
	}
    }

    /*
     * Reset DGCMN.CMN and set internal grid identifier.
     */
    de_rset ( iret );
    dg_udig ( "EXX_", &igo, &zero, &_ensdiag.idgens, stprm, iret );
    dg_esub ( &igo, &zero, &zero, &zero, &ier );
    if ( ier != 0 ) *iret = ier;

    return;
}
コード例 #22
0
ファイル: dfmixr.c プロジェクト: ArielleBassanelli/gempak
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;
}
コード例 #23
0
ファイル: dfnmax.c プロジェクト: RyanHickman/gempak
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;
}
コード例 #24
0
ファイル: dfatn2.c プロジェクト: ArielleBassanelli/gempak
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;
}
コード例 #25
0
ファイル: dflav.c プロジェクト: ArielleBassanelli/gempak
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;
}
コード例 #26
0
ファイル: dvdirr.c プロジェクト: ArielleBassanelli/gempak
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;
}
コード例 #27
0
ファイル: dfrdfs.c プロジェクト: ArielleBassanelli/gempak
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;
}
コード例 #28
0
ファイル: dfle.c プロジェクト: ArielleBassanelli/gempak
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;
}
コード例 #29
0
ファイル: dvshr.c プロジェクト: ArielleBassanelli/gempak
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
ファイル: dftlcl.c プロジェクト: ArielleBassanelli/gempak
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;
}