shseqr.f.html

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

      WORK( 1 ) = REAL( MAX( 1, N ) )
      LQUERY = LWORK.EQ.-1
<span class="comment">*</span><span class="comment">
</span>      INFO = 0
      IF( .NOT.<a name="LSAME.274"></a><a href="lsame.f.html#LSAME.1">LSAME</a>( JOB, <span class="string">'E'</span> ) .AND. .NOT.WANTT ) THEN
         INFO = -1
      ELSE IF( .NOT.<a name="LSAME.276"></a><a href="lsame.f.html#LSAME.1">LSAME</a>( COMPZ, <span class="string">'N'</span> ) .AND. .NOT.WANTZ ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
         INFO = -4
      ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
         INFO = -5
      ELSE IF( LDH.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.MAX( 1, N ) ) ) THEN
         INFO = -11
      ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
         INFO = -13
      END IF
<span class="comment">*</span><span class="comment">
</span>      IF( INFO.NE.0 ) THEN
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">        ==== Quick return in case of invalid argument. ====
</span><span class="comment">*</span><span class="comment">
</span>         CALL <a name="XERBLA.296"></a><a href="xerbla.f.html#XERBLA.1">XERBLA</a>( <span class="string">'<a name="SHSEQR.296"></a><a href="shseqr.f.html#SHSEQR.1">SHSEQR</a>'</span>, -INFO )
         RETURN
<span class="comment">*</span><span class="comment">
</span>      ELSE IF( N.EQ.0 ) THEN
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">        ==== Quick return in case N = 0; nothing to do. ====
</span><span class="comment">*</span><span class="comment">
</span>         RETURN
<span class="comment">*</span><span class="comment">
</span>      ELSE IF( LQUERY ) THEN
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">        ==== Quick return in case of a workspace query ====
</span><span class="comment">*</span><span class="comment">
</span>         CALL <a name="SLAQR0.309"></a><a href="slaqr0.f.html#SLAQR0.1">SLAQR0</a>( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILO,
     $                IHI, Z, LDZ, WORK, LWORK, INFO )
<span class="comment">*</span><span class="comment">        ==== Ensure reported workspace size is backward-compatible with
</span><span class="comment">*</span><span class="comment">        .    previous LAPACK versions. ====
</span>         WORK( 1 ) = MAX( REAL( MAX( 1, N ) ), WORK( 1 ) )
         RETURN
<span class="comment">*</span><span class="comment">
</span>      ELSE
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">        ==== copy eigenvalues isolated by <a name="SGEBAL.318"></a><a href="sgebal.f.html#SGEBAL.1">SGEBAL</a> ====
</span><span class="comment">*</span><span class="comment">
</span>         DO 10 I = 1, ILO - 1
            WR( I ) = H( I, I )
            WI( I ) = ZERO
   10    CONTINUE
         DO 20 I = IHI + 1, N
            WR( I ) = H( I, I )
            WI( I ) = ZERO
   20    CONTINUE
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">        ==== Initialize Z, if requested ====
</span><span class="comment">*</span><span class="comment">
</span>         IF( INITZ )
     $      CALL <a name="SLASET.332"></a><a href="slaset.f.html#SLASET.1">SLASET</a>( <span class="string">'A'</span>, N, N, ZERO, ONE, 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( ILO.EQ.IHI ) THEN
            WR( ILO ) = H( ILO, ILO )
            WI( ILO ) = ZERO
            RETURN
         END IF
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">        ==== <a name="SLAHQR.342"></a><a href="slahqr.f.html#SLAHQR.1">SLAHQR</a>/<a name="SLAQR0.342"></a><a href="slaqr0.f.html#SLAQR0.1">SLAQR0</a> crossover point ====
</span><span class="comment">*</span><span class="comment">
</span>         NMIN = <a name="ILAENV.344"></a><a href="hfy-index.html#ILAENV">ILAENV</a>( 1, <span class="string">'<a name="SHSEQR.344"></a><a href="shseqr.f.html#SHSEQR.1">SHSEQR</a>'</span>, JOB( : 1 ) // COMPZ( : 1 ), N, ILO,
     $          IHI, LWORK )
         NMIN = MAX( NTINY, NMIN )
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">        ==== <a name="SLAQR0.348"></a><a href="slaqr0.f.html#SLAQR0.1">SLAQR0</a> for big matrices; <a name="SLAHQR.348"></a><a href="slahqr.f.html#SLAHQR.1">SLAHQR</a> for small ones ====
</span><span class="comment">*</span><span class="comment">
</span>         IF( N.GT.NMIN ) THEN
            CALL <a name="SLAQR0.351"></a><a href="slaqr0.f.html#SLAQR0.1">SLAQR0</a>( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILO,
     $                   IHI, Z, LDZ, WORK, LWORK, INFO )
         ELSE
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">           ==== Small matrix ====
</span><span class="comment">*</span><span class="comment">
</span>            CALL <a name="SLAHQR.357"></a><a href="slahqr.f.html#SLAHQR.1">SLAHQR</a>( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILO,
     $                   IHI, Z, LDZ, INFO )
<span class="comment">*</span><span class="comment">
</span>            IF( INFO.GT.0 ) THEN
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">              ==== A rare <a name="SLAHQR.362"></a><a href="slahqr.f.html#SLAHQR.1">SLAHQR</a> failure!  <a name="SLAQR0.362"></a><a href="slaqr0.f.html#SLAQR0.1">SLAQR0</a> sometimes succeeds
</span><span class="comment">*</span><span class="comment">              .    when <a name="SLAHQR.363"></a><a href="slahqr.f.html#SLAHQR.1">SLAHQR</a> fails. ====
</span><span class="comment">*</span><span class="comment">
</span>               KBOT = INFO
<span class="comment">*</span><span class="comment">
</span>               IF( N.GE.NL ) THEN
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">                 ==== Larger matrices have enough subdiagonal scratch
</span><span class="comment">*</span><span class="comment">                 .    space to call <a name="SLAQR0.370"></a><a href="slaqr0.f.html#SLAQR0.1">SLAQR0</a> directly. ====
</span><span class="comment">*</span><span class="comment">
</span>                  CALL <a name="SLAQR0.372"></a><a href="slaqr0.f.html#SLAQR0.1">SLAQR0</a>( WANTT, WANTZ, N, ILO, KBOT, H, LDH, WR,
     $                         WI, ILO, IHI, Z, LDZ, WORK, LWORK, INFO )
<span class="comment">*</span><span class="comment">
</span>               ELSE
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">                 ==== Tiny matrices don't have enough subdiagonal
</span><span class="comment">*</span><span class="comment">                 .    scratch space to benefit from <a name="SLAQR0.378"></a><a href="slaqr0.f.html#SLAQR0.1">SLAQR0</a>.  Hence,
</span><span class="comment">*</span><span class="comment">                 .    tiny matrices must be copied into a larger
</span><span class="comment">*</span><span class="comment">                 .    array before calling <a name="SLAQR0.380"></a><a href="slaqr0.f.html#SLAQR0.1">SLAQR0</a>. ====
</span><span class="comment">*</span><span class="comment">
</span>                  CALL <a name="SLACPY.382"></a><a href="slacpy.f.html#SLACPY.1">SLACPY</a>( <span class="string">'A'</span>, N, N, H, LDH, HL, NL )
                  HL( N+1, N ) = ZERO
                  CALL <a name="SLASET.384"></a><a href="slaset.f.html#SLASET.1">SLASET</a>( <span class="string">'A'</span>, NL, NL-N, ZERO, ZERO, HL( 1, N+1 ),
     $                         NL )
                  CALL <a name="SLAQR0.386"></a><a href="slaqr0.f.html#SLAQR0.1">SLAQR0</a>( WANTT, WANTZ, NL, ILO, KBOT, HL, NL, WR,
     $                         WI, ILO, IHI, Z, LDZ, WORKL, NL, INFO )
                  IF( WANTT .OR. INFO.NE.0 )
     $               CALL <a name="SLACPY.389"></a><a href="slacpy.f.html#SLACPY.1">SLACPY</a>( <span class="string">'A'</span>, N, N, HL, NL, H, LDH )
               END IF
            END IF
         END IF
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">        ==== Clear out the trash, if necessary. ====
</span><span class="comment">*</span><span class="comment">
</span>         IF( ( WANTT .OR. INFO.NE.0 ) .AND. N.GT.2 )
     $      CALL <a name="SLASET.397"></a><a href="slaset.f.html#SLASET.1">SLASET</a>( <span class="string">'L'</span>, N-2, N-2, ZERO, ZERO, H( 3, 1 ), LDH )
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">        ==== Ensure reported workspace size is backward-compatible with
</span><span class="comment">*</span><span class="comment">        .    previous LAPACK versions. ====
</span><span class="comment">*</span><span class="comment">
</span>         WORK( 1 ) = MAX( REAL( MAX( 1, N ) ), WORK( 1 ) )
      END IF
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">     ==== End of <a name="SHSEQR.405"></a><a href="shseqr.f.html#SHSEQR.1">SHSEQR</a> ====
</span><span class="comment">*</span><span class="comment">
</span>      END

</pre>

 </body>
</html>