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

◆ dchk5()

subroutine dchk5 ( character*7 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 1530 of file dblat3.f.

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