OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
pzlaconsb.f File Reference

Go to the source code of this file.

Functions/Subroutines

subroutine pzlaconsb (a, desca, i, l, m, h44, h33, h43h34, buf, lwork)

Function/Subroutine Documentation

◆ pzlaconsb()

subroutine pzlaconsb ( complex*16, dimension( * ) a,
integer, dimension( * ) desca,
integer i,
integer l,
integer m,
complex*16 h44,
complex*16 h33,
complex*16 h43h34,
complex*16, dimension( * ) buf,
integer lwork )

Definition at line 1 of file pzlaconsb.f.

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.EQ..AND..EQ..AND. IF( ( MODKM10 ) ( DOWNII )
250.EQ..AND..GT. $ ( RIGHTJJ ) ( ML ) ) THEN
251*
252* We must pack H(M-1,M-1) and send it diagonal down
253*
254.NE..OR..NE. IF( ( DOWNMYROW ) ( RIGHTMYCOL ) ) 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.EQ..AND..EQ..AND. IF( ( MODKM10 ) ( MYROWII )
262.EQ..AND..GT. $ ( RIGHTJJ ) ( ML ) ) THEN
263*
264* We must pack H(M ,M-1) and send it right
265*
266.GT. IF( NPCOL1 ) 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.EQ..AND..EQ..AND. IF( ( MODKM1HBL-1 ) ( UPII )
274.EQ. $ ( MYCOLJJ ) ) THEN
275*
276* We must pack H(M+1,M) and send it up
277*
278.GT. IF( NPROW1 ) 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.EQ..AND..EQ..AND. IF( ( MODKM1HBL-1 ) ( MYROWII )
286.EQ. $ ( LEFTJJ ) ) THEN
287*
288* We must pack H(M ,M+1) and send it left
289*
290.GT. IF( NPCOL1 ) 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.EQ..AND..EQ..AND. IF( ( MODKM1HBL-1 ) ( UPII )
298.EQ. $ ( LEFTJJ ) ) THEN
299*
300* We must pack H(M+1,M+1) & H(M+2,M+1) and send it
301* diagonally up
302*
303.NE..OR..NE. IF( ( UPMYROW ) ( LEFTMYCOL ) ) 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.EQ..AND..EQ..AND. IF( ( MODKM1HBL-2 ) ( UPII )
312.EQ. $ ( MYCOLJJ ) ) THEN
313*
314* We must pack H(M+2,M+1) and send it up
315*
316.GT. IF( NPROW1 ) 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.EQ..AND..EQ. IF( ( MYROWII ) ( MYCOLJJ ) ) THEN
327.EQ..AND..GT..AND. IF( ( MODKM10 ) ( ML )
328.GT..OR..GT. $ ( ( NPROW1 ) ( NPCOL1 ) ) ) THEN
329*
330* We must receive H(M-1,M-1) from diagonal up
331*
332 IRCV1 = IRCV1 + 1
333 END IF
334.EQ..AND..GT..AND..GT. IF( ( MODKM10 ) ( NPCOL1 ) ( ML ) )
335 $ THEN
336*
337* We must receive H(M ,M-1) from left
338*
339 IRCV5 = IRCV5 + 1
340 END IF
341.EQ..AND..GT. IF( ( MODKM1HBL-1 ) ( NPROW1 ) ) THEN
342*
343* We must receive H(M+1,M ) from down
344*
345 IRCV2 = IRCV2 + 1
346 END IF
347.EQ..AND..GT. IF( ( MODKM1HBL-1 ) ( NPCOL1 ) ) THEN
348*
349* We must receive H(M ,M+1) from right
350*
351 IRCV3 = IRCV3 + 1
352 END IF
353.EQ..AND. IF( ( MODKM1HBL-1 )
354.GT..OR..GT. $ ( ( NPROW1 ) ( NPCOL1 ) ) ) 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.EQ..AND..GT. IF( ( MODKM1HBL-2 ) ( NPROW1 ) ) 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.EQ. IF( MODKM10 ) THEN
371 II = II - 1
372 JJ = JJ - 1
373.LT. IF( II0 )
374 $ II = NPROW - 1
375.LT. IF( JJ0 )
376 $ JJ = NPCOL - 1
377 END IF
378 MODKM1 = MODKM1 - 1
379.LT. IF( MODKM10 )
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.GT. IF( IBUF10 ) THEN
387 CALL ZGESD2D( CONTXT, IBUF1, 1, BUF( ISTR1+1 ), IBUF1, DOWN,
388 $ RIGHT )
389 END IF
390.GT. IF( IBUF20 ) THEN
391 CALL ZGESD2D( CONTXT, IBUF2, 1, BUF( ISTR2+1 ), IBUF2, UP,
392 $ MYCOL )
393 END IF
394.GT. IF( IBUF30 ) THEN
395 CALL ZGESD2D( CONTXT, IBUF3, 1, BUF( ISTR3+1 ), IBUF3, MYROW,
396 $ LEFT )
397 END IF
398.GT. IF( IBUF40 ) THEN
399 CALL ZGESD2D( CONTXT, IBUF4, 1, BUF( ISTR4+1 ), IBUF4, UP,
400 $ LEFT )
401 END IF
402.GT. IF( IBUF50 ) 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.GT. IF( IRCV10 ) THEN
410 CALL ZGERV2D( CONTXT, IRCV1, 1, BUF( ISTR1+1 ), IRCV1, UP,
411 $ LEFT )
412 END IF
413.GT. IF( IRCV20 ) THEN
414 CALL ZGERV2D( CONTXT, IRCV2, 1, BUF( ISTR2+1 ), IRCV2, DOWN,
415 $ MYCOL )
416 END IF
417.GT. IF( IRCV30 ) THEN
418 CALL ZGERV2D( CONTXT, IRCV3, 1, BUF( ISTR3+1 ), IRCV3, MYROW,
419 $ RIGHT )
420 END IF
421.GT. IF( IRCV40 ) THEN
422 CALL ZGERV2D( CONTXT, IRCV4, 1, BUF( ISTR4+1 ), IRCV4, DOWN,
423 $ RIGHT )
424 END IF
425.GT. IF( IRCV50 ) 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.EQ..AND..EQ..AND. IF( ( MYROWII ) ( MYCOLJJ )
441.NE. $ ( MODKM1HBL-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.EQ..AND..EQ. IF( ( MYROWII ) ( MYCOLJJ ) ) THEN
455.EQ. IF( MODKM10 ) 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.GT. IF( ML ) THEN
462.GT. IF( NUM1 ) THEN
463 IBUF1 = IBUF1 + 1
464 H00 = BUF( ISTR1+IBUF1 )
465 ELSE
466 H00 = A( ( ICOL1-3 )*LDA+IROW1-1 )
467 END IF
468.GT. IF( NPCOL1 ) 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.EQ. IF( MODKM1HBL-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.GT. IF( NUM1 ) 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.GT. IF( NPROW1 ) THEN
489 IBUF2 = IBUF2 + 1
490 H21 = BUF( ISTR2+IBUF2 )
491 ELSE
492 H21 = A( ( ICOL1-1 )*LDA+IROW1+1 )
493 END IF
494.GT. IF( NPCOL1 ) THEN
495 IBUF3 = IBUF3 + 1
496 H12 = BUF( ISTR3+IBUF3 )
497 ELSE
498 H12 = A( ICOL1*LDA+IROW1 )
499 END IF
500.GT. IF( ML ) 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.EQ. IF( MODKM1HBL-2 ) THEN
510 H22 = A( ( ICOL1-1 )*LDA+IROW1+1 )
511 H11 = A( ( ICOL1-2 )*LDA+IROW1 )
512.GT. IF( NPROW1 ) 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.GT. IF( ML ) THEN
521 H00 = A( ( ICOL1-3 )*LDA+IROW1-1 )
522 H10 = A( ( ICOL1-3 )*LDA+IROW1 )
523 END IF
524 END IF
525.LT..AND..GT. IF( ( MODKM1HBL-2 ) ( MODKM10 ) ) 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.GT. IF( ML ) 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.EQ. IF( ML )
545 $ GO TO 30
546 TST1 = CABS1( V1 )*( CABS1( H00 )+CABS1( H11 )+
547 $ CABS1( H22 ) )
548.LE. IF( CABS1( H10 )*( CABS1( V2 )+CABS1( V3 ) )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.EQ. IF( ML ) 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.EQ. IF( MODKM10 ) THEN
566 II = II - 1
567 JJ = JJ - 1
568.LT. IF( II0 )
569 $ II = NPROW - 1
570.LT. IF( JJ0 )
571 $ JJ = NPCOL - 1
572 END IF
573 MODKM1 = MODKM1 - 1
574.LT. IF( MODKM10 )
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*
ilcm
integer function ilcm(m, n)
Definition ilcm.f:2
pxerbla
subroutine pxerbla(contxt, srname, info)
Definition mpi.f:1600
infog2l
subroutine infog2l(grindx, gcindx, desc, nprow, npcol, myrow, mycol, lrindx, lcindx, rsrc, csrc)
Definition mpi.f:937
blacs_gridinfo
subroutine blacs_gridinfo(cntxt, nprow, npcol, myrow, mycol)
Definition mpi.f:754
pdlamch
double precision function pdlamch(ictxt, cmach)
Definition pdblastst.f:6769
pzlaconsb
subroutine pzlaconsb(a, desca, i, l, m, h44, h33, h43h34, buf, lwork)
Definition pzlaconsb.f:3