LAPACK  3.9.1
LAPACK: Linear Algebra PACKage

◆ schk3()

subroutine schk3 ( 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,
real, dimension( nalf )  ALF,
integer  NMAX,
real, dimension( nmax, nmax )  A,
real, dimension( nmax*nmax )  AA,
real, dimension( nmax*nmax )  AS,
real, dimension( nmax, nmax )  B,
real, dimension( nmax*nmax )  BB,
real, dimension( nmax*nmax )  BS,
real, dimension( nmax )  CT,
real, dimension( nmax )  G,
real, dimension( nmax, nmax )  C 
)

Definition at line 943 of file sblat3.f.

946 *
947 * Tests STRMM and STRSM.
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  REAL ZERO, ONE
959  parameter( zero = 0.0, one = 1.0 )
960 * .. Scalar Arguments ..
961  REAL EPS, THRESH
962  INTEGER NALF, NIDIM, NMAX, NOUT, NTRA
963  LOGICAL FATAL, REWI, TRACE
964  CHARACTER*6 SNAME
965 * .. Array Arguments ..
966  REAL 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  REAL 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 LSE, LSERES
985  EXTERNAL lse, lseres
986 * .. External Subroutines ..
987  EXTERNAL smake, smmch, strmm, strsm
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 SMMCH.
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 smake( 'TR', uplo, diag, na, na, a,
1057  $ nmax, aa, lda, reset, zero )
1058 *
1059 * Generate the matrix B.
1060 *
1061  CALL smake( '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 strmm( 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 strsm( 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 ) = lse( as, aa, laa )
1125  isame( 9 ) = ldas.EQ.lda
1126  IF( null )THEN
1127  isame( 10 ) = lse( bs, bb, lbb )
1128  ELSE
1129  isame( 10 ) = lseres( '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 smmch( 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 smmch( '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 smmch( 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 smmch( '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 SCHK3.
1246 *
strmm
subroutine strmm(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB)
STRMM
Definition: strmm.f:177
strsm
subroutine strsm(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB)
STRSM
Definition: strsm.f:181
lse
logical function lse(RI, RJ, LR)
Definition: sblat2.f:2942
lseres
logical function lseres(TYPE, UPLO, M, N, AA, AS, LDA)
Definition: sblat2.f:2972
smake
subroutine smake(TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, KU, RESET, TRANSL)
Definition: sblat2.f:2650
smmch
subroutine smmch(TRANSA, TRANSB, M, N, KK, ALPHA, A, LDA, B, LDB, BETA, C, LDC, CT, G, CC, LDCC, EPS, ERR, FATAL, NOUT, MV)
Definition: sblat3.f:2508
Here is the call graph for this function: