298 SUBROUTINE clatme( N, DIST, ISEED, D, MODE, COND, DMAX,
300 $ upper, sim, ds, modes, conds, kl, ku, anorm,
310 CHARACTER dist, rsign, sim, upper
311 INTEGER info, kl, ku, lda, mode, modes, n
312 REAL anorm, cond, conds
318 COMPLEX a( lda, * ), d( * ), work( * )
325 parameter( zero = 0.0e+0 )
327 parameter( one = 1.0e+0 )
329 parameter( czero = ( 0.0e+0, 0.0e+0 ) )
331 parameter( cone = ( 1.0e+0, 0.0e+0 ) )
335 INTEGER i, ic, icols, idist, iinfo, ir, irows, irsign,
336 $ isim, iupper,
j, jc, jcr
338 COMPLEX alpha, tau, xnorms
355 INTRINSIC abs, conjg, max, mod
371 IF(
lsame( dist,
'U' ) )
THEN
373 ELSE IF(
lsame( dist,
'S' ) )
THEN
375 ELSE IF(
lsame( dist,
'N' ) )
THEN
377 ELSE IF(
lsame( dist,
'D' ) )
THEN
385 IF(
lsame( rsign,
'T' ) )
THEN
387 ELSE IF(
lsame( rsign,
'F' ) )
THEN
395 IF(
lsame( upper,
'T' ) )
THEN
397 ELSE IF(
lsame( upper,
'F' ) )
THEN
405 IF(
lsame( sim,
'T' ) )
THEN
407 ELSE IF(
lsame( sim,
'F' ) )
THEN
416 IF( modes.EQ.0 .AND. isim.EQ.1 )
THEN
418 IF( ds(
j ).EQ.zero )
427 ELSE IF( idist.EQ.-1 )
THEN
429 ELSE IF( abs( mode ).GT.6 )
THEN
431 ELSE IF( ( mode.NE.0 .AND. abs( mode ).NE.6 ) .AND. cond.LT.one )
434 ELSE IF( irsign.EQ.-1 )
THEN
436 ELSE IF( iupper.EQ.-1 )
THEN
438 ELSE IF( isim.EQ.-1 )
THEN
442 ELSE IF( isim.EQ.1 .AND. abs( modes ).GT.5 )
THEN
444 ELSE IF( isim.EQ.1 .AND. modes.NE.0 .AND. conds.LT.one )
THEN
446 ELSE IF( kl.LT.1 )
THEN
448 ELSE IF( ku.LT.1 .OR. ( ku.LT.n-1 .AND. kl.LT.n-1 ) )
THEN
450 ELSE IF( lda.LT.max( 1, n ) )
THEN
455 CALL
xerbla(
'CLATME', -info )
462 iseed( i ) = mod( abs( iseed( i ) ), 4096 )
465 IF( mod( iseed( 4 ), 2 ).NE.1 )
466 $ iseed( 4 ) = iseed( 4 ) + 1
472 CALL
clatm1( mode, cond, irsign, idist, iseed, d, n, iinfo )
473 IF( iinfo.NE.0 )
THEN
477 IF( mode.NE.0 .AND. abs( mode ).NE.6 )
THEN
483 temp = max( temp, abs( d( i ) ) )
486 IF( temp.GT.zero )
THEN
493 CALL
cscal( n, alpha, d, 1 )
497 CALL
claset(
'Full', n, n, czero, czero, a, lda )
498 CALL
ccopy( n, d, 1, a, lda+1 )
502 IF( iupper.NE.0 )
THEN
504 CALL
clarnv( idist, iseed, jc-1, a( 1, jc ) )
520 CALL
slatm1( modes, conds, 0, 0, iseed, ds, n, iinfo )
521 IF( iinfo.NE.0 )
THEN
528 CALL
clarge( n, a, lda, iseed, work, iinfo )
529 IF( iinfo.NE.0 )
THEN
537 CALL
csscal( n, ds(
j ), a(
j, 1 ), lda )
538 IF( ds(
j ).NE.zero )
THEN
539 CALL
csscal( n, one / ds(
j ), a( 1,
j ), 1 )
548 CALL
clarge( n, a, lda, iseed, work, iinfo )
549 IF( iinfo.NE.0 )
THEN
561 DO 60 jcr = kl + 1, n - 1
566 CALL
ccopy( irows, a( jcr, ic ), 1, work, 1 )
568 CALL
clarfg( irows, xnorms, work( 2 ), 1, tau )
571 alpha =
clarnd( 5, iseed )
573 CALL
cgemv(
'C', irows, icols, cone, a( jcr, ic+1 ), lda,
574 $ work, 1, czero, work( irows+1 ), 1 )
575 CALL
cgerc( irows, icols, -tau, work, 1, work( irows+1 ), 1,
576 $ a( jcr, ic+1 ), lda )
578 CALL
cgemv(
'N', n, irows, cone, a( 1, jcr ), lda, work, 1,
579 $ czero, work( irows+1 ), 1 )
580 CALL
cgerc( n, irows, -conjg( tau ), work( irows+1 ), 1,
581 $ work, 1, a( 1, jcr ), lda )
583 a( jcr, ic ) = xnorms
584 CALL
claset(
'Full', irows-1, 1, czero, czero,
585 $ a( jcr+1, ic ), lda )
587 CALL
cscal( icols+1, alpha, a( jcr, ic ), lda )
588 CALL
cscal( n, conjg( alpha ), a( 1, jcr ), 1 )
590 ELSE IF( ku.LT.n-1 )
THEN
594 DO 70 jcr = ku + 1, n - 1
599 CALL
ccopy( icols, a( ir, jcr ), lda, work, 1 )
601 CALL
clarfg( icols, xnorms, work( 2 ), 1, tau )
604 CALL
clacgv( icols-1, work( 2 ), 1 )
605 alpha =
clarnd( 5, iseed )
607 CALL
cgemv(
'N', irows, icols, cone, a( ir+1, jcr ), lda,
608 $ work, 1, czero, work( icols+1 ), 1 )
609 CALL
cgerc( irows, icols, -tau, work( icols+1 ), 1, work, 1,
610 $ a( ir+1, jcr ), lda )
612 CALL
cgemv(
'C', icols, n, cone, a( jcr, 1 ), lda, work, 1,
613 $ czero, work( icols+1 ), 1 )
614 CALL
cgerc( icols, n, -conjg( tau ), work, 1,
615 $ work( icols+1 ), 1, a( jcr, 1 ), lda )
617 a( ir, jcr ) = xnorms
618 CALL
claset(
'Full', 1, icols-1, czero, czero,
619 $ a( ir, jcr+1 ), lda )
621 CALL
cscal( irows+1, alpha, a( ir, jcr ), 1 )
622 CALL
cscal( n, conjg( alpha ), a( jcr, 1 ), lda )
628 IF( anorm.GE.zero )
THEN
629 temp =
clange(
'M', n, n, a, lda, tempa )
630 IF( temp.GT.zero )
THEN
631 ralpha = anorm / temp
633 CALL
csscal( n, ralpha, a( 1,
j ), 1 )
subroutine claset(UPLO, M, N, ALPHA, BETA, A, LDA)
CLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
LOGICAL function lsame(CA, CB)
LSAME
subroutine cscal(N, CA, CX, INCX)
CSCAL
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine slatm1(MODE, COND, IRSIGN, IDIST, ISEED, D, N, INFO)
SLATM1
subroutine clacgv(N, X, INCX)
CLACGV conjugates a complex vector.
subroutine cgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
CGEMV
REAL function clange(NORM, M, N, A, LDA, WORK)
CLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
subroutine clatme(N, DIST, ISEED, D, MODE, COND, DMAX, RSIGN, UPPER, SIM, DS, MODES, CONDS, KL, KU, ANORM, A, LDA, WORK, INFO)
CLATME
subroutine clarfg(N, ALPHA, X, INCX, TAU)
CLARFG generates an elementary reflector (Householder matrix).
subroutine clarnv(IDIST, ISEED, N, X)
CLARNV returns a vector of random numbers from a uniform or normal distribution.
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
COMPLEX function clarnd(IDIST, ISEED)
CLARND
subroutine ccopy(N, CX, INCX, CY, INCY)
CCOPY
subroutine clarge(N, A, LDA, ISEED, WORK, INFO)
CLARGE
subroutine csscal(N, SA, CX, INCX)
CSSCAL
subroutine cgerc(M, N, ALPHA, X, INCX, Y, INCY, A, LDA)
CGERC
subroutine clatm1(MODE, COND, IRSIGN, IDIST, ISEED, D, N, INFO)
CLATM1