LAPACK  3.10.0
LAPACK: Linear Algebra PACKage

◆ 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 *
zsyrk
subroutine zsyrk(UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC)
ZSYRK
Definition: zsyrk.f:167
zherk
subroutine zherk(UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC)
ZHERK
Definition: zherk.f:173
lzeres
logical function lzeres(TYPE, UPLO, M, N, AA, AS, LDA)
Definition: zblat2.f:3077
zmake
subroutine zmake(TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, KU, RESET, TRANSL)
Definition: zblat2.f:2723
lze
logical function lze(RI, RJ, LR)
Definition: zblat2.f:3047
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: