LAPACK  3.9.0
LAPACK: Linear Algebra PACKage

◆ cchk4()

subroutine cchk4 ( character*12  SNAME,
real  EPS,
real  THRESH,
integer  NOUT,
integer  NTRA,
logical  TRACE,
logical  REWI,
logical  FATAL,
integer  NIDIM,
integer, dimension( nidim )  IDIM,
integer  NALF,
complex, dimension( nalf )  ALF,
integer  NBET,
complex, dimension( nbet )  BET,
integer  NMAX,
complex, dimension( nmax, nmax )  A,
complex, dimension( nmax*nmax )  AA,
complex, dimension( nmax*nmax )  AS,
complex, dimension( nmax, nmax )  B,
complex, dimension( nmax*nmax )  BB,
complex, dimension( nmax*nmax )  BS,
complex, dimension( nmax, nmax )  C,
complex, dimension( nmax*nmax )  CC,
complex, dimension( nmax*nmax )  CS,
complex, dimension( nmax )  CT,
real, dimension( nmax )  G,
integer  IORDER 
)

Definition at line 1445 of file c_cblat3.f.

1445 *
1446 * Tests CHERK and CSYRK.
1447 *
1448 * Auxiliary routine for test program for Level 3 Blas.
1449 *
1450 * -- Written on 8-February-1989.
1451 * Jack Dongarra, Argonne National Laboratory.
1452 * Iain Duff, AERE Harwell.
1453 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
1454 * Sven Hammarling, Numerical Algorithms Group Ltd.
1455 *
1456 * .. Parameters ..
1457  COMPLEX ZERO
1458  parameter( zero = ( 0.0, 0.0 ) )
1459  REAL RONE, RZERO
1460  parameter( rone = 1.0, rzero = 0.0 )
1461 * .. Scalar Arguments ..
1462  REAL EPS, THRESH
1463  INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER
1464  LOGICAL FATAL, REWI, TRACE
1465  CHARACTER*12 SNAME
1466 * .. Array Arguments ..
1467  COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
1468  $ AS( NMAX*NMAX ), B( NMAX, NMAX ),
1469  $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
1470  $ C( NMAX, NMAX ), CC( NMAX*NMAX ),
1471  $ CS( NMAX*NMAX ), CT( NMAX )
1472  REAL G( NMAX )
1473  INTEGER IDIM( NIDIM )
1474 * .. Local Scalars ..
1475  COMPLEX ALPHA, ALS, BETA, BETS
1476  REAL ERR, ERRMAX, RALPHA, RALS, RBETA, RBETS
1477  INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, K, KS,
1478  $ LAA, LCC, LDA, LDAS, LDC, LDCS, LJ, MA, N, NA,
1479  $ NARGS, NC, NS
1480  LOGICAL CONJ, NULL, RESET, SAME, TRAN, UPPER
1481  CHARACTER*1 TRANS, TRANSS, TRANST, UPLO, UPLOS
1482  CHARACTER*2 ICHT, ICHU
1483 * .. Local Arrays ..
1484  LOGICAL ISAME( 13 )
1485 * .. External Functions ..
1486  LOGICAL LCE, LCERES
1487  EXTERNAL lce, lceres
1488 * .. External Subroutines ..
1489  EXTERNAL ccherk, cmake, cmmch, ccsyrk
1490 * .. Intrinsic Functions ..
1491  INTRINSIC cmplx, max, real
1492 * .. Scalars in Common ..
1493  INTEGER INFOT, NOUTC
1494  LOGICAL LERR, OK
1495 * .. Common blocks ..
1496  COMMON /infoc/infot, noutc, ok, lerr
1497 * .. Data statements ..
1498  DATA icht/'NC'/, ichu/'UL'/
1499 * .. Executable Statements ..
1500  conj = sname( 8: 9 ).EQ.'he'
1501 *
1502  nargs = 10
1503  nc = 0
1504  reset = .true.
1505  errmax = rzero
1506 *
1507  DO 100 in = 1, nidim
1508  n = idim( in )
1509 * Set LDC to 1 more than minimum value if room.
1510  ldc = n
1511  IF( ldc.LT.nmax )
1512  $ ldc = ldc + 1
1513 * Skip tests if not enough room.
1514  IF( ldc.GT.nmax )
1515  $ GO TO 100
1516  lcc = ldc*n
1517 *
1518  DO 90 ik = 1, nidim
1519  k = idim( ik )
1520 *
1521  DO 80 ict = 1, 2
1522  trans = icht( ict: ict )
1523  tran = trans.EQ.'C'
1524  IF( tran.AND..NOT.conj )
1525  $ trans = 'T'
1526  IF( tran )THEN
1527  ma = k
1528  na = n
1529  ELSE
1530  ma = n
1531  na = k
1532  END IF
1533 * Set LDA to 1 more than minimum value if room.
1534  lda = ma
1535  IF( lda.LT.nmax )
1536  $ lda = lda + 1
1537 * Skip tests if not enough room.
1538  IF( lda.GT.nmax )
1539  $ GO TO 80
1540  laa = lda*na
1541 *
1542 * Generate the matrix A.
1543 *
1544  CALL cmake( 'ge', ' ', ' ', ma, na, a, nmax, aa, lda,
1545  $ reset, zero )
1546 *
1547  DO 70 icu = 1, 2
1548  uplo = ichu( icu: icu )
1549  upper = uplo.EQ.'U'
1550 *
1551  DO 60 ia = 1, nalf
1552  alpha = alf( ia )
1553  IF( conj )THEN
1554  ralpha = real( alpha )
1555  alpha = cmplx( ralpha, rzero )
1556  END IF
1557 *
1558  DO 50 ib = 1, nbet
1559  beta = bet( ib )
1560  IF( conj )THEN
1561  rbeta = real( beta )
1562  beta = cmplx( rbeta, rzero )
1563  END IF
1564  null = n.LE.0
1565  IF( conj )
1566  $ null = null.OR.( ( k.LE.0.OR.ralpha.EQ.
1567  $ rzero ).AND.rbeta.EQ.rone )
1568 *
1569 * Generate the matrix C.
1570 *
1571  CALL cmake( sname( 8: 9 ), uplo, ' ', n, n, c,
1572  $ nmax, cc, ldc, reset, zero )
1573 *
1574  nc = nc + 1
1575 *
1576 * Save every datum before calling the subroutine.
1577 *
1578  uplos = uplo
1579  transs = trans
1580  ns = n
1581  ks = k
1582  IF( conj )THEN
1583  rals = ralpha
1584  ELSE
1585  als = alpha
1586  END IF
1587  DO 10 i = 1, laa
1588  as( i ) = aa( i )
1589  10 CONTINUE
1590  ldas = lda
1591  IF( conj )THEN
1592  rbets = rbeta
1593  ELSE
1594  bets = beta
1595  END IF
1596  DO 20 i = 1, lcc
1597  cs( i ) = cc( i )
1598  20 CONTINUE
1599  ldcs = ldc
1600 *
1601 * Call the subroutine.
1602 *
1603  IF( conj )THEN
1604  IF( trace )
1605  $ CALL cprcn6( ntra, nc, sname, iorder,
1606  $ uplo, trans, n, k, ralpha, lda, rbeta,
1607  $ ldc)
1608  IF( rewi )
1609  $ rewind ntra
1610  CALL ccherk( iorder, uplo, trans, n, k,
1611  $ ralpha, aa, lda, rbeta, cc,
1612  $ ldc )
1613  ELSE
1614  IF( trace )
1615  $ CALL cprcn4( ntra, nc, sname, iorder,
1616  $ uplo, trans, n, k, alpha, lda, beta, ldc)
1617  IF( rewi )
1618  $ rewind ntra
1619  CALL ccsyrk( iorder, uplo, trans, n, k,
1620  $ alpha, aa, lda, beta, cc, ldc )
1621  END IF
1622 *
1623 * Check if error-exit was taken incorrectly.
1624 *
1625  IF( .NOT.ok )THEN
1626  WRITE( nout, fmt = 9992 )
1627  fatal = .true.
1628  GO TO 120
1629  END IF
1630 *
1631 * See what data changed inside subroutines.
1632 *
1633  isame( 1 ) = uplos.EQ.uplo
1634  isame( 2 ) = transs.EQ.trans
1635  isame( 3 ) = ns.EQ.n
1636  isame( 4 ) = ks.EQ.k
1637  IF( conj )THEN
1638  isame( 5 ) = rals.EQ.ralpha
1639  ELSE
1640  isame( 5 ) = als.EQ.alpha
1641  END IF
1642  isame( 6 ) = lce( as, aa, laa )
1643  isame( 7 ) = ldas.EQ.lda
1644  IF( conj )THEN
1645  isame( 8 ) = rbets.EQ.rbeta
1646  ELSE
1647  isame( 8 ) = bets.EQ.beta
1648  END IF
1649  IF( null )THEN
1650  isame( 9 ) = lce( cs, cc, lcc )
1651  ELSE
1652  isame( 9 ) = lceres( sname( 8: 9 ), uplo, n,
1653  $ n, cs, cc, ldc )
1654  END IF
1655  isame( 10 ) = ldcs.EQ.ldc
1656 *
1657 * If data was incorrectly changed, report and
1658 * return.
1659 *
1660  same = .true.
1661  DO 30 i = 1, nargs
1662  same = same.AND.isame( i )
1663  IF( .NOT.isame( i ) )
1664  $ WRITE( nout, fmt = 9998 )i
1665  30 CONTINUE
1666  IF( .NOT.same )THEN
1667  fatal = .true.
1668  GO TO 120
1669  END IF
1670 *
1671  IF( .NOT.null )THEN
1672 *
1673 * Check the result column by column.
1674 *
1675  IF( conj )THEN
1676  transt = 'C'
1677  ELSE
1678  transt = 'T'
1679  END IF
1680  jc = 1
1681  DO 40 j = 1, n
1682  IF( upper )THEN
1683  jj = 1
1684  lj = j
1685  ELSE
1686  jj = j
1687  lj = n - j + 1
1688  END IF
1689  IF( tran )THEN
1690  CALL cmmch( transt, 'N', lj, 1, k,
1691  $ alpha, a( 1, jj ), nmax,
1692  $ a( 1, j ), nmax, beta,
1693  $ c( jj, j ), nmax, ct, g,
1694  $ cc( jc ), ldc, eps, err,
1695  $ fatal, nout, .true. )
1696  ELSE
1697  CALL cmmch( 'N', transt, lj, 1, k,
1698  $ alpha, a( jj, 1 ), nmax,
1699  $ a( j, 1 ), nmax, beta,
1700  $ c( jj, j ), nmax, ct, g,
1701  $ cc( jc ), ldc, eps, err,
1702  $ fatal, nout, .true. )
1703  END IF
1704  IF( upper )THEN
1705  jc = jc + ldc
1706  ELSE
1707  jc = jc + ldc + 1
1708  END IF
1709  errmax = max( errmax, err )
1710 * If got really bad answer, report and
1711 * return.
1712  IF( fatal )
1713  $ GO TO 110
1714  40 CONTINUE
1715  END IF
1716 *
1717  50 CONTINUE
1718 *
1719  60 CONTINUE
1720 *
1721  70 CONTINUE
1722 *
1723  80 CONTINUE
1724 *
1725  90 CONTINUE
1726 *
1727  100 CONTINUE
1728 *
1729 * Report result.
1730 *
1731  IF( errmax.LT.thresh )THEN
1732  IF ( iorder.EQ.0) WRITE( nout, fmt = 10000 )sname, nc
1733  IF ( iorder.EQ.1) WRITE( nout, fmt = 10001 )sname, nc
1734  ELSE
1735  IF ( iorder.EQ.0) WRITE( nout, fmt = 10002 )sname, nc, errmax
1736  IF ( iorder.EQ.1) WRITE( nout, fmt = 10003 )sname, nc, errmax
1737  END IF
1738  GO TO 130
1739 *
1740  110 CONTINUE
1741  IF( n.GT.1 )
1742  $ WRITE( nout, fmt = 9995 )j
1743 *
1744  120 CONTINUE
1745  WRITE( nout, fmt = 9996 )sname
1746  IF( conj )THEN
1747  CALL cprcn6( nout, nc, sname, iorder, uplo, trans, n, k, ralpha,
1748  $ lda, rbeta, ldc)
1749  ELSE
1750  CALL cprcn4( nout, nc, sname, iorder, uplo, trans, n, k, alpha,
1751  $ lda, beta, ldc)
1752  END IF
1753 *
1754  130 CONTINUE
1755  RETURN
1756 *
1757 10003 FORMAT( ' ', a12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
1758  $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1759  $ 'RATIO ', f8.2, ' - SUSPECT *******' )
1760 10002 FORMAT( ' ', a12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
1761  $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1762  $ 'RATIO ', f8.2, ' - SUSPECT *******' )
1763 10001 FORMAT( ' ', a12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
1764  $ ' (', i6, ' CALL', 'S)' )
1765 10000 FORMAT( ' ', a12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
1766  $ ' (', i6, ' CALL', 'S)' )
1767  9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
1768  $ 'ANGED INCORRECTLY *******' )
1769  9996 FORMAT( ' ******* ', a12,' FAILED ON CALL NUMBER:' )
1770  9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', i3 )
1771  9994 FORMAT(1x, i6, ': ', a12,'(', 2( '''', a1, ''',' ), 2( i3, ',' ),
1772  $ f4.1, ', A,', i3, ',', f4.1, ', C,', i3, ') ',
1773  $ ' .' )
1774  9993 FORMAT(1x, i6, ': ', a12,'(', 2( '''', a1, ''',' ), 2( i3, ',' ),
1775  $ '(', f4.1, ',', f4.1, ') , A,', i3, ',(', f4.1, ',', f4.1,
1776  $ '), C,', i3, ') .' )
1777  9992 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1778  $ '******' )
1779 *
1780 * End of CCHK4.
1781 *
Here is the call graph for this function:
lceres
logical function lceres(TYPE, UPLO, M, N, AA, AS, LDA)
Definition: cblat2.f:3072
cmake
subroutine cmake(TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, KU, RESET, TRANSL)
Definition: cblat2.f:2719
cmmch
subroutine cmmch(TRANSA, TRANSB, M, N, KK, ALPHA, A, LDA, B, LDB, BETA, C, LDC, CT, G, CC, LDCC, EPS, ERR, FATAL, NOUT, MV)
Definition: cblat3.f:3056
cprcn6
subroutine cprcn6(NOUT, NC, SNAME, IORDER, UPLO, TRANSA, N, K, ALPHA, LDA, BETA, LDC)
Definition: c_cblat3.f:1820
lce
logical function lce(RI, RJ, LR)
Definition: cblat2.f:3042
cprcn4
subroutine cprcn4(NOUT, NC, SNAME, IORDER, UPLO, TRANSA, N, K, ALPHA, LDA, BETA, LDC)
Definition: c_cblat3.f:1786