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

◆ schk3()

subroutine schk3 ( character*7 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 950 of file sblat3.f.

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