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

◆ schk3()

subroutine schk3 ( 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,
real, dimension( nalf ) alf,
integer nmax,
real, dimension( nmax, nmax ) a,
real, dimension( nmax*nmax ) aa,
real, dimension( nmax*nmax ) as,
real, dimension( nmax, nmax ) b,
real, dimension( nmax*nmax ) bb,
real, dimension( nmax*nmax ) bs,
real, dimension( nmax ) ct,
real, dimension( nmax ) g,
real, dimension( nmax, nmax ) c,
integer iorder )

Definition at line 1073 of file c_sblat3.f.

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