1 SUBROUTINE PZLASCL( TYPE, CFROM, CTO, M, N, A, IA, JA, DESCA, 2 $ INFO ) 3* 4* -- ScaLAPACK auxiliary 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 CHARACTER TYPE 11 INTEGER IA, INFO, JA, M, N 12 DOUBLE PRECISION CFROM, CTO 13* .. 14* .. Array Arguments .. 15 INTEGER DESCA( * ) 16 COMPLEX*16 A( * ) 17* .. 18* 19* Purpose 20* ======= 21* 22* PZLASCL multiplies the M-by-N complex distributed matrix sub( A ) 23* denoting A(IA:IA+M-1,JA:JA+N-1) by the real scalar CTO/CFROM. This 24* is done without over/underflow as long as the final result 25* CTO * A(I,J) / CFROM does not over/underflow. TYPE specifies that 26* sub( A ) may be full, upper triangular, lower triangular or upper 27* Hessenberg. 28* 29* Notes 30* ===== 31* 32* Each global data object is described by an associated description 33* vector. This vector stores the information required to establish 34* the mapping between an object element and its corresponding process 35* and memory location. 36* 37* Let A be a generic term for any 2D block cyclicly distributed array. 38* Such a global array has an associated description vector DESCA. 39* In the following comments, the character _ should be read as 40* "of the global array". 41* 42* NOTATION STORED IN EXPLANATION 43* --------------- -------------- -------------------------------------- 44* DTYPE_A(global) DESCA( DTYPE_ )The descriptor type. In this case, 45* DTYPE_A = 1. 46* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating 47* the BLACS process grid A is distribu- 48* ted over. The context itself is glo- 49* bal, but the handle (the integer 50* value) may vary. 51* M_A (global) DESCA( M_ ) The number of rows in the global 52* array A. 53* N_A (global) DESCA( N_ ) The number of columns in the global 54* array A. 55* MB_A (global) DESCA( MB_ ) The blocking factor used to distribute 56* the rows of the array. 57* NB_A (global) DESCA( NB_ ) The blocking factor used to distribute 58* the columns of the array. 59* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first 60* row of the array A is distributed. 61* CSRC_A (global) DESCA( CSRC_ ) The process column over which the 62* first column of the array A is 63* distributed. 64* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local 65* array. LLD_A >= MAX(1,LOCr(M_A)). 66* 67* Let K be the number of rows or columns of a distributed matrix, 68* and assume that its process grid has dimension p x q. 69* LOCr( K ) denotes the number of elements of K that a process 70* would receive if K were distributed over the p processes of its 71* process column. 72* Similarly, LOCc( K ) denotes the number of elements of K that a 73* process would receive if K were distributed over the q processes of 74* its process row. 75* The values of LOCr() and LOCc() may be determined via a call to the 76* ScaLAPACK tool function, NUMROC: 77* LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ), 78* LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ). 79* An upper bound for these quantities may be computed by: 80* LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A 81* LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A 82* 83* Arguments 84* ========= 85* 86* TYPE (global input) CHARACTER 87* TYPE indices the storage type of the input distributed 88* matrix. 89* = 'G': sub( A ) is a full matrix, 90* = 'L': sub( A ) is a lower triangular matrix, 91* = 'U': sub( A ) is an upper triangular matrix, 92* = 'H': sub( A ) is an upper Hessenberg matrix. 93* 94* CFROM (global input) DOUBLE PRECISION 95* CTO (global input) DOUBLE PRECISION 96* The distributed matrix sub( A ) is multiplied by CTO/CFROM. 97* A(I,J) is computed without over/underflow if the final 98* result CTO * A(I,J) / CFROM can be represented without 99* over/underflow. CFROM must be nonzero. 100* 101* M (global input) INTEGER 102* The number of rows to be operated on i.e the number of rows 103* of the distributed submatrix sub( A ). M >= 0. 104* 105* N (global input) INTEGER 106* The number of columns to be operated on i.e the number of 107* columns of the distributed submatrix sub( A ). N >= 0. 108* 109* A (local input/local output) COMPLEX*16 pointer into the 110* local memory to an array of dimension (LLD_A,LOCc(JA+N-1)). 111* This array contains the local pieces of the distributed 112* matrix sub( A ). On exit, this array contains the local 113* pieces of the distributed matrix multiplied by CTO/CFROM. 114* 115* IA (global input) INTEGER 116* The row index in the global array A indicating the first 117* row of sub( A ). 118* 119* JA (global input) INTEGER 120* The column index in the global array A indicating the 121* first column of sub( A ). 122* 123* DESCA (global and local input) INTEGER array of dimension DLEN_. 124* The array descriptor for the distributed matrix A. 125* 126* INFO (local output) INTEGER 127* = 0: successful exit 128* < 0: If the i-th argument is an array and the j-entry had 129* an illegal value, then INFO = -(i*100+j), if the i-th 130* argument is a scalar and had an illegal value, then 131* INFO = -i. 132* 133* ===================================================================== 134* 135* .. Parameters .. 136 INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_, 137 $ LLD_, MB_, M_, NB_, N_, RSRC_ 138 PARAMETER ( BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DTYPE_ = 1, 139 $ CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6, 140 $ RSRC_ = 7, CSRC_ = 8, LLD_ = 9 ) 141 DOUBLE PRECISION ONE, ZERO 142 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) 143* .. 144* .. Local Scalars .. 145 LOGICAL DONE 146 INTEGER IACOL, IAROW, ICOFFA, ICTXT, ICURCOL, ICURROW, 147 $ IIA, II, INXTROW, IOFFA, IROFFA, ITYPE, J, JB, 148 $ JJA, JJ, JN, KK, LDA, LL, MYCOL, MYROW, MP, 149 $ NPCOL, NPROW, NQ 150 DOUBLE PRECISION BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM 151* .. 152* .. External Subroutines .. 153 EXTERNAL BLACS_GRIDINFO, CHK1MAT, INFOG2L, PXERBLA 154* .. 155* .. External Functions .. 156 LOGICAL LSAME, DISNAN 157 INTEGER ICEIL, NUMROC 158 DOUBLE PRECISION PDLAMCH 159 EXTERNAL DISNAN, ICEIL, LSAME, NUMROC, PDLAMCH 160* .. 161* .. Intrinsic Functions .. 162 INTRINSIC ABS, MIN, MOD 163* .. 164* .. Executable Statements .. 165* 166* Get grid parameters 167* 168 ICTXT = DESCA( CTXT_ ) 169 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) 170* 171* Test the input parameters 172* 173 IF( NPROW.EQ.-1 ) THEN 174 INFO = -907 175 ELSE 176 INFO = 0 177 CALL CHK1MAT( M, 4, N, 6, IA, JA, DESCA, 9, INFO ) 178 IF( INFO.EQ.0 ) THEN 179 IF( LSAME( TYPE, 'G' ) ) THEN 180 ITYPE = 0 181 ELSE IF( LSAME( TYPE, 'L' ) ) THEN 182 ITYPE = 1 183 ELSE IF( LSAME( TYPE, 'U' ) ) THEN 184 ITYPE = 2 185 ELSE IF( LSAME( TYPE, 'H' ) ) THEN 186 ITYPE = 3 187 ELSE 188 ITYPE = -1 189 END IF 190 IF( ITYPE.EQ.-1 ) THEN 191 INFO = -1 192 ELSE IF( CFROM.EQ.ZERO .OR. DISNAN(CFROM) ) THEN 193 INFO = -4 194 ELSE IF( DISNAN(CTO) ) THEN 195 INFO = -5 196 END IF 197 END IF 198 END IF 199* 200 IF( INFO.NE.0 ) THEN 201 CALL PXERBLA( ICTXT, 'PZLASCL', -INFO ) 202 RETURN 203 END IF 204* 205* Quick return if possible 206* 207 IF( N.EQ.0 .OR. M.EQ.0 ) 208 $ RETURN 209* 210* Get machine parameters 211* 212 SMLNUM = PDLAMCH( ICTXT, 'S' ) 213 BIGNUM = ONE / SMLNUM 214* 215 CFROMC = CFROM 216 CTOC = CTO 217* 218* Compute local indexes 219* 220 LDA = DESCA( LLD_ ) 221 IROFFA = MOD( IA-1, DESCA( MB_ ) ) 222 ICOFFA = MOD( JA-1, DESCA( NB_ ) ) 223 JN = MIN( ICEIL( JA, DESCA( NB_ ) ) * DESCA( NB_ ), JA+N-1 ) 224 CALL INFOG2L( IA, JA, DESCA, NPROW, NPCOL, MYROW, MYCOL, IIA, JJA, 225 $ IAROW, IACOL ) 226 MP = NUMROC( M+IROFFA, DESCA( MB_ ), MYROW, IAROW, NPROW ) 227 IF( MYROW.EQ.IAROW ) 228 $ MP = MP - IROFFA 229 NQ = NUMROC( N+ICOFFA, DESCA( NB_ ), MYCOL, IACOL, NPCOL ) 230 IF( MYCOL.EQ.IACOL ) 231 $ NQ = NQ - ICOFFA 232* 233 10 CONTINUE 234 CFROM1 = CFROMC*SMLNUM 235 IF( CFROM1.EQ.CFROMC ) THEN 236! CFROMC is an inf. Multiply by a correctly signed zero for 237! finite CTOC, or a NaN if CTOC is infinite. 238 MUL = CTOC / CFROMC 239 DONE = .TRUE. 240 CTO1 = CTOC 241 ELSE 242 CTO1 = CTOC / BIGNUM 243 IF( CTO1.EQ.CTOC ) THEN 244! CTOC is either 0 or an inf. In both cases, CTOC itself 245! serves as the correct multiplication factor. 246 MUL = CTOC 247 DONE = .TRUE. 248 CFROMC = ONE 249 ELSE IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN 250 MUL = SMLNUM 251 DONE = .FALSE. 252 CFROMC = CFROM1 253 ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN 254 MUL = BIGNUM 255 DONE = .FALSE. 256 CTOC = CTO1 257 ELSE 258 MUL = CTOC / CFROMC 259 DONE = .TRUE. 260 END IF 261 END IF 262* 263 IOFFA = ( JJA - 1 ) * LDA 264 ICURROW = IAROW 265 ICURCOL = IACOL 266* 267 IF( ITYPE.EQ.0 ) THEN 268* 269* Full matrix 270* 271 DO 30 JJ = JJA, JJA+NQ-1 272 DO 20 II = IIA, IIA+MP-1 273 A( IOFFA+II ) = A( IOFFA+II ) * MUL 274 20 CONTINUE 275 IOFFA = IOFFA + LDA 276 30 CONTINUE 277* 278 ELSE IF( ITYPE.EQ.1 ) THEN 279* 280* Lower triangular matrix 281* 282 II = IIA 283 JJ = JJA 284 JB = JN-JA+1 285* 286 IF( MYCOL.EQ.ICURCOL ) THEN 287 IF( MYROW.EQ.ICURROW ) THEN 288 DO 50 LL = JJ, JJ + JB -1 289 DO 40 KK = II+LL-JJ, IIA+MP-1 290 A( IOFFA+KK ) = A( IOFFA+KK ) * MUL 291 40 CONTINUE 292 IOFFA = IOFFA + LDA 293 50 CONTINUE 294 ELSE 295 DO 70 LL = JJ, JJ + JB -1 296 DO 60 KK = II, IIA+MP-1 297 A( IOFFA+KK ) = A( IOFFA+KK ) * MUL 298 60 CONTINUE 299 IOFFA = IOFFA + LDA 300 70 CONTINUE 301 END IF 302 JJ = JJ + JB 303 END IF 304* 305 IF( MYROW.EQ.ICURROW ) 306 $ II = II + JB 307 ICURROW = MOD( ICURROW+1, NPROW ) 308 ICURCOL = MOD( ICURCOL+1, NPCOL ) 309* 310* Loop over remaining block of columns 311* 312 DO 120 J = JN+1, JA+N-1, DESCA( NB_ ) 313 JB = MIN( JA+N-J, DESCA( NB_ ) ) 314* 315 IF( MYCOL.EQ.ICURCOL ) THEN 316 IF( MYROW.EQ.ICURROW ) THEN 317 DO 90 LL = JJ, JJ + JB -1 318 DO 80 KK = II+LL-JJ, IIA+MP-1 319 A( IOFFA+KK ) = A( IOFFA+KK ) * MUL 320 80 CONTINUE 321 IOFFA = IOFFA + LDA 322 90 CONTINUE 323 ELSE 324 DO 110 LL = JJ, JJ + JB -1 325 DO 100 KK = II, IIA+MP-1 326 A( IOFFA+KK ) = A( IOFFA+KK ) * MUL 327 100 CONTINUE 328 IOFFA = IOFFA + LDA 329 110 CONTINUE 330 END IF 331 JJ = JJ + JB 332 END IF 333* 334 IF( MYROW.EQ.ICURROW ) 335 $ II = II + JB 336 ICURROW = MOD( ICURROW+1, NPROW ) 337 ICURCOL = MOD( ICURCOL+1, NPCOL ) 338* 339 120 CONTINUE 340* 341 ELSE IF( ITYPE.EQ.2 ) THEN 342* 343* Upper triangular matrix 344* 345 II = IIA 346 JJ = JJA 347 JB = JN-JA+1 348* 349 IF( MYCOL.EQ.ICURCOL ) THEN 350 IF( MYROW.EQ.ICURROW ) THEN 351 DO 140 LL = JJ, JJ + JB -1 352 DO 130 KK = IIA, MIN(II+LL-JJ,IIA+MP-1) 353 A( IOFFA+KK ) = A( IOFFA+KK ) * MUL 354 130 CONTINUE 355 IOFFA = IOFFA + LDA 356 140 CONTINUE 357 ELSE 358 DO 160 LL = JJ, JJ + JB -1 359 DO 150 KK = IIA, MIN(II-1,IIA+MP-1) 360 A( IOFFA+KK ) = A( IOFFA+KK ) * MUL 361 150 CONTINUE 362 IOFFA = IOFFA + LDA 363 160 CONTINUE 364 END IF 365 JJ = JJ + JB 366 END IF 367* 368 IF( MYROW.EQ.ICURROW ) 369 $ II = II + JB 370 ICURROW = MOD( ICURROW+1, NPROW ) 371 ICURCOL = MOD( ICURCOL+1, NPCOL ) 372* 373* Loop over remaining block of columns 374* 375 DO 210 J = JN+1, JA+N-1, DESCA( NB_ ) 376 JB = MIN( JA+N-J, DESCA( NB_ ) ) 377* 378 IF( MYCOL.EQ.ICURCOL ) THEN 379 IF( MYROW.EQ.ICURROW ) THEN 380 DO 180 LL = JJ, JJ + JB -1 381 DO 170 KK = IIA, MIN(II+LL-JJ,IIA+MP-1) 382 A( IOFFA+KK ) = A( IOFFA+KK )*MUL 383 170 CONTINUE 384 IOFFA = IOFFA + LDA 385 180 CONTINUE 386 ELSE 387 DO 200 LL = JJ, JJ + JB -1 388 DO 190 KK = IIA, MIN(II-1,IIA+MP-1) 389 A( IOFFA+KK ) = A( IOFFA+KK ) * MUL 390 190 CONTINUE 391 IOFFA = IOFFA + LDA 392 200 CONTINUE 393 END IF 394 JJ = JJ + JB 395 END IF 396* 397 IF( MYROW.EQ.ICURROW ) 398 $ II = II + JB 399 ICURROW = MOD( ICURROW+1, NPROW ) 400 ICURCOL = MOD( ICURCOL+1, NPCOL ) 401* 402 210 CONTINUE 403* 404 ELSE IF( ITYPE.EQ.3 ) THEN 405* 406* Upper Hessenberg matrix 407* 408 II = IIA 409 JJ = JJA 410 JB = JN-JA+1 411* 412* Only one process row 413* 414 IF( NPROW.EQ.1 ) THEN 415* 416* Handle first block of columns separately 417* 418 IF( MYCOL.EQ.ICURCOL ) THEN 419 DO 230 LL = JJ, JJ+JB-1 420 DO 220 KK = IIA, MIN( II+LL-JJ+1, IIA+MP-1 ) 421 A( IOFFA+KK ) = A( IOFFA+KK )*MUL 422 220 CONTINUE 423 IOFFA = IOFFA + LDA 424 230 CONTINUE 425 JJ = JJ + JB 426 END IF 427* 428 ICURCOL = MOD( ICURCOL+1, NPCOL ) 429* 430* Loop over remaining block of columns 431* 432 DO 260 J = JN+1, JA+N-1, DESCA( NB_ ) 433 JB = MIN( JA+N-J, DESCA( NB_ ) ) 434* 435 IF( MYCOL.EQ.ICURCOL ) THEN 436 DO 250 LL = JJ, JJ+JB-1 437 DO 240 KK = IIA, MIN( II+LL-JJ+1, IIA+MP-1 ) 438 A( IOFFA+KK ) = A( IOFFA+KK )*MUL 439 240 CONTINUE 440 IOFFA = IOFFA + LDA 441 250 CONTINUE 442 JJ = JJ + JB 443 END IF 444* 445 II = II + JB 446 ICURCOL = MOD( ICURCOL+1, NPCOL ) 447* 448 260 CONTINUE 449* 450 ELSE 451* 452* Handle first block of columns separately 453* 454 INXTROW = MOD( ICURROW+1, NPROW ) 455 IF( MYCOL.EQ.ICURCOL ) THEN 456 IF( MYROW.EQ.ICURROW ) THEN 457 DO 280 LL = JJ, JJ + JB -1 458 DO 270 KK = IIA, MIN(II+LL-JJ+1,IIA+MP-1) 459 A( IOFFA+KK ) = A( IOFFA+KK ) * MUL 460 270 CONTINUE 461 IOFFA = IOFFA + LDA 462 280 CONTINUE 463 ELSE 464 DO 300 LL = JJ, JJ + JB -1 465 DO 290 KK = IIA, MIN(II-1,IIA+MP-1) 466 A( IOFFA+KK ) = A( IOFFA+KK ) * MUL 467 290 CONTINUE 468 IOFFA = IOFFA + LDA 469 300 CONTINUE 470 IF( MYROW.EQ.INXTROW .AND. II.LE.IIA+MP-1 ) 471 $ A( II+(JJ+JB-2)*LDA ) = A( II+(JJ+JB-2)*LDA ) * MUL 472 END IF 473 JJ = JJ + JB 474 END IF 475* 476 IF( MYROW.EQ.ICURROW ) 477 $ II = II + JB 478 ICURROW = INXTROW 479 ICURROW = MOD( ICURROW+1, NPROW ) 480 ICURCOL = MOD( ICURCOL+1, NPCOL ) 481* 482* Loop over remaining block of columns 483* 484 DO 350 J = JN+1, JA+N-1, DESCA( NB_ ) 485 JB = MIN( JA+N-J, DESCA( NB_ ) ) 486* 487 IF( MYCOL.EQ.ICURCOL ) THEN 488 IF( MYROW.EQ.ICURROW ) THEN 489 DO 320 LL = JJ, JJ + JB -1 490 DO 310 KK = IIA, MIN( II+LL-JJ+1, IIA+MP-1 ) 491 A( IOFFA+KK ) = A( IOFFA+KK ) * MUL 492 310 CONTINUE 493 IOFFA = IOFFA + LDA 494 320 CONTINUE 495 ELSE 496 DO 340 LL = JJ, JJ + JB -1 497 DO 330 KK = IIA, MIN( II-1, IIA+MP-1 ) 498 A( IOFFA+KK ) = A( IOFFA+KK ) * MUL 499 330 CONTINUE 500 IOFFA = IOFFA + LDA 501 340 CONTINUE 502 IF( MYROW.EQ.INXTROW .AND. II.LE.IIA+MP-1 ) 503 $ A( II+(JJ+JB-2)*LDA ) = A( II+(JJ+JB-2)*LDA ) * 504 $ MUL 505 END IF 506 JJ = JJ + JB 507 END IF 508* 509 IF( MYROW.EQ.ICURROW ) 510 $ II = II + JB 511 ICURROW = INXTROW 512 ICURROW = MOD( ICURROW+1, NPROW ) 513 ICURCOL = MOD( ICURCOL+1, NPCOL ) 514* 515 350 CONTINUE 516* 517 END IF 518* 519 END IF 520* 521 IF( .NOT.DONE ) 522 $ GO TO 10 523* 524 RETURN 525* 526* End of PZLASCL 527* 528 END 529