1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635 COMPLEX*16 ZERO, ONE
1636 parameter( zero = ( 0.0d0, 0.0d0 ),
1637 $ one = ( 1.0d0, 0.0d0 ) )
1638 DOUBLE PRECISION RONE, RZERO
1639 parameter( rone = 1.0d0, rzero = 0.0d0 )
1640
1641 DOUBLE PRECISION EPS, THRESH
1642 INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA
1643 LOGICAL FATAL, REWI, TRACE
1644 CHARACTER*7 SNAME
1645
1646 COMPLEX*16 AA( NMAX*NMAX ), AB( 2*NMAX*NMAX ),
1647 $ ALF( NALF ), AS( NMAX*NMAX ), BB( NMAX*NMAX ),
1648 $ BET( NBET ), BS( NMAX*NMAX ), C( NMAX, NMAX ),
1649 $ CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ),
1650 $ W( 2*NMAX )
1651 DOUBLE PRECISION G( NMAX )
1652 INTEGER IDIM( NIDIM )
1653
1654 COMPLEX*16 ALPHA, ALS, BETA, BETS
1655 DOUBLE PRECISION ERR, ERRMAX, RBETA, RBETS
1656 INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, JJAB,
1657 $ K, KS, LAA, LBB, LCC, LDA, LDAS, LDB, LDBS,
1658 $ LDC, LDCS, LJ, MA, N, NA, NARGS, NC, NS
1659 LOGICAL CONJ, NULL, RESET, SAME, TRAN, UPPER
1660 CHARACTER*1 TRANS, TRANSS, TRANST, UPLO, UPLOS
1661 CHARACTER*2 ICHT, ICHU
1662
1663 LOGICAL ISAME( 13 )
1664
1665 LOGICAL LZE, LZERES
1667
1669
1670 INTRINSIC dcmplx, dconjg, max, dble
1671
1672 INTEGER INFOT, NOUTC
1673 LOGICAL LERR, OK
1674
1675 COMMON /infoc/infot, noutc, ok, lerr
1676
1677 DATA icht/'NC'/, ichu/'UL'/
1678
1679 conj = sname( 2: 3 ).EQ.'HE'
1680
1681 nargs = 12
1682 nc = 0
1683 reset = .true.
1684 errmax = rzero
1685
1686 DO 130 in = 1, nidim
1687 n = idim( in )
1688
1689 ldc = n
1690 IF( ldc.LT.nmax )
1691 $ ldc = ldc + 1
1692
1693 IF( ldc.GT.nmax )
1694 $ GO TO 130
1695 lcc = ldc*n
1696
1697 DO 120 ik = 1, nidim
1698 k = idim( ik )
1699
1700 DO 110 ict = 1, 2
1701 trans = icht( ict: ict )
1702 tran = trans.EQ.'C'
1703 IF( tran.AND..NOT.conj )
1704 $ trans = 'T'
1705 IF( tran )THEN
1706 ma = k
1707 na = n
1708 ELSE
1709 ma = n
1710 na = k
1711 END IF
1712
1713 lda = ma
1714 IF( lda.LT.nmax )
1715 $ lda = lda + 1
1716
1717 IF( lda.GT.nmax )
1718 $ GO TO 110
1719 laa = lda*na
1720
1721
1722
1723 IF( tran )THEN
1724 CALL zmake(
'GE',
' ',
' ', ma, na, ab, 2*nmax, aa,
1725 $ lda, reset, zero )
1726 ELSE
1727 CALL zmake(
'GE',
' ',
' ', ma, na, ab, nmax, aa, lda,
1728 $ reset, zero )
1729 END IF
1730
1731
1732
1733 ldb = lda
1734 lbb = laa
1735 IF( tran )THEN
1736 CALL zmake(
'GE',
' ',
' ', ma, na, ab( k + 1 ),
1737 $ 2*nmax, bb, ldb, reset, zero )
1738 ELSE
1739 CALL zmake(
'GE',
' ',
' ', ma, na, ab( k*nmax + 1 ),
1740 $ nmax, bb, ldb, reset, zero )
1741 END IF
1742
1743 DO 100 icu = 1, 2
1744 uplo = ichu( icu: icu )
1745 upper = uplo.EQ.'U'
1746
1747 DO 90 ia = 1, nalf
1748 alpha = alf( ia )
1749
1750 DO 80 ib = 1, nbet
1751 beta = bet( ib )
1752 IF( conj )THEN
1753 rbeta = dble( beta )
1754 beta = dcmplx( rbeta, rzero )
1755 END IF
1756 null = n.LE.0
1757 IF( conj )
1758 $ null = null.OR.( ( k.LE.0.OR.alpha.EQ.
1759 $ zero ).AND.rbeta.EQ.rone )
1760
1761
1762
1763 CALL zmake( sname( 2: 3 ), uplo,
' ', n, n, c,
1764 $ nmax, cc, ldc, reset, zero )
1765
1766 nc = nc + 1
1767
1768
1769
1770 uplos = uplo
1771 transs = trans
1772 ns = n
1773 ks = k
1774 als = alpha
1775 DO 10 i = 1, laa
1776 as( i ) = aa( i )
1777 10 CONTINUE
1778 ldas = lda
1779 DO 20 i = 1, lbb
1780 bs( i ) = bb( i )
1781 20 CONTINUE
1782 ldbs = ldb
1783 IF( conj )THEN
1784 rbets = rbeta
1785 ELSE
1786 bets = beta
1787 END IF
1788 DO 30 i = 1, lcc
1789 cs( i ) = cc( i )
1790 30 CONTINUE
1791 ldcs = ldc
1792
1793
1794
1795 IF( conj )THEN
1796 IF( trace )
1797 $ WRITE( ntra, fmt = 9994 )nc, sname, uplo,
1798 $ trans, n, k, alpha, lda, ldb, rbeta, ldc
1799 IF( rewi )
1800 $ rewind ntra
1801 CALL zher2k( uplo, trans, n, k, alpha, aa,
1802 $ lda, bb, ldb, rbeta, cc, ldc )
1803 ELSE
1804 IF( trace )
1805 $ WRITE( ntra, fmt = 9993 )nc, sname, uplo,
1806 $ trans, n, k, alpha, lda, ldb, beta, ldc
1807 IF( rewi )
1808 $ rewind ntra
1809 CALL zsyr2k( uplo, trans, n, k, alpha, aa,
1810 $ lda, bb, ldb, beta, cc, ldc )
1811 END IF
1812
1813
1814
1815 IF( .NOT.ok )THEN
1816 WRITE( nout, fmt = 9992 )
1817 fatal = .true.
1818 GO TO 150
1819 END IF
1820
1821
1822
1823 isame( 1 ) = uplos.EQ.uplo
1824 isame( 2 ) = transs.EQ.trans
1825 isame( 3 ) = ns.EQ.n
1826 isame( 4 ) = ks.EQ.k
1827 isame( 5 ) = als.EQ.alpha
1828 isame( 6 ) =
lze( as, aa, laa )
1829 isame( 7 ) = ldas.EQ.lda
1830 isame( 8 ) =
lze( bs, bb, lbb )
1831 isame( 9 ) = ldbs.EQ.ldb
1832 IF( conj )THEN
1833 isame( 10 ) = rbets.EQ.rbeta
1834 ELSE
1835 isame( 10 ) = bets.EQ.beta
1836 END IF
1837 IF( null )THEN
1838 isame( 11 ) =
lze( cs, cc, lcc )
1839 ELSE
1840 isame( 11 ) =
lzeres(
'HE', uplo, n, n, cs,
1841 $ cc, ldc )
1842 END IF
1843 isame( 12 ) = ldcs.EQ.ldc
1844
1845
1846
1847
1848 same = .true.
1849 DO 40 i = 1, nargs
1850 same = same.AND.isame( i )
1851 IF( .NOT.isame( i ) )
1852 $ WRITE( nout, fmt = 9998 )i
1853 40 CONTINUE
1854 IF( .NOT.same )THEN
1855 fatal = .true.
1856 GO TO 150
1857 END IF
1858
1859 IF( .NOT.null )THEN
1860
1861
1862
1863 IF( conj )THEN
1864 transt = 'C'
1865 ELSE
1866 transt = 'T'
1867 END IF
1868 jjab = 1
1869 jc = 1
1870 DO 70 j = 1, n
1871 IF( upper )THEN
1872 jj = 1
1873 lj = j
1874 ELSE
1875 jj = j
1876 lj = n - j + 1
1877 END IF
1878 IF( tran )THEN
1879 DO 50 i = 1, k
1880 w( i ) = alpha*ab( ( j - 1 )*2*
1881 $ nmax + k + i )
1882 IF( conj )THEN
1883 w( k + i ) = dconjg( alpha )*
1884 $ ab( ( j - 1 )*2*
1885 $ nmax + i )
1886 ELSE
1887 w( k + i ) = alpha*
1888 $ ab( ( j - 1 )*2*
1889 $ nmax + i )
1890 END IF
1891 50 CONTINUE
1892 CALL zmmch( transt,
'N', lj, 1, 2*k,
1893 $ one, ab( jjab ), 2*nmax, w,
1894 $ 2*nmax, beta, c( jj, j ),
1895 $ nmax, ct, g, cc( jc ), ldc,
1896 $ eps, err, fatal, nout,
1897 $ .true. )
1898 ELSE
1899 DO 60 i = 1, k
1900 IF( conj )THEN
1901 w( i ) = alpha*dconjg( ab( ( k +
1902 $ i - 1 )*nmax + j ) )
1903 w( k + i ) = dconjg( alpha*
1904 $ ab( ( i - 1 )*nmax +
1905 $ j ) )
1906 ELSE
1907 w( i ) = alpha*ab( ( k + i - 1 )*
1908 $ nmax + j )
1909 w( k + i ) = alpha*
1910 $ ab( ( i - 1 )*nmax +
1911 $ j )
1912 END IF
1913 60 CONTINUE
1914 CALL zmmch(
'N',
'N', lj, 1, 2*k, one,
1915 $ ab( jj ), nmax, w, 2*nmax,
1916 $ beta, c( jj, j ), nmax, ct,
1917 $ g, cc( jc ), ldc, eps, err,
1918 $ fatal, nout, .true. )
1919 END IF
1920 IF( upper )THEN
1921 jc = jc + ldc
1922 ELSE
1923 jc = jc + ldc + 1
1924 IF( tran )
1925 $ jjab = jjab + 2*nmax
1926 END IF
1927 errmax = max( errmax, err )
1928
1929
1930 IF( fatal )
1931 $ GO TO 140
1932 70 CONTINUE
1933 END IF
1934
1935 80 CONTINUE
1936
1937 90 CONTINUE
1938
1939 100 CONTINUE
1940
1941 110 CONTINUE
1942
1943 120 CONTINUE
1944
1945 130 CONTINUE
1946
1947
1948
1949 IF( errmax.LT.thresh )THEN
1950 WRITE( nout, fmt = 9999 )sname, nc
1951 ELSE
1952 WRITE( nout, fmt = 9997 )sname, nc, errmax
1953 END IF
1954 GO TO 160
1955
1956 140 CONTINUE
1957 IF( n.GT.1 )
1958 $ WRITE( nout, fmt = 9995 )j
1959
1960 150 CONTINUE
1961 WRITE( nout, fmt = 9996 )sname
1962 IF( conj )THEN
1963 WRITE( nout, fmt = 9994 )nc, sname, uplo, trans, n, k, alpha,
1964 $ lda, ldb, rbeta, ldc
1965 ELSE
1966 WRITE( nout, fmt = 9993 )nc, sname, uplo, trans, n, k, alpha,
1967 $ lda, ldb, beta, ldc
1968 END IF
1969
1970 160 CONTINUE
1971 RETURN
1972
1973 9999 FORMAT( ' ', a6, ' PASSED THE COMPUTATIONAL TESTS (', i6, ' CALL',
1974 $ 'S)' )
1975 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
1976 $ 'ANGED INCORRECTLY *******' )
1977 9997 FORMAT( ' ', a6, ' COMPLETED THE COMPUTATIONAL TESTS (', i6, ' C',
1978 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
1979 $ ' - SUSPECT *******' )
1980 9996 FORMAT( ' ******* ', a6, ' FAILED ON CALL NUMBER:' )
1981 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', i3 )
1982 9994 FORMAT( 1x, i6, ': ', a6, '(', 2( '''', a1, ''',' ), 2( i3, ',' ),
1983 $ '(', f4.1, ',', f4.1, '), A,', i3, ', B,', i3, ',', f4.1,
1984 $ ', C,', i3, ') .' )
1985 9993 FORMAT( 1x, i6, ': ', a6, '(', 2( '''', a1, ''',' ), 2( i3, ',' ),
1986 $ '(', f4.1, ',', f4.1, '), A,', i3, ', B,', i3, ',(', f4.1,
1987 $ ',', f4.1, '), C,', i3, ') .' )
1988 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1989 $ '******' )
1990
1991
1992
subroutine zsyr2k(uplo, trans, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
ZSYR2K
subroutine zher2k(uplo, trans, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
ZHER2K
logical function lze(ri, rj, lr)
logical function lzeres(type, uplo, m, n, aa, as, lda)
subroutine zmake(type, uplo, diag, m, n, a, nmax, aa, lda, kl, ku, reset, transl)
subroutine zmmch(transa, transb, m, n, kk, alpha, a, lda, b, ldb, beta, c, ldc, ct, g, cc, ldcc, eps, err, fatal, nout, mv)