LAPACK
3.5.0
LAPACK: Linear Algebra PACKage
Main Page
Data Types List
Files
File List
File Members
All
Classes
Files
Functions
Variables
Typedefs
Macros
dladiv.f
Go to the documentation of this file.
1
*> \brief \b DLADIV performs complex division in real arithmetic, avoiding unnecessary overflow.
2
*
3
* =========== DOCUMENTATION ===========
4
*
5
* Online html documentation available at
6
* http://www.netlib.org/lapack/explore-html/
7
*
8
*> \htmlonly
9
*> Download DLADIV + dependencies
10
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dladiv.f">
11
*> [TGZ]</a>
12
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dladiv.f">
13
*> [ZIP]</a>
14
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dladiv.f">
15
*> [TXT]</a>
16
*> \endhtmlonly
17
*
18
* Definition:
19
* ===========
20
*
21
* SUBROUTINE DLADIV( A, B, C, D, P, Q )
22
*
23
* .. Scalar Arguments ..
24
* DOUBLE PRECISION A, B, C, D, P, Q
25
* ..
26
*
27
*
28
*> \par Purpose:
29
* =============
30
*>
31
*> \verbatim
32
*>
33
*> DLADIV performs complex division in real arithmetic
34
*>
35
*> a + i*b
36
*> p + i*q = ---------
37
*> c + i*d
38
*>
39
*> The algorithm is due to Michael Baudin and Robert L. Smith
40
*> and can be found in the paper
41
*> "A Robust Complex Division in Scilab"
42
*> \endverbatim
43
*
44
* Arguments:
45
* ==========
46
*
47
*> \param[in] A
48
*> \verbatim
49
*> A is DOUBLE PRECISION
50
*> \endverbatim
51
*>
52
*> \param[in] B
53
*> \verbatim
54
*> B is DOUBLE PRECISION
55
*> \endverbatim
56
*>
57
*> \param[in] C
58
*> \verbatim
59
*> C is DOUBLE PRECISION
60
*> \endverbatim
61
*>
62
*> \param[in] D
63
*> \verbatim
64
*> D is DOUBLE PRECISION
65
*> The scalars a, b, c, and d in the above expression.
66
*> \endverbatim
67
*>
68
*> \param[out] P
69
*> \verbatim
70
*> P is DOUBLE PRECISION
71
*> \endverbatim
72
*>
73
*> \param[out] Q
74
*> \verbatim
75
*> Q is DOUBLE PRECISION
76
*> The scalars p and q in the above expression.
77
*> \endverbatim
78
*
79
* Authors:
80
* ========
81
*
82
*> \author Univ. of Tennessee
83
*> \author Univ. of California Berkeley
84
*> \author Univ. of Colorado Denver
85
*> \author NAG Ltd.
86
*
87
*> \date January 2013
88
*
89
*> \ingroup auxOTHERauxiliary
90
*
91
* =====================================================================
92
SUBROUTINE
dladiv
( A, B, C, D, P, Q )
93
*
94
* -- LAPACK auxiliary routine (version 3.5.0) --
95
* -- LAPACK is a software package provided by Univ. of Tennessee, --
96
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
97
* January 2013
98
*
99
* .. Scalar Arguments ..
100
DOUBLE PRECISION
a,
b
, c, d, p, q
101
* ..
102
*
103
* =====================================================================
104
*
105
* .. Parameters ..
106
DOUBLE PRECISION
bs
107
parameter( bs = 2.0d0 )
108
DOUBLE PRECISION
half
109
parameter( half = 0.5d0 )
110
DOUBLE PRECISION
two
111
parameter( two = 2.0d0 )
112
*
113
* .. Local Scalars ..
114
DOUBLE PRECISION
aa, bb, cc, dd, ab, cd, s, ov, un, be, eps
115
* ..
116
* .. External Functions ..
117
DOUBLE PRECISION
dlamch
118
EXTERNAL
dlamch
119
* ..
120
* .. External Subroutines ..
121
EXTERNAL
dladiv1
122
* ..
123
* .. Intrinsic Functions ..
124
INTRINSIC
abs, max
125
* ..
126
* .. Executable Statements ..
127
*
128
aa = a
129
bb =
b
130
cc = c
131
dd = d
132
ab = max( abs(a), abs(
b
) )
133
cd = max( abs(c), abs(d) )
134
s = 1.0d0
135
136
ov =
dlamch
(
'Overflow threshold'
)
137
un =
dlamch
(
'Safe minimum'
)
138
eps =
dlamch
(
'Epsilon'
)
139
be = bs / (eps*eps)
140
141
IF
( ab >= half*ov )
THEN
142
aa = half * aa
143
bb = half * bb
144
s = two * s
145
END IF
146
IF
( cd >= half*ov )
THEN
147
cc = half * cc
148
dd = half * dd
149
s = half * s
150
END IF
151
IF
( ab <= un*bs/eps )
THEN
152
aa = aa * be
153
bb = bb * be
154
s = s / be
155
END IF
156
IF
( cd <= un*bs/eps )
THEN
157
cc = cc * be
158
dd = dd * be
159
s = s * be
160
END IF
161
IF
( abs( d ).LE.abs( c ) )
THEN
162
CALL
dladiv1
(aa, bb, cc, dd, p, q)
163
ELSE
164
CALL
dladiv1
(bb, aa, dd, cc, p, q)
165
q = -q
166
END IF
167
p = p * s
168
q = q * s
169
*
170
RETURN
171
*
172
* End of DLADIV
173
*
174
END
175
176
177
178
SUBROUTINE
dladiv1
( A, B, C, D, P, Q )
179
*
180
* -- LAPACK auxiliary routine (version 3.5.0) --
181
* -- LAPACK is a software package provided by Univ. of Tennessee, --
182
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
183
* January 2013
184
*
185
* .. Scalar Arguments ..
186
DOUBLE PRECISION
a,
b
, c, d, p, q
187
* ..
188
*
189
* =====================================================================
190
*
191
* .. Parameters ..
192
DOUBLE PRECISION
one
193
parameter( one = 1.0d0 )
194
*
195
* .. Local Scalars ..
196
DOUBLE PRECISION
r, t
197
* ..
198
* .. External Functions ..
199
DOUBLE PRECISION
dladiv2
200
EXTERNAL
dladiv2
201
* ..
202
* .. Executable Statements ..
203
*
204
r = d / c
205
t = one / (c + d * r)
206
p =
dladiv2
(a,
b
, c, d, r, t)
207
a = -a
208
q =
dladiv2
(
b
, a, c, d, r, t)
209
*
210
RETURN
211
*
212
* End of DLADIV1
213
*
214
END
215
216
DOUBLE PRECISION
FUNCTION
dladiv2
( A, B, C, D, R, T )
217
*
218
* -- LAPACK auxiliary routine (version 3.5.0) --
219
* -- LAPACK is a software package provided by Univ. of Tennessee, --
220
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
221
* January 2013
222
*
223
* .. Scalar Arguments ..
224
DOUBLE PRECISION
a,
b
, c, d, r, t
225
* ..
226
*
227
* =====================================================================
228
*
229
* .. Parameters ..
230
DOUBLE PRECISION
zero
231
parameter( zero = 0.0d0 )
232
*
233
* .. Local Scalars ..
234
DOUBLE PRECISION
br
235
* ..
236
* .. Executable Statements ..
237
*
238
IF
( r.NE.zero )
THEN
239
br =
b
* r
240
if
( br.NE.zero )
THEN
241
dladiv2
= (a + br) * t
242
ELSE
243
dladiv2
= a * t + (
b
* t) * r
244
END IF
245
ELSE
246
dladiv2
= (a + d * (
b
/ c)) * t
247
END IF
248
*
249
RETURN
250
*
251
* End of DLADIV12
252
*
253
END
src
dladiv.f
Generated on Mon Dec 30 2013 16:09:49 for LAPACK by
1.8.1.2