LAPACK 3.12.0
LAPACK: Linear Algebra PACKage
Loading...
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  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 1731 of file c_sblat3.f.

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