0022906: Gradient background is clipped by planes
[occt.git] / src / AdvApp2Var / AdvApp2Var_ApproxF2var.cxx
CommitLineData
7fd59977 1//
2// AdvApp2Var_ApproxF2var.cxx
3//
4#include <math.h>
5#include <AdvApp2Var_SysBase.hxx>
6#include <AdvApp2Var_MathBase.hxx>
7#include <AdvApp2Var_Data_f2c.hxx>
8#include <AdvApp2Var_Data.hxx>
9#include <AdvApp2Var_ApproxF2var.hxx>
10
11
12static
13int mmjacpt_(const integer *ndimen,
14 const integer *ncoefu,
15 const integer *ncoefv,
16 const integer *iordru,
17 const integer *iordrv,
18 const doublereal *ptclgd,
19 doublereal *ptcaux,
20 doublereal *ptccan);
21
22
23
24static
25int mma2ce2_(integer *numdec,
26 integer *ndimen,
27 integer *nbsesp,
28 integer *ndimse,
29 integer *ndminu,
30 integer *ndminv,
31 integer *ndguli,
32 integer *ndgvli,
33 integer *ndjacu,
34 integer *ndjacv,
35 integer *iordru,
36 integer *iordrv,
37 integer *nbpntu,
38 integer *nbpntv,
39 doublereal *epsapr,
40 doublereal *sosotb,
41 doublereal *disotb,
42 doublereal *soditb,
43 doublereal *diditb,
44 doublereal *gssutb,
45 doublereal *gssvtb,
46 doublereal *xmaxju,
47 doublereal *xmaxjv,
48 doublereal *vecerr,
49 doublereal *chpair,
50 doublereal *chimpr,
51 doublereal *patjac,
52 doublereal *errmax,
53 doublereal *errmoy,
54 integer *ndegpu,
55 integer *ndegpv,
56 integer *itydec,
57 integer *iercod);
58
59static
60int mma2cfu_(integer *ndujac,
61 integer *nbpntu,
62 integer *nbpntv,
63 doublereal *sosotb,
64 doublereal *disotb,
65 doublereal *soditb,
66 doublereal *diditb,
67 doublereal *gssutb,
68 doublereal *chpair,
69 doublereal *chimpr);
70
71static
72int mma2cfv_(integer *ndvjac,
73 integer *mindgu,
74 integer *maxdgu,
75 integer *nbpntv,
76 doublereal *gssvtb,
77 doublereal *chpair,
78 doublereal *chimpr,
79 doublereal *patjac);
80
81static
82int mma2er1_(integer *ndjacu,
83 integer *ndjacv,
84 integer *ndimen,
85 integer *mindgu,
86 integer *maxdgu,
87 integer *mindgv,
88 integer *maxdgv,
89 integer *iordru,
90 integer *iordrv,
91 doublereal *xmaxju,
92 doublereal *xmaxjv,
93 doublereal *patjac,
94 doublereal *vecerr,
95 doublereal *erreur);
96
97static
98int mma2er2_(integer *ndjacu,
99 integer *ndjacv,
100 integer *ndimen,
101 integer *mindgu,
102 integer *maxdgu,
103 integer *mindgv,
104 integer *maxdgv,
105 integer *iordru,
106 integer *iordrv,
107 doublereal *xmaxju,
108 doublereal *xmaxjv,
109 doublereal *patjac,
110 doublereal *epmscut,
111 doublereal *vecerr,
112 doublereal *erreur,
113 integer *newdgu,
114 integer *newdgv);
115
116static
117int mma2moy_(integer *ndgumx,
118 integer *ndgvmx,
119 integer *ndimen,
120 integer *mindgu,
121 integer *maxdgu,
122 integer *mindgv,
123 integer *maxdgv,
124 integer *iordru,
125 integer *iordrv,
126 doublereal *patjac,
127 doublereal *errmoy);
128
129static
130int mma2ds2_(integer *ndimen,
131 doublereal *uintfn,
132 doublereal *vintfn,
133 void (*foncnp) (
134 int *,
135 double *,
136 double *,
137 int *,
138 double *,
139 int *,
140 double *,
141 int *,
142 int *,
143 double *,
144 int *
145 ),
146 integer *nbpntu,
147 integer *nbpntv,
148 doublereal *urootb,
149 doublereal *vrootb,
150 integer *iiuouv,
151 doublereal *sosotb,
152 doublereal *disotb,
153 doublereal *soditb,
154 doublereal *diditb,
155 doublereal *fpntab,
156 doublereal *ttable,
157 integer *iercod);
158
159
160
161
162static
163int mma1fdi_(integer *ndimen,
164 doublereal *uvfonc,
165 void (*foncnp) (// see AdvApp2Var_EvaluatorFunc2Var.hxx for details
166 int *,
167 double *,
168 double *,
169 int *,
170 double *,
171 int *,
172 double *,
173 int *,
174 int *,
175 double *,
176 int *
177 ),
178 integer *isofav,
179 doublereal *tconst,
180 integer *nbroot,
181 doublereal *ttable,
182 integer *iordre,
183 integer *ideriv,
184 doublereal *fpntab,
185 doublereal *somtab,
186 doublereal *diftab,
187 doublereal *contr1,
188 doublereal *contr2,
189 integer *iercod);
190
191static
192int mma1cdi_(integer *ndimen,
193 integer *nbroot,
194 doublereal *rootlg,
195 integer *iordre,
196 doublereal *contr1,
197 doublereal *contr2,
198 doublereal *somtab,
199 doublereal *diftab,
200 doublereal *fpntab,
201 doublereal *hermit,
202 integer *iercod);
203static
204int mma1jak_(integer *ndimen,
205 integer *nbroot,
206 integer *iordre,
207 integer *ndgjac,
208 doublereal *somtab,
209 doublereal *diftab,
210 doublereal *cgauss,
211 doublereal *crvjac,
212 integer *iercod);
213static
214int mma1cnt_(integer *ndimen,
215 integer *iordre,
216 doublereal *contr1,
217 doublereal *contr2,
218 doublereal *hermit,
219 integer *ndgjac,
220 doublereal *crvjac);
221
222static
223int mma1fer_(integer *ndimen,
224 integer *nbsesp,
225 integer *ndimse,
226 integer *iordre,
227 integer *ndgjac,
228 doublereal *crvjac,
229 integer *ncflim,
230 doublereal *epsapr,
231 doublereal *ycvmax,
232 doublereal *errmax,
233 doublereal *errmoy,
234 integer *ncoeff,
235 integer *iercod);
236
237static
238int mma1noc_(doublereal *dfuvin,
239 integer *ndimen,
240 integer *iordre,
241 doublereal *cntrin,
242 doublereal *duvout,
243 integer *isofav,
244 integer *ideriv,
245 doublereal *cntout);
246
247
248static
249 int mmmapcoe_(integer *ndim,
250 integer *ndgjac,
251 integer *iordre,
252 integer *nbpnts,
253 doublereal *somtab,
254 doublereal *diftab,
255 doublereal *gsstab,
256 doublereal *crvjac);
257
258static
259 int mmaperm_(integer *ncofmx,
260 integer *ndim,
261 integer *ncoeff,
262 integer *iordre,
263 doublereal *crvjac,
264 integer *ncfnew,
265 doublereal *errmoy);
266
267
268#define mmapgss_1 mmapgss_
269#define mmapgs0_1 mmapgs0_
270#define mmapgs1_1 mmapgs1_
271#define mmapgs2_1 mmapgs2_
272
273//=======================================================================
274//function : mma1cdi_
275//purpose :
276//=======================================================================
277int mma1cdi_(integer *ndimen,
278 integer *nbroot,
279 doublereal *rootlg,
280 integer *iordre,
281 doublereal *contr1,
282 doublereal *contr2,
283 doublereal *somtab,
284 doublereal *diftab,
285 doublereal *fpntab,
286 doublereal *hermit,
287 integer *iercod)
288{
289 static integer c__1 = 1;
290
291 /* System generated locals */
292 integer contr1_dim1, contr1_offset, contr2_dim1, contr2_offset,
293 somtab_dim1, somtab_offset, diftab_dim1, diftab_offset,
294 fpntab_dim1, fpntab_offset, hermit_dim1, hermit_offset, i__1,
295 i__2, i__3;
296
297 /* Local variables */
298 static integer nroo2, ncfhe, nd, ii, kk;
299 static integer ibb, kkm, kkp;
300 static doublereal bid1, bid2, bid3;
301
7fd59977 302/* **********************************************************************
303*/
0d969553 304/* FUNCTION : */
7fd59977 305/* ---------- */
0d969553
Y
306/* Discretisation on the parameters of interpolation polynomes */
307/* constraints of order IORDRE. */
7fd59977 308
0d969553 309/* KEYWORDS : */
7fd59977 310/* ----------- */
0d969553 311/* ALL, AB_SPECIFI::CONTRAINTE&, DISCRETISATION, &POINT */
7fd59977 312
0d969553 313/* INPUT ARGUMENTS : */
7fd59977 314/* ------------------ */
0d969553
Y
315/* NDIMEN: Space dimension. */
316/* NBROOT: Number of INTERNAL discretisation parameters. */
317/* It is also the root number Legendre polynome where */
318/* the discretization is performed. */
319/* ROOTLG: Table of discretization parameters ON (-1,1). */
320/* IORDRE: Order of constraint imposed to the extremities of the iso. */
321/* = 0, the extremities of the iso are calculated */
322/* = 1, additionally, the 1st derivative in the direction */
323/* of the iso is calculated. */
324/* = 2, additionally, the 2nd derivative in the direction */
325/* of the iso is calculated. */
326/* CONTR1: Contains, if IORDRE>=0, values IORDRE+1 in TTABLE(0)
327*/
328/* (1st extremity) of derivatives of F(Uc,Ve) or F(Ue,Vc), */
329/* see below. */
330/* CONTR2: Contains, if IORDRE>=0, values IORDRE+1 in */
331/* TTABLE(NBROOT+1) (2nd extremity) of: */
332/* If ISOFAV=1, derived of order IDERIV by U, derived */
333/* ordre 0 to IORDRE by V of F(Uc,Ve) or Uc=TCONST */
334/* (fixed iso value) and Ve is the fixed extremity. */
335/* If ISOFAV=2, derivative of order IDERIV by V, derivative */
336/* of order 0 to IORDRE by U of F(Ue,Vc) or Vc=TCONST */
337/* (fixed iso value) and Ue is the fixed extremity. */
338
339/* SOMTAB: Table of NBROOT/2 sums of 2 index points */
340/* NBROOT-II+1 and II, for II = 1, NBROOT/2. */
341/* DIFTAB: Table of NBROOT/2 differences of 2 index points */
342/* NBROOT-II+1 and II, for II = 1, NBROOT/2. */
343
344/* OUTPUT ARGUMENTS : */
7fd59977 345/* ------------------- */
0d969553
Y
346/* SOMTAB: Table of NBROOT/2 sums of 2 index points */
347/* NBROOT-II+1 and II, for II = 1, NBROOT/2 */
348/* DIFTAB: Table of NBROOT/2 differences of 2 index points */
349/* NBROOT-II+1 and II, for II = 1, NBROOT/2 */
350/* FPNTAB: Auxiliary table. */
351/* HERMIT: Table of coeff. 2*(IORDRE+1) Hermite polynoms */
352/* of degree 2*IORDRE+1. */
353/* IERCOD: Error code, */
354/* = 0, Everythig is OK */
355/* = 1, The value of IORDRE is out of (0,2) */
356/* COMMON USED : */
7fd59977 357/* ---------------- */
358
0d969553 359/* REFERENCES CALLED : */
7fd59977 360/* ----------------------- */
361
0d969553 362/* DESCRIPTION/NOTES/LIMITATIONS : */
7fd59977 363/* ----------------------------------- */
0d969553
Y
364/* The results of discretization are arranged in 2 tables */
365/* SOMTAB and DIFTAB to earn time during the */
366/* calculation of coefficients of the approximation curve. */
7fd59977 367
0d969553
Y
368/* If NBROOT is uneven in SOMTAB(0,*) and DIFTAB(0,*) one stores */
369/* the values of the median root of Legendre (0.D0 in (-1,1)). */
7fd59977 370
7fd59977 371/* **********************************************************************
372*/
373
0d969553 374/* Name of the routine */
7fd59977 375
376
377 /* Parameter adjustments */
378 diftab_dim1 = *nbroot / 2 + 1;
379 diftab_offset = diftab_dim1;
380 diftab -= diftab_offset;
381 somtab_dim1 = *nbroot / 2 + 1;
382 somtab_offset = somtab_dim1;
383 somtab -= somtab_offset;
384 --rootlg;
385 hermit_dim1 = (*iordre << 1) + 2;
386 hermit_offset = hermit_dim1;
387 hermit -= hermit_offset;
388 fpntab_dim1 = *nbroot;
389 fpntab_offset = fpntab_dim1 + 1;
390 fpntab -= fpntab_offset;
391 contr2_dim1 = *ndimen;
392 contr2_offset = contr2_dim1 + 1;
393 contr2 -= contr2_offset;
394 contr1_dim1 = *ndimen;
395 contr1_offset = contr1_dim1 + 1;
396 contr1 -= contr1_offset;
397
398 /* Function Body */
399 ibb = AdvApp2Var_SysBase::mnfndeb_();
400 if (ibb >= 3) {
401 AdvApp2Var_SysBase::mgenmsg_("MMA1CDI", 7L);
402 }
403 *iercod = 0;
404
0d969553 405/* --- Recuperate 2*(IORDRE+1) coeff of 2*(IORDRE+1) of Hermite polynom ---
7fd59977 406*/
407
408 AdvApp2Var_ApproxF2var::mma1her_(iordre, &hermit[hermit_offset], iercod);
409 if (*iercod > 0) {
410 goto L9100;
411 }
412
0d969553 413/* ------------------- Discretization of Hermite polynoms -----------
7fd59977 414*/
415
416 ncfhe = (*iordre + 1) << 1;
417 i__1 = ncfhe;
418 for (ii = 1; ii <= i__1; ++ii) {
419 i__2 = *nbroot;
420 for (kk = 1; kk <= i__2; ++kk) {
421 AdvApp2Var_MathBase::mmmpocur_(&ncfhe, &c__1, &ncfhe, &hermit[ii * hermit_dim1], &
422 rootlg[kk], &fpntab[kk + ii * fpntab_dim1]);
423/* L200: */
424 }
425/* L100: */
426 }
427
0d969553 428/* ---- Discretizations of boundary polynoms are taken ----
7fd59977 429*/
430
431 nroo2 = *nbroot / 2;
432 i__1 = *ndimen;
433 for (nd = 1; nd <= i__1; ++nd) {
434 i__2 = *iordre + 1;
435 for (ii = 1; ii <= i__2; ++ii) {
436 bid1 = contr1[nd + ii * contr1_dim1];
437 bid2 = contr2[nd + ii * contr2_dim1];
438 i__3 = nroo2;
439 for (kk = 1; kk <= i__3; ++kk) {
440 kkm = nroo2 - kk + 1;
441 bid3 = bid1 * fpntab[kkm + ((ii << 1) - 1) * fpntab_dim1] +
442 bid2 * fpntab[kkm + (ii << 1) * fpntab_dim1];
443 somtab[kk + nd * somtab_dim1] -= bid3;
444 diftab[kk + nd * diftab_dim1] += bid3;
445/* L500: */
446 }
447 i__3 = nroo2;
448 for (kk = 1; kk <= i__3; ++kk) {
449 kkp = (*nbroot + 1) / 2 + kk;
450 bid3 = bid1 * fpntab[kkp + ((ii << 1) - 1) * fpntab_dim1] +
451 bid2 * fpntab[kkp + (ii << 1) * fpntab_dim1];
452 somtab[kk + nd * somtab_dim1] -= bid3;
453 diftab[kk + nd * diftab_dim1] -= bid3;
454/* L600: */
455 }
456/* L400: */
457 }
458/* L300: */
459 }
460
0d969553 461/* ------------ Cas when discretization is done on the roots of a -----------
7fd59977 462*/
0d969553 463/* ---------- Legendre polynom of uneven degree, 0 is root --------
7fd59977 464*/
465
466 if (*nbroot % 2 == 1) {
467 i__1 = *ndimen;
468 for (nd = 1; nd <= i__1; ++nd) {
469 i__2 = *iordre + 1;
470 for (ii = 1; ii <= i__2; ++ii) {
471 bid3 = fpntab[nroo2 + 1 + ((ii << 1) - 1) * fpntab_dim1] *
472 contr1[nd + ii * contr1_dim1] + fpntab[nroo2 + 1 + (
473 ii << 1) * fpntab_dim1] * contr2[nd + ii *
474 contr2_dim1];
475/* L800: */
476 }
477 somtab[nd * somtab_dim1] -= bid3;
478 diftab[nd * diftab_dim1] -= bid3;
479/* L700: */
480 }
481 }
482
483 goto L9999;
484
485/* ------------------------------ The End -------------------------------
486*/
0d969553 487/* --> IORDRE is not in the authorized zone. */
7fd59977 488L9100:
489 *iercod = 1;
490 goto L9999;
491
492L9999:
493 if (ibb >= 3) {
494 AdvApp2Var_SysBase::mgsomsg_("MMA1CDI", 7L);
495 }
496 return 0;
497} /* mma1cdi_ */
498
499//=======================================================================
500//function : mma1cnt_
501//purpose :
502//=======================================================================
503int mma1cnt_(integer *ndimen,
504 integer *iordre,
505 doublereal *contr1,
506 doublereal *contr2,
507 doublereal *hermit,
508 integer *ndgjac,
509 doublereal *crvjac)
510{
511 /* System generated locals */
512 integer contr1_dim1, contr1_offset, contr2_dim1, contr2_offset,
513 hermit_dim1, hermit_offset, crvjac_dim1, crvjac_offset, i__1,
514 i__2, i__3;
515
516 /* Local variables */
517 static integer nd, ii, jj, ibb;
518 static doublereal bid;
519
520
521 /* ***********************************************************************
522 */
523
0d969553 524 /* FUNCTION : */
7fd59977 525 /* ---------- */
0d969553 526 /* Add constraint to polynom. */
7fd59977 527
528 /* MOTS CLES : */
529 /* ----------- */
0d969553 530 /* ALL,AB_SPECIFI::COURE&,APPROXIMATION,ADDITION,&CONSTRAINT */
7fd59977 531
0d969553 532 /* INPUT ARGUMENTS : */
7fd59977 533 /* -------------------- */
0d969553
Y
534 /* NDIMEN: Dimension of the space */
535 /* IORDRE: Order of constraint. */
536 /* CONTR1: pt of constraint in -1, from order 0 to IORDRE. */
537 /* CONTR2: Pt of constraint in +1, from order 0 to IORDRE. */
538 /* HERMIT: Table of Hermit polynoms of order IORDRE. */
539 /* CRVJAV: Curve of approximation in Jacobi base. */
7fd59977 540
0d969553 541 /* OUTPUT ARGUMENTS : */
7fd59977 542 /* --------------------- */
0d969553
Y
543 /* CRVJAV: Curve of approximation in Jacobi base */
544 /* to which the polynom of interpolation of constraints is added. */
7fd59977 545
0d969553 546 /* COMMON USED : */
7fd59977 547 /* ------------------ */
548
549
0d969553 550 /* REFERENCES CALLED : */
7fd59977 551 /* --------------------- */
552
553
0d969553 554/* DESCRIPTION/NOTES/LIMITATIONS : */
7fd59977 555/* ----------------------------------- */
556
7fd59977 557/* > */
558/* ***********************************************************************
559 */
560/* DECLARATIONS */
561/* ***********************************************************************
562 */
0d969553 563/* Name of the routine */
7fd59977 564
565/* ***********************************************************************
566 */
567/* INITIALISATIONS */
568/* ***********************************************************************
569 */
570
571 /* Parameter adjustments */
572 hermit_dim1 = (*iordre << 1) + 2;
573 hermit_offset = hermit_dim1;
574 hermit -= hermit_offset;
575 contr2_dim1 = *ndimen;
576 contr2_offset = contr2_dim1 + 1;
577 contr2 -= contr2_offset;
578 contr1_dim1 = *ndimen;
579 contr1_offset = contr1_dim1 + 1;
580 contr1 -= contr1_offset;
581 crvjac_dim1 = *ndgjac + 1;
582 crvjac_offset = crvjac_dim1;
583 crvjac -= crvjac_offset;
584
585 /* Function Body */
586 ibb = AdvApp2Var_SysBase::mnfndeb_();
587 if (ibb >= 3) {
588 AdvApp2Var_SysBase::mgenmsg_("MMA1CNT", 7L);
589 }
590
591/* ***********************************************************************
592 */
0d969553 593/* Processing */
7fd59977 594/* ***********************************************************************
595 */
596
597 i__1 = *ndimen;
598 for (nd = 1; nd <= i__1; ++nd) {
599 i__2 = (*iordre << 1) + 1;
600 for (ii = 0; ii <= i__2; ++ii) {
601 bid = 0.;
602 i__3 = *iordre + 1;
603 for (jj = 1; jj <= i__3; ++jj) {
604 bid = bid + contr1[nd + jj * contr1_dim1] *
605 hermit[ii + ((jj << 1) - 1) * hermit_dim1] +
606 contr2[nd + jj * contr2_dim1] * hermit[ii + (jj << 1) * hermit_dim1];
607 /* L300: */
608 }
609 crvjac[ii + nd * crvjac_dim1] = bid;
610 /* L200: */
611 }
612 /* L100: */
613 }
614
615/* ***********************************************************************
616 */
0d969553 617/* RETURN CALLING PROGRAM */
7fd59977 618/* ***********************************************************************
619 */
620
621 if (ibb >= 3) {
622 AdvApp2Var_SysBase::mgsomsg_("MMA1CNT", 7L);
623 }
624
625 return 0 ;
626} /* mma1cnt_ */
627
628//=======================================================================
629//function : mma1fdi_
630//purpose :
631//=======================================================================
632int mma1fdi_(integer *ndimen,
633 doublereal *uvfonc,
634 void (*foncnp) (// see AdvApp2Var_EvaluatorFunc2Var.hxx for details
635 int *,
636 double *,
637 double *,
638 int *,
639 double *,
640 int *,
641 double *,
642 int *,
643 int *,
644 double *,
645 int *
646 ),
647 integer *isofav,
648 doublereal *tconst,
649 integer *nbroot,
650 doublereal *ttable,
651 integer *iordre,
652 integer *ideriv,
653 doublereal *fpntab,
654 doublereal *somtab,
655 doublereal *diftab,
656 doublereal *contr1,
657 doublereal *contr2,
658 integer *iercod)
659{
660 /* System generated locals */
661 integer fpntab_dim1, somtab_dim1, somtab_offset, diftab_dim1,
662 diftab_offset, contr1_dim1, contr1_offset, contr2_dim1,
663 contr2_offset, i__1, i__2;
664 doublereal d__1;
665
666 /* Local variables */
667 static integer ideb, ifin, nroo2, ideru, iderv;
668 static doublereal renor;
669 static integer ii, nd, ibb, iim, nbp, iip;
670 static doublereal bid1, bid2;
671
672/* **********************************************************************
673*/
674
0d969553 675/* FUNCTION : */
7fd59977 676/* ---------- */
0d969553
Y
677/* DiscretiZation of a non-polynomial function F(U,V) or of */
678/* its derivative with fixed isoparameter. */
7fd59977 679
0d969553 680/* KEYWORDS : */
7fd59977 681/* ----------- */
0d969553 682/* ALL, AB_SPECIFI::FONCTION&, DISCRETISATION, &POINT */
7fd59977 683
0d969553 684/* INPUT ARGUMENTS : */
7fd59977 685/* ------------------ */
0d969553
Y
686/* NDIMEN: Space dimension. */
687/* UVFONC: Limits of the path of definition by U and by V of the approximated function */
688/* FONCNP: The NAME of the non-polynomial function to be approximated */
689/* (external program). */
690/* ISOFAV: Fixed isoparameter for the discretization; */
691/* = 1, discretization with fixed U and variable V. */
692/* = 2, discretization with fixed V and variable U. */
693/* TCONST: Iso value is also fixed. */
694/* NBROOT: Number of INTERNAL discretization parameters. */
695/* (if there are constraints, 2 extremities should be added).
696*/
697/* This is also the root number of the Legendre polynom where */
698/* the discretization is done. */
699/* TTABLE: Table of discretization parameters and of 2 extremities */
700/* (Respectively (-1, NBROOT Legendre roots,1) */
701/* reframed within the adequate interval. */
702/* IORDRE: Order of constraint imposed on the extremities of the iso. */
703/* (If Iso-U, it is necessary to calculate the derivatives by V and vice */
7fd59977 704/* versa). */
0d969553
Y
705/* = 0, the extremities of the iso are calculated. */
706/* = 1, additionally the 1st derivative in the direction of the iso is calculated */
707/* = 2, additionally the 2nd derivative in the direction of the iso is calculated */
708/* IDERIV: Order of derivative transversal to fixed iso (If Iso-U=Uc */
709/* is fixed, the derivative of order IDERIV is discretized by U of */
710/* F(Uc,v). Same if iso-V is fixed). */
711/* Varies from 0 (positioning) to 2 (2nd derivative). */
712
713/* OUTPUT ARGUMENTS : */
7fd59977 714/* ------------------- */
0d969553
Y
715/* FPNTAB: Auxiliary table.
716 SOMTAB: Table of NBROOT/2 sums of 2 index points */
717/* NBROOT-II+1 and II, for II = 1, NBROOT/2 */
718/* DIFTAB: Table of NBROOT/2 differences of 2 index points */
719/* NBROOT-II+1 and II, for II = 1, NBROOT/2 */
720/* CONTR1: Contains, if IORDRE>=0, values IORDRE+1 in TTABLE(0)
721*/
722/* (1st extremity) of derivatives of F(Uc,Ve) or F(Ue,Vc), */
723/* see below. */
724/* CONTR2: Contains, if IORDRE>=0, values IORDRE+1 in */
725/* TTABLE(NBROOT+1) (2nd extremity) of: */
726/* If ISOFAV=1, derived of order IDERIV by U, derived */
727/* ordre 0 to IORDRE by V of F(Uc,Ve) or Uc=TCONST */
728/* (fixed iso value) and Ve is the fixed extremity. */
729/* If ISOFAV=2, derivative of order IDERIV by V, derivative */
730/* of order 0 to IORDRE by U of F(Ue,Vc) or Vc=TCONST */
731/* (fixed iso value) and Ue is the fixed extremity. */
732/* IERCOD: Error code > 100; Pb in evaluation of FONCNP, */
733/* the returned error code is equal to error code of FONCNP + 100. */
734
735/* COMMONS USED : */
7fd59977 736/* ---------------- */
737
0d969553 738/* REFERENCES CALLED : */
7fd59977 739/* ----------------------- */
740
0d969553 741/* DESCRIPTION/NOTES/LIMITATIONS : */
7fd59977 742/* ----------------------------------- */
0d969553
Y
743/* The results of discretization are arranged in 2 tables */
744/* SOMTAB and DIFTAB to earn time during the */
745/* calculation of coefficients of the approximation curve. */
7fd59977 746
0d969553
Y
747/* If NBROOT is uneven in SOMTAB(0,*) and DIFTAB(0,*) one stores */
748/* the values of the median root of Legendre (0.D0 in (-1,1)). */
7fd59977 749
0d969553
Y
750/* Function F(u,v) defined in UVFONC is reparameterized in */
751/* (-1,1)x(-1,1). Then 1st and 2nd derivatives are renormalized. */
7fd59977 752
7fd59977 753/* > */
754/* **********************************************************************
755*/
756
0d969553 757/* Name of the routine */
7fd59977 758
759
760 /* Parameter adjustments */
761 uvfonc -= 3;
762 diftab_dim1 = *nbroot / 2 + 1;
763 diftab_offset = diftab_dim1;
764 diftab -= diftab_offset;
765 somtab_dim1 = *nbroot / 2 + 1;
766 somtab_offset = somtab_dim1;
767 somtab -= somtab_offset;
768 fpntab_dim1 = *ndimen;
769 --fpntab;
770 contr2_dim1 = *ndimen;
771 contr2_offset = contr2_dim1 + 1;
772 contr2 -= contr2_offset;
773 contr1_dim1 = *ndimen;
774 contr1_offset = contr1_dim1 + 1;
775 contr1 -= contr1_offset;
776
777 /* Function Body */
778 ibb = AdvApp2Var_SysBase::mnfndeb_();
779 if (ibb >= 3) {
780 AdvApp2Var_SysBase::mgenmsg_("MMA1FDI", 7L);
781 }
782 *iercod = 0;
783
0d969553 784/* --------------- Definition of the nb of points to calculate --------------
7fd59977 785*/
0d969553 786/* --> If constraints, the limits are also taken */
7fd59977 787 if (*iordre >= 0) {
788 ideb = 0;
789 ifin = *nbroot + 1;
0d969553 790/* --> Otherwise, only Legendre roots (reframed) are used
7fd59977 791. */
792 } else {
793 ideb = 1;
794 ifin = *nbroot;
795 }
0d969553 796/* --> Nb of point to calculate. */
7fd59977 797 nbp = ifin - ideb + 1;
798 nroo2 = *nbroot / 2;
799
0d969553 800/* --------------- Determination of the order of global derivation --------
7fd59977 801*/
0d969553
Y
802/* --> ISOFAV takes only values 1 or 2. */
803/* if Iso-U, derive by U of order IDERIV */
7fd59977 804 if (*isofav == 1) {
805 ideru = *ideriv;
806 iderv = 0;
807 d__1 = (uvfonc[4] - uvfonc[3]) / 2.;
808 renor = AdvApp2Var_MathBase::pow__di(&d__1, ideriv);
0d969553 809/* if Iso-V, derive by V of order IDERIV */
7fd59977 810 } else {
811 ideru = 0;
812 iderv = *ideriv;
813 d__1 = (uvfonc[6] - uvfonc[5]) / 2.;
814 renor = AdvApp2Var_MathBase::pow__di(&d__1, ideriv);
815 }
816
0d969553 817/* ----------- Discretization on roots of the ---------------
7fd59977 818*/
0d969553 819/* ---------------------- Legendre polynom of degree NBROOT -------------------
7fd59977 820*/
821
822 (*foncnp)(ndimen,
823 &uvfonc[3],
824 &uvfonc[5],
825 isofav,
826 tconst,
827 &nbp,
828 &ttable[ideb],
829 &ideru,
830 &iderv,
831 &fpntab[ideb * fpntab_dim1 + 1],
832 iercod);
833 if (*iercod > 0) {
834 goto L9999;
835 }
836 i__1 = *ndimen;
837 for (nd = 1; nd <= i__1; ++nd) {
838 i__2 = nroo2;
839 for (ii = 1; ii <= i__2; ++ii) {
840 iip = (*nbroot + 1) / 2 + ii;
841 iim = nroo2 - ii + 1;
842 bid1 = fpntab[nd + iim * fpntab_dim1];
843 bid2 = fpntab[nd + iip * fpntab_dim1];
844 somtab[ii + nd * somtab_dim1] = renor * (bid2 + bid1);
845 diftab[ii + nd * diftab_dim1] = renor * (bid2 - bid1);
846/* L200: */
847 }
848/* L100: */
849 }
850
0d969553 851/* ------------ Case when discretisation is done on roots of a ----
7fd59977 852*/
0d969553 853/* ---------- Legendre polynom of uneven degree, 0 is root --------
7fd59977 854*/
855
856 if (*nbroot % 2 == 1) {
857 i__1 = *ndimen;
858 for (nd = 1; nd <= i__1; ++nd) {
859 somtab[nd * somtab_dim1] = renor * fpntab[nd + (nroo2 + 1) *
860 fpntab_dim1];
861 diftab[nd * diftab_dim1] = renor * fpntab[nd + (nroo2 + 1) *
862 fpntab_dim1];
863/* L300: */
864 }
865 } else {
866 i__1 = *ndimen;
867 for (nd = 1; nd <= i__1; ++nd) {
868 somtab[nd * somtab_dim1] = 0.;
869 diftab[nd * diftab_dim1] = 0.;
870 }
871 }
872
873
0d969553 874/* --------------------- Take into account constraints ----------------
7fd59977 875*/
876
877 if (*iordre >= 0) {
0d969553 878/* --> Recover already calculated extremities. */
7fd59977 879 i__1 = *ndimen;
880 for (nd = 1; nd <= i__1; ++nd) {
881 contr1[nd + contr1_dim1] = renor * fpntab[nd];
882 contr2[nd + contr2_dim1] = renor * fpntab[nd + (*nbroot + 1) *
883 fpntab_dim1];
884/* L400: */
885 }
0d969553 886/* --> Nb of points to calculate/call to FONCNP */
7fd59977 887 nbp = 1;
0d969553 888/* If Iso-U, derive by V till order IORDRE */
7fd59977 889 if (*isofav == 1) {
0d969553 890/* --> Factor of normalisation 1st derivative. */
7fd59977 891 bid1 = (uvfonc[6] - uvfonc[5]) / 2.;
892 i__1 = *iordre;
893 for (iderv = 1; iderv <= i__1; ++iderv) {
894 (*foncnp)(ndimen, &uvfonc[3], &uvfonc[5], isofav, tconst, &
895 nbp, ttable, &ideru, &iderv, &contr1[(iderv + 1) *
896 contr1_dim1 + 1], iercod);
897 if (*iercod > 0) {
898 goto L9999;
899 }
900/* L500: */
901 }
902 i__1 = *iordre;
903 for (iderv = 1; iderv <= i__1; ++iderv) {
904 (*foncnp)(ndimen, &uvfonc[3], &uvfonc[5], isofav, tconst, &
905 nbp, &ttable[*nbroot + 1], &ideru, &iderv, &contr2[(
906 iderv + 1) * contr2_dim1 + 1], iercod);
907 if (*iercod > 0) {
908 goto L9999;
909 }
910/* L510: */
911 }
0d969553 912/* If Iso-V, derive by U till order IORDRE */
7fd59977 913 } else {
0d969553 914/* --> Factor of normalization 1st derivative. */
7fd59977 915 bid1 = (uvfonc[4] - uvfonc[3]) / 2.;
916 i__1 = *iordre;
917 for (ideru = 1; ideru <= i__1; ++ideru) {
918 (*foncnp)(ndimen, &uvfonc[3], &uvfonc[5], isofav, tconst, &
919 nbp, ttable, &ideru, &iderv, &contr1[(ideru + 1) *
920 contr1_dim1 + 1], iercod);
921 if (*iercod > 0) {
922 goto L9999;
923 }
924/* L600: */
925 }
926 i__1 = *iordre;
927 for (ideru = 1; ideru <= i__1; ++ideru) {
928 (*foncnp)(ndimen, &uvfonc[3], &uvfonc[5], isofav, tconst, &
929 nbp, &ttable[*nbroot + 1], &ideru, &iderv, &contr2[(
930 ideru + 1) * contr2_dim1 + 1], iercod);
931 if (*iercod > 0) {
932 goto L9999;
933 }
934/* L610: */
935 }
936 }
937
0d969553 938/* ------------------------- Normalization of derivatives -------------
7fd59977 939---- */
0d969553 940/* (The function is redefined on (-1,1)*(-1,1)) */
7fd59977 941 bid2 = renor;
942 i__1 = *iordre;
943 for (ii = 1; ii <= i__1; ++ii) {
944 bid2 = bid1 * bid2;
945 i__2 = *ndimen;
946 for (nd = 1; nd <= i__2; ++nd) {
947 contr1[nd + (ii + 1) * contr1_dim1] *= bid2;
948 contr2[nd + (ii + 1) * contr2_dim1] *= bid2;
949/* L710: */
950 }
951/* L700: */
952 }
953 }
954
955/* ------------------------------ The end -------------------------------
956*/
957
958L9999:
959 if (*iercod > 0) {
960 *iercod += 100;
961 AdvApp2Var_SysBase::maermsg_("MMA1FDI", iercod, 7L);
962 }
963 if (ibb >= 3) {
964 AdvApp2Var_SysBase::mgsomsg_("MMA1FDI", 7L);
965 }
966 return 0;
967} /* mma1fdi_ */
968
969//=======================================================================
970//function : mma1fer_
971//purpose :
972//=======================================================================
973int mma1fer_(integer *,//ndimen,
974 integer *nbsesp,
975 integer *ndimse,
976 integer *iordre,
977 integer *ndgjac,
978 doublereal *crvjac,
979 integer *ncflim,
980 doublereal *epsapr,
981 doublereal *ycvmax,
982 doublereal *errmax,
983 doublereal *errmoy,
984 integer *ncoeff,
985 integer *iercod)
986{
987 /* System generated locals */
988 integer crvjac_dim1, crvjac_offset, i__1, i__2;
989
990 /* Local variables */
991 static integer idim, ncfja, ncfnw, ndses, ii, kk, ibb, ier;
992 static integer nbr0;
993
994
995/* ***********************************************************************
996 */
997
0d969553 998/* FUNCTION : */
7fd59977 999/* ---------- */
0d969553 1000/* Calculate the degree and the errors of approximation of a border. */
7fd59977 1001
0d969553 1002/* KEYWORDS : */
7fd59977 1003/* ----------- */
1004/* TOUS,AB_SPECIFI :: COURBE&,TRONCATURE, &PRECISION */
1005
0d969553 1006/* INPUT ARGUMENTS : */
7fd59977 1007/* -------------------- */
7fd59977 1008
0d969553
Y
1009/* NDIMEN: Total Dimension of the space (sum of dimensions of sub-spaces) */
1010/* NBSESP: Number of "independent" sub-spaces. */
1011/* NDIMSE: Table of dimensions of sub-spaces. */
1012/* IORDRE: Order of constraint at the extremities of the border */
1013/* -1 = no constraints, */
1014/* 0 = constraints of passage to limits (i.e. C0), */
1015/* 1 = C0 + constraintes of 1st derivatives (i.e. C1), */
1016/* 2 = C1 + constraintes of 2nd derivatives (i.e. C2). */
1017/* NDGJAC: Degree of development in series to use for the calculation
1018/* in the base of Jacobi. */
1019/* CRVJAC: Table of coeff. of the curve of approximation in the */
1020/* base of Jacobi. */
1021/* NCFLIM: Max number of coeff of the polynomial curve */
1022/* of approximation (should be above or equal to */
1023/* 2*IORDRE+2 and below or equal to 50). */
1024/* EPSAPR: Table of errors of approximations that cannot be passed, */
1025/* sub-space by sub-space. */
1026
1027/* OUTPUT ARGUMENTS : */
7fd59977 1028/* --------------------- */
0d969553
Y
1029/* YCVMAX: Auxiliary Table. */
1030/* ERRMAX: Table of errors (sub-space by sub-space) */
1031/* MAXIMUM made in the approximation of FONCNP by */
7fd59977 1032/* COURBE. */
0d969553
Y
1033/* ERRMOY: Table of errors (sub-space by sub-space) */
1034/* AVERAGE made in the approximation of FONCNP by */
7fd59977 1035/* COURBE. */
0d969553
Y
1036/* NCOEFF: Number of significative coeffs. of the calculated "curve". */
1037/* IERCOD: Error code */
7fd59977 1038/* = 0, ok, */
0d969553
Y
1039/* =-1, warning, required tolerance can't be */
1040/* met with coefficients NFCLIM. */
1041/* = 1, order of constraints (IORDRE) is not within authorised values */
1042/*
7fd59977 1043
0d969553 1044/* COMMONS USED : */
7fd59977 1045/* ------------------ */
1046
0d969553 1047/* REFERENCES CALLED : */
7fd59977 1048/* --------------------- */
1049
0d969553 1050/* DESCRIPTION/NOTES/LIMITATIONS : */
7fd59977 1051/* ----------------------------------- */
7fd59977 1052/* > */
1053/* **********************************************************************
1054*/
1055
0d969553 1056/* Name of the routine */
7fd59977 1057
1058
1059 /* Parameter adjustments */
1060 --ycvmax;
1061 --errmoy;
1062 --errmax;
1063 --epsapr;
1064 --ndimse;
1065 crvjac_dim1 = *ndgjac + 1;
1066 crvjac_offset = crvjac_dim1;
1067 crvjac -= crvjac_offset;
1068
1069 /* Function Body */
1070 ibb = AdvApp2Var_SysBase::mnfndeb_();
1071 if (ibb >= 3) {
1072 AdvApp2Var_SysBase::mgenmsg_("MMA1FER", 7L);
1073 }
1074 *iercod = 0;
1075 idim = 1;
1076 *ncoeff = 0;
1077 ncfja = *ndgjac + 1;
1078
0d969553 1079/* ------------ Calculate the degree of the curve and of the Max error --------
7fd59977 1080*/
0d969553 1081/* -------------- of approximation for all sub-spaces --------
7fd59977 1082*/
1083
1084 i__1 = *nbsesp;
1085 for (ii = 1; ii <= i__1; ++ii) {
1086 ndses = ndimse[ii];
1087
0d969553 1088/* ------------ cutting of coeff. and calculation of Max error -------
7fd59977 1089---- */
1090
1091 AdvApp2Var_MathBase::mmtrpjj_(&ncfja, &ndses, &ncfja, &epsapr[ii], iordre, &crvjac[idim *
1092 crvjac_dim1], &ycvmax[1], &errmax[ii], &ncfnw);
1093
1094/* ******************************************************************
1095**** */
0d969553 1096/* ------------- If precision OK, calculate the average error -------
7fd59977 1097---- */
1098/* ******************************************************************
1099**** */
1100
1101 if (ncfnw <= *ncflim) {
1102 mmaperm_(&ncfja, &ndses, &ncfja, iordre, &crvjac[idim *
1103 crvjac_dim1], &ncfnw, &errmoy[ii]);
1104 *ncoeff = max(ncfnw,*ncoeff);
1105
0d969553 1106/* ------------- Set the declined coefficients to 0.D0 -----------
7fd59977 1107-------- */
1108
1109 nbr0 = *ncflim - ncfnw;
1110 if (nbr0 > 0) {
1111 i__2 = ndses;
1112 for (kk = 1; kk <= i__2; ++kk) {
1113 AdvApp2Var_SysBase::mvriraz_(&nbr0,
1114 (char *)&crvjac[ncfnw + (idim + kk - 1) * crvjac_dim1]);
1115/* L200: */
1116 }
1117 }
1118 } else {
1119
1120/* **************************************************************
1121******** */
0d969553 1122/* ------------------- If required precision can't be reached----
7fd59977 1123-------- */
1124/* **************************************************************
1125******** */
1126
1127 *iercod = -1;
1128
0d969553 1129/* ------------------------- calculate the Max error ------------
7fd59977 1130-------- */
1131
1132 AdvApp2Var_MathBase::mmaperx_(&ncfja, &ndses, &ncfja, iordre, &crvjac[idim *
1133 crvjac_dim1], ncflim, &ycvmax[1], &errmax[ii], &ier);
1134 if (ier > 0) {
1135 goto L9100;
1136 }
1137
0d969553 1138/* -------------------- nb of coeff to be returned -------------
7fd59977 1139-------- */
1140
1141 *ncoeff = *ncflim;
1142
0d969553 1143/* ------------------- and calculation of the average error ----
7fd59977 1144-------- */
1145
1146 mmaperm_(&ncfja, &ndses, &ncfja, iordre, &crvjac[idim *
1147 crvjac_dim1], ncflim, &errmoy[ii]);
1148 }
1149 idim += ndses;
1150/* L100: */
1151 }
1152
1153 goto L9999;
1154
1155/* ------------------------------ The end -------------------------------
1156*/
0d969553 1157/* --> The order of constraints is not within autorized values. */
7fd59977 1158L9100:
1159 *iercod = 1;
1160 goto L9999;
1161
1162L9999:
1163 if (*iercod != 0) {
1164 AdvApp2Var_SysBase::maermsg_("MMA1FER", iercod, 7L);
1165 }
1166 if (ibb >= 3) {
1167 AdvApp2Var_SysBase::mgsomsg_("MMA1FER", 7L);
1168 }
1169 return 0;
1170} /* mma1fer_ */
1171
1172
1173//=======================================================================
1174//function : mma1her_
1175//purpose :
1176//=======================================================================
1177int AdvApp2Var_ApproxF2var::mma1her_(const integer *iordre,
1178 doublereal *hermit,
1179 integer *iercod)
1180{
1181 /* System generated locals */
1182 integer hermit_dim1, hermit_offset;
1183
1184 /* Local variables */
1185 static integer ibb;
1186
1187
1188
1189/* **********************************************************************
1190*/
1191
0d969553 1192/* FUNCTION : */
7fd59977 1193/* ---------- */
0d969553
Y
1194/* Calculate 2*(IORDRE+1) Hermit polynoms of degree 2*IORDRE+1 */
1195/* on (-1,1) */
7fd59977 1196
0d969553 1197/* KEYWORDS : */
7fd59977 1198/* ----------- */
0d969553 1199/* ALL, AB_SPECIFI::CONTRAINTE&, INTERPOLATION, &POLYNOME */
7fd59977 1200
0d969553 1201/* INPUT ARGUMENTS : */
7fd59977 1202/* ------------------ */
0d969553
Y
1203/* IORDRE: Order of constraint. */
1204/* = 0, Polynom of interpolation of order C0 on (-1,1). */
1205/* = 1, Polynom of interpolation of order C0 and C1 on (-1,1). */
1206/* = 2, Polynom of interpolation of order C0, C1 and C2 on (-1,1).
7fd59977 1207*/
1208
0d969553 1209/* OUTPUT ARGUMENTS : */
7fd59977 1210/* ------------------- */
0d969553
Y
1211/* HERMIT: Table of 2*IORDRE+2 coeff. of each of 2*(IORDRE+1) */
1212/* HERMIT polynom. */
1213/* IERCOD: Error code, */
7fd59977 1214/* = 0, Ok */
0d969553
Y
1215/* = 1, required order of constraint is not managed here. */
1216/* COMMONS USED : */
7fd59977 1217/* ---------------- */
1218
0d969553 1219/* REFERENCES CALLED : */
7fd59977 1220/* ----------------------- */
1221
0d969553 1222/* DESCRIPTION/NOTES/LIMITATIONS : */
7fd59977 1223/* ----------------------------------- */
0d969553
Y
1224/* The part of HERMIT(*,2*i+j) table where j=1 or 2 and i=0 to IORDRE,
1225/* contains the coefficients of the polynom of degree 2*IORDRE+1 */
1226/* such as ALL values in -1 and in +1 of this polynom and its */
1227/* derivatives till order of derivation IORDRE are NULL, */
1228/* EXCEPT for the derivative of order i: */
1229/* - valued 1 in -1 if j=1 */
1230/* - valued 1 in +1 if j=2. */
7fd59977 1231/* > */
1232/* **********************************************************************
1233*/
1234
0d969553 1235/* Name of the routine */
7fd59977 1236
1237
1238 /* Parameter adjustments */
1239 hermit_dim1 = (*iordre + 1) << 1;
1240 hermit_offset = hermit_dim1 + 1;
1241 hermit -= hermit_offset;
1242
1243 /* Function Body */
1244 ibb = AdvApp2Var_SysBase::mnfndeb_();
1245 if (ibb >= 3) {
1246 AdvApp2Var_SysBase::mgenmsg_("MMA1HER", 7L);
1247 }
1248 *iercod = 0;
1249
0d969553 1250/* --- Recover (IORDRE+2) coeff of 2*(IORDRE+1) Hermit polynoms --
7fd59977 1251*/
1252
1253 if (*iordre == 0) {
1254 hermit[hermit_dim1 + 1] = .5;
1255 hermit[hermit_dim1 + 2] = -.5;
1256
1257 hermit[(hermit_dim1 << 1) + 1] = .5;
1258 hermit[(hermit_dim1 << 1) + 2] = .5;
1259 } else if (*iordre == 1) {
1260 hermit[hermit_dim1 + 1] = .5;
1261 hermit[hermit_dim1 + 2] = -.75;
1262 hermit[hermit_dim1 + 3] = 0.;
1263 hermit[hermit_dim1 + 4] = .25;
1264
1265 hermit[(hermit_dim1 << 1) + 1] = .5;
1266 hermit[(hermit_dim1 << 1) + 2] = .75;
1267 hermit[(hermit_dim1 << 1) + 3] = 0.;
1268 hermit[(hermit_dim1 << 1) + 4] = -.25;
1269
1270 hermit[hermit_dim1 * 3 + 1] = .25;
1271 hermit[hermit_dim1 * 3 + 2] = -.25;
1272 hermit[hermit_dim1 * 3 + 3] = -.25;
1273 hermit[hermit_dim1 * 3 + 4] = .25;
1274
1275 hermit[(hermit_dim1 << 2) + 1] = -.25;
1276 hermit[(hermit_dim1 << 2) + 2] = -.25;
1277 hermit[(hermit_dim1 << 2) + 3] = .25;
1278 hermit[(hermit_dim1 << 2) + 4] = .25;
1279 } else if (*iordre == 2) {
1280 hermit[hermit_dim1 + 1] = .5;
1281 hermit[hermit_dim1 + 2] = -.9375;
1282 hermit[hermit_dim1 + 3] = 0.;
1283 hermit[hermit_dim1 + 4] = .625;
1284 hermit[hermit_dim1 + 5] = 0.;
1285 hermit[hermit_dim1 + 6] = -.1875;
1286
1287 hermit[(hermit_dim1 << 1) + 1] = .5;
1288 hermit[(hermit_dim1 << 1) + 2] = .9375;
1289 hermit[(hermit_dim1 << 1) + 3] = 0.;
1290 hermit[(hermit_dim1 << 1) + 4] = -.625;
1291 hermit[(hermit_dim1 << 1) + 5] = 0.;
1292 hermit[(hermit_dim1 << 1) + 6] = .1875;
1293
1294 hermit[hermit_dim1 * 3 + 1] = .3125;
1295 hermit[hermit_dim1 * 3 + 2] = -.4375;
1296 hermit[hermit_dim1 * 3 + 3] = -.375;
1297 hermit[hermit_dim1 * 3 + 4] = .625;
1298 hermit[hermit_dim1 * 3 + 5] = .0625;
1299 hermit[hermit_dim1 * 3 + 6] = -.1875;
1300
1301 hermit[(hermit_dim1 << 2) + 1] = -.3125;
1302 hermit[(hermit_dim1 << 2) + 2] = -.4375;
1303 hermit[(hermit_dim1 << 2) + 3] = .375;
1304 hermit[(hermit_dim1 << 2) + 4] = .625;
1305 hermit[(hermit_dim1 << 2) + 5] = -.0625;
1306 hermit[(hermit_dim1 << 2) + 6] = -.1875;
1307
1308 hermit[hermit_dim1 * 5 + 1] = .0625;
1309 hermit[hermit_dim1 * 5 + 2] = -.0625;
1310 hermit[hermit_dim1 * 5 + 3] = -.125;
1311 hermit[hermit_dim1 * 5 + 4] = .125;
1312 hermit[hermit_dim1 * 5 + 5] = .0625;
1313 hermit[hermit_dim1 * 5 + 6] = -.0625;
1314
1315 hermit[hermit_dim1 * 6 + 1] = .0625;
1316 hermit[hermit_dim1 * 6 + 2] = .0625;
1317 hermit[hermit_dim1 * 6 + 3] = -.125;
1318 hermit[hermit_dim1 * 6 + 4] = -.125;
1319 hermit[hermit_dim1 * 6 + 5] = .0625;
1320 hermit[hermit_dim1 * 6 + 6] = .0625;
1321 } else {
1322 *iercod = 1;
1323 }
1324
1325/* ------------------------------ The End -------------------------------
1326*/
1327
1328 AdvApp2Var_SysBase::maermsg_("MMA1HER", iercod, 7L);
1329 if (ibb >= 3) {
1330 AdvApp2Var_SysBase::mgsomsg_("MMA1HER", 7L);
1331 }
1332 return 0;
1333} /* mma1her_ */
1334//=======================================================================
1335//function : mma1jak_
1336//purpose :
1337//=======================================================================
1338int mma1jak_(integer *ndimen,
1339 integer *nbroot,
1340 integer *iordre,
1341 integer *ndgjac,
1342 doublereal *somtab,
1343 doublereal *diftab,
1344 doublereal *cgauss,
1345 doublereal *crvjac,
1346 integer *iercod)
1347{
1348 /* System generated locals */
1349 integer somtab_dim1, somtab_offset, diftab_dim1, diftab_offset,
1350 crvjac_dim1, crvjac_offset, cgauss_dim1;
1351
1352 /* Local variables */
1353 static integer ibb;
1354
1355/* **********************************************************************
1356*/
1357
0d969553 1358/* FUNCTION : */
7fd59977 1359/* ---------- */
0d969553
Y
1360/* Calculate the curve of approximation of a non-polynomial function */
1361/* in the base of Jacobi. */
7fd59977 1362
0d969553 1363/* KEYWORDS : */
7fd59977 1364/* ----------- */
0d969553 1365/* FUNCTION,DISCRETISATION,APPROXIMATION,CONSTRAINT,CURVE,JACOBI */
7fd59977 1366
0d969553 1367/* INPUT ARGUMENTS : */
7fd59977 1368/* ------------------ */
0d969553
Y
1369/* NDIMEN: Total dimension of the space (sum of dimensions */
1370/* of sub-spaces) */
1371/* NBROOT: Nb of points of discretization of the iso, extremities not
1372/* included. */
1373/* IORDRE: Order of constraint at the extremities of the boundary */
1374/* -1 = no constraints, */
1375/* 0 = constraints of passage of limits (i.e. C0), */
1376/* 1 = C0 + constraints of 1st derivatives (i.e. C1), */
1377/* 2 = C1 + constraints of 2nd derivatives (i.e. C2). */
1378/* NDGJAC: Degree of development in series to be used for calculation in the
1379/* base of Jacobi. */
1380
1381/* OUTPUT ARGUMENTS : */
7fd59977 1382/* ------------------- */
0d969553
Y
1383/* CRVJAC : Curve of approximation of FONCNP with (eventually) */
1384/* taking into account of constraints at the extremities. */
1385/* This curve is of degree NDGJAC. */
1386/* IERCOD : Error code : */
1387/* 0 = All is ok. */
1388/* 33 = Pb to return data of du block data */
1389/* of coeff. of integration by GAUSS method. */
1390/* by program MMAPPTT. */
1391
1392/* COMMONS USED : */
7fd59977 1393/* ---------------- */
1394
0d969553 1395/* REFERENCES CALLED : */
7fd59977 1396/* ----------------------- */
7fd59977 1397/* > */
1398/* **********************************************************************
1399*/
1400
0d969553 1401/* Name of the routine */
7fd59977 1402
1403 /* Parameter adjustments */
1404 diftab_dim1 = *nbroot / 2 + 1;
1405 diftab_offset = diftab_dim1;
1406 diftab -= diftab_offset;
1407 somtab_dim1 = *nbroot / 2 + 1;
1408 somtab_offset = somtab_dim1;
1409 somtab -= somtab_offset;
1410 crvjac_dim1 = *ndgjac + 1;
1411 crvjac_offset = crvjac_dim1;
1412 crvjac -= crvjac_offset;
1413 cgauss_dim1 = *nbroot / 2 + 1;
1414
1415 /* Function Body */
1416 ibb = AdvApp2Var_SysBase::mnfndeb_();
1417 if (ibb >= 2) {
1418 AdvApp2Var_SysBase::mgenmsg_("MMA1JAK", 7L);
1419 }
1420 *iercod = 0;
1421
0d969553 1422/* ----------------- Recover coeffs of integration by Gauss -----------
7fd59977 1423*/
1424
1425 AdvApp2Var_ApproxF2var::mmapptt_(ndgjac, nbroot, iordre, cgauss, iercod);
1426 if (*iercod > 0) {
1427 *iercod = 33;
1428 goto L9999;
1429 }
1430
0d969553 1431/* --------------- Calculate the curve in the base of Jacobi -----------
7fd59977 1432*/
1433
1434 mmmapcoe_(ndimen, ndgjac, iordre, nbroot, &somtab[somtab_offset], &diftab[
1435 diftab_offset], cgauss, &crvjac[crvjac_offset]);
1436
1437/* ------------------------------ The End -------------------------------
1438*/
1439
1440L9999:
1441 if (*iercod != 0) {
1442 AdvApp2Var_SysBase::maermsg_("MMA1JAK", iercod, 7L);
1443 }
1444 if (ibb >= 2) {
1445 AdvApp2Var_SysBase::mgsomsg_("MMA1JAK", 7L);
1446 }
1447 return 0;
1448} /* mma1jak_ */
1449
1450//=======================================================================
1451//function : mma1noc_
1452//purpose :
1453//=======================================================================
1454int mma1noc_(doublereal *dfuvin,
1455 integer *ndimen,
1456 integer *iordre,
1457 doublereal *cntrin,
1458 doublereal *duvout,
1459 integer *isofav,
1460 integer *ideriv,
1461 doublereal *cntout)
1462{
1463 /* System generated locals */
1464 integer i__1;
1465 doublereal d__1;
1466
1467
1468 /* Local variables */
1469 static doublereal rider, riord;
1470 static integer nd, ibb;
1471 static doublereal bid;
1472/* **********************************************************************
1473*/
1474
0d969553 1475/* FUNCTION : */
7fd59977 1476/* ---------- */
0d969553
Y
1477/* Normalization of constraints of derivatives, defined on DFUVIN */
1478/* on block DUVOUT. */
7fd59977 1479
0d969553 1480/* KEYWORDS : */
7fd59977 1481/* ----------- */
0d969553 1482/* ALL, AB_SPECIFI::VECTEUR&,DERIVEE&,NORMALISATION,&VECTEUR */
7fd59977 1483
0d969553 1484/* INPUT ARGUMENTS : */
7fd59977 1485/* ------------------ */
0d969553 1486/* DFUVIN: Limits of the block of definition by U and by V where
7fd59977 1487*/
0d969553
Y
1488/* constraints CNTRIN are defined. */
1489/* NDIMEN: Dimension of the space. */
1490/* IORDRE: Order of constraint imposed at the extremities of the iso. */
1491/* (if Iso-U, it is necessary to calculate derivatives by V and vice */
7fd59977 1492/* versa). */
0d969553
Y
1493/* = 0, the extremities of the iso are calculated */
1494/* = 1, additionally the 1st derivative in the direction */
1495/* of the iso is calculated */
1496/* = 2, additionally the 2nd derivative in the direction */
1497/* of the iso is calculated */
1498/* CNTRIN: Contains, if IORDRE>=0, IORDRE+1 derivatives */
1499/* of order IORDRE of F(Uc,v) or of F(u,Vc), following the */
1500/* value of ISOFAV, RENORMALIZED by u and v in (-1,1). */
1501/* DUVOUT: Limits of the block of definition by U and by V where the */
1502/* constraints CNTOUT will be defined. */
1503/* ISOFAV: Isoparameter fixed for the discretization; */
1504/* = 1, discretization with fixed U=Uc and variable V. */
1505/* = 2, discretization with fixed V=Vc and variable U. */
7fd59977 1506/* IDERIV: Ordre de derivee transverse a l'iso fixee (Si Iso-U=Uc */
0d969553
Y
1507/* is fixed, the derivative of order IDERIV is discretized by U */
1508/* of F(Uc,v). The same if iso-V is fixed). */
1509/* Varies from (positioning) to 2 (2nd derivative). */
7fd59977 1510
0d969553 1511/* OUTPUT ARGUMENTS : */
7fd59977 1512/* ------------------- */
0d969553
Y
1513/* CNTOUT: Contains, if IORDRE>=0, IORDRE+1 derivatives */
1514/* of order IORDRE of F(Uc,v) or of F(u,Vc), depending on the */
1515/* value of ISOFAV, RENORMALIZED for u and v in DUVOUT. */
7fd59977 1516
0d969553 1517/* COMMONS USED : */
7fd59977 1518/* ---------------- */
1519
0d969553
Y
1520/* REFERENCES CALLED : */
1521/* --------------------- */
7fd59977 1522
0d969553
Y
1523/* DESCRIPTION/NOTES/LIMITATIONS : */
1524/* ------------------------------- */
1525/* CNTRIN can be an output/input argument, */
1526/* so the call: */
7fd59977 1527
1528/* CALL MMA1NOC(DFUVIN,NDIMEN,IORDRE,CNTRIN,DUVOUT */
1529/* 1 ,ISOFAV,IDERIV,CNTRIN) */
1530
0d969553 1531/* is correct. */
7fd59977 1532/* > */
1533/* **********************************************************************
1534*/
1535
0d969553 1536/* Name of the routine */
7fd59977 1537
1538
1539 /* Parameter adjustments */
1540 dfuvin -= 3;
1541 --cntout;
1542 --cntrin;
1543 duvout -= 3;
1544
1545 /* Function Body */
1546 ibb = AdvApp2Var_SysBase::mnfndeb_();
1547 if (ibb >= 3) {
1548 AdvApp2Var_SysBase::mgenmsg_("MMA1NOC", 7L);
1549 }
1550
0d969553 1551/* --------------- Determination of coefficients of normalization -------
7fd59977 1552 */
1553
1554 if (*isofav == 1) {
1555 d__1 = (dfuvin[4] - dfuvin[3]) / (duvout[4] - duvout[3]);
1556 rider = AdvApp2Var_MathBase::pow__di(&d__1, ideriv);
1557 d__1 = (dfuvin[6] - dfuvin[5]) / (duvout[6] - duvout[5]);
1558 riord = AdvApp2Var_MathBase::pow__di(&d__1, iordre);
1559
1560 } else {
1561 d__1 = (dfuvin[6] - dfuvin[5]) / (duvout[6] - duvout[5]);
1562 rider = AdvApp2Var_MathBase::pow__di(&d__1, ideriv);
1563 d__1 = (dfuvin[4] - dfuvin[3]) / (duvout[4] - duvout[3]);
1564 riord = AdvApp2Var_MathBase::pow__di(&d__1, iordre);
1565 }
1566
0d969553 1567/* ------------- Renormalization of the vector of constraint ---------------
7fd59977 1568*/
1569
1570 bid = rider * riord;
1571 i__1 = *ndimen;
1572 for (nd = 1; nd <= i__1; ++nd) {
1573 cntout[nd] = bid * cntrin[nd];
1574/* L100: */
1575 }
1576
1577/* ------------------------------ The end -------------------------------
1578*/
1579
1580 if (ibb >= 3) {
1581 AdvApp2Var_SysBase::mgsomsg_("MMA1NOC", 7L);
1582 }
1583 return 0;
1584} /* mma1noc_ */
1585
1586//=======================================================================
1587//function : mma1nop_
1588//purpose :
1589//=======================================================================
1590int mma1nop_(integer *nbroot,
1591 doublereal *rootlg,
1592 doublereal *uvfonc,
1593 integer *isofav,
1594 doublereal *ttable,
1595 integer *iercod)
1596
1597{
1598 /* System generated locals */
1599 integer i__1;
1600
1601 /* Local variables */
1602 static doublereal alinu, blinu, alinv, blinv;
1603 static integer ii, ibb;
1604
1605
1606
1607/* ***********************************************************************
1608 */
1609
0d969553 1610/* FUNCTION : */
7fd59977 1611/* ---------- */
0d969553
Y
1612/* Normalization of parameters of an iso, starting from */
1613/* parametric block and parameters on (-1,1). */
7fd59977 1614
0d969553 1615/* KEYWORDS : */
7fd59977 1616/* ----------- */
1617/* TOUS,AB_SPECIFI :: ISO&,POINT&,NORMALISATION,&POINT,&ISO */
1618
0d969553 1619/* INPUT ARGUMENTS : */
7fd59977 1620/* -------------------- */
0d969553
Y
1621/* NBROOT: Nb of points of discretisation INSIDE the iso */
1622/* defined on (-1,1). */
1623/* ROOTLG: Table of discretization parameters on )-1,1( */
1624/* of the iso. */
1625/* UVFONC: Block of definition of the iso */
1626/* ISOFAV: = 1, this is iso-u; =2, this is iso-v. */
1627
1628/* OUTPUT ARGUMENTS : */
7fd59977 1629/* --------------------- */
0d969553 1630/* TTABLE: Table of parameters renormalized on UVFONC of the iso.
7fd59977 1631*/
1632/* IERCOD: = 0, OK */
0d969553 1633/* = 1, ISOFAV is out of allowed values. */
7fd59977 1634
7fd59977 1635/* > */
1636/* **********************************************************************
1637*/
0d969553 1638/* Name of the routine */
7fd59977 1639
1640
1641 /* Parameter adjustments */
1642 --rootlg;
1643 uvfonc -= 3;
1644
1645 /* Function Body */
1646 ibb = AdvApp2Var_SysBase::mnfndeb_();
1647 if (ibb >= 3) {
1648 AdvApp2Var_SysBase::mgenmsg_("MMA1NOP", 7L);
1649 }
1650
1651 alinu = (uvfonc[4] - uvfonc[3]) / 2.;
1652 blinu = (uvfonc[4] + uvfonc[3]) / 2.;
1653 alinv = (uvfonc[6] - uvfonc[5]) / 2.;
1654 blinv = (uvfonc[6] + uvfonc[5]) / 2.;
1655
1656 if (*isofav == 1) {
1657 ttable[0] = uvfonc[5];
1658 i__1 = *nbroot;
1659 for (ii = 1; ii <= i__1; ++ii) {
1660 ttable[ii] = alinv * rootlg[ii] + blinv;
1661/* L100: */
1662 }
1663 ttable[*nbroot + 1] = uvfonc[6];
1664 } else if (*isofav == 2) {
1665 ttable[0] = uvfonc[3];
1666 i__1 = *nbroot;
1667 for (ii = 1; ii <= i__1; ++ii) {
1668 ttable[ii] = alinu * rootlg[ii] + blinu;
1669/* L200: */
1670 }
1671 ttable[*nbroot + 1] = uvfonc[4];
1672 } else {
1673 goto L9100;
1674 }
1675
1676 goto L9999;
1677
1678/* ------------------------------ THE END -------------------------------
1679*/
1680
1681L9100:
1682 *iercod = 1;
1683 goto L9999;
1684
1685L9999:
1686 if (*iercod != 0) {
1687 AdvApp2Var_SysBase::maermsg_("MMA1NOP", iercod, 7L);
1688 }
1689 if (ibb >= 3) {
1690 AdvApp2Var_SysBase::mgsomsg_("MMA1NOP", 7L);
1691 }
1692
1693 return 0 ;
1694
1695} /* mma1nop_ */
1696
1697//=======================================================================
1698//function : mma2ac1_
1699//purpose :
1700//=======================================================================
1701int AdvApp2Var_ApproxF2var::mma2ac1_(integer const *ndimen,
1702 integer const *mxujac,
1703 integer const *mxvjac,
1704 integer const *iordru,
1705 integer const *iordrv,
1706 doublereal const *contr1,
1707 doublereal const * contr2,
1708 doublereal const *contr3,
1709 doublereal const *contr4,
1710 doublereal const *uhermt,
1711 doublereal const *vhermt,
1712 doublereal *patjac)
1713
1714{
1715 /* System generated locals */
1716 integer contr1_dim1, contr1_dim2, contr1_offset, contr2_dim1, contr2_dim2,
1717 contr2_offset, contr3_dim1, contr3_dim2, contr3_offset,
1718 contr4_dim1, contr4_dim2, contr4_offset, uhermt_dim1,
1719 uhermt_offset, vhermt_dim1, vhermt_offset, patjac_dim1,
1720 patjac_dim2, patjac_offset, i__1, i__2, i__3, i__4, i__5;
1721
1722 /* Local variables */
1723 static logical ldbg;
1724 static integer ndgu, ndgv;
1725 static doublereal bidu1, bidu2, bidv1, bidv2;
1726 static integer ioru1, iorv1, ii, nd, jj, ku, kv;
1727 static doublereal cnt1, cnt2, cnt3, cnt4;
1728
1729
1730
1731/* **********************************************************************
1732*/
1733
0d969553 1734/* FUNCTION : */
7fd59977 1735/* ---------- */
0d969553 1736/* Add polynoms of edge constraints. */
7fd59977 1737
0d969553 1738/* KEYWORDS : */
7fd59977 1739/* ----------- */
1740/* TOUS,AB_SPECIFI::POINT&,CONTRAINTE&,ADDITION,&POLYNOME */
1741
0d969553 1742/* INPUT ARGUMENTS : */
7fd59977 1743/* ------------------ */
0d969553
Y
1744/* NDIMEN: Dimension of the space. */
1745/* MXUJAC: Max degree of the polynom of approximation by U. The */
1746/* representation in the orthogonal base starts from degree */
1747/* 0 to degree MXUJAC-2*(IORDRU+1). The polynomial base is the */
1748/* base of Jacobi of order -1 (Legendre), 0, 1 or 2 */
1749/* MXVJAC: Max degree of the polynom of approximation by V. The */
1750/* representation in the orthogonal base starts from degree */
1751/* 0 to degree MXUJAC-2*(IORDRU+1). The polynomial base is the */
1752/* base of Jacobi of order -1 (Legendre), 0, 1 or 2 */
1753/* IORDRU: Order of the base of Jacobi (-1,0,1 or 2) by U. Corresponds */
1754/* to the step of constraints: C0, C1 or C2. */
1755/* IORDRV: Order of the base of Jacobi (-1,0,1 or 2) by V. Corresponds */
1756/* to the step of constraints: C0, C1 or C2. */
1757/* CONTR1: Contains, if IORDRU and IORDRV>=0, the values at the */
1758/* extremities of F(U0,V0) and its derivatives. */
1759/* CONTR2: Contains, if IORDRU and IORDRV>=0, the values at the */
1760/* extremities of F(U1,V0) and its derivatives. */
1761/* CONTR3: Contains, if IORDRU and IORDRV>=0, the values at the */
1762/* extremities of F(U0,V1) and its derivatives. */
1763/* CONTR4: Contains, if IORDRU and IORDRV>=0, the values at the */
1764/* extremities of F(U1,V1) and its derivatives. */
1765/* UHERMT: Coeff. of Hermit polynoms of order IORDRU. */
1766/* VHERMT: Coeff. of Hermit polynoms of order IORDRV. */
1767/* PATJAC: Table of coefficients of the polynom P(u,v) of approximation */
1768/* of F(u,v) WITHOUT taking into account the constraints. */
1769
1770/* OUTPUT ARGUMENTS : */
7fd59977 1771/* ------------------- */
0d969553
Y
1772/* PATJAC: Table of coefficients of the polynom P(u,v) by approximation */
1773/* of F(u,v) WITH taking into account of constraints. */
7fd59977 1774/* > */
1775/* **********************************************************************
1776*/
0d969553 1777/* Name of the routine */
7fd59977 1778
0d969553 1779/* --------------------------- Initialization --------------------------
7fd59977 1780*/
1781
1782 /* Parameter adjustments */
1783 patjac_dim1 = *mxujac + 1;
1784 patjac_dim2 = *mxvjac + 1;
1785 patjac_offset = patjac_dim1 * patjac_dim2;
1786 patjac -= patjac_offset;
1787 uhermt_dim1 = (*iordru << 1) + 2;
1788 uhermt_offset = uhermt_dim1;
1789 uhermt -= uhermt_offset;
1790 vhermt_dim1 = (*iordrv << 1) + 2;
1791 vhermt_offset = vhermt_dim1;
1792 vhermt -= vhermt_offset;
1793 contr4_dim1 = *ndimen;
1794 contr4_dim2 = *iordru + 2;
1795 contr4_offset = contr4_dim1 * (contr4_dim2 + 1) + 1;
1796 contr4 -= contr4_offset;
1797 contr3_dim1 = *ndimen;
1798 contr3_dim2 = *iordru + 2;
1799 contr3_offset = contr3_dim1 * (contr3_dim2 + 1) + 1;
1800 contr3 -= contr3_offset;
1801 contr2_dim1 = *ndimen;
1802 contr2_dim2 = *iordru + 2;
1803 contr2_offset = contr2_dim1 * (contr2_dim2 + 1) + 1;
1804 contr2 -= contr2_offset;
1805 contr1_dim1 = *ndimen;
1806 contr1_dim2 = *iordru + 2;
1807 contr1_offset = contr1_dim1 * (contr1_dim2 + 1) + 1;
1808 contr1 -= contr1_offset;
1809
1810 /* Function Body */
1811 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 3;
1812 if (ldbg) {
1813 AdvApp2Var_SysBase::mgenmsg_("MMA2AC1", 7L);
1814 }
1815
0d969553 1816/* ------------ SUBTRACTION OF ANGULAR CONSTRAINTS -------------------
7fd59977 1817*/
1818
1819 ioru1 = *iordru + 1;
1820 iorv1 = *iordrv + 1;
1821 ndgu = (*iordru << 1) + 1;
1822 ndgv = (*iordrv << 1) + 1;
1823
1824 i__1 = iorv1;
1825 for (jj = 1; jj <= i__1; ++jj) {
1826 i__2 = ioru1;
1827 for (ii = 1; ii <= i__2; ++ii) {
1828 i__3 = *ndimen;
1829 for (nd = 1; nd <= i__3; ++nd) {
1830 cnt1 = contr1[nd + (ii + jj * contr1_dim2) * contr1_dim1];
1831 cnt2 = contr2[nd + (ii + jj * contr2_dim2) * contr2_dim1];
1832 cnt3 = contr3[nd + (ii + jj * contr3_dim2) * contr3_dim1];
1833 cnt4 = contr4[nd + (ii + jj * contr4_dim2) * contr4_dim1];
1834 i__4 = ndgv;
1835 for (kv = 0; kv <= i__4; ++kv) {
1836 bidv1 = vhermt[kv + ((jj << 1) - 1) * vhermt_dim1];
1837 bidv2 = vhermt[kv + (jj << 1) * vhermt_dim1];
1838 i__5 = ndgu;
1839 for (ku = 0; ku <= i__5; ++ku) {
1840 bidu1 = uhermt[ku + ((ii << 1) - 1) * uhermt_dim1];
1841 bidu2 = uhermt[ku + (ii << 1) * uhermt_dim1];
1842 patjac[ku + (kv + nd * patjac_dim2) * patjac_dim1] =
1843 patjac[ku + (kv + nd * patjac_dim2) *
1844 patjac_dim1] - bidu1 * bidv1 * cnt1 - bidu2 *
1845 bidv1 * cnt2 - bidu1 * bidv2 * cnt3 - bidu2 *
1846 bidv2 * cnt4;
1847/* L500: */
1848 }
1849/* L400: */
1850 }
1851/* L300: */
1852 }
1853/* L200: */
1854 }
1855/* L100: */
1856 }
1857
1858/* ------------------------------ The end -------------------------------
1859*/
1860
1861 if (ldbg) {
1862 AdvApp2Var_SysBase::mgsomsg_("MMA2AC1", 7L);
1863 }
1864 return 0;
1865} /* mma2ac1_ */
1866
1867//=======================================================================
1868//function : mma2ac2_
1869//purpose :
1870//=======================================================================
1871int AdvApp2Var_ApproxF2var::mma2ac2_(const integer *ndimen,
1872 const integer *mxujac,
1873 const integer *mxvjac,
1874 const integer *iordrv,
1875 const integer *nclimu,
1876 const integer *ncfiv1,
1877 const doublereal *crbiv1,
1878 const integer *ncfiv2,
1879 const doublereal *crbiv2,
1880 const doublereal *vhermt,
1881 doublereal *patjac)
1882
1883{
1884 /* System generated locals */
1885 integer crbiv1_dim1, crbiv1_dim2, crbiv1_offset, crbiv2_dim1, crbiv2_dim2,
1886 crbiv2_offset, patjac_dim1, patjac_dim2, patjac_offset,
1887 vhermt_dim1, vhermt_offset, i__1, i__2, i__3, i__4;
1888
1889 /* Local variables */
1890 static logical ldbg;
1891 static integer ndgv1, ndgv2, ii, jj, nd, kk;
1892 static doublereal bid1, bid2;
1893
1894/* **********************************************************************
1895*/
1896
0d969553 1897/* FUNCTION : */
7fd59977 1898/* ---------- */
0d969553 1899/* Add polynoms of constraints */
7fd59977 1900
0d969553 1901/* KEYWORDS : */
7fd59977 1902/* ----------- */
0d969553 1903/* FUNCTION,APPROXIMATION,COEFFICIENT,POLYNOM */
7fd59977 1904
0d969553 1905/* INPUT ARGUMENTS : */
7fd59977 1906/* ------------------ */
0d969553
Y
1907/* NDIMEN: Dimension of the space. */
1908/* MXUJAC: Max degree of the polynom of approximation by U. The */
1909/* representation in the orthogonal base starts from degree */
1910/* 0 to degree MXUJAC-2*(IORDRU+1). The polynomial base is the */
1911/* base of Jacobi of order -1 (Legendre), 0, 1 or 2 */
1912/* MXVJAC: Max degree of the polynom of approximation by V. The */
1913/* representation in the orthogonal base starts from degree */
1914/* 0 to degree MXUJAC-2*(IORDRU+1). The polynomial base is the */
1915/* base of Jacobi of order -1 (Legendre), 0, 1 or 2 */
1916/* IORDRV: Order of the base of Jacobi (-1,0,1 or 2) by V. Corresponds */
1917/* to the step of constraints: C0, C1 or C2. */
1918/* NCLIMU LIMIT nb of coeff by u of the solution P(u,v)
1919* NCFIV1: Nb of Coeff. of curves stored in CRBIV1. */
1920/* CRBIV1: Table of coeffs of the approximation of iso-V0 and its */
1921/* derivatives till order IORDRV. */
1922/* NCFIV2: Nb of Coeff. of curves stored in CRBIV2. */
1923/* CRBIV2: Table of coeffs of approximation of iso-V1 and its */
1924/* derivatives till order IORDRV. */
1925/* VHERMT: Coeff. of Hermit polynoms of order IORDRV. */
1926/* PATJAC: Table of coefficients of the polynom P(u,v) of approximation */
1927/* of F(u,v) WITHOUT taking into account the constraints. */
1928
1929/* OUTPUT ARGUMENTS : */
7fd59977 1930/* ------------------- */
0d969553
Y
1931/* PATJAC: Table of coefficients of the polynom P(u,v) by approximation */
1932/* of F(u,v) WITH taking into account of constraints. */
1933/* > *//*
7fd59977 1934
7fd59977 1935
7fd59977 1936/* > */
1937/* **********************************************************************
1938*/
0d969553 1939/* Name of the routine */
7fd59977 1940
1941/* --------------------------- Initialisations --------------------------
1942*/
1943
1944 /* Parameter adjustments */
1945 patjac_dim1 = *mxujac + 1;
1946 patjac_dim2 = *mxvjac + 1;
1947 patjac_offset = patjac_dim1 * patjac_dim2;
1948 patjac -= patjac_offset;
1949 vhermt_dim1 = (*iordrv << 1) + 2;
1950 vhermt_offset = vhermt_dim1;
1951 vhermt -= vhermt_offset;
1952 --ncfiv2;
1953 --ncfiv1;
1954 crbiv2_dim1 = *nclimu;
1955 crbiv2_dim2 = *ndimen;
1956 crbiv2_offset = crbiv2_dim1 * (crbiv2_dim2 + 1);
1957 crbiv2 -= crbiv2_offset;
1958 crbiv1_dim1 = *nclimu;
1959 crbiv1_dim2 = *ndimen;
1960 crbiv1_offset = crbiv1_dim1 * (crbiv1_dim2 + 1);
1961 crbiv1 -= crbiv1_offset;
1962
1963 /* Function Body */
1964 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 3;
1965 if (ldbg) {
1966 AdvApp2Var_SysBase::mgenmsg_("MMA2AC2", 7L);
1967 }
1968
0d969553 1969/* ------------ ADDING of coeff by u of curves, by v of Hermit --------
7fd59977 1970*/
1971
1972 i__1 = *iordrv + 1;
1973 for (ii = 1; ii <= i__1; ++ii) {
1974 ndgv1 = ncfiv1[ii] - 1;
1975 ndgv2 = ncfiv2[ii] - 1;
1976 i__2 = *ndimen;
1977 for (nd = 1; nd <= i__2; ++nd) {
1978 i__3 = (*iordrv << 1) + 1;
1979 for (jj = 0; jj <= i__3; ++jj) {
1980 bid1 = vhermt[jj + ((ii << 1) - 1) * vhermt_dim1];
1981 i__4 = ndgv1;
1982 for (kk = 0; kk <= i__4; ++kk) {
1983 patjac[kk + (jj + nd * patjac_dim2) * patjac_dim1] +=
1984 bid1 * crbiv1[kk + (nd + ii * crbiv1_dim2) *
1985 crbiv1_dim1];
1986/* L400: */
1987 }
1988 bid2 = vhermt[jj + (ii << 1) * vhermt_dim1];
1989 i__4 = ndgv2;
1990 for (kk = 0; kk <= i__4; ++kk) {
1991 patjac[kk + (jj + nd * patjac_dim2) * patjac_dim1] +=
1992 bid2 * crbiv2[kk + (nd + ii * crbiv2_dim2) *
1993 crbiv2_dim1];
1994/* L500: */
1995 }
1996/* L300: */
1997 }
1998/* L200: */
1999 }
2000/* L100: */
2001 }
2002
2003/* ------------------------------ The end -------------------------------
2004*/
2005
2006 if (ldbg) {
2007 AdvApp2Var_SysBase::mgsomsg_("MMA2AC2", 7L);
2008 }
2009 return 0;
2010} /* mma2ac2_ */
2011
2012
2013//=======================================================================
2014//function : mma2ac3_
2015//purpose :
2016//=======================================================================
2017int AdvApp2Var_ApproxF2var::mma2ac3_(const integer *ndimen,
2018 const integer *mxujac,
2019 const integer *mxvjac,
2020 const integer *iordru,
2021 const integer *nclimv,
2022 const integer *ncfiu1,
2023 const doublereal * crbiu1,
2024 const integer *ncfiu2,
2025 const doublereal *crbiu2,
2026 const doublereal *uhermt,
2027 doublereal *patjac)
2028
2029{
2030 /* System generated locals */
2031 integer crbiu1_dim1, crbiu1_dim2, crbiu1_offset, crbiu2_dim1, crbiu2_dim2,
2032 crbiu2_offset, patjac_dim1, patjac_dim2, patjac_offset,
2033 uhermt_dim1, uhermt_offset, i__1, i__2, i__3, i__4;
2034
2035 /* Local variables */
2036 static logical ldbg;
2037 static integer ndgu1, ndgu2, ii, jj, nd, kk;
2038 static doublereal bid1, bid2;
2039
2040
2041
2042
2043/* **********************************************************************
2044*/
2045
0d969553 2046/* FUNCTION : */
7fd59977 2047/* ---------- */
2048/* Ajout des polynomes de contraintes */
2049
0d969553 2050/* KEYWORDS : */
7fd59977 2051/* ----------- */
2052/* FONCTION,APPROXIMATION,COEFFICIENT,POLYNOME */
2053
0d969553 2054/* INPUT ARGUMENTS : */
7fd59977 2055/* ------------------ */
0d969553
Y
2056/* NDIMEN: Dimension of the space. */
2057/* MXUJAC: Max degree of the polynom of approximation by U. The */
2058/* representation in the orthogonal base starts from degree */
2059/* 0 to degree MXUJAC-2*(IORDRU+1). The polynomial base is the */
2060/* base of Jacobi of order -1 (Legendre), 0, 1 or 2 */
2061/* MXVJAC: Max degree of the polynom of approximation by V. The */
2062/* representation in the orthogonal base starts from degree */
2063/* 0 to degree MXUJAC-2*(IORDRU+1). The polynomial base is the */
2064/* base of Jacobi of order -1 (Legendre), 0, 1 or 2 */
2065/* IORDRU: Order of the base of Jacobi (-1,0,1 or 2) by U. Corresponds */
2066/* to the step of constraints: C0, C1 or C2. */
2067/* NCLIMV LIMIT nb of coeff by v of the solution P(u,v)
2068* NCFIU1: Nb of Coeff. of curves stored in CRBIU1. */
2069/* CRBIU1: Table of coeffs of the approximation of iso-U0 and its */
2070/* derivatives till order IORDRU. */
2071/* NCFIU2: Nb of Coeff. of curves stored in CRBIU2. */
2072/* CRBIU2: Table of coeffs of approximation of iso-U1 and its */
2073/* derivatives till order IORDRU */
2074/* UHERMT: Coeff. of Hermit polynoms of order IORDRU. */
2075/* PATJAC: Table of coefficients of the polynom P(u,v) of approximation */
2076/* of F(u,v) WITHOUT taking into account the constraints. */
2077
2078/* OUTPUT ARGUMENTS : */
7fd59977 2079/* ------------------- */
0d969553
Y
2080/* PATJAC: Table of coefficients of the polynom P(u,v) by approximation */
2081/* of F(u,v) WITH taking into account of constraints. */
7fd59977 2082
7fd59977 2083
7fd59977 2084/* > */
2085/* **********************************************************************
2086*/
0d969553 2087/* The name of the routine */
7fd59977 2088
0d969553 2089/* --------------------------- Initializations --------------------------
7fd59977 2090*/
2091
2092 /* Parameter adjustments */
2093 patjac_dim1 = *mxujac + 1;
2094 patjac_dim2 = *mxvjac + 1;
2095 patjac_offset = patjac_dim1 * patjac_dim2;
2096 patjac -= patjac_offset;
2097 uhermt_dim1 = (*iordru << 1) + 2;
2098 uhermt_offset = uhermt_dim1;
2099 uhermt -= uhermt_offset;
2100 --ncfiu2;
2101 --ncfiu1;
2102 crbiu2_dim1 = *nclimv;
2103 crbiu2_dim2 = *ndimen;
2104 crbiu2_offset = crbiu2_dim1 * (crbiu2_dim2 + 1);
2105 crbiu2 -= crbiu2_offset;
2106 crbiu1_dim1 = *nclimv;
2107 crbiu1_dim2 = *ndimen;
2108 crbiu1_offset = crbiu1_dim1 * (crbiu1_dim2 + 1);
2109 crbiu1 -= crbiu1_offset;
2110
2111 /* Function Body */
2112 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 3;
2113 if (ldbg) {
2114 AdvApp2Var_SysBase::mgenmsg_("MMA2AC3", 7L);
2115 }
2116
0d969553 2117/* ------------ ADDING of coeff by u of curves, by v of Hermit --------
7fd59977 2118*/
2119
2120 i__1 = *iordru + 1;
2121 for (ii = 1; ii <= i__1; ++ii) {
2122 ndgu1 = ncfiu1[ii] - 1;
2123 ndgu2 = ncfiu2[ii] - 1;
2124 i__2 = *ndimen;
2125 for (nd = 1; nd <= i__2; ++nd) {
2126 i__3 = ndgu1;
2127 for (jj = 0; jj <= i__3; ++jj) {
2128 bid1 = crbiu1[jj + (nd + ii * crbiu1_dim2) * crbiu1_dim1];
2129 i__4 = (*iordru << 1) + 1;
2130 for (kk = 0; kk <= i__4; ++kk) {
2131 patjac[kk + (jj + nd * patjac_dim2) * patjac_dim1] +=
2132 bid1 * uhermt[kk + ((ii << 1) - 1) * uhermt_dim1];
2133/* L400: */
2134 }
2135/* L300: */
2136 }
2137 i__3 = ndgu2;
2138 for (jj = 0; jj <= i__3; ++jj) {
2139 bid2 = crbiu2[jj + (nd + ii * crbiu2_dim2) * crbiu2_dim1];
2140 i__4 = (*iordru << 1) + 1;
2141 for (kk = 0; kk <= i__4; ++kk) {
2142 patjac[kk + (jj + nd * patjac_dim2) * patjac_dim1] +=
2143 bid2 * uhermt[kk + (ii << 1) * uhermt_dim1];
2144/* L600: */
2145 }
2146/* L500: */
2147 }
2148
2149/* L200: */
2150 }
2151/* L100: */
2152 }
2153
2154/* ------------------------------ The end -------------------------------
2155*/
2156
2157 if (ldbg) {
2158 AdvApp2Var_SysBase::mgsomsg_("MMA2AC3", 7L);
2159 }
2160 return 0;
2161} /* mma2ac3_ */
2162
2163//=======================================================================
2164//function : mma2can_
2165//purpose :
2166//=======================================================================
2167int AdvApp2Var_ApproxF2var::mma2can_(const integer *ncfmxu,
2168 const integer *ncfmxv,
2169 const integer *ndimen,
2170 const integer *iordru,
2171 const integer *iordrv,
2172 const integer *ncoefu,
2173 const integer *ncoefv,
2174 const doublereal *patjac,
2175 doublereal *pataux,
2176 doublereal *patcan,
2177 integer *iercod)
2178
2179{
2180 /* System generated locals */
2181 integer patjac_dim1, patjac_dim2, patjac_offset, patcan_dim1, patcan_dim2,
2182 patcan_offset, i__1, i__2;
2183
2184 /* Local variables */
2185 static logical ldbg;
2186 static integer ilon1, ilon2, ii, nd;
2187
2188
2189
2190
2191/* **********************************************************************
2192*/
2193
0d969553 2194/* FUNCTION : */
7fd59977 2195/* ---------- */
0d969553
Y
2196/* Change of Jacobi base to canonical (-1,1) and writing in a greater */
2197/* table. */
7fd59977 2198
0d969553 2199/* KEYWORDS : */
7fd59977 2200/* ----------- */
0d969553 2201/* ALL,AB_SPECIFI,CARREAU&,CONVERSION,JACOBI,CANNONIQUE,&CARREAU */
7fd59977 2202
0d969553 2203/* INPUT ARGUMENTS : */
7fd59977 2204/* -------------------- */
0d969553
Y
2205/* NCFMXU: Dimension by U of resulting table PATCAN */
2206/* NCFMXV: Dimension by V of resulting table PATCAN */
2207/* NDIMEN: Dimension of the workspace. */
2208/* IORDRU: Order of constraint by U */
2209/* IORDRV: Order of constraint by V. */
2210/* NCOEFU: Nb of coeff by U of square PATJAC */
2211/* NCOEFV: Nb of coeff by V of square PATJAC */
2212/* PATJAC: Square in the base of Jacobi of order IORDRU by U and */
2213/* IORDRV by V. */
2214
2215/* OUTPUT ARGUMENTS : */
7fd59977 2216/* --------------------- */
0d969553
Y
2217/* PATAUX: Auxiliary Table. */
2218/* PATCAN: Table of coefficients in the canonic base. */
2219/* IERCOD: Error code. */
2220/* = 0, everything goes well, and all things are equal. */
2221/* = 1, the program refuses to process with incorrect input arguments */
2222
2223
2224/* COMMONS USED : */
7fd59977 2225/* ------------------ */
2226
0d969553 2227/* REFERENCES CALLED : */
7fd59977 2228/* --------------------- */
2229
0d969553 2230/* DESCRIPTION/NOTES/LIMITATIONS : */
7fd59977 2231/* ----------------------------------- */
7fd59977 2232/* > */
2233/* **********************************************************************
2234*/
2235
2236
2237 /* Parameter adjustments */
2238 patcan_dim1 = *ncfmxu;
2239 patcan_dim2 = *ncfmxv;
2240 patcan_offset = patcan_dim1 * (patcan_dim2 + 1) + 1;
2241 patcan -= patcan_offset;
2242 --pataux;
2243 patjac_dim1 = *ncoefu;
2244 patjac_dim2 = *ncoefv;
2245 patjac_offset = patjac_dim1 * (patjac_dim2 + 1) + 1;
2246 patjac -= patjac_offset;
2247
2248 /* Function Body */
2249 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 2;
2250 if (ldbg) {
2251 AdvApp2Var_SysBase::mgenmsg_("MMA2CAN", 7L);
2252 }
2253 *iercod = 0;
2254
2255 if (*iordru < -1 || *iordru > 2) {
2256 goto L9100;
2257 }
2258 if (*iordrv < -1 || *iordrv > 2) {
2259 goto L9100;
2260 }
2261 if (*ncoefu > *ncfmxu || *ncoefv > *ncfmxv) {
2262 goto L9100;
2263 }
2264
0d969553 2265/* --> Pass to canonic base (-1,1) */
7fd59977 2266 mmjacpt_(ndimen, ncoefu, ncoefv, iordru, iordrv, &patjac[patjac_offset], &
2267 pataux[1], &patcan[patcan_offset]);
2268
0d969553 2269/* --> Write all in a greater table */
7fd59977 2270 AdvApp2Var_MathBase::mmfmca8_((integer *)ncoefu,
2271 (integer *)ncoefv,
2272 (integer *)ndimen,
2273 (integer *)ncfmxu,
2274 (integer *)ncfmxv,
2275 (integer *)ndimen,
2276 (doublereal *)&patcan[patcan_offset],
2277 (doublereal *)&patcan[patcan_offset]);
2278
0d969553 2279/* --> Complete with zeros the resulting table. */
7fd59977 2280 ilon1 = *ncfmxu - *ncoefu;
2281 ilon2 = *ncfmxu * (*ncfmxv - *ncoefv);
2282 i__1 = *ndimen;
2283 for (nd = 1; nd <= i__1; ++nd) {
2284 if (ilon1 > 0) {
2285 i__2 = *ncoefv;
2286 for (ii = 1; ii <= i__2; ++ii) {
2287 AdvApp2Var_SysBase::mvriraz_(&ilon1,
2288 (char *)&patcan[*ncoefu + 1 + (ii + nd * patcan_dim2) * patcan_dim1]);
2289/* L110: */
2290 }
2291 }
2292 if (ilon2 > 0) {
2293 AdvApp2Var_SysBase::mvriraz_(&ilon2,
2294 (char *)&patcan[(*ncoefv + 1 + nd * patcan_dim2) * patcan_dim1 + 1]);
2295 }
2296/* L100: */
2297 }
2298
2299 goto L9999;
2300
0d969553 2301/* ----------------------
7fd59977 2302*/
2303
2304L9100:
2305 *iercod = 1;
2306 goto L9999;
2307
2308L9999:
2309 AdvApp2Var_SysBase::maermsg_("MMA2CAN", iercod, 7L);
2310 if (ldbg) {
2311 AdvApp2Var_SysBase::mgsomsg_("MMA2CAN", 7L);
2312 }
2313 return 0 ;
2314} /* mma2can_ */
2315
2316//=======================================================================
2317//function : mma2cd1_
2318//purpose :
2319//=======================================================================
2320int mma2cd1_(integer *ndimen,
2321 integer *nbpntu,
2322 doublereal *urootl,
2323 integer *nbpntv,
2324 doublereal *vrootl,
2325 integer *iordru,
2326 integer *iordrv,
2327 doublereal *contr1,
2328 doublereal *contr2,
2329 doublereal *contr3,
2330 doublereal *contr4,
2331 doublereal *fpntbu,
2332 doublereal *fpntbv,
2333 doublereal *uhermt,
2334 doublereal *vhermt,
2335 doublereal *sosotb,
2336 doublereal *soditb,
2337 doublereal *disotb,
2338 doublereal *diditb)
2339
2340{
2341 static integer c__1 = 1;
2342
2343/* System generated locals */
2344 integer contr1_dim1, contr1_dim2, contr1_offset, contr2_dim1, contr2_dim2,
2345 contr2_offset, contr3_dim1, contr3_dim2, contr3_offset,
2346 contr4_dim1, contr4_dim2, contr4_offset, uhermt_dim1,
2347 uhermt_offset, vhermt_dim1, vhermt_offset, fpntbu_dim1,
2348 fpntbu_offset, fpntbv_dim1, fpntbv_offset, sosotb_dim1,
2349 sosotb_dim2, sosotb_offset, diditb_dim1, diditb_dim2,
2350 diditb_offset, soditb_dim1, soditb_dim2, soditb_offset,
2351 disotb_dim1, disotb_dim2, disotb_offset, i__1, i__2, i__3, i__4,
2352 i__5;
2353
2354 /* Local variables */
2355 static integer ncfhu, ncfhv, nuroo, nvroo, nd, ii, jj, kk, ll, ibb, kkm,
2356 llm, kkp, llp;
2357 static doublereal bid1, bid2, bid3, bid4;
2358 static doublereal diu1, diu2, div1, div2, sou1, sou2, sov1, sov2;
2359
2360
2361
2362
2363/* **********************************************************************
2364*/
2365
0d969553 2366/* FUNCTION : */
7fd59977 2367/* ---------- */
0d969553
Y
2368/* Discretisation on the parameters of polynoms of interpolation */
2369/* of constraints at the corners of order IORDRE. */
7fd59977 2370
0d969553 2371/* KEYWORDS : */
7fd59977 2372/* ----------- */
2373/* TOUS, AB_SPECIFI::CONTRAINTE&, DISCRETISATION, &POINT */
2374
0d969553 2375/* INPUT ARGUMENTS : */
7fd59977 2376/* ------------------ */
0d969553
Y
2377/* NDIMEN: Dimension of the space. */
2378/* NBPNTU: Nb of INTERNAL parameters of discretisation by U. */
2379/* This is also the nb of root of Legendre polynom where discretization is done. */
2380/* UROOTL: Table of parameters of discretisation ON (-1,1) by U.
2381*/
2382/* NBPNTV: Nb of INTERNAL parameters of discretisation by V. */
2383/* This is also the nb of root of Legendre polynom where discretization is done. */
2384/* VROOTL: Table of discretization parameters on (-1,1) by V.
2385/* IORDRU: Order of constraint imposed at the extremities of iso-V */
2386/* = 0, calculate the extremities of iso-V */
2387/* = 1, calculate, additionally, the 1st derivative in the direction of iso-V */
2388/* = 2, calculate, additionally, the 2nd derivative in the direction of iso-V */
2389/* IORDRV: Order of constraint imposed at the extremities of iso-U */
2390/* = 0, calculate the extremities of iso-U */
2391/* = 1, calculate, additionally, the 1st derivative in the direction of iso-U */
2392/* = 2, calculate, additionally, the 2nd derivative in the direction of iso-U */
2393/* CONTR1: Contains, if IORDRU and IORDRV>=0, the values at the */
2394/* extremities of F(U0,V0) and its derivatives. */
2395/* CONTR2: Contains, if IORDRU and IORDRV>=0, the values at the */
2396/* extremities of F(U1,V0) and its derivatives. */
2397/* CONTR3: Contains, if IORDRU and IORDRV>=0, the values at the */
2398/* extremities of F(U0,V1) and its derivatives. */
2399/* CONTR4: Contains, if IORDRU and IORDRV>=0, the values at the */
2400/* extremities of F(U1,V1) and its derivatives. */
2401/* SOSOTB: Preinitialized table (input/output argument). */
2402/* DISOTB: Preinitialized table (input/output argument). */
2403/* SODITB: Preinitialized table (input/output argument). */
2404/* DIDITB: Preinitialized table (input/output argument) */
2405
2406/* OUTPUT ARGUMENTS : */
7fd59977 2407/* ------------------- */
0d969553
Y
2408/* FPNTBU: Auxiliary table. */
2409/* FPNTBV: Auxiliary table. */
2410/* UHERMT: Table of 2*(IORDRU+1) coeff. of 2*(IORDRU+1) polynoms of Hermite. */
2411/* VHERMT: Table of 2*(IORDRV+1) coeff. of 2*(IORDRV+1) polynoms of Hermite. */
2412/* SOSOTB: Table where the terms of constraints are added */
7fd59977 2413/* C(ui,vj) + C(ui,-vj) + C(-ui,vj) + C(-ui,-vj) */
0d969553
Y
2414/* with ui and vj positive roots of the Legendre polynom */
2415/* of degree NBPNTU and NBPNTV respectively. */
2416/* DISOTB: Table where the terms of constraints are added */
7fd59977 2417/* C(ui,vj) + C(ui,-vj) - C(-ui,vj) - C(-ui,-vj) */
0d969553
Y
2418/* with ui and vj positive roots of the polynom of Legendre */
2419/* of degree NBPNTU and NBPNTV respectively. */
2420/* SODITB: Table where the terms of constraints are added */
7fd59977 2421/* C(ui,vj) - C(ui,-vj) + C(-ui,vj) - C(-ui,-vj) */
0d969553
Y
2422/* with ui and vj positive roots of the polynom of Legendre */
2423/* of degree NBPNTU and NBPNTV respectively. */
2424/* DIDITB: Table where the terms of constraints are added */
7fd59977 2425/* C(ui,vj) - C(ui,-vj) - C(-ui,vj) + C(-ui,-vj) */
0d969553
Y
2426/* with ui and vj positive roots of the polynom of Legendre */
2427/* of degree NBPNTU and NBPNTV respectively. */
7fd59977 2428
0d969553 2429/* COMMONS USED : */
7fd59977 2430/* ---------------- */
2431
0d969553 2432/* REFERENCES CALLED : */
7fd59977 2433/* ----------------------- */
2434
0d969553 2435/* DESCRIPTION/NOTES/LIMITATIONS : */
7fd59977 2436/* ----------------------------------- */
2437
7fd59977 2438/* > */
2439/* **********************************************************************
2440*/
2441
0d969553 2442/* Name of the routine */
7fd59977 2443
2444
2445 /* Parameter adjustments */
2446 --urootl;
2447 diditb_dim1 = *nbpntu / 2 + 1;
2448 diditb_dim2 = *nbpntv / 2 + 1;
2449 diditb_offset = diditb_dim1 * diditb_dim2;
2450 diditb -= diditb_offset;
2451 disotb_dim1 = *nbpntu / 2;
2452 disotb_dim2 = *nbpntv / 2;
2453 disotb_offset = disotb_dim1 * (disotb_dim2 + 1) + 1;
2454 disotb -= disotb_offset;
2455 soditb_dim1 = *nbpntu / 2;
2456 soditb_dim2 = *nbpntv / 2;
2457 soditb_offset = soditb_dim1 * (soditb_dim2 + 1) + 1;
2458 soditb -= soditb_offset;
2459 sosotb_dim1 = *nbpntu / 2 + 1;
2460 sosotb_dim2 = *nbpntv / 2 + 1;
2461 sosotb_offset = sosotb_dim1 * sosotb_dim2;
2462 sosotb -= sosotb_offset;
2463 --vrootl;
2464 uhermt_dim1 = (*iordru << 1) + 2;
2465 uhermt_offset = uhermt_dim1;
2466 uhermt -= uhermt_offset;
2467 fpntbu_dim1 = *nbpntu;
2468 fpntbu_offset = fpntbu_dim1 + 1;
2469 fpntbu -= fpntbu_offset;
2470 vhermt_dim1 = (*iordrv << 1) + 2;
2471 vhermt_offset = vhermt_dim1;
2472 vhermt -= vhermt_offset;
2473 fpntbv_dim1 = *nbpntv;
2474 fpntbv_offset = fpntbv_dim1 + 1;
2475 fpntbv -= fpntbv_offset;
2476 contr4_dim1 = *ndimen;
2477 contr4_dim2 = *iordru + 2;
2478 contr4_offset = contr4_dim1 * (contr4_dim2 + 1) + 1;
2479 contr4 -= contr4_offset;
2480 contr3_dim1 = *ndimen;
2481 contr3_dim2 = *iordru + 2;
2482 contr3_offset = contr3_dim1 * (contr3_dim2 + 1) + 1;
2483 contr3 -= contr3_offset;
2484 contr2_dim1 = *ndimen;
2485 contr2_dim2 = *iordru + 2;
2486 contr2_offset = contr2_dim1 * (contr2_dim2 + 1) + 1;
2487 contr2 -= contr2_offset;
2488 contr1_dim1 = *ndimen;
2489 contr1_dim2 = *iordru + 2;
2490 contr1_offset = contr1_dim1 * (contr1_dim2 + 1) + 1;
2491 contr1 -= contr1_offset;
2492
2493 /* Function Body */
2494 ibb = AdvApp2Var_SysBase::mnfndeb_();
2495 if (ibb >= 3) {
2496 AdvApp2Var_SysBase::mgenmsg_("MMA2CD1", 7L);
2497 }
2498
0d969553 2499/* ------------------- Discretisation of Hermite polynoms -----------
7fd59977 2500*/
2501
2502 ncfhu = (*iordru + 1) << 1;
2503 i__1 = ncfhu;
2504 for (ii = 1; ii <= i__1; ++ii) {
2505 i__2 = *nbpntu;
2506 for (ll = 1; ll <= i__2; ++ll) {
2507 AdvApp2Var_MathBase::mmmpocur_(&ncfhu, &c__1, &ncfhu, &uhermt[ii * uhermt_dim1], &
2508 urootl[ll], &fpntbu[ll + ii * fpntbu_dim1]);
2509/* L20: */
2510 }
2511/* L10: */
2512 }
2513 ncfhv = (*iordrv + 1) << 1;
2514 i__1 = ncfhv;
2515 for (jj = 1; jj <= i__1; ++jj) {
2516 i__2 = *nbpntv;
2517 for (kk = 1; kk <= i__2; ++kk) {
2518 AdvApp2Var_MathBase::mmmpocur_(&ncfhv, &c__1, &ncfhv, &vhermt[jj * vhermt_dim1], &
2519 vrootl[kk], &fpntbv[kk + jj * fpntbv_dim1]);
2520/* L40: */
2521 }
2522/* L30: */
2523 }
2524
0d969553 2525/* ---- The discretizations of polynoms of constraints are subtracted ----
7fd59977 2526*/
2527
2528 nuroo = *nbpntu / 2;
2529 nvroo = *nbpntv / 2;
2530 i__1 = *ndimen;
2531 for (nd = 1; nd <= i__1; ++nd) {
2532
2533 i__2 = *iordrv + 1;
2534 for (jj = 1; jj <= i__2; ++jj) {
2535 i__3 = *iordru + 1;
2536 for (ii = 1; ii <= i__3; ++ii) {
2537 bid1 = contr1[nd + (ii + jj * contr1_dim2) * contr1_dim1];
2538 bid2 = contr2[nd + (ii + jj * contr2_dim2) * contr2_dim1];
2539 bid3 = contr3[nd + (ii + jj * contr3_dim2) * contr3_dim1];
2540 bid4 = contr4[nd + (ii + jj * contr4_dim2) * contr4_dim1];
2541
2542 i__4 = nvroo;
2543 for (kk = 1; kk <= i__4; ++kk) {
2544 kkp = (*nbpntv + 1) / 2 + kk;
2545 kkm = nvroo - kk + 1;
2546 sov1 = fpntbv[kkp + ((jj << 1) - 1) * fpntbv_dim1] +
2547 fpntbv[kkm + ((jj << 1) - 1) * fpntbv_dim1];
2548 div1 = fpntbv[kkp + ((jj << 1) - 1) * fpntbv_dim1] -
2549 fpntbv[kkm + ((jj << 1) - 1) * fpntbv_dim1];
2550 sov2 = fpntbv[kkp + (jj << 1) * fpntbv_dim1] + fpntbv[kkm
2551 + (jj << 1) * fpntbv_dim1];
2552 div2 = fpntbv[kkp + (jj << 1) * fpntbv_dim1] - fpntbv[kkm
2553 + (jj << 1) * fpntbv_dim1];
2554 i__5 = nuroo;
2555 for (ll = 1; ll <= i__5; ++ll) {
2556 llp = (*nbpntu + 1) / 2 + ll;
2557 llm = nuroo - ll + 1;
2558 sou1 = fpntbu[llp + ((ii << 1) - 1) * fpntbu_dim1] +
2559 fpntbu[llm + ((ii << 1) - 1) * fpntbu_dim1];
2560 diu1 = fpntbu[llp + ((ii << 1) - 1) * fpntbu_dim1] -
2561 fpntbu[llm + ((ii << 1) - 1) * fpntbu_dim1];
2562 sou2 = fpntbu[llp + (ii << 1) * fpntbu_dim1] + fpntbu[
2563 llm + (ii << 1) * fpntbu_dim1];
2564 diu2 = fpntbu[llp + (ii << 1) * fpntbu_dim1] - fpntbu[
2565 llm + (ii << 1) * fpntbu_dim1];
2566 sosotb[ll + (kk + nd * sosotb_dim2) * sosotb_dim1] =
2567 sosotb[ll + (kk + nd * sosotb_dim2) *
2568 sosotb_dim1] - bid1 * sou1 * sov1 - bid2 *
2569 sou2 * sov1 - bid3 * sou1 * sov2 - bid4 *
2570 sou2 * sov2;
2571 soditb[ll + (kk + nd * soditb_dim2) * soditb_dim1] =
2572 soditb[ll + (kk + nd * soditb_dim2) *
2573 soditb_dim1] - bid1 * sou1 * div1 - bid2 *
2574 sou2 * div1 - bid3 * sou1 * div2 - bid4 *
2575 sou2 * div2;
2576 disotb[ll + (kk + nd * disotb_dim2) * disotb_dim1] =
2577 disotb[ll + (kk + nd * disotb_dim2) *
2578 disotb_dim1] - bid1 * diu1 * sov1 - bid2 *
2579 diu2 * sov1 - bid3 * diu1 * sov2 - bid4 *
2580 diu2 * sov2;
2581 diditb[ll + (kk + nd * diditb_dim2) * diditb_dim1] =
2582 diditb[ll + (kk + nd * diditb_dim2) *
2583 diditb_dim1] - bid1 * diu1 * div1 - bid2 *
2584 diu2 * div1 - bid3 * diu1 * div2 - bid4 *
2585 diu2 * div2;
2586/* L450: */
2587 }
2588/* L400: */
2589 }
2590
0d969553
Y
2591/* ------------ Case when the discretization is done only on the roots
2592----------- */
2593/* ---------- of Legendre polynom of uneven degree, 0 is root
7fd59977 2594----------- */
7fd59977 2595
2596 if (*nbpntu % 2 == 1) {
2597 sou1 = fpntbu[nuroo + 1 + ((ii << 1) - 1) * fpntbu_dim1];
2598 sou2 = fpntbu[nuroo + 1 + (ii << 1) * fpntbu_dim1];
2599 i__4 = nvroo;
2600 for (kk = 1; kk <= i__4; ++kk) {
2601 kkp = (*nbpntv + 1) / 2 + kk;
2602 kkm = nvroo - kk + 1;
2603 sov1 = fpntbv[kkp + ((jj << 1) - 1) * fpntbv_dim1] +
2604 fpntbv[kkm + ((jj << 1) - 1) * fpntbv_dim1];
2605 div1 = fpntbv[kkp + ((jj << 1) - 1) * fpntbv_dim1] -
2606 fpntbv[kkm + ((jj << 1) - 1) * fpntbv_dim1];
2607 sov2 = fpntbv[kkp + (jj << 1) * fpntbv_dim1] + fpntbv[
2608 kkm + (jj << 1) * fpntbv_dim1];
2609 div2 = fpntbv[kkp + (jj << 1) * fpntbv_dim1] - fpntbv[
2610 kkm + (jj << 1) * fpntbv_dim1];
2611 sosotb[(kk + nd * sosotb_dim2) * sosotb_dim1] =
2612 sosotb[(kk + nd * sosotb_dim2) * sosotb_dim1]
2613 - bid1 * sou1 * sov1 - bid2 * sou2 * sov1 -
2614 bid3 * sou1 * sov2 - bid4 * sou2 * sov2;
2615 diditb[(kk + nd * diditb_dim2) * diditb_dim1] =
2616 diditb[(kk + nd * diditb_dim2) * diditb_dim1]
2617 - bid1 * sou1 * div1 - bid2 * sou2 * div1 -
2618 bid3 * sou1 * div2 - bid4 * sou2 * div2;
2619/* L500: */
2620 }
2621 }
2622
2623 if (*nbpntv % 2 == 1) {
2624 sov1 = fpntbv[nvroo + 1 + ((jj << 1) - 1) * fpntbv_dim1];
2625 sov2 = fpntbv[nvroo + 1 + (jj << 1) * fpntbv_dim1];
2626 i__4 = nuroo;
2627 for (ll = 1; ll <= i__4; ++ll) {
2628 llp = (*nbpntu + 1) / 2 + ll;
2629 llm = nuroo - ll + 1;
2630 sou1 = fpntbu[llp + ((ii << 1) - 1) * fpntbu_dim1] +
2631 fpntbu[llm + ((ii << 1) - 1) * fpntbu_dim1];
2632 diu1 = fpntbu[llp + ((ii << 1) - 1) * fpntbu_dim1] -
2633 fpntbu[llm + ((ii << 1) - 1) * fpntbu_dim1];
2634 sou2 = fpntbu[llp + (ii << 1) * fpntbu_dim1] + fpntbu[
2635 llm + (ii << 1) * fpntbu_dim1];
2636 diu2 = fpntbu[llp + (ii << 1) * fpntbu_dim1] - fpntbu[
2637 llm + (ii << 1) * fpntbu_dim1];
2638 sosotb[ll + nd * sosotb_dim2 * sosotb_dim1] = sosotb[
2639 ll + nd * sosotb_dim2 * sosotb_dim1] - bid1 *
2640 sou1 * sov1 - bid2 * sou2 * sov1 - bid3 *
2641 sou1 * sov2 - bid4 * sou2 * sov2;
2642 diditb[ll + nd * diditb_dim2 * diditb_dim1] = diditb[
2643 ll + nd * diditb_dim2 * diditb_dim1] - bid1 *
2644 diu1 * sov1 - bid2 * diu2 * sov1 - bid3 *
2645 diu1 * sov2 - bid4 * diu2 * sov2;
2646/* L600: */
2647 }
2648 }
2649
2650 if (*nbpntu % 2 == 1 && *nbpntv % 2 == 1) {
2651 sou1 = fpntbu[nuroo + 1 + ((ii << 1) - 1) * fpntbu_dim1];
2652 sou2 = fpntbu[nuroo + 1 + (ii << 1) * fpntbu_dim1];
2653 sov1 = fpntbv[nvroo + 1 + ((jj << 1) - 1) * fpntbv_dim1];
2654 sov2 = fpntbv[nvroo + 1 + (jj << 1) * fpntbv_dim1];
2655 sosotb[nd * sosotb_dim2 * sosotb_dim1] = sosotb[nd *
2656 sosotb_dim2 * sosotb_dim1] - bid1 * sou1 * sov1 -
2657 bid2 * sou2 * sov1 - bid3 * sou1 * sov2 - bid4 *
2658 sou2 * sov2;
2659 diditb[nd * diditb_dim2 * diditb_dim1] = diditb[nd *
2660 diditb_dim2 * diditb_dim1] - bid1 * sou1 * sov1 -
2661 bid2 * sou2 * sov1 - bid3 * sou1 * sov2 - bid4 *
2662 sou2 * sov2;
2663 }
2664
2665/* L300: */
2666 }
2667/* L200: */
2668 }
2669/* L100: */
2670 }
2671 goto L9999;
2672
2673/* ------------------------------ The End -------------------------------
2674*/
2675
2676L9999:
2677 if (ibb >= 3) {
2678 AdvApp2Var_SysBase::mgsomsg_("MMA2CD1", 7L);
2679 }
2680 return 0;
2681} /* mma2cd1_ */
2682
2683//=======================================================================
2684//function : mma2cd2_
2685//purpose :
2686//=======================================================================
2687int mma2cd2_(integer *ndimen,
2688 integer *nbpntu,
2689 integer *nbpntv,
2690 doublereal *vrootl,
2691 integer *iordrv,
2692 doublereal *sotbv1,
2693 doublereal *sotbv2,
2694 doublereal *ditbv1,
2695 doublereal *ditbv2,
2696 doublereal *fpntab,
2697 doublereal *vhermt,
2698 doublereal *sosotb,
2699 doublereal *soditb,
2700 doublereal *disotb,
2701 doublereal *diditb)
2702
2703{
2704 static integer c__1 = 1;
2705 /* System generated locals */
2706 integer sotbv1_dim1, sotbv1_dim2, sotbv1_offset, sotbv2_dim1, sotbv2_dim2,
2707 sotbv2_offset, ditbv1_dim1, ditbv1_dim2, ditbv1_offset,
2708 ditbv2_dim1, ditbv2_dim2, ditbv2_offset, fpntab_dim1,
2709 fpntab_offset, vhermt_dim1, vhermt_offset, sosotb_dim1,
2710 sosotb_dim2, sosotb_offset, diditb_dim1, diditb_dim2,
2711 diditb_offset, soditb_dim1, soditb_dim2, soditb_offset,
2712 disotb_dim1, disotb_dim2, disotb_offset, i__1, i__2, i__3, i__4;
2713
2714 /* Local variables */
2715 static integer ncfhv, nuroo, nvroo, ii, nd, jj, kk, ibb, jjm, jjp;
2716 static doublereal bid1, bid2, bid3, bid4;
2717
2718/* **********************************************************************
2719*/
0d969553 2720/* FUNCTION : */
7fd59977 2721/* ---------- */
0d969553
Y
2722/* Discretisation on the parameters of polynoms of interpolation */
2723/* of constraints on 2 borders iso-V of order IORDRV. */
7fd59977 2724
0d969553
Y
2725
2726/* KEYWORDS : */
7fd59977 2727/* ----------- */
2728/* TOUS, AB_SPECIFI::CONTRAINTE&, DISCRETISATION, &POINT */
2729
7fd59977 2730
0d969553
Y
2731
2732/* INPUT ARGUMENTS : */
2733/* ------------------ */
2734/* NDIMEN: Dimension of the space. */
2735/* NBPNTU: Nb of INTERNAL parameters of discretisation by U. */
2736/* This is also the nb of root of Legendre polynom where discretization is done. */
2737/* UROOTL: Table of parameters of discretisation ON (-1,1) by U.
2738*/
2739/* NBPNTV: Nb of INTERNAL parameters of discretisation by V. */
2740/* This is also the nb of root of Legendre polynom where discretization is done. */
2741/* VROOTL: Table of discretization parameters on (-1,1) by V.
2742/* IORDRV: Order of constraint imposed at the extremities of iso-V */
2743/* = 0, calculate the extremities of iso-V */
2744/* = 1, calculate, additionally, the 1st derivative in the direction of iso-V */
2745/* = 2, calculate, additionally, the 2nd derivative in the direction of iso-V */
2746/* SOTBV1: Table of NBPNTV/2 sums of 2 index points */
2747/* NBPNTV-II+1 and II, for II = 1, NBPNTV/2 on iso-V0. */
2748/* SOTBV2: Table of NBPNTV/2 sums of 2 index points */
2749/* NBPNTV-II+1 and II, for II = 1, NBPNTV/2 on iso-V1. */
2750/* DITBV1: Table of NBPNTV/2 differences of 2 index points */
2751/* NBPNTV-II+1 and II, for II = 1, NBPNTV/2 on iso-V0. */
2752/* DITBV2: Table of NBPNTV/2 differences of 2 index points */
2753/* NBPNTV-II+1 and II, for II = 1, NBPNTV/2 on iso-V1. */
2754/* SOSOTB: Preinitialized table (input/output argument). */
2755/* DISOTB: Preinitialized table (input/output argument). */
2756/* SODITB: Preinitialized table (input/output argument). */
2757/* DIDITB: Preinitialized table (input/output argument) */
2758
2759/* OUTPUT ARGUMENTS : */
7fd59977 2760/* ------------------- */
0d969553
Y
2761/* FPNTAB: Auxiliary table. */
2762/* VHERMT: Table of 2*(IORDRV+1) coeff. of 2*(IORDRV+1) polynoms of Hermite. */
2763/* SOSOTB: Table where the terms of constraints are added */
7fd59977 2764/* C(ui,vj) + C(ui,-vj) + C(-ui,vj) + C(-ui,-vj) */
0d969553
Y
2765/* with ui and vj positive roots of the Legendre polynom */
2766/* of degree NBPNTU and NBPNTV respectively. */
2767/* DISOTB: Table where the terms of constraints are added */
7fd59977 2768/* C(ui,vj) + C(ui,-vj) - C(-ui,vj) - C(-ui,-vj) */
0d969553
Y
2769/* with ui and vj positive roots of the polynom of Legendre */
2770/* of degree NBPNTU and NBPNTV respectively. */
2771/* SODITB: Table where the terms of constraints are added */
7fd59977 2772/* C(ui,vj) - C(ui,-vj) + C(-ui,vj) - C(-ui,-vj) */
0d969553
Y
2773/* with ui and vj positive roots of the polynom of Legendre */
2774/* of degree NBPNTU and NBPNTV respectively. */
2775/* DIDITB: Table where the terms of constraints are added */
7fd59977 2776/* C(ui,vj) - C(ui,-vj) - C(-ui,vj) + C(-ui,-vj) */
0d969553
Y
2777/* with ui and vj positive roots of the polynom of Legendre */
2778/* of degree NBPNTU and NBPNTV respectively. */
7fd59977 2779
0d969553 2780/* COMMONS USED : */
7fd59977 2781/* ---------------- */
2782
0d969553 2783/* REFERENCES CALLED : */
7fd59977 2784/* ----------------------- */
2785
0d969553 2786/* DESCRIPTION/NOTES/LIMITATIONS : */
7fd59977 2787/* ----------------------------------- */
2788
2789
7fd59977 2790/* > */
2791/* **********************************************************************
2792*/
2793
0d969553 2794/* Name of the routine */
7fd59977 2795
2796
2797 /* Parameter adjustments */
2798 diditb_dim1 = *nbpntu / 2 + 1;
2799 diditb_dim2 = *nbpntv / 2 + 1;
2800 diditb_offset = diditb_dim1 * diditb_dim2;
2801 diditb -= diditb_offset;
2802 disotb_dim1 = *nbpntu / 2;
2803 disotb_dim2 = *nbpntv / 2;
2804 disotb_offset = disotb_dim1 * (disotb_dim2 + 1) + 1;
2805 disotb -= disotb_offset;
2806 soditb_dim1 = *nbpntu / 2;
2807 soditb_dim2 = *nbpntv / 2;
2808 soditb_offset = soditb_dim1 * (soditb_dim2 + 1) + 1;
2809 soditb -= soditb_offset;
2810 sosotb_dim1 = *nbpntu / 2 + 1;
2811 sosotb_dim2 = *nbpntv / 2 + 1;
2812 sosotb_offset = sosotb_dim1 * sosotb_dim2;
2813 sosotb -= sosotb_offset;
2814 --vrootl;
2815 vhermt_dim1 = (*iordrv << 1) + 2;
2816 vhermt_offset = vhermt_dim1;
2817 vhermt -= vhermt_offset;
2818 fpntab_dim1 = *nbpntv;
2819 fpntab_offset = fpntab_dim1 + 1;
2820 fpntab -= fpntab_offset;
2821 ditbv2_dim1 = *nbpntu / 2 + 1;
2822 ditbv2_dim2 = *ndimen;
2823 ditbv2_offset = ditbv2_dim1 * (ditbv2_dim2 + 1);
2824 ditbv2 -= ditbv2_offset;
2825 ditbv1_dim1 = *nbpntu / 2 + 1;
2826 ditbv1_dim2 = *ndimen;
2827 ditbv1_offset = ditbv1_dim1 * (ditbv1_dim2 + 1);
2828 ditbv1 -= ditbv1_offset;
2829 sotbv2_dim1 = *nbpntu / 2 + 1;
2830 sotbv2_dim2 = *ndimen;
2831 sotbv2_offset = sotbv2_dim1 * (sotbv2_dim2 + 1);
2832 sotbv2 -= sotbv2_offset;
2833 sotbv1_dim1 = *nbpntu / 2 + 1;
2834 sotbv1_dim2 = *ndimen;
2835 sotbv1_offset = sotbv1_dim1 * (sotbv1_dim2 + 1);
2836 sotbv1 -= sotbv1_offset;
2837
2838 /* Function Body */
2839 ibb = AdvApp2Var_SysBase::mnfndeb_();
2840 if (ibb >= 3) {
2841 AdvApp2Var_SysBase::mgenmsg_("MMA2CD2", 7L);
2842 }
2843
0d969553 2844/* ------------------- Discretization of Hermit polynoms -----------
7fd59977 2845*/
2846
2847 ncfhv = (*iordrv + 1) << 1;
2848 i__1 = ncfhv;
2849 for (ii = 1; ii <= i__1; ++ii) {
2850 i__2 = *nbpntv;
2851 for (jj = 1; jj <= i__2; ++jj) {
2852 AdvApp2Var_MathBase::mmmpocur_(&ncfhv, &c__1, &ncfhv, &vhermt[ii * vhermt_dim1], &
2853 vrootl[jj], &fpntab[jj + ii * fpntab_dim1]);
2854/* L60: */
2855 }
2856/* L50: */
2857 }
2858
0d969553 2859/* ---- The discretizations of polynoms of constraints are subtracted ----
7fd59977 2860*/
2861
2862 nuroo = *nbpntu / 2;
2863 nvroo = *nbpntv / 2;
2864
2865 i__1 = *ndimen;
2866 for (nd = 1; nd <= i__1; ++nd) {
2867 i__2 = *iordrv + 1;
2868 for (ii = 1; ii <= i__2; ++ii) {
2869
2870 i__3 = nuroo;
2871 for (kk = 1; kk <= i__3; ++kk) {
2872 bid1 = sotbv1[kk + (nd + ii * sotbv1_dim2) * sotbv1_dim1];
2873 bid2 = sotbv2[kk + (nd + ii * sotbv2_dim2) * sotbv2_dim1];
2874 bid3 = ditbv1[kk + (nd + ii * ditbv1_dim2) * ditbv1_dim1];
2875 bid4 = ditbv2[kk + (nd + ii * ditbv2_dim2) * ditbv2_dim1];
2876 i__4 = nvroo;
2877 for (jj = 1; jj <= i__4; ++jj) {
2878 jjp = (*nbpntv + 1) / 2 + jj;
2879 jjm = nvroo - jj + 1;
2880 sosotb[kk + (jj + nd * sosotb_dim2) * sosotb_dim1] =
2881 sosotb[kk + (jj + nd * sosotb_dim2) * sosotb_dim1]
2882 - bid1 * (fpntab[jjp + ((ii << 1) - 1) *
2883 fpntab_dim1] + fpntab[jjm + ((ii << 1) - 1) *
2884 fpntab_dim1]) - bid2 * (fpntab[jjp + (ii << 1) *
2885 fpntab_dim1] + fpntab[jjm + (ii << 1) *
2886 fpntab_dim1]);
2887 disotb[kk + (jj + nd * disotb_dim2) * disotb_dim1] =
2888 disotb[kk + (jj + nd * disotb_dim2) * disotb_dim1]
2889 - bid3 * (fpntab[jjp + ((ii << 1) - 1) *
2890 fpntab_dim1] + fpntab[jjm + ((ii << 1) - 1) *
2891 fpntab_dim1]) - bid4 * (fpntab[jjp + (ii << 1) *
2892 fpntab_dim1] + fpntab[jjm + (ii << 1) *
2893 fpntab_dim1]);
2894 soditb[kk + (jj + nd * soditb_dim2) * soditb_dim1] =
2895 soditb[kk + (jj + nd * soditb_dim2) * soditb_dim1]
2896 - bid1 * (fpntab[jjp + ((ii << 1) - 1) *
2897 fpntab_dim1] - fpntab[jjm + ((ii << 1) - 1) *
2898 fpntab_dim1]) - bid2 * (fpntab[jjp + (ii << 1) *
2899 fpntab_dim1] - fpntab[jjm + (ii << 1) *
2900 fpntab_dim1]);
2901 diditb[kk + (jj + nd * diditb_dim2) * diditb_dim1] =
2902 diditb[kk + (jj + nd * diditb_dim2) * diditb_dim1]
2903 - bid3 * (fpntab[jjp + ((ii << 1) - 1) *
2904 fpntab_dim1] - fpntab[jjm + ((ii << 1) - 1) *
2905 fpntab_dim1]) - bid4 * (fpntab[jjp + (ii << 1) *
2906 fpntab_dim1] - fpntab[jjm + (ii << 1) *
2907 fpntab_dim1]);
2908/* L400: */
2909 }
2910/* L300: */
2911 }
2912/* L200: */
2913 }
2914
0d969553
Y
2915/* ------------ Case when the discretization is done only on the roots */
2916/* ---------- of Legendre polynom of uneven degree, 0 is root */
2917
7fd59977 2918
2919 if (*nbpntv % 2 == 1) {
2920 i__2 = *iordrv + 1;
2921 for (ii = 1; ii <= i__2; ++ii) {
2922 i__3 = nuroo;
2923 for (kk = 1; kk <= i__3; ++kk) {
2924 bid1 = sotbv1[kk + (nd + ii * sotbv1_dim2) * sotbv1_dim1]
2925 * fpntab[nvroo + 1 + ((ii << 1) - 1) *
2926 fpntab_dim1] + sotbv2[kk + (nd + ii * sotbv2_dim2)
2927 * sotbv2_dim1] * fpntab[nvroo + 1 + (ii << 1) *
2928 fpntab_dim1];
2929 sosotb[kk + nd * sosotb_dim2 * sosotb_dim1] -= bid1;
2930 bid2 = ditbv1[kk + (nd + ii * ditbv1_dim2) * ditbv1_dim1]
2931 * fpntab[nvroo + 1 + ((ii << 1) - 1) *
2932 fpntab_dim1] + ditbv2[kk + (nd + ii * ditbv2_dim2)
2933 * ditbv2_dim1] * fpntab[nvroo + 1 + (ii << 1) *
2934 fpntab_dim1];
2935 diditb[kk + nd * diditb_dim2 * diditb_dim1] -= bid2;
2936/* L550: */
2937 }
2938/* L500: */
2939 }
2940 }
2941
2942 if (*nbpntu % 2 == 1) {
2943 i__2 = *iordrv + 1;
2944 for (ii = 1; ii <= i__2; ++ii) {
2945 i__3 = nvroo;
2946 for (jj = 1; jj <= i__3; ++jj) {
2947 jjp = (*nbpntv + 1) / 2 + jj;
2948 jjm = nvroo - jj + 1;
2949 bid1 = sotbv1[(nd + ii * sotbv1_dim2) * sotbv1_dim1] * (
2950 fpntab[jjp + ((ii << 1) - 1) * fpntab_dim1] +
2951 fpntab[jjm + ((ii << 1) - 1) * fpntab_dim1]) +
2952 sotbv2[(nd + ii * sotbv2_dim2) * sotbv2_dim1] * (
2953 fpntab[jjp + (ii << 1) * fpntab_dim1] + fpntab[
2954 jjm + (ii << 1) * fpntab_dim1]);
2955 sosotb[(jj + nd * sosotb_dim2) * sosotb_dim1] -= bid1;
2956 bid2 = sotbv1[(nd + ii * sotbv1_dim2) * sotbv1_dim1] * (
2957 fpntab[jjp + ((ii << 1) - 1) * fpntab_dim1] -
2958 fpntab[jjm + ((ii << 1) - 1) * fpntab_dim1]) +
2959 sotbv2[(nd + ii * sotbv2_dim2) * sotbv2_dim1] * (
2960 fpntab[jjp + (ii << 1) * fpntab_dim1] - fpntab[
2961 jjm + (ii << 1) * fpntab_dim1]);
2962 diditb[jj + nd * diditb_dim2 * diditb_dim1] -= bid2;
2963/* L650: */
2964 }
2965/* L600: */
2966 }
2967 }
2968
2969 if (*nbpntu % 2 == 1 && *nbpntv % 2 == 1) {
2970 i__2 = *iordrv + 1;
2971 for (ii = 1; ii <= i__2; ++ii) {
2972 bid1 = sotbv1[(nd + ii * sotbv1_dim2) * sotbv1_dim1] * fpntab[
2973 nvroo + 1 + ((ii << 1) - 1) * fpntab_dim1] + sotbv2[(
2974 nd + ii * sotbv2_dim2) * sotbv2_dim1] * fpntab[nvroo
2975 + 1 + (ii << 1) * fpntab_dim1];
2976 sosotb[nd * sosotb_dim2 * sosotb_dim1] -= bid1;
2977/* L700: */
2978 }
2979 }
2980
2981/* L100: */
2982 }
2983 goto L9999;
2984
2985/* ------------------------------ The End -------------------------------
2986*/
2987
2988L9999:
2989 if (ibb >= 3) {
2990 AdvApp2Var_SysBase::mgsomsg_("MMA2CD2", 7L);
2991 }
2992 return 0;
2993} /* mma2cd2_ */
2994
2995//=======================================================================
2996//function : mma2cd3_
2997//purpose :
2998//=======================================================================
2999int mma2cd3_(integer *ndimen,
3000 integer *nbpntu,
3001 doublereal *urootl,
3002 integer *nbpntv,
3003 integer *iordru,
3004 doublereal *sotbu1,
3005 doublereal *sotbu2,
3006 doublereal *ditbu1,
3007 doublereal *ditbu2,
3008 doublereal *fpntab,
3009 doublereal *uhermt,
3010 doublereal *sosotb,
3011 doublereal *soditb,
3012 doublereal *disotb,
3013 doublereal *diditb)
3014
3015{
3016 static integer c__1 = 1;
3017
3018 /* System generated locals */
3019 integer sotbu1_dim1, sotbu1_dim2, sotbu1_offset, sotbu2_dim1, sotbu2_dim2,
3020 sotbu2_offset, ditbu1_dim1, ditbu1_dim2, ditbu1_offset,
3021 ditbu2_dim1, ditbu2_dim2, ditbu2_offset, fpntab_dim1,
3022 fpntab_offset, uhermt_dim1, uhermt_offset, sosotb_dim1,
3023 sosotb_dim2, sosotb_offset, diditb_dim1, diditb_dim2,
3024 diditb_offset, soditb_dim1, soditb_dim2, soditb_offset,
3025 disotb_dim1, disotb_dim2, disotb_offset, i__1, i__2, i__3, i__4;
3026
3027 /* Local variables */
3028 static integer ncfhu, nuroo, nvroo, ii, nd, jj, kk, ibb, kkm, kkp;
3029 static doublereal bid1, bid2, bid3, bid4;
3030
3031/* **********************************************************************
3032*/
0d969553 3033/* FUNCTION : */
7fd59977 3034/* ---------- */
0d969553
Y
3035/* Discretisation on the parameters of polynoms of interpolation */
3036/* of constraints on 2 borders iso-U of order IORDRU. */
7fd59977 3037
0d969553
Y
3038
3039/* KEYWORDS : */
7fd59977 3040/* ----------- */
3041/* TOUS, AB_SPECIFI::CONTRAINTE&, DISCRETISATION, &POINT */
3042
0d969553 3043/* INPUT ARGUMENTS : */
7fd59977 3044/* ------------------ */
0d969553
Y
3045/* NDIMEN: Dimension of the space. */
3046/* NBPNTU: Nb of INTERNAL parameters of discretisation by U. */
3047/* This is also the nb of root of Legendre polynom where discretization is done. */
3048/* UROOTL: Table of parameters of discretisation ON (-1,1) by U.
3049*/
3050/* NBPNTV: Nb of INTERNAL parameters of discretisation by V. */
3051/* This is also the nb of root of Legendre polynom where discretization is done. */
3052/* IORDRV: Order of constraint imposed at the extremities of iso-V */
3053/* = 0, calculate the extremities of iso-V */
3054/* = 1, calculate, additionally, the 1st derivative in the direction of iso-V */
3055/* = 2, calculate, additionally, the 2nd derivative in the direction of iso-V */
3056/* SOTBU1: Table of NBPNTU/2 sums of 2 index points */
3057/* NBPNTU-II+1 and II, for II = 1, NBPNTU/2 on iso-V0. */
3058/* SOTBU2: Table of NBPNTV/2 sums of 2 index points */
3059/* NBPNTU-II+1 and II, for II = 1, NBPNTU/2 on iso-V1. */
3060/* DITBU1: Table of NBPNTU/2 differences of 2 index points */
3061/* NBPNTU-II+1 and II, for II = 1, NBPNTU/2 on iso-V0. */
3062/* DITBU2: Table of NBPNTU/2 differences of 2 index points */
3063/* NBPNTU-II+1 and II, for II = 1, NBPNTU/2 on iso-V1. */
3064/* SOSOTB: Preinitialized table (input/output argument). */
3065/* DISOTB: Preinitialized table (input/output argument). */
3066/* SODITB: Preinitialized table (input/output argument). */
3067/* DIDITB: Preinitialized table (input/output argument) */
3068
3069/* OUTPUT ARGUMENTS : */
7fd59977 3070/* ------------------- */
0d969553
Y
3071/* FPNTAB: Auxiliary table. */
3072/* UHERMT: Table of 2*(IORDRU+1) coeff. of 2*(IORDRU+1) polynoms of Hermite. */
3073/* SOSOTB: Table where the terms of constraints are added */
7fd59977 3074/* C(ui,vj) + C(ui,-vj) + C(-ui,vj) + C(-ui,-vj) */
0d969553
Y
3075/* with ui and vj positive roots of the Legendre polynom */
3076/* of degree NBPNTU and NBPNTV respectively. */
3077/* DISOTB: Table where the terms of constraints are added */
7fd59977 3078/* C(ui,vj) + C(ui,-vj) - C(-ui,vj) - C(-ui,-vj) */
0d969553
Y
3079/* with ui and vj positive roots of the polynom of Legendre */
3080/* of degree NBPNTU and NBPNTV respectively. */
3081/* SODITB: Table where the terms of constraints are added */
7fd59977 3082/* C(ui,vj) - C(ui,-vj) + C(-ui,vj) - C(-ui,-vj) */
0d969553
Y
3083/* with ui and vj positive roots of the polynom of Legendre */
3084/* of degree NBPNTU and NBPNTV respectively. */
3085/* DIDITB: Table where the terms of constraints are added */
7fd59977 3086/* C(ui,vj) - C(ui,-vj) - C(-ui,vj) + C(-ui,-vj) */
0d969553
Y
3087/* with ui and vj positive roots of the polynom of Legendre */
3088/* of degree NBPNTU and NBPNTV respectively. */
7fd59977 3089
0d969553 3090/* COMMONS USED : */
7fd59977 3091/* ---------------- */
3092
0d969553 3093/* REFERENCES CALLED : */
7fd59977 3094/* ----------------------- */
3095
0d969553 3096/* DESCRIPTION/NOTES/LIMITATIONS : */
7fd59977 3097/* ----------------------------------- */
3098
7fd59977 3099/* $ HISTORIQUE DES MODIFICATIONS : */
3100/* -------------------------------- */
3101/* 08-08-1991: RBD; Creation. */
3102/* > */
3103/* **********************************************************************
3104*/
3105
0d969553 3106/* Name of the routine */
7fd59977 3107
3108
3109 /* Parameter adjustments */
3110 --urootl;
3111 diditb_dim1 = *nbpntu / 2 + 1;
3112 diditb_dim2 = *nbpntv / 2 + 1;
3113 diditb_offset = diditb_dim1 * diditb_dim2;
3114 diditb -= diditb_offset;
3115 disotb_dim1 = *nbpntu / 2;
3116 disotb_dim2 = *nbpntv / 2;
3117 disotb_offset = disotb_dim1 * (disotb_dim2 + 1) + 1;
3118 disotb -= disotb_offset;
3119 soditb_dim1 = *nbpntu / 2;
3120 soditb_dim2 = *nbpntv / 2;
3121 soditb_offset = soditb_dim1 * (soditb_dim2 + 1) + 1;
3122 soditb -= soditb_offset;
3123 sosotb_dim1 = *nbpntu / 2 + 1;
3124 sosotb_dim2 = *nbpntv / 2 + 1;
3125 sosotb_offset = sosotb_dim1 * sosotb_dim2;
3126 sosotb -= sosotb_offset;
3127 uhermt_dim1 = (*iordru << 1) + 2;
3128 uhermt_offset = uhermt_dim1;
3129 uhermt -= uhermt_offset;
3130 fpntab_dim1 = *nbpntu;
3131 fpntab_offset = fpntab_dim1 + 1;
3132 fpntab -= fpntab_offset;
3133 ditbu2_dim1 = *nbpntv / 2 + 1;
3134 ditbu2_dim2 = *ndimen;
3135 ditbu2_offset = ditbu2_dim1 * (ditbu2_dim2 + 1);
3136 ditbu2 -= ditbu2_offset;
3137 ditbu1_dim1 = *nbpntv / 2 + 1;
3138 ditbu1_dim2 = *ndimen;
3139 ditbu1_offset = ditbu1_dim1 * (ditbu1_dim2 + 1);
3140 ditbu1 -= ditbu1_offset;
3141 sotbu2_dim1 = *nbpntv / 2 + 1;
3142 sotbu2_dim2 = *ndimen;
3143 sotbu2_offset = sotbu2_dim1 * (sotbu2_dim2 + 1);
3144 sotbu2 -= sotbu2_offset;
3145 sotbu1_dim1 = *nbpntv / 2 + 1;
3146 sotbu1_dim2 = *ndimen;
3147 sotbu1_offset = sotbu1_dim1 * (sotbu1_dim2 + 1);
3148 sotbu1 -= sotbu1_offset;
3149
3150 /* Function Body */
3151 ibb = AdvApp2Var_SysBase::mnfndeb_();
3152 if (ibb >= 3) {
3153 AdvApp2Var_SysBase::mgenmsg_("MMA2CD3", 7L);
3154 }
3155
0d969553 3156/* ------------------- Discretization of polynoms of Hermit -----------
7fd59977 3157*/
3158
3159 ncfhu = (*iordru + 1) << 1;
3160 i__1 = ncfhu;
3161 for (ii = 1; ii <= i__1; ++ii) {
3162 i__2 = *nbpntu;
3163 for (kk = 1; kk <= i__2; ++kk) {
3164 AdvApp2Var_MathBase::mmmpocur_(&ncfhu,
3165 &c__1,
3166 &ncfhu,
3167 &uhermt[ii * uhermt_dim1],
3168 &urootl[kk],
3169 &fpntab[kk + ii * fpntab_dim1]);
3170/* L60: */
3171 }
3172/* L50: */
3173 }
3174
0d969553 3175/* ---- The discretizations of polynoms of constraints are subtracted ----
7fd59977 3176*/
3177
3178 nvroo = *nbpntv / 2;
3179 nuroo = *nbpntu / 2;
3180
3181 i__1 = *ndimen;
3182 for (nd = 1; nd <= i__1; ++nd) {
3183 i__2 = *iordru + 1;
3184 for (ii = 1; ii <= i__2; ++ii) {
3185
3186 i__3 = nvroo;
3187 for (jj = 1; jj <= i__3; ++jj) {
3188 bid1 = sotbu1[jj + (nd + ii * sotbu1_dim2) * sotbu1_dim1];
3189 bid2 = sotbu2[jj + (nd + ii * sotbu2_dim2) * sotbu2_dim1];
3190 bid3 = ditbu1[jj + (nd + ii * ditbu1_dim2) * ditbu1_dim1];
3191 bid4 = ditbu2[jj + (nd + ii * ditbu2_dim2) * ditbu2_dim1];
3192 i__4 = nuroo;
3193 for (kk = 1; kk <= i__4; ++kk) {
3194 kkp = (*nbpntu + 1) / 2 + kk;
3195 kkm = nuroo - kk + 1;
3196 sosotb[kk + (jj + nd * sosotb_dim2) * sosotb_dim1] =
3197 sosotb[kk + (jj + nd * sosotb_dim2) * sosotb_dim1]
3198 - bid1 * (fpntab[kkp + ((ii << 1) - 1) *
3199 fpntab_dim1] + fpntab[kkm + ((ii << 1) - 1) *
3200 fpntab_dim1]) - bid2 * (fpntab[kkp + (ii << 1) *
3201 fpntab_dim1] + fpntab[kkm + (ii << 1) *
3202 fpntab_dim1]);
3203 disotb[kk + (jj + nd * disotb_dim2) * disotb_dim1] =
3204 disotb[kk + (jj + nd * disotb_dim2) * disotb_dim1]
3205 - bid1 * (fpntab[kkp + ((ii << 1) - 1) *
3206 fpntab_dim1] - fpntab[kkm + ((ii << 1) - 1) *
3207 fpntab_dim1]) - bid2 * (fpntab[kkp + (ii << 1) *
3208 fpntab_dim1] - fpntab[kkm + (ii << 1) *
3209 fpntab_dim1]);
3210 soditb[kk + (jj + nd * soditb_dim2) * soditb_dim1] =
3211 soditb[kk + (jj + nd * soditb_dim2) * soditb_dim1]
3212 - bid3 * (fpntab[kkp + ((ii << 1) - 1) *
3213 fpntab_dim1] + fpntab[kkm + ((ii << 1) - 1) *
3214 fpntab_dim1]) - bid4 * (fpntab[kkp + (ii << 1) *
3215 fpntab_dim1] + fpntab[kkm + (ii << 1) *
3216 fpntab_dim1]);
3217 diditb[kk + (jj + nd * diditb_dim2) * diditb_dim1] =
3218 diditb[kk + (jj + nd * diditb_dim2) * diditb_dim1]
3219 - bid3 * (fpntab[kkp + ((ii << 1) - 1) *
3220 fpntab_dim1] - fpntab[kkm + ((ii << 1) - 1) *
3221 fpntab_dim1]) - bid4 * (fpntab[kkp + (ii << 1) *
3222 fpntab_dim1] - fpntab[kkm + (ii << 1) *
3223 fpntab_dim1]);
3224/* L400: */
3225 }
3226/* L300: */
3227 }
3228/* L200: */
3229 }
3230
0d969553
Y
3231/* ------------ Case when the discretization is done only on the roots */
3232/* ---------- of Legendre polynom of uneven degree, 0 is root */
3233
3234
7fd59977 3235
3236 if (*nbpntu % 2 == 1) {
3237 i__2 = *iordru + 1;
3238 for (ii = 1; ii <= i__2; ++ii) {
3239 i__3 = nvroo;
3240 for (jj = 1; jj <= i__3; ++jj) {
3241 bid1 = sotbu1[jj + (nd + ii * sotbu1_dim2) * sotbu1_dim1]
3242 * fpntab[nuroo + 1 + ((ii << 1) - 1) *
3243 fpntab_dim1] + sotbu2[jj + (nd + ii * sotbu2_dim2)
3244 * sotbu2_dim1] * fpntab[nuroo + 1 + (ii << 1) *
3245 fpntab_dim1];
3246 sosotb[(jj + nd * sosotb_dim2) * sosotb_dim1] -= bid1;
3247 bid2 = ditbu1[jj + (nd + ii * ditbu1_dim2) * ditbu1_dim1]
3248 * fpntab[nuroo + 1 + ((ii << 1) - 1) *
3249 fpntab_dim1] + ditbu2[jj + (nd + ii * ditbu2_dim2)
3250 * ditbu2_dim1] * fpntab[nuroo + 1 + (ii << 1) *
3251 fpntab_dim1];
3252 diditb[(jj + nd * diditb_dim2) * diditb_dim1] -= bid2;
3253/* L550: */
3254 }
3255/* L500: */
3256 }
3257 }
3258
3259 if (*nbpntv % 2 == 1) {
3260 i__2 = *iordru + 1;
3261 for (ii = 1; ii <= i__2; ++ii) {
3262 i__3 = nuroo;
3263 for (kk = 1; kk <= i__3; ++kk) {
3264 kkp = (*nbpntu + 1) / 2 + kk;
3265 kkm = nuroo - kk + 1;
3266 bid1 = sotbu1[(nd + ii * sotbu1_dim2) * sotbu1_dim1] * (
3267 fpntab[kkp + ((ii << 1) - 1) * fpntab_dim1] +
3268 fpntab[kkm + ((ii << 1) - 1) * fpntab_dim1]) +
3269 sotbu2[(nd + ii * sotbu2_dim2) * sotbu2_dim1] * (
3270 fpntab[kkp + (ii << 1) * fpntab_dim1] + fpntab[
3271 kkm + (ii << 1) * fpntab_dim1]);
3272 sosotb[kk + nd * sosotb_dim2 * sosotb_dim1] -= bid1;
3273 bid2 = sotbu1[(nd + ii * sotbu1_dim2) * sotbu1_dim1] * (
3274 fpntab[kkp + ((ii << 1) - 1) * fpntab_dim1] -
3275 fpntab[kkm + ((ii << 1) - 1) * fpntab_dim1]) +
3276 sotbu2[(nd + ii * sotbu2_dim2) * sotbu2_dim1] * (
3277 fpntab[kkp + (ii << 1) * fpntab_dim1] - fpntab[
3278 kkm + (ii << 1) * fpntab_dim1]);
3279 diditb[kk + nd * diditb_dim2 * diditb_dim1] -= bid2;
3280/* L650: */
3281 }
3282/* L600: */
3283 }
3284 }
3285
3286 if (*nbpntu % 2 == 1 && *nbpntv % 2 == 1) {
3287 i__2 = *iordru + 1;
3288 for (ii = 1; ii <= i__2; ++ii) {
3289 bid1 = sotbu1[(nd + ii * sotbu1_dim2) * sotbu1_dim1] * fpntab[
3290 nuroo + 1 + ((ii << 1) - 1) * fpntab_dim1] + sotbu2[(
3291 nd + ii * sotbu2_dim2) * sotbu2_dim1] * fpntab[nuroo
3292 + 1 + (ii << 1) * fpntab_dim1];
3293 sosotb[nd * sosotb_dim2 * sosotb_dim1] -= bid1;
3294/* L700: */
3295 }
3296 }
3297
3298/* L100: */
3299 }
3300 goto L9999;
3301
3302/* ------------------------------ The End -------------------------------
3303*/
3304
3305L9999:
3306 if (ibb >= 3) {
3307 AdvApp2Var_SysBase::mgsomsg_("MMA2CD3", 7L);
3308 }
3309 return 0;
3310} /* mma2cd3_ */
3311
3312//=======================================================================
3313//function : mma2cdi_
3314//purpose :
3315//=======================================================================
3316int AdvApp2Var_ApproxF2var::mma2cdi_( integer *ndimen,
3317 integer *nbpntu,
3318 doublereal *urootl,
3319 integer *nbpntv,
3320 doublereal *vrootl,
3321 integer *iordru,
3322 integer *iordrv,
3323 doublereal *contr1,
3324 doublereal *contr2,
3325 doublereal *contr3,
3326 doublereal *contr4,
3327 doublereal *sotbu1,
3328 doublereal *sotbu2,
3329 doublereal *ditbu1,
3330 doublereal *ditbu2,
3331 doublereal *sotbv1,
3332 doublereal *sotbv2,
3333 doublereal *ditbv1,
3334 doublereal *ditbv2,
3335 doublereal *sosotb,
3336 doublereal *soditb,
3337 doublereal *disotb,
3338 doublereal *diditb,
3339 integer *iercod)
3340
3341{
3342 static integer c__8 = 8;
3343
3344 /* System generated locals */
3345 integer contr1_dim1, contr1_dim2, contr1_offset, contr2_dim1, contr2_dim2,
3346 contr2_offset, contr3_dim1, contr3_dim2, contr3_offset,
3347 contr4_dim1, contr4_dim2, contr4_offset, sosotb_dim1, sosotb_dim2,
3348 sosotb_offset, diditb_dim1, diditb_dim2, diditb_offset,
3349 soditb_dim1, soditb_dim2, soditb_offset, disotb_dim1, disotb_dim2,
3350 disotb_offset;
3351
3352 /* Local variables */
3353 static integer ilong;
3354 static long int iofwr;
3355 static doublereal wrkar[1];
3356 static integer iszwr;
3357 static integer ibb, ier;
3358 static integer isz1, isz2, isz3, isz4;
3359 static long int ipt1, ipt2, ipt3, ipt4;
3360
3361
3362
3363
3364/* **********************************************************************
3365*/
3366
0d969553 3367/* FUNCTION : */
7fd59977 3368/* ---------- */
0d969553
Y
3369/* Discretisation on the parameters of polynomes of interpolation */
3370/* of constraints of order IORDRE. */
7fd59977 3371
0d969553 3372/* KEYWORDS : */
7fd59977 3373/* ----------- */
3374/* TOUS, AB_SPECIFI::CONTRAINTE&, DISCRETISATION, &POINT */
3375
0d969553 3376//* INPUT ARGUMENTS : */
7fd59977 3377/* ------------------ */
0d969553
Y
3378/* NDIMEN: Dimension of the space. */
3379/* NBPNTU: Nb of INTERNAL parameters of discretisation by U. */
3380/* This is also the nb of root of Legendre polynom where discretization is done. */
3381/* UROOTL: Table of parameters of discretisation ON (-1,1) by U.
3382*/
3383/* NBPNTV: Nb of INTERNAL parameters of discretisation by V. */
3384/* This is also the nb of root of Legendre polynom where discretization is done. */
3385/* VROOTL: Table of parameters of discretisation ON (-1,1) by V.
3386
3387/* IORDRV: Order of constraint imposed at the extremities of iso-U */
3388/* = 0, calculate the extremities of iso-U */
3389/* = 1, calculate, additionally, the 1st derivative in the direction of iso-U */
3390/* = 2, calculate, additionally, the 2nd derivative in the direction of iso-U */
3391/* IORDRU: Order of constraint imposed at the extremities of iso-V */
3392/* = 0, calculate the extremities of iso-V */
3393/* = 1, calculate, additionally, the 1st derivative in the direction of iso-V */
3394/* = 2, calculate, additionally, the 2nd derivative in the direction of iso-V */
3395/* CONTR1: Contains, if IORDRU and IORDRV>=0, the values at the */
3396/* extremities of F(U0,V0) and its derivatives. */
3397/* CONTR2: Contains, if IORDRU and IORDRV>=0, the values at the */
3398/* extremities of F(U1,V0) and its derivatives. */
3399/* CONTR3: Contains, if IORDRU and IORDRV>=0, the values at the */
3400/* extremities of F(U0,V1) and its derivatives. */
3401/* CONTR4: Contains, if IORDRU and IORDRV>=0, the values at the */