![]() |
LAPACK
3.4.1
LAPACK: Linear Algebra PACKage
|
00001 *> \brief \b SLAGS2 00002 * 00003 * =========== DOCUMENTATION =========== 00004 * 00005 * Online html documentation available at 00006 * http://www.netlib.org/lapack/explore-html/ 00007 * 00008 *> \htmlonly 00009 *> Download SLAGS2 + dependencies 00010 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/slags2.f"> 00011 *> [TGZ]</a> 00012 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/slags2.f"> 00013 *> [ZIP]</a> 00014 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/slags2.f"> 00015 *> [TXT]</a> 00016 *> \endhtmlonly 00017 * 00018 * Definition: 00019 * =========== 00020 * 00021 * SUBROUTINE SLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU, CSV, 00022 * SNV, CSQ, SNQ ) 00023 * 00024 * .. Scalar Arguments .. 00025 * LOGICAL UPPER 00026 * REAL A1, A2, A3, B1, B2, B3, CSQ, CSU, CSV, SNQ, 00027 * $ SNU, SNV 00028 * .. 00029 * 00030 * 00031 *> \par Purpose: 00032 * ============= 00033 *> 00034 *> \verbatim 00035 *> 00036 *> SLAGS2 computes 2-by-2 orthogonal matrices U, V and Q, such 00037 *> that if ( UPPER ) then 00038 *> 00039 *> U**T *A*Q = U**T *( A1 A2 )*Q = ( x 0 ) 00040 *> ( 0 A3 ) ( x x ) 00041 *> and 00042 *> V**T*B*Q = V**T *( B1 B2 )*Q = ( x 0 ) 00043 *> ( 0 B3 ) ( x x ) 00044 *> 00045 *> or if ( .NOT.UPPER ) then 00046 *> 00047 *> U**T *A*Q = U**T *( A1 0 )*Q = ( x x ) 00048 *> ( A2 A3 ) ( 0 x ) 00049 *> and 00050 *> V**T*B*Q = V**T*( B1 0 )*Q = ( x x ) 00051 *> ( B2 B3 ) ( 0 x ) 00052 *> 00053 *> The rows of the transformed A and B are parallel, where 00054 *> 00055 *> U = ( CSU SNU ), V = ( CSV SNV ), Q = ( CSQ SNQ ) 00056 *> ( -SNU CSU ) ( -SNV CSV ) ( -SNQ CSQ ) 00057 *> 00058 *> Z**T denotes the transpose of Z. 00059 *> 00060 *> \endverbatim 00061 * 00062 * Arguments: 00063 * ========== 00064 * 00065 *> \param[in] UPPER 00066 *> \verbatim 00067 *> UPPER is LOGICAL 00068 *> = .TRUE.: the input matrices A and B are upper triangular. 00069 *> = .FALSE.: the input matrices A and B are lower triangular. 00070 *> \endverbatim 00071 *> 00072 *> \param[in] A1 00073 *> \verbatim 00074 *> A1 is REAL 00075 *> \endverbatim 00076 *> 00077 *> \param[in] A2 00078 *> \verbatim 00079 *> A2 is REAL 00080 *> \endverbatim 00081 *> 00082 *> \param[in] A3 00083 *> \verbatim 00084 *> A3 is REAL 00085 *> On entry, A1, A2 and A3 are elements of the input 2-by-2 00086 *> upper (lower) triangular matrix A. 00087 *> \endverbatim 00088 *> 00089 *> \param[in] B1 00090 *> \verbatim 00091 *> B1 is REAL 00092 *> \endverbatim 00093 *> 00094 *> \param[in] B2 00095 *> \verbatim 00096 *> B2 is REAL 00097 *> \endverbatim 00098 *> 00099 *> \param[in] B3 00100 *> \verbatim 00101 *> B3 is REAL 00102 *> On entry, B1, B2 and B3 are elements of the input 2-by-2 00103 *> upper (lower) triangular matrix B. 00104 *> \endverbatim 00105 *> 00106 *> \param[out] CSU 00107 *> \verbatim 00108 *> CSU is REAL 00109 *> \endverbatim 00110 *> 00111 *> \param[out] SNU 00112 *> \verbatim 00113 *> SNU is REAL 00114 *> The desired orthogonal matrix U. 00115 *> \endverbatim 00116 *> 00117 *> \param[out] CSV 00118 *> \verbatim 00119 *> CSV is REAL 00120 *> \endverbatim 00121 *> 00122 *> \param[out] SNV 00123 *> \verbatim 00124 *> SNV is REAL 00125 *> The desired orthogonal matrix V. 00126 *> \endverbatim 00127 *> 00128 *> \param[out] CSQ 00129 *> \verbatim 00130 *> CSQ is REAL 00131 *> \endverbatim 00132 *> 00133 *> \param[out] SNQ 00134 *> \verbatim 00135 *> SNQ is REAL 00136 *> The desired orthogonal matrix Q. 00137 *> \endverbatim 00138 * 00139 * Authors: 00140 * ======== 00141 * 00142 *> \author Univ. of Tennessee 00143 *> \author Univ. of California Berkeley 00144 *> \author Univ. of Colorado Denver 00145 *> \author NAG Ltd. 00146 * 00147 *> \date November 2011 00148 * 00149 *> \ingroup realOTHERauxiliary 00150 * 00151 * ===================================================================== 00152 SUBROUTINE SLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU, CSV, 00153 $ SNV, CSQ, SNQ ) 00154 * 00155 * -- LAPACK auxiliary routine (version 3.4.0) -- 00156 * -- LAPACK is a software package provided by Univ. of Tennessee, -- 00157 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00158 * November 2011 00159 * 00160 * .. Scalar Arguments .. 00161 LOGICAL UPPER 00162 REAL A1, A2, A3, B1, B2, B3, CSQ, CSU, CSV, SNQ, 00163 $ SNU, SNV 00164 * .. 00165 * 00166 * ===================================================================== 00167 * 00168 * .. Parameters .. 00169 REAL ZERO 00170 PARAMETER ( ZERO = 0.0E+0 ) 00171 * .. 00172 * .. Local Scalars .. 00173 REAL A, AUA11, AUA12, AUA21, AUA22, AVB11, AVB12, 00174 $ AVB21, AVB22, CSL, CSR, D, S1, S2, SNL, 00175 $ SNR, UA11R, UA22R, VB11R, VB22R, B, C, R, UA11, 00176 $ UA12, UA21, UA22, VB11, VB12, VB21, VB22 00177 * .. 00178 * .. External Subroutines .. 00179 EXTERNAL SLARTG, SLASV2 00180 * .. 00181 * .. Intrinsic Functions .. 00182 INTRINSIC ABS 00183 * .. 00184 * .. Executable Statements .. 00185 * 00186 IF( UPPER ) THEN 00187 * 00188 * Input matrices A and B are upper triangular matrices 00189 * 00190 * Form matrix C = A*adj(B) = ( a b ) 00191 * ( 0 d ) 00192 * 00193 A = A1*B3 00194 D = A3*B1 00195 B = A2*B1 - A1*B2 00196 * 00197 * The SVD of real 2-by-2 triangular C 00198 * 00199 * ( CSL -SNL )*( A B )*( CSR SNR ) = ( R 0 ) 00200 * ( SNL CSL ) ( 0 D ) ( -SNR CSR ) ( 0 T ) 00201 * 00202 CALL SLASV2( A, B, D, S1, S2, SNR, CSR, SNL, CSL ) 00203 * 00204 IF( ABS( CSL ).GE.ABS( SNL ) .OR. ABS( CSR ).GE.ABS( SNR ) ) 00205 $ THEN 00206 * 00207 * Compute the (1,1) and (1,2) elements of U**T *A and V**T *B, 00208 * and (1,2) element of |U|**T *|A| and |V|**T *|B|. 00209 * 00210 UA11R = CSL*A1 00211 UA12 = CSL*A2 + SNL*A3 00212 * 00213 VB11R = CSR*B1 00214 VB12 = CSR*B2 + SNR*B3 00215 * 00216 AUA12 = ABS( CSL )*ABS( A2 ) + ABS( SNL )*ABS( A3 ) 00217 AVB12 = ABS( CSR )*ABS( B2 ) + ABS( SNR )*ABS( B3 ) 00218 * 00219 * zero (1,2) elements of U**T *A and V**T *B 00220 * 00221 IF( ( ABS( UA11R )+ABS( UA12 ) ).NE.ZERO ) THEN 00222 IF( AUA12 / ( ABS( UA11R )+ABS( UA12 ) ).LE.AVB12 / 00223 $ ( ABS( VB11R )+ABS( VB12 ) ) ) THEN 00224 CALL SLARTG( -UA11R, UA12, CSQ, SNQ, R ) 00225 ELSE 00226 CALL SLARTG( -VB11R, VB12, CSQ, SNQ, R ) 00227 END IF 00228 ELSE 00229 CALL SLARTG( -VB11R, VB12, CSQ, SNQ, R ) 00230 END IF 00231 * 00232 CSU = CSL 00233 SNU = -SNL 00234 CSV = CSR 00235 SNV = -SNR 00236 * 00237 ELSE 00238 * 00239 * Compute the (2,1) and (2,2) elements of U**T *A and V**T *B, 00240 * and (2,2) element of |U|**T *|A| and |V|**T *|B|. 00241 * 00242 UA21 = -SNL*A1 00243 UA22 = -SNL*A2 + CSL*A3 00244 * 00245 VB21 = -SNR*B1 00246 VB22 = -SNR*B2 + CSR*B3 00247 * 00248 AUA22 = ABS( SNL )*ABS( A2 ) + ABS( CSL )*ABS( A3 ) 00249 AVB22 = ABS( SNR )*ABS( B2 ) + ABS( CSR )*ABS( B3 ) 00250 * 00251 * zero (2,2) elements of U**T*A and V**T*B, and then swap. 00252 * 00253 IF( ( ABS( UA21 )+ABS( UA22 ) ).NE.ZERO ) THEN 00254 IF( AUA22 / ( ABS( UA21 )+ABS( UA22 ) ).LE.AVB22 / 00255 $ ( ABS( VB21 )+ABS( VB22 ) ) ) THEN 00256 CALL SLARTG( -UA21, UA22, CSQ, SNQ, R ) 00257 ELSE 00258 CALL SLARTG( -VB21, VB22, CSQ, SNQ, R ) 00259 END IF 00260 ELSE 00261 CALL SLARTG( -VB21, VB22, CSQ, SNQ, R ) 00262 END IF 00263 * 00264 CSU = SNL 00265 SNU = CSL 00266 CSV = SNR 00267 SNV = CSR 00268 * 00269 END IF 00270 * 00271 ELSE 00272 * 00273 * Input matrices A and B are lower triangular matrices 00274 * 00275 * Form matrix C = A*adj(B) = ( a 0 ) 00276 * ( c d ) 00277 * 00278 A = A1*B3 00279 D = A3*B1 00280 C = A2*B3 - A3*B2 00281 * 00282 * The SVD of real 2-by-2 triangular C 00283 * 00284 * ( CSL -SNL )*( A 0 )*( CSR SNR ) = ( R 0 ) 00285 * ( SNL CSL ) ( C D ) ( -SNR CSR ) ( 0 T ) 00286 * 00287 CALL SLASV2( A, C, D, S1, S2, SNR, CSR, SNL, CSL ) 00288 * 00289 IF( ABS( CSR ).GE.ABS( SNR ) .OR. ABS( CSL ).GE.ABS( SNL ) ) 00290 $ THEN 00291 * 00292 * Compute the (2,1) and (2,2) elements of U**T *A and V**T *B, 00293 * and (2,1) element of |U|**T *|A| and |V|**T *|B|. 00294 * 00295 UA21 = -SNR*A1 + CSR*A2 00296 UA22R = CSR*A3 00297 * 00298 VB21 = -SNL*B1 + CSL*B2 00299 VB22R = CSL*B3 00300 * 00301 AUA21 = ABS( SNR )*ABS( A1 ) + ABS( CSR )*ABS( A2 ) 00302 AVB21 = ABS( SNL )*ABS( B1 ) + ABS( CSL )*ABS( B2 ) 00303 * 00304 * zero (2,1) elements of U**T *A and V**T *B. 00305 * 00306 IF( ( ABS( UA21 )+ABS( UA22R ) ).NE.ZERO ) THEN 00307 IF( AUA21 / ( ABS( UA21 )+ABS( UA22R ) ).LE.AVB21 / 00308 $ ( ABS( VB21 )+ABS( VB22R ) ) ) THEN 00309 CALL SLARTG( UA22R, UA21, CSQ, SNQ, R ) 00310 ELSE 00311 CALL SLARTG( VB22R, VB21, CSQ, SNQ, R ) 00312 END IF 00313 ELSE 00314 CALL SLARTG( VB22R, VB21, CSQ, SNQ, R ) 00315 END IF 00316 * 00317 CSU = CSR 00318 SNU = -SNR 00319 CSV = CSL 00320 SNV = -SNL 00321 * 00322 ELSE 00323 * 00324 * Compute the (1,1) and (1,2) elements of U**T *A and V**T *B, 00325 * and (1,1) element of |U|**T *|A| and |V|**T *|B|. 00326 * 00327 UA11 = CSR*A1 + SNR*A2 00328 UA12 = SNR*A3 00329 * 00330 VB11 = CSL*B1 + SNL*B2 00331 VB12 = SNL*B3 00332 * 00333 AUA11 = ABS( CSR )*ABS( A1 ) + ABS( SNR )*ABS( A2 ) 00334 AVB11 = ABS( CSL )*ABS( B1 ) + ABS( SNL )*ABS( B2 ) 00335 * 00336 * zero (1,1) elements of U**T*A and V**T*B, and then swap. 00337 * 00338 IF( ( ABS( UA11 )+ABS( UA12 ) ).NE.ZERO ) THEN 00339 IF( AUA11 / ( ABS( UA11 )+ABS( UA12 ) ).LE.AVB11 / 00340 $ ( ABS( VB11 )+ABS( VB12 ) ) ) THEN 00341 CALL SLARTG( UA12, UA11, CSQ, SNQ, R ) 00342 ELSE 00343 CALL SLARTG( VB12, VB11, CSQ, SNQ, R ) 00344 END IF 00345 ELSE 00346 CALL SLARTG( VB12, VB11, CSQ, SNQ, R ) 00347 END IF 00348 * 00349 CSU = SNR 00350 SNU = CSR 00351 CSV = SNL 00352 SNV = CSL 00353 * 00354 END IF 00355 * 00356 END IF 00357 * 00358 RETURN 00359 * 00360 * End of SLAGS2 00361 * 00362 END