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

◆ cchk3()

subroutine cchk3 ( character*13 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 1093 of file c_cblat3.f.

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