LAPACK  3.10.1 LAPACK: Linear Algebra PACKage
clartg.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 !
8 ! Definition:
9 ! ===========
10 !
11 ! SUBROUTINE CLARTG( F, G, C, S, R )
12 !
13 ! .. Scalar Arguments ..
14 ! REAL(wp) C
15 ! COMPLEX(wp) F, G, R, S
16 ! ..
17 !
19 ! =============
57 !
58 ! Arguments:
59 ! ==========
60 !
90 !
91 ! Authors:
92 ! ========
93 !
95 !
97 !
99 !
101 ! ==================
104 !
106 ! =====================
116 !
117 subroutine clartg( f, g, c, s, r )
118  use la_constants, &
119  only: wp=>sp, zero=>szero, one=>sone, two=>stwo, czero, &
120  rtmin=>srtmin, rtmax=>srtmax, safmin=>ssafmin, safmax=>ssafmax
121 !
122 ! -- LAPACK auxiliary routine --
123 ! -- LAPACK is a software package provided by Univ. of Tennessee, --
124 ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
125 ! February 2021
126 !
127 ! .. Scalar Arguments ..
128  real(wp) c
129  complex(wp) f, g, r, s
130 ! ..
131 ! .. Local Scalars ..
132  real(wp) :: d, f1, f2, g1, g2, h2, p, u, uu, v, vv, w
133  complex(wp) :: fs, gs, t
134 ! ..
135 ! .. Intrinsic Functions ..
136  intrinsic :: abs, aimag, conjg, max, min, real, sqrt
137 ! ..
138 ! .. Statement Functions ..
139  real(wp) :: ABSSQ
140 ! ..
141 ! .. Statement Function definitions ..
142  abssq( t ) = real( t )**2 + aimag( t )**2
143 ! ..
144 ! .. Executable Statements ..
145 !
146  if( g == czero ) then
147  c = one
148  s = czero
149  r = f
150  else if( f == czero ) then
151  c = zero
152  g1 = max( abs(real(g)), abs(aimag(g)) )
153  if( g1 > rtmin .and. g1 < rtmax ) then
154 !
155 ! Use unscaled algorithm
156 !
157  g2 = abssq( g )
158  d = sqrt( g2 )
159  s = conjg( g ) / d
160  r = d
161  else
162 !
163 ! Use scaled algorithm
164 !
165  u = min( safmax, max( safmin, g1 ) )
166  uu = one / u
167  gs = g*uu
168  g2 = abssq( gs )
169  d = sqrt( g2 )
170  s = conjg( gs ) / d
171  r = d*u
172  end if
173  else
174  f1 = max( abs(real(f)), abs(aimag(f)) )
175  g1 = max( abs(real(g)), abs(aimag(g)) )
176  if( f1 > rtmin .and. f1 < rtmax .and. &
177  g1 > rtmin .and. g1 < rtmax ) then
178 !
179 ! Use unscaled algorithm
180 !
181  f2 = abssq( f )
182  g2 = abssq( g )
183  h2 = f2 + g2
184  if( f2 > rtmin .and. h2 < rtmax ) then
185  d = sqrt( f2*h2 )
186  else
187  d = sqrt( f2 )*sqrt( h2 )
188  end if
189  p = 1 / d
190  c = f2*p
191  s = conjg( g )*( f*p )
192  r = f*( h2*p )
193  else
194 !
195 ! Use scaled algorithm
196 !
197  u = min( safmax, max( safmin, f1, g1 ) )
198  uu = one / u
199  gs = g*uu
200  g2 = abssq( gs )
201  if( f1*uu < rtmin ) then
202 !
203 ! f is not well-scaled when scaled by g1.
204 ! Use a different scaling for f.
205 !
206  v = min( safmax, max( safmin, f1 ) )
207  vv = one / v
208  w = v * uu
209  fs = f*vv
210  f2 = abssq( fs )
211  h2 = f2*w**2 + g2
212  else
213 !
214 ! Otherwise use the same scaling for f and g.
215 !
216  w = one
217  fs = f*uu
218  f2 = abssq( fs )
219  h2 = f2 + g2
220  end if
221  if( f2 > rtmin .and. h2 < rtmax ) then
222  d = sqrt( f2*h2 )
223  else
224  d = sqrt( f2 )*sqrt( h2 )
225  end if
226  p = 1 / d
227  c = ( f2*p )*w
228  s = conjg( gs )*( fs*p )
229  r = ( fs*( h2*p ) )*u
230  end if
231  end if
232  return
233 end subroutine
subroutine clartg(f, g, c, s, r)
CLARTG generates a plane rotation with real cosine and complex sine.
Definition: clartg.f90:118
real(sp), parameter srtmax
real(sp), parameter sone
real(sp), parameter stwo
real(sp), parameter srtmin
complex(sp), parameter czero
integer, parameter sp
real(sp), parameter ssafmin
real(sp), parameter ssafmax
real(sp), parameter szero
LA_CONSTANTS is a module for the scaling constants for the compiled Fortran single and double precisi...