LAPACK  3.9.0
LAPACK: Linear Algebra PACKage

◆ 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 1617 of file zblat3.f.

1617 *
1618 * Tests ZHER2K and ZSYR2K.
1619 *
1620 * Auxiliary routine for test program for Level 3 Blas.
1621 *
1622 * -- Written on 8-February-1989.
1623 * Jack Dongarra, Argonne National Laboratory.
1624 * Iain Duff, AERE Harwell.
1625 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
1626 * Sven Hammarling, Numerical Algorithms Group Ltd.
1627 *
1628 * .. Parameters ..
1629  COMPLEX*16 ZERO, ONE
1630  parameter( zero = ( 0.0d0, 0.0d0 ),
1631  $ one = ( 1.0d0, 0.0d0 ) )
1632  DOUBLE PRECISION RONE, RZERO
1633  parameter( rone = 1.0d0, rzero = 0.0d0 )
1634 * .. Scalar Arguments ..
1635  DOUBLE PRECISION EPS, THRESH
1636  INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA
1637  LOGICAL FATAL, REWI, TRACE
1638  CHARACTER*6 SNAME
1639 * .. Array Arguments ..
1640  COMPLEX*16 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  DOUBLE PRECISION G( NMAX )
1646  INTEGER IDIM( NIDIM )
1647 * .. Local Scalars ..
1648  COMPLEX*16 ALPHA, ALS, BETA, BETS
1649  DOUBLE PRECISION 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 LZE, LZERES
1660  EXTERNAL lze, lzeres
1661 * .. External Subroutines ..
1662  EXTERNAL zher2k, zmake, zmmch, zsyr2k
1663 * .. Intrinsic Functions ..
1664  INTRINSIC dcmplx, dconjg, max, dble
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 zmake( 'GE', ' ', ' ', ma, na, ab, 2*nmax, aa,
1719  $ lda, reset, zero )
1720  ELSE
1721  CALL zmake( '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 zmake( 'GE', ' ', ' ', ma, na, ab( k + 1 ),
1731  $ 2*nmax, bb, ldb, reset, zero )
1732  ELSE
1733  CALL zmake( '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 = dble( beta )
1748  beta = dcmplx( 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 zmake( 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 zher2k( 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 zsyr2k( 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 ) = lze( as, aa, laa )
1823  isame( 7 ) = ldas.EQ.lda
1824  isame( 8 ) = lze( 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 ) = lze( cs, cc, lcc )
1833  ELSE
1834  isame( 11 ) = lzeres( '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 ) = dconjg( 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 zmmch( 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*dconjg( ab( ( k +
1896  $ i - 1 )*nmax + j ) )
1897  w( k + i ) = dconjg( 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 zmmch( '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 ZCHK5.
1986 *
Here is the call graph for this function:
zher2k
subroutine zher2k(UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
ZHER2K
Definition: zher2k.f:200
zmake
subroutine zmake(TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, KU, RESET, TRANSL)
Definition: zblat2.f:2726
lzeres
logical function lzeres(TYPE, UPLO, M, N, AA, AS, LDA)
Definition: zblat2.f:3080
zsyr2k
subroutine zsyr2k(UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
ZSYR2K
Definition: zsyr2k.f:190
lze
logical function lze(RI, RJ, LR)
Definition: zblat2.f:3050
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:3064