LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
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  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 
)

Definition at line 1529 of file dblat3.f.

1529 *
1530 * Tests DSYR2K.
1531 *
1532 * Auxiliary routine for test program for Level 3 Blas.
1533 *
1534 * -- Written on 8-February-1989.
1535 * Jack Dongarra, Argonne National Laboratory.
1536 * Iain Duff, AERE Harwell.
1537 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
1538 * Sven Hammarling, Numerical Algorithms Group Ltd.
1539 *
1540 * .. Parameters ..
1541  DOUBLE PRECISION zero
1542  parameter ( zero = 0.0d0 )
1543 * .. Scalar Arguments ..
1544  DOUBLE PRECISION eps, thresh
1545  INTEGER nalf, nbet, nidim, nmax, nout, ntra
1546  LOGICAL fatal, rewi, trace
1547  CHARACTER*6 sname
1548 * .. Array Arguments ..
1549  DOUBLE PRECISION aa( nmax*nmax ), ab( 2*nmax*nmax ),
1550  $ alf( nalf ), as( nmax*nmax ), bb( nmax*nmax ),
1551  $ bet( nbet ), bs( nmax*nmax ), c( nmax, nmax ),
1552  $ cc( nmax*nmax ), cs( nmax*nmax ), ct( nmax ),
1553  $ g( nmax ), w( 2*nmax )
1554  INTEGER idim( nidim )
1555 * .. Local Scalars ..
1556  DOUBLE PRECISION alpha, als, beta, bets, err, errmax
1557  INTEGER i, ia, ib, ict, icu, ik, in, j, jc, jj, jjab,
1558  $ k, ks, laa, lbb, lcc, lda, ldas, ldb, ldbs,
1559  $ ldc, ldcs, lj, ma, n, na, nargs, nc, ns
1560  LOGICAL null, reset, same, tran, upper
1561  CHARACTER*1 trans, transs, uplo, uplos
1562  CHARACTER*2 ichu
1563  CHARACTER*3 icht
1564 * .. Local Arrays ..
1565  LOGICAL isame( 13 )
1566 * .. External Functions ..
1567  LOGICAL lde, lderes
1568  EXTERNAL lde, lderes
1569 * .. External Subroutines ..
1570  EXTERNAL dmake, dmmch, dsyr2k
1571 * .. Intrinsic Functions ..
1572  INTRINSIC max
1573 * .. Scalars in Common ..
1574  INTEGER infot, noutc
1575  LOGICAL lerr, ok
1576 * .. Common blocks ..
1577  COMMON /infoc/infot, noutc, ok, lerr
1578 * .. Data statements ..
1579  DATA icht/'NTC'/, ichu/'UL'/
1580 * .. Executable Statements ..
1581 *
1582  nargs = 12
1583  nc = 0
1584  reset = .true.
1585  errmax = zero
1586 *
1587  DO 130 in = 1, nidim
1588  n = idim( in )
1589 * Set LDC to 1 more than minimum value if room.
1590  ldc = n
1591  IF( ldc.LT.nmax )
1592  $ ldc = ldc + 1
1593 * Skip tests if not enough room.
1594  IF( ldc.GT.nmax )
1595  $ GO TO 130
1596  lcc = ldc*n
1597  null = n.LE.0
1598 *
1599  DO 120 ik = 1, nidim
1600  k = idim( ik )
1601 *
1602  DO 110 ict = 1, 3
1603  trans = icht( ict: ict )
1604  tran = trans.EQ.'T'.OR.trans.EQ.'C'
1605  IF( tran )THEN
1606  ma = k
1607  na = n
1608  ELSE
1609  ma = n
1610  na = k
1611  END IF
1612 * Set LDA to 1 more than minimum value if room.
1613  lda = ma
1614  IF( lda.LT.nmax )
1615  $ lda = lda + 1
1616 * Skip tests if not enough room.
1617  IF( lda.GT.nmax )
1618  $ GO TO 110
1619  laa = lda*na
1620 *
1621 * Generate the matrix A.
1622 *
1623  IF( tran )THEN
1624  CALL dmake( 'GE', ' ', ' ', ma, na, ab, 2*nmax, aa,
1625  $ lda, reset, zero )
1626  ELSE
1627  CALL dmake( 'GE', ' ', ' ', ma, na, ab, nmax, aa, lda,
1628  $ reset, zero )
1629  END IF
1630 *
1631 * Generate the matrix B.
1632 *
1633  ldb = lda
1634  lbb = laa
1635  IF( tran )THEN
1636  CALL dmake( 'GE', ' ', ' ', ma, na, ab( k + 1 ),
1637  $ 2*nmax, bb, ldb, reset, zero )
1638  ELSE
1639  CALL dmake( 'GE', ' ', ' ', ma, na, ab( k*nmax + 1 ),
1640  $ nmax, bb, ldb, reset, zero )
1641  END IF
1642 *
1643  DO 100 icu = 1, 2
1644  uplo = ichu( icu: icu )
1645  upper = uplo.EQ.'U'
1646 *
1647  DO 90 ia = 1, nalf
1648  alpha = alf( ia )
1649 *
1650  DO 80 ib = 1, nbet
1651  beta = bet( ib )
1652 *
1653 * Generate the matrix C.
1654 *
1655  CALL dmake( 'SY', uplo, ' ', n, n, c, nmax, cc,
1656  $ ldc, reset, zero )
1657 *
1658  nc = nc + 1
1659 *
1660 * Save every datum before calling the subroutine.
1661 *
1662  uplos = uplo
1663  transs = trans
1664  ns = n
1665  ks = k
1666  als = alpha
1667  DO 10 i = 1, laa
1668  as( i ) = aa( i )
1669  10 CONTINUE
1670  ldas = lda
1671  DO 20 i = 1, lbb
1672  bs( i ) = bb( i )
1673  20 CONTINUE
1674  ldbs = ldb
1675  bets = beta
1676  DO 30 i = 1, lcc
1677  cs( i ) = cc( i )
1678  30 CONTINUE
1679  ldcs = ldc
1680 *
1681 * Call the subroutine.
1682 *
1683  IF( trace )
1684  $ WRITE( ntra, fmt = 9994 )nc, sname, uplo,
1685  $ trans, n, k, alpha, lda, ldb, beta, ldc
1686  IF( rewi )
1687  $ rewind ntra
1688  CALL dsyr2k( uplo, trans, n, k, alpha, aa, lda,
1689  $ bb, ldb, beta, cc, ldc )
1690 *
1691 * Check if error-exit was taken incorrectly.
1692 *
1693  IF( .NOT.ok )THEN
1694  WRITE( nout, fmt = 9993 )
1695  fatal = .true.
1696  GO TO 150
1697  END IF
1698 *
1699 * See what data changed inside subroutines.
1700 *
1701  isame( 1 ) = uplos.EQ.uplo
1702  isame( 2 ) = transs.EQ.trans
1703  isame( 3 ) = ns.EQ.n
1704  isame( 4 ) = ks.EQ.k
1705  isame( 5 ) = als.EQ.alpha
1706  isame( 6 ) = lde( as, aa, laa )
1707  isame( 7 ) = ldas.EQ.lda
1708  isame( 8 ) = lde( bs, bb, lbb )
1709  isame( 9 ) = ldbs.EQ.ldb
1710  isame( 10 ) = bets.EQ.beta
1711  IF( null )THEN
1712  isame( 11 ) = lde( cs, cc, lcc )
1713  ELSE
1714  isame( 11 ) = lderes( 'SY', uplo, n, n, cs,
1715  $ cc, ldc )
1716  END IF
1717  isame( 12 ) = ldcs.EQ.ldc
1718 *
1719 * If data was incorrectly changed, report and
1720 * return.
1721 *
1722  same = .true.
1723  DO 40 i = 1, nargs
1724  same = same.AND.isame( i )
1725  IF( .NOT.isame( i ) )
1726  $ WRITE( nout, fmt = 9998 )i
1727  40 CONTINUE
1728  IF( .NOT.same )THEN
1729  fatal = .true.
1730  GO TO 150
1731  END IF
1732 *
1733  IF( .NOT.null )THEN
1734 *
1735 * Check the result column by column.
1736 *
1737  jjab = 1
1738  jc = 1
1739  DO 70 j = 1, n
1740  IF( upper )THEN
1741  jj = 1
1742  lj = j
1743  ELSE
1744  jj = j
1745  lj = n - j + 1
1746  END IF
1747  IF( tran )THEN
1748  DO 50 i = 1, k
1749  w( i ) = ab( ( j - 1 )*2*nmax + k +
1750  $ i )
1751  w( k + i ) = ab( ( j - 1 )*2*nmax +
1752  $ i )
1753  50 CONTINUE
1754  CALL dmmch( 'T', 'N', lj, 1, 2*k,
1755  $ alpha, ab( jjab ), 2*nmax,
1756  $ w, 2*nmax, beta,
1757  $ c( jj, j ), nmax, ct, g,
1758  $ cc( jc ), ldc, eps, err,
1759  $ fatal, nout, .true. )
1760  ELSE
1761  DO 60 i = 1, k
1762  w( i ) = ab( ( k + i - 1 )*nmax +
1763  $ j )
1764  w( k + i ) = ab( ( i - 1 )*nmax +
1765  $ j )
1766  60 CONTINUE
1767  CALL dmmch( 'N', 'N', lj, 1, 2*k,
1768  $ alpha, ab( jj ), nmax, w,
1769  $ 2*nmax, beta, c( jj, j ),
1770  $ nmax, ct, g, cc( jc ), ldc,
1771  $ eps, err, fatal, nout,
1772  $ .true. )
1773  END IF
1774  IF( upper )THEN
1775  jc = jc + ldc
1776  ELSE
1777  jc = jc + ldc + 1
1778  IF( tran )
1779  $ jjab = jjab + 2*nmax
1780  END IF
1781  errmax = max( errmax, err )
1782 * If got really bad answer, report and
1783 * return.
1784  IF( fatal )
1785  $ GO TO 140
1786  70 CONTINUE
1787  END IF
1788 *
1789  80 CONTINUE
1790 *
1791  90 CONTINUE
1792 *
1793  100 CONTINUE
1794 *
1795  110 CONTINUE
1796 *
1797  120 CONTINUE
1798 *
1799  130 CONTINUE
1800 *
1801 * Report result.
1802 *
1803  IF( errmax.LT.thresh )THEN
1804  WRITE( nout, fmt = 9999 )sname, nc
1805  ELSE
1806  WRITE( nout, fmt = 9997 )sname, nc, errmax
1807  END IF
1808  GO TO 160
1809 *
1810  140 CONTINUE
1811  IF( n.GT.1 )
1812  $ WRITE( nout, fmt = 9995 )j
1813 *
1814  150 CONTINUE
1815  WRITE( nout, fmt = 9996 )sname
1816  WRITE( nout, fmt = 9994 )nc, sname, uplo, trans, n, k, alpha,
1817  $ lda, ldb, beta, ldc
1818 *
1819  160 CONTINUE
1820  RETURN
1821 *
1822  9999 FORMAT( ' ', a6, ' PASSED THE COMPUTATIONAL TESTS (', i6, ' CALL',
1823  $ 'S)' )
1824  9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
1825  $ 'ANGED INCORRECTLY *******' )
1826  9997 FORMAT( ' ', a6, ' COMPLETED THE COMPUTATIONAL TESTS (', i6, ' C',
1827  $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
1828  $ ' - SUSPECT *******' )
1829  9996 FORMAT( ' ******* ', a6, ' FAILED ON CALL NUMBER:' )
1830  9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', i3 )
1831  9994 FORMAT( 1x, i6, ': ', a6, '(', 2( '''', a1, ''',' ), 2( i3, ',' ),
1832  $ f4.1, ', A,', i3, ', B,', i3, ',', f4.1, ', C,', i3, ') ',
1833  $ ' .' )
1834  9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1835  $ '******' )
1836 *
1837 * End of DCHK5.
1838 *
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
dsyr2k
subroutine dsyr2k(UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
DSYR2K
Definition: dsyr2k.f:194
lderes
logical function lderes(TYPE, UPLO, M, N, AA, AS, LDA)
Definition: dblat2.f:2975

Here is the call graph for this function: