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