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

◆ 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 1139 of file sblat2.f.

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