LAPACK  3.10.0 LAPACK: Linear Algebra PACKage
slattr.f
Go to the documentation of this file.
1 *> \brief \b SLATTR
2 *
3 * =========== DOCUMENTATION ===========
4 *
5 * Online html documentation available at
6 * http://www.netlib.org/lapack/explore-html/
7 *
8 * Definition:
9 * ===========
10 *
11 * SUBROUTINE SLATTR( IMAT, UPLO, TRANS, DIAG, ISEED, N, A, LDA, B,
12 * WORK, INFO )
13 *
14 * .. Scalar Arguments ..
15 * CHARACTER DIAG, TRANS, UPLO
16 * INTEGER IMAT, INFO, LDA, N
17 * ..
18 * .. Array Arguments ..
19 * INTEGER ISEED( 4 )
20 * REAL A( LDA, * ), B( * ), WORK( * )
21 * ..
22 *
23 *
24 *> \par Purpose:
25 * =============
26 *>
27 *> \verbatim
28 *>
29 *> SLATTR generates a triangular test matrix.
30 *> IMAT and UPLO uniquely specify the properties of the test
31 *> matrix, which is returned in the array A.
32 *> \endverbatim
33 *
34 * Arguments:
35 * ==========
36 *
37 *> \param[in] IMAT
38 *> \verbatim
39 *> IMAT is INTEGER
40 *> An integer key describing which matrix to generate for this
41 *> path.
42 *> \endverbatim
43 *>
44 *> \param[in] UPLO
45 *> \verbatim
46 *> UPLO is CHARACTER*1
47 *> Specifies whether the matrix A will be upper or lower
48 *> triangular.
49 *> = 'U': Upper triangular
50 *> = 'L': Lower triangular
51 *> \endverbatim
52 *>
53 *> \param[in] TRANS
54 *> \verbatim
55 *> TRANS is CHARACTER*1
56 *> Specifies whether the matrix or its transpose will be used.
57 *> = 'N': No transpose
58 *> = 'T': Transpose
59 *> = 'C': Conjugate transpose (= Transpose)
60 *> \endverbatim
61 *>
62 *> \param[out] DIAG
63 *> \verbatim
64 *> DIAG is CHARACTER*1
65 *> Specifies whether or not the matrix A is unit triangular.
66 *> = 'N': Non-unit triangular
67 *> = 'U': Unit triangular
68 *> \endverbatim
69 *>
70 *> \param[in,out] ISEED
71 *> \verbatim
72 *> ISEED is INTEGER array, dimension (4)
73 *> The seed vector for the random number generator (used in
74 *> SLATMS). Modified on exit.
75 *> \endverbatim
76 *>
77 *> \param[in] N
78 *> \verbatim
79 *> N is INTEGER
80 *> The order of the matrix to be generated.
81 *> \endverbatim
82 *>
83 *> \param[out] A
84 *> \verbatim
85 *> A is REAL array, dimension (LDA,N)
86 *> The triangular matrix A. If UPLO = 'U', the leading n by n
87 *> upper triangular part of the array A contains the upper
88 *> triangular matrix, and the strictly lower triangular part of
89 *> A is not referenced. If UPLO = 'L', the leading n by n lower
90 *> triangular part of the array A contains the lower triangular
91 *> matrix, and the strictly upper triangular part of A is not
92 *> referenced. If DIAG = 'U', the diagonal elements of A are
93 *> set so that A(k,k) = k for 1 <= k <= n.
94 *> \endverbatim
95 *>
96 *> \param[in] LDA
97 *> \verbatim
98 *> LDA is INTEGER
99 *> The leading dimension of the array A. LDA >= max(1,N).
100 *> \endverbatim
101 *>
102 *> \param[out] B
103 *> \verbatim
104 *> B is REAL array, dimension (N)
105 *> The right hand side vector, if IMAT > 10.
106 *> \endverbatim
107 *>
108 *> \param[out] WORK
109 *> \verbatim
110 *> WORK is REAL array, dimension (3*N)
111 *> \endverbatim
112 *>
113 *> \param[out] INFO
114 *> \verbatim
115 *> INFO is INTEGER
116 *> = 0: successful exit
117 *> < 0: if INFO = -k, the k-th argument had an illegal value
118 *> \endverbatim
119 *
120 * Authors:
121 * ========
122 *
123 *> \author Univ. of Tennessee
124 *> \author Univ. of California Berkeley
125 *> \author Univ. of Colorado Denver
126 *> \author NAG Ltd.
127 *
128 *> \ingroup single_lin
129 *
130 * =====================================================================
131  SUBROUTINE slattr( IMAT, UPLO, TRANS, DIAG, ISEED, N, A, LDA, B,
132  \$ WORK, INFO )
133 *
134 * -- LAPACK test routine --
135 * -- LAPACK is a software package provided by Univ. of Tennessee, --
136 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
137 *
138 * .. Scalar Arguments ..
139  CHARACTER DIAG, TRANS, UPLO
140  INTEGER IMAT, INFO, LDA, N
141 * ..
142 * .. Array Arguments ..
143  INTEGER ISEED( 4 )
144  REAL A( LDA, * ), B( * ), WORK( * )
145 * ..
146 *
147 * =====================================================================
148 *
149 * .. Parameters ..
150  REAL ONE, TWO, ZERO
151  parameter( one = 1.0e+0, two = 2.0e+0, zero = 0.0e+0 )
152 * ..
153 * .. Local Scalars ..
154  LOGICAL UPPER
155  CHARACTER DIST, TYPE
156  CHARACTER*3 PATH
157  INTEGER I, IY, J, JCOUNT, KL, KU, MODE
158  REAL ANORM, BIGNUM, BNORM, BSCAL, C, CNDNUM, PLUS1,
159  \$ plus2, ra, rb, rexp, s, sfac, smlnum, star1,
160  \$ texp, tleft, tscal, ulp, unfl, x, y, z
161 * ..
162 * .. External Functions ..
163  LOGICAL LSAME
164  INTEGER ISAMAX
165  REAL SLAMCH, SLARND
166  EXTERNAL lsame, isamax, slamch, slarnd
167 * ..
168 * .. External Subroutines ..
169  EXTERNAL scopy, slabad, slarnv, slatb4, slatms, srot,
170  \$ srotg, sscal, sswap
171 * ..
172 * .. Intrinsic Functions ..
173  INTRINSIC abs, max, real, sign, sqrt
174 * ..
175 * .. Executable Statements ..
176 *
177  path( 1: 1 ) = 'Single precision'
178  path( 2: 3 ) = 'TR'
179  unfl = slamch( 'Safe minimum' )
180  ulp = slamch( 'Epsilon' )*slamch( 'Base' )
181  smlnum = unfl
182  bignum = ( one-ulp ) / smlnum
183  CALL slabad( smlnum, bignum )
184  IF( ( imat.GE.7 .AND. imat.LE.10 ) .OR. imat.EQ.18 ) THEN
185  diag = 'U'
186  ELSE
187  diag = 'N'
188  END IF
189  info = 0
190 *
191 * Quick return if N.LE.0.
192 *
193  IF( n.LE.0 )
194  \$ RETURN
195 *
196 * Call SLATB4 to set parameters for SLATMS.
197 *
198  upper = lsame( uplo, 'U' )
199  IF( upper ) THEN
200  CALL slatb4( path, imat, n, n, TYPE, kl, ku, anorm, mode,
201  \$ cndnum, dist )
202  ELSE
203  CALL slatb4( path, -imat, n, n, TYPE, kl, ku, anorm, mode,
204  \$ cndnum, dist )
205  END IF
206 *
207 * IMAT <= 6: Non-unit triangular matrix
208 *
209  IF( imat.LE.6 ) THEN
210  CALL slatms( n, n, dist, iseed, TYPE, b, mode, cndnum, anorm,
211  \$ kl, ku, 'No packing', a, lda, work, info )
212 *
213 * IMAT > 6: Unit triangular matrix
214 * The diagonal is deliberately set to something other than 1.
215 *
216 * IMAT = 7: Matrix is the identity
217 *
218  ELSE IF( imat.EQ.7 ) THEN
219  IF( upper ) THEN
220  DO 20 j = 1, n
221  DO 10 i = 1, j - 1
222  a( i, j ) = zero
223  10 CONTINUE
224  a( j, j ) = j
225  20 CONTINUE
226  ELSE
227  DO 40 j = 1, n
228  a( j, j ) = j
229  DO 30 i = j + 1, n
230  a( i, j ) = zero
231  30 CONTINUE
232  40 CONTINUE
233  END IF
234 *
235 * IMAT > 7: Non-trivial unit triangular matrix
236 *
237 * Generate a unit triangular matrix T with condition CNDNUM by
238 * forming a triangular matrix with known singular values and
239 * filling in the zero entries with Givens rotations.
240 *
241  ELSE IF( imat.LE.10 ) THEN
242  IF( upper ) THEN
243  DO 60 j = 1, n
244  DO 50 i = 1, j - 1
245  a( i, j ) = zero
246  50 CONTINUE
247  a( j, j ) = j
248  60 CONTINUE
249  ELSE
250  DO 80 j = 1, n
251  a( j, j ) = j
252  DO 70 i = j + 1, n
253  a( i, j ) = zero
254  70 CONTINUE
255  80 CONTINUE
256  END IF
257 *
258 * Since the trace of a unit triangular matrix is 1, the product
259 * of its singular values must be 1. Let s = sqrt(CNDNUM),
260 * x = sqrt(s) - 1/sqrt(s), y = sqrt(2/(n-2))*x, and z = x**2.
261 * The following triangular matrix has singular values s, 1, 1,
262 * ..., 1, 1/s:
263 *
264 * 1 y y y ... y y z
265 * 1 0 0 ... 0 0 y
266 * 1 0 ... 0 0 y
267 * . ... . . .
268 * . . . .
269 * 1 0 y
270 * 1 y
271 * 1
272 *
273 * To fill in the zeros, we first multiply by a matrix with small
274 * condition number of the form
275 *
276 * 1 0 0 0 0 ...
277 * 1 + * 0 0 ...
278 * 1 + 0 0 0
279 * 1 + * 0 0
280 * 1 + 0 0
281 * ...
282 * 1 + 0
283 * 1 0
284 * 1
285 *
286 * Each element marked with a '*' is formed by taking the product
287 * of the adjacent elements marked with '+'. The '*'s can be
288 * chosen freely, and the '+'s are chosen so that the inverse of
289 * T will have elements of the same magnitude as T. If the *'s in
290 * both T and inv(T) have small magnitude, T is well conditioned.
291 * The two offdiagonals of T are stored in WORK.
292 *
293 * The product of these two matrices has the form
294 *
295 * 1 y y y y y . y y z
296 * 1 + * 0 0 . 0 0 y
297 * 1 + 0 0 . 0 0 y
298 * 1 + * . . . .
299 * 1 + . . . .
300 * . . . . .
301 * . . . .
302 * 1 + y
303 * 1 y
304 * 1
305 *
306 * Now we multiply by Givens rotations, using the fact that
307 *
308 * [ c s ] [ 1 w ] [ -c -s ] = [ 1 -w ]
309 * [ -s c ] [ 0 1 ] [ s -c ] [ 0 1 ]
310 * and
311 * [ -c -s ] [ 1 0 ] [ c s ] = [ 1 0 ]
312 * [ s -c ] [ w 1 ] [ -s c ] [ -w 1 ]
313 *
314 * where c = w / sqrt(w**2+4) and s = 2 / sqrt(w**2+4).
315 *
316  star1 = 0.25
317  sfac = 0.5
318  plus1 = sfac
319  DO 90 j = 1, n, 2
320  plus2 = star1 / plus1
321  work( j ) = plus1
322  work( n+j ) = star1
323  IF( j+1.LE.n ) THEN
324  work( j+1 ) = plus2
325  work( n+j+1 ) = zero
326  plus1 = star1 / plus2
327  rexp = slarnd( 2, iseed )
328  star1 = star1*( sfac**rexp )
329  IF( rexp.LT.zero ) THEN
330  star1 = -sfac**( one-rexp )
331  ELSE
332  star1 = sfac**( one+rexp )
333  END IF
334  END IF
335  90 CONTINUE
336 *
337  x = sqrt( cndnum ) - 1 / sqrt( cndnum )
338  IF( n.GT.2 ) THEN
339  y = sqrt( 2. / ( n-2 ) )*x
340  ELSE
341  y = zero
342  END IF
343  z = x*x
344 *
345  IF( upper ) THEN
346  IF( n.GT.3 ) THEN
347  CALL scopy( n-3, work, 1, a( 2, 3 ), lda+1 )
348  IF( n.GT.4 )
349  \$ CALL scopy( n-4, work( n+1 ), 1, a( 2, 4 ), lda+1 )
350  END IF
351  DO 100 j = 2, n - 1
352  a( 1, j ) = y
353  a( j, n ) = y
354  100 CONTINUE
355  a( 1, n ) = z
356  ELSE
357  IF( n.GT.3 ) THEN
358  CALL scopy( n-3, work, 1, a( 3, 2 ), lda+1 )
359  IF( n.GT.4 )
360  \$ CALL scopy( n-4, work( n+1 ), 1, a( 4, 2 ), lda+1 )
361  END IF
362  DO 110 j = 2, n - 1
363  a( j, 1 ) = y
364  a( n, j ) = y
365  110 CONTINUE
366  a( n, 1 ) = z
367  END IF
368 *
369 * Fill in the zeros using Givens rotations.
370 *
371  IF( upper ) THEN
372  DO 120 j = 1, n - 1
373  ra = a( j, j+1 )
374  rb = 2.0
375  CALL srotg( ra, rb, c, s )
376 *
377 * Multiply by [ c s; -s c] on the left.
378 *
379  IF( n.GT.j+1 )
380  \$ CALL srot( n-j-1, a( j, j+2 ), lda, a( j+1, j+2 ),
381  \$ lda, c, s )
382 *
383 * Multiply by [-c -s; s -c] on the right.
384 *
385  IF( j.GT.1 )
386  \$ CALL srot( j-1, a( 1, j+1 ), 1, a( 1, j ), 1, -c, -s )
387 *
388 * Negate A(J,J+1).
389 *
390  a( j, j+1 ) = -a( j, j+1 )
391  120 CONTINUE
392  ELSE
393  DO 130 j = 1, n - 1
394  ra = a( j+1, j )
395  rb = 2.0
396  CALL srotg( ra, rb, c, s )
397 *
398 * Multiply by [ c -s; s c] on the right.
399 *
400  IF( n.GT.j+1 )
401  \$ CALL srot( n-j-1, a( j+2, j+1 ), 1, a( j+2, j ), 1, c,
402  \$ -s )
403 *
404 * Multiply by [-c s; -s -c] on the left.
405 *
406  IF( j.GT.1 )
407  \$ CALL srot( j-1, a( j, 1 ), lda, a( j+1, 1 ), lda, -c,
408  \$ s )
409 *
410 * Negate A(J+1,J).
411 *
412  a( j+1, j ) = -a( j+1, j )
413  130 CONTINUE
414  END IF
415 *
416 * IMAT > 10: Pathological test cases. These triangular matrices
417 * are badly scaled or badly conditioned, so when used in solving a
418 * triangular system they may cause overflow in the solution vector.
419 *
420  ELSE IF( imat.EQ.11 ) THEN
421 *
422 * Type 11: Generate a triangular matrix with elements between
423 * -1 and 1. Give the diagonal norm 2 to make it well-conditioned.
424 * Make the right hand side large so that it requires scaling.
425 *
426  IF( upper ) THEN
427  DO 140 j = 1, n
428  CALL slarnv( 2, iseed, j, a( 1, j ) )
429  a( j, j ) = sign( two, a( j, j ) )
430  140 CONTINUE
431  ELSE
432  DO 150 j = 1, n
433  CALL slarnv( 2, iseed, n-j+1, a( j, j ) )
434  a( j, j ) = sign( two, a( j, j ) )
435  150 CONTINUE
436  END IF
437 *
438 * Set the right hand side so that the largest value is BIGNUM.
439 *
440  CALL slarnv( 2, iseed, n, b )
441  iy = isamax( n, b, 1 )
442  bnorm = abs( b( iy ) )
443  bscal = bignum / max( one, bnorm )
444  CALL sscal( n, bscal, b, 1 )
445 *
446  ELSE IF( imat.EQ.12 ) THEN
447 *
448 * Type 12: Make the first diagonal element in the solve small to
449 * cause immediate overflow when dividing by T(j,j).
450 * In type 12, the offdiagonal elements are small (CNORM(j) < 1).
451 *
452  CALL slarnv( 2, iseed, n, b )
453  tscal = one / max( one, real( n-1 ) )
454  IF( upper ) THEN
455  DO 160 j = 1, n
456  CALL slarnv( 2, iseed, j, a( 1, j ) )
457  CALL sscal( j-1, tscal, a( 1, j ), 1 )
458  a( j, j ) = sign( one, a( j, j ) )
459  160 CONTINUE
460  a( n, n ) = smlnum*a( n, n )
461  ELSE
462  DO 170 j = 1, n
463  CALL slarnv( 2, iseed, n-j+1, a( j, j ) )
464  IF( n.GT.j )
465  \$ CALL sscal( n-j, tscal, a( j+1, j ), 1 )
466  a( j, j ) = sign( one, a( j, j ) )
467  170 CONTINUE
468  a( 1, 1 ) = smlnum*a( 1, 1 )
469  END IF
470 *
471  ELSE IF( imat.EQ.13 ) THEN
472 *
473 * Type 13: Make the first diagonal element in the solve small to
474 * cause immediate overflow when dividing by T(j,j).
475 * In type 13, the offdiagonal elements are O(1) (CNORM(j) > 1).
476 *
477  CALL slarnv( 2, iseed, n, b )
478  IF( upper ) THEN
479  DO 180 j = 1, n
480  CALL slarnv( 2, iseed, j, a( 1, j ) )
481  a( j, j ) = sign( one, a( j, j ) )
482  180 CONTINUE
483  a( n, n ) = smlnum*a( n, n )
484  ELSE
485  DO 190 j = 1, n
486  CALL slarnv( 2, iseed, n-j+1, a( j, j ) )
487  a( j, j ) = sign( one, a( j, j ) )
488  190 CONTINUE
489  a( 1, 1 ) = smlnum*a( 1, 1 )
490  END IF
491 *
492  ELSE IF( imat.EQ.14 ) THEN
493 *
494 * Type 14: T is diagonal with small numbers on the diagonal to
495 * make the growth factor underflow, but a small right hand side
496 * chosen so that the solution does not overflow.
497 *
498  IF( upper ) THEN
499  jcount = 1
500  DO 210 j = n, 1, -1
501  DO 200 i = 1, j - 1
502  a( i, j ) = zero
503  200 CONTINUE
504  IF( jcount.LE.2 ) THEN
505  a( j, j ) = smlnum
506  ELSE
507  a( j, j ) = one
508  END IF
509  jcount = jcount + 1
510  IF( jcount.GT.4 )
511  \$ jcount = 1
512  210 CONTINUE
513  ELSE
514  jcount = 1
515  DO 230 j = 1, n
516  DO 220 i = j + 1, n
517  a( i, j ) = zero
518  220 CONTINUE
519  IF( jcount.LE.2 ) THEN
520  a( j, j ) = smlnum
521  ELSE
522  a( j, j ) = one
523  END IF
524  jcount = jcount + 1
525  IF( jcount.GT.4 )
526  \$ jcount = 1
527  230 CONTINUE
528  END IF
529 *
530 * Set the right hand side alternately zero and small.
531 *
532  IF( upper ) THEN
533  b( 1 ) = zero
534  DO 240 i = n, 2, -2
535  b( i ) = zero
536  b( i-1 ) = smlnum
537  240 CONTINUE
538  ELSE
539  b( n ) = zero
540  DO 250 i = 1, n - 1, 2
541  b( i ) = zero
542  b( i+1 ) = smlnum
543  250 CONTINUE
544  END IF
545 *
546  ELSE IF( imat.EQ.15 ) THEN
547 *
548 * Type 15: Make the diagonal elements small to cause gradual
549 * overflow when dividing by T(j,j). To control the amount of
550 * scaling needed, the matrix is bidiagonal.
551 *
552  texp = one / max( one, real( n-1 ) )
553  tscal = smlnum**texp
554  CALL slarnv( 2, iseed, n, b )
555  IF( upper ) THEN
556  DO 270 j = 1, n
557  DO 260 i = 1, j - 2
558  a( i, j ) = 0.
559  260 CONTINUE
560  IF( j.GT.1 )
561  \$ a( j-1, j ) = -one
562  a( j, j ) = tscal
563  270 CONTINUE
564  b( n ) = one
565  ELSE
566  DO 290 j = 1, n
567  DO 280 i = j + 2, n
568  a( i, j ) = 0.
569  280 CONTINUE
570  IF( j.LT.n )
571  \$ a( j+1, j ) = -one
572  a( j, j ) = tscal
573  290 CONTINUE
574  b( 1 ) = one
575  END IF
576 *
577  ELSE IF( imat.EQ.16 ) THEN
578 *
579 * Type 16: One zero diagonal element.
580 *
581  iy = n / 2 + 1
582  IF( upper ) THEN
583  DO 300 j = 1, n
584  CALL slarnv( 2, iseed, j, a( 1, j ) )
585  IF( j.NE.iy ) THEN
586  a( j, j ) = sign( two, a( j, j ) )
587  ELSE
588  a( j, j ) = zero
589  END IF
590  300 CONTINUE
591  ELSE
592  DO 310 j = 1, n
593  CALL slarnv( 2, iseed, n-j+1, a( j, j ) )
594  IF( j.NE.iy ) THEN
595  a( j, j ) = sign( two, a( j, j ) )
596  ELSE
597  a( j, j ) = zero
598  END IF
599  310 CONTINUE
600  END IF
601  CALL slarnv( 2, iseed, n, b )
602  CALL sscal( n, two, b, 1 )
603 *
604  ELSE IF( imat.EQ.17 ) THEN
605 *
606 * Type 17: Make the offdiagonal elements large to cause overflow
607 * when adding a column of T. In the non-transposed case, the
608 * matrix is constructed to cause overflow when adding a column in
609 * every other step.
610 *
611  tscal = unfl / ulp
612  tscal = ( one-ulp ) / tscal
613  DO 330 j = 1, n
614  DO 320 i = 1, n
615  a( i, j ) = 0.
616  320 CONTINUE
617  330 CONTINUE
618  texp = one
619  IF( upper ) THEN
620  DO 340 j = n, 2, -2
621  a( 1, j ) = -tscal / real( n+1 )
622  a( j, j ) = one
623  b( j ) = texp*( one-ulp )
624  a( 1, j-1 ) = -( tscal / real( n+1 ) ) / real( n+2 )
625  a( j-1, j-1 ) = one
626  b( j-1 ) = texp*real( n*n+n-1 )
627  texp = texp*2.
628  340 CONTINUE
629  b( 1 ) = ( real( n+1 ) / real( n+2 ) )*tscal
630  ELSE
631  DO 350 j = 1, n - 1, 2
632  a( n, j ) = -tscal / real( n+1 )
633  a( j, j ) = one
634  b( j ) = texp*( one-ulp )
635  a( n, j+1 ) = -( tscal / real( n+1 ) ) / real( n+2 )
636  a( j+1, j+1 ) = one
637  b( j+1 ) = texp*real( n*n+n-1 )
638  texp = texp*2.
639  350 CONTINUE
640  b( n ) = ( real( n+1 ) / real( n+2 ) )*tscal
641  END IF
642 *
643  ELSE IF( imat.EQ.18 ) THEN
644 *
645 * Type 18: Generate a unit triangular matrix with elements
646 * between -1 and 1, and make the right hand side large so that it
647 * requires scaling.
648 *
649  IF( upper ) THEN
650  DO 360 j = 1, n
651  CALL slarnv( 2, iseed, j-1, a( 1, j ) )
652  a( j, j ) = zero
653  360 CONTINUE
654  ELSE
655  DO 370 j = 1, n
656  IF( j.LT.n )
657  \$ CALL slarnv( 2, iseed, n-j, a( j+1, j ) )
658  a( j, j ) = zero
659  370 CONTINUE
660  END IF
661 *
662 * Set the right hand side so that the largest value is BIGNUM.
663 *
664  CALL slarnv( 2, iseed, n, b )
665  iy = isamax( n, b, 1 )
666  bnorm = abs( b( iy ) )
667  bscal = bignum / max( one, bnorm )
668  CALL sscal( n, bscal, b, 1 )
669 *
670  ELSE IF( imat.EQ.19 ) THEN
671 *
672 * Type 19: Generate a triangular matrix with elements between
673 * BIGNUM/(n-1) and BIGNUM so that at least one of the column
674 * norms will exceed BIGNUM.
675 * 1/3/91: SLATRS no longer can handle this case
676 *
677  tleft = bignum / max( one, real( n-1 ) )
678  tscal = bignum*( real( n-1 ) / max( one, real( n ) ) )
679  IF( upper ) THEN
680  DO 390 j = 1, n
681  CALL slarnv( 2, iseed, j, a( 1, j ) )
682  DO 380 i = 1, j
683  a( i, j ) = sign( tleft, a( i, j ) ) + tscal*a( i, j )
684  380 CONTINUE
685  390 CONTINUE
686  ELSE
687  DO 410 j = 1, n
688  CALL slarnv( 2, iseed, n-j+1, a( j, j ) )
689  DO 400 i = j, n
690  a( i, j ) = sign( tleft, a( i, j ) ) + tscal*a( i, j )
691  400 CONTINUE
692  410 CONTINUE
693  END IF
694  CALL slarnv( 2, iseed, n, b )
695  CALL sscal( n, two, b, 1 )
696  END IF
697 *
698 * Flip the matrix if the transpose will be used.
699 *
700  IF( .NOT.lsame( trans, 'N' ) ) THEN
701  IF( upper ) THEN
702  DO 420 j = 1, n / 2
703  CALL sswap( n-2*j+1, a( j, j ), lda, a( j+1, n-j+1 ),
704  \$ -1 )
705  420 CONTINUE
706  ELSE
707  DO 430 j = 1, n / 2
708  CALL sswap( n-2*j+1, a( j, j ), 1, a( n-j+1, j+1 ),
709  \$ -lda )
710  430 CONTINUE
711  END IF
712  END IF
713 *
714  RETURN
715 *
716 * End of SLATTR
717 *
718  END
subroutine slarnv(IDIST, ISEED, N, X)
SLARNV returns a vector of random numbers from a uniform or normal distribution.
Definition: slarnv.f:97
subroutine slatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
SLATMS
Definition: slatms.f:321
subroutine sswap(N, SX, INCX, SY, INCY)
SSWAP
Definition: sswap.f:82
subroutine srot(N, SX, INCX, SY, INCY, C, S)
SROT
Definition: srot.f:92
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY
Definition: scopy.f:82
subroutine sscal(N, SA, SX, INCX)
SSCAL
Definition: sscal.f:79
subroutine srotg(a, b, c, s)
SROTG
Definition: srotg.f90:93
subroutine slatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
SLATB4
Definition: slatb4.f:120
subroutine slattr(IMAT, UPLO, TRANS, DIAG, ISEED, N, A, LDA, B, WORK, INFO)
SLATTR
Definition: slattr.f:133