329 SUBROUTINE dlatme( N, DIST, ISEED, D, MODE, COND, DMAX, EI,
331 $ upper, sim, ds, modes, conds, kl, ku, anorm,
341 CHARACTER DIST, RSIGN, SIM, UPPER
342 INTEGER INFO, KL, KU, LDA, MODE, MODES, N
343 DOUBLE PRECISION ANORM, COND, CONDS, DMAX
348 DOUBLE PRECISION A( lda, * ), D( * ), DS( * ), WORK( * )
354 DOUBLE PRECISION ZERO
355 parameter( zero = 0.0d0 )
357 parameter( one = 1.0d0 )
358 DOUBLE PRECISION HALF
359 parameter( half = 1.0d0 / 2.0d0 )
362 LOGICAL BADEI, BADS, USEEI
363 INTEGER I, IC, ICOLS, IDIST, IINFO, IR, IROWS, IRSIGN,
364 $ isim, iupper, j, jc, jcr, jr
365 DOUBLE PRECISION ALPHA, TAU, TEMP, XNORMS
368 DOUBLE PRECISION TEMPA( 1 )
372 DOUBLE PRECISION DLANGE, DLARAN
373 EXTERNAL lsame, dlange, dlaran
380 INTRINSIC abs, max, mod
396 IF( lsame( dist,
'U' ) )
THEN
398 ELSE IF( lsame( dist,
'S' ) )
THEN
400 ELSE IF( lsame( dist,
'N' ) )
THEN
410 IF( lsame( ei( 1 ),
' ' ) .OR. mode.NE.0 )
THEN
413 IF( lsame( ei( 1 ),
'R' ) )
THEN
415 IF( lsame( ei( j ),
'I' ) )
THEN
416 IF( lsame( ei( j-1 ),
'I' ) )
419 IF( .NOT.lsame( ei( j ),
'R' ) )
430 IF( lsame( rsign,
'T' ) )
THEN
432 ELSE IF( lsame( rsign,
'F' ) )
THEN
440 IF( lsame( upper,
'T' ) )
THEN
442 ELSE IF( lsame( upper,
'F' ) )
THEN
450 IF( lsame( sim,
'T' ) )
THEN
452 ELSE IF( lsame( sim,
'F' ) )
THEN
461 IF( modes.EQ.0 .AND. isim.EQ.1 )
THEN
463 IF( ds( j ).EQ.zero )
472 ELSE IF( idist.EQ.-1 )
THEN
474 ELSE IF( abs( mode ).GT.6 )
THEN
476 ELSE IF( ( mode.NE.0 .AND. abs( mode ).NE.6 ) .AND. cond.LT.one )
479 ELSE IF( badei )
THEN
481 ELSE IF( irsign.EQ.-1 )
THEN
483 ELSE IF( iupper.EQ.-1 )
THEN
485 ELSE IF( isim.EQ.-1 )
THEN
489 ELSE IF( isim.EQ.1 .AND. abs( modes ).GT.5 )
THEN
491 ELSE IF( isim.EQ.1 .AND. modes.NE.0 .AND. conds.LT.one )
THEN
493 ELSE IF( kl.LT.1 )
THEN
495 ELSE IF( ku.LT.1 .OR. ( ku.LT.n-1 .AND. kl.LT.n-1 ) )
THEN
497 ELSE IF( lda.LT.max( 1, n ) )
THEN
502 CALL
xerbla(
'DLATME', -info )
509 iseed( i ) = mod( abs( iseed( i ) ), 4096 )
512 IF( mod( iseed( 4 ), 2 ).NE.1 )
513 $ iseed( 4 ) = iseed( 4 ) + 1
519 CALL
dlatm1( mode, cond, irsign, idist, iseed, d, n, iinfo )
520 IF( iinfo.NE.0 )
THEN
524 IF( mode.NE.0 .AND. abs( mode ).NE.6 )
THEN
530 temp = max( temp, abs( d( i ) ) )
533 IF( temp.GT.zero )
THEN
535 ELSE IF( dmax.NE.zero )
THEN
542 CALL
dscal( n, alpha, d, 1 )
546 CALL
dlaset(
'Full', n, n, zero, zero, a, lda )
547 CALL
dcopy( n, d, 1, a, lda+1 )
554 IF( lsame( ei( j ),
'I' ) )
THEN
555 a( j-1, j ) = a( j, j )
556 a( j, j-1 ) = -a( j, j )
557 a( j, j ) = a( j-1, j-1 )
562 ELSE IF( abs( mode ).EQ.5 )
THEN
565 IF( dlaran( iseed ).GT.half )
THEN
566 a( j-1, j ) = a( j, j )
567 a( j, j-1 ) = -a( j, j )
568 a( j, j ) = a( j-1, j-1 )
576 IF( iupper.NE.0 )
THEN
578 IF( a( jc-1, jc ).NE.zero )
THEN
583 CALL
dlarnv( idist, iseed, jr, a( 1, jc ) )
599 CALL
dlatm1( modes, conds, 0, 0, iseed, ds, n, iinfo )
600 IF( iinfo.NE.0 )
THEN
607 CALL
dlarge( n, a, lda, iseed, work, iinfo )
608 IF( iinfo.NE.0 )
THEN
616 CALL
dscal( n, ds( j ), a( j, 1 ), lda )
617 IF( ds( j ).NE.zero )
THEN
618 CALL
dscal( n, one / ds( j ), a( 1, j ), 1 )
627 CALL
dlarge( n, a, lda, iseed, work, iinfo )
628 IF( iinfo.NE.0 )
THEN
640 DO 90 jcr = kl + 1, n - 1
645 CALL
dcopy( irows, a( jcr, ic ), 1, work, 1 )
647 CALL
dlarfg( irows, xnorms, work( 2 ), 1, tau )
650 CALL
dgemv(
'T', irows, icols, one, a( jcr, ic+1 ), lda,
651 $ work, 1, zero, work( irows+1 ), 1 )
652 CALL
dger( irows, icols, -tau, work, 1, work( irows+1 ), 1,
653 $ a( jcr, ic+1 ), lda )
655 CALL
dgemv(
'N', n, irows, one, a( 1, jcr ), lda, work, 1,
656 $ zero, work( irows+1 ), 1 )
657 CALL
dger( n, irows, -tau, work( irows+1 ), 1, work, 1,
660 a( jcr, ic ) = xnorms
661 CALL
dlaset(
'Full', irows-1, 1, zero, zero, a( jcr+1, ic ),
664 ELSE IF( ku.LT.n-1 )
THEN
668 DO 100 jcr = ku + 1, n - 1
673 CALL
dcopy( icols, a( ir, jcr ), lda, work, 1 )
675 CALL
dlarfg( icols, xnorms, work( 2 ), 1, tau )
678 CALL
dgemv(
'N', irows, icols, one, a( ir+1, jcr ), lda,
679 $ work, 1, zero, work( icols+1 ), 1 )
680 CALL
dger( irows, icols, -tau, work( icols+1 ), 1, work, 1,
681 $ a( ir+1, jcr ), lda )
683 CALL
dgemv(
'C', icols, n, one, a( jcr, 1 ), lda, work, 1,
684 $ zero, work( icols+1 ), 1 )
685 CALL
dger( icols, n, -tau, work, 1, work( icols+1 ), 1,
688 a( ir, jcr ) = xnorms
689 CALL
dlaset(
'Full', 1, icols-1, zero, zero, a( ir, jcr+1 ),
696 IF( anorm.GE.zero )
THEN
697 temp = dlange(
'M', n, n, a, lda, tempa )
698 IF( temp.GT.zero )
THEN
701 CALL
dscal( n, alpha, a( 1, j ), 1 )
subroutine dger(M, N, ALPHA, X, INCX, Y, INCY, A, LDA)
DGER
subroutine dlarfg(N, ALPHA, X, INCX, TAU)
DLARFG generates an elementary reflector (Householder matrix).
subroutine dcopy(N, DX, INCX, DY, INCY)
DCOPY
subroutine dlatme(N, DIST, ISEED, D, MODE, COND, DMAX, EI, RSIGN, UPPER, SIM, DS, MODES, CONDS, KL, KU, ANORM, A, LDA, WORK, INFO)
DLATME
subroutine dlarnv(IDIST, ISEED, N, X)
DLARNV returns a vector of random numbers from a uniform or normal distribution.
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine dlarge(N, A, LDA, ISEED, WORK, INFO)
DLARGE
subroutine dscal(N, DA, DX, INCX)
DSCAL
subroutine dlaset(UPLO, M, N, ALPHA, BETA, A, LDA)
DLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine dgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
DGEMV
subroutine dlatm1(MODE, COND, IRSIGN, IDIST, ISEED, D, N, INFO)
DLATM1