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

◆ schk4()

subroutine schk4 ( character*7 sname,
real eps,
real thresh,
integer nout,
integer ntra,
logical trace,
logical rewi,
logical fatal,
integer nidim,
integer, dimension( nidim ) idim,
integer nalf,
real, dimension( nalf ) alf,
integer nbet,
real, dimension( nbet ) bet,
integer nmax,
real, dimension( nmax, nmax ) a,
real, dimension( nmax*nmax ) aa,
real, dimension( nmax*nmax ) as,
real, dimension( nmax, nmax ) b,
real, dimension( nmax*nmax ) bb,
real, dimension( nmax*nmax ) bs,
real, dimension( nmax, nmax ) c,
real, dimension( nmax*nmax ) cc,
real, dimension( nmax*nmax ) cs,
real, dimension( nmax ) ct,
real, dimension( nmax ) g )

Definition at line 1255 of file sblat3.f.

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