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

◆ 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 1441 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*
175710003 FORMAT( ' ', a12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
1758 $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1759 $ 'RATIO ', f8.2, ' - SUSPECT *******' )
176010002 FORMAT( ' ', a12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
1761 $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1762 $ 'RATIO ', f8.2, ' - SUSPECT *******' )
176310001 FORMAT( ' ', a12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
1764 $ ' (', i6, ' CALL', 'S)' )
176510000 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*
cprcn6
subroutine cprcn6(nout, nc, sname, iorder, uplo, transa, n, k, alpha, lda, beta, ldc)
Definition c_cblat3.f:1820
cprcn4
subroutine cprcn4(nout, nc, sname, iorder, uplo, transa, n, k, alpha, lda, beta, ldc)
Definition c_cblat3.f:1786
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:3053
Here is the call graph for this function: