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

◆ dchk5()

subroutine dchk5 ( character*6  sname,
double precision  eps,
double precision  thresh,
integer  nout,
integer  ntra,
logical  trace,
logical  rewi,
logical  fatal,
integer  nidim,
integer, dimension( nidim )  idim,
integer  nalf,
double precision, dimension( nalf )  alf,
integer  ninc,
integer, dimension( ninc )  inc,
integer  nmax,
integer  incmax,
double precision, dimension( nmax, nmax )  a,
double precision, dimension( nmax*nmax )  aa,
double precision, dimension( nmax*nmax )  as,
double precision, dimension( nmax )  x,
double precision, dimension( nmax*incmax )  xx,
double precision, dimension( nmax*incmax )  xs,
double precision, dimension( nmax )  y,
double precision, dimension( nmax*incmax )  yy,
double precision, dimension( nmax*incmax )  ys,
double precision, dimension( nmax )  yt,
double precision, dimension( nmax )  g,
double precision, dimension( nmax )  z 
)

Definition at line 1757 of file dblat2.f.

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