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 *
ztrsv
subroutine ztrsv(UPLO, TRANS, DIAG, N, A, LDA, X, INCX)
ZTRSV
Definition: ztrsv.f:151
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
ztbmv
subroutine ztbmv(UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX)
ZTBMV
Definition: ztbmv.f:188
ztpsv
subroutine ztpsv(UPLO, TRANS, DIAG, N, AP, X, INCX)
ZTPSV
Definition: ztpsv.f:146
ztpmv
subroutine ztpmv(UPLO, TRANS, DIAG, N, AP, X, INCX)
ZTPMV
Definition: ztpmv.f:144
lze
logical function lze(RI, RJ, LR)
Definition: zblat2.f:3050
ztbsv
subroutine ztbsv(UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX)
ZTBSV
Definition: ztbsv.f:191
ztrmv
subroutine ztrmv(UPLO, TRANS, DIAG, N, A, LDA, X, INCX)
ZTRMV
Definition: ztrmv.f:149
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:

Here is the caller graph for this function: