LAPACK 3.12.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches

◆ cchk5()

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 1831 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*
cmake
subroutine cmake(type, uplo, diag, m, n, a, nmax, aa, lda, kl, ku, reset, transl)
Definition cblat2.f:2744
lceres
logical function lceres(type, uplo, m, n, aa, as, lda)
Definition cblat2.f:3097
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:2936
lce
logical function lce(ri, rj, lr)
Definition cblat2.f:3067
Here is the call graph for this function: