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

◆ dchk4()

subroutine dchk4 ( 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,
double precision, dimension( nalf ) alf,
integer nbet,
double precision, dimension( nbet ) bet,
integer nmax,
double precision, dimension( nmax, nmax ) a,
double precision, dimension( nmax*nmax ) aa,
double precision, dimension( nmax*nmax ) as,
double precision, dimension( nmax, nmax ) b,
double precision, dimension( nmax*nmax ) bb,
double precision, dimension( nmax*nmax ) bs,
double precision, dimension( nmax, nmax ) c,
double precision, dimension( nmax*nmax ) cc,
double precision, dimension( nmax*nmax ) cs,
double precision, dimension( nmax ) ct,
double precision, dimension( nmax ) g,
integer iorder )

Definition at line 1426 of file c_dblat3.f.

1429*
1430* Tests DSYRK.
1431*
1432* Auxiliary routine for test program for Level 3 Blas.
1433*
1434* -- Written on 8-February-1989.
1435* Jack Dongarra, Argonne National Laboratory.
1436* Iain Duff, AERE Harwell.
1437* Jeremy Du Croz, Numerical Algorithms Group Ltd.
1438* Sven Hammarling, Numerical Algorithms Group Ltd.
1439*
1440* .. Parameters ..
1441 DOUBLE PRECISION ZERO
1442 parameter( zero = 0.0d0 )
1443* .. Scalar Arguments ..
1444 DOUBLE PRECISION EPS, THRESH
1445 INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER
1446 LOGICAL FATAL, REWI, TRACE
1447 CHARACTER*13 SNAME
1448* .. Array Arguments ..
1449 DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
1450 $ AS( NMAX*NMAX ), B( NMAX, NMAX ),
1451 $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
1452 $ C( NMAX, NMAX ), CC( NMAX*NMAX ),
1453 $ CS( NMAX*NMAX ), CT( NMAX ), G( NMAX )
1454 INTEGER IDIM( NIDIM )
1455* .. Local Scalars ..
1456 DOUBLE PRECISION ALPHA, ALS, BETA, BETS, ERR, ERRMAX
1457 INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, K, KS,
1458 $ LAA, LCC, LDA, LDAS, LDC, LDCS, LJ, MA, N, NA,
1459 $ NARGS, NC, NS
1460 LOGICAL NULL, RESET, SAME, TRAN, UPPER
1461 CHARACTER*1 TRANS, TRANSS, UPLO, UPLOS
1462 CHARACTER*2 ICHU
1463 CHARACTER*3 ICHT
1464* .. Local Arrays ..
1465 LOGICAL ISAME( 13 )
1466* .. External Functions ..
1467 LOGICAL LDE, LDERES
1468 EXTERNAL lde, lderes
1469* .. External Subroutines ..
1470 EXTERNAL dmake, dmmch, cdsyrk
1471* .. Intrinsic Functions ..
1472 INTRINSIC max
1473* .. Scalars in Common ..
1474 INTEGER INFOT, NOUTC
1475 LOGICAL OK
1476* .. Common blocks ..
1477 COMMON /infoc/infot, noutc, ok
1478* .. Data statements ..
1479 DATA icht/'NTC'/, ichu/'UL'/
1480* .. Executable Statements ..
1481*
1482 nargs = 10
1483 nc = 0
1484 reset = .true.
1485 errmax = zero
1486*
1487 DO 100 in = 1, nidim
1488 n = idim( in )
1489* Set LDC to 1 more than minimum value if room.
1490 ldc = n
1491 IF( ldc.LT.nmax )
1492 $ ldc = ldc + 1
1493* Skip tests if not enough room.
1494 IF( ldc.GT.nmax )
1495 $ GO TO 100
1496 lcc = ldc*n
1497 null = n.LE.0
1498*
1499 DO 90 ik = 1, nidim
1500 k = idim( ik )
1501*
1502 DO 80 ict = 1, 3
1503 trans = icht( ict: ict )
1504 tran = trans.EQ.'T'.OR.trans.EQ.'C'
1505 IF( tran )THEN
1506 ma = k
1507 na = n
1508 ELSE
1509 ma = n
1510 na = k
1511 END IF
1512* Set LDA to 1 more than minimum value if room.
1513 lda = ma
1514 IF( lda.LT.nmax )
1515 $ lda = lda + 1
1516* Skip tests if not enough room.
1517 IF( lda.GT.nmax )
1518 $ GO TO 80
1519 laa = lda*na
1520*
1521* Generate the matrix A.
1522*
1523 CALL dmake( 'GE', ' ', ' ', ma, na, a, nmax, aa, lda,
1524 $ reset, zero )
1525*
1526 DO 70 icu = 1, 2
1527 uplo = ichu( icu: icu )
1528 upper = uplo.EQ.'U'
1529*
1530 DO 60 ia = 1, nalf
1531 alpha = alf( ia )
1532*
1533 DO 50 ib = 1, nbet
1534 beta = bet( ib )
1535*
1536* Generate the matrix C.
1537*
1538 CALL dmake( 'SY', uplo, ' ', n, n, c, nmax, cc,
1539 $ ldc, reset, zero )
1540*
1541 nc = nc + 1
1542*
1543* Save every datum before calling the subroutine.
1544*
1545 uplos = uplo
1546 transs = trans
1547 ns = n
1548 ks = k
1549 als = alpha
1550 DO 10 i = 1, laa
1551 as( i ) = aa( i )
1552 10 CONTINUE
1553 ldas = lda
1554 bets = beta
1555 DO 20 i = 1, lcc
1556 cs( i ) = cc( i )
1557 20 CONTINUE
1558 ldcs = ldc
1559*
1560* Call the subroutine.
1561*
1562 IF( trace )
1563 $ CALL dprcn4( ntra, nc, sname, iorder, uplo,
1564 $ trans, n, k, alpha, lda, beta, ldc)
1565 IF( rewi )
1566 $ rewind ntra
1567 CALL cdsyrk( iorder, uplo, trans, n, k, alpha,
1568 $ aa, lda, beta, cc, ldc )
1569*
1570* Check if error-exit was taken incorrectly.
1571*
1572 IF( .NOT.ok )THEN
1573 WRITE( nout, fmt = 9993 )
1574 fatal = .true.
1575 GO TO 120
1576 END IF
1577*
1578* See what data changed inside subroutines.
1579*
1580 isame( 1 ) = uplos.EQ.uplo
1581 isame( 2 ) = transs.EQ.trans
1582 isame( 3 ) = ns.EQ.n
1583 isame( 4 ) = ks.EQ.k
1584 isame( 5 ) = als.EQ.alpha
1585 isame( 6 ) = lde( as, aa, laa )
1586 isame( 7 ) = ldas.EQ.lda
1587 isame( 8 ) = bets.EQ.beta
1588 IF( null )THEN
1589 isame( 9 ) = lde( cs, cc, lcc )
1590 ELSE
1591 isame( 9 ) = lderes( 'SY', uplo, n, n, cs,
1592 $ cc, ldc )
1593 END IF
1594 isame( 10 ) = ldcs.EQ.ldc
1595*
1596* If data was incorrectly changed, report and
1597* return.
1598*
1599 same = .true.
1600 DO 30 i = 1, nargs
1601 same = same.AND.isame( i )
1602 IF( .NOT.isame( i ) )
1603 $ WRITE( nout, fmt = 9998 )i
1604 30 CONTINUE
1605 IF( .NOT.same )THEN
1606 fatal = .true.
1607 GO TO 120
1608 END IF
1609*
1610 IF( .NOT.null )THEN
1611*
1612* Check the result column by column.
1613*
1614 jc = 1
1615 DO 40 j = 1, n
1616 IF( upper )THEN
1617 jj = 1
1618 lj = j
1619 ELSE
1620 jj = j
1621 lj = n - j + 1
1622 END IF
1623 IF( tran )THEN
1624 CALL dmmch( 'T', 'N', lj, 1, k, alpha,
1625 $ a( 1, jj ), nmax,
1626 $ a( 1, j ), nmax, beta,
1627 $ c( jj, j ), nmax, ct, g,
1628 $ cc( jc ), ldc, eps, err,
1629 $ fatal, nout, .true. )
1630 ELSE
1631 CALL dmmch( 'N', 'T', lj, 1, k, alpha,
1632 $ a( jj, 1 ), nmax,
1633 $ a( j, 1 ), nmax, beta,
1634 $ c( jj, j ), nmax, ct, g,
1635 $ cc( jc ), ldc, eps, err,
1636 $ fatal, nout, .true. )
1637 END IF
1638 IF( upper )THEN
1639 jc = jc + ldc
1640 ELSE
1641 jc = jc + ldc + 1
1642 END IF
1643 errmax = max( errmax, err )
1644* If got really bad answer, report and
1645* return.
1646 IF( fatal )
1647 $ GO TO 110
1648 40 CONTINUE
1649 END IF
1650*
1651 50 CONTINUE
1652*
1653 60 CONTINUE
1654*
1655 70 CONTINUE
1656*
1657 80 CONTINUE
1658*
1659 90 CONTINUE
1660*
1661 100 CONTINUE
1662*
1663* Report result.
1664*
1665 IF( errmax.LT.thresh )THEN
1666 IF ( iorder.EQ.0) WRITE( nout, fmt = 10000 )sname, nc
1667 IF ( iorder.EQ.1) WRITE( nout, fmt = 10001 )sname, nc
1668 ELSE
1669 IF ( iorder.EQ.0) WRITE( nout, fmt = 10002 )sname, nc, errmax
1670 IF ( iorder.EQ.1) WRITE( nout, fmt = 10003 )sname, nc, errmax
1671 END IF
1672 GO TO 130
1673*
1674 110 CONTINUE
1675 IF( n.GT.1 )
1676 $ WRITE( nout, fmt = 9995 )j
1677*
1678 120 CONTINUE
1679 WRITE( nout, fmt = 9996 )sname
1680 CALL dprcn4( nout, nc, sname, iorder, uplo, trans, n, k, alpha,
1681 $ lda, beta, ldc)
1682*
1683 130 CONTINUE
1684 RETURN
1685*
168610003 FORMAT( ' ', a13,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
1687 $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1688 $ 'RATIO ', f8.2, ' - SUSPECT *******' )
168910002 FORMAT( ' ', a13,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
1690 $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1691 $ 'RATIO ', f8.2, ' - SUSPECT *******' )
169210001 FORMAT( ' ', a13,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
1693 $ ' (', i6, ' CALL', 'S)' )
169410000 FORMAT( ' ', a13,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
1695 $ ' (', i6, ' CALL', 'S)' )
1696 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
1697 $ 'ANGED INCORRECTLY *******' )
1698 9996 FORMAT( ' ******* ', a13,' FAILED ON CALL NUMBER:' )
1699 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', i3 )
1700 9994 FORMAT( 1x, i6, ': ', a13,'(', 2( '''', a1, ''',' ), 2( i3, ',' ),
1701 $ f4.1, ', A,', i3, ',', f4.1, ', C,', i3, ') .' )
1702 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1703 $ '******' )
1704*
1705* End of DCHK4.
1706*
dprcn4
subroutine dprcn4(nout, nc, sname, iorder, uplo, transa, n, k, alpha, lda, beta, ldc)
Definition c_dblat3.f:1711
lde
logical function lde(ri, rj, lr)
Definition dblat2.f:2970
lderes
logical function lderes(type, uplo, m, n, aa, as, lda)
Definition dblat2.f:3000
dmake
subroutine dmake(type, uplo, diag, m, n, a, nmax, aa, lda, kl, ku, reset, transl)
Definition dblat2.f:2678
dmmch
subroutine dmmch(transa, transb, m, n, kk, alpha, a, lda, b, ldb, beta, c, ldc, ct, g, cc, ldcc, eps, err, fatal, nout, mv)
Definition dblat3.f:2594
Here is the call graph for this function: