LAPACK  3.9.0
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 1614 of file cblat3.f.

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