00001
00002
00003
00004
00005
00006 #ifdef __cplusplus
00007 extern "C" {
00008 #endif
00009 #include "f2c.h"
00010
00011 int drlhre_(integer *ndim, doublereal *center, doublereal *
00012 hwidth, integer *wtleng, doublereal *g, doublereal *w, doublereal *
00013 errcof, integer *numfun, S_fp funsub, doublereal *scales, doublereal *
00014 norms, doublereal *x, doublereal *null, doublereal *basval,
00015 doublereal *rgnerr, doublereal *direct)
00016 {
00017
00018 integer null_dim1, null_offset, g_dim1, g_offset, i__1, i__2;
00019 doublereal d__1, d__2, d__3;
00020
00021
00022 static integer i__, j, k;
00023 static doublereal ratio, search, difmax;
00024 extern int dfshre_(integer *, doublereal *, doublereal *,
00025 doublereal *, doublereal *, integer *, S_fp, doublereal *,
00026 doublereal *);
00027 static doublereal frthdf, difsum;
00028 static integer divaxn;
00029 static doublereal rgnvol;
00030
00031
00032
00033
00034
00035
00036
00037
00038
00039
00040
00041
00042
00043
00044
00045
00046
00047
00048
00049
00050
00051
00052
00053
00054
00055
00056
00057
00058
00059
00060
00061
00062
00063
00064
00065
00066
00067
00068
00069
00070
00071
00072
00073
00074
00075
00076
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
00124
00125
00126
00127
00128
00129
00130
00131
00132
00133
00134
00135
00136
00137 --x;
00138 --hwidth;
00139 --center;
00140 norms -= 4;
00141 scales -= 4;
00142 w -= 6;
00143 g_dim1 = *ndim;
00144 g_offset = 1 + g_dim1;
00145 g -= g_offset;
00146 --errcof;
00147 --rgnerr;
00148 --basval;
00149 null_dim1 = *numfun;
00150 null_offset = 1 + null_dim1;
00151 null -= null_offset;
00152
00153
00154 rgnvol = 1.;
00155 divaxn = 1;
00156 i__1 = *ndim;
00157 for (i__ = 1; i__ <= i__1; ++i__) {
00158 rgnvol *= hwidth[i__];
00159 x[i__] = center[i__];
00160 if (hwidth[i__] > hwidth[divaxn]) {
00161 divaxn = i__;
00162 }
00163
00164 }
00165 (*funsub)(ndim, &x[1], numfun, &rgnerr[1]);
00166 i__1 = *numfun;
00167 for (j = 1; j <= i__1; ++j) {
00168 basval[j] = w[6] * rgnerr[j];
00169 for (k = 1; k <= 4; ++k) {
00170 null[j + k * null_dim1] = w[k + 6] * rgnerr[j];
00171
00172 }
00173
00174 }
00175 difmax = 0.;
00176
00177 d__1 = g[g_dim1 * 3 + 1] / g[(g_dim1 << 1) + 1];
00178 ratio = d__1 * d__1;
00179 i__1 = *ndim;
00180 for (i__ = 1; i__ <= i__1; ++i__) {
00181 x[i__] = center[i__] - hwidth[i__] * g[(g_dim1 << 1) + 1];
00182 (*funsub)(ndim, &x[1], numfun, &null[null_dim1 * 5 + 1]);
00183 x[i__] = center[i__] + hwidth[i__] * g[(g_dim1 << 1) + 1];
00184 (*funsub)(ndim, &x[1], numfun, &null[null_dim1 * 6 + 1]);
00185 x[i__] = center[i__] - hwidth[i__] * g[g_dim1 * 3 + 1];
00186 (*funsub)(ndim, &x[1], numfun, &null[null_dim1 * 7 + 1]);
00187 x[i__] = center[i__] + hwidth[i__] * g[g_dim1 * 3 + 1];
00188 (*funsub)(ndim, &x[1], numfun, &null[(null_dim1 << 3) + 1]);
00189 x[i__] = center[i__];
00190 difsum = 0.;
00191 i__2 = *numfun;
00192 for (j = 1; j <= i__2; ++j) {
00193 frthdf = (1 - ratio) * 2 * rgnerr[j] - (null[j + null_dim1 * 7] +
00194 null[j + (null_dim1 << 3)]) + ratio * (null[j + null_dim1
00195 * 5] + null[j + null_dim1 * 6]);
00196
00197
00198
00199 if (rgnerr[j] + frthdf / 4 != rgnerr[j]) {
00200 difsum += abs(frthdf);
00201 }
00202 for (k = 1; k <= 4; ++k) {
00203 null[j + k * null_dim1] = null[j + k * null_dim1] + w[k + 11]
00204 * (null[j + null_dim1 * 5] + null[j + null_dim1 * 6])
00205 + w[k + 16] * (null[j + null_dim1 * 7] + null[j + (
00206 null_dim1 << 3)]);
00207
00208 }
00209 basval[j] = basval[j] + w[11] * (null[j + null_dim1 * 5] + null[j
00210 + null_dim1 * 6]) + w[16] * (null[j + null_dim1 * 7] +
00211 null[j + (null_dim1 << 3)]);
00212
00213 }
00214 if (difsum > difmax) {
00215 difmax = difsum;
00216 divaxn = i__;
00217 }
00218
00219 }
00220 *direct = (doublereal) divaxn;
00221
00222
00223
00224 i__1 = *wtleng;
00225 for (i__ = 4; i__ <= i__1; ++i__) {
00226 dfshre_(ndim, ¢er[1], &hwidth[1], &x[1], &g[i__ * g_dim1 + 1],
00227 numfun, (S_fp)funsub, &rgnerr[1], &null[null_dim1 * 5 + 1]);
00228 i__2 = *numfun;
00229 for (j = 1; j <= i__2; ++j) {
00230 basval[j] += w[i__ * 5 + 1] * rgnerr[j];
00231 for (k = 1; k <= 4; ++k) {
00232 null[j + k * null_dim1] += w[k + 1 + i__ * 5] * rgnerr[j];
00233
00234 }
00235
00236 }
00237
00238 }
00239
00240
00241
00242 i__1 = *numfun;
00243 for (j = 1; j <= i__1; ++j) {
00244
00245
00246
00247
00248
00249
00250 for (i__ = 1; i__ <= 3; ++i__) {
00251 search = 0.;
00252 i__2 = *wtleng;
00253 for (k = 1; k <= i__2; ++k) {
00254
00255 d__2 = search, d__3 = (d__1 = null[j + (i__ + 1) * null_dim1]
00256 + scales[i__ + k * 3] * null[j + i__ * null_dim1],
00257 abs(d__1)) * norms[i__ + k * 3];
00258 search = max(d__2,d__3);
00259
00260 }
00261 null[j + i__ * null_dim1] = search;
00262
00263 }
00264 if (errcof[1] * null[j + null_dim1] <= null[j + (null_dim1 << 1)] &&
00265 errcof[2] * null[j + (null_dim1 << 1)] <= null[j + null_dim1 *
00266 3]) {
00267 rgnerr[j] = errcof[3] * null[j + null_dim1];
00268 } else {
00269
00270 d__1 = null[j + null_dim1], d__2 = null[j + (null_dim1 << 1)],
00271 d__1 = max(d__1,d__2), d__2 = null[j + null_dim1 * 3];
00272 rgnerr[j] = errcof[4] * max(d__1,d__2);
00273 }
00274 rgnerr[j] = rgnvol * rgnerr[j];
00275 basval[j] = rgnvol * basval[j];
00276
00277 }
00278
00279
00280
00281 return 0;
00282 }
00283
00284 #ifdef __cplusplus
00285 }
00286 #endif