Routine: PDLACONSB()  File: SRC\pdlaconsb.f

 
 
# lines: 574
  # code: 574
  # comment: 0
  # blank:0
# Variables:69
# Callers:0
# Callings:1
# Words:438
# Keywords:280
 

 

 
..
     .. Array Arguments ..
     ..
  Purpose
  =======
  PDLACONSB looks for two consecutive small subdiagonal elements by
     seeing the effect of starting a double shift QR iteration
     given by H44, H33, & H43H34 and see if this would make a
     subdiagonal negligible.
  Notes
  =====
  Each global data object is described by an associated description
  vector.  This vector stores the information required to establish
  the mapping between an object element and its corresponding process
  and memory location.
  Let A be a generic term for any 2D block cyclicly distributed array.
  Such a global array has an associated description vector DESCA.
  In the following comments, the character _ should be read as
  "of the global array".
  NOTATION        STORED IN      EXPLANATION
  --------------- -------------- --------------------------------------
  DTYPE_A(global) DESCA( DTYPE_ )The descriptor type.  In this case,
                                 DTYPE_A = 1.
  CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
                                 the BLACS process grid A is distribu-
                                 ted over. The context itself is glo-
                                 bal, but the handle (the integer
                                 value) may vary.
  M_A    (global) DESCA( M_ )    The number of rows in the global
                                 array A.
  N_A    (global) DESCA( N_ )    The number of columns in the global
                                 array A.
  MB_A   (global) DESCA( MB_ )   The blocking factor used to distribute
                                 the rows of the array.
  NB_A   (global) DESCA( NB_ )   The blocking factor used to distribute
                                 the columns of the array.
  RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
                                 row of the array A is distributed.
  CSRC_A (global) DESCA( CSRC_ ) The process column over which the
                                 first column of the array A is
                                 distributed.
  LLD_A  (local)  DESCA( LLD_ )  The leading dimension of the local
                                 array.  LLD_A >= MAX(1,LOCr(M_A)).
  Let K be the number of rows or columns of a distributed matrix,
  and assume that its process grid has dimension p x q.
  LOCr( K ) denotes the number of elements of K that a process
  would receive if K were distributed over the p processes of its
  process column.
  Similarly, LOCc( K ) denotes the number of elements of K that a
  process would receive if K were distributed over the q processes of
  its process row.
  The values of LOCr() and LOCc() may be determined via a call to the
  ScaLAPACK tool function, NUMROC:
          LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ),
          LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ).
  An upper bound for these quantities may be computed by:
          LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A
          LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A
  Arguments
  =========
  A       (global input) DOUBLE PRECISION array, dimension
          (DESCA(LLD_),*)
          On entry, the Hessenberg matrix whose tridiagonal part is
          being scanned.
          Unchanged on exit.
  DESCA   (global and local input) INTEGER array of dimension DLEN_.
          The array descriptor for the distributed matrix A.
  I       (global input) INTEGER
          The global location of the bottom of the unreduced
          submatrix of A.
          Unchanged on exit.
  L       (global input) INTEGER
          The global location of the top of the unreduced submatrix
          of A.
          Unchanged on exit.
  M       (global output) INTEGER
          On exit, this yields the starting location of the QR double
          shift.  This will satisfy: L <= M  <= I-2.
  H44
  H33
  H43H34  (global input) DOUBLE PRECISION
          These three values are for the double shift QR iteration.
  BUF     (local output) DOUBLE PRECISION array of size LWORK.
  LWORK   (global input) INTEGER
          On exit, LWORK is the size of the work buffer.
          This must be at least 7*Ceil( Ceil( (I-L)/HBL ) /
                                        LCM(NPROW,NPCOL) )
          Here LCM is least common multiple, and NPROWxNPCOL is the
          logical grid size.
  Logic:
  ======
        Two consecutive small subdiagonal elements will stall
        convergence of a double shift if their product is small
        relatively even if each is not very small.  Thus it is
        necessary to scan the "tridiagonal portion of the matrix."  In
        the LAPACK algorithm DLAHQR, a loop of M goes from I-2 down to
        L and examines
        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
        H(m+2,m-1).  Since these elements may be on separate
        processors, the first major loop (10) goes over the tridiagonal
        and has each node store whatever values of the 7 it has that
        the node owning H(m,m) does not.  This will occur on a border
        and can happen in no more than 3 locations per block assuming
        square blocks.  There are 5 buffers that each node stores these
        values:  a buffer to send diagonally down and right, a buffer
        to send up, a buffer to send left, a buffer to send diagonally
        up and left and a buffer to send right.  Each of these buffers
        is actually stored in one buffer BUF where BUF(ISTR1+1) starts
        the first buffer, BUF(ISTR2+1) starts the second, etc..  After
        the values are stored, if there are any values that a node
        needs, they will be sent and received.  Then the next major
        loop passes over the data and searches for two consecutive
        small subdiagonals.
  Notes:
     This routine does a global maximum and must be called by all
     processes.
  Implemented by:  G. Henry, November 17, 1996
  =====================================================================
     .. Parameters ..
 
Display dynamic version Find AutoScroll Reload FontSize: - + Hide Comments Hide Blanks Frame FullScreen MailPrint

  
001        SUBROUTINE PDLACONSB( A , DESCA , I , L , M , H44 , H33 , H43H34 , BUF ,
002       $LWORK )
003  
004  *     -- ScaLAPACK routine(version 1.7) --
005  *     University of Tennessee , Knoxville , Oak Ridge National Laboratory ,
006  *     and University of California , Berkeley.
007  *     May 1 , 1997
008  
009  *     .. Scalar Arguments ..
010        INTEGER I , L , LWORK , M
011        DOUBLE PRECISION H33 , H43H34 , H44
012        INTEGER BLOCK_CYCLIC_2D , CSRC_ , CTXT_ , DLEN_ , DTYPE_ ,
013       $LLD_ , MB_ , M_ , NB_ , N_ , RSRC_
014        PARAMETER( BLOCK_CYCLIC_2D = 1 , DLEN_ = 9 , DTYPE_ = 1 ,
015       $CTXT_ = 2 , M_ = 3 , N_ = 4 , MB_ = 5 , NB_ = 6 ,
016       $RSRC_ = 7 , CSRC_ = 8 , LLD_ = 9 )
017  *     ..
018  *     .. Local Scalars ..
019        INTEGER CONTXT , DOWN , HBL , IBUF1 , IBUF2 , IBUF3 , IBUF4 ,
020       $IBUF5 , ICOL1 , II , IRCV1 , IRCV2 , IRCV3 , IRCV4 ,
021       $IRCV5 , IROW1 , ISRC , ISTR1 , ISTR2 , ISTR3 , ISTR4 ,
022       $ISTR5 , JJ , JSRC , LDA , LEFT , MODKM1 , MYCOL ,
023       $MYROW , NPCOL , NPROW , NUM , RIGHT , UP
024        DOUBLE PRECISION H00 , H10 , H11 , H12 , H21 , H22 , H33S , H44S , S ,
025       $TST1 , ULP , V1 , V2 , V3
026  *     ..
027  *     .. External Functions ..
028        INTEGER ILCM
029        DOUBLE PRECISION PDLAMCH
030        EXTERNAL ILCM , PDLAMCH
031  *     ..
032  *     .. External Subroutines ..
033        EXTERNAL BLACS_GRIDINFO , DGERV2D , DGESD2D , IGAMX2D ,
034       $INFOG2L , PXERBLA
035  *     ..
036  *     .. Intrinsic Functions ..
037        INTRINSIC ABS , MOD
038  *     ..
039  *     .. Executable Statements ..
040  
041        HBL = DESCA( MB_ )
042        CONTXT = DESCA( CTXT_ )
043        LDA = DESCA( LLD_ )
044        ULP = PDLAMCH( CONTXT , 'PRECISION' )
045        CALL BLACS_GRIDINFO( CONTXT , NPROW , NPCOL , MYROW , MYCOL )
046        LEFT = MOD( MYCOL + NPCOL - 1 , NPCOL )
047        RIGHT = MOD( MYCOL + 1 , NPCOL )
048        UP = MOD( MYROW + NPROW - 1 , NPROW )
049        DOWN = MOD( MYROW + 1 , NPROW )
050        NUM = NPROW*NPCOL
051  
052  *     BUFFER1 starts at BUF(ISTR1 + 1) and will contain IBUF1 elements
053  *     BUFFER2 starts at BUF(ISTR2 + 1) and will contain IBUF2 elements
054  *     BUFFER3 starts at BUF(ISTR3 + 1) and will contain IBUF3 elements
055  *     BUFFER4 starts at BUF(ISTR4 + 1) and will contain IBUF4 elements
056  *     BUFFER5 starts at BUF(ISTR5 + 1) and will contain IBUF5 elements
057  
058        ISTR1 = 0
059        ISTR2 =(( I - L - 1 ) / HBL )
060        IF( ISTR2*HBL.LT.( I - L - 1 ) )
061       $    ISTR2 = ISTR2 + 1
062            II = ISTR2 / ILCM( NPROW , NPCOL )
063            IF( II*ILCM( NPROW , NPCOL ).LT.ISTR2 ) THEN
064                ISTR2 = II + 1
065            ELSE
066                ISTR2 = II
067            END IF
068            IF( LWORK.LT.7*ISTR2 ) THEN
069                CALL PXERBLA( CONTXT , 'PDLACONSB' , 10 )
070                RETURN
071            END IF
072            ISTR3 = 3*ISTR2
073            ISTR4 = ISTR3 + ISTR2
074            ISTR5 = ISTR3 + ISTR3
075            CALL INFOG2L( I - 2 , I - 2 , DESCA , NPROW , NPCOL , MYROW , MYCOL , IROW1 ,
076       $    ICOL1 , II , JJ )
077            MODKM1 = MOD( I - 3 + HBL , HBL )
078  
079  *         Copy our relevant pieces of triadiagonal that we owe into
080  *         5 buffers to send to whomever owns H(M , M) as M moves diagonally
081  *         up the tridiagonal
082  
083            IBUF1 = 0
084            IBUF2 = 0
085            IBUF3 = 0
086            IBUF4 = 0
087            IBUF5 = 0
088            IRCV1 = 0
089            IRCV2 = 0
090            IRCV3 = 0
091            IRCV4 = 0
092            IRCV5 = 0
093            DO 10 M = I - 2 , L , - 1
094                IF(( MODKM1.EQ.0 ) .AND.( DOWN.EQ.II ) .AND.
095       $( RIGHT.EQ.JJ ) .AND.( M.GT.L ) ) THEN
096  
097  *             We must pack H(M - 1 , M - 1) and send it diagonal down
098  
099                IF(( DOWN.NE.MYROW ) .OR.( RIGHT.NE.MYCOL ) ) THEN
100                    CALL INFOG2L( M - 1 , M - 1 , DESCA , NPROW , NPCOL , MYROW ,
101       $            MYCOL , IROW1 , ICOL1 , ISRC , JSRC )
102                    IBUF1 = IBUF1 + 1
103                    BUF( ISTR1 + IBUF1 ) = A(( ICOL1 - 1 )*LDA + IROW1 )
104                END IF
105            END IF
106            IF(( MODKM1.EQ.0 ) .AND.( MYROW.EQ.II ) .AND.
107       $( RIGHT.EQ.JJ ) .AND.( M.GT.L ) ) THEN
108  
109  *         We must pack H(M , M - 1) and send it right
110  
111            IF( NPCOL.GT.1 ) THEN
112                CALL INFOG2L( M , M - 1 , DESCA , NPROW , NPCOL , MYROW , MYCOL ,
113       $        IROW1 , ICOL1 , ISRC , JSRC )
114                IBUF5 = IBUF5 + 1
115                BUF( ISTR5 + IBUF5 ) = A(( ICOL1 - 1 )*LDA + IROW1 )
116            END IF
117        END IF
118        IF(( MODKM1.EQ.HBL - 1 ) .AND.( UP.EQ.II ) .AND.
119       $( MYCOL.EQ.JJ ) ) THEN
120  
121  *     We must pack H(M + 1 , M) and send it up
122  
123        IF( NPROW.GT.1 ) THEN
124            CALL INFOG2L( M + 1 , M , DESCA , NPROW , NPCOL , MYROW , MYCOL ,
125       $    IROW1 , ICOL1 , ISRC , JSRC )
126            IBUF2 = IBUF2 + 1
127            BUF( ISTR2 + IBUF2 ) = A(( ICOL1 - 1 )*LDA + IROW1 )
128        END IF
129        END IF
130        IF(( MODKM1.EQ.HBL - 1 ) .AND.( MYROW.EQ.II ) .AND.
131       $( LEFT.EQ.JJ ) ) THEN
132  
133  *     We must pack H(M , M + 1) and send it left
134  
135        IF( NPCOL.GT.1 ) THEN
136            CALL INFOG2L( M , M + 1 , DESCA , NPROW , NPCOL , MYROW , MYCOL ,
137       $    IROW1 , ICOL1 , ISRC , JSRC )
138            IBUF3 = IBUF3 + 1
139            BUF( ISTR3 + IBUF3 ) = A(( ICOL1 - 1 )*LDA + IROW1 )
140        END IF
141        END IF
142        IF(( MODKM1.EQ.HBL - 1 ) .AND.( UP.EQ.II ) .AND.
143       $( LEFT.EQ.JJ ) ) THEN
144  
145  *     We must pack H(M + 1 , M + 1) & H(M + 2 , M + 1) and send it
146  *     diagonally up
147  
148        IF(( UP.NE.MYROW ) .OR.( LEFT.NE.MYCOL ) ) THEN
149            CALL INFOG2L( M + 1 , M + 1 , DESCA , NPROW , NPCOL , MYROW ,
150       $    MYCOL , IROW1 , ICOL1 , ISRC , JSRC )
151            IBUF4 = IBUF4 + 2
152            BUF( ISTR4 + IBUF4 - 1 ) = A(( ICOL1 - 1 )*LDA + IROW1 )
153            BUF( ISTR4 + IBUF4 ) = A(( ICOL1 - 1 )*LDA + IROW1 + 1 )
154        END IF
155        END IF
156        IF(( MODKM1.EQ.HBL - 2 ) .AND.( UP.EQ.II ) .AND.
157       $( MYCOL.EQ.JJ ) ) THEN
158  
159  *     We must pack H(M + 2 , M + 1) and send it up
160  
161        IF( NPROW.GT.1 ) THEN
162            CALL INFOG2L( M + 2 , M + 1 , DESCA , NPROW , NPCOL , MYROW ,
163       $    MYCOL , IROW1 , ICOL1 , ISRC , JSRC )
164            IBUF2 = IBUF2 + 1
165            BUF( ISTR2 + IBUF2 ) = A(( ICOL1 - 1 )*LDA + IROW1 )
166        END IF
167        END IF
168  
169  *     Add up the receives
170  
171        IF(( MYROW.EQ.II ) .AND.( MYCOL.EQ.JJ ) ) THEN
172            IF(( MODKM1.EQ.0 ) .AND.( M.GT.L ) .AND.
173       $(( NPROW.GT.1 ) .OR.( NPCOL.GT.1 ) ) ) THEN
174  
175  *         We must receive H(M - 1 , M - 1) from diagonal up
176  
177            IRCV1 = IRCV1 + 1
178        END IF
179        IF(( MODKM1.EQ.0 ) .AND.( NPCOL.GT.1 ) .AND.( M.GT.L ) )
180       $    THEN
181  
182  *         We must receive H(M , M - 1) from left
183  
184            IRCV5 = IRCV5 + 1
185        END IF
186        IF(( MODKM1.EQ.HBL - 1 ) .AND.( NPROW.GT.1 ) ) THEN
187  
188  *         We must receive H(M + 1 , M ) from down
189  
190            IRCV2 = IRCV2 + 1
191        END IF
192        IF(( MODKM1.EQ.HBL - 1 ) .AND.( NPCOL.GT.1 ) ) THEN
193  
194  *         We must receive H(M , M + 1) from right
195  
196            IRCV3 = IRCV3 + 1
197        END IF
198        IF(( MODKM1.EQ.HBL - 1 ) .AND.
199       $(( NPROW.GT.1 ) .OR.( NPCOL.GT.1 ) ) ) THEN
200  
201  *     We must receive H(M + 1 : M + 2 , M + 1) from diagonal down
202  
203        IRCV4 = IRCV4 + 2
204        END IF
205        IF(( MODKM1.EQ.HBL - 2 ) .AND.( NPROW.GT.1 ) ) THEN
206  
207  *         We must receive H(M + 2 , M + 1) from down
208  
209            IRCV2 = IRCV2 + 1
210        END IF
211        END IF
212  
213  *     Possibly change owners(occurs only when MOD(M - 1 , HBL) = 0)
214  
215        IF( MODKM1.EQ.0 ) THEN
216            II = II - 1
217            JJ = JJ - 1
218            IF( II.LT.0 )
219       $        II = NPROW - 1
220                IF( JJ.LT.0 )
221       $            JJ = NPCOL - 1
222                END IF
223                MODKM1 = MODKM1 - 1
224                IF( MODKM1.LT.0 )
225       $            MODKM1 = HBL - 1
226     10 CONTINUE
227  
228  *     Send data on to the appropriate node if there is any data to send
229  
230        IF( IBUF1.GT.0 ) THEN
231            CALL DGESD2D( CONTXT , IBUF1 , 1 , BUF( ISTR1 + 1 ) , IBUF1 , DOWN ,
232       $    RIGHT )
233        END IF
234        IF( IBUF2.GT.0 ) THEN
235            CALL DGESD2D( CONTXT , IBUF2 , 1 , BUF( ISTR2 + 1 ) , IBUF2 , UP ,
236       $    MYCOL )
237        END IF
238        IF( IBUF3.GT.0 ) THEN
239            CALL DGESD2D( CONTXT , IBUF3 , 1 , BUF( ISTR3 + 1 ) , IBUF3 , MYROW ,
240       $    LEFT )
241        END IF
242        IF( IBUF4.GT.0 ) THEN
243            CALL DGESD2D( CONTXT , IBUF4 , 1 , BUF( ISTR4 + 1 ) , IBUF4 , UP ,
244       $    LEFT )
245        END IF
246        IF( IBUF5.GT.0 ) THEN
247            CALL DGESD2D( CONTXT , IBUF5 , 1 , BUF( ISTR5 + 1 ) , IBUF5 , MYROW ,
248       $    RIGHT )
249        END IF
250  
251  *     Receive appropriate data if there is any
252  
253        IF( IRCV1.GT.0 ) THEN
254            CALL DGERV2D( CONTXT , IRCV1 , 1 , BUF( ISTR1 + 1 ) , IRCV1 , UP ,
255       $    LEFT )
256        END IF
257        IF( IRCV2.GT.0 ) THEN
258            CALL DGERV2D( CONTXT , IRCV2 , 1 , BUF( ISTR2 + 1 ) , IRCV2 , DOWN ,
259       $    MYCOL )
260        END IF
261        IF( IRCV3.GT.0 ) THEN
262            CALL DGERV2D( CONTXT , IRCV3 , 1 , BUF( ISTR3 + 1 ) , IRCV3 , MYROW ,
263       $    RIGHT )
264        END IF
265        IF( IRCV4.GT.0 ) THEN
266            CALL DGERV2D( CONTXT , IRCV4 , 1 , BUF( ISTR4 + 1 ) , IRCV4 , DOWN ,
267       $    RIGHT )
268        END IF
269        IF( IRCV5.GT.0 ) THEN
270            CALL DGERV2D( CONTXT , IRCV5 , 1 , BUF( ISTR5 + 1 ) , IRCV5 , MYROW ,
271       $    LEFT )
272        END IF
273  
274  *     Start main loop
275  
276        IBUF1 = 0
277        IBUF2 = 0
278        IBUF3 = 0
279        IBUF4 = 0
280        IBUF5 = 0
281        CALL INFOG2L( I - 2 , I - 2 , DESCA , NPROW , NPCOL , MYROW , MYCOL , IROW1 ,
282       $ICOL1 , II , JJ )
283        MODKM1 = MOD( I - 3 + HBL , HBL )
284        IF(( MYROW.EQ.II ) .AND.( MYCOL.EQ.JJ ) .AND.
285       $( MODKM1.NE.HBL - 1 ) ) THEN
286        CALL INFOG2L( I - 2 , I - 1 , DESCA , NPROW , NPCOL , MYROW , MYCOL ,
287       $IROW1 , ICOL1 , ISRC , JSRC )
288        END IF
289  
290  *     Look for two consecutive small subdiagonal elements.
291  
292        DO 20 M = I - 2 , L , - 1
293  
294  *         Determine the effect of starting the double - shift QR
295  *         iteration at row M , and see if this would make H(M , M - 1)
296  *         negligible.
297  
298            IF(( MYROW.EQ.II ) .AND.( MYCOL.EQ.JJ ) ) THEN
299                IF( MODKM1.EQ.0 ) THEN
300                    H22 = A(( ICOL1 - 1 )*LDA + IROW1 + 1 )
301                    H11 = A(( ICOL1 - 2 )*LDA + IROW1 )
302                    V3 = A(( ICOL1 - 1 )*LDA + IROW1 + 2 )
303                    H21 = A(( ICOL1 - 2 )*LDA + IROW1 + 1 )
304                    H12 = A(( ICOL1 - 1 )*LDA + IROW1 )
305                    IF( M.GT.L ) THEN
306                        IF( NUM.GT.1 ) THEN
307                            IBUF1 = IBUF1 + 1
308                            H00 = BUF( ISTR1 + IBUF1 )
309                        ELSE
310                            H00 = A(( ICOL1 - 3 )*LDA + IROW1 - 1 )
311                        END IF
312                        IF( NPCOL.GT.1 ) THEN
313                            IBUF5 = IBUF5 + 1
314                            H10 = BUF( ISTR5 + IBUF5 )
315                        ELSE
316                            H10 = A(( ICOL1 - 3 )*LDA + IROW1 )
317                        END IF
318                    END IF
319                END IF
320                IF( MODKM1.EQ.HBL - 1 ) THEN
321                    CALL INFOG2L( M , M , DESCA , NPROW , NPCOL , MYROW , MYCOL ,
322       $            IROW1 , ICOL1 , ISRC , JSRC )
323                    H11 = A(( ICOL1 - 1 )*LDA + IROW1 )
324                    IF( NUM.GT.1 ) THEN
325                        IBUF4 = IBUF4 + 2
326                        H22 = BUF( ISTR4 + IBUF4 - 1 )
327                        V3 = BUF( ISTR4 + IBUF4 )
328                    ELSE
329                        H22 = A( ICOL1*LDA + IROW1 + 1 )
330                        V3 = A(( ICOL1 + 1 )*LDA + IROW1 + 1 )
331                    END IF
332                    IF( NPROW.GT.1 ) THEN
333                        IBUF2 = IBUF2 + 1
334                        H21 = BUF( ISTR2 + IBUF2 )
335                    ELSE
336                        H21 = A(( ICOL1 - 1 )*LDA + IROW1 + 1 )
337                    END IF
338                    IF( NPCOL.GT.1 ) THEN
339                        IBUF3 = IBUF3 + 1
340                        H12 = BUF( ISTR3 + IBUF3 )
341                    ELSE
342                        H12 = A( ICOL1*LDA + IROW1 )
343                    END IF
344                    IF( M.GT.L ) THEN
345                        H00 = A(( ICOL1 - 2 )*LDA + IROW1 - 1 )
346                        H10 = A(( ICOL1 - 2 )*LDA + IROW1 )
347                    END IF
348  
349  *                 Adjust ICOL1 for next iteration where MODKM1 = HBL - 2
350  
351                    ICOL1 = ICOL1 + 1
352                END IF
353                IF( MODKM1.EQ.HBL - 2 ) THEN
354                    H22 = A(( ICOL1 - 1 )*LDA + IROW1 + 1 )
355                    H11 = A(( ICOL1 - 2 )*LDA + IROW1 )
356                    IF( NPROW.GT.1 ) THEN
357                        IBUF2 = IBUF2 + 1
358                        V3 = BUF( ISTR2 + IBUF2 )
359                    ELSE
360                        V3 = A(( ICOL1 - 1 )*LDA + IROW1 + 2 )
361                    END IF
362                    H21 = A(( ICOL1 - 2 )*LDA + IROW1 + 1 )
363                    H12 = A(( ICOL1 - 1 )*LDA + IROW1 )
364                    IF( M.GT.L ) THEN
365                        H00 = A(( ICOL1 - 3 )*LDA + IROW1 - 1 )
366                        H10 = A(( ICOL1 - 3 )*LDA + IROW1 )
367                    END IF
368                END IF
369                IF(( MODKM1.LT.HBL - 2 ) .AND.( MODKM1.GT.0 ) ) THEN
370                    H22 = A(( ICOL1 - 1 )*LDA + IROW1 + 1 )
371                    H11 = A(( ICOL1 - 2 )*LDA + IROW1 )
372                    V3 = A(( ICOL1 - 1 )*LDA + IROW1 + 2 )
373                    H21 = A(( ICOL1 - 2 )*LDA + IROW1 + 1 )
374                    H12 = A(( ICOL1 - 1 )*LDA + IROW1 )
375                    IF( M.GT.L ) THEN
376                        H00 = A(( ICOL1 - 3 )*LDA + IROW1 - 1 )
377                        H10 = A(( ICOL1 - 3 )*LDA + IROW1 )
378                    END IF
379                END IF
380                H44S = H44 - H11
381                H33S = H33 - H11
382                V1 =( H33S*H44S - H43H34 ) / H21 + H12
383                V2 = H22 - H11 - H33S - H44S
384                S = ABS( V1 ) + ABS( V2 ) + ABS( V3 )
385                V1 = V1 / S
386                V2 = V2 / S
387                V3 = V3 / S
388                IF( M.EQ.L )
389       $            GO TO 30
390                    TST1 = ABS( V1 )*( ABS( H00 ) + ABS( H11 ) + ABS( H22 ) )
391                    IF( ABS( H10 )*( ABS( V2 ) + ABS( V3 ) ).LE.ULP*TST1 )
392       $                GO TO 30
393  
394  *                     Slide indices diagonally up one for next iteration
395  
396                        IROW1 = IROW1 - 1
397                        ICOL1 = ICOL1 - 1
398                    END IF
399                    IF( M.EQ.L ) THEN
400  
401  *                     Stop regardless of which node we are
402  
403                        GO TO 30
404                    END IF
405  
406  *                 Possibly change owners if on border
407  
408                    IF( MODKM1.EQ.0 ) THEN
409                        II = II - 1
410                        JJ = JJ - 1
411                        IF( II.LT.0 )
412       $                    II = NPROW - 1
413                            IF( JJ.LT.0 )
414       $                        JJ = NPCOL - 1
415                            END IF
416                            MODKM1 = MODKM1 - 1
417                            IF( MODKM1.LT.0 )
418       $                        MODKM1 = HBL - 1
419     20 CONTINUE
420     30 CONTINUE
421  
422        CALL IGAMX2D( CONTXT , 'ALL' , ' ' , 1 , 1 , M , 1 , L , L , - 1 , - 1 , - 1 )
423  
424        RETURN
425  
426  *     End of PDLACONSB
427  
428        END