LAPACK  3.10.0
LAPACK: Linear Algebra PACKage

◆ 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 1130 of file zblat2.f.

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