1: !> \brief \b DLARTG generates a plane rotation with real cosine and real sine.
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 DLARTG( F, G, C, S, R )
12: !
13: ! .. Scalar Arguments ..
14: ! REAL(wp) C, F, G, R, S
15: ! ..
16: !
17: !> \par Purpose:
18: ! =============
19: !>
20: !> \verbatim
21: !>
22: !> DLARTG generates a plane rotation so that
23: !>
24: !> [ C S ] . [ F ] = [ R ]
25: !> [ -S C ] [ G ] [ 0 ]
26: !>
27: !> where C**2 + S**2 = 1.
28: !>
29: !> The mathematical formulas used for C and S are
30: !> R = sign(F) * sqrt(F**2 + G**2)
31: !> C = F / R
32: !> S = G / R
33: !> Hence C >= 0. The algorithm used to compute these quantities
34: !> incorporates scaling to avoid overflow or underflow in computing the
35: !> square root of the sum of squares.
36: !>
37: !> This version is discontinuous in R at F = 0 but it returns the same
38: !> C and S as ZLARTG for complex inputs (F,0) and (G,0).
39: !>
40: !> This is a more accurate version of the BLAS1 routine DROTG,
41: !> with the following other differences:
42: !> F and G are unchanged on return.
43: !> If G=0, then C=1 and S=0.
44: !> If F=0 and (G .ne. 0), then C=0 and S=sign(1,G) without doing any
45: !> floating point operations (saves work in DBDSQR when
46: !> there are zeros on the diagonal).
47: !>
48: !> Below, wp=>dp stands for double precision from LA_CONSTANTS module.
49: !> \endverbatim
50: !
51: ! Arguments:
52: ! ==========
53: !
54: !> \param[in] F
55: !> \verbatim
56: !> F is REAL(wp)
57: !> The first component of vector to be rotated.
58: !> \endverbatim
59: !>
60: !> \param[in] G
61: !> \verbatim
62: !> G is REAL(wp)
63: !> The second component of vector to be rotated.
64: !> \endverbatim
65: !>
66: !> \param[out] C
67: !> \verbatim
68: !> C is REAL(wp)
69: !> The cosine of the rotation.
70: !> \endverbatim
71: !>
72: !> \param[out] S
73: !> \verbatim
74: !> S is REAL(wp)
75: !> The sine of the rotation.
76: !> \endverbatim
77: !>
78: !> \param[out] R
79: !> \verbatim
80: !> R is REAL(wp)
81: !> The nonzero component of the rotated vector.
82: !> \endverbatim
83: !
84: ! Authors:
85: ! ========
86: !
87: !> \author Edward Anderson, Lockheed Martin
88: !
89: !> \date July 2016
90: !
91: !> \ingroup OTHERauxiliary
92: !
93: !> \par Contributors:
94: ! ==================
95: !>
96: !> Weslley Pereira, University of Colorado Denver, USA
97: !
98: !> \par Further Details:
99: ! =====================
100: !>
101: !> \verbatim
102: !>
103: !> Anderson E. (2017)
104: !> Algorithm 978: Safe Scaling in the Level 1 BLAS
105: !> ACM Trans Math Softw 44:1--28
106: !> https://doi.org/10.1145/3061665
107: !>
108: !> \endverbatim
109: !
110: subroutine DLARTG( f, g, c, s, r )
111: use LA_CONSTANTS, &
112: only: wp=>dp, zero=>dzero, half=>dhalf, one=>done, &
113: safmin=>dsafmin, safmax=>dsafmax
114: !
115: ! -- LAPACK auxiliary routine --
116: ! -- LAPACK is a software package provided by Univ. of Tennessee, --
117: ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
118: ! February 2021
119: !
120: ! .. Scalar Arguments ..
121: real(wp) :: c, f, g, r, s
122: ! ..
123: ! .. Local Scalars ..
124: real(wp) :: d, f1, fs, g1, gs, u, rtmin, rtmax
125: ! ..
126: ! .. Intrinsic Functions ..
127: intrinsic :: abs, sign, sqrt
128: ! ..
129: ! .. Constants ..
130: rtmin = sqrt( safmin )
131: rtmax = sqrt( safmax/2 )
132: ! ..
133: ! .. Executable Statements ..
134: !
135: f1 = abs( f )
136: g1 = abs( g )
137: if( g == zero ) then
138: c = one
139: s = zero
140: r = f
141: else if( f == zero ) then
142: c = zero
143: s = sign( one, g )
144: r = g1
145: else if( f1 > rtmin .and. f1 < rtmax .and. &
146: g1 > rtmin .and. g1 < rtmax ) then
147: d = sqrt( f*f + g*g )
148: c = f1 / d
149: r = sign( d, f )
150: s = g / r
151: else
152: u = min( safmax, max( safmin, f1, g1 ) )
153: fs = f / u
154: gs = g / u
155: d = sqrt( fs*fs + gs*gs )
156: c = abs( fs ) / d
157: r = sign( d, f )
158: s = gs / r
159: r = r*u
160: end if
161: return
162: end subroutine
CVSweb interface <joel.bertrand@systella.fr>