LAPACK  3.10.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 1492 of file zblat2.f.

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