190 lines
5.1 KiB
FortranFixed
190 lines
5.1 KiB
FortranFixed
|
*> \brief \b DLAMCH
|
||
|
|
*
|
||
|
|
* =========== DOCUMENTATION ===========
|
||
|
|
*
|
||
|
|
* Online html documentation available at
|
||
|
|
* http://www.netlib.org/lapack/explore-html/
|
||
|
|
*
|
||
|
|
* Definition:
|
||
|
|
* ===========
|
||
|
|
*
|
||
|
|
* DOUBLE PRECISION FUNCTION DLAMCH( CMACH )
|
||
|
|
*
|
||
|
|
*
|
||
|
|
*> \par Purpose:
|
||
|
|
* =============
|
||
|
|
*>
|
||
|
|
*> \verbatim
|
||
|
|
*>
|
||
|
|
*> DLAMCH determines double precision machine parameters.
|
||
|
|
*> \endverbatim
|
||
|
|
*
|
||
|
|
* Arguments:
|
||
|
|
* ==========
|
||
|
|
*
|
||
|
|
*> \param[in] CMACH
|
||
|
|
*> \verbatim
|
||
|
|
*> 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)
|
||
|
|
*> \endverbatim
|
||
|
|
*
|
||
|
|
* Authors:
|
||
|
|
* ========
|
||
|
|
*
|
||
|
|
*> \author Univ. of Tennessee
|
||
|
|
*> \author Univ. of California Berkeley
|
||
|
|
*> \author Univ. of Colorado Denver
|
||
|
|
*> \author NAG Ltd.
|
||
|
|
*
|
||
|
|
*> \date November 2011
|
||
|
|
*
|
||
|
|
*> \ingroup auxOTHERauxiliary
|
||
|
|
*
|
||
|
|
* =====================================================================
|
||
|
|
DOUBLE PRECISION FUNCTION DLAMCH( CMACH )
|
||
|
|
*
|
||
|
|
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||
|
|
* -- LAPACK is a software package provided by Univ. of Tennessee, --
|
||
|
|
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
|
||
|
|
* November 2011
|
||
|
|
*
|
||
|
|
* .. Scalar Arguments ..
|
||
|
|
CHARACTER CMACH
|
||
|
|
* ..
|
||
|
|
*
|
||
|
|
* =====================================================================
|
||
|
|
*
|
||
|
|
* .. Parameters ..
|
||
|
|
DOUBLE PRECISION ONE, ZERO
|
||
|
|
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
|
||
|
|
* ..
|
||
|
|
* .. Local Scalars ..
|
||
|
|
DOUBLE PRECISION RND, EPS, SFMIN, SMALL, RMACH
|
||
|
|
* ..
|
||
|
|
* .. External Functions ..
|
||
|
|
LOGICAL LSAME
|
||
|
|
EXTERNAL LSAME
|
||
|
|
* ..
|
||
|
|
* .. Intrinsic Functions ..
|
||
|
|
INTRINSIC DIGITS, EPSILON, HUGE, MAXEXPONENT,
|
||
|
|
$ MINEXPONENT, RADIX, TINY
|
||
|
|
* ..
|
||
|
|
* .. Executable Statements ..
|
||
|
|
*
|
||
|
|
*
|
||
|
|
* Assume rounding, not chopping. Always.
|
||
|
|
*
|
||
|
|
RND = ONE
|
||
|
|
*
|
||
|
|
IF( ONE.EQ.RND ) THEN
|
||
|
|
EPS = EPSILON(ZERO) * 0.5
|
||
|
|
ELSE
|
||
|
|
EPS = EPSILON(ZERO)
|
||
|
|
END IF
|
||
|
|
*
|
||
|
|
IF( LSAME( CMACH, 'E' ) ) THEN
|
||
|
|
RMACH = EPS
|
||
|
|
ELSE IF( LSAME( CMACH, 'S' ) ) THEN
|
||
|
|
SFMIN = TINY(ZERO)
|
||
|
|
SMALL = ONE / HUGE(ZERO)
|
||
|
|
IF( SMALL.GE.SFMIN ) THEN
|
||
|
|
*
|
||
|
|
* Use SMALL plus a bit, to avoid the possibility of rounding
|
||
|
|
* causing overflow when computing 1/sfmin.
|
||
|
|
*
|
||
|
|
SFMIN = SMALL*( ONE+EPS )
|
||
|
|
END IF
|
||
|
|
RMACH = SFMIN
|
||
|
|
ELSE IF( LSAME( CMACH, 'B' ) ) THEN
|
||
|
|
RMACH = RADIX(ZERO)
|
||
|
|
ELSE IF( LSAME( CMACH, 'P' ) ) THEN
|
||
|
|
RMACH = EPS * RADIX(ZERO)
|
||
|
|
ELSE IF( LSAME( CMACH, 'N' ) ) THEN
|
||
|
|
RMACH = DIGITS(ZERO)
|
||
|
|
ELSE IF( LSAME( CMACH, 'R' ) ) THEN
|
||
|
|
RMACH = RND
|
||
|
|
ELSE IF( LSAME( CMACH, 'M' ) ) THEN
|
||
|
|
RMACH = MINEXPONENT(ZERO)
|
||
|
|
ELSE IF( LSAME( CMACH, 'U' ) ) THEN
|
||
|
|
RMACH = tiny(zero)
|
||
|
|
ELSE IF( LSAME( CMACH, 'L' ) ) THEN
|
||
|
|
RMACH = MAXEXPONENT(ZERO)
|
||
|
|
ELSE IF( LSAME( CMACH, 'O' ) ) THEN
|
||
|
|
RMACH = HUGE(ZERO)
|
||
|
|
ELSE
|
||
|
|
RMACH = ZERO
|
||
|
|
END IF
|
||
|
|
*
|
||
|
|
DLAMCH = RMACH
|
||
|
|
RETURN
|
||
|
|
*
|
||
|
|
* End of DLAMCH
|
||
|
|
*
|
||
|
|
END
|
||
|
|
************************************************************************
|
||
|
|
*> \brief \b DLAMC3
|
||
|
|
*> \details
|
||
|
|
*> \b Purpose:
|
||
|
|
*> \verbatim
|
||
|
|
*> DLAMC3 is intended to force A and B to be stored prior to doing
|
||
|
|
*> the addition of A and B , for use in situations where optimizers
|
||
|
|
*> might hold one of these in a register.
|
||
|
|
*> \endverbatim
|
||
|
|
*> \author LAPACK is a software package provided by Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..
|
||
|
|
*> \date November 2011
|
||
|
|
*> \ingroup auxOTHERauxiliary
|
||
|
|
*>
|
||
|
|
*> \param[in] A
|
||
|
|
*> \verbatim
|
||
|
|
*> A is a DOUBLE PRECISION
|
||
|
|
*> \endverbatim
|
||
|
|
*>
|
||
|
|
*> \param[in] B
|
||
|
|
*> \verbatim
|
||
|
|
*> B is a DOUBLE PRECISION
|
||
|
|
*> The values A and B.
|
||
|
|
*> \endverbatim
|
||
|
|
*>
|
||
|
|
DOUBLE PRECISION FUNCTION DLAMC3( A, B )
|
||
|
|
*
|
||
|
|
* -- LAPACK auxiliary routine (version 3.4.0) --
|
||
|
|
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
|
||
|
|
* November 2010
|
||
|
|
*
|
||
|
|
* .. Scalar Arguments ..
|
||
|
|
DOUBLE PRECISION A, B
|
||
|
|
* ..
|
||
|
|
* =====================================================================
|
||
|
|
*
|
||
|
|
* .. Executable Statements ..
|
||
|
|
*
|
||
|
|
DLAMC3 = A + B
|
||
|
|
*
|
||
|
|
RETURN
|
||
|
|
*
|
||
|
|
* End of DLAMC3
|
||
|
|
*
|
||
|
|
END
|
||
|
|
*
|
||
|
|
************************************************************************
|