ScaLAPACK  2.0.2
ScaLAPACK: Scalable Linear Algebra PACKage
pclaconsb.f
Go to the documentation of this file.
00001       SUBROUTINE PCLACONSB( A, DESCA, I, L, M, H44, H33, H43H34, BUF,
00002      $                      LWORK )
00003 *
00004 *  -- ScaLAPACK routine (version 1.7) --
00005 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
00006 *     and University of California, Berkeley.
00007 *     July 31, 2001
00008 *
00009 *     .. Scalar Arguments ..
00010       INTEGER            I, L, LWORK, M
00011       COMPLEX            H33, H43H34, H44
00012 *     ..
00013 *     .. Array Arguments ..
00014       INTEGER            DESCA( * )
00015       COMPLEX            A( * ), BUF( * )
00016 *     ..
00017 *
00018 *  Purpose
00019 *  =======
00020 *
00021 *  PCLACONSB looks for two consecutive small subdiagonal elements by
00022 *     seeing the effect of starting a double shift QR iteration
00023 *     given by H44, H33, & H43H34 and see if this would make a
00024 *     subdiagonal negligible.
00025 *
00026 *  Notes
00027 *  =====
00028 *
00029 *  Each global data object is described by an associated description
00030 *  vector.  This vector stores the information required to establish
00031 *  the mapping between an object element and its corresponding process
00032 *  and memory location.
00033 *
00034 *  Let A be a generic term for any 2D block cyclicly distributed array.
00035 *  Such a global array has an associated description vector DESCA.
00036 *  In the following comments, the character _ should be read as
00037 *  "of the global array".
00038 *
00039 *  NOTATION        STORED IN      EXPLANATION
00040 *  --------------- -------------- --------------------------------------
00041 *  DTYPE_A(global) DESCA( DTYPE_ )The descriptor type.  In this case,
00042 *                                 DTYPE_A = 1.
00043 *  CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
00044 *                                 the BLACS process grid A is distribu-
00045 *                                 ted over. The context itself is glo-
00046 *                                 bal, but the handle (the integer
00047 *                                 value) may vary.
00048 *  M_A    (global) DESCA( M_ )    The number of rows in the global
00049 *                                 array A.
00050 *  N_A    (global) DESCA( N_ )    The number of columns in the global
00051 *                                 array A.
00052 *  MB_A   (global) DESCA( MB_ )   The blocking factor used to distribute
00053 *                                 the rows of the array.
00054 *  NB_A   (global) DESCA( NB_ )   The blocking factor used to distribute
00055 *                                 the columns of the array.
00056 *  RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
00057 *                                 row of the array A is distributed.
00058 *  CSRC_A (global) DESCA( CSRC_ ) The process column over which the
00059 *                                 first column of the array A is
00060 *                                 distributed.
00061 *  LLD_A  (local)  DESCA( LLD_ )  The leading dimension of the local
00062 *                                 array.  LLD_A >= MAX(1,LOCr(M_A)).
00063 *
00064 *  Let K be the number of rows or columns of a distributed matrix,
00065 *  and assume that its process grid has dimension p x q.
00066 *  LOCr( K ) denotes the number of elements of K that a process
00067 *  would receive if K were distributed over the p processes of its
00068 *  process column.
00069 *  Similarly, LOCc( K ) denotes the number of elements of K that a
00070 *  process would receive if K were distributed over the q processes of
00071 *  its process row.
00072 *  The values of LOCr() and LOCc() may be determined via a call to the
00073 *  ScaLAPACK tool function, NUMROC:
00074 *          LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ),
00075 *          LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ).
00076 *  An upper bound for these quantities may be computed by:
00077 *          LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A
00078 *          LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A
00079 *
00080 *  Arguments
00081 *  =========
00082 *
00083 *  A       (global input) COMPLEX array, dimension
00084 *          (DESCA(LLD_),*)
00085 *          On entry, the Hessenberg matrix whose tridiagonal part is
00086 *          being scanned.
00087 *          Unchanged on exit.
00088 *
00089 *  DESCA   (global and local input) INTEGER array of dimension DLEN_.
00090 *          The array descriptor for the distributed matrix A.
00091 *
00092 *  I       (global input) INTEGER
00093 *          The global location of the bottom of the unreduced
00094 *          submatrix of A.
00095 *          Unchanged on exit.
00096 *
00097 *  L       (global input) INTEGER
00098 *          The global location of the top of the unreduced submatrix
00099 *          of A.
00100 *          Unchanged on exit.
00101 *
00102 *  M       (global output) INTEGER
00103 *          On exit, this yields the starting location of the QR double
00104 *          shift.  This will satisfy: L <= M  <= I-2.
00105 *
00106 *  H44
00107 *  H33
00108 *  H43H34  (global input) COMPLEX
00109 *          These three values are for the double shift QR iteration.
00110 *
00111 *  BUF     (local output) COMPLEX array of size LWORK.
00112 *
00113 *  LWORK   (global input) INTEGER
00114 *          On exit, LWORK is the size of the work buffer.
00115 *          This must be at least 7*Ceil( Ceil( (I-L)/HBL ) /
00116 *                                        LCM(NPROW,NPCOL) )
00117 *          Here LCM is least common multiple, and NPROWxNPCOL is the
00118 *          logical grid size.
00119 *
00120 *  Logic:
00121 *  ======
00122 *
00123 *        Two consecutive small subdiagonal elements will stall
00124 *        convergence of a double shift if their product is small
00125 *        relatively even if each is not very small.  Thus it is
00126 *        necessary to scan the "tridiagonal portion of the matrix."  In
00127 *        the LAPACK algorithm ZLAHQR, a loop of M goes from I-2 down to
00128 *        L and examines
00129 *        H(m,m),H(m+1,m+1),H(m+1,m),H(m,m+1),H(m-1,m-1),H(m,m-1), and
00130 *        H(m+2,m-1).  Since these elements may be on separate
00131 *        processors, the first major loop (10) goes over the tridiagonal
00132 *        and has each node store whatever values of the 7 it has that
00133 *        the node owning H(m,m) does not.  This will occur on a border
00134 *        and can happen in no more than 3 locations per block assuming
00135 *        square blocks.  There are 5 buffers that each node stores these
00136 *        values:  a buffer to send diagonally down and right, a buffer
00137 *        to send up, a buffer to send left, a buffer to send diagonally
00138 *        up and left and a buffer to send right.  Each of these buffers
00139 *        is actually stored in one buffer BUF where BUF(ISTR1+1) starts
00140 *        the first buffer, BUF(ISTR2+1) starts the second, etc..  After
00141 *        the values are stored, if there are any values that a node
00142 *        needs, they will be sent and received.  Then the next major
00143 *        loop passes over the data and searches for two consecutive
00144 *        small subdiagonals.
00145 *
00146 *  Notes:
00147 *
00148 *     This routine does a global maximum and must be called by all
00149 *     processes.
00150 *
00151 *
00152 *  Further Details
00153 *  ===============
00154 *
00155 *  Implemented by:  M. Fahey, May 28, 1999
00156 *
00157 *  =====================================================================
00158 *
00159 *     .. Parameters ..
00160       INTEGER            BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
00161      $                   LLD_, MB_, M_, NB_, N_, RSRC_
00162       PARAMETER          ( BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DTYPE_ = 1,
00163      $                     CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
00164      $                     RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
00165 *     ..
00166 *     .. Local Scalars ..
00167       INTEGER            CONTXT, DOWN, HBL, IBUF1, IBUF2, IBUF3, IBUF4,
00168      $                   IBUF5, ICOL1, II, IRCV1, IRCV2, IRCV3, IRCV4,
00169      $                   IRCV5, IROW1, ISRC, ISTR1, ISTR2, ISTR3, ISTR4,
00170      $                   ISTR5, JJ, JSRC, LDA, LEFT, MODKM1, MYCOL,
00171      $                   MYROW, NPCOL, NPROW, NUM, RIGHT, UP
00172       REAL               S, TST1, ULP
00173       COMPLEX            CDUM, H00, H10, H11, H12, H21, H22, H33S, H44S,
00174      $                   V1, V2, V3
00175 *     ..
00176 *     .. External Functions ..
00177       INTEGER            ILCM
00178       REAL               PSLAMCH
00179       EXTERNAL           ILCM, PSLAMCH
00180 *     ..
00181 *     .. External Subroutines ..
00182       EXTERNAL           BLACS_GRIDINFO, IGAMX2D, INFOG2L, PXERBLA,
00183      $                   CGERV2D, CGESD2D
00184 *     ..
00185 *     .. Intrinsic Functions ..
00186       INTRINSIC          ABS, REAL, AIMAG, MOD
00187 *     ..
00188 *     .. Statement Functions ..
00189       REAL               CABS1
00190 *     ..
00191 *     .. Statement Function definitions ..
00192       CABS1( CDUM ) = ABS( REAL( CDUM ) ) + ABS( AIMAG( CDUM ) )
00193 *     ..
00194 *     .. Executable Statements ..
00195 *
00196       HBL = DESCA( MB_ )
00197       CONTXT = DESCA( CTXT_ )
00198       LDA = DESCA( LLD_ )
00199       ULP = PSLAMCH( CONTXT, 'PRECISION' )
00200       CALL BLACS_GRIDINFO( CONTXT, NPROW, NPCOL, MYROW, MYCOL )
00201       LEFT = MOD( MYCOL+NPCOL-1, NPCOL )
00202       RIGHT = MOD( MYCOL+1, NPCOL )
00203       UP = MOD( MYROW+NPROW-1, NPROW )
00204       DOWN = MOD( MYROW+1, NPROW )
00205       NUM = NPROW*NPCOL
00206 *
00207 *     BUFFER1 starts at BUF(ISTR1+1) and will contain IBUF1 elements
00208 *     BUFFER2 starts at BUF(ISTR2+1) and will contain IBUF2 elements
00209 *     BUFFER3 starts at BUF(ISTR3+1) and will contain IBUF3 elements
00210 *     BUFFER4 starts at BUF(ISTR4+1) and will contain IBUF4 elements
00211 *     BUFFER5 starts at BUF(ISTR5+1) and will contain IBUF5 elements
00212 *
00213       ISTR1 = 0
00214       ISTR2 = ( ( I-L-1 ) / HBL )
00215       IF( ISTR2*HBL.LT.( I-L-1 ) )
00216      $   ISTR2 = ISTR2 + 1
00217       II = ISTR2 / ILCM( NPROW, NPCOL )
00218       IF( II*ILCM( NPROW, NPCOL ).LT.ISTR2 ) THEN
00219          ISTR2 = II + 1
00220       ELSE
00221          ISTR2 = II
00222       END IF
00223       IF( LWORK.LT.7*ISTR2 ) THEN
00224          CALL PXERBLA( CONTXT, 'PCLACONSB', 10 )
00225          RETURN
00226       END IF
00227       ISTR3 = 3*ISTR2
00228       ISTR4 = ISTR3 + ISTR2
00229       ISTR5 = ISTR3 + ISTR3
00230       CALL INFOG2L( I-2, I-2, DESCA, NPROW, NPCOL, MYROW, MYCOL, IROW1,
00231      $              ICOL1, II, JJ )
00232       MODKM1 = MOD( I-3+HBL, HBL )
00233 *
00234 *     Copy our relevant pieces of triadiagonal that we owe into
00235 *     5 buffers to send to whomever owns H(M,M) as M moves diagonally
00236 *     up the tridiagonal
00237 *
00238       IBUF1 = 0
00239       IBUF2 = 0
00240       IBUF3 = 0
00241       IBUF4 = 0
00242       IBUF5 = 0
00243       IRCV1 = 0
00244       IRCV2 = 0
00245       IRCV3 = 0
00246       IRCV4 = 0
00247       IRCV5 = 0
00248       DO 10 M = I - 2, L, -1
00249          IF( ( MODKM1.EQ.0 ) .AND. ( DOWN.EQ.II ) .AND.
00250      $       ( RIGHT.EQ.JJ ) .AND. ( M.GT.L ) ) THEN
00251 *
00252 *           We must pack H(M-1,M-1) and send it diagonal down
00253 *
00254             IF( ( DOWN.NE.MYROW ) .OR. ( RIGHT.NE.MYCOL ) ) THEN
00255                CALL INFOG2L( M-1, M-1, DESCA, NPROW, NPCOL, MYROW,
00256      $                       MYCOL, IROW1, ICOL1, ISRC, JSRC )
00257                IBUF1 = IBUF1 + 1
00258                BUF( ISTR1+IBUF1 ) = A( ( ICOL1-1 )*LDA+IROW1 )
00259             END IF
00260          END IF
00261          IF( ( MODKM1.EQ.0 ) .AND. ( MYROW.EQ.II ) .AND.
00262      $       ( RIGHT.EQ.JJ ) .AND. ( M.GT.L ) ) THEN
00263 *
00264 *           We must pack H(M  ,M-1) and send it right
00265 *
00266             IF( NPCOL.GT.1 ) THEN
00267                CALL INFOG2L( M, M-1, DESCA, NPROW, NPCOL, MYROW, MYCOL,
00268      $                       IROW1, ICOL1, ISRC, JSRC )
00269                IBUF5 = IBUF5 + 1
00270                BUF( ISTR5+IBUF5 ) = A( ( ICOL1-1 )*LDA+IROW1 )
00271             END IF
00272          END IF
00273          IF( ( MODKM1.EQ.HBL-1 ) .AND. ( UP.EQ.II ) .AND.
00274      $       ( MYCOL.EQ.JJ ) ) THEN
00275 *
00276 *           We must pack H(M+1,M) and send it up
00277 *
00278             IF( NPROW.GT.1 ) THEN
00279                CALL INFOG2L( M+1, M, DESCA, NPROW, NPCOL, MYROW, MYCOL,
00280      $                       IROW1, ICOL1, ISRC, JSRC )
00281                IBUF2 = IBUF2 + 1
00282                BUF( ISTR2+IBUF2 ) = A( ( ICOL1-1 )*LDA+IROW1 )
00283             END IF
00284          END IF
00285          IF( ( MODKM1.EQ.HBL-1 ) .AND. ( MYROW.EQ.II ) .AND.
00286      $       ( LEFT.EQ.JJ ) ) THEN
00287 *
00288 *           We must pack H(M  ,M+1) and send it left
00289 *
00290             IF( NPCOL.GT.1 ) THEN
00291                CALL INFOG2L( M, M+1, DESCA, NPROW, NPCOL, MYROW, MYCOL,
00292      $                       IROW1, ICOL1, ISRC, JSRC )
00293                IBUF3 = IBUF3 + 1
00294                BUF( ISTR3+IBUF3 ) = A( ( ICOL1-1 )*LDA+IROW1 )
00295             END IF
00296          END IF
00297          IF( ( MODKM1.EQ.HBL-1 ) .AND. ( UP.EQ.II ) .AND.
00298      $       ( LEFT.EQ.JJ ) ) THEN
00299 *
00300 *           We must pack H(M+1,M+1) & H(M+2,M+1) and send it
00301 *           diagonally up
00302 *
00303             IF( ( UP.NE.MYROW ) .OR. ( LEFT.NE.MYCOL ) ) THEN
00304                CALL INFOG2L( M+1, M+1, DESCA, NPROW, NPCOL, MYROW,
00305      $                       MYCOL, IROW1, ICOL1, ISRC, JSRC )
00306                IBUF4 = IBUF4 + 2
00307                BUF( ISTR4+IBUF4-1 ) = A( ( ICOL1-1 )*LDA+IROW1 )
00308                BUF( ISTR4+IBUF4 ) = A( ( ICOL1-1 )*LDA+IROW1+1 )
00309             END IF
00310          END IF
00311          IF( ( MODKM1.EQ.HBL-2 ) .AND. ( UP.EQ.II ) .AND.
00312      $       ( MYCOL.EQ.JJ ) ) THEN
00313 *
00314 *           We must pack H(M+2,M+1) and send it up
00315 *
00316             IF( NPROW.GT.1 ) THEN
00317                CALL INFOG2L( M+2, M+1, DESCA, NPROW, NPCOL, MYROW,
00318      $                       MYCOL, IROW1, ICOL1, ISRC, JSRC )
00319                IBUF2 = IBUF2 + 1
00320                BUF( ISTR2+IBUF2 ) = A( ( ICOL1-1 )*LDA+IROW1 )
00321             END IF
00322          END IF
00323 *
00324 *        Add up the receives
00325 *
00326          IF( ( MYROW.EQ.II ) .AND. ( MYCOL.EQ.JJ ) ) THEN
00327             IF( ( MODKM1.EQ.0 ) .AND. ( M.GT.L ) .AND.
00328      $          ( ( NPROW.GT.1 ) .OR. ( NPCOL.GT.1 ) ) ) THEN
00329 *
00330 *              We must receive H(M-1,M-1) from diagonal up
00331 *
00332                IRCV1 = IRCV1 + 1
00333             END IF
00334             IF( ( MODKM1.EQ.0 ) .AND. ( NPCOL.GT.1 ) .AND. ( M.GT.L ) )
00335      $           THEN
00336 *
00337 *              We must receive H(M  ,M-1) from left
00338 *
00339                IRCV5 = IRCV5 + 1
00340             END IF
00341             IF( ( MODKM1.EQ.HBL-1 ) .AND. ( NPROW.GT.1 ) ) THEN
00342 *
00343 *              We must receive H(M+1,M  ) from down
00344 *
00345                IRCV2 = IRCV2 + 1
00346             END IF
00347             IF( ( MODKM1.EQ.HBL-1 ) .AND. ( NPCOL.GT.1 ) ) THEN
00348 *
00349 *              We must receive H(M  ,M+1) from right
00350 *
00351                IRCV3 = IRCV3 + 1
00352             END IF
00353             IF( ( MODKM1.EQ.HBL-1 ) .AND.
00354      $          ( ( NPROW.GT.1 ) .OR. ( NPCOL.GT.1 ) ) ) THEN
00355 *
00356 *              We must receive H(M+1:M+2,M+1) from diagonal down
00357 *
00358                IRCV4 = IRCV4 + 2
00359             END IF
00360             IF( ( MODKM1.EQ.HBL-2 ) .AND. ( NPROW.GT.1 ) ) THEN
00361 *
00362 *              We must receive H(M+2,M+1) from down
00363 *
00364                IRCV2 = IRCV2 + 1
00365             END IF
00366          END IF
00367 *
00368 *        Possibly change owners (occurs only when MOD(M-1,HBL) = 0)
00369 *
00370          IF( MODKM1.EQ.0 ) THEN
00371             II = II - 1
00372             JJ = JJ - 1
00373             IF( II.LT.0 )
00374      $         II = NPROW - 1
00375             IF( JJ.LT.0 )
00376      $         JJ = NPCOL - 1
00377          END IF
00378          MODKM1 = MODKM1 - 1
00379          IF( MODKM1.LT.0 )
00380      $      MODKM1 = HBL - 1
00381    10 CONTINUE
00382 *
00383 *
00384 *     Send data on to the appropriate node if there is any data to send
00385 *
00386       IF( IBUF1.GT.0 ) THEN
00387          CALL CGESD2D( CONTXT, IBUF1, 1, BUF( ISTR1+1 ), IBUF1, DOWN,
00388      $                 RIGHT )
00389       END IF
00390       IF( IBUF2.GT.0 ) THEN
00391          CALL CGESD2D( CONTXT, IBUF2, 1, BUF( ISTR2+1 ), IBUF2, UP,
00392      $                 MYCOL )
00393       END IF
00394       IF( IBUF3.GT.0 ) THEN
00395          CALL CGESD2D( CONTXT, IBUF3, 1, BUF( ISTR3+1 ), IBUF3, MYROW,
00396      $                 LEFT )
00397       END IF
00398       IF( IBUF4.GT.0 ) THEN
00399          CALL CGESD2D( CONTXT, IBUF4, 1, BUF( ISTR4+1 ), IBUF4, UP,
00400      $                 LEFT )
00401       END IF
00402       IF( IBUF5.GT.0 ) THEN
00403          CALL CGESD2D( CONTXT, IBUF5, 1, BUF( ISTR5+1 ), IBUF5, MYROW,
00404      $                 RIGHT )
00405       END IF
00406 *
00407 *     Receive appropriate data if there is any
00408 *
00409       IF( IRCV1.GT.0 ) THEN
00410          CALL CGERV2D( CONTXT, IRCV1, 1, BUF( ISTR1+1 ), IRCV1, UP,
00411      $                 LEFT )
00412       END IF
00413       IF( IRCV2.GT.0 ) THEN
00414          CALL CGERV2D( CONTXT, IRCV2, 1, BUF( ISTR2+1 ), IRCV2, DOWN,
00415      $                 MYCOL )
00416       END IF
00417       IF( IRCV3.GT.0 ) THEN
00418          CALL CGERV2D( CONTXT, IRCV3, 1, BUF( ISTR3+1 ), IRCV3, MYROW,
00419      $                 RIGHT )
00420       END IF
00421       IF( IRCV4.GT.0 ) THEN
00422          CALL CGERV2D( CONTXT, IRCV4, 1, BUF( ISTR4+1 ), IRCV4, DOWN,
00423      $                 RIGHT )
00424       END IF
00425       IF( IRCV5.GT.0 ) THEN
00426          CALL CGERV2D( CONTXT, IRCV5, 1, BUF( ISTR5+1 ), IRCV5, MYROW,
00427      $                 LEFT )
00428       END IF
00429 *
00430 *     Start main loop
00431 *
00432       IBUF1 = 0
00433       IBUF2 = 0
00434       IBUF3 = 0
00435       IBUF4 = 0
00436       IBUF5 = 0
00437       CALL INFOG2L( I-2, I-2, DESCA, NPROW, NPCOL, MYROW, MYCOL, IROW1,
00438      $              ICOL1, II, JJ )
00439       MODKM1 = MOD( I-3+HBL, HBL )
00440       IF( ( MYROW.EQ.II ) .AND. ( MYCOL.EQ.JJ ) .AND.
00441      $    ( MODKM1.NE.HBL-1 ) ) THEN
00442          CALL INFOG2L( I-2, I-1, DESCA, NPROW, NPCOL, MYROW, MYCOL,
00443      $                 IROW1, ICOL1, ISRC, JSRC )
00444       END IF
00445 *
00446 *     Look for two consecutive small subdiagonal elements.
00447 *
00448       DO 20 M = I - 2, L, -1
00449 *
00450 *        Determine the effect of starting the double-shift QR
00451 *        iteration at row M, and see if this would make H(M,M-1)
00452 *        negligible.
00453 *
00454          IF( ( MYROW.EQ.II ) .AND. ( MYCOL.EQ.JJ ) ) THEN
00455             IF( MODKM1.EQ.0 ) THEN
00456                H22 = A( ( ICOL1-1 )*LDA+IROW1+1 )
00457                H11 = A( ( ICOL1-2 )*LDA+IROW1 )
00458                V3 = A( ( ICOL1-1 )*LDA+IROW1+2 )
00459                H21 = A( ( ICOL1-2 )*LDA+IROW1+1 )
00460                H12 = A( ( ICOL1-1 )*LDA+IROW1 )
00461                IF( M.GT.L ) THEN
00462                   IF( NUM.GT.1 ) THEN
00463                      IBUF1 = IBUF1 + 1
00464                      H00 = BUF( ISTR1+IBUF1 )
00465                   ELSE
00466                      H00 = A( ( ICOL1-3 )*LDA+IROW1-1 )
00467                   END IF
00468                   IF( NPCOL.GT.1 ) THEN
00469                      IBUF5 = IBUF5 + 1
00470                      H10 = BUF( ISTR5+IBUF5 )
00471                   ELSE
00472                      H10 = A( ( ICOL1-3 )*LDA+IROW1 )
00473                   END IF
00474                END IF
00475             END IF
00476             IF( MODKM1.EQ.HBL-1 ) THEN
00477                CALL INFOG2L( M, M, DESCA, NPROW, NPCOL, MYROW, MYCOL,
00478      $                       IROW1, ICOL1, ISRC, JSRC )
00479                H11 = A( ( ICOL1-1 )*LDA+IROW1 )
00480                IF( NUM.GT.1 ) THEN
00481                   IBUF4 = IBUF4 + 2
00482                   H22 = BUF( ISTR4+IBUF4-1 )
00483                   V3 = BUF( ISTR4+IBUF4 )
00484                ELSE
00485                   H22 = A( ICOL1*LDA+IROW1+1 )
00486                   V3 = A( ( ICOL1+1 )*LDA+IROW1+1 )
00487                END IF
00488                IF( NPROW.GT.1 ) THEN
00489                   IBUF2 = IBUF2 + 1
00490                   H21 = BUF( ISTR2+IBUF2 )
00491                ELSE
00492                   H21 = A( ( ICOL1-1 )*LDA+IROW1+1 )
00493                END IF
00494                IF( NPCOL.GT.1 ) THEN
00495                   IBUF3 = IBUF3 + 1
00496                   H12 = BUF( ISTR3+IBUF3 )
00497                ELSE
00498                   H12 = A( ICOL1*LDA+IROW1 )
00499                END IF
00500                IF( M.GT.L ) THEN
00501                   H00 = A( ( ICOL1-2 )*LDA+IROW1-1 )
00502                   H10 = A( ( ICOL1-2 )*LDA+IROW1 )
00503                END IF
00504 *
00505 *              Adjust ICOL1 for next iteration where MODKM1=HBL-2
00506 *
00507                ICOL1 = ICOL1 + 1
00508             END IF
00509             IF( MODKM1.EQ.HBL-2 ) THEN
00510                H22 = A( ( ICOL1-1 )*LDA+IROW1+1 )
00511                H11 = A( ( ICOL1-2 )*LDA+IROW1 )
00512                IF( NPROW.GT.1 ) THEN
00513                   IBUF2 = IBUF2 + 1
00514                   V3 = BUF( ISTR2+IBUF2 )
00515                ELSE
00516                   V3 = A( ( ICOL1-1 )*LDA+IROW1+2 )
00517                END IF
00518                H21 = A( ( ICOL1-2 )*LDA+IROW1+1 )
00519                H12 = A( ( ICOL1-1 )*LDA+IROW1 )
00520                IF( M.GT.L ) THEN
00521                   H00 = A( ( ICOL1-3 )*LDA+IROW1-1 )
00522                   H10 = A( ( ICOL1-3 )*LDA+IROW1 )
00523                END IF
00524             END IF
00525             IF( ( MODKM1.LT.HBL-2 ) .AND. ( MODKM1.GT.0 ) ) THEN
00526                H22 = A( ( ICOL1-1 )*LDA+IROW1+1 )
00527                H11 = A( ( ICOL1-2 )*LDA+IROW1 )
00528                V3 = A( ( ICOL1-1 )*LDA+IROW1+2 )
00529                H21 = A( ( ICOL1-2 )*LDA+IROW1+1 )
00530                H12 = A( ( ICOL1-1 )*LDA+IROW1 )
00531                IF( M.GT.L ) THEN
00532                   H00 = A( ( ICOL1-3 )*LDA+IROW1-1 )
00533                   H10 = A( ( ICOL1-3 )*LDA+IROW1 )
00534                END IF
00535             END IF
00536             H44S = H44 - H11
00537             H33S = H33 - H11
00538             V1 = ( H33S*H44S-H43H34 ) / H21 + H12
00539             V2 = H22 - H11 - H33S - H44S
00540             S = CABS1( V1 ) + CABS1( V2 ) + CABS1( V3 )
00541             V1 = V1 / S
00542             V2 = V2 / S
00543             V3 = V3 / S
00544             IF( M.EQ.L )
00545      $         GO TO 30
00546             TST1 = CABS1( V1 )*( CABS1( H00 )+CABS1( H11 )+
00547      $             CABS1( H22 ) )
00548             IF( CABS1( H10 )*( CABS1( V2 )+CABS1( V3 ) ).LE.ULP*TST1 )
00549      $         GO TO 30
00550 *
00551 *           Slide indices diagonally up one for next iteration
00552 *
00553             IROW1 = IROW1 - 1
00554             ICOL1 = ICOL1 - 1
00555          END IF
00556          IF( M.EQ.L ) THEN
00557 *
00558 *           Stop regardless of which node we are
00559 *
00560             GO TO 30
00561          END IF
00562 *
00563 *        Possibly change owners if on border
00564 *
00565          IF( MODKM1.EQ.0 ) THEN
00566             II = II - 1
00567             JJ = JJ - 1
00568             IF( II.LT.0 )
00569      $         II = NPROW - 1
00570             IF( JJ.LT.0 )
00571      $         JJ = NPCOL - 1
00572          END IF
00573          MODKM1 = MODKM1 - 1
00574          IF( MODKM1.LT.0 )
00575      $      MODKM1 = HBL - 1
00576    20 CONTINUE
00577    30 CONTINUE
00578 *
00579       CALL IGAMX2D( CONTXT, 'ALL', ' ', 1, 1, M, 1, L, L, -1, -1, -1 )
00580 *
00581       RETURN
00582 *
00583 *     End of PCLACONSB
00584 *
00585       END