LAPACK  3.9.1
LAPACK: Linear Algebra PACKage

◆ cchk5()

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 1765 of file cblat2.f.

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