Routine: PCLACONSB()  File: SRC\pclaconsb.f

 
 
# lines: 585
  # code: 585
  # comment: 0
  # blank:0
# Variables:71
# Callers:0
# Callings:1
# Words:433
# Keywords:283
 

 

 
..
     .. Array Arguments ..
     ..
  Purpose
  =======
  PCLACONSB 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) COMPLEX 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) COMPLEX
          These three values are for the double shift QR iteration.
  BUF     (local output) COMPLEX 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 ZLAHQR, 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.
  Further Details
  ===============
  Implemented by:  M. Fahey, May 28, 1999
  =====================================================================
     .. Parameters ..
 
Display dynamic version Find AutoScroll Reload FontSize: - + Hide Comments Hide Blanks Frame FullScreen MailPrint

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