|
2329
|
1 DOUBLE PRECISION FUNCTION DLAMCH( CMACH ) |
|
|
2 * |
|
7034
|
3 * -- LAPACK auxiliary routine (version 3.1) -- |
|
|
4 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. |
|
|
5 * November 2006 |
|
2329
|
6 * |
|
|
7 * .. Scalar Arguments .. |
|
|
8 CHARACTER CMACH |
|
|
9 * .. |
|
|
10 * |
|
|
11 * Purpose |
|
|
12 * ======= |
|
|
13 * |
|
|
14 * DLAMCH determines double precision machine parameters. |
|
|
15 * |
|
|
16 * Arguments |
|
|
17 * ========= |
|
|
18 * |
|
|
19 * CMACH (input) CHARACTER*1 |
|
|
20 * Specifies the value to be returned by DLAMCH: |
|
|
21 * = 'E' or 'e', DLAMCH := eps |
|
|
22 * = 'S' or 's , DLAMCH := sfmin |
|
|
23 * = 'B' or 'b', DLAMCH := base |
|
|
24 * = 'P' or 'p', DLAMCH := eps*base |
|
|
25 * = 'N' or 'n', DLAMCH := t |
|
|
26 * = 'R' or 'r', DLAMCH := rnd |
|
|
27 * = 'M' or 'm', DLAMCH := emin |
|
|
28 * = 'U' or 'u', DLAMCH := rmin |
|
|
29 * = 'L' or 'l', DLAMCH := emax |
|
|
30 * = 'O' or 'o', DLAMCH := rmax |
|
|
31 * |
|
|
32 * where |
|
|
33 * |
|
|
34 * eps = relative machine precision |
|
|
35 * sfmin = safe minimum, such that 1/sfmin does not overflow |
|
|
36 * base = base of the machine |
|
|
37 * prec = eps*base |
|
|
38 * t = number of (base) digits in the mantissa |
|
|
39 * rnd = 1.0 when rounding occurs in addition, 0.0 otherwise |
|
|
40 * emin = minimum exponent before (gradual) underflow |
|
|
41 * rmin = underflow threshold - base**(emin-1) |
|
|
42 * emax = largest exponent before overflow |
|
|
43 * rmax = overflow threshold - (base**emax)*(1-eps) |
|
|
44 * |
|
|
45 * ===================================================================== |
|
|
46 * |
|
|
47 * .. Parameters .. |
|
|
48 DOUBLE PRECISION ONE, ZERO |
|
|
49 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) |
|
|
50 * .. |
|
|
51 * .. Local Scalars .. |
|
|
52 LOGICAL FIRST, LRND |
|
|
53 INTEGER BETA, IMAX, IMIN, IT |
|
|
54 DOUBLE PRECISION BASE, EMAX, EMIN, EPS, PREC, RMACH, RMAX, RMIN, |
|
|
55 $ RND, SFMIN, SMALL, T |
|
|
56 * .. |
|
|
57 * .. External Functions .. |
|
|
58 LOGICAL LSAME |
|
|
59 EXTERNAL LSAME |
|
|
60 * .. |
|
|
61 * .. External Subroutines .. |
|
|
62 EXTERNAL DLAMC2 |
|
|
63 * .. |
|
|
64 * .. Save statement .. |
|
|
65 SAVE FIRST, EPS, SFMIN, BASE, T, RND, EMIN, RMIN, |
|
|
66 $ EMAX, RMAX, PREC |
|
|
67 * .. |
|
|
68 * .. Data statements .. |
|
|
69 DATA FIRST / .TRUE. / |
|
|
70 * .. |
|
|
71 * .. Executable Statements .. |
|
|
72 * |
|
|
73 IF( FIRST ) THEN |
|
|
74 CALL DLAMC2( BETA, IT, LRND, EPS, IMIN, RMIN, IMAX, RMAX ) |
|
|
75 BASE = BETA |
|
|
76 T = IT |
|
|
77 IF( LRND ) THEN |
|
|
78 RND = ONE |
|
|
79 EPS = ( BASE**( 1-IT ) ) / 2 |
|
|
80 ELSE |
|
|
81 RND = ZERO |
|
|
82 EPS = BASE**( 1-IT ) |
|
|
83 END IF |
|
|
84 PREC = EPS*BASE |
|
|
85 EMIN = IMIN |
|
|
86 EMAX = IMAX |
|
|
87 SFMIN = RMIN |
|
|
88 SMALL = ONE / RMAX |
|
|
89 IF( SMALL.GE.SFMIN ) THEN |
|
|
90 * |
|
|
91 * Use SMALL plus a bit, to avoid the possibility of rounding |
|
|
92 * causing overflow when computing 1/sfmin. |
|
|
93 * |
|
|
94 SFMIN = SMALL*( ONE+EPS ) |
|
|
95 END IF |
|
|
96 END IF |
|
|
97 * |
|
|
98 IF( LSAME( CMACH, 'E' ) ) THEN |
|
|
99 RMACH = EPS |
|
|
100 ELSE IF( LSAME( CMACH, 'S' ) ) THEN |
|
|
101 RMACH = SFMIN |
|
|
102 ELSE IF( LSAME( CMACH, 'B' ) ) THEN |
|
|
103 RMACH = BASE |
|
|
104 ELSE IF( LSAME( CMACH, 'P' ) ) THEN |
|
|
105 RMACH = PREC |
|
|
106 ELSE IF( LSAME( CMACH, 'N' ) ) THEN |
|
|
107 RMACH = T |
|
|
108 ELSE IF( LSAME( CMACH, 'R' ) ) THEN |
|
|
109 RMACH = RND |
|
|
110 ELSE IF( LSAME( CMACH, 'M' ) ) THEN |
|
|
111 RMACH = EMIN |
|
|
112 ELSE IF( LSAME( CMACH, 'U' ) ) THEN |
|
|
113 RMACH = RMIN |
|
|
114 ELSE IF( LSAME( CMACH, 'L' ) ) THEN |
|
|
115 RMACH = EMAX |
|
|
116 ELSE IF( LSAME( CMACH, 'O' ) ) THEN |
|
|
117 RMACH = RMAX |
|
|
118 END IF |
|
|
119 * |
|
|
120 DLAMCH = RMACH |
|
7034
|
121 FIRST = .FALSE. |
|
2329
|
122 RETURN |
|
|
123 * |
|
|
124 * End of DLAMCH |
|
|
125 * |
|
|
126 END |
