LAPACK  3.9.1
LAPACK: Linear Algebra PACKage

◆ 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:2716
lce
logical function lce(RI, RJ, LR)
Definition: cblat2.f:3039
lceres
logical function lceres(TYPE, UPLO, M, N, AA, AS, LDA)
Definition: cblat2.f:3069
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: