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

◆ cchk4()

subroutine cchk4 ( character*13 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 1457 of file c_cblat3.f.

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