LAPACK 3.12.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches

◆ 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 1563 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*
181010003 FORMAT( ' ', a12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
1811 $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1812 $ 'RATIO ', f8.2, ' - SUSPECT *******' )
181310002 FORMAT( ' ', a12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
1814 $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1815 $ 'RATIO ', f8.2, ' - SUSPECT *******' )
181610001 FORMAT( ' ', a12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
1817 $ ' (', i6, ' CALL', 'S)' )
181810000 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*
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:2854
lde
logical function lde(ri, rj, lr)
Definition dblat2.f:2970
lderes
logical function lderes(type, uplo, m, n, aa, as, lda)
Definition dblat2.f:3000
dmake
subroutine dmake(type, uplo, diag, m, n, a, nmax, aa, lda, kl, ku, reset, transl)
Definition dblat2.f:2678
dger
subroutine dger(m, n, alpha, x, incx, y, incy, a, lda)
DGER
Definition dger.f:130
Here is the call graph for this function: