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

◆ cchk3()

subroutine cchk3 ( character*6  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 
)

Definition at line 1155 of file cblat2.f.

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