LAPACK  3.9.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 1282 of file cblat3.f.

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