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

◆ zchk3()

subroutine zchk3 ( character*12  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,
integer  iorder 
)

Definition at line 1175 of file c_zblat2.f.

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