LAPACK  3.9.1
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 1127 of file cblat2.f.

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