LAPACK  3.7.1
LAPACK: Linear Algebra PACKage
dlattp.f
Go to the documentation of this file.
1 *> \brief \b DLATTP
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 DLATTP( IMAT, UPLO, TRANS, DIAG, ISEED, N, A, B, WORK,
12 * INFO )
13 *
14 * .. Scalar Arguments ..
15 * CHARACTER DIAG, TRANS, UPLO
16 * INTEGER IMAT, INFO, N
17 * ..
18 * .. Array Arguments ..
19 * INTEGER ISEED( 4 )
20 * DOUBLE PRECISION A( * ), B( * ), WORK( * )
21 * ..
22 *
23 *
24 *> \par Purpose:
25 * =============
26 *>
27 *> \verbatim
28 *>
29 *> DLATTP generates a triangular test matrix in packed storage.
30 *> IMAT and UPLO uniquely specify the properties of the test
31 *> matrix, which is returned in the array AP.
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 *> DLATMS). 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 DOUBLE PRECISION array, dimension (N*(N+1)/2)
86 *> The upper or lower triangular matrix A, packed columnwise in
87 *> a linear array. The j-th column of A is stored in the array
88 *> AP as follows:
89 *> if UPLO = 'U', AP((j-1)*j/2 + i) = A(i,j) for 1<=i<=j;
90 *> if UPLO = 'L',
91 *> AP((j-1)*(n-j) + j*(j+1)/2 + i-j) = A(i,j) for j<=i<=n.
92 *> \endverbatim
93 *>
94 *> \param[out] B
95 *> \verbatim
96 *> B is DOUBLE PRECISION array, dimension (N)
97 *> The right hand side vector, if IMAT > 10.
98 *> \endverbatim
99 *>
100 *> \param[out] WORK
101 *> \verbatim
102 *> WORK is DOUBLE PRECISION array, dimension (3*N)
103 *> \endverbatim
104 *>
105 *> \param[out] INFO
106 *> \verbatim
107 *> INFO is INTEGER
108 *> = 0: successful exit
109 *> < 0: if INFO = -k, the k-th argument had an illegal value
110 *> \endverbatim
111 *
112 * Authors:
113 * ========
114 *
115 *> \author Univ. of Tennessee
116 *> \author Univ. of California Berkeley
117 *> \author Univ. of Colorado Denver
118 *> \author NAG Ltd.
119 *
120 *> \date December 2016
121 *
122 *> \ingroup double_lin
123 *
124 * =====================================================================
125  SUBROUTINE dlattp( IMAT, UPLO, TRANS, DIAG, ISEED, N, A, B, WORK,
126  $ INFO )
127 *
128 * -- LAPACK test routine (version 3.7.0) --
129 * -- LAPACK is a software package provided by Univ. of Tennessee, --
130 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
131 * December 2016
132 *
133 * .. Scalar Arguments ..
134  CHARACTER DIAG, TRANS, UPLO
135  INTEGER IMAT, INFO, N
136 * ..
137 * .. Array Arguments ..
138  INTEGER ISEED( 4 )
139  DOUBLE PRECISION A( * ), B( * ), WORK( * )
140 * ..
141 *
142 * =====================================================================
143 *
144 * .. Parameters ..
145  DOUBLE PRECISION ONE, TWO, ZERO
146  parameter( one = 1.0d+0, two = 2.0d+0, zero = 0.0d+0 )
147 * ..
148 * .. Local Scalars ..
149  LOGICAL UPPER
150  CHARACTER DIST, PACKIT, TYPE
151  CHARACTER*3 PATH
152  INTEGER I, IY, J, JC, JCNEXT, JCOUNT, JJ, JL, JR, JX,
153  $ kl, ku, mode
154  DOUBLE PRECISION ANORM, BIGNUM, BNORM, BSCAL, C, CNDNUM, PLUS1,
155  $ plus2, ra, rb, rexp, s, sfac, smlnum, star1,
156  $ stemp, t, texp, tleft, tscal, ulp, unfl, x, y,
157  $ z
158 * ..
159 * .. External Functions ..
160  LOGICAL LSAME
161  INTEGER IDAMAX
162  DOUBLE PRECISION DLAMCH, DLARND
163  EXTERNAL lsame, idamax, dlamch, dlarnd
164 * ..
165 * .. External Subroutines ..
166  EXTERNAL dlabad, dlarnv, dlatb4, dlatms, drot, drotg,
167  $ dscal
168 * ..
169 * .. Intrinsic Functions ..
170  INTRINSIC abs, dble, max, sign, sqrt
171 * ..
172 * .. Executable Statements ..
173 *
174  path( 1: 1 ) = 'Double precision'
175  path( 2: 3 ) = 'TP'
176  unfl = dlamch( 'Safe minimum' )
177  ulp = dlamch( 'Epsilon' )*dlamch( 'Base' )
178  smlnum = unfl
179  bignum = ( one-ulp ) / smlnum
180  CALL dlabad( smlnum, bignum )
181  IF( ( imat.GE.7 .AND. imat.LE.10 ) .OR. imat.EQ.18 ) THEN
182  diag = 'U'
183  ELSE
184  diag = 'N'
185  END IF
186  info = 0
187 *
188 * Quick return if N.LE.0.
189 *
190  IF( n.LE.0 )
191  $ RETURN
192 *
193 * Call DLATB4 to set parameters for SLATMS.
194 *
195  upper = lsame( uplo, 'U' )
196  IF( upper ) THEN
197  CALL dlatb4( path, imat, n, n, TYPE, KL, KU, ANORM, MODE,
198  $ cndnum, dist )
199  packit = 'C'
200  ELSE
201  CALL dlatb4( path, -imat, n, n, TYPE, KL, KU, ANORM, MODE,
202  $ cndnum, dist )
203  packit = 'R'
204  END IF
205 *
206 * IMAT <= 6: Non-unit triangular matrix
207 *
208  IF( imat.LE.6 ) THEN
209  CALL dlatms( n, n, dist, iseed, TYPE, B, MODE, CNDNUM, ANORM,
210  $ kl, ku, packit, a, n, work, info )
211 *
212 * IMAT > 6: Unit triangular matrix
213 * The diagonal is deliberately set to something other than 1.
214 *
215 * IMAT = 7: Matrix is the identity
216 *
217  ELSE IF( imat.EQ.7 ) THEN
218  IF( upper ) THEN
219  jc = 1
220  DO 20 j = 1, n
221  DO 10 i = 1, j - 1
222  a( jc+i-1 ) = zero
223  10 CONTINUE
224  a( jc+j-1 ) = j
225  jc = jc + j
226  20 CONTINUE
227  ELSE
228  jc = 1
229  DO 40 j = 1, n
230  a( jc ) = j
231  DO 30 i = j + 1, n
232  a( jc+i-j ) = zero
233  30 CONTINUE
234  jc = jc + n - j + 1
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  jc = 0
247  DO 60 j = 1, n
248  DO 50 i = 1, j - 1
249  a( jc+i ) = zero
250  50 CONTINUE
251  a( jc+j ) = j
252  jc = jc + j
253  60 CONTINUE
254  ELSE
255  jc = 1
256  DO 80 j = 1, n
257  a( jc ) = j
258  DO 70 i = j + 1, n
259  a( jc+i-j ) = zero
260  70 CONTINUE
261  jc = jc + n - j + 1
262  80 CONTINUE
263  END IF
264 *
265 * Since the trace of a unit triangular matrix is 1, the product
266 * of its singular values must be 1. Let s = sqrt(CNDNUM),
267 * x = sqrt(s) - 1/sqrt(s), y = sqrt(2/(n-2))*x, and z = x**2.
268 * The following triangular matrix has singular values s, 1, 1,
269 * ..., 1, 1/s:
270 *
271 * 1 y y y ... y y z
272 * 1 0 0 ... 0 0 y
273 * 1 0 ... 0 0 y
274 * . ... . . .
275 * . . . .
276 * 1 0 y
277 * 1 y
278 * 1
279 *
280 * To fill in the zeros, we first multiply by a matrix with small
281 * condition number of the form
282 *
283 * 1 0 0 0 0 ...
284 * 1 + * 0 0 ...
285 * 1 + 0 0 0
286 * 1 + * 0 0
287 * 1 + 0 0
288 * ...
289 * 1 + 0
290 * 1 0
291 * 1
292 *
293 * Each element marked with a '*' is formed by taking the product
294 * of the adjacent elements marked with '+'. The '*'s can be
295 * chosen freely, and the '+'s are chosen so that the inverse of
296 * T will have elements of the same magnitude as T. If the *'s in
297 * both T and inv(T) have small magnitude, T is well conditioned.
298 * The two offdiagonals of T are stored in WORK.
299 *
300 * The product of these two matrices has the form
301 *
302 * 1 y y y y y . y y z
303 * 1 + * 0 0 . 0 0 y
304 * 1 + 0 0 . 0 0 y
305 * 1 + * . . . .
306 * 1 + . . . .
307 * . . . . .
308 * . . . .
309 * 1 + y
310 * 1 y
311 * 1
312 *
313 * Now we multiply by Givens rotations, using the fact that
314 *
315 * [ c s ] [ 1 w ] [ -c -s ] = [ 1 -w ]
316 * [ -s c ] [ 0 1 ] [ s -c ] [ 0 1 ]
317 * and
318 * [ -c -s ] [ 1 0 ] [ c s ] = [ 1 0 ]
319 * [ s -c ] [ w 1 ] [ -s c ] [ -w 1 ]
320 *
321 * where c = w / sqrt(w**2+4) and s = 2 / sqrt(w**2+4).
322 *
323  star1 = 0.25d0
324  sfac = 0.5d0
325  plus1 = sfac
326  DO 90 j = 1, n, 2
327  plus2 = star1 / plus1
328  work( j ) = plus1
329  work( n+j ) = star1
330  IF( j+1.LE.n ) THEN
331  work( j+1 ) = plus2
332  work( n+j+1 ) = zero
333  plus1 = star1 / plus2
334  rexp = dlarnd( 2, iseed )
335  star1 = star1*( sfac**rexp )
336  IF( rexp.LT.zero ) THEN
337  star1 = -sfac**( one-rexp )
338  ELSE
339  star1 = sfac**( one+rexp )
340  END IF
341  END IF
342  90 CONTINUE
343 *
344  x = sqrt( cndnum ) - one / sqrt( cndnum )
345  IF( n.GT.2 ) THEN
346  y = sqrt( two / dble( n-2 ) )*x
347  ELSE
348  y = zero
349  END IF
350  z = x*x
351 *
352  IF( upper ) THEN
353 *
354 * Set the upper triangle of A with a unit triangular matrix
355 * of known condition number.
356 *
357  jc = 1
358  DO 100 j = 2, n
359  a( jc+1 ) = y
360  IF( j.GT.2 )
361  $ a( jc+j-1 ) = work( j-2 )
362  IF( j.GT.3 )
363  $ a( jc+j-2 ) = work( n+j-3 )
364  jc = jc + j
365  100 CONTINUE
366  jc = jc - n
367  a( jc+1 ) = z
368  DO 110 j = 2, n - 1
369  a( jc+j ) = y
370  110 CONTINUE
371  ELSE
372 *
373 * Set the lower triangle of A with a unit triangular matrix
374 * of known condition number.
375 *
376  DO 120 i = 2, n - 1
377  a( i ) = y
378  120 CONTINUE
379  a( n ) = z
380  jc = n + 1
381  DO 130 j = 2, n - 1
382  a( jc+1 ) = work( j-1 )
383  IF( j.LT.n-1 )
384  $ a( jc+2 ) = work( n+j-1 )
385  a( jc+n-j ) = y
386  jc = jc + n - j + 1
387  130 CONTINUE
388  END IF
389 *
390 * Fill in the zeros using Givens rotations
391 *
392  IF( upper ) THEN
393  jc = 1
394  DO 150 j = 1, n - 1
395  jcnext = jc + j
396  ra = a( jcnext+j-1 )
397  rb = two
398  CALL drotg( ra, rb, c, s )
399 *
400 * Multiply by [ c s; -s c] on the left.
401 *
402  IF( n.GT.j+1 ) THEN
403  jx = jcnext + j
404  DO 140 i = j + 2, n
405  stemp = c*a( jx+j ) + s*a( jx+j+1 )
406  a( jx+j+1 ) = -s*a( jx+j ) + c*a( jx+j+1 )
407  a( jx+j ) = stemp
408  jx = jx + i
409  140 CONTINUE
410  END IF
411 *
412 * Multiply by [-c -s; s -c] on the right.
413 *
414  IF( j.GT.1 )
415  $ CALL drot( j-1, a( jcnext ), 1, a( jc ), 1, -c, -s )
416 *
417 * Negate A(J,J+1).
418 *
419  a( jcnext+j-1 ) = -a( jcnext+j-1 )
420  jc = jcnext
421  150 CONTINUE
422  ELSE
423  jc = 1
424  DO 170 j = 1, n - 1
425  jcnext = jc + n - j + 1
426  ra = a( jc+1 )
427  rb = two
428  CALL drotg( ra, rb, c, s )
429 *
430 * Multiply by [ c -s; s c] on the right.
431 *
432  IF( n.GT.j+1 )
433  $ CALL drot( n-j-1, a( jcnext+1 ), 1, a( jc+2 ), 1, c,
434  $ -s )
435 *
436 * Multiply by [-c s; -s -c] on the left.
437 *
438  IF( j.GT.1 ) THEN
439  jx = 1
440  DO 160 i = 1, j - 1
441  stemp = -c*a( jx+j-i ) + s*a( jx+j-i+1 )
442  a( jx+j-i+1 ) = -s*a( jx+j-i ) - c*a( jx+j-i+1 )
443  a( jx+j-i ) = stemp
444  jx = jx + n - i + 1
445  160 CONTINUE
446  END IF
447 *
448 * Negate A(J+1,J).
449 *
450  a( jc+1 ) = -a( jc+1 )
451  jc = jcnext
452  170 CONTINUE
453  END IF
454 *
455 * IMAT > 10: Pathological test cases. These triangular matrices
456 * are badly scaled or badly conditioned, so when used in solving a
457 * triangular system they may cause overflow in the solution vector.
458 *
459  ELSE IF( imat.EQ.11 ) THEN
460 *
461 * Type 11: Generate a triangular matrix with elements between
462 * -1 and 1. Give the diagonal norm 2 to make it well-conditioned.
463 * Make the right hand side large so that it requires scaling.
464 *
465  IF( upper ) THEN
466  jc = 1
467  DO 180 j = 1, n
468  CALL dlarnv( 2, iseed, j, a( jc ) )
469  a( jc+j-1 ) = sign( two, a( jc+j-1 ) )
470  jc = jc + j
471  180 CONTINUE
472  ELSE
473  jc = 1
474  DO 190 j = 1, n
475  CALL dlarnv( 2, iseed, n-j+1, a( jc ) )
476  a( jc ) = sign( two, a( jc ) )
477  jc = jc + n - j + 1
478  190 CONTINUE
479  END IF
480 *
481 * Set the right hand side so that the largest value is BIGNUM.
482 *
483  CALL dlarnv( 2, iseed, n, b )
484  iy = idamax( n, b, 1 )
485  bnorm = abs( b( iy ) )
486  bscal = bignum / max( one, bnorm )
487  CALL dscal( n, bscal, b, 1 )
488 *
489  ELSE IF( imat.EQ.12 ) THEN
490 *
491 * Type 12: Make the first diagonal element in the solve small to
492 * cause immediate overflow when dividing by T(j,j).
493 * In type 12, the offdiagonal elements are small (CNORM(j) < 1).
494 *
495  CALL dlarnv( 2, iseed, n, b )
496  tscal = one / max( one, dble( n-1 ) )
497  IF( upper ) THEN
498  jc = 1
499  DO 200 j = 1, n
500  CALL dlarnv( 2, iseed, j-1, a( jc ) )
501  CALL dscal( j-1, tscal, a( jc ), 1 )
502  a( jc+j-1 ) = sign( one, dlarnd( 2, iseed ) )
503  jc = jc + j
504  200 CONTINUE
505  a( n*( n+1 ) / 2 ) = smlnum
506  ELSE
507  jc = 1
508  DO 210 j = 1, n
509  CALL dlarnv( 2, iseed, n-j, a( jc+1 ) )
510  CALL dscal( n-j, tscal, a( jc+1 ), 1 )
511  a( jc ) = sign( one, dlarnd( 2, iseed ) )
512  jc = jc + n - j + 1
513  210 CONTINUE
514  a( 1 ) = smlnum
515  END IF
516 *
517  ELSE IF( imat.EQ.13 ) THEN
518 *
519 * Type 13: Make the first diagonal element in the solve small to
520 * cause immediate overflow when dividing by T(j,j).
521 * In type 13, the offdiagonal elements are O(1) (CNORM(j) > 1).
522 *
523  CALL dlarnv( 2, iseed, n, b )
524  IF( upper ) THEN
525  jc = 1
526  DO 220 j = 1, n
527  CALL dlarnv( 2, iseed, j-1, a( jc ) )
528  a( jc+j-1 ) = sign( one, dlarnd( 2, iseed ) )
529  jc = jc + j
530  220 CONTINUE
531  a( n*( n+1 ) / 2 ) = smlnum
532  ELSE
533  jc = 1
534  DO 230 j = 1, n
535  CALL dlarnv( 2, iseed, n-j, a( jc+1 ) )
536  a( jc ) = sign( one, dlarnd( 2, iseed ) )
537  jc = jc + n - j + 1
538  230 CONTINUE
539  a( 1 ) = smlnum
540  END IF
541 *
542  ELSE IF( imat.EQ.14 ) THEN
543 *
544 * Type 14: T is diagonal with small numbers on the diagonal to
545 * make the growth factor underflow, but a small right hand side
546 * chosen so that the solution does not overflow.
547 *
548  IF( upper ) THEN
549  jcount = 1
550  jc = ( n-1 )*n / 2 + 1
551  DO 250 j = n, 1, -1
552  DO 240 i = 1, j - 1
553  a( jc+i-1 ) = zero
554  240 CONTINUE
555  IF( jcount.LE.2 ) THEN
556  a( jc+j-1 ) = smlnum
557  ELSE
558  a( jc+j-1 ) = one
559  END IF
560  jcount = jcount + 1
561  IF( jcount.GT.4 )
562  $ jcount = 1
563  jc = jc - j + 1
564  250 CONTINUE
565  ELSE
566  jcount = 1
567  jc = 1
568  DO 270 j = 1, n
569  DO 260 i = j + 1, n
570  a( jc+i-j ) = zero
571  260 CONTINUE
572  IF( jcount.LE.2 ) THEN
573  a( jc ) = smlnum
574  ELSE
575  a( jc ) = one
576  END IF
577  jcount = jcount + 1
578  IF( jcount.GT.4 )
579  $ jcount = 1
580  jc = jc + n - j + 1
581  270 CONTINUE
582  END IF
583 *
584 * Set the right hand side alternately zero and small.
585 *
586  IF( upper ) THEN
587  b( 1 ) = zero
588  DO 280 i = n, 2, -2
589  b( i ) = zero
590  b( i-1 ) = smlnum
591  280 CONTINUE
592  ELSE
593  b( n ) = zero
594  DO 290 i = 1, n - 1, 2
595  b( i ) = zero
596  b( i+1 ) = smlnum
597  290 CONTINUE
598  END IF
599 *
600  ELSE IF( imat.EQ.15 ) THEN
601 *
602 * Type 15: Make the diagonal elements small to cause gradual
603 * overflow when dividing by T(j,j). To control the amount of
604 * scaling needed, the matrix is bidiagonal.
605 *
606  texp = one / max( one, dble( n-1 ) )
607  tscal = smlnum**texp
608  CALL dlarnv( 2, iseed, n, b )
609  IF( upper ) THEN
610  jc = 1
611  DO 310 j = 1, n
612  DO 300 i = 1, j - 2
613  a( jc+i-1 ) = zero
614  300 CONTINUE
615  IF( j.GT.1 )
616  $ a( jc+j-2 ) = -one
617  a( jc+j-1 ) = tscal
618  jc = jc + j
619  310 CONTINUE
620  b( n ) = one
621  ELSE
622  jc = 1
623  DO 330 j = 1, n
624  DO 320 i = j + 2, n
625  a( jc+i-j ) = zero
626  320 CONTINUE
627  IF( j.LT.n )
628  $ a( jc+1 ) = -one
629  a( jc ) = tscal
630  jc = jc + n - j + 1
631  330 CONTINUE
632  b( 1 ) = one
633  END IF
634 *
635  ELSE IF( imat.EQ.16 ) THEN
636 *
637 * Type 16: One zero diagonal element.
638 *
639  iy = n / 2 + 1
640  IF( upper ) THEN
641  jc = 1
642  DO 340 j = 1, n
643  CALL dlarnv( 2, iseed, j, a( jc ) )
644  IF( j.NE.iy ) THEN
645  a( jc+j-1 ) = sign( two, a( jc+j-1 ) )
646  ELSE
647  a( jc+j-1 ) = zero
648  END IF
649  jc = jc + j
650  340 CONTINUE
651  ELSE
652  jc = 1
653  DO 350 j = 1, n
654  CALL dlarnv( 2, iseed, n-j+1, a( jc ) )
655  IF( j.NE.iy ) THEN
656  a( jc ) = sign( two, a( jc ) )
657  ELSE
658  a( jc ) = zero
659  END IF
660  jc = jc + n - j + 1
661  350 CONTINUE
662  END IF
663  CALL dlarnv( 2, iseed, n, b )
664  CALL dscal( n, two, b, 1 )
665 *
666  ELSE IF( imat.EQ.17 ) THEN
667 *
668 * Type 17: Make the offdiagonal elements large to cause overflow
669 * when adding a column of T. In the non-transposed case, the
670 * matrix is constructed to cause overflow when adding a column in
671 * every other step.
672 *
673  tscal = unfl / ulp
674  tscal = ( one-ulp ) / tscal
675  DO 360 j = 1, n*( n+1 ) / 2
676  a( j ) = zero
677  360 CONTINUE
678  texp = one
679  IF( upper ) THEN
680  jc = ( n-1 )*n / 2 + 1
681  DO 370 j = n, 2, -2
682  a( jc ) = -tscal / dble( n+1 )
683  a( jc+j-1 ) = one
684  b( j ) = texp*( one-ulp )
685  jc = jc - j + 1
686  a( jc ) = -( tscal / dble( n+1 ) ) / dble( n+2 )
687  a( jc+j-2 ) = one
688  b( j-1 ) = texp*dble( n*n+n-1 )
689  texp = texp*two
690  jc = jc - j + 2
691  370 CONTINUE
692  b( 1 ) = ( dble( n+1 ) / dble( n+2 ) )*tscal
693  ELSE
694  jc = 1
695  DO 380 j = 1, n - 1, 2
696  a( jc+n-j ) = -tscal / dble( n+1 )
697  a( jc ) = one
698  b( j ) = texp*( one-ulp )
699  jc = jc + n - j + 1
700  a( jc+n-j-1 ) = -( tscal / dble( n+1 ) ) / dble( n+2 )
701  a( jc ) = one
702  b( j+1 ) = texp*dble( n*n+n-1 )
703  texp = texp*two
704  jc = jc + n - j
705  380 CONTINUE
706  b( n ) = ( dble( n+1 ) / dble( n+2 ) )*tscal
707  END IF
708 *
709  ELSE IF( imat.EQ.18 ) THEN
710 *
711 * Type 18: Generate a unit triangular matrix with elements
712 * between -1 and 1, and make the right hand side large so that it
713 * requires scaling.
714 *
715  IF( upper ) THEN
716  jc = 1
717  DO 390 j = 1, n
718  CALL dlarnv( 2, iseed, j-1, a( jc ) )
719  a( jc+j-1 ) = zero
720  jc = jc + j
721  390 CONTINUE
722  ELSE
723  jc = 1
724  DO 400 j = 1, n
725  IF( j.LT.n )
726  $ CALL dlarnv( 2, iseed, n-j, a( jc+1 ) )
727  a( jc ) = zero
728  jc = jc + n - j + 1
729  400 CONTINUE
730  END IF
731 *
732 * Set the right hand side so that the largest value is BIGNUM.
733 *
734  CALL dlarnv( 2, iseed, n, b )
735  iy = idamax( n, b, 1 )
736  bnorm = abs( b( iy ) )
737  bscal = bignum / max( one, bnorm )
738  CALL dscal( n, bscal, b, 1 )
739 *
740  ELSE IF( imat.EQ.19 ) THEN
741 *
742 * Type 19: Generate a triangular matrix with elements between
743 * BIGNUM/(n-1) and BIGNUM so that at least one of the column
744 * norms will exceed BIGNUM.
745 *
746  tleft = bignum / max( one, dble( n-1 ) )
747  tscal = bignum*( dble( n-1 ) / max( one, dble( n ) ) )
748  IF( upper ) THEN
749  jc = 1
750  DO 420 j = 1, n
751  CALL dlarnv( 2, iseed, j, a( jc ) )
752  DO 410 i = 1, j
753  a( jc+i-1 ) = sign( tleft, a( jc+i-1 ) ) +
754  $ tscal*a( jc+i-1 )
755  410 CONTINUE
756  jc = jc + j
757  420 CONTINUE
758  ELSE
759  jc = 1
760  DO 440 j = 1, n
761  CALL dlarnv( 2, iseed, n-j+1, a( jc ) )
762  DO 430 i = j, n
763  a( jc+i-j ) = sign( tleft, a( jc+i-j ) ) +
764  $ tscal*a( jc+i-j )
765  430 CONTINUE
766  jc = jc + n - j + 1
767  440 CONTINUE
768  END IF
769  CALL dlarnv( 2, iseed, n, b )
770  CALL dscal( n, two, b, 1 )
771  END IF
772 *
773 * Flip the matrix across its counter-diagonal if the transpose will
774 * be used.
775 *
776  IF( .NOT.lsame( trans, 'N' ) ) THEN
777  IF( upper ) THEN
778  jj = 1
779  jr = n*( n+1 ) / 2
780  DO 460 j = 1, n / 2
781  jl = jj
782  DO 450 i = j, n - j
783  t = a( jr-i+j )
784  a( jr-i+j ) = a( jl )
785  a( jl ) = t
786  jl = jl + i
787  450 CONTINUE
788  jj = jj + j + 1
789  jr = jr - ( n-j+1 )
790  460 CONTINUE
791  ELSE
792  jl = 1
793  jj = n*( n+1 ) / 2
794  DO 480 j = 1, n / 2
795  jr = jj
796  DO 470 i = j, n - j
797  t = a( jl+i-j )
798  a( jl+i-j ) = a( jr )
799  a( jr ) = t
800  jr = jr - i
801  470 CONTINUE
802  jl = jl + n - j + 1
803  jj = jj - j - 1
804  480 CONTINUE
805  END IF
806  END IF
807 *
808  RETURN
809 *
810 * End of DLATTP
811 *
812  END
dlatb4
subroutine dlatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
DLATB4
Definition: dlatb4.f:122
drot
subroutine drot(N, DX, INCX, DY, INCY, C, S)
DROT
Definition: drot.f:94
dlatms
subroutine dlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
DLATMS
Definition: dlatms.f:323
dlarnv
subroutine dlarnv(IDIST, ISEED, N, X)
DLARNV returns a vector of random numbers from a uniform or normal distribution.
Definition: dlarnv.f:99
drotg
subroutine drotg(DA, DB, C, S)
DROTG
Definition: drotg.f:71
dscal
subroutine dscal(N, DA, DX, INCX)
DSCAL
Definition: dscal.f:81
dlabad
subroutine dlabad(SMALL, LARGE)
DLABAD
Definition: dlabad.f:76
dlattp
subroutine dlattp(IMAT, UPLO, TRANS, DIAG, ISEED, N, A, B, WORK, INFO)
DLATTP
Definition: dlattp.f:127