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

◆ zchk4()

subroutine zchk4 ( character*12  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 1442 of file c_zblat3.f.

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