LAPACK 3.12.0 LAPACK: Linear Algebra PACKage
Searching...
No Matches
crotg.f90
Go to the documentation of this file.
1
2!
3! =========== DOCUMENTATION ===========
4!
5! Online html documentation available at
6! http://www.netlib.org/lapack/explore-html/
7!
9! =============
35!
36! Arguments:
37! ==========
38!
63!
64! Authors:
65! ========
66!
68!
70!
72!
74! =====================
86!
87! =====================================================================
88subroutine crotg( a, b, c, s )
89 integer, parameter :: wp = kind(1.e0)
90!
91! -- Reference BLAS level1 routine --
92! -- Reference BLAS is a software package provided by Univ. of Tennessee, --
93! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
94!
95! .. Constants ..
96 real(wp), parameter :: zero = 0.0_wp
97 real(wp), parameter :: one = 1.0_wp
98 complex(wp), parameter :: czero = 0.0_wp
99! ..
100! .. Scaling constants ..
101 real(wp), parameter :: safmin = real(radix(0._wp),wp)**max( &
102 minexponent(0._wp)-1, &
103 1-maxexponent(0._wp) &
104 )
105 real(wp), parameter :: safmax = real(radix(0._wp),wp)**max( &
106 1-minexponent(0._wp), &
107 maxexponent(0._wp)-1 &
108 )
109 real(wp), parameter :: rtmin = sqrt( safmin )
110! ..
111! .. Scalar Arguments ..
112 real(wp) :: c
113 complex(wp) :: a, b, s
114! ..
115! .. Local Scalars ..
116 real(wp) :: d, f1, f2, g1, g2, h2, u, v, w, rtmax
117 complex(wp) :: f, fs, g, gs, r, t
118! ..
119! .. Intrinsic Functions ..
120 intrinsic :: abs, aimag, conjg, max, min, real, sqrt
121! ..
122! .. Statement Functions ..
123 real(wp) :: ABSSQ
124! ..
125! .. Statement Function definitions ..
126 abssq( t ) = real( t )**2 + aimag( t )**2
127! ..
128! .. Executable Statements ..
129!
130 f = a
131 g = b
132 if( g == czero ) then
133 c = one
134 s = czero
135 r = f
136 else if( f == czero ) then
137 c = zero
138 if( real(g) == zero ) then
139 r = abs(aimag(g))
140 s = conjg( g ) / r
141 elseif( aimag(g) == zero ) then
142 r = abs(real(g))
143 s = conjg( g ) / r
144 else
145 g1 = max( abs(real(g)), abs(aimag(g)) )
146 rtmax = sqrt( safmax/2 )
147 if( g1 > rtmin .and. g1 < rtmax ) then
148!
149! Use unscaled algorithm
150!
151! The following two lines can be replaced by `d = abs( g )`.
152! This algorithm do not use the intrinsic complex abs.
153 g2 = abssq( g )
154 d = sqrt( g2 )
155 s = conjg( g ) / d
156 r = d
157 else
158!
159! Use scaled algorithm
160!
161 u = min( safmax, max( safmin, g1 ) )
162 gs = g / u
163! The following two lines can be replaced by `d = abs( gs )`.
164! This algorithm do not use the intrinsic complex abs.
165 g2 = abssq( gs )
166 d = sqrt( g2 )
167 s = conjg( gs ) / d
168 r = d*u
169 end if
170 end if
171 else
172 f1 = max( abs(real(f)), abs(aimag(f)) )
173 g1 = max( abs(real(g)), abs(aimag(g)) )
174 rtmax = sqrt( safmax/4 )
175 if( f1 > rtmin .and. f1 < rtmax .and. &
176 g1 > rtmin .and. g1 < rtmax ) then
177!
178! Use unscaled algorithm
179!
180 f2 = abssq( f )
181 g2 = abssq( g )
182 h2 = f2 + g2
183 ! safmin <= f2 <= h2 <= safmax
184 if( f2 >= h2 * safmin ) then
185 ! safmin <= f2/h2 <= 1, and h2/f2 is finite
186 c = sqrt( f2 / h2 )
187 r = f / c
188 rtmax = rtmax * 2
189 if( f2 > rtmin .and. h2 < rtmax ) then
190 ! safmin <= sqrt( f2*h2 ) <= safmax
191 s = conjg( g ) * ( f / sqrt( f2*h2 ) )
192 else
193 s = conjg( g ) * ( r / h2 )
194 end if
195 else
196 ! f2/h2 <= safmin may be subnormal, and h2/f2 may overflow.
197 ! Moreover,
198 ! safmin <= f2*f2 * safmax < f2 * h2 < h2*h2 * safmin <= safmax,
199 ! sqrt(safmin) <= sqrt(f2 * h2) <= sqrt(safmax).
200 ! Also,
201 ! g2 >> f2, which means that h2 = g2.
202 d = sqrt( f2 * h2 )
203 c = f2 / d
204 if( c >= safmin ) then
205 r = f / c
206 else
207 ! f2 / sqrt(f2 * h2) < safmin, then
208 ! sqrt(safmin) <= f2 * sqrt(safmax) <= h2 / sqrt(f2 * h2) <= h2 * (safmin / f2) <= h2 <= safmax
209 r = f * ( h2 / d )
210 end if
211 s = conjg( g ) * ( f / d )
212 end if
213 else
214!
215! Use scaled algorithm
216!
217 u = min( safmax, max( safmin, f1, g1 ) )
218 gs = g / u
219 g2 = abssq( gs )
220 if( f1 / u < rtmin ) then
221!
222! f is not well-scaled when scaled by g1.
223! Use a different scaling for f.
224!
225 v = min( safmax, max( safmin, f1 ) )
226 w = v / u
227 fs = f / v
228 f2 = abssq( fs )
229 h2 = f2*w**2 + g2
230 else
231!
232! Otherwise use the same scaling for f and g.
233!
234 w = one
235 fs = f / u
236 f2 = abssq( fs )
237 h2 = f2 + g2
238 end if
239 ! safmin <= f2 <= h2 <= safmax
240 if( f2 >= h2 * safmin ) then
241 ! safmin <= f2/h2 <= 1, and h2/f2 is finite
242 c = sqrt( f2 / h2 )
243 r = fs / c
244 rtmax = rtmax * 2
245 if( f2 > rtmin .and. h2 < rtmax ) then
246 ! safmin <= sqrt( f2*h2 ) <= safmax
247 s = conjg( gs ) * ( fs / sqrt( f2*h2 ) )
248 else
249 s = conjg( gs ) * ( r / h2 )
250 end if
251 else
252 ! f2/h2 <= safmin may be subnormal, and h2/f2 may overflow.
253 ! Moreover,
254 ! safmin <= f2*f2 * safmax < f2 * h2 < h2*h2 * safmin <= safmax,
255 ! sqrt(safmin) <= sqrt(f2 * h2) <= sqrt(safmax).
256 ! Also,
257 ! g2 >> f2, which means that h2 = g2.
258 d = sqrt( f2 * h2 )
259 c = f2 / d
260 if( c >= safmin ) then
261 r = fs / c
262 else
263 ! f2 / sqrt(f2 * h2) < safmin, then
264 ! sqrt(safmin) <= f2 * sqrt(safmax) <= h2 / sqrt(f2 * h2) <= h2 * (safmin / f2) <= h2 <= safmax
265 r = fs * ( h2 / d )
266 end if
267 s = conjg( gs ) * ( fs / d )
268 end if
269 ! Rescale c and r
270 c = c * w
271 r = r * u
272 end if
273 end if
274 a = r
275 return
276end subroutine
subroutine crotg(a, b, c, s)
CROTG generates a Givens rotation with real cosine and complex sine.
Definition crotg.f90:89