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 September 2012 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.4.2) -- 107* -- LAPACK is a software package provided by Univ. of Tennessee, -- 108* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 109* September 2012 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 EXTERNAL DLAMCH, DLAPY2 134* .. 135* .. Intrinsic Functions .. 136 INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, INT, LOG, 137 $ MAX, SQRT 138* .. 139* .. Statement Functions .. 140 DOUBLE PRECISION ABS1, ABSSQ 141* .. 142* .. Save statement .. 143* SAVE FIRST, SAFMX2, SAFMIN, SAFMN2 144* .. 145* .. Data statements .. 146* DATA FIRST / .TRUE. / 147* .. 148* .. Statement Function definitions .. 149 ABS1( FF ) = MAX( ABS( DBLE( FF ) ), ABS( DIMAG( FF ) ) ) 150 ABSSQ( FF ) = DBLE( FF )**2 + DIMAG( FF )**2 151* .. 152* .. Executable Statements .. 153* 154* IF( FIRST ) THEN 155 SAFMIN = DLAMCH( 'S' ) 156 EPS = DLAMCH( 'E' ) 157 SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) / 158 $ LOG( DLAMCH( 'B' ) ) / TWO ) 159 SAFMX2 = ONE / SAFMN2 160* FIRST = .FALSE. 161* END IF 162 SCALE = MAX( ABS1( F ), ABS1( G ) ) 163 FS = F 164 GS = G 165 COUNT = 0 166 IF( SCALE.GE.SAFMX2 ) THEN 167 10 CONTINUE 168 COUNT = COUNT + 1 169 FS = FS*SAFMN2 170 GS = GS*SAFMN2 171 SCALE = SCALE*SAFMN2 172 IF( SCALE.GE.SAFMX2 ) 173 $ GO TO 10 174 ELSE IF( SCALE.LE.SAFMN2 ) THEN 175 IF( G.EQ.CZERO ) THEN 176 CS = ONE 177 SN = CZERO 178 R = F 179 RETURN 180 END IF 181 20 CONTINUE 182 COUNT = COUNT - 1 183 FS = FS*SAFMX2 184 GS = GS*SAFMX2 185 SCALE = SCALE*SAFMX2 186 IF( SCALE.LE.SAFMN2 ) 187 $ GO TO 20 188 END IF 189 F2 = ABSSQ( FS ) 190 G2 = ABSSQ( GS ) 191 IF( F2.LE.MAX( G2, ONE )*SAFMIN ) THEN 192* 193* This is a rare case: F is very small. 194* 195 IF( F.EQ.CZERO ) THEN 196 CS = ZERO 197 R = DLAPY2( DBLE( G ), DIMAG( G ) ) 198* Do complex/real division explicitly with two real divisions 199 D = DLAPY2( DBLE( GS ), DIMAG( GS ) ) 200 SN = DCMPLX( DBLE( GS ) / D, -DIMAG( GS ) / D ) 201 RETURN 202 END IF 203 F2S = DLAPY2( DBLE( FS ), DIMAG( FS ) ) 204* G2 and G2S are accurate 205* G2 is at least SAFMIN, and G2S is at least SAFMN2 206 G2S = SQRT( G2 ) 207* Error in CS from underflow in F2S is at most 208* UNFL / SAFMN2 .lt. sqrt(UNFL*EPS) .lt. EPS 209* If MAX(G2,ONE)=G2, then F2 .lt. G2*SAFMIN, 210* and so CS .lt. sqrt(SAFMIN) 211* If MAX(G2,ONE)=ONE, then F2 .lt. SAFMIN 212* and so CS .lt. sqrt(SAFMIN)/SAFMN2 = sqrt(EPS) 213* Therefore, CS = F2S/G2S / sqrt( 1 + (F2S/G2S)**2 ) = F2S/G2S 214 CS = F2S / G2S 215* Make sure abs(FF) = 1 216* Do complex/real division explicitly with 2 real divisions 217 IF( ABS1( F ).GT.ONE ) THEN 218 D = DLAPY2( DBLE( F ), DIMAG( F ) ) 219 FF = DCMPLX( DBLE( F ) / D, DIMAG( F ) / D ) 220 ELSE 221 DR = SAFMX2*DBLE( F ) 222 DI = SAFMX2*DIMAG( F ) 223 D = DLAPY2( DR, DI ) 224 FF = DCMPLX( DR / D, DI / D ) 225 END IF 226 SN = FF*DCMPLX( DBLE( GS ) / G2S, -DIMAG( GS ) / G2S ) 227 R = CS*F + SN*G 228 ELSE 229* 230* This is the most common case. 231* Neither F2 nor F2/G2 are less than SAFMIN 232* F2S cannot overflow, and it is accurate 233* 234 F2S = SQRT( ONE+G2 / F2 ) 235* Do the F2S(real)*FS(complex) multiply with two real multiplies 236 R = DCMPLX( F2S*DBLE( FS ), F2S*DIMAG( FS ) ) 237 CS = ONE / F2S 238 D = F2 + G2 239* Do complex/real division explicitly with two real divisions 240 SN = DCMPLX( DBLE( R ) / D, DIMAG( R ) / D ) 241 SN = SN*DCONJG( GS ) 242 IF( COUNT.NE.0 ) THEN 243 IF( COUNT.GT.0 ) THEN 244 DO 30 I = 1, COUNT 245 R = R*SAFMX2 246 30 CONTINUE 247 ELSE 248 DO 40 I = 1, -COUNT 249 R = R*SAFMN2 250 40 CONTINUE 251 END IF 252 END IF 253 END IF 254 RETURN 255* 256* End of ZLARTG 257* 258 END 259c $Id$ 260