LAPACK  3.9.0
LAPACK: Linear Algebra PACKage

◆ 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 1133 of file cblat2.f.

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