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

◆ cchk4()

subroutine cchk4 ( character*12 sname,
real eps,
real thresh,
integer nout,
integer ntra,
logical trace,
logical rewi,
logical fatal,
integer nidim,
integer, dimension( nidim ) idim,
integer nalf,
complex, dimension( nalf ) alf,
integer ninc,
integer, dimension( ninc ) inc,
integer nmax,
integer incmax,
complex, dimension( nmax, nmax ) a,
complex, dimension( nmax*nmax ) aa,
complex, dimension( nmax*nmax ) as,
complex, dimension( nmax ) x,
complex, dimension( nmax*incmax ) xx,
complex, dimension( nmax*incmax ) xs,
complex, dimension( nmax ) y,
complex, dimension( nmax*incmax ) yy,
complex, dimension( nmax*incmax ) ys,
complex, dimension( nmax ) yt,
real, dimension( nmax ) g,
complex, dimension( nmax ) z,
integer iorder )

Definition at line 1554 of file c_cblat2.f.

1558*
1559* Tests CGERC and CGERU.
1560*
1561* Auxiliary routine for test program for Level 2 Blas.
1562*
1563* -- Written on 10-August-1987.
1564* Richard Hanson, Sandia National Labs.
1565* Jeremy Du Croz, NAG Central Office.
1566*
1567* .. Parameters ..
1568 COMPLEX ZERO, HALF, ONE
1569 parameter( zero = ( 0.0, 0.0 ), half = ( 0.5, 0.0 ),
1570 $ one = ( 1.0, 0.0 ) )
1571 REAL RZERO
1572 parameter( rzero = 0.0 )
1573* .. Scalar Arguments ..
1574 REAL EPS, THRESH
1575 INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA,
1576 $ IORDER
1577 LOGICAL FATAL, REWI, TRACE
1578 CHARACTER*12 SNAME
1579* .. Array Arguments ..
1580 COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
1581 $ AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ),
1582 $ XX( NMAX*INCMAX ), Y( NMAX ),
1583 $ YS( NMAX*INCMAX ), YT( NMAX ),
1584 $ YY( NMAX*INCMAX ), Z( NMAX )
1585 REAL G( NMAX )
1586 INTEGER IDIM( NIDIM ), INC( NINC )
1587* .. Local Scalars ..
1588 COMPLEX ALPHA, ALS, TRANSL
1589 REAL ERR, ERRMAX
1590 INTEGER I, IA, IM, IN, INCX, INCXS, INCY, INCYS, IX,
1591 $ IY, J, LAA, LDA, LDAS, LX, LY, M, MS, N, NARGS,
1592 $ NC, ND, NS
1593 LOGICAL CONJ, NULL, RESET, SAME
1594* .. Local Arrays ..
1595 COMPLEX W( 1 )
1596 LOGICAL ISAME( 13 )
1597* .. External Functions ..
1598 LOGICAL LCE, LCERES
1599 EXTERNAL lce, lceres
1600* .. External Subroutines ..
1601 EXTERNAL ccgerc, ccgeru, cmake, cmvch
1602* .. Intrinsic Functions ..
1603 INTRINSIC abs, conjg, max, min
1604* .. Scalars in Common ..
1605 INTEGER INFOT, NOUTC
1606 LOGICAL OK
1607* .. Common blocks ..
1608 COMMON /infoc/infot, noutc, ok
1609* .. Executable Statements ..
1610 conj = sname( 11: 11 ).EQ.'c'
1611* Define the number of arguments.
1612 nargs = 9
1613*
1614 nc = 0
1615 reset = .true.
1616 errmax = rzero
1617*
1618 DO 120 in = 1, nidim
1619 n = idim( in )
1620 nd = n/2 + 1
1621*
1622 DO 110 im = 1, 2
1623 IF( im.EQ.1 )
1624 $ m = max( n - nd, 0 )
1625 IF( im.EQ.2 )
1626 $ m = min( n + nd, nmax )
1627*
1628* Set LDA to 1 more than minimum value if room.
1629 lda = m
1630 IF( lda.LT.nmax )
1631 $ lda = lda + 1
1632* Skip tests if not enough room.
1633 IF( lda.GT.nmax )
1634 $ GO TO 110
1635 laa = lda*n
1636 null = n.LE.0.OR.m.LE.0
1637*
1638 DO 100 ix = 1, ninc
1639 incx = inc( ix )
1640 lx = abs( incx )*m
1641*
1642* Generate the vector X.
1643*
1644 transl = half
1645 CALL cmake( 'ge', ' ', ' ', 1, m, x, 1, xx, abs( incx ),
1646 $ 0, m - 1, reset, transl )
1647 IF( m.GT.1 )THEN
1648 x( m/2 ) = zero
1649 xx( 1 + abs( incx )*( m/2 - 1 ) ) = zero
1650 END IF
1651*
1652 DO 90 iy = 1, ninc
1653 incy = inc( iy )
1654 ly = abs( incy )*n
1655*
1656* Generate the vector Y.
1657*
1658 transl = zero
1659 CALL cmake( 'ge', ' ', ' ', 1, n, y, 1, yy,
1660 $ abs( incy ), 0, n - 1, reset, transl )
1661 IF( n.GT.1 )THEN
1662 y( n/2 ) = zero
1663 yy( 1 + abs( incy )*( n/2 - 1 ) ) = zero
1664 END IF
1665*
1666 DO 80 ia = 1, nalf
1667 alpha = alf( ia )
1668*
1669* Generate the matrix A.
1670*
1671 transl = zero
1672 CALL cmake(sname( 8: 9 ), ' ', ' ', m, n, a, nmax,
1673 $ aa, lda, m - 1, n - 1, reset, transl )
1674*
1675 nc = nc + 1
1676*
1677* Save every datum before calling the subroutine.
1678*
1679 ms = m
1680 ns = n
1681 als = alpha
1682 DO 10 i = 1, laa
1683 as( i ) = aa( i )
1684 10 CONTINUE
1685 ldas = lda
1686 DO 20 i = 1, lx
1687 xs( i ) = xx( i )
1688 20 CONTINUE
1689 incxs = incx
1690 DO 30 i = 1, ly
1691 ys( i ) = yy( i )
1692 30 CONTINUE
1693 incys = incy
1694*
1695* Call the subroutine.
1696*
1697 IF( trace )
1698 $ WRITE( ntra, fmt = 9994 )nc, sname, m, n,
1699 $ alpha, incx, incy, lda
1700 IF( conj )THEN
1701 IF( rewi )
1702 $ rewind ntra
1703 CALL ccgerc( iorder, m, n, alpha, xx, incx,
1704 $ yy, incy, aa, lda )
1705 ELSE
1706 IF( rewi )
1707 $ rewind ntra
1708 CALL ccgeru( iorder, m, n, alpha, xx, incx,
1709 $ yy, incy, aa, lda )
1710 END IF
1711*
1712* Check if error-exit was taken incorrectly.
1713*
1714 IF( .NOT.ok )THEN
1715 WRITE( nout, fmt = 9993 )
1716 fatal = .true.
1717 GO TO 140
1718 END IF
1719*
1720* See what data changed inside subroutine.
1721*
1722 isame( 1 ) = ms.EQ.m
1723 isame( 2 ) = ns.EQ.n
1724 isame( 3 ) = als.EQ.alpha
1725 isame( 4 ) = lce( xs, xx, lx )
1726 isame( 5 ) = incxs.EQ.incx
1727 isame( 6 ) = lce( ys, yy, ly )
1728 isame( 7 ) = incys.EQ.incy
1729 IF( null )THEN
1730 isame( 8 ) = lce( as, aa, laa )
1731 ELSE
1732 isame( 8 ) = lceres( 'ge', ' ', m, n, as, aa,
1733 $ lda )
1734 END IF
1735 isame( 9 ) = ldas.EQ.lda
1736*
1737* If data was incorrectly changed, report and return.
1738*
1739 same = .true.
1740 DO 40 i = 1, nargs
1741 same = same.AND.isame( i )
1742 IF( .NOT.isame( i ) )
1743 $ WRITE( nout, fmt = 9998 )i
1744 40 CONTINUE
1745 IF( .NOT.same )THEN
1746 fatal = .true.
1747 GO TO 140
1748 END IF
1749*
1750 IF( .NOT.null )THEN
1751*
1752* Check the result column by column.
1753*
1754 IF( incx.GT.0 )THEN
1755 DO 50 i = 1, m
1756 z( i ) = x( i )
1757 50 CONTINUE
1758 ELSE
1759 DO 60 i = 1, m
1760 z( i ) = x( m - i + 1 )
1761 60 CONTINUE
1762 END IF
1763 DO 70 j = 1, n
1764 IF( incy.GT.0 )THEN
1765 w( 1 ) = y( j )
1766 ELSE
1767 w( 1 ) = y( n - j + 1 )
1768 END IF
1769 IF( conj )
1770 $ w( 1 ) = conjg( w( 1 ) )
1771 CALL cmvch( 'N', m, 1, alpha, z, nmax, w, 1,
1772 $ one, a( 1, j ), 1, yt, g,
1773 $ aa( 1 + ( j - 1 )*lda ), eps,
1774 $ err, fatal, nout, .true. )
1775 errmax = max( errmax, err )
1776* If got really bad answer, report and return.
1777 IF( fatal )
1778 $ GO TO 130
1779 70 CONTINUE
1780 ELSE
1781* Avoid repeating tests with M.le.0 or N.le.0.
1782 GO TO 110
1783 END IF
1784*
1785 80 CONTINUE
1786*
1787 90 CONTINUE
1788*
1789 100 CONTINUE
1790*
1791 110 CONTINUE
1792*
1793 120 CONTINUE
1794*
1795* Report result.
1796*
1797 IF( errmax.LT.thresh )THEN
1798 WRITE( nout, fmt = 9999 )sname, nc
1799 ELSE
1800 WRITE( nout, fmt = 9997 )sname, nc, errmax
1801 END IF
1802 GO TO 150
1803*
1804 130 CONTINUE
1805 WRITE( nout, fmt = 9995 )j
1806*
1807 140 CONTINUE
1808 WRITE( nout, fmt = 9996 )sname
1809 WRITE( nout, fmt = 9994 )nc, sname, m, n, alpha, incx, incy, lda
1810*
1811 150 CONTINUE
1812 RETURN
1813*
1814 9999 FORMAT(' ',a12, ' PASSED THE COMPUTATIONAL TESTS (', i6, ' CALL',
1815 $ 'S)' )
1816 9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
1817 $ 'ANGED INCORRECTLY *******' )
1818 9997 FORMAT(' ',a12, ' COMPLETED THE COMPUTATIONAL TESTS (', i6, ' C',
1819 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
1820 $ ' - SUSPECT *******' )
1821 9996 FORMAT( ' ******* ',a12, ' FAILED ON CALL NUMBER:' )
1822 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', i3 )
1823 9994 FORMAT(1x, i6, ': ',a12, '(', 2( i3, ',' ), '(', f4.1, ',', f4.1,
1824 $ '), X,', i2, ', Y,', i2, ', A,', i3, ') .' )
1825 9993 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1826 $ '******' )
1827*
1828* End of CCHK4.
1829*
cmake
subroutine cmake(type, uplo, diag, m, n, a, nmax, aa, lda, kl, ku, reset, transl)
Definition cblat2.f:2744
lceres
logical function lceres(type, uplo, m, n, aa, as, lda)
Definition cblat2.f:3097
cmvch
subroutine cmvch(trans, m, n, alpha, a, nmax, x, incx, beta, y, incy, yt, g, yy, eps, err, fatal, nout, mv)
Definition cblat2.f:2936
lce
logical function lce(ri, rj, lr)
Definition cblat2.f:3067
Here is the call graph for this function: