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 )
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 )