LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
subroutine cchk5 ( character*12  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  NINC,
integer, dimension( ninc )  INC,
integer  NMAX,
integer  INCMAX,
complex, dimension( nmax, nmax )  A,
complex, dimension( nmax*nmax )  AA,
complex, dimension( nmax*nmax )  AS,
complex, dimension( nmax )  X,
complex, dimension( nmax*incmax )  XX,
complex, dimension( nmax*incmax )  XS,
complex, dimension( nmax )  Y,
complex, dimension( nmax*incmax )  YY,
complex, dimension( nmax*incmax )  YS,
complex, dimension( nmax )  YT,
real, dimension( nmax )  G,
complex, dimension( nmax )  Z,
integer  IORDER 
)

Definition at line 1835 of file c_cblat2.f.

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

Here is the call graph for this function: