dlamch.c

InsightToolkit-1.4.0(有大量的优化算法程序)

#include "f2c.h"
#include "netlib.h"
#include <stdio.h>

static void dlamc1_(integer *beta, integer *t, logical *rnd, logical *ieee1);
static void dlamc2_(integer *beta, integer *t, logical *rnd, doublereal *eps,
                     integer *emin, doublereal *rmin, integer *emax, doublereal *rmax);
static doublereal dlamc3_(doublereal *a, doublereal *b);
static void dlamc4_(integer *emin, doublereal *start, integer *base);
static void dlamc5_(integer *beta, integer *p, integer *emin, logical *ieee, integer *emax, doublereal *rmax);
static doublereal dlamc33_(doublereal *a, doublereal *b);

doublereal dlamch_(const 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)

   =====================================================================
*/
    /* Initialized data */
    static logical first = TRUE_;
    /* System generated locals */
    integer i__1;
    /* Local variables */
    static doublereal base;
    static integer beta;
    static doublereal emin, prec, emax;
    static integer imin, imax;
    static logical lrnd;
    static doublereal rmin, rmax, t, rmach;
    static doublereal small, sfmin;
    static integer it;
    static doublereal rnd, eps;

    if (first) {
        first = FALSE_;
        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;
    }

    return rmach;

} /* dlamch_ */

/* Subroutine */ void dlamc1_(integer *beta, integer *t, logical *rnd, logical *ieee1)
{
/*  -- 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
    =======

    DLAMC1 determines the machine parameters given by BETA, T, RND, and
    IEEE1.

    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.

    IEEE1   (output) LOGICAL
            Specifies whether rounding appears to be done in the IEEE
            'round to nearest' style.

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

    The routine is based on the routine  ENVRON  by Malcolm and
    incorporates suggestions by Gentleman and Marovich. See

       Malcolm M. A. (1972) Algorithms to reveal properties of
          floating-point arithmetic. Comms. of the ACM, 15, 949-951.

       Gentleman W. M. and Marovich S. B. (1974) More on algorithms
          that reveal properties of floating point arithmetic units.
          Comms. of the ACM, 17, 276-277.

   =====================================================================
*/
    /* Initialized data */
    static logical first = TRUE_;
    /* System generated locals */
    doublereal d__1, d__2;
    /* Local variables */
    static logical lrnd;
    static doublereal a, b, c, f;
    static integer lbeta;
    static doublereal savec;
    static logical lieee1;
    static doublereal t1, t2;
    static integer lt;
    static doublereal one = 1., qtr;

    if (first) {
        first = FALSE_;

/*        LBETA,  LIEEE1,  LT and  LRND  are the  local values  of  BETA,
          IEEE1, T and RND.

          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.

          Compute  a = 2.0**m  with the  smallest positive integer m such
          that
                fl( a + 1.0 ) = a.
*/

        a = c = one;

        while (c == one) {
            a *= 2;
            c = dlamc3_(&a, &one);
            c = dlamc33_(&c, &a);
        }

/*        Now compute  b = 2.0**m  with the smallest positive integer m
          such that
                    fl( a + b ) .gt. a.
*/

        b = one;

        do {
            b *= 2;
            c = dlamc3_(&a, &b);
        } while (c == a);

/*        Now compute the base.  a and c  are neighbouring floating point
          numbers  in the  interval  ( beta**t, beta**( t + 1 ) )  and so
          their difference is beta. Adding 0.25 to c is to ensure that it
          is truncated to beta and not ( beta - 1 ).
*/

        qtr = one / 4;
        savec = c;
        c = dlamc33_(&c, &a);
        lbeta = (integer) (c + qtr);

/*        Now determine whether rounding or chopping occurs,  by adding a
          bit  less  than  beta/2  and a  bit  more  than  beta/2  to a.
*/

        b = (doublereal) lbeta;
        d__1 = b / 2;
        d__2 = -b / 100;
        f = dlamc3_(&d__1, &d__2);
        c = dlamc3_(&f, &a);
        if (c == a) {
            lrnd = TRUE_;
        } else {
            lrnd = FALSE_;
        }
        d__1 = b / 2;
        d__2 = b / 100;
        f = dlamc3_(&d__1, &d__2);
        c = dlamc3_(&f, &a);
        if (lrnd && c == a) {
            lrnd = FALSE_;
        }

/*        Try and decide whether rounding is done in the  IEEE  'round to
          nearest' style. B/2 is half a unit in the last place of the two
          numbers A and SAVEC. Furthermore, A is even, i.e. has last bit
          zero, and SAVEC is odd. Thus adding B/2 to A should not  change
          A, but adding B/2 to SAVEC should change SAVEC.
*/

        d__1 = b / 2;
        t1 = dlamc3_(&d__1, &a);
        d__1 = b / 2;
        t2 = dlamc3_(&d__1, &savec);
        lieee1 = t1 == a && t2 > savec && lrnd;

/*        Now find  the  mantissa, t.  It should  be the  integer part of
          log to the base beta of a,  however it is safer to determine t
          by powering.  So we find t as the smallest positive integer for
          which

             fl( beta**t + 1.0 ) = 1.0.
*/

        lt = 0;
        a = c = one;

        while (c == one) {
            ++lt;
            a *= lbeta;
            c = dlamc3_(&a, &one);
            c = dlamc33_(&c, &a);
        }
    }

    *beta = lbeta;
    *t = lt;
    *rnd = lrnd;
    *ieee1 = lieee1;
} /* dlamc1_ */

/* Subroutine */ void dlamc2_(integer *beta, integer *t, logical *rnd,
                              doublereal *eps, integer *emin, doublereal *rmin,
                              integer *emax, doublereal *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) 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.

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

    /* Initialized data */
    static logical first = TRUE_;
    static logical iwarn = FALSE_;
    /* System generated locals */
    integer i__1;
    doublereal d__1, d__2;
    /* Local variables */
    static logical ieee;
    static doublereal half = 0.5;
    static logical lrnd;
    static doublereal leps, zero = 0., a, b, c;
    static integer i, lbeta;
    static doublereal rbase;
    static integer lemin, lemax, gnmin;
    static doublereal small;
    static integer gpmin;
    static doublereal third, lrmin, lrmax, sixth;
    static logical lieee1;
    static integer lt, ngnmin, ngpmin;
    static doublereal one = 1.;

    if (first) {
        first = FALSE_;

/*        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);