1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
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
1478 DOUBLE PRECISION EPS, THRESH
1479 INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER
1480 LOGICAL FATAL, REWI, TRACE
1481 CHARACTER*13 SNAME
1482
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
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
1500 LOGICAL ISAME( 13 )
1501
1502 LOGICAL LZE, LZERES
1504
1506
1507 INTRINSIC dcmplx, max, dble
1508
1509 INTEGER INFOT, NOUTC
1510 LOGICAL LERR, OK
1511
1512 COMMON /infoc/infot, noutc, ok, lerr
1513
1514 DATA icht/'NC'/, ichu/'UL'/
1515
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
1526 ldc = n
1527 IF( ldc.LT.nmax )
1528 $ ldc = ldc + 1
1529
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
1550 lda = ma
1551 IF( lda.LT.nmax )
1552 $ lda = lda + 1
1553
1554 IF( lda.GT.nmax )
1555 $ GO TO 80
1556 laa = lda*na
1557
1558
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
1586
1587 CALL zmake( sname( 8: 9 ), uplo,
' ', n, n, c,
1588 $ nmax, cc, ldc, reset, zero )
1589
1590 nc = nc + 1
1591
1592
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
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
1640
1641 IF( .NOT.ok )THEN
1642 WRITE( nout, fmt = 9992 )
1643 fatal = .true.
1644 GO TO 120
1645 END IF
1646
1647
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
1674
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
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
1727
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
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
1797
subroutine zprcn6(nout, nc, sname, iorder, uplo, transa, n, k, alpha, lda, beta, ldc)
subroutine zprcn4(nout, nc, sname, iorder, uplo, transa, n, k, alpha, lda, beta, ldc)
logical function lze(ri, rj, lr)
logical function lzeres(type, uplo, m, n, aa, as, lda)
subroutine zmake(type, uplo, diag, m, n, a, nmax, aa, lda, kl, ku, reset, transl)
subroutine zmmch(transa, transb, m, n, kk, alpha, a, lda, b, ldb, beta, c, ldc, ct, g, cc, ldcc, eps, err, fatal, nout, mv)