LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
subroutine zchk5 ( character*12  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,
integer  IORDER 
)

Definition at line 1839 of file c_zblat2.f.

1839 *
1840 * Tests ZHER and ZHPR.
1841 *
1842 * Auxiliary routine for test program for Level 2 Blas.
1843 *
1844 * -- Written on 10-August-1987.
1845 * Richard Hanson, Sandia National Labs.
1846 * Jeremy Du Croz, NAG Central Office.
1847 *
1848 * .. Parameters ..
1849  COMPLEX*16 zero, half, one
1850  parameter ( zero = ( 0.0d0, 0.0d0 ),
1851  $ half = ( 0.5d0, 0.0d0 ),
1852  $ one = ( 1.0d0, 0.0d0 ) )
1853  DOUBLE PRECISION rzero
1854  parameter ( rzero = 0.0d0 )
1855 * .. Scalar Arguments ..
1856  DOUBLE PRECISION eps, thresh
1857  INTEGER incmax, nalf, nidim, ninc, nmax, nout, ntra,
1858  $ iorder
1859  LOGICAL fatal, rewi, trace
1860  CHARACTER*12 sname
1861 * .. Array Arguments ..
1862  COMPLEX*16 a( nmax, nmax ), aa( nmax*nmax ), alf( nalf ),
1863  $ as( nmax*nmax ), x( nmax ), xs( nmax*incmax ),
1864  $ xx( nmax*incmax ), y( nmax ),
1865  $ ys( nmax*incmax ), yt( nmax ),
1866  $ yy( nmax*incmax ), z( nmax )
1867  DOUBLE PRECISION g( nmax )
1868  INTEGER idim( nidim ), inc( ninc )
1869 * .. Local Scalars ..
1870  COMPLEX*16 alpha, transl
1871  DOUBLE PRECISION err, errmax, ralpha, rals
1872  INTEGER i, ia, ic, in, incx, incxs, ix, j, ja, jj, laa,
1873  $ lda, ldas, lj, lx, n, nargs, nc, ns
1874  LOGICAL full, null, packed, reset, same, upper
1875  CHARACTER*1 uplo, uplos
1876  CHARACTER*14 cuplo
1877  CHARACTER*2 ich
1878 * .. Local Arrays ..
1879  COMPLEX*16 w( 1 )
1880  LOGICAL isame( 13 )
1881 * .. External Functions ..
1882  LOGICAL lze, lzeres
1883  EXTERNAL lze, lzeres
1884 * .. External Subroutines ..
1885  EXTERNAL czher, czhpr, zmake, zmvch
1886 * .. Intrinsic Functions ..
1887  INTRINSIC abs, dcmplx, dconjg, max, dble
1888 * .. Scalars in Common ..
1889  INTEGER infot, noutc
1890  LOGICAL ok
1891 * .. Common blocks ..
1892  COMMON /infoc/infot, noutc, ok
1893 * .. Data statements ..
1894  DATA ich/'UL'/
1895 * .. Executable Statements ..
1896  full = sname( 9: 9 ).EQ.'e'
1897  packed = sname( 9: 9 ).EQ.'p'
1898 * Define the number of arguments.
1899  IF( full )THEN
1900  nargs = 7
1901  ELSE IF( packed )THEN
1902  nargs = 6
1903  END IF
1904 *
1905  nc = 0
1906  reset = .true.
1907  errmax = rzero
1908 *
1909  DO 100 in = 1, nidim
1910  n = idim( in )
1911 * Set LDA to 1 more than minimum value if room.
1912  lda = n
1913  IF( lda.LT.nmax )
1914  $ lda = lda + 1
1915 * Skip tests if not enough room.
1916  IF( lda.GT.nmax )
1917  $ GO TO 100
1918  IF( packed )THEN
1919  laa = ( n*( n + 1 ) )/2
1920  ELSE
1921  laa = lda*n
1922  END IF
1923 *
1924  DO 90 ic = 1, 2
1925  uplo = ich( ic: ic )
1926  IF (uplo.EQ.'U')THEN
1927  cuplo = ' CblasUpper'
1928  ELSE
1929  cuplo = ' CblasLower'
1930  END IF
1931  upper = uplo.EQ.'U'
1932 *
1933  DO 80 ix = 1, ninc
1934  incx = inc( ix )
1935  lx = abs( incx )*n
1936 *
1937 * Generate the vector X.
1938 *
1939  transl = half
1940  CALL zmake( 'ge', ' ', ' ', 1, n, x, 1, xx, abs( incx ),
1941  $ 0, n - 1, reset, transl )
1942  IF( n.GT.1 )THEN
1943  x( n/2 ) = zero
1944  xx( 1 + abs( incx )*( n/2 - 1 ) ) = zero
1945  END IF
1946 *
1947  DO 70 ia = 1, nalf
1948  ralpha = dble( alf( ia ) )
1949  alpha = dcmplx( ralpha, rzero )
1950  null = n.LE.0.OR.ralpha.EQ.rzero
1951 *
1952 * Generate the matrix A.
1953 *
1954  transl = zero
1955  CALL zmake( sname( 8: 9 ), uplo, ' ', n, n, a, nmax,
1956  $ aa, lda, n - 1, n - 1, reset, transl )
1957 *
1958  nc = nc + 1
1959 *
1960 * Save every datum before calling the subroutine.
1961 *
1962  uplos = uplo
1963  ns = n
1964  rals = ralpha
1965  DO 10 i = 1, laa
1966  as( i ) = aa( i )
1967  10 CONTINUE
1968  ldas = lda
1969  DO 20 i = 1, lx
1970  xs( i ) = xx( i )
1971  20 CONTINUE
1972  incxs = incx
1973 *
1974 * Call the subroutine.
1975 *
1976  IF( full )THEN
1977  IF( trace )
1978  $ WRITE( ntra, fmt = 9993 )nc, sname, cuplo, n,
1979  $ ralpha, incx, lda
1980  IF( rewi )
1981  $ rewind ntra
1982  CALL czher( iorder, uplo, n, ralpha, xx,
1983  $ incx, aa, lda )
1984  ELSE IF( packed )THEN
1985  IF( trace )
1986  $ WRITE( ntra, fmt = 9994 )nc, sname, cuplo, n,
1987  $ ralpha, incx
1988  IF( rewi )
1989  $ rewind ntra
1990  CALL czhpr( iorder, uplo, n, ralpha,
1991  $ xx, incx, aa )
1992  END IF
1993 *
1994 * Check if error-exit was taken incorrectly.
1995 *
1996  IF( .NOT.ok )THEN
1997  WRITE( nout, fmt = 9992 )
1998  fatal = .true.
1999  GO TO 120
2000  END IF
2001 *
2002 * See what data changed inside subroutines.
2003 *
2004  isame( 1 ) = uplo.EQ.uplos
2005  isame( 2 ) = ns.EQ.n
2006  isame( 3 ) = rals.EQ.ralpha
2007  isame( 4 ) = lze( xs, xx, lx )
2008  isame( 5 ) = incxs.EQ.incx
2009  IF( null )THEN
2010  isame( 6 ) = lze( as, aa, laa )
2011  ELSE
2012  isame( 6 ) = lzeres( sname( 8: 9 ), uplo, n, n, as,
2013  $ aa, lda )
2014  END IF
2015  IF( .NOT.packed )THEN
2016  isame( 7 ) = ldas.EQ.lda
2017  END IF
2018 *
2019 * If data was incorrectly changed, report and return.
2020 *
2021  same = .true.
2022  DO 30 i = 1, nargs
2023  same = same.AND.isame( i )
2024  IF( .NOT.isame( i ) )
2025  $ WRITE( nout, fmt = 9998 )i
2026  30 CONTINUE
2027  IF( .NOT.same )THEN
2028  fatal = .true.
2029  GO TO 120
2030  END IF
2031 *
2032  IF( .NOT.null )THEN
2033 *
2034 * Check the result column by column.
2035 *
2036  IF( incx.GT.0 )THEN
2037  DO 40 i = 1, n
2038  z( i ) = x( i )
2039  40 CONTINUE
2040  ELSE
2041  DO 50 i = 1, n
2042  z( i ) = x( n - i + 1 )
2043  50 CONTINUE
2044  END IF
2045  ja = 1
2046  DO 60 j = 1, n
2047  w( 1 ) = dconjg( z( j ) )
2048  IF( upper )THEN
2049  jj = 1
2050  lj = j
2051  ELSE
2052  jj = j
2053  lj = n - j + 1
2054  END IF
2055  CALL zmvch( 'N', lj, 1, alpha, z( jj ), lj, w,
2056  $ 1, one, a( jj, j ), 1, yt, g,
2057  $ aa( ja ), eps, err, fatal, nout,
2058  $ .true. )
2059  IF( full )THEN
2060  IF( upper )THEN
2061  ja = ja + lda
2062  ELSE
2063  ja = ja + lda + 1
2064  END IF
2065  ELSE
2066  ja = ja + lj
2067  END IF
2068  errmax = max( errmax, err )
2069 * If got really bad answer, report and return.
2070  IF( fatal )
2071  $ GO TO 110
2072  60 CONTINUE
2073  ELSE
2074 * Avoid repeating tests if N.le.0.
2075  IF( n.LE.0 )
2076  $ GO TO 100
2077  END IF
2078 *
2079  70 CONTINUE
2080 *
2081  80 CONTINUE
2082 *
2083  90 CONTINUE
2084 *
2085  100 CONTINUE
2086 *
2087 * Report result.
2088 *
2089  IF( errmax.LT.thresh )THEN
2090  WRITE( nout, fmt = 9999 )sname, nc
2091  ELSE
2092  WRITE( nout, fmt = 9997 )sname, nc, errmax
2093  END IF
2094  GO TO 130
2095 *
2096  110 CONTINUE
2097  WRITE( nout, fmt = 9995 )j
2098 *
2099  120 CONTINUE
2100  WRITE( nout, fmt = 9996 )sname
2101  IF( full )THEN
2102  WRITE( nout, fmt = 9993 )nc, sname, cuplo, n, ralpha, incx, lda
2103  ELSE IF( packed )THEN
2104  WRITE( nout, fmt = 9994 )nc, sname, cuplo, n, ralpha, incx
2105  END IF
2106 *
2107  130 CONTINUE
2108  RETURN
2109 *
2110  9999 FORMAT(' ',a12, ' PASSED THE COMPUTATIONAL TESTS (', i6, ' CALL',
2111  $ 'S)' )
2112  9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
2113  $ 'ANGED INCORRECTLY *******' )
2114  9997 FORMAT(' ',a12, ' COMPLETED THE COMPUTATIONAL TESTS (', i6, ' C',
2115  $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
2116  $ ' - SUSPECT *******' )
2117  9996 FORMAT( ' ******* ',a12, ' FAILED ON CALL NUMBER:' )
2118  9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', i3 )
2119  9994 FORMAT(1x, i6, ': ',a12, '(', a14, ',', i3, ',', f4.1, ', X,',
2120  $ i2, ', AP) .' )
2121  9993 FORMAT(1x, i6, ': ',a12, '(', a14, ',', i3, ',', f4.1, ', X,',
2122  $ i2, ', A,', i3, ') .' )
2123  9992 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
2124  $ '******' )
2125 *
2126 * End of CZHK5.
2127 *
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
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: