LAPACK: SRC/zlaqr5.f Source File

00001       SUBROUTINE ZLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, S,
00002      $                   H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, LDU, NV,
00003      $                   WV, LDWV, NH, WH, LDWH )
00004 *
00005 *  -- LAPACK auxiliary routine (version 3.2) --
00006 *     Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..
00007 *     November 2006
00008 *
00009 *     .. Scalar Arguments ..
00010       INTEGER            IHIZ, ILOZ, KACC22, KBOT, KTOP, LDH, LDU, LDV,
00011      $                   LDWH, LDWV, LDZ, N, NH, NSHFTS, NV
00012       LOGICAL            WANTT, WANTZ
00013 *     ..
00014 *     .. Array Arguments ..
00015       COMPLEX*16         H( LDH, * ), S( * ), U( LDU, * ), V( LDV, * ),
00016      $                   WH( LDWH, * ), WV( LDWV, * ), Z( LDZ, * )
00017 *     ..
00018 *
00019 *     This auxiliary subroutine called by ZLAQR0 performs a
00020 *     single small-bulge multi-shift QR sweep.
00021 *
00022 *      WANTT  (input) logical scalar
00023 *             WANTT = .true. if the triangular Schur factor
00024 *             is being computed.  WANTT is set to .false. otherwise.
00025 *
00026 *      WANTZ  (input) logical scalar
00027 *             WANTZ = .true. if the unitary Schur factor is being
00028 *             computed.  WANTZ is set to .false. otherwise.
00029 *
00030 *      KACC22 (input) integer with value 0, 1, or 2.
00031 *             Specifies the computation mode of far-from-diagonal
00032 *             orthogonal updates.
00033 *        = 0: ZLAQR5 does not accumulate reflections and does not
00034 *             use matrix-matrix multiply to update far-from-diagonal
00035 *             matrix entries.
00036 *        = 1: ZLAQR5 accumulates reflections and uses matrix-matrix
00037 *             multiply to update the far-from-diagonal matrix entries.
00038 *        = 2: ZLAQR5 accumulates reflections, uses matrix-matrix
00039 *             multiply to update the far-from-diagonal matrix entries,
00040 *             and takes advantage of 2-by-2 block structure during
00041 *             matrix multiplies.
00042 *
00043 *      N      (input) integer scalar
00044 *             N is the order of the Hessenberg matrix H upon which this
00045 *             subroutine operates.
00046 *
00047 *      KTOP   (input) integer scalar
00048 *      KBOT   (input) integer scalar
00049 *             These are the first and last rows and columns of an
00050 *             isolated diagonal block upon which the QR sweep is to be
00051 *             applied. It is assumed without a check that
00052 *                       either KTOP = 1  or   H(KTOP,KTOP-1) = 0
00053 *             and
00054 *                       either KBOT = N  or   H(KBOT+1,KBOT) = 0.
00055 *
00056 *      NSHFTS (input) integer scalar
00057 *             NSHFTS gives the number of simultaneous shifts.  NSHFTS
00058 *             must be positive and even.
00059 *
00060 *      S      (input/output) COMPLEX*16 array of size (NSHFTS)
00061 *             S contains the shifts of origin that define the multi-
00062 *             shift QR sweep.  On output S may be reordered.
00063 *
00064 *      H      (input/output) COMPLEX*16 array of size (LDH,N)
00065 *             On input H contains a Hessenberg matrix.  On output a
00066 *             multi-shift QR sweep with shifts SR(J)+i*SI(J) is applied
00067 *             to the isolated diagonal block in rows and columns KTOP
00068 *             through KBOT.
00069 *
00070 *      LDH    (input) integer scalar
00071 *             LDH is the leading dimension of H just as declared in the
00072 *             calling procedure.  LDH.GE.MAX(1,N).
00073 *
00074 *      ILOZ   (input) INTEGER
00075 *      IHIZ   (input) INTEGER
00076 *             Specify the rows of Z to which transformations must be
00077 *             applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N
00078 *
00079 *      Z      (input/output) COMPLEX*16 array of size (LDZ,IHI)
00080 *             If WANTZ = .TRUE., then the QR Sweep unitary
00081 *             similarity transformation is accumulated into
00082 *             Z(ILOZ:IHIZ,ILO:IHI) from the right.
00083 *             If WANTZ = .FALSE., then Z is unreferenced.
00084 *
00085 *      LDZ    (input) integer scalar
00086 *             LDA is the leading dimension of Z just as declared in
00087 *             the calling procedure. LDZ.GE.N.
00088 *
00089 *      V      (workspace) COMPLEX*16 array of size (LDV,NSHFTS/2)
00090 *
00091 *      LDV    (input) integer scalar
00092 *             LDV is the leading dimension of V as declared in the
00093 *             calling procedure.  LDV.GE.3.
00094 *
00095 *      U      (workspace) COMPLEX*16 array of size
00096 *             (LDU,3*NSHFTS-3)
00097 *
00098 *      LDU    (input) integer scalar
00099 *             LDU is the leading dimension of U just as declared in the
00100 *             in the calling subroutine.  LDU.GE.3*NSHFTS-3.
00101 *
00102 *      NH     (input) integer scalar
00103 *             NH is the number of columns in array WH available for
00104 *             workspace. NH.GE.1.
00105 *
00106 *      WH     (workspace) COMPLEX*16 array of size (LDWH,NH)
00107 *
00108 *      LDWH   (input) integer scalar
00109 *             Leading dimension of WH just as declared in the
00110 *             calling procedure.  LDWH.GE.3*NSHFTS-3.
00111 *
00112 *      NV     (input) integer scalar
00113 *             NV is the number of rows in WV agailable for workspace.
00114 *             NV.GE.1.
00115 *
00116 *      WV     (workspace) COMPLEX*16 array of size
00117 *             (LDWV,3*NSHFTS-3)
00118 *
00119 *      LDWV   (input) integer scalar
00120 *             LDWV is the leading dimension of WV as declared in the
00121 *             in the calling subroutine.  LDWV.GE.NV.
00122 *
00123 *     ================================================================
00124 *     Based on contributions by
00125 *        Karen Braman and Ralph Byers, Department of Mathematics,
00126 *        University of Kansas, USA
00127 *
00128 *     ================================================================
00129 *     Reference:
00130 *
00131 *     K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
00132 *     Algorithm Part I: Maintaining Well Focused Shifts, and
00133 *     Level 3 Performance, SIAM Journal of Matrix Analysis,
00134 *     volume 23, pages 929--947, 2002.
00135 *
00136 *     ================================================================
00137 *     .. Parameters ..
00138       COMPLEX*16         ZERO, ONE
00139       PARAMETER          ( ZERO = ( 0.0d0, 0.0d0 ),
00140      $                   ONE = ( 1.0d0, 0.0d0 ) )
00141       DOUBLE PRECISION   RZERO, RONE
00142       PARAMETER          ( RZERO = 0.0d0, RONE = 1.0d0 )
00143 *     ..
00144 *     .. Local Scalars ..
00145       COMPLEX*16         ALPHA, BETA, CDUM, REFSUM
00146       DOUBLE PRECISION   H11, H12, H21, H22, SAFMAX, SAFMIN, SCL,
00147      $                   SMLNUM, TST1, TST2, ULP
00148       INTEGER            I2, I4, INCOL, J, J2, J4, JBOT, JCOL, JLEN,
00149      $                   JROW, JTOP, K, K1, KDU, KMS, KNZ, KRCOL, KZS,
00150      $                   M, M22, MBOT, MEND, MSTART, MTOP, NBMPS, NDCOL,
00151      $                   NS, NU
00152       LOGICAL            ACCUM, BLK22, BMP22
00153 *     ..
00154 *     .. External Functions ..
00155       DOUBLE PRECISION   DLAMCH
00156       EXTERNAL           DLAMCH
00157 *     ..
00158 *     .. Intrinsic Functions ..
00159 *
00160       INTRINSIC          ABS, DBLE, DCONJG, DIMAG, MAX, MIN, MOD
00161 *     ..
00162 *     .. Local Arrays ..
00163       COMPLEX*16         VT( 3 )
00164 *     ..
00165 *     .. External Subroutines ..
00166       EXTERNAL           DLABAD, ZGEMM, ZLACPY, ZLAQR1, ZLARFG, ZLASET,
00167      $                   ZTRMM
00168 *     ..
00169 *     .. Statement Functions ..
00170       DOUBLE PRECISION   CABS1
00171 *     ..
00172 *     .. Statement Function definitions ..
00173       CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) )
00174 *     ..
00175 *     .. Executable Statements ..
00176 *
00177 *     ==== If there are no shifts, then there is nothing to do. ====
00178 *
00179       IF( NSHFTS.LT.2 )
00180      $   RETURN
00181 *
00182 *     ==== If the active block is empty or 1-by-1, then there
00183 *     .    is nothing to do. ====
00184 *
00185       IF( KTOP.GE.KBOT )
00186      $   RETURN
00187 *
00188 *     ==== NSHFTS is supposed to be even, but if it is odd,
00189 *     .    then simply reduce it by one.  ====
00190 *
00191       NS = NSHFTS - MOD( NSHFTS, 2 )
00192 *
00193 *     ==== Machine constants for deflation ====
00194 *
00195       SAFMIN = DLAMCH( 'SAFE MINIMUM' )
00196       SAFMAX = RONE / SAFMIN
00197       CALL DLABAD( SAFMIN, SAFMAX )
00198       ULP = DLAMCH( 'PRECISION' )
00199       SMLNUM = SAFMIN*( DBLE( N ) / ULP )
00200 *
00201 *     ==== Use accumulated reflections to update far-from-diagonal
00202 *     .    entries ? ====
00203 *
00204       ACCUM = ( KACC22.EQ.1 ) .OR. ( KACC22.EQ.2 )
00205 *
00206 *     ==== If so, exploit the 2-by-2 block structure? ====
00207 *
00208       BLK22 = ( NS.GT.2 ) .AND. ( KACC22.EQ.2 )
00209 *
00210 *     ==== clear trash ====
00211 *
00212       IF( KTOP+2.LE.KBOT )
00213      $   H( KTOP+2, KTOP ) = ZERO
00214 *
00215 *     ==== NBMPS = number of 2-shift bulges in the chain ====
00216 *
00217       NBMPS = NS / 2
00218 *
00219 *     ==== KDU = width of slab ====
00220 *
00221       KDU = 6*NBMPS - 3
00222 *
00223 *     ==== Create and chase chains of NBMPS bulges ====
00224 *
00225       DO 210 INCOL = 3*( 1-NBMPS ) + KTOP - 1, KBOT - 2, 3*NBMPS - 2
00226          NDCOL = INCOL + KDU
00227          IF( ACCUM )
00228      $      CALL ZLASET( 'ALL', KDU, KDU, ZERO, ONE, U, LDU )
00229 *
00230 *        ==== Near-the-diagonal bulge chase.  The following loop
00231 *        .    performs the near-the-diagonal part of a small bulge
00232 *        .    multi-shift QR sweep.  Each 6*NBMPS-2 column diagonal
00233 *        .    chunk extends from column INCOL to column NDCOL
00234 *        .    (including both column INCOL and column NDCOL). The
00235 *        .    following loop chases a 3*NBMPS column long chain of
00236 *        .    NBMPS bulges 3*NBMPS-2 columns to the right.  (INCOL
00237 *        .    may be less than KTOP and and NDCOL may be greater than
00238 *        .    KBOT indicating phantom columns from which to chase
00239 *        .    bulges before they are actually introduced or to which
00240 *        .    to chase bulges beyond column KBOT.)  ====
00241 *
00242          DO 140 KRCOL = INCOL, MIN( INCOL+3*NBMPS-3, KBOT-2 )
00243 *
00244 *           ==== Bulges number MTOP to MBOT are active double implicit
00245 *           .    shift bulges.  There may or may not also be small
00246 *           .    2-by-2 bulge, if there is room.  The inactive bulges
00247 *           .    (if any) must wait until the active bulges have moved
00248 *           .    down the diagonal to make room.  The phantom matrix
00249 *           .    paradigm described above helps keep track.  ====
00250 *
00251             MTOP = MAX( 1, ( ( KTOP-1 )-KRCOL+2 ) / 3+1 )
00252             MBOT = MIN( NBMPS, ( KBOT-KRCOL ) / 3 )
00253             M22 = MBOT + 1
00254             BMP22 = ( MBOT.LT.NBMPS ) .AND. ( KRCOL+3*( M22-1 ) ).EQ.
00255      $              ( KBOT-2 )
00256 *
00257 *           ==== Generate reflections to chase the chain right
00258 *           .    one column.  (The minimum value of K is KTOP-1.) ====
00259 *
00260             DO 10 M = MTOP, MBOT
00261                K = KRCOL + 3*( M-1 )
00262                IF( K.EQ.KTOP-1 ) THEN
00263                   CALL ZLAQR1( 3, H( KTOP, KTOP ), LDH, S( 2*M-1 ),
00264      $                         S( 2*M ), V( 1, M ) )
00265                   ALPHA = V( 1, M )
00266                   CALL ZLARFG( 3, ALPHA, V( 2, M ), 1, V( 1, M ) )
00267                ELSE
00268                   BETA = H( K+1, K )
00269                   V( 2, M ) = H( K+2, K )
00270                   V( 3, M ) = H( K+3, K )
00271                   CALL ZLARFG( 3, BETA, V( 2, M ), 1, V( 1, M ) )
00272 *
00273 *                 ==== A Bulge may collapse because of vigilant
00274 *                 .    deflation or destructive underflow.  In the
00275 *                 .    underflow case, try the two-small-subdiagonals
00276 *                 .    trick to try to reinflate the bulge.  ====
00277 *
00278                   IF( H( K+3, K ).NE.ZERO .OR. H( K+3, K+1 ).NE.
00279      $                ZERO .OR. H( K+3, K+2 ).EQ.ZERO ) THEN
00280 *
00281 *                    ==== Typical case: not collapsed (yet). ====
00282 *
00283                      H( K+1, K ) = BETA
00284                      H( K+2, K ) = ZERO
00285                      H( K+3, K ) = ZERO
00286                   ELSE
00287 *
00288 *                    ==== Atypical case: collapsed.  Attempt to
00289 *                    .    reintroduce ignoring H(K+1,K) and H(K+2,K).
00290 *                    .    If the fill resulting from the new
00291 *                    .    reflector is too large, then abandon it.
00292 *                    .    Otherwise, use the new one. ====
00293 *
00294                      CALL ZLAQR1( 3, H( K+1, K+1 ), LDH, S( 2*M-1 ),
00295      $                            S( 2*M ), VT )
00296                      ALPHA = VT( 1 )
00297                      CALL ZLARFG( 3, ALPHA, VT( 2 ), 1, VT( 1 ) )
00298                      REFSUM = DCONJG( VT( 1 ) )*
00299      $                        ( H( K+1, K )+DCONJG( VT( 2 ) )*
00300      $                        H( K+2, K ) )
00301 *
00302                      IF( CABS1( H( K+2, K )-REFSUM*VT( 2 ) )+
00303      $                   CABS1( REFSUM*VT( 3 ) ).GT.ULP*
00304      $                   ( CABS1( H( K, K ) )+CABS1( H( K+1,
00305      $                   K+1 ) )+CABS1( H( K+2, K+2 ) ) ) ) THEN
00306 *
00307 *                       ==== Starting a new bulge here would
00308 *                       .    create non-negligible fill.  Use
00309 *                       .    the old one with trepidation. ====
00310 *
00311                         H( K+1, K ) = BETA
00312                         H( K+2, K ) = ZERO
00313                         H( K+3, K ) = ZERO
00314                      ELSE
00315 *
00316 *                       ==== Stating a new bulge here would
00317 *                       .    create only negligible fill.
00318 *                       .    Replace the old reflector with
00319 *                       .    the new one. ====
00320 *
00321                         H( K+1, K ) = H( K+1, K ) - REFSUM
00322                         H( K+2, K ) = ZERO
00323                         H( K+3, K ) = ZERO
00324                         V( 1, M ) = VT( 1 )
00325                         V( 2, M ) = VT( 2 )
00326                         V( 3, M ) = VT( 3 )
00327                      END IF
00328                   END IF
00329                END IF
00330    10       CONTINUE
00331 *
00332 *           ==== Generate a 2-by-2 reflection, if needed. ====
00333 *
00334             K = KRCOL + 3*( M22-1 )
00335             IF( BMP22 ) THEN
00336                IF( K.EQ.KTOP-1 ) THEN
00337                   CALL ZLAQR1( 2, H( K+1, K+1 ), LDH, S( 2*M22-1 ),
00338      $                         S( 2*M22 ), V( 1, M22 ) )
00339                   BETA = V( 1, M22 )
00340                   CALL ZLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) )
00341                ELSE
00342                   BETA = H( K+1, K )
00343                   V( 2, M22 ) = H( K+2, K )
00344                   CALL ZLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) )
00345                   H( K+1, K ) = BETA
00346                   H( K+2, K ) = ZERO
00347                END IF
00348             END IF
00349 *
00350 *           ==== Multiply H by reflections from the left ====
00351 *
00352             IF( ACCUM ) THEN
00353                JBOT = MIN( NDCOL, KBOT )
00354             ELSE IF( WANTT ) THEN
00355                JBOT = N
00356             ELSE
00357                JBOT = KBOT
00358             END IF
00359             DO 30 J = MAX( KTOP, KRCOL ), JBOT
00360                MEND = MIN( MBOT, ( J-KRCOL+2 ) / 3 )
00361                DO 20 M = MTOP, MEND
00362                   K = KRCOL + 3*( M-1 )
00363                   REFSUM = DCONJG( V( 1, M ) )*
00364      $                     ( H( K+1, J )+DCONJG( V( 2, M ) )*
00365      $                     H( K+2, J )+DCONJG( V( 3, M ) )*H( K+3, J ) )
00366                   H( K+1, J ) = H( K+1, J ) - REFSUM
00367                   H( K+2, J ) = H( K+2, J ) - REFSUM*V( 2, M )
00368                   H( K+3, J ) = H( K+3, J ) - REFSUM*V( 3, M )
00369    20          CONTINUE
00370    30       CONTINUE
00371             IF( BMP22 ) THEN
00372                K = KRCOL + 3*( M22-1 )
00373                DO 40 J = MAX( K+1, KTOP ), JBOT
00374                   REFSUM = DCONJG( V( 1, M22 ) )*
00375      $                     ( H( K+1, J )+DCONJG( V( 2, M22 ) )*
00376      $                     H( K+2, J ) )
00377                   H( K+1, J ) = H( K+1, J ) - REFSUM
00378                   H( K+2, J ) = H( K+2, J ) - REFSUM*V( 2, M22 )
00379    40          CONTINUE
00380             END IF
00381 *
00382 *           ==== Multiply H by reflections from the right.
00383 *           .    Delay filling in the last row until the
00384 *           .    vigilant deflation check is complete. ====
00385 *
00386             IF( ACCUM ) THEN
00387                JTOP = MAX( KTOP, INCOL )
00388             ELSE IF( WANTT ) THEN
00389                JTOP = 1
00390             ELSE
00391                JTOP = KTOP
00392             END IF
00393             DO 80 M = MTOP, MBOT
00394                IF( V( 1, M ).NE.ZERO ) THEN
00395                   K = KRCOL + 3*( M-1 )
00396                   DO 50 J = JTOP, MIN( KBOT, K+3 )
00397                      REFSUM = V( 1, M )*( H( J, K+1 )+V( 2, M )*
00398      $                        H( J, K+2 )+V( 3, M )*H( J, K+3 ) )
00399                      H( J, K+1 ) = H( J, K+1 ) - REFSUM
00400                      H( J, K+2 ) = H( J, K+2 ) -
00401      $                             REFSUM*DCONJG( V( 2, M ) )
00402                      H( J, K+3 ) = H( J, K+3 ) -
00403      $                             REFSUM*DCONJG( V( 3, M ) )
00404    50             CONTINUE
00405 *
00406                   IF( ACCUM ) THEN
00407 *
00408 *                    ==== Accumulate U. (If necessary, update Z later
00409 *                    .    with with an efficient matrix-matrix
00410 *                    .    multiply.) ====
00411 *
00412                      KMS = K - INCOL
00413                      DO 60 J = MAX( 1, KTOP-INCOL ), KDU
00414                         REFSUM = V( 1, M )*( U( J, KMS+1 )+V( 2, M )*
00415      $                           U( J, KMS+2 )+V( 3, M )*U( J, KMS+3 ) )
00416                         U( J, KMS+1 ) = U( J, KMS+1 ) - REFSUM
00417                         U( J, KMS+2 ) = U( J, KMS+2 ) -
00418      $                                  REFSUM*DCONJG( V( 2, M ) )
00419                         U( J, KMS+3 ) = U( J, KMS+3 ) -
00420      $                                  REFSUM*DCONJG( V( 3, M ) )
00421    60                CONTINUE
00422                   ELSE IF( WANTZ ) THEN
00423 *
00424 *                    ==== U is not accumulated, so update Z
00425 *                    .    now by multiplying by reflections
00426 *                    .    from the right. ====
00427 *
00428                      DO 70 J = ILOZ, IHIZ
00429                         REFSUM = V( 1, M )*( Z( J, K+1 )+V( 2, M )*
00430      $                           Z( J, K+2 )+V( 3, M )*Z( J, K+3 ) )
00431                         Z( J, K+1 ) = Z( J, K+1 ) - REFSUM
00432                         Z( J, K+2 ) = Z( J, K+2 ) -
00433      $                                REFSUM*DCONJG( V( 2, M ) )
00434                         Z( J, K+3 ) = Z( J, K+3 ) -
00435      $                                REFSUM*DCONJG( V( 3, M ) )
00436    70                CONTINUE
00437                   END IF
00438                END IF
00439    80       CONTINUE
00440 *
00441 *           ==== Special case: 2-by-2 reflection (if needed) ====
00442 *
00443             K = KRCOL + 3*( M22-1 )
00444             IF( BMP22 .AND. ( V( 1, M22 ).NE.ZERO ) ) THEN
00445                DO 90 J = JTOP, MIN( KBOT, K+3 )
00446                   REFSUM = V( 1, M22 )*( H( J, K+1 )+V( 2, M22 )*
00447      $                     H( J, K+2 ) )
00448                   H( J, K+1 ) = H( J, K+1 ) - REFSUM
00449                   H( J, K+2 ) = H( J, K+2 ) -
00450      $                          REFSUM*DCONJG( V( 2, M22 ) )
00451    90          CONTINUE
00452 *
00453                IF( ACCUM ) THEN
00454                   KMS = K - INCOL
00455                   DO 100 J = MAX( 1, KTOP-INCOL ), KDU
00456                      REFSUM = V( 1, M22 )*( U( J, KMS+1 )+V( 2, M22 )*
00457      $                        U( J, KMS+2 ) )
00458                      U( J, KMS+1 ) = U( J, KMS+1 ) - REFSUM
00459                      U( J, KMS+2 ) = U( J, KMS+2 ) -
00460      $                               REFSUM*DCONJG( V( 2, M22 ) )
00461   100             CONTINUE
00462                ELSE IF( WANTZ ) THEN
00463                   DO 110 J = ILOZ, IHIZ
00464                      REFSUM = V( 1, M22 )*( Z( J, K+1 )+V( 2, M22 )*
00465      $                        Z( J, K+2 ) )
00466                      Z( J, K+1 ) = Z( J, K+1 ) - REFSUM
00467                      Z( J, K+2 ) = Z( J, K+2 ) -
00468      $                             REFSUM*DCONJG( V( 2, M22 ) )
00469   110             CONTINUE
00470                END IF
00471             END IF
00472 *
00473 *           ==== Vigilant deflation check ====
00474 *
00475             MSTART = MTOP
00476             IF( KRCOL+3*( MSTART-1 ).LT.KTOP )
00477      $         MSTART = MSTART + 1
00478             MEND = MBOT
00479             IF( BMP22 )
00480      $         MEND = MEND + 1
00481             IF( KRCOL.EQ.KBOT-2 )
00482      $         MEND = MEND + 1
00483             DO 120 M = MSTART, MEND
00484                K = MIN( KBOT-1, KRCOL+3*( M-1 ) )
00485 *
00486 *              ==== The following convergence test requires that
00487 *              .    the tradition small-compared-to-nearby-diagonals
00488 *              .    criterion and the Ahues & Tisseur (LAWN 122, 1997)
00489 *              .    criteria both be satisfied.  The latter improves
00490 *              .    accuracy in some examples. Falling back on an
00491 *              .    alternate convergence criterion when TST1 or TST2
00492 *              .    is zero (as done here) is traditional but probably
00493 *              .    unnecessary. ====
00494 *
00495                IF( H( K+1, K ).NE.ZERO ) THEN
00496                   TST1 = CABS1( H( K, K ) ) + CABS1( H( K+1, K+1 ) )
00497                   IF( TST1.EQ.RZERO ) THEN
00498                      IF( K.GE.KTOP+1 )
00499      $                  TST1 = TST1 + CABS1( H( K, K-1 ) )
00500                      IF( K.GE.KTOP+2 )
00501      $                  TST1 = TST1 + CABS1( H( K, K-2 ) )
00502                      IF( K.GE.KTOP+3 )
00503      $                  TST1 = TST1 + CABS1( H( K, K-3 ) )
00504                      IF( K.LE.KBOT-2 )
00505      $                  TST1 = TST1 + CABS1( H( K+2, K+1 ) )
00506                      IF( K.LE.KBOT-3 )
00507      $                  TST1 = TST1 + CABS1( H( K+3, K+1 ) )
00508                      IF( K.LE.KBOT-4 )
00509      $                  TST1 = TST1 + CABS1( H( K+4, K+1 ) )
00510                   END IF
00511                   IF( CABS1( H( K+1, K ) ).LE.MAX( SMLNUM, ULP*TST1 ) )
00512      $                 THEN
00513                      H12 = MAX( CABS1( H( K+1, K ) ),
00514      $                     CABS1( H( K, K+1 ) ) )
00515                      H21 = MIN( CABS1( H( K+1, K ) ),
00516      $                     CABS1( H( K, K+1 ) ) )
00517                      H11 = MAX( CABS1( H( K+1, K+1 ) ),
00518      $                     CABS1( H( K, K )-H( K+1, K+1 ) ) )
00519                      H22 = MIN( CABS1( H( K+1, K+1 ) ),
00520      $                     CABS1( H( K, K )-H( K+1, K+1 ) ) )
00521                      SCL = H11 + H12
00522                      TST2 = H22*( H11 / SCL )
00523 *
00524                      IF( TST2.EQ.RZERO .OR. H21*( H12 / SCL ).LE.
00525      $                   MAX( SMLNUM, ULP*TST2 ) )H( K+1, K ) = ZERO
00526                   END IF
00527                END IF
00528   120       CONTINUE
00529 *
00530 *           ==== Fill in the last row of each bulge. ====
00531 *
00532             MEND = MIN( NBMPS, ( KBOT-KRCOL-1 ) / 3 )
00533             DO 130 M = MTOP, MEND
00534                K = KRCOL + 3*( M-1 )
00535                REFSUM = V( 1, M )*V( 3, M )*H( K+4, K+3 )
00536                H( K+4, K+1 ) = -REFSUM
00537                H( K+4, K+2 ) = -REFSUM*DCONJG( V( 2, M ) )
00538                H( K+4, K+3 ) = H( K+4, K+3 ) -
00539      $                         REFSUM*DCONJG( V( 3, M ) )
00540   130       CONTINUE
00541 *
00542 *           ==== End of near-the-diagonal bulge chase. ====
00543 *
00544   140    CONTINUE
00545 *
00546 *        ==== Use U (if accumulated) to update far-from-diagonal
00547 *        .    entries in H.  If required, use U to update Z as
00548 *        .    well. ====
00549 *
00550          IF( ACCUM ) THEN
00551             IF( WANTT ) THEN
00552                JTOP = 1
00553                JBOT = N
00554             ELSE
00555                JTOP = KTOP
00556                JBOT = KBOT
00557             END IF
00558             IF( ( .NOT.BLK22 ) .OR. ( INCOL.LT.KTOP ) .OR.
00559      $          ( NDCOL.GT.KBOT ) .OR. ( NS.LE.2 ) ) THEN
00560 *
00561 *              ==== Updates not exploiting the 2-by-2 block
00562 *              .    structure of U.  K1 and NU keep track of
00563 *              .    the location and size of U in the special
00564 *              .    cases of introducing bulges and chasing
00565 *              .    bulges off the bottom.  In these special
00566 *              .    cases and in case the number of shifts
00567 *              .    is NS = 2, there is no 2-by-2 block
00568 *              .    structure to exploit.  ====
00569 *
00570                K1 = MAX( 1, KTOP-INCOL )
00571                NU = ( KDU-MAX( 0, NDCOL-KBOT ) ) - K1 + 1
00572 *
00573 *              ==== Horizontal Multiply ====
00574 *
00575                DO 150 JCOL = MIN( NDCOL, KBOT ) + 1, JBOT, NH
00576                   JLEN = MIN( NH, JBOT-JCOL+1 )
00577                   CALL ZGEMM( 'C', 'N', NU, JLEN, NU, ONE, U( K1, K1 ),
00578      $                        LDU, H( INCOL+K1, JCOL ), LDH, ZERO, WH,
00579      $                        LDWH )
00580                   CALL ZLACPY( 'ALL', NU, JLEN, WH, LDWH,
00581      $                         H( INCOL+K1, JCOL ), LDH )
00582   150          CONTINUE
00583 *
00584 *              ==== Vertical multiply ====
00585 *
00586                DO 160 JROW = JTOP, MAX( KTOP, INCOL ) - 1, NV
00587                   JLEN = MIN( NV, MAX( KTOP, INCOL )-JROW )
00588                   CALL ZGEMM( 'N', 'N', JLEN, NU, NU, ONE,
00589      $                        H( JROW, INCOL+K1 ), LDH, U( K1, K1 ),
00590      $                        LDU, ZERO, WV, LDWV )
00591                   CALL ZLACPY( 'ALL', JLEN, NU, WV, LDWV,
00592      $                         H( JROW, INCOL+K1 ), LDH )
00593   160          CONTINUE
00594 *
00595 *              ==== Z multiply (also vertical) ====
00596 *
00597                IF( WANTZ ) THEN
00598                   DO 170 JROW = ILOZ, IHIZ, NV
00599                      JLEN = MIN( NV, IHIZ-JROW+1 )
00600                      CALL ZGEMM( 'N', 'N', JLEN, NU, NU, ONE,
00601      $                           Z( JROW, INCOL+K1 ), LDZ, U( K1, K1 ),
00602      $                           LDU, ZERO, WV, LDWV )
00603                      CALL ZLACPY( 'ALL', JLEN, NU, WV, LDWV,
00604      $                            Z( JROW, INCOL+K1 ), LDZ )
00605   170             CONTINUE
00606                END IF
00607             ELSE
00608 *
00609 *              ==== Updates exploiting U's 2-by-2 block structure.
00610 *              .    (I2, I4, J2, J4 are the last rows and columns
00611 *              .    of the blocks.) ====
00612 *
00613                I2 = ( KDU+1 ) / 2
00614                I4 = KDU
00615                J2 = I4 - I2
00616                J4 = KDU
00617 *
00618 *              ==== KZS and KNZ deal with the band of zeros
00619 *              .    along the diagonal of one of the triangular
00620 *              .    blocks. ====
00621 *
00622                KZS = ( J4-J2 ) - ( NS+1 )
00623                KNZ = NS + 1
00624 *
00625 *              ==== Horizontal multiply ====
00626 *
00627                DO 180 JCOL = MIN( NDCOL, KBOT ) + 1, JBOT, NH
00628                   JLEN = MIN( NH, JBOT-JCOL+1 )
00629 *
00630 *                 ==== Copy bottom of H to top+KZS of scratch ====
00631 *                  (The first KZS rows get multiplied by zero.) ====
00632 *
00633                   CALL ZLACPY( 'ALL', KNZ, JLEN, H( INCOL+1+J2, JCOL ),
00634      $                         LDH, WH( KZS+1, 1 ), LDWH )
00635 *
00636 *                 ==== Multiply by U21' ====
00637 *
00638                   CALL ZLASET( 'ALL', KZS, JLEN, ZERO, ZERO, WH, LDWH )
00639                   CALL ZTRMM( 'L', 'U', 'C', 'N', KNZ, JLEN, ONE,
00640      $                        U( J2+1, 1+KZS ), LDU, WH( KZS+1, 1 ),
00641      $                        LDWH )
00642 *
00643 *                 ==== Multiply top of H by U11' ====
00644 *
00645                   CALL ZGEMM( 'C', 'N', I2, JLEN, J2, ONE, U, LDU,
00646      $                        H( INCOL+1, JCOL ), LDH, ONE, WH, LDWH )
00647 *
00648 *                 ==== Copy top of H to bottom of WH ====
00649 *
00650                   CALL ZLACPY( 'ALL', J2, JLEN, H( INCOL+1, JCOL ), LDH,
00651      $                         WH( I2+1, 1 ), LDWH )
00652 *
00653 *                 ==== Multiply by U21' ====
00654 *
00655                   CALL ZTRMM( 'L', 'L', 'C', 'N', J2, JLEN, ONE,
00656      $                        U( 1, I2+1 ), LDU, WH( I2+1, 1 ), LDWH )
00657 *
00658 *                 ==== Multiply by U22 ====
00659 *
00660                   CALL ZGEMM( 'C', 'N', I4-I2, JLEN, J4-J2, ONE,
00661      $                        U( J2+1, I2+1 ), LDU,
00662      $                        H( INCOL+1+J2, JCOL ), LDH, ONE,
00663      $                        WH( I2+1, 1 ), LDWH )
00664 *
00665 *                 ==== Copy it back ====
00666 *
00667                   CALL ZLACPY( 'ALL', KDU, JLEN, WH, LDWH,
00668      $                         H( INCOL+1, JCOL ), LDH )
00669   180          CONTINUE
00670 *
00671 *              ==== Vertical multiply ====
00672 *
00673                DO 190 JROW = JTOP, MAX( INCOL, KTOP ) - 1, NV
00674                   JLEN = MIN( NV, MAX( INCOL, KTOP )-JROW )
00675 *
00676 *                 ==== Copy right of H to scratch (the first KZS
00677 *                 .    columns get multiplied by zero) ====
00678 *
00679                   CALL ZLACPY( 'ALL', JLEN, KNZ, H( JROW, INCOL+1+J2 ),
00680      $                         LDH, WV( 1, 1+KZS ), LDWV )
00681 *
00682 *                 ==== Multiply by U21 ====
00683 *
00684                   CALL ZLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV, LDWV )
00685                   CALL ZTRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE,
00686      $                        U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ),
00687      $                        LDWV )
00688 *
00689 *                 ==== Multiply by U11 ====
00690 *
00691                   CALL ZGEMM( 'N', 'N', JLEN, I2, J2, ONE,
00692      $                        H( JROW, INCOL+1 ), LDH, U, LDU, ONE, WV,
00693      $                        LDWV )
00694 *
00695 *                 ==== Copy left of H to right of scratch ====
00696 *
00697                   CALL ZLACPY( 'ALL', JLEN, J2, H( JROW, INCOL+1 ), LDH,
00698      $                         WV( 1, 1+I2 ), LDWV )
00699 *
00700 *                 ==== Multiply by U21 ====
00701 *
00702                   CALL ZTRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE,
00703      $                        U( 1, I2+1 ), LDU, WV( 1, 1+I2 ), LDWV )
00704 *
00705 *                 ==== Multiply by U22 ====
00706 *
00707                   CALL ZGEMM( 'N', 'N', JLEN, I4-I2, J4-J2, ONE,
00708      $                        H( JROW, INCOL+1+J2 ), LDH,
00709      $                        U( J2+1, I2+1 ), LDU, ONE, WV( 1, 1+I2 ),
00710      $                        LDWV )
00711 *
00712 *                 ==== Copy it back ====
00713 *
00714                   CALL ZLACPY( 'ALL', JLEN, KDU, WV, LDWV,
00715      $                         H( JROW, INCOL+1 ), LDH )
00716   190          CONTINUE
00717 *
00718 *              ==== Multiply Z (also vertical) ====
00719 *
00720                IF( WANTZ ) THEN
00721                   DO 200 JROW = ILOZ, IHIZ, NV
00722                      JLEN = MIN( NV, IHIZ-JROW+1 )
00723 *
00724 *                    ==== Copy right of Z to left of scratch (first
00725 *                    .     KZS columns get multiplied by zero) ====
00726 *
00727                      CALL ZLACPY( 'ALL', JLEN, KNZ,
00728      $                            Z( JROW, INCOL+1+J2 ), LDZ,
00729      $                            WV( 1, 1+KZS ), LDWV )
00730 *
00731 *                    ==== Multiply by U12 ====
00732 *
00733                      CALL ZLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV,
00734      $                            LDWV )
00735                      CALL ZTRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE,
00736      $                           U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ),
00737      $                           LDWV )
00738 *
00739 *                    ==== Multiply by U11 ====
00740 *
00741                      CALL ZGEMM( 'N', 'N', JLEN, I2, J2, ONE,
00742      $                           Z( JROW, INCOL+1 ), LDZ, U, LDU, ONE,
00743      $                           WV, LDWV )
00744 *
00745 *                    ==== Copy left of Z to right of scratch ====
00746 *
00747                      CALL ZLACPY( 'ALL', JLEN, J2, Z( JROW, INCOL+1 ),
00748      $                            LDZ, WV( 1, 1+I2 ), LDWV )
00749 *
00750 *                    ==== Multiply by U21 ====
00751 *
00752                      CALL ZTRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE,
00753      $                           U( 1, I2+1 ), LDU, WV( 1, 1+I2 ),
00754      $                           LDWV )
00755 *
00756 *                    ==== Multiply by U22 ====
00757 *
00758                      CALL ZGEMM( 'N', 'N', JLEN, I4-I2, J4-J2, ONE,
00759      $                           Z( JROW, INCOL+1+J2 ), LDZ,
00760      $                           U( J2+1, I2+1 ), LDU, ONE,
00761      $                           WV( 1, 1+I2 ), LDWV )
00762 *
00763 *                    ==== Copy the result back to Z ====
00764 *
00765                      CALL ZLACPY( 'ALL', JLEN, KDU, WV, LDWV,
00766      $                            Z( JROW, INCOL+1 ), LDZ )
00767   200             CONTINUE
00768                END IF
00769             END IF
00770          END IF
00771   210 CONTINUE
00772 *
00773 *     ==== End of ZLAQR5 ====
00774 *
00775       END