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

◆ zchk3()

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

Definition at line 1078 of file c_zblat3.f.

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