zgghrd.f.html

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

</span>      COMPLEX*16         CONE, CZERO
      PARAMETER          ( CONE = ( 1.0D+0, 0.0D+0 ),
     $                   CZERO = ( 0.0D+0, 0.0D+0 ) )
<span class="comment">*</span><span class="comment">     ..
</span><span class="comment">*</span><span class="comment">     .. Local Scalars ..
</span>      LOGICAL            ILQ, ILZ
      INTEGER            ICOMPQ, ICOMPZ, JCOL, JROW
      DOUBLE PRECISION   C
      COMPLEX*16         CTEMP, S
<span class="comment">*</span><span class="comment">     ..
</span><span class="comment">*</span><span class="comment">     .. External Functions ..
</span>      LOGICAL            <a name="LSAME.138"></a><a href="lsame.f.html#LSAME.1">LSAME</a>
      EXTERNAL           <a name="LSAME.139"></a><a href="lsame.f.html#LSAME.1">LSAME</a>
<span class="comment">*</span><span class="comment">     ..
</span><span class="comment">*</span><span class="comment">     .. External Subroutines ..
</span>      EXTERNAL           <a name="XERBLA.142"></a><a href="xerbla.f.html#XERBLA.1">XERBLA</a>, <a name="ZLARTG.142"></a><a href="zlartg.f.html#ZLARTG.1">ZLARTG</a>, <a name="ZLASET.142"></a><a href="zlaset.f.html#ZLASET.1">ZLASET</a>, <a name="ZROT.142"></a><a href="zrot.f.html#ZROT.1">ZROT</a>
<span class="comment">*</span><span class="comment">     ..
</span><span class="comment">*</span><span class="comment">     .. Intrinsic Functions ..
</span>      INTRINSIC          DCONJG, 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">     Decode COMPQ
</span><span class="comment">*</span><span class="comment">
</span>      IF( <a name="LSAME.151"></a><a href="lsame.f.html#LSAME.1">LSAME</a>( COMPQ, <span class="string">'N'</span> ) ) THEN
         ILQ = .FALSE.
         ICOMPQ = 1
      ELSE IF( <a name="LSAME.154"></a><a href="lsame.f.html#LSAME.1">LSAME</a>( COMPQ, <span class="string">'V'</span> ) ) THEN
         ILQ = .TRUE.
         ICOMPQ = 2
      ELSE IF( <a name="LSAME.157"></a><a href="lsame.f.html#LSAME.1">LSAME</a>( COMPQ, <span class="string">'I'</span> ) ) THEN
         ILQ = .TRUE.
         ICOMPQ = 3
      ELSE
         ICOMPQ = 0
      END IF
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">     Decode COMPZ
</span><span class="comment">*</span><span class="comment">
</span>      IF( <a name="LSAME.166"></a><a href="lsame.f.html#LSAME.1">LSAME</a>( COMPZ, <span class="string">'N'</span> ) ) THEN
         ILZ = .FALSE.
         ICOMPZ = 1
      ELSE IF( <a name="LSAME.169"></a><a href="lsame.f.html#LSAME.1">LSAME</a>( COMPZ, <span class="string">'V'</span> ) ) THEN
         ILZ = .TRUE.
         ICOMPZ = 2
      ELSE IF( <a name="LSAME.172"></a><a href="lsame.f.html#LSAME.1">LSAME</a>( COMPZ, <span class="string">'I'</span> ) ) THEN
         ILZ = .TRUE.
         ICOMPZ = 3
      ELSE
         ICOMPZ = 0
      END IF
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">     Test the input parameters.
</span><span class="comment">*</span><span class="comment">
</span>      INFO = 0
      IF( ICOMPQ.LE.0 ) THEN
         INFO = -1
      ELSE IF( ICOMPZ.LE.0 ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( ILO.LT.1 ) THEN
         INFO = -4
      ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN
         INFO = -5
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -9
      ELSE IF( ( ILQ .AND. LDQ.LT.N ) .OR. LDQ.LT.1 ) THEN
         INFO = -11
      ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN
         INFO = -13
      END IF
      IF( INFO.NE.0 ) THEN
         CALL <a name="XERBLA.202"></a><a href="xerbla.f.html#XERBLA.1">XERBLA</a>( <span class="string">'<a name="ZGGHRD.202"></a><a href="zgghrd.f.html#ZGGHRD.1">ZGGHRD</a>'</span>, -INFO )
         RETURN
      END IF
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">     Initialize Q and Z if desired.
</span><span class="comment">*</span><span class="comment">
</span>      IF( ICOMPQ.EQ.3 )
     $   CALL <a name="ZLASET.209"></a><a href="zlaset.f.html#ZLASET.1">ZLASET</a>( <span class="string">'Full'</span>, N, N, CZERO, CONE, Q, LDQ )
      IF( ICOMPZ.EQ.3 )
     $   CALL <a name="ZLASET.211"></a><a href="zlaset.f.html#ZLASET.1">ZLASET</a>( <span class="string">'Full'</span>, N, N, CZERO, CONE, Z, LDZ )
<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><span class="comment">*</span><span class="comment">     Zero out lower triangle of B
</span><span class="comment">*</span><span class="comment">
</span>      DO 20 JCOL = 1, N - 1
         DO 10 JROW = JCOL + 1, N
            B( JROW, JCOL ) = CZERO
   10    CONTINUE
   20 CONTINUE
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">     Reduce A and B
</span><span class="comment">*</span><span class="comment">
</span>      DO 40 JCOL = ILO, IHI - 2
<span class="comment">*</span><span class="comment">
</span>         DO 30 JROW = IHI, JCOL + 2, -1
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">           Step 1: rotate rows JROW-1, JROW to kill A(JROW,JCOL)
</span><span class="comment">*</span><span class="comment">
</span>            CTEMP = A( JROW-1, JCOL )
            CALL <a name="ZLARTG.235"></a><a href="zlartg.f.html#ZLARTG.1">ZLARTG</a>( CTEMP, A( JROW, JCOL ), C, S,
     $                   A( JROW-1, JCOL ) )
            A( JROW, JCOL ) = CZERO
            CALL <a name="ZROT.238"></a><a href="zrot.f.html#ZROT.1">ZROT</a>( N-JCOL, A( JROW-1, JCOL+1 ), LDA,
     $                 A( JROW, JCOL+1 ), LDA, C, S )
            CALL <a name="ZROT.240"></a><a href="zrot.f.html#ZROT.1">ZROT</a>( N+2-JROW, B( JROW-1, JROW-1 ), LDB,
     $                 B( JROW, JROW-1 ), LDB, C, S )
            IF( ILQ )
     $         CALL <a name="ZROT.243"></a><a href="zrot.f.html#ZROT.1">ZROT</a>( N, Q( 1, JROW-1 ), 1, Q( 1, JROW ), 1, C,
     $                    DCONJG( S ) )
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">           Step 2: rotate columns JROW, JROW-1 to kill B(JROW,JROW-1)
</span><span class="comment">*</span><span class="comment">
</span>            CTEMP = B( JROW, JROW )
            CALL <a name="ZLARTG.249"></a><a href="zlartg.f.html#ZLARTG.1">ZLARTG</a>( CTEMP, B( JROW, JROW-1 ), C, S,
     $                   B( JROW, JROW ) )
            B( JROW, JROW-1 ) = CZERO
            CALL <a name="ZROT.252"></a><a href="zrot.f.html#ZROT.1">ZROT</a>( IHI, A( 1, JROW ), 1, A( 1, JROW-1 ), 1, C, S )
            CALL <a name="ZROT.253"></a><a href="zrot.f.html#ZROT.1">ZROT</a>( JROW-1, B( 1, JROW ), 1, B( 1, JROW-1 ), 1, C,
     $                 S )
            IF( ILZ )
     $         CALL <a name="ZROT.256"></a><a href="zrot.f.html#ZROT.1">ZROT</a>( N, Z( 1, JROW ), 1, Z( 1, JROW-1 ), 1, C, S )
   30    CONTINUE
   40 CONTINUE
<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="ZGGHRD.262"></a><a href="zgghrd.f.html#ZGGHRD.1">ZGGHRD</a>
</span><span class="comment">*</span><span class="comment">
</span>      END

</pre>

 </body>
</html>