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