projects / occt.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Integration of OCCT 6.5.0 from SVN
[occt.git] / src / AdvApp2Var / AdvApp2Var_ApproxF2var.cxx
CommitLineData
7fd59977 1//
2// AdvApp2Var_ApproxF2var.cxx
3//
4#include <math.h>
5#include <AdvApp2Var_SysBase.hxx>
6#include <AdvApp2Var_MathBase.hxx>
7#include <AdvApp2Var_Data_f2c.hxx>
8#include <AdvApp2Var_Data.hxx>
9#include <AdvApp2Var_ApproxF2var.hxx>
10
11
12static
13int mmjacpt_(const integer *ndimen,
14 const integer *ncoefu,
15 const integer *ncoefv,
16 const integer *iordru,
17 const integer *iordrv,
18 const doublereal *ptclgd,
19 doublereal *ptcaux,
20 doublereal *ptccan);
21
22
23
24static
25int mma2ce2_(integer *numdec,
26 integer *ndimen,
27 integer *nbsesp,
28 integer *ndimse,
29 integer *ndminu,
30 integer *ndminv,
31 integer *ndguli,
32 integer *ndgvli,
33 integer *ndjacu,
34 integer *ndjacv,
35 integer *iordru,
36 integer *iordrv,
37 integer *nbpntu,
38 integer *nbpntv,
39 doublereal *epsapr,
40 doublereal *sosotb,
41 doublereal *disotb,
42 doublereal *soditb,
43 doublereal *diditb,
44 doublereal *gssutb,
45 doublereal *gssvtb,
46 doublereal *xmaxju,
47 doublereal *xmaxjv,
48 doublereal *vecerr,
49 doublereal *chpair,
50 doublereal *chimpr,
51 doublereal *patjac,
52 doublereal *errmax,
53 doublereal *errmoy,
54 integer *ndegpu,
55 integer *ndegpv,
56 integer *itydec,
57 integer *iercod);
58
59static
60int mma2cfu_(integer *ndujac,
61 integer *nbpntu,
62 integer *nbpntv,
63 doublereal *sosotb,
64 doublereal *disotb,
65 doublereal *soditb,
66 doublereal *diditb,
67 doublereal *gssutb,
68 doublereal *chpair,
69 doublereal *chimpr);
70
71static
72int mma2cfv_(integer *ndvjac,
73 integer *mindgu,
74 integer *maxdgu,
75 integer *nbpntv,
76 doublereal *gssvtb,
77 doublereal *chpair,
78 doublereal *chimpr,
79 doublereal *patjac);
80
81static
82int mma2er1_(integer *ndjacu,
83 integer *ndjacv,
84 integer *ndimen,
85 integer *mindgu,
86 integer *maxdgu,
87 integer *mindgv,
88 integer *maxdgv,
89 integer *iordru,
90 integer *iordrv,
91 doublereal *xmaxju,
92 doublereal *xmaxjv,
93 doublereal *patjac,
94 doublereal *vecerr,
95 doublereal *erreur);
96
97static
98int mma2er2_(integer *ndjacu,
99 integer *ndjacv,
100 integer *ndimen,
101 integer *mindgu,
102 integer *maxdgu,
103 integer *mindgv,
104 integer *maxdgv,
105 integer *iordru,
106 integer *iordrv,
107 doublereal *xmaxju,
108 doublereal *xmaxjv,
109 doublereal *patjac,
110 doublereal *epmscut,
111 doublereal *vecerr,
112 doublereal *erreur,
113 integer *newdgu,
114 integer *newdgv);
115
116static
117int mma2moy_(integer *ndgumx,
118 integer *ndgvmx,
119 integer *ndimen,
120 integer *mindgu,
121 integer *maxdgu,
122 integer *mindgv,
123 integer *maxdgv,
124 integer *iordru,
125 integer *iordrv,
126 doublereal *patjac,
127 doublereal *errmoy);
128
129static
130int mma2ds2_(integer *ndimen,
131 doublereal *uintfn,
132 doublereal *vintfn,
133 void (*foncnp) (
134 int *,
135 double *,
136 double *,
137 int *,
138 double *,
139 int *,
140 double *,
141 int *,
142 int *,
143 double *,
144 int *
145 ),
146 integer *nbpntu,
147 integer *nbpntv,
148 doublereal *urootb,
149 doublereal *vrootb,
150 integer *iiuouv,
151 doublereal *sosotb,
152 doublereal *disotb,
153 doublereal *soditb,
154 doublereal *diditb,
155 doublereal *fpntab,
156 doublereal *ttable,
157 integer *iercod);
158
159
160
161
162static
163int mma1fdi_(integer *ndimen,
164 doublereal *uvfonc,
165 void (*foncnp) (// see AdvApp2Var_EvaluatorFunc2Var.hxx for details
166 int *,
167 double *,
168 double *,
169 int *,
170 double *,
171 int *,
172 double *,
173 int *,
174 int *,
175 double *,
176 int *
177 ),
178 integer *isofav,
179 doublereal *tconst,
180 integer *nbroot,
181 doublereal *ttable,
182 integer *iordre,
183 integer *ideriv,
184 doublereal *fpntab,
185 doublereal *somtab,
186 doublereal *diftab,
187 doublereal *contr1,
188 doublereal *contr2,
189 integer *iercod);
190
191static
192int mma1cdi_(integer *ndimen,
193 integer *nbroot,
194 doublereal *rootlg,
195 integer *iordre,
196 doublereal *contr1,
197 doublereal *contr2,
198 doublereal *somtab,
199 doublereal *diftab,
200 doublereal *fpntab,
201 doublereal *hermit,
202 integer *iercod);
203static
204int mma1jak_(integer *ndimen,
205 integer *nbroot,
206 integer *iordre,
207 integer *ndgjac,
208 doublereal *somtab,
209 doublereal *diftab,
210 doublereal *cgauss,
211 doublereal *crvjac,
212 integer *iercod);
213static
214int mma1cnt_(integer *ndimen,
215 integer *iordre,
216 doublereal *contr1,
217 doublereal *contr2,
218 doublereal *hermit,
219 integer *ndgjac,
220 doublereal *crvjac);
221
222static
223int mma1fer_(integer *ndimen,
224 integer *nbsesp,
225 integer *ndimse,
226 integer *iordre,
227 integer *ndgjac,
228 doublereal *crvjac,
229 integer *ncflim,
230 doublereal *epsapr,
231 doublereal *ycvmax,
232 doublereal *errmax,
233 doublereal *errmoy,
234 integer *ncoeff,
235 integer *iercod);
236
237static
238int mma1noc_(doublereal *dfuvin,
239 integer *ndimen,
240 integer *iordre,
241 doublereal *cntrin,
242 doublereal *duvout,
243 integer *isofav,
244 integer *ideriv,
245 doublereal *cntout);
246
247
248static
249 int mmmapcoe_(integer *ndim,
250 integer *ndgjac,
251 integer *iordre,
252 integer *nbpnts,
253 doublereal *somtab,
254 doublereal *diftab,
255 doublereal *gsstab,
256 doublereal *crvjac);
257
258static
259 int mmaperm_(integer *ncofmx,
260 integer *ndim,
261 integer *ncoeff,
262 integer *iordre,
263 doublereal *crvjac,
264 integer *ncfnew,
265 doublereal *errmoy);
266
267
268#define mmapgss_1 mmapgss_
269#define mmapgs0_1 mmapgs0_
270#define mmapgs1_1 mmapgs1_
271#define mmapgs2_1 mmapgs2_
272
273//=======================================================================
274//function : mma1cdi_
275//purpose :
276//=======================================================================
277int mma1cdi_(integer *ndimen,
278 integer *nbroot,
279 doublereal *rootlg,
280 integer *iordre,
281 doublereal *contr1,
282 doublereal *contr2,
283 doublereal *somtab,
284 doublereal *diftab,
285 doublereal *fpntab,
286 doublereal *hermit,
287 integer *iercod)
288{
289 static integer c__1 = 1;
290
291 /* System generated locals */
292 integer contr1_dim1, contr1_offset, contr2_dim1, contr2_offset,
293 somtab_dim1, somtab_offset, diftab_dim1, diftab_offset,
294 fpntab_dim1, fpntab_offset, hermit_dim1, hermit_offset, i__1,
295 i__2, i__3;
296
297 /* Local variables */
298 static integer nroo2, ncfhe, nd, ii, kk;
299 static integer ibb, kkm, kkp;
300 static doublereal bid1, bid2, bid3;
301
302
303/* **********************************************************************
304*/
305
306/* FONCTION : */
307/* ---------- */
308/* Discretisation sur les parametres des polynomes d'interpolation */
309/* des contraintes a l'ordre IORDRE. */
310
311/* MOTS CLES : */
312/* ----------- */
313/* TOUS, AB_SPECIFI::CONTRAINTE&, DISCRETISATION, &POINT */
314
315/* ARGUMENTS D'ENTREE : */
316/* ------------------ */
317/* NDIMEN: Dimension de l' espace. */
318/* NBROOT: Nbre de parametres INTERNES de discretisation. */
319/* C'est aussi le nbre de racine du polynome de Legendre ou */
320/* on discretise. */
321/* ROOTLG: Tableau des parametres de discretisation SUR (-1,1). */
322/* IORDRE: Ordre de contrainte impose aux extremites de l'iso. */
323/* = 0, on calcule les extremites de l'iso */
324/* = 1, on calcule, en plus, la derivee 1ere dans le sens */
325/* de l'iso */
326/* = 2, on calcule, en plus, la derivee 2nde dans le sens */
327/* de l'iso */
328/* CONTR1: Contient, si IORDRE>=0, les IORDRE+1 valeurs en TTABLE(0)
329*/
330/* (1ere extremitee) de derivees de F(Uc,Ve) ou F(Ue,Vc), */
331/* voir ci dessous. */
332/* CONTR2: Contient, si IORDRE>=0, les IORDRE+1 valeurs en */
333/* TTABLE(NBROOT+1) (2eme extremitee) de: */
334/* Si ISOFAV=1, derivee d'ordre IDERIV en U, derivee */
335/* d'ordre 0 a IORDRE en V de F(Uc,Ve) ou Uc=TCONST */
336/* (valeur de l'iso fixe) et Ve est l'extremite fixe. */
337/* Si ISOFAV=2, derivee d'ordre IDERIV en V, derivee */
338/* d'ordre 0 a IORDRE en U de F(Ue,Vc) ou Vc=TCONST */
339/* (valeur de l'iso fixe) et Ue est l'extremite fixe. */
340
341/* SOMTAB: Tableau des NBROOT/2 sommes des 2 points d'indices */
342/* NBROOT-II+1 et II, pour II = 1, NBROOT/2. */
343/* DIFTAB: Tableau des NBROOT/2 differences des 2 points d'indices */
344/* NBROOT-II+1 et II, pour II = 1, NBROOT/2. */
345
346/* ARGUMENTS DE SORTIE : */
347/* ------------------- */
348/* SOMTAB: Tableau des NBROOT/2 sommes des 2 points d'indices */
349/* NBROOT-II+1 et II, pour II = 1, NBROOT/2 */
350/* DIFTAB: Tableau des NBROOT/2 differences des 2 points d'indices */
351/* NBROOT-II+1 et II, pour II = 1, NBROOT/2 */
352/* FPNTAB: Tableau auxiliaire. */
353/* HERMIT: Table des coeff. des 2*(IORDRE+1) polynomes d'Hermite */
354/* de degre 2*IORDRE+1. */
355/* IERCOD: Code d'erreur, */
356/* = 0, Tout est OK */
357/* = 1, La valeur de IORDRE est hors de (0,2) */
358
359/* COMMONS UTILISES : */
360/* ---------------- */
361
362/* REFERENCES APPELEES : */
363/* ----------------------- */
364
365/* DESCRIPTION/REMARQUES/LIMITATIONS : */
366/* ----------------------------------- */
367/* Les resultats de la discretisation sont ranges dans 2 tableaux */
368/* SOMTAB et DIFTAB pour gagner du temps par la suite lors du */
369/* calcul des coefficients de la courbe d' approximation. */
370
371/* Si NBROOT est impair, on stocke dans SOMTAB(0,*) et DIFTAB(0,*) */
372/* les valeurs de la racine mediane de Legendre (0.D0 dans (-1,1)). */
373
374
375/* $ HISTORIQUE DES MODIFICATIONS : */
376/* -------------------------------- */
377/* 02-07-1991: RBD; Creation. */
378/* > */
379/* **********************************************************************
380*/
381
382/* Le nom de la routine */
383
384
385 /* Parameter adjustments */
386 diftab_dim1 = *nbroot / 2 + 1;
387 diftab_offset = diftab_dim1;
388 diftab -= diftab_offset;
389 somtab_dim1 = *nbroot / 2 + 1;
390 somtab_offset = somtab_dim1;
391 somtab -= somtab_offset;
392 --rootlg;
393 hermit_dim1 = (*iordre << 1) + 2;
394 hermit_offset = hermit_dim1;
395 hermit -= hermit_offset;
396 fpntab_dim1 = *nbroot;
397 fpntab_offset = fpntab_dim1 + 1;
398 fpntab -= fpntab_offset;
399 contr2_dim1 = *ndimen;
400 contr2_offset = contr2_dim1 + 1;
401 contr2 -= contr2_offset;
402 contr1_dim1 = *ndimen;
403 contr1_offset = contr1_dim1 + 1;
404 contr1 -= contr1_offset;
405
406 /* Function Body */
407 ibb = AdvApp2Var_SysBase::mnfndeb_();
408 if (ibb >= 3) {
409 AdvApp2Var_SysBase::mgenmsg_("MMA1CDI", 7L);
410 }
411 *iercod = 0;
412
413/* --- Recup des 2*(IORDRE+1) coeff des 2*(IORDRE+1) polyn. d'Hermite ---
414*/
415
416 AdvApp2Var_ApproxF2var::mma1her_(iordre, &hermit[hermit_offset], iercod);
417 if (*iercod > 0) {
418 goto L9100;
419 }
420
421/* ------------------- Discretisation des polynomes d'Hermite -----------
422*/
423
424 ncfhe = (*iordre + 1) << 1;
425 i__1 = ncfhe;
426 for (ii = 1; ii <= i__1; ++ii) {
427 i__2 = *nbroot;
428 for (kk = 1; kk <= i__2; ++kk) {
429 AdvApp2Var_MathBase::mmmpocur_(&ncfhe, &c__1, &ncfhe, &hermit[ii * hermit_dim1], &
430 rootlg[kk], &fpntab[kk + ii * fpntab_dim1]);
431/* L200: */
432 }
433/* L100: */
434 }
435
436/* ---- On retranche les discretisations des polynomes de contrainte ----
437*/
438
439 nroo2 = *nbroot / 2;
440 i__1 = *ndimen;
441 for (nd = 1; nd <= i__1; ++nd) {
442 i__2 = *iordre + 1;
443 for (ii = 1; ii <= i__2; ++ii) {
444 bid1 = contr1[nd + ii * contr1_dim1];
445 bid2 = contr2[nd + ii * contr2_dim1];
446 i__3 = nroo2;
447 for (kk = 1; kk <= i__3; ++kk) {
448 kkm = nroo2 - kk + 1;
449 bid3 = bid1 * fpntab[kkm + ((ii << 1) - 1) * fpntab_dim1] +
450 bid2 * fpntab[kkm + (ii << 1) * fpntab_dim1];
451 somtab[kk + nd * somtab_dim1] -= bid3;
452 diftab[kk + nd * diftab_dim1] += bid3;
453/* L500: */
454 }
455 i__3 = nroo2;
456 for (kk = 1; kk <= i__3; ++kk) {
457 kkp = (*nbroot + 1) / 2 + kk;
458 bid3 = bid1 * fpntab[kkp + ((ii << 1) - 1) * fpntab_dim1] +
459 bid2 * fpntab[kkp + (ii << 1) * fpntab_dim1];
460 somtab[kk + nd * somtab_dim1] -= bid3;
461 diftab[kk + nd * diftab_dim1] -= bid3;
462/* L600: */
463 }
464/* L400: */
465 }
466/* L300: */
467 }
468
469/* ------------ Cas ou l' on discretise sur les racines d' un -----------
470*/
471/* ---------- polynome de Legendre de degre impair, 0 est racine --------
472*/
473
474 if (*nbroot % 2 == 1) {
475 i__1 = *ndimen;
476 for (nd = 1; nd <= i__1; ++nd) {
477 i__2 = *iordre + 1;
478 for (ii = 1; ii <= i__2; ++ii) {
479 bid3 = fpntab[nroo2 + 1 + ((ii << 1) - 1) * fpntab_dim1] *
480 contr1[nd + ii * contr1_dim1] + fpntab[nroo2 + 1 + (
481 ii << 1) * fpntab_dim1] * contr2[nd + ii *
482 contr2_dim1];
483/* L800: */
484 }
485 somtab[nd * somtab_dim1] -= bid3;
486 diftab[nd * diftab_dim1] -= bid3;
487/* L700: */
488 }
489 }
490
491 goto L9999;
492
493/* ------------------------------ The End -------------------------------
494*/
495/* --> IORDRE n'est pas dans la plage autorisee. */
496L9100:
497 *iercod = 1;
498 goto L9999;
499
500L9999:
501 if (ibb >= 3) {
502 AdvApp2Var_SysBase::mgsomsg_("MMA1CDI", 7L);
503 }
504 return 0;
505} /* mma1cdi_ */
506
507//=======================================================================
508//function : mma1cnt_
509//purpose :
510//=======================================================================
511int mma1cnt_(integer *ndimen,
512 integer *iordre,
513 doublereal *contr1,
514 doublereal *contr2,
515 doublereal *hermit,
516 integer *ndgjac,
517 doublereal *crvjac)
518{
519 /* System generated locals */
520 integer contr1_dim1, contr1_offset, contr2_dim1, contr2_offset,
521 hermit_dim1, hermit_offset, crvjac_dim1, crvjac_offset, i__1,
522 i__2, i__3;
523
524 /* Local variables */
525 static integer nd, ii, jj, ibb;
526 static doublereal bid;
527
528
529 /* ***********************************************************************
530 */
531
532 /* FONCTION : */
533 /* ---------- */
534 /* Ajout du polynome de contrainte. */
535
536 /* MOTS CLES : */
537 /* ----------- */
538 /* TOUS,AB_SPECIFI::COURE&,APPROXIMATION,ADDITION,&CONTRAINTE */
539
540 /* ARGUMENTS D'ENTREE : */
541 /* -------------------- */
542 /* NDIMEN: Dimension de l'espace */
543 /* IORDRE: Ordre de contrainte. */
544 /* CONTR1: pt de contrainte en -1, de l'ordre 0 a IORDRE. */
545 /* CONTR2: Pt de contrainte en +1, de l'ordre 0 a IORDRE. */
546 /* HERMIT: Table des polynomes d'hermite d'ordre IORDRE. */
547 /* CRVJAV: Courbe d'approximation dans la base de Jacobi. */
548
549 /* ARGUMENTS DE SORTIE : */
550 /* --------------------- */
551 /* CRVJAV: Courbe d'approximation dans la base de Jacobi */
552 /* a laquelle on a ajoute le polynome d'interpolation des */
553 /* contraintes. */
554
555 /* COMMONS UTILISES : */
556 /* ------------------ */
557
558
559 /* REFERENCES APPELEES : */
560 /* --------------------- */
561
562
563/* DESCRIPTION/REMARQUES/LIMITATIONS : */
564/* ----------------------------------- */
565
566
567/* $ HISTORIQUE DES MODIFICATIONS : */
568/* ------------------------------ */
569/* 07-08-91:RBD; Ecriture version originale. */
570/* > */
571/* ***********************************************************************
572 */
573/* DECLARATIONS */
574/* ***********************************************************************
575 */
576/* Le nom de la routine */
577
578/* ***********************************************************************
579 */
580/* INITIALISATIONS */
581/* ***********************************************************************
582 */
583
584 /* Parameter adjustments */
585 hermit_dim1 = (*iordre << 1) + 2;
586 hermit_offset = hermit_dim1;
587 hermit -= hermit_offset;
588 contr2_dim1 = *ndimen;
589 contr2_offset = contr2_dim1 + 1;
590 contr2 -= contr2_offset;
591 contr1_dim1 = *ndimen;
592 contr1_offset = contr1_dim1 + 1;
593 contr1 -= contr1_offset;
594 crvjac_dim1 = *ndgjac + 1;
595 crvjac_offset = crvjac_dim1;
596 crvjac -= crvjac_offset;
597
598 /* Function Body */
599 ibb = AdvApp2Var_SysBase::mnfndeb_();
600 if (ibb >= 3) {
601 AdvApp2Var_SysBase::mgenmsg_("MMA1CNT", 7L);
602 }
603
604/* ***********************************************************************
605 */
606/* TRAITEMENT */
607/* ***********************************************************************
608 */
609
610 i__1 = *ndimen;
611 for (nd = 1; nd <= i__1; ++nd) {
612 i__2 = (*iordre << 1) + 1;
613 for (ii = 0; ii <= i__2; ++ii) {
614 bid = 0.;
615 i__3 = *iordre + 1;
616 for (jj = 1; jj <= i__3; ++jj) {
617 bid = bid + contr1[nd + jj * contr1_dim1] *
618 hermit[ii + ((jj << 1) - 1) * hermit_dim1] +
619 contr2[nd + jj * contr2_dim1] * hermit[ii + (jj << 1) * hermit_dim1];
620 /* L300: */
621 }
622 crvjac[ii + nd * crvjac_dim1] = bid;
623 /* L200: */
624 }
625 /* L100: */
626 }
627
628/* ***********************************************************************
629 */
630/* RETOUR PROGRAMME APPELANT */
631/* ***********************************************************************
632 */
633
634 if (ibb >= 3) {
635 AdvApp2Var_SysBase::mgsomsg_("MMA1CNT", 7L);
636 }
637
638 return 0 ;
639} /* mma1cnt_ */
640
641//=======================================================================
642//function : mma1fdi_
643//purpose :
644//=======================================================================
645int mma1fdi_(integer *ndimen,
646 doublereal *uvfonc,
647 void (*foncnp) (// see AdvApp2Var_EvaluatorFunc2Var.hxx for details
648 int *,
649 double *,
650 double *,
651 int *,
652 double *,
653 int *,
654 double *,
655 int *,
656 int *,
657 double *,
658 int *
659 ),
660 integer *isofav,
661 doublereal *tconst,
662 integer *nbroot,
663 doublereal *ttable,
664 integer *iordre,
665 integer *ideriv,
666 doublereal *fpntab,
667 doublereal *somtab,
668 doublereal *diftab,
669 doublereal *contr1,
670 doublereal *contr2,
671 integer *iercod)
672{
673 /* System generated locals */
674 integer fpntab_dim1, somtab_dim1, somtab_offset, diftab_dim1,
675 diftab_offset, contr1_dim1, contr1_offset, contr2_dim1,
676 contr2_offset, i__1, i__2;
677 doublereal d__1;
678
679 /* Local variables */
680 static integer ideb, ifin, nroo2, ideru, iderv;
681 static doublereal renor;
682 static integer ii, nd, ibb, iim, nbp, iip;
683 static doublereal bid1, bid2;
684
685/* **********************************************************************
686*/
687
688/* FONCTION : */
689/* ---------- */
690/* Discretisation d' une fonction non polynomiale F(U,V) ou d'une */
691/* de ses derivees a isoparametre fixe. */
692
693/* MOTS CLES : */
694/* ----------- */
695/* TOUS, AB_SPECIFI::FONCTION&, DISCRETISATION, &POINT */
696
697/* ARGUMENTS D'ENTREE : */
698/* ------------------ */
699/* NDIMEN: Dimension de l' espace. */
700/* UVFONC: Bornes du pave de definition en U et en V de la fonction */
701/* a approcher. */
702/* FONCNP: Le NOM de la fonction non polynomiale a approcher */
703/* (programme externe). */
704/* ISOFAV: Isoparametre fixe pour la discretisation; */
705/* = 1, on discretise a U fixe et V variable. */
706/* = 2, on discretise a V fixe et U variable. */
707/* TCONST: Valeur de l'iso fixe. */
708/* NBROOT: Nbre de parametres INTERNES de discretisation. */
709/* (s'il y a des contraintes, on doit ajouter 2 extremites).
710*/
711/* C'est aussi le nbre de racine du polynome de Legendre ou */
712/* on discretise. */
713/* TTABLE: Tableau des parametres de discretisation et des 2 */
714/* extremites */
715/* (Respectivement (-1, NBROOT racines de Legendre,1) */
716/* recadrees dans l'intervalle adequat. */
717/* IORDRE: Ordre de contrainte impose aux extremites de l'iso. */
718/* (Si Iso-U, on doit calculer les derivees en V et vice */
719/* versa). */
720/* = 0, on calcule les extremites de l'iso */
721/* = 1, on calcule, en plus, la derivee 1ere dans le sens */
722/* de l'iso */
723/* = 2, on calcule, en plus, la derivee 2nde dans le sens */
724/* de l'iso */
725/* IDERIV: Ordre de derivee transverse a l'iso fixee (Si Iso-U=Uc */
726/* fixee, on discretise la derivee d'ordre IDERIV en U de */
727/* F(Uc,v). Idem si on fixe une iso-V). */
728/* Varie de 0 (positionnement) a 2 (derivee 2nde). */
729
730/* ARGUMENTS DE SORTIE : */
731/* ------------------- */
732/* FPNTAB: Tableau auxiliaire. */
733/* SOMTAB: Tableau des NBROOT/2 sommes des 2 points d'indices */
734/* NBROOT-II+1 et II, pour II = 1, NBROOT/2 */
735/* DIFTAB: Tableau des NBROOT/2 differences des 2 points d'indices */
736/* NBROOT-II+1 et II, pour II = 1, NBROOT/2 */
737/* CONTR1: Contient, si IORDRE>=0, les IORDRE+1 valeurs en TTABLE(0)
738*/
739/* (1ere extremitee) de derivees de F(Uc,Ve) ou F(Ue,Vc), */
740/* voir ci dessous. */
741/* CONTR2: Contient, si IORDRE>=0, les IORDRE+1 valeurs en */
742/* TTABLE(NBROOT+1) (2eme extremitee) de: */
743/* Si ISOFAV=1, derivee d'ordre IDERIV en U, derivee */
744/* d'ordre 0 a IORDRE en V de F(Uc,Ve) ou Uc=TCONST */
745/* (valeur de l'iso fixe) et Ve est l'extremite fixe. */
746/* Si ISOFAV=2, derivee d'ordre IDERIV en V, derivee */
747/* d'ordre 0 a IORDRE en U de F(Ue,Vc) ou Vc=TCONST */
748/* (valeur de l'iso fixe) et Ue est l'extremite fixe. */
749/* IERCOD: Code d' erreur > 100; Pb dans l' evaluation de FONCNP, */
750/* le code d'erreur renvoye est egal au code d' erreur */
751/* de FONCNP + 100. */
752
753/* COMMONS UTILISES : */
754/* ---------------- */
755
756/* REFERENCES APPELEES : */
757/* ----------------------- */
758
759/* DESCRIPTION/REMARQUES/LIMITATIONS : */
760/* ----------------------------------- */
761/* Les resultats de la discretisation sont ranges dans 2 tableaux */
762/* SOMTAB et DIFTAB pour gagner du temps par la suite lors du */
763/* calcul des coefficients de la courbe d' approximation. */
764
765/* Si NBROOT est impair, on stocke dans SOMTAB(0,*) et DIFTAB(0,*) */
766/* les valeurs de la racine mediane de Legendre (0.D0 dans (-1,1)). */
767
768/* La fonction F(u,v) definie dans UVFONC est reparametre dans */
769/* (-1,1)x(-1,1). On renormalise donc les derivees 1eres et 2ndes. */
770
771/* $ HISTORIQUE DES MODIFICATIONS : */
772/* -------------------------------- */
773/* 24-06-1991: RBD; Creation. */
774/* > */
775/* **********************************************************************
776*/
777
778/* Le nom de la routine */
779
780
781 /* Parameter adjustments */
782 uvfonc -= 3;
783 diftab_dim1 = *nbroot / 2 + 1;
784 diftab_offset = diftab_dim1;
785 diftab -= diftab_offset;
786 somtab_dim1 = *nbroot / 2 + 1;
787 somtab_offset = somtab_dim1;
788 somtab -= somtab_offset;
789 fpntab_dim1 = *ndimen;
790 --fpntab;
791 contr2_dim1 = *ndimen;
792 contr2_offset = contr2_dim1 + 1;
793 contr2 -= contr2_offset;
794 contr1_dim1 = *ndimen;
795 contr1_offset = contr1_dim1 + 1;
796 contr1 -= contr1_offset;
797
798 /* Function Body */
799 ibb = AdvApp2Var_SysBase::mnfndeb_();
800 if (ibb >= 3) {
801 AdvApp2Var_SysBase::mgenmsg_("MMA1FDI", 7L);
802 }
803 *iercod = 0;
804
805/* --------------- Definition du nbre de points a calculer --------------
806*/
807/* --> Si contraintes, on prend aussi les bornes */
808 if (*iordre >= 0) {
809 ideb = 0;
810 ifin = *nbroot + 1;
811/* --> Sinon, seule les racines de Legendre (recadrees) sont utilisees
812. */
813 } else {
814 ideb = 1;
815 ifin = *nbroot;
816 }
817/* --> Nbre de point a calculer. */
818 nbp = ifin - ideb + 1;
819 nroo2 = *nbroot / 2;
820
821/* --------------- Determination de l'ordre de derivation global --------
822*/
823/* --> Ici ISOFAV ne prend que les valeurs 1 ou 2. */
824/* Si Iso-U, on derive en U a l'ordre IDERIV */
825 if (*isofav == 1) {
826 ideru = *ideriv;
827 iderv = 0;
828 d__1 = (uvfonc[4] - uvfonc[3]) / 2.;
829 renor = AdvApp2Var_MathBase::pow__di(&d__1, ideriv);
830/* Si Iso-V, on derive en V a l'ordre IDERIV */
831 } else {
832 ideru = 0;
833 iderv = *ideriv;
834 d__1 = (uvfonc[6] - uvfonc[5]) / 2.;
835 renor = AdvApp2Var_MathBase::pow__di(&d__1, ideriv);
836 }
837
838/* ----------- Discretisation sur les racines du polynome ---------------
839*/
840/* ---------------------- de Legendre de degre NBROOT -------------------
841*/
842
843 (*foncnp)(ndimen,
844 &uvfonc[3],
845 &uvfonc[5],
846 isofav,
847 tconst,
848 &nbp,
849 &ttable[ideb],
850 &ideru,
851 &iderv,
852 &fpntab[ideb * fpntab_dim1 + 1],
853 iercod);
854 if (*iercod > 0) {
855 goto L9999;
856 }
857 i__1 = *ndimen;
858 for (nd = 1; nd <= i__1; ++nd) {
859 i__2 = nroo2;
860 for (ii = 1; ii <= i__2; ++ii) {
861 iip = (*nbroot + 1) / 2 + ii;
862 iim = nroo2 - ii + 1;
863 bid1 = fpntab[nd + iim * fpntab_dim1];
864 bid2 = fpntab[nd + iip * fpntab_dim1];
865 somtab[ii + nd * somtab_dim1] = renor * (bid2 + bid1);
866 diftab[ii + nd * diftab_dim1] = renor * (bid2 - bid1);
867/* L200: */
868 }
869/* L100: */
870 }
871
872/* ------------ Cas ou l' on discretise sur les racines d' un -----------
873*/
874/* ---------- polynome de Legendre de degre impair, 0 est racine --------
875*/
876
877 if (*nbroot % 2 == 1) {
878 i__1 = *ndimen;
879 for (nd = 1; nd <= i__1; ++nd) {
880 somtab[nd * somtab_dim1] = renor * fpntab[nd + (nroo2 + 1) *
881 fpntab_dim1];
882 diftab[nd * diftab_dim1] = renor * fpntab[nd + (nroo2 + 1) *
883 fpntab_dim1];
884/* L300: */
885 }
886 } else {
887 i__1 = *ndimen;
888 for (nd = 1; nd <= i__1; ++nd) {
889 somtab[nd * somtab_dim1] = 0.;
890 diftab[nd * diftab_dim1] = 0.;
891 }
892 }
893
894
895/* --------------------- Prise en compte des contraintes ----------------
896*/
897
898 if (*iordre >= 0) {
899/* --> Recup des extremites deja calculees. */
900 i__1 = *ndimen;
901 for (nd = 1; nd <= i__1; ++nd) {
902 contr1[nd + contr1_dim1] = renor * fpntab[nd];
903 contr2[nd + contr2_dim1] = renor * fpntab[nd + (*nbroot + 1) *
904 fpntab_dim1];
905/* L400: */
906 }
907/* --> Nbre de pts a calculer/appel a FONCNP */
908 nbp = 1;
909/* Si Iso-U, on derive en V jusqu'a l'ordre IORDRE */
910 if (*isofav == 1) {
911/* --> Facteur de normalisation derivee 1ere. */
912 bid1 = (uvfonc[6] - uvfonc[5]) / 2.;
913 i__1 = *iordre;
914 for (iderv = 1; iderv <= i__1; ++iderv) {
915 (*foncnp)(ndimen, &uvfonc[3], &uvfonc[5], isofav, tconst, &
916 nbp, ttable, &ideru, &iderv, &contr1[(iderv + 1) *
917 contr1_dim1 + 1], iercod);
918 if (*iercod > 0) {
919 goto L9999;
920 }
921/* L500: */
922 }
923 i__1 = *iordre;
924 for (iderv = 1; iderv <= i__1; ++iderv) {
925 (*foncnp)(ndimen, &uvfonc[3], &uvfonc[5], isofav, tconst, &
926 nbp, &ttable[*nbroot + 1], &ideru, &iderv, &contr2[(
927 iderv + 1) * contr2_dim1 + 1], iercod);
928 if (*iercod > 0) {
929 goto L9999;
930 }
931/* L510: */
932 }
933/* Si Iso-V, on derive en U jusqu'a l'ordre IORDRE */
934 } else {
935/* --> Facteur de normalisation derivee 1ere. */
936 bid1 = (uvfonc[4] - uvfonc[3]) / 2.;
937 i__1 = *iordre;
938 for (ideru = 1; ideru <= i__1; ++ideru) {
939 (*foncnp)(ndimen, &uvfonc[3], &uvfonc[5], isofav, tconst, &
940 nbp, ttable, &ideru, &iderv, &contr1[(ideru + 1) *
941 contr1_dim1 + 1], iercod);
942 if (*iercod > 0) {
943 goto L9999;
944 }
945/* L600: */
946 }
947 i__1 = *iordre;
948 for (ideru = 1; ideru <= i__1; ++ideru) {
949 (*foncnp)(ndimen, &uvfonc[3], &uvfonc[5], isofav, tconst, &
950 nbp, &ttable[*nbroot + 1], &ideru, &iderv, &contr2[(
951 ideru + 1) * contr2_dim1 + 1], iercod);
952 if (*iercod > 0) {
953 goto L9999;
954 }
955/* L610: */
956 }
957 }
958
959/* ------------------------- Normalisation des derivees -------------
960---- */
961/* (La fonction est redefinie sur (-1,1)*(-1,1)) */
962 bid2 = renor;
963 i__1 = *iordre;
964 for (ii = 1; ii <= i__1; ++ii) {
965 bid2 = bid1 * bid2;
966 i__2 = *ndimen;
967 for (nd = 1; nd <= i__2; ++nd) {
968 contr1[nd + (ii + 1) * contr1_dim1] *= bid2;
969 contr2[nd + (ii + 1) * contr2_dim1] *= bid2;
970/* L710: */
971 }
972/* L700: */
973 }
974 }
975
976/* ------------------------------ The end -------------------------------
977*/
978
979L9999:
980 if (*iercod > 0) {
981 *iercod += 100;
982 AdvApp2Var_SysBase::maermsg_("MMA1FDI", iercod, 7L);
983 }
984 if (ibb >= 3) {
985 AdvApp2Var_SysBase::mgsomsg_("MMA1FDI", 7L);
986 }
987 return 0;
988} /* mma1fdi_ */
989
990//=======================================================================
991//function : mma1fer_
992//purpose :
993//=======================================================================
994int mma1fer_(integer *,//ndimen,
995 integer *nbsesp,
996 integer *ndimse,
997 integer *iordre,
998 integer *ndgjac,
999 doublereal *crvjac,
1000 integer *ncflim,
1001 doublereal *epsapr,
1002 doublereal *ycvmax,
1003 doublereal *errmax,
1004 doublereal *errmoy,
1005 integer *ncoeff,
1006 integer *iercod)
1007{
1008 /* System generated locals */
1009 integer crvjac_dim1, crvjac_offset, i__1, i__2;
1010
1011 /* Local variables */
1012 static integer idim, ncfja, ncfnw, ndses, ii, kk, ibb, ier;
1013 static integer nbr0;
1014
1015
1016/* ***********************************************************************
1017 */
1018
1019/* FONCTION : */
1020/* ---------- */
1021/* Calcul du degre et les erreurs d'approximation d'une frontiere. */
1022
1023/* MOTS CLES : */
1024/* ----------- */
1025/* TOUS,AB_SPECIFI :: COURBE&,TRONCATURE, &PRECISION */
1026
1027/* ARGUMENTS D'ENTREE : */
1028/* -------------------- */
1029/* NDIMEN: Dimension totale de l' espace (somme des dimensions */
1030/* des sous-espaces) */
1031/* NBSESP: Nombre de sous-espaces "independants". */
1032/* NDIMSE: Table des dimensions des sous-espaces. */
1033/* IORDRE: Ordre de contrainte aux extremites de la frontiere */
1034/* -1 = pas de contraintes, */
1035/* 0 = contraintes de passage aux bornes (i.e. C0), */
1036/* 1 = C0 + contraintes de derivees 1eres (i.e. C1), */
1037/* 2 = C1 + contraintes de derivees 2ndes (i.e. C2). */
1038/* NDGJAC: Degre du developpement en serie a utiliser pour le calcul
1039*/
1040/* dans la base de Jacobi. */
1041/* CRVJAC: Table des coeff. de la courbe d'approximation dans la */
1042/* base de Jacobi. */
1043/* NCFLIM: Nombre maxi de coeff de la "courbe" polynomiale */
1044/* d' approximation (doit etre superieur ou egal a */
1045/* 2*IORDRE+2 et inferieur ou egal a 50). */
1046/* EPSAPR: Table des erreurs d' approximations a ne pas depasser, */
1047/* sous-espace par sous-espace. */
1048
1049/* ARGUMENTS DE SORTIE : */
1050/* --------------------- */
1051/* YCVMAX: Tableau auxiliaire. */
1052/* ERRMAX: Table des erreurs (sous-espace par sous espace) */
1053/* MAXIMALES commises dans l' approximation de FONCNP par */
1054/* COURBE. */
1055/* ERRMOY: Table des erreurs (sous-espace par sous espace) */
1056/* MOYENNES commises dans l' approximation de FONCNP par */
1057/* COURBE. */
1058/* NCOEFF: Nombre de coeff. significatifs de la "courbe" calculee. */
1059/* IERCOD: Code d'erreur */
1060/* = 0, ok, */
1061/* =-1, warning, la tolerance demandee ne peut etre */
1062/* satisfaite avec NCFLIM coefficients. */
1063/* = 1, L'ordre des contraintes (IORDRE) n'est pas dans les */
1064/* valeurs autorisees. */
1065
1066/* COMMONS UTILISES : */
1067/* ------------------ */
1068
1069/* REFERENCES APPELEES : */
1070/* --------------------- */
1071
1072/* DESCRIPTION/REMARQUES/LIMITATIONS : */
1073/* ----------------------------------- */
1074
1075/* $ HISTORIQUE DES MODIFICATIONS : */
1076/* ------------------------------ */
1077/* 07-02-92: RBD; Correction du retour du code d'erreur negatif. */
1078/* 07-08-91: RBD; VERSION ORIGINALE */
1079/* > */
1080/* **********************************************************************
1081*/
1082
1083/* Le nom de la routine */
1084
1085
1086 /* Parameter adjustments */
1087 --ycvmax;
1088 --errmoy;
1089 --errmax;
1090 --epsapr;
1091 --ndimse;
1092 crvjac_dim1 = *ndgjac + 1;
1093 crvjac_offset = crvjac_dim1;
1094 crvjac -= crvjac_offset;
1095
1096 /* Function Body */
1097 ibb = AdvApp2Var_SysBase::mnfndeb_();
1098 if (ibb >= 3) {
1099 AdvApp2Var_SysBase::mgenmsg_("MMA1FER", 7L);
1100 }
1101 *iercod = 0;
1102 idim = 1;
1103 *ncoeff = 0;
1104 ncfja = *ndgjac + 1;
1105
1106/* ------------ Calcul du degre de la courbe et de l' erreur Max --------
1107*/
1108/* -------------- de l' approximation pour tous les sous-espaces --------
1109*/
1110
1111 i__1 = *nbsesp;
1112 for (ii = 1; ii <= i__1; ++ii) {
1113 ndses = ndimse[ii];
1114
1115/* ------------ coupure des coeff. et calcul de l' erreur Max -------
1116---- */
1117
1118 AdvApp2Var_MathBase::mmtrpjj_(&ncfja, &ndses, &ncfja, &epsapr[ii], iordre, &crvjac[idim *
1119 crvjac_dim1], &ycvmax[1], &errmax[ii], &ncfnw);
1120
1121/* ******************************************************************
1122**** */
1123/* ------------- Si precision OK, calcul de l' erreur moyenne -------
1124---- */
1125/* ******************************************************************
1126**** */
1127
1128 if (ncfnw <= *ncflim) {
1129 mmaperm_(&ncfja, &ndses, &ncfja, iordre, &crvjac[idim *
1130 crvjac_dim1], &ncfnw, &errmoy[ii]);
1131 *ncoeff = max(ncfnw,*ncoeff);
1132
1133/* ------------- Mise a 0.D0 des coefficients ecartes -----------
1134-------- */
1135
1136 nbr0 = *ncflim - ncfnw;
1137 if (nbr0 > 0) {
1138 i__2 = ndses;
1139 for (kk = 1; kk <= i__2; ++kk) {
1140 AdvApp2Var_SysBase::mvriraz_(&nbr0,
1141 (char *)&crvjac[ncfnw + (idim + kk - 1) * crvjac_dim1]);
1142/* L200: */
1143 }
1144 }
1145 } else {
1146
1147/* **************************************************************
1148******** */
1149/* ------------------- Si precision souhaitee non atteinte ------
1150-------- */
1151/* **************************************************************
1152******** */
1153
1154 *iercod = -1;
1155
1156/* ------------------------- calcul de l' erreur Max ------------
1157-------- */
1158
1159 AdvApp2Var_MathBase::mmaperx_(&ncfja, &ndses, &ncfja, iordre, &crvjac[idim *
1160 crvjac_dim1], ncflim, &ycvmax[1], &errmax[ii], &ier);
1161 if (ier > 0) {
1162 goto L9100;
1163 }
1164
1165/* -------------------- du nbre de coeff a renvoyer -------------
1166-------- */
1167
1168 *ncoeff = *ncflim;
1169
1170/* ------------------- et calcul de l' erreur moyenne -----------
1171-------- */
1172
1173 mmaperm_(&ncfja, &ndses, &ncfja, iordre, &crvjac[idim *
1174 crvjac_dim1], ncflim, &errmoy[ii]);
1175 }
1176 idim += ndses;
1177/* L100: */
1178 }
1179
1180 goto L9999;
1181
1182/* ------------------------------ The end -------------------------------
1183*/
1184/* --> L'ordre des contraintes n'est pas dans les valeurs autorisees. */
1185L9100:
1186 *iercod = 1;
1187 goto L9999;
1188
1189L9999:
1190 if (*iercod != 0) {
1191 AdvApp2Var_SysBase::maermsg_("MMA1FER", iercod, 7L);
1192 }
1193 if (ibb >= 3) {
1194 AdvApp2Var_SysBase::mgsomsg_("MMA1FER", 7L);
1195 }
1196 return 0;
1197} /* mma1fer_ */
1198
1199
1200//=======================================================================
1201//function : mma1her_
1202//purpose :
1203//=======================================================================
1204int AdvApp2Var_ApproxF2var::mma1her_(const integer *iordre,
1205 doublereal *hermit,
1206 integer *iercod)
1207{
1208 /* System generated locals */
1209 integer hermit_dim1, hermit_offset;
1210
1211 /* Local variables */
1212 static integer ibb;
1213
1214
1215
1216/* **********************************************************************
1217*/
1218
1219/* FONCTION : */
1220/* ---------- */
1221/* Calcul des 2*(IORDRE+1) polynomes d'Hermite de degre 2*IORDRE+1 */
1222/* sur (-1,1) */
1223
1224/* MOTS CLES : */
1225/* ----------- */
1226/* TOUS, AB_SPECIFI::CONTRAINTE&, INTERPOLATION, &POLYNOME */
1227
1228/* ARGUMENTS D'ENTREE : */
1229/* ------------------ */
1230/* IORDRE: Ordre de contrainte. */
1231/* = 0, Polynome d'interpolation a l'ordre C0 sur (-1,1). */
1232/* = 1, Polynome d'interpolation a l'ordre C0 et C1 sur (-1,1). */
1233/* = 2, Polynome d'interpolation a l'ordre C0, C1 et C2 sur (-1,1).
1234*/
1235
1236/* ARGUMENTS DE SORTIE : */
1237/* ------------------- */
1238/* HERMIT: Table des 2*IORDRE+2 coeff. de chacun des 2*(IORDRE+1) */
1239/* polynomes d'HERMITE. */
1240/* IERCOD: Code d'erreur, */
1241/* = 0, Ok */
1242/* = 1, L'ordre de contrainte demande n'est pas gere ici. */
1243/* COMMONS UTILISES : */
1244/* ---------------- */
1245
1246/* REFERENCES APPELEES : */
1247/* ----------------------- */
1248
1249/* DESCRIPTION/REMARQUES/LIMITATIONS : */
1250/* ----------------------------------- */
1251/* La partie du tableau HERMIT(*,2*i+j) ou j=1 ou 2 et i=0 a IORDRE,
1252*/
1253/* contient les coefficients du polynome de degre 2*IORDRE+1 */
1254/* tel que TOUTES les valeurs en -1 et en +1 de ce polynome et de */
1255/* ses derivees jusqu'a l'ordre de derivation IORDRE sont NULLES, */
1256/* SAUF la derivee d'ordre i: */
1257/* - qui vaut 1 en -1 si j=1 */
1258/* - qui vaut 1 en +1 si j=2. */
1259
1260/* $ HISTORIQUE DES MODIFICATIONS : */
1261/* -------------------------------- */
1262/* 02-07-1991: RBD; Creation. */
1263/* > */
1264/* **********************************************************************
1265*/
1266
1267/* Le nom de la routine */
1268
1269
1270 /* Parameter adjustments */
1271 hermit_dim1 = (*iordre + 1) << 1;
1272 hermit_offset = hermit_dim1 + 1;
1273 hermit -= hermit_offset;
1274
1275 /* Function Body */
1276 ibb = AdvApp2Var_SysBase::mnfndeb_();
1277 if (ibb >= 3) {
1278 AdvApp2Var_SysBase::mgenmsg_("MMA1HER", 7L);
1279 }
1280 *iercod = 0;
1281
1282/* --- Recup des (IORDRE+2) coeff des 2*(IORDRE+1) polynomes d'Hermite --
1283*/
1284
1285 if (*iordre == 0) {
1286 hermit[hermit_dim1 + 1] = .5;
1287 hermit[hermit_dim1 + 2] = -.5;
1288
1289 hermit[(hermit_dim1 << 1) + 1] = .5;
1290 hermit[(hermit_dim1 << 1) + 2] = .5;
1291 } else if (*iordre == 1) {
1292 hermit[hermit_dim1 + 1] = .5;
1293 hermit[hermit_dim1 + 2] = -.75;
1294 hermit[hermit_dim1 + 3] = 0.;
1295 hermit[hermit_dim1 + 4] = .25;
1296
1297 hermit[(hermit_dim1 << 1) + 1] = .5;
1298 hermit[(hermit_dim1 << 1) + 2] = .75;
1299 hermit[(hermit_dim1 << 1) + 3] = 0.;
1300 hermit[(hermit_dim1 << 1) + 4] = -.25;
1301
1302 hermit[hermit_dim1 * 3 + 1] = .25;
1303 hermit[hermit_dim1 * 3 + 2] = -.25;
1304 hermit[hermit_dim1 * 3 + 3] = -.25;
1305 hermit[hermit_dim1 * 3 + 4] = .25;
1306
1307 hermit[(hermit_dim1 << 2) + 1] = -.25;
1308 hermit[(hermit_dim1 << 2) + 2] = -.25;
1309 hermit[(hermit_dim1 << 2) + 3] = .25;
1310 hermit[(hermit_dim1 << 2) + 4] = .25;
1311 } else if (*iordre == 2) {
1312 hermit[hermit_dim1 + 1] = .5;
1313 hermit[hermit_dim1 + 2] = -.9375;
1314 hermit[hermit_dim1 + 3] = 0.;
1315 hermit[hermit_dim1 + 4] = .625;
1316 hermit[hermit_dim1 + 5] = 0.;
1317 hermit[hermit_dim1 + 6] = -.1875;
1318
1319 hermit[(hermit_dim1 << 1) + 1] = .5;
1320 hermit[(hermit_dim1 << 1) + 2] = .9375;
1321 hermit[(hermit_dim1 << 1) + 3] = 0.;
1322 hermit[(hermit_dim1 << 1) + 4] = -.625;
1323 hermit[(hermit_dim1 << 1) + 5] = 0.;
1324 hermit[(hermit_dim1 << 1) + 6] = .1875;
1325
1326 hermit[hermit_dim1 * 3 + 1] = .3125;
1327 hermit[hermit_dim1 * 3 + 2] = -.4375;
1328 hermit[hermit_dim1 * 3 + 3] = -.375;
1329 hermit[hermit_dim1 * 3 + 4] = .625;
1330 hermit[hermit_dim1 * 3 + 5] = .0625;
1331 hermit[hermit_dim1 * 3 + 6] = -.1875;
1332
1333 hermit[(hermit_dim1 << 2) + 1] = -.3125;
1334 hermit[(hermit_dim1 << 2) + 2] = -.4375;
1335 hermit[(hermit_dim1 << 2) + 3] = .375;
1336 hermit[(hermit_dim1 << 2) + 4] = .625;
1337 hermit[(hermit_dim1 << 2) + 5] = -.0625;
1338 hermit[(hermit_dim1 << 2) + 6] = -.1875;
1339
1340 hermit[hermit_dim1 * 5 + 1] = .0625;
1341 hermit[hermit_dim1 * 5 + 2] = -.0625;
1342 hermit[hermit_dim1 * 5 + 3] = -.125;
1343 hermit[hermit_dim1 * 5 + 4] = .125;
1344 hermit[hermit_dim1 * 5 + 5] = .0625;
1345 hermit[hermit_dim1 * 5 + 6] = -.0625;
1346
1347 hermit[hermit_dim1 * 6 + 1] = .0625;
1348 hermit[hermit_dim1 * 6 + 2] = .0625;
1349 hermit[hermit_dim1 * 6 + 3] = -.125;
1350 hermit[hermit_dim1 * 6 + 4] = -.125;
1351 hermit[hermit_dim1 * 6 + 5] = .0625;
1352 hermit[hermit_dim1 * 6 + 6] = .0625;
1353 } else {
1354 *iercod = 1;
1355 }
1356
1357/* ------------------------------ The End -------------------------------
1358*/
1359
1360 AdvApp2Var_SysBase::maermsg_("MMA1HER", iercod, 7L);
1361 if (ibb >= 3) {
1362 AdvApp2Var_SysBase::mgsomsg_("MMA1HER", 7L);
1363 }
1364 return 0;
1365} /* mma1her_ */
1366//=======================================================================
1367//function : mma1jak_
1368//purpose :
1369//=======================================================================
1370int mma1jak_(integer *ndimen,
1371 integer *nbroot,
1372 integer *iordre,
1373 integer *ndgjac,
1374 doublereal *somtab,
1375 doublereal *diftab,
1376 doublereal *cgauss,
1377 doublereal *crvjac,
1378 integer *iercod)
1379{
1380 /* System generated locals */
1381 integer somtab_dim1, somtab_offset, diftab_dim1, diftab_offset,
1382 crvjac_dim1, crvjac_offset, cgauss_dim1;
1383
1384 /* Local variables */
1385 static integer ibb;
1386
1387/* **********************************************************************
1388*/
1389
1390/* FONCTION : */
1391/* ---------- */
1392/* Calcule la courbe d' approximation d' une fonction non */
1393/* polynomiale dans la base de Jacobi. */
1394
1395/* MOTS CLES : */
1396/* ----------- */
1397/* FONCTION,DISCRETISATION,APPROXIMATION,CONTRAINTE,COURBE,JACOBI */
1398
1399/* ARGUMENTS D'ENTREE : */
1400/* ------------------ */
1401/* NDIMEN: Dimension totale de l' espace (somme des dimensions */
1402/* des sous-espaces) */
1403/* NBROOT: Nbre de points de discretisation de l'iso, extremites non
1404*/
1405/* comprises. */
1406/* IORDRE: Ordre de contrainte aux extremites de la frontiere */
1407/* -1 = pas de contraintes, */
1408/* 0 = contraintes de passage aux bornes (i.e. C0), */
1409/* 1 = C0 + contraintes de derivees 1eres (i.e. C1), */
1410/* 2 = C1 + contraintes de derivees 2ndes (i.e. C2). */
1411/* NDGJAC: Degre du developpement en serie a utiliser pour le calcul
1412*/
1413/* dans la base de Jacobi. */
1414
1415/* ARGUMENTS DE SORTIE : */
1416/* ------------------- */
1417/* CRVJAC : Courbe d' approximation de FONCNP avec (eventuellement) */
1418/* prise en compte des contraintes aux extremites. */
1419/* Cette courbe est de degre NDGJAC. */
1420/* IERCOD : Code d' erreur : */
1421/* 0 = Tout est ok. */
1422/* 33 = Pb dans la recuperation des donnees du block data */
1423/* des coeff. d' integration par la methode de GAUSS. */
1424/* par le programme MMAPPTT. */
1425
1426/* COMMONS UTILISES : */
1427/* ---------------- */
1428
1429/* REFERENCES APPELEES : */
1430/* ----------------------- */
1431
1432/* DESCRIPTION/REMARQUES/LIMITATIONS : */
1433/* ----------------------------------- */
1434
1435/* $ HISTORIQUE DES MODIFICATIONS : */
1436/* -------------------------------- */
1437/* 07-08-1991 : RBD ; Creation. */
1438/* > */
1439/* **********************************************************************
1440*/
1441
1442/* Le nom de la routine */
1443
1444 /* Parameter adjustments */
1445 diftab_dim1 = *nbroot / 2 + 1;
1446 diftab_offset = diftab_dim1;
1447 diftab -= diftab_offset;
1448 somtab_dim1 = *nbroot / 2 + 1;
1449 somtab_offset = somtab_dim1;
1450 somtab -= somtab_offset;
1451 crvjac_dim1 = *ndgjac + 1;
1452 crvjac_offset = crvjac_dim1;
1453 crvjac -= crvjac_offset;
1454 cgauss_dim1 = *nbroot / 2 + 1;
1455
1456 /* Function Body */
1457 ibb = AdvApp2Var_SysBase::mnfndeb_();
1458 if (ibb >= 2) {
1459 AdvApp2Var_SysBase::mgenmsg_("MMA1JAK", 7L);
1460 }
1461 *iercod = 0;
1462
1463/* ----------------- Recup des coeff. d'integration par Gauss -----------
1464*/
1465
1466 AdvApp2Var_ApproxF2var::mmapptt_(ndgjac, nbroot, iordre, cgauss, iercod);
1467 if (*iercod > 0) {
1468 *iercod = 33;
1469 goto L9999;
1470 }
1471
1472/* --------------- Calcul de la courbe dans la base de Jacobi -----------
1473*/
1474
1475 mmmapcoe_(ndimen, ndgjac, iordre, nbroot, &somtab[somtab_offset], &diftab[
1476 diftab_offset], cgauss, &crvjac[crvjac_offset]);
1477
1478/* ------------------------------ The End -------------------------------
1479*/
1480
1481L9999:
1482 if (*iercod != 0) {
1483 AdvApp2Var_SysBase::maermsg_("MMA1JAK", iercod, 7L);
1484 }
1485 if (ibb >= 2) {
1486 AdvApp2Var_SysBase::mgsomsg_("MMA1JAK", 7L);
1487 }
1488 return 0;
1489} /* mma1jak_ */
1490
1491//=======================================================================
1492//function : mma1noc_
1493//purpose :
1494//=======================================================================
1495int mma1noc_(doublereal *dfuvin,
1496 integer *ndimen,
1497 integer *iordre,
1498 doublereal *cntrin,
1499 doublereal *duvout,
1500 integer *isofav,
1501 integer *ideriv,
1502 doublereal *cntout)
1503{
1504 /* System generated locals */
1505 integer i__1;
1506 doublereal d__1;
1507
1508
1509 /* Local variables */
1510 static doublereal rider, riord;
1511 static integer nd, ibb;
1512 static doublereal bid;
1513/* **********************************************************************
1514*/
1515
1516/* FONCTION : */
1517/* ---------- */
1518/* Normalisation des contraintes de derivees, definies sur DFUVIN */
1519/* sur le pave DUVOUT. */
1520
1521/* MOTS CLES : */
1522/* ----------- */
1523/* TOUS, AB_SPECIFI::VECTEUR&,DERIVEE&,NORMALISATION,&VECTEUR */
1524
1525/* ARGUMENTS D'ENTREE : */
1526/* ------------------ */
1527/* DFUVIN: Bornes du pave de definition en U et en V ou sont definies
1528*/
1529/* les contraintes CNTRIN. */
1530/* NDIMEN: Dimension de l' espace. */
1531/* IORDRE: Ordre de contrainte impose aux extremites de l'iso. */
1532/* (Si Iso-U, on doit calculer les derivees en V et vice */
1533/* versa). */
1534/* = 0, on a calcule les extremites de l'iso */
1535/* = 1, on a calcule, en plus, la derivee 1ere dans le sens */
1536/* de l'iso */
1537/* = 2, on a calcule, en plus, la derivee 2nde dans le sens */
1538/* de l'iso */
1539/* CNTRIN: Contient, si IORDRE>=0, les IORDRE+1 derivees */
1540/* d'ordre IORDRE de F(Uc,v) ou de F(u,Vc), suivant la */
1541/* valeur de ISOFAV, RENORMALISEES pour u et v dans (-1,1). */
1542/* DUVOUT: Bornes du pave de definition en U et en V ou seront */
1543/* definies les contraintes CNTOUT. */
1544/* ISOFAV: Isoparametre fixe pour la discretisation; */
1545/* = 1, on discretise a U=Uc fixe et V variable. */
1546/* = 2, on discretise a V=Vc fixe et U variable. */
1547/* IDERIV: Ordre de derivee transverse a l'iso fixee (Si Iso-U=Uc */
1548/* fixee, on discretise la derivee d'ordre IDERIV en U de */
1549/* F(Uc,v). Idem si on fixe une iso-V). */
1550/* Varie de 0 (positionnement) a 2 (derivee 2nde). */
1551
1552/* ARGUMENTS DE SORTIE : */
1553/* ------------------- */
1554/* CNTOUT: Contient, si IORDRE>=0, les IORDRE+1 derivees */
1555/* d'ordre IORDRE de F(Uc,v) ou de F(u,Vc), suivant la */
1556/* valeur de ISOFAV, RENORMALISEES pour u et v dans DUVOUT. */
1557
1558/* COMMONS UTILISES : */
1559/* ---------------- */
1560
1561/* REFERENCES APPELEES : */
1562/* ----------------------- */
1563
1564/* DESCRIPTION/REMARQUES/LIMITATIONS : */
1565/* ----------------------------------- */
1566/* CNTRIN peut etre un argument d'entree/sortie, */
1567/* c'est a dire que l'appel: */
1568
1569/* CALL MMA1NOC(DFUVIN,NDIMEN,IORDRE,CNTRIN,DUVOUT */
1570/* 1 ,ISOFAV,IDERIV,CNTRIN) */
1571
1572/* est correct. */
1573
1574/* $ HISTORIQUE DES MODIFICATIONS : */
1575/* -------------------------------- */
1576/* 10-02-1992: RBD; Creation. */
1577/* > */
1578/* **********************************************************************
1579*/
1580
1581/* Le nom de la routine */
1582
1583
1584 /* Parameter adjustments */
1585 dfuvin -= 3;
1586 --cntout;
1587 --cntrin;
1588 duvout -= 3;
1589
1590 /* Function Body */
1591 ibb = AdvApp2Var_SysBase::mnfndeb_();
1592 if (ibb >= 3) {
1593 AdvApp2Var_SysBase::mgenmsg_("MMA1NOC", 7L);
1594 }
1595
1596/* --------------- Determination des coefficients de normalisation -------
1597 */
1598
1599 if (*isofav == 1) {
1600 d__1 = (dfuvin[4] - dfuvin[3]) / (duvout[4] - duvout[3]);
1601 rider = AdvApp2Var_MathBase::pow__di(&d__1, ideriv);
1602 d__1 = (dfuvin[6] - dfuvin[5]) / (duvout[6] - duvout[5]);
1603 riord = AdvApp2Var_MathBase::pow__di(&d__1, iordre);
1604
1605 } else {
1606 d__1 = (dfuvin[6] - dfuvin[5]) / (duvout[6] - duvout[5]);
1607 rider = AdvApp2Var_MathBase::pow__di(&d__1, ideriv);
1608 d__1 = (dfuvin[4] - dfuvin[3]) / (duvout[4] - duvout[3]);
1609 riord = AdvApp2Var_MathBase::pow__di(&d__1, iordre);
1610 }
1611
1612/* ------------- Renormalisation du vecteur de contrainte ---------------
1613*/
1614
1615 bid = rider * riord;
1616 i__1 = *ndimen;
1617 for (nd = 1; nd <= i__1; ++nd) {
1618 cntout[nd] = bid * cntrin[nd];
1619/* L100: */
1620 }
1621
1622/* ------------------------------ The end -------------------------------
1623*/
1624
1625 if (ibb >= 3) {
1626 AdvApp2Var_SysBase::mgsomsg_("MMA1NOC", 7L);
1627 }
1628 return 0;
1629} /* mma1noc_ */
1630
1631//=======================================================================
1632//function : mma1nop_
1633//purpose :
1634//=======================================================================
1635int mma1nop_(integer *nbroot,
1636 doublereal *rootlg,
1637 doublereal *uvfonc,
1638 integer *isofav,
1639 doublereal *ttable,
1640 integer *iercod)
1641
1642{
1643 /* System generated locals */
1644 integer i__1;
1645
1646 /* Local variables */
1647 static doublereal alinu, blinu, alinv, blinv;
1648 static integer ii, ibb;
1649
1650
1651
1652/* ***********************************************************************
1653 */
1654
1655/* FONCTION : */
1656/* ---------- */
1657/* Normalisation de parametres d'une iso, a partir du pave */
1658/* parametrique et des parametres sur (-1,1). */
1659
1660/* MOTS CLES : */
1661/* ----------- */
1662/* TOUS,AB_SPECIFI :: ISO&,POINT&,NORMALISATION,&POINT,&ISO */
1663
1664/* ARGUMENTS D'ENTREE : */
1665/* -------------------- */
1666/* NBROOT: Nbre de pts de discretisation INTERIEURS a l'iso */
1667/* definie sur (-1,1). */
1668/* ROOTLG: Table des parametres de discretisation sur )-1,1( */
1669/* de l'iso. */
1670/* UVFONC: Pave de definition de l'iso */
1671/* ISOFAV: = 1, c'est une iso-u; =2, c'est une iso-v. */
1672
1673/* ARGUMENTS DE SORTIE : */
1674/* --------------------- */
1675/* TTABLE: Table des parametres renormalises sur UVFONC de l'iso.
1676*/
1677/* IERCOD: = 0, OK */
1678/* = 1, ISOFAV est hors des valeurs permises. */
1679
1680/* COMMONS UTILISES : */
1681/* ------------------ */
1682
1683/* REFERENCES APPELEES : */
1684/* --------------------- */
1685
1686/* DESCRIPTION/REMARQUES/LIMITATIONS : */
1687/* ----------------------------------- */
1688
1689/* $ HISTORIQUE DES MODIFICATIONS : */
1690/* ------------------------------ */
1691/* 06-02-92: RBD; Creation version originale, d'apres MA1NPA. */
1692/* > */
1693/* **********************************************************************
1694*/
1695/* Le nom de la routine */
1696
1697
1698 /* Parameter adjustments */
1699 --rootlg;
1700 uvfonc -= 3;
1701
1702 /* Function Body */
1703 ibb = AdvApp2Var_SysBase::mnfndeb_();
1704 if (ibb >= 3) {
1705 AdvApp2Var_SysBase::mgenmsg_("MMA1NOP", 7L);
1706 }
1707
1708 alinu = (uvfonc[4] - uvfonc[3]) / 2.;
1709 blinu = (uvfonc[4] + uvfonc[3]) / 2.;
1710 alinv = (uvfonc[6] - uvfonc[5]) / 2.;
1711 blinv = (uvfonc[6] + uvfonc[5]) / 2.;
1712
1713 if (*isofav == 1) {
1714 ttable[0] = uvfonc[5];
1715 i__1 = *nbroot;
1716 for (ii = 1; ii <= i__1; ++ii) {
1717 ttable[ii] = alinv * rootlg[ii] + blinv;
1718/* L100: */
1719 }
1720 ttable[*nbroot + 1] = uvfonc[6];
1721 } else if (*isofav == 2) {
1722 ttable[0] = uvfonc[3];
1723 i__1 = *nbroot;
1724 for (ii = 1; ii <= i__1; ++ii) {
1725 ttable[ii] = alinu * rootlg[ii] + blinu;
1726/* L200: */
1727 }
1728 ttable[*nbroot + 1] = uvfonc[4];
1729 } else {
1730 goto L9100;
1731 }
1732
1733 goto L9999;
1734
1735/* ------------------------------ THE END -------------------------------
1736*/
1737
1738L9100:
1739 *iercod = 1;
1740 goto L9999;
1741
1742L9999:
1743 if (*iercod != 0) {
1744 AdvApp2Var_SysBase::maermsg_("MMA1NOP", iercod, 7L);
1745 }
1746 if (ibb >= 3) {
1747 AdvApp2Var_SysBase::mgsomsg_("MMA1NOP", 7L);
1748 }
1749
1750 return 0 ;
1751
1752} /* mma1nop_ */
1753
1754//=======================================================================
1755//function : mma2ac1_
1756//purpose :
1757//=======================================================================
1758int AdvApp2Var_ApproxF2var::mma2ac1_(integer const *ndimen,
1759 integer const *mxujac,
1760 integer const *mxvjac,
1761 integer const *iordru,
1762 integer const *iordrv,
1763 doublereal const *contr1,
1764 doublereal const * contr2,
1765 doublereal const *contr3,
1766 doublereal const *contr4,
1767 doublereal const *uhermt,
1768 doublereal const *vhermt,
1769 doublereal *patjac)
1770
1771{
1772 /* System generated locals */
1773 integer contr1_dim1, contr1_dim2, contr1_offset, contr2_dim1, contr2_dim2,
1774 contr2_offset, contr3_dim1, contr3_dim2, contr3_offset,
1775 contr4_dim1, contr4_dim2, contr4_offset, uhermt_dim1,
1776 uhermt_offset, vhermt_dim1, vhermt_offset, patjac_dim1,
1777 patjac_dim2, patjac_offset, i__1, i__2, i__3, i__4, i__5;
1778
1779 /* Local variables */
1780 static logical ldbg;
1781 static integer ndgu, ndgv;
1782 static doublereal bidu1, bidu2, bidv1, bidv2;
1783 static integer ioru1, iorv1, ii, nd, jj, ku, kv;
1784 static doublereal cnt1, cnt2, cnt3, cnt4;
1785
1786
1787
1788/* **********************************************************************
1789*/
1790
1791/* FONCTION : */
1792/* ---------- */
1793/* Ajout des polynomes de contraintes des coins. */
1794
1795/* MOTS CLES : */
1796/* ----------- */
1797/* TOUS,AB_SPECIFI::POINT&,CONTRAINTE&,ADDITION,&POLYNOME */
1798
1799/* ARGUMENTS D'ENTREE : */
1800/* ------------------ */
1801/* NDIMEN: Dimension de l'espace. */
1802/* MXUJAC: Degre maxi du polynome d' approximation en U. La */
1803/* representation dans la base orthogonale part du degre */
1804/* 0 au degre MXUJAC-2*(IORDRU+1). La base polynomiale est */
1805/* la base de Jacobi d' ordre -1 (Legendre), 0, 1 ou 2 */
1806/* MXVJAC: Degre maxi du polynome d' approximation en V. La */
1807/* representation dans la base orthogonale part du degre */
1808/* 0 au degre MXVJAC-2*(IORDRV+1). La base polynomiale est */
1809/* la base de Jacobi d' ordre -1 (Legendre), 0, 1 ou 2 */
1810/* IORDRU: Ordre de la base de Jacobi (-1,0,1 ou 2) en U. Correspond */
1811/* a pas de contraintes, contraintes C0, C1 ou C2. */
1812/* IORDRV: Ordre de la base de Jacobi (-1,0,1 ou 2) en V. Correspond */
1813/* a pas de contraintes, contraintes C0, C1 ou C2. */
1814/* CONTR1: Contient, si IORDRU et IORDRV>=0, les valeurs aux */
1815/* extremitees de F(U0,V0)et de ses derivees. */
1816/* CONTR2: Contient, si IORDRU et IORDRV>=0, les valeurs aux */
1817/* extremitees de F(U1,V0)et de ses derivees. */
1818/* CONTR3: Contient, si IORDRU et IORDRV>=0, les valeurs aux */
1819/* extremitees de F(U0,V1)et de ses derivees. */
1820/* CONTR4: Contient, si IORDRU et IORDRV>=0, les valeurs aux */
1821/* extremitees de F(U1,V1)et de ses derivees. */
1822/* UHERMT: Coeff. des polynomes d'Hermite d'ordre IORDRU. */
1823/* VHERMT: Coeff. des polynomes d'Hermite d'ordre IORDRV. */
1824/* PATJAC: Table des coefficients du polynome P(u,v) d' approximation */
1825/* de F(u,v) SANS prise en compte des contraintes. */
1826
1827/* ARGUMENTS DE SORTIE : */
1828/* ------------------- */
1829/* PATJAC: Table des coefficients du polynome P(u,v) d' approximation */
1830/* de F(u,v) AVEC prise en compte des contraintes. */
1831
1832/* COMMONS UTILISES : */
1833/* ---------------- */
1834
1835/* REFERENCES APPELEES : */
1836/* ----------------------- */
1837
1838/* DESCRIPTION/REMARQUES/LIMITATIONS : */
1839/* ----------------------------------- */
1840
1841/* $ HISTORIQUE DES MODIFICATIONS : */
1842/* -------------------------------- */
1843/* 06-02-1992: RBD; Creation d'apres MA2CA1. */
1844/* > */
1845/* **********************************************************************
1846*/
1847/* Le nom de la routine */
1848
1849/* --------------------------- Initialisations --------------------------
1850*/
1851
1852 /* Parameter adjustments */
1853 patjac_dim1 = *mxujac + 1;
1854 patjac_dim2 = *mxvjac + 1;
1855 patjac_offset = patjac_dim1 * patjac_dim2;
1856 patjac -= patjac_offset;
1857 uhermt_dim1 = (*iordru << 1) + 2;
1858 uhermt_offset = uhermt_dim1;
1859 uhermt -= uhermt_offset;
1860 vhermt_dim1 = (*iordrv << 1) + 2;
1861 vhermt_offset = vhermt_dim1;
1862 vhermt -= vhermt_offset;
1863 contr4_dim1 = *ndimen;
1864 contr4_dim2 = *iordru + 2;
1865 contr4_offset = contr4_dim1 * (contr4_dim2 + 1) + 1;
1866 contr4 -= contr4_offset;
1867 contr3_dim1 = *ndimen;
1868 contr3_dim2 = *iordru + 2;
1869 contr3_offset = contr3_dim1 * (contr3_dim2 + 1) + 1;
1870 contr3 -= contr3_offset;
1871 contr2_dim1 = *ndimen;
1872 contr2_dim2 = *iordru + 2;
1873 contr2_offset = contr2_dim1 * (contr2_dim2 + 1) + 1;
1874 contr2 -= contr2_offset;
1875 contr1_dim1 = *ndimen;
1876 contr1_dim2 = *iordru + 2;
1877 contr1_offset = contr1_dim1 * (contr1_dim2 + 1) + 1;
1878 contr1 -= contr1_offset;
1879
1880 /* Function Body */
1881 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 3;
1882 if (ldbg) {
1883 AdvApp2Var_SysBase::mgenmsg_("MMA2AC1", 7L);
1884 }
1885
1886/* ------------ SOUSTRACTION des CONTRAINTES DE COINS -------------------
1887*/
1888
1889 ioru1 = *iordru + 1;
1890 iorv1 = *iordrv + 1;
1891 ndgu = (*iordru << 1) + 1;
1892 ndgv = (*iordrv << 1) + 1;
1893
1894 i__1 = iorv1;
1895 for (jj = 1; jj <= i__1; ++jj) {
1896 i__2 = ioru1;
1897 for (ii = 1; ii <= i__2; ++ii) {
1898 i__3 = *ndimen;
1899 for (nd = 1; nd <= i__3; ++nd) {
1900 cnt1 = contr1[nd + (ii + jj * contr1_dim2) * contr1_dim1];
1901 cnt2 = contr2[nd + (ii + jj * contr2_dim2) * contr2_dim1];
1902 cnt3 = contr3[nd + (ii + jj * contr3_dim2) * contr3_dim1];
1903 cnt4 = contr4[nd + (ii + jj * contr4_dim2) * contr4_dim1];
1904 i__4 = ndgv;
1905 for (kv = 0; kv <= i__4; ++kv) {
1906 bidv1 = vhermt[kv + ((jj << 1) - 1) * vhermt_dim1];
1907 bidv2 = vhermt[kv + (jj << 1) * vhermt_dim1];
1908 i__5 = ndgu;
1909 for (ku = 0; ku <= i__5; ++ku) {
1910 bidu1 = uhermt[ku + ((ii << 1) - 1) * uhermt_dim1];
1911 bidu2 = uhermt[ku + (ii << 1) * uhermt_dim1];
1912 patjac[ku + (kv + nd * patjac_dim2) * patjac_dim1] =
1913 patjac[ku + (kv + nd * patjac_dim2) *
1914 patjac_dim1] - bidu1 * bidv1 * cnt1 - bidu2 *
1915 bidv1 * cnt2 - bidu1 * bidv2 * cnt3 - bidu2 *
1916 bidv2 * cnt4;
1917/* L500: */
1918 }
1919/* L400: */
1920 }
1921/* L300: */
1922 }
1923/* L200: */
1924 }
1925/* L100: */
1926 }
1927
1928/* ------------------------------ The end -------------------------------
1929*/
1930
1931 if (ldbg) {
1932 AdvApp2Var_SysBase::mgsomsg_("MMA2AC1", 7L);
1933 }
1934 return 0;
1935} /* mma2ac1_ */
1936
1937//=======================================================================
1938//function : mma2ac2_
1939//purpose :
1940//=======================================================================
1941int AdvApp2Var_ApproxF2var::mma2ac2_(const integer *ndimen,
1942 const integer *mxujac,
1943 const integer *mxvjac,
1944 const integer *iordrv,
1945 const integer *nclimu,
1946 const integer *ncfiv1,
1947 const doublereal *crbiv1,
1948 const integer *ncfiv2,
1949 const doublereal *crbiv2,
1950 const doublereal *vhermt,
1951 doublereal *patjac)
1952
1953{
1954 /* System generated locals */
1955 integer crbiv1_dim1, crbiv1_dim2, crbiv1_offset, crbiv2_dim1, crbiv2_dim2,
1956 crbiv2_offset, patjac_dim1, patjac_dim2, patjac_offset,
1957 vhermt_dim1, vhermt_offset, i__1, i__2, i__3, i__4;
1958
1959 /* Local variables */
1960 static logical ldbg;
1961 static integer ndgv1, ndgv2, ii, jj, nd, kk;
1962 static doublereal bid1, bid2;
1963
1964/* **********************************************************************
1965*/
1966
1967/* FONCTION : */
1968/* ---------- */
1969/* Ajout des polynomes de contraintes */
1970
1971/* MOTS CLES : */
1972/* ----------- */
1973/* FONCTION,APPROXIMATION,COEFFICIENT,POLYNOME */
1974
1975/* ARGUMENTS D'ENTREE : */
1976/* ------------------ */
1977/* NDIMEN: Dimension de l'espace. */
1978/* MXUJAC: Degre maxi du polynome d' approximation en U. La */
1979/* representation dans la base orthogonale part du degre */
1980/* 0 au degre MXUJAC-2*(IORDRU+1). La base polynomiale est */
1981/* la base de Jacobi d' ordre -1 (Legendre), 0, 1 ou 2 */
1982/* MXVJAC: Degre maxi du polynome d' approximation en V. La */
1983/* representation dans la base orthogonale part du degre */
1984/* 0 au degre MXVJAC-2*(IORDRV+1). La base polynomiale est */
1985/* la base de Jacobi d' ordre -1 (Legendre), 0, 1 ou 2 */
1986/* IORDRV: Ordre de la base de Jacobi (-1,0,1 ou 2) en V. Correspond */
1987/* a pas de contraintes, contraintes C0, C1 ou C2. */
1988/* NCLIMU: Nbre LIMITE de coeff. en u de la solution P(u,v). */
1989/* NCFIV1: Nbre de Coeff. des courbes stockees dans CRBIV1. */
1990/* CRBIV1: Table des coeffs de l'approximation de l'iso-V0 et ses */
1991/* derivees jusqu'a l'ordre IORDRV. */
1992/* NCFIV2: Nbre de Coeff. des courbes stockees dans CRBIV2. */
1993/* CRBIV2: Table des coeffs de l'approximation de l'iso-V1 et ses */
1994/* derivees jusqu'a l'ordre IORDRV. */
1995/* VHERMT: Table des coeff. des polynomes d'Hermite d'ordre IORDRV. */
1996/* PATJAC: Table des coefficients du polynome P(u,v) d' approximation */
1997/* de F(u,v) SANS prise en compte des contraintes. */
1998
1999/* ARGUMENTS DE SORTIE : */
2000/* ------------------- */
2001/* PATJAC: Table des coefficients du polynome P(u,v) d' approximation */
2002/* de F(u,v) AVEC prise en compte des contraintes. */
2003
2004/* COMMONS UTILISES : */
2005/* ---------------- */
2006
2007/* REFERENCES APPELEES : */
2008/* ----------------------- */
2009
2010/* DESCRIPTION/REMARQUES/LIMITATIONS : */
2011/* ----------------------------------- */
2012
2013/* $ HISTORIQUE DES MODIFICATIONS : */
2014/* -------------------------------- */
2015/* 06-02-1992: RBD; Creation d'apres MA2CA2. */
2016/* > */
2017/* **********************************************************************
2018*/
2019/* Le nom de la routine */
2020
2021/* --------------------------- Initialisations --------------------------
2022*/
2023
2024 /* Parameter adjustments */
2025 patjac_dim1 = *mxujac + 1;
2026 patjac_dim2 = *mxvjac + 1;
2027 patjac_offset = patjac_dim1 * patjac_dim2;
2028 patjac -= patjac_offset;
2029 vhermt_dim1 = (*iordrv << 1) + 2;
2030 vhermt_offset = vhermt_dim1;
2031 vhermt -= vhermt_offset;
2032 --ncfiv2;
2033 --ncfiv1;
2034 crbiv2_dim1 = *nclimu;
2035 crbiv2_dim2 = *ndimen;
2036 crbiv2_offset = crbiv2_dim1 * (crbiv2_dim2 + 1);
2037 crbiv2 -= crbiv2_offset;
2038 crbiv1_dim1 = *nclimu;
2039 crbiv1_dim2 = *ndimen;
2040 crbiv1_offset = crbiv1_dim1 * (crbiv1_dim2 + 1);
2041 crbiv1 -= crbiv1_offset;
2042
2043 /* Function Body */
2044 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 3;
2045 if (ldbg) {
2046 AdvApp2Var_SysBase::mgenmsg_("MMA2AC2", 7L);
2047 }
2048
2049/* ------------ AJOUT des coeff en u des courbes, en v d'Hermite --------
2050*/
2051
2052 i__1 = *iordrv + 1;
2053 for (ii = 1; ii <= i__1; ++ii) {
2054 ndgv1 = ncfiv1[ii] - 1;
2055 ndgv2 = ncfiv2[ii] - 1;
2056 i__2 = *ndimen;
2057 for (nd = 1; nd <= i__2; ++nd) {
2058 i__3 = (*iordrv << 1) + 1;
2059 for (jj = 0; jj <= i__3; ++jj) {
2060 bid1 = vhermt[jj + ((ii << 1) - 1) * vhermt_dim1];
2061 i__4 = ndgv1;
2062 for (kk = 0; kk <= i__4; ++kk) {
2063 patjac[kk + (jj + nd * patjac_dim2) * patjac_dim1] +=
2064 bid1 * crbiv1[kk + (nd + ii * crbiv1_dim2) *
2065 crbiv1_dim1];
2066/* L400: */
2067 }
2068 bid2 = vhermt[jj + (ii << 1) * vhermt_dim1];
2069 i__4 = ndgv2;
2070 for (kk = 0; kk <= i__4; ++kk) {
2071 patjac[kk + (jj + nd * patjac_dim2) * patjac_dim1] +=
2072 bid2 * crbiv2[kk + (nd + ii * crbiv2_dim2) *
2073 crbiv2_dim1];
2074/* L500: */
2075 }
2076/* L300: */
2077 }
2078/* L200: */
2079 }
2080/* L100: */
2081 }
2082
2083/* ------------------------------ The end -------------------------------
2084*/
2085
2086 if (ldbg) {
2087 AdvApp2Var_SysBase::mgsomsg_("MMA2AC2", 7L);
2088 }
2089 return 0;
2090} /* mma2ac2_ */
2091
2092
2093//=======================================================================
2094//function : mma2ac3_
2095//purpose :
2096//=======================================================================
2097int AdvApp2Var_ApproxF2var::mma2ac3_(const integer *ndimen,
2098 const integer *mxujac,
2099 const integer *mxvjac,
2100 const integer *iordru,
2101 const integer *nclimv,
2102 const integer *ncfiu1,
2103 const doublereal * crbiu1,
2104 const integer *ncfiu2,
2105 const doublereal *crbiu2,
2106 const doublereal *uhermt,
2107 doublereal *patjac)
2108
2109{
2110 /* System generated locals */
2111 integer crbiu1_dim1, crbiu1_dim2, crbiu1_offset, crbiu2_dim1, crbiu2_dim2,
2112 crbiu2_offset, patjac_dim1, patjac_dim2, patjac_offset,
2113 uhermt_dim1, uhermt_offset, i__1, i__2, i__3, i__4;
2114
2115 /* Local variables */
2116 static logical ldbg;
2117 static integer ndgu1, ndgu2, ii, jj, nd, kk;
2118 static doublereal bid1, bid2;
2119
2120
2121
2122
2123/* **********************************************************************
2124*/
2125
2126/* FONCTION : */
2127/* ---------- */
2128/* Ajout des polynomes de contraintes */
2129
2130/* MOTS CLES : */
2131/* ----------- */
2132/* FONCTION,APPROXIMATION,COEFFICIENT,POLYNOME */
2133
2134/* ARGUMENTS D'ENTREE : */
2135/* ------------------ */
2136/* NDIMEN: Dimension de l'espace. */
2137/* MXUJAC: Degre maxi du polynome d' approximation en U. La */
2138/* representation dans la base orthogonale part du degre */
2139/* 0 au degre MXUJAC-2*(IORDRU+1). La base polynomiale est */
2140/* la base de Jacobi d' ordre -1 (Legendre), 0, 1 ou 2 */
2141/* MXVJAC: Degre maxi du polynome d' approximation en V. La */
2142/* representation dans la base orthogonale part du degre */
2143/* 0 au degre MXVJAC-2*(IORDRU+1). La base polynomiale est */
2144/* la base de Jacobi d' ordre -1 (Legendre), 0, 1 ou 2 */
2145/* IORDRU: Ordre de la base de Jacobi (-1,0,1 ou 2) en V. Correspond */
2146/* a pas de contraintes, contraintes C0, C1 ou C2. */
2147/* NCLIMV: Nbre LIMITE de coeff. en v de la solution P(u,v). */
2148/* NCFIU1: Nbre de Coeff. des courbes stockees dans CRBIU1. */
2149/* CRBIU1: Table des coeffs de l'approximation de l'iso-U0 et ses */
2150/* derivees jusqu'a l'ordre IORDRU. */
2151/* NCFIU2: Nbre de Coeff. des courbes stockees dans CRBIU2. */
2152/* CRBIU2: Table des coeffs de l'approximation de l'iso-U1 et ses */
2153/* derivees jusqu'a l'ordre IORDRU. */
2154/* UHERMT: Table des coeff. des polynomes d'Hermite d'ordre IORDRU. */
2155/* PATJAC: Table des coefficients du polynome P(u,v) d' approximation */
2156/* de F(u,v) SANS prise en compte des contraintes. */
2157
2158/* ARGUMENTS DE SORTIE : */
2159/* ------------------- */
2160/* PATJAC: Table des coefficients du polynome P(u,v) d' approximation */
2161/* de F(u,v) AVEC prise en compte des contraintes. */
2162
2163/* COMMONS UTILISES : */
2164/* ---------------- */
2165
2166/* REFERENCES APPELEES : */
2167/* ----------------------- */
2168
2169/* DESCRIPTION/REMARQUES/LIMITATIONS : */
2170/* ----------------------------------- */
2171
2172/* $ HISTORIQUE DES MODIFICATIONS : */
2173/* -------------------------------- */
2174/* 06-02-1991: RBD; Creation d'apres MA2CA3. */
2175/* > */
2176/* **********************************************************************
2177*/
2178/* Le nom de la routine */
2179
2180/* --------------------------- Initialisations --------------------------
2181*/
2182
2183 /* Parameter adjustments */
2184 patjac_dim1 = *mxujac + 1;
2185 patjac_dim2 = *mxvjac + 1;
2186 patjac_offset = patjac_dim1 * patjac_dim2;
2187 patjac -= patjac_offset;
2188 uhermt_dim1 = (*iordru << 1) + 2;
2189 uhermt_offset = uhermt_dim1;
2190 uhermt -= uhermt_offset;
2191 --ncfiu2;
2192 --ncfiu1;
2193 crbiu2_dim1 = *nclimv;
2194 crbiu2_dim2 = *ndimen;
2195 crbiu2_offset = crbiu2_dim1 * (crbiu2_dim2 + 1);
2196 crbiu2 -= crbiu2_offset;
2197 crbiu1_dim1 = *nclimv;
2198 crbiu1_dim2 = *ndimen;
2199 crbiu1_offset = crbiu1_dim1 * (crbiu1_dim2 + 1);
2200 crbiu1 -= crbiu1_offset;
2201
2202 /* Function Body */
2203 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 3;
2204 if (ldbg) {
2205 AdvApp2Var_SysBase::mgenmsg_("MMA2AC3", 7L);
2206 }
2207
2208/* ------------ AJOUT des coeff en u des courbes, en v d'Hermite --------
2209*/
2210
2211 i__1 = *iordru + 1;
2212 for (ii = 1; ii <= i__1; ++ii) {
2213 ndgu1 = ncfiu1[ii] - 1;
2214 ndgu2 = ncfiu2[ii] - 1;
2215 i__2 = *ndimen;
2216 for (nd = 1; nd <= i__2; ++nd) {
2217 i__3 = ndgu1;
2218 for (jj = 0; jj <= i__3; ++jj) {
2219 bid1 = crbiu1[jj + (nd + ii * crbiu1_dim2) * crbiu1_dim1];
2220 i__4 = (*iordru << 1) + 1;
2221 for (kk = 0; kk <= i__4; ++kk) {
2222 patjac[kk + (jj + nd * patjac_dim2) * patjac_dim1] +=
2223 bid1 * uhermt[kk + ((ii << 1) - 1) * uhermt_dim1];
2224/* L400: */
2225 }
2226/* L300: */
2227 }
2228 i__3 = ndgu2;
2229 for (jj = 0; jj <= i__3; ++jj) {
2230 bid2 = crbiu2[jj + (nd + ii * crbiu2_dim2) * crbiu2_dim1];
2231 i__4 = (*iordru << 1) + 1;
2232 for (kk = 0; kk <= i__4; ++kk) {
2233 patjac[kk + (jj + nd * patjac_dim2) * patjac_dim1] +=
2234 bid2 * uhermt[kk + (ii << 1) * uhermt_dim1];
2235/* L600: */
2236 }
2237/* L500: */
2238 }
2239
2240/* L200: */
2241 }
2242/* L100: */
2243 }
2244
2245/* ------------------------------ The end -------------------------------
2246*/
2247
2248 if (ldbg) {
2249 AdvApp2Var_SysBase::mgsomsg_("MMA2AC3", 7L);
2250 }
2251 return 0;
2252} /* mma2ac3_ */
2253
2254//=======================================================================
2255//function : mma2can_
2256//purpose :
2257//=======================================================================
2258int AdvApp2Var_ApproxF2var::mma2can_(const integer *ncfmxu,
2259 const integer *ncfmxv,
2260 const integer *ndimen,
2261 const integer *iordru,
2262 const integer *iordrv,
2263 const integer *ncoefu,
2264 const integer *ncoefv,
2265 const doublereal *patjac,
2266 doublereal *pataux,
2267 doublereal *patcan,
2268 integer *iercod)
2269
2270{
2271 /* System generated locals */
2272 integer patjac_dim1, patjac_dim2, patjac_offset, patcan_dim1, patcan_dim2,
2273 patcan_offset, i__1, i__2;
2274
2275 /* Local variables */
2276 static logical ldbg;
2277 static integer ilon1, ilon2, ii, nd;
2278
2279
2280
2281
2282/* **********************************************************************
2283*/
2284
2285/* FONCTION : */
2286/* ---------- */
2287/* Changement de base Jacobi vers canonique (-1,1) et ecriture dans */
2288/* un tableau + grand. */
2289
2290/* MOTS CLES : */
2291/* ----------- */
2292/* TOUS,AB_SPECIFI,CARREAU&,CONVERSION,JACOBI,CANNONIQUE,&CARREAU */
2293
2294/* ARGUMENTS D'ENTREE : */
2295/* -------------------- */
2296/* NCFMXU: Dimension en U du tableau resultat PATCAN */
2297/* NCFMXV: Dimension en V du tableau resultat PATCAN */
2298/* NDIMEN: Dimension de l'espace de travail. */
2299/* IORDRU: Ordre de contrainte en U */
2300/* IORDRV: Ordre de contrainte en V. */
2301/* NCOEFU: Nbre de coeff en U du carreau PATJAC */
2302/* NCOEFV: Nbre de coeff en V du carreau PATJAC */
2303/* PATJAC: Carreau dans la base de Jacobi d'ordre IORDRU en U et */
2304/* IORDRV en V. */
2305
2306/* ARGUMENTS DE SORTIE : */
2307/* --------------------- */
2308/* PATAUX: Tableau auxiliaire. */
2309/* PATCAN: Tableau des coefficients dans la base canonique. */
2310/* IERCOD: Code d'erreur. */
2311/* = 0, tout va tres bien, toutes choses etant egales par */
2312/* ailleurs. */
2313/* = 1, le programme refuse de traiter avec des arguments */
2314/* d'entrees aussi stupides. */
2315
2316/* COMMONS UTILISES : */
2317/* ------------------ */
2318
2319/* REFERENCES APPELEES : */
2320/* --------------------- */
2321
2322/* DESCRIPTION/REMARQUES/LIMITATIONS : */
2323/* ----------------------------------- */
2324
2325/* $ HISTORIQUE DES MODIFICATIONS : */
2326/* ------------------------------ */
2327/* 29-01-1992: RBD; Ecriture version originale. */
2328/* > */
2329/* **********************************************************************
2330*/
2331
2332
2333 /* Parameter adjustments */
2334 patcan_dim1 = *ncfmxu;
2335 patcan_dim2 = *ncfmxv;
2336 patcan_offset = patcan_dim1 * (patcan_dim2 + 1) + 1;
2337 patcan -= patcan_offset;
2338 --pataux;
2339 patjac_dim1 = *ncoefu;
2340 patjac_dim2 = *ncoefv;
2341 patjac_offset = patjac_dim1 * (patjac_dim2 + 1) + 1;
2342 patjac -= patjac_offset;
2343
2344 /* Function Body */
2345 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 2;
2346 if (ldbg) {
2347 AdvApp2Var_SysBase::mgenmsg_("MMA2CAN", 7L);
2348 }
2349 *iercod = 0;
2350
2351 if (*iordru < -1 || *iordru > 2) {
2352 goto L9100;
2353 }
2354 if (*iordrv < -1 || *iordrv > 2) {
2355 goto L9100;
2356 }
2357 if (*ncoefu > *ncfmxu || *ncoefv > *ncfmxv) {
2358 goto L9100;
2359 }
2360
2361/* -------------------- Ah les jolis changements de bases ---------------
2362*/
2363/* ------------ (Sur l'air des 'jolies colonies de vacances') -----------
2364*/
2365
2366/* --> On passe en base canonique (-1,1) */
2367 mmjacpt_(ndimen, ncoefu, ncoefv, iordru, iordrv, &patjac[patjac_offset], &
2368 pataux[1], &patcan[patcan_offset]);
2369
2370/* --> On ecrit le tout dans un tableau + grand */
2371 AdvApp2Var_MathBase::mmfmca8_((integer *)ncoefu,
2372 (integer *)ncoefv,
2373 (integer *)ndimen,
2374 (integer *)ncfmxu,
2375 (integer *)ncfmxv,
2376 (integer *)ndimen,
2377 (doublereal *)&patcan[patcan_offset],
2378 (doublereal *)&patcan[patcan_offset]);
2379
2380/* --> On complete avec des zeros le tableau resultat. */
2381 ilon1 = *ncfmxu - *ncoefu;
2382 ilon2 = *ncfmxu * (*ncfmxv - *ncoefv);
2383 i__1 = *ndimen;
2384 for (nd = 1; nd <= i__1; ++nd) {
2385 if (ilon1 > 0) {
2386 i__2 = *ncoefv;
2387 for (ii = 1; ii <= i__2; ++ii) {
2388 AdvApp2Var_SysBase::mvriraz_(&ilon1,
2389 (char *)&patcan[*ncoefu + 1 + (ii + nd * patcan_dim2) * patcan_dim1]);
2390/* L110: */
2391 }
2392 }
2393 if (ilon2 > 0) {
2394 AdvApp2Var_SysBase::mvriraz_(&ilon2,
2395 (char *)&patcan[(*ncoefv + 1 + nd * patcan_dim2) * patcan_dim1 + 1]);
2396 }
2397/* L100: */
2398 }
2399
2400 goto L9999;
2401
2402/* ---------------------- A la revoyure M'sieu dames --------------------
2403*/
2404
2405L9100:
2406 *iercod = 1;
2407 goto L9999;
2408
2409L9999:
2410 AdvApp2Var_SysBase::maermsg_("MMA2CAN", iercod, 7L);
2411 if (ldbg) {
2412 AdvApp2Var_SysBase::mgsomsg_("MMA2CAN", 7L);
2413 }
2414 return 0 ;
2415} /* mma2can_ */
2416
2417//=======================================================================
2418//function : mma2cd1_
2419//purpose :
2420//=======================================================================
2421int mma2cd1_(integer *ndimen,
2422 integer *nbpntu,
2423 doublereal *urootl,
2424 integer *nbpntv,
2425 doublereal *vrootl,
2426 integer *iordru,
2427 integer *iordrv,
2428 doublereal *contr1,
2429 doublereal *contr2,
2430 doublereal *contr3,
2431 doublereal *contr4,
2432 doublereal *fpntbu,
2433 doublereal *fpntbv,
2434 doublereal *uhermt,
2435 doublereal *vhermt,
2436 doublereal *sosotb,
2437 doublereal *soditb,
2438 doublereal *disotb,
2439 doublereal *diditb)
2440
2441{
2442 static integer c__1 = 1;
2443
2444/* System generated locals */
2445 integer contr1_dim1, contr1_dim2, contr1_offset, contr2_dim1, contr2_dim2,
2446 contr2_offset, contr3_dim1, contr3_dim2, contr3_offset,
2447 contr4_dim1, contr4_dim2, contr4_offset, uhermt_dim1,
2448 uhermt_offset, vhermt_dim1, vhermt_offset, fpntbu_dim1,
2449 fpntbu_offset, fpntbv_dim1, fpntbv_offset, sosotb_dim1,
2450 sosotb_dim2, sosotb_offset, diditb_dim1, diditb_dim2,
2451 diditb_offset, soditb_dim1, soditb_dim2, soditb_offset,
2452 disotb_dim1, disotb_dim2, disotb_offset, i__1, i__2, i__3, i__4,
2453 i__5;
2454
2455 /* Local variables */
2456 static integer ncfhu, ncfhv, nuroo, nvroo, nd, ii, jj, kk, ll, ibb, kkm,
2457 llm, kkp, llp;
2458 static doublereal bid1, bid2, bid3, bid4;
2459 static doublereal diu1, diu2, div1, div2, sou1, sou2, sov1, sov2;
2460
2461
2462
2463
2464/* **********************************************************************
2465*/
2466
2467/* FONCTION : */
2468/* ---------- */
2469/* Discretisation sur les parametres des polynomes d'interpolation */
2470/* des contraintes aux coins a l'ordre IORDRE. */
2471
2472/* MOTS CLES : */
2473/* ----------- */
2474/* TOUS, AB_SPECIFI::CONTRAINTE&, DISCRETISATION, &POINT */
2475
2476/* ARGUMENTS D'ENTREE : */
2477/* ------------------ */
2478/* NDIMEN: Dimension de l' espace. */
2479/* NBPNTU: Nbre de parametres INTERNES de discretisation EN U. */
2480/* C'est aussi le nbre de racine du polynome de Legendre ou */
2481/* on discretise. */
2482/* UROOTL: Tableau des parametres de discretisation SUR (-1,1) EN U.
2483*/
2484/* NBPNTV: Nbre de parametres INTERNES de discretisation EN V. */
2485/* C'est aussi le nbre de racine du polynome de Legendre ou */
2486/* on discretise. */
2487/* VROOTL: Tableau des parametres de discretisation SUR (-1,1) EN V.
2488*/
2489/* IORDRU: Ordre de contrainte impose aux extremites de l'iso-V */
2490/* = 0, on calcule les extremites de l'iso-V */
2491/* = 1, on calcule, en plus, la derivee 1ere dans le sens */
2492/* de l'iso-V */
2493/* = 2, on calcule, en plus, la derivee 2nde dans le sens */
2494/* de l'iso-V */
2495/* IORDRV: Ordre de contrainte impose aux extremites de l'iso-U */
2496/* = 0, on calcule les extremites de l'iso-U. */
2497/* = 1, on calcule, en plus, la derivee 1ere dans le sens */
2498/* de l'iso-U */
2499/* = 2, on calcule, en plus, la derivee 2nde dans le sens */
2500/* de l'iso-U */
2501/* CONTR1: Contient, si IORDRU et IORDRV>=0, les valeurs aux */
2502/* extremitees de F(U0,V0)et de ses derivees. */
2503/* CONTR2: Contient, si IORDRU et IORDRV>=0, les valeurs aux */
2504/* extremitees de F(U1,V0)et de ses derivees. */
2505/* CONTR3: Contient, si IORDRU et IORDRV>=0, les valeurs aux */
2506/* extremitees de F(U0,V1)et de ses derivees. */
2507/* CONTR4: Contient, si IORDRU et IORDRV>=0, les valeurs aux */
2508/* extremitees de F(U1,V1)et de ses derivees. */
2509/* SOSOTB: Tableau deja initialise (argument d'entree/sortie). */
2510/* DISOTB: Tableau deja initialise (argument d'entree/sortie). */
2511/* SODITB: Tableau deja initialise (argument d'entree/sortie). */
2512/* DIDITB: Tableau deja initialise (argument d'entree/sortie). */
2513
2514/* ARGUMENTS DE SORTIE : */
2515/* ------------------- */
2516/* FPNTBU: Tableau auxiliaire. */
2517/* FPNTBV: Tableau auxiliaire. */
2518/* UHERMT: Table des 2*(IORDRU+1) coeff. des 2*(IORDRU+1) polynomes */
2519/* d'Hermite. */
2520/* VHERMT: Table des 2*(IORDRV+1) coeff. des 2*(IORDRV+1) polynomes */
2521/* d'Hermite. */
2522/* SOSOTB: Tableau ou l'on ajoute les termes de contraintes */
2523/* C(ui,vj) + C(ui,-vj) + C(-ui,vj) + C(-ui,-vj) */
2524/* avec ui et vj racines positives du polynome de Legendre */
2525/* de degre NBPNTU et NBPNTV respectivement. */
2526/* DISOTB: Tableau ou l'on ajoute les termes de contraintes */
2527/* C(ui,vj) + C(ui,-vj) - C(-ui,vj) - C(-ui,-vj) */
2528/* avec ui et vj racines positives du polynome de Legendre */
2529/* de degre NBPNTU et NBPNTV respectivement. */
2530/* SODITB: Tableau ou l'on ajoute les termes de contraintes */
2531/* C(ui,vj) - C(ui,-vj) + C(-ui,vj) - C(-ui,-vj) */
2532/* avec ui et vj racines positives du polynome de Legendre */
2533/* de degre NBPNTU et NBPNTV respectivement. */
2534/* DIDITB: Tableau ou l'on ajoute les termes de contraintes */
2535/* C(ui,vj) - C(ui,-vj) - C(-ui,vj) + C(-ui,-vj) */
2536/* avec ui et vj racines positives du polynome de Legendre */
2537/* de degre NBPNTU et NBPNTV respectivement. */
2538
2539/* COMMONS UTILISES : */
2540/* ---------------- */
2541
2542/* REFERENCES APPELEES : */
2543/* ----------------------- */
2544
2545/* DESCRIPTION/REMARQUES/LIMITATIONS : */
2546/* ----------------------------------- */
2547
2548/* $ HISTORIQUE DES MODIFICATIONS : */
2549/* -------------------------------- */
2550/* 09-08-1991: RBD; Creation. */
2551/* > */
2552/* **********************************************************************
2553*/
2554
2555/* Le nom de la routine */
2556
2557
2558 /* Parameter adjustments */
2559 --urootl;
2560 diditb_dim1 = *nbpntu / 2 + 1;
2561 diditb_dim2 = *nbpntv / 2 + 1;
2562 diditb_offset = diditb_dim1 * diditb_dim2;
2563 diditb -= diditb_offset;
2564 disotb_dim1 = *nbpntu / 2;
2565 disotb_dim2 = *nbpntv / 2;
2566 disotb_offset = disotb_dim1 * (disotb_dim2 + 1) + 1;
2567 disotb -= disotb_offset;
2568 soditb_dim1 = *nbpntu / 2;
2569 soditb_dim2 = *nbpntv / 2;
2570 soditb_offset = soditb_dim1 * (soditb_dim2 + 1) + 1;
2571 soditb -= soditb_offset;
2572 sosotb_dim1 = *nbpntu / 2 + 1;
2573 sosotb_dim2 = *nbpntv / 2 + 1;
2574 sosotb_offset = sosotb_dim1 * sosotb_dim2;
2575 sosotb -= sosotb_offset;
2576 --vrootl;
2577 uhermt_dim1 = (*iordru << 1) + 2;
2578 uhermt_offset = uhermt_dim1;
2579 uhermt -= uhermt_offset;
2580 fpntbu_dim1 = *nbpntu;
2581 fpntbu_offset = fpntbu_dim1 + 1;
2582 fpntbu -= fpntbu_offset;
2583 vhermt_dim1 = (*iordrv << 1) + 2;
2584 vhermt_offset = vhermt_dim1;
2585 vhermt -= vhermt_offset;
2586 fpntbv_dim1 = *nbpntv;
2587 fpntbv_offset = fpntbv_dim1 + 1;
2588 fpntbv -= fpntbv_offset;
2589 contr4_dim1 = *ndimen;
2590 contr4_dim2 = *iordru + 2;
2591 contr4_offset = contr4_dim1 * (contr4_dim2 + 1) + 1;
2592 contr4 -= contr4_offset;
2593 contr3_dim1 = *ndimen;
2594 contr3_dim2 = *iordru + 2;
2595 contr3_offset = contr3_dim1 * (contr3_dim2 + 1) + 1;
2596 contr3 -= contr3_offset;
2597 contr2_dim1 = *ndimen;
2598 contr2_dim2 = *iordru + 2;
2599 contr2_offset = contr2_dim1 * (contr2_dim2 + 1) + 1;
2600 contr2 -= contr2_offset;
2601 contr1_dim1 = *ndimen;
2602 contr1_dim2 = *iordru + 2;
2603 contr1_offset = contr1_dim1 * (contr1_dim2 + 1) + 1;
2604 contr1 -= contr1_offset;
2605
2606 /* Function Body */
2607 ibb = AdvApp2Var_SysBase::mnfndeb_();
2608 if (ibb >= 3) {
2609 AdvApp2Var_SysBase::mgenmsg_("MMA2CD1", 7L);
2610 }
2611
2612/* ------------------- Discretisation des polynomes d'Hermite -----------
2613*/
2614
2615 ncfhu = (*iordru + 1) << 1;
2616 i__1 = ncfhu;
2617 for (ii = 1; ii <= i__1; ++ii) {
2618 i__2 = *nbpntu;
2619 for (ll = 1; ll <= i__2; ++ll) {
2620 AdvApp2Var_MathBase::mmmpocur_(&ncfhu, &c__1, &ncfhu, &uhermt[ii * uhermt_dim1], &
2621 urootl[ll], &fpntbu[ll + ii * fpntbu_dim1]);
2622/* L20: */
2623 }
2624/* L10: */
2625 }
2626 ncfhv = (*iordrv + 1) << 1;
2627 i__1 = ncfhv;
2628 for (jj = 1; jj <= i__1; ++jj) {
2629 i__2 = *nbpntv;
2630 for (kk = 1; kk <= i__2; ++kk) {
2631 AdvApp2Var_MathBase::mmmpocur_(&ncfhv, &c__1, &ncfhv, &vhermt[jj * vhermt_dim1], &
2632 vrootl[kk], &fpntbv[kk + jj * fpntbv_dim1]);
2633/* L40: */
2634 }
2635/* L30: */
2636 }
2637
2638/* ---- On retranche les discretisations des polynomes de contrainte ----
2639*/
2640
2641 nuroo = *nbpntu / 2;
2642 nvroo = *nbpntv / 2;
2643 i__1 = *ndimen;
2644 for (nd = 1; nd <= i__1; ++nd) {
2645
2646 i__2 = *iordrv + 1;
2647 for (jj = 1; jj <= i__2; ++jj) {
2648 i__3 = *iordru + 1;
2649 for (ii = 1; ii <= i__3; ++ii) {
2650 bid1 = contr1[nd + (ii + jj * contr1_dim2) * contr1_dim1];
2651 bid2 = contr2[nd + (ii + jj * contr2_dim2) * contr2_dim1];
2652 bid3 = contr3[nd + (ii + jj * contr3_dim2) * contr3_dim1];
2653 bid4 = contr4[nd + (ii + jj * contr4_dim2) * contr4_dim1];
2654
2655 i__4 = nvroo;
2656 for (kk = 1; kk <= i__4; ++kk) {
2657 kkp = (*nbpntv + 1) / 2 + kk;
2658 kkm = nvroo - kk + 1;
2659 sov1 = fpntbv[kkp + ((jj << 1) - 1) * fpntbv_dim1] +
2660 fpntbv[kkm + ((jj << 1) - 1) * fpntbv_dim1];
2661 div1 = fpntbv[kkp + ((jj << 1) - 1) * fpntbv_dim1] -
2662 fpntbv[kkm + ((jj << 1) - 1) * fpntbv_dim1];
2663 sov2 = fpntbv[kkp + (jj << 1) * fpntbv_dim1] + fpntbv[kkm
2664 + (jj << 1) * fpntbv_dim1];
2665 div2 = fpntbv[kkp + (jj << 1) * fpntbv_dim1] - fpntbv[kkm
2666 + (jj << 1) * fpntbv_dim1];
2667 i__5 = nuroo;
2668 for (ll = 1; ll <= i__5; ++ll) {
2669 llp = (*nbpntu + 1) / 2 + ll;
2670 llm = nuroo - ll + 1;
2671 sou1 = fpntbu[llp + ((ii << 1) - 1) * fpntbu_dim1] +
2672 fpntbu[llm + ((ii << 1) - 1) * fpntbu_dim1];
2673 diu1 = fpntbu[llp + ((ii << 1) - 1) * fpntbu_dim1] -
2674 fpntbu[llm + ((ii << 1) - 1) * fpntbu_dim1];
2675 sou2 = fpntbu[llp + (ii << 1) * fpntbu_dim1] + fpntbu[
2676 llm + (ii << 1) * fpntbu_dim1];
2677 diu2 = fpntbu[llp + (ii << 1) * fpntbu_dim1] - fpntbu[
2678 llm + (ii << 1) * fpntbu_dim1];
2679 sosotb[ll + (kk + nd * sosotb_dim2) * sosotb_dim1] =
2680 sosotb[ll + (kk + nd * sosotb_dim2) *
2681 sosotb_dim1] - bid1 * sou1 * sov1 - bid2 *
2682 sou2 * sov1 - bid3 * sou1 * sov2 - bid4 *
2683 sou2 * sov2;
2684 soditb[ll + (kk + nd * soditb_dim2) * soditb_dim1] =
2685 soditb[ll + (kk + nd * soditb_dim2) *
2686 soditb_dim1] - bid1 * sou1 * div1 - bid2 *
2687 sou2 * div1 - bid3 * sou1 * div2 - bid4 *
2688 sou2 * div2;
2689 disotb[ll + (kk + nd * disotb_dim2) * disotb_dim1] =
2690 disotb[ll + (kk + nd * disotb_dim2) *
2691 disotb_dim1] - bid1 * diu1 * sov1 - bid2 *
2692 diu2 * sov1 - bid3 * diu1 * sov2 - bid4 *
2693 diu2 * sov2;
2694 diditb[ll + (kk + nd * diditb_dim2) * diditb_dim1] =
2695 diditb[ll + (kk + nd * diditb_dim2) *
2696 diditb_dim1] - bid1 * diu1 * div1 - bid2 *
2697 diu2 * div1 - bid3 * diu1 * div2 - bid4 *
2698 diu2 * div2;
2699/* L450: */
2700 }
2701/* L400: */
2702 }
2703
2704/* ------------ Cas ou l' on discretise sur les racines d' un
2705----------- */
2706/* ---------- polynome de Legendre de degre impair, 0 est raci
2707ne -------- */
2708
2709 if (*nbpntu % 2 == 1) {
2710 sou1 = fpntbu[nuroo + 1 + ((ii << 1) - 1) * fpntbu_dim1];
2711 sou2 = fpntbu[nuroo + 1 + (ii << 1) * fpntbu_dim1];
2712 i__4 = nvroo;
2713 for (kk = 1; kk <= i__4; ++kk) {
2714 kkp = (*nbpntv + 1) / 2 + kk;
2715 kkm = nvroo - kk + 1;
2716 sov1 = fpntbv[kkp + ((jj << 1) - 1) * fpntbv_dim1] +
2717 fpntbv[kkm + ((jj << 1) - 1) * fpntbv_dim1];
2718 div1 = fpntbv[kkp + ((jj << 1) - 1) * fpntbv_dim1] -
2719 fpntbv[kkm + ((jj << 1) - 1) * fpntbv_dim1];
2720 sov2 = fpntbv[kkp + (jj << 1) * fpntbv_dim1] + fpntbv[
2721 kkm + (jj << 1) * fpntbv_dim1];
2722 div2 = fpntbv[kkp + (jj << 1) * fpntbv_dim1] - fpntbv[
2723 kkm + (jj << 1) * fpntbv_dim1];
2724 sosotb[(kk + nd * sosotb_dim2) * sosotb_dim1] =
2725 sosotb[(kk + nd * sosotb_dim2) * sosotb_dim1]
2726 - bid1 * sou1 * sov1 - bid2 * sou2 * sov1 -
2727 bid3 * sou1 * sov2 - bid4 * sou2 * sov2;
2728 diditb[(kk + nd * diditb_dim2) * diditb_dim1] =
2729 diditb[(kk + nd * diditb_dim2) * diditb_dim1]
2730 - bid1 * sou1 * div1 - bid2 * sou2 * div1 -
2731 bid3 * sou1 * div2 - bid4 * sou2 * div2;
2732/* L500: */
2733 }
2734 }
2735
2736 if (*nbpntv % 2 == 1) {
2737 sov1 = fpntbv[nvroo + 1 + ((jj << 1) - 1) * fpntbv_dim1];
2738 sov2 = fpntbv[nvroo + 1 + (jj << 1) * fpntbv_dim1];
2739 i__4 = nuroo;
2740 for (ll = 1; ll <= i__4; ++ll) {
2741 llp = (*nbpntu + 1) / 2 + ll;
2742 llm = nuroo - ll + 1;
2743 sou1 = fpntbu[llp + ((ii << 1) - 1) * fpntbu_dim1] +
2744 fpntbu[llm + ((ii << 1) - 1) * fpntbu_dim1];
2745 diu1 = fpntbu[llp + ((ii << 1) - 1) * fpntbu_dim1] -
2746 fpntbu[llm + ((ii << 1) - 1) * fpntbu_dim1];
2747 sou2 = fpntbu[llp + (ii << 1) * fpntbu_dim1] + fpntbu[
2748 llm + (ii << 1) * fpntbu_dim1];
2749 diu2 = fpntbu[llp + (ii << 1) * fpntbu_dim1] - fpntbu[
2750 llm + (ii << 1) * fpntbu_dim1];
2751 sosotb[ll + nd * sosotb_dim2 * sosotb_dim1] = sosotb[
2752 ll + nd * sosotb_dim2 * sosotb_dim1] - bid1 *
2753 sou1 * sov1 - bid2 * sou2 * sov1 - bid3 *
2754 sou1 * sov2 - bid4 * sou2 * sov2;
2755 diditb[ll + nd * diditb_dim2 * diditb_dim1] = diditb[
2756 ll + nd * diditb_dim2 * diditb_dim1] - bid1 *
2757 diu1 * sov1 - bid2 * diu2 * sov1 - bid3 *
2758 diu1 * sov2 - bid4 * diu2 * sov2;
2759/* L600: */
2760 }
2761 }
2762
2763 if (*nbpntu % 2 == 1 && *nbpntv % 2 == 1) {
2764 sou1 = fpntbu[nuroo + 1 + ((ii << 1) - 1) * fpntbu_dim1];
2765 sou2 = fpntbu[nuroo + 1 + (ii << 1) * fpntbu_dim1];
2766 sov1 = fpntbv[nvroo + 1 + ((jj << 1) - 1) * fpntbv_dim1];
2767 sov2 = fpntbv[nvroo + 1 + (jj << 1) * fpntbv_dim1];
2768 sosotb[nd * sosotb_dim2 * sosotb_dim1] = sosotb[nd *
2769 sosotb_dim2 * sosotb_dim1] - bid1 * sou1 * sov1 -
2770 bid2 * sou2 * sov1 - bid3 * sou1 * sov2 - bid4 *
2771 sou2 * sov2;
2772 diditb[nd * diditb_dim2 * diditb_dim1] = diditb[nd *
2773 diditb_dim2 * diditb_dim1] - bid1 * sou1 * sov1 -
2774 bid2 * sou2 * sov1 - bid3 * sou1 * sov2 - bid4 *
2775 sou2 * sov2;
2776 }
2777
2778/* L300: */
2779 }
2780/* L200: */
2781 }
2782/* L100: */
2783 }
2784 goto L9999;
2785
2786/* ------------------------------ The End -------------------------------
2787*/
2788
2789L9999:
2790 if (ibb >= 3) {
2791 AdvApp2Var_SysBase::mgsomsg_("MMA2CD1", 7L);
2792 }
2793 return 0;
2794} /* mma2cd1_ */
2795
2796//=======================================================================
2797//function : mma2cd2_
2798//purpose :
2799//=======================================================================
2800int mma2cd2_(integer *ndimen,
2801 integer *nbpntu,
2802 integer *nbpntv,
2803 doublereal *vrootl,
2804 integer *iordrv,
2805 doublereal *sotbv1,
2806 doublereal *sotbv2,
2807 doublereal *ditbv1,
2808 doublereal *ditbv2,
2809 doublereal *fpntab,
2810 doublereal *vhermt,
2811 doublereal *sosotb,
2812 doublereal *soditb,
2813 doublereal *disotb,
2814 doublereal *diditb)
2815
2816{
2817 static integer c__1 = 1;
2818 /* System generated locals */
2819 integer sotbv1_dim1, sotbv1_dim2, sotbv1_offset, sotbv2_dim1, sotbv2_dim2,
2820 sotbv2_offset, ditbv1_dim1, ditbv1_dim2, ditbv1_offset,
2821 ditbv2_dim1, ditbv2_dim2, ditbv2_offset, fpntab_dim1,
2822 fpntab_offset, vhermt_dim1, vhermt_offset, sosotb_dim1,
2823 sosotb_dim2, sosotb_offset, diditb_dim1, diditb_dim2,
2824 diditb_offset, soditb_dim1, soditb_dim2, soditb_offset,
2825 disotb_dim1, disotb_dim2, disotb_offset, i__1, i__2, i__3, i__4;
2826
2827 /* Local variables */
2828 static integer ncfhv, nuroo, nvroo, ii, nd, jj, kk, ibb, jjm, jjp;
2829 static doublereal bid1, bid2, bid3, bid4;
2830
2831/* **********************************************************************
2832*/
2833
2834/* FONCTION : */
2835/* ---------- */
2836/* Discretisation sur les parametres des polynomes d'interpolation */
2837/* des contraintes sur les 2 bords iso-V a l'ordre IORDRV. */
2838
2839/* MOTS CLES : */
2840/* ----------- */
2841/* TOUS, AB_SPECIFI::CONTRAINTE&, DISCRETISATION, &POINT */
2842
2843/* ARGUMENTS D'ENTREE : */
2844/* ------------------ */
2845/* NDIMEN: Dimension de l' espace. */
2846/* NBPNTU: Nbre de parametres INTERNES de discretisation EN U. */
2847/* C'est aussi le nbre de racine du polynome de Legendre ou */
2848/* on discretise. */
2849/* NBPNTV: Nbre de parametres INTERNES de discretisation EN V. */
2850/* C'est aussi le nbre de racine du polynome de Legendre ou */
2851/* on discretise. */
2852/* VROOTL: Tableau des parametres de discretisation SUR (-1,1) EN V.
2853*/
2854/* IORDRV: Ordre de derivation de l'iso-V */
2855/* = 0, on calcule l'iso-V. */
2856/* = 1, on calcule, en plus, la derivee 1ere dans le sens */
2857/* transverse a l'iso-V (donc en V). */
2858/* = 2, on calcule, en plus, la derivee 2nde dans le sens */
2859/* transverse a l'iso-V (donc en V). */
2860/* SOTBV1: Tableau des NBPNTV/2 sommes des 2 points d'indices */
2861/* NBPNTV-II+1 et II, pour II = 1, NBPNTV/2 sur l'iso-V0. */
2862/* SOTBV2: Tableau des NBPNTV/2 sommes des 2 points d'indices */
2863/* NBPNTV-II+1 et II, pour II = 1, NBPNTV/2 sur l'iso-V1. */
2864/* DITBV1: Tableau des NBPNTV/2 differences des 2 points d'indices */
2865/* NBPNTV-II+1 et II, pour II = 1, NBPNTV/2 sur l'iso-V0. */
2866/* DITBV2: Tableau des NBPNTV/2 differences des 2 points d'indices */
2867/* NBPNTV-II+1 et II, pour II = 1, NBPNTV/2 sur l'iso-V1. */
2868/* SOSOTB: Tableau deja initialise (argument d'entree/sortie). */
2869/* DISOTB: Tableau deja initialise (argument d'entree/sortie). */
2870/* SODITB: Tableau deja initialise (argument d'entree/sortie). */
2871/* DIDITB: Tableau deja initialise (argument d'entree/sortie). */
2872
2873/* ARGUMENTS DE SORTIE : */
2874/* ------------------- */
2875/* FPNTAB: Tableau auxiliaire. */
2876/* VHERMT: Table des 2*(IORDRV+1) coeff. des 2*(IORDRV+1) polynomes */
2877/* d'Hermite. */
2878/* SOSOTB: Tableau ou l'on ajoute les termes de contraintes */
2879/* C(ui,vj) + C(ui,-vj) + C(-ui,vj) + C(-ui,-vj) */
2880/* avec ui et vj racines positives du polynome de Legendre */
2881/* de degre NBPNTU et NBPNTV respectivement. */
2882/* DISOTB: Tableau ou l'on ajoute les termes de contraintes */
2883/* C(ui,vj) + C(ui,-vj) - C(-ui,vj) - C(-ui,-vj) */
2884/* avec ui et vj racines positives du polynome de Legendre */
2885/* de degre NBPNTU et NBPNTV respectivement. */
2886/* SODITB: Tableau ou l'on ajoute les termes de contraintes */
2887/* C(ui,vj) - C(ui,-vj) + C(-ui,vj) - C(-ui,-vj) */
2888/* avec ui et vj racines positives du polynome de Legendre */
2889/* de degre NBPNTU et NBPNTV respectivement. */
2890/* DIDITB: Tableau ou l'on ajoute les termes de contraintes */
2891/* C(ui,vj) - C(ui,-vj) - C(-ui,vj) + C(-ui,-vj) */
2892/* avec ui et vj racines positives du polynome de Legendre */
2893/* de degre NBPNTU et NBPNTV respectivement. */
2894
2895/* COMMONS UTILISES : */
2896/* ---------------- */
2897
2898/* REFERENCES APPELEES : */
2899/* ----------------------- */
2900
2901/* DESCRIPTION/REMARQUES/LIMITATIONS : */
2902/* ----------------------------------- */
2903
2904
2905/* $ HISTORIQUE DES MODIFICATIONS : */
2906/* -------------------------------- */
2907/* 08-08-1991: RBD; Creation. */
2908/* > */
2909/* **********************************************************************
2910*/
2911
2912/* Le nom de la routine */
2913
2914
2915 /* Parameter adjustments */
2916 diditb_dim1 = *nbpntu / 2 + 1;
2917 diditb_dim2 = *nbpntv / 2 + 1;
2918 diditb_offset = diditb_dim1 * diditb_dim2;
2919 diditb -= diditb_offset;
2920 disotb_dim1 = *nbpntu / 2;
2921 disotb_dim2 = *nbpntv / 2;
2922 disotb_offset = disotb_dim1 * (disotb_dim2 + 1) + 1;
2923 disotb -= disotb_offset;
2924 soditb_dim1 = *nbpntu / 2;
2925 soditb_dim2 = *nbpntv / 2;
2926 soditb_offset = soditb_dim1 * (soditb_dim2 + 1) + 1;
2927 soditb -= soditb_offset;
2928 sosotb_dim1 = *nbpntu / 2 + 1;
2929 sosotb_dim2 = *nbpntv / 2 + 1;
2930 sosotb_offset = sosotb_dim1 * sosotb_dim2;
2931 sosotb -= sosotb_offset;
2932 --vrootl;
2933 vhermt_dim1 = (*iordrv << 1) + 2;
2934 vhermt_offset = vhermt_dim1;
2935 vhermt -= vhermt_offset;
2936 fpntab_dim1 = *nbpntv;
2937 fpntab_offset = fpntab_dim1 + 1;
2938 fpntab -= fpntab_offset;
2939 ditbv2_dim1 = *nbpntu / 2 + 1;
2940 ditbv2_dim2 = *ndimen;
2941 ditbv2_offset = ditbv2_dim1 * (ditbv2_dim2 + 1);
2942 ditbv2 -= ditbv2_offset;
2943 ditbv1_dim1 = *nbpntu / 2 + 1;
2944 ditbv1_dim2 = *ndimen;
2945 ditbv1_offset = ditbv1_dim1 * (ditbv1_dim2 + 1);
2946 ditbv1 -= ditbv1_offset;
2947 sotbv2_dim1 = *nbpntu / 2 + 1;
2948 sotbv2_dim2 = *ndimen;
2949 sotbv2_offset = sotbv2_dim1 * (sotbv2_dim2 + 1);
2950 sotbv2 -= sotbv2_offset;
2951 sotbv1_dim1 = *nbpntu / 2 + 1;
2952 sotbv1_dim2 = *ndimen;
2953 sotbv1_offset = sotbv1_dim1 * (sotbv1_dim2 + 1);
2954 sotbv1 -= sotbv1_offset;
2955
2956 /* Function Body */
2957 ibb = AdvApp2Var_SysBase::mnfndeb_();
2958 if (ibb >= 3) {
2959 AdvApp2Var_SysBase::mgenmsg_("MMA2CD2", 7L);
2960 }
2961
2962/* ------------------- Discretisation des polynomes d'Hermite -----------
2963*/
2964
2965 ncfhv = (*iordrv + 1) << 1;
2966 i__1 = ncfhv;
2967 for (ii = 1; ii <= i__1; ++ii) {
2968 i__2 = *nbpntv;
2969 for (jj = 1; jj <= i__2; ++jj) {
2970 AdvApp2Var_MathBase::mmmpocur_(&ncfhv, &c__1, &ncfhv, &vhermt[ii * vhermt_dim1], &
2971 vrootl[jj], &fpntab[jj + ii * fpntab_dim1]);
2972/* L60: */
2973 }
2974/* L50: */
2975 }
2976
2977/* ---- On retranche les discretisations des polynomes de contrainte ----
2978*/
2979
2980 nuroo = *nbpntu / 2;
2981 nvroo = *nbpntv / 2;
2982
2983 i__1 = *ndimen;
2984 for (nd = 1; nd <= i__1; ++nd) {
2985 i__2 = *iordrv + 1;
2986 for (ii = 1; ii <= i__2; ++ii) {
2987
2988 i__3 = nuroo;
2989 for (kk = 1; kk <= i__3; ++kk) {
2990 bid1 = sotbv1[kk + (nd + ii * sotbv1_dim2) * sotbv1_dim1];
2991 bid2 = sotbv2[kk + (nd + ii * sotbv2_dim2) * sotbv2_dim1];
2992 bid3 = ditbv1[kk + (nd + ii * ditbv1_dim2) * ditbv1_dim1];
2993 bid4 = ditbv2[kk + (nd + ii * ditbv2_dim2) * ditbv2_dim1];
2994 i__4 = nvroo;
2995 for (jj = 1; jj <= i__4; ++jj) {
2996 jjp = (*nbpntv + 1) / 2 + jj;
2997 jjm = nvroo - jj + 1;
2998 sosotb[kk + (jj + nd * sosotb_dim2) * sosotb_dim1] =
2999 sosotb[kk + (jj + nd * sosotb_dim2) * sosotb_dim1]
3000 - bid1 * (fpntab[jjp + ((ii << 1) - 1) *
3001 fpntab_dim1] + fpntab[jjm + ((ii << 1) - 1) *
3002 fpntab_dim1]) - bid2 * (fpntab[jjp + (ii << 1) *
3003 fpntab_dim1] + fpntab[jjm + (ii << 1) *
3004 fpntab_dim1]);
3005 disotb[kk + (jj + nd * disotb_dim2) * disotb_dim1] =
3006 disotb[kk + (jj + nd * disotb_dim2) * disotb_dim1]
3007 - bid3 * (fpntab[jjp + ((ii << 1) - 1) *
3008 fpntab_dim1] + fpntab[jjm + ((ii << 1) - 1) *
3009 fpntab_dim1]) - bid4 * (fpntab[jjp + (ii << 1) *
3010 fpntab_dim1] + fpntab[jjm + (ii << 1) *
3011 fpntab_dim1]);
3012 soditb[kk + (jj + nd * soditb_dim2) * soditb_dim1] =
3013 soditb[kk + (jj + nd * soditb_dim2) * soditb_dim1]
3014 - bid1 * (fpntab[jjp + ((ii << 1) - 1) *
3015 fpntab_dim1] - fpntab[jjm + ((ii << 1) - 1) *
3016 fpntab_dim1]) - bid2 * (fpntab[jjp + (ii << 1) *
3017 fpntab_dim1] - fpntab[jjm + (ii << 1) *
3018 fpntab_dim1]);
3019 diditb[kk + (jj + nd * diditb_dim2) * diditb_dim1] =
3020 diditb[kk + (jj + nd * diditb_dim2) * diditb_dim1]
3021 - bid3 * (fpntab[jjp + ((ii << 1) - 1) *
3022 fpntab_dim1] - fpntab[jjm + ((ii << 1) - 1) *
3023 fpntab_dim1]) - bid4 * (fpntab[jjp + (ii << 1) *
3024 fpntab_dim1] - fpntab[jjm + (ii << 1) *
3025 fpntab_dim1]);
3026/* L400: */
3027 }
3028/* L300: */
3029 }
3030/* L200: */
3031 }
3032
3033/* ------------ Cas ou l' on discretise sur les racines d' un -------
3034---- */
3035/* ---------- polynome de Legendre de degre impair, 0 est racine ----
3036---- */
3037
3038 if (*nbpntv % 2 == 1) {
3039 i__2 = *iordrv + 1;
3040 for (ii = 1; ii <= i__2; ++ii) {
3041 i__3 = nuroo;
3042 for (kk = 1; kk <= i__3; ++kk) {
3043 bid1 = sotbv1[kk + (nd + ii * sotbv1_dim2) * sotbv1_dim1]
3044 * fpntab[nvroo + 1 + ((ii << 1) - 1) *
3045 fpntab_dim1] + sotbv2[kk + (nd + ii * sotbv2_dim2)
3046 * sotbv2_dim1] * fpntab[nvroo + 1 + (ii << 1) *
3047 fpntab_dim1];
3048 sosotb[kk + nd * sosotb_dim2 * sosotb_dim1] -= bid1;
3049 bid2 = ditbv1[kk + (nd + ii * ditbv1_dim2) * ditbv1_dim1]
3050 * fpntab[nvroo + 1 + ((ii << 1) - 1) *
3051 fpntab_dim1] + ditbv2[kk + (nd + ii * ditbv2_dim2)
3052 * ditbv2_dim1] * fpntab[nvroo + 1 + (ii << 1) *
3053 fpntab_dim1];
3054 diditb[kk + nd * diditb_dim2 * diditb_dim1] -= bid2;
3055/* L550: */
3056 }
3057/* L500: */
3058 }
3059 }
3060
3061 if (*nbpntu % 2 == 1) {
3062 i__2 = *iordrv + 1;
3063 for (ii = 1; ii <= i__2; ++ii) {
3064 i__3 = nvroo;
3065 for (jj = 1; jj <= i__3; ++jj) {
3066 jjp = (*nbpntv + 1) / 2 + jj;
3067 jjm = nvroo - jj + 1;
3068 bid1 = sotbv1[(nd + ii * sotbv1_dim2) * sotbv1_dim1] * (
3069 fpntab[jjp + ((ii << 1) - 1) * fpntab_dim1] +
3070 fpntab[jjm + ((ii << 1) - 1) * fpntab_dim1]) +
3071 sotbv2[(nd + ii * sotbv2_dim2) * sotbv2_dim1] * (
3072 fpntab[jjp + (ii << 1) * fpntab_dim1] + fpntab[
3073 jjm + (ii << 1) * fpntab_dim1]);
3074 sosotb[(jj + nd * sosotb_dim2) * sosotb_dim1] -= bid1;
3075 bid2 = sotbv1[(nd + ii * sotbv1_dim2) * sotbv1_dim1] * (
3076 fpntab[jjp + ((ii << 1) - 1) * fpntab_dim1] -
3077 fpntab[jjm + ((ii << 1) - 1) * fpntab_dim1]) +
3078 sotbv2[(nd + ii * sotbv2_dim2) * sotbv2_dim1] * (
3079 fpntab[jjp + (ii << 1) * fpntab_dim1] - fpntab[
3080 jjm + (ii << 1) * fpntab_dim1]);
3081 diditb[jj + nd * diditb_dim2 * diditb_dim1] -= bid2;
3082/* L650: */
3083 }
3084/* L600: */
3085 }
3086 }
3087
3088 if (*nbpntu % 2 == 1 && *nbpntv % 2 == 1) {
3089 i__2 = *iordrv + 1;
3090 for (ii = 1; ii <= i__2; ++ii) {
3091 bid1 = sotbv1[(nd + ii * sotbv1_dim2) * sotbv1_dim1] * fpntab[
3092 nvroo + 1 + ((ii << 1) - 1) * fpntab_dim1] + sotbv2[(
3093 nd + ii * sotbv2_dim2) * sotbv2_dim1] * fpntab[nvroo
3094 + 1 + (ii << 1) * fpntab_dim1];
3095 sosotb[nd * sosotb_dim2 * sosotb_dim1] -= bid1;
3096/* L700: */
3097 }
3098 }
3099
3100/* L100: */
3101 }
3102 goto L9999;
3103
3104/* ------------------------------ The End -------------------------------
3105*/
3106
3107L9999:
3108 if (ibb >= 3) {
3109 AdvApp2Var_SysBase::mgsomsg_("MMA2CD2", 7L);
3110 }
3111 return 0;
3112} /* mma2cd2_ */
3113
3114//=======================================================================
3115//function : mma2cd3_
3116//purpose :
3117//=======================================================================
3118int mma2cd3_(integer *ndimen,
3119 integer *nbpntu,
3120 doublereal *urootl,
3121 integer *nbpntv,
3122 integer *iordru,
3123 doublereal *sotbu1,
3124 doublereal *sotbu2,
3125 doublereal *ditbu1,
3126 doublereal *ditbu2,
3127 doublereal *fpntab,
3128 doublereal *uhermt,
3129 doublereal *sosotb,
3130 doublereal *soditb,
3131 doublereal *disotb,
3132 doublereal *diditb)
3133
3134{
3135 static integer c__1 = 1;
3136
3137 /* System generated locals */
3138 integer sotbu1_dim1, sotbu1_dim2, sotbu1_offset, sotbu2_dim1, sotbu2_dim2,
3139 sotbu2_offset, ditbu1_dim1, ditbu1_dim2, ditbu1_offset,
3140 ditbu2_dim1, ditbu2_dim2, ditbu2_offset, fpntab_dim1,
3141 fpntab_offset, uhermt_dim1, uhermt_offset, sosotb_dim1,
3142 sosotb_dim2, sosotb_offset, diditb_dim1, diditb_dim2,
3143 diditb_offset, soditb_dim1, soditb_dim2, soditb_offset,
3144 disotb_dim1, disotb_dim2, disotb_offset, i__1, i__2, i__3, i__4;
3145
3146 /* Local variables */
3147 static integer ncfhu, nuroo, nvroo, ii, nd, jj, kk, ibb, kkm, kkp;
3148 static doublereal bid1, bid2, bid3, bid4;
3149
3150/* **********************************************************************
3151*/
3152
3153/* FONCTION : */
3154/* ---------- */
3155/* Discretisation sur les parametres des polynomes d'interpolation */
3156/* des contraintes sur les 2 bords iso-U a l'ordre IORDRU. */
3157
3158/* MOTS CLES : */
3159/* ----------- */
3160/* TOUS, AB_SPECIFI::CONTRAINTE&, DISCRETISATION, &POINT */
3161
3162/* ARGUMENTS D'ENTREE : */
3163/* ------------------ */
3164/* NDIMEN: Dimension de l' espace. */
3165/* NBPNTU: Nbre de parametres INTERNES de discretisation EN U. */
3166/* C'est aussi le nbre de racine du polynome de Legendre ou */
3167/* on discretise. */
3168/* UROOTL: Tableau des parametres de discretisation SUR (-1,1) EN U.
3169*/
3170/* NBPNTV: Nbre de parametres INTERNES de discretisation EN V. */
3171/* C'est aussi le nbre de racine du polynome de Legendre ou */
3172/* on discretise. */
3173/* IORDRU: Ordre de derivation de l'iso-U */
3174/* = 0, on calcule l'iso-U. */
3175/* = 1, on calcule, en plus, la derivee 1ere dans le sens */
3176/* transverse a l'iso-U (donc en U). */
3177/* = 2, on calcule, en plus, la derivee 2nde dans le sens */
3178/* transverse a l'iso-U (donc en U). */
3179/* SOTBU1: Tableau des NBPNTU/2 sommes des 2 points d'indices */
3180/* NBPNTU-II+1 et II, pour II = 1, NBPNTU/2 sur l'iso-U0. */
3181/* SOTBU2: Tableau des NBPNTU/2 sommes des 2 points d'indices */
3182/* NBPNTU-II+1 et II, pour II = 1, NBPNTU/2 sur l'iso-U1. */
3183/* DITBU1: Tableau des NBPNTU/2 differences des 2 points d'indices */
3184/* NBPNTU-II+1 et II, pour II = 1, NBPNTU/2 sur l'iso-U0. */
3185/* DITBU2: Tableau des NBPNTU/2 differences des 2 points d'indices */
3186/* NBPNTU-II+1 et II, pour II = 1, NBPNTU/2 sur l'iso-U1. */
3187/* SOSOTB: Tableau deja initialise (argument d'entree/sortie). */
3188/* DISOTB: Tableau deja initialise (argument d'entree/sortie). */
3189/* SODITB: Tableau deja initialise (argument d'entree/sortie). */
3190/* DIDITB: Tableau deja initialise (argument d'entree/sortie). */
3191
3192/* ARGUMENTS DE SORTIE : */
3193/* ------------------- */
3194/* FPNTAB: Tableau auxiliaire. */
3195/* UHERMT: Table des 2*(IORDRU+1) coeff. des 2*(IORDRU+1) polynomes */
3196/* d'Hermite. */
3197/* SOSOTB: Tableau ou l'on ajoute les termes de contraintes */
3198/* C(ui,vj) + C(ui,-vj) + C(-ui,vj) + C(-ui,-vj) */
3199/* avec ui et vj racines positives du polynome de Legendre */
3200/* de degre NBPNTU et NBPNTV respectivement. */
3201/* DISOTB: Tableau ou l'on ajoute les termes de contraintes */
3202/* C(ui,vj) + C(ui,-vj) - C(-ui,vj) - C(-ui,-vj) */
3203/* avec ui et vj racines positives du polynome de Legendre */
3204/* de degre NBPNTU et NBPNTV respectivement. */
3205/* SODITB: Tableau ou l'on ajoute les termes de contraintes */
3206/* C(ui,vj) - C(ui,-vj) + C(-ui,vj) - C(-ui,-vj) */
3207/* avec ui et vj racines positives du polynome de Legendre */
3208/* de degre NBPNTU et NBPNTV respectivement. */
3209/* DIDITB: Tableau ou l'on ajoute les termes de contraintes */
3210/* C(ui,vj) - C(ui,-vj) - C(-ui,vj) + C(-ui,-vj) */
3211/* avec ui et vj racines positives du polynome de Legendre */
3212/* de degre NBPNTU et NBPNTV respectivement. */
3213
3214/* COMMONS UTILISES : */
3215/* ---------------- */
3216
3217/* REFERENCES APPELEES : */
3218/* ----------------------- */
3219
3220/* DESCRIPTION/REMARQUES/LIMITATIONS : */
3221/* ----------------------------------- */
3222
3223
3224/* $ HISTORIQUE DES MODIFICATIONS : */
3225/* -------------------------------- */
3226/* 08-08-1991: RBD; Creation. */
3227/* > */
3228/* **********************************************************************
3229*/
3230
3231/* Le nom de la routine */
3232
3233
3234 /* Parameter adjustments */
3235 --urootl;
3236 diditb_dim1 = *nbpntu / 2 + 1;
3237 diditb_dim2 = *nbpntv / 2 + 1;
3238 diditb_offset = diditb_dim1 * diditb_dim2;
3239 diditb -= diditb_offset;
3240 disotb_dim1 = *nbpntu / 2;
3241 disotb_dim2 = *nbpntv / 2;
3242 disotb_offset = disotb_dim1 * (disotb_dim2 + 1) + 1;
3243 disotb -= disotb_offset;
3244 soditb_dim1 = *nbpntu / 2;
3245 soditb_dim2 = *nbpntv / 2;
3246 soditb_offset = soditb_dim1 * (soditb_dim2 + 1) + 1;
3247 soditb -= soditb_offset;
3248 sosotb_dim1 = *nbpntu / 2 + 1;
3249 sosotb_dim2 = *nbpntv / 2 + 1;
3250 sosotb_offset = sosotb_dim1 * sosotb_dim2;
3251 sosotb -= sosotb_offset;
3252 uhermt_dim1 = (*iordru << 1) + 2;
3253 uhermt_offset = uhermt_dim1;
3254 uhermt -= uhermt_offset;
3255 fpntab_dim1 = *nbpntu;
3256 fpntab_offset = fpntab_dim1 + 1;
3257 fpntab -= fpntab_offset;
3258 ditbu2_dim1 = *nbpntv / 2 + 1;
3259 ditbu2_dim2 = *ndimen;
3260 ditbu2_offset = ditbu2_dim1 * (ditbu2_dim2 + 1);
3261 ditbu2 -= ditbu2_offset;
3262 ditbu1_dim1 = *nbpntv / 2 + 1;
3263 ditbu1_dim2 = *ndimen;
3264 ditbu1_offset = ditbu1_dim1 * (ditbu1_dim2 + 1);
3265 ditbu1 -= ditbu1_offset;
3266 sotbu2_dim1 = *nbpntv / 2 + 1;
3267 sotbu2_dim2 = *ndimen;
3268 sotbu2_offset = sotbu2_dim1 * (sotbu2_dim2 + 1);
3269 sotbu2 -= sotbu2_offset;
3270 sotbu1_dim1 = *nbpntv / 2 + 1;
3271 sotbu1_dim2 = *ndimen;
3272 sotbu1_offset = sotbu1_dim1 * (sotbu1_dim2 + 1);
3273 sotbu1 -= sotbu1_offset;
3274
3275 /* Function Body */
3276 ibb = AdvApp2Var_SysBase::mnfndeb_();
3277 if (ibb >= 3) {
3278 AdvApp2Var_SysBase::mgenmsg_("MMA2CD3", 7L);
3279 }
3280
3281/* ------------------- Discretisation des polynomes d'Hermite -----------
3282*/
3283
3284 ncfhu = (*iordru + 1) << 1;
3285 i__1 = ncfhu;
3286 for (ii = 1; ii <= i__1; ++ii) {
3287 i__2 = *nbpntu;
3288 for (kk = 1; kk <= i__2; ++kk) {
3289 AdvApp2Var_MathBase::mmmpocur_(&ncfhu,
3290 &c__1,
3291 &ncfhu,
3292 &uhermt[ii * uhermt_dim1],
3293 &urootl[kk],
3294 &fpntab[kk + ii * fpntab_dim1]);
3295/* L60: */
3296 }
3297/* L50: */
3298 }
3299
3300/* ---- On retranche les discretisations des polynomes de contrainte ----
3301*/
3302
3303 nvroo = *nbpntv / 2;
3304 nuroo = *nbpntu / 2;
3305
3306 i__1 = *ndimen;
3307 for (nd = 1; nd <= i__1; ++nd) {
3308 i__2 = *iordru + 1;
3309 for (ii = 1; ii <= i__2; ++ii) {
3310
3311 i__3 = nvroo;
3312 for (jj = 1; jj <= i__3; ++jj) {
3313 bid1 = sotbu1[jj + (nd + ii * sotbu1_dim2) * sotbu1_dim1];
3314 bid2 = sotbu2[jj + (nd + ii * sotbu2_dim2) * sotbu2_dim1];
3315 bid3 = ditbu1[jj + (nd + ii * ditbu1_dim2) * ditbu1_dim1];
3316 bid4 = ditbu2[jj + (nd + ii * ditbu2_dim2) * ditbu2_dim1];
3317 i__4 = nuroo;
3318 for (kk = 1; kk <= i__4; ++kk) {
3319 kkp = (*nbpntu + 1) / 2 + kk;
3320 kkm = nuroo - kk + 1;
3321 sosotb[kk + (jj + nd * sosotb_dim2) * sosotb_dim1] =
3322 sosotb[kk + (jj + nd * sosotb_dim2) * sosotb_dim1]
3323 - bid1 * (fpntab[kkp + ((ii << 1) - 1) *
3324 fpntab_dim1] + fpntab[kkm + ((ii << 1) - 1) *
3325 fpntab_dim1]) - bid2 * (fpntab[kkp + (ii << 1) *
3326 fpntab_dim1] + fpntab[kkm + (ii << 1) *
3327 fpntab_dim1]);
3328 disotb[kk + (jj + nd * disotb_dim2) * disotb_dim1] =
3329 disotb[kk + (jj + nd * disotb_dim2) * disotb_dim1]
3330 - bid1 * (fpntab[kkp + ((ii << 1) - 1) *
3331 fpntab_dim1] - fpntab[kkm + ((ii << 1) - 1) *
3332 fpntab_dim1]) - bid2 * (fpntab[kkp + (ii << 1) *
3333 fpntab_dim1] - fpntab[kkm + (ii << 1) *
3334 fpntab_dim1]);
3335 soditb[kk + (jj + nd * soditb_dim2) * soditb_dim1] =
3336 soditb[kk + (jj + nd * soditb_dim2) * soditb_dim1]
3337 - bid3 * (fpntab[kkp + ((ii << 1) - 1) *
3338 fpntab_dim1] + fpntab[kkm + ((ii << 1) - 1) *
3339 fpntab_dim1]) - bid4 * (fpntab[kkp + (ii << 1) *
3340 fpntab_dim1] + fpntab[kkm + (ii << 1) *
3341 fpntab_dim1]);
3342 diditb[kk + (jj + nd * diditb_dim2) * diditb_dim1] =
3343 diditb[kk + (jj + nd * diditb_dim2) * diditb_dim1]
3344 - bid3 * (fpntab[kkp + ((ii << 1) - 1) *
3345 fpntab_dim1] - fpntab[kkm + ((ii << 1) - 1) *
3346 fpntab_dim1]) - bid4 * (fpntab[kkp + (ii << 1) *
3347 fpntab_dim1] - fpntab[kkm + (ii << 1) *
3348 fpntab_dim1]);
3349/* L400: */
3350 }
3351/* L300: */
3352 }
3353/* L200: */
3354 }
3355
3356/* ------------ Cas ou l' on discretise sur les racines d' un -------
3357---- */
3358/* ---------- polynome de Legendre de degre impair, 0 est racine ----
3359---- */
3360
3361 if (*nbpntu % 2 == 1) {
3362 i__2 = *iordru + 1;
3363 for (ii = 1; ii <= i__2; ++ii) {
3364 i__3 = nvroo;
3365 for (jj = 1; jj <= i__3; ++jj) {
3366 bid1 = sotbu1[jj + (nd + ii * sotbu1_dim2) * sotbu1_dim1]
3367 * fpntab[nuroo + 1 + ((ii << 1) - 1) *
3368 fpntab_dim1] + sotbu2[jj + (nd + ii * sotbu2_dim2)
3369 * sotbu2_dim1] * fpntab[nuroo + 1 + (ii << 1) *
3370 fpntab_dim1];
3371 sosotb[(jj + nd * sosotb_dim2) * sosotb_dim1] -= bid1;
3372 bid2 = ditbu1[jj + (nd + ii * ditbu1_dim2) * ditbu1_dim1]
3373 * fpntab[nuroo + 1 + ((ii << 1) - 1) *
3374 fpntab_dim1] + ditbu2[jj + (nd + ii * ditbu2_dim2)
3375 * ditbu2_dim1] * fpntab[nuroo + 1 + (ii << 1) *
3376 fpntab_dim1];
3377 diditb[(jj + nd * diditb_dim2) * diditb_dim1] -= bid2;
3378/* L550: */
3379 }
3380/* L500: */
3381 }
3382 }
3383
3384 if (*nbpntv % 2 == 1) {
3385 i__2 = *iordru + 1;
3386 for (ii = 1; ii <= i__2; ++ii) {
3387 i__3 = nuroo;
3388 for (kk = 1; kk <= i__3; ++kk) {
3389 kkp = (*nbpntu + 1) / 2 + kk;
3390 kkm = nuroo - kk + 1;
3391 bid1 = sotbu1[(nd + ii * sotbu1_dim2) * sotbu1_dim1] * (
3392 fpntab[kkp + ((ii << 1) - 1) * fpntab_dim1] +
3393 fpntab[kkm + ((ii << 1) - 1) * fpntab_dim1]) +
3394 sotbu2[(nd + ii * sotbu2_dim2) * sotbu2_dim1] * (
3395 fpntab[kkp + (ii << 1) * fpntab_dim1] + fpntab[
3396 kkm + (ii << 1) * fpntab_dim1]);
3397 sosotb[kk + nd * sosotb_dim2 * sosotb_dim1] -= bid1;
3398 bid2 = sotbu1[(nd + ii * sotbu1_dim2) * sotbu1_dim1] * (
3399 fpntab[kkp + ((ii << 1) - 1) * fpntab_dim1] -
3400 fpntab[kkm + ((ii << 1) - 1) * fpntab_dim1]) +
3401 sotbu2[(nd + ii * sotbu2_dim2) * sotbu2_dim1] * (
3402 fpntab[kkp + (ii << 1) * fpntab_dim1] - fpntab[
3403 kkm + (ii << 1) * fpntab_dim1]);
3404 diditb[kk + nd * diditb_dim2 * diditb_dim1] -= bid2;
3405/* L650: */
3406 }
3407/* L600: */
3408 }
3409 }
3410
3411 if (*nbpntu % 2 == 1 && *nbpntv % 2 == 1) {
3412 i__2 = *iordru + 1;
3413 for (ii = 1; ii <= i__2; ++ii) {
3414 bid1 = sotbu1[(nd + ii * sotbu1_dim2) * sotbu1_dim1] * fpntab[
3415 nuroo + 1 + ((ii << 1) - 1) * fpntab_dim1] + sotbu2[(
3416 nd + ii * sotbu2_dim2) * sotbu2_dim1] * fpntab[nuroo
3417 + 1 + (ii << 1) * fpntab_dim1];
3418 sosotb[nd * sosotb_dim2 * sosotb_dim1] -= bid1;
3419/* L700: */
3420 }
3421 }
3422
3423/* L100: */
3424 }
3425 goto L9999;
3426
3427/* ------------------------------ The End -------------------------------
3428*/
3429
3430L9999:
3431 if (ibb >= 3) {
3432 AdvApp2Var_SysBase::mgsomsg_("MMA2CD3", 7L);
3433 }
3434 return 0;
3435} /* mma2cd3_ */
3436
3437//=======================================================================
3438//function : mma2cdi_
3439//purpose :
3440//=======================================================================
3441int AdvApp2Var_ApproxF2var::mma2cdi_( integer *ndimen,
3442 integer *nbpntu,
3443 doublereal *urootl,
3444 integer *nbpntv,
3445 doublereal *vrootl,
3446 integer *iordru,
3447 integer *iordrv,
3448 doublereal *contr1,
3449 doublereal *contr2,
3450 doublereal *contr3,
3451 doublereal *contr4,
3452 doublereal *sotbu1,
3453 doublereal *sotbu2,
3454 doublereal *ditbu1,
3455 doublereal *ditbu2,
3456 doublereal *sotbv1,
3457 doublereal *sotbv2,
3458 doublereal *ditbv1,
3459 doublereal *ditbv2,
3460 doublereal *sosotb,
3461 doublereal *soditb,
3462 doublereal *disotb,
3463 doublereal *diditb,
3464 integer *iercod)
3465
3466{
3467 static integer c__8 = 8;
3468
3469 /* System generated locals */
3470 integer contr1_dim1, contr1_dim2, contr1_offset, contr2_dim1, contr2_dim2,
3471 contr2_offset, contr3_dim1, contr3_dim2, contr3_offset,
3472 contr4_dim1, contr4_dim2, contr4_offset, sosotb_dim1, sosotb_dim2,
3473 sosotb_offset, diditb_dim1, diditb_dim2, diditb_offset,
3474 soditb_dim1, soditb_dim2, soditb_offset, disotb_dim1, disotb_dim2,
3475 disotb_offset;
3476
3477 /* Local variables */
3478 static integer ilong;
3479 static long int iofwr;
3480 static doublereal wrkar[1];
3481 static integer iszwr;
3482 static integer ibb, ier;
3483 static integer isz1, isz2, isz3, isz4;
3484 static long int ipt1, ipt2, ipt3, ipt4;
3485
3486
3487
3488
3489/* **********************************************************************
3490*/
3491
3492/* FONCTION : */
3493/* ---------- */
3494/* Discretisation sur les parametres des polynomes d'interpolation */
3495/* des contraintes a l'ordre IORDRE. */
3496
3497/* MOTS CLES : */
3498/* ----------- */
3499/* TOUS, AB_SPECIFI::CONTRAINTE&, DISCRETISATION, &POINT */
3500
3501/* ARGUMENTS D'ENTREE : */
3502/* ------------------ */
3503/* NDIMEN: Dimension de l' espace. */
3504/* NBPNTU: Nbre de parametres INTERNES de discretisation EN U. */
3505/* C'est aussi le nbre de racine du polynome de Legendre ou */
3506/* on discretise. */
3507/* UROOTL: Tableau des parametres de discretisation SUR (-1,1) EN U.
3508*/
3509/* NBPNTV: Nbre de parametres INTERNES de discretisation EN V. */
3510/* C'est aussi le nbre de racine du polynome de Legendre ou */
3511/* on discretise. */
3512/* VROOTL: Tableau des parametres de discretisation SUR (-1,1) EN V.
3513*/
3514/* IORDRU: Ordre de contrainte impose aux extremites de l'iso-V */
3515/* = 0, on calcule les extremites de l'iso-V */
3516/* = 1, on calcule, en plus, la derivee 1ere dans le sens */
3517/* de l'iso-V */
3518/* = 2, on calcule, en plus, la derivee 2nde dans le sens */
3519/* de l'iso-V */
3520/* IORDRV: Ordre de contrainte impose aux extremites de l'iso-U */
3521/* = 0, on calcule les extremites de l'iso-U. */
3522/* = 1, on calcule, en plus, la derivee 1ere dans le sens */
3523/* de l'iso-U */
3524/* = 2, on calcule, en plus, la derivee 2nde dans le sens */
3525/* de l'iso-U */
3526/* CONTR1: Contient, si IORDRU et IORDRV>=0, les valeurs aux */
3527/* extremitees de F(U0,V0)et de ses derivees. */
3528/* CONTR2: Contient, si IORDRU et IORDRV>=0, les valeurs aux */
3529/* extremitees de F(U1,V0)et de ses derivees. */
3530/* CONTR3: Contient, si IORDRU et IORDRV>=0, les valeurs aux */
3531/* extremitees de F(U0,V1)et de ses derivees. */
3532/* CONTR4: Contient, si IORDRU et IORDRV>=0, les valeurs aux */
3533/* extremitees de F(U1,V1)et de ses derivees. */
3534/* SOTBU1: Tableau des NBPNTU/2 sommes des 2 points d'indices */
3535/* NBPNTU-II+1 et II, pour II = 1, NBPNTU/2 sur l'iso-U0. */
3536/* SOTBU2: Tableau des NBPNTU/2 sommes des 2 points d'indices */
3537/* NBPNTU-II+1 et II, pour II = 1, NBPNTU/2 sur l'iso-U1. */
3538/* DITBU1: Tableau des NBPNTU/2 differences des 2 points d'indices */
3539/* NBPNTU-II+1 et II, pour II = 1, NBPNTU/2 sur l'iso-U0. */
3540/* DITBU2: Tableau des NBPNTU/2 differences des 2 points d'indices */
3541/* NBPNTU-II+1 et II, pour II = 1, NBPNTU/2 sur l'iso-U1. */
3542/* SOTBV1: Tableau des NBPNTV/2 sommes des 2 points d'indices */
3543/* NBPNTV-II+1 et II, pour II = 1, NBPNTV/2 sur l'iso-V0. */
3544/* SOTBV2: Tableau des NBPNTV/2 sommes des 2 points d'indices */
3545/* NBPNTV-II+1 et II, pour II = 1, NBPNTV/2 sur l'iso-V1. */
3546/* DITBV1: Tableau des NBPNTV/2 differences des 2 points d'indices */
3547/* NBPNTV-II+1 et II, pour II = 1, NBPNTV/2 sur l'iso-V0. */
3548/* DITBV2: Tableau des NBPNTV/2 differences des 2 points d'indices */
3549/* NBPNTV-II+1 et II, pour II = 1, NBPNTV/2 sur l'iso-V1. */
3550/* SOSOTB: Tableau deja initialise (argument d'entree/sortie). */
3551/* DISOTB: Tableau deja initialise (argument d'entree/sortie). */
3552/* SODITB: Tableau deja initialise (argument d'entree/sortie). */
3553/* DIDITB: Tableau deja initialise (argument d'entree/sortie). */
3554
3555/* ARGUMENTS DE SORTIE : */
3556/* ------------------- */
3557/* SOSOTB: Tableau ou l'on ajoute les termes de contraintes */
3558/* C(ui,vj) + C(ui,-vj) + C(-ui,vj) + C(-ui,-vj) */
3559/* avec ui et vj racines positives du polynome de Legendre */
3560/* de degre NBPNTU et NBPNTV respectivement. */
3561/* DISOTB: Tableau ou l'on ajoute les termes de contraintes */
3562/* C(ui,vj) + C(ui,-vj) - C(-ui,vj) - C(-ui,-vj) */
3563/* avec ui et vj racines positives du polynome de Legendre */
3564/* de degre NBPNTU et NBPNTV respectivement. */
3565/* SODITB: Tableau ou l'on ajoute les termes de contraintes */
3566/* C(ui,vj) - C(ui,-vj) + C(-ui,vj) - C(-ui,-vj) */
3567/* avec ui et vj racines positives du polynome de Legendre */
3568/* de degre NBPNTU et NBPNTV respectivement. */
3569/* DIDITB: Tableau ou l'on ajoute les termes de contraintes */
3570/* C(ui,vj) - C(ui,-vj) - C(-ui,vj) + C(-ui,-vj) */
3571/* avec ui et vj racines positives du polynome de Legendre */
3572/* de degre NBPNTU et NBPNTV respectivement. */
3573/* IERCOD: = 0, OK, */
3574/* = 1, Valeur de IORDRV ou IORDRU hors des valeurs permises. */
3575/* =13, Pb d'alloc dynamique. */
3576
3577/* COMMONS UTILISES : */
3578/* ---------------- */
3579
3580/* REFERENCES APPELEES : */
3581/* ----------------------- */
3582
3583/* DESCRIPTION/REMARQUES/LIMITATIONS : */
3584/* ----------------------------------- */
3585
3586
3587/* $ HISTORIQUE DES MODIFICATIONS : */
3588/* -------------------------------- */
3589/* 08-08-1991: RBD; Creation. */
3590/* > */
3591/* **********************************************************************
3592*/
3593
3594/* Le nom de la routine */
3595
3596
3597 /* Parameter adjustments */
3598 --urootl;
3599 diditb_dim1 = *nbpntu / 2 + 1;
3600 diditb_dim2 = *nbpntv / 2 + 1;
3601 diditb_offset = diditb_dim1 * diditb_dim2;
3602 diditb -= diditb_offset;
3603 disotb_dim1 = *nbpntu / 2;
3604 disotb_dim2 = *nbpntv / 2;
3605 disotb_offset = disotb_dim1 * (disotb_dim2 + 1) + 1;
3606 disotb -= disotb_offset;
3607 soditb_dim1 = *nbpntu / 2;
3608 soditb_dim2 = *nbpntv / 2;
3609 soditb_offset = soditb_dim1 * (soditb_dim2 + 1) + 1;
3610 soditb -= soditb_offset;
3611 sosotb_dim1 = *nbpntu / 2 + 1;
3612 sosotb_dim2 = *nbpntv / 2 + 1;
3613 sosotb_offset = sosotb_dim1 * sosotb_dim2;
3614 sosotb -= sosotb_offset;
3615 --vrootl;
3616 contr4_dim1 = *ndimen;
3617 contr4_dim2 = *iordru + 2;
3618 contr4_offset = contr4_dim1 * (contr4_dim2 + 1) + 1;
3619 contr4 -= contr4_offset;
3620 contr3_dim1 = *ndimen;
3621 contr3_dim2 = *iordru + 2;
3622 contr3_offset = contr3_dim1 * (contr3_dim2 + 1) + 1;
3623 contr3 -= contr3_offset;
3624 contr2_dim1 = *ndimen;
3625 contr2_dim2 = *iordru + 2;
3626 contr2_offset = contr2_dim1 * (contr2_dim2 + 1) + 1;
3627 contr2 -= contr2_offset;
3628 contr1_dim1 = *ndimen;
3629 contr1_dim2 = *iordru + 2;
3630 contr1_offset = contr1_dim1 * (contr1_dim2 + 1) + 1;
3631 contr1 -= contr1_offset;
3632 --sotbu1;
3633 --sotbu2;
3634 --ditbu1;
3635 --ditbu2;
3636 --sotbv1;
3637 --sotbv2;
3638 --ditbv1;
3639 --ditbv2;
3640
3641 /* Function Body */
3642 ibb = AdvApp2Var_SysBase::mnfndeb_();
3643 if (ibb >= 3) {
3644 AdvApp2Var_SysBase::mgenmsg_("MMA2CDI", 7L);
3645 }
3646 *iercod = 0;
3647 iofwr = 0;
3648 if (*iordru < -1 || *iordru > 2) {
3649 goto L9100;
3650 }
3651 if (*iordrv < -1 || *iordrv > 2) {
3652 goto L9100;
3653 }
3654
3655/* ------------------------- Mise a zero --------------------------------
3656*/
3657
3658 ilong = (*nbpntu / 2 + 1) * (*nbpntv / 2 + 1) * *ndimen;
3659 AdvApp2Var_SysBase::mvriraz_(&ilong, (char *)&sosotb[sosotb_offset]);
3660 AdvApp2Var_SysBase::mvriraz_(&ilong, (char *)&diditb[diditb_offset]);
3661 ilong = *nbpntu / 2 * (*nbpntv / 2) * *ndimen;
3662 AdvApp2Var_SysBase::mvriraz_(&ilong, (char *)&soditb[soditb_offset]);
3663 AdvApp2Var_SysBase::mvriraz_(&ilong, (char *)&disotb[disotb_offset]);
3664 if (*iordru == -1 && *iordrv == -1) {
3665 goto L9999;
3666 }
3667
3668
3669
3670 isz1 = ((*iordru + 1) << 2) * (*iordru + 1);
3671 isz2 = ((*iordrv + 1) << 2) * (*iordrv + 1);
3672 isz3 = ((*iordru + 1) << 1) * *nbpntu;
3673 isz4 = ((*iordrv + 1) << 1) * *nbpntv;
3674 iszwr = isz1 + isz2 + isz3 + isz4;
3675 AdvApp2Var_SysBase::mcrrqst_(&c__8, &iszwr, wrkar, &iofwr, &ier);
3676 if (ier > 0) {
3677 goto L9013;
3678 }
3679 ipt1 = iofwr;
3680 ipt2 = ipt1 + isz1;
3681 ipt3 = ipt2 + isz2;
3682 ipt4 = ipt3 + isz3;
3683
3684 if (*iordru >= 0 && *iordru <= 2) {
3685
3686/* --- Recup des 2*(IORDRU+1) coeff des 2*(IORDRU+1) polyn. d'Hermite
3687--- */
3688
3689 AdvApp2Var_ApproxF2var::mma1her_(iordru, &wrkar[ipt1], iercod);
3690 if (*iercod > 0) {
3691 goto L9100;
3692 }
3693
3694/* ---- On retranche les discretisations des polynomes de contrainte
3695---- */
3696
3697 mma2cd3_(ndimen, nbpntu, &urootl[1], nbpntv, iordru, &sotbu1[1], &
3698 sotbu2[1], &ditbu1[1], &ditbu2[1], &wrkar[ipt3], &wrkar[ipt1],
3699 &sosotb[sosotb_offset], &soditb[soditb_offset], &disotb[
3700 disotb_offset], &diditb[diditb_offset]);
3701 }
3702
3703 if (*iordrv >= 0 && *iordrv <= 2) {
3704
3705/* --- Recup des 2*(IORDRV+1) coeff des 2*(IORDRV+1) polyn. d'Hermite
3706--- */
3707
3708 AdvApp2Var_ApproxF2var::mma1her_(iordrv, &wrkar[ipt2], iercod);
3709 if (*iercod > 0) {
3710 goto L9100;
3711 }
3712
3713/* ---- On retranche les discretisations des polynomes de contrainte
3714---- */
3715
3716 mma2cd2_(ndimen, nbpntu, nbpntv, &vrootl[1], iordrv, &sotbv1[1], &
3717 sotbv2[1], &ditbv1[1], &ditbv2[1], &wrkar[ipt4], &wrkar[ipt2],
3718 &sosotb[sosotb_offset], &soditb[soditb_offset], &disotb[
3719 disotb_offset], &diditb[diditb_offset]);
3720 }
3721
3722/* --------------- On retranche les contraintes de coins ----------------
3723*/
3724
3725 if (*iordru >= 0 && *iordrv >= 0) {
3726 mma2cd1_(ndimen, nbpntu, &urootl[1], nbpntv, &vrootl[1], iordru,
3727 iordrv, &contr1[contr1_offset], &contr2[contr2_offset], &
3728 contr3[contr3_offset], &contr4[contr4_offset], &wrkar[ipt3], &
3729 wrkar[ipt4], &wrkar[ipt1], &wrkar[ipt2], &sosotb[
3730 sosotb_offset], &soditb[soditb_offset], &disotb[disotb_offset]
3731 , &diditb[diditb_offset]);
3732 }
3733 goto L9999;
3734
3735/* ------------------------------ The End -------------------------------
3736*/
3737/* --> IORDRE n'est pas dans la plage autorisee. */
3738L9100:
3739 *iercod = 1;
3740 goto L9999;
3741/* --> PB d'alloc dyn. */
3742L9013:
3743 *iercod = 13;
3744 goto L9999;
3745
3746L9999:
3747 if (iofwr != 0) {
3748 AdvApp2Var_SysBase::mcrdelt_(&c__8, &iszwr, wrkar, &iofwr, &ier);
3749 }
3750 if (ier > 0) {
3751 *iercod = 13;
3752 }
3753 AdvApp2Var_SysBase::maermsg_("MMA2CDI", iercod, 7L);
3754 if (ibb >= 3) {
3755 AdvApp2Var_SysBase::mgsomsg_("MMA2CDI", 7L);
3756 }
3757 return 0;
3758} /* mma2cdi_ */
3759
3760//=======================================================================
3761//function : mma2ce1_
3762//purpose :
3763//=======================================================================
3764int AdvApp2Var_ApproxF2var::mma2ce1_(integer *numdec,
3765 integer *ndimen,
3766 integer *nbsesp,
3767 integer *ndimse,
3768 integer *ndminu,
3769 integer *ndminv,
3770 integer *ndguli,
3771 integer *ndgvli,
3772 integer *ndjacu,
3773 integer *ndjacv,
3774 integer *iordru,
3775 integer *iordrv,
3776 integer *nbpntu,
3777 integer *nbpntv,
3778 doublereal *epsapr,
3779 doublereal *sosotb,
3780 doublereal *disotb,
3781 doublereal *soditb,
3782 doublereal *diditb,
3783 doublereal *patjac,
3784 doublereal *errmax,
3785 doublereal *errmoy,
3786 integer *ndegpu,
3787 integer *ndegpv,
3788 integer *itydec,
3789 integer *iercod)
3790
3791{
3792 static integer c__8 = 8;
3793
3794 /* System generated locals */
3795 integer sosotb_dim1, sosotb_dim2, sosotb_offset, disotb_dim1, disotb_dim2,
3796 disotb_offset, soditb_dim1, soditb_dim2, soditb_offset,
3797 diditb_dim1, diditb_dim2, diditb_offset, patjac_dim1, patjac_dim2,
3798 patjac_offset;
3799
3800 /* Local variables */
3801 static logical ldbg;
3802 static long int iofwr;
3803 static doublereal wrkar[1];
3804 static integer iszwr;
3805 static integer ier;
3806 static integer isz1, isz2, isz3, isz4, isz5, isz6, isz7;
3807 static long int ipt1, ipt2, ipt3, ipt4, ipt5, ipt6, ipt7;
3808
3809
3810
3811/* **********************************************************************
3812*/
3813
3814/* FONCTION : */
3815/* ---------- */
3816/* Calcul des coefficients de l' approximation polynomiale de degre */
3817/* (NDJACU,NDJACV) d'une fonction F(u,v) quelconque, a partir de sa */
3818/* discretisation sur les racines du polynome de Legendre de degre */
3819/* NBPNTU en U et NBPNTV en V. */
3820
3821/* MOTS CLES : */
3822/* ----------- */
3823/* TOUS,AB_SPECIFI::FONCTION&,APPROXIMATION,&POLYNOME,&ERREUR */
3824
3825/* ARGUMENTS D'ENTREE : */
3826/* ------------------ */
3827/* NUMDEC: Indique si on PEUT decouper encore la fonction F(u,v). */
3828/* = 5, On PEUT couper en U ou en V ou dans les 2 sens a la */
3829/* fois. */
3830/* = 4, On PEUT couper en U ou en V MAIS PAS dans les 2 sens */
3831/* a la fois (decoupe en V favorisee). */
3832/* = 3, On PEUT couper en U ou en V MAIS PAS dans les 2 sens */
3833/* a la fois (decoupe en U favorisee). */
3834/* = 2, on ne PEUT couper qu'en V (i.e. inserer un parametre */
3835/* de decoupe Vj). */
3836/* = 1, on ne PEUT couper qu'en U (i.e. inserer un parametre */
3837/* de decoupe Ui). */
3838/* = 0, on ne PEUT plus rien couper */
3839/* NDIMEN: Dimension de l'espace. */
3840/* NBSESP: Nbre de sous-espaces independant sur lesquels on calcule */
3841/* les erreurs. */
3842/* NDIMSE: Table des dimensions de chacun des sous-espaces. */
3843/* NDMINU: Degre minimum en U a conserver pour l'approximation. */
3844/* NDMINV: Degre minimum en V a conserver pour l'approximation. */
3845/* NDGULI: Limite du nbre de coefficients en U de la solution. */
3846/* NDGVLI: Limite du nbre de coefficients en V de la solution. */
3847/* NDJACU: Degre maxi du polynome d' approximation en U. La */
3848/* representation dans la base orthogonale part du degre */
3849/* 0 au degre NDJACU-2*(IORDRU+1). La base polynomiale est */
3850/* la base de Jacobi d' ordre -1 (Legendre), 0, 1 ou 2. */
3851/* On doit avoir 2*IORDRU+1 <= NDMINU <= NDGULI < NDJACU */
3852/* NDJACV: Degre maxi du polynome d' approximation en V. La */
3853/* representation dans la base orthogonale part du degre */
3854/* 0 au degre NDJACV-2*(IORDRV+1). La base polynomiale est */
3855/* la base de Jacobi d' ordre -1 (Legendre), 0, 1 ou 2 */
3856/* On doit avoir 2*IORDRV+1 <= NDMINV <= NDGVLI < NDJACV */
3857/* IORDRU: Ordre de la base de Jacobi (-1,0,1 ou 2) en U. Correspond */
3858/* a pas de contraintes, contraintes C0, C1 ou C2. */
3859/* IORDRV: Ordre de la base de Jacobi (-1,0,1 ou 2) en V. Correspond */
3860/* a pas de contraintes, contraintes C0, C1 ou C2. */
3861/* NBPNTU: Degre du polynome de Legendre sur les racines duquel */
3862/* sont calcules les coefficients d' integration suivant u */
3863/* par la methode de Gauss. On doit avoir NBPNTU = 30, 40, */
3864/* 50 ou 61 et NDJACU-2*(IORDRU+1) < NBPNTU. */
3865/* NBPNTV: Degre du polynome de Legendre sur les racines duquel */
3866/* sont calcules les coefficients d' integration suivant v */
3867/* par la methode de Gauss. On doit avoir NBPNTV = 30, 40, */
3868/* 50 ou 61 et NDJACV-2*(IORDRV+1) < NBPNTV. */
3869/* EPSAPR: Table des NBSESP tolerances imposees sur chacun des */
3870/* sous-espaces. */
3871/* SOSOTB: Tableau de F(ui,vj) + F(ui,-vj) + F(-ui,vj) + F(-ui,-vj) */
3872/* avec ui et vj racines positives du polynome de Legendre */
3873/* de degre NBPNTU et NBPNTV respectivement. De plus, */
3874/* le tableau SOSOTB(0,j) contient F(0,vj) + F(0,-vj), */
3875/* le tableau SOSOTB(i,0) contient F(ui,0) + F(-ui,0) et */
3876/* SOSOTB(0,0) contient F(0,0). */
3877/* DISOTB: Tableau de F(ui,vj) + F(ui,-vj) - F(-ui,vj) - F(-ui,-vj) */
3878/* avec ui et vj racines positives du polynome de Legendre */
3879/* de degre NBPNTU et NBPNTV respectivement. */
3880/* SODITB: Tableau de F(ui,vj) - F(ui,-vj) + F(-ui,vj) - F(-ui,-vj) */
3881/* avec ui et vj racines positives du polynome de Legendre */
3882/* de degre NBPNTU et NBPNTV respectivement. */
3883/* DIDITB: Tableau de F(ui,vj) - F(ui,-vj) - F(-ui,vj) + F(-ui,-vj) */
3884/* avec ui et vj racines positives du polynome de Legendre */
3885/* de degre NBPNTU et NBPNTV respectivement. De plus, */
3886/* le tableau DIDITB(0,j) contient F(0,vj) - F(0,-vj), */
3887/* et le tableau DIDITB(i,0) contient F(ui,0) - F(-ui,0). */
3888
3889/* ARGUMENTS DE SORTIE : */
3890/* ------------------- */
3891/* PATJAC: Table des coefficients du polynome P(u,v) d' approximation */
3892/* de F(u,v) avec eventuellement prise en compte des */
3893/* contraintes. P(u,v) est de degre (NDJACU,NDJACV). */
3894/* Ce tableau ne contient les coeff que si ITYDEC = 0. */
3895/* ERRMAX: Pour 1<=i<=NBSESP, ERRMAX(i) contient les erreurs maxi */
3896/* sur chacun des sous-espaces SI ITYDEC = 0. */
3897/* ERRMOY: Contient les erreurs moyennes pour chacun des NBSESP */
3898/* sous-espaces SI ITYDEC = 0. */
3899/* NDEGPU: Degre en U pour le carreau PATJAC. Valable si ITYDEC=0. */
3900/* NDEGPV: Degre en V pour le carreau PATJAC. Valable si ITYDEC=0. */
3901/* ITYDEC: Indique si on DOIT decouper encore la fonction F(u,v). */
3902/* = 0, on ne DOIT plus rien couper, PATJAC est OK. */
3903/* = 1, on ne DOIT couper qu'en U (i.e. inserer un parametre */
3904/* de decoupe Ui). */
3905/* = 2, on ne DOIT couper qu'en V (i.e. inserer un parametre */
3906/* de decoupe Vj). */
3907/* = 3, On DOIT couper en U ET en V a la fois. */
3908/* IERCOD: Code d'erreur. */
3909/* = 0, Eh bien tout va tres bien. */
3910/* = -1, On a une solution, la meilleure possible, mais la */
3911/* tolerance utilisateur n'est pas satisfaite (3*helas) */
3912/* = 1, Entrees incoherentes. */
3913
3914/* COMMONS UTILISES : */
3915/* ---------------- */
3916
3917/* REFERENCES APPELEES : */
3918/* ----------------------- */
3919
3920/* DESCRIPTION/REMARQUES/LIMITATIONS : */
3921/* ----------------------------------- */
3922
3923/* $ HISTORIQUE DES MODIFICATIONS : */
3924/* -------------------------------- */
3925/* 22-01-1992: RBD; Creation d'apres MA2CF1. */
3926/* > */
3927/* **********************************************************************
3928*/
3929/* Le nom de la routine */
3930
3931
3932/* --------------------------- Initialisations --------------------------
3933*/
3934
3935 /* Parameter adjustments */
3936 --errmoy;
3937 --errmax;
3938 --epsapr;
3939 --ndimse;
3940 patjac_dim1 = *ndjacu + 1;
3941 patjac_dim2 = *ndjacv + 1;
3942 patjac_offset = patjac_dim1 * patjac_dim2;
3943 patjac -= patjac_offset;
3944 diditb_dim1 = *nbpntu / 2 + 1;
3945 diditb_dim2 = *nbpntv / 2 + 1;
3946 diditb_offset = diditb_dim1 * diditb_dim2;
3947 diditb -= diditb_offset;
3948 soditb_dim1 = *nbpntu / 2;
3949 soditb_dim2 = *nbpntv / 2;
3950 soditb_offset = soditb_dim1 * (soditb_dim2 + 1) + 1;
3951 soditb -= soditb_offset;
3952 disotb_dim1 = *nbpntu / 2;
3953 disotb_dim2 = *nbpntv / 2;
3954 disotb_offset = disotb_dim1 * (disotb_dim2 + 1) + 1;
3955 disotb -= disotb_offset;
3956 sosotb_dim1 = *nbpntu / 2 + 1;
3957 sosotb_dim2 = *nbpntv / 2 + 1;
3958 sosotb_offset = sosotb_dim1 * sosotb_dim2;
3959 sosotb -= sosotb_offset;
3960
3961 /* Function Body */
3962 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 3;
3963 if (ldbg) {
3964 AdvApp2Var_SysBase::mgenmsg_("MMA2CE1", 7L);
3965 }
3966 *iercod = 0;
3967 iofwr = 0;
3968
3969 isz1 = (*nbpntu / 2 + 1) * (*ndjacu - ((*iordru + 1) << 1) + 1);
3970 isz2 = (*nbpntv / 2 + 1) * (*ndjacv - ((*iordrv + 1) << 1) + 1);
3971 isz3 = (*nbpntv / 2 + 1) * (*ndjacu - ((*iordru + 1) << 1) + 1) * *ndimen;
3972 isz4 = *nbpntv / 2 * (*ndjacu - ((*iordru + 1) << 1) + 1) * *ndimen;
3973 isz5 = *ndjacu + 1 - ((*iordru + 1) << 1);
3974 isz6 = *ndjacv + 1 - ((*iordrv + 1) << 1);
3975 isz7 = *ndimen << 2;
3976 iszwr = isz1 + isz2 + isz3 + isz4 + isz5 + isz6 + isz7;
3977 AdvApp2Var_SysBase::mcrrqst_(&c__8, &iszwr, wrkar, &iofwr, &ier);
3978 if (ier > 0) {
3979 goto L9013;
3980 }
3981 ipt1 = iofwr;
3982 ipt2 = ipt1 + isz1;
3983 ipt3 = ipt2 + isz2;
3984 ipt4 = ipt3 + isz3;
3985 ipt5 = ipt4 + isz4;
3986 ipt6 = ipt5 + isz5;
3987 ipt7 = ipt6 + isz6;
3988
3989/* ----------------- Recup des coeff. d'integr. de Gauss ----------------
3990*/
3991
3992 AdvApp2Var_ApproxF2var::mmapptt_(ndjacu, nbpntu, iordru, &wrkar[ipt1], iercod);
3993 if (*iercod > 0) {
3994 goto L9999;
3995 }
3996 AdvApp2Var_ApproxF2var::mmapptt_(ndjacv, nbpntv, iordrv, &wrkar[ipt2], iercod);
3997 if (*iercod > 0) {
3998 goto L9999;
3999 }
4000
4001/* ------------------- Recup des max des polynomes de Jacobi ------------
4002*/
4003
4004 AdvApp2Var_ApproxF2var::mma2jmx_(ndjacu, iordru, &wrkar[ipt5]);
4005 AdvApp2Var_ApproxF2var::mma2jmx_(ndjacv, iordrv, &wrkar[ipt6]);
4006
4007/* ------ Calcul des coefficients et de leur contribution a l'erreur ----
4008*/
4009
4010 mma2ce2_(numdec, ndimen, nbsesp, &ndimse[1], ndminu, ndminv, ndguli,
4011 ndgvli, ndjacu, ndjacv, iordru, iordrv, nbpntu, nbpntv, &epsapr[1]
4012 , &sosotb[sosotb_offset], &disotb[disotb_offset], &soditb[
4013 soditb_offset], &diditb[diditb_offset], &wrkar[ipt1], &wrkar[ipt2]
4014 , &wrkar[ipt5], &wrkar[ipt6], &wrkar[ipt7], &wrkar[ipt3], &wrkar[
4015 ipt4], &patjac[patjac_offset], &errmax[1], &errmoy[1], ndegpu,
4016 ndegpv, itydec, iercod);
4017 if (*iercod > 0) {
4018 goto L9999;
4019 }
4020 goto L9999;
4021
4022/* ------------------------------ The end -------------------------------
4023*/
4024
4025L9013:
4026 *iercod = 13;
4027 goto L9999;
4028
4029L9999:
4030 if (iofwr != 0) {
4031 AdvApp2Var_SysBase::mcrdelt_(&c__8, &iszwr, wrkar, &iofwr, &ier);
4032 }
4033 if (ier > 0) {
4034 *iercod = 13;
4035 }
4036 AdvApp2Var_SysBase::maermsg_("MMA2CE1", iercod, 7L);
4037 if (ldbg) {
4038 AdvApp2Var_SysBase::mgsomsg_("MMA2CE1", 7L);
4039 }
4040 return 0;
4041} /* mma2ce1_ */
4042
4043//=======================================================================
4044//function : mma2ce2_
4045//purpose :
4046//=======================================================================
4047int mma2ce2_(integer *numdec,
4048 integer *ndimen,
4049 integer *nbsesp,
4050 integer *ndimse,
4051 integer *ndminu,
4052 integer *ndminv,
4053 integer *ndguli,
4054 integer *ndgvli,
4055 integer *ndjacu,
4056 integer *ndjacv,
4057 integer *iordru,
4058 integer *iordrv,
4059 integer *nbpntu,
4060 integer *nbpntv,
4061 doublereal *epsapr,
4062 doublereal *sosotb,
4063 doublereal *disotb,
4064 doublereal *soditb,
4065 doublereal *diditb,
4066 doublereal *gssutb,
4067 doublereal *gssvtb,
4068 doublereal *xmaxju,
4069 doublereal *xmaxjv,
4070 doublereal *vecerr,
4071 doublereal *chpair,
4072 doublereal *chimpr,
4073 doublereal *patjac,
4074 doublereal *errmax,
4075 doublereal *errmoy,
4076 integer *ndegpu,
4077 integer *ndegpv,
4078 integer *itydec,
4079 integer *iercod)
4080
4081{
4082 /* System generated locals */
4083 integer sosotb_dim1, sosotb_dim2, sosotb_offset, disotb_dim1, disotb_dim2,
4084 disotb_offset, soditb_dim1, soditb_dim2, soditb_offset,
4085 diditb_dim1, diditb_dim2, diditb_offset, gssutb_dim1, gssvtb_dim1,
4086 chpair_dim1, chpair_dim2, chpair_offset, chimpr_dim1,
4087 chimpr_dim2, chimpr_offset, patjac_dim1, patjac_dim2,
4088 patjac_offset, vecerr_dim1, vecerr_offset, i__1, i__2, i__3, i__4;
4089
4090 /* Local variables */
4091 static logical ldbg;
4092 static integer idim, igsu, minu, minv, maxu, maxv, igsv;
4093 static doublereal vaux[3];
4094 static integer i2rdu, i2rdv, ndses, nd, ii, jj, kk, nu, nv;
4095 static doublereal zu, zv;
4096 static integer nu1, nv1;
4097
4098/* **********************************************************************
4099*/
4100
4101/* FONCTION : */
4102/* ---------- */
4103/* Calcul des coefficients de l' approximation polynomiale de degre */
4104/* (NDJACU,NDJACV) d'une fonction F(u,v) quelconque, a partir de sa */
4105/* discretisation sur les racines du polynome de Legendre de degre */
4106/* NBPNTU en U et NBPNTV en V. */
4107
4108/* MOTS CLES : */
4109/* ----------- */
4110/* TOUS,AB_SPECIFI::FONCTION&,APPROXIMATION,&COEFFICIENT,&POLYNOME */
4111
4112/* ARGUMENTS D'ENTREE : */
4113/* ------------------ */
4114/* NUMDEC: Indique si on PEUT decouper encore la fonction F(u,v). */
4115/* = 5, On PEUT couper en U ou en V ou dans les 2 sens a la */
4116/* fois. */
4117/* = 4, On PEUT couper en U ou en V MAIS PAS dans les 2 sens */
4118/* a la fois (decoupe en V favorisee). */
4119/* = 3, On PEUT couper en U ou en V MAIS PAS dans les 2 sens */
4120/* a la fois (decoupe en U favorisee). */
4121/* = 2, on ne PEUT couper qu'en V (i.e. inserer un parametre */
4122/* de decoupe Vj). */
4123/* = 1, on ne PEUT couper qu'en U (i.e. inserer un parametre */
4124/* de decoupe Ui). */
4125/* = 0, on ne PEUT plus rien couper */
4126/* NDIMEN: Dimension totale de l'espace */
4127/* NBSESP: Nbre de sous-espaces independant sur lesquels on calcule */
4128/* les erreurs. */
4129/* NDIMSE: Table des dimensions de chacun des sous-espaces. */
4130/* NDMINU: Degre minimum en U a conserver pour l'approximation. */
4131/* NDMINV: Degre minimum en V a conserver pour l'approximation. */
4132/* NDGULI: Limite du degre en U de la solution. */
4133/* NDGVLI: Limite du degre en V de la solution. */
4134/* NDJACU: Degre maxi du polynome d' approximation en U. La */
4135/* representation dans la base orthogonale part du degre */
4136/* 0 au degre NDJACU-2*(IORDRU+1). La base polynomiale est */
4137/* la base de Jacobi d' ordre -1 (Legendre), 0, 1 ou 2. */
4138/* On doit avoir 2*IORDRU+1 <= NDMINU <= NDGULI < NDJACU */
4139/* NDJACV: Degre maxi du polynome d' approximation en V. La */
4140/* representation dans la base orthogonale part du degre */
4141/* 0 au degre NDJACV-2*(IORDRV+1). La base polynomiale est */
4142/* la base de Jacobi d' ordre -1 (Legendre), 0, 1 ou 2 */
4143/* On doit avoir 2*IORDRV+1 <= NDMINV <= NDGVLI < NDJACV */
4144/* IORDRU: Ordre de la base de Jacobi (-1,0,1 ou 2) en U. Correspond */
4145/* a pas de contraintes, contraintes C0, C1 ou C2. */
4146/* IORDRV: Ordre de la base de Jacobi (-1,0,1 ou 2) en V. Correspond */
4147/* a pas de contraintes, contraintes C0, C1 ou C2. */
4148/* NBPNTU: Degre du polynome de Legendre sur les racines duquel */
4149/* sont calcules les coefficients d' integration suivant u */
4150/* par la methode de Gauss. On doit avoir NBPNTU = 30, 40, */
4151/* 50 ou 61 et NDJACU-2*(IORDRU+1) < NBPNTU. */
4152/* NBPNTV: Degre du polynome de Legendre sur les racines duquel */
4153/* sont calcules les coefficients d' integration suivant v */
4154/* par la methode de Gauss. On doit avoir NBPNTV = 30, 40, */
4155/* 50 ou 61 et NDJACV-2*(IORDRV+1) < NBPNTV. */
4156/* EPSAPR: Table des NBSESP tolerances imposees sur chacun des */
4157/* sous-espaces. */
4158/* SOSOTB: Tableau de F(ui,vj) + F(ui,-vj) + F(-ui,vj) + F(-ui,-vj) */
4159/* avec ui et vj racines positives du polynome de Legendre */
4160/* de degre NBPNTU et NBPNTV respectivement. De plus, */
4161/* le tableau SOSOTB(0,j) contient F(0,vj) + F(0,-vj), */
4162/* le tableau SOSOTB(i,0) contient F(ui,0) + F(-ui,0) et */
4163/* SOSOTB(0,0) contient F(0,0). */
4164/* DISOTB: Tableau de F(ui,vj) + F(ui,-vj) - F(-ui,vj) - F(-ui,-vj) */
4165/* avec ui et vj racines positives du polynome de Legendre */
4166/* de degre NBPNTU et NBPNTV respectivement. */
4167/* SODITB: Tableau de F(ui,vj) - F(ui,-vj) + F(-ui,vj) - F(-ui,-vj) */
4168/* avec ui et vj racines positives du polynome de Legendre */
4169/* de degre NBPNTU et NBPNTV respectivement. */
4170/* DIDITB: Tableau de F(ui,vj) - F(ui,-vj) - F(-ui,vj) + F(-ui,-vj) */
4171/* avec ui et vj racines positives du polynome de Legendre */
4172/* de degre NBPNTU et NBPNTV respectivement. De plus, */
4173/* le tableau DIDITB(0,j) contient F(0,vj) - F(0,-vj), */
4174/* et le tableau DIDITB(i,0) contient F(ui,0) - F(-ui,0). */
4175/* GSSUTB: Table des coefficients d' integration par la methode de */
4176/* Gauss suivant U: i varie de 0 a NBPNTU/2 et k varie de 0 a */
4177/* NDJACU-2*(IORDRU+1). */
4178/* GSSVTB: Table des coefficients d' integration par la methode de */
4179/* Gauss suivant V: i varie de 0 a NBPNTV/2 et k varie de 0 a */
4180/* NDJACV-2*(IORDRV+1). */
4181/* XMAXJU: Valeur maximale des polynomes de Jacobi d'ordre IORDRU, */
4182/* du degre 0 au degre NDJACU - 2*(IORDRU+1) */
4183/* XMAXJV: Valeur maximale des polynomes de Jacobi d'ordre IORDRV, */
4184/* du degre 0 au degre NDJACV - 2*(IORDRV+1) */
4185
4186/* ARGUMENTS DE SORTIE : */
4187/* ------------------- */
4188/* VECERR: Tableau auxiliaire. */
4189/* CHPAIR: Tableau auxiliaire de termes lies au degre NDJACU en U */
4190/* pour calculer les coeff. de l'approximation de degre PAIR */
4191/* en V. */
4192/* CHIMPR: Tableau auxiliaire de termes lies au degre NDJACU en U */
4193/* pour calculer les coeff. de l'approximation de degre IMPAIR
4194*/
4195/* en V. */
4196/* PATJAC: Table des coefficients du polynome P(u,v) d' approximation */
4197/* de F(u,v) avec eventuellement prise en compte des */
4198/* contraintes. P(u,v) est de degre (NDJACU,NDJACV). */
4199/* Ce tableau ne contient les coeff que si ITYDEC = 0. */
4200/* ERRMAX: Pour 1<=i<=NBSESP, ERRMAX(i) contient les erreurs maxi */
4201/* sur chacun des sous-espaces SI ITYDEC = 0. */
4202/* ERRMOY: Contient les erreurs moyennes pour chacun des NBSESP */
4203/* sous-espaces SI ITYDEC = 0. */
4204/* NDEGPU: Degre en U pour le carreau PATJAC. Valable si ITYDEC=0. */
4205/* NDEGPV: Degre en V pour le carreau PATJAC. Valable si ITYDEC=0. */
4206/* ITYDEC: Indique si on DOIT decouper encore la fonction F(u,v). */
4207/* = 0, on ne DOIT plus rien couper, PATJAC est OK ou alors */
4208/* NUMDEC etant egal a zero, on ne pouvait plus couper. */
4209/* = 1, on ne DOIT couper qu'en U (i.e. inserer un parametre */
4210/* de decoupe Ui). */
4211/* = 2, on ne DOIT couper qu'en V (i.e. inserer un parametre */
4212/* de decoupe Vj). */
4213/* = 3, On DOIT couper en U ET en V a la fois. */
4214/* IERCOD: Code d'erreur. */
4215/* = 0, Eh bien tout va tres bien. */
4216/* = -1, On a une solution, la meilleure possible, mais la */
4217/* tolerance utilisateur n'est pas satisfaite (3*helas) */
4218/* = 1, Entrees incoherentes. */
4219
4220/* COMMONS UTILISES : */
4221/* ---------------- */
4222
4223/* REFERENCES APPELEES : */
4224/* ----------------------- */
4225
4226/* DESCRIPTION/REMARQUES/LIMITATIONS : */
4227/* ----------------------------------- */
4228
4229/* $ HISTORIQUE DES MODIFICATIONS : */
4230/* -------------------------------- */
4231/* 07-02-1992: RBD; Gestion des cas MINU>MAXU et/ou MINV>MAXV */
4232/* 05-02-1992: RBD: Prise en compte decalages de CHPAIR et CHIMPR */
4233/* 22-01-1992: RBD; Creation d'apres MA2CF2. */
4234/* > */
4235/* **********************************************************************
4236*/
4237/* Le nom de la routine */
4238
4239
4240/* --------------------------- Initialisations --------------------------
4241*/
4242
4243 /* Parameter adjustments */
4244 vecerr_dim1 = *ndimen;
4245 vecerr_offset = vecerr_dim1 + 1;
4246 vecerr -= vecerr_offset;
4247 --errmoy;
4248 --errmax;
4249 --epsapr;
4250 --ndimse;
4251 patjac_dim1 = *ndjacu + 1;
4252 patjac_dim2 = *ndjacv + 1;
4253 patjac_offset = patjac_dim1 * patjac_dim2;
4254 patjac -= patjac_offset;
4255 gssutb_dim1 = *nbpntu / 2 + 1;
4256 chimpr_dim1 = *nbpntv / 2;
4257 chimpr_dim2 = *ndjacu - ((*iordru + 1) << 1) + 1;
4258 chimpr_offset = chimpr_dim1 * chimpr_dim2 + 1;
4259 chimpr -= chimpr_offset;
4260 chpair_dim1 = *nbpntv / 2 + 1;
4261 chpair_dim2 = *ndjacu - ((*iordru + 1) << 1) + 1;
4262 chpair_offset = chpair_dim1 * chpair_dim2;
4263 chpair -= chpair_offset;
4264 gssvtb_dim1 = *nbpntv / 2 + 1;
4265 diditb_dim1 = *nbpntu / 2 + 1;
4266 diditb_dim2 = *nbpntv / 2 + 1;
4267 diditb_offset = diditb_dim1 * diditb_dim2;
4268 diditb -= diditb_offset;
4269 soditb_dim1 = *nbpntu / 2;
4270 soditb_dim2 = *nbpntv / 2;
4271 soditb_offset = soditb_dim1 * (soditb_dim2 + 1) + 1;
4272 soditb -= soditb_offset;
4273 disotb_dim1 = *nbpntu / 2;
4274 disotb_dim2 = *nbpntv / 2;
4275 disotb_offset = disotb_dim1 * (disotb_dim2 + 1) + 1;
4276 disotb -= disotb_offset;
4277 sosotb_dim1 = *nbpntu / 2 + 1;
4278 sosotb_dim2 = *nbpntv / 2 + 1;
4279 sosotb_offset = sosotb_dim1 * sosotb_dim2;
4280 sosotb -= sosotb_offset;
4281
4282 /* Function Body */
4283 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 3;
4284 if (ldbg) {
4285 AdvApp2Var_SysBase::mgenmsg_("MMA2CE2", 7L);
4286 }
4287/* --> A priori tout va bien */
4288 *iercod = 0;
4289/* --> test des entrees */
4290 if (*numdec < 0 || *numdec > 5) {
4291 goto L9001;
4292 }
4293 if ((*iordru << 1) + 1 > *ndminu) {
4294 goto L9001;
4295 }
4296 if (*ndminu > *ndguli) {
4297 goto L9001;
4298 }
4299 if (*ndguli >= *ndjacu) {
4300 goto L9001;
4301 }
4302 if ((*iordrv << 1) + 1 > *ndminv) {
4303 goto L9001;
4304 }
4305 if (*ndminv > *ndgvli) {
4306 goto L9001;
4307 }
4308 if (*ndgvli >= *ndjacv) {
4309 goto L9001;
4310 }
4311/* --> A priori, pas de decoupes a faire. */
4312 *itydec = 0;
4313/* --> Degres mini a retourner: NDMINU,NDMINV */
4314 *ndegpu = *ndminu;
4315 *ndegpv = *ndminv;
4316/* --> Pour le moment, les erreurs max sont nulles */
4317 AdvApp2Var_SysBase::mvriraz_(nbsesp, (char *)&errmax[1]);
4318 nd = *ndimen << 2;
4319 AdvApp2Var_SysBase::mvriraz_(&nd, (char *)&vecerr[vecerr_offset]);
4320/* --> et le carreau aussi. */
4321 nd = (*ndjacu + 1) * (*ndjacv + 1) * *ndimen;
4322 AdvApp2Var_SysBase::mvriraz_(&nd, (char *)&patjac[patjac_offset]);
4323
4324 i2rdu = (*iordru + 1) << 1;
4325 i2rdv = (*iordrv + 1) << 1;
4326
4327/* **********************************************************************
4328*/
4329/* -------------------- ICI, ON PEUT ENCORE DECOUPER --------------------
4330*/
4331/* **********************************************************************
4332*/
4333
4334 if (*numdec > 0 && *numdec <= 5) {
4335
4336/* ******************************************************************
4337**** */
4338/* ---------------------- Calcul des coeff de la zone 4 -------------
4339---- */
4340
4341 minu = *ndguli + 1;
4342 maxu = *ndjacu;
4343 minv = *ndgvli + 1;
4344 maxv = *ndjacv;
4345 if (minu > maxu) {
4346 goto L9001;
4347 }
4348 if (minv > maxv) {
4349 goto L9001;
4350 }
4351
4352/* ---------------- Calcul des termes lies au degre en U ------------
4353---- */
4354
4355 i__1 = *ndimen;
4356 for (nd = 1; nd <= i__1; ++nd) {
4357 i__2 = maxu;
4358 for (kk = minu; kk <= i__2; ++kk) {
4359 igsu = kk - i2rdu;
4360 mma2cfu_(&kk, nbpntu, nbpntv, &sosotb[nd * sosotb_dim2 *
4361 sosotb_dim1], &disotb[(nd * disotb_dim2 + 1) *
4362 disotb_dim1 + 1], &soditb[(nd * soditb_dim2 + 1) *
4363 soditb_dim1 + 1], &diditb[nd * diditb_dim2 *
4364 diditb_dim1], &gssutb[igsu * gssutb_dim1], &chpair[(
4365 igsu + nd * chpair_dim2) * chpair_dim1], &chimpr[(
4366 igsu + nd * chimpr_dim2) * chimpr_dim1 + 1]);
4367/* L110: */
4368 }
4369/* L100: */
4370 }
4371
4372/* ------------------- Calcul des coefficients de PATJAC ------------
4373---- */
4374
4375 igsu = minu - i2rdu;
4376 i__1 = maxv;
4377 for (jj = minv; jj <= i__1; ++jj) {
4378 igsv = jj - i2rdv;
4379 i__2 = *ndimen;
4380 for (nd = 1; nd <= i__2; ++nd) {
4381 mma2cfv_(&jj, &minu, &maxu, nbpntv, &gssvtb[igsv *
4382 gssvtb_dim1], &chpair[(igsu + nd * chpair_dim2) *
4383 chpair_dim1], &chimpr[(igsu + nd * chimpr_dim2) *
4384 chimpr_dim1 + 1], &patjac[minu + (jj + nd *
4385 patjac_dim2) * patjac_dim1]);
4386/* L130: */
4387 }
4388
4389/* ----- Contribution des termes calcules a l'erreur d'approximati
4390on ---- */
4391/* pour les termes (I,J) avec MINU <= I <= MAXU, J fixe. */
4392
4393 idim = 1;
4394 i__2 = *nbsesp;
4395 for (nd = 1; nd <= i__2; ++nd) {
4396 ndses = ndimse[nd];
4397 mma2er1_(ndjacu, ndjacv, &ndses, &minu, &maxu, &jj, &jj,
4398 iordru, iordrv, xmaxju, xmaxjv, &patjac[idim *
4399 patjac_dim2 * patjac_dim1], &vecerr[vecerr_dim1 + 1],
4400 &vecerr[nd + (vecerr_dim1 << 2)]);
4401 if (vecerr[nd + (vecerr_dim1 << 2)] > epsapr[nd]) {
4402 goto L9300;
4403 }
4404 idim += ndses;
4405/* L140: */
4406 }
4407/* L120: */
4408 }
4409
4410/* ******************************************************************
4411**** */
4412/* ---------------------- Calcul des coeff de la zone 2 -------------
4413---- */
4414
4415 minu = (*iordru + 1) << 1;
4416 maxu = *ndguli;
4417 minv = *ndgvli + 1;
4418 maxv = *ndjacv;
4419
4420/* --> Si la zone 2 est vide, on passe a la zone 3. */
4421/* VECERR(ND,2) a deja ete mis a zero. */
4422 if (minu > maxu) {
4423 goto L300;
4424 }
4425
4426/* ---------------- Calcul des termes lies au degre en U ------------
4427---- */
4428
4429 i__1 = *ndimen;
4430 for (nd = 1; nd <= i__1; ++nd) {
4431 i__2 = maxu;
4432 for (kk = minu; kk <= i__2; ++kk) {
4433 igsu = kk - i2rdu;
4434 mma2cfu_(&kk, nbpntu, nbpntv, &sosotb[nd * sosotb_dim2 *
4435 sosotb_dim1], &disotb[(nd * disotb_dim2 + 1) *
4436 disotb_dim1 + 1], &soditb[(nd * soditb_dim2 + 1) *
4437 soditb_dim1 + 1], &diditb[nd * diditb_dim2 *
4438 diditb_dim1], &gssutb[igsu * gssutb_dim1], &chpair[(
4439 igsu + nd * chpair_dim2) * chpair_dim1], &chimpr[(
4440 igsu + nd * chimpr_dim2) * chimpr_dim1 + 1]);
4441/* L210: */
4442 }
4443/* L200: */
4444 }
4445
4446/* ------------------- Calcul des coefficients de PATJAC ------------
4447---- */
4448
4449 igsu = minu - i2rdu;
4450 i__1 = maxv;
4451 for (jj = minv; jj <= i__1; ++jj) {
4452 igsv = jj - i2rdv;
4453 i__2 = *ndimen;
4454 for (nd = 1; nd <= i__2; ++nd) {
4455 mma2cfv_(&jj, &minu, &maxu, nbpntv, &gssvtb[igsv *
4456 gssvtb_dim1], &chpair[(igsu + nd * chpair_dim2) *
4457 chpair_dim1], &chimpr[(igsu + nd * chimpr_dim2) *
4458 chimpr_dim1 + 1], &patjac[minu + (jj + nd *
4459 patjac_dim2) * patjac_dim1]);
4460/* L230: */
4461 }
4462/* L220: */
4463 }
4464
4465/* ----- Contribution des termes calcules a l'erreur d'approximation
4466---- */
4467/* pour les termes (I,J) avec MINU <= I <= MAXU, MINV <= J <= MAXV */
4468
4469 idim = 1;
4470 i__1 = *nbsesp;
4471 for (nd = 1; nd <= i__1; ++nd) {
4472 ndses = ndimse[nd];
4473 mma2er1_(ndjacu, ndjacv, &ndses, &minu, &maxu, &minv, &maxv,
4474 iordru, iordrv, xmaxju, xmaxjv, &patjac[idim *
4475 patjac_dim2 * patjac_dim1], &vecerr[vecerr_dim1 + 1], &
4476 vecerr[nd + (vecerr_dim1 << 1)]);
4477 idim += ndses;
4478/* L240: */
4479 }
4480
4481/* ******************************************************************
4482**** */
4483/* ---------------------- Calcul des coeff de la zone 3 -------------
4484---- */
4485
4486L300:
4487 minu = *ndguli + 1;
4488 maxu = *ndjacu;
4489 minv = (*iordrv + 1) << 1;
4490 maxv = *ndgvli;
4491
4492/* --> Si la zone 3 est vide, on passe au test de decoupe. */
4493/* VECERR(ND,3) a deja ete mis a zero */
4494 if (minv > maxv) {
4495 goto L400;
4496 }
4497
4498/* ----------- Les termes lies au degre en U sont deja calcules -----
4499---- */
4500/* ------------------- Calcul des coefficients de PATJAC ------------
4501---- */
4502
4503 igsu = minu - i2rdu;
4504 i__1 = maxv;
4505 for (jj = minv; jj <= i__1; ++jj) {
4506 igsv = jj - i2rdv;
4507 i__2 = *ndimen;
4508 for (nd = 1; nd <= i__2; ++nd) {
4509 mma2cfv_(&jj, &minu, &maxu, nbpntv, &gssvtb[igsv *
4510 gssvtb_dim1], &chpair[(igsu + nd * chpair_dim2) *
4511 chpair_dim1], &chimpr[(igsu + nd * chimpr_dim2) *
4512 chimpr_dim1 + 1], &patjac[minu + (jj + nd *
4513 patjac_dim2) * patjac_dim1]);
4514/* L330: */
4515 }
4516/* L320: */
4517 }
4518
4519/* ----- Contribution des termes calcules a l'erreur d'approximation
4520---- */
4521/* pour les termes (I,J) avec MINU <= I <= MAXU, MINV <= J <= MAXV. */
4522
4523 idim = 1;
4524 i__1 = *nbsesp;
4525 for (nd = 1; nd <= i__1; ++nd) {
4526 ndses = ndimse[nd];
4527 mma2er1_(ndjacu, ndjacv, &ndses, &minu, &maxu, &minv, &maxv,
4528 iordru, iordrv, xmaxju, xmaxjv, &patjac[idim *
4529 patjac_dim2 * patjac_dim1], &vecerr[vecerr_dim1 + 1], &
4530 vecerr[nd + vecerr_dim1 * 3]);
4531 idim += ndses;
4532/* L340: */
4533 }
4534
4535/* ******************************************************************
4536**** */
4537/* --------------------------- Tests de decoupe ---------------------
4538---- */
4539
4540L400:
4541 i__1 = *nbsesp;
4542 for (nd = 1; nd <= i__1; ++nd) {
4543 vaux[0] = vecerr[nd + (vecerr_dim1 << 1)];
4544 vaux[1] = vecerr[nd + (vecerr_dim1 << 2)];
4545 vaux[2] = vecerr[nd + vecerr_dim1 * 3];
4546 ii = 3;
4547 errmax[nd] = AdvApp2Var_MathBase::mzsnorm_(&ii, vaux);
4548 if (errmax[nd] > epsapr[nd]) {
4549 ii = 2;
4550 zv = AdvApp2Var_MathBase::mzsnorm_(&ii, vaux);
4551 zu = AdvApp2Var_MathBase::mzsnorm_(&ii, &vaux[1]);
4552 if (zu > epsapr[nd] && zv > epsapr[nd]) {
4553 goto L9300;
4554 }
4555 if (zu > zv) {
4556 goto L9100;
4557 } else {
4558 goto L9200;
4559 }
4560 }
4561/* L410: */
4562 }
4563
4564/* ******************************************************************
4565**** */
4566/* --- OK, le carreau est valable, on calcule les coeff de la zone 1
4567---- */
4568
4569 minu = (*iordru + 1) << 1;
4570 maxu = *ndguli;
4571 minv = (*iordrv + 1) << 1;
4572 maxv = *ndgvli;
4573
4574/* --> Si la zone 1 est vide, on passe au calcul de l'erreur Maxi et
4575*/
4576/* Moyenne. */
4577 if (minu > maxu || minv > maxv) {
4578 goto L600;
4579 }
4580
4581/* ----------- Les termes lies au degre en U sont deja calcules -----
4582---- */
4583/* ------------------- Calcul des coefficients de PATJAC ------------
4584---- */
4585
4586 igsu = minu - i2rdu;
4587 i__1 = maxv;
4588 for (jj = minv; jj <= i__1; ++jj) {
4589 igsv = jj - i2rdv;
4590 i__2 = *ndimen;
4591 for (nd = 1; nd <= i__2; ++nd) {
4592 mma2cfv_(&jj, &minu, &maxu, nbpntv, &gssvtb[igsv *
4593 gssvtb_dim1], &chpair[(igsu + nd * chpair_dim2) *
4594 chpair_dim1], &chimpr[(igsu + nd * chimpr_dim2) *
4595 chimpr_dim1 + 1], &patjac[minu + (jj + nd *
4596 patjac_dim2) * patjac_dim1]);
4597/* L530: */
4598 }
4599/* L520: */
4600 }
4601
4602/* --------------- Maintenant, on baisse le degre au maximum --------
4603---- */
4604
4605L600:
4606/* Computing MAX */
4607 i__1 = 1, i__2 = (*iordru << 1) + 1, i__1 = max(i__1,i__2);
4608 minu = max(i__1,*ndminu);
4609 maxu = *ndguli;
4610/* Computing MAX */
4611 i__1 = 1, i__2 = (*iordrv << 1) + 1, i__1 = max(i__1,i__2);
4612 minv = max(i__1,*ndminv);
4613 maxv = *ndgvli;
4614 idim = 1;
4615 i__1 = *nbsesp;
4616 for (nd = 1; nd <= i__1; ++nd) {
4617 ndses = ndimse[nd];
4618 if (maxu >= (*iordru + 1) << 1 && maxv >= (*iordrv + 1) << 1) {
4619 mma2er2_(ndjacu, ndjacv, &ndses, &minu, &maxu, &minv, &maxv,
4620 iordru, iordrv, xmaxju, xmaxjv, &patjac[idim *
4621 patjac_dim2 * patjac_dim1], &epsapr[nd], &vecerr[
4622 vecerr_dim1 + 1], &errmax[nd], &nu, &nv);
4623 } else {
4624 nu = maxu;
4625 nv = maxv;
4626 }
4627 nu1 = nu + 1;
4628 nv1 = nv + 1;
4629
4630/* --> Calcul de l'erreur moyenne. */
4631 mma2moy_(ndjacu, ndjacv, &ndses, &nu1, ndjacu, &nv1, ndjacv,
4632 iordru, iordrv, &patjac[idim * patjac_dim2 * patjac_dim1],
4633 &errmoy[nd]);
4634
4635/* --> Mise a 0.D0 des coeff ecartes. */
4636 i__2 = idim + ndses - 1;
4637 for (ii = idim; ii <= i__2; ++ii) {
4638 i__3 = *ndjacv;
4639 for (jj = nv1; jj <= i__3; ++jj) {
4640 i__4 = *ndjacu;
4641 for (kk = nu1; kk <= i__4; ++kk) {
4642 patjac[kk + (jj + ii * patjac_dim2) * patjac_dim1] =
4643 0.;
4644/* L640: */
4645 }
4646/* L630: */
4647 }
4648/* L620: */
4649 }
4650
4651/* --> Recup des nbre de coeff de l'approximation. */
4652 *ndegpu = max(*ndegpu,nu);
4653 *ndegpv = max(*ndegpv,nv);
4654 idim += ndses;
4655/* L610: */
4656 }
4657
4658/* ******************************************************************
4659**** */
4660/* -------------------- LA, ON NE PEUT PLUS DECOUPER ----------------
4661---- */
4662/* ******************************************************************
4663**** */
4664
4665 } else {
4666 minu = (*iordru + 1) << 1;
4667 maxu = *ndjacu;
4668 minv = (*iordrv + 1) << 1;
4669 maxv = *ndjacv;
4670
4671/* ---------------- Calcul des termes lies au degre en U ------------
4672---- */
4673
4674 i__1 = *ndimen;
4675 for (nd = 1; nd <= i__1; ++nd) {
4676 i__2 = maxu;
4677 for (kk = minu; kk <= i__2; ++kk) {
4678 igsu = kk - i2rdu;
4679 mma2cfu_(&kk, nbpntu, nbpntv, &sosotb[nd * sosotb_dim2 *
4680 sosotb_dim1], &disotb[(nd * disotb_dim2 + 1) *
4681 disotb_dim1 + 1], &soditb[(nd * soditb_dim2 + 1) *
4682 soditb_dim1 + 1], &diditb[nd * diditb_dim2 *
4683 diditb_dim1], &gssutb[igsu * gssutb_dim1], &chpair[(
4684 igsu + nd * chpair_dim2) * chpair_dim1], &chimpr[(
4685 igsu + nd * chimpr_dim2) * chimpr_dim1 + 1]);
4686/* L710: */
4687 }
4688
4689/* ---------------------- Calcul de tous les coefficients -------
4690-------- */
4691
4692 igsu = minu - i2rdu;
4693 i__2 = maxv;
4694 for (jj = minv; jj <= i__2; ++jj) {
4695 igsv = jj - i2rdv;
4696 mma2cfv_(&jj, &minu, &maxu, nbpntv, &gssvtb[igsv *
4697 gssvtb_dim1], &chpair[(igsu + nd * chpair_dim2) *
4698 chpair_dim1], &chimpr[(igsu + nd * chimpr_dim2) *
4699 chimpr_dim1 + 1], &patjac[minu + (jj + nd *
4700 patjac_dim2) * patjac_dim1]);
4701/* L720: */
4702 }
4703/* L700: */
4704 }
4705
4706/* ----- Contribution des termes calcules a l'erreur d'approximation
4707---- */
4708/* pour les termes (I,J) avec MINU <= I <= MAXU, MINV <= J <= MAXV */
4709
4710 idim = 1;
4711 i__1 = *nbsesp;
4712 for (nd = 1; nd <= i__1; ++nd) {
4713 ndses = ndimse[nd];
4714 minu = (*iordru + 1) << 1;
4715 maxu = *ndjacu;
4716 minv = *ndgvli + 1;
4717 maxv = *ndjacv;
4718 mma2er1_(ndjacu, ndjacv, &ndses, &minu, &maxu, &minv, &maxv,
4719 iordru, iordrv, xmaxju, xmaxjv, &patjac[idim *
4720 patjac_dim2 * patjac_dim1], &vecerr[vecerr_dim1 + 1], &
4721 errmax[nd]);
4722 minu = *ndguli + 1;
4723 maxu = *ndjacu;
4724 minv = (*iordrv + 1) << 1;
4725 maxv = *ndgvli;
4726 if (minv <= maxv) {
4727 mma2er1_(ndjacu, ndjacv, &ndses, &minu, &maxu, &minv, &maxv,
4728 iordru, iordrv, xmaxju, xmaxjv, &patjac[idim *
4729 patjac_dim2 * patjac_dim1], &vecerr[vecerr_dim1 + 1],
4730 &errmax[nd]);
4731 }
4732
4733/* ---------------------------- Si ERRMAX > EPSAPR, stop --------
4734-------- */
4735
4736 if (errmax[nd] > epsapr[nd]) {
4737 *iercod = -1;
4738 nu = *ndguli;
4739 nv = *ndgvli;
4740
4741/* ------------- Sinon, on essaie d'enlever encore des coeff
4742------------ */
4743
4744 } else {
4745/* Computing MAX */
4746 i__2 = 1, i__3 = (*iordru << 1) + 1, i__2 = max(i__2,i__3);
4747 minu = max(i__2,*ndminu);
4748 maxu = *ndguli;
4749/* Computing MAX */
4750 i__2 = 1, i__3 = (*iordrv << 1) + 1, i__2 = max(i__2,i__3);
4751 minv = max(i__2,*ndminv);
4752 maxv = *ndgvli;
4753 if (maxu >= (*iordru + 1) << 1 && maxv >= (*iordrv + 1) << 1) {
4754 mma2er2_(ndjacu, ndjacv, &ndses, &minu, &maxu, &minv, &
4755 maxv, iordru, iordrv, xmaxju, xmaxjv, &patjac[
4756 idim * patjac_dim2 * patjac_dim1], &epsapr[nd], &
4757 vecerr[vecerr_dim1 + 1], &errmax[nd], &nu, &nv);
4758 } else {
4759 nu = maxu;
4760 nv = maxv;
4761 }
4762 }
4763
4764/* --------------------- Calcul de l'erreur moyenne -------------
4765-------- */
4766
4767 nu1 = nu + 1;
4768 nv1 = nv + 1;
4769 mma2moy_(ndjacu, ndjacv, &ndses, &nu1, ndjacu, &nv1, ndjacv,
4770 iordru, iordrv, &patjac[idim * patjac_dim2 * patjac_dim1],
4771 &errmoy[nd]);
4772
4773/* --------------------- Mise a 0.D0 des coeff ecartes ----------
4774-------- */
4775
4776 i__2 = idim + ndses - 1;
4777 for (ii = idim; ii <= i__2; ++ii) {
4778 i__3 = *ndjacv;
4779 for (jj = nv1; jj <= i__3; ++jj) {
4780 i__4 = *ndjacu;
4781 for (kk = nu1; kk <= i__4; ++kk) {
4782 patjac[kk + (jj + ii * patjac_dim2) * patjac_dim1] =
4783 0.;
4784/* L760: */
4785 }
4786/* L750: */
4787 }
4788/* L740: */
4789 }
4790
4791/* --------------- Recup des nbre de coeff de l'approximation ---
4792-------- */
4793
4794 *ndegpu = max(*ndegpu,nu);
4795 *ndegpv = max(*ndegpv,nv);
4796 idim += ndses;
4797/* L730: */
4798 }
4799 }
4800
4801 goto L9999;
4802
4803/* ------------------------------ The end -------------------------------
4804*/
4805/* --> Erreur dans les entrees */
4806L9001:
4807 *iercod = 1;
4808 goto L9999;
4809
4810/* --------- Gestion des decoupes, ici doit avoir 0 < NUMDEC <= 5 -------
4811*/
4812
4813/* --> Ici on peut et on doit couper, on choisit en U si c'est possible */
4814L9100:
4815 if (*numdec <= 0 || *numdec > 5) {
4816 goto L9001;
4817 }
4818 if (*numdec != 2) {
4819 *itydec = 1;
4820 } else {
4821 *itydec = 2;
4822 }
4823 goto L9999;
4824/* --> Ici on peut et on doit couper, on choisit en V si c'est possible */
4825L9200:
4826 if (*numdec <= 0 || *numdec > 5) {
4827 goto L9001;
4828 }
4829 if (*numdec != 1) {
4830 *itydec = 2;
4831 } else {
4832 *itydec = 1;
4833 }
4834 goto L9999;
4835/* --> Ici on peut et on doit couper, on choisit en 4 si c'est possible */
4836L9300:
4837 if (*numdec <= 0 || *numdec > 5) {
4838 goto L9001;
4839 }
4840 if (*numdec == 5) {
4841 *itydec = 3;
4842 } else if (*numdec == 2 || *numdec == 4) {
4843 *itydec = 2;
4844 } else if (*numdec == 1 || *numdec == 3) {
4845 *itydec = 1;
4846 } else {
4847 goto L9001;
4848 }
4849 goto L9999;
4850
4851L9999:
4852 AdvApp2Var_SysBase::maermsg_("MMA2CE2", iercod, 7L);
4853 if (ldbg) {
4854 AdvApp2Var_SysBase::mgsomsg_("MMA2CE2", 7L);
4855 }
4856 return 0;
4857} /* mma2ce2_ */
4858
4859//=======================================================================
4860//function : mma2cfu_
4861//purpose :
4862//=======================================================================
4863int mma2cfu_(integer *ndujac,
4864 integer *nbpntu,
4865 integer *nbpntv,
4866 doublereal *sosotb,
4867 doublereal *disotb,
4868 doublereal *soditb,
4869 doublereal *diditb,
4870 doublereal *gssutb,
4871 doublereal *chpair,
4872 doublereal *chimpr)
4873
4874{
4875 /* System generated locals */
4876 integer sosotb_dim1, disotb_dim1, disotb_offset, soditb_dim1,
4877 soditb_offset, diditb_dim1, i__1, i__2;
4878
4879 /* Local variables */
4880 static logical ldbg;
4881 static integer nptu2, nptv2, ii, jj;
4882 static doublereal bid0, bid1, bid2;
4883
4884
4885/* **********************************************************************
4886*/
4887
4888/* FONCTION : */
4889/* ---------- */
4890/* Calcul des termes lies au degre NDUJAC en U de l' approximation */
4891/* polynomiale d' une fonction F(u,v) quelconque, a partir de sa */
4892/* discretisation sur les racines du polynome de Legendre de degre */
4893/* NBPNTU en U et NBPNTV en V. */
4894
4895/* MOTS CLES : */
4896/* ----------- */
4897/* FONCTION,APPROXIMATION,COEFFICIENT,POLYNOME */
4898
4899/* ARGUMENTS D'ENTREE : */
4900/* ------------------ */
4901/* NDUJAC: Degre en U fixe pour lequel on calcule les termes */
4902/* permettant d'obtenir les coeff. dans Legendre ou Jacobi */
4903/* de degre pair ou impair en V. */
4904/* NBPNTU: Degre du polynome de Legendre sur les racines duquel */
4905/* sont calcules les coefficients d' integration suivant U */
4906/* par la methode de Gauss. On doit avoir NBPNTU = 30, 40, */
4907/* 50 ou 61. */
4908/* NBPNTV: Degre du polynome de Legendre sur les racines duquel */
4909/* sont calcules les coefficients d' integration suivant v */
4910/* par la methode de Gauss. On doit avoir NBPNTV = 30, 40, */
4911/* 50 ou 61. */
4912/* SOSOTB: Tableau de F(ui,vj) + F(ui,-vj) + F(-ui,vj) + F(-ui,-vj) */
4913/* avec ui et vj racines positives du polynome de Legendre */
4914/* de degre NBPNTU et NBPNTV respectivement. De plus, */
4915/* le tableau SOSOTB(0,j) contient F(0,vj) + F(0,-vj), */
4916/* le tableau SOSOTB(i,0) contient F(ui,0) + F(-ui,0) et */
4917/* SOSOTB(0,0) contient F(0,0). */
4918/* DISOTB: Tableau de F(ui,vj) + F(ui,-vj) - F(-ui,vj) - F(-ui,-vj) */
4919/* avec ui et vj racines positives du polynome de Legendre */
4920/* de degre NBPNTU et NBPNTV respectivement. */
4921/* SODITB: Tableau de F(ui,vj) - F(ui,-vj) + F(-ui,vj) - F(-ui,-vj) */
4922/* avec ui et vj racines positives du polynome de Legendre */
4923/* de degre NBPNTU et NBPNTV respectivement. */
4924/* DIDITB: Tableau de F(ui,vj) - F(ui,-vj) - F(-ui,vj) + F(-ui,-vj) */
4925/* avec ui et vj racines positives du polynome de Legendre */
4926/* de degre NBPNTU et NBPNTV respectivement. De plus, */
4927/* le tableau DIDITB(0,j) contient F(0,vj) - F(0,-vj), */
4928/* et le tableau DIDITB(i,0) contient F(ui,0) - F(-ui,0). */
4929/* GSSUTB: Table des coefficients d' integration par la methode de */
4930/* Gauss suivant U pour NDUJAC fixe: i varie de 0 a NBPNTU/2. */
4931
4932/* ARGUMENTS DE SORTIE : */
4933/* ------------------- */
4934/* CHPAIR: Tableau de termes lies au degre NDUJAC en U pour calculer */
4935/* les coeff. de l'approximation de degre PAIR en V. */
4936/* CHIMPR: Tableau de termes lies au degre NDUJAC en U pour calculer */
4937/* les coeff. de l'approximation de degre IMPAIR en V. */
4938
4939/* COMMONS UTILISES : */
4940/* ---------------- */
4941
4942/* REFERENCES APPELEES : */
4943/* ----------------------- */
4944
4945/* DESCRIPTION/REMARQUES/LIMITATIONS : */
4946/* ----------------------------------- */
4947
4948/* $ HISTORIQUE DES MODIFICATIONS : */
4949/* -------------------------------- */
4950/* 10-06-1991 : RBD ; Creation. */
4951/* > */
4952/* **********************************************************************
4953*/
4954/* Le nom de la routine */
4955
4956
4957/* --------------------------- Initialisations --------------------------
4958*/
4959
4960 /* Parameter adjustments */
4961 --chimpr;
4962 diditb_dim1 = *nbpntu / 2 + 1;
4963 soditb_dim1 = *nbpntu / 2;
4964 soditb_offset = soditb_dim1 + 1;
4965 soditb -= soditb_offset;
4966 disotb_dim1 = *nbpntu / 2;
4967 disotb_offset = disotb_dim1 + 1;
4968 disotb -= disotb_offset;
4969 sosotb_dim1 = *nbpntu / 2 + 1;
4970
4971 /* Function Body */
4972 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 3;
4973 if (ldbg) {
4974 AdvApp2Var_SysBase::mgenmsg_("MMA2CFU", 7L);
4975 }
4976
4977 nptu2 = *nbpntu / 2;
4978 nptv2 = *nbpntv / 2;
4979
4980/* **********************************************************************
4981*/
4982/* CALCUL DES COEFFICIENTS EN U */
4983
4984/* ----------------- Calcul des coefficients de degre pair --------------
4985*/
4986
4987 if (*ndujac % 2 == 0) {
4988 i__1 = nptv2;
4989 for (jj = 1; jj <= i__1; ++jj) {
4990 bid1 = 0.;
4991 bid2 = 0.;
4992 i__2 = nptu2;
4993 for (ii = 1; ii <= i__2; ++ii) {
4994 bid0 = gssutb[ii];
4995 bid1 += sosotb[ii + jj * sosotb_dim1] * bid0;
4996 bid2 += soditb[ii + jj * soditb_dim1] * bid0;
4997/* L200: */
4998 }
4999 chpair[jj] = bid1;
5000 chimpr[jj] = bid2;
5001/* L100: */
5002 }
5003
5004/* --------------- Calcul des coefficients de degre impair ----------
5005---- */
5006
5007 } else {
5008 i__1 = nptv2;
5009 for (jj = 1; jj <= i__1; ++jj) {
5010 bid1 = 0.;
5011 bid2 = 0.;
5012 i__2 = nptu2;
5013 for (ii = 1; ii <= i__2; ++ii) {
5014 bid0 = gssutb[ii];
5015 bid1 += disotb[ii + jj * disotb_dim1] * bid0;
5016 bid2 += diditb[ii + jj * diditb_dim1] * bid0;
5017/* L250: */
5018 }
5019 chpair[jj] = bid1;
5020 chimpr[jj] = bid2;
5021/* L150: */
5022 }
5023 }
5024
5025/* ------- Ajout des termes lies a la racine supplementaire (0.D0) ------
5026*/
5027/* ----------- du polynome de Legendre de degre impair NBPNTU -----------
5028*/
5029/* --> Seul les termes NDUJAC pair sont modifies car GSSUTB(0) = 0 */
5030/* lorsque NDUJAC est impair. */
5031
5032 if (*nbpntu % 2 != 0 && *ndujac % 2 == 0) {
5033 bid0 = gssutb[0];
5034 i__1 = nptv2;
5035 for (jj = 1; jj <= i__1; ++jj) {
5036 chpair[jj] += sosotb[jj * sosotb_dim1] * bid0;
5037 chimpr[jj] += diditb[jj * diditb_dim1] * bid0;
5038/* L300: */
5039 }
5040 }
5041
5042/* ------ Calcul des termes lies a la racine supplementaire (0.D0) ------
5043*/
5044/* ----------- du polynome de Legendre de degre impair NBPNTV -----------
5045*/
5046
5047 if (*nbpntv % 2 != 0) {
5048/* --> Seul les termes CHPAIR sont calcules car GSSVTB(0,IH-IDEBV)=0
5049*/
5050/* lorsque IH est impair (voir MMA2CFV). */
5051
5052 if (*ndujac % 2 == 0) {
5053 bid1 = 0.;
5054 i__1 = nptu2;
5055 for (ii = 1; ii <= i__1; ++ii) {
5056 bid1 += sosotb[ii] * gssutb[ii];
5057/* L400: */
5058 }
5059 chpair[0] = bid1;
5060 } else {
5061 bid1 = 0.;
5062 i__1 = nptu2;
5063 for (ii = 1; ii <= i__1; ++ii) {
5064 bid1 += diditb[ii] * gssutb[ii];
5065/* L500: */
5066 }
5067 chpair[0] = bid1;
5068 }
5069 if (*nbpntu % 2 != 0) {
5070 chpair[0] += sosotb[0] * gssutb[0];
5071 }
5072 }
5073
5074/* ------------------------------ The end -------------------------------
5075*/
5076
5077 if (ldbg) {
5078 AdvApp2Var_SysBase::mgsomsg_("MMA2CFU", 7L);
5079 }
5080 return 0;
5081} /* mma2cfu_ */
5082
5083//=======================================================================
5084//function : mma2cfv_
5085//purpose :
5086//=======================================================================
5087int mma2cfv_(integer *ndvjac,
5088 integer *mindgu,
5089 integer *maxdgu,
5090 integer *nbpntv,
5091 doublereal *gssvtb,
5092 doublereal *chpair,
5093 doublereal *chimpr,
5094 doublereal *patjac)
5095
5096{
5097 /* System generated locals */
5098 integer chpair_dim1, chpair_offset, chimpr_dim1, chimpr_offset,
5099 patjac_offset, i__1, i__2;
5100
5101 /* Local variables */
5102 static logical ldbg;
5103 static integer nptv2, ii, jj;
5104 static doublereal bid1;
5105
5106
5107/* **********************************************************************
5108*/
5109
5110/* FONCTION : */
5111/* ---------- */
5112/* Calcul des coefficients de l' approximation polynomiale de F(u,v)
5113*/
5114/* de degre NDVJAC en V et de degre en U variant de MINDGU a MAXDGU.
5115*/
5116
5117/* MOTS CLES : */
5118/* ----------- */
5119/* FONCTION,APPROXIMATION,COEFFICIENT,POLYNOME */
5120
5121/* ARGUMENTS D'ENTREE : */
5122/* ------------------ */
5123/* NDVJAC: Degre du polynome d' approximation en V. */
5124/* La representation dans la base orthogonale part du degre */
5125/* 0. La base polynomiale est la base de Jacobi d' ordre -1 */
5126/* (Legendre), 0, 1 ou 2 */
5127/* MINDGU: Degre minimum en U des coeff. a calculer. */
5128/* MAXDGU: Degre maximum en U des coeff. a calculer. */
5129/* NBPNTV: Degre du polynome de Legendre sur les racines duquel */
5130/* sont calcules les coefficients d' integration suivant V */
5131/* par la methode de Gauss. On doit avoir NBPNTV = 30, 40, */
5132/* 50 ou 61 et NDVJAC < NBPNTV. */
5133/* GSSVTB: Table des coefficients d' integration par la methode de */
5134/* Gauss suivant V pour NDVJAC fixe: j varie de 0 a NBPNTV/2. */
5135/* CHPAIR: Tableau de termes lies aux degres MINDGU a MAXDGU en U pour
5136*/
5137/* calculer les coeff. de l'approximation de degre PAIR NDVJAC
5138*/
5139/* en V. */
5140/* CHIMPR: Tableau de termes lies aux degres MINDGU a MAXDGU en U pour
5141*/
5142/* calculer les coeff. de l'approximation de degre IMPAIR */
5143/* NDVJAC en V. */
5144
5145/* ARGUMENTS DE SORTIE : */
5146/* ------------------- */
5147/* PATJAC: Table des coefficients en U du polynome d' approximation */
5148/* P(u,v) de degre MINDGU a MAXDGU en U et NDVJAC en V. */
5149
5150/* COMMONS UTILISES : */
5151/* ---------------- */
5152
5153/* REFERENCES APPELEES : */
5154/* ----------------------- */
5155
5156/* DESCRIPTION/REMARQUES/LIMITATIONS : */
5157/* ----------------------------------- */
5158
5159/* $ HISTORIQUE DES MODIFICATIONS : */
5160/* -------------------------------- */
5161/* 11-06-1991 : RBD ; Creation. */
5162/* > */
5163/* **********************************************************************
5164*/
5165/* Le nom de la routine */
5166
5167
5168/* --------------------------- Initialisations --------------------------
5169*/
5170
5171 /* Parameter adjustments */
5172 patjac_offset = *mindgu;
5173 patjac -= patjac_offset;
5174 chimpr_dim1 = *nbpntv / 2;
5175 chimpr_offset = chimpr_dim1 * *mindgu + 1;
5176 chimpr -= chimpr_offset;
5177 chpair_dim1 = *nbpntv / 2 + 1;
5178 chpair_offset = chpair_dim1 * *mindgu;
5179 chpair -= chpair_offset;
5180
5181 /* Function Body */
5182 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 3;
5183 if (ldbg) {
5184 AdvApp2Var_SysBase::mgenmsg_("MMA2CFV", 7L);
5185 }
5186 nptv2 = *nbpntv / 2;
5187
5188/* --------- Calcul des coefficients pour un degre NDVJAC pair ----------
5189*/
5190
5191 if (*ndvjac % 2 == 0) {
5192 i__1 = *maxdgu;
5193 for (ii = *mindgu; ii <= i__1; ++ii) {
5194 bid1 = 0.;
5195 i__2 = nptv2;
5196 for (jj = 1; jj <= i__2; ++jj) {
5197 bid1 += chpair[jj + ii * chpair_dim1] * gssvtb[jj];
5198/* L200: */
5199 }
5200 patjac[ii] = bid1;
5201/* L100: */
5202 }
5203
5204/* -------- Calcul des coefficients pour un degre NDVJAC impair -----
5205---- */
5206
5207 } else {
5208 i__1 = *maxdgu;
5209 for (ii = *mindgu; ii <= i__1; ++ii) {
5210 bid1 = 0.;
5211 i__2 = nptv2;
5212 for (jj = 1; jj <= i__2; ++jj) {
5213 bid1 += chimpr[jj + ii * chimpr_dim1] * gssvtb[jj];
5214/* L250: */
5215 }
5216 patjac[ii] = bid1;
5217/* L150: */
5218 }
5219 }
5220
5221/* ------- Ajout des termes lies a la racine supplementaire (0.D0) ------
5222*/
5223/* ----------- du polynome de Legendre de degre impair NBPNTV -----------
5224*/
5225
5226 if (*nbpntv % 2 != 0 && *ndvjac % 2 == 0) {
5227 bid1 = gssvtb[0];
5228 i__1 = *maxdgu;
5229 for (ii = *mindgu; ii <= i__1; ++ii) {
5230 patjac[ii] += bid1 * chpair[ii * chpair_dim1];
5231/* L300: */
5232 }
5233 }
5234
5235/* ------------------------------ The end -------------------------------
5236*/
5237
5238 if (ldbg) {
5239 AdvApp2Var_SysBase::mgsomsg_("MMA2CFV", 7L);
5240 }
5241 return 0;
5242} /* mma2cfv_ */
5243
5244//=======================================================================
5245//function : mma2ds1_
5246//purpose :
5247//=======================================================================
5248int AdvApp2Var_ApproxF2var::mma2ds1_(integer *ndimen,
5249 doublereal *uintfn,
5250 doublereal *vintfn,
5251 void (*foncnp) (
5252 int *,
5253 double *,
5254 double *,
5255 int *,
5256 double *,
5257 int *,
5258 double *,
5259 int *,
5260 int *,
5261 double *,
5262 int *
5263 ),
5264 integer *nbpntu,
5265 integer *nbpntv,
5266 doublereal *urootb,
5267 doublereal *vrootb,
5268 integer *isofav,
5269 doublereal *sosotb,
5270 doublereal *disotb,
5271 doublereal *soditb,
5272 doublereal *diditb,
5273 doublereal *fpntab,
5274 doublereal *ttable,
5275 integer *iercod)
5276
5277{
5278 /* System generated locals */
5279 integer sosotb_dim1, sosotb_dim2, sosotb_offset, disotb_dim1, disotb_dim2,
5280 disotb_offset, soditb_dim1, soditb_dim2, soditb_offset,
5281 diditb_dim1, diditb_dim2, diditb_offset, fpntab_dim1,
5282 fpntab_offset, i__1;
5283
5284 /* Local variables */
5285 static logical ldbg;
5286 static integer ibid1, ibid2, iuouv, nd;
5287 static integer isz1, isz2;
5288
5289
5290
5291/* **********************************************************************
5292*/
5293
5294/* FONCTION : */
5295/* ---------- */
5296/* Discretisation d'une fonction F(u,v) sur les racines des */
5297/* polynomes de Legendre. */
5298
5299/* MOTS CLES : */
5300/* ----------- */
5301/* FONCTION&,DISCRETISATION,&POINT */
5302
5303/* ARGUMENTS D'ENTREE : */
5304/* ------------------ */
5305/* NDIMEN: Dimension de l' espace. */
5306/* UINTFN: Bornes de l' intervalle de definition en u de la fonction */
5307/* a approcher: (UINTFN(1),UINTFN(2)). */
5308/* VINTFN: Bornes de l' intervalle de definition en v de la fonction */
5309/* a approcher: (VINTFN(1),VINTFN(2)). */
5310/* FONCNP: Le NOM de la fonction non polynomiale a approcher. */
5311/* NBPNTU: Le degre du polynome de Legendre sur les racines duquel */
5312/* on discretise FONCNP en u. */
5313/* NBPNTV: Le degre du polynome de Legendre sur les racines duquel */
5314/* on discretise FONCNP en v. */
5315/* UROOTB: Tableau des racines STRICTEMENTS POSITIVES du polynome */
5316/* de Legendre de degre NBPNTU defini sur (-1,1). */
5317/* VROOTB: Tableau des racines STRICTEMENTS POSITIVES du polynome */
5318/* de Legendre de degre NBPNTV defini sur (-1,1). */
5319/* ISOFAV: Indique le type d'iso de F(u,v) a extraire pour ameliorer */
5320/* la rapidite de calcul (n'a aucune influence sur la forme */
5321/* du resultat) */
5322/* = 1, indique que l'on doit calculer les points de F(u,v) */
5323/* avec u fixe (donc avec NBPNTV valeurs differentes de v). */
5324/* = 2, indique que l'on doit calculer les points de F(u,v) */
5325/* avec v fixe (donc avec NBPNTU valeurs differentes de u). */
5326/* SOSOTB: Tableau deja initialise (argument d'entree/sortie). */
5327/* DISOTB: Tableau deja initialise (argument d'entree/sortie). */
5328/* SODITB: Tableau deja initialise (argument d'entree/sortie). */
5329/* DIDITB: Tableau deja initialise (argument d'entree/sortie). */
5330
5331/* ARGUMENTS DE SORTIE : */
5332/* ------------------- */
5333/* SOSOTB: Tableau ou l'on ajoute les termes */
5334/* F(ui,vj) + F(ui,-vj) + F(-ui,vj) + F(-ui,-vj) */
5335/* avec ui et vj racines positives du polynome de Legendre */
5336/* de degre NBPNTU et NBPNTV respectivement. */
5337/* DISOTB: Tableau ou l'on ajoute les termes */
5338/* F(ui,vj) + F(ui,-vj) - F(-ui,vj) - F(-ui,-vj) */
5339/* avec ui et vj racines positives du polynome de Legendre */
5340/* de degre NBPNTU et NBPNTV respectivement. */
5341/* SODITB: Tableau ou l'on ajoute les termes */
5342/* F(ui,vj) - F(ui,-vj) + F(-ui,vj) - F(-ui,-vj) */
5343/* avec ui et vj racines positives du polynome de Legendre */
5344/* de degre NBPNTU et NBPNTV respectivement. */
5345/* DIDITB: Tableau ou l'on ajoute les termes */
5346/* F(ui,vj) - F(ui,-vj) - F(-ui,vj) + F(-ui,-vj) */
5347/* avec ui et vj racines positives du polynome de Legendre */
5348/* de degre NBPNTU et NBPNTV respectivement. */
5349/* FPNTAB: Tableau auxiliaire. */
5350/* TTABLE: Tableau auxiliaire. */
5351/* IERCOD: Code d' erreur >100 Pb dans l' evaluation de FONCNP, */
5352/* le code d'erreur renvoye est egal au code d' erreur */
5353/* de FONCNP + 100. */
5354
5355/* COMMONS UTILISES : */
5356/* ---------------- */
5357
5358/* REFERENCES APPELEES : */
5359/* ----------------------- */
5360
5361/* DESCRIPTION/REMARQUES/LIMITATIONS : */
5362/* ----------------------------------- */
5363/* -->La fonction externe creee par l' appelant de MA2F1K, MA2FDK */
5364/* ou de MA2FXK doit etre de la forme : */
5365/* SUBROUTINE FONCNP(NDIMEN,UINTFN,VINTFN,ISOFAV,TCONST,NBPTAB */
5366/* ,TTABLE,IDERIU,IDERIV,PPNTAB,IERCOD) */
5367/* ou les arguments d' entree sont : */
5368/* - NDIMEN est un entier defini comme la somme des dimensions des */
5369/* sous-espaces (i.e. dimension totale du probleme). */
5370/* - UINTFN(2) est un tableau de 2 reels contenant l' intervalle */
5371/* en u ou est definie la fonction a approximer */
5372/* (donc ici egal a UIFONC). */
5373/* - VINTFN(2) est un tableau de 2 reels contenant l' intervalle */
5374/* en v ou est definie la fonction a approximer */
5375/* (donc ici egal a VIFONC). */
5376/* - ISOFAV, vaut 1 si l'on veut calculer des points a u constant, */
5377/* vaut 2 si l'on calcule les points a v constant. Tout */
5378/* autre valeur est une erreur. */
5379/* - TCONST, un reel, valeur du parametre fixe. Prend ses valeurs */
5380/* dans (UIFONC(1),UIFONC(2)) si ISOFAV = 1 ou dans */
5381/* dans (VIFONC(1),VIFONC(2)) si ISOFAV = 2. */
5382/* - NBPTAB, un entier. Indique le nombre de points a calculer. */
5383/* - TTABLE, un tableau de NBPTAB reels. Ce sont les valeurs du */
5384/* parametre 'libre' de discretisation (v si IISOFAV=1, */
5385/* u si IISOFAV=2). */
5386/* - IDERIU, un entier, prend ses valeurs entre 0 (positionnement) */
5387/* et IORDRE(1) (derivee partielle de la fonction en u a */
5388/* l' ordre IORDRE(1) si IORDRE(1) > 0). */
5389/* - IDERIV, un entier, prend ses valeurs entre 0 (positionnement) */
5390/* et IORDRE(2) (derivee partielle de la fonction en v a */
5391/* l' ordre IORDRE(2) si IORDRE(2) > 0). */
5392/* Si IDERIU=i et IDERIV=j, FONCNP devra calculer des */
5393/* points de la derivee: */
5394/* i+j */
5395/* d F(u,v) */
5396/* -------- */
5397/* i j */
5398/* du dv */
5399
5400/* et les arguments de sortie sont : */
5401/* - FPNTAB(NDIMEN,NBPTAB) contient, en sortie, le tableau des */
5402/* NBPTAB points calcules dans FONCNP. */
5403/* - IERCOD est, en sortie, le code d' erreur de FONCNP. Ce code */
5404/* (entier) doit etre strictement positif s' il y a eu */
5405/* un probleme. */
5406
5407/* Les arguments d' entree NE DOIVENT PAS etre modifies sous FONCNP.
5408*/
5409
5410/* -->Comme FONCNP n' est pas forcement definie dans (-1,1)*(-1,1), on */
5411/* modifie les valeurs de UROOTB et VROOTB en consequence. */
5412
5413/* -->Les resultats de la discretisation sont ranges dans 4 tableaux */
5414/* SOSOTB, DISOTB, SODITB et DIDITB pour gagner du temps par la suite */
5415/* lors du calcul des coefficients du polynome d' approximation. */
5416
5417/* Lorsque NBPNTU est impair: */
5418/* le tableau SOSOTB(0,j) contient F(0,vj) + F(0,-vj), */
5419/* le tableau DIDITB(0,j) contient F(0,vj) - F(0,-vj), */
5420/* Lorsque NBPNTV est impair: */
5421/* le tableau SOSOTB(i,0) contient F(ui,0) + F(-ui,0), */
5422/* le tableau DIDITB(i,0) contient F(ui,0) - F(-ui,0), */
5423/* Lorsque NBPNTU et NBPNTV sont impairs: */
5424/* le terme SOSOTB(0,0) contient F(0,0). */
5425
5426
5427/* $ HISTORIQUE DES MODIFICATIONS : */
5428/* -------------------------------- */
5429/* 06-06-1991: RBD; Creation. */
5430/* > */
5431/* **********************************************************************
5432*/
5433/* Le nom de la routine */
5434
5435
5436/* --------------------------- Initialisations --------------------------
5437*/
5438
5439 /* Parameter adjustments */
5440 fpntab_dim1 = *ndimen;
5441 fpntab_offset = fpntab_dim1 + 1;
5442 fpntab -= fpntab_offset;
5443 --uintfn;
5444 --vintfn;
5445 --urootb;
5446 diditb_dim1 = *nbpntu / 2 + 1;
5447 diditb_dim2 = *nbpntv / 2 + 1;
5448 diditb_offset = diditb_dim1 * diditb_dim2;
5449 diditb -= diditb_offset;
5450 soditb_dim1 = *nbpntu / 2;
5451 soditb_dim2 = *nbpntv / 2;
5452 soditb_offset = soditb_dim1 * (soditb_dim2 + 1) + 1;
5453 soditb -= soditb_offset;
5454 disotb_dim1 = *nbpntu / 2;
5455 disotb_dim2 = *nbpntv / 2;
5456 disotb_offset = disotb_dim1 * (disotb_dim2 + 1) + 1;
5457 disotb -= disotb_offset;
5458 sosotb_dim1 = *nbpntu / 2 + 1;
5459 sosotb_dim2 = *nbpntv / 2 + 1;
5460 sosotb_offset = sosotb_dim1 * sosotb_dim2;
5461 sosotb -= sosotb_offset;
5462 --vrootb;
5463 --ttable;
5464
5465 /* Function Body */
5466 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 3;
5467 if (ldbg) {
5468 AdvApp2Var_SysBase::mgenmsg_("MMA2DS1", 7L);
5469 }
5470 *iercod = 0;
5471 if (*isofav < 1 || *isofav > 2) {
5472 iuouv = 2;
5473 } else {
5474 iuouv = *isofav;
5475 }
5476
5477/* **********************************************************************
5478*/
5479/* --------- Discretisation en U sur les racines du polynome de ---------
5480*/
5481/* --------------- Legendre de degre NBPNTU, iso-V par iso-V ------------
5482*/
5483/* **********************************************************************
5484*/
5485
5486 if (iuouv == 2) {
5487 mma2ds2_(ndimen, &uintfn[1], &vintfn[1], foncnp, nbpntu, nbpntv, &
5488 urootb[1], &vrootb[1], &iuouv, &sosotb[sosotb_offset], &
5489 disotb[disotb_offset], &soditb[soditb_offset], &diditb[
5490 diditb_offset], &fpntab[fpntab_offset], &ttable[1], iercod);
5491
5492/* ******************************************************************
5493**** */
5494/* --------- Discretisation en V sur les racines du polynome de -----
5495---- */
5496/* --------------- Legendre de degre NBPNTV, iso-U par iso-U --------
5497---- */
5498/* ******************************************************************
5499**** */
5500
5501 } else {
5502/* --> Inversion des indices des tableaux */
5503 i__1 = *ndimen;
5504 for (nd = 1; nd <= i__1; ++nd) {
5505 isz1 = *nbpntu / 2 + 1;
5506 isz2 = *nbpntv / 2 + 1;
5507 AdvApp2Var_MathBase::mmfmtb1_(&isz1, &sosotb[nd * sosotb_dim2 * sosotb_dim1], &isz1, &
5508 isz2, &isz2, &sosotb[nd * sosotb_dim2 * sosotb_dim1], &
5509 ibid1, &ibid2, iercod);
5510 if (*iercod > 0) {
5511 goto L9999;
5512 }
5513 AdvApp2Var_MathBase::mmfmtb1_(&isz1, &diditb[nd * diditb_dim2 * diditb_dim1], &isz1, &
5514 isz2, &isz2, &diditb[nd * diditb_dim2 * diditb_dim1], &
5515 ibid1, &ibid2, iercod);
5516 if (*iercod > 0) {
5517 goto L9999;
5518 }
5519 isz1 = *nbpntu / 2;
5520 isz2 = *nbpntv / 2;
5521 AdvApp2Var_MathBase::mmfmtb1_(&isz1, &soditb[(nd * soditb_dim2 + 1) * soditb_dim1 + 1],
5522 &isz1, &isz2, &isz2, &soditb[(nd * soditb_dim2 + 1) *
5523 soditb_dim1 + 1], &ibid1, &ibid2, iercod);
5524 if (*iercod > 0) {
5525 goto L9999;
5526 }
5527 AdvApp2Var_MathBase::mmfmtb1_(&isz1, &disotb[(nd * disotb_dim2 + 1) * disotb_dim1 + 1],
5528 &isz1, &isz2, &isz2, &disotb[(nd * disotb_dim2 + 1) *
5529 disotb_dim1 + 1], &ibid1, &ibid2, iercod);
5530 if (*iercod > 0) {
5531 goto L9999;
5532 }
5533/* L100: */
5534 }
5535
5536 mma2ds2_(ndimen, &vintfn[1], &uintfn[1], foncnp, nbpntv, nbpntu, &
5537 vrootb[1], &urootb[1], &iuouv, &sosotb[sosotb_offset], &
5538 soditb[soditb_offset], &disotb[disotb_offset], &diditb[
5539 diditb_offset], &fpntab[fpntab_offset], &ttable[1], iercod);
5540/* --> Inversion des indices des tableaux */
5541 i__1 = *ndimen;
5542 for (nd = 1; nd <= i__1; ++nd) {
5543 isz1 = *nbpntv / 2 + 1;
5544 isz2 = *nbpntu / 2 + 1;
5545 AdvApp2Var_MathBase::mmfmtb1_(&isz1, &sosotb[nd * sosotb_dim2 * sosotb_dim1], &isz1, &
5546 isz2, &isz2, &sosotb[nd * sosotb_dim2 * sosotb_dim1], &
5547 ibid1, &ibid2, iercod);
5548 if (*iercod > 0) {
5549 goto L9999;
5550 }
5551 AdvApp2Var_MathBase::mmfmtb1_(&isz1, &diditb[nd * diditb_dim2 * diditb_dim1], &isz1, &
5552 isz2, &isz2, &diditb[nd * diditb_dim2 * diditb_dim1], &
5553 ibid1, &ibid2, iercod);
5554 if (*iercod > 0) {
5555 goto L9999;
5556 }
5557 isz1 = *nbpntv / 2;
5558 isz2 = *nbpntu / 2;
5559 AdvApp2Var_MathBase::mmfmtb1_(&isz1, &soditb[(nd * soditb_dim2 + 1) * soditb_dim1 + 1],
5560 &isz1, &isz2, &isz2, &soditb[(nd * soditb_dim2 + 1) *
5561 soditb_dim1 + 1], &ibid1, &ibid2, iercod);
5562 if (*iercod > 0) {
5563 goto L9999;
5564 }
5565 AdvApp2Var_MathBase::mmfmtb1_(&isz1, &disotb[(nd * disotb_dim2 + 1) * disotb_dim1 + 1],
5566 &isz1, &isz2, &isz2, &disotb[(nd * disotb_dim2 + 1) *
5567 disotb_dim1 + 1], &ibid1, &ibid2, iercod);
5568 if (*iercod > 0) {
5569 goto L9999;
5570 }
5571/* L200: */
5572 }
5573 }
5574
5575/* ------------------------------ The end -------------------------------
5576*/
5577
5578L9999:
5579 if (*iercod > 0) {
5580 *iercod += 100;
5581 AdvApp2Var_SysBase::maermsg_("MMA2DS1", iercod, 7L);
5582 }
5583 if (ldbg) {
5584 AdvApp2Var_SysBase::mgsomsg_("MMA2DS1", 7L);
5585 }
5586 return 0;
5587} /* mma2ds1_ */
5588
5589//=======================================================================
5590//function : mma2ds2_
5591//purpose :
5592//=======================================================================
5593int mma2ds2_(integer *ndimen,
5594 doublereal *uintfn,
5595 doublereal *vintfn,
5596 void (*foncnp) (
5597 int *,
5598 double *,
5599 double *,
5600 int *,
5601 double *,
5602 int *,
5603 double *,
5604 int *,
5605 int *,
5606 double *,
5607 int *
5608 ),
5609 integer *nbpntu,
5610 integer *nbpntv,
5611 doublereal *urootb,
5612 doublereal *vrootb,
5613 integer *iiuouv,
5614 doublereal *sosotb,
5615 doublereal *disotb,
5616 doublereal *soditb,
5617 doublereal *diditb,
5618 doublereal *fpntab,
5619 doublereal *ttable,
5620 integer *iercod)
5621
5622{
5623 static integer c__0 = 0;
5624 /* System generated locals */
5625 integer sosotb_dim1, sosotb_dim2, sosotb_offset, disotb_dim1, disotb_dim2,
5626 disotb_offset, soditb_dim1, soditb_dim2, soditb_offset,
5627 diditb_dim1, diditb_dim2, diditb_offset, fpntab_dim1,
5628 fpntab_offset, i__1, i__2, i__3;
5629
5630 /* Local variables */
5631 static integer jdec;
5632 static logical ldbg;
5633 static doublereal alinu, blinu, alinv, blinv, tcons;
5634 static doublereal dbfn1[2], dbfn2[2];
5635 static integer nuroo, nvroo, id, iu, iv;
5636 static doublereal um, up;
5637
5638
5639/* **********************************************************************
5640*/
5641
5642/* FONCTION : */
5643/* ---------- */
5644/* Discretisation d'une fonction F(u,v) sur les racines des polynomes
5645*/
5646/* de Legendre. */
5647
5648/* MOTS CLES : */
5649/* ----------- */
5650/* FONCTION&,DISCRETISATION,&POINT */
5651
5652/* ARGUMENTS D'ENTREE : */
5653/* ------------------ */
5654/* NDIMEN: Dimension de l' espace. */
5655/* UINTFN: Bornes de l' intervalle de definition en u de la fonction */
5656/* a approcher: (UINTFN(1),UINTFN(2)). */
5657/* VINTFN: Bornes de l' intervalle de definition en v de la fonction */
5658/* a approcher: (VINTFN(1),VINTFN(2)). */
5659/* FONCNP: Le NOM de la fonction non polynomiale a approcher. */
5660/* NBPNTU: Le degre du polynome de Legendre sur les racines duquel */
5661/* on discretise FONCNP en u. */
5662/* NBPNTV: Le degre du polynome de Legendre sur les racines duquel */
5663/* on discretise FONCNP en v. */
5664/* UROOTB: Tableau des racines STRICTEMENTS POSITIVES du polynome */
5665/* de Legendre de degre NBPNTU defini sur (-1,1). */
5666/* VROOTB: Tableau des racines STRICTEMENTS POSITIVES du polynome */
5667/* de Legendre de degre NBPNTV defini sur (-1,1). */
5668/* IIUOUV: Indique le type d'iso de F(u,v) a extraire pour ameliorer */
5669/* la rapidite de calcul (n'a aucune influence sur la forme */
5670/* du resultat) */
5671/* = 1, indique que l'on doit calculer les points de F(u,v) */
5672/* avec u fixe (donc avec NBPNTV valeurs differentes de v). */
5673/* = 2, indique que l'on doit calculer les points de F(u,v) */
5674/* avec v fixe (donc avec NBPNTU valeurs differentes de u). */
5675/* SOSOTB: Tableau deja initialise (argument d'entree/sortie). */
5676/* DISOTB: Tableau deja initialise (argument d'entree/sortie). */
5677/* SODITB: Tableau deja initialise (argument d'entree/sortie). */
5678/* DIDITB: Tableau deja initialise (argument d'entree/sortie). */
5679
5680/* ARGUMENTS DE SORTIE : */
5681/* ------------------- */
5682/* SOSOTB: Tableau ou l'on ajoute les termes */
5683/* F(ui,vj) + F(ui,-vj) + F(-ui,vj) + F(-ui,-vj) */
5684/* avec ui et vj racines positives du polynome de Legendre */
5685/* de degre NBPNTU et NBPNTV respectivement. */
5686/* DISOTB: Tableau ou l'on ajoute les termes */
5687/* F(ui,vj) + F(ui,-vj) - F(-ui,vj) - F(-ui,-vj) */
5688/* avec ui et vj racines positives du polynome de Legendre */
5689/* de degre NBPNTU et NBPNTV respectivement. */
5690/* SODITB: Tableau ou l'on ajoute les termes */
5691/* F(ui,vj) - F(ui,-vj) + F(-ui,vj) - F(-ui,-vj) */
5692/* avec ui et vj racines positives du polynome de Legendre */
5693/* de degre NBPNTU et NBPNTV respectivement. */
5694/* DIDITB: Tableau ou l'on ajoute les termes */
5695/* F(ui,vj) - F(ui,-vj) - F(-ui,vj) + F(-ui,-vj) */
5696/* avec ui et vj racines positives du polynome de Legendre */
5697/* de degre NBPNTU et NBPNTV respectivement. */
5698/* FPNTAB: Tableau auxiliaire. */
5699/* TTABLE: Tableau auxiliaire. */
5700/* IERCOD: Code d' erreur >100 Pb dans l' evaluation de FONCNP, */
5701/* le code d'erreur renvoye est egal au code d' erreur */
5702/* de FONCNP + 100. */
5703
5704/* COMMONS UTILISES : */
5705/* ---------------- */
5706
5707/* REFERENCES APPELEES : */
5708/* ----------------------- */
5709
5710/* DESCRIPTION/REMARQUES/LIMITATIONS : */
5711/* ----------------------------------- */
5712/* -->La fonction externe creee par l' appelant de MA2F1K, MA2FDK */
5713/* ou de MA2FXK doit etre de la forme : */
5714/* SUBROUTINE FONCNP(NDIMEN,UINTFN,VINTFN,IIIUOUV,TCONST,NBPTAB */
5715/* ,TTABLE,IDERIU,IDERIV,PPNTAB,IERCOD) */
5716/* ou les arguments d' entree sont : */
5717/* - NDIMEN est un entier defini comme la somme des dimensions des */
5718/* sous-espaces (i.e. dimension totale du probleme). */
5719/* - UINTFN(2) est un tableau de 2 reels contenant l' intervalle */
5720/* en u ou est definie la fonction a approximer */
5721/* (donc ici egal a UIFONC). */
5722/* - VINTFN(2) est un tableau de 2 reels contenant l' intervalle */
5723/* en v ou est definie la fonction a approximer */
5724/* (donc ici egal a VIFONC). */
5725/* - IIIUOUV, vaut 1 si l'on veut calculer des points a u constant,
5726*/
5727/* vaut 2 si l'on calcule les points a v constant. Tout */
5728/* autre valeur est une erreur. */
5729/* - TCONST, un reel, valeur du parametre fixe. Prend ses valeurs */
5730/* dans (UIFONC(1),UIFONC(2)) si IIUOUV = 1 ou dans */
5731/* dans (VIFONC(1),VIFONC(2)) si IIUOUV = 2. */
5732/* - NBPTAB, un entier. Indique le nombre de points a calculer. */
5733/* - TTABLE, un tableau de NBPTAB reels. Ce sont les valeurs du */
5734/* parametre 'libre' de discretisation (v si IIIUOUV=1, */
5735/* u si IIIUOUV=2). */
5736/* - IDERIU, un entier, prend ses valeurs entre 0 (positionnement) */
5737/* et IORDRE(1) (derivee partielle de la fonction en u a */
5738/* l' ordre IORDRE(1) si IORDRE(1) > 0). */
5739/* - IDERIV, un entier, prend ses valeurs entre 0 (positionnement) */
5740/* et IORDRE(2) (derivee partielle de la fonction en v a */
5741/* l' ordre IORDRE(2) si IORDRE(2) > 0). */
5742/* Si IDERIU=i et IDERIV=j, FONCNP devra calculer des */
5743/* points de la derivee: */
5744/* i+j */
5745/* d F(u,v) */
5746/* -------- */
5747/* i j */
5748/* du dv */
5749
5750/* et les arguments de sortie sont : */
5751/* - FPNTAB(NDIMEN,NBPTAB) contient, en sortie, le tableau des */
5752/* NBPTAB points calcules dans FONCNP. */
5753/* - IERCOD est, en sortie, le code d' erreur de FONCNP. Ce code */
5754/* (entier) doit etre strictement positif s' il y a eu */
5755/* un probleme. */
5756
5757/* Les arguments d' entree NE DOIVENT PAS etre modifies sous FONCNP.
5758*/
5759
5760/* -->Comme FONCNP n' est pas forcement definie dans (-1,1)*(-1,1), on */
5761/* modifie les valeurs de UROOTB et VROOTB en consequence. */
5762
5763/* -->Les resultats de la discretisation sont ranges dans 4 tableaux */
5764/* SOSOTB, DISOTB, SODITB et DIDITB pour gagner du temps par la suite */
5765/* lors du calcul des coefficients du polynome d' approximation. */
5766
5767/* Lorsque NBPNTU est impair: */
5768/* le tableau SOSOTB(0,j) contient F(0,vj) + F(0,-vj), */
5769/* le tableau DIDITB(0,j) contient F(0,vj) - F(0,-vj), */
5770/* Lorsque NBPNTV est impair: */
5771/* le tableau SOSOTB(i,0) contient F(ui,0) + F(-ui,0), */
5772/* le tableau DIDITB(i,0) contient F(ui,0) - F(-ui,0), */
5773/* Lorsque NBPNTU et NBPNTV sont impairs: */
5774/* le terme SOSOTB(0,0) contient F(0,0). */
5775
5776/* ATTENTION: On remplit toujours ces 4 tableaux en faisant varier */
5777/* le 1er indice d'abord. C'est a dire que les discretisations */
5778/* de F(...,t) (pour IIUOUV = 2) ou de F(t,...) (IIUOUV = 1) */
5779/* sont stockees dans SOSOTB(...,t), SODITB(...,t), etc... */
5780/* (ceci permet un gain de temps non negligeable). */
5781/* Il faut donc que l'appelant, dans le cas ou IIUOUV=1, */
5782/* intervertisse les roles de u et v, de SODITB et DISOTB AVANT le */
5783/* calcul puis, APRES le calcul prenne la transposee des 4 tableau. */
5784
5785/* $ HISTORIQUE DES MODIFICATIONS : */
5786/* -------------------------------- */
5787/* 26-09-1996: JCT; TCONS toujours defini sur VINTFN, d'ou init. */
5788/* de DBFN1, DBFN2 en fonction de IIUOUV. */
5789/* 06-06-1991: RBD; Finalisation du developpement. */
5790/* 31-07-1989: RBD; Creation. */
5791/* > */
5792/* **********************************************************************
5793*/
5794
5795/* Le nom de la routine */
5796
5797/* --> Indices de boucles. */
5798
5799/* --------------------------- Initialisations --------------------------
5800*/
5801
5802 /* Parameter adjustments */
5803 --uintfn;
5804 --vintfn;
5805 --ttable;
5806 fpntab_dim1 = *ndimen;
5807 fpntab_offset = fpntab_dim1 + 1;
5808 fpntab -= fpntab_offset;
5809 --urootb;
5810 diditb_dim1 = *nbpntu / 2 + 1;
5811 diditb_dim2 = *nbpntv / 2 + 1;
5812 diditb_offset = diditb_dim1 * diditb_dim2;
5813 diditb -= diditb_offset;
5814 soditb_dim1 = *nbpntu / 2;
5815 soditb_dim2 = *nbpntv / 2;
5816 soditb_offset = soditb_dim1 * (soditb_dim2 + 1) + 1;
5817 soditb -= soditb_offset;
5818 disotb_dim1 = *nbpntu / 2;
5819 disotb_dim2 = *nbpntv / 2;
5820 disotb_offset = disotb_dim1 * (disotb_dim2 + 1) + 1;
5821 disotb -= disotb_offset;
5822 sosotb_dim1 = *nbpntu / 2 + 1;
5823 sosotb_dim2 = *nbpntv / 2 + 1;
5824 sosotb_offset = sosotb_dim1 * sosotb_dim2;
5825 sosotb -= sosotb_offset;
5826 --vrootb;
5827
5828 /* Function Body */
5829 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 3;
5830 if (ldbg) {
5831 AdvApp2Var_SysBase::mgenmsg_("MMA2DS2", 7L);
5832 }
5833 *iercod = 0;
5834
5835 alinu = (uintfn[2] - uintfn[1]) / 2.;
5836 blinu = (uintfn[2] + uintfn[1]) / 2.;
5837 alinv = (vintfn[2] - vintfn[1]) / 2.;
5838 blinv = (vintfn[2] + vintfn[1]) / 2.;
5839
5840 if (*iiuouv == 1) {
5841 dbfn1[0] = vintfn[1];
5842 dbfn1[1] = vintfn[2];
5843 dbfn2[0] = uintfn[1];
5844 dbfn2[1] = uintfn[2];
5845 } else {
5846 dbfn1[0] = uintfn[1];
5847 dbfn1[1] = uintfn[2];
5848 dbfn2[0] = vintfn[1];
5849 dbfn2[1] = vintfn[2];
5850 }
5851
5852/* **********************************************************************
5853*/
5854/* -------- Discretisation en U sur les racines du polynome de ----------
5855*/
5856/* ---------------- Legendre de degre NBPNTU, a Vj fixe ----------------
5857*/
5858/* **********************************************************************
5859*/
5860
5861 nuroo = *nbpntu / 2;
5862 nvroo = *nbpntv / 2;
5863 jdec = (*nbpntu + 1) / 2;
5864
5865/* ----------- Chargement des parametres de discretisation en U ---------
5866*/
5867
5868 i__1 = *nbpntu;
5869 for (iu = 1; iu <= i__1; ++iu) {
5870 ttable[iu] = blinu + alinu * urootb[iu];
5871/* L100: */
5872 }
5873
5874/* -------------- Pour Vj fixe, racine de Legendre negative -------------
5875*/
5876
5877 i__1 = nvroo;
5878 for (iv = 1; iv <= i__1; ++iv) {
5879 tcons = blinv + alinv * vrootb[iv];
5880 (*foncnp)(ndimen, dbfn1, dbfn2, iiuouv, &tcons, nbpntu, &
5881 ttable[1], &c__0, &c__0, &fpntab[fpntab_offset], iercod);
5882 if (*iercod > 0) {
5883 goto L9999;
5884 }
5885 i__2 = *ndimen;
5886 for (id = 1; id <= i__2; ++id) {
5887 i__3 = nuroo;
5888 for (iu = 1; iu <= i__3; ++iu) {
5889 up = fpntab[id + (iu + jdec) * fpntab_dim1];
5890 um = fpntab[id + (nuroo - iu + 1) * fpntab_dim1];
5891 sosotb[iu + (nvroo - iv + 1 + id * sosotb_dim2) * sosotb_dim1]
5892 = sosotb[iu + (nvroo - iv + 1 + id * sosotb_dim2) *
5893 sosotb_dim1] + up + um;
5894 disotb[iu + (nvroo - iv + 1 + id * disotb_dim2) * disotb_dim1]
5895 = disotb[iu + (nvroo - iv + 1 + id * disotb_dim2) *
5896 disotb_dim1] + up - um;
5897 soditb[iu + (nvroo - iv + 1 + id * soditb_dim2) * soditb_dim1]
5898 = soditb[iu + (nvroo - iv + 1 + id * soditb_dim2) *
5899 soditb_dim1] - up - um;
5900 diditb[iu + (nvroo - iv + 1 + id * diditb_dim2) * diditb_dim1]
5901 = diditb[iu + (nvroo - iv + 1 + id * diditb_dim2) *
5902 diditb_dim1] - up + um;
5903/* L220: */
5904 }
5905 if (*nbpntu % 2 != 0) {
5906 up = fpntab[id + jdec * fpntab_dim1];
5907 sosotb[(nvroo - iv + 1 + id * sosotb_dim2) * sosotb_dim1] +=
5908 up;
5909 diditb[(nvroo - iv + 1 + id * diditb_dim2) * diditb_dim1] -=
5910 up;
5911 }
5912/* L210: */
5913 }
5914/* L200: */
5915 }
5916
5917/* --------- Pour Vj = 0 (NBPNTV impair), discretisation en U -----------
5918*/
5919
5920 if (*nbpntv % 2 != 0) {
5921 tcons = blinv;
5922 (*foncnp)(ndimen, dbfn1, dbfn2, iiuouv, &tcons, nbpntu, &
5923 ttable[1], &c__0, &c__0, &fpntab[fpntab_offset], iercod);
5924 if (*iercod > 0) {
5925 goto L9999;
5926 }
5927 i__1 = *ndimen;
5928 for (id = 1; id <= i__1; ++id) {
5929 i__2 = nuroo;
5930 for (iu = 1; iu <= i__2; ++iu) {
5931 up = fpntab[id + (jdec + iu) * fpntab_dim1];
5932 um = fpntab[id + (nuroo - iu + 1) * fpntab_dim1];
5933 sosotb[iu + id * sosotb_dim2 * sosotb_dim1] = sosotb[iu + id *
5934 sosotb_dim2 * sosotb_dim1] + up + um;
5935 diditb[iu + id * diditb_dim2 * diditb_dim1] = diditb[iu + id *
5936 diditb_dim2 * diditb_dim1] + up - um;
5937/* L310: */
5938 }
5939 if (*nbpntu % 2 != 0) {
5940 up = fpntab[id + jdec * fpntab_dim1];
5941 sosotb[id * sosotb_dim2 * sosotb_dim1] += up;
5942 }
5943/* L300: */
5944 }
5945 }
5946
5947/* -------------- Pour Vj fixe, racine de Legendre positive -------------
5948*/
5949
5950 i__1 = nvroo;
5951 for (iv = 1; iv <= i__1; ++iv) {
5952 tcons = alinv * vrootb[(*nbpntv + 1) / 2 + iv] + blinv;
5953 (*foncnp)(ndimen, dbfn1, dbfn2, iiuouv, &tcons, nbpntu, &
5954 ttable[1], &c__0, &c__0, &fpntab[fpntab_offset], iercod);
5955 if (*iercod > 0) {
5956 goto L9999;
5957 }
5958 i__2 = *ndimen;
5959 for (id = 1; id <= i__2; ++id) {
5960 i__3 = nuroo;
5961 for (iu = 1; iu <= i__3; ++iu) {
5962 up = fpntab[id + (iu + jdec) * fpntab_dim1];
5963 um = fpntab[id + (nuroo - iu + 1) * fpntab_dim1];
5964 sosotb[iu + (iv + id * sosotb_dim2) * sosotb_dim1] = sosotb[
5965 iu + (iv + id * sosotb_dim2) * sosotb_dim1] + up + um;
5966 disotb[iu + (iv + id * disotb_dim2) * disotb_dim1] = disotb[
5967 iu + (iv + id * disotb_dim2) * disotb_dim1] + up - um;
5968 soditb[iu + (iv + id * soditb_dim2) * soditb_dim1] = soditb[
5969 iu + (iv + id * soditb_dim2) * soditb_dim1] + up + um;
5970 diditb[iu + (iv + id * diditb_dim2) * diditb_dim1] = diditb[
5971 iu + (iv + id * diditb_dim2) * diditb_dim1] + up - um;
5972/* L420: */
5973 }
5974 if (*nbpntu % 2 != 0) {
5975 up = fpntab[id + jdec * fpntab_dim1];
5976 sosotb[(iv + id * sosotb_dim2) * sosotb_dim1] += up;
5977 diditb[(iv + id * diditb_dim2) * diditb_dim1] += up;
5978 }
5979/* L410: */
5980 }
5981/* L400: */
5982 }
5983
5984/* ------------------------------ The end -------------------------------
5985*/
5986
5987L9999:
5988 if (*iercod > 0) {
5989 *iercod += 100;
5990 AdvApp2Var_SysBase::maermsg_("MMA2DS2", iercod, 7L);
5991 }
5992 if (ldbg) {
5993 AdvApp2Var_SysBase::mgsomsg_("MMA2DS2", 7L);
5994 }
5995 return 0;
5996} /* mma2ds2_ */
5997
5998//=======================================================================
5999//function : mma2er1_
6000//purpose :
6001//=======================================================================
6002int mma2er1_(integer *ndjacu,
6003 integer *ndjacv,
6004 integer *ndimen,
6005 integer *mindgu,
6006 integer *maxdgu,
6007 integer *mindgv,
6008 integer *maxdgv,
6009 integer *iordru,
6010 integer *iordrv,
6011 doublereal *xmaxju,
6012 doublereal *xmaxjv,
6013 doublereal *patjac,
6014 doublereal *vecerr,
6015 doublereal *erreur)
6016
6017{
6018 /* System generated locals */
6019 integer patjac_dim1, patjac_dim2, patjac_offset, i__1, i__2, i__3;
6020 doublereal d__1;
6021
6022 /* Local variables */
6023 static logical ldbg;
6024 static integer minu, minv;
6025 static doublereal vaux[2];
6026 static integer ii, nd, jj;
6027 static doublereal bid0, bid1;
6028
6029
6030/* **********************************************************************
6031*/
6032
6033/* FONCTION : */
6034/* ---------- */
6035/* Calcule l' erreur d' approximation maxi faite lorsque l'on */
6036/* enleve les coefficients de PATJAC t.q. le degre en U varie entre */
6037/* MINDGU et MAXDGU et le degre en V varie entre MINDGV et MAXDGV. */
6038
6039/* MOTS CLES : */
6040/* ----------- */
6041/* TOUS,AB_SPECIFI:: CARREAU&,CALCUL,&ERREUR */
6042
6043/* ARGUMENTS D'ENTREE : */
6044/* ------------------ */
6045/* NDJACU: Dimension en U du tableau PATJAC. */
6046/* NDJACV: Dimension en V du tableau PATJAC. */
6047/* NDIMEN: Dimension de l'espace. */
6048/* MINDGU: Borne inf de l'indice en U des coeff. de PATJAC a prendre
6049*/
6050/* en compte. */
6051/* MAXDGU: Borne sup de l'indice en U des coeff. de PATJAC a prendre
6052*/
6053/* en compte. */
6054/* MINDGV: Borne inf de l'indice en V des coeff. de PATJAC a prendre
6055*/
6056/* en compte. */
6057/* MAXDGV: Borne sup de l'indice en V des coeff. de PATJAC a prendre
6058*/
6059/* en compte. */
6060/* IORDRU: Ordre de continuite en U assure par le carreau PATJAC */
6061/* (de -1 a 2) */
6062/* IORDRV: Ordre de continuite en V assure par le carreau PATJAC */
6063/* (de -1 a 2) */
6064/* XMAXJU: Valeur maximale des polynomes de Jacobi d'ordre IORDRU, */
6065/* du degre 0 a MAXDGU - 2*(IORDU+1) */
6066/* XMAXJV: Valeur maximale des polynomes de Jacobi d'ordre IORDRV, */
6067/* du degre 0 a MAXDGV - 2*(IORDV+1) */
6068/* PATJAC: Table des coeff. du carreau d'approximation avec */
6069/* contraintes d'ordre IORDRU en U et IORDRV en V. */
6070
6071/* VECERR: Vecteur auxiliaire. */
6072/* ERREUR: L'erreur MAXI commise enlevant les coeff de PATJAC */
6073/* DEJA CALCULEE */
6074
6075/* ARGUMENTS DE SORTIE : */
6076/* ------------------- */
6077/* ERREUR: L'erreur MAXI commise enlevant les coeff de PATJAC */
6078/* d'indices MINDGU a MAXDGU en U et MINDGV a MAXDGV en V */
6079/* PLUS l'erreur deja calculee. */
6080
6081/* COMMONS UTILISES : */
6082/* ---------------- */
6083
6084/* REFERENCES APPELEES : */
6085/* ----------------------- */
6086
6087/* DESCRIPTION/REMARQUES/LIMITATIONS : */
6088/* ----------------------------------- */
6089/* Dans le tableau PATJAC sont stockes les coeff. Cij du carreau */
6090/* d'approximation de F(U,V). Les indices i et j indique le degre en
6091*/
6092/* U et en V des polynomes de base. Ces polynomes de base sont de la
6093*/
6094/* forme: */
6095
6096/* ((1 - U*U)**(IORDRU+1)).J(i-2*(IORDRU+1)(U), ou */
6097
6098/* le polynome J(i-2*(IORDU+1)(U) est le polynome de Jacobi d'ordre */
6099/* IORDRU+1 (idem en V en remplacant U par V dans l'expression ci */
6100/* dessus). */
6101
6102/* La contribution a l'erreur du terme Cij lorsque celui-ci est */
6103/* enleve de PATJAC est majoree par: */
6104
6105/* DABS(Cij)*XMAXJU(i-2*(IORDRU+1))*XMAXJV(J-2*(IORDRV+1)) ou on a */
6106
6107/* XMAXJU(i-2*(IORDRU+1) = ((1 - U*U)**(IORDRU+1)).J(i-2*(IORDRU+1)(U),
6108*/
6109/* XMAXJV(i-2*(IORDRV+1) = ((1 - V*V)**(IORDRV+1)).J(j-2*(IORDRV+1)(V).
6110*/
6111
6112/* $ HISTORIQUE DES MODIFICATIONS : */
6113/* -------------------------------- */
6114/* 22-01-1992:RBD; Creation d'apres MA2ERR. */
6115/* > */
6116/* ***********************************************************************
6117 */
6118/* Le nom de la routine */
6119
6120
6121/* ----------------------------- Initialisations ------------------------
6122*/
6123
6124 /* Parameter adjustments */
6125 --vecerr;
6126 patjac_dim1 = *ndjacu + 1;
6127 patjac_dim2 = *ndjacv + 1;
6128 patjac_offset = patjac_dim1 * patjac_dim2;
6129 patjac -= patjac_offset;
6130
6131 /* Function Body */
6132 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 3;
6133 if (ldbg) {
6134 AdvApp2Var_SysBase::mgenmsg_("MMA2ER1", 7L);
6135 }
6136
6137 minu = (*iordru + 1) << 1;
6138 minv = (*iordrv + 1) << 1;
6139
6140/* ------------------- Calcul du majorant de l'erreur max ---------------
6141*/
6142/* ----- lorsque sont enleves les coeff. d'indices MINDGU a MAXDGU ------
6143*/
6144/* ---------------- en U et d'indices MINDGV a MAXDGV en V --------------
6145*/
6146
6147 i__1 = *ndimen;
6148 for (nd = 1; nd <= i__1; ++nd) {
6149 bid1 = 0.;
6150 i__2 = *maxdgv;
6151 for (jj = *mindgv; jj <= i__2; ++jj) {
6152 bid0 = 0.;
6153 i__3 = *maxdgu;
6154 for (ii = *mindgu; ii <= i__3; ++ii) {
6155 bid0 += (d__1 = patjac[ii + (jj + nd * patjac_dim2) *
6156 patjac_dim1], abs(d__1)) * xmaxju[ii - minu];
6157/* L300: */
6158 }
6159 bid1 = bid0 * xmaxjv[jj - minv] + bid1;
6160/* L200: */
6161 }
6162 vecerr[nd] = bid1;
6163
6164/* L100: */
6165 }
6166
6167/* ----------------------- Calcul de l' erreur max ----------------------
6168*/
6169
6170 bid1 = AdvApp2Var_MathBase::mzsnorm_(ndimen, &vecerr[1]);
6171 vaux[0] = *erreur;
6172 vaux[1] = bid1;
6173 nd = 2;
6174 *erreur = AdvApp2Var_MathBase::mzsnorm_(&nd, vaux);
6175
6176/* ------------------------- The end ------------------------------------
6177*/
6178
6179 if (ldbg) {
6180 AdvApp2Var_SysBase::mgsomsg_("MMA2ER1", 7L);
6181 }
6182 return 0;
6183} /* mma2er1_ */
6184
6185//=======================================================================
6186//function : mma2er2_
6187//purpose :
6188//=======================================================================
6189int mma2er2_(integer *ndjacu,
6190 integer *ndjacv,
6191 integer *ndimen,
6192 integer *mindgu,
6193 integer *maxdgu,
6194 integer *mindgv,
6195 integer *maxdgv,
6196 integer *iordru,
6197 integer *iordrv,
6198 doublereal *xmaxju,
6199 doublereal *xmaxjv,
6200 doublereal *patjac,
6201 doublereal *epmscut,
6202 doublereal *vecerr,
6203 doublereal *erreur,
6204 integer *newdgu,
6205 integer *newdgv)
6206
6207{
6208 /* System generated locals */
6209 integer patjac_dim1, patjac_dim2, patjac_offset, i__1, i__2;
6210 doublereal d__1;
6211
6212 /* Local variables */
6213 static logical ldbg;
6214 static doublereal vaux[2];
6215 static integer i2rdu, i2rdv;
6216 static doublereal errnu, errnv;
6217 static integer ii, nd, jj, nu, nv;
6218 static doublereal bid0, bid1;
6219
6220
6221/* **********************************************************************
6222*/
6223
6224/* FONCTION : */
6225/* ---------- */
6226/* Enleve des coefficients de PATJAC jusqu'a obtenir les degre en U */
6227/* et V minimum verifiant la tolerance imposee. */
6228
6229/* MOTS CLES : */
6230/* ----------- */
6231/* TOUS,AB_SPECIFI:: CARREAU&,CALCUL,&ERREUR */
6232
6233/* ARGUMENTS D'ENTREE : */
6234/* ------------------ */
6235/* NDJACU: Degre en U du tableau PATJAC. */
6236/* NDJACV: Degre en V du tableau PATJAC. */
6237/* NDIMEN: Dimension de l'espace. */
6238/* MINDGU: Borne de l'indice en U des coeff. de PATJAC a GARDER */
6239/* (doit etre >= 0). */
6240/* MAXDGU: Borne sup de l'indice en U des coeff. de PATJAC a prendre */
6241/* en compte. */
6242/* MINDGV: Borne de l'indice en V des coeff. de PATJAC a GARDER */
6243/* (doit etre >= 0). */
6244/* MAXDGV: Borne sup de l'indice en V des coeff. de PATJAC a prendre */
6245/* en compte. */
6246/* IORDRU: Ordre de continuite en U assure par le carreau PATJAC */
6247/* (de -1 a 2) */
6248/* IORDRV: Ordre de continuite en V assure par le carreau PATJAC */
6249/* (de -1 a 2) */
6250/* XMAXJU: Valeur maximale des polynomes de Jacobi d'ordre IORDRU, */
6251/* du degre 0 a MAXDGU - 2*(IORDU+1) */
6252/* XMAXJV: Valeur maximale des polynomes de Jacobi d'ordre IORDRV, */
6253/* du degre 0 a MAXDGV - 2*(IORDV+1) */
6254/* PATJAC: Table des coeff. du carreau d'approximation avec */
6255/* contraintes d'ordre IORDRU en U et IORDRV en V. */
6256/* EPMSCUT: Tolerance d'approximation. */
6257/* VECERR: tableau auxiliaire. */
6258/* ERREUR: L'erreur MAXI commise DEJA CALCULEE. */
6259
6260/* ARGUMENTS DE SORTIE : */
6261/* ------------------- */
6262/* ERREUR: L'erreur MAXI commise en ne gardant que les coeff de */
6263/* PATJAC d'indices 0 a NEWDGU en U et 0 a NEWDGV en V, */
6264/* PLUS l'erreur maxi deja calculee. */
6265/* NEWDGU: Degre en U minimum t.q. le carreau d'approximation */
6266/* verifie la tolerance. On a toujours NEWDGU >= MINDGU >= 0. */
6267/* NEWDGV: Degre en V minimum t.q. le carreau d'approximation */
6268/* verifie la tolerance. On a toujours NEWDGV >= MINDGV >= 0. */
6269
6270/* COMMONS UTILISES : */
6271/* ---------------- */
6272
6273/* REFERENCES APPELEES : */
6274/* ----------------------- */
6275
6276/* DESCRIPTION/REMARQUES/LIMITATIONS : */
6277/* ----------------------------------- */
6278/* Dans le tableau PATJAC sont stockes les coeff. Cij du carreau */
6279/* d'approximation de F(U,V). Les indices i et j indique le degre */
6280/* en U et en V des polynomes de base. Ces polynomes de base sont */
6281/* de la forme: */
6282
6283/* ((1 - U*U)**(IORDRU+1)).J(i-2*(IORDRU+1)(U), ou */
6284
6285/* le polynome J(i-2*(IORDU+1)(U) est le polynome de Jacobi d'ordre */
6286/* IORDRU+1 (idem en V en remplacant U par V dans l'expression ci */
6287/* dessus). */
6288
6289/* La contribution a l'erreur du terme Cij lorsque celui-ci est */
6290/* enleve de PATJAC est majoree par: */
6291
6292/* DABS(Cij)*XMAXJU(i-2*(IORDRU+1))*XMAXJV(J-2*(IORDRV+1)) ou on a */
6293
6294/* XMAXJU(i-2*(IORDRU+1) = ((1 - U*U)**(IORDRU+1)).J(i-2*(IORDRU+1)(U),
6295*/
6296/* XMAXJV(i-2*(IORDRV+1) = ((1 - V*V)**(IORDRV+1)).J(j-2*(IORDRV+1)(V).
6297*/
6298
6299/* $ HISTORIQUE DES MODIFICATIONS : */
6300/* -------------------------------- */
6301/* 23-01-1992: RBD; Creation d'apres MA2CUT. */
6302/* > */
6303/* **********************************************************************
6304*/
6305/* Le nom de la routine */
6306
6307
6308/* ----------------------------- Initialisations ------------------------
6309*/
6310
6311 /* Parameter adjustments */
6312 --vecerr;
6313 patjac_dim1 = *ndjacu + 1;
6314 patjac_dim2 = *ndjacv + 1;
6315 patjac_offset = patjac_dim1 * patjac_dim2;
6316 patjac -= patjac_offset;
6317
6318 /* Function Body */
6319 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 3;
6320 if (ldbg) {
6321 AdvApp2Var_SysBase::mgenmsg_("MMA2ER2", 7L);
6322 }
6323
6324 i2rdu = (*iordru + 1) << 1;
6325 i2rdv = (*iordrv + 1) << 1;
6326 nu = *maxdgu;
6327 nv = *maxdgv;
6328
6329/* **********************************************************************
6330*/
6331/* -------------------- Coupure des coefficients ------------------------
6332*/
6333/* **********************************************************************
6334*/
6335
6336L1001:
6337
6338/* ------------------- Calcul du majorant de l'erreur max ---------------
6339*/
6340/* ----- lorsque sont enleves les coeff. d'indices MINDGU a MAXDGU ------
6341*/
6342/* ---------------- en U, le degre en V etant fixe a NV -----------------
6343*/
6344
6345 bid0 = 0.;
6346 if (nv > *mindgv) {
6347 bid0 = xmaxjv[nv - i2rdv];
6348 i__1 = *ndimen;
6349 for (nd = 1; nd <= i__1; ++nd) {
6350 bid1 = 0.;
6351 i__2 = nu;
6352 for (ii = i2rdu; ii <= i__2; ++ii) {
6353 bid1 += (d__1 = patjac[ii + (nv + nd * patjac_dim2) *
6354 patjac_dim1], abs(d__1)) * xmaxju[ii - i2rdu] * bid0;
6355/* L200: */
6356 }
6357 vecerr[nd] = bid1;
6358/* L100: */
6359 }
6360 } else {
6361 vecerr[1] = *epmscut * 2;
6362 }
6363 errnv = AdvApp2Var_MathBase::mzsnorm_(ndimen, &vecerr[1]);
6364
6365/* ------------------- Calcul du majorant de l'erreur max ---------------
6366*/
6367/* ----- lorsque sont enleves les coeff. d'indices MINDGV a MAXDGV ------
6368*/
6369/* ---------------- en V, le degre en U etant fixe a NU -----------------
6370*/
6371
6372 bid0 = 0.;
6373 if (nu > *mindgu) {
6374 bid0 = xmaxju[nu - i2rdu];
6375 i__1 = *ndimen;
6376 for (nd = 1; nd <= i__1; ++nd) {
6377 bid1 = 0.;
6378 i__2 = nv;
6379 for (jj = i2rdv; jj <= i__2; ++jj) {
6380 bid1 += (d__1 = patjac[nu + (jj + nd * patjac_dim2) *
6381 patjac_dim1], abs(d__1)) * xmaxjv[jj - i2rdv] * bid0;
6382/* L400: */
6383 }
6384 vecerr[nd] = bid1;
6385/* L300: */
6386 }
6387 } else {
6388 vecerr[1] = *epmscut * 2;
6389 }
6390 errnu = AdvApp2Var_MathBase::mzsnorm_(ndimen, &vecerr[1]);
6391
6392/* ----------------------- Calcul de l' erreur max ----------------------
6393*/
6394
6395 vaux[0] = *erreur;
6396 vaux[1] = errnu;
6397 nd = 2;
6398 errnu = AdvApp2Var_MathBase::mzsnorm_(&nd, vaux);
6399 vaux[1] = errnv;
6400 errnv = AdvApp2Var_MathBase::mzsnorm_(&nd, vaux);
6401
6402 if (errnu > errnv) {
6403 if (errnv < *epmscut) {
6404 *erreur = errnv;
6405 --nv;
6406 } else {
6407 goto L2001;
6408 }
6409 } else {
6410 if (errnu < *epmscut) {
6411 *erreur = errnu;
6412 --nu;
6413 } else {
6414 goto L2001;
6415 }
6416 }
6417
6418 goto L1001;
6419
6420/* -------------------------- Recuperation des degres -------------------
6421*/
6422
6423L2001:
6424 *newdgu = max(nu,1);
6425 *newdgv = max(nv,1);
6426
6427/* ----------------------------------- The end --------------------------
6428*/
6429
6430 if (ldbg) {
6431 AdvApp2Var_SysBase::mgsomsg_("MMA2ER2", 7L);
6432 }
6433 return 0;
6434} /* mma2er2_ */
6435
6436//=======================================================================
6437//function : mma2fnc_
6438//purpose :
6439//=======================================================================
6440int AdvApp2Var_ApproxF2var::mma2fnc_(integer *ndimen,
6441 integer *nbsesp,
6442 integer *ndimse,
6443 doublereal *uvfonc,
6444 void (*foncnp) (
6445 int *,
6446 double *,
6447 double *,
6448 int *,
6449 double *,
6450 int *,
6451 double *,
6452 int *,
6453 int *,
6454 double *,
6455 int *
6456 ),
6457 doublereal *tconst,
6458 integer *isofav,
6459 integer *nbroot,
6460 doublereal *rootlg,
6461 integer *iordre,
6462 integer *ideriv,
6463 integer *ndgjac,
6464 integer *nbcrmx,
6465 integer *ncflim,
6466 doublereal *epsapr,
6467 integer *ncoeff,
6468 doublereal *courbe,
6469 integer *nbcrbe,
6470 doublereal *somtab,
6471 doublereal *diftab,
6472 doublereal *contr1,
6473 doublereal *contr2,
6474 doublereal *tabdec,
6475 doublereal *errmax,
6476 doublereal *errmoy,
6477 integer *iercod)
6478
6479{
6480 static integer c__8 = 8;
6481
6482 /* System generated locals */
6483 integer courbe_dim1, courbe_dim2, courbe_offset, somtab_dim1, somtab_dim2,
6484 somtab_offset, diftab_dim1, diftab_dim2, diftab_offset,
6485 contr1_dim1, contr1_dim2, contr1_offset, contr2_dim1, contr2_dim2,
6486 contr2_offset, errmax_dim1, errmax_offset, errmoy_dim1,
6487 errmoy_offset, i__1;
6488 doublereal d__1;
6489
6490 /* Local variables */
6491 static integer ideb;
6492 static doublereal tmil;
6493 static integer ideb1, ibid1, ibid2, ncfja, ndgre, ilong,
6494 ndwrk;
6495 static doublereal wrkar[1];
6496 static integer nupil;
6497 static long int iofwr;
6498 static doublereal uvpav[4] /* was [2][2] */;
6499 static integer nd, ii;
6500 static integer ibb;
6501 static integer ier;
6502 static doublereal uv11[4] /* was [2][2] */;
6503 static integer ncb1;
6504 static doublereal eps3;
6505 static integer isz1, isz2, isz3, isz4, isz5;
6506 static long int ipt1, ipt2, ipt3, ipt4, ipt5,iptt, jptt;
6507
6508/* **********************************************************************
6509*/
6510
6511/* FONCTION : */
6512/* ---------- */
6513/* Approximation d'UNE frontiere d'une fonction non polynomiale F(u,v) */
6514/* (dans l' espace de dimension NDIMEN) par PLUSIEURS courbes */
6515/* polynomiales, par la methode des moindres carres. Le parametre de la */
6516/* fonction est conserve. */
6517
6518/* MOTS CLES : */
6519/* ----------- */
6520/* TOUS, AB_SPECIFI :: FONCTION&,EXTREMITE&, APPROXIMATION, &COURBE. */
6521
6522/* ARGUMENTS D'ENTREE : */
6523/* ------------------ */
6524/* NDIMEN: Dimension totale de l' espace (somme des dimensions */
6525/* des sous-espaces) */
6526/* NBSESP: Nombre de sous-espaces "independants". */
6527/* NDIMSE: Table des dimensions des sous-espaces. */
6528/* UVFONC: Bornes de l' intervalle (a,b)x(c,d) de definition de la */
6529/* fonction a approcher en U (UVFONC(*,1) contient (a,b)) */
6530/* et en V (UVFONC(*,2) contient (c,d)). */
6531/* FONCNP: Fonction externe de positionnement sur la fonction non */
6532/* polynomiale a approcher. */
6533/* TCONST: Valeur de l'isoparametre de F(u,v) a discretiser. */
6534/* ISOFAV: Type d'iso choisi, = 1, indique que l'on discretise a u */
6535/* fixe; = 2, indique que v est fixe. */
6536/* NBROOT: Nbre de points de discretisation de l'iso, extremites non
6537*/
6538/* comprises. */
6539/* ROOTLG: Table des racines du polynome de Legendre defini sur */
6540/* (-1,1), de degre NBROOT. */
6541/* IORDRE: Ordre de contrainte aux extremites de la frontiere */
6542/* -1 = pas de contraintes, */
6543/* 0 = contraintes de passage aux bornes (i.e. C0), */
6544/* 1 = C0 + contraintes de derivees 1eres (i.e. C1), */
6545/* 2 = C1 + contraintes de derivees 2ndes (i.e. C2). */
6546/* IDERIV: Ordre de derivee de la frontiere. */
6547/* NDGJAC: Degre du developpement en serie a utiliser pour le calcul
6548*/
6549/* dans la base de Jacobi. */
6550/* NBCRMX: Nbre maxi de courbes a creer. */
6551/* NCFLIM: Nombre maxi de coeff de la "courbe" polynomiale */
6552/* d' approximation (doit etre superieur ou egal a */
6553/* 2*IORDRE+2 et inferieur ou egal a 50). */
6554/* EPSAPR: Table des erreurs d' approximations souhaitees */
6555/* sous-espace par sous-espace. */
6556
6557/* ARGUMENTS DE SORTIE : */
6558/* ------------------- */
6559/* NCOEFF: Nombre de coeff. significatifs des courbes calculees. */
6560/* COURBE: Tableau des coeff. des courbes polynomiales calculees. */
6561/* Doit etre dimensionne en (NCFLIM,NDIMEN,NBCRMX). */
6562/* Ces courbes sont TOUJOURS parametrees dans (-1,1). */
6563/* NBCRBE: Nbre de courbes calculees. */
6564/* SOMTAB: Pour F definie sur (-1,1) (sinon on recale les */
6565/* parametres), c'est la table des sommes F(u,vj) + F(u,-vj)
6566*/
6567/* si ISOFAV = 1 (et IDERIV=0, sinon on prend les derivees */
6568/* en u d'ordre IDERIV) ou des sommes F(ui,v) + F(-ui,v) si */
6569/* ISOFAV = 2 (et IDERIV=0, sinon on prend les derivees en */
6570/* v d'ordre IDERIV). */
6571/* DIFTAB: Pour F definie sur (-1,1) (sinon on recale les */
6572/* parametres), c'est la table des sommes F(u,vj) - F(u,-vj)
6573*/
6574/* si ISOFAV = 1 (et IDERIV=0, sinon on prend les derivees */
6575/* en u d'ordre IDERIV) ou des sommes F(ui,v) - F(-ui,v) si */
6576/* ISOFAV = 2 (et IDERIV=0, sinon on prend les derivees en */
6577/* v d'ordre IDERIV). */
6578/* CONTR1: Contient les coordonnees de l'extremite gauche de l'iso */
6579/* et de ses derivees jusqu'a l'ordre IORDRE */
6580/* CONTR2: Contient les coordonnees de l'extremite droite de l'iso */
6581/* et de ses derivees jusqu'a l'ordre IORDRE */
6582/* TABDEC: Table des NBCRBE+1 parametres de decoupe de UVFONC(1:2,1)
6583*/
6584/* si ISOFAV=2, ou de UVFONC(1:2,2) si ISOFAV=1. */
6585/* ERRMAX: Table des erreurs (sous-espace par sous espace) */
6586/* MAXIMALES commises dans l' approximation de FONCNP par */
6587/* les NBCRBE courbes. */
6588/* ERRMOY: Table des erreurs (sous-espace par sous espace) */
6589/* MOYENNES commises dans l' approximation de FONCNP par */
6590/* les NBCRBE courbes. */
6591/* IERCOD: Code d' erreur : */
6592/* -1 = ERRMAX > EPSAPR pour au moins un des sous-espace. */
6593/* (les courbes resultat de degre mathematique NCFLIM-1
6594*/
6595/* au plus , sont quand meme calculees). */
6596/* 0 = Tout est ok. */
6597/* 1 = Pb d' incoherence des entrees. */
6598/* 10 = Pb de calcul de l' interpolation des contraintes. */
6599/* 13 = Pb dans l' allocation dynamique. */
6600/* 33 = Pb dans la recuperation des donnees du block data */
6601/* des coeff. d' integration par la methode de GAUSS. */
6602/* >100 Pb dans l' evaluation de FONCNP, le code d' erreur */
6603/* renvoye est egal au code d' erreur de FONCNP + 100. */
6604
6605/* COMMONS UTILISES : */
6606/* ---------------- */
6607
6608/* REFERENCES APPELEES : */
6609/* ----------------------- */
6610
6611/* DESCRIPTION/REMARQUES/LIMITATIONS : */
6612/* ----------------------------------- */
6613/* --> La partie approximation est faite dans l' espace de dimension */
6614/* NDIMEN (la somme des dimensions des sous-espaces). Par exemple : */
6615/* Si NBSESP=2 et NDIMSE(1)=3, NDIMSE(2)=2, on a un lissage avec */
6616/* NDIMEN=5. Le resultat (dans COURBE(NDIMEN,NCOEFF,i) ), sera */
6617/* compose du resultat du lissage de la fonction 3D dans */
6618/* COURBE(1:3,1:NCOEFF,i) et du lissage de la fonction 2D dans */
6619/* COURBE(4:5,1:NCOEFF,i). */
6620
6621/* --> La routine FONCNP doit etre declaree EXTERNAL dans le programme */
6622/* appelant MMA2FNC. */
6623
6624/* --> La fonction FONCNP, declaree ici en externe, doit etre declaree */
6625/* IMPERATIVEMENT sous la forme : */
6626/* SUBROUTINE FONCNP(NDIMEN,UINTFN,VINTFN,IIUOUV,TCONST,NBPTAB */
6627/* ,TTABLE,IDERIU,IDERIV,IERCOD) */
6628/* ou les arguments d' entree sont : */
6629/* - NDIMEN est un entier defini comme la somme des dimensions des */
6630/* sous-espaces (i.e. dimension totale du probleme). */
6631/* - UINTFN(2) est un tableau de 2 reels contenant l' intervalle */
6632/* en U ou est definie la fonction a approximer */
6633/* (donc ici egal a UIFONC). */
6634/* - VINTFN(2) est un tableau de 2 reels contenant l' intervalle */
6635/* en V ou est definie la fonction a approximer */
6636/* (donc ici egal a VIFONC). */
6637/* - IIUOUV, indique que les points a calculer sont a U constant */
6638/* (IIUOUV=1) ou a V constant (IIUOUV=2). */
6639/* - TCONST, un reel, le parametre fixe de discretisation qui prend
6640*/
6641/* ses valeurs dans (UINTFN(1),UINTFN(2)) si IIUOUV=1, */
6642/* ou dans (VINTFN(1),VINTFN(2)) si IIUOUV=2. */
6643/* - NBPTAB, Le nbre de point de discretisation suivant la variable
6644*/
6645/* libre: V si IIUOUV=1 ou U si IIUOUV = 2. */
6646/* - TTABLE, La table des NBPTAB parametres de discretisation. */
6647/* - IDERIU, un entier, prend ses valeurs entre 0 (positionnement) */
6648/* et IORDRU (derivee partielle en U de la fonction a */
6649/* l' ordre IORDRU si IORDRU > 0). */
6650/* - IDERIV, un entier, prend ses valeurs entre 0 (positionnement) */
6651/* et IORDRV (derivee partielle en V de la fonction a */
6652/* l' ordre IORDRV si IORDRV > 0). */
6653/* et les arguments de sortie sont : */
6654/* - FPNTAB(NDIMEN,NBPTAB) contient, en sortie, le tableau des */
6655/* NBPTAB points calcules de dimension NDIMEN. */
6656/* - IERCOD est, en sortie, le code d' erreur de FONCNP. Ce code */
6657/* (entier) doit etre strictement positif s' il y a eu */
6658/* un probleme. */
6659/* Les arguments d' entree NE DOIVENT PAS etre modifies sous FONCNP.
6660*/
6661
6662/* --> Si IERCOD=-1, la precision demandee n' est pas atteinte (ERRMAX */
6663/* est superieur a EPSAPR sur au moins l' un des sous espaces), mais
6664*/
6665/* on donne le meilleur resultat possible pour NCFLIM et EPSAPR */
6666/* choisis par l'utilisateur. Dans ce cas (ainsi que pour */
6667/* IERCOD=0), on a une solution. */
6668
6669
6670/* $ HISTORIQUE DES MODIFICATIONS : */
6671/* -------------------------------- */
6672/* 04-02-1992: RBD; Correction passage SOMTAB et DIFTAB en argument */
6673/* et appel a MMFMCA8. */
6674/* 26-09-1991: RBD; Creation. */
6675/* > */
6676/* **********************************************************************
6677*/
6678/* Le nom de la routine */
6679
6680 /* Parameter adjustments */
6681 --epsapr;
6682 --ndimse;
6683 uvfonc -= 3;
6684 --rootlg;
6685 errmoy_dim1 = *nbsesp;
6686 errmoy_offset = errmoy_dim1 + 1;
6687 errmoy -= errmoy_offset;
6688 errmax_dim1 = *nbsesp;
6689 errmax_offset = errmax_dim1 + 1;
6690 errmax -= errmax_offset;
6691 contr2_dim1 = *ndimen;
6692 contr2_dim2 = *iordre + 2;
6693 contr2_offset = contr2_dim1 * (contr2_dim2 + 1) + 1;
6694 contr2 -= contr2_offset;
6695 contr1_dim1 = *ndimen;
6696 contr1_dim2 = *iordre + 2;
6697 contr1_offset = contr1_dim1 * (contr1_dim2 + 1) + 1;
6698 contr1 -= contr1_offset;
6699 diftab_dim1 = *nbroot / 2 + 1;
6700 diftab_dim2 = *ndimen;
6701 diftab_offset = diftab_dim1 * (diftab_dim2 + 1);
6702 diftab -= diftab_offset;
6703 somtab_dim1 = *nbroot / 2 + 1;
6704 somtab_dim2 = *ndimen;
6705 somtab_offset = somtab_dim1 * (somtab_dim2 + 1);
6706 somtab -= somtab_offset;
6707 --ncoeff;
6708 courbe_dim1 = *ncflim;
6709 courbe_dim2 = *ndimen;
6710 courbe_offset = courbe_dim1 * (courbe_dim2 + 1) + 1;
6711 courbe -= courbe_offset;
6712
6713 /* Function Body */
6714 ibb = AdvApp2Var_SysBase::mnfndeb_();
6715 if (ibb >= 1) {
6716 AdvApp2Var_SysBase::mgenmsg_("MMA2FNC", 7L);
6717 }
6718 *iercod = 0;
6719 iofwr = 0;
6720
6721/* ---------------- Mise a zero des coefficients de COURBE --------------
6722*/
6723
6724 ilong = *ndimen * *ncflim * *nbcrmx;
6725 AdvApp2Var_SysBase::mvriraz_(&ilong, (char *)&courbe[courbe_offset]);
6726
6727/* **********************************************************************
6728*/
6729/* -------------------------- Verification des entrees ------------------
6730*/
6731/* **********************************************************************
6732*/
6733
6734 AdvApp2Var_MathBase::mmveps3_(&eps3);
6735 if ((d__1 = uvfonc[4] - uvfonc[3], abs(d__1)) < eps3) {
6736 goto L9100;
6737 }
6738 if ((d__1 = uvfonc[6] - uvfonc[5], abs(d__1)) < eps3) {
6739 goto L9100;
6740 }
6741
6742 uv11[0] = -1.;
6743 uv11[1] = 1.;
6744 uv11[2] = -1.;
6745 uv11[3] = 1.;
6746
6747/* **********************************************************************
6748*/
6749/* ------------- Preparation des parametres de discretisation -----------
6750*/
6751/* **********************************************************************
6752*/
6753
6754/* -- Allocation d'une table de parametres et de pts de discretisation --
6755*/
6756/* --> Pour les parametres de discretisation. */
6757 isz1 = *nbroot + 2;
6758/* --> Pour les pts de discretisation dans MMA1FDI et MMA1CDI et la courbe
6759 */
6760/* auxiliaire pour MMAPCMP */
6761 ibid1 = *ndimen * (*nbroot + 2);
6762 ibid2 = ((*iordre + 1) << 1) * *nbroot;
6763 isz2 = max(ibid1,ibid2);
6764 ibid1 = (((*ncflim - 1) / 2 + 1) << 1) * *ndimen;
6765 isz2 = max(ibid1,isz2);
6766/* --> Pour recuperer les polynomes d'hermite. */
6767 isz3 = ((*iordre + 1) << 2) * (*iordre + 1);
6768/* --> Pour les coeff. d'integration de Gauss. */
6769 isz4 = (*nbroot / 2 + 1) * (*ndgjac + 1 - ((*iordre + 1) << 1));
6770/* --> Pour les coeff de la courbe dans la base de Jacobi */
6771 isz5 = (*ndgjac + 1) * *ndimen;
6772
6773 ndwrk = isz1 + isz2 + isz3 + isz4 + isz5;
6774 AdvApp2Var_SysBase::mcrrqst_(&c__8, &ndwrk, wrkar, &iofwr, &ier);
6775 if (ier > 0) {
6776 goto L9013; }
6777/* --> Pour les parametres de discretisation (NBROOT+2 extremites). */
6778 ipt1 = iofwr;
6779/* --> Pour les pts de discretisation FPNTAB(NDIMEN,NBROOT+2), */
6780/* FPNTAB(NBROOT,2*(IORDRE+1)) et pour WRKAR de MMAPCMP. */
6781 ipt2 = ipt1 + isz1;
6782/* --> Pour les polynomes d'Hermite */
6783 ipt3 = ipt2 + isz2;
6784/* --> Pour les coeff d'integration de Gauss. */
6785 ipt4 = ipt3 + isz3;
6786/* --> Pour la courbe dans Jacobi. */
6787 ipt5 = ipt4 + isz4;
6788
6789/* ------------------ Initialisation de la gestion des decoupes ---------
6790*/
6791
6792 if (*isofav == 1) {
6793 uvpav[0] = uvfonc[3];
6794 uvpav[1] = uvfonc[4];
6795 tabdec[0] = uvfonc[5];
6796 tabdec[1] = uvfonc[6];
6797 } else if (*isofav == 2) {
6798 tabdec[0] = uvfonc[3];
6799 tabdec[1] = uvfonc[4];
6800 uvpav[2] = uvfonc[5];
6801 uvpav[3] = uvfonc[6];
6802 } else {
6803 goto L9100;
6804 }
6805
6806 nupil = 1;
6807 *nbcrbe = 0;
6808
6809/* **********************************************************************
6810*/
6811/* APPROXIMATION AVEC DECOUPES */
6812/* **********************************************************************
6813*/
6814
6815L1000:
6816/* --> Lorsque l' on a atteint le haut de la pile, c' est fini ! */
6817 if (nupil - *nbcrbe == 0) {
6818 goto L9900;
6819 }
6820 ncb1 = *nbcrbe + 1;
6821 if (*isofav == 1) {
6822 uvpav[2] = tabdec[*nbcrbe];
6823 uvpav[3] = tabdec[*nbcrbe + 1];
6824 } else if (*isofav == 2) {
6825 uvpav[0] = tabdec[*nbcrbe];
6826 uvpav[1] = tabdec[*nbcrbe + 1];
6827 } else {
6828 goto L9100;
6829 }
6830
6831/* -------------------- Normalisation des parametres --------------------
6832*/
6833
6834 mma1nop_(nbroot, &rootlg[1], uvpav, isofav, &wrkar[ipt1], &ier);
6835 if (ier > 0) {
6836 goto L9100;
6837 }
6838
6839/* -------------------- Discretisation de FONCNP ------------------------
6840*/
6841
6842 mma1fdi_(ndimen, uvpav, foncnp, isofav, tconst, nbroot, &wrkar[ipt1],
6843 iordre, ideriv, &wrkar[ipt2], &somtab[(ncb1 * somtab_dim2 + 1) *
6844 somtab_dim1], &diftab[(ncb1 * diftab_dim2 + 1) * diftab_dim1], &
6845 contr1[(ncb1 * contr1_dim2 + 1) * contr1_dim1 + 1], &contr2[(ncb1
6846 * contr2_dim2 + 1) * contr2_dim1 + 1], iercod);
6847 if (*iercod > 0) {
6848 goto L9900;
6849 }
6850
6851/* -----------On retranche la discretisation des contraintes ------------
6852*/
6853
6854 if (*iordre >= 0) {
6855 mma1cdi_(ndimen, nbroot, &rootlg[1], iordre, &contr1[(ncb1 *
6856 contr1_dim2 + 1) * contr1_dim1 + 1], &contr2[(ncb1 *
6857 contr2_dim2 + 1) * contr2_dim1 + 1], &somtab[(ncb1 *
6858 somtab_dim2 + 1) * somtab_dim1], &diftab[(ncb1 * diftab_dim2
6859 + 1) * diftab_dim1], &wrkar[ipt2], &wrkar[ipt3], &ier);
6860 if (ier > 0) {
6861 goto L9100;
6862 }
6863 }
6864
6865/* **********************************************************************
6866*/
6867/* -------------------- Calcul de la courbe d'approximation -------------
6868*/
6869/* **********************************************************************
6870*/
6871
6872 mma1jak_(ndimen, nbroot, iordre, ndgjac, &somtab[(ncb1 * somtab_dim2 + 1)
6873 * somtab_dim1], &diftab[(ncb1 * diftab_dim2 + 1) * diftab_dim1], &
6874 wrkar[ipt4], &wrkar[ipt5], &ier);
6875 if (ier > 0) {
6876 goto L9100;
6877 }
6878
6879/* **********************************************************************
6880*/
6881/* ---------------- Ajout du polynome d'interpolation -------------------
6882*/
6883/* **********************************************************************
6884*/
6885
6886 if (*iordre >= 0) {
6887 mma1cnt_(ndimen, iordre, &contr1[(ncb1 * contr1_dim2 + 1) *
6888 contr1_dim1 + 1], &contr2[(ncb1 * contr2_dim2 + 1) *
6889 contr2_dim1 + 1], &wrkar[ipt3], ndgjac, &wrkar[ipt5]);
6890 }
6891
6892/* **********************************************************************
6893*/
6894/* --------------- Calcul de l'erreur Max et Moyenne --------------------
6895*/
6896/* **********************************************************************
6897*/
6898
6899 mma1fer_(ndimen, nbsesp, &ndimse[1], iordre, ndgjac, &wrkar[ipt5], ncflim,
6900 &epsapr[1], &wrkar[ipt2], &errmax[ncb1 * errmax_dim1 + 1], &
6901 errmoy[ncb1 * errmoy_dim1 + 1], &ncoeff[ncb1], &ier);
6902 if (ier > 0) {
6903 goto L9100;
6904 }
6905
6906 if (ier == 0 || (ier == -1 && nupil == *nbcrmx)) {
6907
6908/* ******************************************************************
6909**** */
6910/* ----------------------- Compression du resultat ------------------
6911---- */
6912/* ******************************************************************
6913**** */
6914
6915 if (ier == -1) {
6916 *iercod = -1;
6917 }
6918 ncfja = *ndgjac + 1;
6919/* -> Compression du resultat dans WRKAR(IPT2) */
6920 /*pkv f*/
6921 /*
6922 AdvApp2Var_MathBase::mmapcmp_(ndimen,
6923 &ncfja, &ncoeff[ncb1], &wrkar[ipt5], &wrkar[ipt2]);
6924 */
6925 AdvApp2Var_MathBase::mmapcmp_((integer*)ndimen,
6926 &ncfja,
6927 &ncoeff[ncb1],
6928 &wrkar[ipt5],
6929 &wrkar[ipt2]);
6930 /*pkv t*/
6931 ilong = *ndimen * *ncflim;
6932 AdvApp2Var_SysBase::mvriraz_(&ilong, (char*)&wrkar[ipt5]);
6933/* -> Passage a la base canonique (-1,1) (resultat dans WRKAR(IPT5)).
6934*/
6935 ndgre = ncoeff[ncb1] - 1;
6936 i__1 = *ndimen;
6937 for (nd = 1; nd <= i__1; ++nd) {
6938 iptt = ipt2 + ((nd - 1) << 1) * (ndgre / 2 + 1);
6939 jptt = ipt5 + (nd - 1) * ncoeff[ncb1];
6940 AdvApp2Var_MathBase::mmjacan_(iordre, &ndgre, &wrkar[iptt], &wrkar[jptt]);
6941/* L400: */
6942 }
6943
6944/* -> On stocke la courbe calculee */
6945 ibid1 = 1;
6946 AdvApp2Var_MathBase::mmfmca8_(&ncoeff[ncb1], ndimen, &ibid1, ncflim, ndimen, &ibid1, &
6947 wrkar[ipt5], &courbe[(ncb1 * courbe_dim2 + 1) * courbe_dim1 +
6948 1]);
6949
6950/* -> Les contraintes ayant ete normalisee sur (-1,1), on recalcule */
6951/* les contraintes vraies. */
6952 i__1 = *iordre;
6953 for (ii = 0; ii <= i__1; ++ii) {
6954 mma1noc_(uv11, ndimen, &ii, &contr1[(ii + 1 + ncb1 * contr1_dim2)
6955 * contr1_dim1 + 1], uvpav, isofav, ideriv, &contr1[(ii +
6956 1 + ncb1 * contr1_dim2) * contr1_dim1 + 1]);
6957 mma1noc_(uv11, ndimen, &ii, &contr2[(ii + 1 + ncb1 * contr2_dim2)
6958 * contr2_dim1 + 1], uvpav, isofav, ideriv, &contr2[(ii +
6959 1 + ncb1 * contr2_dim2) * contr2_dim1 + 1]);
6960/* L200: */
6961 }
6962 ii = 0;
6963 ibid1 = (*nbroot / 2 + 1) * *ndimen;
6964 mma1noc_(uv11, &ibid1, &ii, &somtab[(ncb1 * somtab_dim2 + 1) *
6965 somtab_dim1], uvpav, isofav, ideriv, &somtab[(ncb1 *
6966 somtab_dim2 + 1) * somtab_dim1]);
6967 mma1noc_(uv11, &ibid1, &ii, &diftab[(ncb1 * diftab_dim2 + 1) *
6968 diftab_dim1], uvpav, isofav, ideriv, &diftab[(ncb1 *
6969 diftab_dim2 + 1) * diftab_dim1]);
6970 ii = 0;
6971 i__1 = *ndimen;
6972 for (nd = 1; nd <= i__1; ++nd) {
6973 mma1noc_(uv11, &ncoeff[ncb1], &ii, &courbe[(nd + ncb1 *
6974 courbe_dim2) * courbe_dim1 + 1], uvpav, isofav, ideriv, &
6975 courbe[(nd + ncb1 * courbe_dim2) * courbe_dim1 + 1]);
6976/* L210: */
6977 }
6978
6979/* -> Mise ajour du nbre de courbes deja crees */
6980 ++(*nbcrbe);
6981
6982/* -> ...sinon on essai de decouper l' intervalle courant en 2... */
6983 } else {
6984 tmil = (tabdec[*nbcrbe + 1] + tabdec[*nbcrbe]) / 2.;
6985 ideb = *nbcrbe + 1;
6986 ideb1 = ideb + 1;
6987 ilong = (nupil - *nbcrbe) << 3;
6988 AdvApp2Var_SysBase::mcrfill_(&ilong, (char *)&tabdec[ideb],(char *)&tabdec[ideb1]);
6989 tabdec[ideb] = tmil;
6990 ++nupil;
6991 }
6992
6993/* ---------- On fait l' approximation de la suite de la pile -----------
6994*/
6995
6996 goto L1000;
6997
6998/* --------------------- Recuperation du code d' erreur -----------------
6999*/
7000/* --> Pb alloc. dynamique. */
7001L9013:
7002 *iercod = 13;
7003 goto L9900;
7004/* --> Entrees incoherentes. */
7005L9100:
7006 *iercod = 1;
7007 goto L9900;
7008
7009/* -------------------------- Desallocation dynamique -------------------
7010*/
7011
7012L9900:
7013 if (iofwr != 0) {
7014 AdvApp2Var_SysBase::mcrdelt_(&c__8, &ndwrk, wrkar, &iofwr, &ier);
7015 }
7016 if (ier > 0) {
7017 *iercod = 13;
7018 }
7019 goto L9999;
7020
7021/* ------------------------------ The end -------------------------------
7022*/
7023
7024L9999:
7025 if (*iercod != 0) {
7026 AdvApp2Var_SysBase::maermsg_("MMA2FNC", iercod, 7L);
7027 }
7028 if (ibb >= 2) {
7029 AdvApp2Var_SysBase::mgsomsg_("MMA2FNC", 7L);
7030 }
7031 return 0;
7032} /* mma2fnc_ */
7033
7034//=======================================================================
7035//function : mma2fx6_
7036//purpose :
7037//=======================================================================
7038int AdvApp2Var_ApproxF2var::mma2fx6_(integer *ncfmxu,
7039 integer *ncfmxv,
7040 integer *ndimen,
7041 integer *nbsesp,
7042 integer *ndimse,
7043 integer *nbupat,
7044 integer *nbvpat,
7045 integer *iordru,
7046 integer *iordrv,
7047 doublereal *epsapr,
7048 doublereal *epsfro,
7049 doublereal *patcan,
7050 doublereal *errmax,
7051 integer *ncoefu,
7052 integer *ncoefv)
7053
7054{
7055 /* System generated locals */
7056 integer epsfro_dim1, epsfro_offset, patcan_dim1, patcan_dim2, patcan_dim3,
7057 patcan_dim4, patcan_offset, errmax_dim1, errmax_dim2,
7058 errmax_offset, ncoefu_dim1, ncoefu_offset, ncoefv_dim1,
7059 ncoefv_offset, i__1, i__2, i__3, i__4, i__5;
7060 doublereal d__1, d__2;
7061
7062 /* Local variables */
7063 static integer idim, ncfu, ncfv, id, ii, nd, jj, ku, kv, ns, ibb;
7064 static doublereal bid;
7065 static doublereal tol;
7066
7067/* **********************************************************************
7068*/
7069
7070/* FONCTION : */
7071/* ---------- */
7072/* Reduction de degre lorsque les carreaux sont les carreaux de */
7073/* contraintes. */
7074
7075/* MOTS CLES : */
7076/* ----------- */
7077/* TOUS,AB_SPECIFI::CARREAU&,REDUCTION,&CARREAU */
7078
7079/* ARGUMENTS D'ENTREE : */
7080/* ------------------ */
7081/* NCFMXU: Nbre maximal de coeff en u de la solution P(u,v) (tableau */
7082/* PATCAN). Cet argument sert uniquement a declarer la taille */
7083/* de ce tableau. */
7084/* NCFMXV: Nbre maximal de coeff en v de la solution P(u,v) (tableau */
7085/* PATCAN). Cet argument sert uniquement a declarer la taille */
7086/* de ce tableau. */
7087/* NDIMEN: Dimension totale de l' espace ou la fonction a approcher */
7088/* prend ses valeurs.(somme des dimensions des sous-espaces) */
7089/* NBSESP: Nombre de sous-espaces independants ou l'on mesure les */
7090/* erreurs. */
7091/* NDIMSE: Table des dimensions des NBSESP sous-espaces. */
7092/* NBUPAT: Nbre de carreau solution en u. */
7093/* NBVPAT: Nbre de carreau solution en v. */
7094/* IORDRU: Ordre de contrainte impose aux extremites de l'iso-V */
7095/* = 0, on calcule les extremites de l'iso-V */
7096/* = 1, on calcule, en plus, la derivee 1ere dans le sens */
7097/* de l'iso-V */
7098/* = 2, on calcule, en plus, la derivee 2nde dans le sens */
7099/* de l'iso-V */
7100/* IORDRV: Ordre de contrainte impose aux extremites de l'iso-U */
7101/* = 0, on calcule les extremites de l'iso-U. */
7102/* = 1, on calcule, en plus, la derivee 1ere dans le sens */
7103/* de l'iso-U */
7104/* = 2, on calcule, en plus, la derivee 2nde dans le sens */
7105/* de l'iso-U */
7106/* EPSAPR: Table des precisions imposees, sous-espace par sous-espace. */
7107/* EPSFRO: Table des precisions imposees, sous-espace par sous-espace */
7108/* sur les frontieres des carreaux. */
7109/* PATCAN: Tableau des coeff. dans la base canonique des carreaux P(u,v)
7110*/
7111/* calcules, pour (u,v) dans (-1,1). */
7112/* ERRMAX: Table des erreurs (sous-espace par sous espace) */
7113/* MAXIMALES commises dans l' approximation de F(u,v) par */
7114/* les P(u,v). */
7115/* NCOEFU: Table des Nbres de coeff. significatifs en u des carreaux */
7116/* calcules. */
7117/* NCOEFV: Table des Nbres de coeff. significatifs en v des carreaux */
7118/* calcules. */
7119
7120/* ARGUMENTS DE SORTIE : */
7121/* ------------------- */
7122/* NCOEFU: Table des Nbres de coeff. significatifs en u des carreaux */
7123/* calcules. */
7124/* NCOEFV: Table des Nbres de coeff. significatifs en v des carreaux */
7125/* calcules. */
7126
7127/* COMMONS UTILISES : */
7128/* ---------------- */
7129
7130/* REFERENCES APPELEES : */
7131/* ----------------------- */
7132
7133/* DESCRIPTION/REMARQUES/LIMITATIONS : */
7134/* ----------------------------------- */
7135
7136/* $ HISTORIQUE DES MODIFICATIONS : */
7137/* -------------------------------- */
7138/* 15-07-1996: JCT/RBD; Initialisation de TOL quand on reduit */
7139/* le degre uniquement en V */
7140/* 14-02-1992: RBD; Creation. */
7141/* > */
7142/* **********************************************************************
7143*/
7144
7145/* Le nom de la routine */
7146
7147
7148 /* Parameter adjustments */
7149 epsfro_dim1 = *nbsesp;
7150 epsfro_offset = epsfro_dim1 * 5 + 1;
7151 epsfro -= epsfro_offset;
7152 --epsapr;
7153 --ndimse;
7154 ncoefv_dim1 = *nbupat;
7155 ncoefv_offset = ncoefv_dim1 + 1;
7156 ncoefv -= ncoefv_offset;
7157 ncoefu_dim1 = *nbupat;
7158 ncoefu_offset = ncoefu_dim1 + 1;
7159 ncoefu -= ncoefu_offset;
7160 errmax_dim1 = *nbsesp;
7161 errmax_dim2 = *nbupat;
7162 errmax_offset = errmax_dim1 * (errmax_dim2 + 1) + 1;
7163 errmax -= errmax_offset;
7164 patcan_dim1 = *ncfmxu;
7165 patcan_dim2 = *ncfmxv;
7166 patcan_dim3 = *ndimen;
7167 patcan_dim4 = *nbupat;
7168 patcan_offset = patcan_dim1 * (patcan_dim2 * (patcan_dim3 * (patcan_dim4
7169 + 1) + 1) + 1) + 1;
7170 patcan -= patcan_offset;
7171
7172 /* Function Body */
7173 ibb = AdvApp2Var_SysBase::mnfndeb_();
7174 if (ibb >= 3) {
7175 AdvApp2Var_SysBase::mgenmsg_("MMA2FX6", 7L);
7176 }
7177
7178
7179 i__1 = *nbvpat;
7180 for (jj = 1; jj <= i__1; ++jj) {
7181 i__2 = *nbupat;
7182 for (ii = 1; ii <= i__2; ++ii) {
7183 ncfu = ncoefu[ii + jj * ncoefu_dim1];
7184 ncfv = ncoefv[ii + jj * ncoefv_dim1];
7185
7186/* **************************************************************
7187******** */
7188/* -------------------- Reduction du degre en U -----------------
7189-------- */
7190/* **************************************************************
7191******** */
7192
7193L200:
7194 if (ncfu <= (*iordru + 1) << 1 && ncfu > 2) {
7195
7196 idim = 0;
7197 i__3 = *nbsesp;
7198 for (ns = 1; ns <= i__3; ++ns) {
7199 tol = epsapr[ns];
7200/* Computing MIN */
7201 d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 9];
7202 tol = min(d__1,d__2);
7203/* Computing MIN */
7204 d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 10];
7205 tol = min(d__1,d__2);
7206/* Computing MIN */
7207 d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 11];
7208 tol = min(d__1,d__2);
7209/* Computing MIN */
7210 d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 12];
7211 tol = min(d__1,d__2);
7212 if (ii == 1 || ii == *nbupat || jj == 1 || jj == *nbvpat)
7213 {
7214/* Computing MIN */
7215 d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 5];
7216 tol = min(d__1,d__2);
7217/* Computing MIN */
7218 d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 6];
7219 tol = min(d__1,d__2);
7220/* Computing MIN */
7221 d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 7];
7222 tol = min(d__1,d__2);
7223/* Computing MIN */
7224 d__1 = tol, d__2 = epsfro[ns + (epsfro_dim1 << 3)];
7225 tol = min(d__1,d__2);
7226 }
7227 bid = 0.;
7228
7229 i__4 = ndimse[ns];
7230 for (nd = 1; nd <= i__4; ++nd) {
7231 id = idim + nd;
7232 i__5 = ncfv;
7233 for (kv = 1; kv <= i__5; ++kv) {
7234 bid += (d__1 = patcan[ncfu + (kv + (id + (ii + jj
7235 * patcan_dim4) * patcan_dim3) *
7236 patcan_dim2) * patcan_dim1], abs(d__1));
7237/* L230: */
7238 }
7239/* L220: */
7240 }
7241
7242 if (bid > tol * 1e-6 || bid > errmax[ns + (ii + jj *
7243 errmax_dim2) * errmax_dim1]) {
7244 goto L300;
7245 }
7246 idim += ndimse[ns];
7247/* L210: */
7248 }
7249
7250 --ncfu;
7251 goto L200;
7252 }
7253
7254/* **************************************************************
7255******** */
7256/* -------------------- Reduction du degre en V -----------------
7257-------- */
7258/* **************************************************************
7259******** */
7260
7261L300:
7262 if (ncfv <= (*iordrv + 1) << 1 && ncfv > 2) {
7263
7264 idim = 0;
7265 i__3 = *nbsesp;
7266 for (ns = 1; ns <= i__3; ++ns) {
7267 tol = epsapr[ns];
7268/* Computing MIN */
7269 d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 9];
7270 tol = min(d__1,d__2);
7271/* Computing MIN */
7272 d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 10];
7273 tol = min(d__1,d__2);
7274/* Computing MIN */
7275 d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 11];
7276 tol = min(d__1,d__2);
7277/* Computing MIN */
7278 d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 12];
7279 tol = min(d__1,d__2);
7280 if (ii == 1 || ii == *nbupat || jj == 1 || jj == *nbvpat)
7281 {
7282/* Computing MIN */
7283 d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 5];
7284 tol = min(d__1,d__2);
7285/* Computing MIN */
7286 d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 6];
7287 tol = min(d__1,d__2);
7288/* Computing MIN */
7289 d__1 = tol, d__2 = epsfro[ns + epsfro_dim1 * 7];
7290 tol = min(d__1,d__2);
7291/* Computing MIN */
7292 d__1 = tol, d__2 = epsfro[ns + (epsfro_dim1 << 3)];
7293 tol = min(d__1,d__2);
7294 }
7295 bid = 0.;
7296
7297 i__4 = ndimse[ns];
7298 for (nd = 1; nd <= i__4; ++nd) {
7299 id = idim + nd;
7300 i__5 = ncfu;
7301 for (ku = 1; ku <= i__5; ++ku) {
7302 bid += (d__1 = patcan[ku + (ncfv + (id + (ii + jj
7303 * patcan_dim4) * patcan_dim3) *
7304 patcan_dim2) * patcan_dim1], abs(d__1));
7305/* L330: */
7306 }
7307/* L320: */
7308 }
7309
7310 if (bid > tol * 1e-6 || bid > errmax[ns + (ii + jj *
7311 errmax_dim2) * errmax_dim1]) {
7312 goto L400;
7313 }
7314 idim += ndimse[ns];
7315/* L310: */
7316 }
7317
7318 --ncfv;
7319 goto L300;
7320 }
7321
7322/* --- On recupere les nbres de coeff. et on passe au carreau suiv
7323ant --- */
7324
7325L400:
7326 ncoefu[ii + jj * ncoefu_dim1] = max(ncfu,2);
7327 ncoefv[ii + jj * ncoefv_dim1] = max(ncfv,2);
7328/* L110: */
7329 }
7330/* L100: */
7331 }
7332
7333/* ------------------------------ The End -------------------------------
7334*/
7335
7336 if (ibb >= 3) {
7337 AdvApp2Var_SysBase::mgsomsg_("MMA2FX6", 7L);
7338 }
7339
7340 return 0 ;
7341} /* mma2fx6_ */
7342
7343//=======================================================================
7344//function : mma2jmx_
7345//purpose :
7346//=======================================================================
7347int AdvApp2Var_ApproxF2var::mma2jmx_(integer *ndgjac,
7348 integer *iordre,
7349 doublereal *xjacmx)
7350{
7351 /* Initialized data */
7352
7353 static doublereal xmax2[57] = { .9682458365518542212948163499456,
7354 .986013297183269340427888048593603,
7355 1.07810420343739860362585159028115,
7356 1.17325804490920057010925920756025,
7357 1.26476561266905634732910520370741,
7358 1.35169950227289626684434056681946,
7359 1.43424378958284137759129885012494,
7360 1.51281316274895465689402798226634,
7361 1.5878364329591908800533936587012,
7362 1.65970112228228167018443636171226,
7363 1.72874345388622461848433443013543,
7364 1.7952515611463877544077632304216,
7365 1.85947199025328260370244491818047,
7366 1.92161634324190018916351663207101,
7367 1.98186713586472025397859895825157,
7368 2.04038269834980146276967984252188,
7369 2.09730119173852573441223706382076,
7370 2.15274387655763462685970799663412,
7371 2.20681777186342079455059961912859,
7372 2.25961782459354604684402726624239,
7373 2.31122868752403808176824020121524,
7374 2.36172618435386566570998793688131,
7375 2.41117852396114589446497298177554,
7376 2.45964731268663657873849811095449,
7377 2.50718840313973523778244737914028,
7378 2.55385260994795361951813645784034,
7379 2.59968631659221867834697883938297,
7380 2.64473199258285846332860663371298,
7381 2.68902863641518586789566216064557,
7382 2.73261215675199397407027673053895,
7383 2.77551570192374483822124304745691,
7384 2.8177699459714315371037628127545,
7385 2.85940333797200948896046563785957,
7386 2.90044232019793636101516293333324,
7387 2.94091151970640874812265419871976,
7388 2.98083391718088702956696303389061,
7389 3.02023099621926980436221568258656,
7390 3.05912287574998661724731962377847,
7391 3.09752842783622025614245706196447,
7392 3.13546538278134559341444834866301,
7393 3.17295042316122606504398054547289,
7394 3.2099992681699613513775259670214,
7395 3.24662674946606137764916854570219,
7396 3.28284687953866689817670991319787,
7397 3.31867291347259485044591136879087,
7398 3.35411740487202127264475726990106,
7399 3.38919225660177218727305224515862,
7400 3.42390876691942143189170489271753,
7401 3.45827767149820230182596660024454,
7402 3.49230918177808483937957161007792,
7403 3.5260130200285724149540352829756,
7404 3.55939845146044235497103883695448,
7405 3.59247431368364585025958062194665,
7406 3.62524904377393592090180712976368,
7407 3.65773070318071087226169680450936,
7408 3.68992700068237648299565823810245,
7409 3.72184531357268220291630708234186 };
7410 static doublereal xmax4[55] = { 1.1092649593311780079813740546678,
7411 1.05299572648705464724876659688996,
7412 1.0949715351434178709281698645813,
7413 1.15078388379719068145021100764647,
7414 1.2094863084718701596278219811869,
7415 1.26806623151369531323304177532868,
7416 1.32549784426476978866302826176202,
7417 1.38142537365039019558329304432581,
7418 1.43575531950773585146867625840552,
7419 1.48850442653629641402403231015299,
7420 1.53973611681876234549146350844736,
7421 1.58953193485272191557448229046492,
7422 1.63797820416306624705258190017418,
7423 1.68515974143594899185621942934906,
7424 1.73115699602477936547107755854868,
7425 1.77604489805513552087086912113251,
7426 1.81989256661534438347398400420601,
7427 1.86276344480103110090865609776681,
7428 1.90471563564740808542244678597105,
7429 1.94580231994751044968731427898046,
7430 1.98607219357764450634552790950067,
7431 2.02556989246317857340333585562678,
7432 2.06433638992049685189059517340452,
7433 2.10240936014742726236706004607473,
7434 2.13982350649113222745523925190532,
7435 2.17661085564771614285379929798896,
7436 2.21280102016879766322589373557048,
7437 2.2484214321456956597803794333791,
7438 2.28349755104077956674135810027654,
7439 2.31805304852593774867640120860446,
7440 2.35210997297725685169643559615022,
7441 2.38568889602346315560143377261814,
7442 2.41880904328694215730192284109322,
7443 2.45148841120796359750021227795539,
7444 2.48374387161372199992570528025315,
7445 2.5155912654873773953959098501893,
7446 2.54704548720896557684101746505398,
7447 2.57812056037881628390134077704127,
7448 2.60882970619319538196517982945269,
7449 2.63918540521920497868347679257107,
7450 2.66919945330942891495458446613851,
7451 2.69888301230439621709803756505788,
7452 2.72824665609081486737132853370048,
7453 2.75730041251405791603760003778285,
7454 2.78605380158311346185098508516203,
7455 2.81451587035387403267676338931454,
7456 2.84269522483114290814009184272637,
7457 2.87060005919012917988363332454033,
7458 2.89823818258367657739520912946934,
7459 2.92561704377132528239806135133273,
7460 2.95274375377994262301217318010209,
7461 2.97962510678256471794289060402033,
7462 3.00626759936182712291041810228171,
7463 3.03267744830655121818899164295959,
7464 3.05886060707437081434964933864149 };
7465 static doublereal xmax6[53] = { 1.21091229812484768570102219548814,
7466 1.11626917091567929907256116528817,
7467 1.1327140810290884106278510474203,
7468 1.1679452722668028753522098022171,
7469 1.20910611986279066645602153641334,
7470 1.25228283758701572089625983127043,
7471 1.29591971597287895911380446311508,
7472 1.3393138157481884258308028584917,
7473 1.3821288728999671920677617491385,
7474 1.42420414683357356104823573391816,
7475 1.46546895108549501306970087318319,
7476 1.50590085198398789708599726315869,
7477 1.54550385142820987194251585145013,
7478 1.58429644271680300005206185490937,
7479 1.62230484071440103826322971668038,
7480 1.65955905239130512405565733793667,
7481 1.69609056468292429853775667485212,
7482 1.73193098017228915881592458573809,
7483 1.7671112206990325429863426635397,
7484 1.80166107681586964987277458875667,
7485 1.83560897003644959204940535551721,
7486 1.86898184653271388435058371983316,
7487 1.90180515174518670797686768515502,
7488 1.93410285411785808749237200054739,
7489 1.96589749778987993293150856865539,
7490 1.99721027139062501070081653790635,
7491 2.02806108474738744005306947877164,
7492 2.05846864831762572089033752595401,
7493 2.08845055210580131460156962214748,
7494 2.11802334209486194329576724042253,
7495 2.14720259305166593214642386780469,
7496 2.17600297710595096918495785742803,
7497 2.20443832785205516555772788192013,
7498 2.2325216999457379530416998244706,
7499 2.2602654243075083168599953074345,
7500 2.28768115912702794202525264301585,
7501 2.3147799369092684021274946755348,
7502 2.34157220782483457076721300512406,
7503 2.36806787963276257263034969490066,
7504 2.39427635443992520016789041085844,
7505 2.42020656255081863955040620243062,
7506 2.44586699364757383088888037359254,
7507 2.47126572552427660024678584642791,
7508 2.49641045058324178349347438430311,
7509 2.52130850028451113942299097584818,
7510 2.54596686772399937214920135190177,
7511 2.5703922285006754089328998222275,
7512 2.59459096001908861492582631591134,
7513 2.61856915936049852435394597597773,
7514 2.64233265984385295286445444361827,
7515 2.66588704638685848486056711408168,
7516 2.68923766976735295746679957665724,
7517 2.71238965987606292679677228666411 };
7518
7519 /* System generated locals */
7520 integer i__1;
7521
7522 /* Local variables */
7523 static logical ldbg;
7524 static integer numax, ii;
7525 static doublereal bid;
7526
7527
7528/* **********************************************************************
7529*/
7530
7531/* FONCTION : */
7532/* ---------- */
7533/* Calcule les max des polynomes de Jacobi multiplies par le poids */
7534/* sur (-1,1) pour ordre 0,4,6 ou Legendre. */
7535
7536/* MOTS CLES : */
7537/* ----------- */
7538/* LEGENDRE,APPROXIMATION,ERREUR. */
7539
7540/* ARGUMENTS D'ENTREE : */
7541/* ------------------ */
7542/* NDGJAC: Nbre de coeff. de l'approximation de Jacobi. */
7543/* IORDRE: Ordre de continuite (de -1 a 2) */
7544
7545/* ARGUMENTS DE SORTIE : */
7546/* ------------------- */
7547/* XJACMX: Table des maximums des polynomes de Jacobi. */
7548
7549/* COMMONS UTILISES : */
7550/* ---------------- */
7551
7552/* REFERENCES APPELEES : */
7553/* ----------------------- */
7554
7555/* DESCRIPTION/REMARQUES/LIMITATIONS : */
7556/* ----------------------------------- */
7557
7558/* $ HISTORIQUE DES MODIFICATIONS : */
7559/* -------------------------------- */
7560/* 20-08-1991: RBD; Creation. */
7561/* > */
7562/* ***********************************************************************
7563 */
7564/* Le nom de la routine */
7565/* ----------------------------- Initialisations ------------------------
7566*/
7567
7568 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 3;
7569 if (ldbg) {
7570 AdvApp2Var_SysBase::mgenmsg_("MMA2JMX", 7L);
7571 }
7572
7573 numax = *ndgjac - ((*iordre + 1) << 1);
7574 if (*iordre == -1) {
7575 i__1 = numax;
7576 for (ii = 0; ii <= i__1; ++ii) {
7577 bid = (ii * 2. + 1.) / 2.;
7578 xjacmx[ii] = sqrt(bid);
7579/* L100: */
7580 }
7581 } else if (*iordre == 0) {
7582 i__1 = numax;
7583 for (ii = 0; ii <= i__1; ++ii) {
7584 xjacmx[ii] = xmax2[ii];
7585/* L200: */
7586 }
7587 } else if (*iordre == 1) {
7588 i__1 = numax;
7589 for (ii = 0; ii <= i__1; ++ii) {
7590 xjacmx[ii] = xmax4[ii];
7591/* L400: */
7592 }
7593 } else if (*iordre == 2) {
7594 i__1 = numax;
7595 for (ii = 0; ii <= i__1; ++ii) {
7596 xjacmx[ii] = xmax6[ii];
7597/* L600: */
7598 }
7599 }
7600
7601/* ------------------------- The end ------------------------------------
7602*/
7603
7604 if (ldbg) {
7605 AdvApp2Var_SysBase::mgsomsg_("MMA2JMX", 7L);
7606 }
7607 return 0;
7608} /* mma2jmx_ */
7609
7610//=======================================================================
7611//function : mma2moy_
7612//purpose :
7613//=======================================================================
7614int mma2moy_(integer *ndgumx,
7615 integer *ndgvmx,
7616 integer *ndimen,
7617 integer *mindgu,
7618 integer *maxdgu,
7619 integer *mindgv,
7620 integer *maxdgv,
7621 integer *iordru,
7622 integer *iordrv,
7623 doublereal *patjac,
7624 doublereal *errmoy)
7625{
7626 /* System generated locals */
7627 integer patjac_dim1, patjac_dim2, patjac_offset, i__1, i__2, i__3;
7628
7629 /* Local variables */
7630 static logical ldbg;
7631 static integer minu, minv, idebu, idebv, ii, nd, jj;
7632 static doublereal bid0, bid1;
7633
7634
7635/* **********************************************************************
7636*/
7637
7638/* FONCTION : */
7639/* ---------- */
7640/* Calcule l'erreur moyenne d'approximation faite lorsque l'on ne */
7641/* garde que les coefficients de PATJAC de degre compris entre */
7642/* 2*(IORDRU+1) et MINDGU en U et 2*(IORDRV+1) et MINDGV en V. */
7643
7644/* MOTS CLES : */
7645/* ----------- */
7646/* LEGENDRE,APPROXIMATION,ERREUR MOYENNE */
7647
7648/* ARGUMENTS D'ENTREE : */
7649/* ------------------ */
7650/* NDGUMX: Dimension en U du tableau PATJAC. */
7651/* NDGVMX: Dimension en V du tableau PATJAC. */
7652/* NDIMEN: Dimension de l'espace. */
7653/* MINDGU: Borne inf de l'indice en U des coeff. de PATJAC a prendre
7654*/
7655/* en compte. */
7656/* MAXDGU: Borne sup de l'indice en U des coeff. de PATJAC a prendre
7657*/
7658/* en compte. */
7659/* MINDGV: Borne inf de l'indice en V des coeff. de PATJAC a prendre
7660*/
7661/* en compte. */
7662/* MAXDGV: Borne sup de l'indice en V des coeff. de PATJAC a prendre
7663*/
7664/* en compte. */
7665/* IORDRU: Ordre de continuite en U assure par le carreau PATJAC */
7666/* (de -1 a 2) */
7667/* IORDRV: Ordre de continuite en V assure par le carreau PATJAC */
7668/* (de -1 a 2) */
7669/* PATJAC: Table des coeff. du carreau d'approximation avec */
7670/* contraintes d'ordre IORDRU en U et IORDRV en V. */
7671
7672/* ARGUMENTS DE SORTIE : */
7673/* ------------------- */
7674/* ERRMOY: L'erreur moyenne commise en ne gardant que les coeff de */
7675/* PATJAC 2*(IORDRU+1) a MINDGU en U et 2*(IORDRV+1) a */
7676/* MINDGV en V. */
7677
7678/* COMMONS UTILISES : */
7679/* ---------------- */
7680
7681/* REFERENCES APPELEES : */
7682/* ----------------------- */
7683
7684/* DESCRIPTION/REMARQUES/LIMITATIONS : */
7685/* ----------------------------------- */
7686/* Dans le tableau PATJAC sont stockes les coeff. Cij du carreau */
7687/* d'approximation de F(U,V). Les indices i et j indique le degre en
7688*/
7689/* U et en V des polynomes de base. Ces polynomes de base sont de la
7690*/
7691/* forme: */
7692
7693/* ((1 - U*U)**(IORDRU+1)).J(i-2*(IORDRU+1)(U), ou */
7694
7695/* le polynome J(i-2*(IORDU+1)(U) est le polynome de Jacobi d'ordre */
7696/* IORDRU+1 (idem en V en remplacant U par V dans l'expression ci */
7697/* dessus). */
7698
7699/* La contribution a l'erreur moyenne du terme Cij lorsque */
7700/* celui-ci est enleve de PATJAC est Cij*Cij. */
7701
7702
7703/* $ HISTORIQUE DES MODIFICATIONS : */
7704/* -------------------------------- */
7705/* 13-06-1991: RBD; Creation. */
7706/* > */
7707/* ***********************************************************************
7708 */
7709/* Le nom de la routine */
7710
7711
7712/* ----------------------------- Initialisations ------------------------
7713*/
7714
7715 /* Parameter adjustments */
7716 patjac_dim1 = *ndgumx + 1;
7717 patjac_dim2 = *ndgvmx + 1;
7718 patjac_offset = patjac_dim1 * patjac_dim2;
7719 patjac -= patjac_offset;
7720
7721 /* Function Body */
7722 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 3;
7723 if (ldbg) {
7724 AdvApp2Var_SysBase::mgenmsg_("MMA2MOY", 7L);
7725 }
7726
7727 idebu = (*iordru + 1) << 1;
7728 idebv = (*iordrv + 1) << 1;
7729 minu = max(idebu,*mindgu);
7730 minv = max(idebv,*mindgv);
7731 bid0 = 0.;
7732 *errmoy = 0.;
7733
7734/* ------------------ Calcul du majorant de l'erreur moyenne ------------
7735*/
7736/* ----- lorsque sont enleves les coeff. d'indices MINDGU a MAXDGU ------
7737*/
7738/* ---------------- en U et d'indices MINDGV a MAXDGV en V --------------
7739*/
7740
7741 i__1 = *ndimen;
7742 for (nd = 1; nd <= i__1; ++nd) {
7743 i__2 = *maxdgv;
7744 for (jj = minv; jj <= i__2; ++jj) {
7745 i__3 = *maxdgu;
7746 for (ii = idebu; ii <= i__3; ++ii) {
7747 bid1 = patjac[ii + (jj + nd * patjac_dim2) * patjac_dim1];
7748 bid0 += bid1 * bid1;
7749/* L300: */
7750 }
7751/* L200: */
7752 }
7753/* L100: */
7754 }
7755
7756 i__1 = *ndimen;
7757 for (nd = 1; nd <= i__1; ++nd) {
7758 i__2 = minv - 1;
7759 for (jj = idebv; jj <= i__2; ++jj) {
7760 i__3 = *maxdgu;
7761 for (ii = minu; ii <= i__3; ++ii) {
7762 bid1 = patjac[ii + (jj + nd * patjac_dim2) * patjac_dim1];
7763 bid0 += bid1 * bid1;
7764/* L600: */
7765 }
7766/* L500: */
7767 }
7768/* L400: */
7769 }
7770
7771/* ----------------------- Calcul de l'erreur moyenne -------------------
7772*/
7773
7774 bid0 /= 4;
7775 *errmoy = sqrt(bid0);
7776
7777/* ------------------------- The end ------------------------------------
7778*/
7779
7780 if (ldbg) {
7781 AdvApp2Var_SysBase::mgsomsg_("MMA2MOY", 7L);
7782 }
7783 return 0;
7784} /* mma2moy_ */
7785
7786//=======================================================================
7787//function : mma2roo_
7788//purpose :
7789//=======================================================================
7790int AdvApp2Var_ApproxF2var::mma2roo_(integer *nbpntu,
7791 integer *nbpntv,
7792 doublereal *urootl,
7793 doublereal *vrootl)
7794{
7795 /* System generated locals */
7796 integer i__1;
7797
7798 /* Local variables */
7799 static integer ii, ibb;
7800
7801/* **********************************************************************
7802*/
7803
7804/* FONCTION : */
7805/* ---------- */
7806/* Recuperation des racines de Legendre pour les discretisations. */
7807
7808/* MOTS CLES : */
7809/* ----------- */
7810/* TOUS, AB_SPECIFI::CONTRAINTE&, DISCRETISATION, &POINT */
7811
7812/* ARGUMENTS D'ENTREE : */
7813/* ------------------ */
7814/* NBPNTU: Nbre de parametres INTERNES de discretisation EN U. */
7815/* C'est aussi le nbre de racine du polynome de Legendre ou */
7816/* on discretise. */
7817/* NBPNTV: Nbre de parametres INTERNES de discretisation EN V. */
7818/* C'est aussi le nbre de racine du polynome de Legendre ou */
7819/* on discretise. */
7820
7821/* ARGUMENTS DE SORTIE : */
7822/* ------------------- */
7823/* UROOTL: Tableau des parametres de discretisation SUR (-1,1) EN U.
7824*/
7825/* VROOTL: Tableau des parametres de discretisation SUR (-1,1) EN V.
7826*/
7827
7828/* COMMONS UTILISES : */
7829/* ---------------- */
7830
7831/* REFERENCES APPELEES : */
7832/* ----------------------- */
7833
7834/* DESCRIPTION/REMARQUES/LIMITATIONS : */
7835/* ----------------------------------- */
7836
7837/* $ HISTORIQUE DES MODIFICATIONS : */
7838/* -------------------------------- */
7839/* 02-07-1991: RBD; Creation. */
7840/* > */
7841/* **********************************************************************
7842*/
7843
7844/* Le nom de la routine */
7845
7846
7847 /* Parameter adjustments */
7848 --urootl;
7849 --vrootl;
7850
7851 /* Function Body */
7852 ibb = AdvApp2Var_SysBase::mnfndeb_();
7853 if (ibb >= 3) {
7854 AdvApp2Var_SysBase::mgenmsg_("MMA2ROO", 7L);
7855 }
7856
7857/* ---------------- Recup des racines POSITIVES sur U ------------------
7858*/
7859
7860 AdvApp2Var_MathBase::mmrtptt_(nbpntu, &urootl[(*nbpntu + 1) / 2 + 1]);
7861 i__1 = *nbpntu / 2;
7862 for (ii = 1; ii <= i__1; ++ii) {
7863 urootl[ii] = -urootl[*nbpntu - ii + 1];
7864/* L100: */
7865 }
7866 if (*nbpntu % 2 == 1) {
7867 urootl[*nbpntu / 2 + 1] = 0.;
7868 }
7869
7870/* ---------------- Recup des racines POSITIVES sur V ------------------
7871*/
7872
7873 AdvApp2Var_MathBase::mmrtptt_(nbpntv, &vrootl[(*nbpntv + 1) / 2 + 1]);
7874 i__1 = *nbpntv / 2;
7875 for (ii = 1; ii <= i__1; ++ii) {
7876 vrootl[ii] = -vrootl[*nbpntv - ii + 1];
7877/* L110: */
7878 }
7879 if (*nbpntv % 2 == 1) {
7880 vrootl[*nbpntv / 2 + 1] = 0.;
7881 }
7882
7883/* ------------------------------ The End -------------------------------
7884*/
7885
7886 if (ibb >= 3) {
7887 AdvApp2Var_SysBase::mgsomsg_("MMA2ROO", 7L);
7888 }
7889 return 0;
7890} /* mma2roo_ */
7891//=======================================================================
7892//function : mmmapcoe_
7893//purpose :
7894//=======================================================================
7895int mmmapcoe_(integer *ndim,
7896 integer *ndgjac,
7897 integer *iordre,
7898 integer *nbpnts,
7899 doublereal *somtab,
7900 doublereal *diftab,
7901 doublereal *gsstab,
7902 doublereal *crvjac)
7903
7904{
7905 /* System generated locals */
7906 integer somtab_dim1, somtab_offset, diftab_dim1, diftab_offset,
7907 crvjac_dim1, crvjac_offset, gsstab_dim1, i__1, i__2, i__3;
7908
7909 /* Local variables */
7910 static integer igss, ikdeb;
7911 static doublereal bidon;
7912 static integer nd, ik, ir, nbroot, ibb;
7913
7914
7915
7916/* **********************************************************************
7917*/
7918
7919/* FONCTION : */
7920/* ---------- */
7921/* Calcul des coefficients de la courbe d' approximation polynomiale
7922*/
7923/* de degre NDGJAC par la methode des moindres carres a partir de la
7924*/
7925/* discretisation de la fonction sur les racines du polynome de */
7926/* Legendre de degre NBPNTS. */
7927
7928/* MOTS CLES : */
7929/* ----------- */
7930/* FONCTION,APPROXIMATION,COEFFICIENT,POLYNOME */
7931
7932/* ARGUMENTS D'ENTREE : */
7933/* ------------------ */
7934/* NDIM : Dimension de l' espace. */
7935/* NDGJAC : Degre maxi du polynome d' approximation. La */
7936/* representation dans la base orthogonale part du degre
7937*/
7938/* 0 au degre NDGJAC-2*(JORDRE+1). La base polynomiale */
7939/* est la base de Jacobi d' ordre -1 (Legendre), 0, 1 */
7940/* et 2 */
7941/* IORDRE : Ordre de la base de Jacobi (-1,0,1 ou 2). Correspond */
7942/* a pas de contraintes, contraintes C0,C1 ou C2. */
7943/* NBPNTS : Degre du polynome de Legendre sur les racines duquel */
7944/* sont calcules les coefficients d' integration par la */
7945/* methode de Gauss. On doit avoir NBPNTS=30,40,50 ou 61
7946*/
7947/* et NDGJAC < NBPNTS. */
7948/* SOMTAB : Tableau de F(ti)+F(-ti) avec ti dans ROOTAB. */
7949/* DIFTAB : Tableau de F(ti)-F(-ti) avec ti dans ROOTAB. */
7950/* GSSTAB(i,k) : Table des coefficients d' integration par la */
7951/* methode de Gauss : i varie de 0 a NBPNTS et */
7952/* k varie de 0 a NDGJAC-2*(JORDRE+1). */
7953
7954/* ARGUMENTS DE SORTIE : */
7955/* ------------------- */
7956/* CRVJAC : Courbe d' approximation de FONCNP avec eventuellement
7957*/
7958/* prise en compte des contraintes aux extremites. */
7959/* Cette courbe est de degre NDGJAC. */
7960
7961/* COMMONS UTILISES : */
7962/* ---------------- */
7963
7964/* REFERENCES APPELEES : */
7965/* ----------------------- */
7966
7967/* DESCRIPTION/REMARQUES/LIMITATIONS : */
7968/* ----------------------------------- */
7969
7970/* $ HISTORIQUE DES MODIFICATIONS : */
7971/* -------------------------------- */
7972/* 11-04-1989 : RBD ; Creation. */
7973/* > */
7974/* **********************************************************************
7975*/
7976
7977/* Le nom de la routine */
7978
7979 /* Parameter adjustments */
7980 crvjac_dim1 = *ndgjac + 1;
7981 crvjac_offset = crvjac_dim1;
7982 crvjac -= crvjac_offset;
7983 gsstab_dim1 = *nbpnts / 2 + 1;
7984 diftab_dim1 = *nbpnts / 2 + 1;
7985 diftab_offset = diftab_dim1;
7986 diftab -= diftab_offset;
7987 somtab_dim1 = *nbpnts / 2 + 1;
7988 somtab_offset = somtab_dim1;
7989 somtab -= somtab_offset;
7990
7991 /* Function Body */
7992 ibb = AdvApp2Var_SysBase::mnfndeb_();
7993 if (ibb >= 2) {
7994 AdvApp2Var_SysBase::mgenmsg_("MMMAPCO", 7L);
7995 }
7996 ikdeb = (*iordre + 1) << 1;
7997 nbroot = *nbpnts / 2;
7998
7999 i__1 = *ndim;
8000 for (nd = 1; nd <= i__1; ++nd) {
8001
8002/* ----------------- Calcul des coefficients de degre pair ----------
8003---- */
8004
8005 i__2 = *ndgjac;
8006 for (ik = ikdeb; ik <= i__2; ik += 2) {
8007 igss = ik - ikdeb;
8008 bidon = 0.;
8009 i__3 = nbroot;
8010 for (ir = 1; ir <= i__3; ++ir) {
8011 bidon += somtab[ir + nd * somtab_dim1] * gsstab[ir + igss *
8012 gsstab_dim1];
8013/* L300: */
8014 }
8015 crvjac[ik + nd * crvjac_dim1] = bidon;
8016/* L200: */
8017 }
8018
8019/* --------------- Calcul des coefficients de degre impair ----------
8020---- */
8021
8022 i__2 = *ndgjac;
8023 for (ik = ikdeb + 1; ik <= i__2; ik += 2) {
8024 igss = ik - ikdeb;
8025 bidon = 0.;
8026 i__3 = nbroot;
8027 for (ir = 1; ir <= i__3; ++ir) {
8028 bidon += diftab[ir + nd * diftab_dim1] * gsstab[ir + igss *
8029 gsstab_dim1];
8030/* L500: */
8031 }
8032 crvjac[ik + nd * crvjac_dim1] = bidon;
8033/* L400: */
8034 }
8035
8036/* L100: */
8037 }
8038
8039/* ------- Ajout des termes lies a la racine supplementaire (0.D0) ------
8040*/
8041/* ----------- du polynome de Legendre de degre impair NBPNTS -----------
8042*/
8043
8044 if (*nbpnts % 2 == 0) {
8045 goto L9999;
8046 }
8047 i__1 = *ndim;
8048 for (nd = 1; nd <= i__1; ++nd) {
8049 i__2 = *ndgjac;
8050 for (ik = ikdeb; ik <= i__2; ik += 2) {
8051 igss = ik - ikdeb;
8052 crvjac[ik + nd * crvjac_dim1] += somtab[nd * somtab_dim1] *
8053 gsstab[igss * gsstab_dim1];
8054/* L700: */
8055 }
8056/* L600: */
8057 }
8058
8059/* ------------------------------ The end -------------------------------
8060*/
8061
8062L9999:
8063 if (ibb >= 2) {
8064 AdvApp2Var_SysBase::mgsomsg_("MMMAPCO", 7L);
8065 }
8066 return 0;
8067} /* mmmapcoe_ */
8068//=======================================================================
8069//function : mmaperm_
8070//purpose :
8071//=======================================================================
8072int mmaperm_(integer *ncofmx,
8073 integer *ndim,
8074 integer *ncoeff,
8075 integer *iordre,
8076 doublereal *crvjac,
8077 integer *ncfnew,
8078 doublereal *errmoy)
8079{
8080 /* System generated locals */
8081 integer crvjac_dim1, crvjac_offset, i__1, i__2;
8082
8083 /* Local variables */
8084 static doublereal bidj;
8085 static integer i__, ia, nd, ncfcut, ibb;
8086 static doublereal bid;
8087
8088
8089
8090/* **********************************************************************
8091*/
8092
8093/* FONCTION : */
8094/* ---------- */
8095/* Calcule la racine carree de l' erreur quadratique moyenne */
8096/* d' approximation faite lorsque l' on ne conserve que les */
8097/* premiers NCFNEW coefficients d' une courbe de degre NCOEFF-1 */
8098/* ecrite dans la base de Jacobi NORMALISEE d' ordre */
8099/* 2*(IORDRE+1). */
8100
8101/* MOTS CLES : */
8102/* ----------- */
8103/* LEGENDRE,POLYGONE,APPROXIMATION,ERREUR. */
8104
8105/* ARGUMENTS D'ENTREE : */
8106/* ------------------ */
8107/* NCOFMX : Degre maximum de la courbe. */
8108/* NDIM : Dimension de l' espace. */
8109/* NCOEFF : Le degre +1 de la courbe. */
8110/* IORDRE : Ordre de contrainte de continuite aux extremites. */
8111/* CRVJAC : La courbe dont on veut baisser le degre. */
8112/* NCFNEW : Le degre +1 du polynome resultat. */
8113
8114/* ARGUMENTS DE SORTIE : */
8115/* ------------------- */
8116/* ERRMOY : La precision moyenne de l' approximation. */
8117
8118/* COMMONS UTILISES : */
8119/* ---------------- */
8120
8121/* REFERENCES APPELEES : */
8122/* ----------------------- */
8123
8124/* DESCRIPTION/REMARQUES/LIMITATIONS : */
8125/* ----------------------------------- */
8126
8127/* $ HISTORIQUE DES MODIFICATIONS : */
8128/* -------------------------------- */
8129/* 23-12-1989 : RBD ; Creation */
8130
8131/* > */
8132/* ***********************************************************************
8133 */
8134
8135/* Le nom de la routine */
8136
8137 /* Parameter adjustments */
8138 crvjac_dim1 = *ncofmx;
8139 crvjac_offset = crvjac_dim1 + 1;
8140 crvjac -= crvjac_offset;
8141
8142 /* Function Body */
8143 ibb = AdvApp2Var_SysBase::mnfndeb_();
8144 if (ibb >= 2) {
8145 AdvApp2Var_SysBase::mgenmsg_("MMAPERM", 7L);
8146 }
8147
8148/* --------- Degre minimum pouvant etre atteint : Arret a 1 ou IA -------
8149*/
8150
8151 ia = (*iordre + 1) << 1;
8152 ncfcut = ia + 1;
8153 if (*ncfnew + 1 > ncfcut) {
8154 ncfcut = *ncfnew + 1;
8155 }
8156
8157/* -------------- Elimination des coefficients de haut degre ------------
8158*/
8159/* ----------- Boucle sur la serie de Jacobi :NCFCUT --> NCOEFF ---------
8160*/
8161
8162 *errmoy = 0.;
8163 bid = 0.;
8164 i__1 = *ndim;
8165 for (nd = 1; nd <= i__1; ++nd) {
8166 i__2 = *ncoeff;
8167 for (i__ = ncfcut; i__ <= i__2; ++i__) {
8168 bidj = crvjac[i__ + nd * crvjac_dim1];
8169 bid += bidj * bidj;
8170/* L200: */
8171 }
8172/* L100: */
8173 }
8174
8175/* ----------- Racine carree de l' erreur quadratique moyenne -----------
8176*/
8177
8178 bid /= 2.;
8179 *errmoy = sqrt(bid);
8180
8181/* ------------------------------- The end ------------------------------
8182*/
8183
8184 if (ibb >= 2) {
8185 AdvApp2Var_SysBase::mgsomsg_("MMAPERM", 7L);
8186 }
8187 return 0;
8188} /* mmaperm_ */
8189//=======================================================================
8190//function : mmapptt_
8191//purpose :
8192//=======================================================================
8193int AdvApp2Var_ApproxF2var::mmapptt_(const integer *ndgjac,
8194 const integer *nbpnts,
8195 const integer *jordre,
8196 doublereal *cgauss,
8197 integer *iercod)
8198{
8199 /* System generated locals */
8200 integer cgauss_dim1, i__1;
8201
8202 /* Local variables */
8203 static integer kjac, iptt, ipdb0, infdg, iptdb, mxjac, ilong, ibb;
8204
8205
8206
8207/* **********************************************************************
8208*/
8209
8210/* FONCTION : */
8211/* ---------- */
8212/* Charge les elements necessaires a une integration par la */
8213/* methode de Gauss pour obtenir les coefficients dans la base de
8214*/
8215/* Legendre de l' approximation par les moindres carres d' une */
8216/* fonction. les elements sont stockes dans les communs MMAPGSS */
8217/* (cas sans contrainte), MMAPGS0 (contraintes C0), MMAPGS1 */
8218/* (contraintes C1) et MMAPGS2 (contraintes C2). */
8219
8220/* MOTS CLES : */
8221/* ----------- */
8222/* INTEGRATION,GAUSS,JACOBI */
8223
8224/* ARGUMENTS D'ENTREE : */
8225/* ------------------ */
8226/* NDGJAC : Degre maxi du polynome d' approximation. La */
8227/* representation dans la base orthogonale part du degre
8228*/
8229/* 0 au degre NDGJAC-2*(JORDRE+1). La base polynomiale */
8230/* est la base de Jacobi d' ordre -1 (Legendre), 0, 1 */
8231/* et 2 */
8232/* NBPNTS : Degre du polynome de Legendre sur les racines duquel */
8233/* sont calcules les coefficients d' integration par la */
8234/* methode de Gauss. On doit avoir NBPNTS=8,10,15,20,25,
8235*/
8236/* 30,40,50 ou 61 et NDGJAC < NBPNTS. */
8237/* JORDRE : Ordre de la base de Jacobi (-1,0,1 ou 2). Correspond */
8238/* a pas de contraintes, contraintes C0,C1 ou C2. */
8239
8240/* ARGUMENTS DE SORTIE : */
8241/* ------------------- */
8242/* CGAUSS(i,k) : Table des coefficients d' integration par la */
8243/* methode de Gauss : i varie de 0 a la partie */
8244/* entiere de NBPNTS/2 et k varie de 0 a */
8245/* NDGJAC-2*(JORDRE+1). */
8246/* Ce sont donc les coeff. d'integration associes */
8247/* aux racines positives du polynome de Legendre de
8248*/
8249/* degre NBPNTS. CGAUSS(0,k) contient les coeff. */
8250/* d'integration associes a la racine t = 0 lorsque
8251*/
8252/* NBPNTS est impair. */
8253/* IERCOD : Code d' erreur. */
8254/* = 0 OK, */
8255/* = 11 NBPNTS ne vaut pas 8,10,15,20,25,30,40,50 ou 61.
8256*/
8257/* = 21 JORDRE ne vaut pas -1,0,1 ou 2. */
8258/* = 31 NDGJAC est trop grand ou trop petit. */
8259
8260/* COMMONS UTILISES : */
8261/* ---------------- */
8262/* MMAPGSS,MMAPGS0,MMAPGS1,MMAPGS2. */
8263
8264/* REFERENCES APPELEES : */
8265/* ----------------------- */
8266
8267/* DESCRIPTION/REMARQUES/LIMITATIONS : */
8268/* ----------------------------------- */
8269
8270/* $ HISTORIQUE DES MODIFICATIONS : */
8271/* -------------------------------- */
8272/* 12-03-93 : MPS ; Ajout des valeurs 8,10,15,20,25 pour */
8273/* le nombre de points d'integration */
8274/* 13-05-91 : RBD ; Ajout commentaires. */
8275/* 03-03-90 : NAK ; Includes. */
8276/* 21-04-87 : RBD ; Creation. */
8277/* > */
8278/* **********************************************************************
8279*/
8280/* Le nom de la routine */
8281
8282
8283/* ***********************************************************************
8284 */
8285
8286/* FONCTION : */
8287/* ---------- */
8288
8289/* MOTS CLES : */
8290/* ----------- */
8291
8292/* DEMSCRIPTION/REMARQUES/LIMITATIONS : */
8293/* ----------------------------------- */
8294/* INITIALISATION : BLOCK DATA */
8295/* FONCTION D'ACCES SEULEMENT : MMAPPTT */
8296
8297/* $ HISTORIQUE DES MODIFICATIONS : */
8298/* ------------------------------ */
8299/* 12-03-93 : MPS ; Modification des parametres IPTGSS et IP0GSS */
8300/* 02-03-90 : NAK ; Creation version originale */
8301/* > */
8302
8303/* ***********************************************************************
8304 */
8305
8306/* FONCTION : */
8307/* ---------- */
8308
8309/* MOTS CLES : */
8310/* ----------- */
8311
8312/* DEMSCRIPTION/REMARQUES/LIMITATIONS : */
8313/* ----------------------------------- */
8314/* INITIALISATION : BLOCK DATA */
8315/* FONCTION D'ACCES SEULEMENT : MMAPPTT */
8316
8317/* $ HISTORIQUE DES MODIFICATIONS : */
8318/* ------------------------------ */
8319/* 12-03-93: MPS ; Modification des parametres IPTGS0 et IP0GS0 */
8320/* 02-03-90 : NAK ; Creation version originale */
8321/* > */
8322/* ***********************************************************************
8323 */
8324
8325/* ***********************************************************************
8326 */
8327
8328/* FONCTION : */
8329/* ---------- */
8330
8331/* MOTS CLES : */
8332/* ----------- */
8333
8334/* DEMSCRIPTION/REMARQUES/LIMITATIONS : */
8335/* ----------------------------------- */
8336/* INITIALISATION : BLOCK DATA */
8337/* FONCTION D'ACCES SEULEMENT : MMAPPTT */
8338
8339/* $ HISTORIQUE DES MODIFICATIONS : */
8340/* ------------------------------ */
8341/* 12-03-93 : MPS ; Modification des parametres IPTGS1 etIP0GS1 */
8342/* 02-03-90 : NAK ; Creation version originale */
8343/* > */
8344/* ***********************************************************************
8345 */
8346
8347
8348/* ***********************************************************************
8349 */
8350
8351/* FONCTION : */
8352/* ---------- */
8353
8354/* MOTS CLES : */
8355/* ----------- */
8356
8357/* DEMSCRIPTION/REMARQUES/LIMITATIONS : */
8358/* ----------------------------------- */
8359/* INITIALISATION : BLOCK DATA */
8360/* FONCTION D'ACCES SEULEMENT : MMAPPTT */
8361
8362/* $ HISTORIQUE DES MODIFICATIONS : */
8363/* ------------------------------ */
8364/* 12-03-93 : MPS ; Modification des parametres IPTGS2 et IP0GS2 */
8365/* 02-03-90 : NAK ; Creation version originale */
8366/* > */
8367
8368/* ***********************************************************************
8369 */
8370 /* Parameter adjustments */
8371 cgauss_dim1 = *nbpnts / 2 + 1;
8372
8373 /* Function Body */
8374 ibb = AdvApp2Var_SysBase::mnfndeb_();
8375 if (ibb >= 2) {
8376 AdvApp2Var_SysBase::mgenmsg_("MMAPPTT", 7L);
8377 }
8378 *iercod = 0;
8379
8380/* ------------------- Tests sur la validite des entrees ----------------
8381*/
8382
8383 infdg = (*jordre + 1) << 1;
8384 if (*nbpnts != 8 && *nbpnts != 10 && *nbpnts != 15 && *nbpnts != 20 && *
8385 nbpnts != 25 && *nbpnts != 30 && *nbpnts != 40 && *nbpnts != 50 &&
8386 *nbpnts != 61) {
8387 goto L9100;
8388 }
8389
8390 if (*jordre < -1 || *jordre > 2) {
8391 goto L9200;
8392 }
8393
8394 if (*ndgjac >= *nbpnts || *ndgjac < infdg) {
8395 goto L9300;
8396 }
8397
8398/* --------------- Calcul du pointeur de debut suivant NBPNTS -----------
8399*/
8400
8401 iptdb = 0;
8402 if (*nbpnts > 8) {
8403 iptdb += (8 - infdg) << 2;
8404 }
8405 if (*nbpnts > 10) {
8406 iptdb += (10 - infdg) * 5;
8407 }
8408 if (*nbpnts > 15) {
8409 iptdb += (15 - infdg) * 7;
8410 }
8411 if (*nbpnts > 20) {
8412 iptdb += (20 - infdg) * 10;
8413 }
8414 if (*nbpnts > 25) {
8415 iptdb += (25 - infdg) * 12;
8416 }
8417 if (*nbpnts > 30) {
8418 iptdb += (30 - infdg) * 15;
8419 }
8420 if (*nbpnts > 40) {
8421 iptdb += (40 - infdg) * 20;
8422 }
8423 if (*nbpnts > 50) {
8424 iptdb += (50 - infdg) * 25;
8425 }
8426
8427 ipdb0 = 1;
8428 if (*nbpnts > 15) {
8429 ipdb0 = ipdb0 + (14 - infdg) / 2 + 1;
8430 }
8431 if (*nbpnts > 25) {
8432 ipdb0 = ipdb0 + (24 - infdg) / 2 + 1;
8433 }
8434
8435/* ------------------ Choix du commun en fonction de JORDRE -------------
8436*/
8437
8438 if (*jordre == -1) {
8439 goto L1000;
8440 }
8441 if (*jordre == 0) {
8442 goto L2000;
8443 }
8444 if (*jordre == 1) {
8445 goto L3000;
8446 }
8447 if (*jordre == 2) {
8448 goto L4000;
8449 }
8450
8451/* ---------------- Commun MMAPGSS (cas sans contraintes) ----------------
8452 */
8453
8454L1000:
8455 ilong = *nbpnts / 2 << 3;
8456 i__1 = *ndgjac;
8457 for (kjac = 0; kjac <= i__1; ++kjac) {
8458 iptt = iptdb + kjac * (*nbpnts / 2) + 1;
8459 AdvApp2Var_SysBase::mcrfill_(&ilong,
8460 (char *)&mmapgss_.gslxjs[iptt - 1],
8461 (char *)&cgauss[kjac * cgauss_dim1 + 1]);
8462/* L100: */
8463 }
8464/* --> Cas ou le nbre de points est impair. */
8465 if (*nbpnts % 2 == 1) {
8466 iptt = ipdb0;
8467 i__1 = *ndgjac;
8468 for (kjac = 0; kjac <= i__1; kjac += 2) {
8469 cgauss[kjac * cgauss_dim1] = mmapgss_.gsl0js[iptt - 1];
8470 ++iptt;
8471/* L150: */
8472 }
8473 i__1 = *ndgjac;
8474 for (kjac = 1; kjac <= i__1; kjac += 2) {
8475 cgauss[kjac * cgauss_dim1] = 0.;
8476/* L160: */
8477 }
8478 }
8479 goto L9999;
8480
8481/* ---------------- Commun MMAPGS0 (cas avec contraintes C0) -------------
8482 */
8483
8484L2000:
8485 mxjac = *ndgjac - infdg;
8486 ilong = *nbpnts / 2 << 3;
8487 i__1 = mxjac;
8488 for (kjac = 0; kjac <= i__1; ++kjac) {
8489 iptt = iptdb + kjac * (*nbpnts / 2) + 1;
8490 AdvApp2Var_SysBase::mcrfill_(&ilong,
8491 (char *)&mmapgs0_.gslxj0[iptt - 1],
8492 (char *)&cgauss[kjac * cgauss_dim1 + 1]);
8493/* L200: */
8494 }
8495/* --> Cas ou le nbre de points est impair. */
8496 if (*nbpnts % 2 == 1) {
8497 iptt = ipdb0;
8498 i__1 = mxjac;
8499 for (kjac = 0; kjac <= i__1; kjac += 2) {
8500 cgauss[kjac * cgauss_dim1] = mmapgs0_.gsl0j0[iptt - 1];
8501 ++iptt;
8502/* L250: */
8503 }
8504 i__1 = mxjac;
8505 for (kjac = 1; kjac <= i__1; kjac += 2) {
8506 cgauss[kjac * cgauss_dim1] = 0.;
8507/* L260: */
8508 }
8509 }
8510 goto L9999;
8511
8512/* ---------------- Commun MMAPGS1 (cas avec contraintes C1) -------------
8513 */
8514
8515L3000:
8516 mxjac = *ndgjac - infdg;
8517 ilong = *nbpnts / 2 << 3;
8518 i__1 = mxjac;
8519 for (kjac = 0; kjac <= i__1; ++kjac) {
8520 iptt = iptdb + kjac * (*nbpnts / 2) + 1;
8521 AdvApp2Var_SysBase::mcrfill_(&ilong,
8522 (char *)&mmapgs1_.gslxj1[iptt - 1],
8523 (char *)&cgauss[kjac * cgauss_dim1 + 1]);
8524/* L300: */
8525 }
8526/* --> Cas ou le nbre de points est impair. */
8527 if (*nbpnts % 2 == 1) {
8528 iptt = ipdb0;
8529 i__1 = mxjac;
8530 for (kjac = 0; kjac <= i__1; kjac += 2) {
8531 cgauss[kjac * cgauss_dim1] = mmapgs1_.gsl0j1[iptt - 1];
8532 ++iptt;
8533/* L350: */
8534 }
8535 i__1 = mxjac;
8536 for (kjac = 1; kjac <= i__1; kjac += 2) {
8537 cgauss[kjac * cgauss_dim1] = 0.;
8538/* L360: */
8539 }
8540 }
8541 goto L9999;
8542
8543/* ---------------- Commun MMAPGS2 (cas avec contraintes C2) -------------
8544 */
8545
8546L4000:
8547 mxjac = *ndgjac - infdg;
8548 ilong = *nbpnts / 2 << 3;
8549 i__1 = mxjac;
8550 for (kjac = 0; kjac <= i__1; ++kjac) {
8551 iptt = iptdb + kjac * (*nbpnts / 2) + 1;
8552 AdvApp2Var_SysBase::mcrfill_(&ilong,
8553 (char *)&mmapgs2_.gslxj2[iptt - 1],
8554 (char *)&cgauss[kjac * cgauss_dim1 + 1]);
8555/* L400: */
8556 }
8557/* --> Cas ou le nbre de points est impair. */
8558 if (*nbpnts % 2 == 1) {
8559 iptt = ipdb0;
8560 i__1 = mxjac;
8561 for (kjac = 0; kjac <= i__1; kjac += 2) {
8562 cgauss[kjac * cgauss_dim1] = mmapgs2_.gsl0j2[iptt - 1];
8563 ++iptt;
8564/* L450: */
8565 }
8566 i__1 = mxjac;
8567 for (kjac = 1; kjac <= i__1; kjac += 2) {
8568 cgauss[kjac * cgauss_dim1] = 0.;
8569/* L460: */
8570 }
8571 }
8572 goto L9999;
8573
8574/* ------------------------- Recuperation du code d' erreur --------------
8575 */
8576/* --> NBPNTS n' est pas bon */
8577L9100:
8578 *iercod = 11;
8579 goto L9999;
8580/* --> JORDRE n' est pas bon */
8581L9200:
8582 *iercod = 21;
8583 goto L9999;
8584/* --> NDGJAC n' est pas bon */
8585L9300:
8586 *iercod = 31;
8587 goto L9999;
8588
8589/* -------------------------------- The end -----------------------------
8590*/
8591
8592L9999:
8593 if (*iercod > 0) {
8594 AdvApp2Var_SysBase::maermsg_("MMAPPTT", iercod, 7L);
8595 }
8596 if (ibb >= 2) {
8597 AdvApp2Var_SysBase::mgsomsg_("MMAPPTT", 7L);
8598 }
8599
8600 return 0 ;
8601} /* mmapptt_ */
8602
8603//=======================================================================
8604//function : mmjacpt_
8605//purpose :
8606//=======================================================================
8607int mmjacpt_(const integer *ndimen,
8608 const integer *ncoefu,
8609 const integer *ncoefv,
8610 const integer *iordru,
8611 const integer *iordrv,
8612 const doublereal *ptclgd,
8613 doublereal *ptcaux,
8614 doublereal *ptccan)
8615{
8616 /* System generated locals */
8617 integer ptccan_dim1, ptccan_dim2, ptccan_offset, ptclgd_dim1, ptclgd_dim2,
8618 ptclgd_offset, ptcaux_dim1, ptcaux_dim2, ptcaux_dim3,
8619 ptcaux_offset, i__1, i__2, i__3;
8620
8621 /* Local variables */
8622 static integer kdim, nd, ii, jj, ibb;
8623
8624/* ***********************************************************************
8625 */
8626
8627/* FONCTION : */
8628/* ---------- */
8629/* Passage de la base canonique a la base de Jacobi pour */
8630/* un "carreau" dans un espace de dimension qcq. */
8631
8632/* MOTS CLES : */
8633/* ----------- */
8634/* LISSAGE,BASE,LEGENDRE */
8635
8636
8637/* ARGUMENTS D'ENTREE : */
8638/* ------------------ */
8639/* NDIMEN : Dimension de l' espace. */
8640/* NCOEFU : Degre+1 en U. */
8641/* NCOEFV : Degre+1 en V. */
8642/* IORDRU : Ordre des polynomes de Jacobi en U. */
8643/* IORDRV : Ordre des polynomes de Jacobi en V. */
8644/* PTCLGD : Le carreau dans la base de Jacobi. */
8645
8646/* ARGUMENTS DE SORTIE : */
8647/* ------------------- */
8648/* PTCAUX : Espace auxilliaire. */
8649/* PTCCAN : Le carreau dans la base canonique (-1,1) */
8650
8651/* COMMONS UTILISES : */
8652/* ---------------- */
8653
8654/* REFERENCES APPELEES : */
8655/* ----------------------- */
8656
8657/* DESCRIPTION/REMARQUES/LIMITATIONS : */
8658/* ----------------------------------- */
8659/* Annule et remplace MJACPC */
8660
8661/* $ HISTORIQUE DES MODIFICATIONS : */
8662/* -------------------------------- */
8663/* 03-08-1989 : RBD; Creation. */
8664/* > */
8665/* *********************************************************************
8666*/
8667/* Le nom de la routine */
8668
8669
8670 /* Parameter adjustments */
8671 ptccan_dim1 = *ncoefu;
8672 ptccan_dim2 = *ncoefv;
8673 ptccan_offset = ptccan_dim1 * (ptccan_dim2 + 1) + 1;
8674 ptccan -= ptccan_offset;
8675 ptcaux_dim1 = *ncoefv;
8676 ptcaux_dim2 = *ncoefu;
8677 ptcaux_dim3 = *ndimen;
8678 ptcaux_offset = ptcaux_dim1 * (ptcaux_dim2 * (ptcaux_dim3 + 1) + 1) + 1;
8679 ptcaux -= ptcaux_offset;
8680 ptclgd_dim1 = *ncoefu;
8681 ptclgd_dim2 = *ncoefv;
8682 ptclgd_offset = ptclgd_dim1 * (ptclgd_dim2 + 1) + 1;
8683 ptclgd -= ptclgd_offset;
8684
8685 /* Function Body */
8686 ibb = AdvApp2Var_SysBase::mnfndeb_();
8687 if (ibb >= 3) {
8688 AdvApp2Var_SysBase::mgenmsg_("MMJACPT", 7L);
8689 }
8690
8691/* Passage dans canonique en u. */
8692
8693 kdim = *ndimen * *ncoefv;
8694 AdvApp2Var_MathBase::mmjaccv_((integer *)ncoefu,
8695 (integer *)&kdim,
8696 (integer *)iordru,
8697 (doublereal *)&ptclgd[ptclgd_offset],
8698 (doublereal *)&ptcaux[ptcaux_offset],
8699 (doublereal *)&ptccan[ptccan_offset]);
8700
8701/* Permutation des u et des v. */
8702
8703 i__1 = *ndimen;
8704 for (nd = 1; nd <= i__1; ++nd) {
8705 i__2 = *ncoefv;
8706 for (jj = 1; jj <= i__2; ++jj) {
8707 i__3 = *ncoefu;
8708 for (ii = 1; ii <= i__3; ++ii) {
8709 ptcaux[jj + (ii + (nd + ptcaux_dim3) * ptcaux_dim2) *
8710 ptcaux_dim1] = ptccan[ii + (jj + nd * ptccan_dim2) *
8711 ptccan_dim1];
8712/* L320: */
8713 }
8714/* L310: */
8715 }
8716/* L300: */
8717 }
8718
8719/* Passage dans canonique en v. */
8720
8721 kdim = *ndimen * *ncoefu;
8722 AdvApp2Var_MathBase::mmjaccv_((integer *)ncoefv,
8723 (integer *)&kdim,
8724 (integer *)iordrv,
8725 (doublereal *)&ptcaux[((ptcaux_dim3 + 1) * ptcaux_dim2 + 1) * ptcaux_dim1 + 1],
8726 (doublereal *)&ptccan[ptccan_offset],
8727 (doublereal *)&ptcaux[(((ptcaux_dim3 << 1) + 1) * ptcaux_dim2 + 1) * ptcaux_dim1 + 1]);
8728
8729/* Permutation des u et des v. */
8730
8731 i__1 = *ndimen;
8732 for (nd = 1; nd <= i__1; ++nd) {
8733 i__2 = *ncoefv;
8734 for (jj = 1; jj <= i__2; ++jj) {
8735 i__3 = *ncoefu;
8736 for (ii = 1; ii <= i__3; ++ii) {
8737 ptccan[ii + (jj + nd * ptccan_dim2) * ptccan_dim1] = ptcaux[
8738 jj + (ii + (nd + (ptcaux_dim3 << 1)) * ptcaux_dim2) *
8739 ptcaux_dim1];
8740/* L420: */
8741 }
8742/* L410: */
8743 }
8744/* L400: */
8745 }
8746
8747/* ---------------------------- THAT'S ALL FOLKS ------------------------
8748*/
8749
8750 if (ibb >= 3) {
8751 AdvApp2Var_SysBase::mgsomsg_("MMJACPT", 7L);
8752 }
8753 return 0;
8754} /* mmjacpt_ */
Open CASCADE Technology repository