LAPACK  3.9.0
LAPACK: Linear Algebra PACKage

◆ 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 1054 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 *
1345 10003 FORMAT( ' ', a12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
1346  $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1347  $ 'RATIO ', f8.2, ' - SUSPECT *******' )
1348 10002 FORMAT( ' ', a12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
1349  $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1350  $ 'RATIO ', f8.2, ' - SUSPECT *******' )
1351 10001 FORMAT( ' ', a12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
1352  $ ' (', i6, ' CALL', 'S)' )
1353 10000 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 *
Here is the call graph for this function:
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:2511
lde
logical function lde(RI, RJ, LR)
Definition: dblat2.f:2945
dmake
subroutine dmake(TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, KU, RESET, TRANSL)
Definition: dblat2.f:2653
dprcn3
subroutine dprcn3(NOUT, NC, SNAME, IORDER, SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, LDA, LDB)
Definition: c_dblat3.f:1369
lderes
logical function lderes(TYPE, UPLO, M, N, AA, AS, LDA)
Definition: dblat2.f:2975