clahrd.f.html

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

</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>      COMPLEX            ZERO, ONE
      PARAMETER          ( ZERO = ( 0.0E+0, 0.0E+0 ),
     $                   ONE = ( 1.0E+0, 0.0E+0 ) )
<span class="comment">*</span><span class="comment">     ..
</span><span class="comment">*</span><span class="comment">     .. Local Scalars ..
</span>      INTEGER            I
      COMPLEX            EI
<span class="comment">*</span><span class="comment">     ..
</span><span class="comment">*</span><span class="comment">     .. External Subroutines ..
</span>      EXTERNAL           CAXPY, CCOPY, CGEMV, <a name="CLACGV.116"></a><a href="clacgv.f.html#CLACGV.1">CLACGV</a>, <a name="CLARFG.116"></a><a href="clarfg.f.html#CLARFG.1">CLARFG</a>, CSCAL,
     $                   CTRMV
<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 <a name="CLACGV.136"></a><a href="clacgv.f.html#CLACGV.1">CLACGV</a>( I-1, A( K+I-1, 1 ), LDA )
            CALL CGEMV( <span class="string">'No transpose'</span>, N, I-1, -ONE, Y, LDY,
     $                  A( K+I-1, 1 ), LDA, ONE, A( 1, I ), 1 )
            CALL <a name="CLACGV.139"></a><a href="clacgv.f.html#CLACGV.1">CLACGV</a>( I-1, A( K+I-1, 1 ), LDA )
<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 CCOPY( I-1, A( K+1, I ), 1, T( 1, NB ), 1 )
            CALL CTRMV( <span class="string">'Lower'</span>, <span class="string">'Conjugate 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 CGEMV( <span class="string">'Conjugate 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 CTRMV( <span class="string">'Upper'</span>, <span class="string">'Conjugate 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 CGEMV( <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 CTRMV( <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 CAXPY( 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>         EI = A( K+I, I )
         CALL <a name="CLARFG.184"></a><a href="clarfg.f.html#CLARFG.1">CLARFG</a>( N-K-I+1, EI, A( MIN( K+I+1, N ), I ), 1,
     $                TAU( 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 CGEMV( <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 CGEMV( <span class="string">'Conjugate 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 CGEMV( <span class="string">'No transpose'</span>, N, I-1, -ONE, Y, LDY, T( 1, I ), 1,
     $               ONE, Y( 1, I ), 1 )
         CALL CSCAL( 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 CSCAL( I-1, -TAU( I ), T( 1, I ), 1 )
         CALL CTRMV( <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="CLAHRD.211"></a><a href="clahrd.f.html#CLAHRD.1">CLAHRD</a>
</span><span class="comment">*</span><span class="comment">
</span>      END

</pre>

 </body>
</html>