00001 DOUBLE PRECISION FUNCTION DLAMCH( CMACH ) 00002 * 00003 * -- LAPACK auxiliary routine (version 3.3.0) -- 00004 * -- LAPACK is a software package provided by Univ. of Tennessee, -- 00005 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00006 * Based on LAPACK DLAMCH but with Fortran 95 query functions 00007 * See: http://www.cs.utk.edu/~luszczek/lapack/lamch.html 00008 * and http://www.netlib.org/lapack-dev/lapack-coding/program-style.html#id2537289 00009 * July 2010 00010 * 00011 * .. Scalar Arguments .. 00012 CHARACTER CMACH 00013 * .. 00014 * 00015 * Purpose 00016 * ======= 00017 * 00018 * DLAMCH determines double precision machine parameters. 00019 * 00020 * Arguments 00021 * ========= 00022 * 00023 * CMACH (input) CHARACTER*1 00024 * Specifies the value to be returned by DLAMCH: 00025 * = 'E' or 'e', DLAMCH := eps 00026 * = 'S' or 's , DLAMCH := sfmin 00027 * = 'B' or 'b', DLAMCH := base 00028 * = 'P' or 'p', DLAMCH := eps*base 00029 * = 'N' or 'n', DLAMCH := t 00030 * = 'R' or 'r', DLAMCH := rnd 00031 * = 'M' or 'm', DLAMCH := emin 00032 * = 'U' or 'u', DLAMCH := rmin 00033 * = 'L' or 'l', DLAMCH := emax 00034 * = 'O' or 'o', DLAMCH := rmax 00035 * 00036 * where 00037 * 00038 * eps = relative machine precision 00039 * sfmin = safe minimum, such that 1/sfmin does not overflow 00040 * base = base of the machine 00041 * prec = eps*base 00042 * t = number of (base) digits in the mantissa 00043 * rnd = 1.0 when rounding occurs in addition, 0.0 otherwise 00044 * emin = minimum exponent before (gradual) underflow 00045 * rmin = underflow threshold - base**(emin-1) 00046 * emax = largest exponent before overflow 00047 * rmax = overflow threshold - (base**emax)*(1-eps) 00048 * 00049 * ===================================================================== 00050 * 00051 * .. Parameters .. 00052 DOUBLE PRECISION ONE, ZERO 00053 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) 00054 * .. 00055 * .. Local Scalars .. 00056 DOUBLE PRECISION RND, EPS, SFMIN, SMALL, RMACH 00057 * .. 00058 * .. External Functions .. 00059 LOGICAL LSAME 00060 EXTERNAL LSAME 00061 * .. 00062 * .. Intrinsic Functions .. 00063 INTRINSIC DIGITS, EPSILON, HUGE, MAXEXPONENT, 00064 $ MINEXPONENT, RADIX, TINY 00065 * .. 00066 * .. Executable Statements .. 00067 * 00068 * 00069 * Assume rounding, not chopping. Always. 00070 * 00071 RND = ONE 00072 * 00073 IF( ONE.EQ.RND ) THEN 00074 EPS = EPSILON(ZERO) * 0.5 00075 ELSE 00076 EPS = EPSILON(ZERO) 00077 END IF 00078 * 00079 IF( LSAME( CMACH, 'E' ) ) THEN 00080 RMACH = EPS 00081 ELSE IF( LSAME( CMACH, 'S' ) ) THEN 00082 SFMIN = TINY(ZERO) 00083 SMALL = ONE / HUGE(ZERO) 00084 IF( SMALL.GE.SFMIN ) THEN 00085 * 00086 * Use SMALL plus a bit, to avoid the possibility of rounding 00087 * causing overflow when computing 1/sfmin. 00088 * 00089 SFMIN = SMALL*( ONE+EPS ) 00090 END IF 00091 RMACH = SFMIN 00092 ELSE IF( LSAME( CMACH, 'B' ) ) THEN 00093 RMACH = RADIX(ZERO) 00094 ELSE IF( LSAME( CMACH, 'P' ) ) THEN 00095 RMACH = EPS * RADIX(ZERO) 00096 ELSE IF( LSAME( CMACH, 'N' ) ) THEN 00097 RMACH = DIGITS(ZERO) 00098 ELSE IF( LSAME( CMACH, 'R' ) ) THEN 00099 RMACH = RND 00100 ELSE IF( LSAME( CMACH, 'M' ) ) THEN 00101 RMACH = MINEXPONENT(ZERO) 00102 ELSE IF( LSAME( CMACH, 'U' ) ) THEN 00103 RMACH = tiny(zero) 00104 ELSE IF( LSAME( CMACH, 'L' ) ) THEN 00105 RMACH = MAXEXPONENT(ZERO) 00106 ELSE IF( LSAME( CMACH, 'O' ) ) THEN 00107 RMACH = HUGE(ZERO) 00108 ELSE 00109 RMACH = ZERO 00110 END IF 00111 * 00112 DLAMCH = RMACH 00113 RETURN 00114 * 00115 * End of DLAMCH 00116 * 00117 END 00118 ************************************************************************ 00119 * 00120 DOUBLE PRECISION FUNCTION DLAMC3( A, B ) 00121 * 00122 * -- LAPACK auxiliary routine (version 3.3.0) -- 00123 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. 00124 * November 2010 00125 * 00126 * .. Scalar Arguments .. 00127 DOUBLE PRECISION A, B 00128 * .. 00129 * 00130 * Purpose 00131 * ======= 00132 * 00133 * DLAMC3 is intended to force A and B to be stored prior to doing 00134 * the addition of A and B , for use in situations where optimizers 00135 * might hold one of these in a register. 00136 * 00137 * Arguments 00138 * ========= 00139 * 00140 * A (input) DOUBLE PRECISION 00141 * B (input) DOUBLE PRECISION 00142 * The values A and B. 00143 * 00144 * ===================================================================== 00145 * 00146 * .. Executable Statements .. 00147 * 00148 DLAMC3 = A + B 00149 * 00150 RETURN 00151 * 00152 * End of DLAMC3 00153 * 00154 END 00155 * 00156 ************************************************************************
1.7.2