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

◆ 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 968 of file zblat3.f.

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