LAPACK  3.9.0
LAPACK: Linear Algebra PACKage

◆ 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 1446 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 *
1758 10003 FORMAT( ' ', a12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
1759  $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1760  $ 'RATIO ', f8.2, ' - SUSPECT *******' )
1761 10002 FORMAT( ' ', a12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
1762  $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1763  $ 'RATIO ', f8.2, ' - SUSPECT *******' )
1764 10001 FORMAT( ' ', a12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
1765  $ ' (', i6, ' CALL', 'S)' )
1766 10000 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 *
Here is the call graph for this function:
zmake
subroutine zmake(TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, KU, RESET, TRANSL)
Definition: zblat2.f:2726
lzeres
logical function lzeres(TYPE, UPLO, M, N, AA, AS, LDA)
Definition: zblat2.f:3080
zprcn4
subroutine zprcn4(NOUT, NC, SNAME, IORDER, UPLO, TRANSA, N, K, ALPHA, LDA, BETA, LDC)
Definition: c_zblat3.f:1787
zprcn6
subroutine zprcn6(NOUT, NC, SNAME, IORDER, UPLO, TRANSA, N, K, ALPHA, LDA, BETA, LDC)
Definition: c_zblat3.f:1821
lze
logical function lze(RI, RJ, LR)
Definition: zblat2.f:3050
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:3064