LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
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 1413 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 *
1670 10003 FORMAT( ' ', a12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
1671  $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1672  $ 'RATIO ', f8.2, ' - SUSPECT *******' )
1673 10002 FORMAT( ' ', a12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
1674  $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1675  $ 'RATIO ', f8.2, ' - SUSPECT *******' )
1676 10001 FORMAT( ' ', a12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
1677  $ ' (', i6, ' CALL', 'S)' )
1678 10000 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 *
dmake
subroutine dmake(TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, KU, RESET, TRANSL)
Definition: dblat2.f:2653
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:2511
lde
logical function lde(RI, RJ, LR)
Definition: dblat2.f:2945
dprcn4
subroutine dprcn4(NOUT, NC, SNAME, IORDER, UPLO, TRANSA, N, K, ALPHA, LDA, BETA, LDC)
Definition: c_dblat3.f:1695
lderes
logical function lderes(TYPE, UPLO, M, N, AA, AS, LDA)
Definition: dblat2.f:2975

Here is the call graph for this function: