LAPACK  3.9.0
LAPACK: Linear Algebra PACKage

◆ cchk4()

subroutine cchk4 ( character*12  SNAME,
real  EPS,
real  THRESH,
integer  NOUT,
integer  NTRA,
logical  TRACE,
logical  REWI,
logical  FATAL,
integer  NIDIM,
integer, dimension( nidim )  IDIM,
integer  NALF,
complex, dimension( nalf )  ALF,
integer  NINC,
integer, dimension( ninc )  INC,
integer  NMAX,
integer  INCMAX,
complex, dimension( nmax, nmax )  A,
complex, dimension( nmax*nmax )  AA,
complex, dimension( nmax*nmax )  AS,
complex, dimension( nmax )  X,
complex, dimension( nmax*incmax )  XX,
complex, dimension( nmax*incmax )  XS,
complex, dimension( nmax )  Y,
complex, dimension( nmax*incmax )  YY,
complex, dimension( nmax*incmax )  YS,
complex, dimension( nmax )  YT,
real, dimension( nmax )  G,
complex, dimension( nmax )  Z,
integer  IORDER 
)

Definition at line 1558 of file c_cblat2.f.

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