LAPACK  3.4.1
LAPACK: Linear Algebra PACKage
dlags2.f
Go to the documentation of this file.
00001 *> \brief \b DLAGS2
00002 *
00003 *  =========== DOCUMENTATION ===========
00004 *
00005 * Online html documentation available at 
00006 *            http://www.netlib.org/lapack/explore-html/ 
00007 *
00008 *> \htmlonly
00009 *> Download DLAGS2 + dependencies 
00010 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlags2.f"> 
00011 *> [TGZ]</a> 
00012 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlags2.f"> 
00013 *> [ZIP]</a> 
00014 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlags2.f"> 
00015 *> [TXT]</a>
00016 *> \endhtmlonly 
00017 *
00018 *  Definition:
00019 *  ===========
00020 *
00021 *       SUBROUTINE DLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU, CSV,
00022 *                          SNV, CSQ, SNQ )
00023 * 
00024 *       .. Scalar Arguments ..
00025 *       LOGICAL            UPPER
00026 *       DOUBLE PRECISION   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 *> DLAGS2 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 DOUBLE PRECISION
00075 *> \endverbatim
00076 *>
00077 *> \param[in] A2
00078 *> \verbatim
00079 *>          A2 is DOUBLE PRECISION
00080 *> \endverbatim
00081 *>
00082 *> \param[in] A3
00083 *> \verbatim
00084 *>          A3 is DOUBLE PRECISION
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 DOUBLE PRECISION
00092 *> \endverbatim
00093 *>
00094 *> \param[in] B2
00095 *> \verbatim
00096 *>          B2 is DOUBLE PRECISION
00097 *> \endverbatim
00098 *>
00099 *> \param[in] B3
00100 *> \verbatim
00101 *>          B3 is DOUBLE PRECISION
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 DOUBLE PRECISION
00109 *> \endverbatim
00110 *>
00111 *> \param[out] SNU
00112 *> \verbatim
00113 *>          SNU is DOUBLE PRECISION
00114 *>          The desired orthogonal matrix U.
00115 *> \endverbatim
00116 *>
00117 *> \param[out] CSV
00118 *> \verbatim
00119 *>          CSV is DOUBLE PRECISION
00120 *> \endverbatim
00121 *>
00122 *> \param[out] SNV
00123 *> \verbatim
00124 *>          SNV is DOUBLE PRECISION
00125 *>          The desired orthogonal matrix V.
00126 *> \endverbatim
00127 *>
00128 *> \param[out] CSQ
00129 *> \verbatim
00130 *>          CSQ is DOUBLE PRECISION
00131 *> \endverbatim
00132 *>
00133 *> \param[out] SNQ
00134 *> \verbatim
00135 *>          SNQ is DOUBLE PRECISION
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 doubleOTHERauxiliary
00150 *
00151 *  =====================================================================
00152       SUBROUTINE DLAGS2( 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       DOUBLE PRECISION   A1, A2, A3, B1, B2, B3, CSQ, CSU, CSV, SNQ,
00163      $                   SNU, SNV
00164 *     ..
00165 *
00166 *  =====================================================================
00167 *
00168 *     .. Parameters ..
00169       DOUBLE PRECISION   ZERO
00170       PARAMETER          ( ZERO = 0.0D+0 )
00171 *     ..
00172 *     .. Local Scalars ..
00173       DOUBLE PRECISION   A, AUA11, AUA12, AUA21, AUA22, AVB11, AVB12,
00174      $                   AVB21, AVB22, B, C, CSL, CSR, D, R, S1, S2,
00175      $                   SNL, SNR, UA11, UA11R, UA12, UA21, UA22, UA22R,
00176      $                   VB11, VB11R, VB12, VB21, VB22, VB22R
00177 *     ..
00178 *     .. External Subroutines ..
00179       EXTERNAL           DLARTG, DLASV2
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 DLASV2( 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 DLARTG( -UA11R, UA12, CSQ, SNQ, R )
00225                ELSE
00226                   CALL DLARTG( -VB11R, VB12, CSQ, SNQ, R )
00227                END IF
00228             ELSE
00229                CALL DLARTG( -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 DLARTG( -UA21, UA22, CSQ, SNQ, R )
00257                ELSE
00258                   CALL DLARTG( -VB21, VB22, CSQ, SNQ, R )
00259                END IF
00260             ELSE
00261                CALL DLARTG( -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 DLASV2( 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 DLARTG( UA22R, UA21, CSQ, SNQ, R )
00310                ELSE
00311                   CALL DLARTG( VB22R, VB21, CSQ, SNQ, R )
00312                END IF
00313             ELSE
00314                CALL DLARTG( 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 DLARTG( UA12, UA11, CSQ, SNQ, R )
00342                ELSE
00343                   CALL DLARTG( VB12, VB11, CSQ, SNQ, R )
00344                END IF
00345             ELSE
00346                CALL DLARTG( 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 DLAGS2
00361 *
00362       END
 All Files Functions