LAPACK  3.9.0
LAPACK: Linear Algebra PACKage

◆ 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  NALF,
complex, dimension( nalf )  ALF,
integer  NMAX,
complex, dimension( nmax, nmax )  A,
complex, dimension( nmax*nmax )  AA,
complex, dimension( nmax*nmax )  AS,
complex, dimension( nmax, nmax )  B,
complex, dimension( nmax*nmax )  BB,
complex, dimension( nmax*nmax )  BS,
complex, dimension( nmax )  CT,
real, dimension( nmax )  G,
complex, dimension( nmax, nmax )  C,
integer  IORDER 
)

Definition at line 1080 of file c_cblat3.f.

1080 *
1081 * Tests CTRMM and CTRSM.
1082 *
1083 * Auxiliary routine for test program for Level 3 Blas.
1084 *
1085 * -- Written on 8-February-1989.
1086 * Jack Dongarra, Argonne National Laboratory.
1087 * Iain Duff, AERE Harwell.
1088 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
1089 * Sven Hammarling, Numerical Algorithms Group Ltd.
1090 *
1091 * .. Parameters ..
1092  COMPLEX ZERO, ONE
1093  parameter( zero = ( 0.0, 0.0 ), one = ( 1.0, 0.0 ) )
1094  REAL RZERO
1095  parameter( rzero = 0.0 )
1096 * .. Scalar Arguments ..
1097  REAL EPS, THRESH
1098  INTEGER NALF, NIDIM, NMAX, NOUT, NTRA, IORDER
1099  LOGICAL FATAL, REWI, TRACE
1100  CHARACTER*12 SNAME
1101 * .. Array Arguments ..
1102  COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
1103  $ AS( NMAX*NMAX ), B( NMAX, NMAX ),
1104  $ BB( NMAX*NMAX ), BS( NMAX*NMAX ),
1105  $ C( NMAX, NMAX ), CT( NMAX )
1106  REAL G( NMAX )
1107  INTEGER IDIM( NIDIM )
1108 * .. Local Scalars ..
1109  COMPLEX ALPHA, ALS
1110  REAL ERR, ERRMAX
1111  INTEGER I, IA, ICD, ICS, ICT, ICU, IM, IN, J, LAA, LBB,
1112  $ LDA, LDAS, LDB, LDBS, M, MS, N, NA, NARGS, NC,
1113  $ NS
1114  LOGICAL LEFT, NULL, RESET, SAME
1115  CHARACTER*1 DIAG, DIAGS, SIDE, SIDES, TRANAS, TRANSA, UPLO,
1116  $ UPLOS
1117  CHARACTER*2 ICHD, ICHS, ICHU
1118  CHARACTER*3 ICHT
1119 * .. Local Arrays ..
1120  LOGICAL ISAME( 13 )
1121 * .. External Functions ..
1122  LOGICAL LCE, LCERES
1123  EXTERNAL lce, lceres
1124 * .. External Subroutines ..
1125  EXTERNAL cmake, cmmch, cctrmm, cctrsm
1126 * .. Intrinsic Functions ..
1127  INTRINSIC max
1128 * .. Scalars in Common ..
1129  INTEGER INFOT, NOUTC
1130  LOGICAL LERR, OK
1131 * .. Common blocks ..
1132  COMMON /infoc/infot, noutc, ok, lerr
1133 * .. Data statements ..
1134  DATA ichu/'UL'/, icht/'NTC'/, ichd/'UN'/, ichs/'LR'/
1135 * .. Executable Statements ..
1136 *
1137  nargs = 11
1138  nc = 0
1139  reset = .true.
1140  errmax = rzero
1141 * Set up zero matrix for CMMCH.
1142  DO 20 j = 1, nmax
1143  DO 10 i = 1, nmax
1144  c( i, j ) = zero
1145  10 CONTINUE
1146  20 CONTINUE
1147 *
1148  DO 140 im = 1, nidim
1149  m = idim( im )
1150 *
1151  DO 130 in = 1, nidim
1152  n = idim( in )
1153 * Set LDB to 1 more than minimum value if room.
1154  ldb = m
1155  IF( ldb.LT.nmax )
1156  $ ldb = ldb + 1
1157 * Skip tests if not enough room.
1158  IF( ldb.GT.nmax )
1159  $ GO TO 130
1160  lbb = ldb*n
1161  null = m.LE.0.OR.n.LE.0
1162 *
1163  DO 120 ics = 1, 2
1164  side = ichs( ics: ics )
1165  left = side.EQ.'L'
1166  IF( left )THEN
1167  na = m
1168  ELSE
1169  na = n
1170  END IF
1171 * Set LDA to 1 more than minimum value if room.
1172  lda = na
1173  IF( lda.LT.nmax )
1174  $ lda = lda + 1
1175 * Skip tests if not enough room.
1176  IF( lda.GT.nmax )
1177  $ GO TO 130
1178  laa = lda*na
1179 *
1180  DO 110 icu = 1, 2
1181  uplo = ichu( icu: icu )
1182 *
1183  DO 100 ict = 1, 3
1184  transa = icht( ict: ict )
1185 *
1186  DO 90 icd = 1, 2
1187  diag = ichd( icd: icd )
1188 *
1189  DO 80 ia = 1, nalf
1190  alpha = alf( ia )
1191 *
1192 * Generate the matrix A.
1193 *
1194  CALL cmake( 'tr', uplo, diag, na, na, a,
1195  $ nmax, aa, lda, reset, zero )
1196 *
1197 * Generate the matrix B.
1198 *
1199  CALL cmake( 'ge', ' ', ' ', m, n, b, nmax,
1200  $ bb, ldb, reset, zero )
1201 *
1202  nc = nc + 1
1203 *
1204 * Save every datum before calling the
1205 * subroutine.
1206 *
1207  sides = side
1208  uplos = uplo
1209  tranas = transa
1210  diags = diag
1211  ms = m
1212  ns = n
1213  als = alpha
1214  DO 30 i = 1, laa
1215  as( i ) = aa( i )
1216  30 CONTINUE
1217  ldas = lda
1218  DO 40 i = 1, lbb
1219  bs( i ) = bb( i )
1220  40 CONTINUE
1221  ldbs = ldb
1222 *
1223 * Call the subroutine.
1224 *
1225  IF( sname( 10: 11 ).EQ.'mm' )THEN
1226  IF( trace )
1227  $ CALL cprcn3( ntra, nc, sname, iorder,
1228  $ side, uplo, transa, diag, m, n, alpha,
1229  $ lda, ldb)
1230  IF( rewi )
1231  $ rewind ntra
1232  CALL cctrmm(iorder, side, uplo, transa,
1233  $ diag, m, n, alpha, aa, lda,
1234  $ bb, ldb )
1235  ELSE IF( sname( 10: 11 ).EQ.'sm' )THEN
1236  IF( trace )
1237  $ CALL cprcn3( ntra, nc, sname, iorder,
1238  $ side, uplo, transa, diag, m, n, alpha,
1239  $ lda, ldb)
1240  IF( rewi )
1241  $ rewind ntra
1242  CALL cctrsm(iorder, side, uplo, transa,
1243  $ diag, m, n, alpha, aa, lda,
1244  $ bb, ldb )
1245  END IF
1246 *
1247 * Check if error-exit was taken incorrectly.
1248 *
1249  IF( .NOT.ok )THEN
1250  WRITE( nout, fmt = 9994 )
1251  fatal = .true.
1252  GO TO 150
1253  END IF
1254 *
1255 * See what data changed inside subroutines.
1256 *
1257  isame( 1 ) = sides.EQ.side
1258  isame( 2 ) = uplos.EQ.uplo
1259  isame( 3 ) = tranas.EQ.transa
1260  isame( 4 ) = diags.EQ.diag
1261  isame( 5 ) = ms.EQ.m
1262  isame( 6 ) = ns.EQ.n
1263  isame( 7 ) = als.EQ.alpha
1264  isame( 8 ) = lce( as, aa, laa )
1265  isame( 9 ) = ldas.EQ.lda
1266  IF( null )THEN
1267  isame( 10 ) = lce( bs, bb, lbb )
1268  ELSE
1269  isame( 10 ) = lceres( 'ge', ' ', m, n, bs,
1270  $ bb, ldb )
1271  END IF
1272  isame( 11 ) = ldbs.EQ.ldb
1273 *
1274 * If data was incorrectly changed, report and
1275 * return.
1276 *
1277  same = .true.
1278  DO 50 i = 1, nargs
1279  same = same.AND.isame( i )
1280  IF( .NOT.isame( i ) )
1281  $ WRITE( nout, fmt = 9998 )i
1282  50 CONTINUE
1283  IF( .NOT.same )THEN
1284  fatal = .true.
1285  GO TO 150
1286  END IF
1287 *
1288  IF( .NOT.null )THEN
1289  IF( sname( 10: 11 ).EQ.'mm' )THEN
1290 *
1291 * Check the result.
1292 *
1293  IF( left )THEN
1294  CALL cmmch( transa, 'N', m, n, m,
1295  $ alpha, a, nmax, b, nmax,
1296  $ zero, c, nmax, ct, g,
1297  $ bb, ldb, eps, err,
1298  $ fatal, nout, .true. )
1299  ELSE
1300  CALL cmmch( 'N', transa, m, n, n,
1301  $ alpha, b, nmax, a, nmax,
1302  $ zero, c, nmax, ct, g,
1303  $ bb, ldb, eps, err,
1304  $ fatal, nout, .true. )
1305  END IF
1306  ELSE IF( sname( 10: 11 ).EQ.'sm' )THEN
1307 *
1308 * Compute approximation to original
1309 * matrix.
1310 *
1311  DO 70 j = 1, n
1312  DO 60 i = 1, m
1313  c( i, j ) = bb( i + ( j - 1 )*
1314  $ ldb )
1315  bb( i + ( j - 1 )*ldb ) = alpha*
1316  $ b( i, j )
1317  60 CONTINUE
1318  70 CONTINUE
1319 *
1320  IF( left )THEN
1321  CALL cmmch( transa, 'N', m, n, m,
1322  $ one, a, nmax, c, nmax,
1323  $ zero, b, nmax, ct, g,
1324  $ bb, ldb, eps, err,
1325  $ fatal, nout, .false. )
1326  ELSE
1327  CALL cmmch( 'N', transa, m, n, n,
1328  $ one, c, nmax, a, nmax,
1329  $ zero, b, nmax, ct, g,
1330  $ bb, ldb, eps, err,
1331  $ fatal, nout, .false. )
1332  END IF
1333  END IF
1334  errmax = max( errmax, err )
1335 * If got really bad answer, report and
1336 * return.
1337  IF( fatal )
1338  $ GO TO 150
1339  END IF
1340 *
1341  80 CONTINUE
1342 *
1343  90 CONTINUE
1344 *
1345  100 CONTINUE
1346 *
1347  110 CONTINUE
1348 *
1349  120 CONTINUE
1350 *
1351  130 CONTINUE
1352 *
1353  140 CONTINUE
1354 *
1355 * Report result.
1356 *
1357  IF( errmax.LT.thresh )THEN
1358  IF ( iorder.EQ.0) WRITE( nout, fmt = 10000 )sname, nc
1359  IF ( iorder.EQ.1) WRITE( nout, fmt = 10001 )sname, nc
1360  ELSE
1361  IF ( iorder.EQ.0) WRITE( nout, fmt = 10002 )sname, nc, errmax
1362  IF ( iorder.EQ.1) WRITE( nout, fmt = 10003 )sname, nc, errmax
1363  END IF
1364  GO TO 160
1365 *
1366  150 CONTINUE
1367  WRITE( nout, fmt = 9996 )sname
1368  IF( trace )
1369  $ CALL cprcn3( ntra, nc, sname, iorder, side, uplo, transa, diag,
1370  $ m, n, alpha, lda, ldb)
1371 *
1372  160 CONTINUE
1373  RETURN
1374 *
1375 10003 FORMAT( ' ', a12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
1376  $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1377  $ 'RATIO ', f8.2, ' - SUSPECT *******' )
1378 10002 FORMAT( ' ', a12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
1379  $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1380  $ 'RATIO ', f8.2, ' - SUSPECT *******' )
1381 10001 FORMAT( ' ', a12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
1382  $ ' (', i6, ' CALL', 'S)' )
1383 10000 FORMAT( ' ', a12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
1384  $ ' (', i6, ' CALL', 'S)' )
1385  9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
1386  $ 'ANGED INCORRECTLY *******' )
1387  9996 FORMAT(' ******* ', a12,' FAILED ON CALL NUMBER:' )
1388  9995 FORMAT(1x, i6, ': ', a12,'(', 4( '''', a1, ''',' ), 2( i3, ',' ),
1389  $ '(', f4.1, ',', f4.1, '), A,', i3, ', B,', i3, ') ',
1390  $ ' .' )
1391  9994 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1392  $ '******' )
1393 *
1394 * End of CCHK3.
1395 *
Here is the call 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
cmmch
subroutine cmmch(TRANSA, TRANSB, M, N, KK, ALPHA, A, LDA, B, LDB, BETA, C, LDC, CT, G, CC, LDCC, EPS, ERR, FATAL, NOUT, MV)
Definition: cblat3.f:3056
cprcn3
subroutine cprcn3(NOUT, NC, SNAME, IORDER, SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, LDA, LDB)
Definition: c_cblat3.f:1400
lce
logical function lce(RI, RJ, LR)
Definition: cblat2.f:3042