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

◆ cchk3()

subroutine cchk3 ( 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,
complex, dimension( nalf )  alf,
integer  nmax,
complex, dimension( nmax, nmax )  a,
complex, dimension( nmax*nmax )  aa,
complex, dimension( nmax*nmax )  as,
complex, dimension( nmax, nmax )  b,
complex, dimension( nmax*nmax )  bb,
complex, dimension( nmax*nmax )  bs,
complex, dimension( nmax )  ct,
real, dimension( nmax )  g,
complex, dimension( nmax, nmax )  c,
integer  iorder 
)

Definition at line 1077 of file c_cblat3.f.

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