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

◆ cchk3()

subroutine cchk3 ( character*6  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 966 of file cblat3.f.

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