LAPACK  3.10.0
LAPACK: Linear Algebra PACKage

◆ schk5()

subroutine schk5 ( character*6  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 
)

Definition at line 1729 of file sblat2.f.

1733 *
1734 * Tests SSYR and SSPR.
1735 *
1736 * Auxiliary routine for test program for Level 2 Blas.
1737 *
1738 * -- Written on 10-August-1987.
1739 * Richard Hanson, Sandia National Labs.
1740 * Jeremy Du Croz, NAG Central Office.
1741 *
1742 * .. Parameters ..
1743  REAL ZERO, HALF, ONE
1744  parameter( zero = 0.0, half = 0.5, one = 1.0 )
1745 * .. Scalar Arguments ..
1746  REAL EPS, THRESH
1747  INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA
1748  LOGICAL FATAL, REWI, TRACE
1749  CHARACTER*6 SNAME
1750 * .. Array Arguments ..
1751  REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
1752  $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ),
1753  $ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ),
1754  $ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ),
1755  $ YY( NMAX*INCMAX ), Z( NMAX )
1756  INTEGER IDIM( NIDIM ), INC( NINC )
1757 * .. Local Scalars ..
1758  REAL ALPHA, ALS, ERR, ERRMAX, TRANSL
1759  INTEGER I, IA, IC, IN, INCX, INCXS, IX, J, JA, JJ, LAA,
1760  $ LDA, LDAS, LJ, LX, N, NARGS, NC, NS
1761  LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER
1762  CHARACTER*1 UPLO, UPLOS
1763  CHARACTER*2 ICH
1764 * .. Local Arrays ..
1765  REAL W( 1 )
1766  LOGICAL ISAME( 13 )
1767 * .. External Functions ..
1768  LOGICAL LSE, LSERES
1769  EXTERNAL lse, lseres
1770 * .. External Subroutines ..
1771  EXTERNAL smake, smvch, sspr, ssyr
1772 * .. Intrinsic Functions ..
1773  INTRINSIC abs, max
1774 * .. Scalars in Common ..
1775  INTEGER INFOT, NOUTC
1776  LOGICAL LERR, OK
1777 * .. Common blocks ..
1778  COMMON /infoc/infot, noutc, ok, lerr
1779 * .. Data statements ..
1780  DATA ich/'UL'/
1781 * .. Executable Statements ..
1782  full = sname( 3: 3 ).EQ.'Y'
1783  packed = sname( 3: 3 ).EQ.'P'
1784 * Define the number of arguments.
1785  IF( full )THEN
1786  nargs = 7
1787  ELSE IF( packed )THEN
1788  nargs = 6
1789  END IF
1790 *
1791  nc = 0
1792  reset = .true.
1793  errmax = zero
1794 *
1795  DO 100 in = 1, nidim
1796  n = idim( in )
1797 * Set LDA to 1 more than minimum value if room.
1798  lda = n
1799  IF( lda.LT.nmax )
1800  $ lda = lda + 1
1801 * Skip tests if not enough room.
1802  IF( lda.GT.nmax )
1803  $ GO TO 100
1804  IF( packed )THEN
1805  laa = ( n*( n + 1 ) )/2
1806  ELSE
1807  laa = lda*n
1808  END IF
1809 *
1810  DO 90 ic = 1, 2
1811  uplo = ich( ic: ic )
1812  upper = uplo.EQ.'U'
1813 *
1814  DO 80 ix = 1, ninc
1815  incx = inc( ix )
1816  lx = abs( incx )*n
1817 *
1818 * Generate the vector X.
1819 *
1820  transl = half
1821  CALL smake( 'GE', ' ', ' ', 1, n, x, 1, xx, abs( incx ),
1822  $ 0, n - 1, reset, transl )
1823  IF( n.GT.1 )THEN
1824  x( n/2 ) = zero
1825  xx( 1 + abs( incx )*( n/2 - 1 ) ) = zero
1826  END IF
1827 *
1828  DO 70 ia = 1, nalf
1829  alpha = alf( ia )
1830  null = n.LE.0.OR.alpha.EQ.zero
1831 *
1832 * Generate the matrix A.
1833 *
1834  transl = zero
1835  CALL smake( sname( 2: 3 ), uplo, ' ', n, n, a, nmax,
1836  $ aa, lda, n - 1, n - 1, reset, transl )
1837 *
1838  nc = nc + 1
1839 *
1840 * Save every datum before calling the subroutine.
1841 *
1842  uplos = uplo
1843  ns = n
1844  als = alpha
1845  DO 10 i = 1, laa
1846  as( i ) = aa( i )
1847  10 CONTINUE
1848  ldas = lda
1849  DO 20 i = 1, lx
1850  xs( i ) = xx( i )
1851  20 CONTINUE
1852  incxs = incx
1853 *
1854 * Call the subroutine.
1855 *
1856  IF( full )THEN
1857  IF( trace )
1858  $ WRITE( ntra, fmt = 9993 )nc, sname, uplo, n,
1859  $ alpha, incx, lda
1860  IF( rewi )
1861  $ rewind ntra
1862  CALL ssyr( uplo, n, alpha, xx, incx, aa, lda )
1863  ELSE IF( packed )THEN
1864  IF( trace )
1865  $ WRITE( ntra, fmt = 9994 )nc, sname, uplo, n,
1866  $ alpha, incx
1867  IF( rewi )
1868  $ rewind ntra
1869  CALL sspr( uplo, n, alpha, xx, incx, aa )
1870  END IF
1871 *
1872 * Check if error-exit was taken incorrectly.
1873 *
1874  IF( .NOT.ok )THEN
1875  WRITE( nout, fmt = 9992 )
1876  fatal = .true.
1877  GO TO 120
1878  END IF
1879 *
1880 * See what data changed inside subroutines.
1881 *
1882  isame( 1 ) = uplo.EQ.uplos
1883  isame( 2 ) = ns.EQ.n
1884  isame( 3 ) = als.EQ.alpha
1885  isame( 4 ) = lse( xs, xx, lx )
1886  isame( 5 ) = incxs.EQ.incx
1887  IF( null )THEN
1888  isame( 6 ) = lse( as, aa, laa )
1889  ELSE
1890  isame( 6 ) = lseres( sname( 2: 3 ), uplo, n, n, as,
1891  $ aa, lda )
1892  END IF
1893  IF( .NOT.packed )THEN
1894  isame( 7 ) = ldas.EQ.lda
1895  END IF
1896 *
1897 * If data was incorrectly changed, report and return.
1898 *
1899  same = .true.
1900  DO 30 i = 1, nargs
1901  same = same.AND.isame( i )
1902  IF( .NOT.isame( i ) )
1903  $ WRITE( nout, fmt = 9998 )i
1904  30 CONTINUE
1905  IF( .NOT.same )THEN
1906  fatal = .true.
1907  GO TO 120
1908  END IF
1909 *
1910  IF( .NOT.null )THEN
1911 *
1912 * Check the result column by column.
1913 *
1914  IF( incx.GT.0 )THEN
1915  DO 40 i = 1, n
1916  z( i ) = x( i )
1917  40 CONTINUE
1918  ELSE
1919  DO 50 i = 1, n
1920  z( i ) = x( n - i + 1 )
1921  50 CONTINUE
1922  END IF
1923  ja = 1
1924  DO 60 j = 1, n
1925  w( 1 ) = z( j )
1926  IF( upper )THEN
1927  jj = 1
1928  lj = j
1929  ELSE
1930  jj = j
1931  lj = n - j + 1
1932  END IF
1933  CALL smvch( 'N', lj, 1, alpha, z( jj ), lj, w,
1934  $ 1, one, a( jj, j ), 1, yt, g,
1935  $ aa( ja ), eps, err, fatal, nout,
1936  $ .true. )
1937  IF( full )THEN
1938  IF( upper )THEN
1939  ja = ja + lda
1940  ELSE
1941  ja = ja + lda + 1
1942  END IF
1943  ELSE
1944  ja = ja + lj
1945  END IF
1946  errmax = max( errmax, err )
1947 * If got really bad answer, report and return.
1948  IF( fatal )
1949  $ GO TO 110
1950  60 CONTINUE
1951  ELSE
1952 * Avoid repeating tests if N.le.0.
1953  IF( n.LE.0 )
1954  $ GO TO 100
1955  END IF
1956 *
1957  70 CONTINUE
1958 *
1959  80 CONTINUE
1960 *
1961  90 CONTINUE
1962 *
1963  100 CONTINUE
1964 *
1965 * Report result.
1966 *
1967  IF( errmax.LT.thresh )THEN
1968  WRITE( nout, fmt = 9999 )sname, nc
1969  ELSE
1970  WRITE( nout, fmt = 9997 )sname, nc, errmax
1971  END IF
1972  GO TO 130
1973 *
1974  110 CONTINUE
1975  WRITE( nout, fmt = 9995 )j
1976 *
1977  120 CONTINUE
1978  WRITE( nout, fmt = 9996 )sname
1979  IF( full )THEN
1980  WRITE( nout, fmt = 9993 )nc, sname, uplo, n, alpha, incx, lda
1981  ELSE IF( packed )THEN
1982  WRITE( nout, fmt = 9994 )nc, sname, uplo, n, alpha, incx
1983  END IF
1984 *
1985  130 CONTINUE
1986  RETURN
1987 *
1988  9999 FORMAT( ' ', a6, ' PASSED THE COMPUTATIONAL TESTS (', i6, ' CALL',
1989  $ 'S)' )
1990  9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
1991  $ 'ANGED INCORRECTLY *******' )
1992  9997 FORMAT( ' ', a6, ' COMPLETED THE COMPUTATIONAL TESTS (', i6, ' C',
1993  $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
1994  $ ' - SUSPECT *******' )
1995  9996 FORMAT( ' ******* ', a6, ' FAILED ON CALL NUMBER:' )
1996  9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', i3 )
1997  9994 FORMAT( 1x, i6, ': ', a6, '(''', a1, ''',', i3, ',', f4.1, ', X,',
1998  $ i2, ', AP) .' )
1999  9993 FORMAT( 1x, i6, ': ', a6, '(''', a1, ''',', i3, ',', f4.1, ', X,',
2000  $ i2, ', A,', i3, ') .' )
2001  9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
2002  $ '******' )
2003 *
2004 * End of SCHK5
2005 *
sspr
subroutine sspr(UPLO, N, ALPHA, X, INCX, AP)
SSPR
Definition: sspr.f:127
ssyr
subroutine ssyr(UPLO, N, ALPHA, X, INCX, A, LDA)
SSYR
Definition: ssyr.f:132
lse
logical function lse(RI, RJ, LR)
Definition: sblat2.f:2942
smvch
subroutine smvch(TRANS, M, N, ALPHA, A, NMAX, X, INCX, BETA, Y, INCY, YT, G, YY, EPS, ERR, FATAL, NOUT, MV)
Definition: sblat2.f:2826
lseres
logical function lseres(TYPE, UPLO, M, N, AA, AS, LDA)
Definition: sblat2.f:2972
smake
subroutine smake(TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, KU, RESET, TRANSL)
Definition: sblat2.f:2650
Here is the call graph for this function:
Here is the caller graph for this function: