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

◆ schk3()

subroutine schk3 ( 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,
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 1055 of file c_sblat3.f.

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