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

◆ zchk5()

subroutine zchk5 ( character*6  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 
)

Definition at line 1798 of file zblat2.f.

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