144 CHARACTER diag, trans, uplo
145 INTEGER imat, info, kd, ldab, n
149 DOUBLE PRECISION ab( ldab, * ), b( * ), work( * )
155 DOUBLE PRECISION one, two, zero
156 parameter ( one = 1.0d+0, two = 2.0d+0, zero = 0.0d+0 )
160 CHARACTER dist, packit, type
162 INTEGER i, ioff, iy, j, jcount, kl, ku, lenj, mode
163 DOUBLE PRECISION anorm, bignum, bnorm, bscal, cndnum, plus1,
164 $ plus2, rexp, sfac, smlnum, star1, texp, tleft,
165 $ tnorm, tscal, ulp, unfl
178 INTRINSIC abs, dble, max, min, sign, sqrt
182 path( 1: 1 ) =
'Double precision'
184 unfl =
dlamch(
'Safe minimum' )
187 bignum = ( one-ulp ) / smlnum
188 CALL dlabad( smlnum, bignum )
189 IF( ( imat.GE.6 .AND. imat.LE.9 ) .OR. imat.EQ.17 )
THEN
203 upper =
lsame( uplo,
'U' )
205 CALL dlatb4( path, imat, n, n,
TYPE, kl, ku, anorm, mode,
208 ioff = 1 + max( 0, kd-n+1 )
212 CALL dlatb4( path, -imat, n, n,
TYPE, kl, ku, anorm, mode,
223 CALL dlatms( n, n, dist, iseed,
TYPE, b, mode, cndnum, anorm,
224 $ kl, ku, packit, ab( ioff, 1 ), ldab, work, info )
231 ELSE IF( imat.EQ.6 )
THEN
234 DO 10 i = max( 1, kd+2-j ), kd
242 DO 30 i = 2, min( kd+1, n-j+1 )
253 ELSE IF( imat.LE.9 )
THEN
254 tnorm = sqrt( cndnum )
260 DO 50 i = max( 1, kd+2-j ), kd
263 ab( kd+1, j ) = dble( j )
267 DO 70 i = 2, min( kd+1, n-j+1 )
270 ab( 1, j ) = dble( j )
279 ab( 1, 2 ) = sign( tnorm,
dlarnd( 2, iseed ) )
281 CALL dlarnv( 2, iseed, lenj, work )
283 ab( 1, 2*( j+1 ) ) = tnorm*work( j )
286 ab( 2, 1 ) = sign( tnorm,
dlarnd( 2, iseed ) )
288 CALL dlarnv( 2, iseed, lenj, work )
290 ab( 2, 2*j+1 ) = tnorm*work( j )
293 ELSE IF( kd.GT.1 )
THEN
311 star1 = sign( tnorm,
dlarnd( 2, iseed ) )
313 plus1 = sign( sfac,
dlarnd( 2, iseed ) )
315 plus2 = star1 / plus1
321 plus1 = star1 / plus2
327 IF( rexp.LT.zero )
THEN
328 star1 = -sfac**( one-rexp )
330 star1 = sfac**( one+rexp )
338 CALL dcopy( n-1, work, 1, ab( kd, 2 ), ldab )
339 CALL dcopy( n-2, work( n+1 ), 1, ab( kd-1, 3 ), ldab )
341 CALL dcopy( n-1, work, 1, ab( 2, 1 ), ldab )
342 CALL dcopy( n-2, work( n+1 ), 1, ab( 3, 1 ), ldab )
350 ELSE IF( imat.EQ.10 )
THEN
358 lenj = min( j, kd+1 )
359 CALL dlarnv( 2, iseed, lenj, ab( kd+2-lenj, j ) )
360 ab( kd+1, j ) = sign( two, ab( kd+1, j ) )
364 lenj = min( n-j+1, kd+1 )
366 $
CALL dlarnv( 2, iseed, lenj, ab( 1, j ) )
367 ab( 1, j ) = sign( two, ab( 1, j ) )
373 CALL dlarnv( 2, iseed, n, b )
375 bnorm = abs( b( iy ) )
376 bscal = bignum / max( one, bnorm )
377 CALL dscal( n, bscal, b, 1 )
379 ELSE IF( imat.EQ.11 )
THEN
385 CALL dlarnv( 2, iseed, n, b )
386 tscal = one / dble( kd+1 )
389 lenj = min( j, kd+1 )
390 CALL dlarnv( 2, iseed, lenj, ab( kd+2-lenj, j ) )
391 CALL dscal( lenj-1, tscal, ab( kd+2-lenj, j ), 1 )
392 ab( kd+1, j ) = sign( one, ab( kd+1, j ) )
394 ab( kd+1, n ) = smlnum*ab( kd+1, n )
397 lenj = min( n-j+1, kd+1 )
398 CALL dlarnv( 2, iseed, lenj, ab( 1, j ) )
400 $
CALL dscal( lenj-1, tscal, ab( 2, j ), 1 )
401 ab( 1, j ) = sign( one, ab( 1, j ) )
403 ab( 1, 1 ) = smlnum*ab( 1, 1 )
406 ELSE IF( imat.EQ.12 )
THEN
412 CALL dlarnv( 2, iseed, n, b )
415 lenj = min( j, kd+1 )
416 CALL dlarnv( 2, iseed, lenj, ab( kd+2-lenj, j ) )
417 ab( kd+1, j ) = sign( one, ab( kd+1, j ) )
419 ab( kd+1, n ) = smlnum*ab( kd+1, n )
422 lenj = min( n-j+1, kd+1 )
423 CALL dlarnv( 2, iseed, lenj, ab( 1, j ) )
424 ab( 1, j ) = sign( one, ab( 1, j ) )
426 ab( 1, 1 ) = smlnum*ab( 1, 1 )
429 ELSE IF( imat.EQ.13 )
THEN
438 DO 180 i = max( 1, kd+1-( j-1 ) ), kd
441 IF( jcount.LE.2 )
THEN
442 ab( kd+1, j ) = smlnum
453 DO 200 i = 2, min( n-j+1, kd+1 )
456 IF( jcount.LE.2 )
THEN
477 DO 230 i = 1, n - 1, 2
483 ELSE IF( imat.EQ.14 )
THEN
489 texp = one / dble( kd+1 )
491 CALL dlarnv( 2, iseed, n, b )
494 DO 240 i = max( 1, kd+2-j ), kd
497 IF( j.GT.1 .AND. kd.GT.0 )
499 ab( kd+1, j ) = tscal
504 DO 260 i = 3, min( n-j+1, kd+1 )
507 IF( j.LT.n .AND. kd.GT.0 )
514 ELSE IF( imat.EQ.15 )
THEN
521 lenj = min( j, kd+1 )
522 CALL dlarnv( 2, iseed, lenj, ab( kd+2-lenj, j ) )
524 ab( kd+1, j ) = sign( two, ab( kd+1, j ) )
531 lenj = min( n-j+1, kd+1 )
532 CALL dlarnv( 2, iseed, lenj, ab( 1, j ) )
534 ab( 1, j ) = sign( two, ab( 1, j ) )
540 CALL dlarnv( 2, iseed, n, b )
541 CALL dscal( n, two, b, 1 )
543 ELSE IF( imat.EQ.16 )
THEN
551 tscal = ( one-ulp ) / tscal
561 DO 320 i = j, max( 1, j-kd+1 ), -2
562 ab( 1+( j-i ), i ) = -tscal / dble( kd+2 )
564 b( i ) = texp*( one-ulp )
565 IF( i.GT.max( 1, j-kd+1 ) )
THEN
566 ab( 2+( j-i ), i-1 ) = -( tscal / dble( kd+2 ) )
568 ab( kd+1, i-1 ) = one
569 b( i-1 ) = texp*dble( ( kd+1 )*( kd+1 )+kd )
573 b( max( 1, j-kd+1 ) ) = ( dble( kd+2 ) /
574 $ dble( kd+3 ) )*tscal
579 lenj = min( kd+1, n-j+1 )
580 DO 340 i = j, min( n, j+kd-1 ), 2
581 ab( lenj-( i-j ), j ) = -tscal / dble( kd+2 )
583 b( j ) = texp*( one-ulp )
584 IF( i.LT.min( n, j+kd-1 ) )
THEN
585 ab( lenj-( i-j+1 ), i+1 ) = -( tscal /
586 $ dble( kd+2 ) ) / dble( kd+3 )
588 b( i+1 ) = texp*dble( ( kd+1 )*( kd+1 )+kd )
592 b( min( n, j+kd-1 ) ) = ( dble( kd+2 ) /
593 $ dble( kd+3 ) )*tscal
603 ELSE IF( imat.EQ.17 )
THEN
611 lenj = min( j-1, kd )
612 CALL dlarnv( 2, iseed, lenj, ab( kd+1-lenj, j ) )
613 ab( kd+1, j ) = dble( j )
617 lenj = min( n-j, kd )
619 $
CALL dlarnv( 2, iseed, lenj, ab( 2, j ) )
620 ab( 1, j ) = dble( j )
626 CALL dlarnv( 2, iseed, n, b )
628 bnorm = abs( b( iy ) )
629 bscal = bignum / max( one, bnorm )
630 CALL dscal( n, bscal, b, 1 )
632 ELSE IF( imat.EQ.18 )
THEN
638 tleft = bignum / max( one, dble( kd ) )
639 tscal = bignum*( dble( kd ) / dble( kd+1 ) )
642 lenj = min( j, kd+1 )
643 CALL dlarnv( 2, iseed, lenj, ab( kd+2-lenj, j ) )
644 DO 390 i = kd + 2 - lenj, kd + 1
645 ab( i, j ) = sign( tleft, ab( i, j ) ) +
651 lenj = min( n-j+1, kd+1 )
652 CALL dlarnv( 2, iseed, lenj, ab( 1, j ) )
654 ab( i, j ) = sign( tleft, ab( i, j ) ) +
659 CALL dlarnv( 2, iseed, n, b )
660 CALL dscal( n, two, b, 1 )
665 IF( .NOT.
lsame( trans,
'N' ) )
THEN
668 lenj = min( n-2*j+1, kd+1 )
669 CALL dswap( lenj, ab( kd+1, j ), ldab-1,
670 $ ab( kd+2-lenj, n-j+1 ), -1 )
674 lenj = min( n-2*j+1, kd+1 )
675 CALL dswap( lenj, ab( 1, j ), 1, ab( lenj, n-j+2-lenj ),
subroutine dcopy(N, DX, INCX, DY, INCY)
DCOPY
integer function idamax(N, DX, INCX)
IDAMAX
double precision function dlamch(CMACH)
DLAMCH
subroutine dlabad(SMALL, LARGE)
DLABAD
subroutine dswap(N, DX, INCX, DY, INCY)
DSWAP
double precision function dlarnd(IDIST, ISEED)
DLARND
subroutine dlatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
DLATB4
subroutine dscal(N, DA, DX, INCX)
DSCAL
subroutine dlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
DLATMS
subroutine dlarnv(IDIST, ISEED, N, X)
DLARNV returns a vector of random numbers from a uniform or normal distribution.
logical function lsame(CA, CB)
LSAME