LAPACK  3.9.1
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  NINC,
integer, dimension( ninc )  INC,
integer  NMAX,
integer  INCMAX,
complex*16, dimension( nmax, nmax )  A,
complex*16, dimension( nmax*nmax )  AA,
complex*16, dimension( nmax*nmax )  AS,
complex*16, dimension( nmax )  X,
complex*16, dimension( nmax*incmax )  XX,
complex*16, dimension( nmax*incmax )  XS,
complex*16, dimension( nmax )  Y,
complex*16, dimension( nmax*incmax )  YY,
complex*16, dimension( nmax*incmax )  YS,
complex*16, dimension( nmax )  YT,
double precision, dimension( nmax )  G,
complex*16, dimension( nmax )  Z 
)

Definition at line 1770 of file zblat2.f.

1774 *
1775 * Tests ZHER and ZHPR.
1776 *
1777 * Auxiliary routine for test program for Level 2 Blas.
1778 *
1779 * -- Written on 10-August-1987.
1780 * Richard Hanson, Sandia National Labs.
1781 * Jeremy Du Croz, NAG Central Office.
1782 *
1783 * .. Parameters ..
1784  COMPLEX*16 ZERO, HALF, ONE
1785  parameter( zero = ( 0.0d0, 0.0d0 ),
1786  $ half = ( 0.5d0, 0.0d0 ),
1787  $ one = ( 1.0d0, 0.0d0 ) )
1788  DOUBLE PRECISION RZERO
1789  parameter( rzero = 0.0d0 )
1790 * .. Scalar Arguments ..
1791  DOUBLE PRECISION EPS, THRESH
1792  INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA
1793  LOGICAL FATAL, REWI, TRACE
1794  CHARACTER*6 SNAME
1795 * .. Array Arguments ..
1796  COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
1797  $ AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ),
1798  $ XX( NMAX*INCMAX ), Y( NMAX ),
1799  $ YS( NMAX*INCMAX ), YT( NMAX ),
1800  $ YY( NMAX*INCMAX ), Z( NMAX )
1801  DOUBLE PRECISION G( NMAX )
1802  INTEGER IDIM( NIDIM ), INC( NINC )
1803 * .. Local Scalars ..
1804  COMPLEX*16 ALPHA, TRANSL
1805  DOUBLE PRECISION ERR, ERRMAX, RALPHA, RALS
1806  INTEGER I, IA, IC, IN, INCX, INCXS, IX, J, JA, JJ, LAA,
1807  $ LDA, LDAS, LJ, LX, N, NARGS, NC, NS
1808  LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER
1809  CHARACTER*1 UPLO, UPLOS
1810  CHARACTER*2 ICH
1811 * .. Local Arrays ..
1812  COMPLEX*16 W( 1 )
1813  LOGICAL ISAME( 13 )
1814 * .. External Functions ..
1815  LOGICAL LZE, LZERES
1816  EXTERNAL lze, lzeres
1817 * .. External Subroutines ..
1818  EXTERNAL zher, zhpr, zmake, zmvch
1819 * .. Intrinsic Functions ..
1820  INTRINSIC abs, dble, dcmplx, dconjg, max
1821 * .. Scalars in Common ..
1822  INTEGER INFOT, NOUTC
1823  LOGICAL LERR, OK
1824 * .. Common blocks ..
1825  COMMON /infoc/infot, noutc, ok, lerr
1826 * .. Data statements ..
1827  DATA ich/'UL'/
1828 * .. Executable Statements ..
1829  full = sname( 3: 3 ).EQ.'E'
1830  packed = sname( 3: 3 ).EQ.'P'
1831 * Define the number of arguments.
1832  IF( full )THEN
1833  nargs = 7
1834  ELSE IF( packed )THEN
1835  nargs = 6
1836  END IF
1837 *
1838  nc = 0
1839  reset = .true.
1840  errmax = rzero
1841 *
1842  DO 100 in = 1, nidim
1843  n = idim( in )
1844 * Set LDA to 1 more than minimum value if room.
1845  lda = n
1846  IF( lda.LT.nmax )
1847  $ lda = lda + 1
1848 * Skip tests if not enough room.
1849  IF( lda.GT.nmax )
1850  $ GO TO 100
1851  IF( packed )THEN
1852  laa = ( n*( n + 1 ) )/2
1853  ELSE
1854  laa = lda*n
1855  END IF
1856 *
1857  DO 90 ic = 1, 2
1858  uplo = ich( ic: ic )
1859  upper = uplo.EQ.'U'
1860 *
1861  DO 80 ix = 1, ninc
1862  incx = inc( ix )
1863  lx = abs( incx )*n
1864 *
1865 * Generate the vector X.
1866 *
1867  transl = half
1868  CALL zmake( 'GE', ' ', ' ', 1, n, x, 1, xx, abs( incx ),
1869  $ 0, n - 1, reset, transl )
1870  IF( n.GT.1 )THEN
1871  x( n/2 ) = zero
1872  xx( 1 + abs( incx )*( n/2 - 1 ) ) = zero
1873  END IF
1874 *
1875  DO 70 ia = 1, nalf
1876  ralpha = dble( alf( ia ) )
1877  alpha = dcmplx( ralpha, rzero )
1878  null = n.LE.0.OR.ralpha.EQ.rzero
1879 *
1880 * Generate the matrix A.
1881 *
1882  transl = zero
1883  CALL zmake( sname( 2: 3 ), uplo, ' ', n, n, a, nmax,
1884  $ aa, lda, n - 1, n - 1, reset, transl )
1885 *
1886  nc = nc + 1
1887 *
1888 * Save every datum before calling the subroutine.
1889 *
1890  uplos = uplo
1891  ns = n
1892  rals = ralpha
1893  DO 10 i = 1, laa
1894  as( i ) = aa( i )
1895  10 CONTINUE
1896  ldas = lda
1897  DO 20 i = 1, lx
1898  xs( i ) = xx( i )
1899  20 CONTINUE
1900  incxs = incx
1901 *
1902 * Call the subroutine.
1903 *
1904  IF( full )THEN
1905  IF( trace )
1906  $ WRITE( ntra, fmt = 9993 )nc, sname, uplo, n,
1907  $ ralpha, incx, lda
1908  IF( rewi )
1909  $ rewind ntra
1910  CALL zher( uplo, n, ralpha, xx, incx, aa, lda )
1911  ELSE IF( packed )THEN
1912  IF( trace )
1913  $ WRITE( ntra, fmt = 9994 )nc, sname, uplo, n,
1914  $ ralpha, incx
1915  IF( rewi )
1916  $ rewind ntra
1917  CALL zhpr( uplo, n, ralpha, xx, incx, aa )
1918  END IF
1919 *
1920 * Check if error-exit was taken incorrectly.
1921 *
1922  IF( .NOT.ok )THEN
1923  WRITE( nout, fmt = 9992 )
1924  fatal = .true.
1925  GO TO 120
1926  END IF
1927 *
1928 * See what data changed inside subroutines.
1929 *
1930  isame( 1 ) = uplo.EQ.uplos
1931  isame( 2 ) = ns.EQ.n
1932  isame( 3 ) = rals.EQ.ralpha
1933  isame( 4 ) = lze( xs, xx, lx )
1934  isame( 5 ) = incxs.EQ.incx
1935  IF( null )THEN
1936  isame( 6 ) = lze( as, aa, laa )
1937  ELSE
1938  isame( 6 ) = lzeres( sname( 2: 3 ), uplo, n, n, as,
1939  $ aa, lda )
1940  END IF
1941  IF( .NOT.packed )THEN
1942  isame( 7 ) = ldas.EQ.lda
1943  END IF
1944 *
1945 * If data was incorrectly changed, report and return.
1946 *
1947  same = .true.
1948  DO 30 i = 1, nargs
1949  same = same.AND.isame( i )
1950  IF( .NOT.isame( i ) )
1951  $ WRITE( nout, fmt = 9998 )i
1952  30 CONTINUE
1953  IF( .NOT.same )THEN
1954  fatal = .true.
1955  GO TO 120
1956  END IF
1957 *
1958  IF( .NOT.null )THEN
1959 *
1960 * Check the result column by column.
1961 *
1962  IF( incx.GT.0 )THEN
1963  DO 40 i = 1, n
1964  z( i ) = x( i )
1965  40 CONTINUE
1966  ELSE
1967  DO 50 i = 1, n
1968  z( i ) = x( n - i + 1 )
1969  50 CONTINUE
1970  END IF
1971  ja = 1
1972  DO 60 j = 1, n
1973  w( 1 ) = dconjg( z( j ) )
1974  IF( upper )THEN
1975  jj = 1
1976  lj = j
1977  ELSE
1978  jj = j
1979  lj = n - j + 1
1980  END IF
1981  CALL zmvch( 'N', lj, 1, alpha, z( jj ), lj, w,
1982  $ 1, one, a( jj, j ), 1, yt, g,
1983  $ aa( ja ), eps, err, fatal, nout,
1984  $ .true. )
1985  IF( full )THEN
1986  IF( upper )THEN
1987  ja = ja + lda
1988  ELSE
1989  ja = ja + lda + 1
1990  END IF
1991  ELSE
1992  ja = ja + lj
1993  END IF
1994  errmax = max( errmax, err )
1995 * If got really bad answer, report and return.
1996  IF( fatal )
1997  $ GO TO 110
1998  60 CONTINUE
1999  ELSE
2000 * Avoid repeating tests if N.le.0.
2001  IF( n.LE.0 )
2002  $ GO TO 100
2003  END IF
2004 *
2005  70 CONTINUE
2006 *
2007  80 CONTINUE
2008 *
2009  90 CONTINUE
2010 *
2011  100 CONTINUE
2012 *
2013 * Report result.
2014 *
2015  IF( errmax.LT.thresh )THEN
2016  WRITE( nout, fmt = 9999 )sname, nc
2017  ELSE
2018  WRITE( nout, fmt = 9997 )sname, nc, errmax
2019  END IF
2020  GO TO 130
2021 *
2022  110 CONTINUE
2023  WRITE( nout, fmt = 9995 )j
2024 *
2025  120 CONTINUE
2026  WRITE( nout, fmt = 9996 )sname
2027  IF( full )THEN
2028  WRITE( nout, fmt = 9993 )nc, sname, uplo, n, ralpha, incx, lda
2029  ELSE IF( packed )THEN
2030  WRITE( nout, fmt = 9994 )nc, sname, uplo, n, ralpha, incx
2031  END IF
2032 *
2033  130 CONTINUE
2034  RETURN
2035 *
2036  9999 FORMAT( ' ', a6, ' PASSED THE COMPUTATIONAL TESTS (', i6, ' CALL',
2037  $ 'S)' )
2038  9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
2039  $ 'ANGED INCORRECTLY *******' )
2040  9997 FORMAT( ' ', a6, ' COMPLETED THE COMPUTATIONAL TESTS (', i6, ' C',
2041  $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
2042  $ ' - SUSPECT *******' )
2043  9996 FORMAT( ' ******* ', a6, ' FAILED ON CALL NUMBER:' )
2044  9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', i3 )
2045  9994 FORMAT( 1x, i6, ': ', a6, '(''', a1, ''',', i3, ',', f4.1, ', X,',
2046  $ i2, ', AP) .' )
2047  9993 FORMAT( 1x, i6, ': ', a6, '(''', a1, ''',', i3, ',', f4.1, ', X,',
2048  $ i2, ', A,', i3, ') .' )
2049  9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
2050  $ '******' )
2051 *
2052 * End of ZCHK5.
2053 *
zhpr
subroutine zhpr(UPLO, N, ALPHA, X, INCX, AP)
ZHPR
Definition: zhpr.f:130
zher
subroutine zher(UPLO, N, ALPHA, X, INCX, A, LDA)
ZHER
Definition: zher.f:135
zmvch
subroutine zmvch(TRANS, M, N, ALPHA, A, NMAX, X, INCX, BETA, Y, INCY, YT, G, YY, EPS, ERR, FATAL, NOUT, MV)
Definition: zblat2.f:2916
lzeres
logical function lzeres(TYPE, UPLO, M, N, AA, AS, LDA)
Definition: zblat2.f:3077
zmake
subroutine zmake(TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, KU, RESET, TRANSL)
Definition: zblat2.f:2723
lze
logical function lze(RI, RJ, LR)
Definition: zblat2.f:3047
Here is the call graph for this function:
Here is the caller graph for this function: