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

◆ cchk5()

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

Definition at line 1615 of file cblat3.f.

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