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

◆ dchk4()

subroutine dchk4 ( 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,
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 1410 of file c_dblat3.f.

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