LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
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 1561 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 *
lzeres
logical function lzeres(TYPE, UPLO, M, N, AA, AS, LDA)
Definition: zblat2.f:3080
zmake
subroutine zmake(TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, KU, RESET, TRANSL)
Definition: zblat2.f:2726
lze
logical function lze(RI, RJ, LR)
Definition: zblat2.f:3050
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:2919

Here is the call graph for this function: