![]() |
LAPACK
3.4.1
LAPACK: Linear Algebra PACKage
|
00001 *> \brief \b ZLATTP 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 ZLATTP( IMAT, UPLO, TRANS, DIAG, ISEED, N, AP, B, WORK, 00012 * RWORK, INFO ) 00013 * 00014 * .. Scalar Arguments .. 00015 * CHARACTER DIAG, TRANS, UPLO 00016 * INTEGER IMAT, INFO, N 00017 * .. 00018 * .. Array Arguments .. 00019 * INTEGER ISEED( 4 ) 00020 * DOUBLE PRECISION RWORK( * ) 00021 * COMPLEX*16 AP( * ), B( * ), WORK( * ) 00022 * .. 00023 * 00024 * 00025 *> \par Purpose: 00026 * ============= 00027 *> 00028 *> \verbatim 00029 *> 00030 *> ZLATTP generates a triangular test matrix in packed storage. 00031 *> IMAT and UPLO uniquely specify the properties of the test matrix, 00032 *> which is returned in the array AP. 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 *> ZLATMS). 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] AP 00085 *> \verbatim 00086 *> AP is COMPLEX*16 array, dimension (N*(N+1)/2) 00087 *> The upper or lower triangular matrix A, packed columnwise in 00088 *> a linear array. The j-th column of A is stored in the array 00089 *> AP as follows: 00090 *> if UPLO = 'U', AP((j-1)*j/2 + i) = A(i,j) for 1<=i<=j; 00091 *> if UPLO = 'L', 00092 *> AP((j-1)*(n-j) + j*(j+1)/2 + i-j) = A(i,j) for j<=i<=n. 00093 *> \endverbatim 00094 *> 00095 *> \param[out] B 00096 *> \verbatim 00097 *> B is COMPLEX*16 array, dimension (N) 00098 *> The right hand side vector, if IMAT > 10. 00099 *> \endverbatim 00100 *> 00101 *> \param[out] WORK 00102 *> \verbatim 00103 *> WORK is COMPLEX*16 array, dimension (2*N) 00104 *> \endverbatim 00105 *> 00106 *> \param[out] RWORK 00107 *> \verbatim 00108 *> RWORK is DOUBLE PRECISION array, dimension (N) 00109 *> \endverbatim 00110 *> 00111 *> \param[out] INFO 00112 *> \verbatim 00113 *> INFO is INTEGER 00114 *> = 0: successful exit 00115 *> < 0: if INFO = -i, the i-th argument had an illegal value 00116 *> \endverbatim 00117 * 00118 * Authors: 00119 * ======== 00120 * 00121 *> \author Univ. of Tennessee 00122 *> \author Univ. of California Berkeley 00123 *> \author Univ. of Colorado Denver 00124 *> \author NAG Ltd. 00125 * 00126 *> \date November 2011 00127 * 00128 *> \ingroup complex16_lin 00129 * 00130 * ===================================================================== 00131 SUBROUTINE ZLATTP( IMAT, UPLO, TRANS, DIAG, ISEED, N, AP, B, WORK, 00132 $ RWORK, INFO ) 00133 * 00134 * -- LAPACK test routine (version 3.4.0) -- 00135 * -- LAPACK is a software package provided by Univ. of Tennessee, -- 00136 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00137 * November 2011 00138 * 00139 * .. Scalar Arguments .. 00140 CHARACTER DIAG, TRANS, UPLO 00141 INTEGER IMAT, INFO, N 00142 * .. 00143 * .. Array Arguments .. 00144 INTEGER ISEED( 4 ) 00145 DOUBLE PRECISION RWORK( * ) 00146 COMPLEX*16 AP( * ), B( * ), WORK( * ) 00147 * .. 00148 * 00149 * ===================================================================== 00150 * 00151 * .. Parameters .. 00152 DOUBLE PRECISION ONE, TWO, ZERO 00153 PARAMETER ( ONE = 1.0D+0, TWO = 2.0D+0, ZERO = 0.0D+0 ) 00154 * .. 00155 * .. Local Scalars .. 00156 LOGICAL UPPER 00157 CHARACTER DIST, PACKIT, TYPE 00158 CHARACTER*3 PATH 00159 INTEGER I, IY, J, JC, JCNEXT, JCOUNT, JJ, JL, JR, JX, 00160 $ KL, KU, MODE 00161 DOUBLE PRECISION ANORM, BIGNUM, BNORM, BSCAL, C, CNDNUM, REXP, 00162 $ SFAC, SMLNUM, T, TEXP, TLEFT, TSCAL, ULP, UNFL, 00163 $ X, Y, Z 00164 COMPLEX*16 CTEMP, PLUS1, PLUS2, RA, RB, S, STAR1 00165 * .. 00166 * .. External Functions .. 00167 LOGICAL LSAME 00168 INTEGER IZAMAX 00169 DOUBLE PRECISION DLAMCH 00170 COMPLEX*16 ZLARND 00171 EXTERNAL LSAME, IZAMAX, DLAMCH, ZLARND 00172 * .. 00173 * .. External Subroutines .. 00174 EXTERNAL DLABAD, DLARNV, ZDSCAL, ZLARNV, ZLATB4, ZLATMS, 00175 $ ZROT, ZROTG 00176 * .. 00177 * .. Intrinsic Functions .. 00178 INTRINSIC ABS, DBLE, DCMPLX, DCONJG, MAX, SQRT 00179 * .. 00180 * .. Executable Statements .. 00181 * 00182 PATH( 1: 1 ) = 'Zomplex precision' 00183 PATH( 2: 3 ) = 'TP' 00184 UNFL = DLAMCH( 'Safe minimum' ) 00185 ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' ) 00186 SMLNUM = UNFL 00187 BIGNUM = ( ONE-ULP ) / SMLNUM 00188 CALL DLABAD( SMLNUM, BIGNUM ) 00189 IF( ( IMAT.GE.7 .AND. IMAT.LE.10 ) .OR. IMAT.EQ.18 ) THEN 00190 DIAG = 'U' 00191 ELSE 00192 DIAG = 'N' 00193 END IF 00194 INFO = 0 00195 * 00196 * Quick return if N.LE.0. 00197 * 00198 IF( N.LE.0 ) 00199 $ RETURN 00200 * 00201 * Call ZLATB4 to set parameters for CLATMS. 00202 * 00203 UPPER = LSAME( UPLO, 'U' ) 00204 IF( UPPER ) THEN 00205 CALL ZLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE, 00206 $ CNDNUM, DIST ) 00207 PACKIT = 'C' 00208 ELSE 00209 CALL ZLATB4( PATH, -IMAT, N, N, TYPE, KL, KU, ANORM, MODE, 00210 $ CNDNUM, DIST ) 00211 PACKIT = 'R' 00212 END IF 00213 * 00214 * IMAT <= 6: Non-unit triangular matrix 00215 * 00216 IF( IMAT.LE.6 ) THEN 00217 CALL ZLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, CNDNUM, 00218 $ ANORM, KL, KU, PACKIT, AP, N, WORK, INFO ) 00219 * 00220 * IMAT > 6: Unit triangular matrix 00221 * The diagonal is deliberately set to something other than 1. 00222 * 00223 * IMAT = 7: Matrix is the identity 00224 * 00225 ELSE IF( IMAT.EQ.7 ) THEN 00226 IF( UPPER ) THEN 00227 JC = 1 00228 DO 20 J = 1, N 00229 DO 10 I = 1, J - 1 00230 AP( JC+I-1 ) = ZERO 00231 10 CONTINUE 00232 AP( JC+J-1 ) = J 00233 JC = JC + J 00234 20 CONTINUE 00235 ELSE 00236 JC = 1 00237 DO 40 J = 1, N 00238 AP( JC ) = J 00239 DO 30 I = J + 1, N 00240 AP( JC+I-J ) = ZERO 00241 30 CONTINUE 00242 JC = JC + N - J + 1 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 JC = 0 00255 DO 60 J = 1, N 00256 DO 50 I = 1, J - 1 00257 AP( JC+I ) = ZERO 00258 50 CONTINUE 00259 AP( JC+J ) = J 00260 JC = JC + J 00261 60 CONTINUE 00262 ELSE 00263 JC = 1 00264 DO 80 J = 1, N 00265 AP( JC ) = J 00266 DO 70 I = J + 1, N 00267 AP( JC+I-J ) = ZERO 00268 70 CONTINUE 00269 JC = JC + N - J + 1 00270 80 CONTINUE 00271 END IF 00272 * 00273 * Since the trace of a unit triangular matrix is 1, the product 00274 * of its singular values must be 1. Let s = sqrt(CNDNUM), 00275 * x = sqrt(s) - 1/sqrt(s), y = sqrt(2/(n-2))*x, and z = x**2. 00276 * The following triangular matrix has singular values s, 1, 1, 00277 * ..., 1, 1/s: 00278 * 00279 * 1 y y y ... y y z 00280 * 1 0 0 ... 0 0 y 00281 * 1 0 ... 0 0 y 00282 * . ... . . . 00283 * . . . . 00284 * 1 0 y 00285 * 1 y 00286 * 1 00287 * 00288 * To fill in the zeros, we first multiply by a matrix with small 00289 * condition number of the form 00290 * 00291 * 1 0 0 0 0 ... 00292 * 1 + * 0 0 ... 00293 * 1 + 0 0 0 00294 * 1 + * 0 0 00295 * 1 + 0 0 00296 * ... 00297 * 1 + 0 00298 * 1 0 00299 * 1 00300 * 00301 * Each element marked with a '*' is formed by taking the product 00302 * of the adjacent elements marked with '+'. The '*'s can be 00303 * chosen freely, and the '+'s are chosen so that the inverse of 00304 * T will have elements of the same magnitude as T. If the *'s in 00305 * both T and inv(T) have small magnitude, T is well conditioned. 00306 * The two offdiagonals of T are stored in WORK. 00307 * 00308 * The product of these two matrices has the form 00309 * 00310 * 1 y y y y y . y y z 00311 * 1 + * 0 0 . 0 0 y 00312 * 1 + 0 0 . 0 0 y 00313 * 1 + * . . . . 00314 * 1 + . . . . 00315 * . . . . . 00316 * . . . . 00317 * 1 + y 00318 * 1 y 00319 * 1 00320 * 00321 * Now we multiply by Givens rotations, using the fact that 00322 * 00323 * [ c s ] [ 1 w ] [ -c -s ] = [ 1 -w ] 00324 * [ -s c ] [ 0 1 ] [ s -c ] [ 0 1 ] 00325 * and 00326 * [ -c -s ] [ 1 0 ] [ c s ] = [ 1 0 ] 00327 * [ s -c ] [ w 1 ] [ -s c ] [ -w 1 ] 00328 * 00329 * where c = w / sqrt(w**2+4) and s = 2 / sqrt(w**2+4). 00330 * 00331 STAR1 = 0.25D0*ZLARND( 5, ISEED ) 00332 SFAC = 0.5D0 00333 PLUS1 = SFAC*ZLARND( 5, ISEED ) 00334 DO 90 J = 1, N, 2 00335 PLUS2 = STAR1 / PLUS1 00336 WORK( J ) = PLUS1 00337 WORK( N+J ) = STAR1 00338 IF( J+1.LE.N ) THEN 00339 WORK( J+1 ) = PLUS2 00340 WORK( N+J+1 ) = ZERO 00341 PLUS1 = STAR1 / PLUS2 00342 REXP = ZLARND( 2, ISEED ) 00343 IF( REXP.LT.ZERO ) THEN 00344 STAR1 = -SFAC**( ONE-REXP )*ZLARND( 5, ISEED ) 00345 ELSE 00346 STAR1 = SFAC**( ONE+REXP )*ZLARND( 5, ISEED ) 00347 END IF 00348 END IF 00349 90 CONTINUE 00350 * 00351 X = SQRT( CNDNUM ) - ONE / SQRT( CNDNUM ) 00352 IF( N.GT.2 ) THEN 00353 Y = SQRT( TWO / DBLE( N-2 ) )*X 00354 ELSE 00355 Y = ZERO 00356 END IF 00357 Z = X*X 00358 * 00359 IF( UPPER ) THEN 00360 * 00361 * Set the upper triangle of A with a unit triangular matrix 00362 * of known condition number. 00363 * 00364 JC = 1 00365 DO 100 J = 2, N 00366 AP( JC+1 ) = Y 00367 IF( J.GT.2 ) 00368 $ AP( JC+J-1 ) = WORK( J-2 ) 00369 IF( J.GT.3 ) 00370 $ AP( JC+J-2 ) = WORK( N+J-3 ) 00371 JC = JC + J 00372 100 CONTINUE 00373 JC = JC - N 00374 AP( JC+1 ) = Z 00375 DO 110 J = 2, N - 1 00376 AP( JC+J ) = Y 00377 110 CONTINUE 00378 ELSE 00379 * 00380 * Set the lower triangle of A with a unit triangular matrix 00381 * of known condition number. 00382 * 00383 DO 120 I = 2, N - 1 00384 AP( I ) = Y 00385 120 CONTINUE 00386 AP( N ) = Z 00387 JC = N + 1 00388 DO 130 J = 2, N - 1 00389 AP( JC+1 ) = WORK( J-1 ) 00390 IF( J.LT.N-1 ) 00391 $ AP( JC+2 ) = WORK( N+J-1 ) 00392 AP( JC+N-J ) = Y 00393 JC = JC + N - J + 1 00394 130 CONTINUE 00395 END IF 00396 * 00397 * Fill in the zeros using Givens rotations 00398 * 00399 IF( UPPER ) THEN 00400 JC = 1 00401 DO 150 J = 1, N - 1 00402 JCNEXT = JC + J 00403 RA = AP( JCNEXT+J-1 ) 00404 RB = TWO 00405 CALL ZROTG( RA, RB, C, S ) 00406 * 00407 * Multiply by [ c s; -conjg(s) c] on the left. 00408 * 00409 IF( N.GT.J+1 ) THEN 00410 JX = JCNEXT + J 00411 DO 140 I = J + 2, N 00412 CTEMP = C*AP( JX+J ) + S*AP( JX+J+1 ) 00413 AP( JX+J+1 ) = -DCONJG( S )*AP( JX+J ) + 00414 $ C*AP( JX+J+1 ) 00415 AP( JX+J ) = CTEMP 00416 JX = JX + I 00417 140 CONTINUE 00418 END IF 00419 * 00420 * Multiply by [-c -s; conjg(s) -c] on the right. 00421 * 00422 IF( J.GT.1 ) 00423 $ CALL ZROT( J-1, AP( JCNEXT ), 1, AP( JC ), 1, -C, -S ) 00424 * 00425 * Negate A(J,J+1). 00426 * 00427 AP( JCNEXT+J-1 ) = -AP( JCNEXT+J-1 ) 00428 JC = JCNEXT 00429 150 CONTINUE 00430 ELSE 00431 JC = 1 00432 DO 170 J = 1, N - 1 00433 JCNEXT = JC + N - J + 1 00434 RA = AP( JC+1 ) 00435 RB = TWO 00436 CALL ZROTG( RA, RB, C, S ) 00437 S = DCONJG( S ) 00438 * 00439 * Multiply by [ c -s; conjg(s) c] on the right. 00440 * 00441 IF( N.GT.J+1 ) 00442 $ CALL ZROT( N-J-1, AP( JCNEXT+1 ), 1, AP( JC+2 ), 1, C, 00443 $ -S ) 00444 * 00445 * Multiply by [-c s; -conjg(s) -c] on the left. 00446 * 00447 IF( J.GT.1 ) THEN 00448 JX = 1 00449 DO 160 I = 1, J - 1 00450 CTEMP = -C*AP( JX+J-I ) + S*AP( JX+J-I+1 ) 00451 AP( JX+J-I+1 ) = -DCONJG( S )*AP( JX+J-I ) - 00452 $ C*AP( JX+J-I+1 ) 00453 AP( JX+J-I ) = CTEMP 00454 JX = JX + N - I + 1 00455 160 CONTINUE 00456 END IF 00457 * 00458 * Negate A(J+1,J). 00459 * 00460 AP( JC+1 ) = -AP( JC+1 ) 00461 JC = JCNEXT 00462 170 CONTINUE 00463 END IF 00464 * 00465 * IMAT > 10: Pathological test cases. These triangular matrices 00466 * are badly scaled or badly conditioned, so when used in solving a 00467 * triangular system they may cause overflow in the solution vector. 00468 * 00469 ELSE IF( IMAT.EQ.11 ) THEN 00470 * 00471 * Type 11: Generate a triangular matrix with elements between 00472 * -1 and 1. Give the diagonal norm 2 to make it well-conditioned. 00473 * Make the right hand side large so that it requires scaling. 00474 * 00475 IF( UPPER ) THEN 00476 JC = 1 00477 DO 180 J = 1, N 00478 CALL ZLARNV( 4, ISEED, J-1, AP( JC ) ) 00479 AP( JC+J-1 ) = ZLARND( 5, ISEED )*TWO 00480 JC = JC + J 00481 180 CONTINUE 00482 ELSE 00483 JC = 1 00484 DO 190 J = 1, N 00485 IF( J.LT.N ) 00486 $ CALL ZLARNV( 4, ISEED, N-J, AP( JC+1 ) ) 00487 AP( JC ) = ZLARND( 5, ISEED )*TWO 00488 JC = JC + N - J + 1 00489 190 CONTINUE 00490 END IF 00491 * 00492 * Set the right hand side so that the largest value is BIGNUM. 00493 * 00494 CALL ZLARNV( 2, ISEED, N, B ) 00495 IY = IZAMAX( N, B, 1 ) 00496 BNORM = ABS( B( IY ) ) 00497 BSCAL = BIGNUM / MAX( ONE, BNORM ) 00498 CALL ZDSCAL( N, BSCAL, B, 1 ) 00499 * 00500 ELSE IF( IMAT.EQ.12 ) THEN 00501 * 00502 * Type 12: Make the first diagonal element in the solve small to 00503 * cause immediate overflow when dividing by T(j,j). 00504 * In type 12, the offdiagonal elements are small (CNORM(j) < 1). 00505 * 00506 CALL ZLARNV( 2, ISEED, N, B ) 00507 TSCAL = ONE / MAX( ONE, DBLE( N-1 ) ) 00508 IF( UPPER ) THEN 00509 JC = 1 00510 DO 200 J = 1, N 00511 CALL ZLARNV( 4, ISEED, J-1, AP( JC ) ) 00512 CALL ZDSCAL( J-1, TSCAL, AP( JC ), 1 ) 00513 AP( JC+J-1 ) = ZLARND( 5, ISEED ) 00514 JC = JC + J 00515 200 CONTINUE 00516 AP( N*( N+1 ) / 2 ) = SMLNUM*AP( N*( N+1 ) / 2 ) 00517 ELSE 00518 JC = 1 00519 DO 210 J = 1, N 00520 CALL ZLARNV( 2, ISEED, N-J, AP( JC+1 ) ) 00521 CALL ZDSCAL( N-J, TSCAL, AP( JC+1 ), 1 ) 00522 AP( JC ) = ZLARND( 5, ISEED ) 00523 JC = JC + N - J + 1 00524 210 CONTINUE 00525 AP( 1 ) = SMLNUM*AP( 1 ) 00526 END IF 00527 * 00528 ELSE IF( IMAT.EQ.13 ) THEN 00529 * 00530 * Type 13: Make the first diagonal element in the solve small to 00531 * cause immediate overflow when dividing by T(j,j). 00532 * In type 13, the offdiagonal elements are O(1) (CNORM(j) > 1). 00533 * 00534 CALL ZLARNV( 2, ISEED, N, B ) 00535 IF( UPPER ) THEN 00536 JC = 1 00537 DO 220 J = 1, N 00538 CALL ZLARNV( 4, ISEED, J-1, AP( JC ) ) 00539 AP( JC+J-1 ) = ZLARND( 5, ISEED ) 00540 JC = JC + J 00541 220 CONTINUE 00542 AP( N*( N+1 ) / 2 ) = SMLNUM*AP( N*( N+1 ) / 2 ) 00543 ELSE 00544 JC = 1 00545 DO 230 J = 1, N 00546 CALL ZLARNV( 4, ISEED, N-J, AP( JC+1 ) ) 00547 AP( JC ) = ZLARND( 5, ISEED ) 00548 JC = JC + N - J + 1 00549 230 CONTINUE 00550 AP( 1 ) = SMLNUM*AP( 1 ) 00551 END IF 00552 * 00553 ELSE IF( IMAT.EQ.14 ) THEN 00554 * 00555 * Type 14: T is diagonal with small numbers on the diagonal to 00556 * make the growth factor underflow, but a small right hand side 00557 * chosen so that the solution does not overflow. 00558 * 00559 IF( UPPER ) THEN 00560 JCOUNT = 1 00561 JC = ( N-1 )*N / 2 + 1 00562 DO 250 J = N, 1, -1 00563 DO 240 I = 1, J - 1 00564 AP( JC+I-1 ) = ZERO 00565 240 CONTINUE 00566 IF( JCOUNT.LE.2 ) THEN 00567 AP( JC+J-1 ) = SMLNUM*ZLARND( 5, ISEED ) 00568 ELSE 00569 AP( JC+J-1 ) = ZLARND( 5, ISEED ) 00570 END IF 00571 JCOUNT = JCOUNT + 1 00572 IF( JCOUNT.GT.4 ) 00573 $ JCOUNT = 1 00574 JC = JC - J + 1 00575 250 CONTINUE 00576 ELSE 00577 JCOUNT = 1 00578 JC = 1 00579 DO 270 J = 1, N 00580 DO 260 I = J + 1, N 00581 AP( JC+I-J ) = ZERO 00582 260 CONTINUE 00583 IF( JCOUNT.LE.2 ) THEN 00584 AP( JC ) = SMLNUM*ZLARND( 5, ISEED ) 00585 ELSE 00586 AP( JC ) = ZLARND( 5, ISEED ) 00587 END IF 00588 JCOUNT = JCOUNT + 1 00589 IF( JCOUNT.GT.4 ) 00590 $ JCOUNT = 1 00591 JC = JC + N - J + 1 00592 270 CONTINUE 00593 END IF 00594 * 00595 * Set the right hand side alternately zero and small. 00596 * 00597 IF( UPPER ) THEN 00598 B( 1 ) = ZERO 00599 DO 280 I = N, 2, -2 00600 B( I ) = ZERO 00601 B( I-1 ) = SMLNUM*ZLARND( 5, ISEED ) 00602 280 CONTINUE 00603 ELSE 00604 B( N ) = ZERO 00605 DO 290 I = 1, N - 1, 2 00606 B( I ) = ZERO 00607 B( I+1 ) = SMLNUM*ZLARND( 5, ISEED ) 00608 290 CONTINUE 00609 END IF 00610 * 00611 ELSE IF( IMAT.EQ.15 ) THEN 00612 * 00613 * Type 15: Make the diagonal elements small to cause gradual 00614 * overflow when dividing by T(j,j). To control the amount of 00615 * scaling needed, the matrix is bidiagonal. 00616 * 00617 TEXP = ONE / MAX( ONE, DBLE( N-1 ) ) 00618 TSCAL = SMLNUM**TEXP 00619 CALL ZLARNV( 4, ISEED, N, B ) 00620 IF( UPPER ) THEN 00621 JC = 1 00622 DO 310 J = 1, N 00623 DO 300 I = 1, J - 2 00624 AP( JC+I-1 ) = ZERO 00625 300 CONTINUE 00626 IF( J.GT.1 ) 00627 $ AP( JC+J-2 ) = DCMPLX( -ONE, -ONE ) 00628 AP( JC+J-1 ) = TSCAL*ZLARND( 5, ISEED ) 00629 JC = JC + J 00630 310 CONTINUE 00631 B( N ) = DCMPLX( ONE, ONE ) 00632 ELSE 00633 JC = 1 00634 DO 330 J = 1, N 00635 DO 320 I = J + 2, N 00636 AP( JC+I-J ) = ZERO 00637 320 CONTINUE 00638 IF( J.LT.N ) 00639 $ AP( JC+1 ) = DCMPLX( -ONE, -ONE ) 00640 AP( JC ) = TSCAL*ZLARND( 5, ISEED ) 00641 JC = JC + N - J + 1 00642 330 CONTINUE 00643 B( 1 ) = DCMPLX( ONE, ONE ) 00644 END IF 00645 * 00646 ELSE IF( IMAT.EQ.16 ) THEN 00647 * 00648 * Type 16: One zero diagonal element. 00649 * 00650 IY = N / 2 + 1 00651 IF( UPPER ) THEN 00652 JC = 1 00653 DO 340 J = 1, N 00654 CALL ZLARNV( 4, ISEED, J, AP( JC ) ) 00655 IF( J.NE.IY ) THEN 00656 AP( JC+J-1 ) = ZLARND( 5, ISEED )*TWO 00657 ELSE 00658 AP( JC+J-1 ) = ZERO 00659 END IF 00660 JC = JC + J 00661 340 CONTINUE 00662 ELSE 00663 JC = 1 00664 DO 350 J = 1, N 00665 CALL ZLARNV( 4, ISEED, N-J+1, AP( JC ) ) 00666 IF( J.NE.IY ) THEN 00667 AP( JC ) = ZLARND( 5, ISEED )*TWO 00668 ELSE 00669 AP( JC ) = ZERO 00670 END IF 00671 JC = JC + N - J + 1 00672 350 CONTINUE 00673 END IF 00674 CALL ZLARNV( 2, ISEED, N, B ) 00675 CALL ZDSCAL( N, TWO, B, 1 ) 00676 * 00677 ELSE IF( IMAT.EQ.17 ) THEN 00678 * 00679 * Type 17: Make the offdiagonal elements large to cause overflow 00680 * when adding a column of T. In the non-transposed case, the 00681 * matrix is constructed to cause overflow when adding a column in 00682 * every other step. 00683 * 00684 TSCAL = UNFL / ULP 00685 TSCAL = ( ONE-ULP ) / TSCAL 00686 DO 360 J = 1, N*( N+1 ) / 2 00687 AP( J ) = ZERO 00688 360 CONTINUE 00689 TEXP = ONE 00690 IF( UPPER ) THEN 00691 JC = ( N-1 )*N / 2 + 1 00692 DO 370 J = N, 2, -2 00693 AP( JC ) = -TSCAL / DBLE( N+1 ) 00694 AP( JC+J-1 ) = ONE 00695 B( J ) = TEXP*( ONE-ULP ) 00696 JC = JC - J + 1 00697 AP( JC ) = -( TSCAL / DBLE( N+1 ) ) / DBLE( N+2 ) 00698 AP( JC+J-2 ) = ONE 00699 B( J-1 ) = TEXP*DBLE( N*N+N-1 ) 00700 TEXP = TEXP*TWO 00701 JC = JC - J + 2 00702 370 CONTINUE 00703 B( 1 ) = ( DBLE( N+1 ) / DBLE( N+2 ) )*TSCAL 00704 ELSE 00705 JC = 1 00706 DO 380 J = 1, N - 1, 2 00707 AP( JC+N-J ) = -TSCAL / DBLE( N+1 ) 00708 AP( JC ) = ONE 00709 B( J ) = TEXP*( ONE-ULP ) 00710 JC = JC + N - J + 1 00711 AP( JC+N-J-1 ) = -( TSCAL / DBLE( N+1 ) ) / DBLE( N+2 ) 00712 AP( JC ) = ONE 00713 B( J+1 ) = TEXP*DBLE( N*N+N-1 ) 00714 TEXP = TEXP*TWO 00715 JC = JC + N - J 00716 380 CONTINUE 00717 B( N ) = ( DBLE( N+1 ) / DBLE( N+2 ) )*TSCAL 00718 END IF 00719 * 00720 ELSE IF( IMAT.EQ.18 ) THEN 00721 * 00722 * Type 18: Generate a unit triangular matrix with elements 00723 * between -1 and 1, and make the right hand side large so that it 00724 * requires scaling. 00725 * 00726 IF( UPPER ) THEN 00727 JC = 1 00728 DO 390 J = 1, N 00729 CALL ZLARNV( 4, ISEED, J-1, AP( JC ) ) 00730 AP( JC+J-1 ) = ZERO 00731 JC = JC + J 00732 390 CONTINUE 00733 ELSE 00734 JC = 1 00735 DO 400 J = 1, N 00736 IF( J.LT.N ) 00737 $ CALL ZLARNV( 4, ISEED, N-J, AP( JC+1 ) ) 00738 AP( JC ) = ZERO 00739 JC = JC + N - J + 1 00740 400 CONTINUE 00741 END IF 00742 * 00743 * Set the right hand side so that the largest value is BIGNUM. 00744 * 00745 CALL ZLARNV( 2, ISEED, N, B ) 00746 IY = IZAMAX( N, B, 1 ) 00747 BNORM = ABS( B( IY ) ) 00748 BSCAL = BIGNUM / MAX( ONE, BNORM ) 00749 CALL ZDSCAL( N, BSCAL, B, 1 ) 00750 * 00751 ELSE IF( IMAT.EQ.19 ) THEN 00752 * 00753 * Type 19: Generate a triangular matrix with elements between 00754 * BIGNUM/(n-1) and BIGNUM so that at least one of the column 00755 * norms will exceed BIGNUM. 00756 * 1/3/91: ZLATPS no longer can handle this case 00757 * 00758 TLEFT = BIGNUM / MAX( ONE, DBLE( N-1 ) ) 00759 TSCAL = BIGNUM*( DBLE( N-1 ) / MAX( ONE, DBLE( N ) ) ) 00760 IF( UPPER ) THEN 00761 JC = 1 00762 DO 420 J = 1, N 00763 CALL ZLARNV( 5, ISEED, J, AP( JC ) ) 00764 CALL DLARNV( 1, ISEED, J, RWORK ) 00765 DO 410 I = 1, J 00766 AP( JC+I-1 ) = AP( JC+I-1 )*( TLEFT+RWORK( I )*TSCAL ) 00767 410 CONTINUE 00768 JC = JC + J 00769 420 CONTINUE 00770 ELSE 00771 JC = 1 00772 DO 440 J = 1, N 00773 CALL ZLARNV( 5, ISEED, N-J+1, AP( JC ) ) 00774 CALL DLARNV( 1, ISEED, N-J+1, RWORK ) 00775 DO 430 I = J, N 00776 AP( JC+I-J ) = AP( JC+I-J )* 00777 $ ( TLEFT+RWORK( I-J+1 )*TSCAL ) 00778 430 CONTINUE 00779 JC = JC + N - J + 1 00780 440 CONTINUE 00781 END IF 00782 CALL ZLARNV( 2, ISEED, N, B ) 00783 CALL ZDSCAL( N, TWO, B, 1 ) 00784 END IF 00785 * 00786 * Flip the matrix across its counter-diagonal if the transpose will 00787 * be used. 00788 * 00789 IF( .NOT.LSAME( TRANS, 'N' ) ) THEN 00790 IF( UPPER ) THEN 00791 JJ = 1 00792 JR = N*( N+1 ) / 2 00793 DO 460 J = 1, N / 2 00794 JL = JJ 00795 DO 450 I = J, N - J 00796 T = AP( JR-I+J ) 00797 AP( JR-I+J ) = AP( JL ) 00798 AP( JL ) = T 00799 JL = JL + I 00800 450 CONTINUE 00801 JJ = JJ + J + 1 00802 JR = JR - ( N-J+1 ) 00803 460 CONTINUE 00804 ELSE 00805 JL = 1 00806 JJ = N*( N+1 ) / 2 00807 DO 480 J = 1, N / 2 00808 JR = JJ 00809 DO 470 I = J, N - J 00810 T = AP( JL+I-J ) 00811 AP( JL+I-J ) = AP( JR ) 00812 AP( JR ) = T 00813 JR = JR - I 00814 470 CONTINUE 00815 JL = JL + N - J + 1 00816 JJ = JJ - J - 1 00817 480 CONTINUE 00818 END IF 00819 END IF 00820 * 00821 RETURN 00822 * 00823 * End of ZLATTP 00824 * 00825 END