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

◆ dchk4()

subroutine dchk4 ( character*6  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 
)

Definition at line 1496 of file dblat2.f.

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