LAPACK  3.9.0
LAPACK: Linear Algebra PACKage

◆ 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 949 of file dblat3.f.

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