slarrd.f.html

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

            END IF
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">           Copy eigenvalues into W and IBLOCK
</span><span class="comment">*</span><span class="comment">           Use -JBLK for block number for unconverged eigenvalues.
</span><span class="comment">*</span><span class="comment">           Loop over the number of output intervals from <a name="SLAEBZ.541"></a><a href="slaebz.f.html#SLAEBZ.1">SLAEBZ</a>
</span>            DO 60 J = 1, IOUT
<span class="comment">*</span><span class="comment">              eigenvalue approximation is middle point of interval
</span>               TMP1 = HALF*( WORK( J+N )+WORK( J+IN+N ) )
<span class="comment">*</span><span class="comment">              semi length of error interval
</span>               TMP2 = HALF*ABS( WORK( J+N )-WORK( J+IN+N ) )
               IF( J.GT.IOUT-IINFO ) THEN
<span class="comment">*</span><span class="comment">                 Flag non-convergence.
</span>                  NCNVRG = .TRUE.
                  IB = -JBLK
               ELSE
                  IB = JBLK
               END IF
               DO 50 JE = IWORK( J ) + 1 + IWOFF,
     $                 IWORK( J+IN ) + IWOFF
                  W( JE ) = TMP1
                  WERR( JE ) = TMP2
                  INDEXW( JE ) = JE - IWOFF
                  IBLOCK( JE ) = IB
   50          CONTINUE
   60       CONTINUE
<span class="comment">*</span><span class="comment">
</span>            M = M + IM
         END IF
   70 CONTINUE

<span class="comment">*</span><span class="comment">     If RANGE='I', then (WL,WU) contains eigenvalues NWL+1,...,NWU
</span><span class="comment">*</span><span class="comment">     If NWL+1 &lt; IL or NWU &gt; IU, discard extra eigenvalues.
</span>      IF( IRANGE.EQ.INDRNG ) THEN
         IDISCL = IL - 1 - NWL
         IDISCU = NWU - IU
<span class="comment">*</span><span class="comment">
</span>         IF( IDISCL.GT.0 ) THEN
            IM = 0
            DO 80 JE = 1, M
<span class="comment">*</span><span class="comment">              Remove some of the smallest eigenvalues from the left so that
</span><span class="comment">*</span><span class="comment">              at the end IDISCL =0. Move all eigenvalues up to the left.
</span>               IF( W( JE ).LE.WLU .AND. IDISCL.GT.0 ) THEN
                  IDISCL = IDISCL - 1
               ELSE
                  IM = IM + 1
                  W( IM ) = W( JE )
                  WERR( IM ) = WERR( JE )
                  INDEXW( IM ) = INDEXW( JE )
                  IBLOCK( IM ) = IBLOCK( JE )
               END IF
 80         CONTINUE
            M = IM
         END IF
         IF( IDISCU.GT.0 ) THEN
<span class="comment">*</span><span class="comment">           Remove some of the largest eigenvalues from the right so that
</span><span class="comment">*</span><span class="comment">           at the end IDISCU =0. Move all eigenvalues up to the left.
</span>            IM=M+1
            DO 81 JE = M, 1, -1
               IF( W( JE ).GE.WUL .AND. IDISCU.GT.0 ) THEN
                  IDISCU = IDISCU - 1
               ELSE
                  IM = IM - 1
                  W( IM ) = W( JE )
                  WERR( IM ) = WERR( JE )
                  INDEXW( IM ) = INDEXW( JE )
                  IBLOCK( IM ) = IBLOCK( JE )
               END IF
 81         CONTINUE
            JEE = 0
            DO 82 JE = IM, M
               JEE = JEE + 1
               W( JEE ) = W( JE )
               WERR( JEE ) = WERR( JE )
               INDEXW( JEE ) = INDEXW( JE )
               IBLOCK( JEE ) = IBLOCK( JE )
 82         CONTINUE
            M = M-IM+1
         END IF

         IF( IDISCL.GT.0 .OR. IDISCU.GT.0 ) THEN
<span class="comment">*</span><span class="comment">           Code to deal with effects of bad arithmetic. (If N(w) is
</span><span class="comment">*</span><span class="comment">           monotone non-decreasing, this should never happen.)
</span><span class="comment">*</span><span class="comment">           Some low eigenvalues to be discarded are not in (WL,WLU],
</span><span class="comment">*</span><span class="comment">           or high eigenvalues to be discarded are not in (WUL,WU]
</span><span class="comment">*</span><span class="comment">           so just kill off the smallest IDISCL/largest IDISCU
</span><span class="comment">*</span><span class="comment">           eigenvalues, by marking the corresponding IBLOCK = 0
</span>            IF( IDISCL.GT.0 ) THEN
               WKILL = WU
               DO 100 JDISC = 1, IDISCL
                  IW = 0
                  DO 90 JE = 1, M
                     IF( IBLOCK( JE ).NE.0 .AND.
     $                    ( W( JE ).LT.WKILL .OR. IW.EQ.0 ) ) THEN
                        IW = JE
                        WKILL = W( JE )
                     END IF
 90               CONTINUE
                  IBLOCK( IW ) = 0
 100           CONTINUE
            END IF
            IF( IDISCU.GT.0 ) THEN
               WKILL = WL
               DO 120 JDISC = 1, IDISCU
                  IW = 0
                  DO 110 JE = 1, M
                     IF( IBLOCK( JE ).NE.0 .AND.
     $                    ( W( JE ).GE.WKILL .OR. IW.EQ.0 ) ) THEN
                        IW = JE
                        WKILL = W( JE )
                     END IF
 110              CONTINUE
                  IBLOCK( IW ) = 0
 120           CONTINUE
            END IF
<span class="comment">*</span><span class="comment">           Now erase all eigenvalues with IBLOCK set to zero
</span>            IM = 0
            DO 130 JE = 1, M
               IF( IBLOCK( JE ).NE.0 ) THEN
                  IM = IM + 1
                  W( IM ) = W( JE )
                  WERR( IM ) = WERR( JE )
                  INDEXW( IM ) = INDEXW( JE )
                  IBLOCK( IM ) = IBLOCK( JE )
               END IF
 130        CONTINUE
            M = IM
         END IF
         IF( IDISCL.LT.0 .OR. IDISCU.LT.0 ) THEN
            TOOFEW = .TRUE.
         END IF
      END IF
<span class="comment">*</span><span class="comment">
</span>      IF(( IRANGE.EQ.ALLRNG .AND. M.NE.N ).OR.
     $   ( IRANGE.EQ.INDRNG .AND. M.NE.IU-IL+1 ) ) THEN
         TOOFEW = .TRUE.
      END IF

<span class="comment">*</span><span class="comment">     If ORDER='B', do nothing the eigenvalues are already sorted by
</span><span class="comment">*</span><span class="comment">        block.
</span><span class="comment">*</span><span class="comment">     If ORDER='E', sort the eigenvalues from smallest to largest
</span>
      IF( <a name="LSAME.678"></a><a href="lsame.f.html#LSAME.1">LSAME</a>(ORDER,<span class="string">'E'</span>) .AND. NSPLIT.GT.1 ) THEN
         DO 150 JE = 1, M - 1
            IE = 0
            TMP1 = W( JE )
            DO 140 J = JE + 1, M
               IF( W( J ).LT.TMP1 ) THEN
                  IE = J
                  TMP1 = W( J )
               END IF
  140       CONTINUE
            IF( IE.NE.0 ) THEN
               TMP2 = WERR( IE )
               ITMP1 = IBLOCK( IE )
               ITMP2 = INDEXW( IE )
               W( IE ) = W( JE )
               WERR( IE ) = WERR( JE )
               IBLOCK( IE ) = IBLOCK( JE )
               INDEXW( IE ) = INDEXW( JE )
               W( JE ) = TMP1
               WERR( JE ) = TMP2
               IBLOCK( JE ) = ITMP1
               INDEXW( JE ) = ITMP2
            END IF
  150    CONTINUE
      END IF
<span class="comment">*</span><span class="comment">
</span>      INFO = 0
      IF( NCNVRG )
     $   INFO = INFO + 1
      IF( TOOFEW )
     $   INFO = INFO + 2
      RETURN
<span class="comment">*</span><span class="comment">
</span><span class="comment">*</span><span class="comment">     End of <a name="SLARRD.711"></a><a href="slarrd.f.html#SLARRD.1">SLARRD</a>
</span><span class="comment">*</span><span class="comment">
</span>      END

</pre>

 </body>
</html>