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