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 586