ScaLAPACK 2.1  2.1
ScaLAPACK: Scalable Linear Algebra PACKage
pzlaconsb.f
Go to the documentation of this file.
1  SUBROUTINE pzlaconsb( A, DESCA, I, L, M, H44, H33, H43H34, BUF,
2  $ LWORK )
3 *
4 * -- ScaLAPACK routine (version 1.7) --
5 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
6 * and University of California, Berkeley.
7 * July 31, 2001
8 *
9 * .. Scalar Arguments ..
10  INTEGER I, L, LWORK, M
11  COMPLEX*16 H33, H43H34, H44
12 * ..
13 * .. Array Arguments ..
14  INTEGER DESCA( * )
15  COMPLEX*16 A( * ), BUF( * )
16 * ..
17 *
18 * Purpose
19 * =======
20 *
21 * PZLACONSB looks for two consecutive small subdiagonal elements by
22 * seeing the effect of starting a double shift QR iteration
23 * given by H44, H33, & H43H34 and see if this would make a
24 * subdiagonal negligible.
25 *
26 * Notes
27 * =====
28 *
29 * Each global data object is described by an associated description
30 * vector. This vector stores the information required to establish
31 * the mapping between an object element and its corresponding process
32 * and memory location.
33 *
34 * Let A be a generic term for any 2D block cyclicly distributed array.
35 * Such a global array has an associated description vector DESCA.
36 * In the following comments, the character _ should be read as
37 * "of the global array".
38 *
39 * NOTATION STORED IN EXPLANATION
40 * --------------- -------------- --------------------------------------
41 * DTYPE_A(global) DESCA( DTYPE_ )The descriptor type. In this case,
42 * DTYPE_A = 1.
43 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
44 * the BLACS process grid A is distribu-
45 * ted over. The context itself is glo-
46 * bal, but the handle (the integer
47 * value) may vary.
48 * M_A (global) DESCA( M_ ) The number of rows in the global
49 * array A.
50 * N_A (global) DESCA( N_ ) The number of columns in the global
51 * array A.
52 * MB_A (global) DESCA( MB_ ) The blocking factor used to distribute
53 * the rows of the array.
54 * NB_A (global) DESCA( NB_ ) The blocking factor used to distribute
55 * the columns of the array.
56 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
57 * row of the array A is distributed.
58 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the
59 * first column of the array A is
60 * distributed.
61 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
62 * array. LLD_A >= MAX(1,LOCr(M_A)).
63 *
64 * Let K be the number of rows or columns of a distributed matrix,
65 * and assume that its process grid has dimension p x q.
66 * LOCr( K ) denotes the number of elements of K that a process
67 * would receive if K were distributed over the p processes of its
68 * process column.
69 * Similarly, LOCc( K ) denotes the number of elements of K that a
70 * process would receive if K were distributed over the q processes of
71 * its process row.
72 * The values of LOCr() and LOCc() may be determined via a call to the
73 * ScaLAPACK tool function, NUMROC:
74 * LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ),
75 * LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ).
76 * An upper bound for these quantities may be computed by:
77 * LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A
78 * LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A
79 *
80 * Arguments
81 * =========
82 *
83 * A (global input) COMPLEX*16 array, dimension
84 * (DESCA(LLD_),*)
85 * On entry, the Hessenberg matrix whose tridiagonal part is
86 * being scanned.
87 * Unchanged on exit.
88 *
89 * DESCA (global and local input) INTEGER array of dimension DLEN_.
90 * The array descriptor for the distributed matrix A.
91 *
92 * I (global input) INTEGER
93 * The global location of the bottom of the unreduced
94 * submatrix of A.
95 * Unchanged on exit.
96 *
97 * L (global input) INTEGER
98 * The global location of the top of the unreduced submatrix
99 * of A.
100 * Unchanged on exit.
101 *
102 * M (global output) INTEGER
103 * On exit, this yields the starting location of the QR double
104 * shift. This will satisfy: L <= M <= I-2.
105 *
106 * H44
107 * H33
108 * H43H34 (global input) COMPLEX*16
109 * These three values are for the double shift QR iteration.
110 *
111 * BUF (local output) COMPLEX*16 array of size LWORK.
112 *
113 * LWORK (global input) INTEGER
114 * On exit, LWORK is the size of the work buffer.
115 * This must be at least 7*Ceil( Ceil( (I-L)/HBL ) /
116 * LCM(NPROW,NPCOL) )
117 * Here LCM is least common multiple, and NPROWxNPCOL is the
118 * logical grid size.
119 *
120 * Logic:
121 * ======
122 *
123 * Two consecutive small subdiagonal elements will stall
124 * convergence of a double shift if their product is small
125 * relatively even if each is not very small. Thus it is
126 * necessary to scan the "tridiagonal portion of the matrix." In
127 * the LAPACK algorithm ZLAHQR, a loop of M goes from I-2 down to
128 * L and examines
129 * 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
130 * H(m+2,m-1). Since these elements may be on separate
131 * processors, the first major loop (10) goes over the tridiagonal
132 * and has each node store whatever values of the 7 it has that
133 * the node owning H(m,m) does not. This will occur on a border
134 * and can happen in no more than 3 locations per block assuming
135 * square blocks. There are 5 buffers that each node stores these
136 * values: a buffer to send diagonally down and right, a buffer
137 * to send up, a buffer to send left, a buffer to send diagonally
138 * up and left and a buffer to send right. Each of these buffers
139 * is actually stored in one buffer BUF where BUF(ISTR1+1) starts
140 * the first buffer, BUF(ISTR2+1) starts the second, etc.. After
141 * the values are stored, if there are any values that a node
142 * needs, they will be sent and received. Then the next major
143 * loop passes over the data and searches for two consecutive
144 * small subdiagonals.
145 *
146 * Notes:
147 *
148 * This routine does a global maximum and must be called by all
149 * processes.
150 *
151 *
152 * Further Details
153 * ===============
154 *
155 * Implemented by: M. Fahey, May 28, 1999
156 *
157 * =====================================================================
158 *
159 * .. Parameters ..
160  INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
161  $ lld_, mb_, m_, nb_, n_, rsrc_
162  parameter( block_cyclic_2d = 1, dlen_ = 9, dtype_ = 1,
163  $ ctxt_ = 2, m_ = 3, n_ = 4, mb_ = 5, nb_ = 6,
164  $ rsrc_ = 7, csrc_ = 8, lld_ = 9 )
165 * ..
166 * .. Local Scalars ..
167  INTEGER CONTXT, DOWN, HBL, IBUF1, IBUF2, IBUF3, IBUF4,
168  $ ibuf5, icol1, ii, ircv1, ircv2, ircv3, ircv4,
169  $ ircv5, irow1, isrc, istr1, istr2, istr3, istr4,
170  $ istr5, jj, jsrc, lda, left, modkm1, mycol,
171  $ myrow, npcol, nprow, num, right, up
172  DOUBLE PRECISION S, TST1, ULP
173  COMPLEX*16 CDUM, H00, H10, H11, H12, H21, H22, H33S, H44S,
174  $ v1, v2, v3
175 * ..
176 * .. External Functions ..
177  INTEGER ILCM
178  DOUBLE PRECISION PDLAMCH
179  EXTERNAL ilcm, pdlamch
180 * ..
181 * .. External Subroutines ..
182  EXTERNAL blacs_gridinfo, igamx2d, infog2l, pxerbla,
183  $ zgerv2d, zgesd2d
184 * ..
185 * .. Intrinsic Functions ..
186  INTRINSIC abs, dble, dimag, mod
187 * ..
188 * .. Statement Functions ..
189  DOUBLE PRECISION CABS1
190 * ..
191 * .. Statement Function definitions ..
192  cabs1( cdum ) = abs( dble( cdum ) ) + abs( dimag( cdum ) )
193 * ..
194 * .. Executable Statements ..
195 *
196  hbl = desca( mb_ )
197  contxt = desca( ctxt_ )
198  lda = desca( lld_ )
199  ulp = pdlamch( contxt, 'PRECISION' )
200  CALL blacs_gridinfo( contxt, nprow, npcol, myrow, mycol )
201  left = mod( mycol+npcol-1, npcol )
202  right = mod( mycol+1, npcol )
203  up = mod( myrow+nprow-1, nprow )
204  down = mod( myrow+1, nprow )
205  num = nprow*npcol
206 *
207 * BUFFER1 starts at BUF(ISTR1+1) and will contain IBUF1 elements
208 * BUFFER2 starts at BUF(ISTR2+1) and will contain IBUF2 elements
209 * BUFFER3 starts at BUF(ISTR3+1) and will contain IBUF3 elements
210 * BUFFER4 starts at BUF(ISTR4+1) and will contain IBUF4 elements
211 * BUFFER5 starts at BUF(ISTR5+1) and will contain IBUF5 elements
212 *
213  istr1 = 0
214  istr2 = ( ( i-l-1 ) / hbl )
215  IF( istr2*hbl.LT.( i-l-1 ) )
216  $ istr2 = istr2 + 1
217  ii = istr2 / ilcm( nprow, npcol )
218  IF( ii*ilcm( nprow, npcol ).LT.istr2 ) THEN
219  istr2 = ii + 1
220  ELSE
221  istr2 = ii
222  END IF
223  IF( lwork.LT.7*istr2 ) THEN
224  CALL pxerbla( contxt, 'PZLACONSB', 10 )
225  RETURN
226  END IF
227  istr3 = 3*istr2
228  istr4 = istr3 + istr2
229  istr5 = istr3 + istr3
230  CALL infog2l( i-2, i-2, desca, nprow, npcol, myrow, mycol, irow1,
231  $ icol1, ii, jj )
232  modkm1 = mod( i-3+hbl, hbl )
233 *
234 * Copy our relevant pieces of triadiagonal that we owe into
235 * 5 buffers to send to whomever owns H(M,M) as M moves diagonally
236 * up the tridiagonal
237 *
238  ibuf1 = 0
239  ibuf2 = 0
240  ibuf3 = 0
241  ibuf4 = 0
242  ibuf5 = 0
243  ircv1 = 0
244  ircv2 = 0
245  ircv3 = 0
246  ircv4 = 0
247  ircv5 = 0
248  DO 10 m = i - 2, l, -1
249  IF( ( modkm1.EQ.0 ) .AND. ( down.EQ.ii ) .AND.
250  $ ( right.EQ.jj ) .AND. ( m.GT.l ) ) THEN
251 *
252 * We must pack H(M-1,M-1) and send it diagonal down
253 *
254  IF( ( down.NE.myrow ) .OR. ( right.NE.mycol ) ) THEN
255  CALL infog2l( m-1, m-1, desca, nprow, npcol, myrow,
256  $ mycol, irow1, icol1, isrc, jsrc )
257  ibuf1 = ibuf1 + 1
258  buf( istr1+ibuf1 ) = a( ( icol1-1 )*lda+irow1 )
259  END IF
260  END IF
261  IF( ( modkm1.EQ.0 ) .AND. ( myrow.EQ.ii ) .AND.
262  $ ( right.EQ.jj ) .AND. ( m.GT.l ) ) THEN
263 *
264 * We must pack H(M ,M-1) and send it right
265 *
266  IF( npcol.GT.1 ) THEN
267  CALL infog2l( m, m-1, desca, nprow, npcol, myrow, mycol,
268  $ irow1, icol1, isrc, jsrc )
269  ibuf5 = ibuf5 + 1
270  buf( istr5+ibuf5 ) = a( ( icol1-1 )*lda+irow1 )
271  END IF
272  END IF
273  IF( ( modkm1.EQ.hbl-1 ) .AND. ( up.EQ.ii ) .AND.
274  $ ( mycol.EQ.jj ) ) THEN
275 *
276 * We must pack H(M+1,M) and send it up
277 *
278  IF( nprow.GT.1 ) THEN
279  CALL infog2l( m+1, m, desca, nprow, npcol, myrow, mycol,
280  $ irow1, icol1, isrc, jsrc )
281  ibuf2 = ibuf2 + 1
282  buf( istr2+ibuf2 ) = a( ( icol1-1 )*lda+irow1 )
283  END IF
284  END IF
285  IF( ( modkm1.EQ.hbl-1 ) .AND. ( myrow.EQ.ii ) .AND.
286  $ ( left.EQ.jj ) ) THEN
287 *
288 * We must pack H(M ,M+1) and send it left
289 *
290  IF( npcol.GT.1 ) THEN
291  CALL infog2l( m, m+1, desca, nprow, npcol, myrow, mycol,
292  $ irow1, icol1, isrc, jsrc )
293  ibuf3 = ibuf3 + 1
294  buf( istr3+ibuf3 ) = a( ( icol1-1 )*lda+irow1 )
295  END IF
296  END IF
297  IF( ( modkm1.EQ.hbl-1 ) .AND. ( up.EQ.ii ) .AND.
298  $ ( left.EQ.jj ) ) THEN
299 *
300 * We must pack H(M+1,M+1) & H(M+2,M+1) and send it
301 * diagonally up
302 *
303  IF( ( up.NE.myrow ) .OR. ( left.NE.mycol ) ) THEN
304  CALL infog2l( m+1, m+1, desca, nprow, npcol, myrow,
305  $ mycol, irow1, icol1, isrc, jsrc )
306  ibuf4 = ibuf4 + 2
307  buf( istr4+ibuf4-1 ) = a( ( icol1-1 )*lda+irow1 )
308  buf( istr4+ibuf4 ) = a( ( icol1-1 )*lda+irow1+1 )
309  END IF
310  END IF
311  IF( ( modkm1.EQ.hbl-2 ) .AND. ( up.EQ.ii ) .AND.
312  $ ( mycol.EQ.jj ) ) THEN
313 *
314 * We must pack H(M+2,M+1) and send it up
315 *
316  IF( nprow.GT.1 ) THEN
317  CALL infog2l( m+2, m+1, desca, nprow, npcol, myrow,
318  $ mycol, irow1, icol1, isrc, jsrc )
319  ibuf2 = ibuf2 + 1
320  buf( istr2+ibuf2 ) = a( ( icol1-1 )*lda+irow1 )
321  END IF
322  END IF
323 *
324 * Add up the receives
325 *
326  IF( ( myrow.EQ.ii ) .AND. ( mycol.EQ.jj ) ) THEN
327  IF( ( modkm1.EQ.0 ) .AND. ( m.GT.l ) .AND.
328  $ ( ( nprow.GT.1 ) .OR. ( npcol.GT.1 ) ) ) THEN
329 *
330 * We must receive H(M-1,M-1) from diagonal up
331 *
332  ircv1 = ircv1 + 1
333  END IF
334  IF( ( modkm1.EQ.0 ) .AND. ( npcol.GT.1 ) .AND. ( m.GT.l ) )
335  $ THEN
336 *
337 * We must receive H(M ,M-1) from left
338 *
339  ircv5 = ircv5 + 1
340  END IF
341  IF( ( modkm1.EQ.hbl-1 ) .AND. ( nprow.GT.1 ) ) THEN
342 *
343 * We must receive H(M+1,M ) from down
344 *
345  ircv2 = ircv2 + 1
346  END IF
347  IF( ( modkm1.EQ.hbl-1 ) .AND. ( npcol.GT.1 ) ) THEN
348 *
349 * We must receive H(M ,M+1) from right
350 *
351  ircv3 = ircv3 + 1
352  END IF
353  IF( ( modkm1.EQ.hbl-1 ) .AND.
354  $ ( ( nprow.GT.1 ) .OR. ( npcol.GT.1 ) ) ) THEN
355 *
356 * We must receive H(M+1:M+2,M+1) from diagonal down
357 *
358  ircv4 = ircv4 + 2
359  END IF
360  IF( ( modkm1.EQ.hbl-2 ) .AND. ( nprow.GT.1 ) ) THEN
361 *
362 * We must receive H(M+2,M+1) from down
363 *
364  ircv2 = ircv2 + 1
365  END IF
366  END IF
367 *
368 * Possibly change owners (occurs only when MOD(M-1,HBL) = 0)
369 *
370  IF( modkm1.EQ.0 ) THEN
371  ii = ii - 1
372  jj = jj - 1
373  IF( ii.LT.0 )
374  $ ii = nprow - 1
375  IF( jj.LT.0 )
376  $ jj = npcol - 1
377  END IF
378  modkm1 = modkm1 - 1
379  IF( modkm1.LT.0 )
380  $ modkm1 = hbl - 1
381  10 CONTINUE
382 *
383 *
384 * Send data on to the appropriate node if there is any data to send
385 *
386  IF( ibuf1.GT.0 ) THEN
387  CALL zgesd2d( contxt, ibuf1, 1, buf( istr1+1 ), ibuf1, down,
388  $ right )
389  END IF
390  IF( ibuf2.GT.0 ) THEN
391  CALL zgesd2d( contxt, ibuf2, 1, buf( istr2+1 ), ibuf2, up,
392  $ mycol )
393  END IF
394  IF( ibuf3.GT.0 ) THEN
395  CALL zgesd2d( contxt, ibuf3, 1, buf( istr3+1 ), ibuf3, myrow,
396  $ left )
397  END IF
398  IF( ibuf4.GT.0 ) THEN
399  CALL zgesd2d( contxt, ibuf4, 1, buf( istr4+1 ), ibuf4, up,
400  $ left )
401  END IF
402  IF( ibuf5.GT.0 ) THEN
403  CALL zgesd2d( contxt, ibuf5, 1, buf( istr5+1 ), ibuf5, myrow,
404  $ right )
405  END IF
406 *
407 * Receive appropriate data if there is any
408 *
409  IF( ircv1.GT.0 ) THEN
410  CALL zgerv2d( contxt, ircv1, 1, buf( istr1+1 ), ircv1, up,
411  $ left )
412  END IF
413  IF( ircv2.GT.0 ) THEN
414  CALL zgerv2d( contxt, ircv2, 1, buf( istr2+1 ), ircv2, down,
415  $ mycol )
416  END IF
417  IF( ircv3.GT.0 ) THEN
418  CALL zgerv2d( contxt, ircv3, 1, buf( istr3+1 ), ircv3, myrow,
419  $ right )
420  END IF
421  IF( ircv4.GT.0 ) THEN
422  CALL zgerv2d( contxt, ircv4, 1, buf( istr4+1 ), ircv4, down,
423  $ right )
424  END IF
425  IF( ircv5.GT.0 ) THEN
426  CALL zgerv2d( contxt, ircv5, 1, buf( istr5+1 ), ircv5, myrow,
427  $ left )
428  END IF
429 *
430 * Start main loop
431 *
432  ibuf1 = 0
433  ibuf2 = 0
434  ibuf3 = 0
435  ibuf4 = 0
436  ibuf5 = 0
437  CALL infog2l( i-2, i-2, desca, nprow, npcol, myrow, mycol, irow1,
438  $ icol1, ii, jj )
439  modkm1 = mod( i-3+hbl, hbl )
440  IF( ( myrow.EQ.ii ) .AND. ( mycol.EQ.jj ) .AND.
441  $ ( modkm1.NE.hbl-1 ) ) THEN
442  CALL infog2l( i-2, i-1, desca, nprow, npcol, myrow, mycol,
443  $ irow1, icol1, isrc, jsrc )
444  END IF
445 *
446 * Look for two consecutive small subdiagonal elements.
447 *
448  DO 20 m = i - 2, l, -1
449 *
450 * Determine the effect of starting the double-shift QR
451 * iteration at row M, and see if this would make H(M,M-1)
452 * negligible.
453 *
454  IF( ( myrow.EQ.ii ) .AND. ( mycol.EQ.jj ) ) THEN
455  IF( modkm1.EQ.0 ) THEN
456  h22 = a( ( icol1-1 )*lda+irow1+1 )
457  h11 = a( ( icol1-2 )*lda+irow1 )
458  v3 = a( ( icol1-1 )*lda+irow1+2 )
459  h21 = a( ( icol1-2 )*lda+irow1+1 )
460  h12 = a( ( icol1-1 )*lda+irow1 )
461  IF( m.GT.l ) THEN
462  IF( num.GT.1 ) THEN
463  ibuf1 = ibuf1 + 1
464  h00 = buf( istr1+ibuf1 )
465  ELSE
466  h00 = a( ( icol1-3 )*lda+irow1-1 )
467  END IF
468  IF( npcol.GT.1 ) THEN
469  ibuf5 = ibuf5 + 1
470  h10 = buf( istr5+ibuf5 )
471  ELSE
472  h10 = a( ( icol1-3 )*lda+irow1 )
473  END IF
474  END IF
475  END IF
476  IF( modkm1.EQ.hbl-1 ) THEN
477  CALL infog2l( m, m, desca, nprow, npcol, myrow, mycol,
478  $ irow1, icol1, isrc, jsrc )
479  h11 = a( ( icol1-1 )*lda+irow1 )
480  IF( num.GT.1 ) THEN
481  ibuf4 = ibuf4 + 2
482  h22 = buf( istr4+ibuf4-1 )
483  v3 = buf( istr4+ibuf4 )
484  ELSE
485  h22 = a( icol1*lda+irow1+1 )
486  v3 = a( ( icol1+1 )*lda+irow1+1 )
487  END IF
488  IF( nprow.GT.1 ) THEN
489  ibuf2 = ibuf2 + 1
490  h21 = buf( istr2+ibuf2 )
491  ELSE
492  h21 = a( ( icol1-1 )*lda+irow1+1 )
493  END IF
494  IF( npcol.GT.1 ) THEN
495  ibuf3 = ibuf3 + 1
496  h12 = buf( istr3+ibuf3 )
497  ELSE
498  h12 = a( icol1*lda+irow1 )
499  END IF
500  IF( m.GT.l ) THEN
501  h00 = a( ( icol1-2 )*lda+irow1-1 )
502  h10 = a( ( icol1-2 )*lda+irow1 )
503  END IF
504 *
505 * Adjust ICOL1 for next iteration where MODKM1=HBL-2
506 *
507  icol1 = icol1 + 1
508  END IF
509  IF( modkm1.EQ.hbl-2 ) THEN
510  h22 = a( ( icol1-1 )*lda+irow1+1 )
511  h11 = a( ( icol1-2 )*lda+irow1 )
512  IF( nprow.GT.1 ) THEN
513  ibuf2 = ibuf2 + 1
514  v3 = buf( istr2+ibuf2 )
515  ELSE
516  v3 = a( ( icol1-1 )*lda+irow1+2 )
517  END IF
518  h21 = a( ( icol1-2 )*lda+irow1+1 )
519  h12 = a( ( icol1-1 )*lda+irow1 )
520  IF( m.GT.l ) THEN
521  h00 = a( ( icol1-3 )*lda+irow1-1 )
522  h10 = a( ( icol1-3 )*lda+irow1 )
523  END IF
524  END IF
525  IF( ( modkm1.LT.hbl-2 ) .AND. ( modkm1.GT.0 ) ) THEN
526  h22 = a( ( icol1-1 )*lda+irow1+1 )
527  h11 = a( ( icol1-2 )*lda+irow1 )
528  v3 = a( ( icol1-1 )*lda+irow1+2 )
529  h21 = a( ( icol1-2 )*lda+irow1+1 )
530  h12 = a( ( icol1-1 )*lda+irow1 )
531  IF( m.GT.l ) THEN
532  h00 = a( ( icol1-3 )*lda+irow1-1 )
533  h10 = a( ( icol1-3 )*lda+irow1 )
534  END IF
535  END IF
536  h44s = h44 - h11
537  h33s = h33 - h11
538  v1 = ( h33s*h44s-h43h34 ) / h21 + h12
539  v2 = h22 - h11 - h33s - h44s
540  s = cabs1( v1 ) + cabs1( v2 ) + cabs1( v3 )
541  v1 = v1 / s
542  v2 = v2 / s
543  v3 = v3 / s
544  IF( m.EQ.l )
545  $ GO TO 30
546  tst1 = cabs1( v1 )*( cabs1( h00 )+cabs1( h11 )+
547  $ cabs1( h22 ) )
548  IF( cabs1( h10 )*( cabs1( v2 )+cabs1( v3 ) ).LE.ulp*tst1 )
549  $ GO TO 30
550 *
551 * Slide indices diagonally up one for next iteration
552 *
553  irow1 = irow1 - 1
554  icol1 = icol1 - 1
555  END IF
556  IF( m.EQ.l ) THEN
557 *
558 * Stop regardless of which node we are
559 *
560  GO TO 30
561  END IF
562 *
563 * Possibly change owners if on border
564 *
565  IF( modkm1.EQ.0 ) THEN
566  ii = ii - 1
567  jj = jj - 1
568  IF( ii.LT.0 )
569  $ ii = nprow - 1
570  IF( jj.LT.0 )
571  $ jj = npcol - 1
572  END IF
573  modkm1 = modkm1 - 1
574  IF( modkm1.LT.0 )
575  $ modkm1 = hbl - 1
576  20 CONTINUE
577  30 CONTINUE
578 *
579  CALL igamx2d( contxt, 'ALL', ' ', 1, 1, m, 1, l, l, -1, -1, -1 )
580 *
581  RETURN
582 *
583 * End of PZLACONSB
584 *
585  END
infog2l
subroutine infog2l(GRINDX, GCINDX, DESC, NPROW, NPCOL, MYROW, MYCOL, LRINDX, LCINDX, RSRC, CSRC)
Definition: infog2l.f:3
pzlaconsb
subroutine pzlaconsb(A, DESCA, I, L, M, H44, H33, H43H34, BUF, LWORK)
Definition: pzlaconsb.f:3
pxerbla
subroutine pxerbla(ICTXT, SRNAME, INFO)
Definition: pxerbla.f:2