LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
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 1777 of file zblat2.f.

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

Here is the call graph for this function:

Here is the caller graph for this function: