LAPACK 3.12.1
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches

◆ zchk5()

subroutine zchk5 ( character*7 sname,
double precision eps,
double precision thresh,
integer nout,
integer ntra,
logical trace,
logical rewi,
logical fatal,
integer nidim,
integer, dimension( nidim ) idim,
integer nalf,
complex*16, dimension( nalf ) alf,
integer nbet,
complex*16, dimension( nbet ) bet,
integer nmax,
complex*16, dimension( 2*nmax*nmax ) ab,
complex*16, dimension( nmax*nmax ) aa,
complex*16, dimension( nmax*nmax ) as,
complex*16, dimension( nmax*nmax ) bb,
complex*16, dimension( nmax*nmax ) bs,
complex*16, dimension( nmax, nmax ) c,
complex*16, dimension( nmax*nmax ) cc,
complex*16, dimension( nmax*nmax ) cs,
complex*16, dimension( nmax ) ct,
double precision, dimension( nmax ) g,
complex*16, dimension( 2*nmax ) w )

Definition at line 1620 of file zblat3.f.

1623*
1624* Tests ZHER2K and ZSYR2K.
1625*
1626* Auxiliary routine for test program for Level 3 Blas.
1627*
1628* -- Written on 8-February-1989.
1629* Jack Dongarra, Argonne National Laboratory.
1630* Iain Duff, AERE Harwell.
1631* Jeremy Du Croz, Numerical Algorithms Group Ltd.
1632* Sven Hammarling, Numerical Algorithms Group Ltd.
1633*
1634* .. Parameters ..
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* .. Scalar Arguments ..
1641 DOUBLE PRECISION EPS, THRESH
1642 INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA
1643 LOGICAL FATAL, REWI, TRACE
1644 CHARACTER*7 SNAME
1645* .. Array Arguments ..
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* .. Local Scalars ..
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* .. Local Arrays ..
1663 LOGICAL ISAME( 13 )
1664* .. External Functions ..
1665 LOGICAL LZE, LZERES
1666 EXTERNAL lze, lzeres
1667* .. External Subroutines ..
1668 EXTERNAL zher2k, zmake, zmmch, zsyr2k
1669* .. Intrinsic Functions ..
1670 INTRINSIC dcmplx, dconjg, max, dble
1671* .. Scalars in Common ..
1672 INTEGER INFOT, NOUTC
1673 LOGICAL LERR, OK
1674* .. Common blocks ..
1675 COMMON /infoc/infot, noutc, ok, lerr
1676* .. Data statements ..
1677 DATA icht/'NC'/, ichu/'UL'/
1678* .. Executable Statements ..
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* Set LDC to 1 more than minimum value if room.
1689 ldc = n
1690 IF( ldc.LT.nmax )
1691 $ ldc = ldc + 1
1692* Skip tests if not enough room.
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* Set LDA to 1 more than minimum value if room.
1713 lda = ma
1714 IF( lda.LT.nmax )
1715 $ lda = lda + 1
1716* Skip tests if not enough room.
1717 IF( lda.GT.nmax )
1718 $ GO TO 110
1719 laa = lda*na
1720*
1721* Generate the matrix A.
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* Generate the matrix B.
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* Generate the matrix C.
1762*
1763 CALL zmake( sname( 2: 3 ), uplo, ' ', n, n, c,
1764 $ nmax, cc, ldc, reset, zero )
1765*
1766 nc = nc + 1
1767*
1768* Save every datum before calling the subroutine.
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* Call the subroutine.
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* Check if error-exit was taken incorrectly.
1814*
1815 IF( .NOT.ok )THEN
1816 WRITE( nout, fmt = 9992 )
1817 fatal = .true.
1818 GO TO 150
1819 END IF
1820*
1821* See what data changed inside subroutines.
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* If data was incorrectly changed, report and
1846* return.
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* Check the result column by column.
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* If got really bad answer, report and
1929* return.
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* Report result.
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* End of ZCHK5
1992*
zsyr2k
subroutine zsyr2k(uplo, trans, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
ZSYR2K
Definition zsyr2k.f:188
zher2k
subroutine zher2k(uplo, trans, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
ZHER2K
Definition zher2k.f:198
lze
logical function lze(ri, rj, lr)
Definition zblat2.f:3075
lzeres
logical function lzeres(type, uplo, m, n, aa, as, lda)
Definition zblat2.f:3105
zmake
subroutine zmake(type, uplo, diag, m, n, a, nmax, aa, lda, kl, ku, reset, transl)
Definition zblat2.f:2751
zmmch
subroutine zmmch(transa, transb, m, n, kk, alpha, a, lda, b, ldb, beta, c, ldc, ct, g, cc, ldcc, eps, err, fatal, nout, mv)
Definition zblat3.f:3266
Here is the call graph for this function: