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,
170 INTRINSIC abs, dble, max, sign, sqrt
174 path( 1: 1 ) =
'Double precision'
176 unfl =
dlamch(
'Safe minimum' )
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
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 ) )
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
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
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 ) )
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 ) )
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 ) )
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 ) ) +
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
double precision function dlarnd(IDIST, ISEED)
DLARND
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
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
subroutine dlattp(IMAT, UPLO, TRANS, DIAG, ISEED, N, A, B, WORK, INFO)
DLATTP
logical function lsame(CA, CB)
LSAME
subroutine dscal(N, DA, DX, INCX)
DSCAL
double precision function dlamch(CMACH)
DLAMCH
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine drot(N, DX, INCX, DY, INCY, C, S)
DROT
integer function idamax(N, DX, INCX)
IDAMAX