125 SUBROUTINE dlattp( IMAT, UPLO, TRANS, DIAG, ISEED, N, A, B, WORK,
134 CHARACTER DIAG, TRANS, UPLO
135 INTEGER IMAT, INFO, N
139 DOUBLE PRECISION A( * ), B( * ), WORK( * )
145 DOUBLE PRECISION ONE, TWO, ZERO
146 parameter( one = 1.0d+0, two = 2.0d+0, zero = 0.0d+0 )
150 CHARACTER DIST, PACKIT, TYPE
152 INTEGER I, IY, J, JC, JCNEXT, JCOUNT, JJ, JL, JR, JX,
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,
162 DOUBLE PRECISION DLAMCH, DLARND
163 EXTERNAL lsame, idamax, dlamch, dlarnd
170 INTRINSIC abs, dble, max, sign, sqrt
174 path( 1: 1 ) =
'Double precision'
176 unfl = dlamch(
'Safe minimum' )
177 ulp = dlamch(
'Epsilon' )*dlamch(
'Base' )
179 bignum = ( one-ulp ) / smlnum
180 CALL
dlabad( smlnum, bignum )
181 IF( ( imat.GE.7 .AND. imat.LE.10 ) .OR. imat.EQ.18 )
THEN
195 upper = lsame( uplo,
'U' )
197 CALL
dlatb4( path, imat, n, n,
TYPE, KL, KU, ANORM, MODE,
201 CALL
dlatb4( path, -imat, n, n,
TYPE, KL, KU, ANORM, MODE,
209 CALL
dlatms( n, n, dist, iseed,
TYPE, B, MODE, CNDNUM, ANORM,
210 $ kl, ku, packit, a, n, work, info )
217 ELSE IF( imat.EQ.7 )
THEN
244 ELSE IF( imat.LE.10 )
THEN
327 plus2 = star1 / plus1
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 )
339 star1 = sfac**( one+rexp )
344 x = sqrt( cndnum ) - one / sqrt( cndnum )
346 y = sqrt( two / dble( n-2 ) )*x
361 $ a( jc+j-1 ) = work( j-2 )
363 $ a( jc+j-2 ) = work( n+j-3 )
382 a( jc+1 ) = work( j-1 )
384 $ a( jc+2 ) = work( n+j-1 )
398 CALL
drotg( ra, rb, c, s )
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 )
415 $ CALL
drot( j-1, a( jcnext ), 1, a( jc ), 1, -c, -s )
419 a( jcnext+j-1 ) = -a( jcnext+j-1 )
425 jcnext = jc + n - j + 1
428 CALL
drotg( ra, rb, c, s )
433 $ CALL
drot( n-j-1, a( jcnext+1 ), 1, a( jc+2 ), 1, c,
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 )
450 a( jc+1 ) = -a( jc+1 )
459 ELSE IF( imat.EQ.11 )
THEN
468 CALL
dlarnv( 2, iseed, j, a( jc ) )
469 a( jc+j-1 ) = sign( two, a( jc+j-1 ) )
475 CALL
dlarnv( 2, iseed, n-j+1, a( jc ) )
476 a( jc ) = sign( two, a( jc ) )
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 )
489 ELSE IF( imat.EQ.12 )
THEN
495 CALL
dlarnv( 2, iseed, n, b )
496 tscal = one / max( one, dble( n-1 ) )
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 ) )
505 a( n*( n+1 ) / 2 ) = smlnum
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 ) )
517 ELSE IF( imat.EQ.13 )
THEN
523 CALL
dlarnv( 2, iseed, n, b )
527 CALL
dlarnv( 2, iseed, j-1, a( jc ) )
528 a( jc+j-1 ) = sign( one, dlarnd( 2, iseed ) )
531 a( n*( n+1 ) / 2 ) = smlnum
535 CALL
dlarnv( 2, iseed, n-j, a( jc+1 ) )
536 a( jc ) = sign( one, dlarnd( 2, iseed ) )
542 ELSE IF( imat.EQ.14 )
THEN
550 jc = ( n-1 )*n / 2 + 1
555 IF( jcount.LE.2 )
THEN
572 IF( jcount.LE.2 )
THEN
594 DO 290 i = 1, n - 1, 2
600 ELSE IF( imat.EQ.15 )
THEN
606 texp = one / max( one, dble( n-1 ) )
608 CALL
dlarnv( 2, iseed, n, b )
635 ELSE IF( imat.EQ.16 )
THEN
643 CALL
dlarnv( 2, iseed, j, a( jc ) )
645 a( jc+j-1 ) = sign( two, a( jc+j-1 ) )
654 CALL
dlarnv( 2, iseed, n-j+1, a( jc ) )
656 a( jc ) = sign( two, a( jc ) )
663 CALL
dlarnv( 2, iseed, n, b )
664 CALL
dscal( n, two, b, 1 )
666 ELSE IF( imat.EQ.17 )
THEN
674 tscal = ( one-ulp ) / tscal
675 DO 360 j = 1, n*( n+1 ) / 2
680 jc = ( n-1 )*n / 2 + 1
682 a( jc ) = -tscal / dble( n+1 )
684 b( j ) = texp*( one-ulp )
686 a( jc ) = -( tscal / dble( n+1 ) ) / dble( n+2 )
688 b( j-1 ) = texp*dble( n*n+n-1 )
692 b( 1 ) = ( dble( n+1 ) / dble( n+2 ) )*tscal
695 DO 380 j = 1, n - 1, 2
696 a( jc+n-j ) = -tscal / dble( n+1 )
698 b( j ) = texp*( one-ulp )
700 a( jc+n-j-1 ) = -( tscal / dble( n+1 ) ) / dble( n+2 )
702 b( j+1 ) = texp*dble( n*n+n-1 )
706 b( n ) = ( dble( n+1 ) / dble( n+2 ) )*tscal
709 ELSE IF( imat.EQ.18 )
THEN
718 CALL
dlarnv( 2, iseed, j-1, a( jc ) )
726 $ CALL
dlarnv( 2, iseed, n-j, a( jc+1 ) )
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 )
740 ELSE IF( imat.EQ.19 )
THEN
746 tleft = bignum / max( one, dble( n-1 ) )
747 tscal = bignum*( dble( n-1 ) / max( one, dble( n ) ) )
751 CALL
dlarnv( 2, iseed, j, a( jc ) )
753 a( jc+i-1 ) = sign( tleft, a( jc+i-1 ) ) +
761 CALL
dlarnv( 2, iseed, n-j+1, a( jc ) )
763 a( jc+i-j ) = sign( tleft, a( jc+i-j ) ) +
769 CALL
dlarnv( 2, iseed, n, b )
770 CALL
dscal( n, two, b, 1 )
776 IF( .NOT.lsame( trans,
'N' ) )
THEN
784 a( jr-i+j ) = a( jl )
798 a( jl+i-j ) = a( jr )
subroutine dlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
DLATMS
subroutine drotg(DA, DB, C, S)
DROTG
subroutine dlarnv(IDIST, ISEED, N, X)
DLARNV returns a vector of random numbers from a uniform or normal distribution.
subroutine dlatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
DLATB4
subroutine dlabad(SMALL, LARGE)
DLABAD
subroutine dlattp(IMAT, UPLO, TRANS, DIAG, ISEED, N, A, B, WORK, INFO)
DLATTP
subroutine dscal(N, DA, DX, INCX)
DSCAL
subroutine drot(N, DX, INCX, DY, INCY, C, S)
DROT