LAPACK  3.6.1 LAPACK: Linear Algebra PACKage
 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 1136 of file zblat2.f.

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

Here is the caller graph for this function: