LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
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 1475 of file sblat2.f.

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

Here is the call graph for this function:

Here is the caller graph for this function: