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

◆ cchk5()

subroutine cchk5 ( character*6  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 1608 of file cblat3.f.

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