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

◆ zchk4()

subroutine zchk4 ( character*12  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,
complex*16, dimension( nalf )  alf,
integer  ninc,
integer, dimension( ninc )  inc,
integer  nmax,
integer  incmax,
complex*16, dimension( nmax, nmax )  a,
complex*16, dimension( nmax*nmax )  aa,
complex*16, dimension( nmax*nmax )  as,
complex*16, dimension( nmax )  x,
complex*16, dimension( nmax*incmax )  xx,
complex*16, dimension( nmax*incmax )  xs,
complex*16, dimension( nmax )  y,
complex*16, dimension( nmax*incmax )  yy,
complex*16, dimension( nmax*incmax )  ys,
complex*16, dimension( nmax )  yt,
double precision, dimension( nmax )  g,
complex*16, dimension( nmax )  z,
integer  iorder 
)

Definition at line 1557 of file c_zblat2.f.

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