zungtr.f.html

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

</span>      INTRINSIC          MAX
<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">     Test the input arguments
</span><span class="comment">*</span><span class="comment">
</span>      INFO = 0
      LQUERY = ( LWORK.EQ.-1 )
      UPPER = <a name="LSAME.95"></a><a href="lsame.f.html#LSAME.1">LSAME</a>( UPLO, <span class="string">'U'</span> )
      IF( .NOT.UPPER .AND. .NOT.<a name="LSAME.96"></a><a href="lsame.f.html#LSAME.1">LSAME</a>( UPLO, <span class="string">'L'</span> ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -4
      ELSE IF( LWORK.LT.MAX( 1, N-1 ) .AND. .NOT.LQUERY ) THEN
         INFO = -7
      END IF
<span class="comment">*</span><span class="comment">
</span>      IF( INFO.EQ.0 ) THEN
         IF( UPPER ) THEN
            NB = <a name="ILAENV.108"></a><a href="hfy-index.html#ILAENV">ILAENV</a>( 1, <span class="string">'<a name="ZUNGQL.108"></a><a href="zungql.f.html#ZUNGQL.1">ZUNGQL</a>'</span>, <span class="string">' '</span>, N-1, N-1, N-1, -1 )
         ELSE
            NB = <a name="ILAENV.110"></a><a href="hfy-index.html#ILAENV">ILAENV</a>( 1, <span class="string">'<a name="ZUNGQR.110"></a><a href="zungqr.f.html#ZUNGQR.1">ZUNGQR</a>'</span>, <span class="string">' '</span>, N-1, N-1, N-1, -1 )
         END IF
         LWKOPT = MAX( 1, N-1 )*NB
         WORK( 1 ) = LWKOPT
      END IF
<span class="comment">*</span><span class="comment">
</span>      IF( INFO.NE.0 ) THEN
         CALL <a name="XERBLA.117"></a><a href="xerbla.f.html#XERBLA.1">XERBLA</a>( <span class="string">'<a name="ZUNGTR.117"></a><a href="zungtr.f.html#ZUNGTR.1">ZUNGTR</a>'</span>, -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
<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.EQ.0 ) THEN
         WORK( 1 ) = 1
         RETURN
      END IF
<span class="comment">*</span><span class="comment">
</span>      IF( UPPER ) THEN
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">        Q was determined by a call to <a name="ZHETRD.132"></a><a href="zhetrd.f.html#ZHETRD.1">ZHETRD</a> with UPLO = 'U'
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">        Shift the vectors which define the elementary reflectors one
</span><span class="comment">*</span><span class="comment">        column to the left, and set the last row and column of Q to
</span><span class="comment">*</span><span class="comment">        those of the unit matrix
</span><span class="comment">*</span><span class="comment">
</span>         DO 20 J = 1, N - 1
            DO 10 I = 1, J - 1
               A( I, J ) = A( I, J+1 )
   10       CONTINUE
            A( N, J ) = ZERO
   20    CONTINUE
         DO 30 I = 1, N - 1
            A( I, N ) = ZERO
   30    CONTINUE
         A( N, N ) = ONE
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">        Generate Q(1:n-1,1:n-1)
</span><span class="comment">*</span><span class="comment">
</span>         CALL <a name="ZUNGQL.151"></a><a href="zungql.f.html#ZUNGQL.1">ZUNGQL</a>( N-1, N-1, N-1, A, LDA, TAU, WORK, LWORK, IINFO )
<span class="comment">*</span><span class="comment">
</span>      ELSE
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">        Q was determined by a call to <a name="ZHETRD.155"></a><a href="zhetrd.f.html#ZHETRD.1">ZHETRD</a> with UPLO = 'L'.
</span><span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">        Shift the vectors which define the elementary reflectors one
</span><span class="comment">*</span><span class="comment">        column to the right, and set the first row and column of Q to
</span><span class="comment">*</span><span class="comment">        those of the unit matrix
</span><span class="comment">*</span><span class="comment">
</span>         DO 50 J = N, 2, -1
            A( 1, J ) = ZERO
            DO 40 I = J + 1, N
               A( I, J ) = A( I, J-1 )
   40       CONTINUE
   50    CONTINUE
         A( 1, 1 ) = ONE
         DO 60 I = 2, N
            A( I, 1 ) = ZERO
   60    CONTINUE
         IF( N.GT.1 ) THEN
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">           Generate Q(2:n,2:n)
</span><span class="comment">*</span><span class="comment">
</span>            CALL <a name="ZUNGQR.175"></a><a href="zungqr.f.html#ZUNGQR.1">ZUNGQR</a>( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK,
     $                   LWORK, IINFO )
         END IF
      END IF
      WORK( 1 ) = LWKOPT
      RETURN
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">     End of <a name="ZUNGTR.182"></a><a href="zungtr.f.html#ZUNGTR.1">ZUNGTR</a>
</span><span class="comment">*</span><span class="comment">
</span>      END

</pre>

 </body>
</html>