LAPACK  3.9.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 1285 of file zblat3.f.

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