1 DOUBLE PRECISION FUNCTION PDLANTR( NORM, UPLO, DIAG, M, N, A, 2 $ IA, JA, DESCA, WORK ) 3 IMPLICIT NONE 4* 5* -- ScaLAPACK auxiliary routine (version 1.7) -- 6* University of Tennessee, Knoxville, Oak Ridge National Laboratory, 7* and University of California, Berkeley. 8* May 1, 1997 9* 10* .. Scalar Arguments .. 11 CHARACTER DIAG, NORM, UPLO 12 INTEGER IA, JA, M, N 13* .. 14* .. Array Arguments .. 15 INTEGER DESCA( * ) 16 DOUBLE PRECISION A( * ), WORK( * ) 17* .. 18* 19* Purpose 20* ======= 21* 22* PDLANTR returns the value of the one norm, or the Frobenius norm, 23* or the infinity norm, or the element of largest absolute value of a 24* trapezoidal or triangular distributed matrix sub( A ) denoting 25* A(IA:IA+M-1, JA:JA+N-1). 26* 27* PDLANTR returns the value 28* 29* ( max(abs(A(i,j))), NORM = 'M' or 'm' with ia <= i <= ia+m-1, 30* ( and ja <= j <= ja+n-1, 31* ( 32* ( norm1( sub( A ) ), NORM = '1', 'O' or 'o' 33* ( 34* ( normI( sub( A ) ), NORM = 'I' or 'i' 35* ( 36* ( normF( sub( A ) ), NORM = 'F', 'f', 'E' or 'e' 37* 38* where norm1 denotes the one norm of a matrix (maximum column sum), 39* normI denotes the infinity norm of a matrix (maximum row sum) and 40* normF denotes the Frobenius norm of a matrix (square root of sum of 41* squares). Note that max(abs(A(i,j))) is not a matrix norm. 42* 43* Notes 44* ===== 45* 46* Each global data object is described by an associated description 47* vector. This vector stores the information required to establish 48* the mapping between an object element and its corresponding process 49* and memory location. 50* 51* Let A be a generic term for any 2D block cyclicly distributed array. 52* Such a global array has an associated description vector DESCA. 53* In the following comments, the character _ should be read as 54* "of the global array". 55* 56* NOTATION STORED IN EXPLANATION 57* --------------- -------------- -------------------------------------- 58* DTYPE_A(global) DESCA( DTYPE_ )The descriptor type. In this case, 59* DTYPE_A = 1. 60* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating 61* the BLACS process grid A is distribu- 62* ted over. The context itself is glo- 63* bal, but the handle (the integer 64* value) may vary. 65* M_A (global) DESCA( M_ ) The number of rows in the global 66* array A. 67* N_A (global) DESCA( N_ ) The number of columns in the global 68* array A. 69* MB_A (global) DESCA( MB_ ) The blocking factor used to distribute 70* the rows of the array. 71* NB_A (global) DESCA( NB_ ) The blocking factor used to distribute 72* the columns of the array. 73* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first 74* row of the array A is distributed. 75* CSRC_A (global) DESCA( CSRC_ ) The process column over which the 76* first column of the array A is 77* distributed. 78* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local 79* array. LLD_A >= MAX(1,LOCr(M_A)). 80* 81* Let K be the number of rows or columns of a distributed matrix, 82* and assume that its process grid has dimension p x q. 83* LOCr( K ) denotes the number of elements of K that a process 84* would receive if K were distributed over the p processes of its 85* process column. 86* Similarly, LOCc( K ) denotes the number of elements of K that a 87* process would receive if K were distributed over the q processes of 88* its process row. 89* The values of LOCr() and LOCc() may be determined via a call to the 90* ScaLAPACK tool function, NUMROC: 91* LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ), 92* LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ). 93* An upper bound for these quantities may be computed by: 94* LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A 95* LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A 96* 97* Arguments 98* ========= 99* 100* NORM (global input) CHARACTER 101* Specifies the value to be returned in PDLANTR as described 102* above. 103* 104* UPLO (global input) CHARACTER 105* Specifies whether the matrix sub( A ) is upper or lower 106* trapezoidal. 107* = 'U': Upper trapezoidal 108* = 'L': Lower trapezoidal 109* Note that sub( A ) is triangular instead of trapezoidal 110* if M = N. 111* 112* DIAG (global input) CHARACTER 113* Specifies whether or not the distributed matrix sub( A ) has 114* unit diagonal. 115* = 'N': Non-unit diagonal 116* = 'U': Unit diagonal 117* 118* M (global input) INTEGER 119* The number of rows to be operated on i.e the number of rows 120* of the distributed submatrix sub( A ). When M = 0, PDLANTR is 121* set to zero. M >= 0. 122* 123* N (global input) INTEGER 124* The number of columns to be operated on i.e the number of 125* columns of the distributed submatrix sub( A ). When N = 0, 126* PDLANTR is set to zero. N >= 0. 127* 128* A (local input) DOUBLE PRECISION pointer into the local memory 129* to an array of dimension (LLD_A, LOCc(JA+N-1) ) containing 130* the local pieces of sub( A ). 131* 132* IA (global input) INTEGER 133* The row index in the global array A indicating the first 134* row of sub( A ). 135* 136* JA (global input) INTEGER 137* The column index in the global array A indicating the 138* first column of sub( A ). 139* 140* DESCA (global and local input) INTEGER array of dimension DLEN_. 141* The array descriptor for the distributed matrix A. 142* 143* WORK (local workspace) DOUBLE PRECISION array dimension (LWORK) 144* LWORK >= 0 if NORM = 'M' or 'm' (not referenced), 145* Nq0 if NORM = '1', 'O' or 'o', 146* Mp0 if NORM = 'I' or 'i', 147* 0 if NORM = 'F', 'f', 'E' or 'e' (not referenced), 148* where 149* 150* IROFFA = MOD( IA-1, MB_A ), ICOFFA = MOD( JA-1, NB_A ), 151* IAROW = INDXG2P( IA, MB_A, MYROW, RSRC_A, NPROW ), 152* IACOL = INDXG2P( JA, NB_A, MYCOL, CSRC_A, NPCOL ), 153* Mp0 = NUMROC( M+IROFFA, MB_A, MYROW, IAROW, NPROW ), 154* Nq0 = NUMROC( N+ICOFFA, NB_A, MYCOL, IACOL, NPCOL ), 155* 156* INDXG2P and NUMROC are ScaLAPACK tool functions; MYROW, 157* MYCOL, NPROW and NPCOL can be determined by calling the 158* subroutine BLACS_GRIDINFO. 159* 160* ===================================================================== 161* 162* .. Parameters .. 163 INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_, 164 $ LLD_, MB_, M_, NB_, N_, RSRC_ 165 PARAMETER ( BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DTYPE_ = 1, 166 $ CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6, 167 $ RSRC_ = 7, CSRC_ = 8, LLD_ = 9 ) 168 DOUBLE PRECISION ONE, ZERO 169 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) 170* .. 171* .. Local Scalars .. 172 LOGICAL UDIAG 173 INTEGER IACOL, IAROW, ICTXT, II, IIA, ICOFF, IOFFA, 174 $ IROFF, J, JB, JJ, JJA, JN, KK, LDA, LL, MP, 175 $ MYCOL, MYROW, NP, NPCOL, NPROW, NQ 176 DOUBLE PRECISION SUM, VALUE 177* .. 178* .. Local Arrays .. 179 DOUBLE PRECISION SSQ( 2 ), COLSSQ( 2 ) 180* .. 181* .. External Subroutines .. 182 EXTERNAL BLACS_GRIDINFO, DCOMBSSQ, DGEBR2D, 183 $ DGEBS2D, DGAMX2D, DGSUM2D, DLASSQ, 184 $ INFOG2L, PDTREECOMB 185* .. 186* .. External Functions .. 187 LOGICAL LSAME 188 INTEGER ICEIL, IDAMAX, NUMROC 189 EXTERNAL LSAME, ICEIL, IDAMAX, NUMROC 190* .. 191* .. Intrinsic Functions .. 192 INTRINSIC ABS, DBLE, MAX, MIN, MOD, SQRT 193* .. 194* .. Executable Statements .. 195* 196* Get grid parameters 197* 198 ICTXT = DESCA( CTXT_ ) 199 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) 200* 201 UDIAG = LSAME( DIAG, 'U' ) 202 CALL INFOG2L( IA, JA, DESCA, NPROW, NPCOL, MYROW, MYCOL, IIA, JJA, 203 $ IAROW, IACOL ) 204 IROFF = MOD( IA-1, DESCA( MB_ ) ) 205 ICOFF = MOD( JA-1, DESCA( NB_ ) ) 206 MP = NUMROC( M+IROFF, DESCA( MB_ ), MYROW, IAROW, NPROW ) 207 NQ = NUMROC( N+ICOFF, DESCA( NB_ ), MYCOL, IACOL, NPCOL ) 208 IF( MYROW.EQ.IAROW ) 209 $ MP = MP - IROFF 210 IF( MYCOL.EQ.IACOL ) 211 $ NQ = NQ - ICOFF 212 LDA = DESCA( LLD_ ) 213 IOFFA = ( JJA - 1 ) * LDA 214* 215 IF( MIN( M, N ).EQ.0 ) THEN 216* 217 VALUE = ZERO 218* 219************************************************************************ 220* max norm 221* 222 ELSE IF( LSAME( NORM, 'M' ) ) THEN 223* 224* Find max(abs(A(i,j))). 225* 226 IF( UDIAG ) THEN 227 VALUE = ONE 228 ELSE 229 VALUE = ZERO 230 END IF 231* 232 IF( LSAME( UPLO, 'U' ) ) THEN 233* 234* Upper triangular matrix 235* 236 II = IIA 237 JJ = JJA 238 JN = MIN( ICEIL( JA, DESCA( NB_ ) ) * DESCA( NB_ ), JA+N-1 ) 239 JB = JN-JA+1 240* 241 IF( MYCOL.EQ.IACOL ) THEN 242 IF( MYROW.EQ.IAROW ) THEN 243 IF( UDIAG ) THEN 244 DO 20 LL = JJ, JJ + JB -1 245 DO 10 KK = IIA, MIN(II+LL-JJ-1,IIA+MP-1) 246 VALUE = MAX( VALUE, ABS( A( IOFFA+KK ) ) ) 247 10 CONTINUE 248 IOFFA = IOFFA + LDA 249 20 CONTINUE 250 ELSE 251 DO 40 LL = JJ, JJ + JB -1 252 DO 30 KK = IIA, MIN( II+LL-JJ, IIA+MP-1 ) 253 VALUE = MAX( VALUE, ABS( A( IOFFA+KK ) ) ) 254 30 CONTINUE 255 IOFFA = IOFFA + LDA 256 40 CONTINUE 257 END IF 258 ELSE 259 DO 60 LL = JJ, JJ + JB -1 260 DO 50 KK = IIA, MIN( II-1, IIA+MP-1 ) 261 VALUE = MAX( VALUE, ABS( A( IOFFA+KK ) ) ) 262 50 CONTINUE 263 IOFFA = IOFFA + LDA 264 60 CONTINUE 265 END IF 266 JJ = JJ + JB 267 END IF 268* 269 IF( MYROW.EQ.IAROW ) 270 $ II = II + JB 271 IAROW = MOD( IAROW+1, NPROW ) 272 IACOL = MOD( IACOL+1, NPCOL ) 273* 274* Loop over remaining block of columns 275* 276 DO 130 J = JN+1, JA+N-1, DESCA( NB_ ) 277 JB = MIN( JA+N-J, DESCA( NB_ ) ) 278* 279 IF( MYCOL.EQ.IACOL ) THEN 280 IF( MYROW.EQ.IAROW ) THEN 281 IF( UDIAG ) THEN 282 DO 80 LL = JJ, JJ + JB -1 283 DO 70 KK = IIA, MIN( II+LL-JJ-1, IIA+MP-1 ) 284 VALUE = MAX( VALUE, ABS( A( IOFFA+KK ) ) ) 285 70 CONTINUE 286 IOFFA = IOFFA + LDA 287 80 CONTINUE 288 ELSE 289 DO 100 LL = JJ, JJ + JB -1 290 DO 90 KK = IIA, MIN( II+LL-JJ, IIA+MP-1 ) 291 VALUE = MAX( VALUE, ABS( A( IOFFA+KK ) ) ) 292 90 CONTINUE 293 IOFFA = IOFFA + LDA 294 100 CONTINUE 295 END IF 296 ELSE 297 DO 120 LL = JJ, JJ + JB -1 298 DO 110 KK = IIA, MIN( II-1, IIA+MP-1 ) 299 VALUE = MAX( VALUE, ABS( A( IOFFA+KK ) ) ) 300 110 CONTINUE 301 IOFFA = IOFFA + LDA 302 120 CONTINUE 303 END IF 304 JJ = JJ + JB 305 END IF 306* 307 IF( MYROW.EQ.IAROW ) 308 $ II = II + JB 309 IAROW = MOD( IAROW+1, NPROW ) 310 IACOL = MOD( IACOL+1, NPCOL ) 311* 312 130 CONTINUE 313* 314 ELSE 315* 316* Lower triangular matrix 317* 318 II = IIA 319 JJ = JJA 320 JN = MIN( ICEIL( JA, DESCA( NB_ ) ) * DESCA( NB_ ), JA+N-1 ) 321 JB = JN-JA+1 322* 323 IF( MYCOL.EQ.IACOL ) THEN 324 IF( MYROW.EQ.IAROW ) THEN 325 IF( UDIAG ) THEN 326 DO 150 LL = JJ, JJ + JB -1 327 DO 140 KK = II+LL-JJ+1, IIA+MP-1 328 VALUE = MAX( VALUE, ABS( A( IOFFA+KK ) ) ) 329 140 CONTINUE 330 IOFFA = IOFFA + LDA 331 150 CONTINUE 332 ELSE 333 DO 170 LL = JJ, JJ + JB -1 334 DO 160 KK = II+LL-JJ, IIA+MP-1 335 VALUE = MAX( VALUE, ABS( A( IOFFA+KK ) ) ) 336 160 CONTINUE 337 IOFFA = IOFFA + LDA 338 170 CONTINUE 339 END IF 340 ELSE 341 DO 190 LL = JJ, JJ + JB -1 342 DO 180 KK = II, IIA+MP-1 343 VALUE = MAX( VALUE, ABS( A( IOFFA+KK ) ) ) 344 180 CONTINUE 345 IOFFA = IOFFA + LDA 346 190 CONTINUE 347 END IF 348 JJ = JJ + JB 349 END IF 350* 351 IF( MYROW.EQ.IAROW ) 352 $ II = II + JB 353 IAROW = MOD( IAROW+1, NPROW ) 354 IACOL = MOD( IACOL+1, NPCOL ) 355* 356* Loop over remaining block of columns 357* 358 DO 260 J = JN+1, JA+N-1, DESCA( NB_ ) 359 JB = MIN( JA+N-J, DESCA( NB_ ) ) 360* 361 IF( MYCOL.EQ.IACOL ) THEN 362 IF( MYROW.EQ.IAROW ) THEN 363 IF( UDIAG ) THEN 364 DO 210 LL = JJ, JJ + JB -1 365 DO 200 KK = II+LL-JJ+1, IIA+MP-1 366 VALUE = MAX( VALUE, ABS( A( IOFFA+KK ) ) ) 367 200 CONTINUE 368 IOFFA = IOFFA + LDA 369 210 CONTINUE 370 ELSE 371 DO 230 LL = JJ, JJ + JB -1 372 DO 220 KK = II+LL-JJ, IIA+MP-1 373 VALUE = MAX( VALUE, ABS( A( IOFFA+KK ) ) ) 374 220 CONTINUE 375 IOFFA = IOFFA + LDA 376 230 CONTINUE 377 END IF 378 ELSE 379 DO 250 LL = JJ, JJ + JB -1 380 DO 240 KK = II, IIA+MP-1 381 VALUE = MAX( VALUE, ABS( A( IOFFA+KK ) ) ) 382 240 CONTINUE 383 IOFFA = IOFFA + LDA 384 250 CONTINUE 385 END IF 386 JJ = JJ + JB 387 END IF 388* 389 IF( MYROW.EQ.IAROW ) 390 $ II = II + JB 391 IAROW = MOD( IAROW+1, NPROW ) 392 IACOL = MOD( IACOL+1, NPCOL ) 393* 394 260 CONTINUE 395* 396 END IF 397* 398* Gather the intermediate results to process (0,0). 399* 400 CALL DGAMX2D( ICTXT, 'All', ' ', 1, 1, VALUE, 1, KK, LL, -1, 401 $ 0, 0 ) 402* 403************************************************************************ 404* one norm 405* 406 ELSE IF( LSAME( NORM, 'O' ) .OR. NORM.EQ.'1' ) THEN 407* 408 VALUE = ZERO 409* 410 IF( LSAME( UPLO, 'U' ) ) THEN 411* 412* Upper triangular matrix 413* 414 II = IIA 415 JJ = JJA 416 JN = MIN( ICEIL( JA, DESCA( NB_ ) ) * DESCA( NB_ ), JA+N-1 ) 417 JB = JN-JA+1 418* 419 IF( MYCOL.EQ.IACOL ) THEN 420 IF( MYROW.EQ.IAROW ) THEN 421 IF( UDIAG ) THEN 422 DO 280 LL = JJ, JJ + JB -1 423 SUM = ZERO 424 DO 270 KK = IIA, MIN( II+LL-JJ-1, IIA+MP-1 ) 425 SUM = SUM + ABS( A( IOFFA+KK ) ) 426 270 CONTINUE 427* Unit diagonal entry 428 KK = II+LL-JJ 429 IF (KK <= IIA+MP-1) THEN 430 SUM = SUM + ONE 431 ENDIF 432 IOFFA = IOFFA + LDA 433 WORK( LL-JJA+1 ) = SUM 434 280 CONTINUE 435 ELSE 436 DO 300 LL = JJ, JJ + JB -1 437 SUM = ZERO 438 DO 290 KK = IIA, MIN( II+LL-JJ, IIA+MP-1 ) 439 SUM = SUM + ABS( A( IOFFA+KK ) ) 440 290 CONTINUE 441 IOFFA = IOFFA + LDA 442 WORK( LL-JJA+1 ) = SUM 443 300 CONTINUE 444 END IF 445 ELSE 446 DO 320 LL = JJ, JJ + JB -1 447 SUM = ZERO 448 DO 310 KK = IIA, MIN( II-1, IIA+MP-1 ) 449 SUM = SUM + ABS( A( IOFFA+KK ) ) 450 310 CONTINUE 451 IOFFA = IOFFA + LDA 452 WORK( LL-JJA+1 ) = SUM 453 320 CONTINUE 454 END IF 455 JJ = JJ + JB 456 END IF 457* 458 IF( MYROW.EQ.IAROW ) 459 $ II = II + JB 460 IAROW = MOD( IAROW+1, NPROW ) 461 IACOL = MOD( IACOL+1, NPCOL ) 462* 463* Loop over remaining block of columns 464* 465 DO 390 J = JN+1, JA+N-1, DESCA( NB_ ) 466 JB = MIN( JA+N-J, DESCA( NB_ ) ) 467* 468 IF( MYCOL.EQ.IACOL ) THEN 469 IF( MYROW.EQ.IAROW ) THEN 470 IF( UDIAG ) THEN 471 DO 340 LL = JJ, JJ + JB -1 472 SUM = ZERO 473 DO 330 KK = IIA, MIN( II+LL-JJ-1, IIA+MP-1 ) 474 SUM = SUM + ABS( A( IOFFA+KK ) ) 475 330 CONTINUE 476* Unit diagonal entry 477 KK = II+LL-JJ 478 IF (KK <= IIA+MP-1) THEN 479 SUM = SUM + ONE 480 ENDIF 481 IOFFA = IOFFA + LDA 482 WORK( LL-JJA+1 ) = SUM 483 340 CONTINUE 484 ELSE 485 DO 360 LL = JJ, JJ + JB -1 486 SUM = ZERO 487 DO 350 KK = IIA, MIN( II+LL-JJ, IIA+MP-1 ) 488 SUM = SUM + ABS( A( IOFFA+KK ) ) 489 350 CONTINUE 490 IOFFA = IOFFA + LDA 491 WORK( LL-JJA+1 ) = SUM 492 360 CONTINUE 493 END IF 494 ELSE 495 DO 380 LL = JJ, JJ + JB -1 496 SUM = ZERO 497 DO 370 KK = IIA, MIN( II-1, IIA+MP-1 ) 498 SUM = SUM + ABS( A( IOFFA+KK ) ) 499 370 CONTINUE 500 IOFFA = IOFFA + LDA 501 WORK( LL-JJA+1 ) = SUM 502 380 CONTINUE 503 END IF 504 JJ = JJ + JB 505 END IF 506* 507 IF( MYROW.EQ.IAROW ) 508 $ II = II + JB 509 IAROW = MOD( IAROW+1, NPROW ) 510 IACOL = MOD( IACOL+1, NPCOL ) 511* 512 390 CONTINUE 513* 514 ELSE 515* 516* Lower triangular matrix 517* 518 II = IIA 519 JJ = JJA 520 JN = MIN( ICEIL( JA, DESCA( NB_ ) ) * DESCA( NB_ ), JA+N-1 ) 521 JB = JN-JA+1 522* 523 IF( MYCOL.EQ.IACOL ) THEN 524 IF( MYROW.EQ.IAROW ) THEN 525 IF( UDIAG ) THEN 526 DO 410 LL = JJ, JJ + JB -1 527 SUM = ONE 528 DO 400 KK = II+LL-JJ+1, IIA+MP-1 529 SUM = SUM + ABS( A( IOFFA+KK ) ) 530 400 CONTINUE 531 IOFFA = IOFFA + LDA 532 WORK( LL-JJA+1 ) = SUM 533 410 CONTINUE 534 ELSE 535 DO 430 LL = JJ, JJ + JB -1 536 SUM = ZERO 537 DO 420 KK = II+LL-JJ, IIA+MP-1 538 SUM = SUM + ABS( A( IOFFA+KK ) ) 539 420 CONTINUE 540 IOFFA = IOFFA + LDA 541 WORK( LL-JJA+1 ) = SUM 542 430 CONTINUE 543 END IF 544 ELSE 545 DO 450 LL = JJ, JJ + JB -1 546 SUM = ZERO 547 DO 440 KK = II, IIA+MP-1 548 SUM = SUM + ABS( A( IOFFA+KK ) ) 549 440 CONTINUE 550 IOFFA = IOFFA + LDA 551 WORK( LL-JJA+1 ) = SUM 552 450 CONTINUE 553 END IF 554 JJ = JJ + JB 555 END IF 556* 557 IF( MYROW.EQ.IAROW ) 558 $ II = II + JB 559 IAROW = MOD( IAROW+1, NPROW ) 560 IACOL = MOD( IACOL+1, NPCOL ) 561* 562* Loop over remaining block of columns 563* 564 DO 520 J = JN+1, JA+N-1, DESCA( NB_ ) 565 JB = MIN( JA+N-J, DESCA( NB_ ) ) 566* 567 IF( MYCOL.EQ.IACOL ) THEN 568 IF( MYROW.EQ.IAROW ) THEN 569 IF( UDIAG ) THEN 570 DO 470 LL = JJ, JJ + JB -1 571 SUM = ONE 572 DO 460 KK = II+LL-JJ+1, IIA+MP-1 573 SUM = SUM + ABS( A( IOFFA+KK ) ) 574 460 CONTINUE 575 IOFFA = IOFFA + LDA 576 WORK( LL-JJA+1 ) = SUM 577 470 CONTINUE 578 ELSE 579 DO 490 LL = JJ, JJ + JB -1 580 SUM = ZERO 581 DO 480 KK = II+LL-JJ, IIA+MP-1 582 SUM = SUM + ABS( A( IOFFA+KK ) ) 583 480 CONTINUE 584 IOFFA = IOFFA + LDA 585 WORK( LL-JJA+1 ) = SUM 586 490 CONTINUE 587 END IF 588 ELSE 589 DO 510 LL = JJ, JJ + JB -1 590 SUM = ZERO 591 DO 500 KK = II, IIA+MP-1 592 SUM = SUM + ABS( A( IOFFA+KK ) ) 593 500 CONTINUE 594 IOFFA = IOFFA + LDA 595 WORK( LL-JJA+1 ) = SUM 596 510 CONTINUE 597 END IF 598 JJ = JJ + JB 599 END IF 600* 601 IF( MYROW.EQ.IAROW ) 602 $ II = II + JB 603 IAROW = MOD( IAROW+1, NPROW ) 604 IACOL = MOD( IACOL+1, NPCOL ) 605* 606 520 CONTINUE 607* 608 END IF 609* 610* Find sum of global matrix columns and store on row 0 of 611* process grid 612* 613 CALL DGSUM2D( ICTXT, 'Columnwise', ' ', 1, NQ, WORK, 1, 614 $ 0, MYCOL ) 615* 616* Find maximum sum of columns for 1-norm 617* 618 IF( MYROW.EQ.0 ) THEN 619 IF( NQ.GT.0 ) THEN 620 VALUE = WORK( IDAMAX( NQ, WORK, 1 ) ) 621 ELSE 622 VALUE = ZERO 623 END IF 624 CALL DGAMX2D( ICTXT, 'Rowwise', ' ', 1, 1, VALUE, 1, KK, LL, 625 $ -1, 0, 0 ) 626 END IF 627* 628************************************************************************ 629* infinity norm 630* 631 ELSE IF( LSAME( NORM, 'I' ) ) THEN 632* 633 IF( LSAME( UPLO, 'U' ) ) THEN 634 DO 540 KK = IIA, IIA+MP-1 635 WORK( KK ) = ZERO 636 540 CONTINUE 637 ELSE 638 DO 570 KK = IIA, IIA+MP-1 639 WORK( KK ) = ZERO 640 570 CONTINUE 641 END IF 642* 643 IF( LSAME( UPLO, 'U' ) ) THEN 644* 645* Upper triangular matrix 646* 647 II = IIA 648 JJ = JJA 649 JN = MIN( ICEIL( JA, DESCA( NB_ ) ) * DESCA( NB_ ), JA+N-1 ) 650 JB = JN-JA+1 651* 652 IF( MYCOL.EQ.IACOL ) THEN 653 IF( MYROW.EQ.IAROW ) THEN 654 IF( UDIAG ) THEN 655 DO 590 LL = JJ, JJ + JB -1 656 DO 580 KK = IIA, MIN( II+LL-JJ-1, IIA+MP-1 ) 657 WORK( KK-IIA+1 ) = WORK( KK-IIA+1 ) + 658 $ ABS( A( IOFFA+KK ) ) 659 580 CONTINUE 660* Unit diagonal entry 661 KK = II+LL-JJ 662 IF (KK <= IIA+MP-1) THEN 663 WORK( KK-IIA+1 ) = WORK( KK-IIA+1 ) + ONE 664 ENDIF 665 IOFFA = IOFFA + LDA 666 590 CONTINUE 667 ELSE 668 DO 610 LL = JJ, JJ + JB -1 669 DO 600 KK = IIA, MIN( II+LL-JJ, IIA+MP-1 ) 670 WORK( KK-IIA+1 ) = WORK( KK-IIA+1 ) + 671 $ ABS( A( IOFFA+KK ) ) 672 600 CONTINUE 673 IOFFA = IOFFA + LDA 674 610 CONTINUE 675 END IF 676 ELSE 677 DO 630 LL = JJ, JJ + JB -1 678 DO 620 KK = IIA, MIN( II-1, IIA+MP-1 ) 679 WORK( KK-IIA+1 ) = WORK( KK-IIA+1 ) + 680 $ ABS( A( IOFFA+KK ) ) 681 620 CONTINUE 682 IOFFA = IOFFA + LDA 683 630 CONTINUE 684 END IF 685 JJ = JJ + JB 686 END IF 687* 688 IF( MYROW.EQ.IAROW ) 689 $ II = II + JB 690 IAROW = MOD( IAROW+1, NPROW ) 691 IACOL = MOD( IACOL+1, NPCOL ) 692* 693* Loop over remaining block of columns 694* 695 DO 700 J = JN+1, JA+N-1, DESCA( NB_ ) 696 JB = MIN( JA+N-J, DESCA( NB_ ) ) 697* 698 IF( MYCOL.EQ.IACOL ) THEN 699 IF( MYROW.EQ.IAROW ) THEN 700 IF( UDIAG ) THEN 701 DO 650 LL = JJ, JJ + JB -1 702 DO 640 KK = IIA, MIN( II+LL-JJ-1, IIA+MP-1 ) 703 WORK( KK-IIA+1 ) = WORK( KK-IIA+1 ) + 704 $ ABS( A( IOFFA+KK ) ) 705 640 CONTINUE 706* Unit diagonal entry 707 KK = II+LL-JJ 708 IF (KK <= IIA+MP-1) THEN 709 WORK( KK-IIA+1 ) = WORK( KK-IIA+1 ) + ONE 710 ENDIF 711 IOFFA = IOFFA + LDA 712 650 CONTINUE 713 ELSE 714 DO 670 LL = JJ, JJ + JB -1 715 DO 660 KK = IIA, MIN( II+LL-JJ, IIA+MP-1 ) 716 WORK( KK-IIA+1 ) = WORK( KK-IIA+1 ) + 717 $ ABS( A( IOFFA+KK ) ) 718 660 CONTINUE 719 IOFFA = IOFFA + LDA 720 670 CONTINUE 721 END IF 722 ELSE 723 DO 690 LL = JJ, JJ + JB -1 724 DO 680 KK = IIA, MIN( II-1, IIA+MP-1 ) 725 WORK( KK-IIA+1 ) = WORK( KK-IIA+1 ) + 726 $ ABS( A( IOFFA+KK ) ) 727 680 CONTINUE 728 IOFFA = IOFFA + LDA 729 690 CONTINUE 730 END IF 731 JJ = JJ + JB 732 END IF 733* 734 IF( MYROW.EQ.IAROW ) 735 $ II = II + JB 736 IAROW = MOD( IAROW+1, NPROW ) 737 IACOL = MOD( IACOL+1, NPCOL ) 738* 739 700 CONTINUE 740* 741 ELSE 742* 743* Lower triangular matrix 744* 745 II = IIA 746 JJ = JJA 747 JN = MIN( ICEIL( JA, DESCA( NB_ ) ) * DESCA( NB_ ), JA+N-1 ) 748 JB = JN-JA+1 749* 750 IF( MYCOL.EQ.IACOL ) THEN 751 IF( MYROW.EQ.IAROW ) THEN 752 IF( UDIAG ) THEN 753 DO 720 LL = JJ, JJ + JB -1 754* Unit diagonal entry 755 KK = II+LL-JJ 756 WORK( KK-IIA+1 ) = WORK( KK-IIA+1 ) + ONE 757 DO 710 KK = II+LL-JJ+1, IIA+MP-1 758 WORK( KK-IIA+1 ) = WORK( KK-IIA+1 ) + 759 $ ABS( A( IOFFA+KK ) ) 760 710 CONTINUE 761 IOFFA = IOFFA + LDA 762 720 CONTINUE 763 ELSE 764 DO 740 LL = JJ, JJ + JB -1 765 DO 730 KK = II+LL-JJ, IIA+MP-1 766 WORK( KK-IIA+1 ) = WORK( KK-IIA+1 ) + 767 $ ABS( A( IOFFA+KK ) ) 768 730 CONTINUE 769 IOFFA = IOFFA + LDA 770 740 CONTINUE 771 END IF 772 ELSE 773 DO 760 LL = JJ, JJ + JB -1 774 DO 750 KK = II, IIA+MP-1 775 WORK( KK-IIA+1 ) = WORK( KK-IIA+1 ) + 776 $ ABS( A( IOFFA+KK ) ) 777 750 CONTINUE 778 IOFFA = IOFFA + LDA 779 760 CONTINUE 780 END IF 781 JJ = JJ + JB 782 END IF 783* 784 IF( MYROW.EQ.IAROW ) 785 $ II = II + JB 786 IAROW = MOD( IAROW+1, NPROW ) 787 IACOL = MOD( IACOL+1, NPCOL ) 788* 789* Loop over remaining block of columns 790* 791 DO 830 J = JN+1, JA+N-1, DESCA( NB_ ) 792 JB = MIN( JA+N-J, DESCA( NB_ ) ) 793* 794 IF( MYCOL.EQ.IACOL ) THEN 795 IF( MYROW.EQ.IAROW ) THEN 796 IF( UDIAG ) THEN 797 DO 780 LL = JJ, JJ + JB -1 798* Unit diagonal entry 799 KK = II+LL-JJ 800 WORK( KK-IIA+1 ) = WORK( KK-IIA+1 ) + ONE 801 DO 770 KK = II+LL-JJ+1, IIA+MP-1 802 WORK( KK-IIA+1 ) = WORK( KK-IIA+1 ) + 803 $ ABS( A( IOFFA+KK ) ) 804 770 CONTINUE 805 IOFFA = IOFFA + LDA 806 780 CONTINUE 807 ELSE 808 DO 800 LL = JJ, JJ + JB -1 809 DO 790 KK = II+LL-JJ, IIA+MP-1 810 WORK( KK-IIA+1 ) = WORK( KK-IIA+1 ) + 811 $ ABS( A( IOFFA+KK ) ) 812 790 CONTINUE 813 IOFFA = IOFFA + LDA 814 800 CONTINUE 815 END IF 816 ELSE 817 DO 820 LL = JJ, JJ + JB -1 818 DO 810 KK = II, IIA+MP-1 819 WORK( KK-IIA+1 ) = WORK( KK-IIA+1 ) + 820 $ ABS( A( IOFFA+KK ) ) 821 810 CONTINUE 822 IOFFA = IOFFA + LDA 823 820 CONTINUE 824 END IF 825 JJ = JJ + JB 826 END IF 827* 828 IF( MYROW.EQ.IAROW ) 829 $ II = II + JB 830 IAROW = MOD( IAROW+1, NPROW ) 831 IACOL = MOD( IACOL+1, NPCOL ) 832* 833 830 CONTINUE 834* 835 END IF 836* 837* Find sum of global matrix rows and store on column 0 of 838* process grid 839* 840 CALL DGSUM2D( ICTXT, 'Rowwise', ' ', MP, 1, WORK, MAX( 1, MP ), 841 $ MYROW, 0 ) 842* 843* Find maximum sum of rows for Infinity-norm 844* 845 IF( MYCOL.EQ.0 ) THEN 846 IF( MP.GT.0 ) THEN 847 VALUE = WORK( IDAMAX( MP, WORK, 1 ) ) 848 ELSE 849 VALUE = ZERO 850 END IF 851 CALL DGAMX2D( ICTXT, 'Columnwise', ' ', 1, 1, VALUE, 1, KK, 852 $ LL, -1, 0, 0 ) 853 END IF 854* 855************************************************************************ 856* Frobenius norm 857* SSQ(1) is scale 858* SSQ(2) is sum-of-squares 859* 860 ELSE IF( LSAME( NORM, 'F' ) .OR. LSAME( NORM, 'E' ) ) THEN 861* 862 IF( UDIAG ) THEN 863 SSQ(1) = ONE 864 SSQ(2) = DBLE( MIN( M, N ) ) / DBLE( NPROW*NPCOL ) 865 ELSE 866 SSQ(1) = ZERO 867 SSQ(2) = ONE 868 END IF 869* 870 IF( LSAME( UPLO, 'U' ) ) THEN 871* 872* *********************** 873* Upper triangular matrix 874* 875 II = IIA 876 JJ = JJA 877 JN = MIN( ICEIL( JA, DESCA( NB_ ) ) * DESCA( NB_ ), JA+N-1 ) 878 JB = JN-JA+1 879* 880* First block column of sub-matrix. 881* 882 IF( MYCOL.EQ.IACOL ) THEN 883 IF( MYROW.EQ.IAROW ) THEN 884* This process has part of current block column, 885* including diagonal block. 886 IF( UDIAG ) THEN 887 DO 840 LL = JJ, JJ + JB -1 888 COLSSQ(1) = ZERO 889 COLSSQ(2) = ONE 890 CALL DLASSQ( MIN( II+LL-JJ-1, IIA+MP-1 )-IIA+1, 891 $ A( IIA+IOFFA ), 1, 892 $ COLSSQ(1), COLSSQ(2) ) 893 CALL DCOMBSSQ( SSQ, COLSSQ ) 894 IOFFA = IOFFA + LDA 895 840 CONTINUE 896 ELSE 897 DO 850 LL = JJ, JJ + JB -1 898 COLSSQ(1) = ZERO 899 COLSSQ(2) = ONE 900 CALL DLASSQ( MIN( II+LL-JJ, IIA+MP-1 )-IIA+1, 901 $ A( IIA+IOFFA ), 1, 902 $ COLSSQ(1), COLSSQ(2) ) 903 CALL DCOMBSSQ( SSQ, COLSSQ ) 904 IOFFA = IOFFA + LDA 905 850 CONTINUE 906 END IF 907 ELSE 908* This rank has part of current block column, 909* but not diagonal block. 910* It seems this lassq will be length 0, since ii = iia. 911 DO 860 LL = JJ, JJ + JB -1 912 COLSSQ(1) = ZERO 913 COLSSQ(2) = ONE 914 CALL DLASSQ( MIN( II-1, IIA+MP-1 )-IIA+1, 915 $ A( IIA+IOFFA ), 1, 916 $ COLSSQ(1), COLSSQ(2) ) 917 CALL DCOMBSSQ( SSQ, COLSSQ ) 918 IOFFA = IOFFA + LDA 919 860 CONTINUE 920 END IF 921 JJ = JJ + JB 922 END IF 923* 924* If this process has part of current block row, advance ii, 925* then advance iarow, iacol to next diagonal block. 926* 927 IF( MYROW.EQ.IAROW ) 928 $ II = II + JB 929 IAROW = MOD( IAROW+1, NPROW ) 930 IACOL = MOD( IACOL+1, NPCOL ) 931* 932* Loop over remaining block columns 933* 934 DO 900 J = JN+1, JA+N-1, DESCA( NB_ ) 935 JB = MIN( JA+N-J, DESCA( NB_ ) ) 936* 937 IF( MYCOL.EQ.IACOL ) THEN 938 IF( MYROW.EQ.IAROW ) THEN 939 IF( UDIAG ) THEN 940 DO 870 LL = JJ, JJ + JB -1 941 COLSSQ(1) = ZERO 942 COLSSQ(2) = ONE 943 CALL DLASSQ( MIN(II+LL-JJ-1, IIA+MP-1)-IIA+1, 944 $ A( IIA+IOFFA ), 1, 945 $ COLSSQ(1), COLSSQ(2) ) 946 CALL DCOMBSSQ( SSQ, COLSSQ ) 947 IOFFA = IOFFA + LDA 948 870 CONTINUE 949 ELSE 950 DO 880 LL = JJ, JJ + JB -1 951 COLSSQ(1) = ZERO 952 COLSSQ(2) = ONE 953 CALL DLASSQ( MIN( II+LL-JJ, IIA+MP-1 )-IIA+1, 954 $ A( IIA+IOFFA ), 1, 955 $ COLSSQ(1), COLSSQ(2) ) 956 CALL DCOMBSSQ( SSQ, COLSSQ ) 957 IOFFA = IOFFA + LDA 958 880 CONTINUE 959 END IF 960 ELSE 961 DO 890 LL = JJ, JJ + JB -1 962 COLSSQ(1) = ZERO 963 COLSSQ(2) = ONE 964 CALL DLASSQ( MIN( II-1, IIA+MP-1 )-IIA+1, 965 $ A( IIA+IOFFA ), 1, 966 $ COLSSQ(1), COLSSQ(2) ) 967 CALL DCOMBSSQ( SSQ, COLSSQ ) 968 IOFFA = IOFFA + LDA 969 890 CONTINUE 970 END IF 971 JJ = JJ + JB 972 END IF 973* 974 IF( MYROW.EQ.IAROW ) 975 $ II = II + JB 976 IAROW = MOD( IAROW+1, NPROW ) 977 IACOL = MOD( IACOL+1, NPCOL ) 978* 979 900 CONTINUE 980* 981 ELSE 982* 983* *********************** 984* Lower triangular matrix 985* 986 II = IIA 987 JJ = JJA 988 JN = MIN( ICEIL( JA, DESCA( NB_ ) ) * DESCA( NB_ ), JA+N-1 ) 989 JB = JN-JA+1 990* 991 IF( MYCOL.EQ.IACOL ) THEN 992 IF( MYROW.EQ.IAROW ) THEN 993 IF( UDIAG ) THEN 994 DO 910 LL = JJ, JJ + JB -1 995 COLSSQ(1) = ZERO 996 COLSSQ(2) = ONE 997 CALL DLASSQ( IIA+MP-(II+LL-JJ+1), 998 $ A( II+LL-JJ+1+IOFFA ), 1, 999 $ COLSSQ(1), COLSSQ(2) ) 1000 CALL DCOMBSSQ( SSQ, COLSSQ ) 1001 IOFFA = IOFFA + LDA 1002 910 CONTINUE 1003 ELSE 1004 DO 920 LL = JJ, JJ + JB -1 1005 COLSSQ(1) = ZERO 1006 COLSSQ(2) = ONE 1007 CALL DLASSQ( IIA+MP-(II+LL-JJ), 1008 $ A( II+LL-JJ+IOFFA ), 1, 1009 $ COLSSQ(1), COLSSQ(2) ) 1010 CALL DCOMBSSQ( SSQ, COLSSQ ) 1011 IOFFA = IOFFA + LDA 1012 920 CONTINUE 1013 END IF 1014 ELSE 1015 DO 930 LL = JJ, JJ + JB -1 1016 COLSSQ(1) = ZERO 1017 COLSSQ(2) = ONE 1018 CALL DLASSQ( IIA+MP-II, A( II+IOFFA ), 1, 1019 $ COLSSQ(1), COLSSQ(2) ) 1020 CALL DCOMBSSQ( SSQ, COLSSQ ) 1021 IOFFA = IOFFA + LDA 1022 930 CONTINUE 1023 END IF 1024 JJ = JJ + JB 1025 END IF 1026* 1027 IF( MYROW.EQ.IAROW ) 1028 $ II = II + JB 1029 IAROW = MOD( IAROW+1, NPROW ) 1030 IACOL = MOD( IACOL+1, NPCOL ) 1031* 1032* Loop over remaining block of columns 1033* 1034 DO 970 J = JN+1, JA+N-1, DESCA( NB_ ) 1035 JB = MIN( JA+N-J, DESCA( NB_ ) ) 1036* 1037 IF( MYCOL.EQ.IACOL ) THEN 1038 IF( MYROW.EQ.IAROW ) THEN 1039 IF( UDIAG ) THEN 1040 DO 940 LL = JJ, JJ + JB -1 1041 COLSSQ(1) = ZERO 1042 COLSSQ(2) = ONE 1043 CALL DLASSQ( IIA+MP-(II+LL-JJ+1), 1044 $ A( II+LL-JJ+1+IOFFA ), 1, 1045 $ COLSSQ(1), COLSSQ(2) ) 1046 CALL DCOMBSSQ( SSQ, COLSSQ ) 1047 IOFFA = IOFFA + LDA 1048 940 CONTINUE 1049 ELSE 1050 DO 950 LL = JJ, JJ + JB -1 1051 COLSSQ(1) = ZERO 1052 COLSSQ(2) = ONE 1053 CALL DLASSQ( IIA+MP-(II+LL-JJ), 1054 $ A( II+LL-JJ+IOFFA ), 1, 1055 $ COLSSQ(1), COLSSQ(2) ) 1056 CALL DCOMBSSQ( SSQ, COLSSQ ) 1057 IOFFA = IOFFA + LDA 1058 950 CONTINUE 1059 END IF 1060 ELSE 1061 DO 960 LL = JJ, JJ + JB -1 1062 COLSSQ(1) = ZERO 1063 COLSSQ(2) = ONE 1064 CALL DLASSQ( IIA+MP-II, A( II+IOFFA ), 1, 1065 $ COLSSQ(1), COLSSQ(2) ) 1066 CALL DCOMBSSQ( SSQ, COLSSQ ) 1067 IOFFA = IOFFA + LDA 1068 960 CONTINUE 1069 END IF 1070 JJ = JJ + JB 1071 END IF 1072* 1073 IF( MYROW.EQ.IAROW ) 1074 $ II = II + JB 1075 IAROW = MOD( IAROW+1, NPROW ) 1076 IACOL = MOD( IACOL+1, NPCOL ) 1077* 1078 970 CONTINUE 1079* 1080 END IF 1081* 1082* *********************** 1083* Perform the global scaled sum 1084* 1085 CALL PDTREECOMB( ICTXT, 'All', 2, SSQ, 0, 0, DCOMBSSQ ) 1086 VALUE = SSQ( 1 ) * SQRT( SSQ( 2 ) ) 1087* 1088 END IF 1089* 1090* Broadcast the result to every process in the grid. 1091* 1092 IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN 1093 CALL DGEBS2D( ICTXT, 'All', ' ', 1, 1, VALUE, 1 ) 1094 ELSE 1095 CALL DGEBR2D( ICTXT, 'All', ' ', 1, 1, VALUE, 1, 0, 0 ) 1096 END IF 1097* 1098 PDLANTR = VALUE 1099* 1100 RETURN 1101* 1102* End of PDLANTR 1103* 1104 END 1105