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

◆ dchk5()

subroutine dchk5 ( character*13 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 nbet,
double precision, dimension( nbet ) bet,
integer nmax,
double precision, dimension( 2*nmax*nmax ) ab,
double precision, dimension( nmax*nmax ) aa,
double precision, dimension( nmax*nmax ) as,
double precision, dimension( nmax*nmax ) bb,
double precision, dimension( nmax*nmax ) bs,
double precision, dimension( nmax, nmax ) c,
double precision, dimension( nmax*nmax ) cc,
double precision, dimension( nmax*nmax ) cs,
double precision, dimension( nmax ) ct,
double precision, dimension( nmax ) g,
double precision, dimension( 2*nmax ) w,
integer iorder )

Definition at line 1742 of file c_dblat3.f.

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