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

◆ schk5()

subroutine schk5 ( character*13 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 nbet,
real, dimension( nbet ) bet,
integer nmax,
real, dimension( 2*nmax*nmax ) ab,
real, dimension( nmax*nmax ) aa,
real, dimension( nmax*nmax ) as,
real, dimension( nmax*nmax ) bb,
real, dimension( nmax*nmax ) bs,
real, dimension( nmax, nmax ) c,
real, dimension( nmax*nmax ) cc,
real, dimension( nmax*nmax ) cs,
real, dimension( nmax ) ct,
real, dimension( nmax ) g,
real, dimension( 2*nmax ) w,
integer iorder )

Definition at line 1749 of file c_sblat3.f.

1753*
1754* Tests SSYR2K.
1755*
1756* Auxiliary routine for test program for Level 3 Blas.
1757*
1758* -- Written on 8-February-1989.
1759* Jack Dongarra, Argonne National Laboratory.
1760* Iain Duff, AERE Harwell.
1761* Jeremy Du Croz, Numerical Algorithms Group Ltd.
1762* Sven Hammarling, Numerical Algorithms Group Ltd.
1763*
1764* .. Parameters ..
1765 REAL ZERO
1766 parameter( zero = 0.0 )
1767* .. Scalar Arguments ..
1768 REAL EPS, THRESH
1769 INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER
1770 LOGICAL FATAL, REWI, TRACE
1771 CHARACTER*13 SNAME
1772* .. Array Arguments ..
1773 REAL AA( NMAX*NMAX ), AB( 2*NMAX*NMAX ),
1774 $ ALF( NALF ), AS( NMAX*NMAX ), BB( NMAX*NMAX ),
1775 $ BET( NBET ), BS( NMAX*NMAX ), C( NMAX, NMAX ),
1776 $ CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ),
1777 $ G( NMAX ), W( 2*NMAX )
1778 INTEGER IDIM( NIDIM )
1779* .. Local Scalars ..
1780 REAL ALPHA, ALS, BETA, BETS, ERR, ERRMAX
1781 INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, JJAB,
1782 $ K, KS, LAA, LBB, LCC, LDA, LDAS, LDB, LDBS,
1783 $ LDC, LDCS, LJ, MA, N, NA, NARGS, NC, NS
1784 LOGICAL NULL, RESET, SAME, TRAN, UPPER
1785 CHARACTER*1 TRANS, TRANSS, UPLO, UPLOS
1786 CHARACTER*2 ICHU
1787 CHARACTER*3 ICHT
1788* .. Local Arrays ..
1789 LOGICAL ISAME( 13 )
1790* .. External Functions ..
1791 LOGICAL LSE, LSERES
1792 EXTERNAL lse, lseres
1793* .. External Subroutines ..
1794 EXTERNAL smake, smmch, cssyr2k
1795* .. Intrinsic Functions ..
1796 INTRINSIC max
1797* .. Scalars in Common ..
1798 INTEGER INFOT, NOUTC
1799 LOGICAL OK
1800* .. Common blocks ..
1801 COMMON /infoc/infot, noutc, ok
1802* .. Data statements ..
1803 DATA icht/'NTC'/, ichu/'UL'/
1804* .. Executable Statements ..
1805*
1806 nargs = 12
1807 nc = 0
1808 reset = .true.
1809 errmax = zero
1810*
1811 DO 130 in = 1, nidim
1812 n = idim( in )
1813* Set LDC to 1 more than minimum value if room.
1814 ldc = n
1815 IF( ldc.LT.nmax )
1816 $ ldc = ldc + 1
1817* Skip tests if not enough room.
1818 IF( ldc.GT.nmax )
1819 $ GO TO 130
1820 lcc = ldc*n
1821 null = n.LE.0
1822*
1823 DO 120 ik = 1, nidim
1824 k = idim( ik )
1825*
1826 DO 110 ict = 1, 3
1827 trans = icht( ict: ict )
1828 tran = trans.EQ.'T'.OR.trans.EQ.'C'
1829 IF( tran )THEN
1830 ma = k
1831 na = n
1832 ELSE
1833 ma = n
1834 na = k
1835 END IF
1836* Set LDA to 1 more than minimum value if room.
1837 lda = ma
1838 IF( lda.LT.nmax )
1839 $ lda = lda + 1
1840* Skip tests if not enough room.
1841 IF( lda.GT.nmax )
1842 $ GO TO 110
1843 laa = lda*na
1844*
1845* Generate the matrix A.
1846*
1847 IF( tran )THEN
1848 CALL smake( 'GE', ' ', ' ', ma, na, ab, 2*nmax, aa,
1849 $ lda, reset, zero )
1850 ELSE
1851 CALL smake( 'GE', ' ', ' ', ma, na, ab, nmax, aa, lda,
1852 $ reset, zero )
1853 END IF
1854*
1855* Generate the matrix B.
1856*
1857 ldb = lda
1858 lbb = laa
1859 IF( tran )THEN
1860 CALL smake( 'GE', ' ', ' ', ma, na, ab( k + 1 ),
1861 $ 2*nmax, bb, ldb, reset, zero )
1862 ELSE
1863 CALL smake( 'GE', ' ', ' ', ma, na, ab( k*nmax + 1 ),
1864 $ nmax, bb, ldb, reset, zero )
1865 END IF
1866*
1867 DO 100 icu = 1, 2
1868 uplo = ichu( icu: icu )
1869 upper = uplo.EQ.'U'
1870*
1871 DO 90 ia = 1, nalf
1872 alpha = alf( ia )
1873*
1874 DO 80 ib = 1, nbet
1875 beta = bet( ib )
1876*
1877* Generate the matrix C.
1878*
1879 CALL smake( 'SY', uplo, ' ', n, n, c, nmax, cc,
1880 $ ldc, reset, zero )
1881*
1882 nc = nc + 1
1883*
1884* Save every datum before calling the subroutine.
1885*
1886 uplos = uplo
1887 transs = trans
1888 ns = n
1889 ks = k
1890 als = alpha
1891 DO 10 i = 1, laa
1892 as( i ) = aa( i )
1893 10 CONTINUE
1894 ldas = lda
1895 DO 20 i = 1, lbb
1896 bs( i ) = bb( i )
1897 20 CONTINUE
1898 ldbs = ldb
1899 bets = beta
1900 DO 30 i = 1, lcc
1901 cs( i ) = cc( i )
1902 30 CONTINUE
1903 ldcs = ldc
1904*
1905* Call the subroutine.
1906*
1907 IF( trace )
1908 $ CALL sprcn5( ntra, nc, sname, iorder, uplo,
1909 $ trans, n, k, alpha, lda, ldb, beta, ldc)
1910 IF( rewi )
1911 $ rewind ntra
1912 CALL cssyr2k( iorder, uplo, trans, n, k, alpha,
1913 $ aa, lda, bb, ldb, beta, cc, ldc )
1914*
1915* Check if error-exit was taken incorrectly.
1916*
1917 IF( .NOT.ok )THEN
1918 WRITE( nout, fmt = 9993 )
1919 fatal = .true.
1920 GO TO 150
1921 END IF
1922*
1923* See what data changed inside subroutines.
1924*
1925 isame( 1 ) = uplos.EQ.uplo
1926 isame( 2 ) = transs.EQ.trans
1927 isame( 3 ) = ns.EQ.n
1928 isame( 4 ) = ks.EQ.k
1929 isame( 5 ) = als.EQ.alpha
1930 isame( 6 ) = lse( as, aa, laa )
1931 isame( 7 ) = ldas.EQ.lda
1932 isame( 8 ) = lse( bs, bb, lbb )
1933 isame( 9 ) = ldbs.EQ.ldb
1934 isame( 10 ) = bets.EQ.beta
1935 IF( null )THEN
1936 isame( 11 ) = lse( cs, cc, lcc )
1937 ELSE
1938 isame( 11 ) = lseres( 'SY', uplo, n, n, cs,
1939 $ cc, ldc )
1940 END IF
1941 isame( 12 ) = ldcs.EQ.ldc
1942*
1943* If data was incorrectly changed, report and
1944* return.
1945*
1946 same = .true.
1947 DO 40 i = 1, nargs
1948 same = same.AND.isame( i )
1949 IF( .NOT.isame( i ) )
1950 $ WRITE( nout, fmt = 9998 )i+1
1951 40 CONTINUE
1952 IF( .NOT.same )THEN
1953 fatal = .true.
1954 GO TO 150
1955 END IF
1956*
1957 IF( .NOT.null )THEN
1958*
1959* Check the result column by column.
1960*
1961 jjab = 1
1962 jc = 1
1963 DO 70 j = 1, n
1964 IF( upper )THEN
1965 jj = 1
1966 lj = j
1967 ELSE
1968 jj = j
1969 lj = n - j + 1
1970 END IF
1971 IF( tran )THEN
1972 DO 50 i = 1, k
1973 w( i ) = ab( ( j - 1 )*2*nmax + k +
1974 $ i )
1975 w( k + i ) = ab( ( j - 1 )*2*nmax +
1976 $ i )
1977 50 CONTINUE
1978 CALL smmch( 'T', 'N', lj, 1, 2*k,
1979 $ alpha, ab( jjab ), 2*nmax,
1980 $ w, 2*nmax, beta,
1981 $ c( jj, j ), nmax, ct, g,
1982 $ cc( jc ), ldc, eps, err,
1983 $ fatal, nout, .true. )
1984 ELSE
1985 DO 60 i = 1, k
1986 w( i ) = ab( ( k + i - 1 )*nmax +
1987 $ j )
1988 w( k + i ) = ab( ( i - 1 )*nmax +
1989 $ j )
1990 60 CONTINUE
1991 CALL smmch( 'N', 'N', lj, 1, 2*k,
1992 $ alpha, ab( jj ), nmax, w,
1993 $ 2*nmax, beta, c( jj, j ),
1994 $ nmax, ct, g, cc( jc ), ldc,
1995 $ eps, err, fatal, nout,
1996 $ .true. )
1997 END IF
1998 IF( upper )THEN
1999 jc = jc + ldc
2000 ELSE
2001 jc = jc + ldc + 1
2002 IF( tran )
2003 $ jjab = jjab + 2*nmax
2004 END IF
2005 errmax = max( errmax, err )
2006* If got really bad answer, report and
2007* return.
2008 IF( fatal )
2009 $ GO TO 140
2010 70 CONTINUE
2011 END IF
2012*
2013 80 CONTINUE
2014*
2015 90 CONTINUE
2016*
2017 100 CONTINUE
2018*
2019 110 CONTINUE
2020*
2021 120 CONTINUE
2022*
2023 130 CONTINUE
2024*
2025* Report result.
2026*
2027 IF( errmax.LT.thresh )THEN
2028 IF ( iorder.EQ.0) WRITE( nout, fmt = 10000 )sname, nc
2029 IF ( iorder.EQ.1) WRITE( nout, fmt = 10001 )sname, nc
2030 ELSE
2031 IF ( iorder.EQ.0) WRITE( nout, fmt = 10002 )sname, nc, errmax
2032 IF ( iorder.EQ.1) WRITE( nout, fmt = 10003 )sname, nc, errmax
2033 END IF
2034 GO TO 160
2035*
2036 140 CONTINUE
2037 IF( n.GT.1 )
2038 $ WRITE( nout, fmt = 9995 )j
2039*
2040 150 CONTINUE
2041 WRITE( nout, fmt = 9996 )sname
2042 CALL sprcn5( nout, nc, sname, iorder, uplo, trans, n, k, alpha,
2043 $ lda, ldb, beta, ldc)
2044*
2045 160 CONTINUE
2046 RETURN
2047*
204810003 FORMAT( ' ', a13,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
2049 $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
2050 $ 'RATIO ', f8.2, ' - SUSPECT *******' )
205110002 FORMAT( ' ', a13,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
2052 $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
2053 $ 'RATIO ', f8.2, ' - SUSPECT *******' )
205410001 FORMAT( ' ', a13,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
2055 $ ' (', i6, ' CALL', 'S)' )
205610000 FORMAT( ' ', a13,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
2057 $ ' (', i6, ' CALL', 'S)' )
2058 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
2059 $ 'ANGED INCORRECTLY *******' )
2060 9996 FORMAT( ' ******* ', a13,' FAILED ON CALL NUMBER:' )
2061 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', i3 )
2062 9994 FORMAT( 1x, i6, ': ', a13,'(', 2( '''', a1, ''',' ), 2( i3, ',' ),
2063 $ f4.1, ', A,', i3, ', B,', i3, ',', f4.1, ', C,', i3, ') ',
2064 $ ' .' )
2065 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
2066 $ '******' )
2067*
2068* End of SCHK5.
2069*
sprcn5
subroutine sprcn5(nout, nc, sname, iorder, uplo, transa, n, k, alpha, lda, ldb, beta, ldc)
Definition c_sblat3.f:2074
lseres
logical function lseres(type, uplo, m, n, aa, as, lda)
Definition sblat2.f:3000
smake
subroutine smake(type, uplo, diag, m, n, a, nmax, aa, lda, kl, ku, reset, transl)
Definition sblat2.f:2678
lse
logical function lse(ri, rj, lr)
Definition sblat2.f:2970
smmch
subroutine smmch(transa, transb, m, n, kk, alpha, a, lda, b, ldb, beta, c, ldc, ct, g, cc, ldcc, eps, err, fatal, nout, mv)
Definition sblat3.f:2594
Here is the call graph for this function: