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