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