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