dgels.f.html

来自「famous linear algebra library (LAPACK) p」· HTML 代码 · 共 447 行 · 第 1/3 页
HTML
447 行
</span><span class="comment">*</span><span class="comment">
</span>            CALL <a name="DORMQR.281"></a><a href="dormqr.f.html#DORMQR.1">DORMQR</a>( <span class="string">'Left'</span>, <span class="string">'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="DTRTRS.289"></a><a href="dtrtrs.f.html#DTRTRS.1">DTRTRS</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="DTRTRS.304"></a><a href="dtrtrs.f.html#DTRTRS.1">DTRTRS</a>( <span class="string">'Upper'</span>, <span class="string">'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 ) = ZERO
   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="DORMQR.321"></a><a href="dormqr.f.html#DORMQR.1">DORMQR</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="DGELQF.335"></a><a href="dgelqf.f.html#DGELQF.1">DGELQF</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="DTRTRS.346"></a><a href="dtrtrs.f.html#DTRTRS.1">DTRTRS</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 ) = ZERO
   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="DORMLQ.363"></a><a href="dormlq.f.html#DORMLQ.1">DORMLQ</a>( <span class="string">'Left'</span>, <span class="string">'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="DORMLQ.377"></a><a href="dormlq.f.html#DORMLQ.1">DORMLQ</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="DTRTRS.385"></a><a href="dtrtrs.f.html#DTRTRS.1">DTRTRS</a>( <span class="string">'Lower'</span>, <span class="string">'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="DLASCL.401"></a><a href="dlascl.f.html#DLASCL.1">DLASCL</a>( <span class="string">'G'</span>, 0, 0, ANRM, SMLNUM, SCLLEN, NRHS, B, LDB,
     $                INFO )
      ELSE IF( IASCL.EQ.2 ) THEN
         CALL <a name="DLASCL.404"></a><a href="dlascl.f.html#DLASCL.1">DLASCL</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="DLASCL.408"></a><a href="dlascl.f.html#DLASCL.1">DLASCL</a>( <span class="string">'G'</span>, 0, 0, SMLNUM, BNRM, SCLLEN, NRHS, B, LDB,
     $                INFO )
      ELSE IF( IBSCL.EQ.2 ) THEN
         CALL <a name="DLASCL.411"></a><a href="dlascl.f.html#DLASCL.1">DLASCL</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 ) = DBLE( 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="DGELS.420"></a><a href="dgels.f.html#DGELS.1">DGELS</a>
</span><span class="comment">*</span><span class="comment">
</span>      END

</pre>

 </body>
</html>
dgels.f.html - 源码说明

本页面展示了「famous linear algebra library (LAPACK) ports to windows」中的 dgels.f.html 源码文件，采用 HTML 编程语言编写，共 447 行代码。您可以在线阅读完整代码内容，也可以返回资源详情页下载完整源码包进行本地学习和开发。
虫虫下载站收录了大量与algebra相关的技术资源，包括源代码、技术文档、电路图等，是电子工程师和嵌入式开发者的专业学习平台。
⌨️ 快捷键说明

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