slahqr.f.html

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

</span><span class="comment">*</span><span class="comment">
</span>      INFO = 0
<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 )
     $   RETURN
      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">     ==== clear out the trash ====
</span>      DO 10 J = ILO, IHI - 3
         H( J+2, J ) = ZERO
         H( J+3, J ) = ZERO
   10 CONTINUE
      IF( ILO.LE.IHI-2 )
     $   H( IHI, IHI-2 ) = ZERO
<span class="comment">*</span><span class="comment">
</span>      NH = IHI - ILO + 1
      NZ = IHIZ - ILOZ + 1
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">     Set machine-dependent constants for the stopping criterion.
</span><span class="comment">*</span><span class="comment">
</span>      SAFMIN = <a name="SLAMCH.184"></a><a href="slamch.f.html#SLAMCH.1">SLAMCH</a>( <span class="string">'SAFE MINIMUM'</span> )
      SAFMAX = ONE / SAFMIN
      CALL <a name="SLABAD.186"></a><a href="slabad.f.html#SLABAD.1">SLABAD</a>( SAFMIN, SAFMAX )
      ULP = <a name="SLAMCH.187"></a><a href="slamch.f.html#SLAMCH.1">SLAMCH</a>( <span class="string">'PRECISION'</span> )
      SMLNUM = SAFMIN*( REAL( NH ) / ULP )
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">     I1 and I2 are the indices of the first row and last column of H
</span><span class="comment">*</span><span class="comment">     to which transformations must be applied. If eigenvalues only are
</span><span class="comment">*</span><span class="comment">     being computed, I1 and I2 are set inside the main loop.
</span><span class="comment">*</span><span class="comment">
</span>      IF( WANTT ) THEN
         I1 = 1
         I2 = N
      END IF
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">     The main loop begins here. I is the loop index and decreases from
</span><span class="comment">*</span><span class="comment">     IHI to ILO in steps of 1 or 2. Each iteration of the loop works
</span><span class="comment">*</span><span class="comment">     with the active submatrix in rows and columns L to I.
</span><span class="comment">*</span><span class="comment">     Eigenvalues I+1 to IHI have already converged. Either L = ILO or
</span><span class="comment">*</span><span class="comment">     H(L,L-1) is negligible so that the matrix splits.
</span><span class="comment">*</span><span class="comment">
</span>      I = IHI
   20 CONTINUE
      L = ILO
      IF( I.LT.ILO )
     $   GO TO 160
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">     Perform QR iterations on rows and columns ILO to I until a
</span><span class="comment">*</span><span class="comment">     submatrix of order 1 or 2 splits off at the bottom because a
</span><span class="comment">*</span><span class="comment">     subdiagonal element has become negligible.
</span><span class="comment">*</span><span class="comment">
</span>      DO 140 ITS = 0, ITMAX
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">        Look for a single small subdiagonal element.
</span><span class="comment">*</span><span class="comment">
</span>         DO 30 K = I, L + 1, -1
            IF( ABS( H( K, K-1 ) ).LE.SMLNUM )
     $         GO TO 40
            TST = ABS( H( K-1, K-1 ) ) + ABS( H( K, K ) )
            IF( TST.EQ.ZERO ) THEN
               IF( K-2.GE.ILO )
     $            TST = TST + ABS( H( K-1, K-2 ) )
               IF( K+1.LE.IHI )
     $            TST = TST + ABS( H( K+1, K ) )
            END IF
<span class="comment">*</span><span class="comment">           ==== The following is a conservative small subdiagonal
</span><span class="comment">*</span><span class="comment">           .    deflation  criterion due to Ahues &amp; Tisseur (LAWN 122,
</span><span class="comment">*</span><span class="comment">           .    1997). It has better mathematical foundation and
</span><span class="comment">*</span><span class="comment">           .    improves accuracy in some cases.  ====
</span>            IF( ABS( H( K, K-1 ) ).LE.ULP*TST ) THEN
               AB = MAX( ABS( H( K, K-1 ) ), ABS( H( K-1, K ) ) )
               BA = MIN( ABS( H( K, K-1 ) ), ABS( H( K-1, K ) ) )
               AA = MAX( ABS( H( K, K ) ),
     $              ABS( H( K-1, K-1 )-H( K, K ) ) )
               BB = MIN( ABS( H( K, K ) ),
     $              ABS( H( K-1, K-1 )-H( K, K ) ) )
               S = AA + AB
               IF( BA*( AB / S ).LE.MAX( SMLNUM,
     $             ULP*( BB*( AA / S ) ) ) )GO TO 40
            END IF
   30    CONTINUE
   40    CONTINUE
         L = K
         IF( L.GT.ILO ) THEN
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">           H(L,L-1) is negligible
</span><span class="comment">*</span><span class="comment">
</span>            H( L, L-1 ) = ZERO
         END IF
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">        Exit from loop if a submatrix of order 1 or 2 has split off.
</span><span class="comment">*</span><span class="comment">
</span>         IF( L.GE.I-1 )
     $      GO TO 150
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">        Now the active submatrix is in rows and columns L to I. If
</span><span class="comment">*</span><span class="comment">        eigenvalues only are being computed, only the active submatrix
</span><span class="comment">*</span><span class="comment">        need be transformed.
</span><span class="comment">*</span><span class="comment">
</span>         IF( .NOT.WANTT ) THEN
            I1 = L
            I2 = I
         END IF
<span class="comment">*</span><span class="comment">
</span>         IF( ITS.EQ.10 .OR. ITS.EQ.20 ) THEN
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">           Exceptional shift.
</span><span class="comment">*</span><span class="comment">
</span>            H11 = DAT1*S + H( I, I )
            H12 = DAT2*S
            H21 = S
            H22 = H11
         ELSE
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">           Prepare to use Francis' double shift
</span><span class="comment">*</span><span class="comment">           (i.e. 2nd degree generalized Rayleigh quotient)
</span><span class="comment">*</span><span class="comment">
</span>            H11 = H( I-1, I-1 )
            H21 = H( I, I-1 )
            H12 = H( I-1, I )
            H22 = H( I, I )
         END IF
         S = ABS( H11 ) + ABS( H12 ) + ABS( H21 ) + ABS( H22 )
         IF( S.EQ.ZERO ) THEN
            RT1R = ZERO
            RT1I = ZERO
            RT2R = ZERO
            RT2I = ZERO
         ELSE
            H11 = H11 / S
            H21 = H21 / S
            H12 = H12 / S
            H22 = H22 / S
            TR = ( H11+H22 ) / TWO
            DET = ( H11-TR )*( H22-TR ) - H12*H21
            RTDISC = SQRT( ABS( DET ) )
            IF( DET.GE.ZERO ) THEN
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">              ==== complex conjugate shifts ====
</span><span class="comment">*</span><span class="comment">
</span>               RT1R = TR*S
               RT2R = RT1R
               RT1I = RTDISC*S
               RT2I = -RT1I
            ELSE
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">              ==== real shifts (use only one of them)  ====
</span><span class="comment">*</span><span class="comment">
</span>               RT1R = TR + RTDISC
               RT2R = TR - RTDISC
               IF( ABS( RT1R-H22 ).LE.ABS( RT2R-H22 ) ) THEN
                  RT1R = RT1R*S
                  RT2R = RT1R
               ELSE
                  RT2R = RT2R*S
                  RT1R = RT2R
               END IF
               RT1I = ZERO
               RT2I = ZERO
            END IF
         END IF
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">        Look for two consecutive small subdiagonal elements.
</span><span class="comment">*</span><span class="comment">
</span>         DO 50 M = I - 2, L, -1
<span class="comment">*</span><span class="comment">           Determine the effect of starting the double-shift QR
</span><span class="comment">*</span><span class="comment">           iteration at row M, and see if this would make H(M,M-1)
</span><span class="comment">*</span><span class="comment">           negligible.  (The following uses scaling to avoid
</span><span class="comment">*</span><span class="comment">           overflows and most underflows.)
</span><span class="comment">*</span><span class="comment">