LAPACK  3.10.1
LAPACK: Linear Algebra PACKage

◆ cchk4()

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 1488 of file cblat2.f.

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