LAPACK  3.10.1
LAPACK: Linear Algebra PACKage

◆ dchk4()

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 1248 of file dblat3.f.

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