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

◆ 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:2678
lde
logical function lde(RI, RJ, LR)
Definition: dblat2.f:2970
lderes
logical function lderes(TYPE, UPLO, M, N, AA, AS, LDA)
Definition: dblat2.f:3000
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: