00001
00002
00003
00004
00005
00006 #ifdef __cplusplus
00007 extern "C" {
00008 #endif
00009 #include "f2c.h"
00010
00011
00012
00013 static integer c__2 = 2;
00014
00015 int d09hre_(integer *ndim, integer *wtleng, doublereal *w,
00016 doublereal *g, doublereal *errcof, doublereal *rulpts)
00017 {
00018
00019 integer g_dim1, g_offset, i__1, i__2;
00020 doublereal d__1, d__2;
00021
00022
00023 integer pow_ii(integer *, integer *);
00024 double sqrt(doublereal);
00025
00026
00027 static integer i__, j;
00028 static doublereal lam0, lam1, lam2, lam3, lamp, ratio, twondm;
00029
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 --rulpts;
00082 g_dim1 = *ndim;
00083 g_offset = 1 + g_dim1;
00084 g -= g_offset;
00085 w -= 6;
00086 --errcof;
00087
00088
00089 i__1 = *wtleng;
00090 for (j = 1; j <= i__1; ++j) {
00091 i__2 = *ndim;
00092 for (i__ = 1; i__ <= i__2; ++i__) {
00093 g[i__ + j * g_dim1] = 0.;
00094
00095 }
00096 for (i__ = 1; i__ <= 5; ++i__) {
00097 w[i__ + j * 5] = 0.;
00098
00099 }
00100 rulpts[j] = (doublereal) (*ndim << 1);
00101
00102 }
00103 twondm = (doublereal) pow_ii(&c__2, ndim);
00104 rulpts[*wtleng] = twondm;
00105 if (*ndim > 2) {
00106 rulpts[8] = (doublereal) ((*ndim << 2) * (*ndim - 1) * (*ndim - 2) /
00107 3);
00108 }
00109 rulpts[7] = (doublereal) ((*ndim << 2) * (*ndim - 1));
00110 rulpts[6] = (doublereal) ((*ndim << 1) * (*ndim - 1));
00111 rulpts[1] = 1.;
00112
00113
00114
00115 lam0 = (float).4707;
00116 lam1 = 4 / (15 - 5 / lam0);
00117 ratio = (1 - lam1 / lam0) / 27;
00118 lam2 = (5 - lam1 * 7 - ratio * 35) / (7 - lam1 * 35 / 3 - ratio * 35 /
00119 lam0);
00120 ratio = ratio * (1 - lam2 / lam0) / 3;
00121 lam3 = (7 - (lam2 + lam1) * 9 + lam2 * 63 * lam1 / 5 - ratio * 63) / (9 -
00122 (lam2 + lam1) * 63 / 5 + lam2 * 21 * lam1 - ratio * 63 / lam0);
00123 lamp = (float).0625;
00124
00125
00126
00127
00128 d__1 = lam0 * 3, d__1 *= d__1;
00129 w[*wtleng * 5 + 1] = 1 / (d__1 * d__1) / twondm;
00130 if (*ndim > 2) {
00131
00132 d__1 = lam1 * 6;
00133 w[41] = (1 - 1 / (lam0 * 3)) / (d__1 * (d__1 * d__1));
00134 }
00135 w[36] = (1 - (lam0 + lam1) * 7 / 5 + lam0 * 7 * lam1 / 3) / (lam1 * 84 *
00136 lam2 * (lam2 - lam0) * (lam2 - lam1));
00137 w[31] = (1 - (lam0 + lam2) * 7 / 5 + lam0 * 7 * lam2 / 3) / (lam1 * 84 *
00138 lam1 * (lam1 - lam0) * (lam1 - lam2)) - w[36] * lam2 / lam1 - (*
00139 ndim - 2 << 1) * w[41];
00140 w[21] = (1 - ((lam0 + lam1 + lam2) / 7 - (lam0 * lam1 + lam0 * lam2 +
00141 lam1 * lam2) / 5) * 9 - lam0 * 3 * lam1 * lam2) / (lam3 * 18 * (
00142 lam3 - lam0) * (lam3 - lam1) * (lam3 - lam2));
00143 w[16] = (1 - ((lam0 + lam1 + lam3) / 7 - (lam0 * lam1 + lam0 * lam3 +
00144 lam1 * lam3) / 5) * 9 - lam0 * 3 * lam1 * lam3) / (lam2 * 18 * (
00145 lam2 - lam0) * (lam2 - lam1) * (lam2 - lam3)) - (*ndim - 1 << 1) *
00146 w[36];
00147 w[11] = (1 - ((lam0 + lam2 + lam3) / 7 - (lam0 * lam2 + lam0 * lam3 +
00148 lam2 * lam3) / 5) * 9 - lam0 * 3 * lam2 * lam3) / (lam1 * 18 * (
00149 lam1 - lam0) * (lam1 - lam2) * (lam1 - lam3)) - (*ndim - 1 << 1) *
00150 (w[36] + w[31] + (*ndim - 2) * w[41]);
00151
00152
00153
00154
00155 d__1 = lam0, d__1 *= d__1;
00156 w[*wtleng * 5 + 2] = 1 / (d__1 * d__1 * 108) / twondm;
00157 if (*ndim > 2) {
00158
00159 d__1 = lam0;
00160
00161 d__2 = lam1 * 6;
00162 w[42] = (1 - twondm * 27 * w[47] * (d__1 * (d__1 * d__1))) / (d__2 * (
00163 d__2 * d__2));
00164 }
00165
00166 d__1 = lam0;
00167 w[37] = (1 - lam1 * 5 / 3 - twondm * 15 * w[*wtleng * 5 + 2] * (d__1 *
00168 d__1) * (lam0 - lam1)) / (lam1 * 60 * lam2 * (lam2 - lam1));
00169
00170 d__1 = lam0;
00171 w[32] = (1 - (lam1 * 8 * lam2 * w[37] + twondm * w[*wtleng * 5 + 2] * (
00172 d__1 * d__1)) * 9) / (lam1 * 36 * lam1) - w[42] * 2 * (*ndim - 2);
00173 w[22] = (1 - ((lam1 + lam2) / 5 - lam1 * lam2 / 3 + twondm * w[*wtleng *
00174 5 + 2] * lam0 * (lam0 - lam1) * (lam0 - lam2)) * 7) / (lam3 * 14 *
00175 (lam3 - lam1) * (lam3 - lam2));
00176 w[17] = (1 - ((lam1 + lam3) / 5 - lam1 * lam3 / 3 + twondm * w[*wtleng *
00177 5 + 2] * lam0 * (lam0 - lam1) * (lam0 - lam3)) * 7) / (lam2 * 14 *
00178 (lam2 - lam1) * (lam2 - lam3)) - (*ndim - 1 << 1) * w[37];
00179 w[12] = (1 - ((lam2 + lam3) / 5 - lam2 * lam3 / 3 + twondm * w[*wtleng *
00180 5 + 2] * lam0 * (lam0 - lam2) * (lam0 - lam3)) * 7) / (lam1 * 14 *
00181 (lam1 - lam2) * (lam1 - lam3)) - (*ndim - 1 << 1) * (w[37] + w[
00182 32] + (*ndim - 2) * w[42]);
00183
00184 d__1 = lam0, d__1 *= d__1;
00185 w[*wtleng * 5 + 3] = 5 / (d__1 * d__1 * 324) / twondm;
00186 if (*ndim > 2) {
00187
00188 d__1 = lam0;
00189
00190 d__2 = lam1 * 6;
00191 w[43] = (1 - twondm * 27 * w[48] * (d__1 * (d__1 * d__1))) / (d__2 * (
00192 d__2 * d__2));
00193 }
00194
00195 d__1 = lam0;
00196 w[38] = (1 - lam1 * 5 / 3 - twondm * 15 * w[*wtleng * 5 + 3] * (d__1 *
00197 d__1) * (lam0 - lam1)) / (lam1 * 60 * lam2 * (lam2 - lam1));
00198
00199 d__1 = lam0;
00200 w[33] = (1 - (lam1 * 8 * lam2 * w[38] + twondm * w[*wtleng * 5 + 3] * (
00201 d__1 * d__1)) * 9) / (lam1 * 36 * lam1) - w[43] * 2 * (*ndim - 2);
00202 w[28] = (1 - ((lam1 + lam2) / 5 - lam1 * lam2 / 3 + twondm * w[*wtleng *
00203 5 + 3] * lam0 * (lam0 - lam1) * (lam0 - lam2)) * 7) / (lamp * 14 *
00204 (lamp - lam1) * (lamp - lam2));
00205 w[18] = (1 - ((lam1 + lamp) / 5 - lam1 * lamp / 3 + twondm * w[*wtleng *
00206 5 + 3] * lam0 * (lam0 - lam1) * (lam0 - lamp)) * 7) / (lam2 * 14 *
00207 (lam2 - lam1) * (lam2 - lamp)) - (*ndim - 1 << 1) * w[38];
00208 w[13] = (1 - ((lam2 + lamp) / 5 - lam2 * lamp / 3 + twondm * w[*wtleng *
00209 5 + 3] * lam0 * (lam0 - lam2) * (lam0 - lamp)) * 7) / (lam1 * 14 *
00210 (lam1 - lam2) * (lam1 - lamp)) - (*ndim - 1 << 1) * (w[38] + w[
00211 33] + (*ndim - 2) * w[43]);
00212
00213 d__1 = lam0, d__1 *= d__1;
00214 w[*wtleng * 5 + 4] = 2 / (d__1 * d__1 * 81) / twondm;
00215 if (*ndim > 2) {
00216
00217 d__1 = lam0;
00218
00219 d__2 = lam1 * 6;
00220 w[44] = (2 - twondm * 27 * w[49] * (d__1 * (d__1 * d__1))) / (d__2 * (
00221 d__2 * d__2));
00222 }
00223 w[39] = (2 - lam1 * 15 / 9 - twondm * 15 * w[*wtleng * 5 + 4] * lam0 * (
00224 lam0 - lam1)) / (lam1 * 60 * lam2 * (lam2 - lam1));
00225
00226 d__1 = lam0;
00227 w[34] = (1 - (lam1 * 8 * lam2 * w[39] + twondm * w[*wtleng * 5 + 4] * (
00228 d__1 * d__1)) * 9) / (lam1 * 36 * lam1) - w[44] * 2 * (*ndim - 2);
00229 w[24] = (2 - ((lam1 + lam2) / 5 - lam1 * lam2 / 3 + twondm * w[*wtleng *
00230 5 + 4] * lam0 * (lam0 - lam1) * (lam0 - lam2)) * 7) / (lam3 * 14 *
00231 (lam3 - lam1) * (lam3 - lam2));
00232 w[19] = (2 - ((lam1 + lam3) / 5 - lam1 * lam3 / 3 + twondm * w[*wtleng *
00233 5 + 4] * lam0 * (lam0 - lam1) * (lam0 - lam3)) * 7) / (lam2 * 14 *
00234 (lam2 - lam1) * (lam2 - lam3)) - (*ndim - 1 << 1) * w[39];
00235 w[14] = (2 - ((lam2 + lam3) / 5 - lam2 * lam3 / 3 + twondm * w[*wtleng *
00236 5 + 4] * lam0 * (lam0 - lam2) * (lam0 - lam3)) * 7) / (lam1 * 14 *
00237 (lam1 - lam2) * (lam1 - lam3)) - (*ndim - 1 << 1) * (w[39] + w[
00238 34] + (*ndim - 2) * w[44]);
00239 w[15] = 1 / (lam1 * 6);
00240
00241
00242
00243 lam0 = sqrt(lam0);
00244 lam1 = sqrt(lam1);
00245 lam2 = sqrt(lam2);
00246 lam3 = sqrt(lam3);
00247 lamp = sqrt(lamp);
00248 i__1 = *ndim;
00249 for (i__ = 1; i__ <= i__1; ++i__) {
00250 g[i__ + *wtleng * g_dim1] = lam0;
00251
00252 }
00253 if (*ndim > 2) {
00254 g[(g_dim1 << 3) + 1] = lam1;
00255 g[(g_dim1 << 3) + 2] = lam1;
00256 g[(g_dim1 << 3) + 3] = lam1;
00257 }
00258 g[g_dim1 * 7 + 1] = lam1;
00259 g[g_dim1 * 7 + 2] = lam2;
00260 g[g_dim1 * 6 + 1] = lam1;
00261 g[g_dim1 * 6 + 2] = lam1;
00262 g[g_dim1 * 5 + 1] = lamp;
00263 g[(g_dim1 << 2) + 1] = lam3;
00264 g[g_dim1 * 3 + 1] = lam2;
00265 g[(g_dim1 << 1) + 1] = lam1;
00266
00267
00268
00269
00270
00271 w[6] = twondm;
00272 for (j = 2; j <= 5; ++j) {
00273 i__1 = *wtleng;
00274 for (i__ = 2; i__ <= i__1; ++i__) {
00275 w[j + i__ * 5] -= w[i__ * 5 + 1];
00276 w[j + 5] -= rulpts[i__] * w[j + i__ * 5];
00277
00278 }
00279
00280 }
00281 i__1 = *wtleng;
00282 for (i__ = 2; i__ <= i__1; ++i__) {
00283 w[i__ * 5 + 1] = twondm * w[i__ * 5 + 1];
00284 w[6] -= rulpts[i__] * w[i__ * 5 + 1];
00285
00286 }
00287
00288
00289
00290 errcof[1] = 5.;
00291 errcof[2] = 5.;
00292 errcof[3] = (float)1.;
00293 errcof[4] = 5.;
00294 errcof[5] = (float).5;
00295 errcof[6] = (float).25;
00296
00297
00298
00299 return 0;
00300 }
00301
00302 #ifdef __cplusplus
00303 }
00304 #endif