Esempio n. 1
0
doublereal dlamch_(char *cmach)
{
    /* Initialized data */

    static logical first = TRUE_;

    /* System generated locals */
    integer i__1;
    doublereal ret_val;

    /* Builtin functions */
    double pow_di(doublereal *, integer *);

    /* Local variables */
    static doublereal t;
    integer it;
    static doublereal rnd, eps, base;
    integer beta;
    static doublereal emin, prec, emax;
    integer imin, imax;
    logical lrnd;
    static doublereal rmin, rmax;
    doublereal rmach;
    extern logical lsame_(char *, char *);
    doublereal small;
    static doublereal sfmin;
    extern /* Subroutine */ int dlamc2_(integer *, integer *, logical *, 
	    doublereal *, integer *, doublereal *, integer *, doublereal *);


/*  -- LAPACK auxiliary routine (version 3.1) -- */
/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/*     November 2006 */

/*     .. Scalar Arguments .. */
/*     .. */

/*  Purpose */
/*  ======= */

/*  DLAMCH determines double precision machine parameters. */

/*  Arguments */
/*  ========= */

/*  CMACH   (input) CHARACTER*1 */
/*          Specifies the value to be returned by DLAMCH: */
/*          = 'E' or 'e',   DLAMCH := eps */
/*          = 'S' or 's ,   DLAMCH := sfmin */
/*          = 'B' or 'b',   DLAMCH := base */
/*          = 'P' or 'p',   DLAMCH := eps*base */
/*          = 'N' or 'n',   DLAMCH := t */
/*          = 'R' or 'r',   DLAMCH := rnd */
/*          = 'M' or 'm',   DLAMCH := emin */
/*          = 'U' or 'u',   DLAMCH := rmin */
/*          = 'L' or 'l',   DLAMCH := emax */
/*          = 'O' or 'o',   DLAMCH := rmax */

/*          where */

/*          eps   = relative machine precision */
/*          sfmin = safe minimum, such that 1/sfmin does not overflow */
/*          base  = base of the machine */
/*          prec  = eps*base */
/*          t     = number of (base) digits in the mantissa */
/*          rnd   = 1.0 when rounding occurs in addition, 0.0 otherwise */
/*          emin  = minimum exponent before (gradual) underflow */
/*          rmin  = underflow threshold - base**(emin-1) */
/*          emax  = largest exponent before overflow */
/*          rmax  = overflow threshold  - (base**emax)*(1-eps) */

/* ===================================================================== */

/*     .. Parameters .. */
/*     .. */
/*     .. Local Scalars .. */
/*     .. */
/*     .. External Functions .. */
/*     .. */
/*     .. External Subroutines .. */
/*     .. */
/*     .. Save statement .. */
/*     .. */
/*     .. Data statements .. */
/*     .. */
/*     .. Executable Statements .. */

    if (first) {
	dlamc2_(&beta, &it, &lrnd, &eps, &imin, &rmin, &imax, &rmax);
	base = (doublereal) beta;
	t = (doublereal) it;
	if (lrnd) {
	    rnd = 1.;
	    i__1 = 1 - it;
	    eps = pow_di(&base, &i__1) / 2;
	} else {
	    rnd = 0.;
	    i__1 = 1 - it;
	    eps = pow_di(&base, &i__1);
	}
	prec = eps * base;
	emin = (doublereal) imin;
	emax = (doublereal) imax;
	sfmin = rmin;
	small = 1. / rmax;
	if (small >= sfmin) {

/*           Use SMALL plus a bit, to avoid the possibility of rounding */
/*           causing overflow when computing  1/sfmin. */

	    sfmin = small * (eps + 1.);
	}
    }

    if (lsame_(cmach, "E")) {
	rmach = eps;
    } else if (lsame_(cmach, "S")) {
	rmach = sfmin;
    } else if (lsame_(cmach, "B")) {
	rmach = base;
    } else if (lsame_(cmach, "P")) {
	rmach = prec;
    } else if (lsame_(cmach, "N")) {
	rmach = t;
    } else if (lsame_(cmach, "R")) {
	rmach = rnd;
    } else if (lsame_(cmach, "M")) {
	rmach = emin;
    } else if (lsame_(cmach, "U")) {
	rmach = rmin;
    } else if (lsame_(cmach, "L")) {
	rmach = emax;
    } else if (lsame_(cmach, "O")) {
	rmach = rmax;
    }

    ret_val = rmach;
    first = FALSE_;
    return ret_val;

/*     End of DLAMCH */

} /* dlamch_ */
Esempio n. 2
0
double dlamch_(char *cmach)
{
/*  -- LAPACK auxiliary routine (version 2.0) --   
       Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
       Courant Institute, Argonne National Lab, and Rice University   
       October 31, 1992   

    Purpose   
    =======   

    DLAMCH determines double precision machine parameters.   

    Arguments   
    =========   

    CMACH   (input) CHARACTER*1   
            Specifies the value to be returned by DLAMCH:   
            = 'E' or 'e',   DLAMCH := eps   
            = 'S' or 's ,   DLAMCH := sfmin   
            = 'B' or 'b',   DLAMCH := base   
            = 'P' or 'p',   DLAMCH := eps*base   
            = 'N' or 'n',   DLAMCH := t   
            = 'R' or 'r',   DLAMCH := rnd   
            = 'M' or 'm',   DLAMCH := emin   
            = 'U' or 'u',   DLAMCH := rmin   
            = 'L' or 'l',   DLAMCH := emax   
            = 'O' or 'o',   DLAMCH := rmax   

            where   

            eps   = relative machine precision   
            sfmin = safe minimum, such that 1/sfmin does not overflow   
            base  = base of the machine   
            prec  = eps*base   
            t     = number of (base) digits in the mantissa   
            rnd   = 1.0 when rounding occurs in addition, 0.0 otherwise   
            emin  = minimum exponent before (gradual) underflow   
            rmin  = underflow threshold - base**(emin-1)   
            emax  = largest exponent before overflow   
            rmax  = overflow threshold  - (base**emax)*(1-eps)   

   ===================================================================== 
*/

    static int first = TRUE_;

    /* System generated locals */
    int i__1;
    double ret_val;
    /* Builtin functions */
    double pow_di(double *, int *);
    /* Local variables */
    static double base;
    static int beta;
    static double emin, prec, emax;
    static int imin, imax;
    static int lrnd;
    static double rmin, rmax, t, rmach;
    extern int lsame_(char *, char *);
    static double small, sfmin;
    extern /* Subroutine */ int dlamc2_(int *, int *, int *, 
	    double *, int *, double *, int *, double *);
    static int it;
    static double rnd, eps;

    if (first) {
	first = FALSE_;
	dlamc2_(&beta, &it, &lrnd, &eps, &imin, &rmin, &imax, &rmax);
	base = (double) beta;
	t = (double) it;
	if (lrnd) {
	    rnd = 1.;
	    i__1 = 1 - it;
	    eps = pow_di(&base, &i__1) / 2;
	} else {
	    rnd = 0.;
	    i__1 = 1 - it;
	    eps = pow_di(&base, &i__1);
	}
	prec = eps * base;
	emin = (double) imin;
	emax = (double) imax;
	sfmin = rmin;
	small = 1. / rmax;
	if (small >= sfmin) {

	/* Use SMALL plus a bit, to avoid the possibility of rounding   
             causing overflow when computing  1/sfmin. */
	    sfmin = small * (eps + 1.);
	}
    }

    if (lsame_(cmach, "E")) {
	rmach = eps;
    } else if (lsame_(cmach, "S")) {
	rmach = sfmin;
    } else if (lsame_(cmach, "B")) {
	rmach = base;
    } else if (lsame_(cmach, "P")) {
	rmach = prec;
    } else if (lsame_(cmach, "N")) {
	rmach = t;
    } else if (lsame_(cmach, "R")) {
	rmach = rnd;
    } else if (lsame_(cmach, "M")) {
	rmach = emin;
    } else if (lsame_(cmach, "U")) {
	rmach = rmin;
    } else if (lsame_(cmach, "L")) {
	rmach = emax;
    } else if (lsame_(cmach, "O")) {
	rmach = rmax;
    }

    ret_val = rmach;
    return ret_val;

/*     End of DLAMCH */

} /* dlamch_ */
Esempio n. 3
0
File: dlamch.c Progetto: Kitware/ITK
/*<       DOUBLE PRECISION FUNCTION DLAMCH( CMACH ) >*/
doublereal dlamch_(char *cmach, ftnlen cmach_len)
{
    /* Initialized data */

    static logical first = TRUE_; /* runtime-initialized constant */

    /* System generated locals */
    integer i__1;
    doublereal ret_val;

    /* Builtin functions */
    double pow_di(doublereal *, integer *);

    /* Local variables */
    static doublereal t; /* runtime-initialized constant */
    integer it;
    static doublereal rnd, eps, base; /* runtime-initialized constant */
    integer beta;
    static doublereal emin, prec, emax; /* runtime-initialized constant */
    integer imin, imax;
    logical lrnd;
    static doublereal rmin, rmax; /* runtime-initialized constant */
    doublereal rmach=0;
    extern logical lsame_(const char *, const char *, ftnlen, ftnlen);
    doublereal small;
    static doublereal sfmin; /* runtime-initialized constant */
    extern /* Subroutine */ int dlamc2_(integer *, integer *, logical *,
            doublereal *, integer *, doublereal *, integer *, doublereal *);

    (void)cmach_len;
/*  -- LAPACK auxiliary routine (version 1.1) -- */
/*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/*     Courant Institute, Argonne National Lab, and Rice University */
/*     October 31, 1992 */

/*     .. Scalar Arguments .. */
/*<       CHARACTER          CMACH >*/
/*     .. */

/*  Purpose */
/*  ======= */

/*  DLAMCH determines double precision machine parameters. */

/*  Arguments */
/*  ========= */

/*  CMACH   (input) CHARACTER*1 */
/*          Specifies the value to be returned by DLAMCH: */
/*          = 'E' or 'e',   DLAMCH := eps */
/*          = 'S' or 's ,   DLAMCH := sfmin */
/*          = 'B' or 'b',   DLAMCH := base */
/*          = 'P' or 'p',   DLAMCH := eps*base */
/*          = 'N' or 'n',   DLAMCH := t */
/*          = 'R' or 'r',   DLAMCH := rnd */
/*          = 'M' or 'm',   DLAMCH := emin */
/*          = 'U' or 'u',   DLAMCH := rmin */
/*          = 'L' or 'l',   DLAMCH := emax */
/*          = 'O' or 'o',   DLAMCH := rmax */

/*          where */

/*          eps   = relative machine precision */
/*          sfmin = safe minimum, such that 1/sfmin does not overflow */
/*          base  = base of the machine */
/*          prec  = eps*base */
/*          t     = number of (base) digits in the mantissa */
/*          rnd   = 1.0 when rounding occurs in addition, 0.0 otherwise */
/*          emin  = minimum exponent before (gradual) underflow */
/*          rmin  = underflow threshold - base**(emin-1) */
/*          emax  = largest exponent before overflow */
/*          rmax  = overflow threshold  - (base**emax)*(1-eps) */

/* ===================================================================== */

/*     .. Parameters .. */
/*<       DOUBLE PRECISION   ONE, ZERO >*/
/*<       PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 ) >*/
/*     .. */
/*     .. Local Scalars .. */
/*<       LOGICAL            FIRST, LRND >*/
/*<       INTEGER            BETA, IMAX, IMIN, IT >*/
/*<    >*/
/*     .. */
/*     .. External Functions .. */
/*<       LOGICAL            LSAME >*/
/*<       EXTERNAL           LSAME >*/
/*     .. */
/*     .. External Subroutines .. */
/*<       EXTERNAL           DLAMC2 >*/
/*     .. */
/*     .. Save statement .. */
/*<    >*/
/*     .. */
/*     .. Data statements .. */
/*<       DATA               FIRST / .TRUE. / >*/
/*     .. */
/*     .. Executable Statements .. */

/*<       IF( FIRST ) THEN >*/
    if (first) {
/*<          FIRST = .FALSE. >*/
        first = FALSE_;
/*<          CALL DLAMC2( BETA, IT, LRND, EPS, IMIN, RMIN, IMAX, RMAX ) >*/
        dlamc2_(&beta, &it, &lrnd, &eps, &imin, &rmin, &imax, &rmax);
/*<          BASE = BETA >*/
        base = (doublereal) beta;
/*<          T = IT >*/
        t = (doublereal) it;
/*<          IF( LRND ) THEN >*/
        if (lrnd) {
/*<             RND = ONE >*/
            rnd = 1.;
/*<             EPS = ( BASE**( 1-IT ) ) / 2 >*/
            i__1 = 1 - it;
            eps = pow_di(&base, &i__1) / 2;
/*<          ELSE >*/
        } else {
/*<             RND = ZERO >*/
            rnd = 0.;
/*<             EPS = BASE**( 1-IT ) >*/
            i__1 = 1 - it;
            eps = pow_di(&base, &i__1);
/*<          END IF >*/
        }
/*<          PREC = EPS*BASE >*/
        prec = eps * base;
/*<          EMIN = IMIN >*/
        emin = (doublereal) imin;
/*<          EMAX = IMAX >*/
        emax = (doublereal) imax;
/*<          SFMIN = RMIN >*/
        sfmin = rmin;
/*<          SMALL = ONE / RMAX >*/
        small = 1. / rmax;
/*<          IF( SMALL.GE.SFMIN ) THEN >*/
        if (small >= sfmin) {

/*           Use SMALL plus a bit, to avoid the possibility of rounding */
/*           causing overflow when computing  1/sfmin. */

/*<             SFMIN = SMALL*( ONE+EPS ) >*/
            sfmin = small * (eps + 1.);
/*<          END IF >*/
        }
/*<       END IF >*/
    }

/*<       IF( LSAME( CMACH, 'E' ) ) THEN >*/
    if (lsame_(cmach, "E", (ftnlen)1, (ftnlen)1)) {
/*<          RMACH = EPS >*/
        rmach = eps;
/*<       ELSE IF( LSAME( CMACH, 'S' ) ) THEN >*/
    } else if (lsame_(cmach, "S", (ftnlen)1, (ftnlen)1)) {
/*<          RMACH = SFMIN >*/
        rmach = sfmin;
/*<       ELSE IF( LSAME( CMACH, 'B' ) ) THEN >*/
    } else if (lsame_(cmach, "B", (ftnlen)1, (ftnlen)1)) {
/*<          RMACH = BASE >*/
        rmach = base;
/*<       ELSE IF( LSAME( CMACH, 'P' ) ) THEN >*/
    } else if (lsame_(cmach, "P", (ftnlen)1, (ftnlen)1)) {
/*<          RMACH = PREC >*/
        rmach = prec;
/*<       ELSE IF( LSAME( CMACH, 'N' ) ) THEN >*/
    } else if (lsame_(cmach, "N", (ftnlen)1, (ftnlen)1)) {
/*<          RMACH = T >*/
        rmach = t;
/*<       ELSE IF( LSAME( CMACH, 'R' ) ) THEN >*/
    } else if (lsame_(cmach, "R", (ftnlen)1, (ftnlen)1)) {
/*<          RMACH = RND >*/
        rmach = rnd;
/*<       ELSE IF( LSAME( CMACH, 'M' ) ) THEN >*/
    } else if (lsame_(cmach, "M", (ftnlen)1, (ftnlen)1)) {
/*<          RMACH = EMIN >*/
        rmach = emin;
/*<       ELSE IF( LSAME( CMACH, 'U' ) ) THEN >*/
    } else if (lsame_(cmach, "U", (ftnlen)1, (ftnlen)1)) {
/*<          RMACH = RMIN >*/
        rmach = rmin;
/*<       ELSE IF( LSAME( CMACH, 'L' ) ) THEN >*/
    } else if (lsame_(cmach, "L", (ftnlen)1, (ftnlen)1)) {
/*<          RMACH = EMAX >*/
        rmach = emax;
/*<       ELSE IF( LSAME( CMACH, 'O' ) ) THEN >*/
    } else if (lsame_(cmach, "O", (ftnlen)1, (ftnlen)1)) {
/*<          RMACH = RMAX >*/
        rmach = rmax;
/*<       END IF >*/
    }

/*<       DLAMCH = RMACH >*/
    ret_val = rmach;
/*<       RETURN >*/
    return ret_val;

/*     End of DLAMCH */

/*<       END >*/
} /* dlamch_ */
Esempio n. 4
0
/*! \brief

<pre>
    Purpose   
    =======   

    DLAMCH determines double precision machine parameters.   

    Arguments   
    =========   

    CMACH   (input) CHARACTER*1   
            Specifies the value to be returned by DLAMCH:   
            = 'E' or 'e',   DLAMCH := eps   
            = 'S' or 's ,   DLAMCH := sfmin   
            = 'B' or 'b',   DLAMCH := base   
            = 'P' or 'p',   DLAMCH := eps*base   
            = 'N' or 'n',   DLAMCH := t   
            = 'R' or 'r',   DLAMCH := rnd   
            = 'M' or 'm',   DLAMCH := emin   
            = 'U' or 'u',   DLAMCH := rmin   
            = 'L' or 'l',   DLAMCH := emax   
            = 'O' or 'o',   DLAMCH := rmax   

            where   

            eps   = relative machine precision   
            sfmin = safe minimum, such that 1/sfmin does not overflow   
            base  = base of the machine   
            prec  = eps*base   
            t     = number of (base) digits in the mantissa   
            rnd   = 1.0 when rounding occurs in addition, 0.0 otherwise   
            emin  = minimum exponent before (gradual) underflow   
            rmin  = underflow threshold - base**(emin-1)   
            emax  = largest exponent before overflow   
            rmax  = overflow threshold  - (base**emax)*(1-eps)   

   ===================================================================== 
</pre>
*/
double dlamch_(char *cmach)
{


    static int first = TRUE_;

    /* System generated locals */
    int i__1;
    double ret_val;
    /* Builtin functions */
    double pow_di(double *, int *);
    /* Local variables */
    static double base;
    static int beta;
    static double emin, prec, emax;
    static int imin, imax;
    static int lrnd;
    static double rmin, rmax, t, rmach;
    extern int lsame_(char *, char *);
    static double small, sfmin;
    extern /* Subroutine */ int dlamc2_(int *, int *, int *, 
	    double *, int *, double *, int *, double *);
    static int it;
    static double rnd, eps;

    if (first) {
	first = FALSE_;
	dlamc2_(&beta, &it, &lrnd, &eps, &imin, &rmin, &imax, &rmax);
	base = (double) beta;
	t = (double) it;
	if (lrnd) {
	    rnd = 1.;
	    i__1 = 1 - it;
	    eps = pow_di(&base, &i__1) / 2;
	} else {
	    rnd = 0.;
	    i__1 = 1 - it;
	    eps = pow_di(&base, &i__1);
	}
	prec = eps * base;
	emin = (double) imin;
	emax = (double) imax;
	sfmin = rmin;
	small = 1. / rmax;
	if (small >= sfmin) {

	/* Use SMALL plus a bit, to avoid the possibility of rounding   
             causing overflow when computing  1/sfmin. */
	    sfmin = small * (eps + 1.);
	}
    }

    if (lsame_(cmach, "E")) {
	rmach = eps;
    } else if (lsame_(cmach, "S")) {
	rmach = sfmin;
    } else if (lsame_(cmach, "B")) {
	rmach = base;
    } else if (lsame_(cmach, "P")) {
	rmach = prec;
    } else if (lsame_(cmach, "N")) {
	rmach = t;
    } else if (lsame_(cmach, "R")) {
	rmach = rnd;
    } else if (lsame_(cmach, "M")) {
	rmach = emin;
    } else if (lsame_(cmach, "U")) {
	rmach = rmin;
    } else if (lsame_(cmach, "L")) {
	rmach = emax;
    } else if (lsame_(cmach, "O")) {
	rmach = rmax;
    }

    ret_val = rmach;
    return ret_val;

/*     End of DLAMCH */

} /* dlamch_ */