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

◆ zchk5()

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 1835 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*
lze
logical function lze(ri, rj, lr)
Definition zblat2.f:3075
lzeres
logical function lzeres(type, uplo, m, n, aa, as, lda)
Definition zblat2.f:3105
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:2944
zmake
subroutine zmake(type, uplo, diag, m, n, a, nmax, aa, lda, kl, ku, reset, transl)
Definition zblat2.f:2751
Here is the call graph for this function: