LAPACK  3.9.0
LAPACK: Linear Algebra PACKage

◆ 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 1081 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 *
1376 10003 FORMAT( ' ', a12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
1377  $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1378  $ 'RATIO ', f8.2, ' - SUSPECT *******' )
1379 10002 FORMAT( ' ', a12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
1380  $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1381  $ 'RATIO ', f8.2, ' - SUSPECT *******' )
1382 10001 FORMAT( ' ', a12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
1383  $ ' (', i6, ' CALL', 'S)' )
1384 10000 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 *
Here is the call graph for this function:
zmake
subroutine zmake(TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, KU, RESET, TRANSL)
Definition: zblat2.f:2726
lzeres
logical function lzeres(TYPE, UPLO, M, N, AA, AS, LDA)
Definition: zblat2.f:3080
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:3050
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:3064