LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
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 1178 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 *
lzeres
logical function lzeres(TYPE, UPLO, M, N, AA, AS, LDA)
Definition: zblat2.f:3080
zmake
subroutine zmake(TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, KU, RESET, TRANSL)
Definition: zblat2.f:2726
lze
logical function lze(RI, RJ, LR)
Definition: zblat2.f:3050
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:2919

Here is the call graph for this function: