LAPACK  3.9.0
LAPACK: Linear Algebra PACKage

◆ zchk3()

subroutine zchk3 ( character*6  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 
)

Definition at line 974 of file zblat3.f.

974 *
975 * Tests ZTRMM and ZTRSM.
976 *
977 * Auxiliary routine for test program for Level 3 Blas.
978 *
979 * -- Written on 8-February-1989.
980 * Jack Dongarra, Argonne National Laboratory.
981 * Iain Duff, AERE Harwell.
982 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
983 * Sven Hammarling, Numerical Algorithms Group Ltd.
984 *
985 * .. Parameters ..
986  COMPLEX*16 ZERO, ONE
987  parameter( zero = ( 0.0d0, 0.0d0 ),
988  $ one = ( 1.0d0, 0.0d0 ) )
989  DOUBLE PRECISION RZERO
990  parameter( rzero = 0.0d0 )
991 * .. Scalar Arguments ..
992  DOUBLE PRECISION EPS, THRESH
993  INTEGER NALF, NIDIM, NMAX, NOUT, NTRA
994  LOGICAL FATAL, REWI, TRACE
995  CHARACTER*6 SNAME
996 * .. Array Arguments ..
997  COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
998  $ AS( NMAX*NMAX ), B( NMAX, NMAX ),
999  $ BB( NMAX*NMAX ), BS( NMAX*NMAX ),
1000  $ C( NMAX, NMAX ), CT( NMAX )
1001  DOUBLE PRECISION G( NMAX )
1002  INTEGER IDIM( NIDIM )
1003 * .. Local Scalars ..
1004  COMPLEX*16 ALPHA, ALS
1005  DOUBLE PRECISION ERR, ERRMAX
1006  INTEGER I, IA, ICD, ICS, ICT, ICU, IM, IN, J, LAA, LBB,
1007  $ LDA, LDAS, LDB, LDBS, M, MS, N, NA, NARGS, NC,
1008  $ NS
1009  LOGICAL LEFT, NULL, RESET, SAME
1010  CHARACTER*1 DIAG, DIAGS, SIDE, SIDES, TRANAS, TRANSA, UPLO,
1011  $ UPLOS
1012  CHARACTER*2 ICHD, ICHS, ICHU
1013  CHARACTER*3 ICHT
1014 * .. Local Arrays ..
1015  LOGICAL ISAME( 13 )
1016 * .. External Functions ..
1017  LOGICAL LZE, LZERES
1018  EXTERNAL lze, lzeres
1019 * .. External Subroutines ..
1020  EXTERNAL zmake, zmmch, ztrmm, ztrsm
1021 * .. Intrinsic Functions ..
1022  INTRINSIC max
1023 * .. Scalars in Common ..
1024  INTEGER INFOT, NOUTC
1025  LOGICAL LERR, OK
1026 * .. Common blocks ..
1027  COMMON /infoc/infot, noutc, ok, lerr
1028 * .. Data statements ..
1029  DATA ichu/'UL'/, icht/'NTC'/, ichd/'UN'/, ichs/'LR'/
1030 * .. Executable Statements ..
1031 *
1032  nargs = 11
1033  nc = 0
1034  reset = .true.
1035  errmax = rzero
1036 * Set up zero matrix for ZMMCH.
1037  DO 20 j = 1, nmax
1038  DO 10 i = 1, nmax
1039  c( i, j ) = zero
1040  10 CONTINUE
1041  20 CONTINUE
1042 *
1043  DO 140 im = 1, nidim
1044  m = idim( im )
1045 *
1046  DO 130 in = 1, nidim
1047  n = idim( in )
1048 * Set LDB to 1 more than minimum value if room.
1049  ldb = m
1050  IF( ldb.LT.nmax )
1051  $ ldb = ldb + 1
1052 * Skip tests if not enough room.
1053  IF( ldb.GT.nmax )
1054  $ GO TO 130
1055  lbb = ldb*n
1056  null = m.LE.0.OR.n.LE.0
1057 *
1058  DO 120 ics = 1, 2
1059  side = ichs( ics: ics )
1060  left = side.EQ.'L'
1061  IF( left )THEN
1062  na = m
1063  ELSE
1064  na = n
1065  END IF
1066 * Set LDA to 1 more than minimum value if room.
1067  lda = na
1068  IF( lda.LT.nmax )
1069  $ lda = lda + 1
1070 * Skip tests if not enough room.
1071  IF( lda.GT.nmax )
1072  $ GO TO 130
1073  laa = lda*na
1074 *
1075  DO 110 icu = 1, 2
1076  uplo = ichu( icu: icu )
1077 *
1078  DO 100 ict = 1, 3
1079  transa = icht( ict: ict )
1080 *
1081  DO 90 icd = 1, 2
1082  diag = ichd( icd: icd )
1083 *
1084  DO 80 ia = 1, nalf
1085  alpha = alf( ia )
1086 *
1087 * Generate the matrix A.
1088 *
1089  CALL zmake( 'TR', uplo, diag, na, na, a,
1090  $ nmax, aa, lda, reset, zero )
1091 *
1092 * Generate the matrix B.
1093 *
1094  CALL zmake( 'GE', ' ', ' ', m, n, b, nmax,
1095  $ bb, ldb, reset, zero )
1096 *
1097  nc = nc + 1
1098 *
1099 * Save every datum before calling the
1100 * subroutine.
1101 *
1102  sides = side
1103  uplos = uplo
1104  tranas = transa
1105  diags = diag
1106  ms = m
1107  ns = n
1108  als = alpha
1109  DO 30 i = 1, laa
1110  as( i ) = aa( i )
1111  30 CONTINUE
1112  ldas = lda
1113  DO 40 i = 1, lbb
1114  bs( i ) = bb( i )
1115  40 CONTINUE
1116  ldbs = ldb
1117 *
1118 * Call the subroutine.
1119 *
1120  IF( sname( 4: 5 ).EQ.'MM' )THEN
1121  IF( trace )
1122  $ WRITE( ntra, fmt = 9995 )nc, sname,
1123  $ side, uplo, transa, diag, m, n, alpha,
1124  $ lda, ldb
1125  IF( rewi )
1126  $ rewind ntra
1127  CALL ztrmm( side, uplo, transa, diag, m,
1128  $ n, alpha, aa, lda, bb, ldb )
1129  ELSE IF( sname( 4: 5 ).EQ.'SM' )THEN
1130  IF( trace )
1131  $ WRITE( ntra, fmt = 9995 )nc, sname,
1132  $ side, uplo, transa, diag, m, n, alpha,
1133  $ lda, ldb
1134  IF( rewi )
1135  $ rewind ntra
1136  CALL ztrsm( side, uplo, transa, diag, m,
1137  $ n, alpha, aa, lda, bb, ldb )
1138  END IF
1139 *
1140 * Check if error-exit was taken incorrectly.
1141 *
1142  IF( .NOT.ok )THEN
1143  WRITE( nout, fmt = 9994 )
1144  fatal = .true.
1145  GO TO 150
1146  END IF
1147 *
1148 * See what data changed inside subroutines.
1149 *
1150  isame( 1 ) = sides.EQ.side
1151  isame( 2 ) = uplos.EQ.uplo
1152  isame( 3 ) = tranas.EQ.transa
1153  isame( 4 ) = diags.EQ.diag
1154  isame( 5 ) = ms.EQ.m
1155  isame( 6 ) = ns.EQ.n
1156  isame( 7 ) = als.EQ.alpha
1157  isame( 8 ) = lze( as, aa, laa )
1158  isame( 9 ) = ldas.EQ.lda
1159  IF( null )THEN
1160  isame( 10 ) = lze( bs, bb, lbb )
1161  ELSE
1162  isame( 10 ) = lzeres( 'GE', ' ', m, n, bs,
1163  $ bb, ldb )
1164  END IF
1165  isame( 11 ) = ldbs.EQ.ldb
1166 *
1167 * If data was incorrectly changed, report and
1168 * return.
1169 *
1170  same = .true.
1171  DO 50 i = 1, nargs
1172  same = same.AND.isame( i )
1173  IF( .NOT.isame( i ) )
1174  $ WRITE( nout, fmt = 9998 )i
1175  50 CONTINUE
1176  IF( .NOT.same )THEN
1177  fatal = .true.
1178  GO TO 150
1179  END IF
1180 *
1181  IF( .NOT.null )THEN
1182  IF( sname( 4: 5 ).EQ.'MM' )THEN
1183 *
1184 * Check the result.
1185 *
1186  IF( left )THEN
1187  CALL zmmch( transa, 'N', m, n, m,
1188  $ alpha, a, nmax, b, nmax,
1189  $ zero, c, nmax, ct, g,
1190  $ bb, ldb, eps, err,
1191  $ fatal, nout, .true. )
1192  ELSE
1193  CALL zmmch( 'N', transa, m, n, n,
1194  $ alpha, b, nmax, a, nmax,
1195  $ zero, c, nmax, ct, g,
1196  $ bb, ldb, eps, err,
1197  $ fatal, nout, .true. )
1198  END IF
1199  ELSE IF( sname( 4: 5 ).EQ.'SM' )THEN
1200 *
1201 * Compute approximation to original
1202 * matrix.
1203 *
1204  DO 70 j = 1, n
1205  DO 60 i = 1, m
1206  c( i, j ) = bb( i + ( j - 1 )*
1207  $ ldb )
1208  bb( i + ( j - 1 )*ldb ) = alpha*
1209  $ b( i, j )
1210  60 CONTINUE
1211  70 CONTINUE
1212 *
1213  IF( left )THEN
1214  CALL zmmch( transa, 'N', m, n, m,
1215  $ one, a, nmax, c, nmax,
1216  $ zero, b, nmax, ct, g,
1217  $ bb, ldb, eps, err,
1218  $ fatal, nout, .false. )
1219  ELSE
1220  CALL zmmch( 'N', transa, m, n, n,
1221  $ one, c, nmax, a, nmax,
1222  $ zero, b, nmax, ct, g,
1223  $ bb, ldb, eps, err,
1224  $ fatal, nout, .false. )
1225  END IF
1226  END IF
1227  errmax = max( errmax, err )
1228 * If got really bad answer, report and
1229 * return.
1230  IF( fatal )
1231  $ GO TO 150
1232  END IF
1233 *
1234  80 CONTINUE
1235 *
1236  90 CONTINUE
1237 *
1238  100 CONTINUE
1239 *
1240  110 CONTINUE
1241 *
1242  120 CONTINUE
1243 *
1244  130 CONTINUE
1245 *
1246  140 CONTINUE
1247 *
1248 * Report result.
1249 *
1250  IF( errmax.LT.thresh )THEN
1251  WRITE( nout, fmt = 9999 )sname, nc
1252  ELSE
1253  WRITE( nout, fmt = 9997 )sname, nc, errmax
1254  END IF
1255  GO TO 160
1256 *
1257  150 CONTINUE
1258  WRITE( nout, fmt = 9996 )sname
1259  WRITE( nout, fmt = 9995 )nc, sname, side, uplo, transa, diag, m,
1260  $ n, alpha, lda, ldb
1261 *
1262  160 CONTINUE
1263  RETURN
1264 *
1265  9999 FORMAT( ' ', a6, ' PASSED THE COMPUTATIONAL TESTS (', i6, ' CALL',
1266  $ 'S)' )
1267  9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
1268  $ 'ANGED INCORRECTLY *******' )
1269  9997 FORMAT( ' ', a6, ' COMPLETED THE COMPUTATIONAL TESTS (', i6, ' C',
1270  $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
1271  $ ' - SUSPECT *******' )
1272  9996 FORMAT( ' ******* ', a6, ' FAILED ON CALL NUMBER:' )
1273  9995 FORMAT( 1x, i6, ': ', a6, '(', 4( '''', a1, ''',' ), 2( i3, ',' ),
1274  $ '(', f4.1, ',', f4.1, '), A,', i3, ', B,', i3, ') ',
1275  $ ' .' )
1276  9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1277  $ '******' )
1278 *
1279 * End of ZCHK3.
1280 *
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
ztrsm
subroutine ztrsm(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB)
ZTRSM
Definition: ztrsm.f:182
lzeres
logical function lzeres(TYPE, UPLO, M, N, AA, AS, LDA)
Definition: zblat2.f:3080
lze
logical function lze(RI, RJ, LR)
Definition: zblat2.f:3050
ztrmm
subroutine ztrmm(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB)
ZTRMM
Definition: ztrmm.f:179
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