LAPACK  3.9.0
LAPACK: Linear Algebra PACKage

◆ 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 1499 of file zblat2.f.

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