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;