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

◆ cchk3()

subroutine cchk3 ( character*7 sname,
real eps,
real thresh,
integer nout,
integer ntra,
logical trace,
logical rewi,
logical fatal,
integer nidim,
integer, dimension( nidim ) idim,
integer nalf,
complex, dimension( nalf ) alf,
integer nmax,
complex, dimension( nmax, nmax ) a,
complex, dimension( nmax*nmax ) aa,
complex, dimension( nmax*nmax ) as,
complex, dimension( nmax, nmax ) b,
complex, dimension( nmax*nmax ) bb,
complex, dimension( nmax*nmax ) bs,
complex, dimension( nmax ) ct,
real, dimension( nmax ) g,
complex, dimension( nmax, nmax ) c )

Definition at line 973 of file cblat3.f.

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