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