LAPACK  3.9.1
LAPACK: Linear Algebra PACKage

◆ 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:2716
lce
logical function lce(RI, RJ, LR)
Definition: cblat2.f:3039
lceres
logical function lceres(TYPE, UPLO, M, N, AA, AS, LDA)
Definition: cblat2.f:3069
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: