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

◆ 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:2970
lseres
logical function lseres(TYPE, UPLO, M, N, AA, AS, LDA)
Definition: sblat2.f:3000
smake
subroutine smake(TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, KU, RESET, TRANSL)
Definition: sblat2.f:2678
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: