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

◆ schk4()

subroutine schk4 ( character*12  sname,
real  eps,
real  thresh,
integer  nout,
integer  ntra,
logical  trace,
logical  rewi,
logical  fatal,
integer  nidim,
integer, dimension( nidim )  idim,
integer  nalf,
real, dimension( nalf )  alf,
integer  nbet,
real, dimension( nbet )  bet,
integer  nmax,
real, dimension( nmax, nmax )  a,
real, dimension( nmax*nmax )  aa,
real, dimension( nmax*nmax )  as,
real, dimension( nmax, nmax )  b,
real, dimension( nmax*nmax )  bb,
real, dimension( nmax*nmax )  bs,
real, dimension( nmax, nmax )  c,
real, dimension( nmax*nmax )  cc,
real, dimension( nmax*nmax )  cs,
real, dimension( nmax )  ct,
real, dimension( nmax )  g,
integer  iorder 
)

Definition at line 1414 of file c_sblat3.f.

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