zlags2.f.html

来自「famous linear algebra library (LAPACK) p」· HTML 代码 · 共 331 行 · 第 1/2 页

</span><span class="comment">*</span><span class="comment">
</span>            IF( ( ABS( UA11R )+ABS1( UA12 ) ).EQ.ZERO ) THEN
               CALL <a name="ZLARTG.152"></a><a href="zlartg.f.html#ZLARTG.1">ZLARTG</a>( -DCMPLX( VB11R ), DCONJG( VB12 ), CSQ, SNQ,
     $                      R )
            ELSE IF( ( ABS( VB11R )+ABS1( VB12 ) ).EQ.ZERO ) THEN
               CALL <a name="ZLARTG.155"></a><a href="zlartg.f.html#ZLARTG.1">ZLARTG</a>( -DCMPLX( UA11R ), DCONJG( UA12 ), CSQ, SNQ,
     $                      R )
            ELSE IF( AUA12 / ( ABS( UA11R )+ABS1( UA12 ) ).LE.AVB12 /
     $               ( ABS( VB11R )+ABS1( VB12 ) ) ) THEN
               CALL <a name="ZLARTG.159"></a><a href="zlartg.f.html#ZLARTG.1">ZLARTG</a>( -DCMPLX( UA11R ), DCONJG( UA12 ), CSQ, SNQ,
     $                      R )
            ELSE
               CALL <a name="ZLARTG.162"></a><a href="zlartg.f.html#ZLARTG.1">ZLARTG</a>( -DCMPLX( VB11R ), DCONJG( VB12 ), CSQ, SNQ,
     $                      R )
            END IF
<span class="comment">*</span><span class="comment">
</span>            CSU = CSL
            SNU = -D1*SNL
            CSV = CSR
            SNV = -D1*SNR
<span class="comment">*</span><span class="comment">
</span>         ELSE
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">           Compute the (2,1) and (2,2) elements of U'*A and V'*B,
</span><span class="comment">*</span><span class="comment">           and (2,2) element of |U|'*|A| and |V|'*|B|.
</span><span class="comment">*</span><span class="comment">
</span>            UA21 = -DCONJG( D1 )*SNL*A1
            UA22 = -DCONJG( D1 )*SNL*A2 + CSL*A3
<span class="comment">*</span><span class="comment">
</span>            VB21 = -DCONJG( D1 )*SNR*B1
            VB22 = -DCONJG( D1 )*SNR*B2 + CSR*B3
<span class="comment">*</span><span class="comment">
</span>            AUA22 = ABS( SNL )*ABS1( A2 ) + ABS( CSL )*ABS( A3 )
            AVB22 = ABS( SNR )*ABS1( B2 ) + ABS( CSR )*ABS( B3 )
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">           zero (2,2) elements of U'*A and V'*B, and then swap.
</span><span class="comment">*</span><span class="comment">
</span>            IF( ( ABS1( UA21 )+ABS1( UA22 ) ).EQ.ZERO ) THEN
               CALL <a name="ZLARTG.188"></a><a href="zlartg.f.html#ZLARTG.1">ZLARTG</a>( -DCONJG( VB21 ), DCONJG( VB22 ), CSQ, SNQ,
     $                      R )
            ELSE IF( ( ABS1( VB21 )+ABS( VB22 ) ).EQ.ZERO ) THEN
               CALL <a name="ZLARTG.191"></a><a href="zlartg.f.html#ZLARTG.1">ZLARTG</a>( -DCONJG( UA21 ), DCONJG( UA22 ), CSQ, SNQ,
     $                      R )
            ELSE IF( AUA22 / ( ABS1( UA21 )+ABS1( UA22 ) ).LE.AVB22 /
     $               ( ABS1( VB21 )+ABS1( VB22 ) ) ) THEN
               CALL <a name="ZLARTG.195"></a><a href="zlartg.f.html#ZLARTG.1">ZLARTG</a>( -DCONJG( UA21 ), DCONJG( UA22 ), CSQ, SNQ,
     $                      R )
            ELSE
               CALL <a name="ZLARTG.198"></a><a href="zlartg.f.html#ZLARTG.1">ZLARTG</a>( -DCONJG( VB21 ), DCONJG( VB22 ), CSQ, SNQ,
     $                      R )
            END IF
<span class="comment">*</span><span class="comment">
</span>            CSU = SNL
            SNU = D1*CSL
            CSV = SNR
            SNV = D1*CSR
<span class="comment">*</span><span class="comment">
</span>         END IF
<span class="comment">*</span><span class="comment">
</span>      ELSE
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">        Input matrices A and B are lower triangular matrices
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">        Form matrix C = A*adj(B) = ( a 0 )
</span><span class="comment">*</span><span class="comment">                                   ( c d )
</span><span class="comment">*</span><span class="comment">
</span>         A = A1*B3
         D = A3*B1
         C = A2*B3 - A3*B2
         FC = ABS( C )
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">        Transform complex 2-by-2 matrix C to real matrix by unitary
</span><span class="comment">*</span><span class="comment">        diagonal matrix diag(d1,1).
</span><span class="comment">*</span><span class="comment">
</span>         D1 = ONE
         IF( FC.NE.ZERO )
     $      D1 = C / FC
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">        The SVD of real 2 by 2 triangular C
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">         ( CSL -SNL )*( A 0 )*(  CSR  SNR ) = ( R 0 )
</span><span class="comment">*</span><span class="comment">         ( SNL  CSL ) ( C D ) ( -SNR  CSR )   ( 0 T )
</span><span class="comment">*</span><span class="comment">
</span>         CALL <a name="DLASV2.233"></a><a href="dlasv2.f.html#DLASV2.1">DLASV2</a>( A, FC, D, S1, S2, SNR, CSR, SNL, CSL )
<span class="comment">*</span><span class="comment">
</span>         IF( ABS( CSR ).GE.ABS( SNR ) .OR. ABS( CSL ).GE.ABS( SNL ) )
     $        THEN
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">           Compute the (2,1) and (2,2) elements of U'*A and V'*B,
</span><span class="comment">*</span><span class="comment">           and (2,1) element of |U|'*|A| and |V|'*|B|.
</span><span class="comment">*</span><span class="comment">
</span>            UA21 = -D1*SNR*A1 + CSR*A2
            UA22R = CSR*A3
<span class="comment">*</span><span class="comment">
</span>            VB21 = -D1*SNL*B1 + CSL*B2
            VB22R = CSL*B3
<span class="comment">*</span><span class="comment">
</span>            AUA21 = ABS( SNR )*ABS( A1 ) + ABS( CSR )*ABS1( A2 )
            AVB21 = ABS( SNL )*ABS( B1 ) + ABS( CSL )*ABS1( B2 )
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">           zero (2,1) elements of U'*A and V'*B.
</span><span class="comment">*</span><span class="comment">
</span>            IF( ( ABS1( UA21 )+ABS( UA22R ) ).EQ.ZERO ) THEN
               CALL <a name="ZLARTG.253"></a><a href="zlartg.f.html#ZLARTG.1">ZLARTG</a>( DCMPLX( VB22R ), VB21, CSQ, SNQ, R )
            ELSE IF( ( ABS1( VB21 )+ABS( VB22R ) ).EQ.ZERO ) THEN
               CALL <a name="ZLARTG.255"></a><a href="zlartg.f.html#ZLARTG.1">ZLARTG</a>( DCMPLX( UA22R ), UA21, CSQ, SNQ, R )
            ELSE IF( AUA21 / ( ABS1( UA21 )+ABS( UA22R ) ).LE.AVB21 /
     $               ( ABS1( VB21 )+ABS( VB22R ) ) ) THEN
               CALL <a name="ZLARTG.258"></a><a href="zlartg.f.html#ZLARTG.1">ZLARTG</a>( DCMPLX( UA22R ), UA21, CSQ, SNQ, R )
            ELSE
               CALL <a name="ZLARTG.260"></a><a href="zlartg.f.html#ZLARTG.1">ZLARTG</a>( DCMPLX( VB22R ), VB21, CSQ, SNQ, R )
            END IF
<span class="comment">*</span><span class="comment">
</span>            CSU = CSR
            SNU = -DCONJG( D1 )*SNR
            CSV = CSL
            SNV = -DCONJG( D1 )*SNL
<span class="comment">*</span><span class="comment">
</span>         ELSE
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">           Compute the (1,1) and (1,2) elements of U'*A and V'*B,
</span><span class="comment">*</span><span class="comment">           and (1,1) element of |U|'*|A| and |V|'*|B|.
</span><span class="comment">*</span><span class="comment">
</span>            UA11 = CSR*A1 + DCONJG( D1 )*SNR*A2
            UA12 = DCONJG( D1 )*SNR*A3
<span class="comment">*</span><span class="comment">
</span>            VB11 = CSL*B1 + DCONJG( D1 )*SNL*B2
            VB12 = DCONJG( D1 )*SNL*B3
<span class="comment">*</span><span class="comment">
</span>            AUA11 = ABS( CSR )*ABS( A1 ) + ABS( SNR )*ABS1( A2 )
            AVB11 = ABS( CSL )*ABS( B1 ) + ABS( SNL )*ABS1( B2 )
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">           zero (1,1) elements of U'*A and V'*B, and then swap.
</span><span class="comment">*</span><span class="comment">
</span>            IF( ( ABS1( UA11 )+ABS1( UA12 ) ).EQ.ZERO ) THEN
               CALL <a name="ZLARTG.285"></a><a href="zlartg.f.html#ZLARTG.1">ZLARTG</a>( VB12, VB11, CSQ, SNQ, R )
            ELSE IF( ( ABS1( VB11 )+ABS1( VB12 ) ).EQ.ZERO ) THEN
               CALL <a name="ZLARTG.287"></a><a href="zlartg.f.html#ZLARTG.1">ZLARTG</a>( UA12, UA11, CSQ, SNQ, R )
            ELSE IF( AUA11 / ( ABS1( UA11 )+ABS1( UA12 ) ).LE.AVB11 /
     $               ( ABS1( VB11 )+ABS1( VB12 ) ) ) THEN
               CALL <a name="ZLARTG.290"></a><a href="zlartg.f.html#ZLARTG.1">ZLARTG</a>( UA12, UA11, CSQ, SNQ, R )
            ELSE
               CALL <a name="ZLARTG.292"></a><a href="zlartg.f.html#ZLARTG.1">ZLARTG</a>( VB12, VB11, CSQ, SNQ, R )
            END IF
<span class="comment">*</span><span class="comment">
</span>            CSU = SNR
            SNU = DCONJG( D1 )*CSR
            CSV = SNL
            SNV = DCONJG( D1 )*CSL
<span class="comment">*</span><span class="comment">
</span>         END IF
<span class="comment">*</span><span class="comment">
</span>      END IF
<span class="comment">*</span><span class="comment">
</span>      RETURN
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">     End of <a name="ZLAGS2.306"></a><a href="zlags2.f.html#ZLAGS2.1">ZLAGS2</a>
</span><span class="comment">*</span><span class="comment">
</span>      END

</pre>

 </body>
</html>