OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
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.LE. IF( N0 )
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.LE. IF( IMAT6 ) 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.EQ. ELSE IF( IMAT7 ) 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.LE. ELSE IF( IMAT10 ) 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.LE. IF( J+1N ) 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.LT. IF( REXPZERO ) 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.GT. IF( N2 ) 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.GT. IF( N3 ) THEN
347 CALL SCOPY( N-3, WORK, 1, A( 2, 3 ), LDA+1 )
348.GT. IF( N4 )
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.GT. IF( N3 ) THEN
358 CALL SCOPY( N-3, WORK, 1, A( 3, 2 ), LDA+1 )
359.GT. IF( N4 )
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.GT. IF( NJ+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.GT. IF( J1 )
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.GT. IF( NJ+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.GT. IF( J1 )
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.EQ. ELSE IF( IMAT11 ) 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.EQ. ELSE IF( IMAT12 ) 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.GT. IF( NJ )
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.EQ. ELSE IF( IMAT13 ) 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.EQ. ELSE IF( IMAT14 ) 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.LE. IF( JCOUNT2 ) THEN
505 A( J, J ) = SMLNUM
506 ELSE
507 A( J, J ) = ONE
508 END IF
509 JCOUNT = JCOUNT + 1
510.GT. IF( JCOUNT4 )
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.LE. IF( JCOUNT2 ) THEN
520 A( J, J ) = SMLNUM
521 ELSE
522 A( J, J ) = ONE
523 END IF
524 JCOUNT = JCOUNT + 1
525.GT. IF( JCOUNT4 )
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.EQ. ELSE IF( IMAT15 ) 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.GT. IF( J1 )
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.LT. IF( JN )
571 $ A( J+1, J ) = -ONE
572 A( J, J ) = TSCAL
573 290 CONTINUE
574 B( 1 ) = ONE
575 END IF
576*
577.EQ. ELSE IF( IMAT16 ) 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.NE. IF( JIY ) 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.NE. IF( JIY ) 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.EQ. ELSE IF( IMAT17 ) 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.EQ. ELSE IF( IMAT18 ) 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.LT. IF( JN )
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.EQ. ELSE IF( IMAT19 ) 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.NOT. IF( 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
slarnv
subroutine slarnv(idist, iseed, n, x)
SLARNV returns a vector of random numbers from a uniform or normal distribution.
Definition slarnv.f:97
slabad
subroutine slabad(small, large)
SLABAD
Definition slabad.f:74
slatms
subroutine slatms(m, n, dist, iseed, sym, d, mode, cond, dmax, kl, ku, pack, a, lda, work, info)
SLATMS
Definition slatms.f:321
sscal
subroutine sscal(n, sa, sx, incx)
SSCAL
Definition sscal.f:79
srot
subroutine srot(n, sx, incx, sy, incy, c, s)
SROT
Definition srot.f:92
srotg
subroutine srotg(a, b, c, s)
SROTG
Definition srotg.f90:93
scopy
subroutine scopy(n, sx, incx, sy, incy)
SCOPY
Definition scopy.f:82
sswap
subroutine sswap(n, sx, incx, sy, incy)
SSWAP
Definition sswap.f:82
slattr
subroutine slattr(imat, uplo, trans, diag, iseed, n, a, lda, b, work, info)
SLATTR
Definition slattr.f:133
slatb4
subroutine slatb4(path, imat, m, n, type, kl, ku, anorm, mode, cndnum, dist)
SLATB4
Definition slatb4.f:120
max
#define max(a, b)
Definition macros.h:21