ScaLAPACK 2.1  2.1
ScaLAPACK: Scalable Linear Algebra PACKage
pdlaconsb.f
Go to the documentation of this file.
1  SUBROUTINE pdlaconsb( 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 * May 1, 1997
8 *
9 * .. Scalar Arguments ..
10  INTEGER I, L, LWORK, M
11  DOUBLE PRECISION H33, H43H34, H44
12 * ..
13 * .. Array Arguments ..
14  INTEGER DESCA( * )
15  DOUBLE PRECISION A( * ), BUF( * )
16 * ..
17 *
18 * Purpose
19 * =======
20 *
21 * PDLACONSB 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) DOUBLE PRECISION 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) DOUBLE PRECISION
109 * These three values are for the double shift QR iteration.
110 *
111 * BUF (local output) DOUBLE PRECISION 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 DLAHQR, 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 * Implemented by: G. Henry, November 17, 1996
153 *
154 * =====================================================================
155 *
156 * .. Parameters ..
157  INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
158  $ lld_, mb_, m_, nb_, n_, rsrc_
159  parameter( block_cyclic_2d = 1, dlen_ = 9, dtype_ = 1,
160  $ ctxt_ = 2, m_ = 3, n_ = 4, mb_ = 5, nb_ = 6,
161  $ rsrc_ = 7, csrc_ = 8, lld_ = 9 )
162 * ..
163 * .. Local Scalars ..
164  INTEGER CONTXT, DOWN, HBL, IBUF1, IBUF2, IBUF3, IBUF4,
165  $ ibuf5, icol1, ii, ircv1, ircv2, ircv3, ircv4,
166  $ ircv5, irow1, isrc, istr1, istr2, istr3, istr4,
167  $ istr5, jj, jsrc, lda, left, modkm1, mycol,
168  $ myrow, npcol, nprow, num, right, up
169  DOUBLE PRECISION H00, H10, H11, H12, H21, H22, H33S, H44S, S,
170  $ tst1, ulp, v1, v2, v3
171 * ..
172 * .. External Functions ..
173  INTEGER ILCM
174  DOUBLE PRECISION PDLAMCH
175  EXTERNAL ilcm, pdlamch
176 * ..
177 * .. External Subroutines ..
178  EXTERNAL blacs_gridinfo, dgerv2d, dgesd2d, igamx2d,
179  $ infog2l, pxerbla
180 * ..
181 * .. Intrinsic Functions ..
182  INTRINSIC abs, mod
183 * ..
184 * .. Executable Statements ..
185 *
186  hbl = desca( mb_ )
187  contxt = desca( ctxt_ )
188  lda = desca( lld_ )
189  ulp = pdlamch( contxt, 'PRECISION' )
190  CALL blacs_gridinfo( contxt, nprow, npcol, myrow, mycol )
191  left = mod( mycol+npcol-1, npcol )
192  right = mod( mycol+1, npcol )
193  up = mod( myrow+nprow-1, nprow )
194  down = mod( myrow+1, nprow )
195  num = nprow*npcol
196 *
197 * BUFFER1 starts at BUF(ISTR1+1) and will contain IBUF1 elements
198 * BUFFER2 starts at BUF(ISTR2+1) and will contain IBUF2 elements
199 * BUFFER3 starts at BUF(ISTR3+1) and will contain IBUF3 elements
200 * BUFFER4 starts at BUF(ISTR4+1) and will contain IBUF4 elements
201 * BUFFER5 starts at BUF(ISTR5+1) and will contain IBUF5 elements
202 *
203  istr1 = 0
204  istr2 = ( ( i-l-1 ) / hbl )
205  IF( istr2*hbl.LT.( i-l-1 ) )
206  $ istr2 = istr2 + 1
207  ii = istr2 / ilcm( nprow, npcol )
208  IF( ii*ilcm( nprow, npcol ).LT.istr2 ) THEN
209  istr2 = ii + 1
210  ELSE
211  istr2 = ii
212  END IF
213  IF( lwork.LT.7*istr2 ) THEN
214  CALL pxerbla( contxt, 'PDLACONSB', 10 )
215  RETURN
216  END IF
217  istr3 = 3*istr2
218  istr4 = istr3 + istr2
219  istr5 = istr3 + istr3
220  CALL infog2l( i-2, i-2, desca, nprow, npcol, myrow, mycol, irow1,
221  $ icol1, ii, jj )
222  modkm1 = mod( i-3+hbl, hbl )
223 *
224 * Copy our relevant pieces of triadiagonal that we owe into
225 * 5 buffers to send to whomever owns H(M,M) as M moves diagonally
226 * up the tridiagonal
227 *
228  ibuf1 = 0
229  ibuf2 = 0
230  ibuf3 = 0
231  ibuf4 = 0
232  ibuf5 = 0
233  ircv1 = 0
234  ircv2 = 0
235  ircv3 = 0
236  ircv4 = 0
237  ircv5 = 0
238  DO 10 m = i - 2, l, -1
239  IF( ( modkm1.EQ.0 ) .AND. ( down.EQ.ii ) .AND.
240  $ ( right.EQ.jj ) .AND. ( m.GT.l ) ) THEN
241 *
242 * We must pack H(M-1,M-1) and send it diagonal down
243 *
244  IF( ( down.NE.myrow ) .OR. ( right.NE.mycol ) ) THEN
245  CALL infog2l( m-1, m-1, desca, nprow, npcol, myrow,
246  $ mycol, irow1, icol1, isrc, jsrc )
247  ibuf1 = ibuf1 + 1
248  buf( istr1+ibuf1 ) = a( ( icol1-1 )*lda+irow1 )
249  END IF
250  END IF
251  IF( ( modkm1.EQ.0 ) .AND. ( myrow.EQ.ii ) .AND.
252  $ ( right.EQ.jj ) .AND. ( m.GT.l ) ) THEN
253 *
254 * We must pack H(M ,M-1) and send it right
255 *
256  IF( npcol.GT.1 ) THEN
257  CALL infog2l( m, m-1, desca, nprow, npcol, myrow, mycol,
258  $ irow1, icol1, isrc, jsrc )
259  ibuf5 = ibuf5 + 1
260  buf( istr5+ibuf5 ) = a( ( icol1-1 )*lda+irow1 )
261  END IF
262  END IF
263  IF( ( modkm1.EQ.hbl-1 ) .AND. ( up.EQ.ii ) .AND.
264  $ ( mycol.EQ.jj ) ) THEN
265 *
266 * We must pack H(M+1,M) and send it up
267 *
268  IF( nprow.GT.1 ) THEN
269  CALL infog2l( m+1, m, desca, nprow, npcol, myrow, mycol,
270  $ irow1, icol1, isrc, jsrc )
271  ibuf2 = ibuf2 + 1
272  buf( istr2+ibuf2 ) = a( ( icol1-1 )*lda+irow1 )
273  END IF
274  END IF
275  IF( ( modkm1.EQ.hbl-1 ) .AND. ( myrow.EQ.ii ) .AND.
276  $ ( left.EQ.jj ) ) THEN
277 *
278 * We must pack H(M ,M+1) and send it left
279 *
280  IF( npcol.GT.1 ) THEN
281  CALL infog2l( m, m+1, desca, nprow, npcol, myrow, mycol,
282  $ irow1, icol1, isrc, jsrc )
283  ibuf3 = ibuf3 + 1
284  buf( istr3+ibuf3 ) = a( ( icol1-1 )*lda+irow1 )
285  END IF
286  END IF
287  IF( ( modkm1.EQ.hbl-1 ) .AND. ( up.EQ.ii ) .AND.
288  $ ( left.EQ.jj ) ) THEN
289 *
290 * We must pack H(M+1,M+1) & H(M+2,M+1) and send it
291 * diagonally up
292 *
293  IF( ( up.NE.myrow ) .OR. ( left.NE.mycol ) ) THEN
294  CALL infog2l( m+1, m+1, desca, nprow, npcol, myrow,
295  $ mycol, irow1, icol1, isrc, jsrc )
296  ibuf4 = ibuf4 + 2
297  buf( istr4+ibuf4-1 ) = a( ( icol1-1 )*lda+irow1 )
298  buf( istr4+ibuf4 ) = a( ( icol1-1 )*lda+irow1+1 )
299  END IF
300  END IF
301  IF( ( modkm1.EQ.hbl-2 ) .AND. ( up.EQ.ii ) .AND.
302  $ ( mycol.EQ.jj ) ) THEN
303 *
304 * We must pack H(M+2,M+1) and send it up
305 *
306  IF( nprow.GT.1 ) THEN
307  CALL infog2l( m+2, m+1, desca, nprow, npcol, myrow,
308  $ mycol, irow1, icol1, isrc, jsrc )
309  ibuf2 = ibuf2 + 1
310  buf( istr2+ibuf2 ) = a( ( icol1-1 )*lda+irow1 )
311  END IF
312  END IF
313 *
314 * Add up the receives
315 *
316  IF( ( myrow.EQ.ii ) .AND. ( mycol.EQ.jj ) ) THEN
317  IF( ( modkm1.EQ.0 ) .AND. ( m.GT.l ) .AND.
318  $ ( ( nprow.GT.1 ) .OR. ( npcol.GT.1 ) ) ) THEN
319 *
320 * We must receive H(M-1,M-1) from diagonal up
321 *
322  ircv1 = ircv1 + 1
323  END IF
324  IF( ( modkm1.EQ.0 ) .AND. ( npcol.GT.1 ) .AND. ( m.GT.l ) )
325  $ THEN
326 *
327 * We must receive H(M ,M-1) from left
328 *
329  ircv5 = ircv5 + 1
330  END IF
331  IF( ( modkm1.EQ.hbl-1 ) .AND. ( nprow.GT.1 ) ) THEN
332 *
333 * We must receive H(M+1,M ) from down
334 *
335  ircv2 = ircv2 + 1
336  END IF
337  IF( ( modkm1.EQ.hbl-1 ) .AND. ( npcol.GT.1 ) ) THEN
338 *
339 * We must receive H(M ,M+1) from right
340 *
341  ircv3 = ircv3 + 1
342  END IF
343  IF( ( modkm1.EQ.hbl-1 ) .AND.
344  $ ( ( nprow.GT.1 ) .OR. ( npcol.GT.1 ) ) ) THEN
345 *
346 * We must receive H(M+1:M+2,M+1) from diagonal down
347 *
348  ircv4 = ircv4 + 2
349  END IF
350  IF( ( modkm1.EQ.hbl-2 ) .AND. ( nprow.GT.1 ) ) THEN
351 *
352 * We must receive H(M+2,M+1) from down
353 *
354  ircv2 = ircv2 + 1
355  END IF
356  END IF
357 *
358 * Possibly change owners (occurs only when MOD(M-1,HBL) = 0)
359 *
360  IF( modkm1.EQ.0 ) THEN
361  ii = ii - 1
362  jj = jj - 1
363  IF( ii.LT.0 )
364  $ ii = nprow - 1
365  IF( jj.LT.0 )
366  $ jj = npcol - 1
367  END IF
368  modkm1 = modkm1 - 1
369  IF( modkm1.LT.0 )
370  $ modkm1 = hbl - 1
371  10 CONTINUE
372 *
373 *
374 * Send data on to the appropriate node if there is any data to send
375 *
376  IF( ibuf1.GT.0 ) THEN
377  CALL dgesd2d( contxt, ibuf1, 1, buf( istr1+1 ), ibuf1, down,
378  $ right )
379  END IF
380  IF( ibuf2.GT.0 ) THEN
381  CALL dgesd2d( contxt, ibuf2, 1, buf( istr2+1 ), ibuf2, up,
382  $ mycol )
383  END IF
384  IF( ibuf3.GT.0 ) THEN
385  CALL dgesd2d( contxt, ibuf3, 1, buf( istr3+1 ), ibuf3, myrow,
386  $ left )
387  END IF
388  IF( ibuf4.GT.0 ) THEN
389  CALL dgesd2d( contxt, ibuf4, 1, buf( istr4+1 ), ibuf4, up,
390  $ left )
391  END IF
392  IF( ibuf5.GT.0 ) THEN
393  CALL dgesd2d( contxt, ibuf5, 1, buf( istr5+1 ), ibuf5, myrow,
394  $ right )
395  END IF
396 *
397 * Receive appropriate data if there is any
398 *
399  IF( ircv1.GT.0 ) THEN
400  CALL dgerv2d( contxt, ircv1, 1, buf( istr1+1 ), ircv1, up,
401  $ left )
402  END IF
403  IF( ircv2.GT.0 ) THEN
404  CALL dgerv2d( contxt, ircv2, 1, buf( istr2+1 ), ircv2, down,
405  $ mycol )
406  END IF
407  IF( ircv3.GT.0 ) THEN
408  CALL dgerv2d( contxt, ircv3, 1, buf( istr3+1 ), ircv3, myrow,
409  $ right )
410  END IF
411  IF( ircv4.GT.0 ) THEN
412  CALL dgerv2d( contxt, ircv4, 1, buf( istr4+1 ), ircv4, down,
413  $ right )
414  END IF
415  IF( ircv5.GT.0 ) THEN
416  CALL dgerv2d( contxt, ircv5, 1, buf( istr5+1 ), ircv5, myrow,
417  $ left )
418  END IF
419 *
420 * Start main loop
421 *
422  ibuf1 = 0
423  ibuf2 = 0
424  ibuf3 = 0
425  ibuf4 = 0
426  ibuf5 = 0
427  CALL infog2l( i-2, i-2, desca, nprow, npcol, myrow, mycol, irow1,
428  $ icol1, ii, jj )
429  modkm1 = mod( i-3+hbl, hbl )
430  IF( ( myrow.EQ.ii ) .AND. ( mycol.EQ.jj ) .AND.
431  $ ( modkm1.NE.hbl-1 ) ) THEN
432  CALL infog2l( i-2, i-1, desca, nprow, npcol, myrow, mycol,
433  $ irow1, icol1, isrc, jsrc )
434  END IF
435 *
436 * Look for two consecutive small subdiagonal elements.
437 *
438  DO 20 m = i - 2, l, -1
439 *
440 * Determine the effect of starting the double-shift QR
441 * iteration at row M, and see if this would make H(M,M-1)
442 * negligible.
443 *
444  IF( ( myrow.EQ.ii ) .AND. ( mycol.EQ.jj ) ) THEN
445  IF( modkm1.EQ.0 ) THEN
446  h22 = a( ( icol1-1 )*lda+irow1+1 )
447  h11 = a( ( icol1-2 )*lda+irow1 )
448  v3 = a( ( icol1-1 )*lda+irow1+2 )
449  h21 = a( ( icol1-2 )*lda+irow1+1 )
450  h12 = a( ( icol1-1 )*lda+irow1 )
451  IF( m.GT.l ) THEN
452  IF( num.GT.1 ) THEN
453  ibuf1 = ibuf1 + 1
454  h00 = buf( istr1+ibuf1 )
455  ELSE
456  h00 = a( ( icol1-3 )*lda+irow1-1 )
457  END IF
458  IF( npcol.GT.1 ) THEN
459  ibuf5 = ibuf5 + 1
460  h10 = buf( istr5+ibuf5 )
461  ELSE
462  h10 = a( ( icol1-3 )*lda+irow1 )
463  END IF
464  END IF
465  END IF
466  IF( modkm1.EQ.hbl-1 ) THEN
467  CALL infog2l( m, m, desca, nprow, npcol, myrow, mycol,
468  $ irow1, icol1, isrc, jsrc )
469  h11 = a( ( icol1-1 )*lda+irow1 )
470  IF( num.GT.1 ) THEN
471  ibuf4 = ibuf4 + 2
472  h22 = buf( istr4+ibuf4-1 )
473  v3 = buf( istr4+ibuf4 )
474  ELSE
475  h22 = a( icol1*lda+irow1+1 )
476  v3 = a( ( icol1+1 )*lda+irow1+1 )
477  END IF
478  IF( nprow.GT.1 ) THEN
479  ibuf2 = ibuf2 + 1
480  h21 = buf( istr2+ibuf2 )
481  ELSE
482  h21 = a( ( icol1-1 )*lda+irow1+1 )
483  END IF
484  IF( npcol.GT.1 ) THEN
485  ibuf3 = ibuf3 + 1
486  h12 = buf( istr3+ibuf3 )
487  ELSE
488  h12 = a( icol1*lda+irow1 )
489  END IF
490  IF( m.GT.l ) THEN
491  h00 = a( ( icol1-2 )*lda+irow1-1 )
492  h10 = a( ( icol1-2 )*lda+irow1 )
493  END IF
494 *
495 * Adjust ICOL1 for next iteration where MODKM1=HBL-2
496 *
497  icol1 = icol1 + 1
498  END IF
499  IF( modkm1.EQ.hbl-2 ) THEN
500  h22 = a( ( icol1-1 )*lda+irow1+1 )
501  h11 = a( ( icol1-2 )*lda+irow1 )
502  IF( nprow.GT.1 ) THEN
503  ibuf2 = ibuf2 + 1
504  v3 = buf( istr2+ibuf2 )
505  ELSE
506  v3 = a( ( icol1-1 )*lda+irow1+2 )
507  END IF
508  h21 = a( ( icol1-2 )*lda+irow1+1 )
509  h12 = a( ( icol1-1 )*lda+irow1 )
510  IF( m.GT.l ) THEN
511  h00 = a( ( icol1-3 )*lda+irow1-1 )
512  h10 = a( ( icol1-3 )*lda+irow1 )
513  END IF
514  END IF
515  IF( ( modkm1.LT.hbl-2 ) .AND. ( modkm1.GT.0 ) ) THEN
516  h22 = a( ( icol1-1 )*lda+irow1+1 )
517  h11 = a( ( icol1-2 )*lda+irow1 )
518  v3 = a( ( icol1-1 )*lda+irow1+2 )
519  h21 = a( ( icol1-2 )*lda+irow1+1 )
520  h12 = a( ( icol1-1 )*lda+irow1 )
521  IF( m.GT.l ) THEN
522  h00 = a( ( icol1-3 )*lda+irow1-1 )
523  h10 = a( ( icol1-3 )*lda+irow1 )
524  END IF
525  END IF
526  h44s = h44 - h11
527  h33s = h33 - h11
528  v1 = ( h33s*h44s-h43h34 ) / h21 + h12
529  v2 = h22 - h11 - h33s - h44s
530  s = abs( v1 ) + abs( v2 ) + abs( v3 )
531  v1 = v1 / s
532  v2 = v2 / s
533  v3 = v3 / s
534  IF( m.EQ.l )
535  $ GO TO 30
536  tst1 = abs( v1 )*( abs( h00 )+abs( h11 )+abs( h22 ) )
537  IF( abs( h10 )*( abs( v2 )+abs( v3 ) ).LE.ulp*tst1 )
538  $ GO TO 30
539 *
540 * Slide indices diagonally up one for next iteration
541 *
542  irow1 = irow1 - 1
543  icol1 = icol1 - 1
544  END IF
545  IF( m.EQ.l ) THEN
546 *
547 * Stop regardless of which node we are
548 *
549  GO TO 30
550  END IF
551 *
552 * Possibly change owners if on border
553 *
554  IF( modkm1.EQ.0 ) THEN
555  ii = ii - 1
556  jj = jj - 1
557  IF( ii.LT.0 )
558  $ ii = nprow - 1
559  IF( jj.LT.0 )
560  $ jj = npcol - 1
561  END IF
562  modkm1 = modkm1 - 1
563  IF( modkm1.LT.0 )
564  $ modkm1 = hbl - 1
565  20 CONTINUE
566  30 CONTINUE
567 *
568  CALL igamx2d( contxt, 'ALL', ' ', 1, 1, m, 1, l, l, -1, -1, -1 )
569 *
570  RETURN
571 *
572 * End of PDLACONSB
573 *
574  END
infog2l
subroutine infog2l(GRINDX, GCINDX, DESC, NPROW, NPCOL, MYROW, MYCOL, LRINDX, LCINDX, RSRC, CSRC)
Definition: infog2l.f:3
pxerbla
subroutine pxerbla(ICTXT, SRNAME, INFO)
Definition: pxerbla.f:2
pdlaconsb
subroutine pdlaconsb(A, DESCA, I, L, M, H44, H33, H43H34, BUF, LWORK)
Definition: pdlaconsb.f:3