zlabrd.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="ZLACGV.169"></a><a href="zlacgv.f.html#ZLACGV.1">ZLACGV</a>( I-1, Y( I, 1 ), LDY )
            CALL ZGEMV( <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="ZLACGV.172"></a><a href="zlacgv.f.html#ZLACGV.1">ZLACGV</a>( I-1, Y( I, 1 ), LDY )
            CALL ZGEMV( <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="ZLARFG.179"></a><a href="zlarfg.f.html#ZLARFG.1">ZLARFG</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 ZGEMV( <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 ZGEMV( <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 ZGEMV( <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 ZGEMV( <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 ZGEMV( <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 ZSCAL( 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="ZLACGV.205"></a><a href="zlacgv.f.html#ZLACGV.1">ZLACGV</a>( N-I, A( I, I+1 ), LDA )
               CALL <a name="ZLACGV.206"></a><a href="zlacgv.f.html#ZLACGV.1">ZLACGV</a>( I, A( I, 1 ), LDA )
               CALL ZGEMV( <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="ZLACGV.209"></a><a href="zlacgv.f.html#ZLACGV.1">ZLACGV</a>( I, A( I, 1 ), LDA )
               CALL <a name="ZLACGV.210"></a><a href="zlacgv.f.html#ZLACGV.1">ZLACGV</a>( I-1, X( I, 1 ), LDX )
               CALL ZGEMV( <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="ZLACGV.214"></a><a href="zlacgv.f.html#ZLACGV.1">ZLACGV</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="ZLARFG.219"></a><a href="zlarfg.f.html#ZLARFG.1">ZLARFG</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 ZGEMV( <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 ZGEMV( <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 ZGEMV( <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 ZGEMV( <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 ZGEMV( <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 ZSCAL( M-I, TAUP( I ), X( I+1, I ), 1 )
               CALL <a name="ZLACGV.238"></a><a href="zlacgv.f.html#ZLACGV.1">ZLACGV</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="ZLACGV.249"></a><a href="zlacgv.f.html#ZLACGV.1">ZLACGV</a>( N-I+1, A( I, I ), LDA )
            CALL <a name="ZLACGV.250"></a><a href="zlacgv.f.html#ZLACGV.1">ZLACGV</a>( I-1, A( I, 1 ), LDA )
            CALL ZGEMV( <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="ZLACGV.253"></a><a href="zlacgv.f.html#ZLACGV.1">ZLACGV</a>( I-1, A( I, 1 ), LDA )
            CALL <a name="ZLACGV.254"></a><a href="zlacgv.f.html#ZLACGV.1">ZLACGV</a>( I-1, X( I, 1 ), LDX )
            CALL ZGEMV( <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="ZLACGV.258"></a><a href="zlacgv.f.html#ZLACGV.1">ZLACGV</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="ZLARFG.263"></a><a href="zlarfg.f.html#ZLARFG.1">ZLARFG</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 ZGEMV( <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 ZGEMV( <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 ZGEMV( <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 ZGEMV( <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 ZGEMV( <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 ZSCAL( M-I, TAUP( I ), X( I+1, I ), 1 )
               CALL <a name="ZLACGV.283"></a><a href="zlacgv.f.html#ZLACGV.1">ZLACGV</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="ZLACGV.287"></a><a href="zlacgv.f.html#ZLACGV.1">ZLACGV</a>( I-1, Y( I, 1 ), LDY )
               CALL ZGEMV( <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="ZLACGV.290"></a><a href="zlacgv.f.html#ZLACGV.1">ZLACGV</a>( I-1, Y( I, 1 ), LDY )
               CALL ZGEMV( <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="ZLARFG.297"></a><a href="zlarfg.f.html#ZLARFG.1">ZLARFG</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 ZGEMV( <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 ZGEMV( <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 ZGEMV( <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 ZGEMV( <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 ZGEMV( <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 ZSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 )
            ELSE
               CALL <a name="ZLACGV.320"></a><a href="zlacgv.f.html#ZLACGV.1">ZLACGV</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="ZLABRD.326"></a><a href="zlabrd.f.html#ZLABRD.1">ZLABRD</a>
</span><span class="comment">*</span><span class="comment">
</span>      END

</pre>

 </body>
</html>
12

zlabrd.f.html - 源码说明

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

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

⌨️ 快捷键说明

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