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