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

◆ zchk3()

subroutine zchk3 ( character*6  sname,
double precision  eps,
double precision  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,
complex*16, dimension( nmax, nmax )  a,
complex*16, dimension( nmax*nmax )  aa,
complex*16, dimension( nmax*nmax )  as,
complex*16, dimension( nmax )  x,
complex*16, dimension( nmax*incmax )  xx,
complex*16, dimension( nmax*incmax )  xs,
complex*16, dimension( nmax )  xt,
double precision, dimension( nmax )  g,
complex*16, dimension( nmax )  z 
)

Definition at line 1158 of file zblat2.f.

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