LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
subroutine cchk3 ( character*12  SNAME,
real  EPS,
real  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, dimension( nmax, nmax )  A,
complex, dimension( nmax*nmax )  AA,
complex, dimension( nmax*nmax )  AS,
complex, dimension( nmax )  X,
complex, dimension( nmax*incmax )  XX,
complex, dimension( nmax*incmax )  XS,
complex, dimension( nmax )  XT,
real, dimension( nmax )  G,
complex, dimension( nmax )  Z,
integer  IORDER 
)

Definition at line 1176 of file c_cblat2.f.

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

Here is the call graph for this function: