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

◆ zchk4()

subroutine zchk4 ( character*13 sname,
double precision eps,
double precision thresh,
integer nout,
integer ntra,
logical trace,
logical rewi,
logical fatal,
integer nidim,
integer, dimension( nidim ) idim,
integer nalf,
complex*16, dimension( nalf ) alf,
integer nbet,
complex*16, dimension( nbet ) bet,
integer nmax,
complex*16, dimension( nmax, nmax ) a,
complex*16, dimension( nmax*nmax ) aa,
complex*16, dimension( nmax*nmax ) as,
complex*16, dimension( nmax, nmax ) b,
complex*16, dimension( nmax*nmax ) bb,
complex*16, dimension( nmax*nmax ) bs,
complex*16, dimension( nmax, nmax ) c,
complex*16, dimension( nmax*nmax ) cc,
complex*16, dimension( nmax*nmax ) cs,
complex*16, dimension( nmax ) ct,
double precision, dimension( nmax ) g,
integer iorder )

Definition at line 1457 of file c_zblat3.f.

1461*
1462* Tests ZHERK and ZSYRK.
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*16 ZERO
1474 parameter( zero = ( 0.0d0, 0.0d0 ) )
1475 DOUBLE PRECISION RONE, RZERO
1476 parameter( rone = 1.0d0, rzero = 0.0d0 )
1477* .. Scalar Arguments ..
1478 DOUBLE PRECISION 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*16 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 DOUBLE PRECISION G( NMAX )
1489 INTEGER IDIM( NIDIM )
1490* .. Local Scalars ..
1491 COMPLEX*16 ALPHA, ALS, BETA, BETS
1492 DOUBLE PRECISION 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 LZE, LZERES
1503 EXTERNAL lze, lzeres
1504* .. External Subroutines ..
1505 EXTERNAL czherk, zmake, zmmch, czsyrk
1506* .. Intrinsic Functions ..
1507 INTRINSIC dcmplx, max, dble
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 zmake( '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 = dble( alpha )
1571 alpha = dcmplx( ralpha, rzero )
1572 END IF
1573*
1574 DO 50 ib = 1, nbet
1575 beta = bet( ib )
1576 IF( conj )THEN
1577 rbeta = dble( beta )
1578 beta = dcmplx( 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 zmake( 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 zprcn6( ntra, nc, sname, iorder,
1622 $ uplo, trans, n, k, ralpha, lda, rbeta,
1623 $ ldc)
1624 IF( rewi )
1625 $ rewind ntra
1626 CALL czherk( iorder, uplo, trans, n, k,
1627 $ ralpha, aa, lda, rbeta, cc,
1628 $ ldc )
1629 ELSE
1630 IF( trace )
1631 $ CALL zprcn4( ntra, nc, sname, iorder,
1632 $ uplo, trans, n, k, alpha, lda, beta, ldc)
1633 IF( rewi )
1634 $ rewind ntra
1635 CALL czsyrk( 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 ) = lze( 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 ) = lze( cs, cc, lcc )
1667 ELSE
1668 isame( 9 ) = lzeres( 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 zmmch( 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 zmmch( '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 zprcn6( nout, nc, sname, iorder, uplo, trans, n, k, ralpha,
1764 $ lda, rbeta, ldc)
1765 ELSE
1766 CALL zprcn4( 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*
zprcn6
subroutine zprcn6(nout, nc, sname, iorder, uplo, transa, n, k, alpha, lda, beta, ldc)
Definition c_zblat3.f:1836
zprcn4
subroutine zprcn4(nout, nc, sname, iorder, uplo, transa, n, k, alpha, lda, beta, ldc)
Definition c_zblat3.f:1802
lze
logical function lze(ri, rj, lr)
Definition zblat2.f:3075
lzeres
logical function lzeres(type, uplo, m, n, aa, as, lda)
Definition zblat2.f:3105
zmake
subroutine zmake(type, uplo, diag, m, n, a, nmax, aa, lda, kl, ku, reset, transl)
Definition zblat2.f:2751
zmmch
subroutine zmmch(transa, transb, m, n, kk, alpha, a, lda, b, ldb, beta, c, ldc, ct, g, cc, ldcc, eps, err, fatal, nout, mv)
Definition zblat3.f:3266
Here is the call graph for this function: