clabrd.f.html

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

HTML
353 行
字号
12
     $   RETURN
<span class="comment">*</span><span class="comment">
</span>      IF( M.GE.N ) THEN
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">        Reduce to upper bidiagonal form
</span><span class="comment">*</span><span class="comment">
</span>         DO 10 I = 1, NB
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">           Update A(i:m,i)
</span><span class="comment">*</span><span class="comment">
</span>            CALL <a name="CLACGV.169"></a><a href="clacgv.f.html#CLACGV.1">CLACGV</a>( I-1, Y( I, 1 ), LDY )
            CALL CGEMV( <span class="string">'No transpose'</span>, M-I+1, I-1, -ONE, A( I, 1 ),
     $                  LDA, Y( I, 1 ), LDY, ONE, A( I, I ), 1 )
            CALL <a name="CLACGV.172"></a><a href="clacgv.f.html#CLACGV.1">CLACGV</a>( I-1, Y( I, 1 ), LDY )
            CALL CGEMV( <span class="string">'No transpose'</span>, M-I+1, I-1, -ONE, X( I, 1 ),
     $                  LDX, A( 1, I ), 1, ONE, A( I, I ), 1 )
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">           Generate reflection Q(i) to annihilate A(i+1:m,i)
</span><span class="comment">*</span><span class="comment">
</span>            ALPHA = A( I, I )
            CALL <a name="CLARFG.179"></a><a href="clarfg.f.html#CLARFG.1">CLARFG</a>( M-I+1, ALPHA, A( MIN( I+1, M ), I ), 1,
     $                   TAUQ( I ) )
            D( I ) = ALPHA
            IF( I.LT.N ) THEN
               A( I, I ) = ONE
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">              Compute Y(i+1:n,i)
</span><span class="comment">*</span><span class="comment">
</span>               CALL CGEMV( <span class="string">'Conjugate transpose'</span>, M-I+1, N-I, ONE,
     $                     A( I, I+1 ), LDA, A( I, I ), 1, ZERO,
     $                     Y( I+1, I ), 1 )
               CALL CGEMV( <span class="string">'Conjugate transpose'</span>, M-I+1, I-1, ONE,
     $                     A( I, 1 ), LDA, A( I, I ), 1, ZERO,
     $                     Y( 1, I ), 1 )
               CALL CGEMV( <span class="string">'No transpose'</span>, N-I, I-1, -ONE, Y( I+1, 1 ),
     $                     LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 )
               CALL CGEMV( <span class="string">'Conjugate transpose'</span>, M-I+1, I-1, ONE,
     $                     X( I, 1 ), LDX, A( I, I ), 1, ZERO,
     $                     Y( 1, I ), 1 )
               CALL CGEMV( <span class="string">'Conjugate transpose'</span>, I-1, N-I, -ONE,
     $                     A( 1, I+1 ), LDA, Y( 1, I ), 1, ONE,
     $                     Y( I+1, I ), 1 )
               CALL CSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 )
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">              Update A(i,i+1:n)
</span><span class="comment">*</span><span class="comment">
</span>               CALL <a name="CLACGV.205"></a><a href="clacgv.f.html#CLACGV.1">CLACGV</a>( N-I, A( I, I+1 ), LDA )
               CALL <a name="CLACGV.206"></a><a href="clacgv.f.html#CLACGV.1">CLACGV</a>( I, A( I, 1 ), LDA )
               CALL CGEMV( <span class="string">'No transpose'</span>, N-I, I, -ONE, Y( I+1, 1 ),
     $                     LDY, A( I, 1 ), LDA, ONE, A( I, I+1 ), LDA )
               CALL <a name="CLACGV.209"></a><a href="clacgv.f.html#CLACGV.1">CLACGV</a>( I, A( I, 1 ), LDA )
               CALL <a name="CLACGV.210"></a><a href="clacgv.f.html#CLACGV.1">CLACGV</a>( I-1, X( I, 1 ), LDX )
               CALL CGEMV( <span class="string">'Conjugate transpose'</span>, I-1, N-I, -ONE,
     $                     A( 1, I+1 ), LDA, X( I, 1 ), LDX, ONE,
     $                     A( I, I+1 ), LDA )
               CALL <a name="CLACGV.214"></a><a href="clacgv.f.html#CLACGV.1">CLACGV</a>( I-1, X( I, 1 ), LDX )
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">              Generate reflection P(i) to annihilate A(i,i+2:n)
</span><span class="comment">*</span><span class="comment">
</span>               ALPHA = A( I, I+1 )
               CALL <a name="CLARFG.219"></a><a href="clarfg.f.html#CLARFG.1">CLARFG</a>( N-I, ALPHA, A( I, MIN( I+2, N ) ),
     $                      LDA, TAUP( I ) )
               E( I ) = ALPHA
               A( I, I+1 ) = ONE
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">              Compute X(i+1:m,i)
</span><span class="comment">*</span><span class="comment">
</span>               CALL CGEMV( <span class="string">'No transpose'</span>, M-I, N-I, ONE, A( I+1, I+1 ),
     $                     LDA, A( I, I+1 ), LDA, ZERO, X( I+1, I ), 1 )
               CALL CGEMV( <span class="string">'Conjugate transpose'</span>, N-I, I, ONE,
     $                     Y( I+1, 1 ), LDY, A( I, I+1 ), LDA, ZERO,
     $                     X( 1, I ), 1 )
               CALL CGEMV( <span class="string">'No transpose'</span>, M-I, I, -ONE, A( I+1, 1 ),
     $                     LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
               CALL CGEMV( <span class="string">'No transpose'</span>, I-1, N-I, ONE, A( 1, I+1 ),
     $                     LDA, A( I, I+1 ), LDA, ZERO, X( 1, I ), 1 )
               CALL CGEMV( <span class="string">'No transpose'</span>, M-I, I-1, -ONE, X( I+1, 1 ),
     $                     LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
               CALL CSCAL( M-I, TAUP( I ), X( I+1, I ), 1 )
               CALL <a name="CLACGV.238"></a><a href="clacgv.f.html#CLACGV.1">CLACGV</a>( N-I, A( I, I+1 ), LDA )
            END IF
   10    CONTINUE
      ELSE
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">        Reduce to lower bidiagonal form
</span><span class="comment">*</span><span class="comment">
</span>         DO 20 I = 1, NB
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">           Update A(i,i:n)
</span><span class="comment">*</span><span class="comment">
</span>            CALL <a name="CLACGV.249"></a><a href="clacgv.f.html#CLACGV.1">CLACGV</a>( N-I+1, A( I, I ), LDA )
            CALL <a name="CLACGV.250"></a><a href="clacgv.f.html#CLACGV.1">CLACGV</a>( I-1, A( I, 1 ), LDA )
            CALL CGEMV( <span class="string">'No transpose'</span>, N-I+1, I-1, -ONE, Y( I, 1 ),
     $                  LDY, A( I, 1 ), LDA, ONE, A( I, I ), LDA )
            CALL <a name="CLACGV.253"></a><a href="clacgv.f.html#CLACGV.1">CLACGV</a>( I-1, A( I, 1 ), LDA )
            CALL <a name="CLACGV.254"></a><a href="clacgv.f.html#CLACGV.1">CLACGV</a>( I-1, X( I, 1 ), LDX )
            CALL CGEMV( <span class="string">'Conjugate transpose'</span>, I-1, N-I+1, -ONE,
     $                  A( 1, I ), LDA, X( I, 1 ), LDX, ONE, A( I, I ),
     $                  LDA )
            CALL <a name="CLACGV.258"></a><a href="clacgv.f.html#CLACGV.1">CLACGV</a>( I-1, X( I, 1 ), LDX )
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">           Generate reflection P(i) to annihilate A(i,i+1:n)
</span><span class="comment">*</span><span class="comment">
</span>            ALPHA = A( I, I )
            CALL <a name="CLARFG.263"></a><a href="clarfg.f.html#CLARFG.1">CLARFG</a>( N-I+1, ALPHA, A( I, MIN( I+1, N ) ), LDA,
     $                   TAUP( I ) )
            D( I ) = ALPHA
            IF( I.LT.M ) THEN
               A( I, I ) = ONE
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">              Compute X(i+1:m,i)
</span><span class="comment">*</span><span class="comment">
</span>               CALL CGEMV( <span class="string">'No transpose'</span>, M-I, N-I+1, ONE, A( I+1, I ),
     $                     LDA, A( I, I ), LDA, ZERO, X( I+1, I ), 1 )
               CALL CGEMV( <span class="string">'Conjugate transpose'</span>, N-I+1, I-1, ONE,
     $                     Y( I, 1 ), LDY, A( I, I ), LDA, ZERO,
     $                     X( 1, I ), 1 )
               CALL CGEMV( <span class="string">'No transpose'</span>, M-I, I-1, -ONE, A( I+1, 1 ),
     $                     LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
               CALL CGEMV( <span class="string">'No transpose'</span>, I-1, N-I+1, ONE, A( 1, I ),
     $                     LDA, A( I, I ), LDA, ZERO, X( 1, I ), 1 )
               CALL CGEMV( <span class="string">'No transpose'</span>, M-I, I-1, -ONE, X( I+1, 1 ),
     $                     LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
               CALL CSCAL( M-I, TAUP( I ), X( I+1, I ), 1 )
               CALL <a name="CLACGV.283"></a><a href="clacgv.f.html#CLACGV.1">CLACGV</a>( N-I+1, A( I, I ), LDA )
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">              Update A(i+1:m,i)
</span><span class="comment">*</span><span class="comment">
</span>               CALL <a name="CLACGV.287"></a><a href="clacgv.f.html#CLACGV.1">CLACGV</a>( I-1, Y( I, 1 ), LDY )
               CALL CGEMV( <span class="string">'No transpose'</span>, M-I, I-1, -ONE, A( I+1, 1 ),
     $                     LDA, Y( I, 1 ), LDY, ONE, A( I+1, I ), 1 )
               CALL <a name="CLACGV.290"></a><a href="clacgv.f.html#CLACGV.1">CLACGV</a>( I-1, Y( I, 1 ), LDY )
               CALL CGEMV( <span class="string">'No transpose'</span>, M-I, I, -ONE, X( I+1, 1 ),
     $                     LDX, A( 1, I ), 1, ONE, A( I+1, I ), 1 )
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">              Generate reflection Q(i) to annihilate A(i+2:m,i)
</span><span class="comment">*</span><span class="comment">
</span>               ALPHA = A( I+1, I )
               CALL <a name="CLARFG.297"></a><a href="clarfg.f.html#CLARFG.1">CLARFG</a>( M-I, ALPHA, A( MIN( I+2, M ), I ), 1,
     $                      TAUQ( I ) )
               E( I ) = ALPHA
               A( I+1, I ) = ONE
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">              Compute Y(i+1:n,i)
</span><span class="comment">*</span><span class="comment">
</span>               CALL CGEMV( <span class="string">'Conjugate transpose'</span>, M-I, N-I, ONE,
     $                     A( I+1, I+1 ), LDA, A( I+1, I ), 1, ZERO,
     $                     Y( I+1, I ), 1 )
               CALL CGEMV( <span class="string">'Conjugate transpose'</span>, M-I, I-1, ONE,
     $                     A( I+1, 1 ), LDA, A( I+1, I ), 1, ZERO,
     $                     Y( 1, I ), 1 )
               CALL CGEMV( <span class="string">'No transpose'</span>, N-I, I-1, -ONE, Y( I+1, 1 ),
     $                     LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 )
               CALL CGEMV( <span class="string">'Conjugate transpose'</span>, M-I, I, ONE,
     $                     X( I+1, 1 ), LDX, A( I+1, I ), 1, ZERO,
     $                     Y( 1, I ), 1 )
               CALL CGEMV( <span class="string">'Conjugate transpose'</span>, I, N-I, -ONE,
     $                     A( 1, I+1 ), LDA, Y( 1, I ), 1, ONE,
     $                     Y( I+1, I ), 1 )
               CALL CSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 )
            ELSE
               CALL <a name="CLACGV.320"></a><a href="clacgv.f.html#CLACGV.1">CLACGV</a>( N-I+1, A( I, I ), LDA )
            END IF
   20    CONTINUE
      END IF
      RETURN
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">     End of <a name="CLABRD.326"></a><a href="clabrd.f.html#CLABRD.1">CLABRD</a>
</span><span class="comment">*</span><span class="comment">
</span>      END

</pre>

 </body>
</html>
12

clabrd.f.html - 源码说明

本页面展示了「famous linear algebra library (LAPACK) ports to windows」中的 clabrd.f.html 源码文件，采用 HTML 编程语言编写，共 353 行代码。您可以在线阅读完整代码内容，也可以返回资源详情页下载完整源码包进行本地学习和开发。

虫虫下载站收录了大量与algebra相关的技术资源，包括源代码、技术文档、电路图等，是电子工程师和嵌入式开发者的专业学习平台。

⌨️ 快捷键说明

复制代码Ctrl + C
搜索代码Ctrl + F
全屏模式F11
增大字号Ctrl + =
减小字号Ctrl + -
显示快捷键?