LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
subroutine cchk4 ( character*6  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 
)

Definition at line 1495 of file cblat2.f.

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

Here is the call graph for this function:

Here is the caller graph for this function: