![]() |
LAPACK
3.4.1
LAPACK: Linear Algebra PACKage
|
00001 *> \brief \b SLARTG 00002 * 00003 * =========== DOCUMENTATION =========== 00004 * 00005 * Online html documentation available at 00006 * http://www.netlib.org/lapack/explore-html/ 00007 * 00008 *> \htmlonly 00009 *> Download SLARTG + dependencies 00010 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/slartg.f"> 00011 *> [TGZ]</a> 00012 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/slartg.f"> 00013 *> [ZIP]</a> 00014 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/slartg.f"> 00015 *> [TXT]</a> 00016 *> \endhtmlonly 00017 * 00018 * Definition: 00019 * =========== 00020 * 00021 * SUBROUTINE SLARTG( F, G, CS, SN, R ) 00022 * 00023 * .. Scalar Arguments .. 00024 * REAL CS, F, G, R, SN 00025 * .. 00026 * 00027 * 00028 *> \par Purpose: 00029 * ============= 00030 *> 00031 *> \verbatim 00032 *> 00033 *> SLARTG generate a plane rotation so that 00034 *> 00035 *> [ CS SN ] . [ F ] = [ R ] where CS**2 + SN**2 = 1. 00036 *> [ -SN CS ] [ G ] [ 0 ] 00037 *> 00038 *> This is a slower, more accurate version of the BLAS1 routine SROTG, 00039 *> with the following other differences: 00040 *> F and G are unchanged on return. 00041 *> If G=0, then CS=1 and SN=0. 00042 *> If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any 00043 *> floating point operations (saves work in SBDSQR when 00044 *> there are zeros on the diagonal). 00045 *> 00046 *> If F exceeds G in magnitude, CS will be positive. 00047 *> \endverbatim 00048 * 00049 * Arguments: 00050 * ========== 00051 * 00052 *> \param[in] F 00053 *> \verbatim 00054 *> F is REAL 00055 *> The first component of vector to be rotated. 00056 *> \endverbatim 00057 *> 00058 *> \param[in] G 00059 *> \verbatim 00060 *> G is REAL 00061 *> The second component of vector to be rotated. 00062 *> \endverbatim 00063 *> 00064 *> \param[out] CS 00065 *> \verbatim 00066 *> CS is REAL 00067 *> The cosine of the rotation. 00068 *> \endverbatim 00069 *> 00070 *> \param[out] SN 00071 *> \verbatim 00072 *> SN is REAL 00073 *> The sine of the rotation. 00074 *> \endverbatim 00075 *> 00076 *> \param[out] R 00077 *> \verbatim 00078 *> R is REAL 00079 *> The nonzero component of the rotated vector. 00080 *> 00081 *> This version has a few statements commented out for thread safety 00082 *> (machine parameters are computed on each entry). 10 feb 03, SJH. 00083 *> \endverbatim 00084 * 00085 * Authors: 00086 * ======== 00087 * 00088 *> \author Univ. of Tennessee 00089 *> \author Univ. of California Berkeley 00090 *> \author Univ. of Colorado Denver 00091 *> \author NAG Ltd. 00092 * 00093 *> \date November 2011 00094 * 00095 *> \ingroup auxOTHERauxiliary 00096 * 00097 * ===================================================================== 00098 SUBROUTINE SLARTG( F, G, CS, SN, R ) 00099 * 00100 * -- LAPACK auxiliary routine (version 3.4.0) -- 00101 * -- LAPACK is a software package provided by Univ. of Tennessee, -- 00102 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00103 * November 2011 00104 * 00105 * .. Scalar Arguments .. 00106 REAL CS, F, G, R, SN 00107 * .. 00108 * 00109 * ===================================================================== 00110 * 00111 * .. Parameters .. 00112 REAL ZERO 00113 PARAMETER ( ZERO = 0.0E0 ) 00114 REAL ONE 00115 PARAMETER ( ONE = 1.0E0 ) 00116 REAL TWO 00117 PARAMETER ( TWO = 2.0E0 ) 00118 * .. 00119 * .. Local Scalars .. 00120 * LOGICAL FIRST 00121 INTEGER COUNT, I 00122 REAL EPS, F1, G1, SAFMIN, SAFMN2, SAFMX2, SCALE 00123 * .. 00124 * .. External Functions .. 00125 REAL SLAMCH 00126 EXTERNAL SLAMCH 00127 * .. 00128 * .. Intrinsic Functions .. 00129 INTRINSIC ABS, INT, LOG, MAX, SQRT 00130 * .. 00131 * .. Save statement .. 00132 * SAVE FIRST, SAFMX2, SAFMIN, SAFMN2 00133 * .. 00134 * .. Data statements .. 00135 * DATA FIRST / .TRUE. / 00136 * .. 00137 * .. Executable Statements .. 00138 * 00139 * IF( FIRST ) THEN 00140 SAFMIN = SLAMCH( 'S' ) 00141 EPS = SLAMCH( 'E' ) 00142 SAFMN2 = SLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) / 00143 $ LOG( SLAMCH( 'B' ) ) / TWO ) 00144 SAFMX2 = ONE / SAFMN2 00145 * FIRST = .FALSE. 00146 * END IF 00147 IF( G.EQ.ZERO ) THEN 00148 CS = ONE 00149 SN = ZERO 00150 R = F 00151 ELSE IF( F.EQ.ZERO ) THEN 00152 CS = ZERO 00153 SN = ONE 00154 R = G 00155 ELSE 00156 F1 = F 00157 G1 = G 00158 SCALE = MAX( ABS( F1 ), ABS( G1 ) ) 00159 IF( SCALE.GE.SAFMX2 ) THEN 00160 COUNT = 0 00161 10 CONTINUE 00162 COUNT = COUNT + 1 00163 F1 = F1*SAFMN2 00164 G1 = G1*SAFMN2 00165 SCALE = MAX( ABS( F1 ), ABS( G1 ) ) 00166 IF( SCALE.GE.SAFMX2 ) 00167 $ GO TO 10 00168 R = SQRT( F1**2+G1**2 ) 00169 CS = F1 / R 00170 SN = G1 / R 00171 DO 20 I = 1, COUNT 00172 R = R*SAFMX2 00173 20 CONTINUE 00174 ELSE IF( SCALE.LE.SAFMN2 ) THEN 00175 COUNT = 0 00176 30 CONTINUE 00177 COUNT = COUNT + 1 00178 F1 = F1*SAFMX2 00179 G1 = G1*SAFMX2 00180 SCALE = MAX( ABS( F1 ), ABS( G1 ) ) 00181 IF( SCALE.LE.SAFMN2 ) 00182 $ GO TO 30 00183 R = SQRT( F1**2+G1**2 ) 00184 CS = F1 / R 00185 SN = G1 / R 00186 DO 40 I = 1, COUNT 00187 R = R*SAFMN2 00188 40 CONTINUE 00189 ELSE 00190 R = SQRT( F1**2+G1**2 ) 00191 CS = F1 / R 00192 SN = G1 / R 00193 END IF 00194 IF( ABS( F ).GT.ABS( G ) .AND. CS.LT.ZERO ) THEN 00195 CS = -CS 00196 SN = -SN 00197 R = -R 00198 END IF 00199 END IF 00200 RETURN 00201 * 00202 * End of SLARTG 00203 * 00204 END