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 sdrvrf4_(integer *nout, integer *nn, integer *nval, real
00030 *thresh, real *c1, real *c2, integer *ldc, real *crf, real *a,
00031 integer *lda, real *s_work_slange__)
00032 {
00033
00034
00035 static integer iseedy[4] = { 1988,1989,1990,1991 };
00036 static char uplos[1*2] = "U" "L";
00037 static char forms[1*2] = "N" "T";
00038 static char transs[1*2] = "N" "T";
00039
00040
00041 static char fmt_9999[] = "(1x,\002 *** Error(s) or Failure(s) while test"
00042 "ing SSFRK ***\002)";
00043 static char fmt_9997[] = "(1x,\002 Failure in \002,a5,\002, CFORM="
00044 "'\002,a1,\002',\002,\002 UPLO='\002,a1,\002',\002,\002 TRANS="
00045 "'\002,a1,\002',\002,\002 N=\002,i3,\002, K =\002,i3,\002, test"
00046 "=\002,g12.5)";
00047 static char fmt_9996[] = "(1x,\002All tests for \002,a5,\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
00053
00054 integer a_dim1, a_offset, c1_dim1, c1_offset, c2_dim1, c2_offset, i__1,
00055 i__2, i__3, i__4;
00056 real r__1;
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, k, n, iik, iin;
00065 real eps, beta;
00066 integer info;
00067 char uplo[1];
00068 integer nrun;
00069 real alpha;
00070 integer nfail, iseed[4];
00071 char cform[1];
00072 integer iform;
00073 real norma, normc;
00074 char trans[1];
00075 integer iuplo;
00076 extern int ssfrk_(char *, char *, char *, integer *,
00077 integer *, real *, real *, integer *, real *, real *), ssyrk_(char *, char *, integer *, integer *,
00078 real *, real *, integer *, real *, real *, integer *);
00079 integer ialpha;
00080 extern doublereal slamch_(char *), slange_(char *, integer *,
00081 integer *, real *, integer *, real *), slarnd_(integer *,
00082 integer *);
00083 integer itrans;
00084 real result[1];
00085 extern int stfttr_(char *, char *, integer *, real *,
00086 real *, integer *, integer *), strttf_(char *,
00087 char *, integer *, real *, integer *, real *, integer *);
00088
00089
00090 static cilist io___28 = { 0, 0, 0, 0, 0 };
00091 static cilist io___29 = { 0, 0, 0, fmt_9999, 0 };
00092 static cilist io___30 = { 0, 0, 0, fmt_9997, 0 };
00093 static cilist io___31 = { 0, 0, 0, fmt_9996, 0 };
00094 static cilist io___32 = { 0, 0, 0, fmt_9995, 0 };
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
00157
00158
00159
00160
00161
00162
00163
00164
00165
00166
00167
00168
00169
00170
00171 --nval;
00172 c2_dim1 = *ldc;
00173 c2_offset = 1 + c2_dim1;
00174 c2 -= c2_offset;
00175 c1_dim1 = *ldc;
00176 c1_offset = 1 + c1_dim1;
00177 c1 -= c1_offset;
00178 --crf;
00179 a_dim1 = *lda;
00180 a_offset = 1 + a_dim1;
00181 a -= a_offset;
00182 --s_work_slange__;
00183
00184
00185
00186
00187
00188
00189
00190 nrun = 0;
00191 nfail = 0;
00192 info = 0;
00193 for (i__ = 1; i__ <= 4; ++i__) {
00194 iseed[i__ - 1] = iseedy[i__ - 1];
00195
00196 }
00197 eps = slamch_("Precision");
00198
00199 i__1 = *nn;
00200 for (iin = 1; iin <= i__1; ++iin) {
00201
00202 n = nval[iin];
00203
00204 i__2 = *nn;
00205 for (iik = 1; iik <= i__2; ++iik) {
00206
00207 k = nval[iin];
00208
00209 for (iform = 1; iform <= 2; ++iform) {
00210
00211 *(unsigned char *)cform = *(unsigned char *)&forms[iform - 1];
00212
00213 for (iuplo = 1; iuplo <= 2; ++iuplo) {
00214
00215 *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo -
00216 1];
00217
00218 for (itrans = 1; itrans <= 2; ++itrans) {
00219
00220 *(unsigned char *)trans = *(unsigned char *)&transs[
00221 itrans - 1];
00222
00223 for (ialpha = 1; ialpha <= 4; ++ialpha) {
00224
00225 if (ialpha == 1) {
00226 alpha = 0.f;
00227 beta = 0.f;
00228 } else if (ialpha == 2) {
00229 alpha = 1.f;
00230 beta = 0.f;
00231 } else if (ialpha == 3) {
00232 alpha = 0.f;
00233 beta = 1.f;
00234 } else {
00235 alpha = slarnd_(&c__2, iseed);
00236 beta = slarnd_(&c__2, iseed);
00237 }
00238
00239
00240
00241
00242
00243
00244 ++nrun;
00245
00246 if (itrans == 1) {
00247
00248
00249
00250 i__3 = k;
00251 for (j = 1; j <= i__3; ++j) {
00252 i__4 = n;
00253 for (i__ = 1; i__ <= i__4; ++i__) {
00254 a[i__ + j * a_dim1] = slarnd_(&c__2,
00255 iseed);
00256 }
00257 }
00258
00259 norma = slange_("I", &n, &k, &a[a_offset],
00260 lda, &s_work_slange__[1]);
00261
00262 } else {
00263
00264
00265
00266 i__3 = n;
00267 for (j = 1; j <= i__3; ++j) {
00268 i__4 = k;
00269 for (i__ = 1; i__ <= i__4; ++i__) {
00270 a[i__ + j * a_dim1] = slarnd_(&c__2,
00271 iseed);
00272 }
00273 }
00274
00275 norma = slange_("I", &k, &n, &a[a_offset],
00276 lda, &s_work_slange__[1]);
00277
00278 }
00279
00280
00281
00282
00283
00284
00285 i__3 = n;
00286 for (j = 1; j <= i__3; ++j) {
00287 i__4 = n;
00288 for (i__ = 1; i__ <= i__4; ++i__) {
00289 c1[i__ + j * c1_dim1] = slarnd_(&c__2,
00290 iseed);
00291 c2[i__ + j * c2_dim1] = c1[i__ + j *
00292 c1_dim1];
00293 }
00294 }
00295
00296
00297
00298
00299 normc = slange_("I", &n, &n, &c1[c1_offset], ldc,
00300 &s_work_slange__[1]);
00301
00302 s_copy(srnamc_1.srnamt, "STRTTF", (ftnlen)32, (
00303 ftnlen)6);
00304 strttf_(cform, uplo, &n, &c1[c1_offset], ldc, &
00305 crf[1], &info);
00306
00307
00308
00309 s_copy(srnamc_1.srnamt, "SSYRK ", (ftnlen)32, (
00310 ftnlen)6);
00311 ssyrk_(uplo, trans, &n, &k, &alpha, &a[a_offset],
00312 lda, &beta, &c1[c1_offset], ldc);
00313
00314
00315
00316 s_copy(srnamc_1.srnamt, "SSFRK ", (ftnlen)32, (
00317 ftnlen)6);
00318 ssfrk_(cform, uplo, trans, &n, &k, &alpha, &a[
00319 a_offset], lda, &beta, &crf[1]);
00320
00321
00322
00323 s_copy(srnamc_1.srnamt, "STFTTR", (ftnlen)32, (
00324 ftnlen)6);
00325 stfttr_(cform, uplo, &n, &crf[1], &c2[c2_offset],
00326 ldc, &info);
00327
00328
00329
00330 i__3 = n;
00331 for (j = 1; j <= i__3; ++j) {
00332 i__4 = n;
00333 for (i__ = 1; i__ <= i__4; ++i__) {
00334 c1[i__ + j * c1_dim1] -= c2[i__ + j *
00335 c2_dim1];
00336 }
00337 }
00338
00339
00340
00341
00342
00343
00344 result[0] = slange_("I", &n, &n, &c1[c1_offset],
00345 ldc, &s_work_slange__[1]);
00346
00347 r__1 = dabs(alpha) * norma + dabs(beta);
00348 result[0] = result[0] / dmax(r__1,1.f) / max(n,1)
00349 / eps;
00350
00351 if (result[0] >= *thresh) {
00352 if (nfail == 0) {
00353 io___28.ciunit = *nout;
00354 s_wsle(&io___28);
00355 e_wsle();
00356 io___29.ciunit = *nout;
00357 s_wsfe(&io___29);
00358 e_wsfe();
00359 }
00360 io___30.ciunit = *nout;
00361 s_wsfe(&io___30);
00362 do_fio(&c__1, "SSFRK", (ftnlen)5);
00363 do_fio(&c__1, cform, (ftnlen)1);
00364 do_fio(&c__1, uplo, (ftnlen)1);
00365 do_fio(&c__1, trans, (ftnlen)1);
00366 do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
00367 integer));
00368 do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
00369 integer));
00370 do_fio(&c__1, (char *)&result[0], (ftnlen)
00371 sizeof(real));
00372 e_wsfe();
00373 ++nfail;
00374 }
00375
00376
00377 }
00378
00379 }
00380
00381 }
00382
00383 }
00384
00385 }
00386
00387 }
00388
00389
00390
00391 if (nfail == 0) {
00392 io___31.ciunit = *nout;
00393 s_wsfe(&io___31);
00394 do_fio(&c__1, "SSFRK", (ftnlen)5);
00395 do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
00396 e_wsfe();
00397 } else {
00398 io___32.ciunit = *nout;
00399 s_wsfe(&io___32);
00400 do_fio(&c__1, "SSFRK", (ftnlen)5);
00401 do_fio(&c__1, (char *)&nfail, (ftnlen)sizeof(integer));
00402 do_fio(&c__1, (char *)&nrun, (ftnlen)sizeof(integer));
00403 e_wsfe();
00404 }
00405
00406
00407 return 0;
00408
00409
00410
00411 }