338 SUBROUTINE clatmt( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX,
339 $ RANK, KL, KU, PACK, A, LDA, WORK, INFO )
347 INTEGER INFO, KL, KU, LDA, M, MODE, N, RANK
348 CHARACTER DIST, PACK, SYM
351 COMPLEX A( LDA, * ), WORK( * )
360 parameter( zero = 0.0e+0 )
362 parameter( one = 1.0e+0 )
364 parameter( czero = ( 0.0e+0, 0.0e+0 ) )
366 parameter( twopi = 6.28318530717958647692528676655900576839e+0 )
369 COMPLEX C, CT, CTEMP, DUMMY, EXTRA, S, ST
370 REAL 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
382 EXTERNAL clarnd, slarnd, lsame
390 INTRINSIC abs, cmplx, conjg, cos, max, min, mod, real,
402 IF( m.EQ.0 .OR. n.EQ.0 )
407 IF( lsame( dist,
'U' ) )
THEN
409 ELSE IF( lsame( dist,
'S' ) )
THEN
411 ELSE IF( lsame( dist,
'N' ) )
THEN
419 IF( lsame( sym,
'N' ) )
THEN
423 ELSE IF( lsame( sym,
'P' ) )
THEN
427 ELSE IF( lsame( sym,
'S' ) )
THEN
431 ELSE IF( lsame( sym,
'H' ) )
THEN
442 IF( lsame( pack,
'N' ) )
THEN
444 ELSE IF( lsame( pack,
'U' ) )
THEN
447 ELSE IF( lsame( pack,
'L' ) )
THEN
450 ELSE IF( lsame( pack,
'C' ) )
THEN
453 ELSE IF( lsame( pack,
'R' ) )
THEN
456 ELSE IF( lsame( pack,
'B' ) )
THEN
459 ELSE IF( lsame( pack,
'Q' ) )
THEN
462 ELSE IF( lsame( pack,
'Z' ) )
THEN
476 IF( ipack.EQ.5 .OR. ipack.EQ.6 )
THEN
478 ELSE IF( ipack.EQ.7 )
THEN
479 minlda = llb + uub + 1
489 IF( real( llb+uub ).LT.0.3*real( max( 1, mr+nc ) ) )
495 IF( lda.LT.m .AND. lda.GE.minlda )
502 ELSE IF( m.NE.n .AND. isym.NE.1 )
THEN
504 ELSE IF( n.LT.0 )
THEN
506 ELSE IF( idist.EQ.-1 )
THEN
508 ELSE IF( isym.EQ.-1 )
THEN
510 ELSE IF( abs( mode ).GT.6 )
THEN
512 ELSE IF( ( mode.NE.0 .AND. abs( mode ).NE.6 ) .AND. cond.LT.one )
515 ELSE IF( kl.LT.0 )
THEN
517 ELSE IF( ku.LT.0 .OR. ( isym.NE.1 .AND. kl.NE.ku ) )
THEN
519 ELSE IF( ipack.EQ.-1 .OR. ( isympk.EQ.1 .AND. isym.EQ.1 ) .OR.
520 $ ( isympk.EQ.2 .AND. isym.EQ.1 .AND. kl.GT.0 ) .OR.
521 $ ( isympk.EQ.3 .AND. isym.EQ.1 .AND. ku.GT.0 ) .OR.
522 $ ( isympk.NE.0 .AND. m.NE.n ) )
THEN
524 ELSE IF( lda.LT.max( 1, minlda ) )
THEN
529 CALL xerbla(
'CLATMT', -info )
536 iseed( i ) = mod( abs( iseed( i ) ), 4096 )
539 IF( mod( iseed( 4 ), 2 ).NE.1 )
540 $ iseed( 4 ) = iseed( 4 ) + 1
546 CALL slatm7( mode, cond, irsign, idist, iseed, d, mnmin, rank,
548 IF( iinfo.NE.0 )
THEN
556 IF( abs( d( 1 ) ).LE.abs( d( rank ) ) )
THEN
562 IF( mode.NE.0 .AND. abs( mode ).NE.6 )
THEN
568 temp = max( temp, abs( d( i ) ) )
571 IF( temp.GT.zero )
THEN
578 CALL sscal( rank, alpha, d, 1 )
582 CALL claset(
'Full', lda, n, czero, czero, a, lda )
593 IF( ipack.GT.4 )
THEN
596 IF( ipack.GT.5 )
THEN
616 IF( llb.EQ.0 .AND. uub.EQ.0 )
THEN
618 a( ( 1-iskew )*j+ioffst, j ) = cmplx( d( j ) )
621 IF( ipack.LE.2 .OR. ipack.GE.5 )
624 ELSE IF( givens )
THEN
633 IF( ipack.GT.4 )
THEN
640 a( ( 1-iskew )*j+ioffst, j ) = cmplx( d( j ) )
652 DO 150 jr = 1, min( m+jku, n ) + jkl - 1
654 angle = twopi*slarnd( 1, iseed )
655 c = cos( angle )*clarnd( 5, iseed )
656 s = sin( angle )*clarnd( 5, iseed )
657 icol = max( 1, jr-jkl )
659 il = min( n, jr+jku ) + 1 - icol
660 CALL clarot( .true., jr.GT.jkl, .false., il,
662 $ s, a( jr-iskew*icol+ioffst, icol ),
663 $ ilda, extra, dummy )
670 DO 140 jch = jr - jkl, 1, -jkl - jku
672 CALL clartg( a( ir+1-iskew*( ic+1 )+ioffst,
673 $ ic+1 ), extra, realc, s, dummy )
674 dummy = clarnd( 5, iseed )
675 c = conjg( realc*dummy )
676 s = conjg( -s*dummy )
678 irow = max( 1, jch-jku )
682 CALL clarot( .false., iltemp, .true., il, c,
684 $ a( irow-iskew*ic+ioffst, ic ),
685 $ ilda, ctemp, extra )
687 CALL clartg( a( irow+1-iskew*( ic+1 )+ioffst,
688 $ ic+1 ), ctemp, realc, s, dummy )
689 dummy = clarnd( 5, iseed )
690 c = conjg( realc*dummy )
691 s = conjg( -s*dummy )
693 icol = max( 1, jch-jku-jkl )
696 CALL clarot( .true., jch.GT.jku+jkl,
698 $ il, c, s, a( irow-iskew*icol+
699 $ ioffst, icol ), ilda, extra,
713 DO 180 jc = 1, min( n+jkl, m ) + jku - 1
715 angle = twopi*slarnd( 1, iseed )
716 c = cos( angle )*clarnd( 5, iseed )
717 s = sin( angle )*clarnd( 5, iseed )
718 irow = max( 1, jc-jku )
720 il = min( m, jc+jkl ) + 1 - irow
721 CALL clarot( .false., jc.GT.jku, .false., il,
723 $ s, a( irow-iskew*jc+ioffst, jc ),
724 $ ilda, extra, dummy )
731 DO 170 jch = jc - jku, 1, -jkl - jku
733 CALL clartg( a( ir+1-iskew*( ic+1 )+ioffst,
734 $ ic+1 ), extra, realc, s, dummy )
735 dummy = clarnd( 5, iseed )
736 c = conjg( realc*dummy )
737 s = conjg( -s*dummy )
739 icol = max( 1, jch-jkl )
743 CALL clarot( .true., iltemp, .true., il, c,
745 $ a( ir-iskew*icol+ioffst, icol ),
746 $ ilda, ctemp, extra )
748 CALL clartg( a( ir+1-iskew*( icol+1 )+ioffst,
749 $ icol+1 ), ctemp, realc, s,
751 dummy = clarnd( 5, iseed )
752 c = conjg( realc*dummy )
753 s = conjg( -s*dummy )
754 irow = max( 1, jch-jkl-jku )
757 CALL clarot( .false., jch.GT.jkl+jku,
759 $ il, c, s, a( irow-iskew*icol+
760 $ ioffst, icol ), ilda, extra,
781 iendch = min( m, n+jkl ) - 1
782 DO 210 jc = min( m+jku, n ) - 1, 1 - jkl, -1
784 angle = twopi*slarnd( 1, iseed )
785 c = cos( angle )*clarnd( 5, iseed )
786 s = sin( angle )*clarnd( 5, iseed )
787 irow = max( 1, jc-jku+1 )
789 il = min( m, jc+jkl+1 ) + 1 - irow
790 CALL clarot( .false., .false., jc+jkl.LT.m,
792 $ c, s, a( irow-iskew*jc+ioffst,
793 $ jc ), ilda, dummy, extra )
799 DO 200 jch = jc + jkl, iendch, jkl + jku
802 CALL clartg( a( jch-iskew*ic+ioffst, ic ),
803 $ extra, realc, s, dummy )
804 dummy = clarnd( 5, iseed )
809 icol = min( n-1, jch+jku )
810 iltemp = jch + jku.LT.n
812 CALL clarot( .true., ilextr, iltemp,
814 $ c, s, a( jch-iskew*ic+ioffst, ic ),
815 $ ilda, extra, ctemp )
817 CALL clartg( a( jch-iskew*icol+ioffst,
818 $ icol ), ctemp, realc, s, dummy )
819 dummy = clarnd( 5, iseed )
822 il = min( iendch, jch+jkl+jku ) + 2 - jch
824 CALL clarot( .false., .true.,
825 $ jch+jkl+jku.LE.iendch, il, c, s,
826 $ a( jch-iskew*icol+ioffst,
827 $ icol ), ilda, ctemp, extra )
842 iendch = min( n, m+jku ) - 1
843 DO 240 jr = min( n+jkl, m ) - 1, 1 - jku, -1
845 angle = twopi*slarnd( 1, iseed )
846 c = cos( angle )*clarnd( 5, iseed )
847 s = sin( angle )*clarnd( 5, iseed )
848 icol = max( 1, jr-jkl+1 )
850 il = min( n, jr+jku+1 ) + 1 - icol
851 CALL clarot( .true., .false., jr+jku.LT.n,
853 $ c, s, a( jr-iskew*icol+ioffst,
854 $ icol ), ilda, dummy, extra )
860 DO 230 jch = jr + jku, iendch, jkl + jku
863 CALL clartg( a( ir-iskew*jch+ioffst, jch ),
864 $ extra, realc, s, dummy )
865 dummy = clarnd( 5, iseed )
870 irow = min( m-1, jch+jkl )
871 iltemp = jch + jkl.LT.m
873 CALL clarot( .false., ilextr, iltemp,
875 $ c, s, a( ir-iskew*jch+ioffst,
876 $ jch ), ilda, extra, ctemp )
878 CALL clartg( a( irow-iskew*jch+ioffst, jch ),
879 $ ctemp, realc, s, dummy )
880 dummy = clarnd( 5, iseed )
883 il = min( iendch, jch+jkl+jku ) + 2 - jch
885 CALL clarot( .true., .true.,
886 $ jch+jkl+jku.LE.iendch, il, c, s,
887 $ a( irow-iskew*jch+ioffst, jch ),
888 $ ilda, ctemp, extra )
909 IF( ipack.GE.5 )
THEN
917 a( ( 1-iskew )*j+ioffg, j ) = cmplx( d( j ) )
922 irow = max( 1, jc-k )
923 il = min( jc+1, k+2 )
925 ctemp = a( jc-iskew*( jc+1 )+ioffg, jc+1 )
926 angle = twopi*slarnd( 1, iseed )
927 c = cos( angle )*clarnd( 5, iseed )
928 s = sin( angle )*clarnd( 5, iseed )
933 ctemp = conjg( ctemp )
937 CALL clarot( .false., jc.GT.k, .true., il, c, s,
938 $ a( irow-iskew*jc+ioffg, jc ), ilda,
940 CALL clarot( .true., .true., .false.,
941 $ min( k, n-jc )+1, ct, st,
942 $ a( ( 1-iskew )*jc+ioffg, jc ), ilda,
948 DO 270 jch = jc - k, 1, -k
949 CALL clartg( a( jch+1-iskew*( icol+1 )+ioffg,
950 $ icol+1 ), extra, realc, s, dummy )
951 dummy = clarnd( 5, iseed )
952 c = conjg( realc*dummy )
953 s = conjg( -s*dummy )
954 ctemp = a( jch-iskew*( jch+1 )+ioffg, jch+1 )
959 ctemp = conjg( ctemp )
963 CALL clarot( .true., .true., .true., k+2, c,
965 $ a( ( 1-iskew )*jch+ioffg, jch ),
966 $ ilda, ctemp, extra )
967 irow = max( 1, jch-k )
968 il = min( jch+1, k+2 )
970 CALL clarot( .false., jch.GT.k, .true., il,
972 $ st, a( irow-iskew*jch+ioffg, jch ),
973 $ ilda, extra, ctemp )
982 IF( ipack.NE.ipackg .AND. ipack.NE.3 )
THEN
984 irow = ioffst - iskew*jc
986 DO 300 jr = jc, min( n, jc+uub )
987 a( jr+irow, jc ) = a( jc-iskew*jr+ioffg, jr )
990 DO 310 jr = jc, min( n, jc+uub )
991 a( jr+irow, jc ) = conjg( a( jc-iskew*jr+
996 IF( ipack.EQ.5 )
THEN
997 DO 340 jc = n - uub + 1, n
998 DO 330 jr = n + 2 - jc, uub + 1
1003 IF( ipackg.EQ.6 )
THEN
1013 IF( ipack.GE.5 )
THEN
1022 a( ( 1-iskew )*j+ioffg, j ) = cmplx( d( j ) )
1026 DO 370 jc = n - 1, 1, -1
1027 il = min( n+1-jc, k+2 )
1029 ctemp = a( 1+( 1-iskew )*jc+ioffg, jc )
1030 angle = twopi*slarnd( 1, iseed )
1031 c = cos( angle )*clarnd( 5, iseed )
1032 s = sin( angle )*clarnd( 5, iseed )
1037 ctemp = conjg( ctemp )
1041 CALL clarot( .false., .true., n-jc.GT.k, il, c,
1043 $ a( ( 1-iskew )*jc+ioffg, jc ), ilda,
1045 icol = max( 1, jc-k+1 )
1046 CALL clarot( .true., .false., .true., jc+2-icol,
1047 $ ct, st, a( jc-iskew*icol+ioffg,
1048 $ icol ), ilda, dummy, ctemp )
1053 DO 360 jch = jc + k, n - 1, k
1054 CALL clartg( a( jch-iskew*icol+ioffg, icol ),
1055 $ extra, realc, s, dummy )
1056 dummy = clarnd( 5, iseed )
1059 ctemp = a( 1+( 1-iskew )*jch+ioffg, jch )
1064 ctemp = conjg( ctemp )
1068 CALL clarot( .true., .true., .true., k+2, c,
1070 $ a( jch-iskew*icol+ioffg, icol ),
1071 $ ilda, extra, ctemp )
1072 il = min( n+1-jch, k+2 )
1074 CALL clarot( .false., .true., n-jch.GT.k, il,
1075 $ ct, st, a( ( 1-iskew )*jch+ioffg,
1076 $ jch ), ilda, ctemp, extra )
1085 IF( ipack.NE.ipackg .AND. ipack.NE.4 )
THEN
1086 DO 410 jc = n, 1, -1
1087 irow = ioffst - iskew*jc
1089 DO 390 jr = jc, max( 1, jc-uub ), -1
1090 a( jr+irow, jc ) = a( jc-iskew*jr+ioffg, jr )
1093 DO 400 jr = jc, max( 1, jc-uub ), -1
1094 a( jr+irow, jc ) = conjg( a( jc-iskew*jr+
1099 IF( ipack.EQ.6 )
THEN
1101 DO 420 jr = 1, uub + 1 - jc
1106 IF( ipackg.EQ.5 )
THEN
1116 IF( .NOT.csym )
THEN
1118 irow = ioffst + ( 1-iskew )*jc
1119 a( irow, jc ) = cmplx( real( a( irow, jc ) ) )
1134 IF( isym.EQ.1 )
THEN
1138 CALL clagge( mr, nc, llb, uub, d, a, lda, iseed, work,
1146 CALL clagsy( m, llb, d, a, lda, iseed, work, iinfo )
1148 CALL claghe( m, llb, d, a, lda, iseed, work, iinfo )
1152 IF( iinfo.NE.0 )
THEN
1160 IF( ipack.NE.ipackg )
THEN
1161 IF( ipack.EQ.1 )
THEN
1171 ELSE IF( ipack.EQ.2 )
THEN
1181 ELSE IF( ipack.EQ.3 )
THEN
1190 IF( irow.GT.lda )
THEN
1194 a( irow, icol ) = a( i, j )
1198 ELSE IF( ipack.EQ.4 )
THEN
1207 IF( irow.GT.lda )
THEN
1211 a( irow, icol ) = a( i, j )
1215 ELSE IF( ipack.GE.5 )
THEN
1227 DO 530 i = min( j+llb, m ), 1, -1
1228 a( i-j+uub+1, j ) = a( i, j )
1232 DO 560 j = uub + 2, n
1233 DO 550 i = j - uub, min( j+llb, m )
1234 a( i-j+uub+1, j ) = a( i, j )
1244 IF( ipack.EQ.3 .OR. ipack.EQ.4 )
THEN
1246 DO 570 jr = irow + 1, lda
1252 ELSE IF( ipack.GE.5 )
THEN
1263 DO 590 jr = 1, uub + 1 - jc
1266 DO 600 jr = max( 1, min( ir1, ir2-jc ) ), lda