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

◆ schk3()

subroutine schk3 ( character*12  sname,
real  eps,
real  thresh,
integer  nout,
integer  ntra,
logical  trace,
logical  rewi,
logical  fatal,
integer  nidim,
integer, dimension( nidim )  idim,
integer  nkb,
integer, dimension( nkb )  kb,
integer  ninc,
integer, dimension( ninc )  inc,
integer  nmax,
integer  incmax,
real, dimension( nmax, nmax )  a,
real, dimension( nmax*nmax )  aa,
real, dimension( nmax*nmax )  as,
real, dimension( nmax )  x,
real, dimension( nmax*incmax )  xx,
real, dimension( nmax*incmax )  xs,
real, dimension( nmax )  xt,
real, dimension( nmax )  g,
real, dimension( nmax )  z,
integer  iorder 
)

Definition at line 1176 of file c_sblat2.f.

1179*
1180* Tests STRMV, STBMV, STPMV, STRSV, STBSV and STPSV.
1181*
1182* Auxiliary routine for test program for Level 2 Blas.
1183*
1184* -- Written on 10-August-1987.
1185* Richard Hanson, Sandia National Labs.
1186* Jeremy Du Croz, NAG Central Office.
1187*
1188* .. Parameters ..
1189 REAL ZERO, HALF, ONE
1190 parameter( zero = 0.0, half = 0.5, one = 1.0 )
1191* .. Scalar Arguments ..
1192 REAL EPS, THRESH
1193 INTEGER INCMAX, NIDIM, NINC, NKB, NMAX, NOUT, NTRA,
1194 $ IORDER
1195 LOGICAL FATAL, REWI, TRACE
1196 CHARACTER*12 SNAME
1197* .. Array Arguments ..
1198 REAL A( NMAX, NMAX ), AA( NMAX*NMAX ),
1199 $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ),
1200 $ XS( NMAX*INCMAX ), XT( NMAX ),
1201 $ XX( NMAX*INCMAX ), Z( NMAX )
1202 INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB )
1203* .. Local Scalars ..
1204 REAL ERR, ERRMAX, TRANSL
1205 INTEGER I, ICD, ICT, ICU, IK, IN, INCX, INCXS, IX, K,
1206 $ KS, LAA, LDA, LDAS, LX, N, NARGS, NC, NK, NS
1207 LOGICAL BANDED, FULL, NULL, PACKED, RESET, SAME
1208 CHARACTER*1 DIAG, DIAGS, TRANS, TRANSS, UPLO, UPLOS
1209 CHARACTER*14 CUPLO,CTRANS,CDIAG
1210 CHARACTER*2 ICHD, ICHU
1211 CHARACTER*3 ICHT
1212* .. Local Arrays ..
1213 LOGICAL ISAME( 13 )
1214* .. External Functions ..
1215 LOGICAL LSE, LSERES
1216 EXTERNAL lse, lseres
1217* .. External Subroutines ..
1218 EXTERNAL smake, smvch, cstbmv, cstbsv, cstpmv,
1219 $ cstpsv, cstrmv, cstrsv
1220* .. Intrinsic Functions ..
1221 INTRINSIC abs, max
1222* .. Scalars in Common ..
1223 INTEGER INFOT, NOUTC
1224 LOGICAL OK
1225* .. Common blocks ..
1226 COMMON /infoc/infot, noutc, ok
1227* .. Data statements ..
1228 DATA ichu/'UL'/, icht/'NTC'/, ichd/'UN'/
1229* .. Executable Statements ..
1230 full = sname( 9: 9 ).EQ.'r'
1231 banded = sname( 9: 9 ).EQ.'b'
1232 packed = sname( 9: 9 ).EQ.'p'
1233* Define the number of arguments.
1234 IF( full )THEN
1235 nargs = 8
1236 ELSE IF( banded )THEN
1237 nargs = 9
1238 ELSE IF( packed )THEN
1239 nargs = 7
1240 END IF
1241*
1242 nc = 0
1243 reset = .true.
1244 errmax = zero
1245* Set up zero vector for SMVCH.
1246 DO 10 i = 1, nmax
1247 z( i ) = zero
1248 10 CONTINUE
1249*
1250 DO 110 in = 1, nidim
1251 n = idim( in )
1252*
1253 IF( banded )THEN
1254 nk = nkb
1255 ELSE
1256 nk = 1
1257 END IF
1258 DO 100 ik = 1, nk
1259 IF( banded )THEN
1260 k = kb( ik )
1261 ELSE
1262 k = n - 1
1263 END IF
1264* Set LDA to 1 more than minimum value if room.
1265 IF( banded )THEN
1266 lda = k + 1
1267 ELSE
1268 lda = n
1269 END IF
1270 IF( lda.LT.nmax )
1271 $ lda = lda + 1
1272* Skip tests if not enough room.
1273 IF( lda.GT.nmax )
1274 $ GO TO 100
1275 IF( packed )THEN
1276 laa = ( n*( n + 1 ) )/2
1277 ELSE
1278 laa = lda*n
1279 END IF
1280 null = n.LE.0
1281*
1282 DO 90 icu = 1, 2
1283 uplo = ichu( icu: icu )
1284 IF (uplo.EQ.'U')THEN
1285 cuplo = ' CblasUpper'
1286 ELSE
1287 cuplo = ' CblasLower'
1288 END IF
1289*
1290 DO 80 ict = 1, 3
1291 trans = icht( ict: ict )
1292 IF (trans.EQ.'N')THEN
1293 ctrans = ' CblasNoTrans'
1294 ELSE IF (trans.EQ.'T')THEN
1295 ctrans = ' CblasTrans'
1296 ELSE
1297 ctrans = 'CblasConjTrans'
1298 END IF
1299*
1300 DO 70 icd = 1, 2
1301 diag = ichd( icd: icd )
1302 IF (diag.EQ.'N')THEN
1303 cdiag = ' CblasNonUnit'
1304 ELSE
1305 cdiag = ' CblasUnit'
1306 END IF
1307*
1308* Generate the matrix A.
1309*
1310 transl = zero
1311 CALL smake( sname( 8: 9 ), uplo, diag, n, n, a,
1312 $ nmax, aa, lda, k, k, reset, transl )
1313*
1314 DO 60 ix = 1, ninc
1315 incx = inc( ix )
1316 lx = abs( incx )*n
1317*
1318* Generate the vector X.
1319*
1320 transl = half
1321 CALL smake( 'ge', ' ', ' ', 1, n, x, 1, xx,
1322 $ abs( incx ), 0, n - 1, reset,
1323 $ transl )
1324 IF( n.GT.1 )THEN
1325 x( n/2 ) = zero
1326 xx( 1 + abs( incx )*( n/2 - 1 ) ) = zero
1327 END IF
1328*
1329 nc = nc + 1
1330*
1331* Save every datum before calling the subroutine.
1332*
1333 uplos = uplo
1334 transs = trans
1335 diags = diag
1336 ns = n
1337 ks = k
1338 DO 20 i = 1, laa
1339 as( i ) = aa( i )
1340 20 CONTINUE
1341 ldas = lda
1342 DO 30 i = 1, lx
1343 xs( i ) = xx( i )
1344 30 CONTINUE
1345 incxs = incx
1346*
1347* Call the subroutine.
1348*
1349 IF( sname( 10: 11 ).EQ.'mv' )THEN
1350 IF( full )THEN
1351 IF( trace )
1352 $ WRITE( ntra, fmt = 9993 )nc, sname,
1353 $ cuplo, ctrans, cdiag, n, lda, incx
1354 IF( rewi )
1355 $ rewind ntra
1356 CALL cstrmv( iorder, uplo, trans, diag,
1357 $ n, aa, lda, xx, incx )
1358 ELSE IF( banded )THEN
1359 IF( trace )
1360 $ WRITE( ntra, fmt = 9994 )nc, sname,
1361 $ cuplo, ctrans, cdiag, n, k, lda, incx
1362 IF( rewi )
1363 $ rewind ntra
1364 CALL cstbmv( iorder, uplo, trans, diag,
1365 $ n, k, aa, lda, xx, incx )
1366 ELSE IF( packed )THEN
1367 IF( trace )
1368 $ WRITE( ntra, fmt = 9995 )nc, sname,
1369 $ cuplo, ctrans, cdiag, n, incx
1370 IF( rewi )
1371 $ rewind ntra
1372 CALL cstpmv( iorder, uplo, trans, diag,
1373 $ n, aa, xx, incx )
1374 END IF
1375 ELSE IF( sname( 10: 11 ).EQ.'sv' )THEN
1376 IF( full )THEN
1377 IF( trace )
1378 $ WRITE( ntra, fmt = 9993 )nc, sname,
1379 $ cuplo, ctrans, cdiag, n, lda, incx
1380 IF( rewi )
1381 $ rewind ntra
1382 CALL cstrsv( iorder, uplo, trans, diag,
1383 $ n, aa, lda, xx, incx )
1384 ELSE IF( banded )THEN
1385 IF( trace )
1386 $ WRITE( ntra, fmt = 9994 )nc, sname,
1387 $ cuplo, ctrans, cdiag, n, k, lda, incx
1388 IF( rewi )
1389 $ rewind ntra
1390 CALL cstbsv( iorder, uplo, trans, diag,
1391 $ n, k, aa, lda, xx, incx )
1392 ELSE IF( packed )THEN
1393 IF( trace )
1394 $ WRITE( ntra, fmt = 9995 )nc, sname,
1395 $ cuplo, ctrans, cdiag, n, incx
1396 IF( rewi )
1397 $ rewind ntra
1398 CALL cstpsv( iorder, uplo, trans, diag,
1399 $ n, aa, xx, incx )
1400 END IF
1401 END IF
1402*
1403* Check if error-exit was taken incorrectly.
1404*
1405 IF( .NOT.ok )THEN
1406 WRITE( nout, fmt = 9992 )
1407 fatal = .true.
1408 GO TO 120
1409 END IF
1410*
1411* See what data changed inside subroutines.
1412*
1413 isame( 1 ) = uplo.EQ.uplos
1414 isame( 2 ) = trans.EQ.transs
1415 isame( 3 ) = diag.EQ.diags
1416 isame( 4 ) = ns.EQ.n
1417 IF( full )THEN
1418 isame( 5 ) = lse( as, aa, laa )
1419 isame( 6 ) = ldas.EQ.lda
1420 IF( null )THEN
1421 isame( 7 ) = lse( xs, xx, lx )
1422 ELSE
1423 isame( 7 ) = lseres( 'ge', ' ', 1, n, xs,
1424 $ xx, abs( incx ) )
1425 END IF
1426 isame( 8 ) = incxs.EQ.incx
1427 ELSE IF( banded )THEN
1428 isame( 5 ) = ks.EQ.k
1429 isame( 6 ) = lse( as, aa, laa )
1430 isame( 7 ) = ldas.EQ.lda
1431 IF( null )THEN
1432 isame( 8 ) = lse( xs, xx, lx )
1433 ELSE
1434 isame( 8 ) = lseres( 'ge', ' ', 1, n, xs,
1435 $ xx, abs( incx ) )
1436 END IF
1437 isame( 9 ) = incxs.EQ.incx
1438 ELSE IF( packed )THEN
1439 isame( 5 ) = lse( as, aa, laa )
1440 IF( null )THEN
1441 isame( 6 ) = lse( xs, xx, lx )
1442 ELSE
1443 isame( 6 ) = lseres( 'ge', ' ', 1, n, xs,
1444 $ xx, abs( incx ) )
1445 END IF
1446 isame( 7 ) = incxs.EQ.incx
1447 END IF
1448*
1449* If data was incorrectly changed, report and
1450* return.
1451*
1452 same = .true.
1453 DO 40 i = 1, nargs
1454 same = same.AND.isame( i )
1455 IF( .NOT.isame( i ) )
1456 $ WRITE( nout, fmt = 9998 )i
1457 40 CONTINUE
1458 IF( .NOT.same )THEN
1459 fatal = .true.
1460 GO TO 120
1461 END IF
1462*
1463 IF( .NOT.null )THEN
1464 IF( sname( 10: 11 ).EQ.'mv' )THEN
1465*
1466* Check the result.
1467*
1468 CALL smvch( trans, n, n, one, a, nmax, x,
1469 $ incx, zero, z, incx, xt, g,
1470 $ xx, eps, err, fatal, nout,
1471 $ .true. )
1472 ELSE IF( sname( 10: 11 ).EQ.'sv' )THEN
1473*
1474* Compute approximation to original vector.
1475*
1476 DO 50 i = 1, n
1477 z( i ) = xx( 1 + ( i - 1 )*
1478 $ abs( incx ) )
1479 xx( 1 + ( i - 1 )*abs( incx ) )
1480 $ = x( i )
1481 50 CONTINUE
1482 CALL smvch( trans, n, n, one, a, nmax, z,
1483 $ incx, zero, x, incx, xt, g,
1484 $ xx, eps, err, fatal, nout,
1485 $ .false. )
1486 END IF
1487 errmax = max( errmax, err )
1488* If got really bad answer, report and return.
1489 IF( fatal )
1490 $ GO TO 120
1491 ELSE
1492* Avoid repeating tests with N.le.0.
1493 GO TO 110
1494 END IF
1495*
1496 60 CONTINUE
1497*
1498 70 CONTINUE
1499*
1500 80 CONTINUE
1501*
1502 90 CONTINUE
1503*
1504 100 CONTINUE
1505*
1506 110 CONTINUE
1507*
1508* Report result.
1509*
1510 IF( errmax.LT.thresh )THEN
1511 IF ( iorder.EQ.0) WRITE( nout, fmt = 10000 )sname, nc
1512 IF ( iorder.EQ.1) WRITE( nout, fmt = 10001 )sname, nc
1513 ELSE
1514 IF ( iorder.EQ.0) WRITE( nout, fmt = 10002 )sname, nc, errmax
1515 IF ( iorder.EQ.1) WRITE( nout, fmt = 10003 )sname, nc, errmax
1516 END IF
1517 GO TO 130
1518*
1519 120 CONTINUE
1520 WRITE( nout, fmt = 9996 )sname
1521 IF( full )THEN
1522 WRITE( nout, fmt = 9993 )nc, sname, cuplo, ctrans, cdiag, n,
1523 $ lda, incx
1524 ELSE IF( banded )THEN
1525 WRITE( nout, fmt = 9994 )nc, sname, cuplo, ctrans, cdiag, n,
1526 $ k, lda, incx
1527 ELSE IF( packed )THEN
1528 WRITE( nout, fmt = 9995 )nc, sname, cuplo, ctrans, cdiag, n,
1529 $ incx
1530 END IF
1531*
1532 130 CONTINUE
1533 RETURN
1534*
153510003 FORMAT( ' ', a12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
1536 $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1537 $ 'RATIO ', f8.2, ' - SUSPECT *******' )
153810002 FORMAT( ' ', a12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
1539 $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1540 $ 'RATIO ', f8.2, ' - SUSPECT *******' )
154110001 FORMAT( ' ', a12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
1542 $ ' (', i6, ' CALL', 'S)' )
154310000 FORMAT( ' ', a12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
1544 $ ' (', i6, ' CALL', 'S)' )
1545 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
1546 $ 'ANGED INCORRECTLY *******' )
1547 9997 FORMAT( ' ',a12, ' COMPLETED THE COMPUTATIONAL TESTS (', i6, ' C',
1548 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
1549 $ ' - SUSPECT *******' )
1550 9996 FORMAT( ' ******* ',a12, ' FAILED ON CALL NUMBER:' )
1551 9995 FORMAT( 1x, i6, ': ',a12, '(', 3( a14,',' ),/ 10x, i3, ', AP, ',
1552 $ 'X,', i2, ') .' )
1553 9994 FORMAT( 1x, i6, ': ',a12, '(', 3( a14,',' ),/ 10x, 2( i3, ',' ),
1554 $ ' A,', i3, ', X,', i2, ') .' )
1555 9993 FORMAT( 1x, i6, ': ',a12, '(', 3( a14,',' ),/ 10x, i3, ', A,',
1556 $ i3, ', X,', i2, ') .' )
1557 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1558 $ '******' )
1559*
1560* End of SCHK3.
1561*
smvch
subroutine smvch(trans, m, n, alpha, a, nmax, x, incx, beta, y, incy, yt, g, yy, eps, err, fatal, nout, mv)
Definition sblat2.f:2854
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
Here is the call graph for this function: