cgels.f.html

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

HTML
448 行
字号
123
</span>            CALL <a name="CUNMQR.282"></a><a href="cunmqr.f.html#CUNMQR.1">CUNMQR</a>( <span class="string">'Left'</span>, <span class="string">'Conjugate transpose'</span>, M, NRHS, N, A,
     $                   LDA, WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN,
     $                   INFO )
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">           workspace at least NRHS, optimally NRHS*NB
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">           B(1:N,1:NRHS) := inv(R) * B(1:N,1:NRHS)
</span><span class="comment">*</span><span class="comment">
</span>            CALL <a name="CTRTRS.290"></a><a href="ctrtrs.f.html#CTRTRS.1">CTRTRS</a>( <span class="string">'Upper'</span>, <span class="string">'No transpose'</span>, <span class="string">'Non-unit'</span>, N, NRHS,
     $                   A, LDA, B, LDB, INFO )
<span class="comment">*</span><span class="comment">
</span>            IF( INFO.GT.0 ) THEN
               RETURN
            END IF
<span class="comment">*</span><span class="comment">
</span>            SCLLEN = N
<span class="comment">*</span><span class="comment">
</span>         ELSE
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">           Overdetermined system of equations A' * X = B
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">           B(1:N,1:NRHS) := inv(R') * B(1:N,1:NRHS)
</span><span class="comment">*</span><span class="comment">
</span>            CALL <a name="CTRTRS.305"></a><a href="ctrtrs.f.html#CTRTRS.1">CTRTRS</a>( <span class="string">'Upper'</span>, <span class="string">'Conjugate transpose'</span>,<span class="string">'Non-unit'</span>,
     $                   N, NRHS, A, LDA, B, LDB, INFO )
<span class="comment">*</span><span class="comment">
</span>            IF( INFO.GT.0 ) THEN
               RETURN
            END IF
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">           B(N+1:M,1:NRHS) = ZERO
</span><span class="comment">*</span><span class="comment">
</span>            DO 20 J = 1, NRHS
               DO 10 I = N + 1, M
                  B( I, J ) = CZERO
   10          CONTINUE
   20       CONTINUE
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">           B(1:M,1:NRHS) := Q(1:N,:) * B(1:N,1:NRHS)
</span><span class="comment">*</span><span class="comment">
</span>            CALL <a name="CUNMQR.322"></a><a href="cunmqr.f.html#CUNMQR.1">CUNMQR</a>( <span class="string">'Left'</span>, <span class="string">'No transpose'</span>, M, NRHS, N, A, LDA,
     $                   WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN,
     $                   INFO )
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">           workspace at least NRHS, optimally NRHS*NB
</span><span class="comment">*</span><span class="comment">
</span>            SCLLEN = M
<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">        Compute LQ factorization of A
</span><span class="comment">*</span><span class="comment">
</span>         CALL <a name="CGELQF.336"></a><a href="cgelqf.f.html#CGELQF.1">CGELQF</a>( M, N, A, LDA, WORK( 1 ), WORK( MN+1 ), LWORK-MN,
     $                INFO )
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">        workspace at least M, optimally M*NB.
</span><span class="comment">*</span><span class="comment">
</span>         IF( .NOT.TPSD ) THEN
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">           underdetermined system of equations A * X = B
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">           B(1:M,1:NRHS) := inv(L) * B(1:M,1:NRHS)
</span><span class="comment">*</span><span class="comment">
</span>            CALL <a name="CTRTRS.347"></a><a href="ctrtrs.f.html#CTRTRS.1">CTRTRS</a>( <span class="string">'Lower'</span>, <span class="string">'No transpose'</span>, <span class="string">'Non-unit'</span>, M, NRHS,
     $                   A, LDA, B, LDB, INFO )
<span class="comment">*</span><span class="comment">
</span>            IF( INFO.GT.0 ) THEN
               RETURN
            END IF
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">           B(M+1:N,1:NRHS) = 0
</span><span class="comment">*</span><span class="comment">
</span>            DO 40 J = 1, NRHS
               DO 30 I = M + 1, N
                  B( I, J ) = CZERO
   30          CONTINUE
   40       CONTINUE
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">           B(1:N,1:NRHS) := Q(1:N,:)' * B(1:M,1:NRHS)
</span><span class="comment">*</span><span class="comment">
</span>            CALL <a name="CUNMLQ.364"></a><a href="cunmlq.f.html#CUNMLQ.1">CUNMLQ</a>( <span class="string">'Left'</span>, <span class="string">'Conjugate transpose'</span>, N, NRHS, M, A,
     $                   LDA, WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN,
     $                   INFO )
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">           workspace at least NRHS, optimally NRHS*NB
</span><span class="comment">*</span><span class="comment">
</span>            SCLLEN = N
<span class="comment">*</span><span class="comment">
</span>         ELSE
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">           overdetermined system min || A' * X - B ||
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">           B(1:N,1:NRHS) := Q * B(1:N,1:NRHS)
</span><span class="comment">*</span><span class="comment">
</span>            CALL <a name="CUNMLQ.378"></a><a href="cunmlq.f.html#CUNMLQ.1">CUNMLQ</a>( <span class="string">'Left'</span>, <span class="string">'No transpose'</span>, N, NRHS, M, A, LDA,
     $                   WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN,
     $                   INFO )
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">           workspace at least NRHS, optimally NRHS*NB
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">           B(1:M,1:NRHS) := inv(L') * B(1:M,1:NRHS)
</span><span class="comment">*</span><span class="comment">
</span>            CALL <a name="CTRTRS.386"></a><a href="ctrtrs.f.html#CTRTRS.1">CTRTRS</a>( <span class="string">'Lower'</span>, <span class="string">'Conjugate transpose'</span>, <span class="string">'Non-unit'</span>,
     $                   M, NRHS, A, LDA, B, LDB, INFO )
<span class="comment">*</span><span class="comment">
</span>            IF( INFO.GT.0 ) THEN
               RETURN
            END IF
<span class="comment">*</span><span class="comment">
</span>            SCLLEN = M
<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><span class="comment">*</span><span class="comment">     Undo scaling
</span><span class="comment">*</span><span class="comment">
</span>      IF( IASCL.EQ.1 ) THEN
         CALL <a name="CLASCL.402"></a><a href="clascl.f.html#CLASCL.1">CLASCL</a>( <span class="string">'G'</span>, 0, 0, ANRM, SMLNUM, SCLLEN, NRHS, B, LDB,
     $                INFO )
      ELSE IF( IASCL.EQ.2 ) THEN
         CALL <a name="CLASCL.405"></a><a href="clascl.f.html#CLASCL.1">CLASCL</a>( <span class="string">'G'</span>, 0, 0, ANRM, BIGNUM, SCLLEN, NRHS, B, LDB,
     $                INFO )
      END IF
      IF( IBSCL.EQ.1 ) THEN
         CALL <a name="CLASCL.409"></a><a href="clascl.f.html#CLASCL.1">CLASCL</a>( <span class="string">'G'</span>, 0, 0, SMLNUM, BNRM, SCLLEN, NRHS, B, LDB,
     $                INFO )
      ELSE IF( IBSCL.EQ.2 ) THEN
         CALL <a name="CLASCL.412"></a><a href="clascl.f.html#CLASCL.1">CLASCL</a>( <span class="string">'G'</span>, 0, 0, BIGNUM, BNRM, SCLLEN, NRHS, B, LDB,
     $                INFO )
      END IF
<span class="comment">*</span><span class="comment">
</span>   50 CONTINUE
      WORK( 1 ) = REAL( WSIZE )
<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="CGELS.421"></a><a href="cgels.f.html#CGELS.1">CGELS</a>
</span><span class="comment">*</span><span class="comment">
</span>      END

</pre>

 </body>
</html>
123

cgels.f.html - 源码说明

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

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

⌨️ 快捷键说明

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