LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
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 1179 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 *
1535 10003 FORMAT( ' ', a12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
1536  $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1537  $ 'RATIO ', f8.2, ' - SUSPECT *******' )
1538 10002 FORMAT( ' ', a12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
1539  $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1540  $ 'RATIO ', f8.2, ' - SUSPECT *******' )
1541 10001 FORMAT( ' ', a12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
1542  $ ' (', i6, ' CALL', 'S)' )
1543 10000 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 *
smake
subroutine smake(TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, KU, RESET, TRANSL)
Definition: sblat2.f:2653
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:2829
lse
logical function lse(RI, RJ, LR)
Definition: sblat2.f:2945
lseres
logical function lseres(TYPE, UPLO, M, N, AA, AS, LDA)
Definition: sblat2.f:2975

Here is the call graph for this function: