ScaLAPACK  2.0.2
ScaLAPACK: Scalable Linear Algebra PACKage
pdlaqr5.f
Go to the documentation of this file.
00001       SUBROUTINE PDLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS,
00002      $                    SR, SI, H, DESCH, ILOZ, IHIZ, Z, DESCZ, WORK,
00003      $                    LWORK, IWORK, LIWORK )
00004 *
00005 *     Contribution from the Department of Computing Science and HPC2N,
00006 *     Umea University, Sweden
00007 *
00008 *  -- ScaLAPACK routine (version 2.0.2) --
00009 *     Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
00010 *     May 1 2012
00011 *
00012       IMPLICIT NONE
00013 *
00014 *     .. Scalar Arguments ..
00015       INTEGER            IHIZ, ILOZ, KACC22, KBOT, KTOP, N, NSHFTS,
00016      $                   LWORK, LIWORK
00017       LOGICAL            WANTT, WANTZ
00018 *     ..
00019 *     .. Array Arguments ..
00020       INTEGER            DESCH( * ), DESCZ( * ), IWORK( * )
00021       DOUBLE PRECISION   H( * ), SI( * ), SR( * ), Z( * ), WORK( * )
00022 *     ..
00023 *
00024 *  Purpose
00025 *  =======
00026 *
00027 *  This auxiliary subroutine called by PDLAQR0 performs a
00028 *  single small-bulge multi-shift QR sweep by chasing separated
00029 *  groups of bulges along the main block diagonal of H.
00030 *
00031 *   WANTT  (global input) logical scalar
00032 *          WANTT = .TRUE. if the quasi-triangular Schur factor
00033 *          is being computed.  WANTT is set to .FALSE. otherwise.
00034 *
00035 *   WANTZ  (global input) logical scalar
00036 *          WANTZ = .TRUE. if the orthogonal Schur factor is being
00037 *          computed.  WANTZ is set to .FALSE. otherwise.
00038 *
00039 *   KACC22 (global input) integer with value 0, 1, or 2.
00040 *          Specifies the computation mode of far-from-diagonal
00041 *          orthogonal updates.
00042 *     = 1: PDLAQR5 accumulates reflections and uses matrix-matrix
00043 *          multiply to update the far-from-diagonal matrix entries.
00044 *     = 2: PDLAQR5 accumulates reflections, uses matrix-matrix
00045 *          multiply to update the far-from-diagonal matrix entries,
00046 *          and takes advantage of 2-by-2 block structure during
00047 *          matrix multiplies.
00048 *
00049 *   N      (global input) integer scalar
00050 *          N is the order of the Hessenberg matrix H upon which this
00051 *          subroutine operates.
00052 *
00053 *   KTOP   (global input) integer scalar
00054 *   KBOT   (global input) integer scalar
00055 *          These are the first and last rows and columns of an
00056 *          isolated diagonal block upon which the QR sweep is to be
00057 *          applied. It is assumed without a check that
00058 *                    either KTOP = 1  or   H(KTOP,KTOP-1) = 0
00059 *          and
00060 *                    either KBOT = N  or   H(KBOT+1,KBOT) = 0.
00061 *
00062 *   NSHFTS (global input) integer scalar
00063 *          NSHFTS gives the number of simultaneous shifts.  NSHFTS
00064 *          must be positive and even.
00065 *
00066 *   SR     (global input) DOUBLE PRECISION array of size (NSHFTS)
00067 *   SI     (global input) DOUBLE PRECISION array of size (NSHFTS)
00068 *          SR contains the real parts and SI contains the imaginary
00069 *          parts of the NSHFTS shifts of origin that define the
00070 *          multi-shift QR sweep.
00071 *
00072 *   H      (local input/output) DOUBLE PRECISION array of size 
00073 *          (DESCH(LLD_),*)
00074 *          On input H contains a Hessenberg matrix.  On output a
00075 *          multi-shift QR sweep with shifts SR(J)+i*SI(J) is applied
00076 *          to the isolated diagonal block in rows and columns KTOP
00077 *          through KBOT.
00078 *
00079 *   DESCH  (global and local input) INTEGER array of dimension DLEN_.
00080 *          The array descriptor for the distributed matrix H.
00081 *
00082 *   ILOZ   (global input) INTEGER
00083 *   IHIZ   (global input) INTEGER
00084 *          Specify the rows of Z to which transformations must be
00085 *          applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N
00086 *
00087 *   Z      (local input/output) DOUBLE PRECISION array of size
00088 *          (DESCZ(LLD_),*)
00089 *          If WANTZ = .TRUE., then the QR Sweep orthogonal
00090 *          similarity transformation is accumulated into
00091 *          Z(ILOZ:IHIZ,ILO:IHI) from the right.
00092 *          If WANTZ = .FALSE., then Z is unreferenced.
00093 *
00094 *   DESCZ  (global and local input) INTEGER array of dimension DLEN_.
00095 *          The array descriptor for the distributed matrix Z.
00096 *
00097 *   WORK   (local workspace) DOUBLE PRECISION array, dimension(DWORK)
00098 *
00099 *   LWORK  (local input) INTEGER
00100 *          The length of the workspace array WORK.
00101 *
00102 *   IWORK  (local workspace) INTEGER array, dimension (LIWORK)
00103 *
00104 *   LIWORK (local input) INTEGER
00105 *          The length of the workspace array IWORK.
00106 *
00107 *     ================================================================
00108 *     Based on contributions by
00109 *        Robert Granat, Department of Computing Science and HPC2N,
00110 *        University of Umea, Sweden.
00111 *
00112 *     ============================================================
00113 *     References:
00114 *       K. Braman, R. Byers, and R. Mathias,
00115 *       The Multi-Shift QR Algorithm Part I: Maintaining Well Focused
00116 *       Shifts, and Level 3 Performance.
00117 *       SIAM J. Matrix Anal. Appl., 23(4):929--947, 2002.
00118 *
00119 *       R. Granat, B. Kagstrom, and D. Kressner,
00120 *       A Novel Parallel QR Algorithm for Hybrid Distributed Momory HPC
00121 *       Systems.
00122 *       SIAM J. Sci. Comput., 32(4):2345--2378, 2010.
00123 *
00124 *     ============================================================
00125 *     .. Parameters ..
00126       INTEGER            BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
00127      $                   LLD_, MB_, M_, NB_, N_, RSRC_
00128       PARAMETER          ( BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DTYPE_ = 1,
00129      $                     CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
00130      $                     RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
00131       DOUBLE PRECISION   ZERO, ONE
00132       PARAMETER          ( ZERO = 0.0d0, ONE = 1.0d0 )
00133       INTEGER            NTINY
00134       PARAMETER          ( NTINY = 11 )
00135 *     ..
00136 *     .. Local Scalars ..
00137       DOUBLE PRECISION   ALPHA, BETA, H11, H12, H21, H22, REFSUM,
00138      $                   SAFMAX, SAFMIN, SCL, SMLNUM, SWAP, TST1, TST2,
00139      $                   ULP, TAU, ELEM, STAMP, DDUM, ORTH
00140       INTEGER            I, I2, I4, INCOL, J, J2, J4, JBOT, JCOL, JLEN,
00141      $                   JROW, JTOP, K, K1, KDU, KMS, KNZ, KRCOL, KZS,
00142      $                   M, M22, MBOT, MEND, MSTART, MTOP, NBMPS, NDCOL,
00143      $                   NS, NU, LLDH, LLDZ, LLDU, LLDV, LLDW, LLDWH,
00144      $                   INFO, ICTXT, NPROW, NPCOL, NB, IROFFH, ITOP,
00145      $                   NWIN, MYROW, MYCOL, LNS, NUMWIN, LKACC22,
00146      $                   LCHAIN, WIN, IDONEJOB, IPNEXT, ANMWIN, LENRBUF,
00147      $                   LENCBUF, ICHOFF, LRSRC, LCSRC, LKTOP, LKBOT,
00148      $                   II, JJ, SWIN, EWIN, LNWIN, DIM, LLKTOP, LLKBOT,
00149      $                   IPV, IPU, IPH, IPW, KU, KWH, KWV, NVE, LKS,
00150      $                   IDUM, NHO, DIR, WINID, INDX, ILOC, JLOC, RSRC1,
00151      $                   CSRC1, RSRC2, CSRC2, RSRC3, CSRC3, RSRC4, IPUU,
00152      $                   CSRC4, LROWS, LCOLS, INDXS, KS, JLOC1, ILOC1,
00153      $                   LKTOP1, LKTOP2, WCHUNK, NUMCHUNK, ODDEVEN,
00154      $                   CHUNKNUM, DIM1, DIM4, IPW3, HROWS, ZROWS,
00155      $                   HCOLS, IPW1, IPW2, RSRC, EAST, JLOC4, ILOC4,
00156      $                   WEST, CSRC, SOUTH, NORHT, INDXE, NORTH,
00157      $                   IHH, IPIW, LKBOT1, NPROCS, LIROFFH,
00158      $                   WINFIN, RWS3, CLS3, INDX2, HROWS2,
00159      $                   ZROWS2, HCOLS2, MNRBUF,
00160      $                   MXRBUF, MNCBUF, MXCBUF, LWKOPT
00161       LOGICAL            BLK22, BMP22, INTRO, DONEJOB, ODDNPROW,
00162      $                   ODDNPCOL, LQUERY, BCDONE
00163       CHARACTER          JBCMPZ*2, JOB
00164 *     ..
00165 *     .. External Functions ..
00166       LOGICAL            LSAME
00167       INTEGER            PILAENVX, ICEIL, INDXG2P, INDXG2L, NUMROC
00168       DOUBLE PRECISION   DLAMCH, DLANGE
00169       EXTERNAL           DLAMCH, PILAENVX, ICEIL, INDXG2P, INDXG2L,
00170      $                   NUMROC, LSAME, DLANGE
00171 *     ..
00172 *     .. Intrinsic Functions ..
00173       INTRINSIC          ABS, DBLE, MAX, MIN, MOD
00174 *     ..
00175 *     .. Local Arrays ..
00176       DOUBLE PRECISION   VT( 3 )
00177 *     ..
00178 *     .. External Subroutines ..
00179       EXTERNAL           DGEMM, DLABAD, DLAMOV, DLAQR1, DLARFG, DLASET,
00180      $                   DTRMM, DLAQR6
00181 *     ..
00182 *     .. Executable Statements ..
00183 *
00184       INFO = 0
00185       ICTXT = DESCH( CTXT_ )
00186       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
00187       NPROCS = NPROW*NPCOL
00188       LLDH = DESCH( LLD_ )
00189       LLDZ = DESCZ( LLD_ )
00190       NB = DESCH( MB_ )
00191       IROFFH = MOD( KTOP - 1, NB )
00192       LQUERY = LWORK.EQ.-1 .OR. LIWORK.EQ.-1
00193 *
00194 *     If there are no shifts, then there is nothing to do.
00195 *
00196       IF( .NOT. LQUERY .AND. NSHFTS.LT.2 )
00197      $   RETURN
00198 *
00199 *     If the active block is empty or 1-by-1, then there
00200 *     is nothing to do.
00201 *
00202       IF( .NOT. LQUERY .AND. KTOP.GE.KBOT )
00203      $   RETURN
00204 *
00205 *     Shuffle shifts into pairs of real shifts and pairs of
00206 *     complex conjugate shifts assuming complex conjugate
00207 *     shifts are already adjacent to one another.
00208 *
00209       IF( .NOT. LQUERY ) THEN
00210          DO 10 I = 1, NSHFTS - 2, 2
00211             IF( SI( I ).NE.-SI( I+1 ) ) THEN
00212 *
00213                SWAP = SR( I )
00214                SR( I ) = SR( I+1 )
00215                SR( I+1 ) = SR( I+2 )
00216                SR( I+2 ) = SWAP
00217 *
00218                SWAP = SI( I )
00219                SI( I ) = SI( I+1 )
00220                SI( I+1 ) = SI( I+2 )
00221                SI( I+2 ) = SWAP
00222             END IF
00223    10    CONTINUE
00224       END IF
00225 *
00226 *     NSHFTS is supposed to be even, but if is odd,
00227 *     then simply reduce it by one.  The shuffle above
00228 *     ensures that the dropped shift is real and that
00229 *     the remaining shifts are paired.
00230 *
00231       NS = NSHFTS - MOD( NSHFTS, 2 )
00232 *
00233 *     Extract the size of the computational window.
00234 *
00235       NWIN = PILAENVX( ICTXT, 19, 'PDLAQR5', JBCMPZ, N, NB, NB, NB )
00236       NWIN = MIN( NWIN, KBOT-KTOP+1 )
00237 *
00238 *     Adjust number of simultaneous shifts if it exceeds the limit
00239 *     set by the number of diagonal blocks in the active submatrix
00240 *     H(KTOP:KBOT,KTOP:KBOT).
00241 *
00242       NS = MAX( 2, MIN( NS, ICEIL( KBOT-KTOP+1, NB )*NWIN/3 ) )
00243       NS = NS - MOD( NS, 2 )
00244 
00245 *
00246 *     Decide the number of simultaneous computational windows
00247 *     from the number of shifts - each window should contain up to
00248 *     (NWIN / 3) shifts. Also compute the number of shifts per
00249 *     window and make sure that number is even.
00250 *
00251       LNS = MIN( MAX( 2, NWIN / 3 ), MAX( 2, NS / MIN(NPROW,NPCOL) ) )
00252       LNS = LNS - MOD( LNS, 2 )
00253       NUMWIN = MAX( 1, MIN( ICEIL( NS, LNS ),
00254      $     ICEIL( KBOT-KTOP+1, NB ) - 1 ) )
00255       IF( NPROW.NE.NPCOL ) THEN
00256          NUMWIN = MIN( NUMWIN, MIN(NPROW,NPCOL) )
00257          LNS = MIN( LNS, MAX( 2, NS / MIN(NPROW,NPCOL) ) )
00258          LNS = LNS - MOD( LNS, 2 )
00259       END IF
00260 *
00261 *     Machine constants for deflation.
00262 *
00263       SAFMIN = DLAMCH( 'SAFE MINIMUM' )
00264       SAFMAX = ONE / SAFMIN
00265       CALL DLABAD( SAFMIN, SAFMAX )
00266       ULP = DLAMCH( 'PRECISION' )
00267       SMLNUM = SAFMIN*( DBLE( N ) / ULP )
00268 *
00269 *     Use accumulated reflections to update far-from-diagonal
00270 *     entries on a local level?
00271 *
00272       IF( LNS.LT.14 ) THEN
00273          LKACC22 = 1
00274       ELSE
00275          LKACC22 = 2
00276       END IF
00277 *
00278 *     If so, exploit the 2-by-2 block structure?
00279 *     ( Usually it is not efficient to exploit the 2-by-2 structure
00280 *       because the block size is too small. )
00281 *
00282       BLK22 = ( LNS.GT.2 ) .AND. ( KACC22.EQ.2 )
00283 *
00284 *     Clear trash.
00285 *
00286       IF( .NOT. LQUERY .AND. KTOP+2.LE.KBOT )
00287      $   CALL PDELSET( H, KTOP+2, KTOP, DESCH, ZERO )
00288 *
00289 *     NBMPS = number of 2-shift bulges in each chain
00290 *
00291       NBMPS = LNS / 2
00292 *
00293 *     KDU = width of slab
00294 *
00295       KDU = 6*NBMPS - 3
00296 *
00297 *     LCHAIN = length of each chain
00298 *
00299       LCHAIN = 3 * NBMPS + 1
00300 *
00301 *     Check if workspace query.
00302 *
00303       IF( LQUERY ) THEN
00304          HROWS = NUMROC( N, NB, MYROW, DESCH(RSRC_), NPROW )
00305          HCOLS = NUMROC( N, NB, MYCOL, DESCH(CSRC_), NPCOL )
00306          LWKOPT = (5+2*NUMWIN)*NB**2 + 2*HROWS*NB + HCOLS*NB +
00307      $        MAX( HROWS*NB, HCOLS*NB )
00308          WORK(1)  = DBLE(LWKOPT)
00309          IWORK(1) = 5*NUMWIN
00310          RETURN
00311       END IF
00312 *
00313 *     Check if KTOP and KBOT are valid.
00314 *
00315       IF( KTOP.LT.1 .OR. KBOT.GT.N ) STOP
00316 *
00317 *     Create and chase NUMWIN chains of NBMPS bulges.
00318 *
00319 *     Set up window introduction.
00320 *
00321       ANMWIN = 0
00322       INTRO = .TRUE.
00323       IPIW = 1
00324 *
00325 *     Main loop:
00326 *     While-loop over the computational windows which is
00327 *     terminated when all windows have been introduced,
00328 *     chased down to the bottom of the considered submatrix
00329 *     and chased off.
00330 *
00331  20   CONTINUE
00332 *
00333 *     Set up next window as long as we have less than the prescribed
00334 *     number of windows. Each window is described an integer quadruple:
00335 *     1. Local value of KTOP (below denoted by LKTOP)
00336 *     2. Local value of KBOT (below denoted by LKBOT)
00337 *     3-4. Processor indices (LRSRC,LCSRC) associated with the window.
00338 *     (5. Mark that decides if a window is fully processed or not)
00339 *
00340 *     Notice - the next window is only introduced if the first block
00341 *     in the active submatrix does not contain any other windows.
00342 *
00343       IF( ANMWIN.GT.0 ) THEN
00344          LKTOP = IWORK( 1+(ANMWIN-1)*5 )
00345       ELSE
00346          LKTOP = KTOP
00347       END IF
00348       IF( INTRO .AND. (ANMWIN.EQ.0 .OR. LKTOP.GT.ICEIL(KTOP,NB)*NB) )
00349      $     THEN
00350          ANMWIN = ANMWIN + 1
00351 *
00352 *        Structure of IWORK:
00353 *        IWORK( 1+(WIN-1)*5 ): start position
00354 *        IWORK( 2+(WIN-1)*5 ): stop position
00355 *        IWORK( 3+(WIN-1)*5 ): processor row id
00356 *        IWORK( 4+(WIN-1)*5 ): processor col id
00357 *        IWORK( 5+(WIN-1)*5 ): window status (0, 1, or 2)
00358 *
00359          IWORK( 1+(ANMWIN-1)*5 ) = KTOP
00360          IWORK( 2+(ANMWIN-1)*5 ) = KTOP +
00361      $                             MIN( NWIN,NB-IROFFH,KBOT-KTOP+1 ) - 1
00362          IWORK( 3+(ANMWIN-1)*5 ) = INDXG2P( IWORK(1+(ANMWIN-1)*5), NB,
00363      $                             MYROW, DESCH(RSRC_), NPROW )
00364          IWORK( 4+(ANMWIN-1)*5 ) = INDXG2P( IWORK(2+(ANMWIN-1)*5), NB,
00365      $                             MYCOL, DESCH(CSRC_), NPCOL )
00366          IWORK( 5+(ANMWIN-1)*5 ) = 0
00367          IPIW = 6+(ANMWIN-1)*5
00368          IF( ANMWIN.EQ.NUMWIN ) INTRO = .FALSE.
00369       END IF
00370 *
00371 *     Do-loop over the number of windows.
00372 *
00373       IPNEXT = 1
00374       DONEJOB = .FALSE.
00375       IDONEJOB = 0
00376       LENRBUF = 0
00377       LENCBUF = 0
00378       ICHOFF = 0
00379       DO 40 WIN = 1, ANMWIN
00380 *
00381 *        Extract window information to simplify the rest.
00382 *
00383          LRSRC = IWORK( 3+(WIN-1)*5 )
00384          LCSRC = IWORK( 4+(WIN-1)*5 )
00385          LKTOP = IWORK( 1+(WIN-1)*5 )
00386          LKBOT = IWORK( 2+(WIN-1)*5 )
00387          LNWIN = LKBOT - LKTOP + 1
00388 *
00389 *        Check if anything to do for current window, i.e., if the local
00390 *        chain of bulges has reached the next block border etc.
00391 *
00392          IF( IWORK(5+(WIN-1)*5).LT.2 .AND. LNWIN.GT.1 .AND.
00393      $        (LNWIN.GT.LCHAIN .OR. LKBOT.EQ.KBOT ) ) THEN
00394             LIROFFH = MOD(LKTOP-1,NB)
00395             SWIN = LKTOP-LIROFFH
00396             EWIN = MIN(KBOT,LKTOP-LIROFFH+NB-1)
00397             DIM = EWIN-SWIN+1
00398             IF( DIM.LE.NTINY .AND. .NOT.LKBOT.EQ.KBOT ) THEN
00399                IWORK( 5+(WIN-1)*5 ) = 2
00400                GO TO 45
00401             END IF
00402             IDONEJOB = 1
00403             IF( IWORK(5+(WIN-1)*5).EQ.0 ) THEN
00404                IWORK(5+(WIN-1)*5) = 1
00405             END IF
00406 *
00407 *           Let the process that owns the corresponding window do the
00408 *           local bulge chase.
00409 *
00410             IF( MYROW.EQ.LRSRC .AND. MYCOL.EQ.LCSRC ) THEN
00411 *
00412 *              Set the kind of job to do in DLAQR6:
00413 *              1. JOB = 'I': Introduce and chase bulges in window WIN
00414 *              2. JOB = 'C': Chase bulges from top to bottom of window WIN
00415 *              3. JOB = 'O': Chase bulges off window WIN
00416 *              4. JOB = 'A': All of 1-3 above is done - this will for
00417 *                            example happen for very small active
00418 *                            submatrices (like 2-by-2)
00419 *
00420                LLKBOT = LLKTOP + LNWIN - 1
00421                IF( LKTOP.EQ.KTOP .AND. LKBOT.EQ.KBOT ) THEN
00422                   JOB = 'All steps'
00423                   ICHOFF = 1
00424                ELSEIF( LKTOP.EQ.KTOP ) THEN
00425                   JOB = 'Introduce and chase'
00426                ELSEIF( LKBOT.EQ.KBOT ) THEN
00427                   JOB = 'Off-chase bulges'
00428                   ICHOFF = 1
00429                ELSE
00430                   JOB = 'Chase bulges'
00431                END IF
00432 *
00433 *              Copy submatrix of H corresponding to window WIN into
00434 *              workspace and set out additional workspace for storing
00435 *              orthogonal transformations. This submatrix must be at
00436 *              least (NTINY+1)-by-(NTINY+1) to fit into DLAQR6 - if not,
00437 *              abort and go for cross border bulge chasing with this
00438 *              particular window.
00439 *
00440                II = INDXG2L( SWIN, NB, MYROW, DESCH(RSRC_), NPROW )
00441                JJ = INDXG2L( SWIN, NB, MYCOL, DESCH(CSRC_), NPCOL )
00442                LLKTOP = 1 + LIROFFH
00443                LLKBOT = LLKTOP + LNWIN - 1
00444 *
00445                IPU = IPNEXT
00446                IPH = IPU + LNWIN**2
00447                IPUU = IPH + MAX(NTINY+1,DIM)**2
00448                IPV = IPUU + MAX(NTINY+1,DIM)**2
00449                IPNEXT = IPH
00450 *
00451                IF( LSAME( JOB, 'A' ) .OR. LSAME( JOB, 'O' ) .AND.
00452      $              DIM.LT.NTINY+1 ) THEN
00453                   CALL DLASET( 'All', NTINY+1, NTINY+1, ZERO, ONE,
00454      $                 WORK(IPH), NTINY+1 )
00455                END IF
00456                CALL DLAMOV( 'Upper', DIM, DIM, H(II+(JJ-1)*LLDH), LLDH,
00457      $              WORK(IPH), MAX(NTINY+1,DIM) )
00458                CALL DCOPY(  DIM-1, H(II+(JJ-1)*LLDH+1), LLDH+1,
00459      $              WORK(IPH+1), MAX(NTINY+1,DIM)+1 )
00460                IF( LSAME( JOB, 'C' ) .OR. LSAME( JOB, 'O') ) THEN
00461                   CALL DCOPY(  DIM-2, H(II+(JJ-1)*LLDH+2), LLDH+1,
00462      $                 WORK(IPH+2), MAX(NTINY+1,DIM)+1 )
00463                   CALL DCOPY(  DIM-3, H(II+(JJ-1)*LLDH+3), LLDH+1,
00464      $                 WORK(IPH+3), MAX(NTINY+1,DIM)+1 )
00465                   CALL DLASET( 'Lower', DIM-4, DIM-4, ZERO,
00466      $                 ZERO, WORK(IPH+4), MAX(NTINY+1,DIM) )
00467                ELSE
00468                   CALL DLASET( 'Lower', DIM-2, DIM-2, ZERO,
00469      $                 ZERO, WORK(IPH+2), MAX(NTINY+1,DIM) )
00470                END IF
00471 *
00472                KU = MAX(NTINY+1,DIM) - KDU + 1
00473                KWH = KDU + 1
00474                NHO = ( MAX(NTINY+1,DIM)-KDU+1-4 ) - ( KDU+1 ) + 1
00475                KWV = KDU + 4
00476                NVE = MAX(NTINY+1,DIM) - KDU - KWV + 1
00477                CALL DLASET( 'All', MAX(NTINY+1,DIM),
00478      $              MAX(NTINY+1,DIM), ZERO, ONE, WORK(IPUU),
00479      $              MAX(NTINY+1,DIM) )
00480 *
00481 *              Small-bulge multi-shift QR sweep.
00482 *
00483                LKS = MAX( 1, NS - WIN*LNS + 1 )
00484                CALL DLAQR6( JOB, WANTT, .TRUE., LKACC22,
00485      $              MAX(NTINY+1,DIM), LLKTOP, LLKBOT, LNS, SR( LKS ),
00486      $              SI( LKS ), WORK(IPH), MAX(NTINY+1,DIM), LLKTOP,
00487      $              LLKBOT, WORK(IPUU), MAX(NTINY+1,DIM), WORK(IPU),
00488      $              3, WORK( IPH+KU-1 ),
00489      $              MAX(NTINY+1,DIM), NVE, WORK( IPH+KWV-1 ),
00490      $              MAX(NTINY+1,DIM), NHO, WORK( IPH-1+KU+(KWH-1)*
00491      $              MAX(NTINY+1,DIM) ), MAX(NTINY+1,DIM) )
00492 *
00493 *              Copy submatrix of H back.
00494 *
00495                CALL DLAMOV( 'Upper', DIM, DIM, WORK(IPH),
00496      $              MAX(NTINY+1,DIM), H(II+(JJ-1)*LLDH), LLDH )
00497                CALL DCOPY( DIM-1, WORK(IPH+1), MAX(NTINY+1,DIM)+1,
00498      $              H(II+(JJ-1)*LLDH+1), LLDH+1 )
00499                IF( LSAME( JOB, 'I' ) .OR. LSAME( JOB, 'C' ) ) THEN
00500                   CALL DCOPY( DIM-2, WORK(IPH+2), DIM+1,
00501      $                 H(II+(JJ-1)*LLDH+2), LLDH+1 )
00502                   CALL DCOPY( DIM-3, WORK(IPH+3), DIM+1,
00503      $                 H(II+(JJ-1)*LLDH+3), LLDH+1 )
00504                ELSE
00505                   CALL DLASET( 'Lower', DIM-2, DIM-2, ZERO,
00506      $                 ZERO, H(II+(JJ-1)*LLDH+2), LLDH )
00507                END IF
00508 *
00509 *              Copy actual submatrix of U to the correct place
00510 *              of the buffer.
00511 *
00512                CALL DLAMOV( 'All', LNWIN, LNWIN,
00513      $              WORK(IPUU+(MAX(NTINY+1,DIM)*LIROFFH)+LIROFFH),
00514      $              MAX(NTINY+1,DIM), WORK(IPU), LNWIN )
00515             END IF
00516 *
00517 *           In case the local submatrix was smaller than
00518 *           (NTINY+1)-by-(NTINY+1) we go here and proceed.
00519 *
00520  45         CONTINUE
00521          ELSE
00522             IWORK( 5+(WIN-1)*5 ) = 2
00523          END IF
00524 *
00525 *        Increment counter for buffers of orthogonal transformations.
00526 *
00527          IF( MYROW.EQ.LRSRC .OR. MYCOL.EQ.LCSRC ) THEN
00528             IF( IDONEJOB.EQ.1 .AND. IWORK(5+(WIN-1)*5).LT.2 ) THEN
00529                IF( MYROW.EQ.LRSRC ) LENRBUF = LENRBUF + LNWIN*LNWIN
00530                IF( MYCOL.EQ.LCSRC ) LENCBUF = LENCBUF + LNWIN*LNWIN
00531             END IF
00532          END IF
00533  40   CONTINUE
00534 *
00535 *     Did some work in the above do-loop?
00536 *
00537       CALL IGSUM2D( ICTXT, 'All', '1-Tree', 1, 1, IDONEJOB, 1, -1, -1 )
00538       DONEJOB = IDONEJOB.GT.0
00539 *
00540 *     Chased off bulges from first window?
00541 *
00542       IF( NPROCS.GT.1 )
00543      $   CALL IGAMX2D( ICTXT, 'All', '1-Tree', 1, 1, ICHOFF, 1, -1,
00544      $        -1, -1, -1, -1 )
00545 *
00546 *     If work was done in the do-loop over local windows, perform
00547 *     updates, otherwise go for cross border bulge chasing and updates.
00548 *
00549       IF( DONEJOB ) THEN
00550 *
00551 *        Broadcast orthogonal transformations.
00552 *
00553  49      CONTINUE
00554          IF( LENRBUF.GT.0 .OR. LENCBUF.GT.0 ) THEN
00555             DO 50 DIR = 1, 2
00556                BCDONE = .FALSE.
00557                DO 60 WIN = 1, ANMWIN
00558                   IF( ( LENRBUF.EQ.0 .AND. LENCBUF.EQ.0 ) .OR.
00559      $                 BCDONE ) GO TO 62
00560                   LRSRC = IWORK( 3+(WIN-1)*5 )
00561                   LCSRC = IWORK( 4+(WIN-1)*5 )
00562                   IF( MYROW.EQ.LRSRC .AND. MYCOL.EQ.LCSRC ) THEN
00563                      IF( DIR.EQ.1 .AND. LENRBUF.GT.0 .AND.
00564      $                    NPCOL.GT.1 ) THEN
00565                         CALL DGEBS2D( ICTXT, 'Row', '1-Tree', LENRBUF,
00566      $                       1, WORK, LENRBUF )
00567                      ELSEIF( DIR.EQ.2 .AND. LENCBUF.GT.0 .AND.
00568      $                    NPROW.GT.1 ) THEN
00569                         CALL DGEBS2D( ICTXT, 'Col', '1-Tree', LENCBUF,
00570      $                       1, WORK, LENCBUF )
00571                      END IF
00572                      IF( LENRBUF.GT.0 )
00573      $                  CALL DLAMOV( 'All', LENRBUF, 1, WORK, LENRBUF,
00574      $                       WORK(1+LENRBUF), LENCBUF )
00575                      BCDONE = .TRUE.
00576                   ELSEIF( MYROW.EQ.LRSRC .AND. DIR.EQ.1 ) THEN
00577                      IF( LENRBUF.GT.0 .AND. NPCOL.GT.1 ) THEN
00578                         CALL DGEBR2D( ICTXT, 'Row', '1-Tree', LENRBUF,
00579      $                       1, WORK, LENRBUF, LRSRC, LCSRC )
00580                         BCDONE = .TRUE.
00581                      END IF
00582                   ELSEIF( MYCOL.EQ.LCSRC .AND. DIR.EQ.2 ) THEN
00583                      IF( LENCBUF.GT.0 .AND. NPROW.GT.1 ) THEN
00584                         CALL DGEBR2D( ICTXT, 'Col', '1-Tree', LENCBUF,
00585      $                       1, WORK(1+LENRBUF), LENCBUF, LRSRC, LCSRC )
00586                         BCDONE = .TRUE.
00587                      END IF
00588                   END IF
00589  62               CONTINUE
00590  60            CONTINUE
00591  50         CONTINUE
00592          END IF
00593 *
00594 *        Compute updates - make sure to skip windows that was skipped
00595 *        regarding local bulge chasing.
00596 *
00597          DO 65 DIR = 1, 2
00598             WINID = 0
00599             IF( DIR.EQ.1 ) THEN
00600                IPNEXT = 1
00601             ELSE
00602                IPNEXT = 1 + LENRBUF
00603             END IF
00604             DO 70 WIN = 1, ANMWIN
00605                IF( IWORK( 5+(WIN-1)*5 ).EQ.2 ) GO TO 75
00606                LRSRC = IWORK( 3+(WIN-1)*5 )
00607                LCSRC = IWORK( 4+(WIN-1)*5 )
00608                LKTOP = IWORK( 1+(WIN-1)*5 )
00609                LKBOT = IWORK( 2+(WIN-1)*5 )
00610                LNWIN = LKBOT - LKTOP + 1
00611                IF( (MYROW.EQ.LRSRC.AND.LENRBUF.GT.0.AND.DIR.EQ.1) .OR.
00612      $              (MYCOL.EQ.LCSRC.AND.LENCBUF.GT.0.AND.DIR.EQ.2 ) )
00613      $              THEN
00614 *
00615 *                 Set up workspaces.
00616 *
00617                   IPU = IPNEXT
00618                   IPNEXT = IPU + LNWIN*LNWIN
00619                   IPW = 1 + LENRBUF + LENCBUF
00620                   LIROFFH = MOD(LKTOP-1,NB)
00621                   WINID = WINID + 1
00622 *
00623 *                 Recompute JOB to see if block structure of U could
00624 *                 possibly be exploited or not.
00625 *
00626                   IF( LKTOP.EQ.KTOP .AND. LKBOT.EQ.KBOT ) THEN
00627                      JOB = 'All steps'
00628                   ELSEIF( LKTOP.EQ.KTOP ) THEN
00629                      JOB = 'Introduce and chase'
00630                   ELSEIF( LKBOT.EQ.KBOT ) THEN
00631                      JOB = 'Off-chase bulges'
00632                   ELSE
00633                      JOB = 'Chase bulges'
00634                   END IF
00635                END IF
00636 *
00637 *              Use U to update far-from-diagonal entries in H.
00638 *              If required, use U to update Z as well.
00639 *
00640                IF( .NOT. BLK22 .OR. .NOT. LSAME(JOB,'C')
00641      $              .OR. LNS.LE.2 ) THEN
00642 *
00643                   IF( DIR.EQ.2 .AND. LENCBUF.GT.0 .AND.
00644      $                 MYCOL.EQ.LCSRC ) THEN
00645                      IF( WANTT ) THEN
00646                         DO 80 INDX = 1, LKTOP-LIROFFH-1, NB
00647                            CALL INFOG2L( INDX, LKTOP, DESCH, NPROW,
00648      $                          NPCOL, MYROW, MYCOL, ILOC, JLOC, RSRC1,
00649      $                          CSRC1 )
00650                            IF( MYROW.EQ.RSRC1.AND.MYCOL.EQ.CSRC1 ) THEN
00651                               LROWS = MIN( NB, LKTOP-INDX )
00652                               CALL DGEMM('No transpose', 'No transpose',
00653      $                             LROWS, LNWIN, LNWIN, ONE,
00654      $                             H((JLOC-1)*LLDH+ILOC), LLDH,
00655      $                             WORK( IPU ), LNWIN, ZERO,
00656      $                             WORK(IPW),
00657      $                             LROWS )
00658                               CALL DLAMOV( 'All', LROWS, LNWIN,
00659      $                             WORK(IPW), LROWS,
00660      $                             H((JLOC-1)*LLDH+ILOC), LLDH )
00661                            END IF
00662  80                     CONTINUE
00663                      END IF
00664                      IF( WANTZ ) THEN
00665                         DO 90 INDX = 1, N, NB
00666                            CALL INFOG2L( INDX, LKTOP, DESCZ, NPROW,
00667      $                          NPCOL, MYROW, MYCOL, ILOC, JLOC, RSRC1,
00668      $                          CSRC1 )
00669                            IF( MYROW.EQ.RSRC1.AND.MYCOL.EQ.CSRC1 ) THEN
00670                               LROWS = MIN(NB,N-INDX+1)
00671                               CALL DGEMM( 'No transpose',
00672      $                             'No transpose', LROWS, LNWIN, LNWIN,
00673      $                             ONE, Z((JLOC-1)*LLDZ+ILOC), LLDZ,
00674      $                             WORK( IPU ), LNWIN, ZERO,
00675      $                             WORK(IPW), LROWS )
00676                               CALL DLAMOV( 'All', LROWS, LNWIN,
00677      $                             WORK(IPW), LROWS,
00678      $                             Z((JLOC-1)*LLDZ+ILOC), LLDZ )
00679                            END IF
00680  90                     CONTINUE
00681                      END IF
00682                   END IF
00683 *
00684 *                 Update the rows of H affected by the bulge-chase.
00685 *
00686                   IF( DIR.EQ.1 .AND. LENRBUF.GT.0 .AND.
00687      $                 MYROW.EQ.LRSRC ) THEN
00688                      IF( WANTT ) THEN
00689                         IF( ICEIL(LKBOT,NB).EQ.ICEIL(KBOT,NB) ) THEN
00690                            LCOLS = MIN(ICEIL(KBOT,NB)*NB,N) - KBOT
00691                         ELSE
00692                            LCOLS = 0
00693                         END IF
00694                         IF( LCOLS.GT.0 ) THEN
00695                            INDX = KBOT + 1
00696                            CALL INFOG2L( LKTOP, INDX, DESCH, NPROW,
00697      $                          NPCOL, MYROW, MYCOL, ILOC, JLOC,
00698      $                          RSRC1, CSRC1 )
00699                            IF( MYROW.EQ.RSRC1.AND.MYCOL.EQ.CSRC1 ) THEN
00700                               CALL DGEMM( 'Transpose', 'No Transpose',
00701      $                             LNWIN, LCOLS, LNWIN, ONE, WORK(IPU),
00702      $                             LNWIN, H((JLOC-1)*LLDH+ILOC), LLDH,
00703      $                             ZERO, WORK(IPW), LNWIN )
00704                               CALL DLAMOV( 'All', LNWIN, LCOLS,
00705      $                             WORK(IPW), LNWIN,
00706      $                             H((JLOC-1)*LLDH+ILOC), LLDH )
00707                            END IF
00708                         END IF
00709  93                     CONTINUE
00710                         INDXS = ICEIL(LKBOT,NB)*NB + 1
00711                         DO 95 INDX = INDXS, N, NB
00712                            CALL INFOG2L( LKTOP, INDX,
00713      $                          DESCH, NPROW, NPCOL, MYROW, MYCOL,
00714      $                          ILOC, JLOC, RSRC1, CSRC1 )
00715                            IF( MYROW.EQ.RSRC1.AND.MYCOL.EQ.CSRC1 ) THEN
00716                               LCOLS = MIN( NB, N-INDX+1 )
00717                               CALL DGEMM( 'Transpose', 'No Transpose',
00718      $                             LNWIN, LCOLS, LNWIN, ONE, WORK(IPU),
00719      $                             LNWIN, H((JLOC-1)*LLDH+ILOC), LLDH,
00720      $                             ZERO, WORK(IPW),
00721      $                             LNWIN )
00722                               CALL DLAMOV( 'All', LNWIN, LCOLS,
00723      $                             WORK(IPW), LNWIN,
00724      $                             H((JLOC-1)*LLDH+ILOC), LLDH )
00725                            END IF
00726  95                     CONTINUE
00727                      END IF
00728                   END IF
00729                ELSE
00730                   KS = LNWIN-LNS/2*3
00731 *
00732 *                 The LNWIN-by-LNWIN matrix U containing the accumulated
00733 *                 orthogonal transformations has the following structure:
00734 *
00735 *                     [ U11  U12 ]
00736 *                 U = [          ],
00737 *                     [ U21  U22 ]
00738 *
00739 *                 where U21 is KS-by-KS upper triangular and U12 is
00740 *                 (LNWIN-KS)-by-(LNWIN-KS) lower triangular.
00741 *                 Here, KS = LNS.
00742 *
00743 *                 Update the columns of H and Z affected by the bulge
00744 *                 chasing.
00745 *
00746 *                 Compute H2*U21 + H1*U11 in workspace.
00747 *
00748                   IF( DIR.EQ.2 .AND. LENCBUF.GT.0 .AND.
00749      $                 MYCOL.EQ.LCSRC ) THEN
00750                      IF( WANTT ) THEN
00751                         DO 100 INDX = 1, LKTOP-LIROFFH-1, NB
00752                            CALL INFOG2L( INDX, LKTOP, DESCH, NPROW,
00753      $                          NPCOL, MYROW, MYCOL, ILOC, JLOC, RSRC1,
00754      $                          CSRC1 )
00755                            IF( MYROW.EQ.RSRC1.AND.MYCOL.EQ.CSRC1 ) THEN
00756                               JLOC1 = INDXG2L( LKTOP+LNWIN-KS, NB,
00757      $                             MYCOL, DESCH( CSRC_ ), NPCOL )
00758                               LROWS = MIN( NB, LKTOP-INDX )
00759                               CALL DLAMOV( 'All', LROWS, KS,
00760      $                             H((JLOC1-1)*LLDH+ILOC ), LLDH,
00761      $                             WORK(IPW), LROWS )
00762                               CALL DTRMM( 'Right', 'Upper',
00763      $                             'No transpose','Non-unit', LROWS,
00764      $                             KS, ONE, WORK( IPU+LNWIN-KS ), LNWIN,
00765      $                             WORK(IPW), LROWS )
00766                               CALL DGEMM('No transpose', 'No transpose',
00767      $                             LROWS, KS, LNWIN-KS, ONE,
00768      $                             H((JLOC-1)*LLDH+ILOC), LLDH,
00769      $                             WORK( IPU ), LNWIN, ONE, WORK(IPW),
00770      $                             LROWS )
00771 *
00772 *                             Compute H1*U12 + H2*U22 in workspace.
00773 *
00774                               CALL DLAMOV( 'All', LROWS, LNWIN-KS,
00775      $                             H((JLOC-1)*LLDH+ILOC), LLDH,
00776      $                             WORK( IPW+KS*LROWS ), LROWS )
00777                               CALL DTRMM( 'Right', 'Lower',
00778      $                             'No transpose', 'Non-Unit',
00779      $                             LROWS, LNWIN-KS, ONE,
00780      $                             WORK( IPU+LNWIN*KS ), LNWIN,
00781      $                             WORK( IPW+KS*LROWS ), LROWS )
00782                               CALL DGEMM('No transpose', 'No transpose',
00783      $                             LROWS, LNWIN-KS, KS, ONE,
00784      $                             H((JLOC1-1)*LLDH+ILOC), LLDH,
00785      $                             WORK( IPU+LNWIN*KS+LNWIN-KS ), LNWIN,
00786      $                             ONE, WORK( IPW+KS*LROWS ), LROWS )
00787 *
00788 *                             Copy workspace to H.
00789 *
00790                               CALL DLAMOV( 'All', LROWS, LNWIN,
00791      $                             WORK(IPW), LROWS,
00792      $                             H((JLOC-1)*LLDH+ILOC), LLDH )
00793                            END IF
00794  100                    CONTINUE
00795                      END IF
00796 *
00797                      IF( WANTZ ) THEN
00798 *
00799 *                       Compute Z2*U21 + Z1*U11 in workspace.
00800 *
00801                         DO 110 INDX = 1, N, NB
00802                            CALL INFOG2L( INDX, LKTOP, DESCZ, NPROW,
00803      $                          NPCOL, MYROW, MYCOL, ILOC, JLOC, RSRC1,
00804      $                          CSRC1 )
00805                            IF( MYROW.EQ.RSRC1.AND.MYCOL.EQ.CSRC1 ) THEN
00806                               JLOC1 = INDXG2L( LKTOP+LNWIN-KS, NB,
00807      $                             MYCOL, DESCZ( CSRC_ ), NPCOL )
00808                               LROWS = MIN(NB,N-INDX+1)
00809                               CALL DLAMOV( 'All', LROWS, KS,
00810      $                             Z((JLOC1-1)*LLDZ+ILOC ), LLDZ,
00811      $                             WORK(IPW), LROWS )
00812                               CALL DTRMM( 'Right', 'Upper',
00813      $                             'No transpose', 'Non-unit',
00814      $                             LROWS, KS, ONE, WORK( IPU+LNWIN-KS ),
00815      $                             LNWIN, WORK(IPW), LROWS )
00816                               CALL DGEMM( 'No transpose',
00817      $                             'No transpose', LROWS, KS, LNWIN-KS,
00818      $                             ONE, Z((JLOC-1)*LLDZ+ILOC), LLDZ,
00819      $                             WORK( IPU ), LNWIN, ONE, WORK(IPW),
00820      $                             LROWS )
00821 *
00822 *                             Compute Z1*U12 + Z2*U22 in workspace.
00823 *
00824                               CALL DLAMOV( 'All', LROWS, LNWIN-KS,
00825      $                             Z((JLOC-1)*LLDZ+ILOC), LLDZ,
00826      $                             WORK( IPW+KS*LROWS ), LROWS)
00827                               CALL DTRMM( 'Right', 'Lower',
00828      $                             'No transpose', 'Non-unit',
00829      $                             LROWS, LNWIN-KS, ONE,
00830      $                             WORK( IPU+LNWIN*KS ), LNWIN,
00831      $                             WORK( IPW+KS*LROWS ), LROWS )
00832                               CALL DGEMM( 'No transpose',
00833      $                             'No transpose', LROWS, LNWIN-KS, KS,
00834      $                             ONE, Z((JLOC1-1)*LLDZ+ILOC), LLDZ,
00835      $                             WORK( IPU+LNWIN*KS+LNWIN-KS ), LNWIN,
00836      $                             ONE, WORK( IPW+KS*LROWS ),
00837      $                             LROWS )
00838 *
00839 *                             Copy workspace to Z.
00840 *
00841                               CALL DLAMOV( 'All', LROWS, LNWIN,
00842      $                             WORK(IPW), LROWS,
00843      $                             Z((JLOC-1)*LLDZ+ILOC), LLDZ )
00844                            END IF
00845  110                    CONTINUE
00846                      END IF
00847                   END IF
00848 *
00849                   IF( DIR.EQ.1 .AND. LENRBUF.GT.0 .AND.
00850      $                 MYROW.EQ.LRSRC ) THEN
00851                      IF( WANTT ) THEN
00852                         INDXS = ICEIL(LKBOT,NB)*NB + 1
00853                         DO 120 INDX = INDXS, N, NB
00854                            CALL INFOG2L( LKTOP, INDX,
00855      $                          DESCH, NPROW, NPCOL, MYROW, MYCOL, ILOC,
00856      $                          JLOC, RSRC1, CSRC1 )
00857                            IF( MYROW.EQ.RSRC1.AND.MYCOL.EQ.CSRC1 ) THEN
00858 *
00859 *                             Compute U21**T*H2 + U11**T*H1 in workspace.
00860 *
00861                               ILOC1 = INDXG2L( LKTOP+LNWIN-KS, NB,
00862      $                             MYROW, DESCH( RSRC_ ), NPROW )
00863                               LCOLS = MIN( NB, N-INDX+1 )
00864                               CALL DLAMOV( 'All', KS, LCOLS,
00865      $                             H((JLOC-1)*LLDH+ILOC1), LLDH,
00866      $                             WORK(IPW), LNWIN )
00867                               CALL DTRMM( 'Left', 'Upper', 'Transpose',
00868      $                             'Non-unit', KS, LCOLS, ONE,
00869      $                             WORK( IPU+LNWIN-KS ), LNWIN,
00870      $                             WORK(IPW), LNWIN )
00871                               CALL DGEMM( 'Transpose', 'No transpose',
00872      $                             KS, LCOLS, LNWIN-KS, ONE, WORK(IPU),
00873      $                             LNWIN, H((JLOC-1)*LLDH+ILOC), LLDH,
00874      $                             ONE, WORK(IPW), LNWIN )
00875 *
00876 *                             Compute U12**T*H1 + U22**T*H2 in workspace.
00877 *
00878                               CALL DLAMOV( 'All', LNWIN-KS, LCOLS,
00879      $                             H((JLOC-1)*LLDH+ILOC), LLDH,
00880      $                             WORK( IPW+KS ), LNWIN )
00881                               CALL DTRMM( 'Left', 'Lower', 'Transpose',
00882      $                             'Non-unit', LNWIN-KS, LCOLS, ONE,
00883      $                             WORK( IPU+LNWIN*KS ), LNWIN,
00884      $                             WORK( IPW+KS ), LNWIN )
00885                               CALL DGEMM( 'Transpose', 'No Transpose',
00886      $                             LNWIN-KS, LCOLS, KS, ONE,
00887      $                             WORK( IPU+LNWIN*KS+LNWIN-KS ), LNWIN,
00888      $                             H((JLOC-1)*LLDH+ILOC1), LLDH,
00889      $                             ONE, WORK( IPW+KS ), LNWIN )
00890 *
00891 *                             Copy workspace to H.
00892 *
00893                               CALL DLAMOV( 'All', LNWIN, LCOLS,
00894      $                             WORK(IPW), LNWIN,
00895      $                             H((JLOC-1)*LLDH+ILOC), LLDH )
00896                            END IF
00897  120                    CONTINUE
00898                      END IF
00899                   END IF
00900                END IF
00901 *
00902 *              Update position information about current window.
00903 *
00904                IF( DIR.EQ.2 ) THEN
00905                   IF( LKBOT.EQ.KBOT ) THEN
00906                      LKTOP = KBOT+1
00907                      LKBOT = KBOT+1
00908                      IWORK( 1+(WIN-1)*5 ) = LKTOP
00909                      IWORK( 2+(WIN-1)*5 ) = LKBOT
00910                      IWORK( 5+(WIN-1)*5 ) = 2
00911                   ELSE
00912                      LKTOP = MIN( LKTOP + LNWIN - LCHAIN,
00913      $                    ICEIL( LKTOP, NB )*NB - LCHAIN + 1,
00914      $                    KBOT )
00915                      IWORK( 1+(WIN-1)*5 ) = LKTOP
00916                      LKBOT = MIN( LKBOT + LNWIN - LCHAIN,
00917      $                    ICEIL( LKBOT, NB )*NB, KBOT )
00918                      IWORK( 2+(WIN-1)*5 ) = LKBOT
00919                      LNWIN = LKBOT-LKTOP+1
00920                      IF( LNWIN.EQ.LCHAIN ) IWORK(5+(WIN-1)*5) = 2
00921                   END IF
00922                END IF
00923  75            CONTINUE
00924  70         CONTINUE
00925  65      CONTINUE
00926 *
00927 *        If bulges were chasen off from first window, the window is
00928 *        removed.
00929 *
00930          IF( ICHOFF.GT.0 ) THEN
00931             DO 128 WIN = 2, ANMWIN
00932                IWORK( 1+(WIN-2)*5 ) = IWORK( 1+(WIN-1)*5 )
00933                IWORK( 2+(WIN-2)*5 ) = IWORK( 2+(WIN-1)*5 )
00934                IWORK( 3+(WIN-2)*5 ) = IWORK( 3+(WIN-1)*5 )
00935                IWORK( 4+(WIN-2)*5 ) = IWORK( 4+(WIN-1)*5 )
00936                IWORK( 5+(WIN-2)*5 ) = IWORK( 5+(WIN-1)*5 )
00937  128        CONTINUE
00938             ANMWIN = ANMWIN - 1
00939             IPIW = 6+(ANMWIN-1)*5
00940          END IF
00941 *
00942 *        If we have no more windows, return.
00943 *
00944          IF( ANMWIN.LT.1 ) RETURN
00945 *
00946       ELSE
00947 *
00948 *        Set up windows such that as many bulges as possible can be
00949 *        moved over the border to the next block. Make sure that the
00950 *        cross border window is at least (NTINY+1)-by-(NTINY+1), unless
00951 *        we are chasing off the bulges from the last window. This is
00952 *        accomplished by setting the bottom index LKBOT such that the
00953 *        local window has the correct size.
00954 *
00955 *        If LKBOT then becomes larger than KBOT, the endpoint of the whole
00956 *        global submatrix, or LKTOP from a window located already residing
00957 *        at the other side of the border, this is taken care of by some
00958 *        dirty tricks.
00959 *
00960          DO 130 WIN = 1, ANMWIN
00961             LKTOP1 = IWORK( 1+(WIN-1)*5 )
00962             LKBOT = IWORK( 2+(WIN-1)*5 )
00963             LNWIN = MAX( 6, MIN( LKBOT - LKTOP1 + 1, LCHAIN ) )
00964             LKBOT1 = MAX( MIN( KBOT, ICEIL(LKTOP1,NB)*NB+LCHAIN),
00965      $           MIN( KBOT, MIN( LKTOP1+2*LNWIN-1,
00966      $           (ICEIL(LKTOP1,NB)+1)*NB ) ) )
00967             IWORK( 2+(WIN-1)*5 ) = LKBOT1
00968  130     CONTINUE
00969          ICHOFF = 0
00970 *
00971 *        Keep a record over what windows that were moved over the borders
00972 *        such that we can delay some windows due to lack of space on the
00973 *        other side of the border; we do not want to leave any of the
00974 *        bulges behind...
00975 *
00976 *        IWORK( 5+(WIN-1)*5 ) = 0: window WIN has not been processed
00977 *        IWORK( 5+(WIN-1)*5 ) = 1: window WIN is being processed (need to
00978 *                                  know for updates)
00979 *        IWORK( 5+(WIN-1)*5 ) = 2: window WIN has been fully processed
00980 *
00981 *        So, start by marking all windows as not processed.
00982 *
00983          DO 135 WIN = 1, ANMWIN
00984             IWORK( 5+(WIN-1)*5 ) = 0
00985  135     CONTINUE
00986 *
00987 *        Do the cross border bulge-chase as follows: Start from the
00988 *        first window (the one that is closest to be chased off the
00989 *        diagonal of H) and take the odd windows first followed by the
00990 *        even ones. To not get into hang-problems on processor meshes
00991 *        with at least one odd dimension, the windows will in such a case
00992 *        be processed in chunks of {the minimum odd process dimension}-1
00993 *        windows to avoid overlapping processor scopes in forming the
00994 *        cross border computational windows and the cross border update
00995 *        regions.
00996 *
00997          WCHUNK = MAX( 1, MIN( ANMWIN, NPROW-1, NPCOL-1 ) )
00998          NUMCHUNK = ICEIL( ANMWIN, WCHUNK )
00999 *
01000 *        Based on the computed chunk of windows, start working with
01001 *        crossborder bulge-chasing. Repeat this as long as there is
01002 *        still work left to do (137 is a kind of do-while statement).
01003 *
01004  137     CONTINUE
01005 *
01006 *        Zero out LENRBUF and LENCBUF each time we restart this loop.
01007 *
01008          LENRBUF = 0
01009          LENCBUF = 0
01010 *
01011          DO 140 ODDEVEN = 1, MIN( 2, ANMWIN )
01012          DO 150 CHUNKNUM = 1, NUMCHUNK
01013             IPNEXT = 1
01014             DO 160 WIN = ODDEVEN+(CHUNKNUM-1)*WCHUNK,
01015      $           MIN(ANMWIN,MAX(1,ODDEVEN+(CHUNKNUM)*WCHUNK-1)), 2
01016 *
01017 *              Get position and size of the WIN:th active window and
01018 *              make sure that we skip the cross border bulge for this
01019 *              window if the window is not shared between several data
01020 *              layout blocks (and processors).
01021 *
01022 *              Also, delay windows that do not have sufficient size of
01023 *              the other side of the border. Moreover, make sure to skip
01024 *              windows that was already processed in the last round of
01025 *              the do-while loop (137).
01026 *
01027                IF( IWORK( 5+(WIN-1)*5 ).EQ.2 ) GO TO 165
01028                LKTOP = IWORK( 1+(WIN-1)*5 )
01029                LKBOT = IWORK( 2+(WIN-1)*5 )
01030                IF( WIN.GT.1 ) THEN
01031                   LKTOP2 = IWORK( 1+(WIN-2)*5 )
01032                ELSE
01033                   LKTOP2 = KBOT+1
01034                END IF
01035                IF( ICEIL(LKTOP,NB).EQ.ICEIL(LKBOT,NB) .OR.
01036      $              LKBOT.GE.LKTOP2 ) GO TO 165
01037                LNWIN = LKBOT - LKTOP + 1
01038                IF( LNWIN.LE.NTINY .AND. LKBOT.NE.KBOT .AND.
01039      $              .NOT. MOD(LKBOT,NB).EQ.0  ) GO TO 165
01040 *
01041 *              If window is going to be processed, mark it as processed.
01042 *
01043                IWORK( 5+(WIN-1)*5 ) = 1
01044 *
01045 *              Extract processors for current cross border window,
01046 *              as below:
01047 *
01048 *                        1 | 2
01049 *                        --+--
01050 *                        3 | 4
01051 *
01052                RSRC1 = IWORK( 3+(WIN-1)*5 )
01053                CSRC1 = IWORK( 4+(WIN-1)*5 )
01054                RSRC2 = RSRC1
01055                CSRC2 = MOD( CSRC1+1, NPCOL )
01056                RSRC3 = MOD( RSRC1+1, NPROW )
01057                CSRC3 = CSRC1
01058                RSRC4 = MOD( RSRC1+1, NPROW )
01059                CSRC4 = MOD( CSRC1+1, NPCOL )
01060 *
01061 *              Form group of four processors for cross border window.
01062 *
01063                IF( ( MYROW.EQ.RSRC1 .AND. MYCOL.EQ.CSRC1 ) .OR.
01064      $              ( MYROW.EQ.RSRC2 .AND. MYCOL.EQ.CSRC2 ) .OR.
01065      $              ( MYROW.EQ.RSRC3 .AND. MYCOL.EQ.CSRC3 ) .OR.
01066      $              ( MYROW.EQ.RSRC4 .AND. MYCOL.EQ.CSRC4 ) ) THEN
01067 *
01068 *                 Compute the upper and lower parts of the active
01069 *                 window.
01070 *
01071                   DIM1 = NB - MOD(LKTOP-1,NB)
01072                   DIM4 = LNWIN - DIM1
01073 *
01074 *                 Temporarily compute a new value of the size of the
01075 *                 computational window that is larger than or equal to
01076 *                 NTINY+1; call the *real* value DIM.
01077 *
01078                   DIM = LNWIN
01079                   LNWIN = MAX(NTINY+1,LNWIN)
01080 *
01081 *                 Divide workspace.
01082 *
01083                   IPU = IPNEXT
01084                   IPH = IPU + DIM**2
01085                   IPUU = IPH + LNWIN**2
01086                   IPV = IPUU + LNWIN**2
01087                   IPNEXT = IPH
01088                   IF( DIM.LT.LNWIN ) THEN
01089                      CALL DLASET( 'All', LNWIN, LNWIN, ZERO,
01090      $                    ONE, WORK( IPH ), LNWIN )
01091                   ELSE
01092                      CALL DLASET( 'All', DIM, DIM, ZERO,
01093      $                    ZERO, WORK( IPH ), LNWIN )
01094                   END IF
01095 *
01096 *                 Form the active window.
01097 *
01098                   IF( MYROW.EQ.RSRC1 .AND. MYCOL.EQ.CSRC1 ) THEN
01099                      ILOC = INDXG2L( LKTOP, NB, MYROW,
01100      $                    DESCH( RSRC_ ), NPROW )
01101                      JLOC = INDXG2L( LKTOP, NB, MYCOL,
01102      $                    DESCH( CSRC_ ), NPCOL )
01103                      CALL DLAMOV( 'All', DIM1, DIM1,
01104      $                    H((JLOC-1)*LLDH+ILOC), LLDH, WORK(IPH),
01105      $                    LNWIN )
01106                      IF( RSRC1.NE.RSRC4 .OR. CSRC1.NE.CSRC4 ) THEN
01107 *                       Proc#1 <==> Proc#4
01108                         CALL DGESD2D( ICTXT, DIM1, DIM1,
01109      $                       WORK(IPH), LNWIN, RSRC4, CSRC4 )
01110                         CALL DGERV2D( ICTXT, DIM4, DIM4,
01111      $                       WORK(IPH+DIM1*LNWIN+DIM1),
01112      $                       LNWIN, RSRC4, CSRC4 )
01113                      END IF
01114                   END IF
01115                   IF( MYROW.EQ.RSRC4 .AND. MYCOL.EQ.CSRC4 ) THEN
01116                      ILOC = INDXG2L( LKTOP+DIM1, NB, MYROW,
01117      $                    DESCH( RSRC_ ), NPROW )
01118                      JLOC = INDXG2L( LKTOP+DIM1, NB, MYCOL,
01119      $                    DESCH( CSRC_ ), NPCOL )
01120                      CALL DLAMOV( 'All', DIM4, DIM4,
01121      $                    H((JLOC-1)*LLDH+ILOC), LLDH,
01122      $                    WORK(IPH+DIM1*LNWIN+DIM1),
01123      $                    LNWIN )
01124                      IF( RSRC4.NE.RSRC1 .OR. CSRC4.NE.CSRC1 ) THEN
01125 *                       Proc#4 <==> Proc#1
01126                         CALL DGESD2D( ICTXT, DIM4, DIM4,
01127      $                       WORK(IPH+DIM1*LNWIN+DIM1),
01128      $                       LNWIN, RSRC1, CSRC1 )
01129                         CALL DGERV2D( ICTXT, DIM1, DIM1,
01130      $                       WORK(IPH), LNWIN, RSRC1, CSRC1 )
01131                      END IF
01132                   END IF
01133                   IF( MYROW.EQ.RSRC2 .AND. MYCOL.EQ.CSRC2 ) THEN
01134                      ILOC = INDXG2L( LKTOP, NB, MYROW,
01135      $                    DESCH( RSRC_ ), NPROW )
01136                      JLOC = INDXG2L( LKTOP+DIM1, NB, MYCOL,
01137      $                    DESCH( CSRC_ ), NPCOL )
01138                      CALL DLAMOV( 'All', DIM1, DIM4,
01139      $                    H((JLOC-1)*LLDH+ILOC), LLDH,
01140      $                    WORK(IPH+DIM1*LNWIN), LNWIN )
01141                      IF( RSRC2.NE.RSRC1 .OR. CSRC2.NE.CSRC1 ) THEN
01142 *                       Proc#2 ==> Proc#1
01143                         CALL DGESD2D( ICTXT, DIM1, DIM4,
01144      $                       WORK(IPH+DIM1*LNWIN),
01145      $                       LNWIN, RSRC1, CSRC1 )
01146                      END IF
01147                   END IF
01148                   IF( MYROW.EQ.RSRC2 .AND. MYCOL.EQ.CSRC2 ) THEN
01149                      IF( RSRC2.NE.RSRC4 .OR. CSRC2.NE.CSRC4 ) THEN
01150 *                       Proc#2 ==> Proc#4
01151                         CALL DGESD2D( ICTXT, DIM1, DIM4,
01152      $                       WORK(IPH+DIM1*LNWIN),
01153      $                       LNWIN, RSRC4, CSRC4 )
01154                      END IF
01155                   END IF
01156                   IF( MYROW.EQ.RSRC3 .AND. MYCOL.EQ.CSRC3 ) THEN
01157                      ILOC = INDXG2L( LKTOP+DIM1, NB, MYROW,
01158      $                    DESCH( RSRC_ ), NPROW )
01159                      JLOC = INDXG2L( LKTOP+DIM1-1, NB, MYCOL,
01160      $                    DESCH( CSRC_ ), NPCOL )
01161                      CALL DLAMOV( 'All', 1, 1,
01162      $                    H((JLOC-1)*LLDH+ILOC), LLDH,
01163      $                    WORK(IPH+(DIM1-1)*LNWIN+DIM1),
01164      $                    LNWIN )
01165                      IF( RSRC3.NE.RSRC1 .OR. CSRC3.NE.CSRC1 ) THEN
01166 *                       Proc#3 ==> Proc#1
01167                         CALL DGESD2D( ICTXT, 1, 1,
01168      $                       WORK(IPH+(DIM1-1)*LNWIN+DIM1),
01169      $                       LNWIN, RSRC1, CSRC1 )
01170                      END IF
01171                   END IF
01172                   IF( MYROW.EQ.RSRC3 .AND. MYCOL.EQ.CSRC3 ) THEN
01173                      IF( RSRC3.NE.RSRC4 .OR. CSRC3.NE.CSRC4 ) THEN
01174 *                       Proc#3 ==> Proc#4
01175                         CALL DGESD2D( ICTXT, 1, 1,
01176      $                       WORK(IPH+(DIM1-1)*LNWIN+DIM1),
01177      $                       LNWIN, RSRC4, CSRC4 )
01178                      END IF
01179                   END IF
01180                   IF( MYROW.EQ.RSRC1 .AND. MYCOL.EQ.CSRC1 ) THEN
01181                      IF( RSRC1.NE.RSRC2 .OR. CSRC1.NE.CSRC2 ) THEN
01182 *                       Proc#1 <== Proc#2
01183                         CALL DGERV2D( ICTXT, DIM1, DIM4,
01184      $                       WORK(IPH+DIM1*LNWIN),
01185      $                       LNWIN, RSRC2, CSRC2 )
01186                      END IF
01187                      IF( RSRC1.NE.RSRC3 .OR. CSRC1.NE.CSRC3 ) THEN
01188 *                       Proc#1 <== Proc#3
01189                         CALL DGERV2D( ICTXT, 1, 1,
01190      $                       WORK(IPH+(DIM1-1)*LNWIN+DIM1),
01191      $                       LNWIN, RSRC3, CSRC3 )
01192                      END IF
01193                   END IF
01194                   IF( MYROW.EQ.RSRC4 .AND. MYCOL.EQ.CSRC4 ) THEN
01195                      IF( RSRC4.NE.RSRC2 .OR. CSRC4.NE.CSRC2 ) THEN
01196 *                       Proc#4 <== Proc#2
01197                         CALL DGERV2D( ICTXT, DIM1, DIM4,
01198      $                       WORK(IPH+DIM1*LNWIN),
01199      $                       LNWIN, RSRC2, CSRC2 )
01200                      END IF
01201                      IF( RSRC4.NE.RSRC3 .OR. CSRC4.NE.CSRC3 ) THEN
01202 *                       Proc#4 <== Proc#3
01203                         CALL DGERV2D( ICTXT, 1, 1,
01204      $                       WORK(IPH+(DIM1-1)*LNWIN+DIM1),
01205      $                       LNWIN, RSRC3, CSRC3 )
01206                      END IF
01207                   END IF
01208 *
01209 *                 Prepare for call to DLAQR6 - it could happen that no
01210 *                 bulges where introduced in the pre-cross border step
01211 *                 since the chain was too long to fit in the top-left
01212 *                 part of the cross border window. In such a case, the
01213 *                 bulges are introduced here instead.  It could also
01214 *                 happen that the bottom-right part is too small to hold
01215 *                 the whole chain -- in such a case, the bulges are
01216 *                 chasen off immediately, as well.
01217 *
01218                   IF( (MYROW.EQ.RSRC1 .AND. MYCOL.EQ.CSRC1) .OR.
01219      $                 (MYROW.EQ.RSRC4 .AND. MYCOL.EQ.CSRC4) ) THEN
01220                      IF( LKTOP.EQ.KTOP .AND. LKBOT.EQ.KBOT .AND.
01221      $                    (DIM1.LE.LCHAIN .OR. DIM1.LE.NTINY ) ) THEN
01222                         JOB = 'All steps'
01223                         ICHOFF = 1
01224                      ELSEIF( LKTOP.EQ.KTOP .AND.
01225      $                    ( DIM1.LE.LCHAIN .OR. DIM1.LE.NTINY ) ) THEN
01226                         JOB = 'Introduce and chase'
01227                      ELSEIF( LKBOT.EQ.KBOT ) THEN
01228                         JOB = 'Off-chase bulges'
01229                         ICHOFF = 1
01230                      ELSE
01231                         JOB = 'Chase bulges'
01232                      END IF
01233                      KU = LNWIN - KDU + 1
01234                      KWH = KDU + 1
01235                      NHO = ( LNWIN-KDU+1-4 ) - ( KDU+1 ) + 1
01236                      KWV = KDU + 4
01237                      NVE = LNWIN - KDU - KWV + 1
01238                      CALL DLASET( 'All', LNWIN, LNWIN,
01239      $                    ZERO, ONE, WORK(IPUU), LNWIN )
01240 *
01241 *                    Small-bulge multi-shift QR sweep.
01242 *
01243                      LKS = MAX(1, NS - WIN*LNS + 1)
01244                      CALL DLAQR6( JOB, WANTT, .TRUE., LKACC22, LNWIN,
01245      $                    1, DIM, LNS, SR( LKS ), SI( LKS ),
01246      $                    WORK(IPH), LNWIN, 1, DIM,
01247      $                    WORK(IPUU), LNWIN, WORK(IPU), 3,
01248      $                    WORK( IPH+KU-1 ), LNWIN, NVE,
01249      $                    WORK( IPH+KWV-1 ), LNWIN, NHO,
01250      $                    WORK( IPH-1+KU+(KWH-1)*LNWIN ), LNWIN )
01251 *
01252 *                    Copy local submatrices of H back to global matrix.
01253 *
01254                      IF( MYROW.EQ.RSRC1 .AND. MYCOL.EQ.CSRC1 ) THEN
01255                         ILOC = INDXG2L( LKTOP, NB, MYROW,
01256      $                       DESCH( RSRC_ ), NPROW )
01257                         JLOC = INDXG2L( LKTOP, NB, MYCOL,
01258      $                       DESCH( CSRC_ ), NPCOL )
01259                         CALL DLAMOV( 'All', DIM1, DIM1, WORK(IPH),
01260      $                       LNWIN, H((JLOC-1)*LLDH+ILOC),
01261      $                       LLDH )
01262                      END IF
01263                      IF( MYROW.EQ.RSRC4 .AND. MYCOL.EQ.CSRC4 ) THEN
01264                         ILOC = INDXG2L( LKTOP+DIM1, NB, MYROW,
01265      $                       DESCH( RSRC_ ), NPROW )
01266                         JLOC = INDXG2L( LKTOP+DIM1, NB, MYCOL,
01267      $                       DESCH( CSRC_ ), NPCOL )
01268                         CALL DLAMOV( 'All', DIM4, DIM4,
01269      $                       WORK(IPH+DIM1*LNWIN+DIM1),
01270      $                       LNWIN, H((JLOC-1)*LLDH+ILOC), LLDH )
01271                      END IF
01272 *
01273 *                    Copy actual submatrix of U to the correct place of
01274 *                    the buffer.
01275 *
01276                      CALL DLAMOV( 'All', DIM, DIM,
01277      $                    WORK(IPUU), LNWIN, WORK(IPU), DIM )
01278                   END IF
01279 *
01280 *                 Return data to process 2 and 3.
01281 *
01282                   RWS3 = MIN(3,DIM4)
01283                   CLS3 = MIN(3,DIM1)
01284                   IF( MYROW.EQ.RSRC1 .AND. MYCOL.EQ.CSRC1 ) THEN
01285                      IF( RSRC1.NE.RSRC3 .OR. CSRC1.NE.CSRC3 ) THEN
01286 *                       Proc#1 ==> Proc#3
01287                         CALL DGESD2D( ICTXT, RWS3, CLS3,
01288      $                       WORK( IPH+(DIM1-CLS3)*LNWIN+DIM1 ),
01289      $                       LNWIN, RSRC3, CSRC3 )
01290                      END IF
01291                   END IF
01292                   IF( MYROW.EQ.RSRC4 .AND. MYCOL.EQ.CSRC4 ) THEN
01293                      IF( RSRC4.NE.RSRC2 .OR. CSRC4.NE.CSRC2 ) THEN
01294 *                       Proc#4 ==> Proc#2
01295                         CALL DGESD2D( ICTXT, DIM1, DIM4,
01296      $                       WORK( IPH+DIM1*LNWIN),
01297      $                       LNWIN, RSRC2, CSRC2 )
01298                      END IF
01299                   END IF
01300                   IF( MYROW.EQ.RSRC2 .AND. MYCOL.EQ.CSRC2 ) THEN
01301                      ILOC = INDXG2L( LKTOP, NB, MYROW,
01302      $                    DESCH( RSRC_ ), NPROW )
01303                      JLOC = INDXG2L( LKTOP+DIM1, NB, MYCOL,
01304      $                    DESCH( CSRC_ ), NPCOL )
01305                      IF( RSRC2.NE.RSRC4 .OR. CSRC2.NE.CSRC4 ) THEN
01306 *                       Proc#2 <== Proc#4
01307                         CALL DGERV2D( ICTXT, DIM1, DIM4,
01308      $                       WORK(IPH+DIM1*LNWIN),
01309      $                       LNWIN, RSRC4, CSRC4 )
01310                      END IF
01311                      CALL DLAMOV( 'All', DIM1, DIM4,
01312      $                    WORK( IPH+DIM1*LNWIN ), LNWIN,
01313      $                    H((JLOC-1)*LLDH+ILOC), LLDH )
01314                   END IF
01315                   IF( MYROW.EQ.RSRC3 .AND. MYCOL.EQ.CSRC3 ) THEN
01316                      ILOC = INDXG2L( LKTOP+DIM1, NB, MYROW,
01317      $                    DESCH( RSRC_ ), NPROW )
01318                      JLOC = INDXG2L( LKTOP+DIM1-CLS3, NB, MYCOL,
01319      $                    DESCH( CSRC_ ), NPCOL )
01320                      IF( RSRC3.NE.RSRC1 .OR. CSRC3.NE.CSRC1 ) THEN
01321 *                       Proc#3 <== Proc#1
01322                         CALL DGERV2D( ICTXT, RWS3, CLS3,
01323      $                       WORK( IPH+(DIM1-CLS3)*LNWIN+DIM1 ),
01324      $                       LNWIN, RSRC1, CSRC1 )
01325                      END IF
01326                      CALL DLAMOV( 'Upper', RWS3, CLS3,
01327      $                    WORK( IPH+(DIM1-CLS3)*LNWIN+DIM1 ),
01328      $                    LNWIN, H((JLOC-1)*LLDH+ILOC),
01329      $                    LLDH )
01330                      IF( RWS3.GT.1 .AND. CLS3.GT.1 ) THEN
01331                         ELEM = WORK( IPH+(DIM1-CLS3)*LNWIN+DIM1+1 )
01332                         IF( ELEM.NE.ZERO ) THEN
01333                            CALL DLAMOV( 'Lower', RWS3-1, CLS3-1,
01334      $                          WORK( IPH+(DIM1-CLS3)*LNWIN+DIM1+1 ),
01335      $                          LNWIN, H((JLOC-1)*LLDH+ILOC+1), LLDH )
01336                         END IF
01337                      END IF
01338                   END IF
01339 *
01340 *                 Restore correct value of LNWIN.
01341 *
01342                   LNWIN = DIM
01343 *
01344                END IF
01345 *
01346 *              Increment counter for buffers of orthogonal
01347 *              transformations.
01348 *
01349                IF( MYROW.EQ.RSRC1 .OR. MYCOL.EQ.CSRC1 .OR.
01350      $              MYROW.EQ.RSRC4 .OR. MYCOL.EQ.CSRC4 ) THEN
01351                   IF( MYROW.EQ.RSRC1 .OR. MYROW.EQ.RSRC4 )
01352      $               LENRBUF = LENRBUF + LNWIN*LNWIN
01353                   IF( MYCOL.EQ.CSRC1 .OR. MYCOL.EQ.CSRC4 )
01354      $               LENCBUF = LENCBUF + LNWIN*LNWIN
01355                END IF
01356 *
01357 *              If no cross border bulge chasing was performed for the
01358 *              current WIN:th window, the processor jump to this point
01359 *              and consider the next one.
01360 *
01361  165           CONTINUE
01362 *
01363  160        CONTINUE
01364 *
01365 *           Broadcast orthogonal transformations -- this will only happen
01366 *           if the buffer associated with the orthogonal transformations
01367 *           is not empty (controlled by LENRBUF, for row-wise
01368 *           broadcasts, and LENCBUF, for column-wise broadcasts).
01369 *
01370             DO 170 DIR = 1, 2
01371                BCDONE = .FALSE.
01372                DO 180 WIN = ODDEVEN+(CHUNKNUM-1)*WCHUNK,
01373      $              MIN(ANMWIN,MAX(1,ODDEVEN+(CHUNKNUM)*WCHUNK-1)), 2
01374                   IF( ( LENRBUF.EQ.0 .AND. LENCBUF.EQ.0 ) .OR.
01375      $                 BCDONE ) GO TO 185
01376                   RSRC1 = IWORK( 3+(WIN-1)*5 )
01377                   CSRC1 = IWORK( 4+(WIN-1)*5 )
01378                   RSRC4 = MOD( RSRC1+1, NPROW )
01379                   CSRC4 = MOD( CSRC1+1, NPCOL )
01380                   IF( ( MYROW.EQ.RSRC1 .AND. MYCOL.EQ.CSRC1 ) .OR.
01381      $                 ( MYROW.EQ.RSRC4 .AND. MYCOL.EQ.CSRC4 ) ) THEN
01382                      IF( DIR.EQ.1 .AND. LENRBUF.GT.0 .AND.
01383      $                    NPCOL.GT.1 .AND. NPROCS.GT.2 ) THEN
01384                         IF( MYROW.EQ.RSRC1 .OR. ( MYROW.EQ.RSRC4
01385      $                       .AND. RSRC4.NE.RSRC1 ) ) THEN
01386                            CALL DGEBS2D( ICTXT, 'Row', '1-Tree',
01387      $                          LENRBUF, 1, WORK, LENRBUF )
01388                         ELSE
01389                            CALL DGEBR2D( ICTXT, 'Row', '1-Tree',
01390      $                          LENRBUF, 1, WORK, LENRBUF, RSRC1,
01391      $                          CSRC1 )
01392                         END IF
01393                      ELSEIF( DIR.EQ.2 .AND. LENCBUF.GT.0 .AND.
01394      $                       NPROW.GT.1 .AND. NPROCS.GT.2 ) THEN
01395                         IF( MYCOL.EQ.CSRC1 .OR. ( MYCOL.EQ.CSRC4
01396      $                       .AND. CSRC4.NE.CSRC1 ) ) THEN
01397                            CALL DGEBS2D( ICTXT, 'Col', '1-Tree',
01398      $                          LENCBUF, 1, WORK, LENCBUF )
01399                         ELSE
01400                            CALL DGEBR2D( ICTXT, 'Col', '1-Tree',
01401      $                          LENCBUF, 1, WORK(1+LENRBUF), LENCBUF,
01402      $                          RSRC1, CSRC1 )
01403                         END IF
01404                      END IF
01405                      IF( LENRBUF.GT.0 .AND. ( MYCOL.EQ.CSRC1 .OR.
01406      $                    ( MYCOL.EQ.CSRC4 .AND. CSRC4.NE.CSRC1 ) ) )
01407      $                  CALL DLAMOV( 'All', LENRBUF, 1, WORK, LENRBUF,
01408      $                       WORK(1+LENRBUF), LENCBUF )
01409                      BCDONE = .TRUE.
01410                   ELSEIF( MYROW.EQ.RSRC1 .AND. DIR.EQ.1 ) THEN
01411                      IF( LENRBUF.GT.0 .AND. NPCOL.GT.1 )
01412      $                  CALL DGEBR2D( ICTXT, 'Row', '1-Tree', LENRBUF,
01413      $                       1, WORK, LENRBUF, RSRC1, CSRC1 )
01414                      BCDONE = .TRUE.
01415                   ELSEIF( MYCOL.EQ.CSRC1 .AND. DIR.EQ.2 ) THEN
01416                      IF( LENCBUF.GT.0 .AND. NPROW.GT.1 )
01417      $                  CALL DGEBR2D( ICTXT, 'Col', '1-Tree', LENCBUF,
01418      $                       1, WORK(1+LENRBUF), LENCBUF, RSRC1, CSRC1 )
01419                      BCDONE = .TRUE.
01420                   ELSEIF( MYROW.EQ.RSRC4 .AND. DIR.EQ.1 ) THEN
01421                      IF( LENRBUF.GT.0 .AND. NPCOL.GT.1 )
01422      $                  CALL DGEBR2D( ICTXT, 'Row', '1-Tree', LENRBUF,
01423      $                       1, WORK, LENRBUF, RSRC4, CSRC4 )
01424                      BCDONE = .TRUE.
01425                   ELSEIF( MYCOL.EQ.CSRC4 .AND. DIR.EQ.2 ) THEN
01426                      IF( LENCBUF.GT.0 .AND. NPROW.GT.1 )
01427      $                  CALL DGEBR2D( ICTXT, 'Col', '1-Tree', LENCBUF,
01428      $                       1, WORK(1+LENRBUF), LENCBUF, RSRC4, CSRC4 )
01429                      BCDONE = .TRUE.
01430                   END IF
01431  185              CONTINUE
01432  180           CONTINUE
01433  170        CONTINUE
01434 *
01435 *           Prepare for computing cross border updates by exchanging
01436 *           data in cross border update regions in H and Z.
01437 *
01438             DO 190 DIR = 1, 2
01439                WINID = 0
01440                IPW3 = 1
01441                DO 200 WIN = ODDEVEN+(CHUNKNUM-1)*WCHUNK,
01442      $              MIN(ANMWIN,MAX(1,ODDEVEN+(CHUNKNUM)*WCHUNK-1)), 2
01443                   IF( IWORK( 5+(WIN-1)*5 ).NE.1 ) GO TO 205
01444 *
01445 *                 Make sure this part of the code is only executed when
01446 *                 there has been some work performed on the WIN:th
01447 *                 window.
01448 *
01449                   LKTOP = IWORK( 1+(WIN-1)*5 )
01450                   LKBOT = IWORK( 2+(WIN-1)*5 )
01451 *
01452 *                 Extract processor indices associated with
01453 *                 the current window.
01454 *
01455                   RSRC1 = IWORK( 3+(WIN-1)*5 )
01456                   CSRC1 = IWORK( 4+(WIN-1)*5 )
01457                   RSRC4 = MOD( RSRC1+1, NPROW )
01458                   CSRC4 = MOD( CSRC1+1, NPCOL )
01459 *
01460 *                 Compute local number of rows and columns
01461 *                 of H and Z to exchange.
01462 *
01463                   IF(((MYCOL.EQ.CSRC1.OR.MYCOL.EQ.CSRC4).AND.DIR.EQ.2)
01464      $                 .OR.((MYROW.EQ.RSRC1.OR.MYROW.EQ.RSRC4).AND.
01465      $                 DIR.EQ.1)) THEN
01466                      WINID = WINID + 1
01467                      LNWIN = LKBOT - LKTOP + 1
01468                      IPU = IPNEXT
01469                      DIM1 = NB - MOD(LKTOP-1,NB)
01470                      DIM4 = LNWIN - DIM1
01471                      IPNEXT = IPU + LNWIN*LNWIN
01472                      IF( DIR.EQ.2 ) THEN
01473                         IF( WANTZ ) THEN
01474                            ZROWS = NUMROC( N, NB, MYROW, DESCZ( RSRC_ ),
01475      $                          NPROW )
01476                         ELSE
01477                            ZROWS = 0
01478                         END IF
01479                         IF( WANTT ) THEN
01480                            HROWS = NUMROC( LKTOP-1, NB, MYROW,
01481      $                          DESCH( RSRC_ ), NPROW )
01482                         ELSE
01483                            HROWS = 0
01484                         END IF
01485                      ELSE
01486                         ZROWS = 0
01487                         HROWS = 0
01488                      END IF
01489                      IF( DIR.EQ.1 ) THEN
01490                         IF( WANTT ) THEN
01491                            HCOLS = NUMROC( N - (LKTOP+DIM1-1), NB,
01492      $                          MYCOL, CSRC4, NPCOL )
01493                            IF( MYCOL.EQ.CSRC4 ) HCOLS = HCOLS - DIM4
01494                         ELSE
01495                            HCOLS = 0
01496                         END IF
01497                      ELSE
01498                         HCOLS = 0
01499                      END IF
01500                      IPW = MAX( 1 + LENRBUF + LENCBUF, IPW3 )
01501                      IPW1 = IPW + HROWS * LNWIN
01502                      IF( WANTZ ) THEN
01503                         IPW2 = IPW1 + LNWIN * HCOLS
01504                         IPW3 = IPW2 + ZROWS * LNWIN
01505                      ELSE
01506                         IPW3 = IPW1 + LNWIN * HCOLS
01507                      END IF
01508                   END IF
01509 *
01510 *                 Let each process row and column involved in the updates
01511 *                 exchange data in H and Z with their neighbours.
01512 *
01513                   IF( DIR.EQ.2 .AND. WANTT .AND. LENCBUF.GT.0 ) THEN
01514                      IF( MYCOL.EQ.CSRC1 .OR. MYCOL.EQ.CSRC4 ) THEN
01515                         DO 210 INDX = 1, NPROW
01516                            IF( MYCOL.EQ.CSRC1 ) THEN
01517                               CALL INFOG2L( 1+(INDX-1)*NB, LKTOP, DESCH,
01518      $                             NPROW, NPCOL, MYROW, MYCOL, ILOC,
01519      $                             JLOC1, RSRC, CSRC1 )
01520                               IF( MYROW.EQ.RSRC ) THEN
01521                                  CALL DLAMOV( 'All', HROWS, DIM1,
01522      $                                H((JLOC1-1)*LLDH+ILOC), LLDH,
01523      $                                WORK(IPW), HROWS )
01524                                  IF( NPCOL.GT.1 ) THEN
01525                                     EAST = MOD( MYCOL + 1, NPCOL )
01526                                     CALL DGESD2D( ICTXT, HROWS, DIM1,
01527      $                                   WORK(IPW), HROWS, RSRC, EAST )
01528                                     CALL DGERV2D( ICTXT, HROWS, DIM4,
01529      $                                   WORK(IPW+HROWS*DIM1), HROWS,
01530      $                                   RSRC, EAST )
01531                                  END IF
01532                               END IF
01533                            END IF
01534                            IF( MYCOL.EQ.CSRC4 ) THEN
01535                               CALL INFOG2L( 1+(INDX-1)*NB, LKTOP+DIM1,
01536      $                             DESCH, NPROW, NPCOL, MYROW, MYCOL,
01537      $                             ILOC, JLOC4, RSRC, CSRC4 )
01538                               IF( MYROW.EQ.RSRC ) THEN
01539                                  CALL DLAMOV( 'All', HROWS, DIM4,
01540      $                                H((JLOC4-1)*LLDH+ILOC), LLDH,
01541      $                                WORK(IPW+HROWS*DIM1), HROWS )
01542                                  IF( NPCOL.GT.1 ) THEN
01543                                     WEST = MOD( MYCOL - 1 + NPCOL,
01544      $                                   NPCOL )
01545                                     CALL DGESD2D( ICTXT, HROWS, DIM4,
01546      $                                   WORK(IPW+HROWS*DIM1), HROWS,
01547      $                                   RSRC, WEST )
01548                                     CALL DGERV2D( ICTXT, HROWS, DIM1,
01549      $                                   WORK(IPW), HROWS, RSRC, WEST )
01550                                  END IF
01551                               END IF
01552                            END IF
01553  210                    CONTINUE
01554                      END IF
01555                   END IF
01556 *
01557                   IF( DIR.EQ.1 .AND. WANTT .AND. LENRBUF.GT.0 ) THEN
01558                      IF( MYROW.EQ.RSRC1 .OR. MYROW.EQ.RSRC4 ) THEN
01559                         DO 220 INDX = 1, NPCOL
01560                            IF( MYROW.EQ.RSRC1 ) THEN
01561                               IF( INDX.EQ.1 ) THEN
01562                                  IF( LKBOT.LT.N ) THEN
01563                                     CALL INFOG2L( LKTOP, LKBOT+1, DESCH,
01564      $                                   NPROW, NPCOL, MYROW, MYCOL,
01565      $                                   ILOC1, JLOC, RSRC1, CSRC )
01566                                  ELSE
01567                                     CSRC = -1
01568                                  END IF
01569                               ELSEIF( MOD(LKBOT,NB).NE.0 ) THEN
01570                                  CALL INFOG2L( LKTOP,
01571      $                                (ICEIL(LKBOT,NB)+(INDX-2))*NB+1,
01572      $                                DESCH, NPROW, NPCOL, MYROW, MYCOL,
01573      $                                ILOC1, JLOC, RSRC1, CSRC )
01574                               ELSE
01575                                  CALL INFOG2L( LKTOP,
01576      $                                (ICEIL(LKBOT,NB)+(INDX-1))*NB+1,
01577      $                                DESCH, NPROW, NPCOL, MYROW, MYCOL,
01578      $                                ILOC1, JLOC, RSRC1, CSRC )
01579                               END IF
01580                               IF( MYCOL.EQ.CSRC ) THEN
01581                                  CALL DLAMOV( 'All', DIM1, HCOLS,
01582      $                                H((JLOC-1)*LLDH+ILOC1), LLDH,
01583      $                                WORK(IPW1), LNWIN )
01584                                  IF( NPROW.GT.1 ) THEN
01585                                     SOUTH = MOD( MYROW + 1, NPROW )
01586                                     CALL DGESD2D( ICTXT, DIM1, HCOLS,
01587      $                                   WORK(IPW1), LNWIN, SOUTH,
01588      $                                   CSRC )
01589                                     CALL DGERV2D( ICTXT, DIM4, HCOLS,
01590      $                                   WORK(IPW1+DIM1), LNWIN, SOUTH,
01591      $                                   CSRC )
01592                                  END IF
01593                               END IF
01594                            END IF
01595                            IF( MYROW.EQ.RSRC4 ) THEN
01596                               IF( INDX.EQ.1 ) THEN
01597                                  IF( LKBOT.LT.N ) THEN
01598                                     CALL INFOG2L( LKTOP+DIM1, LKBOT+1,
01599      $                                   DESCH, NPROW, NPCOL, MYROW,
01600      $                                   MYCOL, ILOC4, JLOC, RSRC4,
01601      $                                   CSRC )
01602                                  ELSE
01603                                     CSRC = -1
01604                                  END IF
01605                               ELSEIF( MOD(LKBOT,NB).NE.0 ) THEN
01606                                  CALL INFOG2L( LKTOP+DIM1,
01607      $                                (ICEIL(LKBOT,NB)+(INDX-2))*NB+1,
01608      $                                DESCH, NPROW, NPCOL, MYROW, MYCOL,
01609      $                                ILOC4, JLOC, RSRC4, CSRC )
01610                               ELSE
01611                                  CALL INFOG2L( LKTOP+DIM1,
01612      $                                (ICEIL(LKBOT,NB)+(INDX-1))*NB+1,
01613      $                                DESCH, NPROW, NPCOL, MYROW, MYCOL,
01614      $                                ILOC4, JLOC, RSRC4, CSRC )
01615                               END IF
01616                               IF( MYCOL.EQ.CSRC ) THEN
01617                                  CALL DLAMOV( 'All', DIM4, HCOLS,
01618      $                                H((JLOC-1)*LLDH+ILOC4), LLDH,
01619      $                                WORK(IPW1+DIM1), LNWIN )
01620                                  IF( NPROW.GT.1 ) THEN
01621                                     NORTH = MOD( MYROW - 1 + NPROW,
01622      $                                   NPROW )
01623                                     CALL DGESD2D( ICTXT, DIM4, HCOLS,
01624      $                                   WORK(IPW1+DIM1), LNWIN, NORTH,
01625      $                                   CSRC )
01626                                     CALL DGERV2D( ICTXT, DIM1, HCOLS,
01627      $                                   WORK(IPW1), LNWIN, NORTH,
01628      $                                   CSRC )
01629                                  END IF
01630                               END IF
01631                            END IF
01632  220                    CONTINUE
01633                      END IF
01634                   END IF
01635 *
01636                   IF( DIR.EQ.2 .AND. WANTZ .AND. LENCBUF.GT.0) THEN
01637                      IF( MYCOL.EQ.CSRC1 .OR. MYCOL.EQ.CSRC4 ) THEN
01638                         DO 230 INDX = 1, NPROW
01639                            IF( MYCOL.EQ.CSRC1 ) THEN
01640                               CALL INFOG2L( 1+(INDX-1)*NB, LKTOP,
01641      $                             DESCZ, NPROW, NPCOL, MYROW, MYCOL,
01642      $                             ILOC, JLOC1, RSRC, CSRC1 )
01643                               IF( MYROW.EQ.RSRC ) THEN
01644                                  CALL DLAMOV( 'All', ZROWS, DIM1,
01645      $                                Z((JLOC1-1)*LLDZ+ILOC), LLDZ,
01646      $                                WORK(IPW2), ZROWS )
01647                                  IF( NPCOL.GT.1 ) THEN
01648                                     EAST = MOD( MYCOL + 1, NPCOL )
01649                                     CALL DGESD2D( ICTXT, ZROWS, DIM1,
01650      $                                   WORK(IPW2), ZROWS, RSRC,
01651      $                                   EAST )
01652                                     CALL DGERV2D( ICTXT, ZROWS, DIM4,
01653      $                                   WORK(IPW2+ZROWS*DIM1),
01654      $                                   ZROWS, RSRC, EAST )
01655                                  END IF
01656                               END IF
01657                            END IF
01658                            IF( MYCOL.EQ.CSRC4 ) THEN
01659                               CALL INFOG2L( 1+(INDX-1)*NB,
01660      $                             LKTOP+DIM1, DESCZ, NPROW, NPCOL,
01661      $                             MYROW, MYCOL, ILOC, JLOC4, RSRC,
01662      $                             CSRC4 )
01663                               IF( MYROW.EQ.RSRC ) THEN
01664                                  CALL DLAMOV( 'All', ZROWS, DIM4,
01665      $                                Z((JLOC4-1)*LLDZ+ILOC), LLDZ,
01666      $                                WORK(IPW2+ZROWS*DIM1), ZROWS )
01667                                  IF( NPCOL.GT.1 ) THEN
01668                                     WEST = MOD( MYCOL - 1 + NPCOL,
01669      $                                   NPCOL )
01670                                     CALL DGESD2D( ICTXT, ZROWS, DIM4,
01671      $                                   WORK(IPW2+ZROWS*DIM1),
01672      $                                   ZROWS, RSRC, WEST )
01673                                     CALL DGERV2D( ICTXT, ZROWS, DIM1,
01674      $                                   WORK(IPW2), ZROWS, RSRC,
01675      $                                   WEST )
01676                                  END IF
01677                               END IF
01678                            END IF
01679  230                    CONTINUE
01680                      END IF
01681                   END IF
01682 *
01683 *                 If no exchanges was performed for the current window,
01684 *                 all processors jump to this point and try the next
01685 *                 one.
01686 *
01687  205              CONTINUE
01688 *
01689  200           CONTINUE
01690 *
01691 *              Compute crossborder bulge-chase updates.
01692 *
01693                WINID = 0
01694                IF( DIR.EQ.1 ) THEN
01695                   IPNEXT = 1
01696                ELSE
01697                   IPNEXT = 1 + LENRBUF
01698                END IF
01699                IPW3 = 1
01700                DO 240 WIN = ODDEVEN+(CHUNKNUM-1)*WCHUNK,
01701      $              MIN(ANMWIN,MAX(1,ODDEVEN+(CHUNKNUM)*WCHUNK-1)), 2
01702                   IF( IWORK( 5+(WIN-1)*5 ).NE.1 ) GO TO 245
01703 *
01704 *                 Only perform this part of the code if there was really
01705 *                 some work performed on the WIN:th window.
01706 *
01707                   LKTOP = IWORK( 1+(WIN-1)*5 )
01708                   LKBOT = IWORK( 2+(WIN-1)*5 )
01709                   LNWIN = LKBOT - LKTOP + 1
01710 *
01711 *                 Extract the processor indices associated with
01712 *                 the current window.
01713 *
01714                   RSRC1 = IWORK( 3+(WIN-1)*5 )
01715                   CSRC1 = IWORK( 4+(WIN-1)*5 )
01716                   RSRC4 = MOD( RSRC1+1, NPROW )
01717                   CSRC4 = MOD( CSRC1+1, NPCOL )
01718 *
01719                   IF(((MYCOL.EQ.CSRC1.OR.MYCOL.EQ.CSRC4).AND.DIR.EQ.2)
01720      $                 .OR.((MYROW.EQ.RSRC1.OR.MYROW.EQ.RSRC4).AND.
01721      $                 DIR.EQ.1)) THEN
01722 *
01723 *                    Set up workspaces.
01724 *
01725                      WINID = WINID + 1
01726                      LKTOP = IWORK( 1+(WIN-1)*5 )
01727                      LKBOT = IWORK( 2+(WIN-1)*5 )
01728                      LNWIN = LKBOT - LKTOP + 1
01729                      DIM1 = NB - MOD(LKTOP-1,NB)
01730                      DIM4 = LNWIN - DIM1
01731                      IPU = IPNEXT + (WINID-1)*LNWIN*LNWIN
01732                      IF( DIR.EQ.2 ) THEN
01733                         IF( WANTZ ) THEN
01734                            ZROWS = NUMROC( N, NB, MYROW, DESCZ( RSRC_ ),
01735      $                          NPROW )
01736                         ELSE
01737                            ZROWS = 0
01738                         END IF
01739                         IF( WANTT ) THEN
01740                            HROWS = NUMROC( LKTOP-1, NB, MYROW,
01741      $                          DESCH( RSRC_ ), NPROW )
01742                         ELSE
01743                            HROWS = 0
01744                         END IF
01745                      ELSE
01746                         ZROWS = 0
01747                         HROWS = 0
01748                      END IF
01749                      IF( DIR.EQ.1 ) THEN
01750                         IF( WANTT ) THEN
01751                            HCOLS = NUMROC( N - (LKTOP+DIM1-1), NB,
01752      $                          MYCOL, CSRC4, NPCOL )
01753                            IF( MYCOL.EQ.CSRC4 ) HCOLS = HCOLS - DIM4
01754                         ELSE
01755                            HCOLS = 0
01756                         END IF
01757                      ELSE
01758                         HCOLS = 0
01759                      END IF
01760 *
01761 *                    IPW  = local copy of overlapping column block of H
01762 *                    IPW1 = local copy of overlapping row block of H
01763 *                    IPW2 = local copy of overlapping column block of Z
01764 *                    IPW3 = workspace for right hand side of matrix
01765 *                           multiplication
01766 *
01767                      IPW = MAX( 1 + LENRBUF + LENCBUF, IPW3 )
01768                      IPW1 = IPW + HROWS * LNWIN
01769                      IF( WANTZ ) THEN
01770                         IPW2 = IPW1 + LNWIN * HCOLS
01771                         IPW3 = IPW2 + ZROWS * LNWIN
01772                      ELSE
01773                         IPW3 = IPW1 + LNWIN * HCOLS
01774                      END IF
01775 *
01776 *                    Recompute job to see if special structure of U
01777 *                    could possibly be exploited.
01778 *
01779                      IF( LKTOP.EQ.KTOP .AND. LKBOT.EQ.KBOT ) THEN
01780                         JOB = 'All steps'
01781                      ELSEIF( LKTOP.EQ.KTOP .AND.
01782      $                    ( DIM1.LT.LCHAIN+1 .OR. DIM1.LE.NTINY ) )
01783      $                    THEN
01784                         JOB = 'Introduce and chase'
01785                      ELSEIF( LKBOT.EQ.KBOT ) THEN
01786                         JOB = 'Off-chase bulges'
01787                      ELSE
01788                         JOB = 'Chase bulges'
01789                      END IF
01790                   END IF
01791 *
01792 *                 Test if to exploit sparsity structure of
01793 *                 orthogonal matrix U.
01794 *
01795                   KS = DIM1+DIM4-LNS/2*3
01796                   IF( .NOT. BLK22 .OR. DIM1.NE.KS .OR.
01797      $                 DIM4.NE.KS .OR. LSAME(JOB,'I') .OR.
01798      $                 LSAME(JOB,'O') .OR. LNS.LE.2 ) THEN
01799 *
01800 *                    Update the columns of H and Z.
01801 *
01802                      IF( DIR.EQ.2 .AND. WANTT .AND. LENCBUF.GT.0 ) THEN
01803                         DO 250 INDX = 1, MIN(LKTOP-1,1+(NPROW-1)*NB), NB
01804                            IF( MYCOL.EQ.CSRC1 ) THEN
01805                               CALL INFOG2L( INDX, LKTOP, DESCH, NPROW,
01806      $                             NPCOL, MYROW, MYCOL, ILOC, JLOC,
01807      $                             RSRC, CSRC1 )
01808                               IF( MYROW.EQ.RSRC ) THEN
01809                                  CALL DGEMM( 'No transpose',
01810      $                                'No transpose', HROWS, DIM1,
01811      $                                LNWIN, ONE, WORK( IPW ), HROWS,
01812      $                                WORK( IPU ), LNWIN, ZERO,
01813      $                                WORK(IPW3), HROWS )
01814                                  CALL DLAMOV( 'All', HROWS, DIM1,
01815      $                                WORK(IPW3), HROWS,
01816      $                                H((JLOC-1)*LLDH+ILOC), LLDH )
01817                               END IF
01818                            END IF
01819                            IF( MYCOL.EQ.CSRC4 ) THEN
01820                               CALL INFOG2L( INDX, LKTOP+DIM1, DESCH,
01821      $                             NPROW, NPCOL, MYROW, MYCOL, ILOC,
01822      $                             JLOC, RSRC, CSRC4 )
01823                               IF( MYROW.EQ.RSRC ) THEN
01824                                  CALL DGEMM( 'No transpose',
01825      $                                'No transpose', HROWS, DIM4,
01826      $                                LNWIN, ONE, WORK( IPW ), HROWS,
01827      $                                WORK( IPU+LNWIN*DIM1 ), LNWIN,
01828      $                                ZERO, WORK(IPW3), HROWS )
01829                                  CALL DLAMOV( 'All', HROWS, DIM4,
01830      $                                WORK(IPW3), HROWS,
01831      $                                H((JLOC-1)*LLDH+ILOC), LLDH )
01832                               END IF
01833                            END IF
01834  250                    CONTINUE
01835                      END IF
01836 *
01837                      IF( DIR.EQ.2 .AND. WANTZ .AND. LENCBUF.GT.0 ) THEN
01838                         DO 260 INDX = 1, MIN(N,1+(NPROW-1)*NB), NB
01839                            IF( MYCOL.EQ.CSRC1 ) THEN
01840                               CALL INFOG2L( INDX, LKTOP, DESCZ, NPROW,
01841      $                             NPCOL, MYROW, MYCOL, ILOC, JLOC,
01842      $                             RSRC, CSRC1 )
01843                               IF( MYROW.EQ.RSRC ) THEN
01844                                  CALL DGEMM( 'No transpose',
01845      $                                'No transpose', ZROWS, DIM1,
01846      $                                LNWIN, ONE, WORK( IPW2 ),
01847      $                                ZROWS, WORK( IPU ), LNWIN,
01848      $                                ZERO, WORK(IPW3), ZROWS )
01849                                  CALL DLAMOV( 'All', ZROWS, DIM1,
01850      $                                WORK(IPW3), ZROWS,
01851      $                                Z((JLOC-1)*LLDZ+ILOC), LLDZ )
01852                               END IF
01853                            END IF
01854                            IF( MYCOL.EQ.CSRC4 ) THEN
01855                               CALL INFOG2L( INDX, LKTOP+DIM1, DESCZ,
01856      $                             NPROW, NPCOL, MYROW, MYCOL, ILOC,
01857      $                             JLOC, RSRC, CSRC4 )
01858                               IF( MYROW.EQ.RSRC ) THEN
01859                                  CALL DGEMM( 'No transpose',
01860      $                                'No transpose', ZROWS, DIM4,
01861      $                                LNWIN, ONE, WORK( IPW2 ),
01862      $                                ZROWS,
01863      $                                WORK( IPU+LNWIN*DIM1 ), LNWIN,
01864      $                                ZERO, WORK(IPW3), ZROWS )
01865                                  CALL DLAMOV( 'All', ZROWS, DIM4,
01866      $                                WORK(IPW3), ZROWS,
01867      $                                Z((JLOC-1)*LLDZ+ILOC), LLDZ )
01868                               END IF
01869                            END IF
01870  260                    CONTINUE
01871                      END IF
01872 *
01873 *                    Update the rows of H.
01874 *
01875                      IF( DIR.EQ.1 .AND. WANTT .AND. LENRBUF.GT.0 ) THEN
01876                         IF( LKBOT.LT.N ) THEN
01877                            IF( MYROW.EQ.RSRC1.AND.MYCOL.EQ.CSRC4 .AND.
01878      $                          MOD(LKBOT,NB).NE.0 ) THEN
01879                               INDX = LKBOT + 1
01880                               CALL INFOG2L( LKTOP, INDX, DESCH, NPROW,
01881      $                             NPCOL, MYROW, MYCOL, ILOC, JLOC,
01882      $                             RSRC1, CSRC4 )
01883                               CALL DGEMM( 'Transpose', 'No Transpose',
01884      $                             DIM1, HCOLS, LNWIN, ONE, WORK(IPU),
01885      $                             LNWIN, WORK( IPW1 ), LNWIN, ZERO,
01886      $                             WORK(IPW3), DIM1 )
01887                               CALL DLAMOV( 'All', DIM1, HCOLS,
01888      $                             WORK(IPW3), DIM1,
01889      $                             H((JLOC-1)*LLDH+ILOC), LLDH )
01890                            END IF
01891                            IF( MYROW.EQ.RSRC4.AND.MYCOL.EQ.CSRC4 .AND.
01892      $                          MOD(LKBOT,NB).NE.0 ) THEN
01893                               INDX = LKBOT + 1
01894                               CALL INFOG2L( LKTOP+DIM1, INDX, DESCH,
01895      $                             NPROW, NPCOL, MYROW, MYCOL, ILOC,
01896      $                             JLOC, RSRC4, CSRC4 )
01897                               CALL DGEMM( 'Transpose', 'No Transpose',
01898      $                             DIM4, HCOLS, LNWIN, ONE,
01899      $                             WORK( IPU+DIM1*LNWIN ), LNWIN,
01900      $                             WORK( IPW1), LNWIN, ZERO,
01901      $                             WORK(IPW3), DIM4 )
01902                               CALL DLAMOV( 'All', DIM4, HCOLS,
01903      $                             WORK(IPW3), DIM4,
01904      $                             H((JLOC-1)*LLDH+ILOC), LLDH )
01905                            END IF
01906                            INDXS = ICEIL(LKBOT,NB)*NB + 1
01907                            IF( MOD(LKBOT,NB).NE.0 ) THEN
01908                               INDXE = MIN(N,INDXS+(NPCOL-2)*NB)
01909                            ELSE
01910                               INDXE = MIN(N,INDXS+(NPCOL-1)*NB)
01911                            END IF
01912                            DO 270 INDX = INDXS, INDXE, NB
01913                               IF( MYROW.EQ.RSRC1 ) THEN
01914                                  CALL INFOG2L( LKTOP, INDX, DESCH,
01915      $                                NPROW, NPCOL, MYROW, MYCOL, ILOC,
01916      $                                JLOC, RSRC1, CSRC )
01917                                  IF( MYCOL.EQ.CSRC ) THEN
01918                                     CALL DGEMM( 'Transpose',
01919      $                                   'No Transpose', DIM1, HCOLS,
01920      $                                   LNWIN, ONE, WORK( IPU ), LNWIN,
01921      $                                   WORK( IPW1 ), LNWIN, ZERO,
01922      $                                   WORK(IPW3), DIM1 )
01923                                     CALL DLAMOV( 'All', DIM1, HCOLS,
01924      $                                   WORK(IPW3), DIM1,
01925      $                                   H((JLOC-1)*LLDH+ILOC), LLDH )
01926                                  END IF
01927                               END IF
01928                               IF( MYROW.EQ.RSRC4 ) THEN
01929                                  CALL INFOG2L( LKTOP+DIM1, INDX, DESCH,
01930      $                                NPROW, NPCOL, MYROW, MYCOL, ILOC,
01931      $                                JLOC, RSRC4, CSRC )
01932                                  IF( MYCOL.EQ.CSRC ) THEN
01933                                     CALL DGEMM( 'Transpose',
01934      $                                   'No Transpose', DIM4, HCOLS,
01935      $                                   LNWIN, ONE,
01936      $                                   WORK( IPU+LNWIN*DIM1 ), LNWIN,
01937      $                                   WORK( IPW1 ), LNWIN,
01938      $                                   ZERO, WORK(IPW3), DIM4 )
01939                                     CALL DLAMOV( 'All', DIM4, HCOLS,
01940      $                                   WORK(IPW3), DIM4,
01941      $                                   H((JLOC-1)*LLDH+ILOC), LLDH )
01942                                  END IF
01943                               END IF
01944  270                       CONTINUE
01945                         END IF
01946                      END IF
01947                   ELSE
01948 *
01949 *                    Update the columns of H and Z.
01950 *
01951 *                    Compute H2*U21 + H1*U11 on the left side of the border.
01952 *
01953                      IF( DIR.EQ.2 .AND. WANTT .AND. LENCBUF.GT.0 ) THEN
01954                         INDXE = MIN(LKTOP-1,1+(NPROW-1)*NB)
01955                         DO 280 INDX = 1, INDXE, NB
01956                            IF( MYCOL.EQ.CSRC1 ) THEN
01957                               CALL INFOG2L( INDX, LKTOP, DESCH, NPROW,
01958      $                             NPCOL, MYROW, MYCOL, ILOC, JLOC,
01959      $                             RSRC, CSRC1 )
01960                               IF( MYROW.EQ.RSRC ) THEN
01961                                  CALL DLAMOV( 'All', HROWS, KS,
01962      $                                WORK( IPW+HROWS*DIM4), HROWS,
01963      $                                WORK(IPW3), HROWS )
01964                                  CALL DTRMM( 'Right', 'Upper',
01965      $                                'No transpose',
01966      $                                'Non-unit', HROWS, KS, ONE,
01967      $                                WORK( IPU+DIM4 ), LNWIN,
01968      $                                WORK(IPW3), HROWS )
01969                                  CALL DGEMM( 'No transpose',
01970      $                                'No transpose', HROWS, KS, DIM4,
01971      $                                ONE, WORK( IPW ), HROWS,
01972      $                                WORK( IPU ), LNWIN, ONE,
01973      $                                WORK(IPW3), HROWS )
01974                                  CALL DLAMOV( 'All', HROWS, KS,
01975      $                                WORK(IPW3), HROWS,
01976      $                                H((JLOC-1)*LLDH+ILOC), LLDH )
01977                               END IF
01978                            END IF
01979 *
01980 *                          Compute H1*U12 + H2*U22 on the right side of
01981 *                          the border.
01982 *
01983                            IF( MYCOL.EQ.CSRC4 ) THEN
01984                               CALL INFOG2L( INDX, LKTOP+DIM1, DESCH,
01985      $                             NPROW, NPCOL, MYROW, MYCOL, ILOC,
01986      $                             JLOC, RSRC, CSRC4 )
01987                               IF( MYROW.EQ.RSRC ) THEN
01988                                  CALL DLAMOV( 'All', HROWS, DIM4,
01989      $                                WORK(IPW), HROWS, WORK( IPW3 ),
01990      $                                HROWS )
01991                                  CALL DTRMM( 'Right', 'Lower',
01992      $                                'No transpose',
01993      $                                'Non-unit', HROWS, DIM4, ONE,
01994      $                                WORK( IPU+LNWIN*KS ), LNWIN,
01995      $                                WORK( IPW3 ), HROWS )
01996                                  CALL DGEMM( 'No transpose',
01997      $                                'No transpose', HROWS, DIM4, KS,
01998      $                                ONE, WORK( IPW+HROWS*DIM4),
01999      $                                HROWS,
02000      $                                WORK( IPU+LNWIN*KS+DIM4 ), LNWIN,
02001      $                                ONE, WORK( IPW3 ), HROWS )
02002                                  CALL DLAMOV( 'All', HROWS, DIM4,
02003      $                                WORK(IPW3), HROWS,
02004      $                                H((JLOC-1)*LLDH+ILOC), LLDH )
02005                               END IF
02006                            END IF
02007  280                    CONTINUE
02008                      END IF
02009 *
02010                      IF( DIR.EQ.2 .AND. WANTZ .AND. LENCBUF.GT.0 ) THEN
02011 *
02012 *                       Compute Z2*U21 + Z1*U11 on the left side
02013 *                       of border.
02014 *
02015                         INDXE = MIN(N,1+(NPROW-1)*NB)
02016                         DO 290 INDX = 1, INDXE, NB
02017                            IF( MYCOL.EQ.CSRC1 ) THEN
02018                               CALL INFOG2L( INDX, I, DESCZ, NPROW,
02019      $                             NPCOL, MYROW, MYCOL, ILOC, JLOC,
02020      $                             RSRC, CSRC1 )
02021                               IF( MYROW.EQ.RSRC ) THEN
02022                                  CALL DLAMOV( 'All', ZROWS, KS,
02023      $                                WORK( IPW2+ZROWS*DIM4),
02024      $                                ZROWS, WORK(IPW3), ZROWS )
02025                                  CALL DTRMM( 'Right', 'Upper',
02026      $                                'No transpose',
02027      $                                'Non-unit', ZROWS, KS, ONE,
02028      $                                WORK( IPU+DIM4 ), LNWIN,
02029      $                                WORK(IPW3), ZROWS )
02030                                  CALL DGEMM( 'No transpose',
02031      $                                'No transpose', ZROWS, KS,
02032      $                                DIM4, ONE, WORK( IPW2 ),
02033      $                                ZROWS, WORK( IPU ), LNWIN,
02034      $                                ONE, WORK(IPW3), ZROWS )
02035                                  CALL DLAMOV( 'All', ZROWS, KS,
02036      $                                WORK(IPW3), ZROWS,
02037      $                                Z((JLOC-1)*LLDZ+ILOC), LLDZ )
02038                               END IF
02039                            END IF
02040 *
02041 *                          Compute Z1*U12 + Z2*U22 on the right side
02042 *                          of border.
02043 *
02044                            IF( MYCOL.EQ.CSRC4 ) THEN
02045                               CALL INFOG2L( INDX, I+DIM1, DESCZ,
02046      $                             NPROW, NPCOL, MYROW, MYCOL, ILOC,
02047      $                             JLOC, RSRC, CSRC4 )
02048                               IF( MYROW.EQ.RSRC ) THEN
02049                                  CALL DLAMOV( 'All', ZROWS, DIM4,
02050      $                                WORK(IPW2), ZROWS,
02051      $                                WORK( IPW3 ), ZROWS )
02052                                  CALL DTRMM( 'Right', 'Lower',
02053      $                                'No transpose',
02054      $                                'Non-unit', ZROWS, DIM4,
02055      $                                ONE, WORK( IPU+LNWIN*KS ),
02056      $                                LNWIN, WORK( IPW3 ), ZROWS )
02057                                  CALL DGEMM( 'No transpose',
02058      $                                'No transpose', ZROWS, DIM4,
02059      $                                KS, ONE,
02060      $                                WORK( IPW2+ZROWS*(DIM4)),
02061      $                                ZROWS,
02062      $                                WORK( IPU+LNWIN*KS+DIM4 ),
02063      $                                LNWIN, ONE, WORK( IPW3 ),
02064      $                                ZROWS )
02065                                  CALL DLAMOV( 'All', ZROWS, DIM4,
02066      $                                WORK(IPW3), ZROWS,
02067      $                                Z((JLOC-1)*LLDZ+ILOC), LLDZ )
02068                               END IF
02069                            END IF
02070  290                    CONTINUE
02071                      END IF
02072 *
02073                      IF( DIR.EQ.1 .AND. WANTT .AND. LENRBUF.GT.0) THEN
02074                         IF ( LKBOT.LT.N ) THEN
02075 *
02076 *                          Compute U21**T*H2 + U11**T*H1 on the upper
02077 *                          side of the border.
02078 *
02079                            IF( MYROW.EQ.RSRC1.AND.MYCOL.EQ.CSRC4.AND.
02080      $                          MOD(LKBOT,NB).NE.0 ) THEN
02081                               INDX = LKBOT + 1
02082                               CALL INFOG2L( LKTOP, INDX, DESCH, NPROW,
02083      $                             NPCOL, MYROW, MYCOL, ILOC, JLOC,
02084      $                             RSRC1, CSRC4 )
02085                               CALL DLAMOV( 'All', KS, HCOLS,
02086      $                             WORK( IPW1+DIM4 ), LNWIN,
02087      $                             WORK(IPW3), KS )
02088                               CALL DTRMM( 'Left', 'Upper', 'Transpose',
02089      $                             'Non-unit', KS, HCOLS, ONE,
02090      $                             WORK( IPU+DIM4 ), LNWIN,
02091      $                             WORK(IPW3), KS )
02092                               CALL DGEMM( 'Transpose', 'No transpose',
02093      $                             KS, HCOLS, DIM4, ONE, WORK(IPU),
02094      $                             LNWIN, WORK(IPW1), LNWIN,
02095      $                             ONE, WORK(IPW3), KS )
02096                               CALL DLAMOV( 'All', KS, HCOLS,
02097      $                             WORK(IPW3), KS,
02098      $                             H((JLOC-1)*LLDH+ILOC), LLDH )
02099                            END IF
02100 *
02101 *                          Compute U12**T*H1 + U22**T*H2 one the lower
02102 *                          side of the border.
02103 *
02104                            IF( MYROW.EQ.RSRC4.AND.MYCOL.EQ.CSRC4.AND.
02105      $                          MOD(LKBOT,NB).NE.0 ) THEN
02106                               INDX = LKBOT + 1
02107                               CALL INFOG2L( LKTOP+DIM1, INDX, DESCH,
02108      $                             NPROW, NPCOL, MYROW, MYCOL, ILOC,
02109      $                             JLOC, RSRC4, CSRC4 )
02110                               CALL DLAMOV( 'All', DIM4, HCOLS,
02111      $                             WORK( IPW1 ), LNWIN,
02112      $                             WORK( IPW3 ), DIM4 )
02113                               CALL DTRMM( 'Left', 'Lower', 'Transpose',
02114      $                             'Non-unit', DIM4, HCOLS, ONE,
02115      $                             WORK( IPU+LNWIN*KS ), LNWIN,
02116      $                             WORK( IPW3 ), DIM4 )
02117                               CALL DGEMM( 'Transpose', 'No Transpose',
02118      $                             DIM4, HCOLS, KS, ONE,
02119      $                             WORK( IPU+LNWIN*KS+DIM4 ), LNWIN,
02120      $                             WORK( IPW1+DIM1 ), LNWIN,
02121      $                             ONE, WORK( IPW3), DIM4 )
02122                               CALL DLAMOV( 'All', DIM4, HCOLS,
02123      $                             WORK(IPW3), DIM4,
02124      $                             H((JLOC-1)*LLDH+ILOC), LLDH )
02125                            END IF
02126 *
02127 *                          Compute U21**T*H2 + U11**T*H1 on upper side
02128 *                          on border.
02129 *
02130                            INDXS = ICEIL(LKBOT,NB)*NB+1
02131                            IF( MOD(LKBOT,NB).NE.0 ) THEN
02132                               INDXE = MIN(N,INDXS+(NPCOL-2)*NB)
02133                            ELSE
02134                               INDXE = MIN(N,INDXS+(NPCOL-1)*NB)
02135                            END IF
02136                            DO 300 INDX = INDXS, INDXE, NB
02137                               IF( MYROW.EQ.RSRC1 ) THEN
02138                                  CALL INFOG2L( LKTOP, INDX, DESCH,
02139      $                                NPROW, NPCOL, MYROW, MYCOL, ILOC,
02140      $                                JLOC, RSRC1, CSRC )
02141                                  IF( MYCOL.EQ.CSRC ) THEN
02142                                     CALL DLAMOV( 'All', KS, HCOLS,
02143      $                                   WORK( IPW1+DIM4 ), LNWIN,
02144      $                                   WORK(IPW3), KS )
02145                                     CALL DTRMM( 'Left', 'Upper',
02146      $                                   'Transpose', 'Non-unit',
02147      $                                   KS, HCOLS, ONE,
02148      $                                   WORK( IPU+DIM4 ), LNWIN,
02149      $                                   WORK(IPW3), KS )
02150                                     CALL DGEMM( 'Transpose',
02151      $                                   'No transpose', KS, HCOLS,
02152      $                                   DIM4, ONE, WORK(IPU), LNWIN,
02153      $                                   WORK(IPW1), LNWIN, ONE,
02154      $                                   WORK(IPW3), KS )
02155                                     CALL DLAMOV( 'All', KS, HCOLS,
02156      $                                   WORK(IPW3), KS,
02157      $                                   H((JLOC-1)*LLDH+ILOC), LLDH )
02158                                  END IF
02159                               END IF
02160 *
02161 *                             Compute U12**T*H1 + U22**T*H2 on lower
02162 *                             side of border.
02163 *
02164                               IF( MYROW.EQ.RSRC4 ) THEN
02165                                  CALL INFOG2L( LKTOP+DIM1, INDX, DESCH,
02166      $                                NPROW, NPCOL, MYROW, MYCOL, ILOC,
02167      $                                JLOC, RSRC4, CSRC )
02168                                  IF( MYCOL.EQ.CSRC ) THEN
02169                                     CALL DLAMOV( 'All', DIM4, HCOLS,
02170      $                                   WORK( IPW1 ), LNWIN,
02171      $                                   WORK( IPW3 ), DIM4 )
02172                                     CALL DTRMM( 'Left', 'Lower',
02173      $                                   'Transpose','Non-unit',
02174      $                                   DIM4, HCOLS, ONE,
02175      $                                   WORK( IPU+LNWIN*KS ), LNWIN,
02176      $                                   WORK( IPW3 ), DIM4 )
02177                                     CALL DGEMM( 'Transpose',
02178      $                                   'No Transpose', DIM4, HCOLS,
02179      $                                   KS, ONE,
02180      $                                   WORK( IPU+LNWIN*KS+DIM4 ),
02181      $                                   LNWIN, WORK( IPW1+DIM1 ),
02182      $                                   LNWIN, ONE, WORK( IPW3),
02183      $                                   DIM4 )
02184                                     CALL DLAMOV( 'All', DIM4, HCOLS,
02185      $                                   WORK(IPW3), DIM4,
02186      $                                   H((JLOC-1)*LLDH+ILOC), LLDH )
02187                                  END IF
02188                               END IF
02189  300                       CONTINUE
02190                         END IF
02191                      END IF
02192                   END IF
02193 *
02194 *                 Update window information - mark processed windows are
02195 *                 completed.
02196 *
02197                   IF( DIR.EQ.2 ) THEN
02198                      IF( LKBOT.EQ.KBOT ) THEN
02199                         LKTOP = KBOT+1
02200                         LKBOT = KBOT+1
02201                         IWORK( 1+(WIN-1)*5 ) = LKTOP
02202                         IWORK( 2+(WIN-1)*5 ) = LKBOT
02203                      ELSE
02204                         LKTOP = MIN( LKTOP + LNWIN - LCHAIN,
02205      $                       MIN( KBOT, ICEIL( LKBOT, NB )*NB ) -
02206      $                       LCHAIN + 1 )
02207                         IWORK( 1+(WIN-1)*5 ) = LKTOP
02208                         LKBOT = MIN( MAX( LKBOT + LNWIN - LCHAIN,
02209      $                       LKTOP + NWIN - 1), MIN( KBOT,
02210      $                       ICEIL( LKBOT, NB )*NB ) )
02211                         IWORK( 2+(WIN-1)*5 ) = LKBOT
02212                      END IF
02213                      IF( IWORK( 5+(WIN-1)*5 ).EQ.1 )
02214      $                    IWORK( 5+(WIN-1)*5 ) = 2
02215                      IWORK( 3+(WIN-1)*5 ) = RSRC4
02216                      IWORK( 4+(WIN-1)*5 ) = CSRC4
02217                   END IF
02218 *
02219 *                 If nothing was done for the WIN:th window, all
02220 *                 processors come here and consider the next one
02221 *                 instead.
02222 *
02223  245              CONTINUE
02224  240           CONTINUE
02225  190        CONTINUE
02226  150     CONTINUE
02227  140     CONTINUE
02228 *
02229 *        Chased off bulges from first window?
02230 *
02231          IF( NPROCS.GT.1 )
02232      $      CALL IGAMX2D( ICTXT, 'All', '1-Tree', 1, 1, ICHOFF, 1,
02233      $           -1, -1, -1, -1, -1 )
02234 *
02235 *        If the bulge was chasen off from first window it is removed.
02236 *
02237          IF( ICHOFF.GT.0 ) THEN
02238             DO 198 WIN = 2, ANMWIN
02239                IWORK( 1+(WIN-2)*5 ) = IWORK( 1+(WIN-1)*5 )
02240                IWORK( 2+(WIN-2)*5 ) = IWORK( 2+(WIN-1)*5 )
02241                IWORK( 3+(WIN-2)*5 ) = IWORK( 3+(WIN-1)*5 )
02242                IWORK( 4+(WIN-2)*5 ) = IWORK( 4+(WIN-1)*5 )
02243  198        CONTINUE
02244             ANMWIN = ANMWIN - 1
02245             IPIW = 6+(ANMWIN-1)*5
02246          END IF
02247 *
02248 *        If we have no more windows, return.
02249 *
02250          IF( ANMWIN.LT.1 ) RETURN
02251 *
02252 *        Check for any more windows to bring over the border.
02253 *
02254          WINFIN = 0
02255          DO 199 WIN = 1, ANMWIN
02256             WINFIN = WINFIN+IWORK( 5+(WIN-1)*5 )
02257  199     CONTINUE
02258          IF( WINFIN.LT.2*ANMWIN ) GO TO 137
02259 *
02260 *        Zero out process mark for each window - this is legal now when
02261 *        the process starts over with local bulge-chasing etc.
02262 *
02263          DO 201 WIN = 1, ANMWIN
02264             IWORK( 5+(WIN-1)*5 ) = 0
02265  201     CONTINUE
02266 *
02267       END IF
02268 *
02269 *     Go back to local bulge-chase and see if there is more work to do.
02270 *
02271       GO TO 20
02272 *
02273 *     End of PDLAQR5
02274 *
02275       END