00001
00002
00003
00004
00005
00006
00007
00008
00009
00010
00011
00012
00013 #include "f2c.h"
00014 #include "blaswrap.h"
00015
00016
00017
00018 struct {
00019 char srnamt[32];
00020 } srnamc_;
00021
00022 #define srnamc_1 srnamc_
00023
00024
00025
00026 static integer c__2 = 2;
00027 static integer c__1 = 1;
00028
00029 int sdrvrf1_(integer *nout, integer *nn, integer *nval, real
00030 *thresh, real *a, integer *lda, real *arf, real *work)
00031 {
00032
00033
00034 static integer iseedy[4] = { 1988,1989,1990,1991 };
00035 static char uplos[1*2] = "U" "L";
00036 static char forms[1*2] = "N" "T";
00037 static char norms[1*4] = "M" "1" "I" "F";
00038
00039
00040 static char fmt_9999[] = "(1x,\002 *** Error(s) or Failure(s) while test"
00041 "ing SLANSF ***\002)";
00042 static char fmt_9998[] = "(1x,\002 Error in \002,a6,\002 with UPLO="
00043 "'\002,a1,\002', FORM='\002,a1,\002', N=\002,i5)";
00044 static char fmt_9997[] = "(1x,\002 Failure in \002,a6,\002 N=\002,"
00045 "i5,\002 TYPE=\002,i5,\002 UPLO='\002,a1,\002', FORM ='\002,a1"
00046 ",\002', NORM='\002,a1,\002', test=\002,g12.5)";
00047 static char fmt_9996[] = "(1x,\002All tests for \002,a6,\002 auxiliary r"
00048 "outine passed the \002,\002threshold (\002,i5,\002 tests run)"
00049 "\002)";
00050 static char fmt_9995[] = "(1x,a6,\002 auxiliary routine:\002,i5,\002 out"
00051 " of \002,i5,\002 tests failed to pass the threshold\002)";
00052 static char fmt_9994[] = "(26x,i5,\002 error message recorded (\002,a6"
00053 ",\002)\002)";
00054
00055
00056 integer a_dim1, a_offset, i__1, i__2, i__3;
00057
00058
00059 int s_copy(char *, char *, ftnlen, ftnlen);
00060 integer s_wsle(cilist *), e_wsle(void), s_wsfe(cilist *), e_wsfe(void),
00061 do_fio(integer *, char *, ftnlen);
00062
00063
00064 integer i__, j, n, iin, iit;
00065 real eps;
00066 integer info;
00067 char norm[1], uplo[1];
00068 integer nrun, nfail;
00069 real large;
00070 integer iseed[4];
00071 char cform[1];
00072 real small;
00073 integer iform;
00074 real norma;
00075 integer inorm, iuplo, nerrs;
00076 extern doublereal slamch_(char *), slarnd_(integer *, integer *),
00077 slansf_(char *, char *, char *, integer *, real *, real *), slansy_(char *, char *, integer *, real *,
00078 integer *, real *);
00079 real result[1];
00080 extern int strttf_(char *, char *, integer *, real *,
00081 integer *, real *, integer *);
00082 real normarf;
00083
00084
00085 static cilist io___22 = { 0, 0, 0, 0, 0 };
00086 static cilist io___23 = { 0, 0, 0, fmt_9999, 0 };
00087 static cilist io___24 = { 0, 0, 0, fmt_9998, 0 };
00088 static cilist io___30 = { 0, 0, 0, 0, 0 };
00089 static cilist io___31 = { 0, 0, 0, fmt_9999, 0 };
00090 static cilist io___32 = { 0, 0, 0, fmt_9997, 0 };
00091 static cilist io___33 = { 0, 0, 0, fmt_9996, 0 };
00092 static cilist io___34 = { 0, 0, 0, fmt_9995, 0 };
00093 static cilist io___35 = { 0, 0, 0, fmt_9994, 0 };
00094
00095
00096
00097
00098
00099
00100
00101
00102
00103
00104
00105
00106
00107
00108
00109
00110
00111
00112
00113
00114
00115
00116
00117
00118
00119
00120
00121
00122
00123
00124
00125
00126
00127
00128
00129
00130
00131
00132
00133
00134
00135
00136
00137
00138
00139
00140
00141
00142
00143
00144
00145
00146
00147
00148
00149
00150
00151
00152
00153
00154
00155
00156 --nval;
00157 a_dim1 = *lda;
00158 a_offset = 1 + a_dim1;
00159 a -= a_offset;
00160 --arf;
00161 --work;
00162
00163
00164
00165
00166
00167
00168
00169 nrun = 0;
00170 nfail = 0;
00171 nerrs = 0;
00172 info = 0;
00173 for (i__ = 1; i__ <= 4; ++i__) {
00174 iseed[i__ - 1] = iseedy[i__ - 1];
00175
00176 }
00177
00178 eps = slamch_("Precision");
00179 small = slamch_("Safe minimum");
00180 large = 1.f / small;
00181 small = small * *lda * *lda;
00182 large = large / *lda / *lda;
00183
00184 i__1 = *nn;
00185 for (iin = 1; iin <= i__1; ++iin) {
00186
00187 n = nval[iin];
00188
00189 for (iit = 1; iit <= 3; ++iit) {
00190
00191
00192
00193
00194
00195 i__2 = n;
00196 for (j = 1; j <= i__2; ++j) {
00197 i__3 = n;
00198 for (i__ = 1; i__ <= i__3; ++i__) {
00199 a[i__ + j * a_dim1] = slarnd_(&c__2, iseed);
00200 }
00201 }
00202
00203 if (iit == 2) {
00204 i__2 = n;
00205 for (j = 1; j <= i__2; ++j) {
00206 i__3 = n;
00207 for (i__ = 1; i__ <= i__3; ++i__) {
00208 a[i__ + j * a_dim1] *= large;
00209 }
00210 }
00211 }
00212
00213 if (iit == 3) {
00214 i__2 = n;
00215 for (j = 1; j <= i__2; ++j) {
00216 i__3 = n;
00217 for (i__ = 1; i__ <= i__3; ++i__) {
00218 a[i__ + j * a_dim1] *= small;
00219 }
00220 }
00221 }
00222
00223
00224
00225 for (iuplo = 1; iuplo <= 2; ++iuplo) {
00226
00227 *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 1];
00228
00229
00230
00231 for (iform = 1; iform <= 2; ++iform) {
00232
00233 *(unsigned char *)cform = *(unsigned char *)&forms[iform
00234 - 1];
00235
00236 s_copy(srnamc_1.srnamt, "STRTTF", (ftnlen)32, (ftnlen)6);
00237 strttf_(cform, uplo, &n, &a[a_offset], lda, &arf[1], &
00238 info);
00239
00240
00241
00242 if (info != 0) {
00243 if (nfail == 0 && nerrs == 0) {
00244 io___22.ciunit = *nout;
00245 s_wsle(&io___22);
00246 e_wsle();
00247 io___23.ciunit = *nout;
00248 s_wsfe(&io___23);
00249 e_wsfe();
00250 }
00251 io___24.ciunit = *nout;
00252 s_wsfe(&io___24);
00253 do_fio(&c__1, srnamc_1.srnamt, (ftnlen)32);
00254 do_fio(&c__1, uplo, (ftnlen)1);
00255 do_fio(&c__1, cform, (ftnlen)1);
00256 do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
00257 e_wsfe();
00258 ++nerrs;
00259 goto L100;
00260 }
00261
00262 for (inorm = 1; inorm <= 4; ++inorm) {
00263
00264
00265
00266 *(unsigned char *)norm = *(unsigned char *)&norms[
00267 inorm - 1];
00268 normarf = slansf_(norm, cform, uplo, &n, &arf[1], &
00269 work[1]);
00270 norma = slansy_(norm, uplo, &n, &a[a_offset], lda, &
00271 work[1]);
00272
00273 result[0] = (norma - normarf) / norma / eps;
00274 ++nrun;
00275
00276 if (result[0] >= *thresh) {
00277 if (nfail == 0 && nerrs == 0) {
00278 io___30.ciunit = *nout;
00279 s_wsle(&io___30);
00280 e_wsle();
00281 io___31.ciunit = *nout;
00282 s_wsfe(&io___31);
00283 e_wsfe();
00284 }
00285 io___32.ciunit = *nout;
00286 s_wsfe(&io___32);
00287 do_fio(&c__1, "SLANSF", (ftnlen)6);
00288 do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
00289 ;
00290 do_fio(&c__1, (char *)&iit, (ftnlen)sizeof(
00291 integer));
00292 do_fio(&c__1, uplo, (ftnlen)1);
00293 do_fio(&c__1, cform, (ftnlen)1);
00294 do_fio(&c__1, norm, (ftnlen)1);
00295 do_fio(&c__1, (char *)&result[0], (ftnlen)sizeof(
00296 real));
00297 e_wsfe();
00298 ++nfail;
00299 }
00300
00301 }
00302 L100:
00303 ;
00304 }
00305
00306 }
00307
00308 }
00309
00310 }
00311
00312
00313
00314 if (nfail == 0) {
00315 io___33.ciunit = *nout;
00316 s_wsfe(&io___33);
00317 do_fio(&c__1, "SLANSF", (ftnlen)6);
00318 do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
00319 e_wsfe();
00320 } else {
00321 io___34.ciunit = *nout;
00322 s_wsfe(&io___34);
00323 do_fio(&c__1, "SLANSF", (ftnlen)6);
00324 do_fio(&c__1, (char *)&nfail, (ftnlen)sizeof(integer));
00325 do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
00326 e_wsfe();
00327 }
00328 if (nerrs != 0) {
00329 io___35.ciunit = *nout;
00330 s_wsfe(&io___35);
00331 do_fio(&c__1, (char *)&nerrs, (ftnlen)sizeof(integer));
00332 do_fio(&c__1, "SLANSF", (ftnlen)6);
00333 e_wsfe();
00334 }
00335
00336
00337 return 0;
00338
00339
00340
00341 }