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__5 = 5;
00021 static integer c__7 = 7;
00022 static integer c__20 = 20;
00023
00024 int zchkbk_(integer *nin, integer *nout)
00025 {
00026
00027 static char fmt_9999[] = "(1x,\002.. test output of ZGEBAK .. \002)";
00028 static char fmt_9998[] = "(1x,\002value of largest test error "
00029 " = \002,d12.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 doublereal d__1, d__2, d__3, d__4;
00042 doublecomplex z__1, z__2;
00043
00044
00045 integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
00046 e_rsle(void);
00047 double d_imag(doublecomplex *);
00048 integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
00049
00050
00051 doublecomplex e[400] ;
00052 integer i__, j, n;
00053 doublereal x;
00054 integer ihi;
00055 doublecomplex ein[400] ;
00056 integer ilo;
00057 doublereal eps;
00058 integer knt, info, lmax[2];
00059 doublereal rmax, vmax, scale[20];
00060 integer ninfo;
00061 extern doublereal dlamch_(char *);
00062 extern int zgebak_(char *, char *, integer *, integer *,
00063 integer *, doublereal *, integer *, doublecomplex *, integer *,
00064 integer *);
00065 doublereal safmin;
00066
00067
00068 static cilist io___7 = { 0, 0, 0, 0, 0 };
00069 static cilist io___11 = { 0, 0, 0, 0, 0 };
00070 static cilist io___14 = { 0, 0, 0, 0, 0 };
00071 static cilist io___17 = { 0, 0, 0, 0, 0 };
00072 static cilist io___22 = { 0, 0, 0, fmt_9999, 0 };
00073 static cilist io___23 = { 0, 0, 0, fmt_9998, 0 };
00074 static cilist io___24 = { 0, 0, 0, fmt_9997, 0 };
00075 static cilist io___25 = { 0, 0, 0, fmt_9996, 0 };
00076 static cilist io___26 = { 0, 0, 0, fmt_9995, 0 };
00077 static cilist io___27 = { 0, 0, 0, fmt_9994, 0 };
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
00124 lmax[0] = 0;
00125 lmax[1] = 0;
00126 ninfo = 0;
00127 knt = 0;
00128 rmax = 0.;
00129 eps = dlamch_("E");
00130 safmin = dlamch_("S");
00131
00132 L10:
00133
00134 io___7.ciunit = *nin;
00135 s_rsle(&io___7);
00136 do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
00137 do_lio(&c__3, &c__1, (char *)&ilo, (ftnlen)sizeof(integer));
00138 do_lio(&c__3, &c__1, (char *)&ihi, (ftnlen)sizeof(integer));
00139 e_rsle();
00140 if (n == 0) {
00141 goto L60;
00142 }
00143
00144 io___11.ciunit = *nin;
00145 s_rsle(&io___11);
00146 i__1 = n;
00147 for (i__ = 1; i__ <= i__1; ++i__) {
00148 do_lio(&c__5, &c__1, (char *)&scale[i__ - 1], (ftnlen)sizeof(
00149 doublereal));
00150 }
00151 e_rsle();
00152 i__1 = n;
00153 for (i__ = 1; i__ <= i__1; ++i__) {
00154 io___14.ciunit = *nin;
00155 s_rsle(&io___14);
00156 i__2 = n;
00157 for (j = 1; j <= i__2; ++j) {
00158 do_lio(&c__7, &c__1, (char *)&e[i__ + j * 20 - 21], (ftnlen)
00159 sizeof(doublecomplex));
00160 }
00161 e_rsle();
00162
00163 }
00164
00165 i__1 = n;
00166 for (i__ = 1; i__ <= i__1; ++i__) {
00167 io___17.ciunit = *nin;
00168 s_rsle(&io___17);
00169 i__2 = n;
00170 for (j = 1; j <= i__2; ++j) {
00171 do_lio(&c__7, &c__1, (char *)&ein[i__ + j * 20 - 21], (ftnlen)
00172 sizeof(doublecomplex));
00173 }
00174 e_rsle();
00175
00176 }
00177
00178 ++knt;
00179 zgebak_("B", "R", &n, &ilo, &ihi, scale, &n, e, &c__20, &info);
00180
00181 if (info != 0) {
00182 ++ninfo;
00183 lmax[0] = knt;
00184 }
00185
00186 vmax = 0.;
00187 i__1 = n;
00188 for (i__ = 1; i__ <= i__1; ++i__) {
00189 i__2 = n;
00190 for (j = 1; j <= i__2; ++j) {
00191 i__3 = i__ + j * 20 - 21;
00192 i__4 = i__ + j * 20 - 21;
00193 z__2.r = e[i__3].r - ein[i__4].r, z__2.i = e[i__3].i - ein[i__4]
00194 .i;
00195 z__1.r = z__2.r, z__1.i = z__2.i;
00196 x = ((d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1), abs(d__2)
00197 )) / eps;
00198 i__3 = i__ + j * 20 - 21;
00199 if ((d__1 = e[i__3].r, abs(d__1)) + (d__2 = d_imag(&e[i__ + j *
00200 20 - 21]), abs(d__2)) > safmin) {
00201 i__4 = i__ + j * 20 - 21;
00202 x /= (d__3 = e[i__4].r, abs(d__3)) + (d__4 = d_imag(&e[i__ +
00203 j * 20 - 21]), abs(d__4));
00204 }
00205 vmax = max(vmax,x);
00206
00207 }
00208
00209 }
00210
00211 if (vmax > rmax) {
00212 lmax[1] = knt;
00213 rmax = vmax;
00214 }
00215
00216 goto L10;
00217
00218 L60:
00219
00220 io___22.ciunit = *nout;
00221 s_wsfe(&io___22);
00222 e_wsfe();
00223
00224 io___23.ciunit = *nout;
00225 s_wsfe(&io___23);
00226 do_fio(&c__1, (char *)&rmax, (ftnlen)sizeof(doublereal));
00227 e_wsfe();
00228 io___24.ciunit = *nout;
00229 s_wsfe(&io___24);
00230 do_fio(&c__1, (char *)&lmax[0], (ftnlen)sizeof(integer));
00231 e_wsfe();
00232 io___25.ciunit = *nout;
00233 s_wsfe(&io___25);
00234 do_fio(&c__1, (char *)&lmax[1], (ftnlen)sizeof(integer));
00235 e_wsfe();
00236 io___26.ciunit = *nout;
00237 s_wsfe(&io___26);
00238 do_fio(&c__1, (char *)&ninfo, (ftnlen)sizeof(integer));
00239 e_wsfe();
00240 io___27.ciunit = *nout;
00241 s_wsfe(&io___27);
00242 do_fio(&c__1, (char *)&knt, (ftnlen)sizeof(integer));
00243 e_wsfe();
00244
00245 return 0;
00246
00247
00248
00249 }