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

◆ zchk3()

subroutine zchk3 ( character*7 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 977 of file zblat3.f.

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