338 SUBROUTINE zlatmt( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX,
339 $ RANK, KL, KU, PACK, A, LDA, WORK, INFO )
346 DOUBLE PRECISION COND, DMAX
347 INTEGER INFO, KL, KU, LDA, M, MODE, N, RANK
348 CHARACTER DIST, PACK, SYM
351 COMPLEX*16 A( LDA, * ), WORK( * )
352 DOUBLE PRECISION D( * )
359 DOUBLE PRECISION ZERO
360 parameter( zero = 0.0d+0 )
362 parameter( one = 1.0d+0 )
364 parameter( czero = ( 0.0d+0, 0.0d+0 ) )
365 DOUBLE PRECISION TWOPI
366 parameter( twopi = 6.28318530717958647692528676655900576839d+0 )
369 COMPLEX*16 C, CT, DUMMY, EXTRA, S, ST, ZTEMP
370 DOUBLE PRECISION ALPHA, ANGLE, REALC, TEMP
371 INTEGER I, IC, ICOL, IDIST, IENDCH, IINFO, IL, ILDA,
372 $ ioffg, ioffst, ipack, ipackg, ir, ir1, ir2,
373 $ irow, irsign, iskew, isym, isympk, j, jc, jch,
374 $ jkl, jku, jr, k, llb, minlda, mnmin, mr, nc,
376 LOGICAL CSYM, GIVENS, ILEXTR, ILTEMP, TOPDWN
380 DOUBLE PRECISION DLARND
382 EXTERNAL zlarnd, dlarnd, lsame
389 INTRINSIC abs, cos, dble, dcmplx, dconjg, max, min, mod,
401 IF( m.EQ.0 .OR. n.EQ.0 )
406 IF( lsame( dist,
'U' ) )
THEN
408 ELSE IF( lsame( dist,
'S' ) )
THEN
410 ELSE IF( lsame( dist,
'N' ) )
THEN
418 IF( lsame( sym,
'N' ) )
THEN
422 ELSE IF( lsame( sym,
'P' ) )
THEN
426 ELSE IF( lsame( sym,
'S' ) )
THEN
430 ELSE IF( lsame( sym,
'H' ) )
THEN
441 IF( lsame( pack,
'N' ) )
THEN
443 ELSE IF( lsame( pack,
'U' ) )
THEN
446 ELSE IF( lsame( pack,
'L' ) )
THEN
449 ELSE IF( lsame( pack,
'C' ) )
THEN
452 ELSE IF( lsame( pack,
'R' ) )
THEN
455 ELSE IF( lsame( pack,
'B' ) )
THEN
458 ELSE IF( lsame( pack,
'Q' ) )
THEN
461 ELSE IF( lsame( pack,
'Z' ) )
THEN
475 IF( ipack.EQ.5 .OR. ipack.EQ.6 )
THEN
477 ELSE IF( ipack.EQ.7 )
THEN
478 minlda = llb + uub + 1
488 IF( dble( llb+uub ).LT.0.3d0*dble( max( 1, mr+nc ) ) )
494 IF( lda.LT.m .AND. lda.GE.minlda )
501 ELSE IF( m.NE.n .AND. isym.NE.1 )
THEN
503 ELSE IF( n.LT.0 )
THEN
505 ELSE IF( idist.EQ.-1 )
THEN
507 ELSE IF( isym.EQ.-1 )
THEN
509 ELSE IF( abs( mode ).GT.6 )
THEN
511 ELSE IF( ( mode.NE.0 .AND. abs( mode ).NE.6 ) .AND. cond.LT.one )
514 ELSE IF( kl.LT.0 )
THEN
516 ELSE IF( ku.LT.0 .OR. ( isym.NE.1 .AND. kl.NE.ku ) )
THEN
518 ELSE IF( ipack.EQ.-1 .OR. ( isympk.EQ.1 .AND. isym.EQ.1 ) .OR.
519 $ ( isympk.EQ.2 .AND. isym.EQ.1 .AND. kl.GT.0 ) .OR.
520 $ ( isympk.EQ.3 .AND. isym.EQ.1 .AND. ku.GT.0 ) .OR.
521 $ ( isympk.NE.0 .AND. m.NE.n ) )
THEN
523 ELSE IF( lda.LT.max( 1, minlda ) )
THEN
528 CALL xerbla(
'ZLATMT', -info )
535 iseed( i ) = mod( abs( iseed( i ) ), 4096 )
538 IF( mod( iseed( 4 ), 2 ).NE.1 )
539 $ iseed( 4 ) = iseed( 4 ) + 1
545 CALL dlatm7( mode, cond, irsign, idist, iseed, d, mnmin, rank,
547 IF( iinfo.NE.0 )
THEN
555 IF( abs( d( 1 ) ).LE.abs( d( rank ) ) )
THEN
561 IF( mode.NE.0 .AND. abs( mode ).NE.6 )
THEN
567 temp = max( temp, abs( d( i ) ) )
570 IF( temp.GT.zero )
THEN
577 CALL dscal( rank, alpha, d, 1 )
581 CALL zlaset(
'Full', lda, n, czero, czero, a, lda )
592 IF( ipack.GT.4 )
THEN
595 IF( ipack.GT.5 )
THEN
615 IF( llb.EQ.0 .AND. uub.EQ.0 )
THEN
617 a( ( 1-iskew )*j+ioffst, j ) = dcmplx( d( j ) )
620 IF( ipack.LE.2 .OR. ipack.GE.5 )
623 ELSE IF( givens )
THEN
632 IF( ipack.GT.4 )
THEN
639 a( ( 1-iskew )*j+ioffst, j ) = dcmplx( d( j ) )
651 DO 150 jr = 1, min( m+jku, n ) + jkl - 1
653 angle = twopi*dlarnd( 1, iseed )
654 c = cos( angle )*zlarnd( 5, iseed )
655 s = sin( angle )*zlarnd( 5, iseed )
656 icol = max( 1, jr-jkl )
658 il = min( n, jr+jku ) + 1 - icol
659 CALL zlarot( .true., jr.GT.jkl, .false., il,
661 $ s, a( jr-iskew*icol+ioffst, icol ),
662 $ ilda, extra, dummy )
669 DO 140 jch = jr - jkl, 1, -jkl - jku
671 CALL zlartg( a( ir+1-iskew*( ic+1 )+ioffst,
672 $ ic+1 ), extra, realc, s, dummy )
673 dummy = dlarnd( 5, iseed )
674 c = dconjg( realc*dummy )
675 s = dconjg( -s*dummy )
677 irow = max( 1, jch-jku )
681 CALL zlarot( .false., iltemp, .true., il, c,
683 $ a( irow-iskew*ic+ioffst, ic ),
684 $ ilda, ztemp, extra )
686 CALL zlartg( a( irow+1-iskew*( ic+1 )+ioffst,
687 $ ic+1 ), ztemp, realc, s, dummy )
688 dummy = zlarnd( 5, iseed )
689 c = dconjg( realc*dummy )
690 s = dconjg( -s*dummy )
692 icol = max( 1, jch-jku-jkl )
695 CALL zlarot( .true., jch.GT.jku+jkl,
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,
722 $ s, a( irow-iskew*jc+ioffst, jc ),
723 $ ilda, extra, dummy )
730 DO 170 jch = jc - jku, 1, -jkl - jku
732 CALL zlartg( a( ir+1-iskew*( ic+1 )+ioffst,
733 $ ic+1 ), extra, realc, s, dummy )
734 dummy = zlarnd( 5, iseed )
735 c = dconjg( realc*dummy )
736 s = dconjg( -s*dummy )
738 icol = max( 1, jch-jkl )
742 CALL zlarot( .true., iltemp, .true., il, c,
744 $ a( ir-iskew*icol+ioffst, icol ),
745 $ ilda, ztemp, extra )
747 CALL zlartg( a( ir+1-iskew*( icol+1 )+ioffst,
748 $ icol+1 ), ztemp, realc, s,
750 dummy = zlarnd( 5, iseed )
751 c = dconjg( realc*dummy )
752 s = dconjg( -s*dummy )
753 irow = max( 1, jch-jkl-jku )
756 CALL zlarot( .false., jch.GT.jkl+jku,
758 $ il, c, s, a( irow-iskew*icol+
759 $ ioffst, icol ), ilda, extra,
780 iendch = min( m, n+jkl ) - 1
781 DO 210 jc = min( m+jku, n ) - 1, 1 - jkl, -1
783 angle = twopi*dlarnd( 1, iseed )
784 c = cos( angle )*zlarnd( 5, iseed )
785 s = sin( angle )*zlarnd( 5, iseed )
786 irow = max( 1, jc-jku+1 )
788 il = min( m, jc+jkl+1 ) + 1 - irow
789 CALL zlarot( .false., .false., jc+jkl.LT.m,
791 $ c, s, a( irow-iskew*jc+ioffst,
792 $ jc ), ilda, dummy, extra )
798 DO 200 jch = jc + jkl, iendch, jkl + jku
801 CALL zlartg( a( jch-iskew*ic+ioffst, ic ),
802 $ extra, realc, s, dummy )
803 dummy = zlarnd( 5, iseed )
808 icol = min( n-1, jch+jku )
809 iltemp = jch + jku.LT.n
811 CALL zlarot( .true., ilextr, iltemp,
813 $ c, s, a( jch-iskew*ic+ioffst, ic ),
814 $ ilda, extra, ztemp )
816 CALL zlartg( a( jch-iskew*icol+ioffst,
817 $ icol ), ztemp, realc, s, dummy )
818 dummy = zlarnd( 5, iseed )
821 il = min( iendch, jch+jkl+jku ) + 2 - jch
823 CALL zlarot( .false., .true.,
824 $ jch+jkl+jku.LE.iendch, il, c, s,
825 $ a( jch-iskew*icol+ioffst,
826 $ icol ), ilda, ztemp, extra )
841 iendch = min( n, m+jku ) - 1
842 DO 240 jr = min( n+jkl, m ) - 1, 1 - jku, -1
844 angle = twopi*dlarnd( 1, iseed )
845 c = cos( angle )*zlarnd( 5, iseed )
846 s = sin( angle )*zlarnd( 5, iseed )
847 icol = max( 1, jr-jkl+1 )
849 il = min( n, jr+jku+1 ) + 1 - icol
850 CALL zlarot( .true., .false., jr+jku.LT.n,
852 $ c, s, a( jr-iskew*icol+ioffst,
853 $ icol ), ilda, dummy, extra )
859 DO 230 jch = jr + jku, iendch, jkl + jku
862 CALL zlartg( a( ir-iskew*jch+ioffst, jch ),
863 $ extra, realc, s, dummy )
864 dummy = zlarnd( 5, iseed )
869 irow = min( m-1, jch+jkl )
870 iltemp = jch + jkl.LT.m
872 CALL zlarot( .false., ilextr, iltemp,
874 $ c, s, a( ir-iskew*jch+ioffst,
875 $ jch ), ilda, extra, ztemp )
877 CALL zlartg( a( irow-iskew*jch+ioffst, jch ),
878 $ ztemp, realc, s, dummy )
879 dummy = zlarnd( 5, iseed )
882 il = min( iendch, jch+jkl+jku ) + 2 - jch
884 CALL zlarot( .true., .true.,
885 $ jch+jkl+jku.LE.iendch, il, c, s,
886 $ a( irow-iskew*jch+ioffst, jch ),
887 $ ilda, ztemp, extra )
908 IF( ipack.GE.5 )
THEN
916 a( ( 1-iskew )*j+ioffg, j ) = dcmplx( d( j ) )
921 irow = max( 1, jc-k )
922 il = min( jc+1, k+2 )
924 ztemp = a( jc-iskew*( jc+1 )+ioffg, jc+1 )
925 angle = twopi*dlarnd( 1, iseed )
926 c = cos( angle )*zlarnd( 5, iseed )
927 s = sin( angle )*zlarnd( 5, iseed )
932 ztemp = dconjg( ztemp )
936 CALL zlarot( .false., jc.GT.k, .true., il, c, s,
937 $ a( irow-iskew*jc+ioffg, jc ), ilda,
939 CALL zlarot( .true., .true., .false.,
940 $ min( k, n-jc )+1, ct, st,
941 $ a( ( 1-iskew )*jc+ioffg, jc ), ilda,
947 DO 270 jch = jc - k, 1, -k
948 CALL zlartg( a( jch+1-iskew*( icol+1 )+ioffg,
949 $ icol+1 ), extra, realc, s, dummy )
950 dummy = zlarnd( 5, iseed )
951 c = dconjg( realc*dummy )
952 s = dconjg( -s*dummy )
953 ztemp = a( jch-iskew*( jch+1 )+ioffg, jch+1 )
958 ztemp = dconjg( ztemp )
962 CALL zlarot( .true., .true., .true., k+2, c,
964 $ a( ( 1-iskew )*jch+ioffg, jch ),
965 $ ilda, ztemp, extra )
966 irow = max( 1, jch-k )
967 il = min( jch+1, k+2 )
969 CALL zlarot( .false., jch.GT.k, .true., il,
971 $ st, a( irow-iskew*jch+ioffg, jch ),
972 $ ilda, extra, ztemp )
981 IF( ipack.NE.ipackg .AND. ipack.NE.3 )
THEN
983 irow = ioffst - iskew*jc
985 DO 300 jr = jc, min( n, jc+uub )
986 a( jr+irow, jc ) = a( jc-iskew*jr+ioffg, jr )
989 DO 310 jr = jc, min( n, jc+uub )
990 a( jr+irow, jc ) = dconjg( a( jc-iskew*jr+
995 IF( ipack.EQ.5 )
THEN
996 DO 340 jc = n - uub + 1, n
997 DO 330 jr = n + 2 - jc, uub + 1
1002 IF( ipackg.EQ.6 )
THEN
1012 IF( ipack.GE.5 )
THEN
1021 a( ( 1-iskew )*j+ioffg, j ) = dcmplx( d( j ) )
1025 DO 370 jc = n - 1, 1, -1
1026 il = min( n+1-jc, k+2 )
1028 ztemp = a( 1+( 1-iskew )*jc+ioffg, jc )
1029 angle = twopi*dlarnd( 1, iseed )
1030 c = cos( angle )*zlarnd( 5, iseed )
1031 s = sin( angle )*zlarnd( 5, iseed )
1036 ztemp = dconjg( ztemp )
1040 CALL zlarot( .false., .true., n-jc.GT.k, il, c,
1042 $ a( ( 1-iskew )*jc+ioffg, jc ), ilda,
1044 icol = max( 1, jc-k+1 )
1045 CALL zlarot( .true., .false., .true., jc+2-icol,
1046 $ ct, st, a( jc-iskew*icol+ioffg,
1047 $ icol ), ilda, dummy, ztemp )
1052 DO 360 jch = jc + k, n - 1, k
1053 CALL zlartg( a( jch-iskew*icol+ioffg, icol ),
1054 $ extra, realc, s, dummy )
1055 dummy = zlarnd( 5, iseed )
1058 ztemp = a( 1+( 1-iskew )*jch+ioffg, jch )
1063 ztemp = dconjg( ztemp )
1067 CALL zlarot( .true., .true., .true., k+2, c,
1069 $ a( jch-iskew*icol+ioffg, icol ),
1070 $ ilda, extra, ztemp )
1071 il = min( n+1-jch, k+2 )
1073 CALL zlarot( .false., .true., n-jch.GT.k, il,
1074 $ ct, st, a( ( 1-iskew )*jch+ioffg,
1075 $ jch ), ilda, ztemp, extra )
1084 IF( ipack.NE.ipackg .AND. ipack.NE.4 )
THEN
1085 DO 410 jc = n, 1, -1
1086 irow = ioffst - iskew*jc
1088 DO 390 jr = jc, max( 1, jc-uub ), -1
1089 a( jr+irow, jc ) = a( jc-iskew*jr+ioffg, jr )
1092 DO 400 jr = jc, max( 1, jc-uub ), -1
1093 a( jr+irow, jc ) = dconjg( a( jc-iskew*jr+
1098 IF( ipack.EQ.6 )
THEN
1100 DO 420 jr = 1, uub + 1 - jc
1105 IF( ipackg.EQ.5 )
THEN
1115 IF( .NOT.csym )
THEN
1117 irow = ioffst + ( 1-iskew )*jc
1118 a( irow, jc ) = dcmplx( dble( a( irow, jc ) ) )
1133 IF( isym.EQ.1 )
THEN
1137 CALL zlagge( mr, nc, llb, uub, d, a, lda, iseed, work,
1145 CALL zlagsy( m, llb, d, a, lda, iseed, work, iinfo )
1147 CALL zlaghe( m, llb, d, a, lda, iseed, work, iinfo )
1151 IF( iinfo.NE.0 )
THEN
1159 IF( ipack.NE.ipackg )
THEN
1160 IF( ipack.EQ.1 )
THEN
1170 ELSE IF( ipack.EQ.2 )
THEN
1180 ELSE IF( ipack.EQ.3 )
THEN
1189 IF( irow.GT.lda )
THEN
1193 a( irow, icol ) = a( i, j )
1197 ELSE IF( ipack.EQ.4 )
THEN
1206 IF( irow.GT.lda )
THEN
1210 a( irow, icol ) = a( i, j )
1214 ELSE IF( ipack.GE.5 )
THEN
1226 DO 530 i = min( j+llb, m ), 1, -1
1227 a( i-j+uub+1, j ) = a( i, j )
1231 DO 560 j = uub + 2, n
1232 DO 550 i = j - uub, min( j+llb, m )
1233 a( i-j+uub+1, j ) = a( i, j )
1243 IF( ipack.EQ.3 .OR. ipack.EQ.4 )
THEN
1245 DO 570 jr = irow + 1, lda
1251 ELSE IF( ipack.GE.5 )
THEN
1262 DO 590 jr = 1, uub + 1 - jc
1265 DO 600 jr = max( 1, min( ir1, ir2-jc ) ), lda