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