1*> \brief \b ZLARTG generates a plane rotation with real cosine and complex sine.
2*
3*  =========== DOCUMENTATION ===========
4*
5* Online html documentation available at
6*            http://www.netlib.org/lapack/explore-html/
7*
8*> \htmlonly
9*> Download ZLARTG + dependencies
10*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlartg.f">
11*> [TGZ]</a>
12*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlartg.f">
13*> [ZIP]</a>
14*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlartg.f">
15*> [TXT]</a>
16*> \endhtmlonly
17*
18*  Definition:
19*  ===========
20*
21*       SUBROUTINE ZLARTG( F, G, CS, SN, R )
22*
23*       .. Scalar Arguments ..
24*       DOUBLE PRECISION   CS
25*       COMPLEX*16         F, G, R, SN
26*       ..
27*
28*
29*> \par Purpose:
30*  =============
31*>
32*> \verbatim
33*>
34*> ZLARTG generates a plane rotation so that
35*>
36*>    [  CS  SN  ]     [ F ]     [ R ]
37*>    [  __      ]  .  [   ]  =  [   ]   where CS**2 + |SN|**2 = 1.
38*>    [ -SN  CS  ]     [ G ]     [ 0 ]
39*>
40*> This is a faster version of the BLAS1 routine ZROTG, except for
41*> the following differences:
42*>    F and G are unchanged on return.
43*>    If G=0, then CS=1 and SN=0.
44*>    If F=0, then CS=0 and SN is chosen so that R is real.
45*> \endverbatim
46*
47*  Arguments:
48*  ==========
49*
50*> \param[in] F
51*> \verbatim
52*>          F is COMPLEX*16
53*>          The first component of vector to be rotated.
54*> \endverbatim
55*>
56*> \param[in] G
57*> \verbatim
58*>          G is COMPLEX*16
59*>          The second component of vector to be rotated.
60*> \endverbatim
61*>
62*> \param[out] CS
63*> \verbatim
64*>          CS is DOUBLE PRECISION
65*>          The cosine of the rotation.
66*> \endverbatim
67*>
68*> \param[out] SN
69*> \verbatim
70*>          SN is COMPLEX*16
71*>          The sine of the rotation.
72*> \endverbatim
73*>
74*> \param[out] R
75*> \verbatim
76*>          R is COMPLEX*16
77*>          The nonzero component of the rotated vector.
78*> \endverbatim
79*
80*  Authors:
81*  ========
82*
83*> \author Univ. of Tennessee
84*> \author Univ. of California Berkeley
85*> \author Univ. of Colorado Denver
86*> \author NAG Ltd.
87*
88*> \date December 2016
89*
90*> \ingroup complex16OTHERauxiliary
91*
92*> \par Further Details:
93*  =====================
94*>
95*> \verbatim
96*>
97*>  3-5-96 - Modified with a new algorithm by W. Kahan and J. Demmel
98*>
99*>  This version has a few statements commented out for thread safety
100*>  (machine parameters are computed on each entry). 10 feb 03, SJH.
101*> \endverbatim
102*>
103*  =====================================================================
104      SUBROUTINE ZLARTG( F, G, CS, SN, R )
105*
106*  -- LAPACK auxiliary routine (version 3.7.0) --
107*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
108*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
109*     December 2016
110*
111*     .. Scalar Arguments ..
112      DOUBLE PRECISION   CS
113      COMPLEX*16         F, G, R, SN
114*     ..
115*
116*  =====================================================================
117*
118*     .. Parameters ..
119      DOUBLE PRECISION   TWO, ONE, ZERO
120      PARAMETER          ( TWO = 2.0D+0, ONE = 1.0D+0, ZERO = 0.0D+0 )
121      COMPLEX*16         CZERO
122      PARAMETER          ( CZERO = ( 0.0D+0, 0.0D+0 ) )
123*     ..
124*     .. Local Scalars ..
125*     LOGICAL            FIRST
126      INTEGER            COUNT, I
127      DOUBLE PRECISION   D, DI, DR, EPS, F2, F2S, G2, G2S, SAFMIN,
128     $                   SAFMN2, SAFMX2, SCALE
129      COMPLEX*16         FF, FS, GS
130*     ..
131*     .. External Functions ..
132      DOUBLE PRECISION   DLAMCH, DLAPY2
133      LOGICAL            DISNAN
134      EXTERNAL           DLAMCH, DLAPY2, DISNAN
135*     ..
136*     .. Intrinsic Functions ..
137      INTRINSIC          ABS, DBLE, DCMPLX, DCONJG, DIMAG, INT, LOG,
138     $                   MAX, SQRT
139*     ..
140*     .. Statement Functions ..
141      DOUBLE PRECISION   ABS1, ABSSQ
142*     ..
143*     .. Statement Function definitions ..
144      ABS1( FF ) = MAX( ABS( DBLE( FF ) ), ABS( DIMAG( FF ) ) )
145      ABSSQ( FF ) = DBLE( FF )**2 + DIMAG( FF )**2
146*     ..
147*     .. Executable Statements ..
148*
149      SAFMIN = DLAMCH( 'S' )
150      EPS = DLAMCH( 'E' )
151      SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) /
152     $         LOG( DLAMCH( 'B' ) ) / TWO )
153      SAFMX2 = ONE / SAFMN2
154      SCALE = MAX( ABS1( F ), ABS1( G ) )
155      FS = F
156      GS = G
157      COUNT = 0
158      IF( SCALE.GE.SAFMX2 ) THEN
159   10    CONTINUE
160         COUNT = COUNT + 1
161         FS = FS*SAFMN2
162         GS = GS*SAFMN2
163         SCALE = SCALE*SAFMN2
164         IF( SCALE.GE.SAFMX2 )
165     $      GO TO 10
166      ELSE IF( SCALE.LE.SAFMN2 ) THEN
167         IF( G.EQ.CZERO.OR.DISNAN( ABS( G ) ) ) THEN
168            CS = ONE
169            SN = CZERO
170            R = F
171            RETURN
172         END IF
173   20    CONTINUE
174         COUNT = COUNT - 1
175         FS = FS*SAFMX2
176         GS = GS*SAFMX2
177         SCALE = SCALE*SAFMX2
178         IF( SCALE.LE.SAFMN2 )
179     $      GO TO 20
180      END IF
181      F2 = ABSSQ( FS )
182      G2 = ABSSQ( GS )
183      IF( F2.LE.MAX( G2, ONE )*SAFMIN ) THEN
184*
185*        This is a rare case: F is very small.
186*
187         IF( F.EQ.CZERO ) THEN
188            CS = ZERO
189            R = DLAPY2( DBLE( G ), DIMAG( G ) )
190*           Do complex/real division explicitly with two real divisions
191            D = DLAPY2( DBLE( GS ), DIMAG( GS ) )
192            SN = DCMPLX( DBLE( GS ) / D, -DIMAG( GS ) / D )
193            RETURN
194         END IF
195         F2S = DLAPY2( DBLE( FS ), DIMAG( FS ) )
196*        G2 and G2S are accurate
197*        G2 is at least SAFMIN, and G2S is at least SAFMN2
198         G2S = SQRT( G2 )
199*        Error in CS from underflow in F2S is at most
200*        UNFL / SAFMN2 .lt. sqrt(UNFL*EPS) .lt. EPS
201*        If MAX(G2,ONE)=G2, then F2 .lt. G2*SAFMIN,
202*        and so CS .lt. sqrt(SAFMIN)
203*        If MAX(G2,ONE)=ONE, then F2 .lt. SAFMIN
204*        and so CS .lt. sqrt(SAFMIN)/SAFMN2 = sqrt(EPS)
205*        Therefore, CS = F2S/G2S / sqrt( 1 + (F2S/G2S)**2 ) = F2S/G2S
206         CS = F2S / G2S
207*        Make sure abs(FF) = 1
208*        Do complex/real division explicitly with 2 real divisions
209         IF( ABS1( F ).GT.ONE ) THEN
210            D = DLAPY2( DBLE( F ), DIMAG( F ) )
211            FF = DCMPLX( DBLE( F ) / D, DIMAG( F ) / D )
212         ELSE
213            DR = SAFMX2*DBLE( F )
214            DI = SAFMX2*DIMAG( F )
215            D = DLAPY2( DR, DI )
216            FF = DCMPLX( DR / D, DI / D )
217         END IF
218         SN = FF*DCMPLX( DBLE( GS ) / G2S, -DIMAG( GS ) / G2S )
219         R = CS*F + SN*G
220      ELSE
221*
222*        This is the most common case.
223*        Neither F2 nor F2/G2 are less than SAFMIN
224*        F2S cannot overflow, and it is accurate
225*
226         F2S = SQRT( ONE+G2 / F2 )
227*        Do the F2S(real)*FS(complex) multiply with two real multiplies
228         R = DCMPLX( F2S*DBLE( FS ), F2S*DIMAG( FS ) )
229         CS = ONE / F2S
230         D = F2 + G2
231*        Do complex/real division explicitly with two real divisions
232         SN = DCMPLX( DBLE( R ) / D, DIMAG( R ) / D )
233         SN = SN*DCONJG( GS )
234         IF( COUNT.NE.0 ) THEN
235            IF( COUNT.GT.0 ) THEN
236               DO 30 I = 1, COUNT
237                  R = R*SAFMX2
238   30          CONTINUE
239            ELSE
240               DO 40 I = 1, -COUNT
241                  R = R*SAFMN2
242   40          CONTINUE
243            END IF
244         END IF
245      END IF
246      RETURN
247*
248*     End of ZLARTG
249*
250      END
251