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

◆ dchk3()

subroutine dchk3 ( 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,
double precision, dimension( nalf )  alf,
integer  nmax,
double precision, dimension( nmax, nmax )  a,
double precision, dimension( nmax*nmax )  aa,
double precision, dimension( nmax*nmax )  as,
double precision, dimension( nmax, nmax )  b,
double precision, dimension( nmax*nmax )  bb,
double precision, dimension( nmax*nmax )  bs,
double precision, dimension( nmax )  ct,
double precision, dimension( nmax )  g,
double precision, dimension( nmax, nmax )  c 
)

Definition at line 943 of file dblat3.f.

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