LAPACK  3.9.0
LAPACK: Linear Algebra PACKage

◆ schk3()

subroutine schk3 ( character*6  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 
)

Definition at line 1117 of file sblat2.f.

1117 *
1118 * Tests STRMV, STBMV, STPMV, STRSV, STBSV and STPSV.
1119 *
1120 * Auxiliary routine for test program for Level 2 Blas.
1121 *
1122 * -- Written on 10-August-1987.
1123 * Richard Hanson, Sandia National Labs.
1124 * Jeremy Du Croz, NAG Central Office.
1125 *
1126 * .. Parameters ..
1127  REAL ZERO, HALF, ONE
1128  parameter( zero = 0.0, half = 0.5, one = 1.0 )
1129 * .. Scalar Arguments ..
1130  REAL EPS, THRESH
1131  INTEGER INCMAX, NIDIM, NINC, NKB, NMAX, NOUT, NTRA
1132  LOGICAL FATAL, REWI, TRACE
1133  CHARACTER*6 SNAME
1134 * .. Array Arguments ..
1135  REAL A( NMAX, NMAX ), AA( NMAX*NMAX ),
1136  $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ),
1137  $ XS( NMAX*INCMAX ), XT( NMAX ),
1138  $ XX( NMAX*INCMAX ), Z( NMAX )
1139  INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB )
1140 * .. Local Scalars ..
1141  REAL ERR, ERRMAX, TRANSL
1142  INTEGER I, ICD, ICT, ICU, IK, IN, INCX, INCXS, IX, K,
1143  $ KS, LAA, LDA, LDAS, LX, N, NARGS, NC, NK, NS
1144  LOGICAL BANDED, FULL, NULL, PACKED, RESET, SAME
1145  CHARACTER*1 DIAG, DIAGS, TRANS, TRANSS, UPLO, UPLOS
1146  CHARACTER*2 ICHD, ICHU
1147  CHARACTER*3 ICHT
1148 * .. Local Arrays ..
1149  LOGICAL ISAME( 13 )
1150 * .. External Functions ..
1151  LOGICAL LSE, LSERES
1152  EXTERNAL lse, lseres
1153 * .. External Subroutines ..
1154  EXTERNAL smake, smvch, stbmv, stbsv, stpmv, stpsv,
1155  $ strmv, strsv
1156 * .. Intrinsic Functions ..
1157  INTRINSIC abs, max
1158 * .. Scalars in Common ..
1159  INTEGER INFOT, NOUTC
1160  LOGICAL LERR, OK
1161 * .. Common blocks ..
1162  COMMON /infoc/infot, noutc, ok, lerr
1163 * .. Data statements ..
1164  DATA ichu/'UL'/, icht/'NTC'/, ichd/'UN'/
1165 * .. Executable Statements ..
1166  full = sname( 3: 3 ).EQ.'R'
1167  banded = sname( 3: 3 ).EQ.'B'
1168  packed = sname( 3: 3 ).EQ.'P'
1169 * Define the number of arguments.
1170  IF( full )THEN
1171  nargs = 8
1172  ELSE IF( banded )THEN
1173  nargs = 9
1174  ELSE IF( packed )THEN
1175  nargs = 7
1176  END IF
1177 *
1178  nc = 0
1179  reset = .true.
1180  errmax = zero
1181 * Set up zero vector for SMVCH.
1182  DO 10 i = 1, nmax
1183  z( i ) = zero
1184  10 CONTINUE
1185 *
1186  DO 110 in = 1, nidim
1187  n = idim( in )
1188 *
1189  IF( banded )THEN
1190  nk = nkb
1191  ELSE
1192  nk = 1
1193  END IF
1194  DO 100 ik = 1, nk
1195  IF( banded )THEN
1196  k = kb( ik )
1197  ELSE
1198  k = n - 1
1199  END IF
1200 * Set LDA to 1 more than minimum value if room.
1201  IF( banded )THEN
1202  lda = k + 1
1203  ELSE
1204  lda = n
1205  END IF
1206  IF( lda.LT.nmax )
1207  $ lda = lda + 1
1208 * Skip tests if not enough room.
1209  IF( lda.GT.nmax )
1210  $ GO TO 100
1211  IF( packed )THEN
1212  laa = ( n*( n + 1 ) )/2
1213  ELSE
1214  laa = lda*n
1215  END IF
1216  null = n.LE.0
1217 *
1218  DO 90 icu = 1, 2
1219  uplo = ichu( icu: icu )
1220 *
1221  DO 80 ict = 1, 3
1222  trans = icht( ict: ict )
1223 *
1224  DO 70 icd = 1, 2
1225  diag = ichd( icd: icd )
1226 *
1227 * Generate the matrix A.
1228 *
1229  transl = zero
1230  CALL smake( sname( 2: 3 ), uplo, diag, n, n, a,
1231  $ nmax, aa, lda, k, k, reset, transl )
1232 *
1233  DO 60 ix = 1, ninc
1234  incx = inc( ix )
1235  lx = abs( incx )*n
1236 *
1237 * Generate the vector X.
1238 *
1239  transl = half
1240  CALL smake( 'GE', ' ', ' ', 1, n, x, 1, xx,
1241  $ abs( incx ), 0, n - 1, reset,
1242  $ transl )
1243  IF( n.GT.1 )THEN
1244  x( n/2 ) = zero
1245  xx( 1 + abs( incx )*( n/2 - 1 ) ) = zero
1246  END IF
1247 *
1248  nc = nc + 1
1249 *
1250 * Save every datum before calling the subroutine.
1251 *
1252  uplos = uplo
1253  transs = trans
1254  diags = diag
1255  ns = n
1256  ks = k
1257  DO 20 i = 1, laa
1258  as( i ) = aa( i )
1259  20 CONTINUE
1260  ldas = lda
1261  DO 30 i = 1, lx
1262  xs( i ) = xx( i )
1263  30 CONTINUE
1264  incxs = incx
1265 *
1266 * Call the subroutine.
1267 *
1268  IF( sname( 4: 5 ).EQ.'MV' )THEN
1269  IF( full )THEN
1270  IF( trace )
1271  $ WRITE( ntra, fmt = 9993 )nc, sname,
1272  $ uplo, trans, diag, n, lda, incx
1273  IF( rewi )
1274  $ rewind ntra
1275  CALL strmv( uplo, trans, diag, n, aa, lda,
1276  $ xx, incx )
1277  ELSE IF( banded )THEN
1278  IF( trace )
1279  $ WRITE( ntra, fmt = 9994 )nc, sname,
1280  $ uplo, trans, diag, n, k, lda, incx
1281  IF( rewi )
1282  $ rewind ntra
1283  CALL stbmv( uplo, trans, diag, n, k, aa,
1284  $ lda, xx, incx )
1285  ELSE IF( packed )THEN
1286  IF( trace )
1287  $ WRITE( ntra, fmt = 9995 )nc, sname,
1288  $ uplo, trans, diag, n, incx
1289  IF( rewi )
1290  $ rewind ntra
1291  CALL stpmv( uplo, trans, diag, n, aa, xx,
1292  $ incx )
1293  END IF
1294  ELSE IF( sname( 4: 5 ).EQ.'SV' )THEN
1295  IF( full )THEN
1296  IF( trace )
1297  $ WRITE( ntra, fmt = 9993 )nc, sname,
1298  $ uplo, trans, diag, n, lda, incx
1299  IF( rewi )
1300  $ rewind ntra
1301  CALL strsv( uplo, trans, diag, n, aa, lda,
1302  $ xx, incx )
1303  ELSE IF( banded )THEN
1304  IF( trace )
1305  $ WRITE( ntra, fmt = 9994 )nc, sname,
1306  $ uplo, trans, diag, n, k, lda, incx
1307  IF( rewi )
1308  $ rewind ntra
1309  CALL stbsv( uplo, trans, diag, n, k, aa,
1310  $ lda, xx, incx )
1311  ELSE IF( packed )THEN
1312  IF( trace )
1313  $ WRITE( ntra, fmt = 9995 )nc, sname,
1314  $ uplo, trans, diag, n, incx
1315  IF( rewi )
1316  $ rewind ntra
1317  CALL stpsv( uplo, trans, diag, n, aa, xx,
1318  $ incx )
1319  END IF
1320  END IF
1321 *
1322 * Check if error-exit was taken incorrectly.
1323 *
1324  IF( .NOT.ok )THEN
1325  WRITE( nout, fmt = 9992 )
1326  fatal = .true.
1327  GO TO 120
1328  END IF
1329 *
1330 * See what data changed inside subroutines.
1331 *
1332  isame( 1 ) = uplo.EQ.uplos
1333  isame( 2 ) = trans.EQ.transs
1334  isame( 3 ) = diag.EQ.diags
1335  isame( 4 ) = ns.EQ.n
1336  IF( full )THEN
1337  isame( 5 ) = lse( as, aa, laa )
1338  isame( 6 ) = ldas.EQ.lda
1339  IF( null )THEN
1340  isame( 7 ) = lse( xs, xx, lx )
1341  ELSE
1342  isame( 7 ) = lseres( 'GE', ' ', 1, n, xs,
1343  $ xx, abs( incx ) )
1344  END IF
1345  isame( 8 ) = incxs.EQ.incx
1346  ELSE IF( banded )THEN
1347  isame( 5 ) = ks.EQ.k
1348  isame( 6 ) = lse( as, aa, laa )
1349  isame( 7 ) = ldas.EQ.lda
1350  IF( null )THEN
1351  isame( 8 ) = lse( xs, xx, lx )
1352  ELSE
1353  isame( 8 ) = lseres( 'GE', ' ', 1, n, xs,
1354  $ xx, abs( incx ) )
1355  END IF
1356  isame( 9 ) = incxs.EQ.incx
1357  ELSE IF( packed )THEN
1358  isame( 5 ) = lse( as, aa, laa )
1359  IF( null )THEN
1360  isame( 6 ) = lse( xs, xx, lx )
1361  ELSE
1362  isame( 6 ) = lseres( 'GE', ' ', 1, n, xs,
1363  $ xx, abs( incx ) )
1364  END IF
1365  isame( 7 ) = incxs.EQ.incx
1366  END IF
1367 *
1368 * If data was incorrectly changed, report and
1369 * return.
1370 *
1371  same = .true.
1372  DO 40 i = 1, nargs
1373  same = same.AND.isame( i )
1374  IF( .NOT.isame( i ) )
1375  $ WRITE( nout, fmt = 9998 )i
1376  40 CONTINUE
1377  IF( .NOT.same )THEN
1378  fatal = .true.
1379  GO TO 120
1380  END IF
1381 *
1382  IF( .NOT.null )THEN
1383  IF( sname( 4: 5 ).EQ.'MV' )THEN
1384 *
1385 * Check the result.
1386 *
1387  CALL smvch( trans, n, n, one, a, nmax, x,
1388  $ incx, zero, z, incx, xt, g,
1389  $ xx, eps, err, fatal, nout,
1390  $ .true. )
1391  ELSE IF( sname( 4: 5 ).EQ.'SV' )THEN
1392 *
1393 * Compute approximation to original vector.
1394 *
1395  DO 50 i = 1, n
1396  z( i ) = xx( 1 + ( i - 1 )*
1397  $ abs( incx ) )
1398  xx( 1 + ( i - 1 )*abs( incx ) )
1399  $ = x( i )
1400  50 CONTINUE
1401  CALL smvch( trans, n, n, one, a, nmax, z,
1402  $ incx, zero, x, incx, xt, g,
1403  $ xx, eps, err, fatal, nout,
1404  $ .false. )
1405  END IF
1406  errmax = max( errmax, err )
1407 * If got really bad answer, report and return.
1408  IF( fatal )
1409  $ GO TO 120
1410  ELSE
1411 * Avoid repeating tests with N.le.0.
1412  GO TO 110
1413  END IF
1414 *
1415  60 CONTINUE
1416 *
1417  70 CONTINUE
1418 *
1419  80 CONTINUE
1420 *
1421  90 CONTINUE
1422 *
1423  100 CONTINUE
1424 *
1425  110 CONTINUE
1426 *
1427 * Report result.
1428 *
1429  IF( errmax.LT.thresh )THEN
1430  WRITE( nout, fmt = 9999 )sname, nc
1431  ELSE
1432  WRITE( nout, fmt = 9997 )sname, nc, errmax
1433  END IF
1434  GO TO 130
1435 *
1436  120 CONTINUE
1437  WRITE( nout, fmt = 9996 )sname
1438  IF( full )THEN
1439  WRITE( nout, fmt = 9993 )nc, sname, uplo, trans, diag, n, lda,
1440  $ incx
1441  ELSE IF( banded )THEN
1442  WRITE( nout, fmt = 9994 )nc, sname, uplo, trans, diag, n, k,
1443  $ lda, incx
1444  ELSE IF( packed )THEN
1445  WRITE( nout, fmt = 9995 )nc, sname, uplo, trans, diag, n, incx
1446  END IF
1447 *
1448  130 CONTINUE
1449  RETURN
1450 *
1451  9999 FORMAT( ' ', a6, ' PASSED THE COMPUTATIONAL TESTS (', i6, ' CALL',
1452  $ 'S)' )
1453  9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
1454  $ 'ANGED INCORRECTLY *******' )
1455  9997 FORMAT( ' ', a6, ' COMPLETED THE COMPUTATIONAL TESTS (', i6, ' C',
1456  $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
1457  $ ' - SUSPECT *******' )
1458  9996 FORMAT( ' ******* ', a6, ' FAILED ON CALL NUMBER:' )
1459  9995 FORMAT( 1x, i6, ': ', a6, '(', 3( '''', a1, ''',' ), i3, ', AP, ',
1460  $ 'X,', i2, ') .' )
1461  9994 FORMAT( 1x, i6, ': ', a6, '(', 3( '''', a1, ''',' ), 2( i3, ',' ),
1462  $ ' A,', i3, ', X,', i2, ') .' )
1463  9993 FORMAT( 1x, i6, ': ', a6, '(', 3( '''', a1, ''',' ), i3, ', A,',
1464  $ i3, ', X,', i2, ') .' )
1465  9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1466  $ '******' )
1467 *
1468 * End of SCHK3.
1469 *
Here is the call graph for this function:
Here is the caller graph for this function:
strmv
subroutine strmv(UPLO, TRANS, DIAG, N, A, LDA, X, INCX)
STRMV
Definition: strmv.f:149
stpsv
subroutine stpsv(UPLO, TRANS, DIAG, N, AP, X, INCX)
STPSV
Definition: stpsv.f:146
strsv
subroutine strsv(UPLO, TRANS, DIAG, N, A, LDA, X, INCX)
STRSV
Definition: strsv.f:151
stbsv
subroutine stbsv(UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX)
STBSV
Definition: stbsv.f:191
smake
subroutine smake(TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, KU, RESET, TRANSL)
Definition: sblat2.f:2653
stbmv
subroutine stbmv(UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX)
STBMV
Definition: stbmv.f:188
lse
logical function lse(RI, RJ, LR)
Definition: sblat2.f:2945
stpmv
subroutine stpmv(UPLO, TRANS, DIAG, N, AP, X, INCX)
STPMV
Definition: stpmv.f:144
lseres
logical function lseres(TYPE, UPLO, M, N, AA, AS, LDA)
Definition: sblat2.f:2975
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