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