![]() |
LAPACK
3.4.1
LAPACK: Linear Algebra PACKage
|
00001 *> \brief \b DLATTB 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 DLATTB( IMAT, UPLO, TRANS, DIAG, ISEED, N, KD, AB, 00012 * LDAB, B, WORK, INFO ) 00013 * 00014 * .. Scalar Arguments .. 00015 * CHARACTER DIAG, TRANS, UPLO 00016 * INTEGER IMAT, INFO, KD, LDAB, N 00017 * .. 00018 * .. Array Arguments .. 00019 * INTEGER ISEED( 4 ) 00020 * DOUBLE PRECISION AB( LDAB, * ), B( * ), WORK( * ) 00021 * .. 00022 * 00023 * 00024 *> \par Purpose: 00025 * ============= 00026 *> 00027 *> \verbatim 00028 *> 00029 *> DLATTB generates a triangular test matrix in 2-dimensional storage. 00030 *> IMAT and UPLO uniquely specify the properties of the test matrix, 00031 *> which is returned in the array A. 00032 *> \endverbatim 00033 * 00034 * Arguments: 00035 * ========== 00036 * 00037 *> \param[in] IMAT 00038 *> \verbatim 00039 *> IMAT is INTEGER 00040 *> An integer key describing which matrix to generate for this 00041 *> path. 00042 *> \endverbatim 00043 *> 00044 *> \param[in] UPLO 00045 *> \verbatim 00046 *> UPLO is CHARACTER*1 00047 *> Specifies whether the matrix A will be upper or lower 00048 *> triangular. 00049 *> = 'U': Upper triangular 00050 *> = 'L': Lower triangular 00051 *> \endverbatim 00052 *> 00053 *> \param[in] TRANS 00054 *> \verbatim 00055 *> TRANS is CHARACTER*1 00056 *> Specifies whether the matrix or its transpose will be used. 00057 *> = 'N': No transpose 00058 *> = 'T': Transpose 00059 *> = 'C': Conjugate transpose (= transpose) 00060 *> \endverbatim 00061 *> 00062 *> \param[out] DIAG 00063 *> \verbatim 00064 *> DIAG is CHARACTER*1 00065 *> Specifies whether or not the matrix A is unit triangular. 00066 *> = 'N': Non-unit triangular 00067 *> = 'U': Unit triangular 00068 *> \endverbatim 00069 *> 00070 *> \param[in,out] ISEED 00071 *> \verbatim 00072 *> ISEED is INTEGER array, dimension (4) 00073 *> The seed vector for the random number generator (used in 00074 *> DLATMS). Modified on exit. 00075 *> \endverbatim 00076 *> 00077 *> \param[in] N 00078 *> \verbatim 00079 *> N is INTEGER 00080 *> The order of the matrix to be generated. 00081 *> \endverbatim 00082 *> 00083 *> \param[in] KD 00084 *> \verbatim 00085 *> KD is INTEGER 00086 *> The number of superdiagonals or subdiagonals of the banded 00087 *> triangular matrix A. KD >= 0. 00088 *> \endverbatim 00089 *> 00090 *> \param[out] AB 00091 *> \verbatim 00092 *> AB is DOUBLE PRECISION array, dimension (LDAB,N) 00093 *> The upper or lower triangular banded matrix A, stored in the 00094 *> first KD+1 rows of AB. Let j be a column of A, 1<=j<=n. 00095 *> If UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j. 00096 *> If UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). 00097 *> \endverbatim 00098 *> 00099 *> \param[in] LDAB 00100 *> \verbatim 00101 *> LDAB is INTEGER 00102 *> The leading dimension of the array AB. LDAB >= KD+1. 00103 *> \endverbatim 00104 *> 00105 *> \param[out] B 00106 *> \verbatim 00107 *> B is DOUBLE PRECISION array, dimension (N) 00108 *> \endverbatim 00109 *> 00110 *> \param[out] WORK 00111 *> \verbatim 00112 *> WORK is DOUBLE PRECISION array, dimension (2*N) 00113 *> \endverbatim 00114 *> 00115 *> \param[out] INFO 00116 *> \verbatim 00117 *> INFO is INTEGER 00118 *> = 0: successful exit 00119 *> < 0: if INFO = -k, the k-th argument had an illegal value 00120 *> \endverbatim 00121 * 00122 * Authors: 00123 * ======== 00124 * 00125 *> \author Univ. of Tennessee 00126 *> \author Univ. of California Berkeley 00127 *> \author Univ. of Colorado Denver 00128 *> \author NAG Ltd. 00129 * 00130 *> \date November 2011 00131 * 00132 *> \ingroup double_lin 00133 * 00134 * ===================================================================== 00135 SUBROUTINE DLATTB( IMAT, UPLO, TRANS, DIAG, ISEED, N, KD, AB, 00136 $ LDAB, B, WORK, INFO ) 00137 * 00138 * -- LAPACK test routine (version 3.4.0) -- 00139 * -- LAPACK is a software package provided by Univ. of Tennessee, -- 00140 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00141 * November 2011 00142 * 00143 * .. Scalar Arguments .. 00144 CHARACTER DIAG, TRANS, UPLO 00145 INTEGER IMAT, INFO, KD, LDAB, N 00146 * .. 00147 * .. Array Arguments .. 00148 INTEGER ISEED( 4 ) 00149 DOUBLE PRECISION AB( LDAB, * ), B( * ), WORK( * ) 00150 * .. 00151 * 00152 * ===================================================================== 00153 * 00154 * .. Parameters .. 00155 DOUBLE PRECISION ONE, TWO, ZERO 00156 PARAMETER ( ONE = 1.0D+0, TWO = 2.0D+0, ZERO = 0.0D+0 ) 00157 * .. 00158 * .. Local Scalars .. 00159 LOGICAL UPPER 00160 CHARACTER DIST, PACKIT, TYPE 00161 CHARACTER*3 PATH 00162 INTEGER I, IOFF, IY, J, JCOUNT, KL, KU, LENJ, MODE 00163 DOUBLE PRECISION ANORM, BIGNUM, BNORM, BSCAL, CNDNUM, PLUS1, 00164 $ PLUS2, REXP, SFAC, SMLNUM, STAR1, TEXP, TLEFT, 00165 $ TNORM, TSCAL, ULP, UNFL 00166 * .. 00167 * .. External Functions .. 00168 LOGICAL LSAME 00169 INTEGER IDAMAX 00170 DOUBLE PRECISION DLAMCH, DLARND 00171 EXTERNAL LSAME, IDAMAX, DLAMCH, DLARND 00172 * .. 00173 * .. External Subroutines .. 00174 EXTERNAL DCOPY, DLABAD, DLARNV, DLATB4, DLATMS, DSCAL, 00175 $ DSWAP 00176 * .. 00177 * .. Intrinsic Functions .. 00178 INTRINSIC ABS, DBLE, MAX, MIN, SIGN, SQRT 00179 * .. 00180 * .. Executable Statements .. 00181 * 00182 PATH( 1: 1 ) = 'Double precision' 00183 PATH( 2: 3 ) = 'TB' 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.6 .AND. IMAT.LE.9 ) .OR. IMAT.EQ.17 ) 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 DLATB4 to set parameters for SLATMS. 00202 * 00203 UPPER = LSAME( UPLO, 'U' ) 00204 IF( UPPER ) THEN 00205 CALL DLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE, 00206 $ CNDNUM, DIST ) 00207 KU = KD 00208 IOFF = 1 + MAX( 0, KD-N+1 ) 00209 KL = 0 00210 PACKIT = 'Q' 00211 ELSE 00212 CALL DLATB4( PATH, -IMAT, N, N, TYPE, KL, KU, ANORM, MODE, 00213 $ CNDNUM, DIST ) 00214 KL = KD 00215 IOFF = 1 00216 KU = 0 00217 PACKIT = 'B' 00218 END IF 00219 * 00220 * IMAT <= 5: Non-unit triangular matrix 00221 * 00222 IF( IMAT.LE.5 ) THEN 00223 CALL DLATMS( N, N, DIST, ISEED, TYPE, B, MODE, CNDNUM, ANORM, 00224 $ KL, KU, PACKIT, AB( IOFF, 1 ), LDAB, WORK, INFO ) 00225 * 00226 * IMAT > 5: Unit triangular matrix 00227 * The diagonal is deliberately set to something other than 1. 00228 * 00229 * IMAT = 6: Matrix is the identity 00230 * 00231 ELSE IF( IMAT.EQ.6 ) THEN 00232 IF( UPPER ) THEN 00233 DO 20 J = 1, N 00234 DO 10 I = MAX( 1, KD+2-J ), KD 00235 AB( I, J ) = ZERO 00236 10 CONTINUE 00237 AB( KD+1, J ) = J 00238 20 CONTINUE 00239 ELSE 00240 DO 40 J = 1, N 00241 AB( 1, J ) = J 00242 DO 30 I = 2, MIN( KD+1, N-J+1 ) 00243 AB( I, J ) = ZERO 00244 30 CONTINUE 00245 40 CONTINUE 00246 END IF 00247 * 00248 * IMAT > 6: Non-trivial unit triangular matrix 00249 * 00250 * A unit triangular matrix T with condition CNDNUM is formed. 00251 * In this version, T only has bandwidth 2, the rest of it is zero. 00252 * 00253 ELSE IF( IMAT.LE.9 ) THEN 00254 TNORM = SQRT( CNDNUM ) 00255 * 00256 * Initialize AB to zero. 00257 * 00258 IF( UPPER ) THEN 00259 DO 60 J = 1, N 00260 DO 50 I = MAX( 1, KD+2-J ), KD 00261 AB( I, J ) = ZERO 00262 50 CONTINUE 00263 AB( KD+1, J ) = DBLE( J ) 00264 60 CONTINUE 00265 ELSE 00266 DO 80 J = 1, N 00267 DO 70 I = 2, MIN( KD+1, N-J+1 ) 00268 AB( I, J ) = ZERO 00269 70 CONTINUE 00270 AB( 1, J ) = DBLE( J ) 00271 80 CONTINUE 00272 END IF 00273 * 00274 * Special case: T is tridiagonal. Set every other offdiagonal 00275 * so that the matrix has norm TNORM+1. 00276 * 00277 IF( KD.EQ.1 ) THEN 00278 IF( UPPER ) THEN 00279 AB( 1, 2 ) = SIGN( TNORM, DLARND( 2, ISEED ) ) 00280 LENJ = ( N-3 ) / 2 00281 CALL DLARNV( 2, ISEED, LENJ, WORK ) 00282 DO 90 J = 1, LENJ 00283 AB( 1, 2*( J+1 ) ) = TNORM*WORK( J ) 00284 90 CONTINUE 00285 ELSE 00286 AB( 2, 1 ) = SIGN( TNORM, DLARND( 2, ISEED ) ) 00287 LENJ = ( N-3 ) / 2 00288 CALL DLARNV( 2, ISEED, LENJ, WORK ) 00289 DO 100 J = 1, LENJ 00290 AB( 2, 2*J+1 ) = TNORM*WORK( J ) 00291 100 CONTINUE 00292 END IF 00293 ELSE IF( KD.GT.1 ) THEN 00294 * 00295 * Form a unit triangular matrix T with condition CNDNUM. T is 00296 * given by 00297 * | 1 + * | 00298 * | 1 + | 00299 * T = | 1 + * | 00300 * | 1 + | 00301 * | 1 + * | 00302 * | 1 + | 00303 * | . . . | 00304 * Each element marked with a '*' is formed by taking the product 00305 * of the adjacent elements marked with '+'. The '*'s can be 00306 * chosen freely, and the '+'s are chosen so that the inverse of 00307 * T will have elements of the same magnitude as T. 00308 * 00309 * The two offdiagonals of T are stored in WORK. 00310 * 00311 STAR1 = SIGN( TNORM, DLARND( 2, ISEED ) ) 00312 SFAC = SQRT( TNORM ) 00313 PLUS1 = SIGN( SFAC, DLARND( 2, ISEED ) ) 00314 DO 110 J = 1, N, 2 00315 PLUS2 = STAR1 / PLUS1 00316 WORK( J ) = PLUS1 00317 WORK( N+J ) = STAR1 00318 IF( J+1.LE.N ) THEN 00319 WORK( J+1 ) = PLUS2 00320 WORK( N+J+1 ) = ZERO 00321 PLUS1 = STAR1 / PLUS2 00322 * 00323 * Generate a new *-value with norm between sqrt(TNORM) 00324 * and TNORM. 00325 * 00326 REXP = DLARND( 2, ISEED ) 00327 IF( REXP.LT.ZERO ) THEN 00328 STAR1 = -SFAC**( ONE-REXP ) 00329 ELSE 00330 STAR1 = SFAC**( ONE+REXP ) 00331 END IF 00332 END IF 00333 110 CONTINUE 00334 * 00335 * Copy the tridiagonal T to AB. 00336 * 00337 IF( UPPER ) THEN 00338 CALL DCOPY( N-1, WORK, 1, AB( KD, 2 ), LDAB ) 00339 CALL DCOPY( N-2, WORK( N+1 ), 1, AB( KD-1, 3 ), LDAB ) 00340 ELSE 00341 CALL DCOPY( N-1, WORK, 1, AB( 2, 1 ), LDAB ) 00342 CALL DCOPY( N-2, WORK( N+1 ), 1, AB( 3, 1 ), LDAB ) 00343 END IF 00344 END IF 00345 * 00346 * IMAT > 9: 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.10 ) THEN 00351 * 00352 * Type 10: 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 120 J = 1, N 00358 LENJ = MIN( J, KD+1 ) 00359 CALL DLARNV( 2, ISEED, LENJ, AB( KD+2-LENJ, J ) ) 00360 AB( KD+1, J ) = SIGN( TWO, AB( KD+1, J ) ) 00361 120 CONTINUE 00362 ELSE 00363 DO 130 J = 1, N 00364 LENJ = MIN( N-J+1, KD+1 ) 00365 IF( LENJ.GT.0 ) 00366 $ CALL DLARNV( 2, ISEED, LENJ, AB( 1, J ) ) 00367 AB( 1, J ) = SIGN( TWO, AB( 1, J ) ) 00368 130 CONTINUE 00369 END IF 00370 * 00371 * Set the right hand side so that the largest value is BIGNUM. 00372 * 00373 CALL DLARNV( 2, ISEED, N, B ) 00374 IY = IDAMAX( N, B, 1 ) 00375 BNORM = ABS( B( IY ) ) 00376 BSCAL = BIGNUM / MAX( ONE, BNORM ) 00377 CALL DSCAL( N, BSCAL, B, 1 ) 00378 * 00379 ELSE IF( IMAT.EQ.11 ) THEN 00380 * 00381 * Type 11: Make the first diagonal element in the solve small to 00382 * cause immediate overflow when dividing by T(j,j). 00383 * In type 11, the offdiagonal elements are small (CNORM(j) < 1). 00384 * 00385 CALL DLARNV( 2, ISEED, N, B ) 00386 TSCAL = ONE / DBLE( KD+1 ) 00387 IF( UPPER ) THEN 00388 DO 140 J = 1, N 00389 LENJ = MIN( J, KD+1 ) 00390 CALL DLARNV( 2, ISEED, LENJ, AB( KD+2-LENJ, J ) ) 00391 CALL DSCAL( LENJ-1, TSCAL, AB( KD+2-LENJ, J ), 1 ) 00392 AB( KD+1, J ) = SIGN( ONE, AB( KD+1, J ) ) 00393 140 CONTINUE 00394 AB( KD+1, N ) = SMLNUM*AB( KD+1, N ) 00395 ELSE 00396 DO 150 J = 1, N 00397 LENJ = MIN( N-J+1, KD+1 ) 00398 CALL DLARNV( 2, ISEED, LENJ, AB( 1, J ) ) 00399 IF( LENJ.GT.1 ) 00400 $ CALL DSCAL( LENJ-1, TSCAL, AB( 2, J ), 1 ) 00401 AB( 1, J ) = SIGN( ONE, AB( 1, J ) ) 00402 150 CONTINUE 00403 AB( 1, 1 ) = SMLNUM*AB( 1, 1 ) 00404 END IF 00405 * 00406 ELSE IF( IMAT.EQ.12 ) THEN 00407 * 00408 * Type 12: Make the first diagonal element in the solve small to 00409 * cause immediate overflow when dividing by T(j,j). 00410 * In type 12, the offdiagonal elements are O(1) (CNORM(j) > 1). 00411 * 00412 CALL DLARNV( 2, ISEED, N, B ) 00413 IF( UPPER ) THEN 00414 DO 160 J = 1, N 00415 LENJ = MIN( J, KD+1 ) 00416 CALL DLARNV( 2, ISEED, LENJ, AB( KD+2-LENJ, J ) ) 00417 AB( KD+1, J ) = SIGN( ONE, AB( KD+1, J ) ) 00418 160 CONTINUE 00419 AB( KD+1, N ) = SMLNUM*AB( KD+1, N ) 00420 ELSE 00421 DO 170 J = 1, N 00422 LENJ = MIN( N-J+1, KD+1 ) 00423 CALL DLARNV( 2, ISEED, LENJ, AB( 1, J ) ) 00424 AB( 1, J ) = SIGN( ONE, AB( 1, J ) ) 00425 170 CONTINUE 00426 AB( 1, 1 ) = SMLNUM*AB( 1, 1 ) 00427 END IF 00428 * 00429 ELSE IF( IMAT.EQ.13 ) THEN 00430 * 00431 * Type 13: 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 190 J = N, 1, -1 00438 DO 180 I = MAX( 1, KD+1-( J-1 ) ), KD 00439 AB( I, J ) = ZERO 00440 180 CONTINUE 00441 IF( JCOUNT.LE.2 ) THEN 00442 AB( KD+1, J ) = SMLNUM 00443 ELSE 00444 AB( KD+1, J ) = ONE 00445 END IF 00446 JCOUNT = JCOUNT + 1 00447 IF( JCOUNT.GT.4 ) 00448 $ JCOUNT = 1 00449 190 CONTINUE 00450 ELSE 00451 JCOUNT = 1 00452 DO 210 J = 1, N 00453 DO 200 I = 2, MIN( N-J+1, KD+1 ) 00454 AB( I, J ) = ZERO 00455 200 CONTINUE 00456 IF( JCOUNT.LE.2 ) THEN 00457 AB( 1, J ) = SMLNUM 00458 ELSE 00459 AB( 1, J ) = ONE 00460 END IF 00461 JCOUNT = JCOUNT + 1 00462 IF( JCOUNT.GT.4 ) 00463 $ JCOUNT = 1 00464 210 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 220 I = N, 2, -2 00472 B( I ) = ZERO 00473 B( I-1 ) = SMLNUM 00474 220 CONTINUE 00475 ELSE 00476 B( N ) = ZERO 00477 DO 230 I = 1, N - 1, 2 00478 B( I ) = ZERO 00479 B( I+1 ) = SMLNUM 00480 230 CONTINUE 00481 END IF 00482 * 00483 ELSE IF( IMAT.EQ.14 ) THEN 00484 * 00485 * Type 14: 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 / DBLE( KD+1 ) 00490 TSCAL = SMLNUM**TEXP 00491 CALL DLARNV( 2, ISEED, N, B ) 00492 IF( UPPER ) THEN 00493 DO 250 J = 1, N 00494 DO 240 I = MAX( 1, KD+2-J ), KD 00495 AB( I, J ) = ZERO 00496 240 CONTINUE 00497 IF( J.GT.1 .AND. KD.GT.0 ) 00498 $ AB( KD, J ) = -ONE 00499 AB( KD+1, J ) = TSCAL 00500 250 CONTINUE 00501 B( N ) = ONE 00502 ELSE 00503 DO 270 J = 1, N 00504 DO 260 I = 3, MIN( N-J+1, KD+1 ) 00505 AB( I, J ) = ZERO 00506 260 CONTINUE 00507 IF( J.LT.N .AND. KD.GT.0 ) 00508 $ AB( 2, J ) = -ONE 00509 AB( 1, J ) = TSCAL 00510 270 CONTINUE 00511 B( 1 ) = ONE 00512 END IF 00513 * 00514 ELSE IF( IMAT.EQ.15 ) THEN 00515 * 00516 * Type 15: One zero diagonal element. 00517 * 00518 IY = N / 2 + 1 00519 IF( UPPER ) THEN 00520 DO 280 J = 1, N 00521 LENJ = MIN( J, KD+1 ) 00522 CALL DLARNV( 2, ISEED, LENJ, AB( KD+2-LENJ, J ) ) 00523 IF( J.NE.IY ) THEN 00524 AB( KD+1, J ) = SIGN( TWO, AB( KD+1, J ) ) 00525 ELSE 00526 AB( KD+1, J ) = ZERO 00527 END IF 00528 280 CONTINUE 00529 ELSE 00530 DO 290 J = 1, N 00531 LENJ = MIN( N-J+1, KD+1 ) 00532 CALL DLARNV( 2, ISEED, LENJ, AB( 1, J ) ) 00533 IF( J.NE.IY ) THEN 00534 AB( 1, J ) = SIGN( TWO, AB( 1, J ) ) 00535 ELSE 00536 AB( 1, J ) = ZERO 00537 END IF 00538 290 CONTINUE 00539 END IF 00540 CALL DLARNV( 2, ISEED, N, B ) 00541 CALL DSCAL( N, TWO, B, 1 ) 00542 * 00543 ELSE IF( IMAT.EQ.16 ) THEN 00544 * 00545 * Type 16: Make the offdiagonal elements large to cause overflow 00546 * when adding a column of T. In the non-transposed case, the 00547 * matrix is constructed to cause overflow when adding a column in 00548 * every other step. 00549 * 00550 TSCAL = UNFL / ULP 00551 TSCAL = ( ONE-ULP ) / TSCAL 00552 DO 310 J = 1, N 00553 DO 300 I = 1, KD + 1 00554 AB( I, J ) = ZERO 00555 300 CONTINUE 00556 310 CONTINUE 00557 TEXP = ONE 00558 IF( KD.GT.0 ) THEN 00559 IF( UPPER ) THEN 00560 DO 330 J = N, 1, -KD 00561 DO 320 I = J, MAX( 1, J-KD+1 ), -2 00562 AB( 1+( J-I ), I ) = -TSCAL / DBLE( KD+2 ) 00563 AB( KD+1, I ) = ONE 00564 B( I ) = TEXP*( ONE-ULP ) 00565 IF( I.GT.MAX( 1, J-KD+1 ) ) THEN 00566 AB( 2+( J-I ), I-1 ) = -( TSCAL / DBLE( KD+2 ) ) 00567 $ / DBLE( KD+3 ) 00568 AB( KD+1, I-1 ) = ONE 00569 B( I-1 ) = TEXP*DBLE( ( KD+1 )*( KD+1 )+KD ) 00570 END IF 00571 TEXP = TEXP*TWO 00572 320 CONTINUE 00573 B( MAX( 1, J-KD+1 ) ) = ( DBLE( KD+2 ) / 00574 $ DBLE( KD+3 ) )*TSCAL 00575 330 CONTINUE 00576 ELSE 00577 DO 350 J = 1, N, KD 00578 TEXP = ONE 00579 LENJ = MIN( KD+1, N-J+1 ) 00580 DO 340 I = J, MIN( N, J+KD-1 ), 2 00581 AB( LENJ-( I-J ), J ) = -TSCAL / DBLE( KD+2 ) 00582 AB( 1, J ) = ONE 00583 B( J ) = TEXP*( ONE-ULP ) 00584 IF( I.LT.MIN( N, J+KD-1 ) ) THEN 00585 AB( LENJ-( I-J+1 ), I+1 ) = -( TSCAL / 00586 $ DBLE( KD+2 ) ) / DBLE( KD+3 ) 00587 AB( 1, I+1 ) = ONE 00588 B( I+1 ) = TEXP*DBLE( ( KD+1 )*( KD+1 )+KD ) 00589 END IF 00590 TEXP = TEXP*TWO 00591 340 CONTINUE 00592 B( MIN( N, J+KD-1 ) ) = ( DBLE( KD+2 ) / 00593 $ DBLE( KD+3 ) )*TSCAL 00594 350 CONTINUE 00595 END IF 00596 ELSE 00597 DO 360 J = 1, N 00598 AB( 1, J ) = ONE 00599 B( J ) = DBLE( J ) 00600 360 CONTINUE 00601 END IF 00602 * 00603 ELSE IF( IMAT.EQ.17 ) THEN 00604 * 00605 * Type 17: Generate a unit triangular matrix with elements 00606 * between -1 and 1, and make the right hand side large so that it 00607 * requires scaling. 00608 * 00609 IF( UPPER ) THEN 00610 DO 370 J = 1, N 00611 LENJ = MIN( J-1, KD ) 00612 CALL DLARNV( 2, ISEED, LENJ, AB( KD+1-LENJ, J ) ) 00613 AB( KD+1, J ) = DBLE( J ) 00614 370 CONTINUE 00615 ELSE 00616 DO 380 J = 1, N 00617 LENJ = MIN( N-J, KD ) 00618 IF( LENJ.GT.0 ) 00619 $ CALL DLARNV( 2, ISEED, LENJ, AB( 2, J ) ) 00620 AB( 1, J ) = DBLE( J ) 00621 380 CONTINUE 00622 END IF 00623 * 00624 * Set the right hand side so that the largest value is BIGNUM. 00625 * 00626 CALL DLARNV( 2, ISEED, N, B ) 00627 IY = IDAMAX( N, B, 1 ) 00628 BNORM = ABS( B( IY ) ) 00629 BSCAL = BIGNUM / MAX( ONE, BNORM ) 00630 CALL DSCAL( N, BSCAL, B, 1 ) 00631 * 00632 ELSE IF( IMAT.EQ.18 ) THEN 00633 * 00634 * Type 18: Generate a triangular matrix with elements between 00635 * BIGNUM/KD and BIGNUM so that at least one of the column 00636 * norms will exceed BIGNUM. 00637 * 00638 TLEFT = BIGNUM / MAX( ONE, DBLE( KD ) ) 00639 TSCAL = BIGNUM*( DBLE( KD ) / DBLE( KD+1 ) ) 00640 IF( UPPER ) THEN 00641 DO 400 J = 1, N 00642 LENJ = MIN( J, KD+1 ) 00643 CALL DLARNV( 2, ISEED, LENJ, AB( KD+2-LENJ, J ) ) 00644 DO 390 I = KD + 2 - LENJ, KD + 1 00645 AB( I, J ) = SIGN( TLEFT, AB( I, J ) ) + 00646 $ TSCAL*AB( I, J ) 00647 390 CONTINUE 00648 400 CONTINUE 00649 ELSE 00650 DO 420 J = 1, N 00651 LENJ = MIN( N-J+1, KD+1 ) 00652 CALL DLARNV( 2, ISEED, LENJ, AB( 1, J ) ) 00653 DO 410 I = 1, LENJ 00654 AB( I, J ) = SIGN( TLEFT, AB( I, J ) ) + 00655 $ TSCAL*AB( I, J ) 00656 410 CONTINUE 00657 420 CONTINUE 00658 END IF 00659 CALL DLARNV( 2, ISEED, N, B ) 00660 CALL DSCAL( N, TWO, B, 1 ) 00661 END IF 00662 * 00663 * Flip the matrix if the transpose will be used. 00664 * 00665 IF( .NOT.LSAME( TRANS, 'N' ) ) THEN 00666 IF( UPPER ) THEN 00667 DO 430 J = 1, N / 2 00668 LENJ = MIN( N-2*J+1, KD+1 ) 00669 CALL DSWAP( LENJ, AB( KD+1, J ), LDAB-1, 00670 $ AB( KD+2-LENJ, N-J+1 ), -1 ) 00671 430 CONTINUE 00672 ELSE 00673 DO 440 J = 1, N / 2 00674 LENJ = MIN( N-2*J+1, KD+1 ) 00675 CALL DSWAP( LENJ, AB( 1, J ), 1, AB( LENJ, N-J+2-LENJ ), 00676 $ -LDAB+1 ) 00677 440 CONTINUE 00678 END IF 00679 END IF 00680 * 00681 RETURN 00682 * 00683 * End of DLATTB 00684 * 00685 END