LAPACK  3.9.0
LAPACK: Linear Algebra PACKage

◆ 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 1058 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 *
1349 10003 FORMAT( ' ', a12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
1350  $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1351  $ 'RATIO ', f8.2, ' - SUSPECT *******' )
1352 10002 FORMAT( ' ', a12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
1353  $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1354  $ 'RATIO ', f8.2, ' - SUSPECT *******' )
1355 10001 FORMAT( ' ', a12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
1356  $ ' (', i6, ' CALL', 'S)' )
1357 10000 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 *
Here is the call graph for this function:
smake
subroutine smake(TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, KU, RESET, TRANSL)
Definition: sblat2.f:2653
lse
logical function lse(RI, RJ, LR)
Definition: sblat2.f:2945
lseres
logical function lseres(TYPE, UPLO, M, N, AA, AS, LDA)
Definition: sblat2.f:2975
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:2511
sprcn3
subroutine sprcn3(NOUT, NC, SNAME, IORDER, SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, LDA, LDB)
Definition: c_sblat3.f:1373