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

◆ schk5()

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

Definition at line 1835 of file c_sblat2.f.

1839*
1840* Tests SSYR and SSPR.
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 REAL ZERO, HALF, ONE
1850 parameter( zero = 0.0, half = 0.5, one = 1.0 )
1851* .. Scalar Arguments ..
1852 REAL 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 REAL 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 REAL 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 REAL W( 1 )
1874 LOGICAL ISAME( 13 )
1875* .. External Functions ..
1876 LOGICAL LSE, LSERES
1877 EXTERNAL lse, lseres
1878* .. External Subroutines ..
1879 EXTERNAL smake, smvch, csspr, cssyr
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 smake( '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 smake( 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 cssyr( 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 csspr( 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 ) = lse( xs, xx, lx )
2000 isame( 5 ) = incxs.EQ.incx
2001 IF( null )THEN
2002 isame( 6 ) = lse( as, aa, laa )
2003 ELSE
2004 isame( 6 ) = lseres( 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 smvch( '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 )
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 SCHK5.
2129*
subroutine smvch(trans, m, n, alpha, a, nmax, x, incx, beta, y, incy, yt, g, yy, eps, err, fatal, nout, mv)
Definition sblat2.f:2854
logical function lseres(type, uplo, m, n, aa, as, lda)
Definition sblat2.f:3000
subroutine smake(type, uplo, diag, m, n, a, nmax, aa, lda, kl, ku, reset, transl)
Definition sblat2.f:2678
logical function lse(ri, rj, lr)
Definition sblat2.f:2970
Here is the call graph for this function: