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

◆ zchk4()

subroutine zchk4 ( character*6  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 1279 of file zblat3.f.

1282*
1283* Tests ZHERK and ZSYRK.
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*16 ZERO
1295 parameter( zero = ( 0.0d0, 0.0d0 ) )
1296 DOUBLE PRECISION RONE, RZERO
1297 parameter( rone = 1.0d0, rzero = 0.0d0 )
1298* .. Scalar Arguments ..
1299 DOUBLE PRECISION EPS, THRESH
1300 INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA
1301 LOGICAL FATAL, REWI, TRACE
1302 CHARACTER*6 SNAME
1303* .. Array Arguments ..
1304 COMPLEX*16 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 DOUBLE PRECISION G( NMAX )
1310 INTEGER IDIM( NIDIM )
1311* .. Local Scalars ..
1312 COMPLEX*16 ALPHA, ALS, BETA, BETS
1313 DOUBLE PRECISION 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 LZE, LZERES
1324 EXTERNAL lze, lzeres
1325* .. External Subroutines ..
1326 EXTERNAL zherk, zmake, zmmch, zsyrk
1327* .. Intrinsic Functions ..
1328 INTRINSIC dcmplx, max, dble
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 zmake( '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 = dble( alpha )
1392 alpha = dcmplx( ralpha, rzero )
1393 END IF
1394*
1395 DO 50 ib = 1, nbet
1396 beta = bet( ib )
1397 IF( conj )THEN
1398 rbeta = dble( beta )
1399 beta = dcmplx( 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 zmake( 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 zherk( 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 zsyrk( 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 ) = lze( 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 ) = lze( cs, cc, lcc )
1486 ELSE
1487 isame( 9 ) = lzeres( 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 zmmch( 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 zmmch( '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 ZCHK4
1609*
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:3061
Here is the call graph for this function: