LAPACK  3.9.0
LAPACK: Linear Algebra PACKage

◆ 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 1418 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 *
1675 10003 FORMAT( ' ', a12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
1676  $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1677  $ 'RATIO ', f8.2, ' - SUSPECT *******' )
1678 10002 FORMAT( ' ', a12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
1679  $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1680  $ 'RATIO ', f8.2, ' - SUSPECT *******' )
1681 10001 FORMAT( ' ', a12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
1682  $ ' (', i6, ' CALL', 'S)' )
1683 10000 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 *
Here is the call graph for this function:
smake
subroutine smake(TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, KU, RESET, TRANSL)
Definition: sblat2.f:2653
lse
logical function lse(RI, RJ, LR)
Definition: sblat2.f:2945
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:2975
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:2511