340 SUBROUTINE zlatmt( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX,
341 $ rank, kl, ku, pack, a, lda, work, info )
349 DOUBLE PRECISION COND, DMAX
350 INTEGER INFO, KL, KU, LDA, M, MODE, N, RANK
351 CHARACTER DIST, PACK, SYM
354 COMPLEX*16 A( lda, * ), WORK( * )
355 DOUBLE PRECISION D( * )
362 DOUBLE PRECISION ZERO
363 parameter ( zero = 0.0d+0 )
365 parameter ( one = 1.0d+0 )
367 parameter ( czero = ( 0.0d+0, 0.0d+0 ) )
368 DOUBLE PRECISION TWOPI
369 parameter ( twopi = 6.2831853071795864769252867663d+0 )
372 COMPLEX*16 C, CT, DUMMY, EXTRA, S, ST, ZTEMP
373 DOUBLE PRECISION ALPHA, ANGLE, REALC, TEMP
374 INTEGER I, IC, ICOL, IDIST, IENDCH, IINFO, IL, ILDA,
375 $ ioffg, ioffst, ipack, ipackg, ir, ir1, ir2,
376 $ irow, irsign, iskew, isym, isympk, j, jc, jch,
377 $ jkl, jku, jr, k, llb, minlda, mnmin, mr, nc,
379 LOGICAL CSYM, GIVENS, ILEXTR, ILTEMP, TOPDWN
383 DOUBLE PRECISION DLARND
385 EXTERNAL zlarnd, dlarnd, lsame
392 INTRINSIC abs, cos, dble, dcmplx, dconjg, max, min, mod,
404 IF( m.EQ.0 .OR. n.EQ.0 )
409 IF( lsame( dist,
'U' ) )
THEN
411 ELSE IF( lsame( dist,
'S' ) )
THEN
413 ELSE IF( lsame( dist,
'N' ) )
THEN
421 IF( lsame( sym,
'N' ) )
THEN
425 ELSE IF( lsame( sym,
'P' ) )
THEN
429 ELSE IF( lsame( sym,
'S' ) )
THEN
433 ELSE IF( lsame( sym,
'H' ) )
THEN
444 IF( lsame( pack,
'N' ) )
THEN
446 ELSE IF( lsame( pack,
'U' ) )
THEN
449 ELSE IF( lsame( pack,
'L' ) )
THEN
452 ELSE IF( lsame( pack,
'C' ) )
THEN
455 ELSE IF( lsame( pack,
'R' ) )
THEN
458 ELSE IF( lsame( pack,
'B' ) )
THEN
461 ELSE IF( lsame( pack,
'Q' ) )
THEN
464 ELSE IF( lsame( pack,
'Z' ) )
THEN
478 IF( ipack.EQ.5 .OR. ipack.EQ.6 )
THEN
480 ELSE IF( ipack.EQ.7 )
THEN
481 minlda = llb + uub + 1
491 IF( dble( llb+uub ).LT.0.3d0*dble( max( 1, mr+nc ) ) )
497 IF( lda.LT.m .AND. lda.GE.minlda )
504 ELSE IF( m.NE.n .AND. isym.NE.1 )
THEN
506 ELSE IF( n.LT.0 )
THEN
508 ELSE IF( idist.EQ.-1 )
THEN
510 ELSE IF( isym.EQ.-1 )
THEN
512 ELSE IF( abs( mode ).GT.6 )
THEN
514 ELSE IF( ( mode.NE.0 .AND. abs( mode ).NE.6 ) .AND. cond.LT.one )
517 ELSE IF( kl.LT.0 )
THEN
519 ELSE IF( ku.LT.0 .OR. ( isym.NE.1 .AND. kl.NE.ku ) )
THEN
521 ELSE IF( ipack.EQ.-1 .OR. ( isympk.EQ.1 .AND. isym.EQ.1 ) .OR.
522 $ ( isympk.EQ.2 .AND. isym.EQ.1 .AND. kl.GT.0 ) .OR.
523 $ ( isympk.EQ.3 .AND. isym.EQ.1 .AND. ku.GT.0 ) .OR.
524 $ ( isympk.NE.0 .AND. m.NE.n ) )
THEN
526 ELSE IF( lda.LT.max( 1, minlda ) )
THEN
531 CALL xerbla(
'ZLATMT', -info )
538 iseed( i ) = mod( abs( iseed( i ) ), 4096 )
541 IF( mod( iseed( 4 ), 2 ).NE.1 )
542 $ iseed( 4 ) = iseed( 4 ) + 1
548 CALL dlatm7( mode, cond, irsign, idist, iseed, d, mnmin, rank,
550 IF( iinfo.NE.0 )
THEN
558 IF( abs( d( 1 ) ).LE.abs( d( rank ) ) )
THEN
564 IF( mode.NE.0 .AND. abs( mode ).NE.6 )
THEN
570 temp = max( temp, abs( d( i ) ) )
573 IF( temp.GT.zero )
THEN
580 CALL dscal( rank, alpha, d, 1 )
584 CALL zlaset(
'Full', lda, n, czero, czero, a, lda )
595 IF( ipack.GT.4 )
THEN
598 IF( ipack.GT.5 )
THEN
618 IF( llb.EQ.0 .AND. uub.EQ.0 )
THEN
620 a( ( 1-iskew )*j+ioffst, j ) = dcmplx( d( j ) )
623 IF( ipack.LE.2 .OR. ipack.GE.5 )
626 ELSE IF( givens )
THEN
635 IF( ipack.GT.4 )
THEN
642 a( ( 1-iskew )*j+ioffst, j ) = dcmplx( d( j ) )
654 DO 150 jr = 1, min( m+jku, n ) + jkl - 1
656 angle = twopi*dlarnd( 1, iseed )
657 c = cos( angle )*zlarnd( 5, iseed )
658 s = sin( angle )*zlarnd( 5, iseed )
659 icol = max( 1, jr-jkl )
661 il = min( n, jr+jku ) + 1 - icol
662 CALL zlarot( .true., jr.GT.jkl, .false., il, c,
663 $ s, a( jr-iskew*icol+ioffst, icol ),
664 $ ilda, extra, dummy )
671 DO 140 jch = jr - jkl, 1, -jkl - jku
673 CALL zlartg( a( ir+1-iskew*( ic+1 )+ioffst,
674 $ ic+1 ), extra, realc, s, dummy )
675 dummy = dlarnd( 5, iseed )
676 c = dconjg( realc*dummy )
677 s = dconjg( -s*dummy )
679 irow = max( 1, jch-jku )
683 CALL zlarot( .false., iltemp, .true., il, c, s,
684 $ a( irow-iskew*ic+ioffst, ic ),
685 $ ilda, ztemp, extra )
687 CALL zlartg( a( irow+1-iskew*( ic+1 )+ioffst,
688 $ ic+1 ), ztemp, realc, s, dummy )
689 dummy = zlarnd( 5, iseed )
690 c = dconjg( realc*dummy )
691 s = dconjg( -s*dummy )
693 icol = max( 1, jch-jku-jkl )
696 CALL zlarot( .true., jch.GT.jku+jkl, .true.,
697 $ il, c, s, a( irow-iskew*icol+
698 $ ioffst, icol ), ilda, extra,
712 DO 180 jc = 1, min( n+jkl, m ) + jku - 1
714 angle = twopi*dlarnd( 1, iseed )
715 c = cos( angle )*zlarnd( 5, iseed )
716 s = sin( angle )*zlarnd( 5, iseed )
717 irow = max( 1, jc-jku )
719 il = min( m, jc+jkl ) + 1 - irow
720 CALL zlarot( .false., jc.GT.jku, .false., il, c,
721 $ s, a( irow-iskew*jc+ioffst, jc ),
722 $ ilda, extra, dummy )
729 DO 170 jch = jc - jku, 1, -jkl - jku
731 CALL zlartg( a( ir+1-iskew*( ic+1 )+ioffst,
732 $ ic+1 ), extra, realc, s, dummy )
733 dummy = zlarnd( 5, iseed )
734 c = dconjg( realc*dummy )
735 s = dconjg( -s*dummy )
737 icol = max( 1, jch-jkl )
741 CALL zlarot( .true., iltemp, .true., il, c, s,
742 $ a( ir-iskew*icol+ioffst, icol ),
743 $ ilda, ztemp, extra )
745 CALL zlartg( a( ir+1-iskew*( icol+1 )+ioffst,
746 $ icol+1 ), ztemp, realc, s,
748 dummy = zlarnd( 5, iseed )
749 c = dconjg( realc*dummy )
750 s = dconjg( -s*dummy )
751 irow = max( 1, jch-jkl-jku )
754 CALL zlarot( .false., jch.GT.jkl+jku, .true.,
755 $ il, c, s, a( irow-iskew*icol+
756 $ ioffst, icol ), ilda, extra,
777 iendch = min( m, n+jkl ) - 1
778 DO 210 jc = min( m+jku, n ) - 1, 1 - jkl, -1
780 angle = twopi*dlarnd( 1, iseed )
781 c = cos( angle )*zlarnd( 5, iseed )
782 s = sin( angle )*zlarnd( 5, iseed )
783 irow = max( 1, jc-jku+1 )
785 il = min( m, jc+jkl+1 ) + 1 - irow
786 CALL zlarot( .false., .false., jc+jkl.LT.m, il,
787 $ c, s, a( irow-iskew*jc+ioffst,
788 $ jc ), ilda, dummy, extra )
794 DO 200 jch = jc + jkl, iendch, jkl + jku
797 CALL zlartg( a( jch-iskew*ic+ioffst, ic ),
798 $ extra, realc, s, dummy )
799 dummy = zlarnd( 5, iseed )
804 icol = min( n-1, jch+jku )
805 iltemp = jch + jku.LT.n
807 CALL zlarot( .true., ilextr, iltemp, icol+2-ic,
808 $ c, s, a( jch-iskew*ic+ioffst, ic ),
809 $ ilda, extra, ztemp )
811 CALL zlartg( a( jch-iskew*icol+ioffst,
812 $ icol ), ztemp, realc, s, dummy )
813 dummy = zlarnd( 5, iseed )
816 il = min( iendch, jch+jkl+jku ) + 2 - jch
818 CALL zlarot( .false., .true.,
819 $ jch+jkl+jku.LE.iendch, il, c, s,
820 $ a( jch-iskew*icol+ioffst,
821 $ icol ), ilda, ztemp, extra )
836 iendch = min( n, m+jku ) - 1
837 DO 240 jr = min( n+jkl, m ) - 1, 1 - jku, -1
839 angle = twopi*dlarnd( 1, iseed )
840 c = cos( angle )*zlarnd( 5, iseed )
841 s = sin( angle )*zlarnd( 5, iseed )
842 icol = max( 1, jr-jkl+1 )
844 il = min( n, jr+jku+1 ) + 1 - icol
845 CALL zlarot( .true., .false., jr+jku.LT.n, il,
846 $ c, s, a( jr-iskew*icol+ioffst,
847 $ icol ), ilda, dummy, extra )
853 DO 230 jch = jr + jku, iendch, jkl + jku
856 CALL zlartg( a( ir-iskew*jch+ioffst, jch ),
857 $ extra, realc, s, dummy )
858 dummy = zlarnd( 5, iseed )
863 irow = min( m-1, jch+jkl )
864 iltemp = jch + jkl.LT.m
866 CALL zlarot( .false., ilextr, iltemp, irow+2-ir,
867 $ c, s, a( ir-iskew*jch+ioffst,
868 $ jch ), ilda, extra, ztemp )
870 CALL zlartg( a( irow-iskew*jch+ioffst, jch ),
871 $ ztemp, realc, s, dummy )
872 dummy = zlarnd( 5, iseed )
875 il = min( iendch, jch+jkl+jku ) + 2 - jch
877 CALL zlarot( .true., .true.,
878 $ jch+jkl+jku.LE.iendch, il, c, s,
879 $ a( irow-iskew*jch+ioffst, jch ),
880 $ ilda, ztemp, extra )
901 IF( ipack.GE.5 )
THEN
909 a( ( 1-iskew )*j+ioffg, j ) = dcmplx( d( j ) )
914 irow = max( 1, jc-k )
915 il = min( jc+1, k+2 )
917 ztemp = a( jc-iskew*( jc+1 )+ioffg, jc+1 )
918 angle = twopi*dlarnd( 1, iseed )
919 c = cos( angle )*zlarnd( 5, iseed )
920 s = sin( angle )*zlarnd( 5, iseed )
925 ztemp = dconjg( ztemp )
929 CALL zlarot( .false., jc.GT.k, .true., il, c, s,
930 $ a( irow-iskew*jc+ioffg, jc ), ilda,
932 CALL zlarot( .true., .true., .false.,
933 $ min( k, n-jc )+1, ct, st,
934 $ a( ( 1-iskew )*jc+ioffg, jc ), ilda,
940 DO 270 jch = jc - k, 1, -k
941 CALL zlartg( a( jch+1-iskew*( icol+1 )+ioffg,
942 $ icol+1 ), extra, realc, s, dummy )
943 dummy = zlarnd( 5, iseed )
944 c = dconjg( realc*dummy )
945 s = dconjg( -s*dummy )
946 ztemp = a( jch-iskew*( jch+1 )+ioffg, jch+1 )
951 ztemp = dconjg( ztemp )
955 CALL zlarot( .true., .true., .true., k+2, c, s,
956 $ a( ( 1-iskew )*jch+ioffg, jch ),
957 $ ilda, ztemp, extra )
958 irow = max( 1, jch-k )
959 il = min( jch+1, k+2 )
961 CALL zlarot( .false., jch.GT.k, .true., il, ct,
962 $ st, a( irow-iskew*jch+ioffg, jch ),
963 $ ilda, extra, ztemp )
972 IF( ipack.NE.ipackg .AND. ipack.NE.3 )
THEN
974 irow = ioffst - iskew*jc
976 DO 300 jr = jc, min( n, jc+uub )
977 a( jr+irow, jc ) = a( jc-iskew*jr+ioffg, jr )
980 DO 310 jr = jc, min( n, jc+uub )
981 a( jr+irow, jc ) = dconjg( a( jc-iskew*jr+
986 IF( ipack.EQ.5 )
THEN
987 DO 340 jc = n - uub + 1, n
988 DO 330 jr = n + 2 - jc, uub + 1
993 IF( ipackg.EQ.6 )
THEN
1003 IF( ipack.GE.5 )
THEN
1012 a( ( 1-iskew )*j+ioffg, j ) = dcmplx( d( j ) )
1016 DO 370 jc = n - 1, 1, -1
1017 il = min( n+1-jc, k+2 )
1019 ztemp = a( 1+( 1-iskew )*jc+ioffg, jc )
1020 angle = twopi*dlarnd( 1, iseed )
1021 c = cos( angle )*zlarnd( 5, iseed )
1022 s = sin( angle )*zlarnd( 5, iseed )
1027 ztemp = dconjg( ztemp )
1031 CALL zlarot( .false., .true., n-jc.GT.k, il, c, s,
1032 $ a( ( 1-iskew )*jc+ioffg, jc ), ilda,
1034 icol = max( 1, jc-k+1 )
1035 CALL zlarot( .true., .false., .true., jc+2-icol,
1036 $ ct, st, a( jc-iskew*icol+ioffg,
1037 $ icol ), ilda, dummy, ztemp )
1042 DO 360 jch = jc + k, n - 1, k
1043 CALL zlartg( a( jch-iskew*icol+ioffg, icol ),
1044 $ extra, realc, s, dummy )
1045 dummy = zlarnd( 5, iseed )
1048 ztemp = a( 1+( 1-iskew )*jch+ioffg, jch )
1053 ztemp = dconjg( ztemp )
1057 CALL zlarot( .true., .true., .true., k+2, c, s,
1058 $ a( jch-iskew*icol+ioffg, icol ),
1059 $ ilda, extra, ztemp )
1060 il = min( n+1-jch, k+2 )
1062 CALL zlarot( .false., .true., n-jch.GT.k, il,
1063 $ ct, st, a( ( 1-iskew )*jch+ioffg,
1064 $ jch ), ilda, ztemp, extra )
1073 IF( ipack.NE.ipackg .AND. ipack.NE.4 )
THEN
1074 DO 410 jc = n, 1, -1
1075 irow = ioffst - iskew*jc
1077 DO 390 jr = jc, max( 1, jc-uub ), -1
1078 a( jr+irow, jc ) = a( jc-iskew*jr+ioffg, jr )
1081 DO 400 jr = jc, max( 1, jc-uub ), -1
1082 a( jr+irow, jc ) = dconjg( a( jc-iskew*jr+
1087 IF( ipack.EQ.6 )
THEN
1089 DO 420 jr = 1, uub + 1 - jc
1094 IF( ipackg.EQ.5 )
THEN
1104 IF( .NOT.csym )
THEN
1106 irow = ioffst + ( 1-iskew )*jc
1107 a( irow, jc ) = dcmplx( dble( a( irow, jc ) ) )
1122 IF( isym.EQ.1 )
THEN
1126 CALL zlagge( mr, nc, llb, uub, d, a, lda, iseed, work,
1134 CALL zlagsy( m, llb, d, a, lda, iseed, work, iinfo )
1136 CALL zlaghe( m, llb, d, a, lda, iseed, work, iinfo )
1140 IF( iinfo.NE.0 )
THEN
1148 IF( ipack.NE.ipackg )
THEN
1149 IF( ipack.EQ.1 )
THEN
1159 ELSE IF( ipack.EQ.2 )
THEN
1169 ELSE IF( ipack.EQ.3 )
THEN
1178 IF( irow.GT.lda )
THEN
1182 a( irow, icol ) = a( i, j )
1186 ELSE IF( ipack.EQ.4 )
THEN
1195 IF( irow.GT.lda )
THEN
1199 a( irow, icol ) = a( i, j )
1203 ELSE IF( ipack.GE.5 )
THEN
1215 DO 530 i = min( j+llb, m ), 1, -1
1216 a( i-j+uub+1, j ) = a( i, j )
1220 DO 560 j = uub + 2, n
1221 DO 550 i = j - uub, min( j+llb, m )
1222 a( i-j+uub+1, j ) = a( i, j )
1232 IF( ipack.EQ.3 .OR. ipack.EQ.4 )
THEN
1234 DO 570 jr = irow + 1, lda
1240 ELSE IF( ipack.GE.5 )
THEN
1251 DO 590 jr = 1, uub + 1 - jc
1254 DO 600 jr = max( 1, min( ir1, ir2-jc ) ), lda
subroutine zlatmt(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, RANK, KL, KU, PACK, A, LDA, WORK, INFO)
ZLATMT
subroutine zlaghe(N, K, D, A, LDA, ISEED, WORK, INFO)
ZLAGHE
subroutine zlaset(UPLO, M, N, ALPHA, BETA, A, LDA)
ZLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine zlagsy(N, K, D, A, LDA, ISEED, WORK, INFO)
ZLAGSY
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine dscal(N, DA, DX, INCX)
DSCAL
subroutine dlatm7(MODE, COND, IRSIGN, IDIST, ISEED, D, N, RANK, INFO)
DLATM7
subroutine zlagge(M, N, KL, KU, D, A, LDA, ISEED, WORK, INFO)
ZLAGGE
subroutine zlarot(LROWS, LLEFT, LRIGHT, NL, C, S, A, LDA, XLEFT, XRIGHT)
ZLAROT
subroutine zlartg(F, G, CS, SN, R)
ZLARTG generates a plane rotation with real cosine and complex sine.