LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
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 1730 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 *
2026 10003 FORMAT( ' ', a12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
2027  $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
2028  $ 'RATIO ', f8.2, ' - SUSPECT *******' )
2029 10002 FORMAT( ' ', a12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
2030  $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
2031  $ 'RATIO ', f8.2, ' - SUSPECT *******' )
2032 10001 FORMAT( ' ', a12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
2033  $ ' (', i6, ' CALL', 'S)' )
2034 10000 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 *
dmake
subroutine dmake(TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, KU, RESET, TRANSL)
Definition: dblat2.f:2653
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:2511
lde
logical function lde(RI, RJ, LR)
Definition: dblat2.f:2945
dprcn5
subroutine dprcn5(NOUT, NC, SNAME, IORDER, UPLO, TRANSA, N, K, ALPHA, LDA, LDB, BETA, LDC)
Definition: c_dblat3.f:2052
lderes
logical function lderes(TYPE, UPLO, M, N, AA, AS, LDA)
Definition: dblat2.f:2975

Here is the call graph for this function: