LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
subroutine dchk4 ( 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,
double precision, dimension( nalf )  ALF,
integer  NBET,
double precision, dimension( nbet )  BET,
integer  NMAX,
double precision, dimension( nmax, nmax )  A,
double precision, dimension( nmax*nmax )  AA,
double precision, dimension( nmax*nmax )  AS,
double precision, dimension( nmax, nmax )  B,
double precision, dimension( nmax*nmax )  BB,
double precision, dimension( nmax*nmax )  BS,
double precision, dimension( nmax, nmax )  C,
double precision, dimension( nmax*nmax )  CC,
double precision, dimension( nmax*nmax )  CS,
double precision, dimension( nmax )  CT,
double precision, dimension( nmax )  G 
)

Definition at line 1254 of file dblat3.f.

1254 *
1255 * Tests DSYRK.
1256 *
1257 * Auxiliary routine for test program for Level 3 Blas.
1258 *
1259 * -- Written on 8-February-1989.
1260 * Jack Dongarra, Argonne National Laboratory.
1261 * Iain Duff, AERE Harwell.
1262 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
1263 * Sven Hammarling, Numerical Algorithms Group Ltd.
1264 *
1265 * .. Parameters ..
1266  DOUBLE PRECISION zero
1267  parameter ( zero = 0.0d0 )
1268 * .. Scalar Arguments ..
1269  DOUBLE PRECISION eps, thresh
1270  INTEGER nalf, nbet, nidim, nmax, nout, ntra
1271  LOGICAL fatal, rewi, trace
1272  CHARACTER*6 sname
1273 * .. Array Arguments ..
1274  DOUBLE PRECISION a( nmax, nmax ), aa( nmax*nmax ), alf( nalf ),
1275  $ as( nmax*nmax ), b( nmax, nmax ),
1276  $ bb( nmax*nmax ), bet( nbet ), bs( nmax*nmax ),
1277  $ c( nmax, nmax ), cc( nmax*nmax ),
1278  $ cs( nmax*nmax ), ct( nmax ), g( nmax )
1279  INTEGER idim( nidim )
1280 * .. Local Scalars ..
1281  DOUBLE PRECISION alpha, als, beta, bets, err, errmax
1282  INTEGER i, ia, ib, ict, icu, ik, in, j, jc, jj, k, ks,
1283  $ laa, lcc, lda, ldas, ldc, ldcs, lj, ma, n, na,
1284  $ nargs, nc, ns
1285  LOGICAL null, reset, same, tran, upper
1286  CHARACTER*1 trans, transs, uplo, uplos
1287  CHARACTER*2 ichu
1288  CHARACTER*3 icht
1289 * .. Local Arrays ..
1290  LOGICAL isame( 13 )
1291 * .. External Functions ..
1292  LOGICAL lde, lderes
1293  EXTERNAL lde, lderes
1294 * .. External Subroutines ..
1295  EXTERNAL dmake, dmmch, dsyrk
1296 * .. Intrinsic Functions ..
1297  INTRINSIC max
1298 * .. Scalars in Common ..
1299  INTEGER infot, noutc
1300  LOGICAL lerr, ok
1301 * .. Common blocks ..
1302  COMMON /infoc/infot, noutc, ok, lerr
1303 * .. Data statements ..
1304  DATA icht/'NTC'/, ichu/'UL'/
1305 * .. Executable Statements ..
1306 *
1307  nargs = 10
1308  nc = 0
1309  reset = .true.
1310  errmax = zero
1311 *
1312  DO 100 in = 1, nidim
1313  n = idim( in )
1314 * Set LDC to 1 more than minimum value if room.
1315  ldc = n
1316  IF( ldc.LT.nmax )
1317  $ ldc = ldc + 1
1318 * Skip tests if not enough room.
1319  IF( ldc.GT.nmax )
1320  $ GO TO 100
1321  lcc = ldc*n
1322  null = n.LE.0
1323 *
1324  DO 90 ik = 1, nidim
1325  k = idim( ik )
1326 *
1327  DO 80 ict = 1, 3
1328  trans = icht( ict: ict )
1329  tran = trans.EQ.'T'.OR.trans.EQ.'C'
1330  IF( tran )THEN
1331  ma = k
1332  na = n
1333  ELSE
1334  ma = n
1335  na = k
1336  END IF
1337 * Set LDA to 1 more than minimum value if room.
1338  lda = ma
1339  IF( lda.LT.nmax )
1340  $ lda = lda + 1
1341 * Skip tests if not enough room.
1342  IF( lda.GT.nmax )
1343  $ GO TO 80
1344  laa = lda*na
1345 *
1346 * Generate the matrix A.
1347 *
1348  CALL dmake( 'GE', ' ', ' ', ma, na, a, nmax, aa, lda,
1349  $ reset, zero )
1350 *
1351  DO 70 icu = 1, 2
1352  uplo = ichu( icu: icu )
1353  upper = uplo.EQ.'U'
1354 *
1355  DO 60 ia = 1, nalf
1356  alpha = alf( ia )
1357 *
1358  DO 50 ib = 1, nbet
1359  beta = bet( ib )
1360 *
1361 * Generate the matrix C.
1362 *
1363  CALL dmake( 'SY', uplo, ' ', n, n, c, nmax, cc,
1364  $ ldc, reset, zero )
1365 *
1366  nc = nc + 1
1367 *
1368 * Save every datum before calling the subroutine.
1369 *
1370  uplos = uplo
1371  transs = trans
1372  ns = n
1373  ks = k
1374  als = alpha
1375  DO 10 i = 1, laa
1376  as( i ) = aa( i )
1377  10 CONTINUE
1378  ldas = lda
1379  bets = beta
1380  DO 20 i = 1, lcc
1381  cs( i ) = cc( i )
1382  20 CONTINUE
1383  ldcs = ldc
1384 *
1385 * Call the subroutine.
1386 *
1387  IF( trace )
1388  $ WRITE( ntra, fmt = 9994 )nc, sname, uplo,
1389  $ trans, n, k, alpha, lda, beta, ldc
1390  IF( rewi )
1391  $ rewind ntra
1392  CALL dsyrk( uplo, trans, n, k, alpha, aa, lda,
1393  $ beta, cc, ldc )
1394 *
1395 * Check if error-exit was taken incorrectly.
1396 *
1397  IF( .NOT.ok )THEN
1398  WRITE( nout, fmt = 9993 )
1399  fatal = .true.
1400  GO TO 120
1401  END IF
1402 *
1403 * See what data changed inside subroutines.
1404 *
1405  isame( 1 ) = uplos.EQ.uplo
1406  isame( 2 ) = transs.EQ.trans
1407  isame( 3 ) = ns.EQ.n
1408  isame( 4 ) = ks.EQ.k
1409  isame( 5 ) = als.EQ.alpha
1410  isame( 6 ) = lde( as, aa, laa )
1411  isame( 7 ) = ldas.EQ.lda
1412  isame( 8 ) = bets.EQ.beta
1413  IF( null )THEN
1414  isame( 9 ) = lde( cs, cc, lcc )
1415  ELSE
1416  isame( 9 ) = lderes( 'SY', uplo, n, n, cs,
1417  $ cc, ldc )
1418  END IF
1419  isame( 10 ) = ldcs.EQ.ldc
1420 *
1421 * If data was incorrectly changed, report and
1422 * return.
1423 *
1424  same = .true.
1425  DO 30 i = 1, nargs
1426  same = same.AND.isame( i )
1427  IF( .NOT.isame( i ) )
1428  $ WRITE( nout, fmt = 9998 )i
1429  30 CONTINUE
1430  IF( .NOT.same )THEN
1431  fatal = .true.
1432  GO TO 120
1433  END IF
1434 *
1435  IF( .NOT.null )THEN
1436 *
1437 * Check the result column by column.
1438 *
1439  jc = 1
1440  DO 40 j = 1, n
1441  IF( upper )THEN
1442  jj = 1
1443  lj = j
1444  ELSE
1445  jj = j
1446  lj = n - j + 1
1447  END IF
1448  IF( tran )THEN
1449  CALL dmmch( 'T', 'N', lj, 1, k, alpha,
1450  $ a( 1, jj ), nmax,
1451  $ a( 1, j ), nmax, beta,
1452  $ c( jj, j ), nmax, ct, g,
1453  $ cc( jc ), ldc, eps, err,
1454  $ fatal, nout, .true. )
1455  ELSE
1456  CALL dmmch( 'N', 'T', lj, 1, k, alpha,
1457  $ a( jj, 1 ), nmax,
1458  $ a( j, 1 ), nmax, beta,
1459  $ c( jj, j ), nmax, ct, g,
1460  $ cc( jc ), ldc, eps, err,
1461  $ fatal, nout, .true. )
1462  END IF
1463  IF( upper )THEN
1464  jc = jc + ldc
1465  ELSE
1466  jc = jc + ldc + 1
1467  END IF
1468  errmax = max( errmax, err )
1469 * If got really bad answer, report and
1470 * return.
1471  IF( fatal )
1472  $ GO TO 110
1473  40 CONTINUE
1474  END IF
1475 *
1476  50 CONTINUE
1477 *
1478  60 CONTINUE
1479 *
1480  70 CONTINUE
1481 *
1482  80 CONTINUE
1483 *
1484  90 CONTINUE
1485 *
1486  100 CONTINUE
1487 *
1488 * Report result.
1489 *
1490  IF( errmax.LT.thresh )THEN
1491  WRITE( nout, fmt = 9999 )sname, nc
1492  ELSE
1493  WRITE( nout, fmt = 9997 )sname, nc, errmax
1494  END IF
1495  GO TO 130
1496 *
1497  110 CONTINUE
1498  IF( n.GT.1 )
1499  $ WRITE( nout, fmt = 9995 )j
1500 *
1501  120 CONTINUE
1502  WRITE( nout, fmt = 9996 )sname
1503  WRITE( nout, fmt = 9994 )nc, sname, uplo, trans, n, k, alpha,
1504  $ lda, beta, ldc
1505 *
1506  130 CONTINUE
1507  RETURN
1508 *
1509  9999 FORMAT( ' ', a6, ' PASSED THE COMPUTATIONAL TESTS (', i6, ' CALL',
1510  $ 'S)' )
1511  9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
1512  $ 'ANGED INCORRECTLY *******' )
1513  9997 FORMAT( ' ', a6, ' COMPLETED THE COMPUTATIONAL TESTS (', i6, ' C',
1514  $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
1515  $ ' - SUSPECT *******' )
1516  9996 FORMAT( ' ******* ', a6, ' FAILED ON CALL NUMBER:' )
1517  9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', i3 )
1518  9994 FORMAT( 1x, i6, ': ', a6, '(', 2( '''', a1, ''',' ), 2( i3, ',' ),
1519  $ f4.1, ', A,', i3, ',', f4.1, ', C,', i3, ') .' )
1520  9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1521  $ '******' )
1522 *
1523 * End of DCHK4.
1524 *
dmake
subroutine dmake(TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, KU, RESET, TRANSL)
Definition: dblat2.f:2653
dmmch
subroutine dmmch(TRANSA, TRANSB, M, N, KK, ALPHA, A, LDA, B, LDB, BETA, C, LDC, CT, G, CC, LDCC, EPS, ERR, FATAL, NOUT, MV)
Definition: dblat3.f:2511
lde
logical function lde(RI, RJ, LR)
Definition: dblat2.f:2945
dsyrk
subroutine dsyrk(UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC)
DSYRK
Definition: dsyrk.f:171
lderes
logical function lderes(TYPE, UPLO, M, N, AA, AS, LDA)
Definition: dblat2.f:2975

Here is the call graph for this function: