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

◆ dchk3()

subroutine dchk3 ( character*12  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 1051 of file c_dblat3.f.

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