📄 dgbtrf.f.html

📁 famous linear algebra library (LAPACK) ports to windows
💻 HTML
📖 第 1 页 / 共 3 页
字号:
上一页 1 23
     $                      IPIV( J ), 1 )
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">              Adjust the pivot indices.
</span><span class="comment">*</span><span class="comment">
</span>               DO 90 I = J, J + JB - 1
                  IPIV( I ) = IPIV( I ) + J - 1
   90          CONTINUE
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">              Apply the row interchanges to A13, A23, and A33
</span><span class="comment">*</span><span class="comment">              columnwise.
</span><span class="comment">*</span><span class="comment">
</span>               K2 = J - 1 + JB + J2
               DO 110 I = 1, J3
                  JJ = K2 + I
                  DO 100 II = J + I - 1, J + JB - 1
                     IP = IPIV( II )
                     IF( IP.NE.II ) THEN
                        TEMP = AB( KV+1+II-JJ, JJ )
                        AB( KV+1+II-JJ, JJ ) = AB( KV+1+IP-JJ, JJ )
                        AB( KV+1+IP-JJ, JJ ) = TEMP
                     END IF
  100             CONTINUE
  110          CONTINUE
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">              Update the relevant part of the trailing submatrix
</span><span class="comment">*</span><span class="comment">
</span>               IF( J2.GT.0 ) THEN
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">                 Update A12
</span><span class="comment">*</span><span class="comment">
</span>                  CALL DTRSM( <span class="string">'Left'</span>, <span class="string">'Lower'</span>, <span class="string">'No transpose'</span>, <span class="string">'Unit'</span>,
     $                        JB, J2, ONE, AB( KV+1, J ), LDAB-1,
     $                        AB( KV+1-JB, J+JB ), LDAB-1 )
<span class="comment">*</span><span class="comment">
</span>                  IF( I2.GT.0 ) THEN
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">                    Update A22
</span><span class="comment">*</span><span class="comment">
</span>                     CALL DGEMM( <span class="string">'No transpose'</span>, <span class="string">'No transpose'</span>, I2, J2,
     $                           JB, -ONE, AB( KV+1+JB, J ), LDAB-1,
     $                           AB( KV+1-JB, J+JB ), LDAB-1, ONE,
     $                           AB( KV+1, J+JB ), LDAB-1 )
                  END IF
<span class="comment">*</span><span class="comment">
</span>                  IF( I3.GT.0 ) THEN
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">                    Update A32
</span><span class="comment">*</span><span class="comment">
</span>                     CALL DGEMM( <span class="string">'No transpose'</span>, <span class="string">'No transpose'</span>, I3, J2,
     $                           JB, -ONE, WORK31, LDWORK,
     $                           AB( KV+1-JB, J+JB ), LDAB-1, ONE,
     $                           AB( KV+KL+1-JB, J+JB ), LDAB-1 )
                  END IF
               END IF
<span class="comment">*</span><span class="comment">
</span>               IF( J3.GT.0 ) THEN
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">                 Copy the lower triangle of A13 into the work array
</span><span class="comment">*</span><span class="comment">                 WORK13
</span><span class="comment">*</span><span class="comment">
</span>                  DO 130 JJ = 1, J3
                     DO 120 II = JJ, JB
                        WORK13( II, JJ ) = AB( II-JJ+1, JJ+J+KV-1 )
  120                CONTINUE
  130             CONTINUE
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">                 Update A13 in the work array
</span><span class="comment">*</span><span class="comment">
</span>                  CALL DTRSM( <span class="string">'Left'</span>, <span class="string">'Lower'</span>, <span class="string">'No transpose'</span>, <span class="string">'Unit'</span>,
     $                        JB, J3, ONE, AB( KV+1, J ), LDAB-1,
     $                        WORK13, LDWORK )
<span class="comment">*</span><span class="comment">
</span>                  IF( I2.GT.0 ) THEN
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">                    Update A23
</span><span class="comment">*</span><span class="comment">
</span>                     CALL DGEMM( <span class="string">'No transpose'</span>, <span class="string">'No transpose'</span>, I2, J3,
     $                           JB, -ONE, AB( KV+1+JB, J ), LDAB-1,
     $                           WORK13, LDWORK, ONE, AB( 1+JB, J+KV ),
     $                           LDAB-1 )
                  END IF
<span class="comment">*</span><span class="comment">
</span>                  IF( I3.GT.0 ) THEN
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">                    Update A33
</span><span class="comment">*</span><span class="comment">
</span>                     CALL DGEMM( <span class="string">'No transpose'</span>, <span class="string">'No transpose'</span>, I3, J3,
     $                           JB, -ONE, WORK31, LDWORK, WORK13,
     $                           LDWORK, ONE, AB( 1+KL, J+KV ), LDAB-1 )
                  END IF
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">                 Copy the lower triangle of A13 back into place
</span><span class="comment">*</span><span class="comment">
</span>                  DO 150 JJ = 1, J3
                     DO 140 II = JJ, JB
                        AB( II-JJ+1, JJ+J+KV-1 ) = WORK13( II, JJ )
  140                CONTINUE
  150             CONTINUE
               END IF
            ELSE
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">              Adjust the pivot indices.
</span><span class="comment">*</span><span class="comment">
</span>               DO 160 I = J, J + JB - 1
                  IPIV( I ) = IPIV( I ) + J - 1
  160          CONTINUE
            END IF
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">           Partially undo the interchanges in the current block to
</span><span class="comment">*</span><span class="comment">           restore the upper triangular form of A31 and copy the upper
</span><span class="comment">*</span><span class="comment">           triangle of A31 back into place
</span><span class="comment">*</span><span class="comment">
</span>            DO 170 JJ = J + JB - 1, J, -1
               JP = IPIV( JJ ) - JJ + 1
               IF( JP.NE.1 ) THEN
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">                 Apply interchange to columns J to JJ-1
</span><span class="comment">*</span><span class="comment">
</span>                  IF( JP+JJ-1.LT.J+KL ) THEN
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">                    The interchange does not affect A31
</span><span class="comment">*</span><span class="comment">
</span>                     CALL DSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1,
     $                           AB( KV+JP+JJ-J, J ), LDAB-1 )
                  ELSE
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">                    The interchange does affect A31
</span><span class="comment">*</span><span class="comment">
</span>                     CALL DSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1,
     $                           WORK31( JP+JJ-J-KL, 1 ), LDWORK )
                  END IF
               END IF
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">              Copy the current column of A31 back into place
</span><span class="comment">*</span><span class="comment">
</span>               NW = MIN( I3, JJ-J+1 )
               IF( NW.GT.0 )
     $            CALL DCOPY( NW, WORK31( 1, JJ-J+1 ), 1,
     $                        AB( KV+KL+1-JJ+J, JJ ), 1 )
  170       CONTINUE
  180    CONTINUE
      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="DGBTRF.439"></a><a href="dgbtrf.f.html#DGBTRF.1">DGBTRF</a>
</span><span class="comment">*</span><span class="comment">
</span>      END

</pre>

 </body>
</html>
上一页 1 23
⌨️ 快捷键说明

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