LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
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 972 of file cblat3.f.

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

Here is the call graph for this function: