 |
LAPACK 3.3.1
Linear Algebra PACKage
|
|
LAPACK 3.3.1
Linear Algebra PACKage
|
00001 SUBROUTINE DLATTR( IMAT, UPLO, TRANS, DIAG, ISEED, N, A, LDA, B, 00002 $ WORK, INFO ) 00003 * 00004 * -- LAPACK test routine (version 3.1) -- 00005 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. 00006 * November 2006 00007 * 00008 * .. Scalar Arguments .. 00009 CHARACTER DIAG, TRANS, UPLO 00010 INTEGER IMAT, INFO, LDA, N 00011 * .. 00012 * .. Array Arguments .. 00013 INTEGER ISEED( 4 ) 00014 DOUBLE PRECISION A( LDA, * ), B( * ), WORK( * ) 00015 * .. 00016 * 00017 * Purpose 00018 * ======= 00019 * 00020 * DLATTR generates a triangular test matrix. 00021 * IMAT and UPLO uniquely specify the properties of the test 00022 * matrix, which is returned in the array A. 00023 * 00024 * Arguments 00025 * ========= 00026 * 00027 * IMAT (input) INTEGER 00028 * An integer key describing which matrix to generate for this 00029 * path. 00030 * 00031 * UPLO (input) CHARACTER*1 00032 * Specifies whether the matrix A will be upper or lower 00033 * triangular. 00034 * = 'U': Upper triangular 00035 * = 'L': Lower triangular 00036 * 00037 * TRANS (input) CHARACTER*1 00038 * Specifies whether the matrix or its transpose will be used. 00039 * = 'N': No transpose 00040 * = 'T': Transpose 00041 * = 'C': Conjugate transpose (= Transpose) 00042 * 00043 * DIAG (output) CHARACTER*1 00044 * Specifies whether or not the matrix A is unit triangular. 00045 * = 'N': Non-unit triangular 00046 * = 'U': Unit triangular 00047 * 00048 * ISEED (input/output) INTEGER array, dimension (4) 00049 * The seed vector for the random number generator (used in 00050 * DLATMS). Modified on exit. 00051 * 00052 * N (input) INTEGER 00053 * The order of the matrix to be generated. 00054 * 00055 * A (output) DOUBLE PRECISION array, dimension (LDA,N) 00056 * The triangular matrix A. If UPLO = 'U', the leading n by n 00057 * upper triangular part of the array A contains the upper 00058 * triangular matrix, and the strictly lower triangular part of 00059 * A is not referenced. If UPLO = 'L', the leading n by n lower 00060 * triangular part of the array A contains the lower triangular 00061 * matrix, and the strictly upper triangular part of A is not 00062 * referenced. If DIAG = 'U', the diagonal elements of A are 00063 * set so that A(k,k) = k for 1 <= k <= n. 00064 * 00065 * LDA (input) INTEGER 00066 * The leading dimension of the array A. LDA >= max(1,N). 00067 * 00068 * B (output) DOUBLE PRECISION array, dimension (N) 00069 * The right hand side vector, if IMAT > 10. 00070 * 00071 * WORK (workspace) DOUBLE PRECISION array, dimension (3*N) 00072 * 00073 * INFO (output) INTEGER 00074 * = 0: successful exit 00075 * < 0: if INFO = -k, the k-th argument had an illegal value 00076 * 00077 * ===================================================================== 00078 * 00079 * .. Parameters .. 00080 DOUBLE PRECISION ONE, TWO, ZERO 00081 PARAMETER ( ONE = 1.0D+0, TWO = 2.0D+0, ZERO = 0.0D+0 ) 00082 * .. 00083 * .. Local Scalars .. 00084 LOGICAL UPPER 00085 CHARACTER DIST, TYPE 00086 CHARACTER*3 PATH 00087 INTEGER I, IY, J, JCOUNT, KL, KU, MODE 00088 DOUBLE PRECISION ANORM, BIGNUM, BNORM, BSCAL, C, CNDNUM, PLUS1, 00089 $ PLUS2, RA, RB, REXP, S, SFAC, SMLNUM, STAR1, 00090 $ TEXP, TLEFT, TSCAL, ULP, UNFL, X, Y, Z 00091 * .. 00092 * .. External Functions .. 00093 LOGICAL LSAME 00094 INTEGER IDAMAX 00095 DOUBLE PRECISION DLAMCH, DLARND 00096 EXTERNAL LSAME, IDAMAX, DLAMCH, DLARND 00097 * .. 00098 * .. External Subroutines .. 00099 EXTERNAL DCOPY, DLABAD, DLARNV, DLATB4, DLATMS, DROT, 00100 $ DROTG, DSCAL, DSWAP 00101 * .. 00102 * .. Intrinsic Functions .. 00103 INTRINSIC ABS, DBLE, MAX, SIGN, SQRT 00104 * .. 00105 * .. Executable Statements .. 00106 * 00107 PATH( 1: 1 ) = 'Double precision' 00108 PATH( 2: 3 ) = 'TR' 00109 UNFL = DLAMCH( 'Safe minimum' ) 00110 ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' ) 00111 SMLNUM = UNFL 00112 BIGNUM = ( ONE-ULP ) / SMLNUM 00113 CALL DLABAD( SMLNUM, BIGNUM ) 00114 IF( ( IMAT.GE.7 .AND. IMAT.LE.10 ) .OR. IMAT.EQ.18 ) THEN 00115 DIAG = 'U' 00116 ELSE 00117 DIAG = 'N' 00118 END IF 00119 INFO = 0 00120 * 00121 * Quick return if N.LE.0. 00122 * 00123 IF( N.LE.0 ) 00124 $ RETURN 00125 * 00126 * Call DLATB4 to set parameters for SLATMS. 00127 * 00128 UPPER = LSAME( UPLO, 'U' ) 00129 IF( UPPER ) THEN 00130 CALL DLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE, 00131 $ CNDNUM, DIST ) 00132 ELSE 00133 CALL DLATB4( PATH, -IMAT, N, N, TYPE, KL, KU, ANORM, MODE, 00134 $ CNDNUM, DIST ) 00135 END IF 00136 * 00137 * IMAT <= 6: Non-unit triangular matrix 00138 * 00139 IF( IMAT.LE.6 ) THEN 00140 CALL DLATMS( N, N, DIST, ISEED, TYPE, B, MODE, CNDNUM, ANORM, 00141 $ KL, KU, 'No packing', A, LDA, WORK, INFO ) 00142 * 00143 * IMAT > 6: Unit triangular matrix 00144 * The diagonal is deliberately set to something other than 1. 00145 * 00146 * IMAT = 7: Matrix is the identity 00147 * 00148 ELSE IF( IMAT.EQ.7 ) THEN 00149 IF( UPPER ) THEN 00150 DO 20 J = 1, N 00151 DO 10 I = 1, J - 1 00152 A( I, J ) = ZERO 00153 10 CONTINUE 00154 A( J, J ) = J 00155 20 CONTINUE 00156 ELSE 00157 DO 40 J = 1, N 00158 A( J, J ) = J 00159 DO 30 I = J + 1, N 00160 A( I, J ) = ZERO 00161 30 CONTINUE 00162 40 CONTINUE 00163 END IF 00164 * 00165 * IMAT > 7: Non-trivial unit triangular matrix 00166 * 00167 * Generate a unit triangular matrix T with condition CNDNUM by 00168 * forming a triangular matrix with known singular values and 00169 * filling in the zero entries with Givens rotations. 00170 * 00171 ELSE IF( IMAT.LE.10 ) THEN 00172 IF( UPPER ) THEN 00173 DO 60 J = 1, N 00174 DO 50 I = 1, J - 1 00175 A( I, J ) = ZERO 00176 50 CONTINUE 00177 A( J, J ) = J 00178 60 CONTINUE 00179 ELSE 00180 DO 80 J = 1, N 00181 A( J, J ) = J 00182 DO 70 I = J + 1, N 00183 A( I, J ) = ZERO 00184 70 CONTINUE 00185 80 CONTINUE 00186 END IF 00187 * 00188 * Since the trace of a unit triangular matrix is 1, the product 00189 * of its singular values must be 1. Let s = sqrt(CNDNUM), 00190 * x = sqrt(s) - 1/sqrt(s), y = sqrt(2/(n-2))*x, and z = x**2. 00191 * The following triangular matrix has singular values s, 1, 1, 00192 * ..., 1, 1/s: 00193 * 00194 * 1 y y y ... y y z 00195 * 1 0 0 ... 0 0 y 00196 * 1 0 ... 0 0 y 00197 * . ... . . . 00198 * . . . . 00199 * 1 0 y 00200 * 1 y 00201 * 1 00202 * 00203 * To fill in the zeros, we first multiply by a matrix with small 00204 * condition number of the form 00205 * 00206 * 1 0 0 0 0 ... 00207 * 1 + * 0 0 ... 00208 * 1 + 0 0 0 00209 * 1 + * 0 0 00210 * 1 + 0 0 00211 * ... 00212 * 1 + 0 00213 * 1 0 00214 * 1 00215 * 00216 * Each element marked with a '*' is formed by taking the product 00217 * of the adjacent elements marked with '+'. The '*'s can be 00218 * chosen freely, and the '+'s are chosen so that the inverse of 00219 * T will have elements of the same magnitude as T. If the *'s in 00220 * both T and inv(T) have small magnitude, T is well conditioned. 00221 * The two offdiagonals of T are stored in WORK. 00222 * 00223 * The product of these two matrices has the form 00224 * 00225 * 1 y y y y y . y y z 00226 * 1 + * 0 0 . 0 0 y 00227 * 1 + 0 0 . 0 0 y 00228 * 1 + * . . . . 00229 * 1 + . . . . 00230 * . . . . . 00231 * . . . . 00232 * 1 + y 00233 * 1 y 00234 * 1 00235 * 00236 * Now we multiply by Givens rotations, using the fact that 00237 * 00238 * [ c s ] [ 1 w ] [ -c -s ] = [ 1 -w ] 00239 * [ -s c ] [ 0 1 ] [ s -c ] [ 0 1 ] 00240 * and 00241 * [ -c -s ] [ 1 0 ] [ c s ] = [ 1 0 ] 00242 * [ s -c ] [ w 1 ] [ -s c ] [ -w 1 ] 00243 * 00244 * where c = w / sqrt(w**2+4) and s = 2 / sqrt(w**2+4). 00245 * 00246 STAR1 = 0.25D0 00247 SFAC = 0.5D0 00248 PLUS1 = SFAC 00249 DO 90 J = 1, N, 2 00250 PLUS2 = STAR1 / PLUS1 00251 WORK( J ) = PLUS1 00252 WORK( N+J ) = STAR1 00253 IF( J+1.LE.N ) THEN 00254 WORK( J+1 ) = PLUS2 00255 WORK( N+J+1 ) = ZERO 00256 PLUS1 = STAR1 / PLUS2 00257 REXP = DLARND( 2, ISEED ) 00258 STAR1 = STAR1*( SFAC**REXP ) 00259 IF( REXP.LT.ZERO ) THEN 00260 STAR1 = -SFAC**( ONE-REXP ) 00261 ELSE 00262 STAR1 = SFAC**( ONE+REXP ) 00263 END IF 00264 END IF 00265 90 CONTINUE 00266 * 00267 X = SQRT( CNDNUM ) - 1 / SQRT( CNDNUM ) 00268 IF( N.GT.2 ) THEN 00269 Y = SQRT( 2.D0 / ( N-2 ) )*X 00270 ELSE 00271 Y = ZERO 00272 END IF 00273 Z = X*X 00274 * 00275 IF( UPPER ) THEN 00276 IF( N.GT.3 ) THEN 00277 CALL DCOPY( N-3, WORK, 1, A( 2, 3 ), LDA+1 ) 00278 IF( N.GT.4 ) 00279 $ CALL DCOPY( N-4, WORK( N+1 ), 1, A( 2, 4 ), LDA+1 ) 00280 END IF 00281 DO 100 J = 2, N - 1 00282 A( 1, J ) = Y 00283 A( J, N ) = Y 00284 100 CONTINUE 00285 A( 1, N ) = Z 00286 ELSE 00287 IF( N.GT.3 ) THEN 00288 CALL DCOPY( N-3, WORK, 1, A( 3, 2 ), LDA+1 ) 00289 IF( N.GT.4 ) 00290 $ CALL DCOPY( N-4, WORK( N+1 ), 1, A( 4, 2 ), LDA+1 ) 00291 END IF 00292 DO 110 J = 2, N - 1 00293 A( J, 1 ) = Y 00294 A( N, J ) = Y 00295 110 CONTINUE 00296 A( N, 1 ) = Z 00297 END IF 00298 * 00299 * Fill in the zeros using Givens rotations. 00300 * 00301 IF( UPPER ) THEN 00302 DO 120 J = 1, N - 1 00303 RA = A( J, J+1 ) 00304 RB = 2.0D0 00305 CALL DROTG( RA, RB, C, S ) 00306 * 00307 * Multiply by [ c s; -s c] on the left. 00308 * 00309 IF( N.GT.J+1 ) 00310 $ CALL DROT( N-J-1, A( J, J+2 ), LDA, A( J+1, J+2 ), 00311 $ LDA, C, S ) 00312 * 00313 * Multiply by [-c -s; s -c] on the right. 00314 * 00315 IF( J.GT.1 ) 00316 $ CALL DROT( J-1, A( 1, J+1 ), 1, A( 1, J ), 1, -C, -S ) 00317 * 00318 * Negate A(J,J+1). 00319 * 00320 A( J, J+1 ) = -A( J, J+1 ) 00321 120 CONTINUE 00322 ELSE 00323 DO 130 J = 1, N - 1 00324 RA = A( J+1, J ) 00325 RB = 2.0D0 00326 CALL DROTG( RA, RB, C, S ) 00327 * 00328 * Multiply by [ c -s; s c] on the right. 00329 * 00330 IF( N.GT.J+1 ) 00331 $ CALL DROT( N-J-1, A( J+2, J+1 ), 1, A( J+2, J ), 1, C, 00332 $ -S ) 00333 * 00334 * Multiply by [-c s; -s -c] on the left. 00335 * 00336 IF( J.GT.1 ) 00337 $ CALL DROT( J-1, A( J, 1 ), LDA, A( J+1, 1 ), LDA, -C, 00338 $ S ) 00339 * 00340 * Negate A(J+1,J). 00341 * 00342 A( J+1, J ) = -A( J+1, J ) 00343 130 CONTINUE 00344 END IF 00345 * 00346 * IMAT > 10: Pathological test cases. These triangular matrices 00347 * are badly scaled or badly conditioned, so when used in solving a 00348 * triangular system they may cause overflow in the solution vector. 00349 * 00350 ELSE IF( IMAT.EQ.11 ) THEN 00351 * 00352 * Type 11: Generate a triangular matrix with elements between 00353 * -1 and 1. Give the diagonal norm 2 to make it well-conditioned. 00354 * Make the right hand side large so that it requires scaling. 00355 * 00356 IF( UPPER ) THEN 00357 DO 140 J = 1, N 00358 CALL DLARNV( 2, ISEED, J, A( 1, J ) ) 00359 A( J, J ) = SIGN( TWO, A( J, J ) ) 00360 140 CONTINUE 00361 ELSE 00362 DO 150 J = 1, N 00363 CALL DLARNV( 2, ISEED, N-J+1, A( J, J ) ) 00364 A( J, J ) = SIGN( TWO, A( J, J ) ) 00365 150 CONTINUE 00366 END IF 00367 * 00368 * Set the right hand side so that the largest value is BIGNUM. 00369 * 00370 CALL DLARNV( 2, ISEED, N, B ) 00371 IY = IDAMAX( N, B, 1 ) 00372 BNORM = ABS( B( IY ) ) 00373 BSCAL = BIGNUM / MAX( ONE, BNORM ) 00374 CALL DSCAL( N, BSCAL, B, 1 ) 00375 * 00376 ELSE IF( IMAT.EQ.12 ) THEN 00377 * 00378 * Type 12: Make the first diagonal element in the solve small to 00379 * cause immediate overflow when dividing by T(j,j). 00380 * In type 12, the offdiagonal elements are small (CNORM(j) < 1). 00381 * 00382 CALL DLARNV( 2, ISEED, N, B ) 00383 TSCAL = ONE / MAX( ONE, DBLE( N-1 ) ) 00384 IF( UPPER ) THEN 00385 DO 160 J = 1, N 00386 CALL DLARNV( 2, ISEED, J, A( 1, J ) ) 00387 CALL DSCAL( J-1, TSCAL, A( 1, J ), 1 ) 00388 A( J, J ) = SIGN( ONE, A( J, J ) ) 00389 160 CONTINUE 00390 A( N, N ) = SMLNUM*A( N, N ) 00391 ELSE 00392 DO 170 J = 1, N 00393 CALL DLARNV( 2, ISEED, N-J+1, A( J, J ) ) 00394 IF( N.GT.J ) 00395 $ CALL DSCAL( N-J, TSCAL, A( J+1, J ), 1 ) 00396 A( J, J ) = SIGN( ONE, A( J, J ) ) 00397 170 CONTINUE 00398 A( 1, 1 ) = SMLNUM*A( 1, 1 ) 00399 END IF 00400 * 00401 ELSE IF( IMAT.EQ.13 ) THEN 00402 * 00403 * Type 13: Make the first diagonal element in the solve small to 00404 * cause immediate overflow when dividing by T(j,j). 00405 * In type 13, the offdiagonal elements are O(1) (CNORM(j) > 1). 00406 * 00407 CALL DLARNV( 2, ISEED, N, B ) 00408 IF( UPPER ) THEN 00409 DO 180 J = 1, N 00410 CALL DLARNV( 2, ISEED, J, A( 1, J ) ) 00411 A( J, J ) = SIGN( ONE, A( J, J ) ) 00412 180 CONTINUE 00413 A( N, N ) = SMLNUM*A( N, N ) 00414 ELSE 00415 DO 190 J = 1, N 00416 CALL DLARNV( 2, ISEED, N-J+1, A( J, J ) ) 00417 A( J, J ) = SIGN( ONE, A( J, J ) ) 00418 190 CONTINUE 00419 A( 1, 1 ) = SMLNUM*A( 1, 1 ) 00420 END IF 00421 * 00422 ELSE IF( IMAT.EQ.14 ) THEN 00423 * 00424 * Type 14: T is diagonal with small numbers on the diagonal to 00425 * make the growth factor underflow, but a small right hand side 00426 * chosen so that the solution does not overflow. 00427 * 00428 IF( UPPER ) THEN 00429 JCOUNT = 1 00430 DO 210 J = N, 1, -1 00431 DO 200 I = 1, J - 1 00432 A( I, J ) = ZERO 00433 200 CONTINUE 00434 IF( JCOUNT.LE.2 ) THEN 00435 A( J, J ) = SMLNUM 00436 ELSE 00437 A( J, J ) = ONE 00438 END IF 00439 JCOUNT = JCOUNT + 1 00440 IF( JCOUNT.GT.4 ) 00441 $ JCOUNT = 1 00442 210 CONTINUE 00443 ELSE 00444 JCOUNT = 1 00445 DO 230 J = 1, N 00446 DO 220 I = J + 1, N 00447 A( I, J ) = ZERO 00448 220 CONTINUE 00449 IF( JCOUNT.LE.2 ) THEN 00450 A( J, J ) = SMLNUM 00451 ELSE 00452 A( J, J ) = ONE 00453 END IF 00454 JCOUNT = JCOUNT + 1 00455 IF( JCOUNT.GT.4 ) 00456 $ JCOUNT = 1 00457 230 CONTINUE 00458 END IF 00459 * 00460 * Set the right hand side alternately zero and small. 00461 * 00462 IF( UPPER ) THEN 00463 B( 1 ) = ZERO 00464 DO 240 I = N, 2, -2 00465 B( I ) = ZERO 00466 B( I-1 ) = SMLNUM 00467 240 CONTINUE 00468 ELSE 00469 B( N ) = ZERO 00470 DO 250 I = 1, N - 1, 2 00471 B( I ) = ZERO 00472 B( I+1 ) = SMLNUM 00473 250 CONTINUE 00474 END IF 00475 * 00476 ELSE IF( IMAT.EQ.15 ) THEN 00477 * 00478 * Type 15: Make the diagonal elements small to cause gradual 00479 * overflow when dividing by T(j,j). To control the amount of 00480 * scaling needed, the matrix is bidiagonal. 00481 * 00482 TEXP = ONE / MAX( ONE, DBLE( N-1 ) ) 00483 TSCAL = SMLNUM**TEXP 00484 CALL DLARNV( 2, ISEED, N, B ) 00485 IF( UPPER ) THEN 00486 DO 270 J = 1, N 00487 DO 260 I = 1, J - 2 00488 A( I, J ) = 0.D0 00489 260 CONTINUE 00490 IF( J.GT.1 ) 00491 $ A( J-1, J ) = -ONE 00492 A( J, J ) = TSCAL 00493 270 CONTINUE 00494 B( N ) = ONE 00495 ELSE 00496 DO 290 J = 1, N 00497 DO 280 I = J + 2, N 00498 A( I, J ) = 0.D0 00499 280 CONTINUE 00500 IF( J.LT.N ) 00501 $ A( J+1, J ) = -ONE 00502 A( J, J ) = TSCAL 00503 290 CONTINUE 00504 B( 1 ) = ONE 00505 END IF 00506 * 00507 ELSE IF( IMAT.EQ.16 ) THEN 00508 * 00509 * Type 16: One zero diagonal element. 00510 * 00511 IY = N / 2 + 1 00512 IF( UPPER ) THEN 00513 DO 300 J = 1, N 00514 CALL DLARNV( 2, ISEED, J, A( 1, J ) ) 00515 IF( J.NE.IY ) THEN 00516 A( J, J ) = SIGN( TWO, A( J, J ) ) 00517 ELSE 00518 A( J, J ) = ZERO 00519 END IF 00520 300 CONTINUE 00521 ELSE 00522 DO 310 J = 1, N 00523 CALL DLARNV( 2, ISEED, N-J+1, A( J, J ) ) 00524 IF( J.NE.IY ) THEN 00525 A( J, J ) = SIGN( TWO, A( J, J ) ) 00526 ELSE 00527 A( J, J ) = ZERO 00528 END IF 00529 310 CONTINUE 00530 END IF 00531 CALL DLARNV( 2, ISEED, N, B ) 00532 CALL DSCAL( N, TWO, B, 1 ) 00533 * 00534 ELSE IF( IMAT.EQ.17 ) THEN 00535 * 00536 * Type 17: Make the offdiagonal elements large to cause overflow 00537 * when adding a column of T. In the non-transposed case, the 00538 * matrix is constructed to cause overflow when adding a column in 00539 * every other step. 00540 * 00541 TSCAL = UNFL / ULP 00542 TSCAL = ( ONE-ULP ) / TSCAL 00543 DO 330 J = 1, N 00544 DO 320 I = 1, N 00545 A( I, J ) = 0.D0 00546 320 CONTINUE 00547 330 CONTINUE 00548 TEXP = ONE 00549 IF( UPPER ) THEN 00550 DO 340 J = N, 2, -2 00551 A( 1, J ) = -TSCAL / DBLE( N+1 ) 00552 A( J, J ) = ONE 00553 B( J ) = TEXP*( ONE-ULP ) 00554 A( 1, J-1 ) = -( TSCAL / DBLE( N+1 ) ) / DBLE( N+2 ) 00555 A( J-1, J-1 ) = ONE 00556 B( J-1 ) = TEXP*DBLE( N*N+N-1 ) 00557 TEXP = TEXP*2.D0 00558 340 CONTINUE 00559 B( 1 ) = ( DBLE( N+1 ) / DBLE( N+2 ) )*TSCAL 00560 ELSE 00561 DO 350 J = 1, N - 1, 2 00562 A( N, J ) = -TSCAL / DBLE( N+1 ) 00563 A( J, J ) = ONE 00564 B( J ) = TEXP*( ONE-ULP ) 00565 A( N, J+1 ) = -( TSCAL / DBLE( N+1 ) ) / DBLE( N+2 ) 00566 A( J+1, J+1 ) = ONE 00567 B( J+1 ) = TEXP*DBLE( N*N+N-1 ) 00568 TEXP = TEXP*2.D0 00569 350 CONTINUE 00570 B( N ) = ( DBLE( N+1 ) / DBLE( N+2 ) )*TSCAL 00571 END IF 00572 * 00573 ELSE IF( IMAT.EQ.18 ) THEN 00574 * 00575 * Type 18: Generate a unit triangular matrix with elements 00576 * between -1 and 1, and make the right hand side large so that it 00577 * requires scaling. 00578 * 00579 IF( UPPER ) THEN 00580 DO 360 J = 1, N 00581 CALL DLARNV( 2, ISEED, J-1, A( 1, J ) ) 00582 A( J, J ) = ZERO 00583 360 CONTINUE 00584 ELSE 00585 DO 370 J = 1, N 00586 IF( J.LT.N ) 00587 $ CALL DLARNV( 2, ISEED, N-J, A( J+1, J ) ) 00588 A( J, J ) = ZERO 00589 370 CONTINUE 00590 END IF 00591 * 00592 * Set the right hand side so that the largest value is BIGNUM. 00593 * 00594 CALL DLARNV( 2, ISEED, N, B ) 00595 IY = IDAMAX( N, B, 1 ) 00596 BNORM = ABS( B( IY ) ) 00597 BSCAL = BIGNUM / MAX( ONE, BNORM ) 00598 CALL DSCAL( N, BSCAL, B, 1 ) 00599 * 00600 ELSE IF( IMAT.EQ.19 ) THEN 00601 * 00602 * Type 19: Generate a triangular matrix with elements between 00603 * BIGNUM/(n-1) and BIGNUM so that at least one of the column 00604 * norms will exceed BIGNUM. 00605 * 1/3/91: DLATRS no longer can handle this case 00606 * 00607 TLEFT = BIGNUM / MAX( ONE, DBLE( N-1 ) ) 00608 TSCAL = BIGNUM*( DBLE( N-1 ) / MAX( ONE, DBLE( N ) ) ) 00609 IF( UPPER ) THEN 00610 DO 390 J = 1, N 00611 CALL DLARNV( 2, ISEED, J, A( 1, J ) ) 00612 DO 380 I = 1, J 00613 A( I, J ) = SIGN( TLEFT, A( I, J ) ) + TSCAL*A( I, J ) 00614 380 CONTINUE 00615 390 CONTINUE 00616 ELSE 00617 DO 410 J = 1, N 00618 CALL DLARNV( 2, ISEED, N-J+1, A( J, J ) ) 00619 DO 400 I = J, N 00620 A( I, J ) = SIGN( TLEFT, A( I, J ) ) + TSCAL*A( I, J ) 00621 400 CONTINUE 00622 410 CONTINUE 00623 END IF 00624 CALL DLARNV( 2, ISEED, N, B ) 00625 CALL DSCAL( N, TWO, B, 1 ) 00626 END IF 00627 * 00628 * Flip the matrix if the transpose will be used. 00629 * 00630 IF( .NOT.LSAME( TRANS, 'N' ) ) THEN 00631 IF( UPPER ) THEN 00632 DO 420 J = 1, N / 2 00633 CALL DSWAP( N-2*J+1, A( J, J ), LDA, A( J+1, N-J+1 ), 00634 $ -1 ) 00635 420 CONTINUE 00636 ELSE 00637 DO 430 J = 1, N / 2 00638 CALL DSWAP( N-2*J+1, A( J, J ), 1, A( N-J+1, J+1 ), 00639 $ -LDA ) 00640 430 CONTINUE 00641 END IF 00642 END IF 00643 * 00644 RETURN 00645 * 00646 * End of DLATTR 00647 * 00648 END
1.7.3 
