LAPACK  3.10.1
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 1111 of file sblat2.f.

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