1 REAL FUNCTION SLAMCH( CMACH )
2 *
3 * -- LAPACK auxiliary routine (version 3.3.0) --
4 * -- LAPACK is a software package provided by Univ. of Tennessee, --
5 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
6 * Based on LAPACK DLAMCH but with Fortran 95 query functions
7 * See: http://www.cs.utk.edu/~luszczek/lapack/lamch.html
8 * and http://www.netlib.org/lapack-dev/lapack-coding/program-style.html#id2537289
9 * July 2010
10 *
11 * .. Scalar Arguments ..
12 CHARACTER CMACH
13 * ..
14 *
15 * Purpose
16 * =======
17 *
18 * SLAMCH determines single precision machine parameters.
19 *
20 * Arguments
21 * =========
22 *
23 * CMACH (input) CHARACTER*1
24 * Specifies the value to be returned by SLAMCH:
25 * = 'E' or 'e', SLAMCH := eps
26 * = 'S' or 's , SLAMCH := sfmin
27 * = 'B' or 'b', SLAMCH := base
28 * = 'P' or 'p', SLAMCH := eps*base
29 * = 'N' or 'n', SLAMCH := t
30 * = 'R' or 'r', SLAMCH := rnd
31 * = 'M' or 'm', SLAMCH := emin
32 * = 'U' or 'u', SLAMCH := rmin
33 * = 'L' or 'l', SLAMCH := emax
34 * = 'O' or 'o', SLAMCH := rmax
35 *
36 * where
37 *
38 * eps = relative machine precision
39 * sfmin = safe minimum, such that 1/sfmin does not overflow
40 * base = base of the machine
41 * prec = eps*base
42 * t = number of (base) digits in the mantissa
43 * rnd = 1.0 when rounding occurs in addition, 0.0 otherwise
44 * emin = minimum exponent before (gradual) underflow
45 * rmin = underflow threshold - base**(emin-1)
46 * emax = largest exponent before overflow
47 * rmax = overflow threshold - (base**emax)*(1-eps)
48 *
49 * =====================================================================
50 *
51 * .. Parameters ..
52 REAL ONE, ZERO
53 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
54 * ..
55 * .. Local Scalars ..
56 REAL RND, EPS, SFMIN, SMALL, RMACH
57 * ..
58 * .. External Functions ..
59 LOGICAL LSAME
60 EXTERNAL LSAME
61 * ..
62 * .. Intrinsic Functions ..
63 INTRINSIC DIGITS, EPSILON, HUGE, MAXEXPONENT,
64 $ MINEXPONENT, RADIX, TINY
65 * ..
66 * .. Executable Statements ..
67 *
68 *
69 * Assume rounding, not chopping. Always.
70 *
71 RND = ONE
72 *
73 IF( ONE.EQ.RND ) THEN
74 EPS = EPSILON(ZERO) * 0.5
75 ELSE
76 EPS = EPSILON(ZERO)
77 END IF
78 *
79 IF( LSAME( CMACH, 'E' ) ) THEN
80 RMACH = EPS
81 ELSE IF( LSAME( CMACH, 'S' ) ) THEN
82 SFMIN = TINY(ZERO)
83 SMALL = ONE / HUGE(ZERO)
84 IF( SMALL.GE.SFMIN ) THEN
85 *
86 * Use SMALL plus a bit, to avoid the possibility of rounding
87 * causing overflow when computing 1/sfmin.
88 *
89 SFMIN = SMALL*( ONE+EPS )
90 END IF
91 RMACH = SFMIN
92 ELSE IF( LSAME( CMACH, 'B' ) ) THEN
93 RMACH = RADIX(ZERO)
94 ELSE IF( LSAME( CMACH, 'P' ) ) THEN
95 RMACH = EPS * RADIX(ZERO)
96 ELSE IF( LSAME( CMACH, 'N' ) ) THEN
97 RMACH = DIGITS(ZERO)
98 ELSE IF( LSAME( CMACH, 'R' ) ) THEN
99 RMACH = RND
100 ELSE IF( LSAME( CMACH, 'M' ) ) THEN
101 RMACH = MINEXPONENT(ZERO)
102 ELSE IF( LSAME( CMACH, 'U' ) ) THEN
103 RMACH = tiny(zero)
104 ELSE IF( LSAME( CMACH, 'L' ) ) THEN
105 RMACH = MAXEXPONENT(ZERO)
106 ELSE IF( LSAME( CMACH, 'O' ) ) THEN
107 RMACH = HUGE(ZERO)
108 ELSE
109 RMACH = ZERO
110 END IF
111 *
112 SLAMCH = RMACH
113 RETURN
114 *
115 * End of SLAMCH
116 *
117 END
118 ************************************************************************
119 *
120 REAL FUNCTION SLAMC3( A, B )
121 *
122 * -- LAPACK auxiliary routine (version 3.3.0) --
123 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
124 * November 2010
125 *
126 * .. Scalar Arguments ..
127 REAL A, B
128 * ..
129 *
130 * Purpose
131 * =======
132 *
133 * SLAMC3 is intended to force A and B to be stored prior to doing
134 * the addition of A and B , for use in situations where optimizers
135 * might hold one of these in a register.
136 *
137 * Arguments
138 * =========
139 *
140 * A (input) REAL
141 * B (input) REAL
142 * The values A and B.
143 *
144 * =====================================================================
145 *
146 * .. Executable Statements ..
147 *
148 SLAMC3 = A + B
149 *
150 RETURN
151 *
152 * End of SLAMC3
153 *
154 END
155 *
156 ************************************************************************
2 *
3 * -- LAPACK auxiliary routine (version 3.3.0) --
4 * -- LAPACK is a software package provided by Univ. of Tennessee, --
5 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
6 * Based on LAPACK DLAMCH but with Fortran 95 query functions
7 * See: http://www.cs.utk.edu/~luszczek/lapack/lamch.html
8 * and http://www.netlib.org/lapack-dev/lapack-coding/program-style.html#id2537289
9 * July 2010
10 *
11 * .. Scalar Arguments ..
12 CHARACTER CMACH
13 * ..
14 *
15 * Purpose
16 * =======
17 *
18 * SLAMCH determines single precision machine parameters.
19 *
20 * Arguments
21 * =========
22 *
23 * CMACH (input) CHARACTER*1
24 * Specifies the value to be returned by SLAMCH:
25 * = 'E' or 'e', SLAMCH := eps
26 * = 'S' or 's , SLAMCH := sfmin
27 * = 'B' or 'b', SLAMCH := base
28 * = 'P' or 'p', SLAMCH := eps*base
29 * = 'N' or 'n', SLAMCH := t
30 * = 'R' or 'r', SLAMCH := rnd
31 * = 'M' or 'm', SLAMCH := emin
32 * = 'U' or 'u', SLAMCH := rmin
33 * = 'L' or 'l', SLAMCH := emax
34 * = 'O' or 'o', SLAMCH := rmax
35 *
36 * where
37 *
38 * eps = relative machine precision
39 * sfmin = safe minimum, such that 1/sfmin does not overflow
40 * base = base of the machine
41 * prec = eps*base
42 * t = number of (base) digits in the mantissa
43 * rnd = 1.0 when rounding occurs in addition, 0.0 otherwise
44 * emin = minimum exponent before (gradual) underflow
45 * rmin = underflow threshold - base**(emin-1)
46 * emax = largest exponent before overflow
47 * rmax = overflow threshold - (base**emax)*(1-eps)
48 *
49 * =====================================================================
50 *
51 * .. Parameters ..
52 REAL ONE, ZERO
53 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
54 * ..
55 * .. Local Scalars ..
56 REAL RND, EPS, SFMIN, SMALL, RMACH
57 * ..
58 * .. External Functions ..
59 LOGICAL LSAME
60 EXTERNAL LSAME
61 * ..
62 * .. Intrinsic Functions ..
63 INTRINSIC DIGITS, EPSILON, HUGE, MAXEXPONENT,
64 $ MINEXPONENT, RADIX, TINY
65 * ..
66 * .. Executable Statements ..
67 *
68 *
69 * Assume rounding, not chopping. Always.
70 *
71 RND = ONE
72 *
73 IF( ONE.EQ.RND ) THEN
74 EPS = EPSILON(ZERO) * 0.5
75 ELSE
76 EPS = EPSILON(ZERO)
77 END IF
78 *
79 IF( LSAME( CMACH, 'E' ) ) THEN
80 RMACH = EPS
81 ELSE IF( LSAME( CMACH, 'S' ) ) THEN
82 SFMIN = TINY(ZERO)
83 SMALL = ONE / HUGE(ZERO)
84 IF( SMALL.GE.SFMIN ) THEN
85 *
86 * Use SMALL plus a bit, to avoid the possibility of rounding
87 * causing overflow when computing 1/sfmin.
88 *
89 SFMIN = SMALL*( ONE+EPS )
90 END IF
91 RMACH = SFMIN
92 ELSE IF( LSAME( CMACH, 'B' ) ) THEN
93 RMACH = RADIX(ZERO)
94 ELSE IF( LSAME( CMACH, 'P' ) ) THEN
95 RMACH = EPS * RADIX(ZERO)
96 ELSE IF( LSAME( CMACH, 'N' ) ) THEN
97 RMACH = DIGITS(ZERO)
98 ELSE IF( LSAME( CMACH, 'R' ) ) THEN
99 RMACH = RND
100 ELSE IF( LSAME( CMACH, 'M' ) ) THEN
101 RMACH = MINEXPONENT(ZERO)
102 ELSE IF( LSAME( CMACH, 'U' ) ) THEN
103 RMACH = tiny(zero)
104 ELSE IF( LSAME( CMACH, 'L' ) ) THEN
105 RMACH = MAXEXPONENT(ZERO)
106 ELSE IF( LSAME( CMACH, 'O' ) ) THEN
107 RMACH = HUGE(ZERO)
108 ELSE
109 RMACH = ZERO
110 END IF
111 *
112 SLAMCH = RMACH
113 RETURN
114 *
115 * End of SLAMCH
116 *
117 END
118 ************************************************************************
119 *
120 REAL FUNCTION SLAMC3( A, B )
121 *
122 * -- LAPACK auxiliary routine (version 3.3.0) --
123 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
124 * November 2010
125 *
126 * .. Scalar Arguments ..
127 REAL A, B
128 * ..
129 *
130 * Purpose
131 * =======
132 *
133 * SLAMC3 is intended to force A and B to be stored prior to doing
134 * the addition of A and B , for use in situations where optimizers
135 * might hold one of these in a register.
136 *
137 * Arguments
138 * =========
139 *
140 * A (input) REAL
141 * B (input) REAL
142 * The values A and B.
143 *
144 * =====================================================================
145 *
146 * .. Executable Statements ..
147 *
148 SLAMC3 = A + B
149 *
150 RETURN
151 *
152 * End of SLAMC3
153 *
154 END
155 *
156 ************************************************************************