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

◆ zchk5()

subroutine zchk5 ( character*6  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 1611 of file zblat3.f.

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