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

## ◆ cchk4()

 subroutine cchk4 ( character*6 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 )

Definition at line 1516 of file cblat2.f.

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