LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
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 1736 of file sblat2.f.

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

Here is the call graph for this function:

Here is the caller graph for this function: