LAPACK  3.10.0
LAPACK: Linear Algebra PACKage

◆ cchk4()

subroutine cchk4 ( character*6  SNAME,
real  EPS,
real  THRESH,
integer  NOUT,
integer  NTRA,
logical  TRACE,
logical  REWI,
logical  FATAL,
integer  NIDIM,
integer, dimension( nidim )  IDIM,
integer  NALF,
complex, dimension( nalf )  ALF,
integer  NBET,
complex, dimension( nbet )  BET,
integer  NMAX,
complex, dimension( nmax, nmax )  A,
complex, dimension( nmax*nmax )  AA,
complex, dimension( nmax*nmax )  AS,
complex, dimension( nmax, nmax )  B,
complex, dimension( nmax*nmax )  BB,
complex, dimension( nmax*nmax )  BS,
complex, dimension( nmax, nmax )  C,
complex, dimension( nmax*nmax )  CC,
complex, dimension( nmax*nmax )  CS,
complex, dimension( nmax )  CT,
real, dimension( nmax )  G 
)

Definition at line 1276 of file cblat3.f.

1279 *
1280 * Tests CHERK and CSYRK.
1281 *
1282 * Auxiliary routine for test program for Level 3 Blas.
1283 *
1284 * -- Written on 8-February-1989.
1285 * Jack Dongarra, Argonne National Laboratory.
1286 * Iain Duff, AERE Harwell.
1287 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
1288 * Sven Hammarling, Numerical Algorithms Group Ltd.
1289 *
1290 * .. Parameters ..
1291  COMPLEX ZERO
1292  parameter( zero = ( 0.0, 0.0 ) )
1293  REAL RONE, RZERO
1294  parameter( rone = 1.0, rzero = 0.0 )
1295 * .. Scalar Arguments ..
1296  REAL EPS, THRESH
1297  INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA
1298  LOGICAL FATAL, REWI, TRACE
1299  CHARACTER*6 SNAME
1300 * .. Array Arguments ..
1301  COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
1302  $ AS( NMAX*NMAX ), B( NMAX, NMAX ),
1303  $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
1304  $ C( NMAX, NMAX ), CC( NMAX*NMAX ),
1305  $ CS( NMAX*NMAX ), CT( NMAX )
1306  REAL G( NMAX )
1307  INTEGER IDIM( NIDIM )
1308 * .. Local Scalars ..
1309  COMPLEX ALPHA, ALS, BETA, BETS
1310  REAL ERR, ERRMAX, RALPHA, RALS, RBETA, RBETS
1311  INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, K, KS,
1312  $ LAA, LCC, LDA, LDAS, LDC, LDCS, LJ, MA, N, NA,
1313  $ NARGS, NC, NS
1314  LOGICAL CONJ, NULL, RESET, SAME, TRAN, UPPER
1315  CHARACTER*1 TRANS, TRANSS, TRANST, UPLO, UPLOS
1316  CHARACTER*2 ICHT, ICHU
1317 * .. Local Arrays ..
1318  LOGICAL ISAME( 13 )
1319 * .. External Functions ..
1320  LOGICAL LCE, LCERES
1321  EXTERNAL lce, lceres
1322 * .. External Subroutines ..
1323  EXTERNAL cherk, cmake, cmmch, csyrk
1324 * .. Intrinsic Functions ..
1325  INTRINSIC cmplx, max, real
1326 * .. Scalars in Common ..
1327  INTEGER INFOT, NOUTC
1328  LOGICAL LERR, OK
1329 * .. Common blocks ..
1330  COMMON /infoc/infot, noutc, ok, lerr
1331 * .. Data statements ..
1332  DATA icht/'NC'/, ichu/'UL'/
1333 * .. Executable Statements ..
1334  conj = sname( 2: 3 ).EQ.'HE'
1335 *
1336  nargs = 10
1337  nc = 0
1338  reset = .true.
1339  errmax = rzero
1340 *
1341  DO 100 in = 1, nidim
1342  n = idim( in )
1343 * Set LDC to 1 more than minimum value if room.
1344  ldc = n
1345  IF( ldc.LT.nmax )
1346  $ ldc = ldc + 1
1347 * Skip tests if not enough room.
1348  IF( ldc.GT.nmax )
1349  $ GO TO 100
1350  lcc = ldc*n
1351 *
1352  DO 90 ik = 1, nidim
1353  k = idim( ik )
1354 *
1355  DO 80 ict = 1, 2
1356  trans = icht( ict: ict )
1357  tran = trans.EQ.'C'
1358  IF( tran.AND..NOT.conj )
1359  $ trans = 'T'
1360  IF( tran )THEN
1361  ma = k
1362  na = n
1363  ELSE
1364  ma = n
1365  na = k
1366  END IF
1367 * Set LDA to 1 more than minimum value if room.
1368  lda = ma
1369  IF( lda.LT.nmax )
1370  $ lda = lda + 1
1371 * Skip tests if not enough room.
1372  IF( lda.GT.nmax )
1373  $ GO TO 80
1374  laa = lda*na
1375 *
1376 * Generate the matrix A.
1377 *
1378  CALL cmake( 'GE', ' ', ' ', ma, na, a, nmax, aa, lda,
1379  $ reset, zero )
1380 *
1381  DO 70 icu = 1, 2
1382  uplo = ichu( icu: icu )
1383  upper = uplo.EQ.'U'
1384 *
1385  DO 60 ia = 1, nalf
1386  alpha = alf( ia )
1387  IF( conj )THEN
1388  ralpha = real( alpha )
1389  alpha = cmplx( ralpha, rzero )
1390  END IF
1391 *
1392  DO 50 ib = 1, nbet
1393  beta = bet( ib )
1394  IF( conj )THEN
1395  rbeta = real( beta )
1396  beta = cmplx( rbeta, rzero )
1397  END IF
1398  null = n.LE.0
1399  IF( conj )
1400  $ null = null.OR.( ( k.LE.0.OR.ralpha.EQ.
1401  $ rzero ).AND.rbeta.EQ.rone )
1402 *
1403 * Generate the matrix C.
1404 *
1405  CALL cmake( sname( 2: 3 ), uplo, ' ', n, n, c,
1406  $ nmax, cc, ldc, reset, zero )
1407 *
1408  nc = nc + 1
1409 *
1410 * Save every datum before calling the subroutine.
1411 *
1412  uplos = uplo
1413  transs = trans
1414  ns = n
1415  ks = k
1416  IF( conj )THEN
1417  rals = ralpha
1418  ELSE
1419  als = alpha
1420  END IF
1421  DO 10 i = 1, laa
1422  as( i ) = aa( i )
1423  10 CONTINUE
1424  ldas = lda
1425  IF( conj )THEN
1426  rbets = rbeta
1427  ELSE
1428  bets = beta
1429  END IF
1430  DO 20 i = 1, lcc
1431  cs( i ) = cc( i )
1432  20 CONTINUE
1433  ldcs = ldc
1434 *
1435 * Call the subroutine.
1436 *
1437  IF( conj )THEN
1438  IF( trace )
1439  $ WRITE( ntra, fmt = 9994 )nc, sname, uplo,
1440  $ trans, n, k, ralpha, lda, rbeta, ldc
1441  IF( rewi )
1442  $ rewind ntra
1443  CALL cherk( uplo, trans, n, k, ralpha, aa,
1444  $ lda, rbeta, cc, ldc )
1445  ELSE
1446  IF( trace )
1447  $ WRITE( ntra, fmt = 9993 )nc, sname, uplo,
1448  $ trans, n, k, alpha, lda, beta, ldc
1449  IF( rewi )
1450  $ rewind ntra
1451  CALL csyrk( uplo, trans, n, k, alpha, aa,
1452  $ lda, beta, cc, ldc )
1453  END IF
1454 *
1455 * Check if error-exit was taken incorrectly.
1456 *
1457  IF( .NOT.ok )THEN
1458  WRITE( nout, fmt = 9992 )
1459  fatal = .true.
1460  GO TO 120
1461  END IF
1462 *
1463 * See what data changed inside subroutines.
1464 *
1465  isame( 1 ) = uplos.EQ.uplo
1466  isame( 2 ) = transs.EQ.trans
1467  isame( 3 ) = ns.EQ.n
1468  isame( 4 ) = ks.EQ.k
1469  IF( conj )THEN
1470  isame( 5 ) = rals.EQ.ralpha
1471  ELSE
1472  isame( 5 ) = als.EQ.alpha
1473  END IF
1474  isame( 6 ) = lce( as, aa, laa )
1475  isame( 7 ) = ldas.EQ.lda
1476  IF( conj )THEN
1477  isame( 8 ) = rbets.EQ.rbeta
1478  ELSE
1479  isame( 8 ) = bets.EQ.beta
1480  END IF
1481  IF( null )THEN
1482  isame( 9 ) = lce( cs, cc, lcc )
1483  ELSE
1484  isame( 9 ) = lceres( sname( 2: 3 ), uplo, n,
1485  $ n, cs, cc, ldc )
1486  END IF
1487  isame( 10 ) = ldcs.EQ.ldc
1488 *
1489 * If data was incorrectly changed, report and
1490 * return.
1491 *
1492  same = .true.
1493  DO 30 i = 1, nargs
1494  same = same.AND.isame( i )
1495  IF( .NOT.isame( i ) )
1496  $ WRITE( nout, fmt = 9998 )i
1497  30 CONTINUE
1498  IF( .NOT.same )THEN
1499  fatal = .true.
1500  GO TO 120
1501  END IF
1502 *
1503  IF( .NOT.null )THEN
1504 *
1505 * Check the result column by column.
1506 *
1507  IF( conj )THEN
1508  transt = 'C'
1509  ELSE
1510  transt = 'T'
1511  END IF
1512  jc = 1
1513  DO 40 j = 1, n
1514  IF( upper )THEN
1515  jj = 1
1516  lj = j
1517  ELSE
1518  jj = j
1519  lj = n - j + 1
1520  END IF
1521  IF( tran )THEN
1522  CALL cmmch( transt, 'N', lj, 1, k,
1523  $ alpha, a( 1, jj ), nmax,
1524  $ a( 1, j ), nmax, beta,
1525  $ c( jj, j ), nmax, ct, g,
1526  $ cc( jc ), ldc, eps, err,
1527  $ fatal, nout, .true. )
1528  ELSE
1529  CALL cmmch( 'N', transt, lj, 1, k,
1530  $ alpha, a( jj, 1 ), nmax,
1531  $ a( j, 1 ), nmax, beta,
1532  $ c( jj, j ), nmax, ct, g,
1533  $ cc( jc ), ldc, eps, err,
1534  $ fatal, nout, .true. )
1535  END IF
1536  IF( upper )THEN
1537  jc = jc + ldc
1538  ELSE
1539  jc = jc + ldc + 1
1540  END IF
1541  errmax = max( errmax, err )
1542 * If got really bad answer, report and
1543 * return.
1544  IF( fatal )
1545  $ GO TO 110
1546  40 CONTINUE
1547  END IF
1548 *
1549  50 CONTINUE
1550 *
1551  60 CONTINUE
1552 *
1553  70 CONTINUE
1554 *
1555  80 CONTINUE
1556 *
1557  90 CONTINUE
1558 *
1559  100 CONTINUE
1560 *
1561 * Report result.
1562 *
1563  IF( errmax.LT.thresh )THEN
1564  WRITE( nout, fmt = 9999 )sname, nc
1565  ELSE
1566  WRITE( nout, fmt = 9997 )sname, nc, errmax
1567  END IF
1568  GO TO 130
1569 *
1570  110 CONTINUE
1571  IF( n.GT.1 )
1572  $ WRITE( nout, fmt = 9995 )j
1573 *
1574  120 CONTINUE
1575  WRITE( nout, fmt = 9996 )sname
1576  IF( conj )THEN
1577  WRITE( nout, fmt = 9994 )nc, sname, uplo, trans, n, k, ralpha,
1578  $ lda, rbeta, ldc
1579  ELSE
1580  WRITE( nout, fmt = 9993 )nc, sname, uplo, trans, n, k, alpha,
1581  $ lda, beta, ldc
1582  END IF
1583 *
1584  130 CONTINUE
1585  RETURN
1586 *
1587  9999 FORMAT( ' ', a6, ' PASSED THE COMPUTATIONAL TESTS (', i6, ' CALL',
1588  $ 'S)' )
1589  9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
1590  $ 'ANGED INCORRECTLY *******' )
1591  9997 FORMAT( ' ', a6, ' COMPLETED THE COMPUTATIONAL TESTS (', i6, ' C',
1592  $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
1593  $ ' - SUSPECT *******' )
1594  9996 FORMAT( ' ******* ', a6, ' FAILED ON CALL NUMBER:' )
1595  9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', i3 )
1596  9994 FORMAT( 1x, i6, ': ', a6, '(', 2( '''', a1, ''',' ), 2( i3, ',' ),
1597  $ f4.1, ', A,', i3, ',', f4.1, ', C,', i3, ') ',
1598  $ ' .' )
1599  9993 FORMAT( 1x, i6, ': ', a6, '(', 2( '''', a1, ''',' ), 2( i3, ',' ),
1600  $ '(', f4.1, ',', f4.1, ') , A,', i3, ',(', f4.1, ',', f4.1,
1601  $ '), C,', i3, ') .' )
1602  9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1603  $ '******' )
1604 *
1605 * End of CCHK4
1606 *
cmake
subroutine cmake(TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, KU, RESET, TRANSL)
Definition: cblat2.f:2716
lce
logical function lce(RI, RJ, LR)
Definition: cblat2.f:3039
lceres
logical function lceres(TYPE, UPLO, M, N, AA, AS, LDA)
Definition: cblat2.f:3069
cmmch
subroutine cmmch(TRANSA, TRANSB, M, N, KK, ALPHA, A, LDA, B, LDB, BETA, C, LDC, CT, G, CC, LDCC, EPS, ERR, FATAL, NOUT, MV)
Definition: cblat3.f:3053
csyrk
subroutine csyrk(UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC)
CSYRK
Definition: csyrk.f:167
cherk
subroutine cherk(UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC)
CHERK
Definition: cherk.f:173
Here is the call graph for this function: