LAPACK  3.9.1
LAPACK: Linear Algebra PACKage

◆ schk5()

subroutine schk5 ( 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  NBET,
real, dimension( nbet )  BET,
integer  NMAX,
real, dimension( 2*nmax*nmax )  AB,
real, dimension( nmax*nmax )  AA,
real, dimension( nmax*nmax )  AS,
real, dimension( nmax*nmax )  BB,
real, dimension( nmax*nmax )  BS,
real, dimension( nmax, nmax )  C,
real, dimension( nmax*nmax )  CC,
real, dimension( nmax*nmax )  CS,
real, dimension( nmax )  CT,
real, dimension( nmax )  G,
real, dimension( 2*nmax )  W 
)

Definition at line 1523 of file sblat3.f.

1526 *
1527 * Tests SSYR2K.
1528 *
1529 * Auxiliary routine for test program for Level 3 Blas.
1530 *
1531 * -- Written on 8-February-1989.
1532 * Jack Dongarra, Argonne National Laboratory.
1533 * Iain Duff, AERE Harwell.
1534 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
1535 * Sven Hammarling, Numerical Algorithms Group Ltd.
1536 *
1537 * .. Parameters ..
1538  REAL ZERO
1539  parameter( zero = 0.0 )
1540 * .. Scalar Arguments ..
1541  REAL EPS, THRESH
1542  INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA
1543  LOGICAL FATAL, REWI, TRACE
1544  CHARACTER*6 SNAME
1545 * .. Array Arguments ..
1546  REAL AA( NMAX*NMAX ), AB( 2*NMAX*NMAX ),
1547  $ ALF( NALF ), AS( NMAX*NMAX ), BB( NMAX*NMAX ),
1548  $ BET( NBET ), BS( NMAX*NMAX ), C( NMAX, NMAX ),
1549  $ CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ),
1550  $ G( NMAX ), W( 2*NMAX )
1551  INTEGER IDIM( NIDIM )
1552 * .. Local Scalars ..
1553  REAL ALPHA, ALS, BETA, BETS, ERR, ERRMAX
1554  INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, JJAB,
1555  $ K, KS, LAA, LBB, LCC, LDA, LDAS, LDB, LDBS,
1556  $ LDC, LDCS, LJ, MA, N, NA, NARGS, NC, NS
1557  LOGICAL NULL, RESET, SAME, TRAN, UPPER
1558  CHARACTER*1 TRANS, TRANSS, UPLO, UPLOS
1559  CHARACTER*2 ICHU
1560  CHARACTER*3 ICHT
1561 * .. Local Arrays ..
1562  LOGICAL ISAME( 13 )
1563 * .. External Functions ..
1564  LOGICAL LSE, LSERES
1565  EXTERNAL lse, lseres
1566 * .. External Subroutines ..
1567  EXTERNAL smake, smmch, ssyr2k
1568 * .. Intrinsic Functions ..
1569  INTRINSIC max
1570 * .. Scalars in Common ..
1571  INTEGER INFOT, NOUTC
1572  LOGICAL LERR, OK
1573 * .. Common blocks ..
1574  COMMON /infoc/infot, noutc, ok, lerr
1575 * .. Data statements ..
1576  DATA icht/'NTC'/, ichu/'UL'/
1577 * .. Executable Statements ..
1578 *
1579  nargs = 12
1580  nc = 0
1581  reset = .true.
1582  errmax = zero
1583 *
1584  DO 130 in = 1, nidim
1585  n = idim( in )
1586 * Set LDC to 1 more than minimum value if room.
1587  ldc = n
1588  IF( ldc.LT.nmax )
1589  $ ldc = ldc + 1
1590 * Skip tests if not enough room.
1591  IF( ldc.GT.nmax )
1592  $ GO TO 130
1593  lcc = ldc*n
1594  null = n.LE.0
1595 *
1596  DO 120 ik = 1, nidim
1597  k = idim( ik )
1598 *
1599  DO 110 ict = 1, 3
1600  trans = icht( ict: ict )
1601  tran = trans.EQ.'T'.OR.trans.EQ.'C'
1602  IF( tran )THEN
1603  ma = k
1604  na = n
1605  ELSE
1606  ma = n
1607  na = k
1608  END IF
1609 * Set LDA to 1 more than minimum value if room.
1610  lda = ma
1611  IF( lda.LT.nmax )
1612  $ lda = lda + 1
1613 * Skip tests if not enough room.
1614  IF( lda.GT.nmax )
1615  $ GO TO 110
1616  laa = lda*na
1617 *
1618 * Generate the matrix A.
1619 *
1620  IF( tran )THEN
1621  CALL smake( 'GE', ' ', ' ', ma, na, ab, 2*nmax, aa,
1622  $ lda, reset, zero )
1623  ELSE
1624  CALL smake( 'GE', ' ', ' ', ma, na, ab, nmax, aa, lda,
1625  $ reset, zero )
1626  END IF
1627 *
1628 * Generate the matrix B.
1629 *
1630  ldb = lda
1631  lbb = laa
1632  IF( tran )THEN
1633  CALL smake( 'GE', ' ', ' ', ma, na, ab( k + 1 ),
1634  $ 2*nmax, bb, ldb, reset, zero )
1635  ELSE
1636  CALL smake( 'GE', ' ', ' ', ma, na, ab( k*nmax + 1 ),
1637  $ nmax, bb, ldb, reset, zero )
1638  END IF
1639 *
1640  DO 100 icu = 1, 2
1641  uplo = ichu( icu: icu )
1642  upper = uplo.EQ.'U'
1643 *
1644  DO 90 ia = 1, nalf
1645  alpha = alf( ia )
1646 *
1647  DO 80 ib = 1, nbet
1648  beta = bet( ib )
1649 *
1650 * Generate the matrix C.
1651 *
1652  CALL smake( 'SY', uplo, ' ', n, n, c, nmax, cc,
1653  $ ldc, reset, zero )
1654 *
1655  nc = nc + 1
1656 *
1657 * Save every datum before calling the subroutine.
1658 *
1659  uplos = uplo
1660  transs = trans
1661  ns = n
1662  ks = k
1663  als = alpha
1664  DO 10 i = 1, laa
1665  as( i ) = aa( i )
1666  10 CONTINUE
1667  ldas = lda
1668  DO 20 i = 1, lbb
1669  bs( i ) = bb( i )
1670  20 CONTINUE
1671  ldbs = ldb
1672  bets = beta
1673  DO 30 i = 1, lcc
1674  cs( i ) = cc( i )
1675  30 CONTINUE
1676  ldcs = ldc
1677 *
1678 * Call the subroutine.
1679 *
1680  IF( trace )
1681  $ WRITE( ntra, fmt = 9994 )nc, sname, uplo,
1682  $ trans, n, k, alpha, lda, ldb, beta, ldc
1683  IF( rewi )
1684  $ rewind ntra
1685  CALL ssyr2k( uplo, trans, n, k, alpha, aa, lda,
1686  $ bb, ldb, beta, cc, ldc )
1687 *
1688 * Check if error-exit was taken incorrectly.
1689 *
1690  IF( .NOT.ok )THEN
1691  WRITE( nout, fmt = 9993 )
1692  fatal = .true.
1693  GO TO 150
1694  END IF
1695 *
1696 * See what data changed inside subroutines.
1697 *
1698  isame( 1 ) = uplos.EQ.uplo
1699  isame( 2 ) = transs.EQ.trans
1700  isame( 3 ) = ns.EQ.n
1701  isame( 4 ) = ks.EQ.k
1702  isame( 5 ) = als.EQ.alpha
1703  isame( 6 ) = lse( as, aa, laa )
1704  isame( 7 ) = ldas.EQ.lda
1705  isame( 8 ) = lse( bs, bb, lbb )
1706  isame( 9 ) = ldbs.EQ.ldb
1707  isame( 10 ) = bets.EQ.beta
1708  IF( null )THEN
1709  isame( 11 ) = lse( cs, cc, lcc )
1710  ELSE
1711  isame( 11 ) = lseres( 'SY', uplo, n, n, cs,
1712  $ cc, ldc )
1713  END IF
1714  isame( 12 ) = ldcs.EQ.ldc
1715 *
1716 * If data was incorrectly changed, report and
1717 * return.
1718 *
1719  same = .true.
1720  DO 40 i = 1, nargs
1721  same = same.AND.isame( i )
1722  IF( .NOT.isame( i ) )
1723  $ WRITE( nout, fmt = 9998 )i
1724  40 CONTINUE
1725  IF( .NOT.same )THEN
1726  fatal = .true.
1727  GO TO 150
1728  END IF
1729 *
1730  IF( .NOT.null )THEN
1731 *
1732 * Check the result column by column.
1733 *
1734  jjab = 1
1735  jc = 1
1736  DO 70 j = 1, n
1737  IF( upper )THEN
1738  jj = 1
1739  lj = j
1740  ELSE
1741  jj = j
1742  lj = n - j + 1
1743  END IF
1744  IF( tran )THEN
1745  DO 50 i = 1, k
1746  w( i ) = ab( ( j - 1 )*2*nmax + k +
1747  $ i )
1748  w( k + i ) = ab( ( j - 1 )*2*nmax +
1749  $ i )
1750  50 CONTINUE
1751  CALL smmch( 'T', 'N', lj, 1, 2*k,
1752  $ alpha, ab( jjab ), 2*nmax,
1753  $ w, 2*nmax, beta,
1754  $ c( jj, j ), nmax, ct, g,
1755  $ cc( jc ), ldc, eps, err,
1756  $ fatal, nout, .true. )
1757  ELSE
1758  DO 60 i = 1, k
1759  w( i ) = ab( ( k + i - 1 )*nmax +
1760  $ j )
1761  w( k + i ) = ab( ( i - 1 )*nmax +
1762  $ j )
1763  60 CONTINUE
1764  CALL smmch( 'N', 'N', lj, 1, 2*k,
1765  $ alpha, ab( jj ), nmax, w,
1766  $ 2*nmax, beta, c( jj, j ),
1767  $ nmax, ct, g, cc( jc ), ldc,
1768  $ eps, err, fatal, nout,
1769  $ .true. )
1770  END IF
1771  IF( upper )THEN
1772  jc = jc + ldc
1773  ELSE
1774  jc = jc + ldc + 1
1775  IF( tran )
1776  $ jjab = jjab + 2*nmax
1777  END IF
1778  errmax = max( errmax, err )
1779 * If got really bad answer, report and
1780 * return.
1781  IF( fatal )
1782  $ GO TO 140
1783  70 CONTINUE
1784  END IF
1785 *
1786  80 CONTINUE
1787 *
1788  90 CONTINUE
1789 *
1790  100 CONTINUE
1791 *
1792  110 CONTINUE
1793 *
1794  120 CONTINUE
1795 *
1796  130 CONTINUE
1797 *
1798 * Report result.
1799 *
1800  IF( errmax.LT.thresh )THEN
1801  WRITE( nout, fmt = 9999 )sname, nc
1802  ELSE
1803  WRITE( nout, fmt = 9997 )sname, nc, errmax
1804  END IF
1805  GO TO 160
1806 *
1807  140 CONTINUE
1808  IF( n.GT.1 )
1809  $ WRITE( nout, fmt = 9995 )j
1810 *
1811  150 CONTINUE
1812  WRITE( nout, fmt = 9996 )sname
1813  WRITE( nout, fmt = 9994 )nc, sname, uplo, trans, n, k, alpha,
1814  $ lda, ldb, beta, ldc
1815 *
1816  160 CONTINUE
1817  RETURN
1818 *
1819  9999 FORMAT( ' ', a6, ' PASSED THE COMPUTATIONAL TESTS (', i6, ' CALL',
1820  $ 'S)' )
1821  9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
1822  $ 'ANGED INCORRECTLY *******' )
1823  9997 FORMAT( ' ', a6, ' COMPLETED THE COMPUTATIONAL TESTS (', i6, ' C',
1824  $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
1825  $ ' - SUSPECT *******' )
1826  9996 FORMAT( ' ******* ', a6, ' FAILED ON CALL NUMBER:' )
1827  9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', i3 )
1828  9994 FORMAT( 1x, i6, ': ', a6, '(', 2( '''', a1, ''',' ), 2( i3, ',' ),
1829  $ f4.1, ', A,', i3, ', B,', i3, ',', f4.1, ', C,', i3, ') ',
1830  $ ' .' )
1831  9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1832  $ '******' )
1833 *
1834 * End of SCHK5.
1835 *
ssyr2k
subroutine ssyr2k(UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
SSYR2K
Definition: ssyr2k.f:192
lse
logical function lse(RI, RJ, LR)
Definition: sblat2.f:2942
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
smmch
subroutine smmch(TRANSA, TRANSB, M, N, KK, ALPHA, A, LDA, B, LDB, BETA, C, LDC, CT, G, CC, LDCC, EPS, ERR, FATAL, NOUT, MV)
Definition: sblat3.f:2508
Here is the call graph for this function: