LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
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 1735 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 *
2030 10003 FORMAT( ' ', a12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
2031  $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
2032  $ 'RATIO ', f8.2, ' - SUSPECT *******' )
2033 10002 FORMAT( ' ', a12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
2034  $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
2035  $ 'RATIO ', f8.2, ' - SUSPECT *******' )
2036 10001 FORMAT( ' ', a12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
2037  $ ' (', i6, ' CALL', 'S)' )
2038 10000 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
smake
subroutine smake(TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, KU, RESET, TRANSL)
Definition: sblat2.f:2653
lse
logical function lse(RI, RJ, LR)
Definition: sblat2.f:2945
lseres
logical function lseres(TYPE, UPLO, M, N, AA, AS, LDA)
Definition: sblat2.f:2975
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:2511

Here is the call graph for this function: