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

◆ dchk5()

subroutine dchk5 ( character*12  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 1726 of file c_dblat3.f.

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