00001
00002
00003
00004
00005
00006
00007
00008
00009
00010
00011
00012
00013 #include "f2c.h"
00014 #include "blaswrap.h"
00015
00016
00017
00018 static integer c__3 = 3;
00019 static integer c__1 = 1;
00020 static integer c__4 = 4;
00021 static integer c__6 = 6;
00022 static integer c__20 = 20;
00023
00024 int cchkbk_(integer *nin, integer *nout)
00025 {
00026
00027 static char fmt_9999[] = "(1x,\002.. test output of CGEBAK .. \002)";
00028 static char fmt_9998[] = "(1x,\002value of largest test error "
00029 " = \002,e12.3)";
00030 static char fmt_9997[] = "(1x,\002example number where info is not zero "
00031 " = \002,i4)";
00032 static char fmt_9996[] = "(1x,\002example number having largest error "
00033 " = \002,i4)";
00034 static char fmt_9995[] = "(1x,\002number of examples where info is not 0"
00035 " = \002,i4)";
00036 static char fmt_9994[] = "(1x,\002total number of examples tested "
00037 " = \002,i4)";
00038
00039
00040 integer i__1, i__2, i__3, i__4;
00041 real r__1, r__2, r__3, r__4;
00042 complex q__1, q__2;
00043
00044
00045 integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
00046 e_rsle(void);
00047 double r_imag(complex *);
00048 integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
00049
00050
00051 complex e[400] ;
00052 integer i__, j, n;
00053 real x;
00054 integer ihi;
00055 complex ein[400] ;
00056 integer ilo;
00057 real eps;
00058 integer knt, info, lmax[2];
00059 real rmax, vmax, scale[20];
00060 integer ninfo;
00061 extern int cgebak_(char *, char *, integer *, integer *,
00062 integer *, real *, integer *, complex *, integer *, integer *);
00063 extern doublereal slamch_(char *);
00064 real safmin;
00065
00066
00067 static cilist io___7 = { 0, 0, 0, 0, 0 };
00068 static cilist io___11 = { 0, 0, 0, 0, 0 };
00069 static cilist io___14 = { 0, 0, 0, 0, 0 };
00070 static cilist io___17 = { 0, 0, 0, 0, 0 };
00071 static cilist io___22 = { 0, 0, 0, fmt_9999, 0 };
00072 static cilist io___23 = { 0, 0, 0, fmt_9998, 0 };
00073 static cilist io___24 = { 0, 0, 0, fmt_9997, 0 };
00074 static cilist io___25 = { 0, 0, 0, fmt_9996, 0 };
00075 static cilist io___26 = { 0, 0, 0, fmt_9995, 0 };
00076 static cilist io___27 = { 0, 0, 0, fmt_9994, 0 };
00077
00078
00079
00080
00081
00082
00083
00084
00085
00086
00087
00088
00089
00090
00091
00092
00093
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 lmax[0] = 0;
00124 lmax[1] = 0;
00125 ninfo = 0;
00126 knt = 0;
00127 rmax = 0.f;
00128 eps = slamch_("E");
00129 safmin = slamch_("S");
00130
00131 L10:
00132
00133 io___7.ciunit = *nin;
00134 s_rsle(&io___7);
00135 do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
00136 do_lio(&c__3, &c__1, (char *)&ilo, (ftnlen)sizeof(integer));
00137 do_lio(&c__3, &c__1, (char *)&ihi, (ftnlen)sizeof(integer));
00138 e_rsle();
00139 if (n == 0) {
00140 goto L60;
00141 }
00142
00143 io___11.ciunit = *nin;
00144 s_rsle(&io___11);
00145 i__1 = n;
00146 for (i__ = 1; i__ <= i__1; ++i__) {
00147 do_lio(&c__4, &c__1, (char *)&scale[i__ - 1], (ftnlen)sizeof(real));
00148 }
00149 e_rsle();
00150 i__1 = n;
00151 for (i__ = 1; i__ <= i__1; ++i__) {
00152 io___14.ciunit = *nin;
00153 s_rsle(&io___14);
00154 i__2 = n;
00155 for (j = 1; j <= i__2; ++j) {
00156 do_lio(&c__6, &c__1, (char *)&e[i__ + j * 20 - 21], (ftnlen)
00157 sizeof(complex));
00158 }
00159 e_rsle();
00160
00161 }
00162
00163 i__1 = n;
00164 for (i__ = 1; i__ <= i__1; ++i__) {
00165 io___17.ciunit = *nin;
00166 s_rsle(&io___17);
00167 i__2 = n;
00168 for (j = 1; j <= i__2; ++j) {
00169 do_lio(&c__6, &c__1, (char *)&ein[i__ + j * 20 - 21], (ftnlen)
00170 sizeof(complex));
00171 }
00172 e_rsle();
00173
00174 }
00175
00176 ++knt;
00177 cgebak_("B", "R", &n, &ilo, &ihi, scale, &n, e, &c__20, &info);
00178
00179 if (info != 0) {
00180 ++ninfo;
00181 lmax[0] = knt;
00182 }
00183
00184 vmax = 0.f;
00185 i__1 = n;
00186 for (i__ = 1; i__ <= i__1; ++i__) {
00187 i__2 = n;
00188 for (j = 1; j <= i__2; ++j) {
00189 i__3 = i__ + j * 20 - 21;
00190 i__4 = i__ + j * 20 - 21;
00191 q__2.r = e[i__3].r - ein[i__4].r, q__2.i = e[i__3].i - ein[i__4]
00192 .i;
00193 q__1.r = q__2.r, q__1.i = q__2.i;
00194 x = ((r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(&q__1), dabs(
00195 r__2))) / eps;
00196 i__3 = i__ + j * 20 - 21;
00197 if ((r__1 = e[i__3].r, dabs(r__1)) + (r__2 = r_imag(&e[i__ + j *
00198 20 - 21]), dabs(r__2)) > safmin) {
00199 i__4 = i__ + j * 20 - 21;
00200 x /= (r__3 = e[i__4].r, dabs(r__3)) + (r__4 = r_imag(&e[i__ +
00201 j * 20 - 21]), dabs(r__4));
00202 }
00203 vmax = dmax(vmax,x);
00204
00205 }
00206
00207 }
00208
00209 if (vmax > rmax) {
00210 lmax[1] = knt;
00211 rmax = vmax;
00212 }
00213
00214 goto L10;
00215
00216 L60:
00217
00218 io___22.ciunit = *nout;
00219 s_wsfe(&io___22);
00220 e_wsfe();
00221
00222 io___23.ciunit = *nout;
00223 s_wsfe(&io___23);
00224 do_fio(&c__1, (char *)&rmax, (ftnlen)sizeof(real));
00225 e_wsfe();
00226 io___24.ciunit = *nout;
00227 s_wsfe(&io___24);
00228 do_fio(&c__1, (char *)&lmax[0], (ftnlen)sizeof(integer));
00229 e_wsfe();
00230 io___25.ciunit = *nout;
00231 s_wsfe(&io___25);
00232 do_fio(&c__1, (char *)&lmax[1], (ftnlen)sizeof(integer));
00233 e_wsfe();
00234 io___26.ciunit = *nout;
00235 s_wsfe(&io___26);
00236 do_fio(&c__1, (char *)&ninfo, (ftnlen)sizeof(integer));
00237 e_wsfe();
00238 io___27.ciunit = *nout;
00239 s_wsfe(&io___27);
00240 do_fio(&c__1, (char *)&knt, (ftnlen)sizeof(integer));
00241 e_wsfe();
00242
00243 return 0;
00244
00245
00246
00247 }