LAPACK 3.12.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches

◆ cchk3()

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 1173 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*
cmake
subroutine cmake(type, uplo, diag, m, n, a, nmax, aa, lda, kl, ku, reset, transl)
Definition cblat2.f:2744
lceres
logical function lceres(type, uplo, m, n, aa, as, lda)
Definition cblat2.f:3097
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:2936
lce
logical function lce(ri, rj, lr)
Definition cblat2.f:3067
Here is the call graph for this function: