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