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

◆ dchk5()

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 1523 of file dblat3.f.

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