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

◆ cchk4()

subroutine cchk4 ( character*7 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 1283 of file cblat3.f.

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