LAPACK  3.9.1
LAPACK: Linear Algebra PACKage

◆ schk4()

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

Definition at line 1468 of file sblat2.f.

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