1*> \brief \b DLATTR 2* 3* =========== DOCUMENTATION =========== 4* 5* Online html documentation available at 6* http://www.netlib.org/lapack/explore-html/ 7* 8* Definition: 9* =========== 10* 11* SUBROUTINE DLATTR( IMAT, UPLO, TRANS, DIAG, ISEED, N, A, LDA, B, 12* WORK, INFO ) 13* 14* .. Scalar Arguments .. 15* CHARACTER DIAG, TRANS, UPLO 16* INTEGER IMAT, INFO, LDA, N 17* .. 18* .. Array Arguments .. 19* INTEGER ISEED( 4 ) 20* DOUBLE PRECISION A( LDA, * ), B( * ), WORK( * ) 21* .. 22* 23* 24*> \par Purpose: 25* ============= 26*> 27*> \verbatim 28*> 29*> DLATTR generates a triangular test matrix. 30*> IMAT and UPLO uniquely specify the properties of the test 31*> matrix, which is returned in the array A. 32*> \endverbatim 33* 34* Arguments: 35* ========== 36* 37*> \param[in] IMAT 38*> \verbatim 39*> IMAT is INTEGER 40*> An integer key describing which matrix to generate for this 41*> path. 42*> \endverbatim 43*> 44*> \param[in] UPLO 45*> \verbatim 46*> UPLO is CHARACTER*1 47*> Specifies whether the matrix A will be upper or lower 48*> triangular. 49*> = 'U': Upper triangular 50*> = 'L': Lower triangular 51*> \endverbatim 52*> 53*> \param[in] TRANS 54*> \verbatim 55*> TRANS is CHARACTER*1 56*> Specifies whether the matrix or its transpose will be used. 57*> = 'N': No transpose 58*> = 'T': Transpose 59*> = 'C': Conjugate transpose (= Transpose) 60*> \endverbatim 61*> 62*> \param[out] DIAG 63*> \verbatim 64*> DIAG is CHARACTER*1 65*> Specifies whether or not the matrix A is unit triangular. 66*> = 'N': Non-unit triangular 67*> = 'U': Unit triangular 68*> \endverbatim 69*> 70*> \param[in,out] ISEED 71*> \verbatim 72*> ISEED is INTEGER array, dimension (4) 73*> The seed vector for the random number generator (used in 74*> DLATMS). Modified on exit. 75*> \endverbatim 76*> 77*> \param[in] N 78*> \verbatim 79*> N is INTEGER 80*> The order of the matrix to be generated. 81*> \endverbatim 82*> 83*> \param[out] A 84*> \verbatim 85*> A is DOUBLE PRECISION array, dimension (LDA,N) 86*> The triangular matrix A. If UPLO = 'U', the leading n by n 87*> upper triangular part of the array A contains the upper 88*> triangular matrix, and the strictly lower triangular part of 89*> A is not referenced. If UPLO = 'L', the leading n by n lower 90*> triangular part of the array A contains the lower triangular 91*> matrix, and the strictly upper triangular part of A is not 92*> referenced. If DIAG = 'U', the diagonal elements of A are 93*> set so that A(k,k) = k for 1 <= k <= n. 94*> \endverbatim 95*> 96*> \param[in] LDA 97*> \verbatim 98*> LDA is INTEGER 99*> The leading dimension of the array A. LDA >= max(1,N). 100*> \endverbatim 101*> 102*> \param[out] B 103*> \verbatim 104*> B is DOUBLE PRECISION array, dimension (N) 105*> The right hand side vector, if IMAT > 10. 106*> \endverbatim 107*> 108*> \param[out] WORK 109*> \verbatim 110*> WORK is DOUBLE PRECISION array, dimension (3*N) 111*> \endverbatim 112*> 113*> \param[out] INFO 114*> \verbatim 115*> INFO is INTEGER 116*> = 0: successful exit 117*> < 0: if INFO = -k, the k-th argument had an illegal value 118*> \endverbatim 119* 120* Authors: 121* ======== 122* 123*> \author Univ. of Tennessee 124*> \author Univ. of California Berkeley 125*> \author Univ. of Colorado Denver 126*> \author NAG Ltd. 127* 128*> \ingroup double_lin 129* 130* ===================================================================== 131 SUBROUTINE DLATTR( IMAT, UPLO, TRANS, DIAG, ISEED, N, A, LDA, B, 132 $ WORK, INFO ) 133* 134* -- LAPACK test routine -- 135* -- LAPACK is a software package provided by Univ. of Tennessee, -- 136* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 137* 138* .. Scalar Arguments .. 139 CHARACTER DIAG, TRANS, UPLO 140 INTEGER IMAT, INFO, LDA, N 141* .. 142* .. Array Arguments .. 143 INTEGER ISEED( 4 ) 144 DOUBLE PRECISION A( LDA, * ), B( * ), WORK( * ) 145* .. 146* 147* ===================================================================== 148* 149* .. Parameters .. 150 DOUBLE PRECISION ONE, TWO, ZERO 151 PARAMETER ( ONE = 1.0D+0, TWO = 2.0D+0, ZERO = 0.0D+0 ) 152* .. 153* .. Local Scalars .. 154 LOGICAL UPPER 155 CHARACTER DIST, TYPE 156 CHARACTER*3 PATH 157 INTEGER I, IY, J, JCOUNT, KL, KU, MODE 158 DOUBLE PRECISION ANORM, BIGNUM, BNORM, BSCAL, C, CNDNUM, PLUS1, 159 $ PLUS2, RA, RB, REXP, S, SFAC, SMLNUM, STAR1, 160 $ TEXP, TLEFT, TSCAL, ULP, UNFL, X, Y, Z 161* .. 162* .. External Functions .. 163 LOGICAL LSAME 164 INTEGER IDAMAX 165 DOUBLE PRECISION DLAMCH, DLARND 166 EXTERNAL LSAME, IDAMAX, DLAMCH, DLARND 167* .. 168* .. External Subroutines .. 169 EXTERNAL DCOPY, DLABAD, DLARNV, DLATB4, DLATMS, DROT, 170 $ DROTG, DSCAL, DSWAP 171* .. 172* .. Intrinsic Functions .. 173 INTRINSIC ABS, DBLE, MAX, SIGN, SQRT 174* .. 175* .. Executable Statements .. 176* 177 PATH( 1: 1 ) = 'Double precision' 178 PATH( 2: 3 ) = 'TR' 179 UNFL = DLAMCH( 'Safe minimum' ) 180 ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' ) 181 SMLNUM = UNFL 182 BIGNUM = ( ONE-ULP ) / SMLNUM 183 CALL DLABAD( SMLNUM, BIGNUM ) 184 IF( ( IMAT.GE.7 .AND. IMAT.LE.10 ) .OR. IMAT.EQ.18 ) THEN 185 DIAG = 'U' 186 ELSE 187 DIAG = 'N' 188 END IF 189 INFO = 0 190* 191* Quick return if N.LE.0. 192* 193 IF( N.LE.0 ) 194 $ RETURN 195* 196* Call DLATB4 to set parameters for SLATMS. 197* 198 UPPER = LSAME( UPLO, 'U' ) 199 IF( UPPER ) THEN 200 CALL DLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE, 201 $ CNDNUM, DIST ) 202 ELSE 203 CALL DLATB4( PATH, -IMAT, N, N, TYPE, KL, KU, ANORM, MODE, 204 $ CNDNUM, DIST ) 205 END IF 206* 207* IMAT <= 6: Non-unit triangular matrix 208* 209 IF( IMAT.LE.6 ) THEN 210 CALL DLATMS( N, N, DIST, ISEED, TYPE, B, MODE, CNDNUM, ANORM, 211 $ KL, KU, 'No packing', A, LDA, WORK, INFO ) 212* 213* IMAT > 6: Unit triangular matrix 214* The diagonal is deliberately set to something other than 1. 215* 216* IMAT = 7: Matrix is the identity 217* 218 ELSE IF( IMAT.EQ.7 ) THEN 219 IF( UPPER ) THEN 220 DO 20 J = 1, N 221 DO 10 I = 1, J - 1 222 A( I, J ) = ZERO 223 10 CONTINUE 224 A( J, J ) = J 225 20 CONTINUE 226 ELSE 227 DO 40 J = 1, N 228 A( J, J ) = J 229 DO 30 I = J + 1, N 230 A( I, J ) = ZERO 231 30 CONTINUE 232 40 CONTINUE 233 END IF 234* 235* IMAT > 7: Non-trivial unit triangular matrix 236* 237* Generate a unit triangular matrix T with condition CNDNUM by 238* forming a triangular matrix with known singular values and 239* filling in the zero entries with Givens rotations. 240* 241 ELSE IF( IMAT.LE.10 ) THEN 242 IF( UPPER ) THEN 243 DO 60 J = 1, N 244 DO 50 I = 1, J - 1 245 A( I, J ) = ZERO 246 50 CONTINUE 247 A( J, J ) = J 248 60 CONTINUE 249 ELSE 250 DO 80 J = 1, N 251 A( J, J ) = J 252 DO 70 I = J + 1, N 253 A( I, J ) = ZERO 254 70 CONTINUE 255 80 CONTINUE 256 END IF 257* 258* Since the trace of a unit triangular matrix is 1, the product 259* of its singular values must be 1. Let s = sqrt(CNDNUM), 260* x = sqrt(s) - 1/sqrt(s), y = sqrt(2/(n-2))*x, and z = x**2. 261* The following triangular matrix has singular values s, 1, 1, 262* ..., 1, 1/s: 263* 264* 1 y y y ... y y z 265* 1 0 0 ... 0 0 y 266* 1 0 ... 0 0 y 267* . ... . . . 268* . . . . 269* 1 0 y 270* 1 y 271* 1 272* 273* To fill in the zeros, we first multiply by a matrix with small 274* condition number of the form 275* 276* 1 0 0 0 0 ... 277* 1 + * 0 0 ... 278* 1 + 0 0 0 279* 1 + * 0 0 280* 1 + 0 0 281* ... 282* 1 + 0 283* 1 0 284* 1 285* 286* Each element marked with a '*' is formed by taking the product 287* of the adjacent elements marked with '+'. The '*'s can be 288* chosen freely, and the '+'s are chosen so that the inverse of 289* T will have elements of the same magnitude as T. If the *'s in 290* both T and inv(T) have small magnitude, T is well conditioned. 291* The two offdiagonals of T are stored in WORK. 292* 293* The product of these two matrices has the form 294* 295* 1 y y y y y . y y z 296* 1 + * 0 0 . 0 0 y 297* 1 + 0 0 . 0 0 y 298* 1 + * . . . . 299* 1 + . . . . 300* . . . . . 301* . . . . 302* 1 + y 303* 1 y 304* 1 305* 306* Now we multiply by Givens rotations, using the fact that 307* 308* [ c s ] [ 1 w ] [ -c -s ] = [ 1 -w ] 309* [ -s c ] [ 0 1 ] [ s -c ] [ 0 1 ] 310* and 311* [ -c -s ] [ 1 0 ] [ c s ] = [ 1 0 ] 312* [ s -c ] [ w 1 ] [ -s c ] [ -w 1 ] 313* 314* where c = w / sqrt(w**2+4) and s = 2 / sqrt(w**2+4). 315* 316 STAR1 = 0.25D0 317 SFAC = 0.5D0 318 PLUS1 = SFAC 319 DO 90 J = 1, N, 2 320 PLUS2 = STAR1 / PLUS1 321 WORK( J ) = PLUS1 322 WORK( N+J ) = STAR1 323 IF( J+1.LE.N ) THEN 324 WORK( J+1 ) = PLUS2 325 WORK( N+J+1 ) = ZERO 326 PLUS1 = STAR1 / PLUS2 327 REXP = DLARND( 2, ISEED ) 328 STAR1 = STAR1*( SFAC**REXP ) 329 IF( REXP.LT.ZERO ) THEN 330 STAR1 = -SFAC**( ONE-REXP ) 331 ELSE 332 STAR1 = SFAC**( ONE+REXP ) 333 END IF 334 END IF 335 90 CONTINUE 336* 337 X = SQRT( CNDNUM ) - 1 / SQRT( CNDNUM ) 338 IF( N.GT.2 ) THEN 339 Y = SQRT( 2.D0 / ( N-2 ) )*X 340 ELSE 341 Y = ZERO 342 END IF 343 Z = X*X 344* 345 IF( UPPER ) THEN 346 IF( N.GT.3 ) THEN 347 CALL DCOPY( N-3, WORK, 1, A( 2, 3 ), LDA+1 ) 348 IF( N.GT.4 ) 349 $ CALL DCOPY( N-4, WORK( N+1 ), 1, A( 2, 4 ), LDA+1 ) 350 END IF 351 DO 100 J = 2, N - 1 352 A( 1, J ) = Y 353 A( J, N ) = Y 354 100 CONTINUE 355 A( 1, N ) = Z 356 ELSE 357 IF( N.GT.3 ) THEN 358 CALL DCOPY( N-3, WORK, 1, A( 3, 2 ), LDA+1 ) 359 IF( N.GT.4 ) 360 $ CALL DCOPY( N-4, WORK( N+1 ), 1, A( 4, 2 ), LDA+1 ) 361 END IF 362 DO 110 J = 2, N - 1 363 A( J, 1 ) = Y 364 A( N, J ) = Y 365 110 CONTINUE 366 A( N, 1 ) = Z 367 END IF 368* 369* Fill in the zeros using Givens rotations. 370* 371 IF( UPPER ) THEN 372 DO 120 J = 1, N - 1 373 RA = A( J, J+1 ) 374 RB = 2.0D0 375 CALL DROTG( RA, RB, C, S ) 376* 377* Multiply by [ c s; -s c] on the left. 378* 379 IF( N.GT.J+1 ) 380 $ CALL DROT( N-J-1, A( J, J+2 ), LDA, A( J+1, J+2 ), 381 $ LDA, C, S ) 382* 383* Multiply by [-c -s; s -c] on the right. 384* 385 IF( J.GT.1 ) 386 $ CALL DROT( J-1, A( 1, J+1 ), 1, A( 1, J ), 1, -C, -S ) 387* 388* Negate A(J,J+1). 389* 390 A( J, J+1 ) = -A( J, J+1 ) 391 120 CONTINUE 392 ELSE 393 DO 130 J = 1, N - 1 394 RA = A( J+1, J ) 395 RB = 2.0D0 396 CALL DROTG( RA, RB, C, S ) 397* 398* Multiply by [ c -s; s c] on the right. 399* 400 IF( N.GT.J+1 ) 401 $ CALL DROT( N-J-1, A( J+2, J+1 ), 1, A( J+2, J ), 1, C, 402 $ -S ) 403* 404* Multiply by [-c s; -s -c] on the left. 405* 406 IF( J.GT.1 ) 407 $ CALL DROT( J-1, A( J, 1 ), LDA, A( J+1, 1 ), LDA, -C, 408 $ S ) 409* 410* Negate A(J+1,J). 411* 412 A( J+1, J ) = -A( J+1, J ) 413 130 CONTINUE 414 END IF 415* 416* IMAT > 10: Pathological test cases. These triangular matrices 417* are badly scaled or badly conditioned, so when used in solving a 418* triangular system they may cause overflow in the solution vector. 419* 420 ELSE IF( IMAT.EQ.11 ) THEN 421* 422* Type 11: Generate a triangular matrix with elements between 423* -1 and 1. Give the diagonal norm 2 to make it well-conditioned. 424* Make the right hand side large so that it requires scaling. 425* 426 IF( UPPER ) THEN 427 DO 140 J = 1, N 428 CALL DLARNV( 2, ISEED, J, A( 1, J ) ) 429 A( J, J ) = SIGN( TWO, A( J, J ) ) 430 140 CONTINUE 431 ELSE 432 DO 150 J = 1, N 433 CALL DLARNV( 2, ISEED, N-J+1, A( J, J ) ) 434 A( J, J ) = SIGN( TWO, A( J, J ) ) 435 150 CONTINUE 436 END IF 437* 438* Set the right hand side so that the largest value is BIGNUM. 439* 440 CALL DLARNV( 2, ISEED, N, B ) 441 IY = IDAMAX( N, B, 1 ) 442 BNORM = ABS( B( IY ) ) 443 BSCAL = BIGNUM / MAX( ONE, BNORM ) 444 CALL DSCAL( N, BSCAL, B, 1 ) 445* 446 ELSE IF( IMAT.EQ.12 ) THEN 447* 448* Type 12: Make the first diagonal element in the solve small to 449* cause immediate overflow when dividing by T(j,j). 450* In type 12, the offdiagonal elements are small (CNORM(j) < 1). 451* 452 CALL DLARNV( 2, ISEED, N, B ) 453 TSCAL = ONE / MAX( ONE, DBLE( N-1 ) ) 454 IF( UPPER ) THEN 455 DO 160 J = 1, N 456 CALL DLARNV( 2, ISEED, J, A( 1, J ) ) 457 CALL DSCAL( J-1, TSCAL, A( 1, J ), 1 ) 458 A( J, J ) = SIGN( ONE, A( J, J ) ) 459 160 CONTINUE 460 A( N, N ) = SMLNUM*A( N, N ) 461 ELSE 462 DO 170 J = 1, N 463 CALL DLARNV( 2, ISEED, N-J+1, A( J, J ) ) 464 IF( N.GT.J ) 465 $ CALL DSCAL( N-J, TSCAL, A( J+1, J ), 1 ) 466 A( J, J ) = SIGN( ONE, A( J, J ) ) 467 170 CONTINUE 468 A( 1, 1 ) = SMLNUM*A( 1, 1 ) 469 END IF 470* 471 ELSE IF( IMAT.EQ.13 ) THEN 472* 473* Type 13: Make the first diagonal element in the solve small to 474* cause immediate overflow when dividing by T(j,j). 475* In type 13, the offdiagonal elements are O(1) (CNORM(j) > 1). 476* 477 CALL DLARNV( 2, ISEED, N, B ) 478 IF( UPPER ) THEN 479 DO 180 J = 1, N 480 CALL DLARNV( 2, ISEED, J, A( 1, J ) ) 481 A( J, J ) = SIGN( ONE, A( J, J ) ) 482 180 CONTINUE 483 A( N, N ) = SMLNUM*A( N, N ) 484 ELSE 485 DO 190 J = 1, N 486 CALL DLARNV( 2, ISEED, N-J+1, A( J, J ) ) 487 A( J, J ) = SIGN( ONE, A( J, J ) ) 488 190 CONTINUE 489 A( 1, 1 ) = SMLNUM*A( 1, 1 ) 490 END IF 491* 492 ELSE IF( IMAT.EQ.14 ) THEN 493* 494* Type 14: T is diagonal with small numbers on the diagonal to 495* make the growth factor underflow, but a small right hand side 496* chosen so that the solution does not overflow. 497* 498 IF( UPPER ) THEN 499 JCOUNT = 1 500 DO 210 J = N, 1, -1 501 DO 200 I = 1, J - 1 502 A( I, J ) = ZERO 503 200 CONTINUE 504 IF( JCOUNT.LE.2 ) THEN 505 A( J, J ) = SMLNUM 506 ELSE 507 A( J, J ) = ONE 508 END IF 509 JCOUNT = JCOUNT + 1 510 IF( JCOUNT.GT.4 ) 511 $ JCOUNT = 1 512 210 CONTINUE 513 ELSE 514 JCOUNT = 1 515 DO 230 J = 1, N 516 DO 220 I = J + 1, N 517 A( I, J ) = ZERO 518 220 CONTINUE 519 IF( JCOUNT.LE.2 ) THEN 520 A( J, J ) = SMLNUM 521 ELSE 522 A( J, J ) = ONE 523 END IF 524 JCOUNT = JCOUNT + 1 525 IF( JCOUNT.GT.4 ) 526 $ JCOUNT = 1 527 230 CONTINUE 528 END IF 529* 530* Set the right hand side alternately zero and small. 531* 532 IF( UPPER ) THEN 533 B( 1 ) = ZERO 534 DO 240 I = N, 2, -2 535 B( I ) = ZERO 536 B( I-1 ) = SMLNUM 537 240 CONTINUE 538 ELSE 539 B( N ) = ZERO 540 DO 250 I = 1, N - 1, 2 541 B( I ) = ZERO 542 B( I+1 ) = SMLNUM 543 250 CONTINUE 544 END IF 545* 546 ELSE IF( IMAT.EQ.15 ) THEN 547* 548* Type 15: Make the diagonal elements small to cause gradual 549* overflow when dividing by T(j,j). To control the amount of 550* scaling needed, the matrix is bidiagonal. 551* 552 TEXP = ONE / MAX( ONE, DBLE( N-1 ) ) 553 TSCAL = SMLNUM**TEXP 554 CALL DLARNV( 2, ISEED, N, B ) 555 IF( UPPER ) THEN 556 DO 270 J = 1, N 557 DO 260 I = 1, J - 2 558 A( I, J ) = 0.D0 559 260 CONTINUE 560 IF( J.GT.1 ) 561 $ A( J-1, J ) = -ONE 562 A( J, J ) = TSCAL 563 270 CONTINUE 564 B( N ) = ONE 565 ELSE 566 DO 290 J = 1, N 567 DO 280 I = J + 2, N 568 A( I, J ) = 0.D0 569 280 CONTINUE 570 IF( J.LT.N ) 571 $ A( J+1, J ) = -ONE 572 A( J, J ) = TSCAL 573 290 CONTINUE 574 B( 1 ) = ONE 575 END IF 576* 577 ELSE IF( IMAT.EQ.16 ) THEN 578* 579* Type 16: One zero diagonal element. 580* 581 IY = N / 2 + 1 582 IF( UPPER ) THEN 583 DO 300 J = 1, N 584 CALL DLARNV( 2, ISEED, J, A( 1, J ) ) 585 IF( J.NE.IY ) THEN 586 A( J, J ) = SIGN( TWO, A( J, J ) ) 587 ELSE 588 A( J, J ) = ZERO 589 END IF 590 300 CONTINUE 591 ELSE 592 DO 310 J = 1, N 593 CALL DLARNV( 2, ISEED, N-J+1, A( J, J ) ) 594 IF( J.NE.IY ) THEN 595 A( J, J ) = SIGN( TWO, A( J, J ) ) 596 ELSE 597 A( J, J ) = ZERO 598 END IF 599 310 CONTINUE 600 END IF 601 CALL DLARNV( 2, ISEED, N, B ) 602 CALL DSCAL( N, TWO, B, 1 ) 603* 604 ELSE IF( IMAT.EQ.17 ) THEN 605* 606* Type 17: Make the offdiagonal elements large to cause overflow 607* when adding a column of T. In the non-transposed case, the 608* matrix is constructed to cause overflow when adding a column in 609* every other step. 610* 611 TSCAL = UNFL / ULP 612 TSCAL = ( ONE-ULP ) / TSCAL 613 DO 330 J = 1, N 614 DO 320 I = 1, N 615 A( I, J ) = 0.D0 616 320 CONTINUE 617 330 CONTINUE 618 TEXP = ONE 619 IF( UPPER ) THEN 620 DO 340 J = N, 2, -2 621 A( 1, J ) = -TSCAL / DBLE( N+1 ) 622 A( J, J ) = ONE 623 B( J ) = TEXP*( ONE-ULP ) 624 A( 1, J-1 ) = -( TSCAL / DBLE( N+1 ) ) / DBLE( N+2 ) 625 A( J-1, J-1 ) = ONE 626 B( J-1 ) = TEXP*DBLE( N*N+N-1 ) 627 TEXP = TEXP*2.D0 628 340 CONTINUE 629 B( 1 ) = ( DBLE( N+1 ) / DBLE( N+2 ) )*TSCAL 630 ELSE 631 DO 350 J = 1, N - 1, 2 632 A( N, J ) = -TSCAL / DBLE( N+1 ) 633 A( J, J ) = ONE 634 B( J ) = TEXP*( ONE-ULP ) 635 A( N, J+1 ) = -( TSCAL / DBLE( N+1 ) ) / DBLE( N+2 ) 636 A( J+1, J+1 ) = ONE 637 B( J+1 ) = TEXP*DBLE( N*N+N-1 ) 638 TEXP = TEXP*2.D0 639 350 CONTINUE 640 B( N ) = ( DBLE( N+1 ) / DBLE( N+2 ) )*TSCAL 641 END IF 642* 643 ELSE IF( IMAT.EQ.18 ) THEN 644* 645* Type 18: Generate a unit triangular matrix with elements 646* between -1 and 1, and make the right hand side large so that it 647* requires scaling. 648* 649 IF( UPPER ) THEN 650 DO 360 J = 1, N 651 CALL DLARNV( 2, ISEED, J-1, A( 1, J ) ) 652 A( J, J ) = ZERO 653 360 CONTINUE 654 ELSE 655 DO 370 J = 1, N 656 IF( J.LT.N ) 657 $ CALL DLARNV( 2, ISEED, N-J, A( J+1, J ) ) 658 A( J, J ) = ZERO 659 370 CONTINUE 660 END IF 661* 662* Set the right hand side so that the largest value is BIGNUM. 663* 664 CALL DLARNV( 2, ISEED, N, B ) 665 IY = IDAMAX( N, B, 1 ) 666 BNORM = ABS( B( IY ) ) 667 BSCAL = BIGNUM / MAX( ONE, BNORM ) 668 CALL DSCAL( N, BSCAL, B, 1 ) 669* 670 ELSE IF( IMAT.EQ.19 ) THEN 671* 672* Type 19: Generate a triangular matrix with elements between 673* BIGNUM/(n-1) and BIGNUM so that at least one of the column 674* norms will exceed BIGNUM. 675* 1/3/91: DLATRS no longer can handle this case 676* 677 TLEFT = BIGNUM / MAX( ONE, DBLE( N-1 ) ) 678 TSCAL = BIGNUM*( DBLE( N-1 ) / MAX( ONE, DBLE( N ) ) ) 679 IF( UPPER ) THEN 680 DO 390 J = 1, N 681 CALL DLARNV( 2, ISEED, J, A( 1, J ) ) 682 DO 380 I = 1, J 683 A( I, J ) = SIGN( TLEFT, A( I, J ) ) + TSCAL*A( I, J ) 684 380 CONTINUE 685 390 CONTINUE 686 ELSE 687 DO 410 J = 1, N 688 CALL DLARNV( 2, ISEED, N-J+1, A( J, J ) ) 689 DO 400 I = J, N 690 A( I, J ) = SIGN( TLEFT, A( I, J ) ) + TSCAL*A( I, J ) 691 400 CONTINUE 692 410 CONTINUE 693 END IF 694 CALL DLARNV( 2, ISEED, N, B ) 695 CALL DSCAL( N, TWO, B, 1 ) 696 END IF 697* 698* Flip the matrix if the transpose will be used. 699* 700 IF( .NOT.LSAME( TRANS, 'N' ) ) THEN 701 IF( UPPER ) THEN 702 DO 420 J = 1, N / 2 703 CALL DSWAP( N-2*J+1, A( J, J ), LDA, A( J+1, N-J+1 ), 704 $ -1 ) 705 420 CONTINUE 706 ELSE 707 DO 430 J = 1, N / 2 708 CALL DSWAP( N-2*J+1, A( J, J ), 1, A( N-J+1, J+1 ), 709 $ -LDA ) 710 430 CONTINUE 711 END IF 712 END IF 713* 714 RETURN 715* 716* End of DLATTR 717* 718 END 719