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

◆ zchk4()

subroutine zchk4 ( character*7 sname,
double precision eps,
double precision thresh,
integer nout,
integer ntra,
logical trace,
logical rewi,
logical fatal,
integer nidim,
integer, dimension( nidim ) idim,
integer nalf,
complex*16, dimension( nalf ) alf,
integer nbet,
complex*16, dimension( nbet ) bet,
integer nmax,
complex*16, dimension( nmax, nmax ) a,
complex*16, dimension( nmax*nmax ) aa,
complex*16, dimension( nmax*nmax ) as,
complex*16, dimension( nmax, nmax ) b,
complex*16, dimension( nmax*nmax ) bb,
complex*16, dimension( nmax*nmax ) bs,
complex*16, dimension( nmax, nmax ) c,
complex*16, dimension( nmax*nmax ) cc,
complex*16, dimension( nmax*nmax ) cs,
complex*16, dimension( nmax ) ct,
double precision, dimension( nmax ) g )

Definition at line 1288 of file zblat3.f.

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