LAPACK  3.9.0
LAPACK: Linear Algebra PACKage

◆ dchk4()

subroutine dchk4 ( character*12  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,
double precision, dimension( nalf )  ALF,
integer  NINC,
integer, dimension( ninc )  INC,
integer  NMAX,
integer  INCMAX,
double precision, dimension( nmax, nmax )  A,
double precision, dimension( nmax*nmax )  AA,
double precision, dimension( nmax*nmax )  AS,
double precision, dimension( nmax )  X,
double precision, dimension( nmax*incmax )  XX,
double precision, dimension( nmax*incmax )  XS,
double precision, dimension( nmax )  Y,
double precision, dimension( nmax*incmax )  YY,
double precision, dimension( nmax*incmax )  YS,
double precision, dimension( nmax )  YT,
double precision, dimension( nmax )  G,
double precision, dimension( nmax )  Z,
integer  IORDER 
)

Definition at line 1567 of file c_dblat2.f.

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