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

◆ dchk5()

subroutine dchk5 ( 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,
double precision, dimension( nalf )  alf,
integer  ninc,
integer, dimension( ninc )  inc,
integer  nmax,
integer  incmax,
double precision, dimension( nmax, nmax )  a,
double precision, dimension( nmax*nmax )  aa,
double precision, dimension( nmax*nmax )  as,
double precision, dimension( nmax )  x,
double precision, dimension( nmax*incmax )  xx,
double precision, dimension( nmax*incmax )  xs,
double precision, dimension( nmax )  y,
double precision, dimension( nmax*incmax )  yy,
double precision, dimension( nmax*incmax )  ys,
double precision, dimension( nmax )  yt,
double precision, dimension( nmax )  g,
double precision, dimension( nmax )  z,
integer  iorder 
)

Definition at line 1835 of file c_dblat2.f.

1839*
1840* Tests DSYR and DSPR.
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 DOUBLE PRECISION ZERO, HALF, ONE
1850 parameter( zero = 0.0d0, half = 0.5d0, one = 1.0d0 )
1851* .. Scalar Arguments ..
1852 DOUBLE PRECISION EPS, THRESH
1853 INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA,
1854 $ IORDER
1855 LOGICAL FATAL, REWI, TRACE
1856 CHARACTER*12 SNAME
1857* .. Array Arguments ..
1858 DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
1859 $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ),
1860 $ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ),
1861 $ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ),
1862 $ YY( NMAX*INCMAX ), Z( NMAX )
1863 INTEGER IDIM( NIDIM ), INC( NINC )
1864* .. Local Scalars ..
1865 DOUBLE PRECISION ALPHA, ALS, ERR, ERRMAX, TRANSL
1866 INTEGER I, IA, IC, IN, INCX, INCXS, IX, J, JA, JJ, LAA,
1867 $ LDA, LDAS, LJ, LX, N, NARGS, NC, NS
1868 LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER
1869 CHARACTER*1 UPLO, UPLOS
1870 CHARACTER*14 CUPLO
1871 CHARACTER*2 ICH
1872* .. Local Arrays ..
1873 DOUBLE PRECISION W( 1 )
1874 LOGICAL ISAME( 13 )
1875* .. External Functions ..
1876 LOGICAL LDE, LDERES
1877 EXTERNAL lde, lderes
1878* .. External Subroutines ..
1879 EXTERNAL dmake, dmvch, cdspr, cdsyr
1880* .. Intrinsic Functions ..
1881 INTRINSIC abs, max
1882* .. Scalars in Common ..
1883 INTEGER INFOT, NOUTC
1884 LOGICAL OK
1885* .. Common blocks ..
1886 COMMON /infoc/infot, noutc, ok
1887* .. Data statements ..
1888 DATA ich/'UL'/
1889* .. Executable Statements ..
1890 full = sname( 9: 9 ).EQ.'y'
1891 packed = sname( 9: 9 ).EQ.'p'
1892* Define the number of arguments.
1893 IF( full )THEN
1894 nargs = 7
1895 ELSE IF( packed )THEN
1896 nargs = 6
1897 END IF
1898*
1899 nc = 0
1900 reset = .true.
1901 errmax = zero
1902*
1903 DO 100 in = 1, nidim
1904 n = idim( in )
1905* Set LDA to 1 more than minimum value if room.
1906 lda = n
1907 IF( lda.LT.nmax )
1908 $ lda = lda + 1
1909* Skip tests if not enough room.
1910 IF( lda.GT.nmax )
1911 $ GO TO 100
1912 IF( packed )THEN
1913 laa = ( n*( n + 1 ) )/2
1914 ELSE
1915 laa = lda*n
1916 END IF
1917*
1918 DO 90 ic = 1, 2
1919 uplo = ich( ic: ic )
1920 IF (uplo.EQ.'U')THEN
1921 cuplo = ' CblasUpper'
1922 ELSE
1923 cuplo = ' CblasLower'
1924 END IF
1925 upper = uplo.EQ.'U'
1926*
1927 DO 80 ix = 1, ninc
1928 incx = inc( ix )
1929 lx = abs( incx )*n
1930*
1931* Generate the vector X.
1932*
1933 transl = half
1934 CALL dmake( 'ge', ' ', ' ', 1, n, x, 1, xx, abs( incx ),
1935 $ 0, n - 1, reset, transl )
1936 IF( n.GT.1 )THEN
1937 x( n/2 ) = zero
1938 xx( 1 + abs( incx )*( n/2 - 1 ) ) = zero
1939 END IF
1940*
1941 DO 70 ia = 1, nalf
1942 alpha = alf( ia )
1943 null = n.LE.0.OR.alpha.EQ.zero
1944*
1945* Generate the matrix A.
1946*
1947 transl = zero
1948 CALL dmake( sname( 8: 9 ), uplo, ' ', n, n, a, nmax,
1949 $ aa, lda, n - 1, n - 1, reset, transl )
1950*
1951 nc = nc + 1
1952*
1953* Save every datum before calling the subroutine.
1954*
1955 uplos = uplo
1956 ns = n
1957 als = alpha
1958 DO 10 i = 1, laa
1959 as( i ) = aa( i )
1960 10 CONTINUE
1961 ldas = lda
1962 DO 20 i = 1, lx
1963 xs( i ) = xx( i )
1964 20 CONTINUE
1965 incxs = incx
1966*
1967* Call the subroutine.
1968*
1969 IF( full )THEN
1970 IF( trace )
1971 $ WRITE( ntra, fmt = 9993 )nc, sname, cuplo, n,
1972 $ alpha, incx, lda
1973 IF( rewi )
1974 $ rewind ntra
1975 CALL cdsyr( iorder, uplo, n, alpha, xx, incx,
1976 $ aa, lda )
1977 ELSE IF( packed )THEN
1978 IF( trace )
1979 $ WRITE( ntra, fmt = 9994 )nc, sname, cuplo, n,
1980 $ alpha, incx
1981 IF( rewi )
1982 $ rewind ntra
1983 CALL cdspr( iorder, uplo, n, alpha, xx, incx, aa )
1984 END IF
1985*
1986* Check if error-exit was taken incorrectly.
1987*
1988 IF( .NOT.ok )THEN
1989 WRITE( nout, fmt = 9992 )
1990 fatal = .true.
1991 GO TO 120
1992 END IF
1993*
1994* See what data changed inside subroutines.
1995*
1996 isame( 1 ) = uplo.EQ.uplos
1997 isame( 2 ) = ns.EQ.n
1998 isame( 3 ) = als.EQ.alpha
1999 isame( 4 ) = lde( xs, xx, lx )
2000 isame( 5 ) = incxs.EQ.incx
2001 IF( null )THEN
2002 isame( 6 ) = lde( as, aa, laa )
2003 ELSE
2004 isame( 6 ) = lderes( sname( 8: 9 ), uplo, n, n, as,
2005 $ aa, lda )
2006 END IF
2007 IF( .NOT.packed )THEN
2008 isame( 7 ) = ldas.EQ.lda
2009 END IF
2010*
2011* If data was incorrectly changed, report and return.
2012*
2013 same = .true.
2014 DO 30 i = 1, nargs
2015 same = same.AND.isame( i )
2016 IF( .NOT.isame( i ) )
2017 $ WRITE( nout, fmt = 9998 )i
2018 30 CONTINUE
2019 IF( .NOT.same )THEN
2020 fatal = .true.
2021 GO TO 120
2022 END IF
2023*
2024 IF( .NOT.null )THEN
2025*
2026* Check the result column by column.
2027*
2028 IF( incx.GT.0 )THEN
2029 DO 40 i = 1, n
2030 z( i ) = x( i )
2031 40 CONTINUE
2032 ELSE
2033 DO 50 i = 1, n
2034 z( i ) = x( n - i + 1 )
2035 50 CONTINUE
2036 END IF
2037 ja = 1
2038 DO 60 j = 1, n
2039 w( 1 ) = z( j )
2040 IF( upper )THEN
2041 jj = 1
2042 lj = j
2043 ELSE
2044 jj = j
2045 lj = n - j + 1
2046 END IF
2047 CALL dmvch( 'N', lj, 1, alpha, z( jj ), lj, w,
2048 $ 1, one, a( jj, j ), 1, yt, g,
2049 $ aa( ja ), eps, err, fatal, nout,
2050 $ .true. )
2051 IF( full )THEN
2052 IF( upper )THEN
2053 ja = ja + lda
2054 ELSE
2055 ja = ja + lda + 1
2056 END IF
2057 ELSE
2058 ja = ja + lj
2059 END IF
2060 errmax = max( errmax, err )
2061* If got really bad answer, report and return.
2062 IF( fatal )
2063 $ GO TO 110
2064 60 CONTINUE
2065 ELSE
2066* Avoid repeating tests if N.le.0.
2067 IF( n.LE.0 )
2068 $ GO TO 100
2069 END IF
2070*
2071 70 CONTINUE
2072*
2073 80 CONTINUE
2074*
2075 90 CONTINUE
2076*
2077 100 CONTINUE
2078*
2079* Report result.
2080*
2081 IF( errmax.LT.thresh )THEN
2082 IF ( iorder.EQ.0) WRITE( nout, fmt = 10000 )sname, nc
2083 IF ( iorder.EQ.1) WRITE( nout, fmt = 10001 )sname, nc
2084 ELSE
2085 IF ( iorder.EQ.0) WRITE( nout, fmt = 10002 )sname, nc, errmax
2086 IF ( iorder.EQ.1) WRITE( nout, fmt = 10003 )sname, nc, errmax
2087 END IF
2088 GO TO 130
2089*
2090 110 CONTINUE
2091 WRITE( nout, fmt = 9995 )j
2092*
2093 120 CONTINUE
2094 WRITE( nout, fmt = 9996 )sname
2095 IF( full )THEN
2096 WRITE( nout, fmt = 9993 )nc, sname, cuplo, n, alpha, incx, lda
2097 ELSE IF( packed )THEN
2098 WRITE( nout, fmt = 9994 )nc, sname, cuplo, n, alpha, incx
2099 END IF
2100*
2101 130 CONTINUE
2102 RETURN
2103*
210410003 FORMAT( ' ', a12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
2105 $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
2106 $ 'RATIO ', f8.2, ' - SUSPECT *******' )
210710002 FORMAT( ' ', a12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
2108 $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
2109 $ 'RATIO ', f8.2, ' - SUSPECT *******' )
211010001 FORMAT( ' ', a12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
2111 $ ' (', i6, ' CALL', 'S)' )
211210000 FORMAT( ' ', a12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
2113 $ ' (', i6, ' CALL', 'S)' )
2114 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
2115 $ 'ANGED INCORRECTLY *******' )
2116 9997 FORMAT( ' ',a12, ' COMPLETED THE COMPUTATIONAL TESTS (', i6, ' C',
2117 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
2118 $ ' - SUSPECT *******' )
2119 9996 FORMAT( ' ******* ',a12, ' FAILED ON CALL NUMBER:' )
2120 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', i3 )
2121 9994 FORMAT( 1x, i6, ': ',a12, '(', a14, ',', i3, ',', f4.1, ', X,',
2122 $ i2, ', AP) .' )
2123 9993 FORMAT( 1x, i6, ': ',a12, '(', a14, ',', i3, ',', f4.1, ', X,',
2124 $ i2, ', A,', i3, ') .' )
2125 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
2126 $ '******' )
2127*
2128* End of DCHK5.
2129*
dmvch
subroutine dmvch(trans, m, n, alpha, a, nmax, x, incx, beta, y, incy, yt, g, yy, eps, err, fatal, nout, mv)
Definition dblat2.f:2854
lde
logical function lde(ri, rj, lr)
Definition dblat2.f:2970
lderes
logical function lderes(type, uplo, m, n, aa, as, lda)
Definition dblat2.f:3000
dmake
subroutine dmake(type, uplo, diag, m, n, a, nmax, aa, lda, kl, ku, reset, transl)
Definition dblat2.f:2678
Here is the call graph for this function: