LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
subroutine cchk5 ( character*6  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 
)

Definition at line 1772 of file cblat2.f.

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

Here is the caller graph for this function: