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

◆ dchk3()

subroutine dchk3 ( character*13 sname,
double precision eps,
double precision thresh,
integer nout,
integer ntra,
logical trace,
logical rewi,
logical fatal,
integer nidim,
integer, dimension( nidim ) idim,
integer nalf,
double precision, dimension( nalf ) alf,
integer nmax,
double precision, dimension( nmax, nmax ) a,
double precision, dimension( nmax*nmax ) aa,
double precision, dimension( nmax*nmax ) as,
double precision, dimension( nmax, nmax ) b,
double precision, dimension( nmax*nmax ) bb,
double precision, dimension( nmax*nmax ) bs,
double precision, dimension( nmax ) ct,
double precision, dimension( nmax ) g,
double precision, dimension( nmax, nmax ) c,
integer iorder )

Definition at line 1067 of file c_dblat3.f.

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