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

◆ zchk4()

subroutine zchk4 ( 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,
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 
)

Definition at line 1520 of file zblat2.f.

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