projects / occt.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
0022312: Translation of french commentaries in OCCT files
[occt.git] / src / AdvApp2Var / AdvApp2Var_ApproxF2var.cxx
CommitLineData
7fd59977 1//
2// AdvApp2Var_ApproxF2var.cxx
3//
4#include <math.h>
5#include <AdvApp2Var_SysBase.hxx>
6#include <AdvApp2Var_MathBase.hxx>
7#include <AdvApp2Var_Data_f2c.hxx>
8#include <AdvApp2Var_Data.hxx>
9#include <AdvApp2Var_ApproxF2var.hxx>
10
11
12static
13int mmjacpt_(const integer *ndimen,
14 const integer *ncoefu,
15 const integer *ncoefv,
16 const integer *iordru,
17 const integer *iordrv,
18 const doublereal *ptclgd,
19 doublereal *ptcaux,
20 doublereal *ptccan);
21
22
23
24static
25int mma2ce2_(integer *numdec,
26 integer *ndimen,
27 integer *nbsesp,
28 integer *ndimse,
29 integer *ndminu,
30 integer *ndminv,
31 integer *ndguli,
32 integer *ndgvli,
33 integer *ndjacu,
34 integer *ndjacv,
35 integer *iordru,
36 integer *iordrv,
37 integer *nbpntu,
38 integer *nbpntv,
39 doublereal *epsapr,
40 doublereal *sosotb,
41 doublereal *disotb,
42 doublereal *soditb,
43 doublereal *diditb,
44 doublereal *gssutb,
45 doublereal *gssvtb,
46 doublereal *xmaxju,
47 doublereal *xmaxjv,
48 doublereal *vecerr,
49 doublereal *chpair,
50 doublereal *chimpr,
51 doublereal *patjac,
52 doublereal *errmax,
53 doublereal *errmoy,
54 integer *ndegpu,
55 integer *ndegpv,
56 integer *itydec,
57 integer *iercod);
58
59static
60int mma2cfu_(integer *ndujac,
61 integer *nbpntu,
62 integer *nbpntv,
63 doublereal *sosotb,
64 doublereal *disotb,
65 doublereal *soditb,
66 doublereal *diditb,
67 doublereal *gssutb,
68 doublereal *chpair,
69 doublereal *chimpr);
70
71static
72int mma2cfv_(integer *ndvjac,
73 integer *mindgu,
74 integer *maxdgu,
75 integer *nbpntv,
76 doublereal *gssvtb,
77 doublereal *chpair,
78 doublereal *chimpr,
79 doublereal *patjac);
80
81static
82int mma2er1_(integer *ndjacu,
83 integer *ndjacv,
84 integer *ndimen,
85 integer *mindgu,
86 integer *maxdgu,
87 integer *mindgv,
88 integer *maxdgv,
89 integer *iordru,
90 integer *iordrv,
91 doublereal *xmaxju,
92 doublereal *xmaxjv,
93 doublereal *patjac,
94 doublereal *vecerr,
95 doublereal *erreur);
96
97static
98int mma2er2_(integer *ndjacu,
99 integer *ndjacv,
100 integer *ndimen,
101 integer *mindgu,
102 integer *maxdgu,
103 integer *mindgv,
104 integer *maxdgv,
105 integer *iordru,
106 integer *iordrv,
107 doublereal *xmaxju,
108 doublereal *xmaxjv,
109 doublereal *patjac,
110 doublereal *epmscut,
111 doublereal *vecerr,
112 doublereal *erreur,
113 integer *newdgu,
114 integer *newdgv);
115
116static
117int mma2moy_(integer *ndgumx,
118 integer *ndgvmx,
119 integer *ndimen,
120 integer *mindgu,
121 integer *maxdgu,
122 integer *mindgv,
123 integer *maxdgv,
124 integer *iordru,
125 integer *iordrv,
126 doublereal *patjac,
127 doublereal *errmoy);
128
129static
130int mma2ds2_(integer *ndimen,
131 doublereal *uintfn,
132 doublereal *vintfn,
133 void (*foncnp) (
134 int *,
135 double *,
136 double *,
137 int *,
138 double *,
139 int *,
140 double *,
141 int *,
142 int *,
143 double *,
144 int *
145 ),
146 integer *nbpntu,
147 integer *nbpntv,
148 doublereal *urootb,
149 doublereal *vrootb,
150 integer *iiuouv,
151 doublereal *sosotb,
152 doublereal *disotb,
153 doublereal *soditb,
154 doublereal *diditb,
155 doublereal *fpntab,
156 doublereal *ttable,
157 integer *iercod);
158
159
160
161
162static
163int mma1fdi_(integer *ndimen,
164 doublereal *uvfonc,
165 void (*foncnp) (// see AdvApp2Var_EvaluatorFunc2Var.hxx for details
166 int *,
167 double *,
168 double *,
169 int *,
170 double *,
171 int *,
172 double *,
173 int *,
174 int *,
175 double *,
176 int *
177 ),
178 integer *isofav,
179 doublereal *tconst,
180 integer *nbroot,
181 doublereal *ttable,
182 integer *iordre,
183 integer *ideriv,
184 doublereal *fpntab,
185 doublereal *somtab,
186 doublereal *diftab,
187 doublereal *contr1,
188 doublereal *contr2,
189 integer *iercod);
190
191static
192int mma1cdi_(integer *ndimen,
193 integer *nbroot,
194 doublereal *rootlg,
195 integer *iordre,
196 doublereal *contr1,
197 doublereal *contr2,
198 doublereal *somtab,
199 doublereal *diftab,
200 doublereal *fpntab,
201 doublereal *hermit,
202 integer *iercod);
203static
204int mma1jak_(integer *ndimen,
205 integer *nbroot,
206 integer *iordre,
207 integer *ndgjac,
208 doublereal *somtab,
209 doublereal *diftab,
210 doublereal *cgauss,
211 doublereal *crvjac,
212 integer *iercod);
213static
214int mma1cnt_(integer *ndimen,
215 integer *iordre,
216 doublereal *contr1,
217 doublereal *contr2,
218 doublereal *hermit,
219 integer *ndgjac,
220 doublereal *crvjac);
221
222static
223int mma1fer_(integer *ndimen,
224 integer *nbsesp,
225 integer *ndimse,
226 integer *iordre,
227 integer *ndgjac,
228 doublereal *crvjac,
229 integer *ncflim,
230 doublereal *epsapr,
231 doublereal *ycvmax,
232 doublereal *errmax,
233 doublereal *errmoy,
234 integer *ncoeff,
235 integer *iercod);
236
237static
238int mma1noc_(doublereal *dfuvin,
239 integer *ndimen,
240 integer *iordre,
241 doublereal *cntrin,
242 doublereal *duvout,
243 integer *isofav,
244 integer *ideriv,
245 doublereal *cntout);
246
247
248static
249 int mmmapcoe_(integer *ndim,
250 integer *ndgjac,
251 integer *iordre,
252 integer *nbpnts,
253 doublereal *somtab,
254 doublereal *diftab,
255 doublereal *gsstab,
256 doublereal *crvjac);
257
258static
259 int mmaperm_(integer *ncofmx,
260 integer *ndim,
261 integer *ncoeff,
262 integer *iordre,
263 doublereal *crvjac,
264 integer *ncfnew,
265 doublereal *errmoy);
266
267
268#define mmapgss_1 mmapgss_
269#define mmapgs0_1 mmapgs0_
270#define mmapgs1_1 mmapgs1_
271#define mmapgs2_1 mmapgs2_
272
273//=======================================================================
274//function : mma1cdi_
275//purpose :
276//=======================================================================
277int mma1cdi_(integer *ndimen,
278 integer *nbroot,
279 doublereal *rootlg,
280 integer *iordre,
281 doublereal *contr1,
282 doublereal *contr2,
283 doublereal *somtab,
284 doublereal *diftab,
285 doublereal *fpntab,
286 doublereal *hermit,
287 integer *iercod)
288{
289 static integer c__1 = 1;
290
291 /* System generated locals */
292 integer contr1_dim1, contr1_offset, contr2_dim1, contr2_offset,
293 somtab_dim1, somtab_offset, diftab_dim1, diftab_offset,
294 fpntab_dim1, fpntab_offset, hermit_dim1, hermit_offset, i__1,
295 i__2, i__3;
296
297 /* Local variables */
298 static integer nroo2, ncfhe, nd, ii, kk;
299 static integer ibb, kkm, kkp;
300 static doublereal bid1, bid2, bid3;
301
7fd59977 302/* **********************************************************************
303*/
0d969553 304/* FUNCTION : */
7fd59977 305/* ---------- */
0d969553
Y		 306/* Discretisation on the parameters of interpolation polynomes */
307/* constraints of order IORDRE. */
7fd59977 308
0d969553 309/* KEYWORDS : */
7fd59977 310/* ----------- */
0d969553 311/* ALL, AB_SPECIFI::CONTRAINTE&, DISCRETISATION, &POINT */
7fd59977 312
0d969553 313/* INPUT ARGUMENTS : */
7fd59977 314/* ------------------ */
0d969553
Y		 315/* NDIMEN: Space dimension. */
316/* NBROOT: Number of INTERNAL discretisation parameters. */
317/* It is also the root number Legendre polynome where */
318/* the discretization is performed. */
319/* ROOTLG: Table of discretization parameters ON (-1,1). */
320/* IORDRE: Order of constraint imposed to the extremities of the iso. */
321/* = 0, the extremities of the iso are calculated */
322/* = 1, additionally, the 1st derivative in the direction */
323/* of the iso is calculated. */
324/* = 2, additionally, the 2nd derivative in the direction */
325/* of the iso is calculated. */
326/* CONTR1: Contains, if IORDRE>=0, values IORDRE+1 in TTABLE(0)
327*/
328/* (1st extremity) of derivatives of F(Uc,Ve) or F(Ue,Vc), */
329/* see below. */
330/* CONTR2: Contains, if IORDRE>=0, values IORDRE+1 in */
331/* TTABLE(NBROOT+1) (2nd extremity) of: */
332/* If ISOFAV=1, derived of order IDERIV by U, derived */
333/* ordre 0 to IORDRE by V of F(Uc,Ve) or Uc=TCONST */
334/* (fixed iso value) and Ve is the fixed extremity. */
335/* If ISOFAV=2, derivative of order IDERIV by V, derivative */
336/* of order 0 to IORDRE by U of F(Ue,Vc) or Vc=TCONST */
337/* (fixed iso value) and Ue is the fixed extremity. */
338
339/* SOMTAB: Table of NBROOT/2 sums of 2 index points */
340/* NBROOT-II+1 and II, for II = 1, NBROOT/2. */
341/* DIFTAB: Table of NBROOT/2 differences of 2 index points */
342/* NBROOT-II+1 and II, for II = 1, NBROOT/2. */
343
344/* OUTPUT ARGUMENTS : */
7fd59977 345/* ------------------- */
0d969553
Y		 346/* SOMTAB: Table of NBROOT/2 sums of 2 index points */
347/* NBROOT-II+1 and II, for II = 1, NBROOT/2 */
348/* DIFTAB: Table of NBROOT/2 differences of 2 index points */
349/* NBROOT-II+1 and II, for II = 1, NBROOT/2 */
350/* FPNTAB: Auxiliary table. */
351/* HERMIT: Table of coeff. 2*(IORDRE+1) Hermite polynoms */
352/* of degree 2*IORDRE+1. */
353/* IERCOD: Error code, */
354/* = 0, Everythig is OK */
355/* = 1, The value of IORDRE is out of (0,2) */
356/* COMMON USED : */
7fd59977 357/* ---------------- */
358
0d969553 359/* REFERENCES CALLED : */
7fd59977 360/* ----------------------- */
361
0d969553 362/* DESCRIPTION/NOTES/LIMITATIONS : */
7fd59977 363/* ----------------------------------- */
0d969553
Y		 364/* The results of discretization are arranged in 2 tables */
365/* SOMTAB and DIFTAB to earn time during the */
366/* calculation of coefficients of the approximation curve. */
7fd59977 367
0d969553
Y		 368/* If NBROOT is uneven in SOMTAB(0,*) and DIFTAB(0,*) one stores */
369/* the values of the median root of Legendre (0.D0 in (-1,1)). */
7fd59977 370
7fd59977 371/* **********************************************************************
372*/
373
0d969553 374/* Name of the routine */
7fd59977 375
376
377 /* Parameter adjustments */
378 diftab_dim1 = *nbroot / 2 + 1;
379 diftab_offset = diftab_dim1;
380 diftab -= diftab_offset;
381 somtab_dim1 = *nbroot / 2 + 1;
382 somtab_offset = somtab_dim1;
383 somtab -= somtab_offset;
384 --rootlg;
385 hermit_dim1 = (*iordre << 1) + 2;
386 hermit_offset = hermit_dim1;
387 hermit -= hermit_offset;
388 fpntab_dim1 = *nbroot;
389 fpntab_offset = fpntab_dim1 + 1;
390 fpntab -= fpntab_offset;
391 contr2_dim1 = *ndimen;
392 contr2_offset = contr2_dim1 + 1;
393 contr2 -= contr2_offset;
394 contr1_dim1 = *ndimen;
395 contr1_offset = contr1_dim1 + 1;
396 contr1 -= contr1_offset;
397
398 /* Function Body */
399 ibb = AdvApp2Var_SysBase::mnfndeb_();
400 if (ibb >= 3) {
401 AdvApp2Var_SysBase::mgenmsg_("MMA1CDI", 7L);
402 }
403 *iercod = 0;
404
0d969553 405/* --- Recuperate 2*(IORDRE+1) coeff of 2*(IORDRE+1) of Hermite polynom ---
7fd59977 406*/
407
408 AdvApp2Var_ApproxF2var::mma1her_(iordre, &hermit[hermit_offset], iercod);
409 if (*iercod > 0) {
410 goto L9100;
411 }
412
0d969553 413/* ------------------- Discretization of Hermite polynoms -----------
7fd59977 414*/
415
416 ncfhe = (*iordre + 1) << 1;
417 i__1 = ncfhe;
418 for (ii = 1; ii <= i__1; ++ii) {
419 i__2 = *nbroot;
420 for (kk = 1; kk <= i__2; ++kk) {
421 AdvApp2Var_MathBase::mmmpocur_(&ncfhe, &c__1, &ncfhe, &hermit[ii * hermit_dim1], &
422 rootlg[kk], &fpntab[kk + ii * fpntab_dim1]);
423/* L200: */
424 }
425/* L100: */
426 }
427
0d969553 428/* ---- Discretizations of boundary polynoms are taken ----
7fd59977 429*/
430
431 nroo2 = *nbroot / 2;
432 i__1 = *ndimen;
433 for (nd = 1; nd <= i__1; ++nd) {
434 i__2 = *iordre + 1;
435 for (ii = 1; ii <= i__2; ++ii) {
436 bid1 = contr1[nd + ii * contr1_dim1];
437 bid2 = contr2[nd + ii * contr2_dim1];
438 i__3 = nroo2;
439 for (kk = 1; kk <= i__3; ++kk) {
440 kkm = nroo2 - kk + 1;
441 bid3 = bid1 * fpntab[kkm + ((ii << 1) - 1) * fpntab_dim1] +
442 bid2 * fpntab[kkm + (ii << 1) * fpntab_dim1];
443 somtab[kk + nd * somtab_dim1] -= bid3;
444 diftab[kk + nd * diftab_dim1] += bid3;
445/* L500: */
446 }
447 i__3 = nroo2;
448 for (kk = 1; kk <= i__3; ++kk) {
449 kkp = (*nbroot + 1) / 2 + kk;
450 bid3 = bid1 * fpntab[kkp + ((ii << 1) - 1) * fpntab_dim1] +
451 bid2 * fpntab[kkp + (ii << 1) * fpntab_dim1];
452 somtab[kk + nd * somtab_dim1] -= bid3;
453 diftab[kk + nd * diftab_dim1] -= bid3;
454/* L600: */
455 }
456/* L400: */
457 }
458/* L300: */
459 }
460
0d969553 461/* ------------ Cas when discretization is done on the roots of a -----------
7fd59977 462*/
0d969553 463/* ---------- Legendre polynom of uneven degree, 0 is root --------
7fd59977 464*/
465
466 if (*nbroot % 2 == 1) {
467 i__1 = *ndimen;
468 for (nd = 1; nd <= i__1; ++nd) {
469 i__2 = *iordre + 1;
470 for (ii = 1; ii <= i__2; ++ii) {
471 bid3 = fpntab[nroo2 + 1 + ((ii << 1) - 1) * fpntab_dim1] *
472 contr1[nd + ii * contr1_dim1] + fpntab[nroo2 + 1 + (
473 ii << 1) * fpntab_dim1] * contr2[nd + ii *
474 contr2_dim1];
475/* L800: */
476 }
477 somtab[nd * somtab_dim1] -= bid3;
478 diftab[nd * diftab_dim1] -= bid3;
479/* L700: */
480 }
481 }
482
483 goto L9999;
484
485/* ------------------------------ The End -------------------------------
486*/
0d969553 487/* --> IORDRE is not in the authorized zone. */
7fd59977 488L9100:
489 *iercod = 1;
490 goto L9999;
491
492L9999:
493 if (ibb >= 3) {
494 AdvApp2Var_SysBase::mgsomsg_("MMA1CDI", 7L);
495 }
496 return 0;
497} /* mma1cdi_ */
498
499//=======================================================================
500//function : mma1cnt_
501//purpose :
502//=======================================================================
503int mma1cnt_(integer *ndimen,
504 integer *iordre,
505 doublereal *contr1,
506 doublereal *contr2,
507 doublereal *hermit,
508 integer *ndgjac,
509 doublereal *crvjac)
510{
511 /* System generated locals */
512 integer contr1_dim1, contr1_offset, contr2_dim1, contr2_offset,
513 hermit_dim1, hermit_offset, crvjac_dim1, crvjac_offset, i__1,
514 i__2, i__3;
515
516 /* Local variables */
517 static integer nd, ii, jj, ibb;
518 static doublereal bid;
519
520
521 /* ***********************************************************************
522 */
523
0d969553 524 /* FUNCTION : */
7fd59977 525 /* ---------- */
0d969553 526 /* Add constraint to polynom. */
7fd59977 527
528 /* MOTS CLES : */
529 /* ----------- */
0d969553 530 /* ALL,AB_SPECIFI::COURE&,APPROXIMATION,ADDITION,&CONSTRAINT */
7fd59977 531
0d969553 532 /* INPUT ARGUMENTS : */
7fd59977 533 /* -------------------- */
0d969553
Y		 534 /* NDIMEN: Dimension of the space */
535 /* IORDRE: Order of constraint. */
536 /* CONTR1: pt of constraint in -1, from order 0 to IORDRE. */
537 /* CONTR2: Pt of constraint in +1, from order 0 to IORDRE. */
538 /* HERMIT: Table of Hermit polynoms of order IORDRE. */
539 /* CRVJAV: Curve of approximation in Jacobi base. */
7fd59977 540
0d969553 541 /* OUTPUT ARGUMENTS : */
7fd59977 542 /* --------------------- */
0d969553
Y		 543 /* CRVJAV: Curve of approximation in Jacobi base */
544 /* to which the polynom of interpolation of constraints is added. */
7fd59977 545
0d969553 546 /* COMMON USED : */
7fd59977 547 /* ------------------ */
548
549
0d969553 550 /* REFERENCES CALLED : */
7fd59977 551 /* --------------------- */
552
553
0d969553 554/* DESCRIPTION/NOTES/LIMITATIONS : */
7fd59977 555/* ----------------------------------- */
556
7fd59977 557/* > */
558/* ***********************************************************************
559 */
560/* DECLARATIONS */
561/* ***********************************************************************
562 */
0d969553 563/* Name of the routine */
7fd59977 564
565/* ***********************************************************************
566 */
567/* INITIALISATIONS */
568/* ***********************************************************************
569 */
570
571 /* Parameter adjustments */
572 hermit_dim1 = (*iordre << 1) + 2;
573 hermit_offset = hermit_dim1;
574 hermit -= hermit_offset;
575 contr2_dim1 = *ndimen;
576 contr2_offset = contr2_dim1 + 1;
577 contr2 -= contr2_offset;
578 contr1_dim1 = *ndimen;
579 contr1_offset = contr1_dim1 + 1;
580 contr1 -= contr1_offset;
581 crvjac_dim1 = *ndgjac + 1;
582 crvjac_offset = crvjac_dim1;
583 crvjac -= crvjac_offset;
584
585 /* Function Body */
586 ibb = AdvApp2Var_SysBase::mnfndeb_();
587 if (ibb >= 3) {
588 AdvApp2Var_SysBase::mgenmsg_("MMA1CNT", 7L);
589 }
590
591/* ***********************************************************************
592 */
0d969553 593/* Processing */
7fd59977 594/* ***********************************************************************
595 */
596
597 i__1 = *ndimen;
598 for (nd = 1; nd <= i__1; ++nd) {
599 i__2 = (*iordre << 1) + 1;
600 for (ii = 0; ii <= i__2; ++ii) {
601 bid = 0.;
602 i__3 = *iordre + 1;
603 for (jj = 1; jj <= i__3; ++jj) {
604 bid = bid + contr1[nd + jj * contr1_dim1] *
605 hermit[ii + ((jj << 1) - 1) * hermit_dim1] +
606 contr2[nd + jj * contr2_dim1] * hermit[ii + (jj << 1) * hermit_dim1];
607 /* L300: */
608 }
609 crvjac[ii + nd * crvjac_dim1] = bid;
610 /* L200: */
611 }
612 /* L100: */
613 }
614
615/* ***********************************************************************
616 */
0d969553 617/* RETURN CALLING PROGRAM */
7fd59977 618/* ***********************************************************************
619 */
620
621 if (ibb >= 3) {
622 AdvApp2Var_SysBase::mgsomsg_("MMA1CNT", 7L);
623 }
624
625 return 0 ;
626} /* mma1cnt_ */
627
628//=======================================================================
629//function : mma1fdi_
630//purpose :
631//=======================================================================
632int mma1fdi_(integer *ndimen,
633 doublereal *uvfonc,
634 void (*foncnp) (// see AdvApp2Var_EvaluatorFunc2Var.hxx for details
635 int *,
636 double *,
637 double *,
638 int *,
639 double *,
640 int *,
641 double *,
642 int *,
643 int *,
644 double *,
645 int *
646 ),
647 integer *isofav,
648 doublereal *tconst,
649 integer *nbroot,
650 doublereal *ttable,
651 integer *iordre,
652 integer *ideriv,
653 doublereal *fpntab,
654 doublereal *somtab,
655 doublereal *diftab,
656 doublereal *contr1,
657 doublereal *contr2,
658 integer *iercod)
659{
660 /* System generated locals */
661 integer fpntab_dim1, somtab_dim1, somtab_offset, diftab_dim1,
662 diftab_offset, contr1_dim1, contr1_offset, contr2_dim1,
663 contr2_offset, i__1, i__2;
664 doublereal d__1;
665
666 /* Local variables */
667 static integer ideb, ifin, nroo2, ideru, iderv;
668 static doublereal renor;
669 static integer ii, nd, ibb, iim, nbp, iip;
670 static doublereal bid1, bid2;
671
672/* **********************************************************************
673*/
674
0d969553 675/* FUNCTION : */
7fd59977 676/* ---------- */
0d969553
Y		 677/* DiscretiZation of a non-polynomial function F(U,V) or of */
678/* its derivative with fixed isoparameter. */
7fd59977 679
0d969553 680/* KEYWORDS : */
7fd59977 681/* ----------- */
0d969553 682/* ALL, AB_SPECIFI::FONCTION&, DISCRETISATION, &POINT */
7fd59977 683
0d969553 684/* INPUT ARGUMENTS : */
7fd59977 685/* ------------------ */
0d969553
Y		 686/* NDIMEN: Space dimension. */
687/* UVFONC: Limits of the path of definition by U and by V of the approximated function */
688/* FONCNP: The NAME of the non-polynomial function to be approximated */
689/* (external program). */
690/* ISOFAV: Fixed isoparameter for the discretization; */
691/* = 1, discretization with fixed U and variable V. */
692/* = 2, discretization with fixed V and variable U. */
693/* TCONST: Iso value is also fixed. */
694/* NBROOT: Number of INTERNAL discretization parameters. */
695/* (if there are constraints, 2 extremities should be added).
696*/
697/* This is also the root number of the Legendre polynom where */
698/* the discretization is done. */
699/* TTABLE: Table of discretization parameters and of 2 extremities */
700/* (Respectively (-1, NBROOT Legendre roots,1) */
701/* reframed within the adequate interval. */
702/* IORDRE: Order of constraint imposed on the extremities of the iso. */
703/* (If Iso-U, it is necessary to calculate the derivatives by V and vice */
7fd59977 704/* versa). */
0d969553
Y		 705/* = 0, the extremities of the iso are calculated. */
706/* = 1, additionally the 1st derivative in the direction of the iso is calculated */
707/* = 2, additionally the 2nd derivative in the direction of the iso is calculated */
708/* IDERIV: Order of derivative transversal to fixed iso (If Iso-U=Uc */
709/* is fixed, the derivative of order IDERIV is discretized by U of */
710/* F(Uc,v). Same if iso-V is fixed). */
711/* Varies from 0 (positioning) to 2 (2nd derivative). */
712
713/* OUTPUT ARGUMENTS : */
7fd59977 714/* ------------------- */
0d969553
Y		 715/* FPNTAB: Auxiliary table.
716 SOMTAB: Table of NBROOT/2 sums of 2 index points */
717/* NBROOT-II+1 and II, for II = 1, NBROOT/2 */
718/* DIFTAB: Table of NBROOT/2 differences of 2 index points */
719/* NBROOT-II+1 and II, for II = 1, NBROOT/2 */
720/* CONTR1: Contains, if IORDRE>=0, values IORDRE+1 in TTABLE(0)
721*/
722/* (1st extremity) of derivatives of F(Uc,Ve) or F(Ue,Vc), */
723/* see below. */
724/* CONTR2: Contains, if IORDRE>=0, values IORDRE+1 in */
725/* TTABLE(NBROOT+1) (2nd extremity) of: */
726/* If ISOFAV=1, derived of order IDERIV by U, derived */
727/* ordre 0 to IORDRE by V of F(Uc,Ve) or Uc=TCONST */
728/* (fixed iso value) and Ve is the fixed extremity. */
729/* If ISOFAV=2, derivative of order IDERIV by V, derivative */
730/* of order 0 to IORDRE by U of F(Ue,Vc) or Vc=TCONST */
731/* (fixed iso value) and Ue is the fixed extremity. */
732/* IERCOD: Error code > 100; Pb in evaluation of FONCNP, */
733/* the returned error code is equal to error code of FONCNP + 100. */
734
735/* COMMONS USED : */
7fd59977 736/* ---------------- */
737
0d969553 738/* REFERENCES CALLED : */
7fd59977 739/* ----------------------- */
740
0d969553 741/* DESCRIPTION/NOTES/LIMITATIONS : */
7fd59977 742/* ----------------------------------- */
0d969553
Y		 743/* The results of discretization are arranged in 2 tables */
744/* SOMTAB and DIFTAB to earn time during the */
745/* calculation of coefficients of the approximation curve. */
7fd59977 746
0d969553
Y		 747/* If NBROOT is uneven in SOMTAB(0,*) and DIFTAB(0,*) one stores */
748/* the values of the median root of Legendre (0.D0 in (-1,1)). */
7fd59977 749
0d969553
Y		 750/* Function F(u,v) defined in UVFONC is reparameterized in */
751/* (-1,1)x(-1,1). Then 1st and 2nd derivatives are renormalized. */
7fd59977 752
7fd59977 753/* > */
754/* **********************************************************************
755*/
756
0d969553 757/* Name of the routine */
7fd59977 758
759
760 /* Parameter adjustments */
761 uvfonc -= 3;
762 diftab_dim1 = *nbroot / 2 + 1;
763 diftab_offset = diftab_dim1;
764 diftab -= diftab_offset;
765 somtab_dim1 = *nbroot / 2 + 1;
766 somtab_offset = somtab_dim1;
767 somtab -= somtab_offset;
768 fpntab_dim1 = *ndimen;
769 --fpntab;
770 contr2_dim1 = *ndimen;
771 contr2_offset = contr2_dim1 + 1;
772 contr2 -= contr2_offset;
773 contr1_dim1 = *ndimen;
774 contr1_offset = contr1_dim1 + 1;
775 contr1 -= contr1_offset;
776
777 /* Function Body */
778 ibb = AdvApp2Var_SysBase::mnfndeb_();
779 if (ibb >= 3) {
780 AdvApp2Var_SysBase::mgenmsg_("MMA1FDI", 7L);
781 }
782 *iercod = 0;
783
0d969553 784/* --------------- Definition of the nb of points to calculate --------------
7fd59977 785*/
0d969553 786/* --> If constraints, the limits are also taken */
7fd59977 787 if (*iordre >= 0) {
788 ideb = 0;
789 ifin = *nbroot + 1;
0d969553 790/* --> Otherwise, only Legendre roots (reframed) are used
7fd59977 791. */
792 } else {
793 ideb = 1;
794 ifin = *nbroot;
795 }
0d969553 796/* --> Nb of point to calculate. */
7fd59977 797 nbp = ifin - ideb + 1;
798 nroo2 = *nbroot / 2;
799
0d969553 800/* --------------- Determination of the order of global derivation --------
7fd59977 801*/
0d969553
Y		 802/* --> ISOFAV takes only values 1 or 2. */
803/* if Iso-U, derive by U of order IDERIV */
7fd59977 804 if (*isofav == 1) {
805 ideru = *ideriv;
806 iderv = 0;
807 d__1 = (uvfonc[4] - uvfonc[3]) / 2.;
808 renor = AdvApp2Var_MathBase::pow__di(&d__1, ideriv);
0d969553 809/* if Iso-V, derive by V of order IDERIV */
7fd59977 810 } else {
811 ideru = 0;
812 iderv = *ideriv;
813 d__1 = (uvfonc[6] - uvfonc[5]) / 2.;
814 renor = AdvApp2Var_MathBase::pow__di(&d__1, ideriv);
815 }
816
0d969553 817/* ----------- Discretization on roots of the ---------------
7fd59977 818*/
0d969553 819/* ---------------------- Legendre polynom of degree NBROOT -------------------
7fd59977 820*/
821
822 (*foncnp)(ndimen,
823 &uvfonc[3],
824 &uvfonc[5],
825 isofav,
826 tconst,
827 &nbp,
828 &ttable[ideb],
829 &ideru,
830 &iderv,
831 &fpntab[ideb * fpntab_dim1 + 1],
832 iercod);
833 if (*iercod > 0) {
834 goto L9999;
835 }
836 i__1 = *ndimen;
837 for (nd = 1; nd <= i__1; ++nd) {
838 i__2 = nroo2;
839 for (ii = 1; ii <= i__2; ++ii) {
840 iip = (*nbroot + 1) / 2 + ii;
841 iim = nroo2 - ii + 1;
842 bid1 = fpntab[nd + iim * fpntab_dim1];
843 bid2 = fpntab[nd + iip * fpntab_dim1];
844 somtab[ii + nd * somtab_dim1] = renor * (bid2 + bid1);
845 diftab[ii + nd * diftab_dim1] = renor * (bid2 - bid1);
846/* L200: */
847 }
848/* L100: */
849 }
850
0d969553 851/* ------------ Case when discretisation is done on roots of a ----
7fd59977 852*/
0d969553 853/* ---------- Legendre polynom of uneven degree, 0 is root --------
7fd59977 854*/
855
856 if (*nbroot % 2 == 1) {
857 i__1 = *ndimen;
858 for (nd = 1; nd <= i__1; ++nd) {
859 somtab[nd * somtab_dim1] = renor * fpntab[nd + (nroo2 + 1) *
860 fpntab_dim1];
861 diftab[nd * diftab_dim1] = renor * fpntab[nd + (nroo2 + 1) *
862 fpntab_dim1];
863/* L300: */
864 }
865 } else {
866 i__1 = *ndimen;
867 for (nd = 1; nd <= i__1; ++nd) {
868 somtab[nd * somtab_dim1] = 0.;
869 diftab[nd * diftab_dim1] = 0.;
870 }
871 }
872
873
0d969553 874/* --------------------- Take into account constraints ----------------
7fd59977 875*/
876
877 if (*iordre >= 0) {
0d969553 878/* --> Recover already calculated extremities. */
7fd59977 879 i__1 = *ndimen;
880 for (nd = 1; nd <= i__1; ++nd) {
881 contr1[nd + contr1_dim1] = renor * fpntab[nd];
882 contr2[nd + contr2_dim1] = renor * fpntab[nd + (*nbroot + 1) *
883 fpntab_dim1];
884/* L400: */
885 }
0d969553 886/* --> Nb of points to calculate/call to FONCNP */
7fd59977 887 nbp = 1;
0d969553 888/* If Iso-U, derive by V till order IORDRE */
7fd59977 889 if (*isofav == 1) {
0d969553 890/* --> Factor of normalisation 1st derivative. */
7fd59977 891 bid1 = (uvfonc[6] - uvfonc[5]) / 2.;
892 i__1 = *iordre;
893 for (iderv = 1; iderv <= i__1; ++iderv) {
894 (*foncnp)(ndimen, &uvfonc[3], &uvfonc[5], isofav, tconst, &
895 nbp, ttable, &ideru, &iderv, &contr1[(iderv + 1) *
896 contr1_dim1 + 1], iercod);
897 if (*iercod > 0) {
898 goto L9999;
899 }
900/* L500: */
901 }
902 i__1 = *iordre;
903 for (iderv = 1; iderv <= i__1; ++iderv) {
904 (*foncnp)(ndimen, &uvfonc[3], &uvfonc[5], isofav, tconst, &
905 nbp, &ttable[*nbroot + 1], &ideru, &iderv, &contr2[(
906 iderv + 1) * contr2_dim1 + 1], iercod);
907 if (*iercod > 0) {
908 goto L9999;
909 }
910/* L510: */
911 }
0d969553 912/* If Iso-V, derive by U till order IORDRE */
7fd59977 913 } else {
0d969553 914/* --> Factor of normalization 1st derivative. */
7fd59977 915 bid1 = (uvfonc[4] - uvfonc[3]) / 2.;
916 i__1 = *iordre;
917 for (ideru = 1; ideru <= i__1; ++ideru) {
918 (*foncnp)(ndimen, &uvfonc[3], &uvfonc[5], isofav, tconst, &
919 nbp, ttable, &ideru, &iderv, &contr1[(ideru + 1) *
920 contr1_dim1 + 1], iercod);
921 if (*iercod > 0) {
922 goto L9999;
923 }
924/* L600: */
925 }
926 i__1 = *iordre;
927 for (ideru = 1; ideru <= i__1; ++ideru) {
928 (*foncnp)(ndimen, &uvfonc[3], &uvfonc[5], isofav, tconst, &
929 nbp, &ttable[*nbroot + 1], &ideru, &iderv, &contr2[(
930 ideru + 1) * contr2_dim1 + 1], iercod);
931 if (*iercod > 0) {
932 goto L9999;
933 }
934/* L610: */
935 }
936 }
937
0d969553 938/* ------------------------- Normalization of derivatives -------------
7fd59977 939---- */
0d969553 940/* (The function is redefined on (-1,1)*(-1,1)) */
7fd59977 941 bid2 = renor;
942 i__1 = *iordre;
943 for (ii = 1; ii <= i__1; ++ii) {
944 bid2 = bid1 * bid2;
945 i__2 = *ndimen;
946 for (nd = 1; nd <= i__2; ++nd) {
947 contr1[nd + (ii + 1) * contr1_dim1] *= bid2;
948 contr2[nd + (ii + 1) * contr2_dim1] *= bid2;
949/* L710: */
950 }
951/* L700: */
952 }
953 }
954
955/* ------------------------------ The end -------------------------------
956*/
957
958L9999:
959 if (*iercod > 0) {
960 *iercod += 100;
961 AdvApp2Var_SysBase::maermsg_("MMA1FDI", iercod, 7L);
962 }
963 if (ibb >= 3) {
964 AdvApp2Var_SysBase::mgsomsg_("MMA1FDI", 7L);
965 }
966 return 0;
967} /* mma1fdi_ */
968
969//=======================================================================
970//function : mma1fer_
971//purpose :
972//=======================================================================
973int mma1fer_(integer *,//ndimen,
974 integer *nbsesp,
975 integer *ndimse,
976 integer *iordre,
977 integer *ndgjac,
978 doublereal *crvjac,
979 integer *ncflim,
980 doublereal *epsapr,
981 doublereal *ycvmax,
982 doublereal *errmax,
983 doublereal *errmoy,
984 integer *ncoeff,
985 integer *iercod)
986{
987 /* System generated locals */
988 integer crvjac_dim1, crvjac_offset, i__1, i__2;
989
990 /* Local variables */
991 static integer idim, ncfja, ncfnw, ndses, ii, kk, ibb, ier;
992 static integer nbr0;
993
994
995/* ***********************************************************************
996 */
997
0d969553 998/* FUNCTION : */
7fd59977 999/* ---------- */
0d969553 1000/* Calculate the degree and the errors of approximation of a border. */
7fd59977 1001
0d969553 1002/* KEYWORDS : */
7fd59977 1003/* ----------- */
1004/* TOUS,AB_SPECIFI :: COURBE&,TRONCATURE, &PRECISION */
1005
0d969553 1006/* INPUT ARGUMENTS : */
7fd59977 1007/* -------------------- */
7fd59977 1008
0d969553
Y		 1009/* NDIMEN: Total Dimension of the space (sum of dimensions of sub-spaces) */
1010/* NBSESP: Number of "independent" sub-spaces. */
1011/* NDIMSE: Table of dimensions of sub-spaces. */
1012/* IORDRE: Order of constraint at the extremities of the border */
1013/* -1 = no constraints, */
1014/* 0 = constraints of passage to limits (i.e. C0), */
1015/* 1 = C0 + constraintes of 1st derivatives (i.e. C1), */
1016/* 2 = C1 + constraintes of 2nd derivatives (i.e. C2). */
1017/* NDGJAC: Degree of development in series to use for the calculation
1018/* in the base of Jacobi. */
1019/* CRVJAC: Table of coeff. of the curve of approximation in the */
1020/* base of Jacobi. */
1021/* NCFLIM: Max number of coeff of the polynomial curve */
1022/* of approximation (should be above or equal to */
1023/* 2*IORDRE+2 and below or equal to 50). */
1024/* EPSAPR: Table of errors of approximations that cannot be passed, */
1025/* sub-space by sub-space. */
1026
1027/* OUTPUT ARGUMENTS : */
7fd59977 1028/* --------------------- */
0d969553
Y		 1029/* YCVMAX: Auxiliary Table. */
1030/* ERRMAX: Table of errors (sub-space by sub-space) */
1031/* MAXIMUM made in the approximation of FONCNP by */
7fd59977 1032/* COURBE. */
0d969553
Y		 1033/* ERRMOY: Table of errors (sub-space by sub-space) */
1034/* AVERAGE made in the approximation of FONCNP by */
7fd59977 1035/* COURBE. */
0d969553
Y		 1036/* NCOEFF: Number of significative coeffs. of the calculated "curve". */
1037/* IERCOD: Error code */
7fd59977 1038/* = 0, ok, */
0d969553
Y		 1039/* =-1, warning, required tolerance can't be */
1040/* met with coefficients NFCLIM. */
1041/* = 1, order of constraints (IORDRE) is not within authorised values */
1042/*
7fd59977 1043
0d969553 1044/* COMMONS USED : */
7fd59977 1045/* ------------------ */
1046
0d969553 1047/* REFERENCES CALLED : */
7fd59977 1048/* --------------------- */
1049
0d969553 1050/* DESCRIPTION/NOTES/LIMITATIONS : */
7fd59977 1051/* ----------------------------------- */
7fd59977 1052/* > */
1053/* **********************************************************************
1054*/
1055
0d969553 1056/* Name of the routine */
7fd59977 1057
1058
1059 /* Parameter adjustments */
1060 --ycvmax;
1061 --errmoy;
1062 --errmax;
1063 --epsapr;
1064 --ndimse;
1065 crvjac_dim1 = *ndgjac + 1;
1066 crvjac_offset = crvjac_dim1;
1067 crvjac -= crvjac_offset;
1068
1069 /* Function Body */
1070 ibb = AdvApp2Var_SysBase::mnfndeb_();
1071 if (ibb >= 3) {
1072 AdvApp2Var_SysBase::mgenmsg_("MMA1FER", 7L);
1073 }
1074 *iercod = 0;
1075 idim = 1;
1076 *ncoeff = 0;
1077 ncfja = *ndgjac + 1;
1078
0d969553 1079/* ------------ Calculate the degree of the curve and of the Max error --------
7fd59977 1080*/
0d969553 1081/* -------------- of approximation for all sub-spaces --------
7fd59977 1082*/
1083
1084 i__1 = *nbsesp;
1085 for (ii = 1; ii <= i__1; ++ii) {
1086 ndses = ndimse[ii];
1087
0d969553 1088/* ------------ cutting of coeff. and calculation of Max error -------
7fd59977 1089---- */
1090
1091 AdvApp2Var_MathBase::mmtrpjj_(&ncfja, &ndses, &ncfja, &epsapr[ii], iordre, &crvjac[idim *
1092 crvjac_dim1], &ycvmax[1], &errmax[ii], &ncfnw);
1093
1094/* ******************************************************************
1095**** */
0d969553 1096/* ------------- If precision OK, calculate the average error -------
7fd59977 1097---- */
1098/* ******************************************************************
1099**** */
1100
1101 if (ncfnw <= *ncflim) {
1102 mmaperm_(&ncfja, &ndses, &ncfja, iordre, &crvjac[idim *
1103 crvjac_dim1], &ncfnw, &errmoy[ii]);
1104 *ncoeff = max(ncfnw,*ncoeff);
1105
0d969553 1106/* ------------- Set the declined coefficients to 0.D0 -----------
7fd59977 1107-------- */
1108
1109 nbr0 = *ncflim - ncfnw;
1110 if (nbr0 > 0) {
1111 i__2 = ndses;
1112 for (kk = 1; kk <= i__2; ++kk) {
1113 AdvApp2Var_SysBase::mvriraz_(&nbr0,
1114 (char *)&crvjac[ncfnw + (idim + kk - 1) * crvjac_dim1]);
1115/* L200: */
1116 }
1117 }
1118 } else {
1119
1120/* **************************************************************
1121******** */
0d969553 1122/* ------------------- If required precision can't be reached----
7fd59977 1123-------- */
1124/* **************************************************************
1125******** */
1126
1127 *iercod = -1;
1128
0d969553 1129/* ------------------------- calculate the Max error ------------
7fd59977 1130-------- */
1131
1132 AdvApp2Var_MathBase::mmaperx_(&ncfja, &ndses, &ncfja, iordre, &crvjac[idim *
1133 crvjac_dim1], ncflim, &ycvmax[1], &errmax[ii], &ier);
1134 if (ier > 0) {
1135 goto L9100;
1136 }
1137
0d969553 1138/* -------------------- nb of coeff to be returned -------------
7fd59977 1139-------- */
1140
1141 *ncoeff = *ncflim;
1142
0d969553 1143/* ------------------- and calculation of the average error ----
7fd59977 1144-------- */
1145
1146 mmaperm_(&ncfja, &ndses, &ncfja, iordre, &crvjac[idim *
1147 crvjac_dim1], ncflim, &errmoy[ii]);
1148 }
1149 idim += ndses;
1150/* L100: */
1151 }
1152
1153 goto L9999;
1154
1155/* ------------------------------ The end -------------------------------
1156*/
0d969553 1157/* --> The order of constraints is not within autorized values. */
7fd59977 1158L9100:
1159 *iercod = 1;
1160 goto L9999;
1161
1162L9999:
1163 if (*iercod != 0) {
1164 AdvApp2Var_SysBase::maermsg_("MMA1FER", iercod, 7L);
1165 }
1166 if (ibb >= 3) {
1167 AdvApp2Var_SysBase::mgsomsg_("MMA1FER", 7L);
1168 }
1169 return 0;
1170} /* mma1fer_ */
1171
1172
1173//=======================================================================
1174//function : mma1her_
1175//purpose :
1176//=======================================================================
1177int AdvApp2Var_ApproxF2var::mma1her_(const integer *iordre,
1178 doublereal *hermit,
1179 integer *iercod)
1180{
1181 /* System generated locals */
1182 integer hermit_dim1, hermit_offset;
1183
1184 /* Local variables */
1185 static integer ibb;
1186
1187
1188
1189/* **********************************************************************
1190*/
1191
0d969553 1192/* FUNCTION : */
7fd59977 1193/* ---------- */
0d969553
Y		 1194/* Calculate 2*(IORDRE+1) Hermit polynoms of degree 2*IORDRE+1 */
1195/* on (-1,1) */
7fd59977 1196
0d969553 1197/* KEYWORDS : */
7fd59977 1198/* ----------- */
0d969553 1199/* ALL, AB_SPECIFI::CONTRAINTE&, INTERPOLATION, &POLYNOME */
7fd59977 1200
0d969553 1201/* INPUT ARGUMENTS : */
7fd59977 1202/* ------------------ */
0d969553
Y		 1203/* IORDRE: Order of constraint. */
1204/* = 0, Polynom of interpolation of order C0 on (-1,1). */
1205/* = 1, Polynom of interpolation of order C0 and C1 on (-1,1). */
1206/* = 2, Polynom of interpolation of order C0, C1 and C2 on (-1,1).
7fd59977 1207*/
1208
0d969553 1209/* OUTPUT ARGUMENTS : */
7fd59977 1210/* ------------------- */
0d969553
Y		 1211/* HERMIT: Table of 2*IORDRE+2 coeff. of each of 2*(IORDRE+1) */
1212/* HERMIT polynom. */
1213/* IERCOD: Error code, */
7fd59977 1214/* = 0, Ok */
0d969553
Y		 1215/* = 1, required order of constraint is not managed here. */
1216/* COMMONS USED : */
7fd59977 1217/* ---------------- */
1218
0d969553 1219/* REFERENCES CALLED : */
7fd59977 1220/* ----------------------- */
1221
0d969553 1222/* DESCRIPTION/NOTES/LIMITATIONS : */
7fd59977 1223/* ----------------------------------- */
0d969553
Y		 1224/* The part of HERMIT(*,2*i+j) table where j=1 or 2 and i=0 to IORDRE,
1225/* contains the coefficients of the polynom of degree 2*IORDRE+1 */
1226/* such as ALL values in -1 and in +1 of this polynom and its */
1227/* derivatives till order of derivation IORDRE are NULL, */
1228/* EXCEPT for the derivative of order i: */
1229/* - valued 1 in -1 if j=1 */
1230/* - valued 1 in +1 if j=2. */
7fd59977 1231/* > */
1232/* **********************************************************************
1233*/
1234
0d969553 1235/* Name of the routine */
7fd59977 1236
1237
1238 /* Parameter adjustments */
1239 hermit_dim1 = (*iordre + 1) << 1;
1240 hermit_offset = hermit_dim1 + 1;
1241 hermit -= hermit_offset;
1242
1243 /* Function Body */
1244 ibb = AdvApp2Var_SysBase::mnfndeb_();
1245 if (ibb >= 3) {
1246 AdvApp2Var_SysBase::mgenmsg_("MMA1HER", 7L);
1247 }
1248 *iercod = 0;
1249
0d969553 1250/* --- Recover (IORDRE+2) coeff of 2*(IORDRE+1) Hermit polynoms --
7fd59977 1251*/
1252
1253 if (*iordre == 0) {
1254 hermit[hermit_dim1 + 1] = .5;
1255 hermit[hermit_dim1 + 2] = -.5;
1256
1257 hermit[(hermit_dim1 << 1) + 1] = .5;
1258 hermit[(hermit_dim1 << 1) + 2] = .5;
1259 } else if (*iordre == 1) {
1260 hermit[hermit_dim1 + 1] = .5;
1261 hermit[hermit_dim1 + 2] = -.75;
1262 hermit[hermit_dim1 + 3] = 0.;
1263 hermit[hermit_dim1 + 4] = .25;
1264
1265 hermit[(hermit_dim1 << 1) + 1] = .5;
1266 hermit[(hermit_dim1 << 1) + 2] = .75;
1267 hermit[(hermit_dim1 << 1) + 3] = 0.;
1268 hermit[(hermit_dim1 << 1) + 4] = -.25;
1269
1270 hermit[hermit_dim1 * 3 + 1] = .25;
1271 hermit[hermit_dim1 * 3 + 2] = -.25;
1272 hermit[hermit_dim1 * 3 + 3] = -.25;
1273 hermit[hermit_dim1 * 3 + 4] = .25;
1274
1275 hermit[(hermit_dim1 << 2) + 1] = -.25;
1276 hermit[(hermit_dim1 << 2) + 2] = -.25;
1277 hermit[(hermit_dim1 << 2) + 3] = .25;
1278 hermit[(hermit_dim1 << 2) + 4] = .25;
1279 } else if (*iordre == 2) {
1280 hermit[hermit_dim1 + 1] = .5;
1281 hermit[hermit_dim1 + 2] = -.9375;
1282 hermit[hermit_dim1 + 3] = 0.;
1283 hermit[hermit_dim1 + 4] = .625;
1284 hermit[hermit_dim1 + 5] = 0.;
1285 hermit[hermit_dim1 + 6] = -.1875;
1286
1287 hermit[(hermit_dim1 << 1) + 1] = .5;
1288 hermit[(hermit_dim1 << 1) + 2] = .9375;
1289 hermit[(hermit_dim1 << 1) + 3] = 0.;
1290 hermit[(hermit_dim1 << 1) + 4] = -.625;
1291 hermit[(hermit_dim1 << 1) + 5] = 0.;
1292 hermit[(hermit_dim1 << 1) + 6] = .1875;
1293
1294 hermit[hermit_dim1 * 3 + 1] = .3125;
1295 hermit[hermit_dim1 * 3 + 2] = -.4375;
1296 hermit[hermit_dim1 * 3 + 3] = -.375;
1297 hermit[hermit_dim1 * 3 + 4] = .625;
1298 hermit[hermit_dim1 * 3 + 5] = .0625;
1299 hermit[hermit_dim1 * 3 + 6] = -.1875;
1300
1301 hermit[(hermit_dim1 << 2) + 1] = -.3125;
1302 hermit[(hermit_dim1 << 2) + 2] = -.4375;
1303 hermit[(hermit_dim1 << 2) + 3] = .375;
1304 hermit[(hermit_dim1 << 2) + 4] = .625;
1305 hermit[(hermit_dim1 << 2) + 5] = -.0625;
1306 hermit[(hermit_dim1 << 2) + 6] = -.1875;
1307
1308 hermit[hermit_dim1 * 5 + 1] = .0625;
1309 hermit[hermit_dim1 * 5 + 2] = -.0625;
1310 hermit[hermit_dim1 * 5 + 3] = -.125;
1311 hermit[hermit_dim1 * 5 + 4] = .125;
1312 hermit[hermit_dim1 * 5 + 5] = .0625;
1313 hermit[hermit_dim1 * 5 + 6] = -.0625;
1314
1315 hermit[hermit_dim1 * 6 + 1] = .0625;
1316 hermit[hermit_dim1 * 6 + 2] = .0625;
1317 hermit[hermit_dim1 * 6 + 3] = -.125;
1318 hermit[hermit_dim1 * 6 + 4] = -.125;
1319 hermit[hermit_dim1 * 6 + 5] = .0625;
1320 hermit[hermit_dim1 * 6 + 6] = .0625;
1321 } else {
1322 *iercod = 1;
1323 }
1324
1325/* ------------------------------ The End -------------------------------
1326*/
1327
1328 AdvApp2Var_SysBase::maermsg_("MMA1HER", iercod, 7L);
1329 if (ibb >= 3) {
1330 AdvApp2Var_SysBase::mgsomsg_("MMA1HER", 7L);
1331 }
1332 return 0;
1333} /* mma1her_ */
1334//=======================================================================
1335//function : mma1jak_
1336//purpose :
1337//=======================================================================
1338int mma1jak_(integer *ndimen,
1339 integer *nbroot,
1340 integer *iordre,
1341 integer *ndgjac,
1342 doublereal *somtab,
1343 doublereal *diftab,
1344 doublereal *cgauss,
1345 doublereal *crvjac,
1346 integer *iercod)
1347{
1348 /* System generated locals */
1349 integer somtab_dim1, somtab_offset, diftab_dim1, diftab_offset,
1350 crvjac_dim1, crvjac_offset, cgauss_dim1;
1351
1352 /* Local variables */
1353 static integer ibb;
1354
1355/* **********************************************************************
1356*/
1357
0d969553 1358/* FUNCTION : */
7fd59977 1359/* ---------- */
0d969553
Y		 1360/* Calculate the curve of approximation of a non-polynomial function */
1361/* in the base of Jacobi. */
7fd59977 1362
0d969553 1363/* KEYWORDS : */
7fd59977 1364/* ----------- */
0d969553 1365/* FUNCTION,DISCRETISATION,APPROXIMATION,CONSTRAINT,CURVE,JACOBI */
7fd59977 1366
0d969553 1367/* INPUT ARGUMENTS : */
7fd59977 1368/* ------------------ */
0d969553
Y		 1369/* NDIMEN: Total dimension of the space (sum of dimensions */
1370/* of sub-spaces) */
1371/* NBROOT: Nb of points of discretization of the iso, extremities not
1372/* included. */
1373/* IORDRE: Order of constraint at the extremities of the boundary */
1374/* -1 = no constraints, */
1375/* 0 = constraints of passage of limits (i.e. C0), */
1376/* 1 = C0 + constraints of 1st derivatives (i.e. C1), */
1377/* 2 = C1 + constraints of 2nd derivatives (i.e. C2). */
1378/* NDGJAC: Degree of development in series to be used for calculation in the
1379/* base of Jacobi. */
1380
1381/* OUTPUT ARGUMENTS : */
7fd59977 1382/* ------------------- */
0d969553
Y		 1383/* CRVJAC : Curve of approximation of FONCNP with (eventually) */
1384/* taking into account of constraints at the extremities. */
1385/* This curve is of degree NDGJAC. */
1386/* IERCOD : Error code : */
1387/* 0 = All is ok. */
1388/* 33 = Pb to return data of du block data */
1389/* of coeff. of integration by GAUSS method. */
1390/* by program MMAPPTT. */
1391
1392/* COMMONS USED : */
7fd59977 1393/* ---------------- */
1394
0d969553 1395/* REFERENCES CALLED : */
7fd59977 1396/* ----------------------- */
7fd59977 1397/* > */
1398/* **********************************************************************
1399*/
1400
0d969553 1401/* Name of the routine */
7fd59977 1402
1403 /* Parameter adjustments */
1404 diftab_dim1 = *nbroot / 2 + 1;
1405 diftab_offset = diftab_dim1;
1406 diftab -= diftab_offset;
1407 somtab_dim1 = *nbroot / 2 + 1;
1408 somtab_offset = somtab_dim1;
1409 somtab -= somtab_offset;
1410 crvjac_dim1 = *ndgjac + 1;
1411 crvjac_offset = crvjac_dim1;
1412 crvjac -= crvjac_offset;
1413 cgauss_dim1 = *nbroot / 2 + 1;
1414
1415 /* Function Body */
1416 ibb = AdvApp2Var_SysBase::mnfndeb_();
1417 if (ibb >= 2) {
1418 AdvApp2Var_SysBase::mgenmsg_("MMA1JAK", 7L);
1419 }
1420 *iercod = 0;
1421
0d969553 1422/* ----------------- Recover coeffs of integration by Gauss -----------
7fd59977 1423*/
1424
1425 AdvApp2Var_ApproxF2var::mmapptt_(ndgjac, nbroot, iordre, cgauss, iercod);
1426 if (*iercod > 0) {
1427 *iercod = 33;
1428 goto L9999;
1429 }
1430
0d969553 1431/* --------------- Calculate the curve in the base of Jacobi -----------
7fd59977 1432*/
1433
1434 mmmapcoe_(ndimen, ndgjac, iordre, nbroot, &somtab[somtab_offset], &diftab[
1435 diftab_offset], cgauss, &crvjac[crvjac_offset]);
1436
1437/* ------------------------------ The End -------------------------------
1438*/
1439
1440L9999:
1441 if (*iercod != 0) {
1442 AdvApp2Var_SysBase::maermsg_("MMA1JAK", iercod, 7L);
1443 }
1444 if (ibb >= 2) {
1445 AdvApp2Var_SysBase::mgsomsg_("MMA1JAK", 7L);
1446 }
1447 return 0;
1448} /* mma1jak_ */
1449
1450//=======================================================================
1451//function : mma1noc_
1452//purpose :
1453//=======================================================================
1454int mma1noc_(doublereal *dfuvin,
1455 integer *ndimen,
1456 integer *iordre,
1457 doublereal *cntrin,
1458 doublereal *duvout,
1459 integer *isofav,
1460 integer *ideriv,
1461 doublereal *cntout)
1462{
1463 /* System generated locals */
1464 integer i__1;
1465 doublereal d__1;
1466
1467
1468 /* Local variables */
1469 static doublereal rider, riord;
1470 static integer nd, ibb;
1471 static doublereal bid;
1472/* **********************************************************************
1473*/
1474
0d969553 1475/* FUNCTION : */
7fd59977 1476/* ---------- */
0d969553
Y		 1477/* Normalization of constraints of derivatives, defined on DFUVIN */
1478/* on block DUVOUT. */
7fd59977 1479
0d969553 1480/* KEYWORDS : */
7fd59977 1481/* ----------- */
0d969553 1482/* ALL, AB_SPECIFI::VECTEUR&,DERIVEE&,NORMALISATION,&VECTEUR */
7fd59977 1483
0d969553 1484/* INPUT ARGUMENTS : */
7fd59977 1485/* ------------------ */
0d969553 1486/* DFUVIN: Limits of the block of definition by U and by V where
7fd59977 1487*/
0d969553
Y		 1488/* constraints CNTRIN are defined. */
1489/* NDIMEN: Dimension of the space. */
1490/* IORDRE: Order of constraint imposed at the extremities of the iso. */
1491/* (if Iso-U, it is necessary to calculate derivatives by V and vice */
7fd59977 1492/* versa). */
0d969553
Y		 1493/* = 0, the extremities of the iso are calculated */
1494/* = 1, additionally the 1st derivative in the direction */
1495/* of the iso is calculated */
1496/* = 2, additionally the 2nd derivative in the direction */
1497/* of the iso is calculated */
1498/* CNTRIN: Contains, if IORDRE>=0, IORDRE+1 derivatives */
1499/* of order IORDRE of F(Uc,v) or of F(u,Vc), following the */
1500/* value of ISOFAV, RENORMALIZED by u and v in (-1,1). */
1501/* DUVOUT: Limits of the block of definition by U and by V where the */
1502/* constraints CNTOUT will be defined. */
1503/* ISOFAV: Isoparameter fixed for the discretization; */
1504/* = 1, discretization with fixed U=Uc and variable V. */
1505/* = 2, discretization with fixed V=Vc and variable U. */
7fd59977 1506/* IDERIV: Ordre de derivee transverse a l'iso fixee (Si Iso-U=Uc */
0d969553
Y		 1507/* is fixed, the derivative of order IDERIV is discretized by U */
1508/* of F(Uc,v). The same if iso-V is fixed). */
1509/* Varies from (positioning) to 2 (2nd derivative). */
7fd59977 1510
0d969553 1511/* OUTPUT ARGUMENTS : */
7fd59977 1512/* ------------------- */
0d969553
Y		 1513/* CNTOUT: Contains, if IORDRE>=0, IORDRE+1 derivatives */
1514/* of order IORDRE of F(Uc,v) or of F(u,Vc), depending on the */
1515/* value of ISOFAV, RENORMALIZED for u and v in DUVOUT. */
7fd59977 1516
0d969553 1517/* COMMONS USED : */
7fd59977 1518/* ---------------- */
1519
0d969553
Y		 1520/* REFERENCES CALLED : */
1521/* --------------------- */
7fd59977 1522
0d969553
Y		 1523/* DESCRIPTION/NOTES/LIMITATIONS : */
1524/* ------------------------------- */
1525/* CNTRIN can be an output/input argument, */
1526/* so the call: */
7fd59977 1527
1528/* CALL MMA1NOC(DFUVIN,NDIMEN,IORDRE,CNTRIN,DUVOUT */
1529/* 1 ,ISOFAV,IDERIV,CNTRIN) */
1530
0d969553 1531/* is correct. */
7fd59977 1532/* > */
1533/* **********************************************************************
1534*/
1535
0d969553 1536/* Name of the routine */
7fd59977 1537
1538
1539 /* Parameter adjustments */
1540 dfuvin -= 3;
1541 --cntout;
1542 --cntrin;
1543 duvout -= 3;
1544
1545 /* Function Body */
1546 ibb = AdvApp2Var_SysBase::mnfndeb_();
1547 if (ibb >= 3) {
1548 AdvApp2Var_SysBase::mgenmsg_("MMA1NOC", 7L);
1549 }
1550
0d969553 1551/* --------------- Determination of coefficients of normalization -------
7fd59977 1552 */
1553
1554 if (*isofav == 1) {
1555 d__1 = (dfuvin[4] - dfuvin[3]) / (duvout[4] - duvout[3]);
1556 rider = AdvApp2Var_MathBase::pow__di(&d__1, ideriv);
1557 d__1 = (dfuvin[6] - dfuvin[5]) / (duvout[6] - duvout[5]);
1558 riord = AdvApp2Var_MathBase::pow__di(&d__1, iordre);
1559
1560 } else {
1561 d__1 = (dfuvin[6] - dfuvin[5]) / (duvout[6] - duvout[5]);
1562 rider = AdvApp2Var_MathBase::pow__di(&d__1, ideriv);
1563 d__1 = (dfuvin[4] - dfuvin[3]) / (duvout[4] - duvout[3]);
1564 riord = AdvApp2Var_MathBase::pow__di(&d__1, iordre);
1565 }
1566
0d969553 1567/* ------------- Renormalization of the vector of constraint ---------------
7fd59977 1568*/
1569
1570 bid = rider * riord;
1571 i__1 = *ndimen;
1572 for (nd = 1; nd <= i__1; ++nd) {
1573 cntout[nd] = bid * cntrin[nd];
1574/* L100: */
1575 }
1576
1577/* ------------------------------ The end -------------------------------
1578*/
1579
1580 if (ibb >= 3) {
1581 AdvApp2Var_SysBase::mgsomsg_("MMA1NOC", 7L);
1582 }
1583 return 0;
1584} /* mma1noc_ */
1585
1586//=======================================================================
1587//function : mma1nop_
1588//purpose :
1589//=======================================================================
1590int mma1nop_(integer *nbroot,
1591 doublereal *rootlg,
1592 doublereal *uvfonc,
1593 integer *isofav,
1594 doublereal *ttable,
1595 integer *iercod)
1596
1597{
1598 /* System generated locals */
1599 integer i__1;
1600
1601 /* Local variables */
1602 static doublereal alinu, blinu, alinv, blinv;
1603 static integer ii, ibb;
1604
1605
1606
1607/* ***********************************************************************
1608 */
1609
0d969553 1610/* FUNCTION : */
7fd59977 1611/* ---------- */
0d969553
Y		 1612/* Normalization of parameters of an iso, starting from */
1613/* parametric block and parameters on (-1,1). */
7fd59977 1614
0d969553 1615/* KEYWORDS : */
7fd59977 1616/* ----------- */
1617/* TOUS,AB_SPECIFI :: ISO&,POINT&,NORMALISATION,&POINT,&ISO */
1618
0d969553 1619/* INPUT ARGUMENTS : */
7fd59977 1620/* -------------------- */
0d969553
Y		 1621/* NBROOT: Nb of points of discretisation INSIDE the iso */
1622/* defined on (-1,1). */
1623/* ROOTLG: Table of discretization parameters on )-1,1( */
1624/* of the iso. */
1625/* UVFONC: Block of definition of the iso */
1626/* ISOFAV: = 1, this is iso-u; =2, this is iso-v. */
1627
1628/* OUTPUT ARGUMENTS : */
7fd59977 1629/* --------------------- */
0d969553 1630/* TTABLE: Table of parameters renormalized on UVFONC of the iso.
7fd59977 1631*/
1632/* IERCOD: = 0, OK */
0d969553 1633/* = 1, ISOFAV is out of allowed values. */
7fd59977 1634
7fd59977 1635/* > */
1636/* **********************************************************************
1637*/
0d969553 1638/* Name of the routine */
7fd59977 1639
1640
1641 /* Parameter adjustments */
1642 --rootlg;
1643 uvfonc -= 3;
1644
1645 /* Function Body */
1646 ibb = AdvApp2Var_SysBase::mnfndeb_();
1647 if (ibb >= 3) {
1648 AdvApp2Var_SysBase::mgenmsg_("MMA1NOP", 7L);
1649 }
1650
1651 alinu = (uvfonc[4] - uvfonc[3]) / 2.;
1652 blinu = (uvfonc[4] + uvfonc[3]) / 2.;
1653 alinv = (uvfonc[6] - uvfonc[5]) / 2.;
1654 blinv = (uvfonc[6] + uvfonc[5]) / 2.;
1655
1656 if (*isofav == 1) {
1657 ttable[0] = uvfonc[5];
1658 i__1 = *nbroot;
1659 for (ii = 1; ii <= i__1; ++ii) {
1660 ttable[ii] = alinv * rootlg[ii] + blinv;
1661/* L100: */
1662 }
1663 ttable[*nbroot + 1] = uvfonc[6];
1664 } else if (*isofav == 2) {
1665 ttable[0] = uvfonc[3];
1666 i__1 = *nbroot;
1667 for (ii = 1; ii <= i__1; ++ii) {
1668 ttable[ii] = alinu * rootlg[ii] + blinu;
1669/* L200: */
1670 }
1671 ttable[*nbroot + 1] = uvfonc[4];
1672 } else {
1673 goto L9100;
1674 }
1675
1676 goto L9999;
1677
1678/* ------------------------------ THE END -------------------------------
1679*/
1680
1681L9100:
1682 *iercod = 1;
1683 goto L9999;
1684
1685L9999:
1686 if (*iercod != 0) {
1687 AdvApp2Var_SysBase::maermsg_("MMA1NOP", iercod, 7L);
1688 }
1689 if (ibb >= 3) {
1690 AdvApp2Var_SysBase::mgsomsg_("MMA1NOP", 7L);
1691 }
1692
1693 return 0 ;
1694
1695} /* mma1nop_ */
1696
1697//=======================================================================
1698//function : mma2ac1_
1699//purpose :
1700//=======================================================================
1701int AdvApp2Var_ApproxF2var::mma2ac1_(integer const *ndimen,
1702 integer const *mxujac,
1703 integer const *mxvjac,
1704 integer const *iordru,
1705 integer const *iordrv,
1706 doublereal const *contr1,
1707 doublereal const * contr2,
1708 doublereal const *contr3,
1709 doublereal const *contr4,
1710 doublereal const *uhermt,
1711 doublereal const *vhermt,
1712 doublereal *patjac)
1713
1714{
1715 /* System generated locals */
1716 integer contr1_dim1, contr1_dim2, contr1_offset, contr2_dim1, contr2_dim2,
1717 contr2_offset, contr3_dim1, contr3_dim2, contr3_offset,
1718 contr4_dim1, contr4_dim2, contr4_offset, uhermt_dim1,
1719 uhermt_offset, vhermt_dim1, vhermt_offset, patjac_dim1,
1720 patjac_dim2, patjac_offset, i__1, i__2, i__3, i__4, i__5;
1721
1722 /* Local variables */
1723 static logical ldbg;
1724 static integer ndgu, ndgv;
1725 static doublereal bidu1, bidu2, bidv1, bidv2;
1726 static integer ioru1, iorv1, ii, nd, jj, ku, kv;
1727 static doublereal cnt1, cnt2, cnt3, cnt4;
1728
1729
1730
1731/* **********************************************************************
1732*/
1733
0d969553 1734/* FUNCTION : */
7fd59977 1735/* ---------- */
0d969553 1736/* Add polynoms of edge constraints. */
7fd59977 1737
0d969553 1738/* KEYWORDS : */
7fd59977 1739/* ----------- */
1740/* TOUS,AB_SPECIFI::POINT&,CONTRAINTE&,ADDITION,&POLYNOME */
1741
0d969553 1742/* INPUT ARGUMENTS : */
7fd59977 1743/* ------------------ */
0d969553
Y		 1744/* NDIMEN: Dimension of the space. */
1745/* MXUJAC: Max degree of the polynom of approximation by U. The */
1746/* representation in the orthogonal base starts from degree */
1747/* 0 to degree MXUJAC-2*(IORDRU+1). The polynomial base is the */
1748/* base of Jacobi of order -1 (Legendre), 0, 1 or 2 */
1749/* MXVJAC: Max degree of the polynom of approximation by V. The */
1750/* representation in the orthogonal base starts from degree */
1751/* 0 to degree MXUJAC-2*(IORDRU+1). The polynomial base is the */
1752/* base of Jacobi of order -1 (Legendre), 0, 1 or 2 */
1753/* IORDRU: Order of the base of Jacobi (-1,0,1 or 2) by U. Corresponds */
1754/* to the step of constraints: C0, C1 or C2. */
1755/* IORDRV: Order of the base of Jacobi (-1,0,1 or 2) by V. Corresponds */
1756/* to the step of constraints: C0, C1 or C2. */
1757/* CONTR1: Contains, if IORDRU and IORDRV>=0, the values at the */
1758/* extremities of F(U0,V0) and its derivatives. */
1759/* CONTR2: Contains, if IORDRU and IORDRV>=0, the values at the */
1760/* extremities of F(U1,V0) and its derivatives. */
1761/* CONTR3: Contains, if IORDRU and IORDRV>=0, the values at the */
1762/* extremities of F(U0,V1) and its derivatives. */
1763/* CONTR4: Contains, if IORDRU and IORDRV>=0, the values at the */
1764/* extremities of F(U1,V1) and its derivatives. */
1765/* UHERMT: Coeff. of Hermit polynoms of order IORDRU. */
1766/* VHERMT: Coeff. of Hermit polynoms of order IORDRV. */
1767/* PATJAC: Table of coefficients of the polynom P(u,v) of approximation */
1768/* of F(u,v) WITHOUT taking into account the constraints. */
1769
1770/* OUTPUT ARGUMENTS : */
7fd59977 1771/* ------------------- */
0d969553
Y		 1772/* PATJAC: Table of coefficients of the polynom P(u,v) by approximation */
1773/* of F(u,v) WITH taking into account of constraints. */
7fd59977 1774/* > */
1775/* **********************************************************************
1776*/
0d969553 1777/* Name of the routine */
7fd59977 1778
0d969553 1779/* --------------------------- Initialization --------------------------
7fd59977 1780*/
1781
1782 /* Parameter adjustments */
1783 patjac_dim1 = *mxujac + 1;
1784 patjac_dim2 = *mxvjac + 1;
1785 patjac_offset = patjac_dim1 * patjac_dim2;
1786 patjac -= patjac_offset;
1787 uhermt_dim1 = (*iordru << 1) + 2;
1788 uhermt_offset = uhermt_dim1;
1789 uhermt -= uhermt_offset;
1790 vhermt_dim1 = (*iordrv << 1) + 2;
1791 vhermt_offset = vhermt_dim1;
1792 vhermt -= vhermt_offset;
1793 contr4_dim1 = *ndimen;
1794 contr4_dim2 = *iordru + 2;
1795 contr4_offset = contr4_dim1 * (contr4_dim2 + 1) + 1;
1796 contr4 -= contr4_offset;
1797 contr3_dim1 = *ndimen;
1798 contr3_dim2 = *iordru + 2;
1799 contr3_offset = contr3_dim1 * (contr3_dim2 + 1) + 1;
1800 contr3 -= contr3_offset;
1801 contr2_dim1 = *ndimen;
1802 contr2_dim2 = *iordru + 2;
1803 contr2_offset = contr2_dim1 * (contr2_dim2 + 1) + 1;
1804 contr2 -= contr2_offset;
1805 contr1_dim1 = *ndimen;
1806 contr1_dim2 = *iordru + 2;
1807 contr1_offset = contr1_dim1 * (contr1_dim2 + 1) + 1;
1808 contr1 -= contr1_offset;
1809
1810 /* Function Body */
1811 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 3;
1812 if (ldbg) {
1813 AdvApp2Var_SysBase::mgenmsg_("MMA2AC1", 7L);
1814 }
1815
0d969553 1816/* ------------ SUBTRACTION OF ANGULAR CONSTRAINTS -------------------
7fd59977 1817*/
1818
1819 ioru1 = *iordru + 1;
1820 iorv1 = *iordrv + 1;
1821 ndgu = (*iordru << 1) + 1;
1822 ndgv = (*iordrv << 1) + 1;
1823
1824 i__1 = iorv1;
1825 for (jj = 1; jj <= i__1; ++jj) {
1826 i__2 = ioru1;
1827 for (ii = 1; ii <= i__2; ++ii) {
1828 i__3 = *ndimen;
1829 for (nd = 1; nd <= i__3; ++nd) {
1830 cnt1 = contr1[nd + (ii + jj * contr1_dim2) * contr1_dim1];
1831 cnt2 = contr2[nd + (ii + jj * contr2_dim2) * contr2_dim1];
1832 cnt3 = contr3[nd + (ii + jj * contr3_dim2) * contr3_dim1];
1833 cnt4 = contr4[nd + (ii + jj * contr4_dim2) * contr4_dim1];
1834 i__4 = ndgv;
1835 for (kv = 0; kv <= i__4; ++kv) {
1836 bidv1 = vhermt[kv + ((jj << 1) - 1) * vhermt_dim1];
1837 bidv2 = vhermt[kv + (jj << 1) * vhermt_dim1];
1838 i__5 = ndgu;
1839 for (ku = 0; ku <= i__5; ++ku) {
1840 bidu1 = uhermt[ku + ((ii << 1) - 1) * uhermt_dim1];
1841 bidu2 = uhermt[ku + (ii << 1) * uhermt_dim1];
1842 patjac[ku + (kv + nd * patjac_dim2) * patjac_dim1] =
1843 patjac[ku + (kv + nd * patjac_dim2) *
1844 patjac_dim1] - bidu1 * bidv1 * cnt1 - bidu2 *
1845 bidv1 * cnt2 - bidu1 * bidv2 * cnt3 - bidu2 *
1846 bidv2 * cnt4;
1847/* L500: */
1848 }
1849/* L400: */
1850 }
1851/* L300: */
1852 }
1853/* L200: */
1854 }
1855/* L100: */
1856 }
1857
1858/* ------------------------------ The end -------------------------------
1859*/
1860
1861 if (ldbg) {
1862 AdvApp2Var_SysBase::mgsomsg_("MMA2AC1", 7L);
1863 }
1864 return 0;
1865} /* mma2ac1_ */
1866
1867//=======================================================================
1868//function : mma2ac2_
1869//purpose :
1870//=======================================================================
1871int AdvApp2Var_ApproxF2var::mma2ac2_(const integer *ndimen,
1872 const integer *mxujac,
1873 const integer *mxvjac,
1874 const integer *iordrv,
1875 const integer *nclimu,
1876 const integer *ncfiv1,
1877 const doublereal *crbiv1,
1878 const integer *ncfiv2,
1879 const doublereal *crbiv2,
1880 const doublereal *vhermt,
1881 doublereal *patjac)
1882
1883{
1884 /* System generated locals */
1885 integer crbiv1_dim1, crbiv1_dim2, crbiv1_offset, crbiv2_dim1, crbiv2_dim2,
1886 crbiv2_offset, patjac_dim1, patjac_dim2, patjac_offset,
1887 vhermt_dim1, vhermt_offset, i__1, i__2, i__3, i__4;
1888
1889 /* Local variables */
1890 static logical ldbg;
1891 static integer ndgv1, ndgv2, ii, jj, nd, kk;
1892 static doublereal bid1, bid2;
1893
1894/* **********************************************************************
1895*/
1896
0d969553 1897/* FUNCTION : */
7fd59977 1898/* ---------- */
0d969553 1899/* Add polynoms of constraints */
7fd59977 1900
0d969553 1901/* KEYWORDS : */
7fd59977 1902/* ----------- */
0d969553 1903/* FUNCTION,APPROXIMATION,COEFFICIENT,POLYNOM */
7fd59977 1904
0d969553 1905/* INPUT ARGUMENTS : */
7fd59977 1906/* ------------------ */
0d969553
Y		 1907/* NDIMEN: Dimension of the space. */
1908/* MXUJAC: Max degree of the polynom of approximation by U. The */
1909/* representation in the orthogonal base starts from degree */
1910/* 0 to degree MXUJAC-2*(IORDRU+1). The polynomial base is the */
1911/* base of Jacobi of order -1 (Legendre), 0, 1 or 2 */
1912/* MXVJAC: Max degree of the polynom of approximation by V. The */
1913/* representation in the orthogonal base starts from degree */
1914/* 0 to degree MXUJAC-2*(IORDRU+1). The polynomial base is the */
1915/* base of Jacobi of order -1 (Legendre), 0, 1 or 2 */
1916/* IORDRV: Order of the base of Jacobi (-1,0,1 or 2) by V. Corresponds */
1917/* to the step of constraints: C0, C1 or C2. */
1918/* NCLIMU LIMIT nb of coeff by u of the solution P(u,v)
1919* NCFIV1: Nb of Coeff. of curves stored in CRBIV1. */
1920/* CRBIV1: Table of coeffs of the approximation of iso-V0 and its */
1921/* derivatives till order IORDRV. */
1922/* NCFIV2: Nb of Coeff. of curves stored in CRBIV2. */
1923/* CRBIV2: Table of coeffs of approximation of iso-V1 and its */
1924/* derivatives till order IORDRV. */
1925/* VHERMT: Coeff. of Hermit polynoms of order IORDRV. */
1926/* PATJAC: Table of coefficients of the polynom P(u,v) of approximation */
1927/* of F(u,v) WITHOUT taking into account the constraints. */
1928
1929/* OUTPUT ARGUMENTS : */
7fd59977 1930/* ------------------- */
0d969553
Y		 1931/* PATJAC: Table of coefficients of the polynom P(u,v) by approximation */
1932/* of F(u,v) WITH taking into account of constraints. */
1933/* > *//*
7fd59977 1934
7fd59977 1935
7fd59977 1936/* > */
1937/* **********************************************************************
1938*/
0d969553 1939/* Name of the routine */
7fd59977 1940
1941/* --------------------------- Initialisations --------------------------
1942*/
1943
1944 /* Parameter adjustments */
1945 patjac_dim1 = *mxujac + 1;
1946 patjac_dim2 = *mxvjac + 1;
1947 patjac_offset = patjac_dim1 * patjac_dim2;
1948 patjac -= patjac_offset;
1949 vhermt_dim1 = (*iordrv << 1) + 2;
1950 vhermt_offset = vhermt_dim1;
1951 vhermt -= vhermt_offset;
1952 --ncfiv2;
1953 --ncfiv1;
1954 crbiv2_dim1 = *nclimu;
1955 crbiv2_dim2 = *ndimen;
1956 crbiv2_offset = crbiv2_dim1 * (crbiv2_dim2 + 1);
1957 crbiv2 -= crbiv2_offset;
1958 crbiv1_dim1 = *nclimu;
1959 crbiv1_dim2 = *ndimen;
1960 crbiv1_offset = crbiv1_dim1 * (crbiv1_dim2 + 1);
1961 crbiv1 -= crbiv1_offset;
1962
1963 /* Function Body */
1964 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 3;
1965 if (ldbg) {
1966 AdvApp2Var_SysBase::mgenmsg_("MMA2AC2", 7L);
1967 }
1968
0d969553 1969/* ------------ ADDING of coeff by u of curves, by v of Hermit --------
7fd59977 1970*/
1971
1972 i__1 = *iordrv + 1;
1973 for (ii = 1; ii <= i__1; ++ii) {
1974 ndgv1 = ncfiv1[ii] - 1;
1975 ndgv2 = ncfiv2[ii] - 1;
1976 i__2 = *ndimen;
1977 for (nd = 1; nd <= i__2; ++nd) {
1978 i__3 = (*iordrv << 1) + 1;
1979 for (jj = 0; jj <= i__3; ++jj) {
1980 bid1 = vhermt[jj + ((ii << 1) - 1) * vhermt_dim1];
1981 i__4 = ndgv1;
1982 for (kk = 0; kk <= i__4; ++kk) {
1983 patjac[kk + (jj + nd * patjac_dim2) * patjac_dim1] +=
1984 bid1 * crbiv1[kk + (nd + ii * crbiv1_dim2) *
1985 crbiv1_dim1];
1986/* L400: */
1987 }
1988 bid2 = vhermt[jj + (ii << 1) * vhermt_dim1];
1989 i__4 = ndgv2;
1990 for (kk = 0; kk <= i__4; ++kk) {
1991 patjac[kk + (jj + nd * patjac_dim2) * patjac_dim1] +=
1992 bid2 * crbiv2[kk + (nd + ii * crbiv2_dim2) *
1993 crbiv2_dim1];
1994/* L500: */
1995 }
1996/* L300: */
1997 }
1998/* L200: */
1999 }
2000/* L100: */
2001 }
2002
2003/* ------------------------------ The end -------------------------------
2004*/
2005
2006 if (ldbg) {
2007 AdvApp2Var_SysBase::mgsomsg_("MMA2AC2", 7L);
2008 }
2009 return 0;
2010} /* mma2ac2_ */
2011
2012
2013//=======================================================================
2014//function : mma2ac3_
2015//purpose :
2016//=======================================================================
2017int AdvApp2Var_ApproxF2var::mma2ac3_(const integer *ndimen,
2018 const integer *mxujac,
2019 const integer *mxvjac,
2020 const integer *iordru,
2021 const integer *nclimv,
2022 const integer *ncfiu1,
2023 const doublereal * crbiu1,
2024 const integer *ncfiu2,
2025 const doublereal *crbiu2,
2026 const doublereal *uhermt,
2027 doublereal *patjac)
2028
2029{
2030 /* System generated locals */
2031 integer crbiu1_dim1, crbiu1_dim2, crbiu1_offset, crbiu2_dim1, crbiu2_dim2,
2032 crbiu2_offset, patjac_dim1, patjac_dim2, patjac_offset,
2033 uhermt_dim1, uhermt_offset, i__1, i__2, i__3, i__4;
2034
2035 /* Local variables */
2036 static logical ldbg;
2037 static integer ndgu1, ndgu2, ii, jj, nd, kk;
2038 static doublereal bid1, bid2;
2039
2040
2041
2042
2043/* **********************************************************************
2044*/
2045
0d969553 2046/* FUNCTION : */
7fd59977 2047/* ---------- */
2048/* Ajout des polynomes de contraintes */
2049
0d969553 2050/* KEYWORDS : */
7fd59977 2051/* ----------- */
2052/* FONCTION,APPROXIMATION,COEFFICIENT,POLYNOME */
2053
0d969553 2054/* INPUT ARGUMENTS : */
7fd59977 2055/* ------------------ */
0d969553
Y		 2056/* NDIMEN: Dimension of the space. */
2057/* MXUJAC: Max degree of the polynom of approximation by U. The */
2058/* representation in the orthogonal base starts from degree */
2059/* 0 to degree MXUJAC-2*(IORDRU+1). The polynomial base is the */
2060/* base of Jacobi of order -1 (Legendre), 0, 1 or 2 */
2061/* MXVJAC: Max degree of the polynom of approximation by V. The */
2062/* representation in the orthogonal base starts from degree */
2063/* 0 to degree MXUJAC-2*(IORDRU+1). The polynomial base is the */
2064/* base of Jacobi of order -1 (Legendre), 0, 1 or 2 */
2065/* IORDRU: Order of the base of Jacobi (-1,0,1 or 2) by U. Corresponds */
2066/* to the step of constraints: C0, C1 or C2. */
2067/* NCLIMV LIMIT nb of coeff by v of the solution P(u,v)
2068* NCFIU1: Nb of Coeff. of curves stored in CRBIU1. */
2069/* CRBIU1: Table of coeffs of the approximation of iso-U0 and its */
2070/* derivatives till order IORDRU. */
2071/* NCFIU2: Nb of Coeff. of curves stored in CRBIU2. */
2072/* CRBIU2: Table of coeffs of approximation of iso-U1 and its */
2073/* derivatives till order IORDRU */
2074/* UHERMT: Coeff. of Hermit polynoms of order IORDRU. */
2075/* PATJAC: Table of coefficients of the polynom P(u,v) of approximation */
2076/* of F(u,v) WITHOUT taking into account the constraints. */
2077
2078/* OUTPUT ARGUMENTS : */
7fd59977 2079/* ------------------- */
0d969553
Y		 2080/* PATJAC: Table of coefficients of the polynom P(u,v) by approximation */
2081/* of F(u,v) WITH taking into account of constraints. */
7fd59977 2082
7fd59977 2083
7fd59977 2084/* > */
2085/* **********************************************************************
2086*/
0d969553 2087/* The name of the routine */
7fd59977 2088
0d969553 2089/* --------------------------- Initializations --------------------------
7fd59977 2090*/
2091
2092 /* Parameter adjustments */
2093 patjac_dim1 = *mxujac + 1;
2094 patjac_dim2 = *mxvjac + 1;
2095 patjac_offset = patjac_dim1 * patjac_dim2;
2096 patjac -= patjac_offset;
2097 uhermt_dim1 = (*iordru << 1) + 2;
2098 uhermt_offset = uhermt_dim1;
2099 uhermt -= uhermt_offset;
2100 --ncfiu2;
2101 --ncfiu1;
2102 crbiu2_dim1 = *nclimv;
2103 crbiu2_dim2 = *ndimen;
2104 crbiu2_offset = crbiu2_dim1 * (crbiu2_dim2 + 1);
2105 crbiu2 -= crbiu2_offset;
2106 crbiu1_dim1 = *nclimv;
2107 crbiu1_dim2 = *ndimen;
2108 crbiu1_offset = crbiu1_dim1 * (crbiu1_dim2 + 1);
2109 crbiu1 -= crbiu1_offset;
2110
2111 /* Function Body */
2112 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 3;
2113 if (ldbg) {
2114 AdvApp2Var_SysBase::mgenmsg_("MMA2AC3", 7L);
2115 }
2116
0d969553 2117/* ------------ ADDING of coeff by u of curves, by v of Hermit --------
7fd59977 2118*/
2119
2120 i__1 = *iordru + 1;
2121 for (ii = 1; ii <= i__1; ++ii) {
2122 ndgu1 = ncfiu1[ii] - 1;
2123 ndgu2 = ncfiu2[ii] - 1;
2124 i__2 = *ndimen;
2125 for (nd = 1; nd <= i__2; ++nd) {
2126 i__3 = ndgu1;
2127 for (jj = 0; jj <= i__3; ++jj) {
2128 bid1 = crbiu1[jj + (nd + ii * crbiu1_dim2) * crbiu1_dim1];
2129 i__4 = (*iordru << 1) + 1;
2130 for (kk = 0; kk <= i__4; ++kk) {
2131 patjac[kk + (jj + nd * patjac_dim2) * patjac_dim1] +=
2132 bid1 * uhermt[kk + ((ii << 1) - 1) * uhermt_dim1];
2133/* L400: */
2134 }
2135/* L300: */
2136 }
2137 i__3 = ndgu2;
2138 for (jj = 0; jj <= i__3; ++jj) {
2139 bid2 = crbiu2[jj + (nd + ii * crbiu2_dim2) * crbiu2_dim1];
2140 i__4 = (*iordru << 1) + 1;
2141 for (kk = 0; kk <= i__4; ++kk) {
2142 patjac[kk + (jj + nd * patjac_dim2) * patjac_dim1] +=
2143 bid2 * uhermt[kk + (ii << 1) * uhermt_dim1];
2144/* L600: */
2145 }
2146/* L500: */
2147 }
2148
2149/* L200: */
2150 }
2151/* L100: */
2152 }
2153
2154/* ------------------------------ The end -------------------------------
2155*/
2156
2157 if (ldbg) {
2158 AdvApp2Var_SysBase::mgsomsg_("MMA2AC3", 7L);
2159 }
2160 return 0;
2161} /* mma2ac3_ */
2162
2163//=======================================================================
2164//function : mma2can_
2165//purpose :
2166//=======================================================================
2167int AdvApp2Var_ApproxF2var::mma2can_(const integer *ncfmxu,
2168 const integer *ncfmxv,
2169 const integer *ndimen,
2170 const integer *iordru,
2171 const integer *iordrv,
2172 const integer *ncoefu,
2173 const integer *ncoefv,
2174 const doublereal *patjac,
2175 doublereal *pataux,
2176 doublereal *patcan,
2177 integer *iercod)
2178
2179{
2180 /* System generated locals */
2181 integer patjac_dim1, patjac_dim2, patjac_offset, patcan_dim1, patcan_dim2,
2182 patcan_offset, i__1, i__2;
2183
2184 /* Local variables */
2185 static logical ldbg;
2186 static integer ilon1, ilon2, ii, nd;
2187
2188
2189
2190
2191/* **********************************************************************
2192*/
2193
0d969553 2194/* FUNCTION : */
7fd59977 2195/* ---------- */
0d969553
Y		 2196/* Change of Jacobi base to canonical (-1,1) and writing in a greater */
2197/* table. */
7fd59977 2198
0d969553 2199/* KEYWORDS : */
7fd59977 2200/* ----------- */
0d969553 2201/* ALL,AB_SPECIFI,CARREAU&,CONVERSION,JACOBI,CANNONIQUE,&CARREAU */
7fd59977 2202
0d969553 2203/* INPUT ARGUMENTS : */
7fd59977 2204/* -------------------- */
0d969553
Y		 2205/* NCFMXU: Dimension by U of resulting table PATCAN */
2206/* NCFMXV: Dimension by V of resulting table PATCAN */
2207/* NDIMEN: Dimension of the workspace. */
2208/* IORDRU: Order of constraint by U */
2209/* IORDRV: Order of constraint by V. */
2210/* NCOEFU: Nb of coeff by U of square PATJAC */
2211/* NCOEFV: Nb of coeff by V of square PATJAC */
2212/* PATJAC: Square in the base of Jacobi of order IORDRU by U and */
2213/* IORDRV by V. */
2214
2215/* OUTPUT ARGUMENTS : */
7fd59977 2216/* --------------------- */
0d969553
Y		 2217/* PATAUX: Auxiliary Table. */
2218/* PATCAN: Table of coefficients in the canonic base. */
2219/* IERCOD: Error code. */
2220/* = 0, everything goes well, and all things are equal. */
2221/* = 1, the program refuses to process with incorrect input arguments */
2222
2223
2224/* COMMONS USED : */
7fd59977 2225/* ------------------ */
2226
0d969553 2227/* REFERENCES CALLED : */
7fd59977 2228/* --------------------- */
2229
0d969553 2230/* DESCRIPTION/NOTES/LIMITATIONS : */
7fd59977 2231/* ----------------------------------- */
7fd59977 2232/* > */
2233/* **********************************************************************
2234*/
2235
2236
2237 /* Parameter adjustments */
2238 patcan_dim1 = *ncfmxu;
2239 patcan_dim2 = *ncfmxv;
2240 patcan_offset = patcan_dim1 * (patcan_dim2 + 1) + 1;
2241 patcan -= patcan_offset;
2242 --pataux;
2243 patjac_dim1 = *ncoefu;
2244 patjac_dim2 = *ncoefv;
2245 patjac_offset = patjac_dim1 * (patjac_dim2 + 1) + 1;
2246 patjac -= patjac_offset;
2247
2248 /* Function Body */
2249 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 2;
2250 if (ldbg) {
2251 AdvApp2Var_SysBase::mgenmsg_("MMA2CAN", 7L);
2252 }
2253 *iercod = 0;
2254
2255 if (*iordru < -1 || *iordru > 2) {
2256 goto L9100;
2257 }
2258 if (*iordrv < -1 || *iordrv > 2) {
2259 goto L9100;
2260 }
2261 if (*ncoefu > *ncfmxu || *ncoefv > *ncfmxv) {
2262 goto L9100;
2263 }
2264
0d969553 2265/* --> Pass to canonic base (-1,1) */
7fd59977 2266 mmjacpt_(ndimen, ncoefu, ncoefv, iordru, iordrv, &patjac[patjac_offset], &
2267 pataux[1], &patcan[patcan_offset]);
2268
0d969553 2269/* --> Write all in a greater table */
7fd59977 2270 AdvApp2Var_MathBase::mmfmca8_((integer *)ncoefu,
2271 (integer *)ncoefv,
2272 (integer *)ndimen,
2273 (integer *)ncfmxu,
2274 (integer *)ncfmxv,
2275 (integer *)ndimen,
2276 (doublereal *)&patcan[patcan_offset],
2277 (doublereal *)&patcan[patcan_offset]);
2278
0d969553 2279/* --> Complete with zeros the resulting table. */
7fd59977 2280 ilon1 = *ncfmxu - *ncoefu;
2281 ilon2 = *ncfmxu * (*ncfmxv - *ncoefv);
2282 i__1 = *ndimen;
2283 for (nd = 1; nd <= i__1; ++nd) {
2284 if (ilon1 > 0) {
2285 i__2 = *ncoefv;
2286 for (ii = 1; ii <= i__2; ++ii) {
2287 AdvApp2Var_SysBase::mvriraz_(&ilon1,
2288 (char *)&patcan[*ncoefu + 1 + (ii + nd * patcan_dim2) * patcan_dim1]);
2289/* L110: */
2290 }
2291 }
2292 if (ilon2 > 0) {
2293 AdvApp2Var_SysBase::mvriraz_(&ilon2,
2294 (char *)&patcan[(*ncoefv + 1 + nd * patcan_dim2) * patcan_dim1 + 1]);
2295 }
2296/* L100: */
2297 }
2298
2299 goto L9999;
2300
0d969553 2301/* ----------------------
7fd59977 2302*/
2303
2304L9100:
2305 *iercod = 1;
2306 goto L9999;
2307
2308L9999:
2309 AdvApp2Var_SysBase::maermsg_("MMA2CAN", iercod, 7L);
2310 if (ldbg) {
2311 AdvApp2Var_SysBase::mgsomsg_("MMA2CAN", 7L);
2312 }
2313 return 0 ;
2314} /* mma2can_ */
2315
2316//=======================================================================
2317//function : mma2cd1_
2318//purpose :
2319//=======================================================================
2320int mma2cd1_(integer *ndimen,
2321 integer *nbpntu,
2322 doublereal *urootl,
2323 integer *nbpntv,
2324 doublereal *vrootl,
2325 integer *iordru,
2326 integer *iordrv,
2327 doublereal *contr1,
2328 doublereal *contr2,
2329 doublereal *contr3,
2330 doublereal *contr4,
2331 doublereal *fpntbu,
2332 doublereal *fpntbv,
2333 doublereal *uhermt,
2334 doublereal *vhermt,
2335 doublereal *sosotb,
2336 doublereal *soditb,
2337 doublereal *disotb,
2338 doublereal *diditb)
2339
2340{
2341 static integer c__1 = 1;
2342
2343/* System generated locals */
2344 integer contr1_dim1, contr1_dim2, contr1_offset, contr2_dim1, contr2_dim2,
2345 contr2_offset, contr3_dim1, contr3_dim2, contr3_offset,
2346 contr4_dim1, contr4_dim2, contr4_offset, uhermt_dim1,
2347 uhermt_offset, vhermt_dim1, vhermt_offset, fpntbu_dim1,
2348 fpntbu_offset, fpntbv_dim1, fpntbv_offset, sosotb_dim1,
2349 sosotb_dim2, sosotb_offset, diditb_dim1, diditb_dim2,
2350 diditb_offset, soditb_dim1, soditb_dim2, soditb_offset,
2351 disotb_dim1, disotb_dim2, disotb_offset, i__1, i__2, i__3, i__4,
2352 i__5;
2353
2354 /* Local variables */
2355 static integer ncfhu, ncfhv, nuroo, nvroo, nd, ii, jj, kk, ll, ibb, kkm,
2356 llm, kkp, llp;
2357 static doublereal bid1, bid2, bid3, bid4;
2358 static doublereal diu1, diu2, div1, div2, sou1, sou2, sov1, sov2;
2359
2360
2361
2362
2363/* **********************************************************************
2364*/
2365
0d969553 2366/* FUNCTION : */
7fd59977 2367/* ---------- */
0d969553
Y		 2368/* Discretisation on the parameters of polynoms of interpolation */
2369/* of constraints at the corners of order IORDRE. */
7fd59977 2370
0d969553 2371/* KEYWORDS : */
7fd59977 2372/* ----------- */
2373/* TOUS, AB_SPECIFI::CONTRAINTE&, DISCRETISATION, &POINT */
2374
0d969553 2375/* INPUT ARGUMENTS : */
7fd59977 2376/* ------------------ */
0d969553
Y		 2377/* NDIMEN: Dimension of the space. */
2378/* NBPNTU: Nb of INTERNAL parameters of discretisation by U. */
2379/* This is also the nb of root of Legendre polynom where discretization is done. */
2380/* UROOTL: Table of parameters of discretisation ON (-1,1) by U.
2381*/
2382/* NBPNTV: Nb of INTERNAL parameters of discretisation by V. */
2383/* This is also the nb of root of Legendre polynom where discretization is done. */
2384/* VROOTL: Table of discretization parameters on (-1,1) by V.
2385/* IORDRU: Order of constraint imposed at the extremities of iso-V */
2386/* = 0, calculate the extremities of iso-V */
2387/* = 1, calculate, additionally, the 1st derivative in the direction of iso-V */
2388/* = 2, calculate, additionally, the 2nd derivative in the direction of iso-V */
2389/* IORDRV: Order of constraint imposed at the extremities of iso-U */
2390/* = 0, calculate the extremities of iso-U */
2391/* = 1, calculate, additionally, the 1st derivative in the direction of iso-U */
2392/* = 2, calculate, additionally, the 2nd derivative in the direction of iso-U */
2393/* CONTR1: Contains, if IORDRU and IORDRV>=0, the values at the */
2394/* extremities of F(U0,V0) and its derivatives. */
2395/* CONTR2: Contains, if IORDRU and IORDRV>=0, the values at the */
2396/* extremities of F(U1,V0) and its derivatives. */
2397/* CONTR3: Contains, if IORDRU and IORDRV>=0, the values at the */
2398/* extremities of F(U0,V1) and its derivatives. */
2399/* CONTR4: Contains, if IORDRU and IORDRV>=0, the values at the */
2400/* extremities of F(U1,V1) and its derivatives. */
2401/* SOSOTB: Preinitialized table (input/output argument). */
2402/* DISOTB: Preinitialized table (input/output argument). */
2403/* SODITB: Preinitialized table (input/output argument). */
2404/* DIDITB: Preinitialized table (input/output argument) */
2405
2406/* OUTPUT ARGUMENTS : */
7fd59977 2407/* ------------------- */
0d969553
Y		 2408/* FPNTBU: Auxiliary table. */
2409/* FPNTBV: Auxiliary table. */
2410/* UHERMT: Table of 2*(IORDRU+1) coeff. of 2*(IORDRU+1) polynoms of Hermite. */
2411/* VHERMT: Table of 2*(IORDRV+1) coeff. of 2*(IORDRV+1) polynoms of Hermite. */
2412/* SOSOTB: Table where the terms of constraints are added */
7fd59977 2413/* C(ui,vj) + C(ui,-vj) + C(-ui,vj) + C(-ui,-vj) */
0d969553
Y		 2414/* with ui and vj positive roots of the Legendre polynom */
2415/* of degree NBPNTU and NBPNTV respectively. */
2416/* DISOTB: Table where the terms of constraints are added */
7fd59977 2417/* C(ui,vj) + C(ui,-vj) - C(-ui,vj) - C(-ui,-vj) */
0d969553
Y		 2418/* with ui and vj positive roots of the polynom of Legendre */
2419/* of degree NBPNTU and NBPNTV respectively. */
2420/* SODITB: Table where the terms of constraints are added */
7fd59977 2421/* C(ui,vj) - C(ui,-vj) + C(-ui,vj) - C(-ui,-vj) */
0d969553
Y		 2422/* with ui and vj positive roots of the polynom of Legendre */
2423/* of degree NBPNTU and NBPNTV respectively. */
2424/* DIDITB: Table where the terms of constraints are added */
7fd59977 2425/* C(ui,vj) - C(ui,-vj) - C(-ui,vj) + C(-ui,-vj) */
0d969553
Y		 2426/* with ui and vj positive roots of the polynom of Legendre */
2427/* of degree NBPNTU and NBPNTV respectively. */
7fd59977 2428
0d969553 2429/* COMMONS USED : */
7fd59977 2430/* ---------------- */
2431
0d969553 2432/* REFERENCES CALLED : */
7fd59977 2433/* ----------------------- */
2434
0d969553 2435/* DESCRIPTION/NOTES/LIMITATIONS : */
7fd59977 2436/* ----------------------------------- */
2437
7fd59977 2438/* > */
2439/* **********************************************************************
2440*/
2441
0d969553 2442/* Name of the routine */
7fd59977 2443
2444
2445 /* Parameter adjustments */
2446 --urootl;
2447 diditb_dim1 = *nbpntu / 2 + 1;
2448 diditb_dim2 = *nbpntv / 2 + 1;
2449 diditb_offset = diditb_dim1 * diditb_dim2;
2450 diditb -= diditb_offset;
2451 disotb_dim1 = *nbpntu / 2;
2452 disotb_dim2 = *nbpntv / 2;
2453 disotb_offset = disotb_dim1 * (disotb_dim2 + 1) + 1;
2454 disotb -= disotb_offset;
2455 soditb_dim1 = *nbpntu / 2;
2456 soditb_dim2 = *nbpntv / 2;
2457 soditb_offset = soditb_dim1 * (soditb_dim2 + 1) + 1;
2458 soditb -= soditb_offset;
2459 sosotb_dim1 = *nbpntu / 2 + 1;
2460 sosotb_dim2 = *nbpntv / 2 + 1;
2461 sosotb_offset = sosotb_dim1 * sosotb_dim2;
2462 sosotb -= sosotb_offset;
2463 --vrootl;
2464 uhermt_dim1 = (*iordru << 1) + 2;
2465 uhermt_offset = uhermt_dim1;
2466 uhermt -= uhermt_offset;
2467 fpntbu_dim1 = *nbpntu;
2468 fpntbu_offset = fpntbu_dim1 + 1;
2469 fpntbu -= fpntbu_offset;
2470 vhermt_dim1 = (*iordrv << 1) + 2;
2471 vhermt_offset = vhermt_dim1;
2472 vhermt -= vhermt_offset;
2473 fpntbv_dim1 = *nbpntv;
2474 fpntbv_offset = fpntbv_dim1 + 1;
2475 fpntbv -= fpntbv_offset;
2476 contr4_dim1 = *ndimen;
2477 contr4_dim2 = *iordru + 2;
2478 contr4_offset = contr4_dim1 * (contr4_dim2 + 1) + 1;
2479 contr4 -= contr4_offset;
2480 contr3_dim1 = *ndimen;
2481 contr3_dim2 = *iordru + 2;
2482 contr3_offset = contr3_dim1 * (contr3_dim2 + 1) + 1;
2483 contr3 -= contr3_offset;
2484 contr2_dim1 = *ndimen;
2485 contr2_dim2 = *iordru + 2;
2486 contr2_offset = contr2_dim1 * (contr2_dim2 + 1) + 1;
2487 contr2 -= contr2_offset;
2488 contr1_dim1 = *ndimen;
2489 contr1_dim2 = *iordru + 2;
2490 contr1_offset = contr1_dim1 * (contr1_dim2 + 1) + 1;
2491 contr1 -= contr1_offset;
2492
2493 /* Function Body */
2494 ibb = AdvApp2Var_SysBase::mnfndeb_();
2495 if (ibb >= 3) {
2496 AdvApp2Var_SysBase::mgenmsg_("MMA2CD1", 7L);
2497 }
2498
0d969553 2499/* ------------------- Discretisation of Hermite polynoms -----------
7fd59977 2500*/
2501
2502 ncfhu = (*iordru + 1) << 1;
2503 i__1 = ncfhu;
2504 for (ii = 1; ii <= i__1; ++ii) {
2505 i__2 = *nbpntu;
2506 for (ll = 1; ll <= i__2; ++ll) {
2507 AdvApp2Var_MathBase::mmmpocur_(&ncfhu, &c__1, &ncfhu, &uhermt[ii * uhermt_dim1], &
2508 urootl[ll], &fpntbu[ll + ii * fpntbu_dim1]);
2509/* L20: */
2510 }
2511/* L10: */
2512 }
2513 ncfhv = (*iordrv + 1) << 1;
2514 i__1 = ncfhv;
2515 for (jj = 1; jj <= i__1; ++jj) {
2516 i__2 = *nbpntv;
2517 for (kk = 1; kk <= i__2; ++kk) {
2518 AdvApp2Var_MathBase::mmmpocur_(&ncfhv, &c__1, &ncfhv, &vhermt[jj * vhermt_dim1], &
2519 vrootl[kk], &fpntbv[kk + jj * fpntbv_dim1]);
2520/* L40: */
2521 }
2522/* L30: */
2523 }
2524
0d969553 2525/* ---- The discretizations of polynoms of constraints are subtracted ----
7fd59977 2526*/
2527
2528 nuroo = *nbpntu / 2;
2529 nvroo = *nbpntv / 2;
2530 i__1 = *ndimen;
2531 for (nd = 1; nd <= i__1; ++nd) {
2532
2533 i__2 = *iordrv + 1;
2534 for (jj = 1; jj <= i__2; ++jj) {
2535 i__3 = *iordru + 1;
2536 for (ii = 1; ii <= i__3; ++ii) {
2537 bid1 = contr1[nd + (ii + jj * contr1_dim2) * contr1_dim1];
2538 bid2 = contr2[nd + (ii + jj * contr2_dim2) * contr2_dim1];
2539 bid3 = contr3[nd + (ii + jj * contr3_dim2) * contr3_dim1];
2540 bid4 = contr4[nd + (ii + jj * contr4_dim2) * contr4_dim1];
2541
2542 i__4 = nvroo;
2543 for (kk = 1; kk <= i__4; ++kk) {
2544 kkp = (*nbpntv + 1) / 2 + kk;
2545 kkm = nvroo - kk + 1;
2546 sov1 = fpntbv[kkp + ((jj << 1) - 1) * fpntbv_dim1] +
2547 fpntbv[kkm + ((jj << 1) - 1) * fpntbv_dim1];
2548 div1 = fpntbv[kkp + ((jj << 1) - 1) * fpntbv_dim1] -
2549 fpntbv[kkm + ((jj << 1) - 1) * fpntbv_dim1];
2550 sov2 = fpntbv[kkp + (jj << 1) * fpntbv_dim1] + fpntbv[kkm
2551 + (jj << 1) * fpntbv_dim1];
2552 div2 = fpntbv[kkp + (jj << 1) * fpntbv_dim1] - fpntbv[kkm
2553 + (jj << 1) * fpntbv_dim1];
2554 i__5 = nuroo;
2555 for (ll = 1; ll <= i__5; ++ll) {
2556 llp = (*nbpntu + 1) / 2 + ll;
2557 llm = nuroo - ll + 1;
2558 sou1 = fpntbu[llp + ((ii << 1) - 1) * fpntbu_dim1] +
2559 fpntbu[llm + ((ii << 1) - 1) * fpntbu_dim1];
2560 diu1 = fpntbu[llp + ((ii << 1) - 1) * fpntbu_dim1] -
2561 fpntbu[llm + ((ii << 1) - 1) * fpntbu_dim1];
2562 sou2 = fpntbu[llp + (ii << 1) * fpntbu_dim1] + fpntbu[
2563 llm + (ii << 1) * fpntbu_dim1];
2564 diu2 = fpntbu[llp + (ii << 1) * fpntbu_dim1] - fpntbu[
2565 llm + (ii << 1) * fpntbu_dim1];
2566 sosotb[ll + (kk + nd * sosotb_dim2) * sosotb_dim1] =
2567 sosotb[ll + (kk + nd * sosotb_dim2) *
2568 sosotb_dim1] - bid1 * sou1 * sov1 - bid2 *
2569 sou2 * sov1 - bid3 * sou1 * sov2 - bid4 *
2570 sou2 * sov2;
2571 soditb[ll + (kk + nd * soditb_dim2) * soditb_dim1] =
2572 soditb[ll + (kk + nd * soditb_dim2) *
2573 soditb_dim1] - bid1 * sou1 * div1 - bid2 *
2574 sou2 * div1 - bid3 * sou1 * div2 - bid4 *
2575 sou2 * div2;
2576 disotb[ll + (kk + nd * disotb_dim2) * disotb_dim1] =
2577 disotb[ll + (kk + nd * disotb_dim2) *
2578 disotb_dim1] - bid1 * diu1 * sov1 - bid2 *
2579 diu2 * sov1 - bid3 * diu1 * sov2 - bid4 *
2580 diu2 * sov2;
2581 diditb[ll + (kk + nd * diditb_dim2) * diditb_dim1] =
2582 diditb[ll + (kk + nd * diditb_dim2) *
2583 diditb_dim1] - bid1 * diu1 * div1 - bid2 *
2584 diu2 * div1 - bid3 * diu1 * div2 - bid4 *
2585 diu2 * div2;
2586/* L450: */
2587 }
2588/* L400: */
2589 }
2590
0d969553
Y		 2591/* ------------ Case when the discretization is done only on the roots
2592----------- */
2593/* ---------- of Legendre polynom of uneven degree, 0 is root
7fd59977 2594----------- */
7fd59977 2595
2596 if (*nbpntu % 2 == 1) {
2597 sou1 = fpntbu[nuroo + 1 + ((ii << 1) - 1) * fpntbu_dim1];
2598 sou2 = fpntbu[nuroo + 1 + (ii << 1) * fpntbu_dim1];
2599 i__4 = nvroo;
2600 for (kk = 1; kk <= i__4; ++kk) {
2601 kkp = (*nbpntv + 1) / 2 + kk;
2602 kkm = nvroo - kk + 1;
2603 sov1 = fpntbv[kkp + ((jj << 1) - 1) * fpntbv_dim1] +
2604 fpntbv[kkm + ((jj << 1) - 1) * fpntbv_dim1];
2605 div1 = fpntbv[kkp + ((jj << 1) - 1) * fpntbv_dim1] -
2606 fpntbv[kkm + ((jj << 1) - 1) * fpntbv_dim1];
2607 sov2 = fpntbv[kkp + (jj << 1) * fpntbv_dim1] + fpntbv[
2608 kkm + (jj << 1) * fpntbv_dim1];
2609 div2 = fpntbv[kkp + (jj << 1) * fpntbv_dim1] - fpntbv[
2610 kkm + (jj << 1) * fpntbv_dim1];
2611 sosotb[(kk + nd * sosotb_dim2) * sosotb_dim1] =
2612 sosotb[(kk + nd * sosotb_dim2) * sosotb_dim1]
2613 - bid1 * sou1 * sov1 - bid2 * sou2 * sov1 -
2614 bid3 * sou1 * sov2 - bid4 * sou2 * sov2;
2615 diditb[(kk + nd * diditb_dim2) * diditb_dim1] =
2616 diditb[(kk + nd * diditb_dim2) * diditb_dim1]
2617 - bid1 * sou1 * div1 - bid2 * sou2 * div1 -
2618 bid3 * sou1 * div2 - bid4 * sou2 * div2;
2619/* L500: */
2620 }
2621 }
2622
2623 if (*nbpntv % 2 == 1) {
2624 sov1 = fpntbv[nvroo + 1 + ((jj << 1) - 1) * fpntbv_dim1];
2625 sov2 = fpntbv[nvroo + 1 + (jj << 1) * fpntbv_dim1];
2626 i__4 = nuroo;
2627 for (ll = 1; ll <= i__4; ++ll) {
2628 llp = (*nbpntu + 1) / 2 + ll;
2629 llm = nuroo - ll + 1;
2630 sou1 = fpntbu[llp + ((ii << 1) - 1) * fpntbu_dim1] +
2631 fpntbu[llm + ((ii << 1) - 1) * fpntbu_dim1];
2632 diu1 = fpntbu[llp + ((ii << 1) - 1) * fpntbu_dim1] -
2633 fpntbu[llm + ((ii << 1) - 1) * fpntbu_dim1];
2634 sou2 = fpntbu[llp + (ii << 1) * fpntbu_dim1] + fpntbu[
2635 llm + (ii << 1) * fpntbu_dim1];
2636 diu2 = fpntbu[llp + (ii << 1) * fpntbu_dim1] - fpntbu[
2637 llm + (ii << 1) * fpntbu_dim1];
2638 sosotb[ll + nd * sosotb_dim2 * sosotb_dim1] = sosotb[
2639 ll + nd * sosotb_dim2 * sosotb_dim1] - bid1 *
2640 sou1 * sov1 - bid2 * sou2 * sov1 - bid3 *
2641 sou1 * sov2 - bid4 * sou2 * sov2;
2642 diditb[ll + nd * diditb_dim2 * diditb_dim1] = diditb[
2643 ll + nd * diditb_dim2 * diditb_dim1] - bid1 *
2644 diu1 * sov1 - bid2 * diu2 * sov1 - bid3 *
2645 diu1 * sov2 - bid4 * diu2 * sov2;
2646/* L600: */
2647 }
2648 }
2649
2650 if (*nbpntu % 2 == 1 && *nbpntv % 2 == 1) {
2651 sou1 = fpntbu[nuroo + 1 + ((ii << 1) - 1) * fpntbu_dim1];
2652 sou2 = fpntbu[nuroo + 1 + (ii << 1) * fpntbu_dim1];
2653 sov1 = fpntbv[nvroo + 1 + ((jj << 1) - 1) * fpntbv_dim1];
2654 sov2 = fpntbv[nvroo + 1 + (jj << 1) * fpntbv_dim1];
2655 sosotb[nd * sosotb_dim2 * sosotb_dim1] = sosotb[nd *
2656 sosotb_dim2 * sosotb_dim1] - bid1 * sou1 * sov1 -
2657 bid2 * sou2 * sov1 - bid3 * sou1 * sov2 - bid4 *
2658 sou2 * sov2;
2659 diditb[nd * diditb_dim2 * diditb_dim1] = diditb[nd *
2660 diditb_dim2 * diditb_dim1] - bid1 * sou1 * sov1 -
2661 bid2 * sou2 * sov1 - bid3 * sou1 * sov2 - bid4 *
2662 sou2 * sov2;
2663 }
2664
2665/* L300: */
2666 }
2667/* L200: */
2668 }
2669/* L100: */
2670 }
2671 goto L9999;
2672
2673/* ------------------------------ The End -------------------------------
2674*/
2675
2676L9999:
2677 if (ibb >= 3) {
2678 AdvApp2Var_SysBase::mgsomsg_("MMA2CD1", 7L);
2679 }
2680 return 0;
2681} /* mma2cd1_ */
2682
2683//=======================================================================
2684//function : mma2cd2_
2685//purpose :
2686//=======================================================================
2687int mma2cd2_(integer *ndimen,
2688 integer *nbpntu,
2689 integer *nbpntv,
2690 doublereal *vrootl,
2691 integer *iordrv,
2692 doublereal *sotbv1,
2693 doublereal *sotbv2,
2694 doublereal *ditbv1,
2695 doublereal *ditbv2,
2696 doublereal *fpntab,
2697 doublereal *vhermt,
2698 doublereal *sosotb,
2699 doublereal *soditb,
2700 doublereal *disotb,
2701 doublereal *diditb)
2702
2703{
2704 static integer c__1 = 1;
2705 /* System generated locals */
2706 integer sotbv1_dim1, sotbv1_dim2, sotbv1_offset, sotbv2_dim1, sotbv2_dim2,
2707 sotbv2_offset, ditbv1_dim1, ditbv1_dim2, ditbv1_offset,
2708 ditbv2_dim1, ditbv2_dim2, ditbv2_offset, fpntab_dim1,
2709 fpntab_offset, vhermt_dim1, vhermt_offset, sosotb_dim1,
2710 sosotb_dim2, sosotb_offset, diditb_dim1, diditb_dim2,
2711 diditb_offset, soditb_dim1, soditb_dim2, soditb_offset,
2712 disotb_dim1, disotb_dim2, disotb_offset, i__1, i__2, i__3, i__4;
2713
2714 /* Local variables */
2715 static integer ncfhv, nuroo, nvroo, ii, nd, jj, kk, ibb, jjm, jjp;
2716 static doublereal bid1, bid2, bid3, bid4;
2717
2718/* **********************************************************************
2719*/
0d969553 2720/* FUNCTION : */
7fd59977 2721/* ---------- */
0d969553
Y		 2722/* Discretisation on the parameters of polynoms of interpolation */
2723/* of constraints on 2 borders iso-V of order IORDRV. */
7fd59977 2724
0d969553
Y		 2725
2726/* KEYWORDS : */
7fd59977 2727/* ----------- */
2728/* TOUS, AB_SPECIFI::CONTRAINTE&, DISCRETISATION, &POINT */
2729
7fd59977 2730
0d969553
Y		 2731
2732/* INPUT ARGUMENTS : */
2733/* ------------------ */
2734/* NDIMEN: Dimension of the space. */
2735/* NBPNTU: Nb of INTERNAL parameters of discretisation by U. */
2736/* This is also the nb of root of Legendre polynom where discretization is done. */
2737/* UROOTL: Table of parameters of discretisation ON (-1,1) by U.
2738*/
2739/* NBPNTV: Nb of INTERNAL parameters of discretisation by V. */
2740/* This is also the nb of root of Legendre polynom where discretization is done. */
2741/* VROOTL: Table of discretization parameters on (-1,1) by V.
2742/* IORDRV: Order of constraint imposed at the extremities of iso-V */
2743/* = 0, calculate the extremities of iso-V */
2744/* = 1, calculate, additionally, the 1st derivative in the direction of iso-V */
2745/* = 2, calculate, additionally, the 2nd derivative in the direction of iso-V */
2746/* SOTBV1: Table of NBPNTV/2 sums of 2 index points */
2747/* NBPNTV-II+1 and II, for II = 1, NBPNTV/2 on iso-V0. */
2748/* SOTBV2: Table of NBPNTV/2 sums of 2 index points */
2749/* NBPNTV-II+1 and II, for II = 1, NBPNTV/2 on iso-V1. */
2750/* DITBV1: Table of NBPNTV/2 differences of 2 index points */
2751/* NBPNTV-II+1 and II, for II = 1, NBPNTV/2 on iso-V0. */
2752/* DITBV2: Table of NBPNTV/2 differences of 2 index points */
2753/* NBPNTV-II+1 and II, for II = 1, NBPNTV/2 on iso-V1. */
2754/* SOSOTB: Preinitialized table (input/output argument). */
2755/* DISOTB: Preinitialized table (input/output argument). */
2756/* SODITB: Preinitialized table (input/output argument). */
2757/* DIDITB: Preinitialized table (input/output argument) */
2758
2759/* OUTPUT ARGUMENTS : */
7fd59977 2760/* ------------------- */
0d969553
Y		 2761/* FPNTAB: Auxiliary table. */
2762/* VHERMT: Table of 2*(IORDRV+1) coeff. of 2*(IORDRV+1) polynoms of Hermite. */
2763/* SOSOTB: Table where the terms of constraints are added */
7fd59977 2764/* C(ui,vj) + C(ui,-vj) + C(-ui,vj) + C(-ui,-vj) */
0d969553
Y		 2765/* with ui and vj positive roots of the Legendre polynom */
2766/* of degree NBPNTU and NBPNTV respectively. */
2767/* DISOTB: Table where the terms of constraints are added */
7fd59977 2768/* C(ui,vj) + C(ui,-vj) - C(-ui,vj) - C(-ui,-vj) */
0d969553
Y		 2769/* with ui and vj positive roots of the polynom of Legendre */
2770/* of degree NBPNTU and NBPNTV respectively. */
2771/* SODITB: Table where the terms of constraints are added */
7fd59977 2772/* C(ui,vj) - C(ui,-vj) + C(-ui,vj) - C(-ui,-vj) */
0d969553
Y		 2773/* with ui and vj positive roots of the polynom of Legendre */
2774/* of degree NBPNTU and NBPNTV respectively. */
2775/* DIDITB: Table where the terms of constraints are added */
7fd59977 2776/* C(ui,vj) - C(ui,-vj) - C(-ui,vj) + C(-ui,-vj) */
0d969553
Y		 2777/* with ui and vj positive roots of the polynom of Legendre */
2778/* of degree NBPNTU and NBPNTV respectively. */
7fd59977 2779
0d969553 2780/* COMMONS USED : */
7fd59977 2781/* ---------------- */
2782
0d969553 2783/* REFERENCES CALLED : */
7fd59977 2784/* ----------------------- */
2785
0d969553 2786/* DESCRIPTION/NOTES/LIMITATIONS : */
7fd59977 2787/* ----------------------------------- */
2788
2789
7fd59977 2790/* > */
2791/* **********************************************************************
2792*/
2793
0d969553 2794/* Name of the routine */
7fd59977 2795
2796
2797 /* Parameter adjustments */
2798 diditb_dim1 = *nbpntu / 2 + 1;
2799 diditb_dim2 = *nbpntv / 2 + 1;
2800 diditb_offset = diditb_dim1 * diditb_dim2;
2801 diditb -= diditb_offset;
2802 disotb_dim1 = *nbpntu / 2;
2803 disotb_dim2 = *nbpntv / 2;
2804 disotb_offset = disotb_dim1 * (disotb_dim2 + 1) + 1;
2805 disotb -= disotb_offset;
2806 soditb_dim1 = *nbpntu / 2;
2807 soditb_dim2 = *nbpntv / 2;
2808 soditb_offset = soditb_dim1 * (soditb_dim2 + 1) + 1;
2809 soditb -= soditb_offset;
2810 sosotb_dim1 = *nbpntu / 2 + 1;
2811 sosotb_dim2 = *nbpntv / 2 + 1;
2812 sosotb_offset = sosotb_dim1 * sosotb_dim2;
2813 sosotb -= sosotb_offset;
2814 --vrootl;
2815 vhermt_dim1 = (*iordrv << 1) + 2;
2816 vhermt_offset = vhermt_dim1;
2817 vhermt -= vhermt_offset;
2818 fpntab_dim1 = *nbpntv;
2819 fpntab_offset = fpntab_dim1 + 1;
2820 fpntab -= fpntab_offset;
2821 ditbv2_dim1 = *nbpntu / 2 + 1;
2822 ditbv2_dim2 = *ndimen;
2823 ditbv2_offset = ditbv2_dim1 * (ditbv2_dim2 + 1);
2824 ditbv2 -= ditbv2_offset;
2825 ditbv1_dim1 = *nbpntu / 2 + 1;
2826 ditbv1_dim2 = *ndimen;
2827 ditbv1_offset = ditbv1_dim1 * (ditbv1_dim2 + 1);
2828 ditbv1 -= ditbv1_offset;
2829 sotbv2_dim1 = *nbpntu / 2 + 1;
2830 sotbv2_dim2 = *ndimen;
2831 sotbv2_offset = sotbv2_dim1 * (sotbv2_dim2 + 1);
2832 sotbv2 -= sotbv2_offset;
2833 sotbv1_dim1 = *nbpntu / 2 + 1;
2834 sotbv1_dim2 = *ndimen;
2835 sotbv1_offset = sotbv1_dim1 * (sotbv1_dim2 + 1);
2836 sotbv1 -= sotbv1_offset;
2837
2838 /* Function Body */
2839 ibb = AdvApp2Var_SysBase::mnfndeb_();
2840 if (ibb >= 3) {
2841 AdvApp2Var_SysBase::mgenmsg_("MMA2CD2", 7L);
2842 }
2843
0d969553 2844/* ------------------- Discretization of Hermit polynoms -----------
7fd59977 2845*/
2846
2847 ncfhv = (*iordrv + 1) << 1;
2848 i__1 = ncfhv;
2849 for (ii = 1; ii <= i__1; ++ii) {
2850 i__2 = *nbpntv;
2851 for (jj = 1; jj <= i__2; ++jj) {
2852 AdvApp2Var_MathBase::mmmpocur_(&ncfhv, &c__1, &ncfhv, &vhermt[ii * vhermt_dim1], &
2853 vrootl[jj], &fpntab[jj + ii * fpntab_dim1]);
2854/* L60: */
2855 }
2856/* L50: */
2857 }
2858
0d969553 2859/* ---- The discretizations of polynoms of constraints are subtracted ----
7fd59977 2860*/
2861
2862 nuroo = *nbpntu / 2;
2863 nvroo = *nbpntv / 2;
2864
2865 i__1 = *ndimen;
2866 for (nd = 1; nd <= i__1; ++nd) {
2867 i__2 = *iordrv + 1;
2868 for (ii = 1; ii <= i__2; ++ii) {
2869
2870 i__3 = nuroo;
2871 for (kk = 1; kk <= i__3; ++kk) {
2872 bid1 = sotbv1[kk + (nd + ii * sotbv1_dim2) * sotbv1_dim1];
2873 bid2 = sotbv2[kk + (nd + ii * sotbv2_dim2) * sotbv2_dim1];
2874 bid3 = ditbv1[kk + (nd + ii * ditbv1_dim2) * ditbv1_dim1];
2875 bid4 = ditbv2[kk + (nd + ii * ditbv2_dim2) * ditbv2_dim1];
2876 i__4 = nvroo;
2877 for (jj = 1; jj <= i__4; ++jj) {
2878 jjp = (*nbpntv + 1) / 2 + jj;
2879 jjm = nvroo - jj + 1;
2880 sosotb[kk + (jj + nd * sosotb_dim2) * sosotb_dim1] =
2881 sosotb[kk + (jj + nd * sosotb_dim2) * sosotb_dim1]
2882 - bid1 * (fpntab[jjp + ((ii << 1) - 1) *
2883 fpntab_dim1] + fpntab[jjm + ((ii << 1) - 1) *
2884 fpntab_dim1]) - bid2 * (fpntab[jjp + (ii << 1) *
2885 fpntab_dim1] + fpntab[jjm + (ii << 1) *
2886 fpntab_dim1]);
2887 disotb[kk + (jj + nd * disotb_dim2) * disotb_dim1] =
2888 disotb[kk + (jj + nd * disotb_dim2) * disotb_dim1]
2889 - bid3 * (fpntab[jjp + ((ii << 1) - 1) *
2890 fpntab_dim1] + fpntab[jjm + ((ii << 1) - 1) *
2891 fpntab_dim1]) - bid4 * (fpntab[jjp + (ii << 1) *
2892 fpntab_dim1] + fpntab[jjm + (ii << 1) *
2893 fpntab_dim1]);
2894 soditb[kk + (jj + nd * soditb_dim2) * soditb_dim1] =
2895 soditb[kk + (jj + nd * soditb_dim2) * soditb_dim1]
2896 - bid1 * (fpntab[jjp + ((ii << 1) - 1) *
2897 fpntab_dim1] - fpntab[jjm + ((ii << 1) - 1) *
2898 fpntab_dim1]) - bid2 * (fpntab[jjp + (ii << 1) *
2899 fpntab_dim1] - fpntab[jjm + (ii << 1) *
2900 fpntab_dim1]);
2901 diditb[kk + (jj + nd * diditb_dim2) * diditb_dim1] =
2902 diditb[kk + (jj + nd * diditb_dim2) * diditb_dim1]
2903 - bid3 * (fpntab[jjp + ((ii << 1) - 1) *
2904 fpntab_dim1] - fpntab[jjm + ((ii << 1) - 1) *
2905 fpntab_dim1]) - bid4 * (fpntab[jjp + (ii << 1) *
2906 fpntab_dim1] - fpntab[jjm + (ii << 1) *
2907 fpntab_dim1]);
2908/* L400: */
2909 }
2910/* L300: */
2911 }
2912/* L200: */
2913 }
2914
0d969553
Y		 2915/* ------------ Case when the discretization is done only on the roots */
2916/* ---------- of Legendre polynom of uneven degree, 0 is root */
2917
7fd59977 2918
2919 if (*nbpntv % 2 == 1) {
2920 i__2 = *iordrv + 1;
2921 for (ii = 1; ii <= i__2; ++ii) {
2922 i__3 = nuroo;
2923 for (kk = 1; kk <= i__3; ++kk) {
2924 bid1 = sotbv1[kk + (nd + ii * sotbv1_dim2) * sotbv1_dim1]
2925 * fpntab[nvroo + 1 + ((ii << 1) - 1) *
2926 fpntab_dim1] + sotbv2[kk + (nd + ii * sotbv2_dim2)
2927 * sotbv2_dim1] * fpntab[nvroo + 1 + (ii << 1) *
2928 fpntab_dim1];
2929 sosotb[kk + nd * sosotb_dim2 * sosotb_dim1] -= bid1;
2930 bid2 = ditbv1[kk + (nd + ii * ditbv1_dim2) * ditbv1_dim1]
2931 * fpntab[nvroo + 1 + ((ii << 1) - 1) *
2932 fpntab_dim1] + ditbv2[kk + (nd + ii * ditbv2_dim2)
2933 * ditbv2_dim1] * fpntab[nvroo + 1 + (ii << 1) *
2934 fpntab_dim1];
2935 diditb[kk + nd * diditb_dim2 * diditb_dim1] -= bid2;
2936/* L550: */
2937 }
2938/* L500: */
2939 }
2940 }
2941
2942 if (*nbpntu % 2 == 1) {
2943 i__2 = *iordrv + 1;
2944 for (ii = 1; ii <= i__2; ++ii) {
2945 i__3 = nvroo;
2946 for (jj = 1; jj <= i__3; ++jj) {
2947 jjp = (*nbpntv + 1) / 2 + jj;
2948 jjm = nvroo - jj + 1;
2949 bid1 = sotbv1[(nd + ii * sotbv1_dim2) * sotbv1_dim1] * (
2950 fpntab[jjp + ((ii << 1) - 1) * fpntab_dim1] +
2951 fpntab[jjm + ((ii << 1) - 1) * fpntab_dim1]) +
2952 sotbv2[(nd + ii * sotbv2_dim2) * sotbv2_dim1] * (
2953 fpntab[jjp + (ii << 1) * fpntab_dim1] + fpntab[
2954 jjm + (ii << 1) * fpntab_dim1]);
2955 sosotb[(jj + nd * sosotb_dim2) * sosotb_dim1] -= bid1;
2956 bid2 = sotbv1[(nd + ii * sotbv1_dim2) * sotbv1_dim1] * (
2957 fpntab[jjp + ((ii << 1) - 1) * fpntab_dim1] -
2958 fpntab[jjm + ((ii << 1) - 1) * fpntab_dim1]) +
2959 sotbv2[(nd + ii * sotbv2_dim2) * sotbv2_dim1] * (
2960 fpntab[jjp + (ii << 1) * fpntab_dim1] - fpntab[
2961 jjm + (ii << 1) * fpntab_dim1]);
2962 diditb[jj + nd * diditb_dim2 * diditb_dim1] -= bid2;
2963/* L650: */
2964 }
2965/* L600: */
2966 }
2967 }
2968
2969 if (*nbpntu % 2 == 1 && *nbpntv % 2 == 1) {
2970 i__2 = *iordrv + 1;
2971 for (ii = 1; ii <= i__2; ++ii) {
2972 bid1 = sotbv1[(nd + ii * sotbv1_dim2) * sotbv1_dim1] * fpntab[
2973 nvroo + 1 + ((ii << 1) - 1) * fpntab_dim1] + sotbv2[(
2974 nd + ii * sotbv2_dim2) * sotbv2_dim1] * fpntab[nvroo
2975 + 1 + (ii << 1) * fpntab_dim1];
2976 sosotb[nd * sosotb_dim2 * sosotb_dim1] -= bid1;
2977/* L700: */
2978 }
2979 }
2980
2981/* L100: */
2982 }
2983 goto L9999;
2984
2985/* ------------------------------ The End -------------------------------
2986*/
2987
2988L9999:
2989 if (ibb >= 3) {
2990 AdvApp2Var_SysBase::mgsomsg_("MMA2CD2", 7L);
2991 }
2992 return 0;
2993} /* mma2cd2_ */
2994
2995//=======================================================================
2996//function : mma2cd3_
2997//purpose :
2998//=======================================================================
2999int mma2cd3_(integer *ndimen,
3000 integer *nbpntu,
3001 doublereal *urootl,
3002 integer *nbpntv,
3003 integer *iordru,
3004 doublereal *sotbu1,
3005 doublereal *sotbu2,
3006 doublereal *ditbu1,
3007 doublereal *ditbu2,
3008 doublereal *fpntab,
3009 doublereal *uhermt,
3010 doublereal *sosotb,
3011 doublereal *soditb,
3012 doublereal *disotb,
3013 doublereal *diditb)
3014
3015{
3016 static integer c__1 = 1;
3017
3018 /* System generated locals */
3019 integer sotbu1_dim1, sotbu1_dim2, sotbu1_offset, sotbu2_dim1, sotbu2_dim2,
3020 sotbu2_offset, ditbu1_dim1, ditbu1_dim2, ditbu1_offset,
3021 ditbu2_dim1, ditbu2_dim2, ditbu2_offset, fpntab_dim1,
3022 fpntab_offset, uhermt_dim1, uhermt_offset, sosotb_dim1,
3023 sosotb_dim2, sosotb_offset, diditb_dim1, diditb_dim2,
3024 diditb_offset, soditb_dim1, soditb_dim2, soditb_offset,
3025 disotb_dim1, disotb_dim2, disotb_offset, i__1, i__2, i__3, i__4;
3026
3027 /* Local variables */
3028 static integer ncfhu, nuroo, nvroo, ii, nd, jj, kk, ibb, kkm, kkp;
3029 static doublereal bid1, bid2, bid3, bid4;
3030
3031/* **********************************************************************
3032*/
0d969553 3033/* FUNCTION : */
7fd59977 3034/* ---------- */
0d969553
Y		 3035/* Discretisation on the parameters of polynoms of interpolation */
3036/* of constraints on 2 borders iso-U of order IORDRU. */
7fd59977 3037
0d969553
Y		 3038
3039/* KEYWORDS : */
7fd59977 3040/* ----------- */
3041/* TOUS, AB_SPECIFI::CONTRAINTE&, DISCRETISATION, &POINT */
3042
0d969553 3043/* INPUT ARGUMENTS : */
7fd59977 3044/* ------------------ */
0d969553
Y		 3045/* NDIMEN: Dimension of the space. */
3046/* NBPNTU: Nb of INTERNAL parameters of discretisation by U. */
3047/* This is also the nb of root of Legendre polynom where discretization is done. */
3048/* UROOTL: Table of parameters of discretisation ON (-1,1) by U.
3049*/
3050/* NBPNTV: Nb of INTERNAL parameters of discretisation by V. */
3051/* This is also the nb of root of Legendre polynom where discretization is done. */
3052/* IORDRV: Order of constraint imposed at the extremities of iso-V */
3053/* = 0, calculate the extremities of iso-V */
3054/* = 1, calculate, additionally, the 1st derivative in the direction of iso-V */
3055/* = 2, calculate, additionally, the 2nd derivative in the direction of iso-V */
3056/* SOTBU1: Table of NBPNTU/2 sums of 2 index points */
3057/* NBPNTU-II+1 and II, for II = 1, NBPNTU/2 on iso-V0. */
3058/* SOTBU2: Table of NBPNTV/2 sums of 2 index points */
3059/* NBPNTU-II+1 and II, for II = 1, NBPNTU/2 on iso-V1. */
3060/* DITBU1: Table of NBPNTU/2 differences of 2 index points */
3061/* NBPNTU-II+1 and II, for II = 1, NBPNTU/2 on iso-V0. */
3062/* DITBU2: Table of NBPNTU/2 differences of 2 index points */
3063/* NBPNTU-II+1 and II, for II = 1, NBPNTU/2 on iso-V1. */
3064/* SOSOTB: Preinitialized table (input/output argument). */
3065/* DISOTB: Preinitialized table (input/output argument). */
3066/* SODITB: Preinitialized table (input/output argument). */
3067/* DIDITB: Preinitialized table (input/output argument) */
3068
3069/* OUTPUT ARGUMENTS : */
7fd59977 3070/* ------------------- */
0d969553
Y		 3071/* FPNTAB: Auxiliary table. */
3072/* UHERMT: Table of 2*(IORDRU+1) coeff. of 2*(IORDRU+1) polynoms of Hermite. */
3073/* SOSOTB: Table where the terms of constraints are added */
7fd59977 3074/* C(ui,vj) + C(ui,-vj) + C(-ui,vj) + C(-ui,-vj) */
0d969553
Y		 3075/* with ui and vj positive roots of the Legendre polynom */
3076/* of degree NBPNTU and NBPNTV respectively. */
3077/* DISOTB: Table where the terms of constraints are added */
7fd59977 3078/* C(ui,vj) + C(ui,-vj) - C(-ui,vj) - C(-ui,-vj) */
0d969553
Y		 3079/* with ui and vj positive roots of the polynom of Legendre */
3080/* of degree NBPNTU and NBPNTV respectively. */
3081/* SODITB: Table where the terms of constraints are added */
7fd59977 3082/* C(ui,vj) - C(ui,-vj) + C(-ui,vj) - C(-ui,-vj) */
0d969553
Y		 3083/* with ui and vj positive roots of the polynom of Legendre */
3084/* of degree NBPNTU and NBPNTV respectively. */
3085/* DIDITB: Table where the terms of constraints are added */
7fd59977 3086/* C(ui,vj) - C(ui,-vj) - C(-ui,vj) + C(-ui,-vj) */
0d969553
Y		 3087/* with ui and vj positive roots of the polynom of Legendre */
3088/* of degree NBPNTU and NBPNTV respectively. */
7fd59977 3089
0d969553 3090/* COMMONS USED : */
7fd59977 3091/* ---------------- */
3092
0d969553 3093/* REFERENCES CALLED : */
7fd59977 3094/* ----------------------- */
3095
0d969553 3096/* DESCRIPTION/NOTES/LIMITATIONS : */
7fd59977 3097/* ----------------------------------- */
3098
7fd59977 3099/* $ HISTORIQUE DES MODIFICATIONS : */
3100/* -------------------------------- */
3101/* 08-08-1991: RBD; Creation. */
3102/* > */
3103/* **********************************************************************
3104*/
3105
0d969553 3106/* Name of the routine */
7fd59977 3107
3108
3109 /* Parameter adjustments */
3110 --urootl;
3111 diditb_dim1 = *nbpntu / 2 + 1;
3112 diditb_dim2 = *nbpntv / 2 + 1;
3113 diditb_offset = diditb_dim1 * diditb_dim2;
3114 diditb -= diditb_offset;
3115 disotb_dim1 = *nbpntu / 2;
3116 disotb_dim2 = *nbpntv / 2;
3117 disotb_offset = disotb_dim1 * (disotb_dim2 + 1) + 1;
3118 disotb -= disotb_offset;
3119 soditb_dim1 = *nbpntu / 2;
3120 soditb_dim2 = *nbpntv / 2;
3121 soditb_offset = soditb_dim1 * (soditb_dim2 + 1) + 1;
3122 soditb -= soditb_offset;
3123 sosotb_dim1 = *nbpntu / 2 + 1;
3124 sosotb_dim2 = *nbpntv / 2 + 1;
3125 sosotb_offset = sosotb_dim1 * sosotb_dim2;
3126 sosotb -= sosotb_offset;
3127 uhermt_dim1 = (*iordru << 1) + 2;
3128 uhermt_offset = uhermt_dim1;
3129 uhermt -= uhermt_offset;
3130 fpntab_dim1 = *nbpntu;
3131 fpntab_offset = fpntab_dim1 + 1;
3132 fpntab -= fpntab_offset;
3133 ditbu2_dim1 = *nbpntv / 2 + 1;
3134 ditbu2_dim2 = *ndimen;
3135 ditbu2_offset = ditbu2_dim1 * (ditbu2_dim2 + 1);
3136 ditbu2 -= ditbu2_offset;
3137 ditbu1_dim1 = *nbpntv / 2 + 1;
3138 ditbu1_dim2 = *ndimen;
3139 ditbu1_offset = ditbu1_dim1 * (ditbu1_dim2 + 1);
3140 ditbu1 -= ditbu1_offset;
3141 sotbu2_dim1 = *nbpntv / 2 + 1;
3142 sotbu2_dim2 = *ndimen;
3143 sotbu2_offset = sotbu2_dim1 * (sotbu2_dim2 + 1);
3144 sotbu2 -= sotbu2_offset;
3145 sotbu1_dim1 = *nbpntv / 2 + 1;
3146 sotbu1_dim2 = *ndimen;
3147 sotbu1_offset = sotbu1_dim1 * (sotbu1_dim2 + 1);
3148 sotbu1 -= sotbu1_offset;
3149
3150 /* Function Body */
3151 ibb = AdvApp2Var_SysBase::mnfndeb_();
3152 if (ibb >= 3) {
3153 AdvApp2Var_SysBase::mgenmsg_("MMA2CD3", 7L);
3154 }
3155
0d969553 3156/* ------------------- Discretization of polynoms of Hermit -----------
7fd59977 3157*/
3158
3159 ncfhu = (*iordru + 1) << 1;
3160 i__1 = ncfhu;
3161 for (ii = 1; ii <= i__1; ++ii) {
3162 i__2 = *nbpntu;
3163 for (kk = 1; kk <= i__2; ++kk) {
3164 AdvApp2Var_MathBase::mmmpocur_(&ncfhu,
3165 &c__1,
3166 &ncfhu,
3167 &uhermt[ii * uhermt_dim1],
3168 &urootl[kk],
3169 &fpntab[kk + ii * fpntab_dim1]);
3170/* L60: */
3171 }
3172/* L50: */
3173 }
3174
0d969553 3175/* ---- The discretizations of polynoms of constraints are subtracted ----
7fd59977 3176*/
3177
3178 nvroo = *nbpntv / 2;
3179 nuroo = *nbpntu / 2;
3180
3181 i__1 = *ndimen;
3182 for (nd = 1; nd <= i__1; ++nd) {
3183 i__2 = *iordru + 1;
3184 for (ii = 1; ii <= i__2; ++ii) {
3185
3186 i__3 = nvroo;
3187 for (jj = 1; jj <= i__3; ++jj) {
3188 bid1 = sotbu1[jj + (nd + ii * sotbu1_dim2) * sotbu1_dim1];
3189 bid2 = sotbu2[jj + (nd + ii * sotbu2_dim2) * sotbu2_dim1];
3190 bid3 = ditbu1[jj + (nd + ii * ditbu1_dim2) * ditbu1_dim1];
3191 bid4 = ditbu2[jj + (nd + ii * ditbu2_dim2) * ditbu2_dim1];
3192 i__4 = nuroo;
3193 for (kk = 1; kk <= i__4; ++kk) {
3194 kkp = (*nbpntu + 1) / 2 + kk;
3195 kkm = nuroo - kk + 1;
3196 sosotb[kk + (jj + nd * sosotb_dim2) * sosotb_dim1] =
3197 sosotb[kk + (jj + nd * sosotb_dim2) * sosotb_dim1]
3198 - bid1 * (fpntab[kkp + ((ii << 1) - 1) *
3199 fpntab_dim1] + fpntab[kkm + ((ii << 1) - 1) *
3200 fpntab_dim1]) - bid2 * (fpntab[kkp + (ii << 1) *
3201 fpntab_dim1] + fpntab[kkm + (ii << 1) *
3202 fpntab_dim1]);
3203 disotb[kk + (jj + nd * disotb_dim2) * disotb_dim1] =
3204 disotb[kk + (jj + nd * disotb_dim2) * disotb_dim1]
3205 - bid1 * (fpntab[kkp + ((ii << 1) - 1) *
3206 fpntab_dim1] - fpntab[kkm + ((ii << 1) - 1) *
3207 fpntab_dim1]) - bid2 * (fpntab[kkp + (ii << 1) *
3208 fpntab_dim1] - fpntab[kkm + (ii << 1) *
3209 fpntab_dim1]);
3210 soditb[kk + (jj + nd * soditb_dim2) * soditb_dim1] =
3211 soditb[kk + (jj + nd * soditb_dim2) * soditb_dim1]
3212 - bid3 * (fpntab[kkp + ((ii << 1) - 1) *
3213 fpntab_dim1] + fpntab[kkm + ((ii << 1) - 1) *
3214 fpntab_dim1]) - bid4 * (fpntab[kkp + (ii << 1) *
3215 fpntab_dim1] + fpntab[kkm + (ii << 1) *
3216 fpntab_dim1]);
3217 diditb[kk + (jj + nd * diditb_dim2) * diditb_dim1] =
3218 diditb[kk + (jj + nd * diditb_dim2) * diditb_dim1]
3219 - bid3 * (fpntab[kkp + ((ii << 1) - 1) *
3220 fpntab_dim1] - fpntab[kkm + ((ii << 1) - 1) *
3221 fpntab_dim1]) - bid4 * (fpntab[kkp + (ii << 1) *
3222 fpntab_dim1] - fpntab[kkm + (ii << 1) *
3223 fpntab_dim1]);
3224/* L400: */
3225 }
3226/* L300: */
3227 }
3228/* L200: */
3229 }
3230
0d969553
Y		 3231/* ------------ Case when the discretization is done only on the roots */
3232/* ---------- of Legendre polynom of uneven degree, 0 is root */
3233
3234
7fd59977 3235
3236 if (*nbpntu % 2 == 1) {
3237 i__2 = *iordru + 1;
3238 for (ii = 1; ii <= i__2; ++ii) {
3239 i__3 = nvroo;
3240 for (jj = 1; jj <= i__3; ++jj) {
3241 bid1 = sotbu1[jj + (nd + ii * sotbu1_dim2) * sotbu1_dim1]
3242 * fpntab[nuroo + 1 + ((ii << 1) - 1) *
3243 fpntab_dim1] + sotbu2[jj + (nd + ii * sotbu2_dim2)
3244 * sotbu2_dim1] * fpntab[nuroo + 1 + (ii << 1) *
3245 fpntab_dim1];
3246 sosotb[(jj + nd * sosotb_dim2) * sosotb_dim1] -= bid1;
3247 bid2 = ditbu1[jj + (nd + ii * ditbu1_dim2) * ditbu1_dim1]
3248 * fpntab[nuroo + 1 + ((ii << 1) - 1) *
3249 fpntab_dim1] + ditbu2[jj + (nd + ii * ditbu2_dim2)
3250 * ditbu2_dim1] * fpntab[nuroo + 1 + (ii << 1) *
3251 fpntab_dim1];
3252 diditb[(jj + nd * diditb_dim2) * diditb_dim1] -= bid2;
3253/* L550: */
3254 }
3255/* L500: */
3256 }
3257 }
3258
3259 if (*nbpntv % 2 == 1) {
3260 i__2 = *iordru + 1;
3261 for (ii = 1; ii <= i__2; ++ii) {
3262 i__3 = nuroo;
3263 for (kk = 1; kk <= i__3; ++kk) {
3264 kkp = (*nbpntu + 1) / 2 + kk;
3265 kkm = nuroo - kk + 1;
3266 bid1 = sotbu1[(nd + ii * sotbu1_dim2) * sotbu1_dim1] * (
3267 fpntab[kkp + ((ii << 1) - 1) * fpntab_dim1] +
3268 fpntab[kkm + ((ii << 1) - 1) * fpntab_dim1]) +
3269 sotbu2[(nd + ii * sotbu2_dim2) * sotbu2_dim1] * (
3270 fpntab[kkp + (ii << 1) * fpntab_dim1] + fpntab[
3271 kkm + (ii << 1) * fpntab_dim1]);
3272 sosotb[kk + nd * sosotb_dim2 * sosotb_dim1] -= bid1;
3273 bid2 = sotbu1[(nd + ii * sotbu1_dim2) * sotbu1_dim1] * (
3274 fpntab[kkp + ((ii << 1) - 1) * fpntab_dim1] -
3275 fpntab[kkm + ((ii << 1) - 1) * fpntab_dim1]) +
3276 sotbu2[(nd + ii * sotbu2_dim2) * sotbu2_dim1] * (
3277 fpntab[kkp + (ii << 1) * fpntab_dim1] - fpntab[
3278 kkm + (ii << 1) * fpntab_dim1]);
3279 diditb[kk + nd * diditb_dim2 * diditb_dim1] -= bid2;
3280/* L650: */
3281 }
3282/* L600: */
3283 }
3284 }
3285
3286 if (*nbpntu % 2 == 1 && *nbpntv % 2 == 1) {
3287 i__2 = *iordru + 1;
3288 for (ii = 1; ii <= i__2; ++ii) {
3289 bid1 = sotbu1[(nd + ii * sotbu1_dim2) * sotbu1_dim1] * fpntab[
3290 nuroo + 1 + ((ii << 1) - 1) * fpntab_dim1] + sotbu2[(
3291 nd + ii * sotbu2_dim2) * sotbu2_dim1] * fpntab[nuroo
3292 + 1 + (ii << 1) * fpntab_dim1];
3293 sosotb[nd * sosotb_dim2 * sosotb_dim1] -= bid1;
3294/* L700: */
3295 }
3296 }
3297
3298/* L100: */
3299 }
3300 goto L9999;
3301
3302/* ------------------------------ The End -------------------------------
3303*/
3304
3305L9999:
3306 if (ibb >= 3) {
3307 AdvApp2Var_SysBase::mgsomsg_("MMA2CD3", 7L);
3308 }
3309 return 0;
3310} /* mma2cd3_ */
3311
3312//=======================================================================
3313//function : mma2cdi_
3314//purpose :
3315//=======================================================================
3316int AdvApp2Var_ApproxF2var::mma2cdi_( integer *ndimen,
3317 integer *nbpntu,
3318 doublereal *urootl,
3319 integer *nbpntv,
3320 doublereal *vrootl,
3321 integer *iordru,
3322 integer *iordrv,
3323 doublereal *contr1,
3324 doublereal *contr2,
3325 doublereal *contr3,
3326 doublereal *contr4,
3327 doublereal *sotbu1,
3328 doublereal *sotbu2,
3329 doublereal *ditbu1,
3330 doublereal *ditbu2,
3331 doublereal *sotbv1,
3332 doublereal *sotbv2,
3333 doublereal *ditbv1,
3334 doublereal *ditbv2,
3335 doublereal *sosotb,
3336 doublereal *soditb,
3337 doublereal *disotb,
3338 doublereal *diditb,
3339 integer *iercod)
3340
3341{
3342 static integer c__8 = 8;
3343
3344 /* System generated locals */
3345 integer contr1_dim1, contr1_dim2, contr1_offset, contr2_dim1, contr2_dim2,
3346 contr2_offset, contr3_dim1, contr3_dim2, contr3_offset,
3347 contr4_dim1, contr4_dim2, contr4_offset, sosotb_dim1, sosotb_dim2,
3348 sosotb_offset, diditb_dim1, diditb_dim2, diditb_offset,
3349 soditb_dim1, soditb_dim2, soditb_offset, disotb_dim1, disotb_dim2,
3350 disotb_offset;
3351
3352 /* Local variables */
3353 static integer ilong;
3354 static long int iofwr;
3355 static doublereal wrkar[1];
3356 static integer iszwr;
3357 static integer ibb, ier;
3358 static integer isz1, isz2, isz3, isz4;
3359 static long int ipt1, ipt2, ipt3, ipt4;
3360
3361
3362
3363
3364/* **********************************************************************
3365*/
3366
0d969553 3367/* FUNCTION : */
7fd59977 3368/* ---------- */
0d969553
Y		 3369/* Discretisation on the parameters of polynomes of interpolation */
3370/* of constraints of order IORDRE. */
7fd59977 3371
0d969553 3372/* KEYWORDS : */
7fd59977 3373/* ----------- */
3374/* TOUS, AB_SPECIFI::CONTRAINTE&, DISCRETISATION, &POINT */
3375
0d969553 3376//* INPUT ARGUMENTS : */
7fd59977 3377/* ------------------ */
0d969553
Y		 3378/* NDIMEN: Dimension of the space. */
3379/* NBPNTU: Nb of INTERNAL parameters of discretisation by U. */
3380/* This is also the nb of root of Legendre polynom where discretization is done. */
3381/* UROOTL: Table of parameters of discretisation ON (-1,1) by U.
3382*/
3383/* NBPNTV: Nb of INTERNAL parameters of discretisation by V. */
3384/* This is also the nb of root of Legendre polynom where discretization is done. */
3385/* VROOTL: Table of parameters of discretisation ON (-1,1) by V.
3386
3387/* IORDRV: Order of constraint imposed at the extremities of iso-U */
3388/* = 0, calculate the extremities of iso-U */
3389/* = 1, calculate, additionally, the 1st derivative in the direction of iso-U */
3390/* = 2, calculate, additionally, the 2nd derivative in the direction of iso-U */
3391/* IORDRU: Order of constraint imposed at the extremities of iso-V */
3392/* = 0, calculate the extremities of iso-V */
3393/* = 1, calculate, additionally, the 1st derivative in the direction of iso-V */
3394/* = 2, calculate, additionally, the 2nd derivative in the direction of iso-V */
3395/* CONTR1: Contains, if IORDRU and IORDRV>=0, the values at the */
3396/* extremities of F(U0,V0) and its derivatives. */
3397/* CONTR2: Contains, if IORDRU and IORDRV>=0, the values at the */
3398/* extremities of F(U1,V0) and its derivatives. */
3399/* CONTR3: Contains, if IORDRU and IORDRV>=0, the values at the */
3400/* extremities of F(U0,V1) and its derivatives. */
3401/* CONTR4: Contains, if IORDRU and IORDRV>=0, the values at the */
3402/* extremities of F(U1,V1) and its derivatives. */
3403/* SOTBU1: Table of NBPNTU/2 sums of 2 index points */
3404/* NBPNTU-II+1 and II, for II = 1, NBPNTU/2 on iso-V0. */
3405/* SOTBU2: Table of NBPNTV/2 sums of 2 index points */
3406/* NBPNTU-II+1 and II, for II = 1, NBPNTU/2 on iso-V1. */
3407/* DITBU1: Table of NBPNTU/2 differences of 2 index points */
3408/* NBPNTU-II+1 and II, for II = 1, NBPNTU/2 on iso-V0. */
3409/* DITBU2: Table of NBPNTU/2 differences of 2 index points */
3410/* NBPNTU-II+1 and II, for II = 1, NBPNTU/2 on iso-V1. */
3411/* SOTBV1: Table of NBPNTV/2 sums of 2 index points */
3412/* NBPNTV-II+1 and II, for II = 1, NBPNTV/2 on iso-V0. */
3413/* SOTBV2: Table of NBPNTV/2 sums of 2 index points */
3414/* NBPNTV-II+1 and II, for II = 1, NBPNTV/2 on iso-V1. */
3415/* DITBV1: Table of NBPNTV/2 differences of 2 index points */
3416/* NBPNTV-II+1 and II, for II = 1, NBPNTV/2 on iso-V0. */
3417/* DITBV2: Table of NBPNTV/2 differences of 2 index points */
3418/* NBPNTV-II+1 and II, for II = 1, NBPNTV/2 on iso-V1. */
3419/* SOSOTB: Preinitialized table (input/output argument). */
3420/* DISOTB: Preinitialized table (input/output argument). */
3421/* SODITB: Preinitialized table (input/output argument). */
3422/* DIDITB: Preinitialized table (input/output argument) */
7fd59977 3423
3424/* ARGUMENTS DE SORTIE : */
3425/* ------------------- */
0d969553 3426/* SOSOTB: Table where the terms of constraints are added */
7fd59977 3427/* C(ui,vj) + C(ui,-vj) + C(-ui,vj) + C(-ui,-vj) */
0d969553
Y		 3428/* with ui and vj positive roots of the Legendre polynom */
3429/* of degree NBPNTU and NBPNTV respectively. */
3430/* DISOTB: Table where the terms of constraints are added */
7fd59977 3431/* C(ui,vj) + C(ui,-vj) - C(-ui,vj) - C(-ui,-vj) */
0d969553
Y		 3432/* with ui and vj positive roots of the polynom of Legendre */
3433/* of degree NBPNTU and NBPNTV respectively. */
3434/* SODITB: Table where the terms of constraints are added */
7fd59977 3435/* C(ui,vj) - C(ui,-vj) + C(-ui,vj) - C(-ui,-vj) */
0d969553
Y		 3436/* with ui and vj positive roots of the polynom of Legendre */
3437/* of degree NBPNTU and NBPNTV respectively. */
3438/* DIDITB: Table where the terms of constraints are added */
7fd59977 3439/* C(ui,vj) - C(ui,-vj) - C(-ui,vj) + C(-ui,-vj) */
0d969553
Y		 3440/* with ui and vj positive roots of the polynom of Legendre */
3441/* of degree NBPNTU and NBPNTV respectively. */
7fd59977 3442/* IERCOD: = 0, OK, */
0d969553
Y		 3443/* = 1, Value or IORDRV or IORDRU is out of allowed values. */
3444/* =13, Pb of dynamic allocation. */
7fd59977 3445
0d969553 3446/* COMMONS USED : */
7fd59977 3447/* ---------------- */
3448
0d969553
Y		 3449/* REFERENCES CALLED : */
3450/* -------------------- */
7fd59977 3451
0d969553
Y		 3452/* DESCRIPTION/NOTES/LIMITATIONS : */
3453/* ------------------------------- */
7fd59977 3454
7fd59977 3455/* > */
3456/* **********************************************************************
3457*/
3458
0d969553 3459/* The name of the routine */
7fd59977 3460
3461
3462 /* Parameter adjustments */
3463 --urootl;
3464 diditb_dim1 = *nbpntu / 2 + 1;
3465 diditb_dim2 = *nbpntv / 2 + 1;
3466 diditb_offset = diditb_dim1 * diditb_dim2;
3467 diditb -= diditb_offset;
3468 disotb_dim1 = *nbpntu / 2;
3469 disotb_dim2 = *nbpntv / 2;
3470 disotb_offset = disotb_dim1 * (disotb_dim2 + 1) + 1;
3471 disotb -= disotb_offset;
3472 soditb_dim1 = *nbpntu / 2;
3473 soditb_dim2 = *nbpntv / 2;
3474 soditb_offset = soditb_dim1 * (soditb_dim2 + 1) + 1;
3475 soditb -= soditb_offset;
3476 sosotb_dim1 = *nbpntu / 2 + 1;
3477 sosotb_dim2 = *nbpntv / 2 + 1;
3478 sosotb_offset = sosotb_dim1 * sosotb_dim2;
3479 sosotb -= sosotb_offset;
3480 --vrootl;
3481 contr4_dim1 = *ndimen;
3482 contr4_dim2 = *iordru + 2;
3483 contr4_offset = contr4_dim1 * (contr4_dim2 + 1) + 1;
3484 contr4 -= contr4_offset;
3485 contr3_dim1 = *ndimen;
3486 contr3_dim2 = *iordru + 2;
3487 contr3_offset = contr3_dim1 * (contr3_dim2 + 1) + 1;
3488 contr3 -= contr3_offset;
3489 contr2_dim1 = *ndimen;
3490 contr2_dim2 = *iordru + 2;
3491 contr2_offset = contr2_dim1 * (contr2_dim2 + 1) + 1;
3492 contr2 -= contr2_offset;
3493 contr1_dim1 = *ndimen;
3494 contr1_dim2 = *iordru + 2;
3495 contr1_offset = contr1_dim1 * (contr1_dim2 + 1) + 1;
3496 contr1 -= contr1_offset;
3497 --sotbu1;
3498 --sotbu2;
3499 --ditbu1;
3500 --ditbu2;
3501 --sotbv1;
3502 --sotbv2;
3503 --ditbv1;
3504 --ditbv2;
3505
3506 /* Function Body */
3507 ibb = AdvApp2Var_SysBase::mnfndeb_();
3508 if (ibb >= 3) {
3509 AdvApp2Var_SysBase::mgenmsg_("MMA2CDI", 7L);
3510 }
3511 *iercod = 0;
3512 iofwr = 0;
3513 if (*iordru < -1 || *iordru > 2) {
3514 goto L9100;
3515 }
3516 if (*iordrv < -1 || *iordrv > 2) {
3517 goto L9100;
3518 }
3519
0d969553 3520/* ------------------------- Set to zero --------------------------------
7fd59977 3521*/
3522
3523 ilong = (*nbpntu / 2 + 1) * (*nbpntv / 2 + 1) * *ndimen;
3524 AdvApp2Var_SysBase::mvriraz_(&ilong, (char *)&sosotb[sosotb_offset]);
3525 AdvApp2Var_SysBase::mvriraz_(&ilong, (char *)&diditb[diditb_offset]);
3526 ilong = *nbpntu / 2 * (*nbpntv / 2) * *ndimen;
3527 AdvApp2Var_SysBase::mvriraz_(&ilong, (char *)&soditb[soditb_offset]);
3528 AdvApp2Var_SysBase::mvriraz_(&ilong, (char *)&disotb[disotb_offset]);
3529 if (*iordru == -1 && *iordrv == -1) {
3530 goto L9999;
3531 }
3532
3533
3534
3535 isz1 = ((*iordru + 1) << 2) * (*iordru + 1);
3536 isz2 = ((*iordrv + 1) << 2) * (*iordrv + 1);
3537 isz3 = ((*iordru + 1) << 1) * *nbpntu;
3538 isz4 = ((*iordrv + 1) << 1) * *nbpntv;
3539 iszwr = isz1 + isz2 + isz3 + isz4;
3540 AdvApp2Var_SysBase::mcrrqst_(&c__8, &iszwr, wrkar, &iofwr, &ier);
3541 if (ier > 0) {
3542 goto L9013;
3543 }
3544 ipt1 = iofwr;
3545 ipt2 = ipt1 + isz1;
3546 ipt3 = ipt2 + isz2;
3547 ipt4 = ipt3 + isz3;
3548
3549 if (*iordru >= 0 && *iordru <= 2) {
3550
0d969553 3551/* --- Return 2*(IORDRU+1) coeff of 2*(IORDRU+1) polynoms of Hermite
7fd59977 3552--- */
3553
3554 AdvApp2Var_ApproxF2var::mma1her_(iordru, &wrkar[ipt1], iercod);
3555 if (*iercod > 0) {
3556 goto L9100;
3557 }
3558
0d969553 3559/* ---- Subract discretizations of polynoms of constraints
7fd59977 3560---- */
3561
3562 mma2cd3_(ndimen, nbpntu, &urootl[1], nbpntv, iordru, &sotbu1[1], &
3563 sotbu2[1], &ditbu1[1], &ditbu2[1], &wrkar[ipt3], &wrkar[ipt1],
3564 &sosotb[sosotb_offset], &soditb[soditb_offset], &disotb[
3565 disotb_offset], &diditb[diditb_offset]);
3566 }
3567
3568 if (*iordrv >= 0 && *iordrv <= 2) {
3569
0d969553 3570/* --- Return 2*(IORDRV+1) coeff of 2*(IORDRV+1) polynoms of Hermite
7fd59977 3571--- */
3572
3573 AdvApp2Var_ApproxF2var::mma1her_(iordrv, &wrkar[ipt2], iercod);
3574 if (*iercod > 0) {
3575 goto L9100;
3576 }
3577
0d969553 3578/* ---- Subtract discretisations of polynoms of constraint
7fd59977 3579---- */
3580
3581 mma2cd2_(ndimen, nbpntu, nbpntv, &vrootl[1], iordrv, &sotbv1[1], &
3582 sotbv2[1], &ditbv1[1], &ditbv2[1], &wrkar[ipt4], &wrkar[ipt2],
3583 &sosotb[sosotb_offset], &soditb[soditb_offset], &disotb[
3584 disotb_offset], &diditb[diditb_offset]);
3585 }
3586
0d969553 3587/* --------------- Subtract constraints of corners ----------------
7fd59977 3588*/
3589
3590 if (*iordru >= 0 && *iordrv >= 0) {
3591 mma2cd1_(ndimen, nbpntu, &urootl[1], nbpntv, &vrootl[1], iordru,
3592 iordrv, &contr1[contr1_offset], &contr2[contr2_offset], &
3593 contr3[contr3_offset], &contr4[contr4_offset], &wrkar[ipt3], &
3594 wrkar[ipt4], &wrkar[ipt1], &wrkar[ipt2], &sosotb[
3595 sosotb_offset], &soditb[soditb_offset], &disotb[disotb_offset]
3596 , &diditb[diditb_offset]);
3597 }
3598 goto L9999;
3599
3600/* ------------------------------ The End -------------------------------
3601*/
0d969553 3602/* --> IORDRE is not within the autorised diapason. */
7fd59977 3603L9100:
3604 *iercod = 1;
3605 goto L9999;
0d969553 3606/* --> PB of dynamic allocation. */
7fd59977 3607L9013:
3608 *iercod = 13;
3609 goto L9999;
3610
3611L9999:
3612 if (iofwr != 0) {
3613 AdvApp2Var_SysBase::mcrdelt_(&c__8, &iszwr, wrkar, &iofwr, &ier);
3614 }
3615 if (ier > 0) {
3616 *iercod = 13;
3617 }
3618 AdvApp2Var_SysBase::maermsg_("MMA2CDI", iercod, 7L);
3619 if (ibb >= 3) {
3620 AdvApp2Var_SysBase::mgsomsg_("MMA2CDI", 7L);
3621 }
3622 return 0;
3623} /* mma2cdi_ */
3624
3625//=======================================================================
3626//function : mma2ce1_
3627//purpose :
3628//=======================================================================
3629int AdvApp2Var_ApproxF2var::mma2ce1_(integer *numdec,
3630 integer *ndimen,
3631 integer *nbsesp,
3632 integer *ndimse,
3633 integer *ndminu,
3634 integer *ndminv,
3635 integer *ndguli,
3636 integer *ndgvli,
3637 integer *ndjacu,
3638 integer *ndjacv,
3639 integer *iordru,
3640 integer *iordrv,
3641 integer *nbpntu,
3642 integer *nbpntv,
3643 doublereal *epsapr,
3644 doublereal *sosotb,
3645 doublereal *disotb,
3646 doublereal *soditb,
3647 doublereal *diditb,
3648 doublereal *patjac,
3649 doublereal *errmax,
3650 doublereal *errmoy,
3651 integer *ndegpu,
3652 integer *ndegpv,
3653 integer *itydec,
3654 integer *iercod)
3655
3656{
3657 static integer c__8 = 8;
3658
3659 /* System generated locals */
3660 integer sosotb_dim1, sosotb_dim2, sosotb_offset, disotb_dim1, disotb_dim2,
3661 disotb_offset, soditb_dim1, soditb_dim2, soditb_offset,
3662 diditb_dim1, diditb_dim2, diditb_offset, patjac_dim1, patjac_dim2,
3663 patjac_offset;
3664
3665 /* Local variables */
3666 static logical ldbg;
3667 static long int iofwr;
3668 static doublereal wrkar[1];
3669 static integer iszwr;
3670 static integer ier;
3671 static integer isz1, isz2, isz3, isz4, isz5, isz6, isz7;
3672 static long int ipt1, ipt2, ipt3, ipt4, ipt5, ipt6, ipt7;
3673
3674
3675
3676/* **********************************************************************
3677*/
3678
0d969553 3679/* FUNCTION : */
7fd59977 3680/* ---------- */
0d969553
Y		 3681/* Calculation of coefficients of polynomial approximation of degree */
3682/* (NDJACU,NDJACV) of a function F(u,v), starting from its */
3683/* discretization on roots of Legendre polynom of degree */
3684/* NBPNTU by U and NBPNTV by V. */
7fd59977 3685
0d969553 3686/* KEYWORDS : */
7fd59977 3687/* ----------- */
3688/* TOUS,AB_SPECIFI::FONCTION&,APPROXIMATION,&POLYNOME,&ERREUR */
3689
0d969553 3690/* INPUT ARGUMENTS : */
7fd59977 3691/* ------------------ */
0d969553
Y		 3692/* NUMDEC: Indicates if it is POSSIBLE to cut function F(u,v). */
3693/* = 5, It is POSSIBLE to cut by U or by V or in both directions simultaneously. */
3694/* = 4, It is POSSIBLE to cut by U or by V BUT NOT in both */
3695/* directions simultaneously (cutting by V is preferable). */
3696/* = 3, It is POSSIBLE to cut by U or by V BUT NOT in both */
3697/* directions simultaneously (cutting by U is preferable). */
3698/* = 2, It is POSSIBLE to cut only by V (i.e. insert parameter */
3699/* of cutting Vj). */
3700/* = 1, It is POSSIBLE to cut only by U (i.e. insert parameter */
3701/* of cutting Ui). */
3702/* = 0, It is not POSSIBLE to cut anything */
3703/* NDIMEN: Dimension of the space. */
3704/* NBSESP: Nb of independent sub-spaces on which the errors are calculated. */
3705/* NDIMSE: Table of dimensions of each of sub-spaces. */
3706/* NDMINU: Minimum degree by U to be preserved for the approximation. */
3707/* NDMINV: Minimum degree by V to be preserved for the approximation. */
3708/* NDGULI: Limit of nb of coefficients by U of the solution. */
3709/* NDGVLI: Limit of nb of coefficients by V of the solution. */
3710/* NDJACU: Max degree of the polynom of approximation by U. */
3711/* The representation in the orthogonal base starts from degree */
3712/* 0 to degree NDJACU-2*(IORDRU+1). The polynomial base is the base of */
3713/* Jacobi of order -1 (Legendre), 0, 1 or 2. */
3714/* It is required that 2*IORDRU+1 <= NDMINU <= NDGULI < NDJACU */
3715/* NDJACV: Max degree of the polynom of approximation by V. */
3716/* The representation in the orthogonal base starts from degree */
3717/* 0 to degree NDJACV-2*(IORDRV+1). The polynomial base is */
3718/* the base of Jacobi of order -1 (Legendre), 0, 1 or 2 */
3719/* It is required that 2*IORDRV+1 <= NDMINV <= NDGVLI < NDJACV */
3720/* IORDRU: Order of the Jacobi base (-1,0,1 or 2) by U. Corresponds */
3721/* to the step of constraints C0, C1 or C2. */
3722/* IORDRV: Order of the Jacobi base (-1,0,1 or 2) by U. Corresponds */
3723/* to the step of constraints C0, C1 or C2. */
3724/* NBPNTU: Degree of Legendre polynom on the roots which of are */
3725/* calculated the coefficients of integration by u */
3726/* by Gauss method. It is required that NBPNTU = 30, 40, */
3727/* 50 or 61 and NDJACU-2*(IORDRU+1) < NBPNTU. */
3728/* NBPNTV: Degree of Legendre polynom on the roots which of are */
3729/* calculated the coefficients of integration by u */
3730/* by Gauss method. It is required that NBPNTV = 30, 40, */
3731/* 50 or 61 and NDJACV-2*(IORDRV+1) < NBPNTV. */
3732/* EPSAPR: Table of NBSESP tolerances imposed on each sub-spaces. */
3733/* SOSOTB: Table of F(ui,vj) + F(ui,-vj) + F(-ui,vj) + F(-ui,-vj) */
3734/* with ui and vj - positive roots of the Legendre polynom */
3735/* of degree NBPNTU and NBPNTV respectively. Additionally, */
3736/* table SOSOTB(0,j) contains F(0,vj) + F(0,-vj), */
3737/* table SOSOTB(i,0) contains F(ui,0) + F(-ui,0) and */
3738/* SOSOTB(0,0) contains F(0,0). */
3739/* DISOTB: Table of F(ui,vj) + F(ui,-vj) - F(-ui,vj) - F(-ui,-vj) */
3740/* with ui and vj positive roots of Legendre polynom */
3741/* of degree NBPNTU and NBPNTV respectively. */
3742/* SODITB: Table of F(ui,vj) - F(ui,-vj) + F(-ui,vj) - F(-ui,-vj) */
3743/* with ui and vj positive roots of Legendre polynom */
3744/* of degree NBPNTU and NBPNTV respectively. */
3745/* DIDITB: Table of F(ui,vj) - F(ui,-vj) - F(-ui,vj) + F(-ui,-vj) */
3746/* with ui and vj positive roots of Legendre polynom */
3747/* of degree NBPNTU and NBPNTV respectively. Additionally, */
3748/* table DIDITB(0,j) contains F(0,vj) - F(0,-vj), */
3749/* and table DIDITB(i,0) contains F(ui,0) - F(-ui,0). */
3750
3751/* OUTPUT ARGUMENTS */
3752/* --------------- */
3753/* PATJAC: Table of coefficients of polynom P(u,v) of approximation */
3754/* of F(u,v) with eventually taking into account of */
3755/* constraints. P(u,v) is of degree (NDJACU,NDJACV). */
3756/* This table contains other coeff if ITYDEC = 0. */
3757/* ERRMAX: For 1<=i<=NBSESP, ERRMAX(i) contains max errors */
3758/* on each of sub-spaces SI ITYDEC = 0. */
3759/* ERRMOY: Contains average errors for each of NBSESP sub-spaces SI ITYDEC = 0. */
3760/* NDEGPU: Degree by U for square PATJAC. Valable if ITYDEC=0. */
3761/* NDEGPV: Degree by V for square PATJAC. Valable if ITYDEC=0. */
3762/* ITYDEC: Shows if it is NECESSARY to cut again function F(u,v). */
3763/* = 0, it is not NECESSARY to cut anything, PATJAC is OK. */
3764/* = 1, it is NECESSARY to cut only by U (i.e. insert parameter of cutting Ui). */
3765/* = 2, it is NECESSARY to cut only by V (i.e. insert parameter of cutting Vj). */
3766/* = 3, it is NECESSARY to cut both by U AND by V. */
3767/* IERCOD: Error code. */
3768/* = 0, Everything is OK. */
3769/* = -1, There is the best possible solution, but the */
3770/* user tolerance is not satisfactory (3*only) */
3771/* = 1, Incoherent entries. */
3772
3773/* COMMONS USED : */
7fd59977 3774/* ---------------- */
3775
0d969553
Y		 3776/* REFERENCES CALLED : */
3777/* --------------------- */
7fd59977 3778
0d969553
Y		 3779/* DESCRIPTION/NOTES/LIMITATIONS : */
3780/* ------------------------------- */
7fd59977 3781
7fd59977 3782/* > */
3783/* **********************************************************************
3784*/
0d969553 3785/* Name of the routine */
7fd59977 3786
3787
3788/* --------------------------- Initialisations --------------------------
3789*/
3790
3791 /* Parameter adjustments */
3792 --errmoy;
3793 --errmax;
3794 --epsapr;
3795 --ndimse;
3796 patjac_dim1 = *ndjacu + 1;
3797 patjac_dim2 = *ndjacv + 1;
3798 patjac_offset = patjac_dim1 * patjac_dim2;
3799 patjac -= patjac_offset;
3800 diditb_dim1 = *nbpntu / 2 + 1;
3801 diditb_dim2 = *nbpntv / 2 + 1;
3802 diditb_offset = diditb_dim1 * diditb_dim2;
3803 diditb -= diditb_offset;
3804 soditb_dim1 = *nbpntu / 2;
3805 soditb_dim2 = *nbpntv / 2;
3806 soditb_offset = soditb_dim1 * (soditb_dim2 + 1) + 1;
3807 soditb -= soditb_offset;
3808 disotb_dim1 = *nbpntu / 2;
3809 disotb_dim2 = *nbpntv / 2;
3810 disotb_offset = disotb_dim1 * (disotb_dim2 + 1) + 1;
3811 disotb -= disotb_offset;
3812 sosotb_dim1 = *nbpntu / 2 + 1;
3813 sosotb_dim2 = *nbpntv / 2 + 1;
3814 sosotb_offset = sosotb_dim1 * sosotb_dim2;
3815 sosotb -= sosotb_offset;
3816
3817 /* Function Body */
3818 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 3;
3819 if (ldbg) {
3820 AdvApp2Var_SysBase::mgenmsg_("MMA2CE1", 7L);
3821 }
3822 *iercod = 0;
3823 iofwr = 0;
3824
3825 isz1 = (*nbpntu / 2 + 1) * (*ndjacu - ((*iordru + 1) << 1) + 1);
3826 isz2 = (*nbpntv / 2 + 1) * (*ndjacv - ((*iordrv + 1) << 1) + 1);
3827 isz3 = (*nbpntv / 2 + 1) * (*ndjacu - ((*iordru + 1) << 1) + 1) * *ndimen;
3828 isz4 = *nbpntv / 2 * (*ndjacu - ((*iordru + 1) << 1) + 1) * *ndimen;
3829 isz5 = *ndjacu + 1 - ((*iordru + 1) << 1);
3830 isz6 = *ndjacv + 1 - ((*iordrv + 1) << 1);
3831 isz7 = *ndimen << 2;
3832 iszwr = isz1 + isz2 + isz3 + isz4 + isz5 + isz6 + isz7;
3833 AdvApp2Var_SysBase::mcrrqst_(&c__8, &iszwr, wrkar, &iofwr, &ier);
3834 if (ier > 0) {
3835 goto L9013;
3836 }
3837 ipt1 = iofwr;
3838 ipt2 = ipt1 + isz1;
3839 ipt3 = ipt2 + isz2;
3840 ipt4 = ipt3 + isz3;
3841 ipt5 = ipt4 + isz4;
3842 ipt6 = ipt5 + isz5;
3843 ipt7 = ipt6 + isz6;
3844
0d969553 3845/* ----------------- Return Gauss coefficients of integration ----------------
7fd59977 3846*/
3847
3848 AdvApp2Var_ApproxF2var::mmapptt_(ndjacu, nbpntu, iordru, &wrkar[ipt1], iercod);
3849 if (*iercod > 0) {
3850 goto L9999;
3851 }
3852 AdvApp2Var_ApproxF2var::mmapptt_(ndjacv, nbpntv, iordrv, &wrkar[ipt2], iercod);
3853 if (*iercod > 0) {
3854 goto L9999;
3855 }
3856
0d969553 3857/* ------------------- Return max polynoms of Jacobi ------------
7fd59977 3858*/
3859
3860 AdvApp2Var_ApproxF2var::mma2jmx_(ndjacu, iordru, &wrkar[ipt5]);
3861 AdvApp2Var_ApproxF2var::mma2jmx_(ndjacv, iordrv, &wrkar[ipt6]);
3862
0d969553 3863/* ------ Calculate the coefficients and their contribution to the error ----
7fd59977 3864*/
3865
3866 mma2ce2_(numdec, ndimen, nbsesp, &ndimse[1], ndminu, ndminv, ndguli,
3867 ndgvli, ndjacu, ndjacv, iordru, iordrv, nbpntu, nbpntv, &epsapr[1]
3868 , &sosotb[sosotb_offset], &disotb[disotb_offset], &soditb[
3869 soditb_offset], &diditb[diditb_offset], &wrkar[ipt1], &wrkar[ipt2]
3870 , &wrkar[ipt5], &wrkar[ipt6], &wrkar[ipt7], &wrkar[ipt3], &wrkar[
3871 ipt4], &patjac[patjac_offset], &errmax[1], &errmoy[1], ndegpu,
3872 ndegpv, itydec, iercod);
3873 if (*iercod > 0) {
3874 goto L9999;
3875 }
3876 goto L9999;
3877
3878/* ------------------------------ The end -------------------------------
3879*/
3880
3881L9013:
3882 *iercod = 13;
3883 goto L9999;
3884
3885L9999:
3886 if (iofwr != 0) {
3887 AdvApp2Var_SysBase::mcrdelt_(&c__8, &iszwr, wrkar, &iofwr, &ier);
3888 }
3889 if (ier > 0) {
3890 *iercod = 13;
3891 }
3892 AdvApp2Var_SysBase::maermsg_("MMA2CE1", iercod, 7L);
3893 if (ldbg) {
3894 AdvApp2Var_SysBase::mgsomsg_("MMA2CE1", 7L);
3895 }
3896 return 0;
3897} /* mma2ce1_ */
3898
3899//=======================================================================
3900//function : mma2ce2_
3901//purpose :
3902//=======================================================================
3903int mma2ce2_(integer *numdec,
3904 integer *ndimen,
3905 integer *nbsesp,
3906 integer *ndimse,
3907 integer *ndminu,
3908 integer *ndminv,
3909 integer *ndguli,
3910 integer *ndgvli,
3911 integer *ndjacu,
3912 integer *ndjacv,
3913 integer *iordru,
3914 integer *iordrv,
3915 integer *nbpntu,
3916 integer *nbpntv,
3917 doublereal *epsapr,
3918 doublereal *sosotb,
3919 doublereal *disotb,
3920 doublereal *soditb,
3921 doublereal *diditb,
3922 doublereal *gssutb,
3923 doublereal *gssvtb,
3924 doublereal *xmaxju,
3925 doublereal *xmaxjv,
3926 doublereal *vecerr,
3927 doublereal *chpair,
3928 doublereal *chimpr,
3929 doublereal *patjac,
3930 doublereal *errmax,
3931 doublereal *errmoy,
3932 integer *ndegpu,
3933 integer *ndegpv,
3934 integer *itydec,
3935 integer *iercod)
3936
3937{
3938 /* System generated locals */
3939 integer sosotb_dim1, sosotb_dim2, sosotb_offset, disotb_dim1, disotb_dim2,
3940 disotb_offset, soditb_dim1, soditb_dim2, soditb_offset,
3941 diditb_dim1, diditb_dim2, diditb_offset, gssutb_dim1, gssvtb_dim1,
3942 chpair_dim1, chpair_dim2, chpair_offset, chimpr_dim1,
3943 chimpr_dim2, chimpr_offset, patjac_dim1, patjac_dim2,
3944 patjac_offset, vecerr_dim1, vecerr_offset, i__1, i__2, i__3, i__4;
3945
3946 /* Local variables */
3947 static logical ldbg;
3948 static integer idim, igsu, minu, minv, maxu, maxv, igsv;
3949 static doublereal vaux[3];
3950 static integer i2rdu, i2rdv, ndses, nd, ii, jj, kk, nu, nv;
3951 static doublereal zu, zv;
3952 static integer nu1, nv1;
3953
3954/* **********************************************************************
3955*/
0d969553 3956/* FUNCTION : */
7fd59977 3957/* ---------- */
0d969553
Y		 3958/* Calculation of coefficients of polynomial approximation of degree */
3959/* (NDJACU,NDJACV) of a function F(u,v), starting from its */
3960/* discretization on roots of Legendre polynom of degree */
3961/* NBPNTU by U and NBPNTV by V. */
7fd59977 3962
0d969553 3963/* KEYWORDS : */
7fd59977 3964/* ----------- */
3965/* TOUS,AB_SPECIFI::FONCTION&,APPROXIMATION,&COEFFICIENT,&POLYNOME */
3966
0d969553 3967/* INPUT ARGUMENTS : */
7fd59977 3968/* ------------------ */
0d969553
Y		 3969/* NUMDEC: Indicates if it is POSSIBLE to cut function F(u,v). */
3970/* = 5, It is POSSIBLE to cut by U or by V or in both directions simultaneously. */
3971/* = 4, It is POSSIBLE to cut by U or by V BUT NOT in both */
3972/* directions simultaneously (cutting by V is preferable). */
3973/* = 3, It is POSSIBLE to cut by U or by V BUT NOT in both */
3974/* directions simultaneously (cutting by U is preferable). */
3975/* = 2, It is POSSIBLE to cut only by V (i.e. insert parameter */
3976/* of cutting Vj). */
3977/* = 1, It is POSSIBLE to cut only by U (i.e. insert parameter */
3978/* of cutting Ui). */
3979/* = 0, It is not POSSIBLE to cut anything */
3980/* NDIMEN: Total dimension of the space. */
3981/* NBSESP: Nb of independent sub-spaces on which the errors are calculated. */
3982/* NDIMSE: Table of dimensions of each of sub-spaces. */
3983/* NDMINU: Minimum degree by U to be preserved for the approximation. */
3984/* NDMINV: Minimum degree by V to be preserved for the approximation. */
3985/* NDGULI: Limit of nb of coefficients by U of the solution. */
3986/* NDGVLI: Limit of nb of coefficients by V of the solution. */
3987/* NDJACU: Max degree of the polynom of approximation by U. */
3988/* The representation in the orthogonal base starts from degree */
3989/* 0 to degree NDJACU-2*(IORDRU+1). The polynomial base is the base of */
3990/* Jacobi of order -1 (Legendre), 0, 1 or 2. */
3991/* It is required that 2*IORDRU+1 <= NDMINU <= NDGULI < NDJACU */
3992/* NDJACV: Max degree of the polynom of approximation by V. */
3993/* The representation in the orthogonal base starts from degree */
3994/* 0 to degree NDJACV-2*(IORDRV+1). The polynomial base is */
3995/* the base of Jacobi of order -1 (Legendre), 0, 1 or 2 */
3996/* It is required that 2*IORDRV+1 <= NDMINV <= NDGVLI < NDJACV */
3997/* IORDRU: Order of the Jacobi base (-1,0,1 or 2) by U. Corresponds */
3998/* to the step of constraints C0, C1 or C2. */
3999/* IORDRV: Order of the Jacobi base (-1,0,1 or 2) by U. Corresponds */
4000/* to the step of constraints C0, C1 or C2. */
4001/* NBPNTU: Degree of Legendre polynom on the roots which of are */
4002/* calculated the coefficients of integration by u */
4003/* by Gauss method. It is required that NBPNTU = 30, 40, */
4004/* 50 or 61 and NDJACU-2*(IORDRU+1) < NBPNTU. */
4005/* NBPNTV: Degree of Legendre polynom on the roots which of are */
4006/* calculated the coefficients of integration by u */
4007/* by Gauss method. It is required that NBPNTV = 30, 40, */
4008/* 50 or 61 and NDJACV-2*(IORDRV+1) < NBPNTV. */
4009/* EPSAPR: Table of NBSESP tolerances imposed on each sub-spaces. */
4010/* SOSOTB: Table of F(ui,vj) + F(ui,-vj) + F(-ui,vj) + F(-ui,-vj) */
4011/* with ui and vj - positive roots of the Legendre polynom */
4012/* of degree NBPNTU and NBPNTV respectively. Additionally, */
4013/* table SOSOTB(0,j) contains F(0,vj) + F(0,-vj), */
4014/* table SOSOTB(i,0) contains F(ui,0) + F(-ui,0) and */
4015/* SOSOTB(0,0) contains F(0,0). */
4016/* DISOTB: Table of F(ui,vj) + F(ui,-vj) - F(-ui,vj) - F(-ui,-vj) */
4017/* with ui and vj positive roots of Legendre polynom */
4018/* of degree NBPNTU and NBPNTV respectively. */
4019/* SODITB: Table of F(ui,vj) - F(ui,-vj) + F(-ui,vj) - F(-ui,-vj) */
4020/* with ui and vj positive roots of Legendre polynom */
4021/* of degree NBPNTU and NBPNTV respectively. */
4022/* DIDITB: Table of F(ui,vj) - F(ui,-vj) - F(-ui,vj) + F(-ui,-vj) */
4023/* with ui and vj positive roots of Legendre polynom */
4024/* of degree NBPNTU and NBPNTV respectively. Additionally, */
4025/* table DIDITB(0,j) contains F(0,vj) - F(0,-vj), */
4026/* and table DIDITB(i,0) contains F(ui,0) - F(-ui,0). */
4027/* GSSUTB: Table of coefficients of integration by Gauss method */
4028/* by U: i varies from 0 to NBPNTU/2 and k varies from 0 to */
7fd59977 4029/* NDJACU-2*(IORDRU+1). */
0d969553
Y		 4030/* GSSVTB: Table of coefficients of integration by Gauss method */
4031/* by V: i varies from 0 to NBPNTV/2 and k varies from 0 to */
7fd59977 4032/* NDJACV-2*(IORDRV+1). */
0d969553
Y		 4033/* XMAXJU: Maximum value of Jacobi polynoms of order IORDRU, */
4034/* from degree 0 to degree NDJACU - 2*(IORDRU+1) */
4035/* XMAXJV: Maximum value of Jacobi polynoms of order IORDRV, */
4036/* from degree 0 to degree NDJACV - 2*(IORDRV+1) */
7fd59977 4037
0d969553 4038/* OUTPUT ARGUMENTS : */
7fd59977 4039/* ------------------- */
0d969553
Y		 4040/* VECERR: Auxiliary table. */
4041/* CHPAIR: Auxiliary table of terms connected to degree NDJACU by U */
4042/* to calculate the coeff. of approximation of EVEN degree by V. */
4043/* CHIMPR: Auxiliary table of terms connected to degree NDJACU by U */
4044/* to calculate the coeff. of approximation of UNEVEN degree by V. */
4045/* PATJAC: Table of coefficients of polynom P(u,v) of approximation */
4046/* of F(u,v) with eventually taking into account of */
4047/* constraints. P(u,v) is of degree (NDJACU,NDJACV). */
4048/* This table contains other coeff if ITYDEC = 0. */
4049/* ERRMAX: For 1<=i<=NBSESP, ERRMAX(i) contains max errors */
4050/* on each of sub-spaces SI ITYDEC = 0. */
4051/* ERRMOY: Contains average errors for each of NBSESP sub-spaces SI ITYDEC = 0. */
4052/* NDEGPU: Degree by U for square PATJAC. Valable if ITYDEC=0. */
4053/* NDEGPV: Degree by V for square PATJAC. Valable if ITYDEC=0. */
4054/* ITYDEC: Shows if it is NECESSARY to cut again function F(u,v). */
4055/* = 0, it is not NECESSARY to cut anything, PATJAC is OK. */
4056/* = 1, it is NECESSARY to cut only by U (i.e. insert parameter of cutting Ui). */
4057/* = 2, it is NECESSARY to cut only by V (i.e. insert parameter of cutting Vj). */
4058/* = 3, it is NECESSARY to cut both by U AND by V. */
4059/* IERCOD: Error code. */
4060/* = 0, Everything is OK. */
4061/* = -1, There is the best possible solution, but the */
4062/* user tolerance is not satisfactory (3*only) */
4063/* = 1, Incoherent entries. */
4064
4065/* COMMONS USED : */
7fd59977 4066/* ---------------- */
4067
0d969553
Y		 4068/* REFERENCES CALLED : */
4069/* --------------------- */
7fd59977 4070
0d969553 4071/* DESCRIPTION/NOTES/LIMITATIONS : */
7fd59977 4072/* > */
4073/* **********************************************************************
4074*/
0d969553 4075/* Name of the routine */
7fd59977 4076
4077
4078/* --------------------------- Initialisations --------------------------
4079*/
4080
4081 /* Parameter adjustments */
4082 vecerr_dim1 = *ndimen;
4083 vecerr_offset = vecerr_dim1 + 1;
4084 vecerr -= vecerr_offset;
4085 --errmoy;
4086 --errmax;
4087 --epsapr;
4088 --ndimse;
4089 patjac_dim1 = *ndjacu + 1;
4090 patjac_dim2 = *ndjacv + 1;
4091 patjac_offset = patjac_dim1 * patjac_dim2;
4092 patjac -= patjac_offset;
4093 gssutb_dim1 = *nbpntu / 2 + 1;
4094 chimpr_dim1 = *nbpntv / 2;
4095 chimpr_dim2 = *ndjacu - ((*iordru + 1) << 1) + 1;
4096 chimpr_offset = chimpr_dim1 * chimpr_dim2 + 1;
4097 chimpr -= chimpr_offset;
4098 chpair_dim1 = *nbpntv / 2 + 1;
4099 chpair_dim2 = *ndjacu - ((*iordru + 1) << 1) + 1;
4100 chpair_offset = chpair_dim1 * chpair_dim2;
4101 chpair -= chpair_offset;
4102 gssvtb_dim1 = *nbpntv / 2 + 1;
4103 diditb_dim1 = *nbpntu / 2 + 1;
4104 diditb_dim2 = *nbpntv / 2 + 1;
4105 diditb_offset = diditb_dim1 * diditb_dim2;
4106 diditb -= diditb_offset;
4107 soditb_dim1 = *nbpntu / 2;
4108 soditb_dim2 = *nbpntv / 2;
4109 soditb_offset = soditb_dim1 * (soditb_dim2 + 1) + 1;
4110 soditb -= soditb_offset;
4111 disotb_dim1 = *nbpntu / 2;
4112 disotb_dim2 = *nbpntv / 2;
4113 disotb_offset = disotb_dim1 * (disotb_dim2 + 1) + 1;
4114 disotb -= disotb_offset;
4115 sosotb_dim1 = *nbpntu / 2 + 1;
4116 sosotb_dim2 = *nbpntv / 2 + 1;
4117 sosotb_offset = sosotb_dim1 * sosotb_dim2;
4118 sosotb -= sosotb_offset;
4119
4120 /* Function Body */
4121 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 3;
4122 if (ldbg) {
4123 AdvApp2Var_SysBase::mgenmsg_("MMA2CE2", 7L);
4124 }
0d969553 4125/* --> A priori everything is OK */
7fd59977 4126 *iercod = 0;
0d969553 4127/* --> test of inputs */
7fd59977 4128 if (*numdec < 0 || *numdec > 5) {
4129 goto L9001;
4130 }
4131 if ((*iordru << 1) + 1 > *ndminu) {
4132 goto L9001;
4133 }
4134 if (*ndminu > *ndguli) {
4135 goto L9001;
4136 }
4137 if (*ndguli >= *ndjacu) {
4138 goto L9001;
4139 }
4140 if ((*iordrv << 1) + 1 > *ndminv) {
4141 goto L9001;
4142 }
4143 if (*ndminv > *ndgvli) {
4144 goto L9001;
4145 }
4146 if (*ndgvli >= *ndjacv) {
4147 goto L9001;
4148 }
0d969553 4149/* --> A priori, no cuts to be done */
7fd59977 4150 *itydec = 0;
0d969553 4151/* --> Min. degrees to return: NDMINU,NDMINV */
7fd59977 4152 *ndegpu = *ndminu;
4153 *ndegpv = *ndminv;
0d969553 4154/* --> For the moment, max errors are null */
7fd59977 4155 AdvApp2Var_SysBase::mvriraz_(nbsesp, (char *)&errmax[1]);
4156 nd = *ndimen << 2;
4157 AdvApp2Var_SysBase::mvriraz_(&nd, (char *)&vecerr[vecerr_offset]);
0d969553 4158/* --> and the square, too. */
7fd59977 4159 nd = (*ndjacu + 1) * (*ndjacv + 1) * *ndimen;
4160 AdvApp2Var_SysBase::mvriraz_(&nd, (char *)&patjac[patjac_offset]);
4161
4162 i2rdu = (*iordru + 1) << 1;
4163 i2rdv = (*iordrv + 1) << 1;
4164
4165/* **********************************************************************
4166*/
0d969553 4167/* -------------------- HERE IT IS POSSIBLE TO CUT ----------------------
7fd59977 4168*/
4169/* **********************************************************************
4170*/
4171
4172 if (*numdec > 0 && *numdec <= 5) {
4173
4174/* ******************************************************************
4175**** */
0d969553 4176/* ---------------------- Calculate coeff of zone 4 -------------
7fd59977 4177---- */
4178
4179 minu = *ndguli + 1;
4180 maxu = *ndjacu;
4181 minv = *ndgvli + 1;
4182 maxv = *ndjacv;
4183 if (minu > maxu) {
4184 goto L9001;
4185 }
4186 if (minv > maxv) {
4187 goto L9001;
4188 }
4189
0d969553 4190/* ---------------- Calculate the terms connected to degree by U ---------
7fd59977 4191---- */
4192
4193 i__1 = *ndimen;
4194 for (nd = 1; nd <= i__1; ++nd) {
4195 i__2 = maxu;
4196 for (kk = minu; kk <= i__2; ++kk) {
4197 igsu = kk - i2rdu;
4198 mma2cfu_(&kk, nbpntu, nbpntv, &sosotb[nd * sosotb_dim2 *
4199 sosotb_dim1], &disotb[(nd * disotb_dim2 + 1) *
4200 disotb_dim1 + 1], &soditb[(nd * soditb_dim2 + 1) *
4201 soditb_dim1 + 1], &diditb[nd * diditb_dim2 *
4202 diditb_dim1], &gssutb[igsu * gssutb_dim1], &chpair[(
4203 igsu + nd * chpair_dim2) * chpair_dim1], &chimpr[(
4204 igsu + nd * chimpr_dim2) * chimpr_dim1 + 1]);
4205/* L110: */
4206 }
4207/* L100: */
4208 }
4209
0d969553 4210/* ------------------- Calculate the coefficients of PATJAC ------------
7fd59977 4211---- */
4212
4213 igsu = minu - i2rdu;
4214 i__1 = maxv;
4215 for (jj = minv; jj <= i__1; ++jj) {
4216 igsv = jj - i2rdv;
4217 i__2 = *ndimen;
4218 for (nd = 1; nd <= i__2; ++nd) {
4219 mma2cfv_(&jj, &minu, &maxu, nbpntv, &gssvtb[igsv *
4220 gssvtb_dim1], &chpair[(igsu + nd * chpair_dim2) *
4221 chpair_dim1], &chimpr[(igsu + nd * chimpr_dim2) *
4222 chimpr_dim1 + 1], &patjac[minu + (jj + nd *
4223 patjac_dim2) * patjac_dim1]);
4224/* L130: */
4225 }
4226
0d969553
Y		 4227/* ----- Contribution of calculated terms to the approximation error */
4228/* for terms (I,J) with MINU <= I <= MAXU, J fixe. */
7fd59977 4229
4230 idim = 1;
4231 i__2 = *nbsesp;
4232 for (nd = 1; nd <= i__2; ++nd) {
4233 ndses = ndimse[nd];
4234 mma2er1_(ndjacu, ndjacv, &ndses, &minu, &maxu, &jj, &jj,
4235 iordru, iordrv, xmaxju, xmaxjv, &patjac[idim *
4236 patjac_dim2 * patjac_dim1], &vecerr[vecerr_dim1 + 1],
4237 &vecerr[nd + (vecerr_dim1 << 2)]);
4238 if (vecerr[nd + (vecerr_dim1 << 2)] > epsapr[nd]) {
4239 goto L9300;
4240 }
4241 idim += ndses;
4242/* L140: */
4243 }
4244/* L120: */
4245 }
4246
4247/* ******************************************************************
4248**** */
0d969553 4249/* ---------------------- Calculate the coeff of zone 2 -------------
7fd59977 4250---- */
4251
4252 minu = (*iordru + 1) << 1;
4253 maxu = *ndguli;
4254 minv = *ndgvli + 1;
4255 maxv = *ndjacv;
4256
0d969553
Y		 4257/* --> If zone 2 is empty, pass to zone 3. */
4258/* VECERR(ND,2) was already set to zero. */
7fd59977 4259 if (minu > maxu) {
4260 goto L300;
4261 }
4262
0d969553 4263/* ---------------- Calculate the terms connected to degree by U ------------
7fd59977 4264---- */
4265
4266 i__1 = *ndimen;
4267 for (nd = 1; nd <= i__1; ++nd) {
4268 i__2 = maxu;
4269 for (kk = minu; kk <= i__2; ++kk) {
4270 igsu = kk - i2rdu;
4271 mma2cfu_(&kk, nbpntu, nbpntv, &sosotb[nd * sosotb_dim2 *
4272 sosotb_dim1], &disotb[(nd * disotb_dim2 + 1) *
4273 disotb_dim1 + 1], &soditb[(nd * soditb_dim2 + 1) *
4274 soditb_dim1 + 1], &diditb[nd * diditb_dim2 *
4275 diditb_dim1], &gssutb[igsu * gssutb_dim1], &chpair[(
4276 igsu + nd * chpair_dim2) * chpair_dim1], &chimpr[(
4277 igsu + nd * chimpr_dim2) * chimpr_dim1 + 1]);
4278/* L210: */
4279 }
4280/* L200: */
4281 }
4282
0d969553 4283/* ------------------- Calculate the coefficients of PATJAC ------------
7fd59977 4284---- */
4285
4286 igsu = minu - i2rdu;
4287 i__1 = maxv;
4288 for (jj = minv; jj <= i__1; ++jj) {
4289 igsv = jj - i2rdv;
4290 i__2 = *ndimen;
4291 for (nd = 1; nd <= i__2; ++nd) {
4292 mma2cfv_(&jj, &minu, &maxu, nbpntv, &gssvtb[igsv *
4293 gssvtb_dim1], &chpair[(igsu + nd * chpair_dim2) *
4294 chpair_dim1], &chimpr[(igsu + nd * chimpr_dim2) *
4295 chimpr_dim1 + 1], &patjac[minu + (jj + nd *
4296 patjac_dim2) * patjac_dim1]);
4297/* L230: */
4298 }
4299/* L220: */
4300 }
4301
0d969553
Y		 4302/* -----Contribution of calculated terms to the approximation error */
4303/* for terms (I,J) with MINU <= I <= MAXU, MINV <= J <= MAXV */
7fd59977 4304
4305 idim = 1;
4306 i__1 = *nbsesp;
4307 for (nd = 1; nd <= i__1; ++nd) {
4308 ndses = ndimse[nd];
4309 mma2er1_(ndjacu, ndjacv, &ndses, &minu, &maxu, &minv, &maxv,
4310 iordru, iordrv, xmaxju, xmaxjv, &patjac[idim *
4311 patjac_dim2 * patjac_dim1], &vecerr[vecerr_dim1 + 1], &
4312 vecerr[nd + (vecerr_dim1 << 1)]);
4313 idim += ndses;
4314/* L240: */
4315 }
4316
4317/* ******************************************************************
4318**** */
0d969553 4319/* ---------------------- Calculation of coeff of zone 3 -------------
7fd59977 4320---- */
4321
4322L300:
4323 minu = *ndguli + 1;
4324 maxu = *ndjacu;
4325 minv = (*iordrv + 1) << 1;
4326 maxv = *ndgvli;
4327
0d969553
Y		 4328/* -> If zone 3 is empty, pass to the test of cutting. */
4329/* VECERR(ND,3) was already set to zero */
7fd59977 4330 if (minv > maxv) {
4331 goto L400;
4332 }
4333
0d969553 4334/* ----------- The terms connected to the degree by U are already calculated -----
7fd59977 4335---- */
0d969553 4336/* ------------------- Calculation of coefficients of PATJAC ------------
7fd59977 4337---- */
4338
4339 igsu = minu - i2rdu;
4340 i__1 = maxv;
4341 for (jj = minv; jj <= i__1; ++jj) {
4342 igsv = jj - i2rdv;
4343 i__2 = *ndimen;
4344 for (nd = 1; nd <= i__2; ++nd) {
4345 mma2cfv_(&jj, &minu, &maxu, nbpntv, &gssvtb[igsv *
4346 gssvtb_dim1], &chpair[(igsu + nd * chpair_dim2) *
4347 chpair_dim1], &chimpr[(igsu + nd * chimpr_dim2) *
4348 chimpr_dim1 + 1], &patjac[minu + (jj + nd *
4349 patjac_dim2) * patjac_dim1]);
4350/* L330: */
4351 }
4352/* L320: */
4353 }
4354
0d969553
Y		 4355/* ----- Contribution of calculated terms to the approximation error
4356/* for terms (I,J) with MINU <= I <= MAXU, MINV <= J <= MAXV. */
7fd59977 4357
4358 idim = 1;
4359 i__1 = *nbsesp;
4360 for (nd = 1; nd <= i__1; ++nd) {
4361 ndses = ndimse[nd];
4362 mma2er1_(ndjacu, ndjacv, &ndses, &minu, &maxu, &minv, &maxv,
4363 iordru, iordrv, xmaxju, xmaxjv, &patjac[idim *
4364 patjac_dim2 * patjac_dim1], &vecerr[vecerr_dim1 + 1], &
4365 vecerr[nd + vecerr_dim1 * 3]);
4366 idim += ndses;
4367/* L340: */
4368 }
4369
4370/* ******************************************************************
4371**** */
0d969553 4372/* --------------------------- Tests of cutting ---------------------
7fd59977 4373---- */
4374
4375L400:
4376 i__1 = *nbsesp;
4377 for (nd = 1; nd <= i__1; ++nd) {
4378 vaux[0] = vecerr[nd + (vecerr_dim1 << 1)];
4379 vaux[1] = vecerr[nd + (vecerr_dim1 << 2)];
4380 vaux[2] = vecerr[nd + vecerr_dim1 * 3];
4381 ii = 3;
4382 errmax[nd] = AdvApp2Var_MathBase::mzsnorm_(&ii, vaux);
4383 if (errmax[nd] > epsapr[nd]) {
4384 ii = 2;
4385 zv = AdvApp2Var_MathBase::mzsnorm_(&ii, vaux);
4386 zu = AdvApp2Var_MathBase::mzsnorm_(&ii, &vaux[1]);
4387 if (zu > epsapr[nd] && zv > epsapr[nd]) {
4388 goto L9300;
4389 }
4390 if (zu > zv) {
4391 goto L9100;
4392 } else {
4393 goto L9200;
4394 }
4395 }
4396/* L410: */
4397 }
4398
4399/* ******************************************************************
4400**** */
0d969553 4401/* --- OK, the square is valid, the coeff of zone 1 are calculated
7fd59977 4402---- */
4403
4404 minu = (*iordru + 1) << 1;
4405 maxu = *ndguli;
4406 minv = (*iordrv + 1) << 1;
4407 maxv = *ndgvli;
4408
0d969553 4409/* --> If zone 1 is empty, pass to the calculation of Max and Average error. */
7fd59977 4410 if (minu > maxu || minv > maxv) {
4411 goto L600;
4412 }
4413
0d969553 4414/* ----------- The terms connected to degree by U are already calculated -----
7fd59977 4415---- */
0d969553 4416/* ------------------- Calculate the coefficients of PATJAC ------------
7fd59977 4417---- */
4418
4419 igsu = minu - i2rdu;
4420 i__1 = maxv;
4421 for (jj = minv; jj <= i__1; ++jj) {
4422 igsv = jj - i2rdv;
4423 i__2 = *ndimen;
4424 for (nd = 1; nd <= i__2; ++nd) {
4425 mma2cfv_(&jj, &minu, &maxu, nbpntv, &gssvtb[igsv *
4426 gssvtb_dim1], &chpair[(igsu + nd * chpair_dim2) *
4427 chpair_dim1], &chimpr[(igsu + nd * chimpr_dim2) *
4428 chimpr_dim1 + 1], &patjac[minu + (jj + nd *
4429 patjac_dim2) * patjac_dim1]);
4430/* L530: */
4431 }
4432/* L520: */
4433 }
4434
0d969553 4435/* --------------- Now the degree is maximally lowered --------
7fd59977 4436---- */
4437
4438L600:
4439/* Computing MAX */
4440 i__1 = 1, i__2 = (*iordru << 1) + 1, i__1 = max(i__1,i__2);
4441 minu = max(i__1,*ndminu);
4442 maxu = *ndguli;
4443/* Computing MAX */
4444 i__1 = 1, i__2 = (*iordrv << 1) + 1, i__1 = max(i__1,i__2);
4445 minv = max(i__1,*ndminv);
4446 maxv = *ndgvli;
4447 idim = 1;
4448 i__1 = *nbsesp;
4449 for (nd = 1; nd <= i__1; ++nd) {
4450 ndses = ndimse[nd];
4451 if (maxu >= (*iordru + 1) << 1 && maxv >= (*iordrv + 1) << 1) {
4452 mma2er2_(ndjacu, ndjacv, &ndses, &minu, &maxu, &minv, &maxv,
4453 iordru, iordrv, xmaxju, xmaxjv, &patjac[idim *
4454 patjac_dim2 * patjac_dim1], &epsapr[nd], &vecerr[
4455 vecerr_dim1 + 1], &errmax[nd], &nu, &nv);
4456 } else {
4457 nu = maxu;
4458 nv = maxv;
4459 }
4460 nu1 = nu + 1;
4461 nv1 = nv + 1;
4462
0d969553 4463/* --> Calculate the average error. */
7fd59977 4464 mma2moy_(ndjacu, ndjacv, &ndses, &nu1, ndjacu, &nv1, ndjacv,
4465 iordru, iordrv, &patjac[idim * patjac_dim2 * patjac_dim1],
4466 &errmoy[nd]);
4467
0d969553 4468/* --> Set to 0.D0 the rejected coeffs. */
7fd59977 4469 i__2 = idim + ndses - 1;
4470 for (ii = idim; ii <= i__2; ++ii) {
4471 i__3 = *ndjacv;
4472 for (jj = nv1; jj <= i__3; ++jj) {
4473 i__4 = *ndjacu;
4474 for (kk = nu1; kk <= i__4; ++kk) {
4475 patjac[kk + (jj + ii * patjac_dim2) * patjac_dim1] =
4476 0.;
4477/* L640: */
4478 }
4479/* L630: */
4480 }
4481/* L620: */
4482 }
4483
0d969553 4484/* --> Return the nb of coeffs of approximation. */
7fd59977 4485 *ndegpu = max(*ndegpu,nu);
4486 *ndegpv = max(*ndegpv,nv);
4487 idim += ndses;
4488/* L610: */
4489 }
4490
4491/* ******************************************************************
4492**** */
0d969553 4493/* -------------------- IT IS NOT POSSIBLE TO CUT -------------------
7fd59977 4494---- */
4495/* ******************************************************************
4496**** */
4497
4498 } else {
4499 minu = (*iordru + 1) << 1;
4500 maxu = *ndjacu;
4501 minv = (*iordrv + 1) << 1;
4502 maxv = *ndjacv;
4503
0d969553 4504/* ---------------- Calculate the terms connected to the degree by U ------------
7fd59977 4505---- */
4506
4507 i__1 = *ndimen;
4508 for (nd = 1; nd <= i__1; ++nd) {
4509 i__2 = maxu;
4510 for (kk = minu; kk <= i__2; ++kk) {
4511 igsu = kk - i2rdu;
4512 mma2cfu_(&kk, nbpntu, nbpntv, &sosotb[nd * sosotb_dim2 *
4513 sosotb_dim1], &disotb[(nd * disotb_dim2 + 1) *
4514 disotb_dim1 + 1], &soditb[(nd * soditb_dim2 + 1) *
4515 soditb_dim1 + 1], &diditb[nd * diditb_dim2 *
4516 diditb_dim1], &gssutb[igsu * gssutb_dim1], &chpair[(
4517 igsu + nd * chpair_dim2) * chpair_dim1], &chimpr[(
4518 igsu + nd * chimpr_dim2) * chimpr_dim1 + 1]);
4519/* L710: */
4520 }
4521
0d969553 4522/* ---------------------- Calculate all coefficients -------
7fd59977 4523-------- */
4524
4525 igsu = minu - i2rdu;
4526 i__2 = maxv;
4527 for (jj = minv; jj <= i__2; ++jj) {
4528 igsv = jj - i2rdv;
4529 mma2cfv_(&jj, &minu, &maxu, nbpntv, &gssvtb[igsv *
4530 gssvtb_dim1], &chpair[(igsu + nd * chpair_dim2) *
4531 chpair_dim1], &chimpr[(igsu + nd * chimpr_dim2) *
4532 chimpr_dim1 + 1], &patjac[minu + (jj + nd *
4533 patjac_dim2) * patjac_dim1]);
4534/* L720: */
4535 }
4536/* L700: */
4537 }
4538
0d969553
Y		 4539/* ----- Contribution of calculated terms to the approximation error
4540/* for terms (I,J) with MINU <= I <= MAXU, MINV <= J <= MAXV */
7fd59977 4541
4542 idim = 1;
4543 i__1 = *nbsesp;
4544 for (nd = 1; nd <= i__1; ++nd) {
4545 ndses = ndimse[nd];
4546 minu = (*iordru + 1) << 1;
4547 maxu = *ndjacu;
4548 minv = *ndgvli + 1;
4549 maxv = *ndjacv;
4550 mma2er1_(ndjacu, ndjacv, &ndses, &minu, &maxu, &minv, &maxv,
4551 iordru, iordrv, xmaxju, xmaxjv, &patjac[idim *
4552 patjac_dim2 * patjac_dim1], &vecerr[vecerr_dim1 + 1], &
4553 errmax[nd]);
4554 minu = *ndguli + 1;
4555 maxu = *ndjacu;
4556 minv = (*iordrv + 1) << 1;
4557 maxv = *ndgvli;
4558 if (minv <= maxv) {
4559 mma2er1_(ndjacu, ndjacv, &ndses, &minu, &maxu, &minv, &maxv,
4560 iordru, iordrv, xmaxju, xmaxjv, &patjac[idim *
4561 patjac_dim2 * patjac_dim1], &vecerr[vecerr_dim1 + 1],
4562 &errmax[nd]);
4563 }
4564
0d969553 4565/* ---------------------------- IF ERRMAX > EPSAPR, stop --------
7fd59977 4566-------- */
4567
4568 if (errmax[nd] > epsapr[nd]) {
4569 *iercod = -1;
4570 nu = *ndguli;
4571 nv = *ndgvli;
4572
0d969553 4573/* ------------- Otherwise, try to remove again the coeff
7fd59977 4574------------ */
4575
4576 } else {
4577/* Computing MAX */
4578 i__2 = 1, i__3 = (*iordru << 1) + 1, i__2 = max(i__2,i__3);
4579 minu = max(i__2,*ndminu);
4580 maxu = *ndguli;
4581/* Computing MAX */
4582 i__2 = 1, i__3 = (*iordrv << 1) + 1, i__2 = max(i__2,i__3);
4583 minv = max(i__2,*ndminv);
4584 maxv = *ndgvli;
4585 if (maxu >= (*iordru + 1) << 1 && maxv >= (*iordrv + 1) << 1) {
4586 mma2er2_(ndjacu, ndjacv, &ndses, &minu, &maxu, &minv, &
4587 maxv, iordru, iordrv, xmaxju, xmaxjv, &patjac[
4588 idim * patjac_dim2 * patjac_dim1], &epsapr[nd], &
4589 vecerr[vecerr_dim1 + 1], &errmax[nd], &nu, &nv);
4590 } else {
4591 nu = maxu;
4592 nv = maxv;
4593 }
4594 }
4595
0d969553 4596/* --------------------- Calculate the average error -------------
7fd59977 4597-------- */
4598
4599 nu1 = nu + 1;
4600 nv1 = nv + 1;
4601 mma2moy_(ndjacu, ndjacv, &ndses, &nu1, ndjacu, &nv1, ndjacv,
4602 iordru, iordrv, &patjac[idim * patjac_dim2 * patjac_dim1],
4603 &errmoy[nd]);
4604
0d969553 4605/* --------------------- Set to 0.D0 the rejected coeffs ----------
7fd59977 4606-------- */
4607
4608 i__2 = idim + ndses - 1;
4609 for (ii = idim; ii <= i__2; ++ii) {
4610 i__3 = *ndjacv;
4611 for (jj = nv1; jj <= i__3; ++jj) {
4612 i__4 = *ndjacu;
4613 for (kk = nu1; kk <= i__4; ++kk) {
4614 patjac[kk + (jj + ii * patjac_dim2) * patjac_dim1] =
4615 0.;
4616/* L760: */
4617 }
4618/* L750: */
4619 }
4620/* L740: */
4621 }
4622
0d969553 4623/* --------------- Return the nb of coeff of approximation ---
7fd59977 4624-------- */
4625
4626 *ndegpu = max(*ndegpu,nu);
4627 *ndegpv = max(*ndegpv,nv);
4628 idim += ndses;
4629/* L730: */
4630 }
4631 }
4632
4633 goto L9999;
4634
4635/* ------------------------------ The end -------------------------------
4636*/
0d969553 4637/* --> Error in inputs */
7fd59977 4638L9001:
4639 *iercod = 1;
4640 goto L9999;
4641
0d969553 4642/* --------- Management of cuts, it is required 0 < NUMDEC <= 5 -------
7fd59977 4643*/
4644
0d969553 4645/* --> Here it is possible and necessary to cut, choose by U if it is possible */
7fd59977 4646L9100:
4647 if (*numdec <= 0 || *numdec > 5) {
4648 goto L9001;
4649 }
4650 if (*numdec != 2) {
4651 *itydec = 1;
4652 } else {
4653 *itydec = 2;
4654 }
4655 goto L9999;
0d969553 4656/* --> Here it is possible and necessary to cut, choose by U if it is possible */
7fd59977 4657L9200:
4658 if (*numdec <= 0 || *numdec > 5) {
4659 goto L9001;
4660 }
4661 if (*numdec != 1) {
4662 *itydec = 2;
4663 } else {
4664 *itydec = 1;
4665 }
4666 goto L9999;
0d969553 4667/* --> Here it is possible and necessary to cut, choose by 4 if it is possible */
7fd59977 4668L9300:
4669 if (*numdec <= 0 || *numdec > 5) {
4670 goto L9001;
4671 }
4672 if (*numdec == 5) {
4673 *itydec = 3;
4674 } else if (*numdec == 2 || *numdec == 4) {
4675 *itydec = 2;
4676 } else if (*numdec == 1 || *numdec == 3) {
4677 *itydec = 1;
4678 } else {
4679 goto L9001;
4680 }
4681 goto L9999;
4682
4683L9999:
4684 AdvApp2Var_SysBase::maermsg_("MMA2CE2", iercod, 7L);
4685 if (ldbg) {
4686 AdvApp2Var_SysBase::mgsomsg_("MMA2CE2", 7L);
4687 }
4688 return 0;
4689} /* mma2ce2_ */
4690
4691//=======================================================================
4692//function : mma2cfu_
4693//purpose :
4694//=======================================================================
4695int mma2cfu_(integer *ndujac,
4696 integer *nbpntu,
4697 integer *nbpntv,
4698 doublereal *sosotb,
4699 doublereal *disotb,
4700 doublereal *soditb,
4701 doublereal *diditb,
4702 doublereal *gssutb,
4703 doublereal *chpair,
4704 doublereal *chimpr)
4705
4706{
4707 /* System generated locals */
4708 integer sosotb_dim1, disotb_dim1, disotb_offset, soditb_dim1,
4709 soditb_offset, diditb_dim1, i__1, i__2;
4710
4711 /* Local variables */
4712 static logical ldbg;
4713 static integer nptu2, nptv2, ii, jj;
4714 static doublereal bid0, bid1, bid2;
4715
4716
4717/* **********************************************************************
4718*/
4719
0d969553 4720/* FUNCTION : */
7fd59977 4721/* ---------- */
0d969553
Y		 4722/* Calculate the terms connected to degree NDUJAC by U of the polynomial approximation */
4723/* of function F(u,v), starting from its discretisation
4724/* on the roots of Legendre polynom of degree */
4725/* NBPNTU by U and NBPNTV by V. */
7fd59977 4726
0d969553 4727/* KEYWORDS : */
7fd59977 4728/* ----------- */
4729/* FONCTION,APPROXIMATION,COEFFICIENT,POLYNOME */
4730
0d969553 4731/* INPUT ARGUMENTSE : */
7fd59977 4732/* ------------------ */
0d969553
Y		 4733/* NDUJAC: Fixed degree by U for which the terms */
4734/* allowing to obtain the Legendre or Jacobi coeff*/
4735/* of even or uneven degree by V are calculated. */
4736/* NBPNTU: Degree of Legendre polynom on the roots which of */
4737/* the coefficients of integration by U are calculated */
4738/* by Gauss method. It is required that NBPNTU = 30, 40, 50 or 61. */
4739/* NBPNTV: Degree of Legendre polynom on the roots which of */
4740/* the coefficients of integration by V are calculated */
4741/* by Gauss method. It is required that NBPNTV = 30, 40, 50 or 61. */
4742/* SOSOTB: Table of F(ui,vj) + F(ui,-vj) + F(-ui,vj) + F(-ui,-vj) */
4743/* with ui and vj positive roots of Legendre polynom */
4744/* of degree NBPNTU and NBPNTV respectively. Moreover, */
4745/* table SOSOTB(0,j) contains F(0,vj) + F(0,-vj), */
4746/* table SOSOTB(i,0) contains F(ui,0) + F(-ui,0) and */
4747/* SOSOTB(0,0) contains F(0,0). */
4748/* DISOTB: Table of F(ui,vj) + F(ui,-vj) - F(-ui,vj) - F(-ui,-vj) */
4749/* with ui and vj positive roots of Legendre polynom */
4750/* of degree NBPNTU and NBPNTV respectively. */
4751/* SODITB: Table of F(ui,vj) - F(ui,-vj) + F(-ui,vj) - F(-ui,-vj) */
4752/* with ui and vj positive roots of Legendre polynom */
4753/* of degree NBPNTU and NBPNTV respectively. */
4754/* DIDITB: Table of F(ui,vj) - F(ui,-vj) - F(-ui,vj) + F(-ui,-vj) */
4755/* avec ui and vj positive roots of Legendre polynom */
4756/* of degree NBPNTU and NBPNTV respectively. Moreover, */
4757/* table DIDITB(0,j) contains F(0,vj) - F(0,-vj), */
4758/* and table DIDITB(i,0) contains F(ui,0) - F(-ui,0). */
4759/* GSSUTB: Table of coefficients of integration by Gauss method */
4760/* Gauss by U for fixed NDUJAC : i varies from 0 to NBPNTU/2. */
4761
4762/* OUTPUT ARGUMENTS : */
7fd59977 4763/* ------------------- */
0d969553
Y		 4764/* CHPAIR: Table of terms connected to degree NDUJAC by U to calculate the */
4765/* coeff. of the approximation of EVEN degree by V. */
4766/* CHIMPR: Table of terms connected to degree NDUJAC by U to calculate */
4767/* the coeff. of approximation of UNEVEN degree by V. */
7fd59977 4768
0d969553 4769/* COMMONS USED : */
7fd59977 4770/* ---------------- */
4771
0d969553 4772/* REFERENCES CALLED : */
7fd59977 4773/* ----------------------- */
4774
0d969553 4775/* DESCRIPTION/NOTES/LIMITATIONS : */
7fd59977 4776/* ----------------------------------- */
4777
0d969553 4778
7fd59977 4779/* > */
4780/* **********************************************************************
4781*/
0d969553 4782/* Name of the routine */
7fd59977 4783
4784
4785/* --------------------------- Initialisations --------------------------
4786*/
4787
4788 /* Parameter adjustments */
4789 --chimpr;
4790 diditb_dim1 = *nbpntu / 2 + 1;
4791 soditb_dim1 = *nbpntu / 2;
4792 soditb_offset = soditb_dim1 + 1;
4793 soditb -= soditb_offset;
4794 disotb_dim1 = *nbpntu / 2;
4795 disotb_offset = disotb_dim1 + 1;
4796 disotb -= disotb_offset;
4797 sosotb_dim1 = *nbpntu / 2 + 1;
4798
4799 /* Function Body */
4800 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 3;
4801 if (ldbg) {
4802 AdvApp2Var_SysBase::mgenmsg_("MMA2CFU", 7L);
4803 }
4804
4805 nptu2 = *nbpntu / 2;
4806 nptv2 = *nbpntv / 2;
4807
4808/* **********************************************************************
4809*/
0d969553 4810/* CALCULATE COEFFICIENTS BY U */
7fd59977 4811
0d969553 4812/* ----------------- Calculate coefficients of even degree --------------
7fd59977 4813*/
4814
4815 if (*ndujac % 2 == 0) {
4816 i__1 = nptv2;
4817 for (jj = 1; jj <= i__1; ++jj) {
4818 bid1 = 0.;
4819 bid2 = 0.;
4820 i__2 = nptu2;
4821 for (ii = 1; ii <= i__2; ++ii) {
4822 bid0 = gssutb[ii];
4823 bid1 += sosotb[ii + jj * sosotb_dim1] * bid0;
4824 bid2 += soditb[ii + jj * soditb_dim1] * bid0;
4825/* L200: */
4826 }
4827 chpair[jj] = bid1;
4828 chimpr[jj] = bid2;
4829/* L100: */
4830 }
4831
0d969553 4832/* --------------- Calculate coefficients of uneven degree ----------
7fd59977 4833---- */
4834
4835 } else {
4836 i__1 = nptv2;
4837 for (jj = 1; jj <= i__1; ++jj) {
4838 bid1 = 0.;
4839 bid2 = 0.;
4840 i__2 = nptu2;
4841 for (ii = 1; ii <= i__2; ++ii) {
4842 bid0 = gssutb[ii];
4843 bid1 += disotb[ii + jj * disotb_dim1] * bid0;
4844 bid2 += diditb[ii + jj * diditb_dim1] * bid0;
4845/* L250: */
4846 }
4847 chpair[jj] = bid1;
4848 chimpr[jj] = bid2;
4849/* L150: */
4850 }
4851 }
4852
0d969553
Y		 4853/* ------- Add terms connected to the supplementary root (0.D0) ------
4854/* ----------- of Legendre polynom of uneven degree NBPNTU -----------
7fd59977 4855*/
0d969553
Y		 4856/* --> Only even NDUJAC terms are modified as GSSUTB(0) = 0 */
4857/* when NDUJAC is uneven. */
7fd59977 4858
4859 if (*nbpntu % 2 != 0 && *ndujac % 2 == 0) {
4860 bid0 = gssutb[0];
4861 i__1 = nptv2;
4862 for (jj = 1; jj <= i__1; ++jj) {
4863 chpair[jj] += sosotb[jj * sosotb_dim1] * bid0;
4864 chimpr[jj] += diditb[jj * diditb_dim1] * bid0;
4865/* L300: */
4866 }
4867 }
4868
0d969553 4869/* ------ Calculate the terms connected to supplementary roots (0.D0) ------
7fd59977 4870*/
0d969553 4871/* ----------- of Legendre polynom of uneven degree NBPNTV -----------
7fd59977 4872*/
4873
4874 if (*nbpntv % 2 != 0) {
0d969553 4875/* --> Only CHPAIR terms are calculated as GSSVTB(0,IH-IDEBV)=0
7fd59977 4876*/
0d969553 4877/* when IH is uneven (see MMA2CFV). */
7fd59977 4878
4879 if (*ndujac % 2 == 0) {
4880 bid1 = 0.;
4881 i__1 = nptu2;
4882 for (ii = 1; ii <= i__1; ++ii) {
4883 bid1 += sosotb[ii] * gssutb[ii];
4884/* L400: */
4885 }
4886 chpair[0] = bid1;
4887 } else {
4888 bid1 = 0.;
4889 i__1 = nptu2;
4890 for (ii = 1; ii <= i__1; ++ii) {
4891 bid1 += diditb[ii] * gssutb[ii];
4892/* L500: */
4893 }
4894 chpair[0] = bid1;
4895 }
4896 if (*nbpntu % 2 != 0) {
4897 chpair[0] += sosotb[0] * gssutb[0];
4898 }
4899 }
4900
4901/* ------------------------------ The end -------------------------------
4902*/
4903
4904 if (ldbg) {
4905 AdvApp2Var_SysBase::mgsomsg_("MMA2CFU", 7L);
4906 }
4907 return 0;
4908} /* mma2cfu_ */
4909
4910//=======================================================================
4911//function : mma2cfv_
4912//purpose :
4913//=======================================================================
4914int mma2cfv_(integer *ndvjac,
4915 integer *mindgu,
4916 integer *maxdgu,
4917 integer *nbpntv,
4918 doublereal *gssvtb,
4919 doublereal *chpair,
4920 doublereal *chimpr,
4921 doublereal *patjac)
4922
4923{
4924 /* System generated locals */
4925 integer chpair_dim1, chpair_offset, chimpr_dim1, chimpr_offset,
4926 patjac_offset, i__1, i__2;
4927
4928 /* Local variables */
4929 static logical ldbg;
4930 static integer nptv2, ii, jj;
4931 static doublereal bid1;
4932
4933
4934/* **********************************************************************
4935*/
4936
0d969553 4937/* FUNCTION : */
7fd59977 4938/* ---------- */
0d969553
Y		 4939/* Calculate the coefficients of polynomial approximation of F(u,v)
4940/* of degree NDVJAC by V and of degree by U varying from MINDGU to MAXDGU.
7fd59977 4941*/
4942
0d969553 4943/* Keywords : */
7fd59977 4944/* ----------- */
4945/* FONCTION,APPROXIMATION,COEFFICIENT,POLYNOME */
4946
0d969553 4947/* INPUT ARGUMENTS : */
7fd59977 4948/* ------------------ */
7fd59977 4949
0d969553
Y		 4950/* NDVJAC: Degree of the polynom of approximation by V. */
4951/* The representation in the orthogonal base starts from degre 0.
4952 /* The polynomial base is the base of Jacobi of order -1 */
4953/* (Legendre), 0, 1 or 2 */
4954/* MINDGU: Degree minimum by U of coeff. to calculate. */
4955/* MAXDGU: Degree maximum by U of coeff. to calculate. */
4956/* NBPNTV: Degree of the Legendre polynom on the roots which of */
4957/* the coefficients of integration by V are calculated */
4958/* by Gauss method. It is reqired that NBPNTV = 30, 40, 50 or 61 and NDVJAC < NBPNTV. */
4959/* GSSVTB: Table of coefficients of integration by Gauss method */
4960/* by V for NDVJAC fixed: j varies from 0 to NBPNTV/2. */
4961/* CHPAIR: Table of terms connected to degrees from MINDGU to MAXDGU by U to
4962/* calculate the coeff. of approximation of EVEN degree NDVJAC by V. */
4963/* CHIMPR: Table of terms connected to degrees from MINDGU to MAXDGU by U to
4964/* calculate the coeff. of approximation of UNEVEN degree NDVJAC by V. */
4965
4966/* OUTPUT ARGUMENTS : */
7fd59977 4967/* ------------------- */
0d969553
Y		 4968/* PATJAC: Table of coefficients by U of the polynom of approximation */
4969/* P(u,v) of degree MINDGU to MAXDGU by U and NDVJAC by V. */
7fd59977 4970
0d969553
Y		 4971/* COMMONS USED : */
4972/* -------------- */
7fd59977 4973
0d969553
Y		 4974/* REFERENCES CALLED : */
4975/* --------------------- */
7fd59977 4976
0d969553
Y		 4977/* DESCRIPTION/NOTES/LIMITATIONS : */
4978/* ------------------------------- */
7fd59977 4979/* > */
4980/* **********************************************************************
4981*/
0d969553 4982/* Name of the routine */
7fd59977 4983
4984
4985/* --------------------------- Initialisations --------------------------
4986*/
4987
4988 /* Parameter adjustments */
4989 patjac_offset = *mindgu;
4990 patjac -= patjac_offset;
4991 chimpr_dim1 = *nbpntv / 2;
4992 chimpr_offset = chimpr_dim1 * *mindgu + 1;
4993 chimpr -= chimpr_offset;
4994 chpair_dim1 = *nbpntv / 2 + 1;
4995 chpair_offset = chpair_dim1 * *mindgu;
4996 chpair -= chpair_offset;
4997
4998 /* Function Body */
4999 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 3;
5000 if (ldbg) {
5001 AdvApp2Var_SysBase::mgenmsg_("MMA2CFV", 7L);
5002 }
5003 nptv2 = *nbpntv / 2;
5004
0d969553 5005/* --------- Calculate the coefficients for even degree NDVJAC ----------
7fd59977 5006*/
5007
5008 if (*ndvjac % 2 == 0) {
5009 i__1 = *maxdgu;
5010 for (ii = *mindgu; ii <= i__1; ++ii) {
5011 bid1 = 0.;
5012 i__2 = nptv2;
5013 for (jj = 1; jj <= i__2; ++jj) {
5014 bid1 += chpair[jj + ii * chpair_dim1] * gssvtb[jj];
5015/* L200: */
5016 }
5017 patjac[ii] = bid1;
5018/* L100: */
5019 }
5020
0d969553 5021/* -------- Calculate the coefficients for uneven degree NDVJAC -----
7fd59977 5022---- */
5023
5024 } else {
5025 i__1 = *maxdgu;
5026 for (ii = *mindgu; ii <= i__1; ++ii) {
5027 bid1 = 0.;
5028 i__2 = nptv2;
5029 for (jj = 1; jj <= i__2; ++jj) {
5030 bid1 += chimpr[jj + ii * chimpr_dim1] * gssvtb[jj];
5031/* L250: */
5032 }
5033 patjac[ii] = bid1;
5034/* L150: */
5035 }
5036 }
5037
0d969553
Y		 5038/* ------- Add terms connected to the supplementary root (0.D0) ----- */
5039/* --------of the Legendre polynom of uneven degree NBPNTV --------- */
7fd59977 5040
5041 if (*nbpntv % 2 != 0 && *ndvjac % 2 == 0) {
5042 bid1 = gssvtb[0];
5043 i__1 = *maxdgu;
5044 for (ii = *mindgu; ii <= i__1; ++ii) {
5045 patjac[ii] += bid1 * chpair[ii * chpair_dim1];
5046/* L300: */
5047 }
5048 }
5049
5050/* ------------------------------ The end -------------------------------
5051*/
5052
5053 if (ldbg) {
5054 AdvApp2Var_SysBase::mgsomsg_("MMA2CFV", 7L);
5055 }
5056 return 0;
5057} /* mma2cfv_ */
5058
5059//=======================================================================
5060//function : mma2ds1_
5061//purpose :
5062//=======================================================================
5063int AdvApp2Var_ApproxF2var::mma2ds1_(integer *ndimen,
5064 doublereal *uintfn,
5065 doublereal *vintfn,
5066 void (*foncnp) (
5067 int *,
5068 double *,
5069 double *,
5070 int *,
5071 double *,
5072 int *,
5073 double *,
5074 int *,
5075 int *,
5076 double *,
5077 int *
5078 ),
5079 integer *nbpntu,
5080 integer *nbpntv,
5081 doublereal *urootb,
5082 doublereal *vrootb,
5083 integer *isofav,
5084 doublereal *sosotb,
5085 doublereal *disotb,
5086 doublereal *soditb,
5087 doublereal *diditb,
5088 doublereal *fpntab,
5089 doublereal *ttable,
5090 integer *iercod)
5091
5092{
5093 /* System generated locals */
5094 integer sosotb_dim1, sosotb_dim2, sosotb_offset, disotb_dim1, disotb_dim2,
5095 disotb_offset, soditb_dim1, soditb_dim2, soditb_offset,
5096 diditb_dim1, diditb_dim2, diditb_offset, fpntab_dim1,
5097 fpntab_offset, i__1;
5098
5099 /* Local variables */
5100 static logical ldbg;
5101 static integer ibid1, ibid2, iuouv, nd;
5102 static integer isz1, isz2;
5103
5104
5105
5106/* **********************************************************************
5107*/
5108
0d969553 5109/* FUNCTION : */
7fd59977 5110/* ---------- */
0d969553 5111/* Discretisation of function F(u,v) on the roots of Legendre polynoms. */
7fd59977 5112
0d969553 5113/* KEYWORDS : */
7fd59977 5114/* ----------- */
5115/* FONCTION&,DISCRETISATION,&POINT */
5116
0d969553 5117/* INPUT ARGUMENTS : */
7fd59977 5118/* ------------------ */
0d969553
Y		 5119/* NDIMEN: Dimension of the space. */
5120/* UINTFN: Limits of the interval of definition by u of the function */
5121/* to be processed: (UINTFN(1),UINTFN(2)). */
5122/* VINTFN: Limits of the interval of definition by v of the function */
5123/* to be processed: (VINTFN(1),VINTFN(2)). */
5124/* FONCNP: The NAME of the non-polynomial function to be processed. */
5125/* NBPNTU: The degree of Legendre polynom on the roots which of */
5126/* FONCNP is discretized by u. */
5127/* NBPNTV: The degree of Legendre polynom on the roots which of */
5128/* FONCNP is discretized by v. */
5129/* UROOTB: Table of STRICTLY POSITIVE roots of the polynom */
5130/* of Legendre of degree NBPNTU defined on (-1,1). */
5131/* VROOTB: Table of STRICTLY POSITIVE roots of the polynom */
5132/* of Legendre of degree NBPNTV defined on (-1,1). */
5133/* ISOFAV: Shows the type of iso of F(u,v) to be extracted to improve */
5134/* the rapidity of calculation (has no influence on the form */
5135/* of result) */
5136/* = 1, shows that it is necessary to calculate the points of F(u,v) */
5137/* with fixed u (with NBPNTV values different from v). */
5138/* = 2, shows that it is necessaty to calculate the points of F(u,v) */
5139/* with fixed v (with NBPNTU values different from u). */
5140/* SOSOTB: Preinitialized table (input/output argument). */
5141/* DISOTB: Preinitialized table (input/output argument). */
5142/* SODITB: Preinitialized table (input/output argument). */
5143/* DIDITB: Preinitialized table (input/output argument). */
5144
5145/* OUTPUT ARGUMENTS : */
7fd59977 5146/* ------------------- */
0d969553 5147/* SOSOTB: Table where the terms */
7fd59977 5148/* F(ui,vj) + F(ui,-vj) + F(-ui,vj) + F(-ui,-vj) */
0d969553
Y		 5149/* are added with ui and vj positive roots of Legendre polynom */
5150/* of degree NBPNTU and NBPNTV respectively. */
5151/* DISOTB: Table where the terms */
7fd59977 5152/* F(ui,vj) + F(ui,-vj) - F(-ui,vj) - F(-ui,-vj) */
0d969553
Y		 5153/* are added with ui and vj positive roots of Legendre polynom */
5154/* of degree NBPNTU and NBPNTV respectively. */
5155/* SODITB: Table where the terms */
7fd59977 5156/* F(ui,vj) - F(ui,-vj) + F(-ui,vj) - F(-ui,-vj) */
0d969553
Y		 5157/* are added with ui and vj positive roots of Legendre polynom */
5158/* of degree NBPNTU and NBPNTV respectively. */
5159/* DIDITB: Table where the terms */
7fd59977 5160/* F(ui,vj) - F(ui,-vj) - F(-ui,vj) + F(-ui,-vj) */
0d969553
Y		 5161/* are added with ui and vj positive roots of Legendre polynom */
5162/* of degree NBPNTU and NBPNTV respectively. */
5163/* FPNTAB: Auxiliary table. */
5164/* TTABLE: Auxiliary table. */
5165/* IERCOD: Error code >100 Pb in the evaluation of FONCNP, */
5166/* the returned error code is equal to error code of FONCNP + 100. */
5167
5168/* COMMONS USED : */
7fd59977 5169/* ---------------- */
5170
0d969553
Y		 5171/* REFERENCES CALLED : */
5172/* --------------------- */
7fd59977 5173
0d969553 5174/* DESCRIPTION/NOTES/LIMITATIONS : */
7fd59977 5175/* ----------------------------------- */
0d969553
Y		 5176/* --> The external function created by the caller of MA2F1K, MA2FDK */
5177/* where MA2FXK should be in the following form : */
7fd59977 5178/* SUBROUTINE FONCNP(NDIMEN,UINTFN,VINTFN,ISOFAV,TCONST,NBPTAB */
5179/* ,TTABLE,IDERIU,IDERIV,PPNTAB,IERCOD) */
0d969553
Y		 5180/* with the following input arguments : */
5181/* - NDIMEN is integer defined as the sum of dimensions of */
5182/* sub-spaces (i.e. total dimension of the problem). */
5183/* - UINTFN(2) is a table of 2 reals containing the interval */
5184/* by u where the function to be approximated is defined */
5185/* (so it is equal to UIFONC). */
5186/* - VINTFN(2) is a table of 2 reals containing the interval */
5187/* by v where the function to be approximated is defined */
5188/* (so it is equal to VIFONC). */
5189/* - ISOFAV, is 1 if it is necessary to calculate points with constant u, */
5190/* is 2 if it is necessary to calculate points with constant v. */
5191/* Any other value is an error. */
5192/* - TCONST, real, value of the fixed parameter. Takes values */
5193/* in (UIFONC(1),UIFONC(2)) if ISOFAV = 1 or */
5194/* ins (VIFONC(1),VIFONC(2)) if ISOFAV = 2. */
5195/* - NBPTAB, integer. Shows the number of points to be calculated. */
5196/* - TTABLE, a table of reals NBPTAB. These are the values of */
5197/* 'free' parameter of discretization (v if IISOFAV=1, */
5198/* u if IISOFAV=2). */
5199/* - IDERIU, integer, takes values between 0 (position) */
5200/* and IORDRE(1) (partial derivative of the function by u */
5201/* of order IORDRE(1) if IORDRE(1) > 0). */
5202/* - IDERIV, integer, takes values between 0 (position) */
5203/* and IORDRE(2) (partial derivative of the function by v */
5204/* of order IORDRE(2) if IORDRE(2) > 0). */
5205/* If IDERIU=i and IDERIV=j, FONCNP should calculate the */
5206/* points of the derivative : */
7fd59977 5207/* i+j */
5208/* d F(u,v) */
5209/* -------- */
5210/* i j */
5211/* du dv */
5212
0d969553
Y		 5213/* and the output arguments aret : */
5214/* - FPNTAB(NDIMEN,NBPTAB) contains, at output, the table of */
5215/* NBPTAB points calculated in FONCNP. */
5216/* - IERCOD is, at output the error code of FONCNP. This code */
5217/* (integer) should be strictly positive if there is a problem. */
7fd59977 5218
0d969553 5219/* The input arguments SHOULD NOT be modified under FONCNP.
7fd59977 5220*/
5221
0d969553
Y		 5222/* -->As FONCNP is not forcedly defined in (-1,1)*(-1,1), the */
5223/* values of UROOTB and VROOTB are consequently modified. */
7fd59977 5224
0d969553
Y		 5225/* -->The results of discretisation are ranked in 4 tables */
5226/* SOSOTB, DISOTB, SODITB and DIDITB to earn time */
5227/* during the calculation of coefficients of the polynom of approximation. */
7fd59977 5228
0d969553
Y		 5229/* When NBPNTU is uneven : */
5230/* table SOSOTB(0,j) contains F(0,vj) + F(0,-vj), */
5231/* table DIDITB(0,j) contains F(0,vj) - F(0,-vj), */
5232/* When NBPNTV is uneven : */
5233/* table SOSOTB(i,0) contains F(ui,0) + F(-ui,0), */
5234/* table DIDITB(i,0) contains F(ui,0) - F(-ui,0), */
5235/* When NBPNTU and NBPNTV are uneven : */
5236/* term SOSOTB(0,0) contains F(0,0). */
7fd59977 5237
7fd59977 5238/* > */
5239/* **********************************************************************
5240*/
0d969553 5241/* Name of the routine */
7fd59977 5242
5243
0d969553 5244/* --------------------------- Initialization --------------------------
7fd59977 5245*/
5246
5247 /* Parameter adjustments */
5248 fpntab_dim1 = *ndimen;
5249 fpntab_offset = fpntab_dim1 + 1;
5250 fpntab -= fpntab_offset;
5251 --uintfn;
5252 --vintfn;
5253 --urootb;
5254 diditb_dim1 = *nbpntu / 2 + 1;
5255 diditb_dim2 = *nbpntv / 2 + 1;
5256 diditb_offset = diditb_dim1 * diditb_dim2;
5257 diditb -= diditb_offset;
5258 soditb_dim1 = *nbpntu / 2;
5259 soditb_dim2 = *nbpntv / 2;
5260 soditb_offset = soditb_dim1 * (soditb_dim2 + 1) + 1;
5261 soditb -= soditb_offset;
5262 disotb_dim1 = *nbpntu / 2;
5263 disotb_dim2 = *nbpntv / 2;
5264 disotb_offset = disotb_dim1 * (disotb_dim2 + 1) + 1;
5265 disotb -= disotb_offset;
5266 sosotb_dim1 = *nbpntu / 2 + 1;
5267 sosotb_dim2 = *nbpntv / 2 + 1;
5268 sosotb_offset = sosotb_dim1 * sosotb_dim2;
5269 sosotb -= sosotb_offset;
5270 --vrootb;
5271 --ttable;
5272
5273 /* Function Body */
5274 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 3;
5275 if (ldbg) {
5276 AdvApp2Var_SysBase::mgenmsg_("MMA2DS1", 7L);
5277 }
5278 *iercod = 0;
5279 if (*isofav < 1 || *isofav > 2) {
5280 iuouv = 2;
5281 } else {
5282 iuouv = *isofav;
5283 }
5284
5285/* **********************************************************************
5286*/
0d969553
Y		 5287/* --------- Discretization by U on the roots of the polynom of ------ */
5288/* --------------- Legendre of degree NBPNTU, iso-V by iso-V --------- */
7fd59977 5289/* **********************************************************************
5290*/
5291
5292 if (iuouv == 2) {
5293 mma2ds2_(ndimen, &uintfn[1], &vintfn[1], foncnp, nbpntu, nbpntv, &
5294 urootb[1], &vrootb[1], &iuouv, &sosotb[sosotb_offset], &
5295 disotb[disotb_offset], &soditb[soditb_offset], &diditb[
5296 diditb_offset], &fpntab[fpntab_offset], &ttable[1], iercod);
5297
5298/* ******************************************************************
5299**** */
0d969553
Y		 5300/* --------- Discretization by V on the roots of the polynom of ------ */
5301/* --------------- Legendre of degree NBPNTV, iso-V by iso-V --------- */
7fd59977 5302/* ******************************************************************
5303**** */
5304
5305 } else {
0d969553 5306/* --> Inversion of indices of tables */
7fd59977 5307 i__1 = *ndimen;
5308 for (nd = 1; nd <= i__1; ++nd) {
5309 isz1 = *nbpntu / 2 + 1;
5310 isz2 = *nbpntv / 2 + 1;
5311 AdvApp2Var_MathBase::mmfmtb1_(&isz1, &sosotb[nd * sosotb_dim2 * sosotb_dim1], &isz1, &
5312 isz2, &isz2, &sosotb[nd * sosotb_dim2 * sosotb_dim1], &
5313 ibid1, &ibid2, iercod);
5314 if (*iercod > 0) {
5315 goto L9999;
5316 }
5317 AdvApp2Var_MathBase::mmfmtb1_(&isz1, &diditb[nd * diditb_dim2 * diditb_dim1], &isz1, &
5318 isz2, &isz2, &diditb[nd * diditb_dim2 * diditb_dim1], &
5319 ibid1, &ibid2, iercod);
5320 if (*iercod > 0) {
5321 goto L9999;
5322 }
5323 isz1 = *nbpntu / 2;
5324 isz2 = *nbpntv / 2;
5325 AdvApp2Var_MathBase::mmfmtb1_(&isz1, &soditb[(nd * soditb_dim2 + 1) * soditb_dim1 + 1],
5326 &isz1, &isz2, &isz2, &soditb[(nd * soditb_dim2 + 1) *
5327 soditb_dim1 + 1], &ibid1, &ibid2, iercod);
5328 if (*iercod > 0) {
5329 goto L9999;
5330 }
5331 AdvApp2Var_MathBase::mmfmtb1_(&isz1, &disotb[(nd * disotb_dim2 + 1) * disotb_dim1 + 1],
5332 &isz1, &isz2, &isz2, &disotb[(nd * disotb_dim2 + 1) *
5333 disotb_dim1 + 1], &ibid1, &ibid2, iercod);
5334 if (*iercod > 0) {
5335 goto L9999;
5336 }
5337/* L100: */
5338 }
5339
5340 mma2ds2_(ndimen, &vintfn[1], &uintfn[1], foncnp, nbpntv, nbpntu, &
5341 vrootb[1], &urootb[1], &iuouv, &sosotb[sosotb_offset], &
5342 soditb[soditb_offset], &disotb[disotb_offset], &diditb[
5343 diditb_offset], &fpntab[fpntab_offset], &ttable[1], iercod);
0d969553 5344/* --> Inversion of indices of tables */
7fd59977 5345 i__1 = *ndimen;
5346 for (nd = 1; nd <= i__1; ++nd) {
5347 isz1 = *nbpntv / 2 + 1;
5348 isz2 = *nbpntu / 2 + 1;
5349 AdvApp2Var_MathBase::mmfmtb1_(&isz1, &sosotb[nd * sosotb_dim2 * sosotb_dim1], &isz1, &
5350 isz2, &isz2, &sosotb[nd * sosotb_dim2 * sosotb_dim1], &
5351 ibid1, &ibid2, iercod);
5352 if (*iercod > 0) {
5353 goto L9999;
5354 }
5355 AdvApp2Var_MathBase::mmfmtb1_(&isz1, &diditb[nd * diditb_dim2 * diditb_dim1], &isz1, &
5356 isz2, &isz2, &diditb[nd * diditb_dim2 * diditb_dim1], &
5357 ibid1, &ibid2, iercod);
5358 if (*iercod > 0) {
5359 goto L9999;
5360 }
5361 isz1 = *nbpntv / 2;
5362 isz2 = *nbpntu / 2;
5363 AdvApp2Var_MathBase::mmfmtb1_(&isz1, &soditb[(nd * soditb_dim2 + 1) * soditb_dim1 + 1],
5364 &isz1, &isz2, &isz2, &soditb[(nd * soditb_dim2 + 1) *
5365 soditb_dim1 + 1], &ibid1, &ibid2, iercod);
5366 if (*iercod > 0) {
5367 goto L9999;
5368 }
5369 AdvApp2Var_MathBase::mmfmtb1_(&isz1, &disotb[(nd * disotb_dim2 + 1) * disotb_dim1 + 1],
5370 &isz1, &isz2, &isz2, &disotb[(nd * disotb_dim2 + 1) *
5371 disotb_dim1 + 1], &ibid1, &ibid2, iercod);
5372 if (*iercod > 0) {
5373 goto L9999;
5374 }
5375/* L200: */
5376 }
5377 }
5378
5379/* ------------------------------ The end -------------------------------
5380*/
5381
5382L9999:
5383 if (*iercod > 0) {
5384 *iercod += 100;
5385 AdvApp2Var_SysBase::maermsg_("MMA2DS1", iercod, 7L);
5386 }
5387 if (ldbg) {
5388 AdvApp2Var_SysBase::mgsomsg_("MMA2DS1", 7L);
5389 }
5390 return 0;
5391} /* mma2ds1_ */
5392
5393//=======================================================================
5394//function : mma2ds2_
5395//purpose :
5396//=======================================================================
5397int mma2ds2_(integer *ndimen,
5398 doublereal *uintfn,
5399 doublereal *vintfn,
5400 void (*foncnp) (
5401 int *,
5402 double *,
5403 double *,
5404 int *,
5405 double *,
5406 int *,
5407 double *,
5408 int *,
5409 int *,
5410 double *,
5411 int *
5412 ),
5413 integer *nbpntu,
5414 integer *nbpntv,
5415 doublereal *urootb,
5416 doublereal *vrootb,
5417 integer *iiuouv,
5418 doublereal *sosotb,
5419 doublereal *disotb,
5420 doublereal *soditb,
5421 doublereal *diditb,
5422 doublereal *fpntab,
5423 doublereal *ttable,
5424 integer *iercod)
5425
5426{
5427 static integer c__0 = 0;
5428 /* System generated locals */
5429 integer sosotb_dim1, sosotb_dim2, sosotb_offset, disotb_dim1, disotb_dim2,
5430 disotb_offset, soditb_dim1, soditb_dim2, soditb_offset,
5431 diditb_dim1, diditb_dim2, diditb_offset, fpntab_dim1,
5432 fpntab_offset, i__1, i__2, i__3;
5433
5434 /* Local variables */
5435 static integer jdec;
5436 static logical ldbg;
5437 static doublereal alinu, blinu, alinv, blinv, tcons;
5438 static doublereal dbfn1[2], dbfn2[2];
5439 static integer nuroo, nvroo, id, iu, iv;
5440 static doublereal um, up;
5441
5442
5443/* **********************************************************************
5444*/
5445
0d969553 5446/* FUNCTION : */
7fd59977 5447/* ---------- */
0d969553 5448/* Discretization of function F(u,v) on the roots of polynoms of Legendre. */
7fd59977 5449
0d969553 5450/* KEYWORDS : */
7fd59977 5451/* ----------- */
5452/* FONCTION&,DISCRETISATION,&POINT */
5453
0d969553 5454/* INPUT ARGUMENTS : */
7fd59977 5455/* ------------------ */
0d969553
Y		 5456/* NDIMEN: Dimension of the space. */
5457/* UINTFN: Limits of the interval of definition by u of the function */
5458/* to be processed: (UINTFN(1),UINTFN(2)). */
5459/* VINTFN: Limits of the interval of definition by v of the function */
5460/* to be processed: (VINTFN(1),VINTFN(2)). */
5461/* FONCNP: The NAME of the non-polynomial function to be processed. */
5462/* NBPNTU: The degree of Legendre polynom on the roots which of */
5463/* FONCNP is discretized by u. */
5464/* NBPNTV: The degree of Legendre polynom on the roots which of */
5465/* FONCNP is discretized by v. */
5466/* UROOTB: Table of STRICTLY POSITIVE roots of the polynom */
5467/* of Legendre of degree NBPNTU defined on (-1,1). */
5468/* VROOTB: Table of STRICTLY POSITIVE roots of the polynom */
5469/* of Legendre of degree NBPNTV defined on (-1,1). */
5470/* IIUOUV: Shows the type of iso of F(u,v) tom be extracted to improve the */
5471/* rapidity of calculation (has no influence on the form of result) */
5472/* = 1, shows that it is necessary to calculate the points of F(u,v) */
5473/* with fixed u (so with NBPNTV values different from v). */
5474/* = 2, shows that it is necessary to calculate the points of F(u,v) */
5475/* with fixed v (so with NBPNTV values different from u). */
5476/* SOSOTB: Preinitialized table (input/output argument). */
5477/* DISOTB: Preinitialized table (input/output argument). */
5478/* SODITB: Preinitialized table (input/output argument). */
5479/* DIDITB: Preinitialized table (input/output argument). */
5480
5481/* OUTPUT ARGUMENTS : */
7fd59977 5482/* ------------------- */
0d969553 5483/* SOSOTB: Table where the terms */
7fd59977 5484/* F(ui,vj) + F(ui,-vj) + F(-ui,vj) + F(-ui,-vj) */
0d969553
Y		 5485/* are added with ui and vj positive roots of Legendre polynom */
5486/* of degree NBPNTU and NBPNTV respectively. */
5487/* DISOTB: Table where the terms */
7fd59977 5488/* F(ui,vj) + F(ui,-vj) - F(-ui,vj) - F(-ui,-vj) */
0d969553
Y		 5489/* are added with ui and vj positive roots of Legendre polynom */
5490/* of degree NBPNTU and NBPNTV respectively. */
5491/* SODITB: Table where the terms */
7fd59977 5492/* F(ui,vj) - F(ui,-vj) + F(-ui,vj) - F(-ui,-vj) */
0d969553
Y		 5493/* are added with ui and vj positive roots of Legendre polynom */
5494/* of degree NBPNTU and NBPNTV respectively. */
5495/* DIDITB: Table where the terms */
7fd59977 5496/* F(ui,vj) - F(ui,-vj) - F(-ui,vj) + F(-ui,-vj) */
0d969553
Y		 5497/* are added with ui and vj positive roots of Legendre polynom */
5498/* of degree NBPNTU and NBPNTV respectively. */
5499/* FPNTAB: Auxiliary table. */
5500/* TTABLE: Auxiliary table. */
5501/* IERCOD: Error code >100 Pb in the evaluation of FONCNP, */
5502/* the returned error code is equal to error code of FONCNP + 100. */
5503
5504/* COMMONS USED : */
7fd59977 5505/* ---------------- */
5506
0d969553
Y		 5507/* REFERENCES CALLED : */
5508/* --------------------- */
7fd59977 5509
0d969553 5510/* DESCRIPTION/NOTES/LIMITATIONS : */
7fd59977 5511/* ----------------------------------- */
0d969553
Y		 5512/* --> The external function created by the caller of MA2F1K, MA2FDK */
5513/* where MA2FXK should be in the following form : */
7fd59977 5514/* SUBROUTINE FONCNP(NDIMEN,UINTFN,VINTFN,IIIUOUV,TCONST,NBPTAB */
5515/* ,TTABLE,IDERIU,IDERIV,PPNTAB,IERCOD) */
0d969553
Y		 5516/* with the following input arguments : */
5517/* - NDIMEN is integer defined as the sum of dimensions of */
5518/* sub-spaces (i.e. total dimension of the problem). */
5519/* - UINTFN(2) is a table of 2 reals containing the interval */
5520/* by u where the function to be approximated is defined */
5521/* (so it is equal to UIFONC). */
5522/* - VINTFN(2) is a table of 2 reals containing the interval */
5523/* by v where the function to be approximated is defined */
5524/* (so it is equal to VIFONC). */
5525/* - IIIUOUV, is 1 if it is necessary to calculate points with constant u, */
5526/* is 2 if it is necessary to calculate points with constant v. */
5527/* Any other value is an error. */
5528/* - TCONST, real, value of the fixed parameter. Takes values */
5529/* in (UIFONC(1),UIFONC(2)) if ISOFAV = 1 or */
5530/* ins (VIFONC(1),VIFONC(2)) if ISOFAV = 2. */
5531/* - NBPTAB, integer. Shows the number of points to be calculated. */
5532/* - TTABLE, a table of reals NBPTAB. These are the values of */
5533/* 'free' parameter of discretization (v if IIIUOUV=1, */
5534/* u if IIIUOUV=2). */
5535/* - IDERIU, integer, takes values between 0 (position) */
5536/* and IORDRE(1) (partial derivative of the function by u */
5537/* of order IORDRE(1) if IORDRE(1) > 0). */
5538/* - IDERIV, integer, takes values between 0 (position) */
5539/* and IORDRE(2) (partial derivative of the function by v */
5540/* of order IORDRE(2) if IORDRE(2) > 0). */
5541/* If IDERIU=i and IDERIV=j, FONCNP should calculate the */
5542/* points of the derivative : */
7fd59977 5543/* i+j */
5544/* d F(u,v) */
5545/* -------- */
5546/* i j */
5547/* du dv */
5548
0d969553
Y		 5549/* and the output arguments aret : */
5550/* - FPNTAB(NDIMEN,NBPTAB) contains, at output, the table of */
5551/* NBPTAB points calculated in FONCNP. */
5552/* - IERCOD is, at output the error code of FONCNP. This code */
5553/* (integer) should be strictly positive if there is a problem. */
5554
5555/* The input arguments SHOULD NOT be modified under FONCNP.
5556*/
5557
5558/* -->As FONCNP is not forcedly defined in (-1,1)*(-1,1), the */
5559/* values of UROOTB and VROOTB are consequently modified. */
5560
5561/* -->The results of discretisation are ranked in 4 tables */
5562/* SOSOTB, DISOTB, SODITB and DIDITB to earn time */
5563/* during the calculation of coefficients of the polynom of approximation. */
5564
5565/* When NBPNTU is uneven : */
5566/* table SOSOTB(0,j) contains F(0,vj) + F(0,-vj), */
5567/* table DIDITB(0,j) contains F(0,vj) - F(0,-vj), */
5568/* When NBPNTV is uneven : */
5569/* table SOSOTB(i,0) contains F(ui,0) + F(-ui,0), */
5570/* table DIDITB(i,0) contains F(ui,0) - F(-ui,0), */
5571/* When NBPNTU and NBPNTV are uneven : */
5572/* term SOSOTB(0,0) contains F(0,0). */
5573
5574/* ATTENTION: These 4 tables are filled by varying the */
5575/* 1st index first. So, the discretizations */
5576/* of F(...,t) (for IIUOUV = 2) or of F(t,...) (IIUOUV = 1) */
5577/* are stored in SOSOTB(...,t), SODITB(...,t), etc... */
5578/* (this allows to gain important time). */
5579/* It is required that the caller, in case of IIUOUV=1, */
5580/* invert the roles of u and v, of SODITB and DISOTB BEFORE the */
7fd59977 5581
7fd59977 5582/* > */
5583/* **********************************************************************
5584*/
5585
0d969553 5586/* Name of the routine */
7fd59977 5587
0d969553 5588/* --> Indices of loops. */
7fd59977 5589
0d969553 5590/* --------------------------- Initialization --------------------------
7fd59977 5591*/
5592
5593 /* Parameter adjustments */
5594 --uintfn;
5595 --vintfn;
5596 --ttable;
5597 fpntab_dim1 = *ndimen;
5598 fpntab_offset = fpntab_dim1 + 1;
5599 fpntab -= fpntab_offset;
5600 --urootb;
5601 diditb_dim1 = *nbpntu / 2 + 1;
5602 diditb_dim2 = *nbpntv / 2 + 1;
5603 diditb_offset = diditb_dim1 * diditb_dim2;
5604 diditb -= diditb_offset;
5605 soditb_dim1 = *nbpntu / 2;
5606 soditb_dim2 = *nbpntv / 2;
5607 soditb_offset = soditb_dim1 * (soditb_dim2 + 1) + 1;
5608 soditb -= soditb_offset;
5609 disotb_dim1 = *nbpntu / 2;
5610 disotb_dim2 = *nbpntv / 2;
5611 disotb_offset = disotb_dim1 * (disotb_dim2 + 1) + 1;
5612 disotb -= disotb_offset;
5613 sosotb_dim1 = *nbpntu / 2 + 1;
5614 sosotb_dim2 = *nbpntv / 2 + 1;
5615 sosotb_offset = sosotb_dim1 * sosotb_dim2;
5616 sosotb -= sosotb_offset;
5617 --vrootb;
5618
5619 /* Function Body */
5620 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 3;
5621 if (ldbg) {
5622 AdvApp2Var_SysBase::mgenmsg_("MMA2DS2", 7L);
5623 }
5624 *iercod = 0;
5625
5626 alinu = (uintfn[2] - uintfn[1]) / 2.;
5627 blinu = (uintfn[2] + uintfn[1]) / 2.;
5628 alinv = (vintfn[2] - vintfn[1]) / 2.;
5629 blinv = (vintfn[2] + vintfn[1]) / 2.;
5630
5631 if (*iiuouv == 1) {
5632 dbfn1[0] = vintfn[1];
5633 dbfn1[1] = vintfn[2];
5634 dbfn2[0] = uintfn[1];
5635 dbfn2[1] = uintfn[2];
5636 } else {
5637 dbfn1[0] = uintfn[1];
5638 dbfn1[1] = uintfn[2];
5639 dbfn2[0] = vintfn[1];
5640 dbfn2[1] = vintfn[2];
5641 }
5642
5643/* **********************************************************************
5644*/
0d969553
Y		 5645/* -------- Discretization by U on the roots of Legendre polynom -------- */
5646/* ---------------- of degree NBPNTU, with Vj fixed -------------------- */
7fd59977 5647/* **********************************************************************
5648*/
5649
5650 nuroo = *nbpntu / 2;
5651 nvroo = *nbpntv / 2;
5652 jdec = (*nbpntu + 1) / 2;
5653
0d969553 5654/* ----------- Loading of parameters of discretization by U ------------- */
7fd59977 5655
5656 i__1 = *nbpntu;
5657 for (iu = 1; iu <= i__1; ++iu) {
5658 ttable[iu] = blinu + alinu * urootb[iu];
5659/* L100: */
5660 }
5661
0d969553 5662/* -------------- For Vj fixed, negative root of Legendre ------------- */
7fd59977 5663
5664 i__1 = nvroo;
5665 for (iv = 1; iv <= i__1; ++iv) {
5666 tcons = blinv + alinv * vrootb[iv];
5667 (*foncnp)(ndimen, dbfn1, dbfn2, iiuouv, &tcons, nbpntu, &
5668 ttable[1], &c__0, &c__0, &fpntab[fpntab_offset], iercod);
5669 if (*iercod > 0) {
5670 goto L9999;
5671 }
5672 i__2 = *ndimen;
5673 for (id = 1; id <= i__2; ++id) {
5674 i__3 = nuroo;
5675 for (iu = 1; iu <= i__3; ++iu) {
5676 up = fpntab[id + (iu + jdec) * fpntab_dim1];
5677 um = fpntab[id + (nuroo - iu + 1) * fpntab_dim1];
5678 sosotb[iu + (nvroo - iv + 1 + id * sosotb_dim2) * sosotb_dim1]
5679 = sosotb[iu + (nvroo - iv + 1 + id * sosotb_dim2) *
5680 sosotb_dim1] + up + um;
5681 disotb[iu + (nvroo - iv + 1 + id * disotb_dim2) * disotb_dim1]
5682 = disotb[iu + (nvroo - iv + 1 + id * disotb_dim2) *
5683 disotb_dim1] + up - um;
5684 soditb[iu + (nvroo - iv + 1 + id * soditb_dim2) * soditb_dim1]
5685 = soditb[iu + (nvroo - iv + 1 + id * soditb_dim2) *
5686 soditb_dim1] - up - um;
5687 diditb[iu + (nvroo - iv + 1 + id * diditb_dim2) * diditb_dim1]
5688 = diditb[iu + (nvroo - iv + 1 + id * diditb_dim2) *
5689 diditb_dim1] - up + um;
5690/* L220: */
5691 }
5692 if (*nbpntu % 2 != 0) {
5693 up = fpntab[id + jdec * fpntab_dim1];
5694 sosotb[(nvroo - iv + 1 + id * sosotb_dim2) * sosotb_dim1] +=
5695 up;
5696 diditb[(nvroo - iv + 1 + id * diditb_dim2) * diditb_dim1] -=
5697 up;
5698 }
5699/* L210: */
5700 }
5701/* L200: */
5702 }
5703
0d969553 5704/* --------- For Vj = 0 (uneven NBPNTV), discretization by U ----------- */
7fd59977 5705
5706 if (*nbpntv % 2 != 0) {
5707 tcons = blinv;
5708 (*foncnp)(ndimen, dbfn1, dbfn2, iiuouv, &tcons, nbpntu, &
5709 ttable[1], &c__0, &c__0, &fpntab[fpntab_offset], iercod);
5710 if (*iercod > 0) {
5711 goto L9999;
5712 }
5713 i__1 = *ndimen;
5714 for (id = 1; id <= i__1; ++id) {
5715 i__2 = nuroo;
5716 for (iu = 1; iu <= i__2; ++iu) {
5717 up = fpntab[id + (jdec + iu) * fpntab_dim1];
5718 um = fpntab[id + (nuroo - iu + 1) * fpntab_dim1];
5719 sosotb[iu + id * sosotb_dim2 * sosotb_dim1] = sosotb[iu + id *
5720 sosotb_dim2 * sosotb_dim1] + up + um;
5721 diditb[iu + id * diditb_dim2 * diditb_dim1] = diditb[iu + id *
5722 diditb_dim2 * diditb_dim1] + up - um;
5723/* L310: */
5724 }
5725 if (*nbpntu % 2 != 0) {
5726 up = fpntab[id + jdec * fpntab_dim1];
5727 sosotb[id * sosotb_dim2 * sosotb_dim1] += up;
5728 }
5729/* L300: */
5730 }
5731 }
5732
0d969553 5733/* -------------- For Vj fixed, positive root of Legendre ------------- */
7fd59977 5734
5735 i__1 = nvroo;
5736 for (iv = 1; iv <= i__1; ++iv) {
5737 tcons = alinv * vrootb[(*nbpntv + 1) / 2 + iv] + blinv;
5738 (*foncnp)(ndimen, dbfn1, dbfn2, iiuouv, &tcons, nbpntu, &
5739 ttable[1], &c__0, &c__0, &fpntab[fpntab_offset], iercod);
5740 if (*iercod > 0) {
5741 goto L9999;
5742 }
5743 i__2 = *ndimen;
5744 for (id = 1; id <= i__2; ++id) {
5745 i__3 = nuroo;
5746 for (iu = 1; iu <= i__3; ++iu) {
5747 up = fpntab[id + (iu + jdec) * fpntab_dim1];
5748 um = fpntab[id + (nuroo - iu + 1) * fpntab_dim1];
5749 sosotb[iu + (iv + id * sosotb_dim2) * sosotb_dim1] = sosotb[
5750 iu + (iv + id * sosotb_dim2) * sosotb_dim1] + up + um;
5751 disotb[iu + (iv + id * disotb_dim2) * disotb_dim1] = disotb[
5752 iu + (iv + id * disotb_dim2) * disotb_dim1] + up - um;
5753 soditb[iu + (iv + id * soditb_dim2) * soditb_dim1] = soditb[
5754 iu + (iv + id * soditb_dim2) * soditb_dim1] + up + um;
5755 diditb[iu + (iv + id * diditb_dim2) * diditb_dim1] = diditb[
5756 iu + (iv + id * diditb_dim2) * diditb_dim1] + up - um;
5757/* L420: */
5758 }
5759 if (*nbpntu % 2 != 0) {
5760 up = fpntab[id + jdec * fpntab_dim1];
5761 sosotb[(iv + id * sosotb_dim2) * sosotb_dim1] += up;
5762 diditb[(iv + id * diditb_dim2) * diditb_dim1] += up;
5763 }
5764/* L410: */
5765 }
5766/* L400: */
5767 }
5768
5769/* ------------------------------ The end -------------------------------
5770*/
5771
5772L9999:
5773 if (*iercod > 0) {
5774 *iercod += 100;
5775 AdvApp2Var_SysBase::maermsg_("MMA2DS2", iercod, 7L);
5776 }
5777 if (ldbg) {
5778 AdvApp2Var_SysBase::mgsomsg_("MMA2DS2", 7L);
5779 }
5780 return 0;
5781} /* mma2ds2_ */
5782
5783//=======================================================================
5784//function : mma2er1_
5785//purpose :
5786//=======================================================================
5787int mma2er1_(integer *ndjacu,
5788 integer *ndjacv,
5789 integer *ndimen,
5790 integer *mindgu,
5791 integer *maxdgu,
5792 integer *mindgv,
5793 integer *maxdgv,
5794 integer *iordru,
5795 integer *iordrv,
5796 doublereal *xmaxju,
5797 doublereal *xmaxjv,
5798 doublereal *patjac,
5799 doublereal *vecerr,
5800 doublereal *erreur)
5801
5802{
5803 /* System generated locals */
5804 integer patjac_dim1, patjac_dim2, patjac_offset, i__1, i__2, i__3;
5805 doublereal d__1;
5806
5807 /* Local variables */
5808 static logical ldbg;
5809 static integer minu, minv;
5810 static doublereal vaux[2];
5811 static integer ii, nd, jj;
5812 static doublereal bid0, bid1;
5813
5814
5815/* **********************************************************************
5816*/
5817
0d969553 5818/* FUNCTION : */
7fd59977 5819/* ---------- */
0d969553
Y		 5820/* Calculate max approximation error done when */
5821/* the coefficients of PATJAC such that the degree by U varies between */
5822/* MINDGU and MAXDGU and the degree by V varies between MINDGV and MAXDGV are removed. */
7fd59977 5823
0d969553 5824/* KEYWORDS : */
7fd59977 5825/* ----------- */
5826/* TOUS,AB_SPECIFI:: CARREAU&,CALCUL,&ERREUR */
5827
0d969553 5828/* INPUT ARGUMENTS : */
7fd59977 5829/* ------------------ */
0d969553
Y		 5830/* NDJACU: Dimension by U of table PATJAC. */
5831/* NDJACV: Dimension by V of table PATJAC. */
5832/* NDIMEN: Dimension of the space. */
5833/* MINDGU: Lower limit of index by U of coeff. of PATJAC to be taken into account. */
5834/* MAXDGU: Upper limit of index by U of coeff. of PATJAC to be taken into account. */
5835/* MINDGV: Lower limit of index by V of coeff. of PATJAC to be taken into account. */
5836/* MAXDGV: Upper limit of index by V of coeff. of PATJAC to be taken into account. */
5837/* IORDRU: Order of continuity by U provided by square PATJAC (from -1 to 2) */
5838/* IORDRV: Order of continuity by U provided by square PATJAC (from -1 to 2) */
5839/* XMAXJU: Maximum value of Jacobi polynoms of order IORDRU, */
5840/* from degree 0 to MAXDGU - 2*(IORDU+1) */
5841/* XMAXJV: Maximum value of Jacobi polynoms of order IORDRV, */
5842/* from degree 0 to MAXDGV - 2*(IORDV+1) */
5843/* PATJAC: Table of coeff. of square of approximation with */
5844/* constraints of order IORDRU by U and IORDRV by V. */
5845/* VECERR: Auxiliary vector. */
5846/* ERREUR: MAX Error commited during removal of ALREADY CALCULATED coeff of PATJAC */
5847
5848/* OUTPUT ARGUMENTS : */
7fd59977 5849/* ------------------- */
0d969553
Y		 5850/* ERREUR: MAX Error commited during removal of coeff of PATJAC */
5851/* of indices from MINDGU to MAXDGU by U and from MINDGV to MAXDGV by V */
5852/* THEN the already calculated error. */
7fd59977 5853
0d969553 5854/* COMMONS USED : */
7fd59977 5855/* ---------------- */
5856
0d969553
Y		 5857/* REFERENCES CALLED : */
5858/* --------------------- */
7fd59977 5859
0d969553 5860/* DESCRIPTION/NOTES/LIMITATIONS : */
7fd59977 5861/* ----------------------------------- */
0d969553
Y		 5862/* Table PATJAC is the place of storage of coeff. Cij of the square of */
5863/* approximation of F(U,V). The indices i and j show the degree */
5864/* by U and by V of base polynoms. These polynoms have the form: */
7fd59977 5865
0d969553 5866/* ((1 - U*U)**(IORDRU+1)).J(i-2*(IORDRU+1)(U), where */
7fd59977 5867
0d969553
Y		 5868/* polynom J(i-2*(IORDU+1)(U) is the Jacobi polynom of order */
5869/* IORDRU+1 (the same by V by replacing U u V in the expression above). */
7fd59977 5870
0d969553
Y		 5871/* The contribution to the error of term Cij when it is */
5872/* removed from PATJAC is increased by: */
7fd59977 5873
0d969553 5874/* DABS(Cij)*XMAXJU(i-2*(IORDRU+1))*XMAXJV(J-2*(IORDRV+1)) where */
7fd59977 5875
5876/* XMAXJU(i-2*(IORDRU+1) = ((1 - U*U)**(IORDRU+1)).J(i-2*(IORDRU+1)(U),
5877*/
5878/* XMAXJV(i-2*(IORDRV+1) = ((1 - V*V)**(IORDRV+1)).J(j-2*(IORDRV+1)(V).
5879*/
5880
7fd59977 5881/* > */
5882/* ***********************************************************************
5883 */
0d969553 5884/* Name of the routine */
7fd59977 5885
5886
5887/* ----------------------------- Initialisations ------------------------
5888*/
5889
5890 /* Parameter adjustments */
5891 --vecerr;
5892 patjac_dim1 = *ndjacu + 1;
5893 patjac_dim2 = *ndjacv + 1;
5894 patjac_offset = patjac_dim1 * patjac_dim2;
5895 patjac -= patjac_offset;
5896
5897 /* Function Body */
5898 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 3;
5899 if (ldbg) {
5900 AdvApp2Var_SysBase::mgenmsg_("MMA2ER1", 7L);
5901 }
5902
5903 minu = (*iordru + 1) << 1;
5904 minv = (*iordrv + 1) << 1;
5905
0d969553
Y		 5906/* ------------------- Calculate the increment of the max error --------------- */
5907/* ----- during the removal of the coeffs of indices from MINDGU to MAXDGU ---- */
5908/* ---------------- by U and indices from MINDGV to MAXDGV by V --------------- */
7fd59977 5909
5910 i__1 = *ndimen;
5911 for (nd = 1; nd <= i__1; ++nd) {
5912 bid1 = 0.;
5913 i__2 = *maxdgv;
5914 for (jj = *mindgv; jj <= i__2; ++jj) {
5915 bid0 = 0.;
5916 i__3 = *maxdgu;
5917 for (ii = *mindgu; ii <= i__3; ++ii) {
5918 bid0 += (d__1 = patjac[ii + (jj + nd * patjac_dim2) *
5919 patjac_dim1], abs(d__1)) * xmaxju[ii - minu];
5920/* L300: */
5921 }
5922 bid1 = bid0 * xmaxjv[jj - minv] + bid1;
5923/* L200: */
5924 }
5925 vecerr[nd] = bid1;
5926
5927/* L100: */
5928 }
5929
0d969553 5930/* ----------------------- Calculate the max error ----------------------*/
7fd59977 5931
5932 bid1 = AdvApp2Var_MathBase::mzsnorm_(ndimen, &vecerr[1]);
5933 vaux[0] = *erreur;
5934 vaux[1] = bid1;
5935 nd = 2;
5936 *erreur = AdvApp2Var_MathBase::mzsnorm_(&nd, vaux);
5937
5938/* ------------------------- The end ------------------------------------
5939*/
5940
5941 if (ldbg) {
5942 AdvApp2Var_SysBase::mgsomsg_("MMA2ER1", 7L);
5943 }
5944 return 0;
5945} /* mma2er1_ */
5946
5947//=======================================================================
5948//function : mma2er2_
5949//purpose :
5950//=======================================================================
5951int mma2er2_(integer *ndjacu,
5952 integer *ndjacv,
5953 integer *ndimen,
5954 integer *mindgu,
5955 integer *maxdgu,
5956 integer *mindgv,
5957 integer *maxdgv,
5958 integer *iordru,
5959 integer *iordrv,
5960 doublereal *xmaxju,
5961 doublereal *xmaxjv,
5962 doublereal *patjac,
5963 doublereal *epmscut,
5964 doublereal *vecerr,
5965 doublereal *erreur,
5966 integer *newdgu,
5967 integer *newdgv)
5968
5969{
5970 /* System generated locals */
5971 integer patjac_dim1, patjac_dim2, patjac_offset, i__1, i__2;
5972 doublereal d__1;
5973
5974 /* Local variables */
5975 static logical ldbg;
5976 static doublereal vaux[2];
5977 static integer i2rdu, i2rdv;
5978 static doublereal errnu, errnv;
5979 static integer ii, nd, jj, nu, nv;
5980 static doublereal bid0, bid1;
5981
5982
5983/* **********************************************************************
5984*/
5985
0d969553 5986/* FUNCTION : */
7fd59977 5987/* ---------- */
0d969553
Y		 5988/* Remove coefficients of PATJAC to obtain the minimum degree */
5989/* by U and V checking the imposed tolerance. */
7fd59977 5990
0d969553 5991/* KEYWORDS : */
7fd59977 5992/* ----------- */
5993/* TOUS,AB_SPECIFI:: CARREAU&,CALCUL,&ERREUR */
5994
0d969553 5995/* INPUT ARGUMENTS : */
7fd59977 5996/* ------------------ */
0d969553
Y		 5997/* NDJACU: Degree by U of table PATJAC. */
5998/* NDJACV: Degree by V of table PATJAC. */
5999/* NDIMEN: Dimension of the space. */
6000/* MINDGU: Limit of index by U of coeff. of PATJAC to be PRESERVED (should be >=0). */
6001/* MAXDGU: Upper limit of index by U of coeff. of PATJAC to be taken into account. */
6002/* MINDGV: Limit of index by V of coeff. of PATJAC to be PRESERVED (should be >=0). */
6003/* MAXDGV: Upper limit of index by V of coeff. of PATJAC to be taken into account. */
6004/* IORDRU: Order of continuity by U provided by square PATJAC (from -1 to 2) */
6005/* IORDRV: Order of continuity by U provided by square PATJAC (from -1 to 2) */
6006/* XMAXJU: Maximum value of Jacobi polynoms of order IORDRU, */
6007/* from degree 0 to MAXDGU - 2*(IORDU+1) */
6008/* XMAXJV: Maximum value of Jacobi polynoms of order IORDRV, */
6009/* from degree 0 to MAXDGV - 2*(IORDV+1) */
6010/* PATJAC: Table of coeff. of square of approximation with */
6011/* constraints of order IORDRU by U and IORDRV by V. */
6012/* EPMSCUT: Tolerance of approximation. */
6013/* VECERR: Auxiliary vector. */
6014/* ERREUR: MAX Error commited ALREADY CALCULATED */
6015
6016/* OUTPUT ARGUMENTS : */
7fd59977 6017/* ------------------- */
0d969553
Y		 6018/* ERREUR: MAX Error commited by preserving only coeff of PATJAC */
6019/* of indices from 0 to NEWDGU by U and from 0 to NEWDGV by V */
6020/* PLUS the already calculated error. */
6021/* NEWDGU: Min. Degree by U such as the square of approximation */
6022/* could check the tolerance. There is always NEWDGU >= MINDGU >= 0. */
6023/* NEWDGV: Min. Degree by V such as the square of approximation */
6024/* could check the tolerance. There is always NEWDGV >= MINDGV >= 0. */
6025
6026
6027/* COMMONS USED : */
7fd59977 6028/* ---------------- */
6029
0d969553
Y		 6030/* REFERENCES CALLED : */
6031/* --------------------- */
7fd59977 6032
0d969553 6033/* DESCRIPTION/NOTES/LIMITATIONS : */
7fd59977 6034/* ----------------------------------- */
0d969553
Y		 6035/* Table PATJAC is the place of storage of coeff. Cij of the square of */
6036/* approximation of F(U,V). The indices i and j show the degree */
6037/* by U and by V of base polynoms. These polynoms have the form: */
7fd59977 6038
0d969553 6039/* ((1 - U*U)**(IORDRU+1)).J(i-2*(IORDRU+1)(U), where */
7fd59977 6040
0d969553
Y		 6041/* polynom J(i-2*(IORDU+1)(U) is the Jacobi polynom of order */
6042/* IORDRU+1 (the same by V by replacing U u V in the expression above). */
7fd59977 6043
0d969553
Y		 6044/* The contribution to the error of term Cij when it is */
6045/* removed from PATJAC is increased by: */
7fd59977 6046
0d969553 6047/* DABS(Cij)*XMAXJU(i-2*(IORDRU+1))*XMAXJV(J-2*(IORDRV+1)) where */
7fd59977 6048
6049/* XMAXJU(i-2*(IORDRU+1) = ((1 - U*U)**(IORDRU+1)).J(i-2*(IORDRU+1)(U),
6050*/
6051/* XMAXJV(i-2*(IORDRV+1) = ((1 - V*V)**(IORDRV+1)).J(j-2*(IORDRV+1)(V).
6052*/
6053
7fd59977 6054/* > */
6055/* **********************************************************************
6056*/
0d969553 6057/* Name of the routine */
7fd59977 6058
6059
6060/* ----------------------------- Initialisations ------------------------
6061*/
6062
6063 /* Parameter adjustments */
6064 --vecerr;
6065 patjac_dim1 = *ndjacu + 1;
6066 patjac_dim2 = *ndjacv + 1;
6067 patjac_offset = patjac_dim1 * patjac_dim2;
6068 patjac -= patjac_offset;
6069
6070 /* Function Body */
6071 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 3;
6072 if (ldbg) {
6073 AdvApp2Var_SysBase::mgenmsg_("MMA2ER2", 7L);
6074 }
6075
6076 i2rdu = (*iordru + 1) << 1;
6077 i2rdv = (*iordrv + 1) << 1;
6078 nu = *maxdgu;
6079 nv = *maxdgv;
6080
6081/* **********************************************************************
6082*/
0d969553 6083/* -------------------- Cutting of oefficients ------------------------
7fd59977 6084*/
6085/* **********************************************************************
6086*/
6087
6088L1001:
6089
0d969553
Y		 6090/* ------------------- Calculate the increment of max error --------------- */
6091/* ----- during the removal of coeff. of indices from MINDGU to MAXDGU ------ */
6092/* ---------------- by U, the degree by V is fixed to NV -----------------
7fd59977 6093*/
6094
6095 bid0 = 0.;
6096 if (nv > *mindgv) {
6097 bid0 = xmaxjv[nv - i2rdv];
6098 i__1 = *ndimen;
6099 for (nd = 1; nd <= i__1; ++nd) {
6100 bid1 = 0.;
6101 i__2 = nu;
6102 for (ii = i2rdu; ii <= i__2; ++ii) {
6103 bid1 += (d__1 = patjac[ii + (nv + nd * patjac_dim2) *
6104 patjac_dim1], abs(d__1)) * xmaxju[ii - i2rdu] * bid0;
6105/* L200: */
6106 }
6107 vecerr[nd] = bid1;
6108/* L100: */
6109 }
6110 } else {
6111 vecerr[1] = *epmscut * 2;
6112 }
6113 errnv = AdvApp2Var_MathBase::mzsnorm_(ndimen, &vecerr[1]);
6114
0d969553
Y		 6115/* ------------------- Calculate the increment of max error --------------- */
6116/* ----- during the removal of coeff. of indices from MINDGV to MAXDGV ------ */
6117/* ---------------- by V, the degree by U is fixed to NU -----------------
7fd59977 6118*/
6119
6120 bid0 = 0.;
6121 if (nu > *mindgu) {
6122 bid0 = xmaxju[nu - i2rdu];
6123 i__1 = *ndimen;
6124 for (nd = 1; nd <= i__1; ++nd) {
6125 bid1 = 0.;
6126 i__2 = nv;
6127 for (jj = i2rdv; jj <= i__2; ++jj) {
6128 bid1 += (d__1 = patjac[nu + (jj + nd * patjac_dim2) *
6129 patjac_dim1], abs(d__1)) * xmaxjv[jj - i2rdv] * bid0;
6130/* L400: */
6131 }
6132 vecerr[nd] = bid1;
6133/* L300: */
6134 }
6135 } else {
6136 vecerr[1] = *epmscut * 2;
6137 }
6138 errnu = AdvApp2Var_MathBase::mzsnorm_(ndimen, &vecerr[1]);
6139
0d969553 6140/* ----------------------- Calculate the max error ----------------------
7fd59977 6141*/
6142
6143 vaux[0] = *erreur;
6144 vaux[1] = errnu;
6145 nd = 2;
6146 errnu = AdvApp2Var_MathBase::mzsnorm_(&nd, vaux);
6147 vaux[1] = errnv;
6148 errnv = AdvApp2Var_MathBase::mzsnorm_(&nd, vaux);
6149
6150 if (errnu > errnv) {
6151 if (errnv < *epmscut) {
6152 *erreur = errnv;
6153 --nv;
6154 } else {
6155 goto L2001;
6156 }
6157 } else {
6158 if (errnu < *epmscut) {
6159 *erreur = errnu;
6160 --nu;
6161 } else {
6162 goto L2001;
6163 }
6164 }
6165
6166 goto L1001;
6167
0d969553 6168/* -------------------------- Return the degrees -------------------
7fd59977 6169*/
6170
6171L2001:
6172 *newdgu = max(nu,1);
6173 *newdgv = max(nv,1);
6174
6175/* ----------------------------------- The end --------------------------
6176*/
6177
6178 if (ldbg) {
6179 AdvApp2Var_SysBase::mgsomsg_("MMA2ER2", 7L);
6180 }
6181 return 0;
6182} /* mma2er2_ */
6183
6184//=======================================================================
6185//function : mma2fnc_
6186//purpose :
6187//=======================================================================
6188int AdvApp2Var_ApproxF2var::mma2fnc_(integer *ndimen,
6189 integer *nbsesp,
6190 integer *ndimse,
6191 doublereal *uvfonc,
6192 void (*foncnp) (
6193 int *,
6194 double *,
6195 double *,
6196 int *,
6197 double *,
6198 int *,
6199 double *,
6200 int *,
6201 int *,
6202 double *,
6203 int *
6204 ),
6205 doublereal *tconst,
6206 integer *isofav,
6207 integer *nbroot,
6208 doublereal *rootlg,
6209 integer *iordre,
6210 integer *ideriv,
6211 integer *ndgjac,
6212 integer *nbcrmx,
6213 integer *ncflim,
6214 doublereal *epsapr,
6215 integer *ncoeff,
6216 doublereal *courbe,
6217 integer *nbcrbe,
6218 doublereal *somtab,
6219 doublereal *diftab,
6220 doublereal *contr1,
6221 doublereal *contr2,
6222 doublereal *tabdec,
6223 doublereal *errmax,
6224 doublereal *errmoy,
6225 integer *iercod)
6226
6227{
6228 static integer c__8 = 8;
6229
6230 /* System generated locals */
6231 integer courbe_dim1, courbe_dim2, courbe_offset, somtab_dim1, somtab_dim2,
6232 somtab_offset, diftab_dim1, diftab_dim2, diftab_offset,
6233 contr1_dim1, contr1_dim2, contr1_offset, contr2_dim1, contr2_dim2,
6234 contr2_offset, errmax_dim1, errmax_offset, errmoy_dim1,
6235 errmoy_offset, i__1;
6236 doublereal d__1;
6237
6238 /* Local variables */
6239 static integer ideb;
6240 static doublereal tmil;
6241 static integer ideb1, ibid1, ibid2, ncfja, ndgre, ilong,
6242 ndwrk;
6243 static doublereal wrkar[1];
6244 static integer nupil;
6245 static long int iofwr;
6246 static doublereal uvpav[4] /* was [2][2] */;
6247 static integer nd, ii;
6248 static integer ibb;
6249 static integer ier;
6250 static doublereal uv11[4] /* was [2][2] */;
6251 static integer ncb1;
6252 static doublereal eps3;
6253 static integer isz1, isz2, isz3, isz4, isz5;
6254 static long int ipt1, ipt2, ipt3, ipt4, ipt5,iptt, jptt;
6255
6256/* **********************************************************************
6257*/
6258
0d969553 6259/* FUNCTION : */
7fd59977 6260/* ---------- */
0d969553
Y		 6261/* Approximation of a limit of non polynomial function F(u,v) */
6262/* (in the space of dimension NDIMEN) by SEVERAL */
6263/* polynomial curves, by the method of least squares. The parameter of the function is preserved. */
7fd59977 6264
0d969553 6265/* KEYWORDS : */
7fd59977 6266/* ----------- */
6267/* TOUS, AB_SPECIFI :: FONCTION&,EXTREMITE&, APPROXIMATION, &COURBE. */
6268
0d969553
Y		 6269/* INPUT ARGUMENTS : */
6270/* ----------------- */
6271/* NDIMEN: Total Dimension of the space (sum of dimensions */
6272/* of sub-spaces) */
6273/* NBSESP: Number of "independent" sub-spaces. */
6274/* NDIMSE: Table of dimensions of sub-spaces. */
6275/* UVFONC: Limits of the interval (a,b)x(c,d) of definition of the */
6276/* function to be approached by U (UVFONC(*,1) contains (a,b)) */
6277/* and by V (UVFONC(*,2) contains (c,d)). */
6278/* FONCNP: External function of position on the non polynomial function to be approached. */
6279/* TCONST: Value of isoparameter of F(u,v) to be discretized. */
6280/* ISOFAV: Type of chosen iso, = 1, shose that discretization is with u */
6281/* fixed; = 2, shows that v is fixed. */
6282/* NBROOT: Nb of points of discretisation of the iso, extremities not included. */
6283/* ROOTLG: Table of roots of the polynom of Legendre defined on */
6284/* (-1,1), of degree NBROOT. */
6285/* IORDRE: Order of constraint at the extremities of the limit */
6286/* -1 = no constraints, */
6287/* 0 = constraints of passage to limits (i.e. C0), */
6288/* 1 = C0 + constraints of 1st derivatives (i.e. C1), */
6289/* 2 = C1 + constraints of 2nd derivatives (i.e. C2). */
6290/* IDERIV: Order of derivative of the limit. */
6291/* NDGJAC: Degree of serial development to be used for calculation in */
6292/* the Jacobi base. */
6293/* NBCRMX: Max Nb of curves to be created. */
6294/* NCFLIM: Max Nb of coeff of the polynomial curve */
6295/* of approximation (should be above or equal to */
6296/* 2*IORDRE+2 and below or equal to 50). */
6297/* EPSAPR: Table of required errors of approximation */
6298/* sub-space by sub-space. */
6299
6300/* OUTPUT ARGUMENTS : */
7fd59977 6301/* ------------------- */
0d969553
Y		 6302/* NCOEFF: Number of significative coeff of calculated curves. */
6303/* COURBE: Table of coeff. of calculated polynomial curves. */
6304/* Should be dimensioned in (NCFLIM,NDIMEN,NBCRMX). */
6305/* These curves are ALWAYS parametrized in (-1,1). */
6306/* NBCRBE: Nb of calculated curves. */
6307/* SOMTAB: For F defined on (-1,1) (otherwise rescale the */
6308/* parameters), this is the table of sums F(u,vj) + F(u,-vj)
6309*/
6310/* if ISOFAV = 1 (and IDERIV=0, otherwise the derivatives */
6311/* by u of order IDERIV are taken) or sumes F(ui,v) + F(-ui,v) if */
6312/* ISOFAV = 2 (and IDERIV=0, otherwise the derivatives by */
6313/* v of order IDERIV are taken). */
6314/* DIFTAB: For F defined on (-1,1) (otherwise rescale the */
6315/* parameters), this is the table of sums F(u,vj) - F(u,-vj)
6316*/
6317/* if ISOFAV = 1 (and IDERIV=0, otherwise the derivatives */
6318/* by u of order IDERIV are taken) or sumes F(ui,v) + F(-ui,v) if */
6319/* ISOFAV = 2 (and IDERIV=0, otherwise the derivatives by */
6320/* v of order IDERIV are taken). */
6321/* CONTR1: Contains the coordinates of the left extremity of the iso */
6322/* and of its derivatives till order IORDRE */
6323/* CONTR2: Contains the coordinates of the right extremity of the iso */
6324/* and of its derivatives till order IORDRE */
6325/* TABDEC: Table of NBCRBE+1 parameters of cut of UVFONC(1:2,1)
6326*/
6327/* if ISOFAV=2, or of UVFONC(1:2,2) if ISOFAV=1. */
6328/* ERRMAX: Table of MAX errors (sub-space by sub-space) */
6329/* committed in the approximation of FONCNP by NBCRBE curves. */
6330/* ERRMOY: Table of AVERAGE errors (sub-space by sub-space) */
6331/* committed in the approximation of FONCNP by NBCRBE curves.
6332/* IERCOD: Error code: */
6333/* -1 = ERRMAX > EPSAPR for at least one sub-space. */
6334/* (the resulting curves of at least mathematic degree NCFLIM-1 */
6335/* are calculated). */
6336/* 0 = Everything is ok. */
6337/* 1 = Pb of incoherence of inputs. */
6338/* 10 = Pb of calculation of the interpolation of constraints. */
6339/* 13 = Pb in the dynamic allocation. */
6340/* 33 = Pb in the data recuperation from block data */
6341/* of coeff. of integration by GAUSS method. */
6342/* >100 Pb in the evaluation of FONCNP, the returned error code */
6343/* is equal to the error code of FONCNP + 100. */
6344
6345/* COMMONS USED : */
7fd59977 6346/* ---------------- */
6347
0d969553 6348/* REFERENCES CALLED : */
7fd59977 6349/* ----------------------- */
6350
0d969553 6351/* DESCRIPTION/NOTES/LIMITATIONS : */
7fd59977 6352/* ----------------------------------- */
0d969553
Y		 6353/* --> The approximation part is done in the space of dimension */
6354/* NDIMEN (the sum of dimensions of sub-spaces). For example : */
6355/* If NBSESP=2 and NDIMSE(1)=3, NDIMSE(2)=2, there is smoothing with */
6356/* NDIMEN=5. The result (in COURBE(NDIMEN,NCOEFF,i) ), will be */
6357/* composed of the result of smoothing of 3D function in */
6358/* COURBE(1:3,1:NCOEFF,i) and of smoothing of 2D function in */
7fd59977 6359/* COURBE(4:5,1:NCOEFF,i). */
6360
0d969553
Y		 6361/* --> Routine FONCNP should be declared EXTERNAL in the program */
6362/* calling MMA2FNC. */
7fd59977 6363
0d969553
Y		 6364/* --> Function FONCNP, declared externally, should be declared */
6365/* IMPERATIVELY in form : */
7fd59977 6366/* SUBROUTINE FONCNP(NDIMEN,UINTFN,VINTFN,IIUOUV,TCONST,NBPTAB */
6367/* ,TTABLE,IDERIU,IDERIV,IERCOD) */
0d969553
Y		 6368/* where the input arguments are : */
6369/* - NDIMEN is integer defined as the sum of dimensions of */
6370/* sub-spaces (i.e. total dimension of the problem). */
6371/* - UINTFN(2) is a table of 2 reals containing the interval */
6372/* by u where the function to be approximated is defined */
6373/* (so it is equal to UIFONC). */
6374/* - VINTFN(2) is a table of 2 reals containing the interval */
6375/* by v where the function to be approximated is defined */
6376/* (so it is equal to VIFONC). */
6377/* - IIUOUV, shows that the points to be calculated have a constant U */
6378/* (IIUOUV=1) or a constant V (IIUOUV=2). */
6379/* - TCONST, real, value of the fixed discretisation parameter. Takes values */
6380/* in (UINTFN(1),UINTFN(2)) if IIUOUV=1, */
6381/* or in (VINTFN(1),VINTFN(2)) if IIUOUV=2. */
6382/* - NBPTAB, the nb of point of discretisation following the free variable */
6383/* : V if IIUOUV=1 or U if IIUOUV = 2. */
6384/* - TTABLE, Table of NBPTAB parametres of discretisation. . */
6385/* - IDERIU, integer, takes values between 0 (position) */
6386/* and IORDREU (partial derivative of the function by u */
6387/* of order IORDREU if IORDREU > 0). */
6388/* - IDERIV, integer, takes values between 0 (position) */
6389/* and IORDREV (partial derivative of the function by v */
6390/* of order IORDREV if IORDREV > 0). */
6391/* and the output arguments are : */
6392/* - FPNTAB(NDIMEN,NBPTAB) contains, at output, the table of */
6393/* NBPTAB points calculated in FONCNP. */
6394/* - IERCOD is, at output the error code of FONCNP. This code */
6395/* (integer) should be strictly positive if there is a problem. */
6396
6397/* The input arguments SHOULD NOT BE modified under FONCNP.
6398*/
6399
6400/* --> If IERCOD=-1, the required precision can't be reached (ERRMAX */
6401/* is above EPSAPR on at least one sub-space), but
6402*/
6403/* one gives the best possible result for NCFLIM and EPSAPR */
6404/* chosen by the user. In this case (and for IERCOD=0), there is a solution. */
7fd59977 6405
7fd59977 6406/* > */
6407/* **********************************************************************
6408*/
0d969553 6409/* Name of the routine */
7fd59977 6410
6411 /* Parameter adjustments */
6412 --epsapr;
6413 --ndimse;
6414 uvfonc -= 3;
6415 --rootlg;
6416 errmoy_dim1 = *nbsesp;
6417 errmoy_offset = errmoy_dim1 + 1;
6418 errmoy -= errmoy_offset;
6419 errmax_dim1 = *nbsesp;
6420 errmax_offset = errmax_dim1 + 1;
6421 errmax -= errmax_offset;
6422 contr2_dim1 = *ndimen;
6423 contr2_dim2 = *iordre + 2;
6424 contr2_offset = contr2_dim1 * (contr2_dim2 + 1) + 1;
6425 contr2 -= contr2_offset;
6426 contr1_dim1 = *ndimen;
6427 contr1_dim2 = *iordre + 2;
6428 contr1_offset = contr1_dim1 * (contr1_dim2 + 1) + 1;
6429 contr1 -= contr1_offset;
6430 diftab_dim1 = *nbroot / 2 + 1;
6431 diftab_dim2 = *ndimen;
6432 diftab_offset = diftab_dim1 * (diftab_dim2 + 1);
6433 diftab -= diftab_offset;
6434 somtab_dim1 = *nbroot / 2 + 1;
6435 somtab_dim2 = *ndimen;
6436 somtab_offset = somtab_dim1 * (somtab_dim2 + 1);
6437 somtab -= somtab_offset;
6438 --ncoeff;
6439 courbe_dim1 = *ncflim;
6440 courbe_dim2 = *ndimen;
6441 courbe_offset = courbe_dim1 * (courbe_dim2 + 1) + 1;
6442 courbe -= courbe_offset;
6443
6444 /* Function Body */
6445 ibb = AdvApp2Var_SysBase::mnfndeb_();
6446 if (ibb >= 1) {
6447 AdvApp2Var_SysBase::mgenmsg_("MMA2FNC", 7L);
6448 }
6449 *iercod = 0;
6450 iofwr = 0;
6451
0d969553 6452/* ---------------- Set to zero the coefficients of CURVE --------------
7fd59977 6453*/
6454
6455 ilong = *ndimen * *ncflim * *nbcrmx;
6456 AdvApp2Var_SysBase::mvriraz_(&ilong, (char *)&courbe[courbe_offset]);
6457
6458/* **********************************************************************
6459*/
0d969553 6460/* -------------------------- Checking of entries ------------------
7fd59977 6461*/
6462/* **********************************************************************
6463*/
6464
6465 AdvApp2Var_MathBase::mmveps3_(&eps3);
6466 if ((d__1 = uvfonc[4] - uvfonc[3], abs(d__1)) < eps3) {
6467 goto L9100;
6468 }
6469 if ((d__1 = uvfonc[6] - uvfonc[5], abs(d__1)) < eps3) {
6470 goto L9100;
6471 }
6472
6473 uv11[0] = -1.;
6474 uv11[1] = 1.;
6475 uv11[2] = -1.;
6476 uv11[3] = 1.;
6477
0d969553
Y		 6478/* ********************************************************************** */
6479/* ------------- Preparation of parameters of discretisation ----------- */
7fd59977 6480/* **********************************************************************
6481*/
6482
0d969553
Y		 6483/* -- Allocation of a table of parameters and points of discretisation -- */
6484/* --> For the parameters of discretisation. */
7fd59977 6485 isz1 = *nbroot + 2;
0d969553 6486/* --> For the points of discretisation in MMA1FDI and MMA1CDI and
7fd59977 6487 */
0d969553 6488/* the auxiliary curve for MMAPCMP */
7fd59977 6489 ibid1 = *ndimen * (*nbroot + 2);
6490 ibid2 = ((*iordre + 1) << 1) * *nbroot;
6491 isz2 = max(ibid1,ibid2);
6492 ibid1 = (((*ncflim - 1) / 2 + 1) << 1) * *ndimen;
6493 isz2 = max(ibid1,isz2);
0d969553 6494/* --> To return the polynoms of hermit. */
7fd59977 6495 isz3 = ((*iordre + 1) << 2) * (*iordre + 1);
0d969553 6496/* --> For the Gauss coeff. of integration. */
7fd59977 6497 isz4 = (*nbroot / 2 + 1) * (*ndgjac + 1 - ((*iordre + 1) << 1));
0d969553 6498/* --> For the coeff of the curve in the base of Jacobi */
7fd59977 6499 isz5 = (*ndgjac + 1) * *ndimen;
6500
6501 ndwrk = isz1 + isz2 + isz3 + isz4 + isz5;
6502 AdvApp2Var_SysBase::mcrrqst_(&c__8, &ndwrk, wrkar, &iofwr, &ier);
6503 if (ier > 0) {
6504 goto L9013; }
0d969553 6505/* --> For the parameters of discretisation (NBROOT+2 extremities). */
7fd59977 6506 ipt1 = iofwr;
0d969553
Y		 6507/* --> For the points of discretisation FPNTAB(NDIMEN,NBROOT+2), */
6508/* FPNTAB(NBROOT,2*(IORDRE+1)) and for WRKAR of MMAPCMP. */
7fd59977 6509 ipt2 = ipt1 + isz1;
0d969553 6510/* --> For the polynoms of Hermit */
7fd59977 6511 ipt3 = ipt2 + isz2;
0d969553 6512/* --> For the Gauss coeff of integration. */
7fd59977 6513 ipt4 = ipt3 + isz3;
0d969553 6514/* --> For the curve in Jacobi. */
7fd59977 6515 ipt5 = ipt4 + isz4;
6516
0d969553 6517/* ------------------ Initialisation of management of cuts ---------
7fd59977 6518*/
6519
6520 if (*isofav == 1) {
6521 uvpav[0] = uvfonc[3];
6522 uvpav[1] = uvfonc[4];
6523 tabdec[0] = uvfonc[5];
6524 tabdec[1] = uvfonc[6];
6525 } else if (*isofav == 2) {
6526 tabdec[0] = uvfonc[3];
6527 tabdec[1] = uvfonc[4];
6528 uvpav[2] = uvfonc[5];
6529 uvpav[3] = uvfonc[6];
6530 } else {
6531 goto L9100;
6532 }
6533
6534 nupil = 1;
6535 *nbcrbe = 0;
6536
6537/* **********************************************************************
6538*/
0d969553 6539/* APPROXIMATION WITH CUTS */
7fd59977 6540/* **********************************************************************
6541*/
6542
6543L1000:
0d969553 6544/* --> When the top is reached, this is the end ! */
7fd59977 6545 if (nupil - *nbcrbe == 0) {
6546 goto L9900;
6547 }
6548 ncb1 = *nbcrbe + 1;
6549 if (*isofav == 1) {
6550 uvpav[2] = tabdec[*nbcrbe];
6551 uvpav[3] = tabdec[*nbcrbe + 1];
6552 } else if (*isofav == 2) {
6553 uvpav[0] = tabdec[*nbcrbe];
6554 uvpav[1] = tabdec[*nbcrbe + 1];
6555 } else {
6556 goto L9100;
6557 }
6558
0d969553 6559/* -------------------- Normalization of parameters -------------------- */
7fd59977 6560
6561 mma1nop_(nbroot, &rootlg[1], uvpav, isofav, &wrkar[ipt1], &ier);
6562 if (ier > 0) {
6563 goto L9100;
6564 }
6565
0d969553 6566/* -------------------- Discretisation of FONCNP ------------------------ */
7fd59977 6567
6568 mma1fdi_(ndimen, uvpav, foncnp, isofav, tconst, nbroot, &wrkar[ipt1],
6569 iordre, ideriv, &wrkar[ipt2], &somtab[(ncb1 * somtab_dim2 + 1) *
6570 somtab_dim1], &diftab[(ncb1 * diftab_dim2 + 1) * diftab_dim1], &
6571 contr1[(ncb1 * contr1_dim2 + 1) * contr1_dim1 + 1], &contr2[(ncb1
6572 * contr2_dim2 + 1) * contr2_dim1 + 1], iercod);
6573 if (*iercod > 0) {
6574 goto L9900;
6575 }
6576
0d969553 6577/* -----------Cut the discretisation of constraints ------------*/
7fd59977 6578
6579 if (*iordre >= 0) {
6580 mma1cdi_(ndimen, nbroot, &rootlg[1], iordre, &contr1[(ncb1 *
6581 contr1_dim2 + 1) * contr1_dim1 + 1], &contr2[(ncb1 *
6582 contr2_dim2 + 1) * contr2_dim1 + 1], &somtab[(ncb1 *
6583 somtab_dim2 + 1) * somtab_dim1], &diftab[(ncb1 * diftab_dim2
6584 + 1) * diftab_dim1], &wrkar[ipt2], &wrkar[ipt3], &ier);
6585 if (ier > 0) {
6586 goto L9100;
6587 }
6588 }
6589
6590/* **********************************************************************
6591*/
0d969553 6592/* -------------------- Calculate the curve of approximation -------------
7fd59977 6593*/
6594/* **********************************************************************
6595*/
6596
6597 mma1jak_(ndimen, nbroot, iordre, ndgjac, &somtab[(ncb1 * somtab_dim2 + 1)
6598 * somtab_dim1], &diftab[(ncb1 * diftab_dim2 + 1) * diftab_dim1], &
6599 wrkar[ipt4], &wrkar[ipt5], &ier);
6600 if (ier > 0) {
6601 goto L9100;
6602 }
6603
6604/* **********************************************************************
6605*/
0d969553 6606/* ---------------- Add polynom of interpolation -------------------
7fd59977 6607*/
6608/* **********************************************************************
6609*/
6610
6611 if (*iordre >= 0) {
6612 mma1cnt_(ndimen, iordre, &contr1[(ncb1 * contr1_dim2 + 1) *
6613 contr1_dim1 + 1], &contr2[(ncb1 * contr2_dim2 + 1) *
6614 contr2_dim1 + 1], &wrkar[ipt3], ndgjac, &wrkar[ipt5]);
6615 }
6616
6617/* **********************************************************************
6618*/
0d969553 6619/* --------------- Calculate Max and Average error ----------------------
7fd59977 6620*/
6621/* **********************************************************************
6622*/
6623
6624 mma1fer_(ndimen, nbsesp, &ndimse[1], iordre, ndgjac, &wrkar[ipt5], ncflim,
6625 &epsapr[1], &wrkar[ipt2], &errmax[ncb1 * errmax_dim1 + 1], &
6626 errmoy[ncb1 * errmoy_dim1 + 1], &ncoeff[ncb1], &ier);
6627 if (ier > 0) {
6628 goto L9100;
6629 }
6630
6631 if (ier == 0 || (ier == -1 && nupil == *nbcrmx)) {
6632
6633/* ******************************************************************
6634**** */
6635/* ----------------------- Compression du resultat ------------------
6636---- */
6637/* ******************************************************************
6638**** */
6639
6640 if (ier == -1) {
6641 *iercod = -1;
6642 }
6643 ncfja = *ndgjac + 1;
0d969553 6644/* -> Compression of result in WRKAR(IPT2) */
7fd59977 6645 /*pkv f*/
6646 /*
6647 AdvApp2Var_MathBase::mmapcmp_(ndimen,
6648 &ncfja, &ncoeff[ncb1], &wrkar[ipt5], &wrkar[ipt2]);
6649 */
6650 AdvApp2Var_MathBase::mmapcmp_((integer*)ndimen,
6651 &ncfja,
6652 &ncoeff[ncb1],
6653 &wrkar[ipt5],
6654 &wrkar[ipt2]);
6655 /*pkv t*/
6656 ilong = *ndimen * *ncflim;
6657 AdvApp2Var_SysBase::mvriraz_(&ilong, (char*)&wrkar[ipt5]);
0d969553 6658/* -> Passage to canonic base (-1,1) (result in WRKAR(IPT5)).
7fd59977 6659*/
6660 ndgre = ncoeff[ncb1] - 1;
6661 i__1 = *ndimen;
6662 for (nd = 1; nd <= i__1; ++nd) {
6663 iptt = ipt2 + ((nd - 1) << 1) * (ndgre / 2 + 1);
6664 jptt = ipt5 + (nd - 1) * ncoeff[ncb1];
6665 AdvApp2Var_MathBase::mmjacan_(iordre, &ndgre, &wrkar[iptt], &wrkar[jptt]);
6666/* L400: */
6667 }
6668
0d969553 6669/* -> Store the calculated curve */
7fd59977 6670 ibid1 = 1;
6671 AdvApp2Var_MathBase::mmfmca8_(&ncoeff[ncb1], ndimen, &ibid1, ncflim, ndimen, &ibid1, &
6672 wrkar[ipt5], &courbe[(ncb1 * courbe_dim2 + 1) * courbe_dim1 +
6673 1]);
6674
0d969553
Y		 6675/* -> Before normalization of constraints on (-1,1), recalculate */
6676/* the true constraints. */
7fd59977 6677 i__1 = *iordre;
6678 for (ii = 0; ii <= i__1; ++ii) {
6679 mma1noc_(uv11, ndimen, &ii, &contr1[(ii + 1 + ncb1 * contr1_dim2)
6680 * contr1_dim1 + 1], uvpav, isofav, ideriv, &contr1[(ii +
6681 1 + ncb1 * contr1_dim2) * contr1_dim1 + 1]);
6682 mma1noc_(uv11, ndimen, &ii, &contr2[(ii + 1 + ncb1 * contr2_dim2)
6683 * contr2_dim1 + 1], uvpav, isofav, ideriv, &contr2[(ii +
6684 1 + ncb1 * contr2_dim2) * contr2_dim1 + 1]);
6685/* L200: */
6686 }
6687 ii = 0;
6688 ibid1 = (*nbroot / 2 + 1) * *ndimen;
6689 mma1noc_(uv11, &ibid1, &ii, &somtab[(ncb1 * somtab_dim2 + 1) *
6690 somtab_dim1], uvpav, isofav, ideriv, &somtab[(ncb1 *
6691 somtab_dim2 + 1) * somtab_dim1]);
6692 mma1noc_(uv11, &ibid1, &ii, &diftab[(ncb1 * diftab_dim2 + 1) *
6693 diftab_dim1], uvpav, isofav, ideriv, &diftab[(ncb1 *
6694 diftab_dim2 + 1) * diftab_dim1]);
6695 ii = 0;
6696 i__1 = *ndimen;
6697 for (nd = 1; nd <= i__1; ++nd) {
6698 mma1noc_(uv11, &ncoeff[ncb1], &ii, &courbe[(nd + ncb1 *
6699 courbe_dim2) * courbe_dim1 + 1], uvpav, isofav, ideriv, &
6700 courbe[(nd + ncb1 * courbe_dim2) * courbe_dim1 + 1]);
6701/* L210: */
6702 }
6703
0d969553 6704/* -> Update the nb of already created curves */
7fd59977 6705 ++(*nbcrbe);
6706
0d969553 6707/* -> ...otherwise try to cut the current interval in 2... */
7fd59977 6708 } else {
6709 tmil = (tabdec[*nbcrbe + 1] + tabdec[*nbcrbe]) / 2.;
6710 ideb = *nbcrbe + 1;
6711 ideb1 = ideb + 1;
6712 ilong = (nupil - *nbcrbe) << 3;
6713 AdvApp2Var_SysBase::mcrfill_(&ilong, (char *)&tabdec[ideb],(char *)&tabdec[ideb1]);
6714 tabdec[ideb] = tmil;
6715 ++nupil;
6716 }
6717
0d969553 6718/* ---------- Make approximation of the rest -----------
7fd59977 6719*/
6720
6721 goto L1000;
6722
0d969553 6723/* --------------------- Return code of error -----------------
7fd59977 6724*/
0d969553 6725/* --> Pb with dynamic allocation */
7fd59977 6726L9013:
6727 *iercod = 13;
6728 goto L9900;
0d969553 6729/* --> Inputs incoherent. */
7fd59977 6730L9100:
6731 *iercod = 1;
6732 goto L9900;
6733
0d969553 6734/* -------------------------- Dynamic desallocation -------------------
7fd59977 6735*/
6736
6737L9900:
6738 if (iofwr != 0) {
6739 AdvApp2Var_SysBase::mcrdelt_(&c__8, &ndwrk, wrkar, &iofwr, &ier);
6740 }
6741 if (ier > 0) {
6742 *iercod = 13;
6743 }
6744 goto L9999;
6745
6746/* ------------------------------ The end -------------------------------
6747*/
6748
6749L9999:
6750 if (*iercod != 0) {
6751 AdvApp2Var_SysBase::maermsg_("MMA2FNC", iercod, 7L);
6752 }
6753 if (ibb >= 2) {
6754 AdvApp2Var_SysBase::mgsomsg_("MMA2FNC", 7L);
6755 }
6756 return 0;
6757} /* mma2fnc_ */
6758
6759//=======================================================================
6760//function : mma2fx6_
6761//purpose :
6762//=======================================================================
6763int AdvApp2Var_ApproxF2var::mma2fx6_(integer *ncfmxu,
6764 integer *ncfmxv,
6765 integer *ndimen,
6766 integer *nbsesp,
6767 integer *ndimse,
6768 integer *nbupat,
6769 integer *nbvpat,
6770 integer *iordru,
6771 integer *iordrv,
6772 doublereal *epsapr,
6773 doublereal *epsfro,
6774 doublereal *patcan,
6775 doublereal *errmax,
6776 integer *ncoefu,
6777 integer *ncoefv)
6778
6779{
6780 /* System generated locals */
6781 integer epsfro_dim1, epsfro_offset, patcan_dim1, patcan_dim2, patcan_dim3,
6782 patcan_dim4, patcan_offset, errmax_dim1, errmax_dim2,
6783 errmax_offset, ncoefu_dim1, ncoefu_offset, ncoefv_dim1,
6784 ncoefv_offset, i__1, i__2, i__3, i__4, i__5;
6785 doublereal d__1, d__2;
6786
6787 /* Local variables */
6788 static integer idim, ncfu, ncfv, id, ii, nd, jj, ku, kv, ns, ibb;
6789 static doublereal bid;
6790 static doublereal tol;
6791
6792/* **********************************************************************
6793*/
6794
0d969553 6795/* FUNCTION : */
7fd59977 6796/* ---------- */
0d969553 6797/* Reduction of degree when the squares are the squares of constraints. */
7fd59977 6798
0d969553 6799/* KEYWORDS : */
7fd59977 6800/* ----------- */
6801/* TOUS,AB_SPECIFI::CARREAU&,REDUCTION,&CARREAU */
6802
0d969553 6803/* INPUT ARGUMENTS : */
7fd59977 6804/* ------------------ */
0d969553
Y		 6805/* NCFMXU: Max Nb of coeff by u of solution P(u,v) (table */
6806/* PATCAN). This argument serves only to declare the size of this table. */
6807/* NCFMXV: Max Nb of coeff by v of solution P(u,v) (table */
6808/* PATCAN). This argument serves only to declare the size of this table. */
6809/* NDIMEN: Total dimension of the space where the processed function */
6810/* takes its values.(sum of dimensions of sub-spaces) */
6811/* NBSESP: Nb of independent sub-spaces where the errors are measured. */
6812/* NDIMSE: Table of dimensions of NBSESP sub-spaces. */
6813/* NBUPAT: Nb of square solution by u. */
6814/* NBVPAT: Nb of square solution by v. */
6815/* IORDRU: Order of constraint imposed at the extremities of iso-V */
6816/* = 0, the extremities of iso-V are calculated */
6817/* = 1, additionally the 1st derivative in the direction of iso-V is calculated */
6818/* = 2, additionally the 2nd derivative in the direction of iso-V is calculated */
7fd59977 6819/* IORDRV: Ordre de contrainte impose aux extremites de l'iso-U */
6820/* = 0, on calcule les extremites de l'iso-U. */
0d969553
Y		 6821/* = 1, additionally the 1st derivative in the direction of iso-U is calculated */
6822/* = 2, additionally the 2nd derivative in the direction of iso-U is calculated */
6823/* EPSAPR: Table of imposed precisions, sub-space by sub-space. */
6824/* EPSFRO: Table of imposed precisions, sub-space by sub-space on the limits of squares. */
6825/* PATCAN: Table of coeff. in the canonic base of squares P(u,v) calculated for (u,v) in (-1,1). */
6826/* ERRMAX: Table of MAX errors (sub-space by sub-space) */
6827/* committed in the approximation of F(u,v) by P(u,v). */
6828/* NCOEFU: Table of Nb of significative coeffs. by u of calculated squares. */
6829/* NCOEFV: Table of Nb of significative coeffs. by v of calculated squares. */
6830
6831/* OUTPUT ARGUMENTS : */
7fd59977 6832/* ------------------- */
0d969553
Y		 6833/* NCOEFU: Table of Nb of significative coeffs. by u of calculated squares. */
6834/* NCOEFV: Table of Nb of significative coeffs. by v of calculated squares. */
7fd59977 6835
0d969553 6836/* COMMONS USED : */
7fd59977 6837/* ---------------- */
6838
0d969553
Y		 6839/* REFERENCES CALLED : */
6840/* --------------------- */
7fd59977 6841
0d969553
Y		 6842/* DESCRIPTION/NOTES/LIMITATIONS : */
6843/* ------------------------------- */
7fd59977 6844/* > */
6845/* **********************************************************************
6846*/
6847
0d969553 6848/* Name of the routine */
7fd59977 6849
6850
6851 /* Parameter adjustments */
6852 epsfro_dim1 = *nbsesp;
6853 epsfro_offset = epsfro_dim1 * 5 + 1;
6854 epsfro -= epsfro_offset;
6855 --epsapr;
6856 --ndimse;
6857 ncoefv_dim1 = *nbupat;
6858 ncoefv_offset = ncoefv_dim1 + 1;
6859 ncoefv -= ncoefv_offset;
6860 ncoefu_dim1 = *nbupat;
6861 ncoefu_offset = ncoefu_dim1 + 1;
6862 ncoefu -= ncoefu_offset;
6863 errmax_dim1 = *nbsesp;
6864 errmax_dim2 = *nbupat;
6865 errmax_offset = errmax_dim1 * (errmax_dim2 + 1) + 1;
6866 errmax -= errmax_offset;
6867 patcan_dim1 = *ncfmxu;
6868 patcan_dim2 = *ncfmxv;
6869 patcan_dim3 = *ndimen;
6870 patcan_dim4 = *nbupat;
6871 patcan_offset = patcan_dim1 * (patcan_dim2 * (patcan_dim3 * (patcan_dim4
6872 + 1) + 1) + 1) + 1;
6873 patcan -= patcan_offset;
6874
6875 /* Function Body */
6876 ibb = AdvApp2Var_SysBase::mnfndeb_();
6877 if (ibb >= 3) {
6878 AdvApp2Var_SysBase::mgenmsg_("MMA2FX6", 7L);
6879 }
6880
6881
6882 i__1 = *nbvpat;
6883 for (jj = 1; jj <= i__1; ++jj) {
6884 i__2 = *nbupat;
6885 for (ii = 1; ii <= i__2; ++ii) {
6886 ncfu = ncoefu[ii + jj * ncoefu_dim1];
6887 ncfv = ncoefv[ii + jj * ncoefv_dim1];
6888
0d969553
Y		 6889/* ********************************************************************** */
6890/* -------------------- Reduction of degree by U ------------------------- */
6891/* ********************************************************************** */
7fd59977 6892
6893L200:
6894 if (ncfu <= (*iordru + 1) << 1 && ncfu > 2) {
6895
6896 idim = 0;
6897 i__3 = *nbsesp;
6898 for (ns = 1; ns <= i__3; ++ns) {
6899 tol = epsapr[ns];
6900/* Computing MIN */
6901 d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 9];
6902 tol = min(d__1,d__2);
6903/* Computing MIN */
6904 d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 10];
6905 tol = min(d__1,d__2);
6906/* Computing MIN */
6907 d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 11];
6908 tol = min(d__1,d__2);
6909/* Computing MIN */
6910 d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 12];
6911 tol = min(d__1,d__2);
6912 if (ii == 1 || ii == *nbupat || jj == 1 || jj == *nbvpat)
6913 {
6914/* Computing MIN */
6915 d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 5];
6916 tol = min(d__1,d__2);
6917/* Computing MIN */
6918 d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 6];
6919 tol = min(d__1,d__2);
6920/* Computing MIN */
6921 d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 7];
6922 tol = min(d__1,d__2);
6923/* Computing MIN */
6924 d__1 = tol, d__2 = epsfro[ns + (epsfro_dim1 << 3)];
6925 tol = min(d__1,d__2);
6926 }
6927 bid = 0.;
6928
6929 i__4 = ndimse[ns];
6930 for (nd = 1; nd <= i__4; ++nd) {
6931 id = idim + nd;
6932 i__5 = ncfv;
6933 for (kv = 1; kv <= i__5; ++kv) {
6934 bid += (d__1 = patcan[ncfu + (kv + (id + (ii + jj
6935 * patcan_dim4) * patcan_dim3) *
6936 patcan_dim2) * patcan_dim1], abs(d__1));
6937/* L230: */
6938 }
6939/* L220: */
6940 }
6941
6942 if (bid > tol * 1e-6 || bid > errmax[ns + (ii + jj *
6943 errmax_dim2) * errmax_dim1]) {
6944 goto L300;
6945 }
6946 idim += ndimse[ns];
6947/* L210: */
6948 }
6949
6950 --ncfu;
6951 goto L200;
6952 }
6953
0d969553
Y		 6954/* ********************************************************************** */
6955/* -------------------- Reduction of degree by V ------------------------- */
6956/* ********************************************************************** */
7fd59977 6957
6958L300:
6959 if (ncfv <= (*iordrv + 1) << 1 && ncfv > 2) {
6960
6961 idim = 0;
6962 i__3 = *nbsesp;
6963 for (ns = 1; ns <= i__3; ++ns) {
6964 tol = epsapr[ns];
6965/* Computing MIN */
6966 d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 9];
6967 tol = min(d__1,d__2);
6968/* Computing MIN */
6969 d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 10];
6970 tol = min(d__1,d__2);
6971/* Computing MIN */
6972 d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 11];
6973 tol = min(d__1,d__2);
6974/* Computing MIN */
6975 d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 12];
6976 tol = min(d__1,d__2);
6977 if (ii == 1 || ii == *nbupat || jj == 1 || jj == *nbvpat)
6978 {
6979/* Computing MIN */
6980 d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 5];
6981 tol = min(d__1,d__2);
6982/* Computing MIN */
6983 d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 6];
6984 tol = min(d__1,d__2);
6985/* Computing MIN */
6986 d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 7];
6987 tol = min(d__1,d__2);
6988/* Computing MIN */
6989 d__1 = tol, d__2 = epsfro[ns + (epsfro_dim1 << 3)];
6990 tol = min(d__1,d__2);
6991 }
6992 bid = 0.;
6993
6994 i__4 = ndimse[ns];
6995 for (nd = 1; nd <= i__4; ++nd) {
6996 id = idim + nd;
6997 i__5 = ncfu;
6998 for (ku = 1; ku <= i__5; ++ku) {
6999 bid += (d__1 = patcan[ku + (ncfv + (id + (ii + jj
7000 * patcan_dim4) * patcan_dim3) *
7001 patcan_dim2) * patcan_dim1], abs(d__1));
7002/* L330: */
7003 }
7004/* L320: */
7005 }
7006
7007 if (bid > tol * 1e-6 || bid > errmax[ns + (ii + jj *
7008 errmax_dim2) * errmax_dim1]) {
7009 goto L400;
7010 }
7011 idim += ndimse[ns];
7012/* L310: */
7013 }
7014
7015 --ncfv;
7016 goto L300;
7017 }
7018
0d969553 7019/* --- Return the nbs of coeff. and pass to the next square --- */
7fd59977 7020
7021L400:
7022 ncoefu[ii + jj * ncoefu_dim1] = max(ncfu,2);
7023 ncoefv[ii + jj * ncoefv_dim1] = max(ncfv,2);
7024/* L110: */
7025 }
7026/* L100: */
7027 }
7028
7029/* ------------------------------ The End -------------------------------
7030*/
7031
7032 if (ibb >= 3) {
7033 AdvApp2Var_SysBase::mgsomsg_("MMA2FX6", 7L);
7034 }
7035
7036 return 0 ;
7037} /* mma2fx6_ */
7038
7039//=======================================================================
7040//function : mma2jmx_
7041//purpose :
7042//=======================================================================
7043int AdvApp2Var_ApproxF2var::mma2jmx_(integer *ndgjac,
7044 integer *iordre,
7045 doublereal *xjacmx)
7046{
7047 /* Initialized data */
7048
7049 static doublereal xmax2[57] = { .9682458365518542212948163499456,
7050 .986013297183269340427888048593603,
7051 1.07810420343739860362585159028115,
7052 1.17325804490920057010925920756025,
7053 1.26476561266905634732910520370741,
7054 1.35169950227289626684434056681946,
7055 1.43424378958284137759129885012494,
7056 1.51281316274895465689402798226634,
7057 1.5878364329591908800533936587012,
7058 1.65970112228228167018443636171226,
7059 1.72874345388622461848433443013543,
7060 1.7952515611463877544077632304216,
7061 1.85947199025328260370244491818047,
7062 1.92161634324190018916351663207101,
7063 1.98186713586472025397859895825157,
7064 2.04038269834980146276967984252188,
7065 2.09730119173852573441223706382076,
7066 2.15274387655763462685970799663412,
7067 2.20681777186342079455059961912859,
7068 2.25961782459354604684402726624239,
7069 2.31122868752403808176824020121524,
7070 2.36172618435386566570998793688131,
7071 2.41117852396114589446497298177554,
7072 2.45964731268663657873849811095449,
7073 2.50718840313973523778244737914028,
7074 2.55385260994795361951813645784034,
7075 2.59968631659221867834697883938297,
7076 2.64473199258285846332860663371298,
7077 2.68902863641518586789566216064557,
7078 2.73261215675199397407027673053895,
7079 2.77551570192374483822124304745691,
7080 2.8177699459714315371037628127545,
7081 2.85940333797200948896046563785957,
7082 2.90044232019793636101516293333324,
7083 2.94091151970640874812265419871976,
7084 2.98083391718088702956696303389061,
7085 3.02023099621926980436221568258656,
7086 3.05912287574998661724731962377847,
7087 3.09752842783622025614245706196447,
7088 3.13546538278134559341444834866301,
7089 3.17295042316122606504398054547289,
7090 3.2099992681699613513775259670214,
7091 3.24662674946606137764916854570219,
7092 3.28284687953866689817670991319787,
7093 3.31867291347259485044591136879087,
7094 3.35411740487202127264475726990106,
7095 3.38919225660177218727305224515862,
7096 3.42390876691942143189170489271753,
7097 3.45827767149820230182596660024454,
7098 3.49230918177808483937957161007792,
7099 3.5260130200285724149540352829756,
7100 3.55939845146044235497103883695448,
7101 3.59247431368364585025958062194665,
7102 3.62524904377393592090180712976368,
7103 3.65773070318071087226169680450936,
7104 3.68992700068237648299565823810245,
7105 3.72184531357268220291630708234186 };
7106 static doublereal xmax4[55] = { 1.1092649593311780079813740546678,
7107 1.05299572648705464724876659688996,
7108 1.0949715351434178709281698645813,
7109 1.15078388379719068145021100764647,
7110 1.2094863084718701596278219811869,
7111 1.26806623151369531323304177532868,
7112 1.32549784426476978866302826176202,
7113 1.38142537365039019558329304432581,
7114 1.43575531950773585146867625840552,
7115 1.48850442653629641402403231015299,
7116 1.53973611681876234549146350844736,
7117 1.58953193485272191557448229046492,
7118 1.63797820416306624705258190017418,
7119 1.68515974143594899185621942934906,
7120 1.73115699602477936547107755854868,
7121 1.77604489805513552087086912113251,
7122 1.81989256661534438347398400420601,
7123 1.86276344480103110090865609776681,
7124 1.90471563564740808542244678597105,
7125 1.94580231994751044968731427898046,
7126 1.98607219357764450634552790950067,
7127 2.02556989246317857340333585562678,
7128 2.06433638992049685189059517340452,
7129 2.10240936014742726236706004607473,
7130 2.13982350649113222745523925190532,
7131 2.17661085564771614285379929798896,
7132 2.21280102016879766322589373557048,
7133 2.2484214321456956597803794333791,
7134 2.28349755104077956674135810027654,
7135 2.31805304852593774867640120860446,
7136 2.35210997297725685169643559615022,
7137 2.38568889602346315560143377261814,
7138 2.41880904328694215730192284109322,
7139 2.45148841120796359750021227795539,
7140 2.48374387161372199992570528025315,
7141 2.5155912654873773953959098501893,
7142 2.54704548720896557684101746505398,
7143 2.57812056037881628390134077704127,
7144 2.60882970619319538196517982945269,
7145 2.63918540521920497868347679257107,
7146 2.66919945330942891495458446613851,
7147 2.69888301230439621709803756505788,
7148 2.72824665609081486737132853370048,
7149 2.75730041251405791603760003778285,
7150 2.78605380158311346185098508516203,
7151 2.81451587035387403267676338931454,
7152 2.84269522483114290814009184272637,
7153 2.87060005919012917988363332454033,
7154 2.89823818258367657739520912946934,
7155 2.92561704377132528239806135133273,
7156 2.95274375377994262301217318010209,
7157 2.97962510678256471794289060402033,
7158 3.00626759936182712291041810228171,
7159 3.03267744830655121818899164295959,
7160 3.05886060707437081434964933864149 };
7161 static doublereal xmax6[53] = { 1.21091229812484768570102219548814,
7162 1.11626917091567929907256116528817,
7163 1.1327140810290884106278510474203,
7164 1.1679452722668028753522098022171,
7165 1.20910611986279066645602153641334,
7166 1.25228283758701572089625983127043,
7167 1.29591971597287895911380446311508,
7168 1.3393138157481884258308028584917,
7169 1.3821288728999671920677617491385,
7170 1.42420414683357356104823573391816,
7171 1.46546895108549501306970087318319,
7172 1.50590085198398789708599726315869,
7173 1.54550385142820987194251585145013,
7174 1.58429644271680300005206185490937,
7175 1.62230484071440103826322971668038,
7176 1.65955905239130512405565733793667,
7177 1.69609056468292429853775667485212,
7178 1.73193098017228915881592458573809,
7179 1.7671112206990325429863426635397,
7180 1.80166107681586964987277458875667,
7181 1.83560897003644959204940535551721,
7182 1.86898184653271388435058371983316,
7183 1.90180515174518670797686768515502,
7184 1.93410285411785808749237200054739,
7185 1.96589749778987993293150856865539,
7186 1.99721027139062501070081653790635,
7187 2.02806108474738744005306947877164,
7188 2.05846864831762572089033752595401,
7189 2.08845055210580131460156962214748,
7190 2.11802334209486194329576724042253,
7191 2.14720259305166593214642386780469,
7192 2.17600297710595096918495785742803,
7193 2.20443832785205516555772788192013,
7194 2.2325216999457379530416998244706,
7195 2.2602654243075083168599953074345,
7196 2.28768115912702794202525264301585,
7197 2.3147799369092684021274946755348,
7198 2.34157220782483457076721300512406,
7199 2.36806787963276257263034969490066,
7200 2.39427635443992520016789041085844,
7201 2.42020656255081863955040620243062,
7202 2.44586699364757383088888037359254,
7203 2.47126572552427660024678584642791,
7204 2.49641045058324178349347438430311,
7205 2.52130850028451113942299097584818,
7206 2.54596686772399937214920135190177,
7207 2.5703922285006754089328998222275,
7208 2.59459096001908861492582631591134,
7209 2.61856915936049852435394597597773,
7210 2.64233265984385295286445444361827,
7211 2.66588704638685848486056711408168,
7212 2.68923766976735295746679957665724,
7213 2.71238965987606292679677228666411 };
7214
7215 /* System generated locals */
7216 integer i__1;
7217
7218 /* Local variables */
7219 static logical ldbg;
7220 static integer numax, ii;
7221 static doublereal bid;
7222
7223
7224/* **********************************************************************
7225*/
7226
0d969553 7227/* FUNCTION : */
7fd59977 7228/* ---------- */
0d969553
Y		 7229/* Calculate the max of Jacobo polynoms multiplied by the weight on */
7230/* (-1,1) for order 0,4,6 or Legendre. */
7fd59977 7231
0d969553 7232/* KEYWORDSS : */
7fd59977 7233/* ----------- */
7234/* LEGENDRE,APPROXIMATION,ERREUR. */
7235
0d969553 7236/* INPUT ARGUMENTS : */
7fd59977 7237/* ------------------ */
0d969553
Y		 7238/* NDGJAC: Nb of Jacobi coeff. of approximation. */
7239/* IORDRE: Order of continuity (from -1 to 2) */
7fd59977 7240
0d969553 7241/* OUTPUT ARGUMENTS : */
7fd59977 7242/* ------------------- */
0d969553 7243/* XJACMX: Table of maximums of Jacobi polynoms. */
7fd59977 7244
0d969553 7245/* COMMONS USED : */
7fd59977 7246/* ---------------- */
7247
0d969553
Y		 7248/* REFERENCES CALLED : */
7249/* --------------------- */
7fd59977 7250
0d969553 7251/* DESCRIPTION/NOTES/LIMITATIONS : */
7fd59977 7252/* ----------------------------------- */
7253
7fd59977 7254/* > */
7255/* ***********************************************************************
7256 */
0d969553 7257/* Name of the routine */
7fd59977 7258/* ----------------------------- Initialisations ------------------------
7259*/
7260
7261 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 3;
7262 if (ldbg) {
7263 AdvApp2Var_SysBase::mgenmsg_("MMA2JMX", 7L);
7264 }
7265
7266 numax = *ndgjac - ((*iordre + 1) << 1);
7267 if (*iordre == -1) {
7268 i__1 = numax;
7269 for (ii = 0; ii <= i__1; ++ii) {
7270 bid = (ii * 2. + 1.) / 2.;
7271 xjacmx[ii] = sqrt(bid);
7272/* L100: */
7273 }
7274 } else if (*iordre == 0) {
7275 i__1 = numax;
7276 for (ii = 0; ii <= i__1; ++ii) {
7277 xjacmx[ii] = xmax2[ii];
7278/* L200: */
7279 }
7280 } else if (*iordre == 1) {
7281 i__1 = numax;
7282 for (ii = 0; ii <= i__1; ++ii) {
7283 xjacmx[ii] = xmax4[ii];
7284/* L400: */
7285 }
7286 } else if (*iordre == 2) {
7287 i__1 = numax;
7288 for (ii = 0; ii <= i__1; ++ii) {
7289 xjacmx[ii] = xmax6[ii];
7290/* L600: */
7291 }
7292 }
7293
7294/* ------------------------- The end ------------------------------------
7295*/
7296
7297 if (ldbg) {
7298 AdvApp2Var_SysBase::mgsomsg_("MMA2JMX", 7L);
7299 }
7300 return 0;
7301} /* mma2jmx_ */
7302
7303//=======================================================================
7304//function : mma2moy_
7305//purpose :
7306//=======================================================================
7307int mma2moy_(integer *ndgumx,
7308 integer *ndgvmx,
7309 integer *ndimen,
7310 integer *mindgu,
7311 integer *maxdgu,
7312 integer *mindgv,
7313 integer *maxdgv,
7314 integer *iordru,
7315 integer *iordrv,
7316 doublereal *patjac,
7317 doublereal *errmoy)
7318{
7319 /* System generated locals */
7320 integer patjac_dim1, patjac_dim2, patjac_offset, i__1, i__2, i__3;
7321
7322 /* Local variables */
7323 static logical ldbg;
7324 static integer minu, minv, idebu, idebv, ii, nd, jj;
7325 static doublereal bid0, bid1;
7326
7327
7328/* **********************************************************************
7329*/
7330
0d969553 7331/* FUNCTION : */
7fd59977 7332/* ---------- */
0d969553
Y		 7333/* Calculate the average approximation error made when only */
7334/* the coefficients of PATJAC of degree between */
7335/* 2*(IORDRU+1) and MINDGU by U and 2*(IORDRV+1) and MINDGV by V are preserved. */
7fd59977 7336
0d969553 7337/* KEYWORDS : */
7fd59977 7338/* ----------- */
0d969553 7339/* LEGENDRE,APPROXIMATION, AVERAGE ERROR */
7fd59977 7340
0d969553 7341/* INPUT ARGUMENTS : */
7fd59977 7342/* ------------------ */
0d969553
Y		 7343/* NDGUMX: Dimension by U of table PATJAC. */
7344/* NDGVMX: Dimension by V of table PATJAC. */
7345/* NDIMEN: Dimension of the space. */
7346/* MINDGU: Lower limit of the index by U of PATJAC coeff to be taken into account. */
7347/* MAXDGU: Upper limit of the index by U of PATJAC coeff to be taken into account. */
7348/* MINDGV: Lower limit of the index by V of PATJAC coeff to be taken into account. */
7349/* MAXDGV: Upper limit of the index by V of PATJAC coeff to be taken into account. */
7350/* IORDRU: Order of continuity by U provided by square PATJAC (from -1 to 2) */
7351/* IORDRV: Order of continuity by V provided by square PATJAC (from -1 to 2) */
7352/* PATJAC: Table of coeff. of the approximation square with */
7353/* constraints of order IORDRU by U and IORDRV by V. */
7354
7355/* OUTPUT ARGUMENTS : */
7fd59977 7356/* ------------------- */
0d969553
Y		 7357/* ERRMOY: Average error commited by preserving only the coeff of */
7358/* PATJAC 2*(IORDRU+1) in MINDGU by U and 2*(IORDRV+1) in MINDGV by V. */
7fd59977 7359
0d969553 7360/* COMMONS USED : */
7fd59977 7361/* ---------------- */
7362
0d969553
Y		 7363/* REFERENCES CALLED : */
7364/* --------------------- */
7fd59977 7365
0d969553 7366/* DESCRIPTION/NOTES/LIMITATIONS : */
7fd59977 7367/* ----------------------------------- */
0d969553
Y		 7368/* Table PATJAC stores the coeff. Cij of */
7369/* approximation square F(U,V). Indexes i and j show the degree by */
7370/* U and by V of the base polynoms. These base polynoms are in the form: */
7fd59977 7371
0d969553 7372/* ((1 - U*U)**(IORDRU+1)).J(i-2*(IORDRU+1)(U), where */
7fd59977 7373
0d969553
Y		 7374/* polynom J(i-2*(IORDU+1)(U) is the Jacobi polynom of order */
7375/* IORDRU+1 (the same by V by replacing U by V in the above expression). */
7fd59977 7376
0d969553
Y		 7377/* The contribution to the average error of term Cij when */
7378/* it is removed from PATJAC is Cij*Cij. */
7fd59977 7379
7fd59977 7380/* > */
7381/* ***********************************************************************
7382 */
0d969553 7383/* Name of the routine */
7fd59977 7384
7385
7386/* ----------------------------- Initialisations ------------------------
7387*/
7388
7389 /* Parameter adjustments */
7390 patjac_dim1 = *ndgumx + 1;
7391 patjac_dim2 = *ndgvmx + 1;
7392 patjac_offset = patjac_dim1 * patjac_dim2;
7393 patjac -= patjac_offset;
7394
7395 /* Function Body */
7396 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 3;
7397 if (ldbg) {
7398 AdvApp2Var_SysBase::mgenmsg_("MMA2MOY", 7L);
7399 }
7400
7401 idebu = (*iordru + 1) << 1;
7402 idebv = (*iordrv + 1) << 1;
7403 minu = max(idebu,*mindgu);
7404 minv = max(idebv,*mindgv);
7405 bid0 = 0.;
7406 *errmoy = 0.;
7407
0d969553
Y		 7408/* ------------------ Calculation of the upper bound of the average error ------------ */
7409/* -------------------- when the coeff. of indexes from MINDGU to MAXDGU ------ */
7410/* ---------------- by U and of indexes from MINDGV to MAXDGV by V are removed -------------- */
7fd59977 7411
7412 i__1 = *ndimen;
7413 for (nd = 1; nd <= i__1; ++nd) {
7414 i__2 = *maxdgv;
7415 for (jj = minv; jj <= i__2; ++jj) {
7416 i__3 = *maxdgu;
7417 for (ii = idebu; ii <= i__3; ++ii) {
7418 bid1 = patjac[ii + (jj + nd * patjac_dim2) * patjac_dim1];
7419 bid0 += bid1 * bid1;
7420/* L300: */
7421 }
7422/* L200: */
7423 }
7424/* L100: */
7425 }
7426
7427 i__1 = *ndimen;
7428 for (nd = 1; nd <= i__1; ++nd) {
7429 i__2 = minv - 1;
7430 for (jj = idebv; jj <= i__2; ++jj) {
7431 i__3 = *maxdgu;
7432 for (ii = minu; ii <= i__3; ++ii) {
7433 bid1 = patjac[ii + (jj + nd * patjac_dim2) * patjac_dim1];
7434 bid0 += bid1 * bid1;
7435/* L600: */
7436 }
7437/* L500: */
7438 }
7439/* L400: */
7440 }
7441
0d969553 7442/* ----------------------- Calculation of the average error -------------
7fd59977 7443*/
7444
7445 bid0 /= 4;
7446 *errmoy = sqrt(bid0);
7447
7448/* ------------------------- The end ------------------------------------
7449*/
7450
7451 if (ldbg) {
7452 AdvApp2Var_SysBase::mgsomsg_("MMA2MOY", 7L);
7453 }
7454 return 0;
7455} /* mma2moy_ */
7456
7457//=======================================================================
7458//function : mma2roo_
7459//purpose :
7460//=======================================================================
7461int AdvApp2Var_ApproxF2var::mma2roo_(integer *nbpntu,
7462 integer *nbpntv,
7463 doublereal *urootl,
7464 doublereal *vrootl)
7465{
7466 /* System generated locals */
7467 integer i__1;
7468
7469 /* Local variables */
7470 static integer ii, ibb;
7471
7472/* **********************************************************************
7473*/
7474
0d969553 7475/* FUNCTION : */
7fd59977 7476/* ---------- */
0d969553 7477/* Return roots of Legendre for discretisations. */
7fd59977 7478
0d969553 7479/* KEYWORDS : */
7fd59977 7480/* ----------- */
7481/* TOUS, AB_SPECIFI::CONTRAINTE&, DISCRETISATION, &POINT */
7482
0d969553 7483/* INPUT ARGUMENTS : */
7fd59977 7484/* ------------------ */
0d969553
Y		 7485/* NBPNTU: Nb of INTERNAL parameters of discretization BY U. */
7486/* This is also the nb of root of the Legendre polynom where the discretization is done. */
7487/* NBPNTV: Nb of INTERNAL parameters of discretization BY V. */
7488/* This is also the nb of root of the Legendre polynom where the discretization is done. */
7fd59977 7489
0d969553 7490/* OUTPUT ARGUMENTS : */
7fd59977 7491/* ------------------- */
0d969553 7492/* UROOTL: Table of parameters of discretisation ON (-1,1) BY U.
7fd59977 7493*/
0d969553 7494/* VROOTL: Table of parameters of discretisation ON (-1,1) BY V.
7fd59977 7495*/
7496
0d969553 7497/* COMMONS USED : */
7fd59977 7498/* ---------------- */
7499
0d969553
Y		 7500/* REFERENCES CALLED : */
7501/* --------------------- */
7fd59977 7502
0d969553 7503/* DESCRIPTION/NOTES/LIMITATIONS : */
7fd59977 7504/* ----------------------------------- */
7505
7fd59977 7506/* > */
7507/* **********************************************************************
7508*/
7509
0d969553 7510/* Name of the routine */
7fd59977 7511
7512
7513 /* Parameter adjustments */
7514 --urootl;
7515 --vrootl;
7516
7517 /* Function Body */
7518 ibb = AdvApp2Var_SysBase::mnfndeb_();
7519 if (ibb >= 3) {
7520 AdvApp2Var_SysBase::mgenmsg_("MMA2ROO", 7L);
7521 }
7522
0d969553 7523/* ---------------- Return the POSITIVE roots on U ------------------
7fd59977 7524*/
7525
7526 AdvApp2Var_MathBase::mmrtptt_(nbpntu, &urootl[(*nbpntu + 1) / 2 + 1]);
7527 i__1 = *nbpntu / 2;
7528 for (ii = 1; ii <= i__1; ++ii) {
7529 urootl[ii] = -urootl[*nbpntu - ii + 1];
7530/* L100: */
7531 }
7532 if (*nbpntu % 2 == 1) {
7533 urootl[*nbpntu / 2 + 1] = 0.;
7534 }
7535
0d969553 7536/* ---------------- Return the POSITIVE roots on V ------------------
7fd59977 7537*/
7538
7539 AdvApp2Var_MathBase::mmrtptt_(nbpntv, &vrootl[(*nbpntv + 1) / 2 + 1]);
7540 i__1 = *nbpntv / 2;
7541 for (ii = 1; ii <= i__1; ++ii) {
7542 vrootl[ii] = -vrootl[*nbpntv - ii + 1];
7543/* L110: */
7544 }
7545 if (*nbpntv % 2 == 1) {
7546 vrootl[*nbpntv / 2 + 1] = 0.;
7547 }
7548
7549/* ------------------------------ The End -------------------------------
7550*/
7551
7552 if (ibb >= 3) {
7553 AdvApp2Var_SysBase::mgsomsg_("MMA2ROO", 7L);
7554 }
7555 return 0;
7556} /* mma2roo_ */
7557//=======================================================================
7558//function : mmmapcoe_
7559//purpose :
7560//=======================================================================
7561int mmmapcoe_(integer *ndim,
7562 integer *ndgjac,
7563 integer *iordre,
7564 integer *nbpnts,
7565 doublereal *somtab,
7566 doublereal *diftab,
7567 doublereal *gsstab,
7568 doublereal *crvjac)
7569
7570{
7571 /* System generated locals */
7572 integer somtab_dim1, somtab_offset, diftab_dim1, diftab_offset,
7573 crvjac_dim1, crvjac_offset, gsstab_dim1, i__1, i__2, i__3;
7574
7575 /* Local variables */
7576 static integer igss, ikdeb;
7577 static doublereal bidon;
7578 static integer nd, ik, ir, nbroot, ibb;
7579
7580
7581
7582/* **********************************************************************
7583*/
7584
0d969553 7585/* FUNCTION : */
7fd59977 7586/* ---------- */
0d969553
Y		 7587/* Calculate the coefficients of polinomial approximation curve */
7588/* of degree NDGJAC by the method of smallest squares starting from */
7589/* the discretization of function on the roots of Legendre polynom */
7590/* of degree NBPNTS. */
7fd59977 7591
0d969553 7592/* KEYWORDS : */
7fd59977 7593/* ----------- */
7594/* FONCTION,APPROXIMATION,COEFFICIENT,POLYNOME */
7595
0d969553 7596/* INPUT ARGUMENTS : */
7fd59977 7597/* ------------------ */
0d969553
Y		 7598/* NDIM : Dimension of the space. */
7599/* NDGJAC : Max Degree of the polynom of approximation. */
7600/* The representation in the orthogonal base starts from degree */
7601/* 0 to degree NDGJAC-2*(JORDRE+1). The polynomial base */
7602/* is the base of Jacobi of order -1 (Legendre), 0, 1 and 2 */
7603/* IORDRE : Order of the base of Jacobi (-1,0,1 or 2). Corresponds */
7604/* to step of constraints, C0,C1 or C2. */
7605/* NBPNTS : Degree of the polynom of Legendre on the roots which of */
7606/* are calculated the coefficients of integration by */
7607/* Gauss method. It is required to set NBPNTS=30,40,50 or 61 */
7608/* and NDGJAC < NBPNTS. */
7609/* SOMTAB : Table of F(ti)+F(-ti) with ti in ROOTAB. */
7610/* DIFTAB : Table of F(ti)-F(-ti) with ti in ROOTAB. */
7611/* GSSTAB(i,k) : Table of coefficients of integration by the Gauss method : */
7612/* i varies from 0 to NBPNTS and */
7613/* k varies from 0 to NDGJAC-2*(JORDRE+1). */
7614
7615/* OUTPUT ARGUMENTSE : */
7fd59977 7616/* ------------------- */
0d969553
Y		 7617/* CRVJAC : Curve of approximation of FONCNP with eventually */
7618/* taking into account of constraints at the extremities. */
7619/* This curve is of degree NDGJAC. */
7fd59977 7620
0d969553 7621/* COMMONS USED : */
7fd59977 7622/* ---------------- */
7623
0d969553
Y		 7624/* REFERENCES CALLED : */
7625/* --------------------- */
7fd59977 7626
0d969553
Y		 7627/* DESCRIPTION/NOTES/LIMITATIONS : */
7628/* ------------------------------- */
7fd59977 7629/* > */
7630/* **********************************************************************
7631*/
7632
0d969553 7633/* Name of the routine */
7fd59977 7634
7635 /* Parameter adjustments */
7636 crvjac_dim1 = *ndgjac + 1;
7637 crvjac_offset = crvjac_dim1;
7638 crvjac -= crvjac_offset;
7639 gsstab_dim1 = *nbpnts / 2 + 1;
7640 diftab_dim1 = *nbpnts / 2 + 1;
7641 diftab_offset = diftab_dim1;
7642 diftab -= diftab_offset;
7643 somtab_dim1 = *nbpnts / 2 + 1;
7644 somtab_offset = somtab_dim1;
7645 somtab -= somtab_offset;
7646
7647 /* Function Body */
7648 ibb = AdvApp2Var_SysBase::mnfndeb_();
7649 if (ibb >= 2) {
7650 AdvApp2Var_SysBase::mgenmsg_("MMMAPCO", 7L);
7651 }
7652 ikdeb = (*iordre + 1) << 1;
7653 nbroot = *nbpnts / 2;
7654
7655 i__1 = *ndim;
7656 for (nd = 1; nd <= i__1; ++nd) {
7657
0d969553 7658/* ----------------- Calculate the coefficients of even degree ----------
7fd59977 7659---- */
7660
7661 i__2 = *ndgjac;
7662 for (ik = ikdeb; ik <= i__2; ik += 2) {
7663 igss = ik - ikdeb;
7664 bidon = 0.;
7665 i__3 = nbroot;
7666 for (ir = 1; ir <= i__3; ++ir) {
7667 bidon += somtab[ir + nd * somtab_dim1] * gsstab[ir + igss *
7668 gsstab_dim1];
7669/* L300: */
7670 }
7671 crvjac[ik + nd * crvjac_dim1] = bidon;
7672/* L200: */
7673 }
7674
0d969553 7675/* --------------- Calculate the coefficients of uneven degree ----------
7fd59977 7676---- */
7677
7678 i__2 = *ndgjac;
7679 for (ik = ikdeb + 1; ik <= i__2; ik += 2) {
7680 igss = ik - ikdeb;
7681 bidon = 0.;
7682 i__3 = nbroot;
7683 for (ir = 1; ir <= i__3; ++ir) {
7684 bidon += diftab[ir + nd * diftab_dim1] * gsstab[ir + igss *
7685 gsstab_dim1];
7686/* L500: */
7687 }
7688 crvjac[ik + nd * crvjac_dim1] = bidon;
7689/* L400: */
7690 }
7691
7692/* L100: */
7693 }
7694
0d969553
Y		 7695/* ------- Add terms connected to the supplementary root (0.D0) ------ */
7696/* ----------- of Legendre polynom of uneven degree NBPNTS -----------
7fd59977 7697*/
7698
7699 if (*nbpnts % 2 == 0) {
7700 goto L9999;
7701 }
7702 i__1 = *ndim;
7703 for (nd = 1; nd <= i__1; ++nd) {
7704 i__2 = *ndgjac;
7705 for (ik = ikdeb; ik <= i__2; ik += 2) {
7706 igss = ik - ikdeb;
7707 crvjac[ik + nd * crvjac_dim1] += somtab[nd * somtab_dim1] *
7708 gsstab[igss * gsstab_dim1];
7709/* L700: */
7710 }
7711/* L600: */
7712 }
7713
7714/* ------------------------------ The end -------------------------------
7715*/
7716
7717L9999:
7718 if (ibb >= 2) {
7719 AdvApp2Var_SysBase::mgsomsg_("MMMAPCO", 7L);
7720 }
7721 return 0;
7722} /* mmmapcoe_ */
7723//=======================================================================
7724//function : mmaperm_
7725//purpose :
7726//=======================================================================
7727int mmaperm_(integer *ncofmx,
7728 integer *ndim,
7729 integer *ncoeff,
7730 integer *iordre,
7731 doublereal *crvjac,
7732 integer *ncfnew,
7733 doublereal *errmoy)
7734{
7735 /* System generated locals */
7736 integer crvjac_dim1, crvjac_offset, i__1, i__2;
7737
7738 /* Local variables */
7739 static doublereal bidj;
7740 static integer i__, ia, nd, ncfcut, ibb;
7741 static doublereal bid;
7742
7743
7744
7745/* **********************************************************************
7746*/
7747
0d969553 7748/* FUNCTION : */
7fd59977 7749/* ---------- */
0d969553
Y		 7750/* Calculate the square root of the average quadratic error */
7751/* of approximation done when only the */
7752/* first NCFNEW coefficients of a curve of degree NCOEFF-1 */
7753/* written in NORMALIZED Jacobi base of order 2*(IORDRE+1) are preserved. */
7fd59977 7754
0d969553 7755/* KEYWORDS : */
7fd59977 7756/* ----------- */
7757/* LEGENDRE,POLYGONE,APPROXIMATION,ERREUR. */
7758
0d969553 7759/* INPUT ARGUMENTS : */
7fd59977 7760/* ------------------ */
0d969553
Y		 7761/* NCOFMX : Maximum degree of the curve. */
7762/* NDIM : Dimension of the space. */
7763/* NCOEFF : Degree +1 of the curve. */
7764/* IORDRE : Order of constraint of continuity at the extremities. */
7765/* CRVJAC : The curve the degree which of will be lowered. */
7766/* NCFNEW : Degree +1 of the resulting polynom. */
7767
7768/* OUTPUT ARGUMENTS : */
7fd59977 7769/* ------------------- */
0d969553 7770/* ERRMOY : Average precision of approximation. */
7fd59977 7771
0d969553 7772/* COMMONS USED : */
7fd59977 7773/* ---------------- */
7774
0d969553 7775/* REFERENCES CALLED : */
7fd59977 7776/* ----------------------- */
7777
0d969553 7778/* DESCRIPTION/NOTES/LIMITATIONS : */
7fd59977 7779/* ----------------------------------- */
7fd59977 7780/* > */
7781/* ***********************************************************************
7782 */
7783
0d969553 7784/* Name of the routine */
7fd59977 7785
7786 /* Parameter adjustments */
7787 crvjac_dim1 = *ncofmx;
7788 crvjac_offset = crvjac_dim1 + 1;
7789 crvjac -= crvjac_offset;
7790
7791 /* Function Body */
7792 ibb = AdvApp2Var_SysBase::mnfndeb_();
7793 if (ibb >= 2) {
7794 AdvApp2Var_SysBase::mgenmsg_("MMAPERM", 7L);
7795 }
7796
0d969553 7797/* --------- Minimum degree that can be reached : Stop at 1 or IA -------
7fd59977 7798*/
7799
7800 ia = (*iordre + 1) << 1;
7801 ncfcut = ia + 1;
7802 if (*ncfnew + 1 > ncfcut) {
7803 ncfcut = *ncfnew + 1;
7804 }
7805
0d969553
Y		 7806/* -------------- Elimination of coefficients of high degree ------------ */
7807/* ----------- Loop on the series of Jacobi :NCFCUT --> NCOEFF --------- */
7fd59977 7808
7809 *errmoy = 0.;
7810 bid = 0.;
7811 i__1 = *ndim;
7812 for (nd = 1; nd <= i__1; ++nd) {
7813 i__2 = *ncoeff;
7814 for (i__ = ncfcut; i__ <= i__2; ++i__) {
7815 bidj = crvjac[i__ + nd * crvjac_dim1];
7816 bid += bidj * bidj;
7817/* L200: */
7818 }
7819/* L100: */
7820 }
7821
0d969553 7822/* ----------- Square Root of average quadratic error e -----------
7fd59977 7823*/
7824
7825 bid /= 2.;
7826 *errmoy = sqrt(bid);
7827
7828/* ------------------------------- The end ------------------------------
7829*/
7830
7831 if (ibb >= 2) {
7832 AdvApp2Var_SysBase::mgsomsg_("MMAPERM", 7L);
7833 }
7834 return 0;
7835} /* mmaperm_ */
7836//=======================================================================
7837//function : mmapptt_
7838//purpose :
7839//=======================================================================
7840int AdvApp2Var_ApproxF2var::mmapptt_(const integer *ndgjac,
7841 const integer *nbpnts,
7842 const integer *jordre,
7843 doublereal *cgauss,
7844 integer *iercod)
7845{
7846 /* System generated locals */
7847 integer cgauss_dim1, i__1;
7848
7849 /* Local variables */
7850 static integer kjac, iptt, ipdb0, infdg, iptdb, mxjac, ilong, ibb;
7851
7852
7853
7854/* **********************************************************************
7855*/
7856
0d969553 7857/* FUNCTION : */
7fd59977 7858/* ---------- */
0d969553
Y		 7859/* Load the elements required for integration by */
7860/* Gauss method to obtain the coefficients in the base of
7861/* Legendre of the approximation by the least squares of a */
7862/* function. The elements are stored in commons MMAPGSS */
7863/* (case without constraint), MMAPGS0 (constraints C0), MMAPGS1 */
7864/* (constraints C1) and MMAPGS2 (constraints C2). */
7865
7866/* KEYWORDS : */
7fd59977 7867/* ----------- */
7868/* INTEGRATION,GAUSS,JACOBI */
7869
0d969553 7870/* INPUT ARGUMENTS : */
7fd59977 7871/* ------------------ */
0d969553
Y		 7872/* NDGJAC : Max degree of the polynom of approximation. */
7873/* The representation in orthogonal base goes from degree
7874/* 0 to degree NDGJAC-2*(JORDRE+1). The polynomial base */
7875/* is the base of Jacobi of order -1 (Legendre), 0, 1 and 2 */
7876/* NBPNTS : Degree of the polynom of Legendre on the roots which of */
7877/* are calculated the coefficients of integration by the */
7878/* method of Gauss. It is required that NBPNTS=8,10,15,20,25, */
7879/* 30,40,50 or 61 and NDGJAC < NBPNTS. */
7880/* JORDRE : Order of the base of Jacobi (-1,0,1 or 2). Corresponds */
7881/* to step of constraints C0,C1 or C2. */
7882
7883/* OUTPUT ARGUMENTS : */
7fd59977 7884/* ------------------- */
0d969553
Y		 7885/* CGAUSS(i,k) : Table of coefficients of integration by */
7886/* Gauss method : i varies from 0 to the integer part */
7887/* of NBPNTS/2 and k varies from 0 to NDGJAC-2*(JORDRE+1). */
7888/* These are the coeff. of integration associated to */
7889/* positive roots of the polynom of Legendre of degree */
7890/* NBPNTS. CGAUSS(0,k) contains coeff. */
7891/* of integration associated to root t = 0 when */
7892/* NBPNTS is uneven. */
7893/* IERCOD : Error code. */
7fd59977 7894/* = 0 OK, */
0d969553
Y		 7895/* = 11 NBPNTS is not 8,10,15,20,25,30,40,50 or 61. */
7896/* = 21 JORDRE is not -1,0,1 or 2. */
7897/* = 31 NDGJAC is too great or too small. */
7fd59977 7898
0d969553 7899/* COMMONS USED : */
7fd59977 7900/* ---------------- */
7901/* MMAPGSS,MMAPGS0,MMAPGS1,MMAPGS2. */
7fd59977 7902/* ***********************************************************************
7903 */
7904 /* Parameter adjustments */
7905 cgauss_dim1 = *nbpnts / 2 + 1;
7906
7907 /* Function Body */
7908 ibb = AdvApp2Var_SysBase::mnfndeb_();
7909 if (ibb >= 2) {
7910 AdvApp2Var_SysBase::mgenmsg_("MMAPPTT", 7L);
7911 }
7912 *iercod = 0;
7913
0d969553 7914/* ------------------- Tests on the validity of inputs ----------------
7fd59977 7915*/
7916
7917 infdg = (*jordre + 1) << 1;
7918 if (*nbpnts != 8 && *nbpnts != 10 && *nbpnts != 15 && *nbpnts != 20 && *
7919 nbpnts != 25 && *nbpnts != 30 && *nbpnts != 40 && *nbpnts != 50 &&
7920 *nbpnts != 61) {
7921 goto L9100;
7922 }
7923
7924 if (*jordre < -1 || *jordre > 2) {
7925 goto L9200;
7926 }
7927
7928 if (*ndgjac >= *nbpnts || *ndgjac < infdg) {
7929 goto L9300;
7930 }
7931
0d969553 7932/* --------------- Calculation of the start pointer following NBPNTS -----------
7fd59977 7933*/
7934
7935 iptdb = 0;
7936 if (*nbpnts > 8) {
7937 iptdb += (8 - infdg) << 2;
7938 }
7939 if (*nbpnts > 10) {
7940 iptdb += (10 - infdg) * 5;
7941 }
7942 if (*nbpnts > 15) {
7943 iptdb += (15 - infdg) * 7;
7944 }
7945 if (*nbpnts > 20) {
7946 iptdb += (20 - infdg) * 10;
7947 }
7948 if (*nbpnts > 25) {
7949 iptdb += (25 - infdg) * 12;
7950 }
7951 if (*nbpnts > 30) {
7952 iptdb += (30 - infdg) * 15;
7953 }
7954 if (*nbpnts > 40) {
7955 iptdb += (40 - infdg) * 20;
7956 }
7957 if (*nbpnts > 50) {
7958 iptdb += (50 - infdg) * 25;
7959 }
7960
7961 ipdb0 = 1;
7962 if (*nbpnts > 15) {
7963 ipdb0 = ipdb0 + (14 - infdg) / 2 + 1;
7964 }
7965 if (*nbpnts > 25) {
7966 ipdb0 = ipdb0 + (24 - infdg) / 2 + 1;
7967 }
7968
0d969553 7969/* ------------------ Choice of the common depending on JORDRE -------------
7fd59977 7970*/
7971
7972 if (*jordre == -1) {
7973 goto L1000;
7974 }
7975 if (*jordre == 0) {
7976 goto L2000;
7977 }
7978 if (*jordre == 1) {
7979 goto L3000;
7980 }
7981 if (*jordre == 2) {
7982 goto L4000;
7983 }
7984
0d969553 7985/* ---------------- Common MMAPGSS (case without constraints) ----------------
7fd59977 7986 */
7987
7988L1000:
7989 ilong = *nbpnts / 2 << 3;
7990 i__1 = *ndgjac;
7991 for (kjac = 0; kjac <= i__1; ++kjac) {
7992 iptt = iptdb + kjac * (*nbpnts / 2) + 1;
7993 AdvApp2Var_SysBase::mcrfill_(&ilong,
7994 (char *)&mmapgss_.gslxjs[iptt - 1],
7995 (char *)&cgauss[kjac * cgauss_dim1 + 1]);
7996/* L100: */
7997 }
0d969553 7998/* --> Case when the number of points is uneven. */
7fd59977 7999 if (*nbpnts % 2 == 1) {
8000 iptt = ipdb0;
8001 i__1 = *ndgjac;
8002 for (kjac = 0; kjac <= i__1; kjac += 2) {
8003 cgauss[kjac * cgauss_dim1] = mmapgss_.gsl0js[iptt - 1];
8004 ++iptt;
8005/* L150: */
8006 }
8007 i__1 = *ndgjac;
8008 for (kjac = 1; kjac <= i__1; kjac += 2) {
8009 cgauss[kjac * cgauss_dim1] = 0.;
8010/* L160: */
8011 }
8012 }
8013 goto L9999;
8014
0d969553 8015/* ---------------- Common MMAPGS0 (case with constraints C0) -------------
7fd59977 8016 */
8017
8018L2000:
8019 mxjac = *ndgjac - infdg;
8020 ilong = *nbpnts / 2 << 3;
8021 i__1 = mxjac;
8022 for (kjac = 0; kjac <= i__1; ++kjac) {
8023 iptt = iptdb + kjac * (*nbpnts / 2) + 1;
8024 AdvApp2Var_SysBase::mcrfill_(&ilong,
8025 (char *)&mmapgs0_.gslxj0[iptt - 1],
8026 (char *)&cgauss[kjac * cgauss_dim1 + 1]);
8027/* L200: */
8028 }
0d969553 8029/* --> Case when the number of points is uneven. */
7fd59977 8030 if (*nbpnts % 2 == 1) {
8031 iptt = ipdb0;
8032 i__1 = mxjac;
8033 for (kjac = 0; kjac <= i__1; kjac += 2) {
8034 cgauss[kjac * cgauss_dim1] = mmapgs0_.gsl0j0[iptt - 1];
8035 ++iptt;
8036/* L250: */
8037 }
8038 i__1 = mxjac;
8039 for (kjac = 1; kjac <= i__1; kjac += 2) {
8040 cgauss[kjac * cgauss_dim1] = 0.;
8041/* L260: */
8042 }
8043 }
8044 goto L9999;
8045
0d969553 8046/* ---------------- Common MMAPGS1 (case with constraints C1) -------------
7fd59977 8047 */
8048
8049L3000:
8050 mxjac = *ndgjac - infdg;
8051 ilong = *nbpnts / 2 << 3;
8052 i__1 = mxjac;
8053 for (kjac = 0; kjac <= i__1; ++kjac) {
8054 iptt = iptdb + kjac * (*nbpnts / 2) + 1;
8055 AdvApp2Var_SysBase::mcrfill_(&ilong,
8056 (char *)&mmapgs1_.gslxj1[iptt - 1],
8057 (char *)&cgauss[kjac * cgauss_dim1 + 1]);
8058/* L300: */
8059 }
0d969553 8060/* --> Case when the number of points is uneven. */
7fd59977 8061 if (*nbpnts % 2 == 1) {
8062 iptt = ipdb0;
8063 i__1 = mxjac;
8064 for (kjac = 0; kjac <= i__1; kjac += 2) {
8065 cgauss[kjac * cgauss_dim1] = mmapgs1_.gsl0j1[iptt - 1];
8066 ++iptt;
8067/* L350: */
8068 }
8069 i__1 = mxjac;
8070 for (kjac = 1; kjac <= i__1; kjac += 2) {
8071 cgauss[kjac * cgauss_dim1] = 0.;
8072/* L360: */
8073 }
8074 }
8075 goto L9999;
8076
0d969553 8077/* ---------------- Common MMAPGS2 (case with constraints C2) -------------
7fd59977 8078 */
8079
8080L4000:
8081 mxjac = *ndgjac - infdg;
8082 ilong = *nbpnts / 2 << 3;
8083 i__1 = mxjac;
8084 for (kjac = 0; kjac <= i__1; ++kjac) {
8085 iptt = iptdb + kjac * (*nbpnts / 2) + 1;
8086 AdvApp2Var_SysBase::mcrfill_(&ilong,
8087 (char *)&mmapgs2_.gslxj2[iptt - 1],
8088 (char *)&cgauss[kjac * cgauss_dim1 + 1]);
8089/* L400: */
8090 }
0d969553 8091/* --> Cas of uneven number of points. */
7fd59977 8092 if (*nbpnts % 2 == 1) {
8093 iptt = ipdb0;
8094 i__1 = mxjac;
8095 for (kjac = 0; kjac <= i__1; kjac += 2) {
8096 cgauss[kjac * cgauss_dim1] = mmapgs2_.gsl0j2[iptt - 1];
8097 ++iptt;
8098/* L450: */
8099 }
8100 i__1 = mxjac;
8101 for (kjac = 1; kjac <= i__1; kjac += 2) {
8102 cgauss[kjac * cgauss_dim1] = 0.;
8103/* L460: */
8104 }
8105 }
8106 goto L9999;
8107
0d969553 8108/* ------------------------- Return the error code --------------
7fd59977 8109 */
0d969553 8110/* --> NBPNTS is not OK */
7fd59977 8111L9100:
8112 *iercod = 11;
8113 goto L9999;
0d969553 8114/* --> JORDRE is not OK */
7fd59977 8115L9200:
8116 *iercod = 21;
8117 goto L9999;
0d969553 8118/* --> NDGJAC is not OK */
7fd59977 8119L9300:
8120 *iercod = 31;
8121 goto L9999;
8122
8123/* -------------------------------- The end -----------------------------
8124*/
8125
8126L9999:
8127 if (*iercod > 0) {
8128 AdvApp2Var_SysBase::maermsg_("MMAPPTT", iercod, 7L);
8129 }
8130 if (ibb >= 2) {
8131 AdvApp2Var_SysBase::mgsomsg_("MMAPPTT", 7L);
8132 }
8133
8134 return 0 ;
8135} /* mmapptt_ */
8136
8137//=======================================================================
8138//function : mmjacpt_
8139//purpose :
8140//=======================================================================
8141int mmjacpt_(const integer *ndimen,
8142 const integer *ncoefu,
8143 const integer *ncoefv,
8144 const integer *iordru,
8145 const integer *iordrv,
8146 const doublereal *ptclgd,
8147 doublereal *ptcaux,
8148 doublereal *ptccan)
8149{
8150 /* System generated locals */
8151 integer ptccan_dim1, ptccan_dim2, ptccan_offset, ptclgd_dim1, ptclgd_dim2,
8152 ptclgd_offset, ptcaux_dim1, ptcaux_dim2, ptcaux_dim3,
8153 ptcaux_offset, i__1, i__2, i__3;
8154
8155 /* Local variables */
8156 static integer kdim, nd, ii, jj, ibb;
8157
8158/* ***********************************************************************
8159 */
8160
8161/* FONCTION : */
8162/* ---------- */
0d969553
Y		 8163/* Passage from canonical to Jacobi base for a */
8164/* "square" in a space of arbitrary dimension. */
7fd59977 8165
8166/* MOTS CLES : */
8167/* ----------- */
0d969553 8168/* SMOOTHING,BASE,LEGENDRE */
7fd59977 8169
8170
0d969553 8171/* INPUT ARGUMENTS : */
7fd59977 8172/* ------------------ */
0d969553
Y		 8173/* NDIMEN : Dimension of the space. */
8174/* NCOEFU : Degree+1 by U. */
8175/* NCOEFV : Degree+1 by V. */
8176/* IORDRU : Order of Jacobi polynoms by U. */
8177/* IORDRV : Order of Jacobi polynoms by V. */
8178/* PTCLGD : The square in the Jacobi base. */
8179
8180/* OUTPUT ARGUMENTS : */
7fd59977 8181/* ------------------- */
0d969553
Y		 8182/* PTCAUX : Auxilliary space. */
8183/* PTCCAN : The square in the canonic base (-1,1) */
7fd59977 8184
0d969553 8185/* COMMONS USED : */
7fd59977 8186/* ---------------- */
8187
0d969553 8188/* APPLIED REFERENCES : */
7fd59977 8189/* ----------------------- */
8190
0d969553 8191/* DESCRIPTION/NOTES/LIMITATIONS : */
7fd59977 8192/* ----------------------------------- */
0d969553 8193/* Cancels and replaces MJACPC */
7fd59977 8194
7fd59977 8195/* *********************************************************************
8196*/
0d969553 8197/* Name of the routine */
7fd59977 8198
8199
8200 /* Parameter adjustments */
8201 ptccan_dim1 = *ncoefu;
8202 ptccan_dim2 = *ncoefv;
8203 ptccan_offset = ptccan_dim1 * (ptccan_dim2 + 1) + 1;
8204 ptccan -= ptccan_offset;
8205 ptcaux_dim1 = *ncoefv;
8206 ptcaux_dim2 = *ncoefu;
8207 ptcaux_dim3 = *ndimen;
8208 ptcaux_offset = ptcaux_dim1 * (ptcaux_dim2 * (ptcaux_dim3 + 1) + 1) + 1;
8209 ptcaux -= ptcaux_offset;
8210 ptclgd_dim1 = *ncoefu;
8211 ptclgd_dim2 = *ncoefv;
8212 ptclgd_offset = ptclgd_dim1 * (ptclgd_dim2 + 1) + 1;
8213 ptclgd -= ptclgd_offset;
8214
8215 /* Function Body */
8216 ibb = AdvApp2Var_SysBase::mnfndeb_();
8217 if (ibb >= 3) {
8218 AdvApp2Var_SysBase::mgenmsg_("MMJACPT", 7L);
8219 }
8220
0d969553 8221/* Passage into canonical by u. */
7fd59977 8222
8223 kdim = *ndimen * *ncoefv;
8224 AdvApp2Var_MathBase::mmjaccv_((integer *)ncoefu,
8225 (integer *)&kdim,
8226 (integer *)iordru,
8227 (doublereal *)&ptclgd[ptclgd_offset],
8228 (doublereal *)&ptcaux[ptcaux_offset],
8229 (doublereal *)&ptccan[ptccan_offset]);
8230
0d969553 8231/* Swapping of u and v. */
7fd59977 8232
8233 i__1 = *ndimen;
8234 for (nd = 1; nd <= i__1; ++nd) {
8235 i__2 = *ncoefv;
8236 for (jj = 1; jj <= i__2; ++jj) {
8237 i__3 = *ncoefu;
8238 for (ii = 1; ii <= i__3; ++ii) {
8239 ptcaux[jj + (ii + (nd + ptcaux_dim3) * ptcaux_dim2) *
8240 ptcaux_dim1] = ptccan[ii + (jj + nd * ptccan_dim2) *
8241 ptccan_dim1];
8242/* L320: */
8243 }
8244/* L310: */
8245 }
8246/* L300: */
8247 }
8248
0d969553 8249/* Passage into canonical by v. */
7fd59977 8250
8251 kdim = *ndimen * *ncoefu;
8252 AdvApp2Var_MathBase::mmjaccv_((integer *)ncoefv,
8253 (integer *)&kdim,
8254 (integer *)iordrv,
8255 (doublereal *)&ptcaux[((ptcaux_dim3 + 1) * ptcaux_dim2 + 1) * ptcaux_dim1 + 1],
8256 (doublereal *)&ptccan[ptccan_offset],
8257 (doublereal *)&ptcaux[(((ptcaux_dim3 << 1) + 1) * ptcaux_dim2 + 1) * ptcaux_dim1 + 1]);
8258
0d969553 8259/* Swapping of u and v. */
7fd59977 8260
8261 i__1 = *ndimen;
8262 for (nd = 1; nd <= i__1; ++nd) {
8263 i__2 = *ncoefv;
8264 for (jj = 1; jj <= i__2; ++jj) {
8265 i__3 = *ncoefu;
8266 for (ii = 1; ii <= i__3; ++ii) {
8267 ptccan[ii + (jj + nd * ptccan_dim2) * ptccan_dim1] = ptcaux[
8268 jj + (ii + (nd + (ptcaux_dim3 << 1)) * ptcaux_dim2) *
8269 ptcaux_dim1];
8270/* L420: */
8271 }
8272/* L410: */
8273 }
8274/* L400: */
8275 }
8276
8277/* ---------------------------- THAT'S ALL FOLKS ------------------------
8278*/
8279
8280 if (ibb >= 3) {
8281 AdvApp2Var_SysBase::mgsomsg_("MMJACPT", 7L);
8282 }
8283 return 0;
8284} /* mmjacpt_ */
Open CASCADE Technology repository