slahrd.f.html

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

</span><span class="comment">*</span><span class="comment">     ( v1  v2  a   a   a )
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">  where a denotes an element of the original matrix A, h denotes a
</span><span class="comment">*</span><span class="comment">  modified element of the upper Hessenberg matrix H, and vi denotes an
</span><span class="comment">*</span><span class="comment">  element of the vector defining H(i).
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">  =====================================================================
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">     .. Parameters ..
</span>      REAL               ZERO, ONE
      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
<span class="comment">*</span><span class="comment">     ..
</span><span class="comment">*</span><span class="comment">     .. Local Scalars ..
</span>      INTEGER            I
      REAL               EI
<span class="comment">*</span><span class="comment">     ..
</span><span class="comment">*</span><span class="comment">     .. External Subroutines ..
</span>      EXTERNAL           SAXPY, SCOPY, SGEMV, <a name="SLARFG.115"></a><a href="slarfg.f.html#SLARFG.1">SLARFG</a>, SSCAL, STRMV
<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(1:n,i)
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">           Compute i-th column of A - Y * V'
</span><span class="comment">*</span><span class="comment">
</span>            CALL SGEMV( <span class="string">'No transpose'</span>, N, I-1, -ONE, Y, LDY,
     $                  A( K+I-1, 1 ), LDA, ONE, A( 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 SCOPY( I-1, A( K+1, I ), 1, T( 1, NB ), 1 )
            CALL STRMV( <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 SGEMV( <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 STRMV( <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 SGEMV( <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 STRMV( <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 SAXPY( 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="SLARFG.178"></a><a href="slarfg.f.html#SLARFG.1">SLARFG</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(1:n,i)
</span><span class="comment">*</span><span class="comment">
</span>         CALL SGEMV( <span class="string">'No transpose'</span>, N, N-K-I+1, ONE, A( 1, I+1 ), LDA,
     $               A( K+I, I ), 1, ZERO, Y( 1, I ), 1 )
         CALL SGEMV( <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 SGEMV( <span class="string">'No transpose'</span>, N, I-1, -ONE, Y, LDY, T( 1, I ), 1,
     $               ONE, Y( 1, I ), 1 )
         CALL SSCAL( N, TAU( I ), Y( 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 SSCAL( I-1, -TAU( I ), T( 1, I ), 1 )
         CALL STRMV( <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>      RETURN
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">     End of <a name="SLAHRD.205"></a><a href="slahrd.f.html#SLAHRD.1">SLAHRD</a>
</span><span class="comment">*</span><span class="comment">
</span>      END

</pre>

 </body>
</html>