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

◆ 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:2744
lceres
logical function lceres(type, uplo, m, n, aa, as, lda)
Definition cblat2.f:3097
lce
logical function lce(ri, rj, lr)
Definition cblat2.f:3067
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: