dlahr2.f.html

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

     $                     ONE = 1.0D+0 )
<span class="comment">*</span><span class="comment">     ..
</span><span class="comment">*</span><span class="comment">     .. Local Scalars ..
</span>      INTEGER            I
      DOUBLE PRECISION  EI
<span class="comment">*</span><span class="comment">     ..
</span><span class="comment">*</span><span class="comment">     .. External Subroutines ..
</span>      EXTERNAL           DAXPY, DCOPY, DGEMM, DGEMV, <a name="DLACPY.121"></a><a href="dlacpy.f.html#DLACPY.1">DLACPY</a>,
     $                   <a name="DLARFG.122"></a><a href="dlarfg.f.html#DLARFG.1">DLARFG</a>, DSCAL, DTRMM, DTRMV
<span class="comment">*</span><span class="comment">     ..
</span><span class="comment">*</span><span class="comment">     .. Intrinsic Functions ..
</span>      INTRINSIC          MIN
<span class="comment">*</span><span class="comment">     ..
</span><span class="comment">*</span><span class="comment">     .. Executable Statements ..
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">     Quick return if possible
</span><span class="comment">*</span><span class="comment">
</span>      IF( N.LE.1 )
     $   RETURN
<span class="comment">*</span><span class="comment">
</span>      DO 10 I = 1, NB
         IF( I.GT.1 ) THEN
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">           Update A(K+1:N,I)
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">           Update I-th column of A - Y * V'
</span><span class="comment">*</span><span class="comment">
</span>            CALL DGEMV( <span class="string">'NO TRANSPOSE'</span>, N-K, I-1, -ONE, Y(K+1,1), LDY,
     $                  A( K+I-1, 1 ), LDA, ONE, A( K+1, I ), 1 )
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">           Apply I - V * T' * V' to this column (call it b) from the
</span><span class="comment">*</span><span class="comment">           left, using the last column of T as workspace
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">           Let  V = ( V1 )   and   b = ( b1 )   (first I-1 rows)
</span><span class="comment">*</span><span class="comment">                    ( V2 )             ( b2 )
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">           where V1 is unit lower triangular
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">           w := V1' * b1
</span><span class="comment">*</span><span class="comment">
</span>            CALL DCOPY( I-1, A( K+1, I ), 1, T( 1, NB ), 1 )
            CALL DTRMV( <span class="string">'Lower'</span>, <span class="string">'Transpose'</span>, <span class="string">'UNIT'</span>, 
     $                  I-1, A( K+1, 1 ),
     $                  LDA, T( 1, NB ), 1 )
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">           w := w + V2'*b2
</span><span class="comment">*</span><span class="comment">
</span>            CALL DGEMV( <span class="string">'Transpose'</span>, N-K-I+1, I-1, 
     $                  ONE, A( K+I, 1 ),
     $                  LDA, A( K+I, I ), 1, ONE, T( 1, NB ), 1 )
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">           w := T'*w
</span><span class="comment">*</span><span class="comment">
</span>            CALL DTRMV( <span class="string">'Upper'</span>, <span class="string">'Transpose'</span>, <span class="string">'NON-UNIT'</span>, 
     $                  I-1, T, LDT,
     $                  T( 1, NB ), 1 )
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">           b2 := b2 - V2*w
</span><span class="comment">*</span><span class="comment">
</span>            CALL DGEMV( <span class="string">'NO TRANSPOSE'</span>, N-K-I+1, I-1, -ONE, 
     $                  A( K+I, 1 ),
     $                  LDA, T( 1, NB ), 1, ONE, A( K+I, I ), 1 )
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">           b1 := b1 - V1*w
</span><span class="comment">*</span><span class="comment">
</span>            CALL DTRMV( <span class="string">'Lower'</span>, <span class="string">'NO TRANSPOSE'</span>, 
     $                  <span class="string">'UNIT'</span>, I-1,
     $                  A( K+1, 1 ), LDA, T( 1, NB ), 1 )
            CALL DAXPY( I-1, -ONE, T( 1, NB ), 1, A( K+1, I ), 1 )
<span class="comment">*</span><span class="comment">
</span>            A( K+I-1, I-1 ) = EI
         END IF
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">        Generate the elementary reflector H(I) to annihilate
</span><span class="comment">*</span><span class="comment">        A(K+I+1:N,I)
</span><span class="comment">*</span><span class="comment">
</span>         CALL <a name="DLARFG.190"></a><a href="dlarfg.f.html#DLARFG.1">DLARFG</a>( N-K-I+1, A( K+I, I ), A( MIN( K+I+1, N ), I ), 1,
     $                TAU( I ) )
         EI = A( K+I, I )
         A( K+I, I ) = ONE
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">        Compute  Y(K+1:N,I)
</span><span class="comment">*</span><span class="comment">
</span>         CALL DGEMV( <span class="string">'NO TRANSPOSE'</span>, N-K, N-K-I+1, 
     $               ONE, A( K+1, I+1 ),
     $               LDA, A( K+I, I ), 1, ZERO, Y( K+1, I ), 1 )
         CALL DGEMV( <span class="string">'Transpose'</span>, N-K-I+1, I-1, 
     $               ONE, A( K+I, 1 ), LDA,
     $               A( K+I, I ), 1, ZERO, T( 1, I ), 1 )
         CALL DGEMV( <span class="string">'NO TRANSPOSE'</span>, N-K, I-1, -ONE, 
     $               Y( K+1, 1 ), LDY,
     $               T( 1, I ), 1, ONE, Y( K+1, I ), 1 )
         CALL DSCAL( N-K, TAU( I ), Y( K+1, I ), 1 )
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">        Compute T(1:I,I)
</span><span class="comment">*</span><span class="comment">
</span>         CALL DSCAL( I-1, -TAU( I ), T( 1, I ), 1 )
         CALL DTRMV( <span class="string">'Upper'</span>, <span class="string">'No Transpose'</span>, <span class="string">'NON-UNIT'</span>, 
     $               I-1, T, LDT,
     $               T( 1, I ), 1 )
         T( I, I ) = TAU( I )
<span class="comment">*</span><span class="comment">
</span>   10 CONTINUE
      A( K+NB, NB ) = EI
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">     Compute Y(1:K,1:NB)
</span><span class="comment">*</span><span class="comment">
</span>      CALL <a name="DLACPY.221"></a><a href="dlacpy.f.html#DLACPY.1">DLACPY</a>( <span class="string">'ALL'</span>, K, NB, A( 1, 2 ), LDA, Y, LDY )
      CALL DTRMM( <span class="string">'RIGHT'</span>, <span class="string">'Lower'</span>, <span class="string">'NO TRANSPOSE'</span>, 
     $            <span class="string">'UNIT'</span>, K, NB,
     $            ONE, A( K+1, 1 ), LDA, Y, LDY )
      IF( N.GT.K+NB )
     $   CALL DGEMM( <span class="string">'NO TRANSPOSE'</span>, <span class="string">'NO TRANSPOSE'</span>, K, 
     $               NB, N-K-NB, ONE,
     $               A( 1, 2+NB ), LDA, A( K+1+NB, 1 ), LDA, ONE, Y,
     $               LDY )
      CALL DTRMM( <span class="string">'RIGHT'</span>, <span class="string">'Upper'</span>, <span class="string">'NO TRANSPOSE'</span>, 
     $            <span class="string">'NON-UNIT'</span>, K, NB,
     $            ONE, T, LDT, Y, LDY )
<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="DLAHR2.236"></a><a href="dlahr2.f.html#DLAHR2.1">DLAHR2</a>
</span><span class="comment">*</span><span class="comment">
</span>      END

</pre>

 </body>
</html>