LAPACK  3.10.1
LAPACK: Linear Algebra PACKage

◆ zlattp()

subroutine zlattp ( integer  IMAT,
character  UPLO,
character  TRANS,
character  DIAG,
integer, dimension( 4 )  ISEED,
integer  N,
complex*16, dimension( * )  AP,
complex*16, dimension( * )  B,
complex*16, dimension( * )  WORK,
double precision, dimension( * )  RWORK,
integer  INFO 
)

ZLATTP

Purpose:
 ZLATTP generates a triangular test matrix in packed storage.
 IMAT and UPLO uniquely specify the properties of the test matrix,
 which is returned in the array AP.
Parameters
[in]IMAT
          IMAT is INTEGER
          An integer key describing which matrix to generate for this
          path.
[in]UPLO
          UPLO is CHARACTER*1
          Specifies whether the matrix A will be upper or lower
          triangular.
          = 'U':  Upper triangular
          = 'L':  Lower triangular
[in]TRANS
          TRANS is CHARACTER*1
          Specifies whether the matrix or its transpose will be used.
          = 'N':  No transpose
          = 'T':  Transpose
          = 'C':  Conjugate transpose
[out]DIAG
          DIAG is CHARACTER*1
          Specifies whether or not the matrix A is unit triangular.
          = 'N':  Non-unit triangular
          = 'U':  Unit triangular
[in,out]ISEED
          ISEED is INTEGER array, dimension (4)
          The seed vector for the random number generator (used in
          ZLATMS).  Modified on exit.
[in]N
          N is INTEGER
          The order of the matrix to be generated.
[out]AP
          AP is COMPLEX*16 array, dimension (N*(N+1)/2)
          The upper or lower triangular matrix A, packed columnwise in
          a linear array.  The j-th column of A is stored in the array
          AP as follows:
          if UPLO = 'U', AP((j-1)*j/2 + i) = A(i,j) for 1<=i<=j;
          if UPLO = 'L',
             AP((j-1)*(n-j) + j*(j+1)/2 + i-j) = A(i,j) for j<=i<=n.
[out]B
          B is COMPLEX*16 array, dimension (N)
          The right hand side vector, if IMAT > 10.
[out]WORK
          WORK is COMPLEX*16 array, dimension (2*N)
[out]RWORK
          RWORK is DOUBLE PRECISION array, dimension (N)
[out]INFO
          INFO is INTEGER
          = 0:  successful exit
          < 0:  if INFO = -i, the i-th argument had an illegal value
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 129 of file zlattp.f.

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