Exemple #1
0
/* Subroutine */ int dlamc2_(int *beta, int *t, int *rnd, 
	double *eps, int *emin, double *rmin, int *emax, 
	double *rmax)
{
/*  -- 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   
    =======   

    DLAMC2 determines the machine parameters specified in its argument   
    list.   

    Arguments   
    =========   

    BETA    (output) INT   
            The base of the machine.   

    T       (output) INT   
            The number of ( BETA ) digits in the mantissa.   

    RND     (output) INT   
            Specifies whether proper rounding  ( RND = .TRUE. )  or   
            chopping  ( RND = .FALSE. )  occurs in addition. This may not 
  
            be a reliable guide to the way in which the machine performs 
  
            its arithmetic.   

    EPS     (output) DOUBLE PRECISION   
            The smallest positive number such that   

               fl( 1.0 - EPS ) .LT. 1.0,   

            where fl denotes the computed value.   

    EMIN    (output) INT   
            The minimum exponent before (gradual) underflow occurs.   

    RMIN    (output) DOUBLE PRECISION   
            The smallest normalized number for the machine, given by   
            BASE**( EMIN - 1 ), where  BASE  is the floating point value 
  
            of BETA.   

    EMAX    (output) INT   
            The maximum exponent before overflow occurs.   

    RMAX    (output) DOUBLE PRECISION   
            The largest positive number for the machine, given by   
            BASE**EMAX * ( 1 - EPS ), where  BASE  is the floating point 
  
            value of BETA.   

    Further Details   
    ===============   

    The computation of  EPS  is based on a routine PARANOIA by   
    W. Kahan of the University of California at Berkeley.   

   ===================================================================== 
*/
    /* Table of constant values */
    static int c__1 = 1;
    
    /* Initialized data */
    static int first = TRUE_;
    static int iwarn = FALSE_;
    /* System generated locals */
    int i__1;
    double d__1, d__2, d__3, d__4, d__5;
    /* Builtin functions */
    double pow_di(double *, int *);
    /* Local variables */
    static int ieee;
    static double half;
    static int lrnd;
    static double leps, zero, a, b, c;
    static int i, lbeta;
    static double rbase;
    static int lemin, lemax, gnmin;
    static double small;
    static int gpmin;
    static double third, lrmin, lrmax, sixth;
    extern /* Subroutine */ int dlamc1_(int *, int *, int *, 
	    int *);
    extern double dlamc3_(double *, double *);
    static int lieee1;
    extern /* Subroutine */ int dlamc4_(int *, double *, int *), 
	    dlamc5_(int *, int *, int *, int *, int *, 
	    double *);
    static int lt, ngnmin, ngpmin;
    static double one, two;

    if (first) {
	first = FALSE_;
	zero = 0.;
	one = 1.;
	two = 2.;

/*        LBETA, LT, LRND, LEPS, LEMIN and LRMIN  are the local values
 of   
          BETA, T, RND, EPS, EMIN and RMIN.   

          Throughout this routine  we use the function  DLAMC3  to ens
ure   
          that relevant values are stored  and not held in registers, 
 or   
          are not affected by optimizers.   

          DLAMC1 returns the parameters  LBETA, LT, LRND and LIEEE1. 
*/

	dlamc1_(&lbeta, &lt, &lrnd, &lieee1);

/*        Start to find EPS. */

	b = (double) lbeta;
	i__1 = -lt;
	a = pow_di(&b, &i__1);
	leps = a;

/*        Try some tricks to see whether or not this is the correct  E
PS. */

	b = two / 3;
	half = one / 2;
	d__1 = -half;
	sixth = dlamc3_(&b, &d__1);
	third = dlamc3_(&sixth, &sixth);
	d__1 = -half;
	b = dlamc3_(&third, &d__1);
	b = dlamc3_(&b, &sixth);
	b = abs(b);
	if (b < leps) {
	    b = leps;
	}

	leps = 1.;

/* +       WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP */
L10:
	if (leps > b && b > zero) {
	    leps = b;
	    d__1 = half * leps;
/* Computing 5th power */
	    d__3 = two, d__4 = d__3, d__3 *= d__3;
/* Computing 2nd power */
	    d__5 = leps;
	    d__2 = d__4 * (d__3 * d__3) * (d__5 * d__5);
	    c = dlamc3_(&d__1, &d__2);
	    d__1 = -c;
	    c = dlamc3_(&half, &d__1);
	    b = dlamc3_(&half, &c);
	    d__1 = -b;
	    c = dlamc3_(&half, &d__1);
	    b = dlamc3_(&half, &c);
	    goto L10;
	}
/* +       END WHILE */

	if (a < leps) {
	    leps = a;
	}

/*        Computation of EPS complete.   

          Now find  EMIN.  Let A = + or - 1, and + or - (1 + BASE**(-3
)).   
          Keep dividing  A by BETA until (gradual) underflow occurs. T
his   
          is detected when we cannot recover the previous A. */

	rbase = one / lbeta;
	small = one;
	for (i = 1; i <= 3; ++i) {
	    d__1 = small * rbase;
	    small = dlamc3_(&d__1, &zero);
/* L20: */
	}
	a = dlamc3_(&one, &small);
	dlamc4_(&ngpmin, &one, &lbeta);
	d__1 = -one;
	dlamc4_(&ngnmin, &d__1, &lbeta);
	dlamc4_(&gpmin, &a, &lbeta);
	d__1 = -a;
	dlamc4_(&gnmin, &d__1, &lbeta);
	ieee = FALSE_;

	if (ngpmin == ngnmin && gpmin == gnmin) {
	    if (ngpmin == gpmin) {
		lemin = ngpmin;
/*            ( Non twos-complement machines, no gradual under
flow;   
                e.g.,  VAX ) */
	    } else if (gpmin - ngpmin == 3) {
		lemin = ngpmin - 1 + lt;
		ieee = TRUE_;
/*            ( Non twos-complement machines, with gradual und
erflow;   
                e.g., IEEE standard followers ) */
	    } else {
		lemin = min(ngpmin,gpmin);
/*            ( A guess; no known machine ) */
		iwarn = TRUE_;
	    }

	} else if (ngpmin == gpmin && ngnmin == gnmin) {
	    if ((i__1 = ngpmin - ngnmin, abs(i__1)) == 1) {
		lemin = max(ngpmin,ngnmin);
/*            ( Twos-complement machines, no gradual underflow
;   
                e.g., CYBER 205 ) */
	    } else {
		lemin = min(ngpmin,ngnmin);
/*            ( A guess; no known machine ) */
		iwarn = TRUE_;
	    }

	} else if ((i__1 = ngpmin - ngnmin, abs(i__1)) == 1 && gpmin == gnmin)
		 {
	    if (gpmin - min(ngpmin,ngnmin) == 3) {
		lemin = max(ngpmin,ngnmin) - 1 + lt;
/*            ( Twos-complement machines with gradual underflo
w;   
                no known machine ) */
	    } else {
		lemin = min(ngpmin,ngnmin);
/*            ( A guess; no known machine ) */
		iwarn = TRUE_;
	    }

	} else {
/* Computing MIN */
	    i__1 = min(ngpmin,ngnmin), i__1 = min(i__1,gpmin);
	    lemin = min(i__1,gnmin);
/*         ( A guess; no known machine ) */
	    iwarn = TRUE_;
	}
/* **   
   Comment out this if block if EMIN is ok */
	if (iwarn) {
	    first = TRUE_;
	    printf("\n\n WARNING. The value EMIN may be incorrect:- ");
	    printf("EMIN = %8i\n",lemin);
	    printf("If, after inspection, the value EMIN looks acceptable");
            printf("please comment out \n the IF block as marked within the"); 
            printf("code of routine DLAMC2, \n otherwise supply EMIN"); 
            printf("explicitly.\n");
	}
/* **   

          Assume IEEE arithmetic if we found denormalised  numbers abo
ve,   
          or if arithmetic seems to round in the  IEEE style,  determi
ned   
          in routine DLAMC1. A true IEEE machine should have both  thi
ngs   
          true; however, faulty machines may have one or the other. */

	ieee = ieee || lieee1;

/*        Compute  RMIN by successive division by  BETA. We could comp
ute   
          RMIN as BASE**( EMIN - 1 ),  but some machines underflow dur
ing   
          this computation. */

	lrmin = 1.;
	i__1 = 1 - lemin;
	for (i = 1; i <= 1-lemin; ++i) {
	    d__1 = lrmin * rbase;
	    lrmin = dlamc3_(&d__1, &zero);
/* L30: */
	}

/*        Finally, call DLAMC5 to compute EMAX and RMAX. */

	dlamc5_(&lbeta, &lt, &lemin, &ieee, &lemax, &lrmax);
    }

    *beta = lbeta;
    *t = lt;
    *rnd = lrnd;
    *eps = leps;
    *emin = lemin;
    *rmin = lrmin;
    *emax = lemax;
    *rmax = lrmax;

    return 0;


/*     End of DLAMC2 */

} /* dlamc2_ */
Exemple #2
0
/* Subroutine */ int dlamc2_(integer* beta, integer* t, logical* rnd,
                             doublereal* eps, integer* emin, doublereal* rmin, integer* emax,
                             doublereal* rmax) {
    /* Initialized data */

    static logical first = TRUE_;
    static logical iwarn = FALSE_;

    /* Format strings */
    static char fmt_9999[] = "(//\002 WARNING. The value EMIN may be incorre"
                             "ct:-\002,\002  EMIN = \002,i8,/\002 If, after inspection, the va"
                             "lue EMIN looks\002,\002 acceptable please comment out \002,/\002"
                             " the IF block as marked within the code of routine\002,\002 DLAM"
                             "C2,\002,/\002 otherwise supply EMIN explicitly.\002,/)";

    /* System generated locals */
    integer i__1;
    doublereal d__1, d__2, d__3, d__4, d__5;

    /* Builtin functions */
    double pow_di(doublereal*, integer*);
    //integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);

    /* Local variables */
    doublereal a, b, c__;
    integer i__;
    static integer lt;
    doublereal one, two;
    logical ieee;
    doublereal half;
    logical lrnd;
    static doublereal leps;
    doublereal zero;
    static integer lbeta;
    doublereal rbase;
    static integer lemin, lemax;
    integer gnmin;
    doublereal small;
    integer gpmin;
    doublereal third;
    static doublereal lrmin, lrmax;
    doublereal sixth;
    extern /* Subroutine */ int dlamc1_(integer*, integer*, logical*,
                                        logical*);
    extern doublereal dlamc3_(doublereal*, doublereal*);
    logical lieee1;
    extern /* Subroutine */ int dlamc4_(integer*, doublereal*, integer*),
           dlamc5_(integer*, integer*, integer*, logical*, integer*,
                   doublereal*);
    integer ngnmin, ngpmin;

    /* Fortran I/O blocks */
    static cilist io___58 = { 0, 6, 0, fmt_9999, 0 };



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

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

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

    /*  DLAMC2 determines the machine parameters specified in its argument */
    /*  list. */

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

    /*  BETA    (output) INTEGER */
    /*          The base of the machine. */

    /*  T       (output) INTEGER */
    /*          The number of ( BETA ) digits in the mantissa. */

    /*  RND     (output) LOGICAL */
    /*          Specifies whether proper rounding  ( RND = .TRUE. )  or */
    /*          chopping  ( RND = .FALSE. )  occurs in addition. This may not */
    /*          be a reliable guide to the way in which the machine performs */
    /*          its arithmetic. */

    /*  EPS     (output) DOUBLE PRECISION */
    /*          The smallest positive number such that */

    /*             fl( 1.0 - EPS ) .LT. 1.0, */

    /*          where fl denotes the computed value. */

    /*  EMIN    (output) INTEGER */
    /*          The minimum exponent before (gradual) underflow occurs. */

    /*  RMIN    (output) DOUBLE PRECISION */
    /*          The smallest normalized number for the machine, given by */
    /*          BASE**( EMIN - 1 ), where  BASE  is the floating point value */
    /*          of BETA. */

    /*  EMAX    (output) INTEGER */
    /*          The maximum exponent before overflow occurs. */

    /*  RMAX    (output) DOUBLE PRECISION */
    /*          The largest positive number for the machine, given by */
    /*          BASE**EMAX * ( 1 - EPS ), where  BASE  is the floating point */
    /*          value of BETA. */

    /*  Further Details */
    /*  =============== */

    /*  The computation of  EPS  is based on a routine PARANOIA by */
    /*  W. Kahan of the University of California at Berkeley. */

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

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

    if (first) {
        zero = 0.;
        one = 1.;
        two = 2.;

        /*        LBETA, LT, LRND, LEPS, LEMIN and LRMIN  are the local values of */
        /*        BETA, T, RND, EPS, EMIN and RMIN. */

        /*        Throughout this routine  we use the function  DLAMC3  to ensure */
        /*        that relevant values are stored  and not held in registers,  or */
        /*        are not affected by optimizers. */

        /*        DLAMC1 returns the parameters  LBETA, LT, LRND and LIEEE1. */

        dlamc1_(&lbeta, &lt, &lrnd, &lieee1);

        /*        Start to find EPS. */

        b = (doublereal) lbeta;
        i__1 = -lt;
        a = pow_di(&b, &i__1);
        leps = a;

        /*        Try some tricks to see whether or not this is the correct  EPS. */

        b = two / 3;
        half = one / 2;
        d__1 = -half;
        sixth = dlamc3_(&b, &d__1);
        third = dlamc3_(&sixth, &sixth);
        d__1 = -half;
        b = dlamc3_(&third, &d__1);
        b = dlamc3_(&b, &sixth);
        b = abs(b);
        if (b < leps) {
            b = leps;
        }

        leps = 1.;

        /* +       WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP */
L10:
        if (leps > b && b > zero) {
            leps = b;
            d__1 = half * leps;
            /* Computing 5th power */
            d__3 = two, d__4 = d__3, d__3 *= d__3;
            /* Computing 2nd power */
            d__5 = leps;
            d__2 = d__4 * (d__3 * d__3) * (d__5 * d__5);
            c__ = dlamc3_(&d__1, &d__2);
            d__1 = -c__;
            c__ = dlamc3_(&half, &d__1);
            b = dlamc3_(&half, &c__);
            d__1 = -b;
            c__ = dlamc3_(&half, &d__1);
            b = dlamc3_(&half, &c__);
            goto L10;
        }
        /* +       END WHILE */

        if (a < leps) {
            leps = a;
        }

        /*        Computation of EPS complete. */

        /*        Now find  EMIN.  Let A = + or - 1, and + or - (1 + BASE**(-3)). */
        /*        Keep dividing  A by BETA until (gradual) underflow occurs. This */
        /*        is detected when we cannot recover the previous A. */

        rbase = one / lbeta;
        small = one;
        for (i__ = 1; i__ <= 3; ++i__) {
            d__1 = small * rbase;
            small = dlamc3_(&d__1, &zero);
            /* L20: */
        }
        a = dlamc3_(&one, &small);
        dlamc4_(&ngpmin, &one, &lbeta);
        d__1 = -one;
        dlamc4_(&ngnmin, &d__1, &lbeta);
        dlamc4_(&gpmin, &a, &lbeta);
        d__1 = -a;
        dlamc4_(&gnmin, &d__1, &lbeta);
        ieee = FALSE_;

        if (ngpmin == ngnmin && gpmin == gnmin) {
            if (ngpmin == gpmin) {
                lemin = ngpmin;
                /*            ( Non twos-complement machines, no gradual underflow; */
                /*              e.g.,  VAX ) */
            } else if (gpmin - ngpmin == 3) {
                lemin = ngpmin - 1 + lt;
                ieee = TRUE_;
                /*            ( Non twos-complement machines, with gradual underflow; */
                /*              e.g., IEEE standard followers ) */
            } else {
                lemin = min(ngpmin, gpmin);
                /*            ( A guess; no known machine ) */
                iwarn = TRUE_;
            }

        } else if (ngpmin == gpmin && ngnmin == gnmin) {
            if ((i__1 = ngpmin - ngnmin, abs(i__1)) == 1) {
                lemin = max(ngpmin, ngnmin);
                /*            ( Twos-complement machines, no gradual underflow; */
                /*              e.g., CYBER 205 ) */
            } else {
                lemin = min(ngpmin, ngnmin);
                /*            ( A guess; no known machine ) */
                iwarn = TRUE_;
            }

        } else if ((i__1 = ngpmin - ngnmin, abs(i__1)) == 1 && gpmin == gnmin) {
            if (gpmin - min(ngpmin, ngnmin) == 3) {
                lemin = max(ngpmin, ngnmin) - 1 + lt;
                /*            ( Twos-complement machines with gradual underflow; */
                /*              no known machine ) */
            } else {
                lemin = min(ngpmin, ngnmin);
                /*            ( A guess; no known machine ) */
                iwarn = TRUE_;
            }

        } else {
            /* Computing MIN */
            i__1 = min(ngpmin, ngnmin), i__1 = min(i__1, gpmin);
            lemin = min(i__1, gnmin);
            /*         ( A guess; no known machine ) */
            iwarn = TRUE_;
        }
        first = FALSE_;
        /* ** */
        /* Comment out this if block if EMIN is ok */
        if (iwarn) {
            first = TRUE_;
            printf("\n\n WARNING. The value EMIN may be incorrect:- ");
            printf("EMIN = %8i\n", lemin);
            printf("If, after inspection, the value EMIN looks acceptable");
            printf("please comment out \n the IF block as marked within the");
            printf("code of routine DLAMC2, \n otherwise supply EMIN");
            printf("explicitly.\n");
            /*
            	    s_wsfe(&io___58);
            	    do_fio(&c__1, (char *)&lemin, (ftnlen)sizeof(integer));
            	    e_wsfe();
            */
        }
        /* ** */

        /*        Assume IEEE arithmetic if we found denormalised  numbers above, */
        /*        or if arithmetic seems to round in the  IEEE style,  determined */
        /*        in routine DLAMC1. A true IEEE machine should have both  things */
        /*        true; however, faulty machines may have one or the other. */

        ieee = ieee || lieee1;

        /*        Compute  RMIN by successive division by  BETA. We could compute */
        /*        RMIN as BASE**( EMIN - 1 ),  but some machines underflow during */
        /*        this computation. */

        lrmin = 1.;
        i__1 = 1 - lemin;
        for (i__ = 1; i__ <= i__1; ++i__) {
            d__1 = lrmin * rbase;
            lrmin = dlamc3_(&d__1, &zero);
            /* L30: */
        }

        /*        Finally, call DLAMC5 to compute EMAX and RMAX. */

        dlamc5_(&lbeta, &lt, &lemin, &ieee, &lemax, &lrmax);
    }

    *beta = lbeta;
    *t = lt;
    *rnd = lrnd;
    *eps = leps;
    *emin = lemin;
    *rmin = lrmin;
    *emax = lemax;
    *rmax = lrmax;

    return 0;


    /*     End of DLAMC2 */

} /* dlamc2_ */