488 SUBROUTINE zlatmr( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX,
489 $ RSIGN, GRADE, DL, MODEL, CONDL, DR, MODER,
490 $ CONDR, PIVTNG, IPIVOT, KL, KU, SPARSE, ANORM,
491 $ PACK, A, LDA, IWORK, INFO )
499 CHARACTER DIST, GRADE, PACK, PIVTNG, RSIGN, SYM
500 INTEGER INFO, KL, KU, LDA, M, MODE, MODEL, MODER, N
501 DOUBLE PRECISION ANORM, COND, CONDL, CONDR, SPARSE
505 INTEGER IPIVOT( * ), ISEED( 4 ), IWORK( * )
506 COMPLEX*16 A( lda, * ), D( * ), DL( * ), DR( * )
512 DOUBLE PRECISION ZERO
513 parameter( zero = 0.0d0 )
515 parameter( one = 1.0d0 )
517 parameter( cone = ( 1.0d0, 0.0d0 ) )
519 parameter( czero = ( 0.0d0, 0.0d0 ) )
522 LOGICAL BADPVT, DZERO, FULBND
523 INTEGER I, IDIST, IGRADE, IISUB, IPACK, IPVTNG, IRSIGN,
524 $ isub, isym, j, jjsub, jsub, k, kll, kuu, mnmin,
525 $ mnsub, mxsub, npvts
526 DOUBLE PRECISION ONORM, TEMP
527 COMPLEX*16 CALPHA, CTEMP
530 DOUBLE PRECISION TEMPA( 1 )
534 DOUBLE PRECISION ZLANGB, ZLANGE, ZLANSB, ZLANSP, ZLANSY
535 COMPLEX*16 ZLATM2, ZLATM3
536 EXTERNAL lsame, zlangb, zlange, zlansb, zlansp, zlansy,
543 INTRINSIC abs, dble, dconjg, max, min, mod
554 IF( m.EQ.0 .OR. n.EQ.0 )
559 IF( lsame( dist,
'U' ) )
THEN 561 ELSE IF( lsame( dist,
'S' ) )
THEN 563 ELSE IF( lsame( dist,
'N' ) )
THEN 565 ELSE IF( lsame( dist,
'D' ) )
THEN 573 IF( lsame( sym,
'H' ) )
THEN 575 ELSE IF( lsame( sym,
'N' ) )
THEN 577 ELSE IF( lsame( sym,
'S' ) )
THEN 585 IF( lsame( rsign,
'F' ) )
THEN 587 ELSE IF( lsame( rsign,
'T' ) )
THEN 595 IF( lsame( pivtng,
'N' ) )
THEN 597 ELSE IF( lsame( pivtng,
' ' ) )
THEN 599 ELSE IF( lsame( pivtng,
'L' ) )
THEN 602 ELSE IF( lsame( pivtng,
'R' ) )
THEN 605 ELSE IF( lsame( pivtng,
'B' ) )
THEN 608 ELSE IF( lsame( pivtng,
'F' ) )
THEN 617 IF( lsame( grade,
'N' ) )
THEN 619 ELSE IF( lsame( grade,
'L' ) )
THEN 621 ELSE IF( lsame( grade,
'R' ) )
THEN 623 ELSE IF( lsame( grade,
'B' ) )
THEN 625 ELSE IF( lsame( grade,
'E' ) )
THEN 627 ELSE IF( lsame( grade,
'H' ) )
THEN 629 ELSE IF( lsame( grade,
'S' ) )
THEN 637 IF( lsame( pack,
'N' ) )
THEN 639 ELSE IF( lsame( pack,
'U' ) )
THEN 641 ELSE IF( lsame( pack,
'L' ) )
THEN 643 ELSE IF( lsame( pack,
'C' ) )
THEN 645 ELSE IF( lsame( pack,
'R' ) )
THEN 647 ELSE IF( lsame( pack,
'B' ) )
THEN 649 ELSE IF( lsame( pack,
'Q' ) )
THEN 651 ELSE IF( lsame( pack,
'Z' ) )
THEN 666 IF( igrade.EQ.4 .AND. model.EQ.0 )
THEN 668 IF( dl( i ).EQ.czero )
676 IF( ipvtng.GT.0 )
THEN 678 IF( ipivot( j ).LE.0 .OR. ipivot( j ).GT.npvts )
687 ELSE IF( m.NE.n .AND. ( isym.EQ.0 .OR. isym.EQ.2 ) )
THEN 689 ELSE IF( n.LT.0 )
THEN 691 ELSE IF( idist.EQ.-1 )
THEN 693 ELSE IF( isym.EQ.-1 )
THEN 695 ELSE IF( mode.LT.-6 .OR. mode.GT.6 )
THEN 697 ELSE IF( ( mode.NE.-6 .AND. mode.NE.0 .AND. mode.NE.6 ) .AND.
700 ELSE IF( ( mode.NE.-6 .AND. mode.NE.0 .AND. mode.NE.6 ) .AND.
701 $ irsign.EQ.-1 )
THEN 703 ELSE IF( igrade.EQ.-1 .OR. ( igrade.EQ.4 .AND. m.NE.n ) .OR.
704 $ ( ( igrade.EQ.1 .OR. igrade.EQ.2 .OR. igrade.EQ.3 .OR.
705 $ igrade.EQ.4 .OR. igrade.EQ.6 ) .AND. isym.EQ.0 ) .OR.
706 $ ( ( igrade.EQ.1 .OR. igrade.EQ.2 .OR. igrade.EQ.3 .OR.
707 $ igrade.EQ.4 .OR. igrade.EQ.5 ) .AND. isym.EQ.2 ) )
THEN 709 ELSE IF( igrade.EQ.4 .AND. dzero )
THEN 711 ELSE IF( ( igrade.EQ.1 .OR. igrade.EQ.3 .OR. igrade.EQ.4 .OR.
712 $ igrade.EQ.5 .OR. igrade.EQ.6 ) .AND.
713 $ ( model.LT.-6 .OR. model.GT.6 ) )
THEN 715 ELSE IF( ( igrade.EQ.1 .OR. igrade.EQ.3 .OR. igrade.EQ.4 .OR.
716 $ igrade.EQ.5 .OR. igrade.EQ.6 ) .AND.
717 $ ( model.NE.-6 .AND. model.NE.0 .AND. model.NE.6 ) .AND.
718 $ condl.LT.one )
THEN 720 ELSE IF( ( igrade.EQ.2 .OR. igrade.EQ.3 ) .AND.
721 $ ( moder.LT.-6 .OR. moder.GT.6 ) )
THEN 723 ELSE IF( ( igrade.EQ.2 .OR. igrade.EQ.3 ) .AND.
724 $ ( moder.NE.-6 .AND. moder.NE.0 .AND. moder.NE.6 ) .AND.
725 $ condr.LT.one )
THEN 727 ELSE IF( ipvtng.EQ.-1 .OR. ( ipvtng.EQ.3 .AND. m.NE.n ) .OR.
728 $ ( ( ipvtng.EQ.1 .OR. ipvtng.EQ.2 ) .AND. ( isym.EQ.0 .OR.
729 $ isym.EQ.2 ) ) )
THEN 731 ELSE IF( ipvtng.NE.0 .AND. badpvt )
THEN 733 ELSE IF( kl.LT.0 )
THEN 735 ELSE IF( ku.LT.0 .OR. ( ( isym.EQ.0 .OR. isym.EQ.2 ) .AND. kl.NE.
738 ELSE IF( sparse.LT.zero .OR. sparse.GT.one )
THEN 740 ELSE IF( ipack.EQ.-1 .OR. ( ( ipack.EQ.1 .OR. ipack.EQ.2 .OR.
741 $ ipack.EQ.5 .OR. ipack.EQ.6 ) .AND. isym.EQ.1 ) .OR.
742 $ ( ipack.EQ.3 .AND. isym.EQ.1 .AND. ( kl.NE.0 .OR. m.NE.
743 $ n ) ) .OR. ( ipack.EQ.4 .AND. isym.EQ.1 .AND. ( ku.NE.
744 $ 0 .OR. m.NE.n ) ) )
THEN 746 ELSE IF( ( ( ipack.EQ.0 .OR. ipack.EQ.1 .OR. ipack.EQ.2 ) .AND.
747 $ lda.LT.max( 1, m ) ) .OR. ( ( ipack.EQ.3 .OR. ipack.EQ.
748 $ 4 ) .AND. lda.LT.1 ) .OR. ( ( ipack.EQ.5 .OR. ipack.EQ.
749 $ 6 ) .AND. lda.LT.kuu+1 ) .OR.
750 $ ( ipack.EQ.7 .AND. lda.LT.kll+kuu+1 ) )
THEN 755 CALL xerbla(
'ZLATMR', -info )
762 IF( kuu.EQ.n-1 .AND. kll.EQ.m-1 )
768 iseed( i ) = mod( abs( iseed( i ) ), 4096 )
771 iseed( 4 ) = 2*( iseed( 4 ) / 2 ) + 1
777 CALL zlatm1( mode, cond, irsign, idist, iseed, d, mnmin, info )
782 IF( mode.NE.0 .AND. mode.NE.-6 .AND. mode.NE.6 )
THEN 788 temp = max( temp, abs( d( i ) ) )
790 IF( temp.EQ.zero .AND. dmax.NE.czero )
THEN 794 IF( temp.NE.zero )
THEN 800 d( i ) = calpha*d( i )
809 d( i ) = dble( d( i ) )
815 IF( igrade.EQ.1 .OR. igrade.EQ.3 .OR. igrade.EQ.4 .OR. igrade.EQ.
816 $ 5 .OR. igrade.EQ.6 )
THEN 817 CALL zlatm1( model, condl, 0, idist, iseed, dl, m, info )
826 IF( igrade.EQ.2 .OR. igrade.EQ.3 )
THEN 827 CALL zlatm1( moder, condr, 0, idist, iseed, dr, n, info )
836 IF( ipvtng.GT.0 )
THEN 844 iwork( i ) = iwork( k )
848 DO 90 i = npvts, 1, -1
851 iwork( i ) = iwork( k )
867 IF( ipack.EQ.0 )
THEN 871 ctemp = zlatm3( m, n, i, j, isub, jsub, kl, ku,
872 $ idist, iseed, d, igrade, dl, dr, ipvtng,
874 a( isub, jsub ) = ctemp
875 a( jsub, isub ) = dconjg( ctemp )
878 ELSE IF( isym.EQ.1 )
THEN 881 ctemp = zlatm3( m, n, i, j, isub, jsub, kl, ku,
882 $ idist, iseed, d, igrade, dl, dr, ipvtng,
884 a( isub, jsub ) = ctemp
887 ELSE IF( isym.EQ.2 )
THEN 890 ctemp = zlatm3( m, n, i, j, isub, jsub, kl, ku,
891 $ idist, iseed, d, igrade, dl, dr, ipvtng,
893 a( isub, jsub ) = ctemp
894 a( jsub, isub ) = ctemp
899 ELSE IF( ipack.EQ.1 )
THEN 903 ctemp = zlatm3( m, n, i, j, isub, jsub, kl, ku, idist,
904 $ iseed, d, igrade, dl, dr, ipvtng, iwork,
906 mnsub = min( isub, jsub )
907 mxsub = max( isub, jsub )
908 IF( mxsub.EQ.isub .AND. isym.EQ.0 )
THEN 909 a( mnsub, mxsub ) = dconjg( ctemp )
911 a( mnsub, mxsub ) = ctemp
914 $ a( mxsub, mnsub ) = czero
918 ELSE IF( ipack.EQ.2 )
THEN 922 ctemp = zlatm3( m, n, i, j, isub, jsub, kl, ku, idist,
923 $ iseed, d, igrade, dl, dr, ipvtng, iwork,
925 mnsub = min( isub, jsub )
926 mxsub = max( isub, jsub )
927 IF( mxsub.EQ.jsub .AND. isym.EQ.0 )
THEN 928 a( mxsub, mnsub ) = dconjg( ctemp )
930 a( mxsub, mnsub ) = ctemp
933 $ a( mnsub, mxsub ) = czero
937 ELSE IF( ipack.EQ.3 )
THEN 941 ctemp = zlatm3( m, n, i, j, isub, jsub, kl, ku, idist,
942 $ iseed, d, igrade, dl, dr, ipvtng, iwork,
948 mnsub = min( isub, jsub )
949 mxsub = max( isub, jsub )
950 k = mxsub*( mxsub-1 ) / 2 + mnsub
954 jjsub = ( k-1 ) / lda + 1
955 iisub = k - lda*( jjsub-1 )
957 IF( mxsub.EQ.isub .AND. isym.EQ.0 )
THEN 958 a( iisub, jjsub ) = dconjg( ctemp )
960 a( iisub, jjsub ) = ctemp
965 ELSE IF( ipack.EQ.4 )
THEN 969 ctemp = zlatm3( m, n, i, j, isub, jsub, kl, ku, idist,
970 $ iseed, d, igrade, dl, dr, ipvtng, iwork,
975 mnsub = min( isub, jsub )
976 mxsub = max( isub, jsub )
977 IF( mnsub.EQ.1 )
THEN 980 k = n*( n+1 ) / 2 - ( n-mnsub+1 )*( n-mnsub+2 ) /
981 $ 2 + mxsub - mnsub + 1
986 jjsub = ( k-1 ) / lda + 1
987 iisub = k - lda*( jjsub-1 )
989 IF( mxsub.EQ.jsub .AND. isym.EQ.0 )
THEN 990 a( iisub, jjsub ) = dconjg( ctemp )
992 a( iisub, jjsub ) = ctemp
997 ELSE IF( ipack.EQ.5 )
THEN 1000 DO 240 i = j - kuu, j
1002 a( j-i+1, i+n ) = czero
1004 ctemp = zlatm3( m, n, i, j, isub, jsub, kl, ku,
1005 $ idist, iseed, d, igrade, dl, dr, ipvtng,
1007 mnsub = min( isub, jsub )
1008 mxsub = max( isub, jsub )
1009 IF( mxsub.EQ.jsub .AND. isym.EQ.0 )
THEN 1010 a( mxsub-mnsub+1, mnsub ) = dconjg( ctemp )
1012 a( mxsub-mnsub+1, mnsub ) = ctemp
1018 ELSE IF( ipack.EQ.6 )
THEN 1021 DO 260 i = j - kuu, j
1022 ctemp = zlatm3( m, n, i, j, isub, jsub, kl, ku, idist,
1023 $ iseed, d, igrade, dl, dr, ipvtng, iwork,
1025 mnsub = min( isub, jsub )
1026 mxsub = max( isub, jsub )
1027 IF( mxsub.EQ.isub .AND. isym.EQ.0 )
THEN 1028 a( mnsub-mxsub+kuu+1, mxsub ) = dconjg( ctemp )
1030 a( mnsub-mxsub+kuu+1, mxsub ) = ctemp
1035 ELSE IF( ipack.EQ.7 )
THEN 1037 IF( isym.NE.1 )
THEN 1039 DO 280 i = j - kuu, j
1040 ctemp = zlatm3( m, n, i, j, isub, jsub, kl, ku,
1041 $ idist, iseed, d, igrade, dl, dr, ipvtng,
1043 mnsub = min( isub, jsub )
1044 mxsub = max( isub, jsub )
1046 $ a( j-i+1+kuu, i+n ) = czero
1047 IF( mxsub.EQ.isub .AND. isym.EQ.0 )
THEN 1048 a( mnsub-mxsub+kuu+1, mxsub ) = dconjg( ctemp )
1050 a( mnsub-mxsub+kuu+1, mxsub ) = ctemp
1052 IF( i.GE.1 .AND. mnsub.NE.mxsub )
THEN 1053 IF( mnsub.EQ.isub .AND. isym.EQ.0 )
THEN 1054 a( mxsub-mnsub+1+kuu,
1055 $ mnsub ) = dconjg( ctemp )
1057 a( mxsub-mnsub+1+kuu, mnsub ) = ctemp
1062 ELSE IF( isym.EQ.1 )
THEN 1064 DO 300 i = j - kuu, j + kll
1065 ctemp = zlatm3( m, n, i, j, isub, jsub, kl, ku,
1066 $ idist, iseed, d, igrade, dl, dr, ipvtng,
1068 a( isub-jsub+kuu+1, jsub ) = ctemp
1079 IF( ipack.EQ.0 )
THEN 1080 IF( isym.EQ.0 )
THEN 1083 a( i, j ) = zlatm2( m, n, i, j, kl, ku, idist,
1084 $ iseed, d, igrade, dl, dr, ipvtng,
1086 a( j, i ) = dconjg( a( i, j ) )
1089 ELSE IF( isym.EQ.1 )
THEN 1092 a( i, j ) = zlatm2( m, n, i, j, kl, ku, idist,
1093 $ iseed, d, igrade, dl, dr, ipvtng,
1097 ELSE IF( isym.EQ.2 )
THEN 1100 a( i, j ) = zlatm2( m, n, i, j, kl, ku, idist,
1101 $ iseed, d, igrade, dl, dr, ipvtng,
1103 a( j, i ) = a( i, j )
1108 ELSE IF( ipack.EQ.1 )
THEN 1112 a( i, j ) = zlatm2( m, n, i, j, kl, ku, idist, iseed,
1113 $ d, igrade, dl, dr, ipvtng, iwork, sparse )
1119 ELSE IF( ipack.EQ.2 )
THEN 1123 IF( isym.EQ.0 )
THEN 1124 a( j, i ) = dconjg( zlatm2( m, n, i, j, kl, ku,
1125 $ idist, iseed, d, igrade, dl, dr,
1126 $ ipvtng, iwork, sparse ) )
1128 a( j, i ) = zlatm2( m, n, i, j, kl, ku, idist,
1129 $ iseed, d, igrade, dl, dr, ipvtng,
1137 ELSE IF( ipack.EQ.3 )
THEN 1144 IF( isub.GT.lda )
THEN 1148 a( isub, jsub ) = zlatm2( m, n, i, j, kl, ku, idist,
1149 $ iseed, d, igrade, dl, dr, ipvtng,
1154 ELSE IF( ipack.EQ.4 )
THEN 1156 IF( isym.EQ.0 .OR. isym.EQ.2 )
THEN 1165 k = n*( n+1 ) / 2 - ( n-i+1 )*( n-i+2 ) / 2 +
1171 jsub = ( k-1 ) / lda + 1
1172 isub = k - lda*( jsub-1 )
1174 a( isub, jsub ) = zlatm2( m, n, i, j, kl, ku,
1175 $ idist, iseed, d, igrade, dl, dr,
1176 $ ipvtng, iwork, sparse )
1178 $ a( isub, jsub ) = dconjg( a( isub, jsub ) )
1187 IF( isub.GT.lda )
THEN 1191 a( isub, jsub ) = zlatm2( m, n, i, j, kl, ku,
1192 $ idist, iseed, d, igrade, dl, dr,
1193 $ ipvtng, iwork, sparse )
1198 ELSE IF( ipack.EQ.5 )
THEN 1201 DO 480 i = j - kuu, j
1203 a( j-i+1, i+n ) = czero
1205 IF( isym.EQ.0 )
THEN 1206 a( j-i+1, i ) = dconjg( zlatm2( m, n, i, j, kl,
1207 $ ku, idist, iseed, d, igrade, dl,
1208 $ dr, ipvtng, iwork, sparse ) )
1210 a( j-i+1, i ) = zlatm2( m, n, i, j, kl, ku,
1211 $ idist, iseed, d, igrade, dl, dr,
1212 $ ipvtng, iwork, sparse )
1218 ELSE IF( ipack.EQ.6 )
THEN 1221 DO 500 i = j - kuu, j
1222 a( i-j+kuu+1, j ) = zlatm2( m, n, i, j, kl, ku, idist,
1223 $ iseed, d, igrade, dl, dr, ipvtng,
1228 ELSE IF( ipack.EQ.7 )
THEN 1230 IF( isym.NE.1 )
THEN 1232 DO 520 i = j - kuu, j
1233 a( i-j+kuu+1, j ) = zlatm2( m, n, i, j, kl, ku,
1234 $ idist, iseed, d, igrade, dl,
1235 $ dr, ipvtng, iwork, sparse )
1237 $ a( j-i+1+kuu, i+n ) = czero
1238 IF( i.GE.1 .AND. i.NE.j )
THEN 1239 IF( isym.EQ.0 )
THEN 1240 a( j-i+1+kuu, i ) = dconjg( a( i-j+kuu+1,
1243 a( j-i+1+kuu, i ) = a( i-j+kuu+1, j )
1248 ELSE IF( isym.EQ.1 )
THEN 1250 DO 540 i = j - kuu, j + kll
1251 a( i-j+kuu+1, j ) = zlatm2( m, n, i, j, kl, ku,
1252 $ idist, iseed, d, igrade, dl,
1253 $ dr, ipvtng, iwork, sparse )
1264 IF( ipack.EQ.0 )
THEN 1265 onorm = zlange(
'M', m, n, a, lda, tempa )
1266 ELSE IF( ipack.EQ.1 )
THEN 1267 onorm = zlansy(
'M',
'U', n, a, lda, tempa )
1268 ELSE IF( ipack.EQ.2 )
THEN 1269 onorm = zlansy(
'M',
'L', n, a, lda, tempa )
1270 ELSE IF( ipack.EQ.3 )
THEN 1271 onorm = zlansp(
'M',
'U', n, a, tempa )
1272 ELSE IF( ipack.EQ.4 )
THEN 1273 onorm = zlansp(
'M',
'L', n, a, tempa )
1274 ELSE IF( ipack.EQ.5 )
THEN 1275 onorm = zlansb(
'M',
'L', n, kll, a, lda, tempa )
1276 ELSE IF( ipack.EQ.6 )
THEN 1277 onorm = zlansb(
'M',
'U', n, kuu, a, lda, tempa )
1278 ELSE IF( ipack.EQ.7 )
THEN 1279 onorm = zlangb(
'M', n, kll, kuu, a, lda, tempa )
1282 IF( anorm.GE.zero )
THEN 1284 IF( anorm.GT.zero .AND. onorm.EQ.zero )
THEN 1291 ELSE IF( ( anorm.GT.one .AND. onorm.LT.one ) .OR.
1292 $ ( anorm.LT.one .AND. onorm.GT.one ) )
THEN 1296 IF( ipack.LE.2 )
THEN 1298 CALL zdscal( m, one / onorm, a( 1, j ), 1 )
1299 CALL zdscal( m, anorm, a( 1, j ), 1 )
1302 ELSE IF( ipack.EQ.3 .OR. ipack.EQ.4 )
THEN 1304 CALL zdscal( n*( n+1 ) / 2, one / onorm, a, 1 )
1305 CALL zdscal( n*( n+1 ) / 2, anorm, a, 1 )
1307 ELSE IF( ipack.GE.5 )
THEN 1310 CALL zdscal( kll+kuu+1, one / onorm, a( 1, j ), 1 )
1311 CALL zdscal( kll+kuu+1, anorm, a( 1, j ), 1 )
1320 IF( ipack.LE.2 )
THEN 1322 CALL zdscal( m, anorm / onorm, a( 1, j ), 1 )
1325 ELSE IF( ipack.EQ.3 .OR. ipack.EQ.4 )
THEN 1327 CALL zdscal( n*( n+1 ) / 2, anorm / onorm, a, 1 )
1329 ELSE IF( ipack.GE.5 )
THEN 1332 CALL zdscal( kll+kuu+1, anorm / onorm, a( 1, j ), 1 )
subroutine zlatmr(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, RSIGN, GRADE, DL, MODEL, CONDL, DR, MODER, CONDR, PIVTNG, IPIVOT, KL, KU, SPARSE, ANORM, PACK, A, LDA, IWORK, INFO)
ZLATMR
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine zdscal(N, DA, ZX, INCX)
ZDSCAL
subroutine zlatm1(MODE, COND, IRSIGN, IDIST, ISEED, D, N, INFO)
ZLATM1