projects / occt.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
0022312: Translation of french commentaries in OCCT files
[occt.git] / src / AdvApp2Var / AdvApp2Var_MathBase.cxx
CommitLineData
7fd59977 1//
2// AdvApp2Var_MathBase.cxx
3//
4#include <math.h>
5#include <AdvApp2Var_SysBase.hxx>
6#include <AdvApp2Var_Data_f2c.hxx>
7#include <AdvApp2Var_MathBase.hxx>
8#include <AdvApp2Var_Data.hxx>
9
10// statics
11static
12int mmchole_(integer *mxcoef,
13 integer *dimens,
14 doublereal *amatri,
15 integer *aposit,
16 integer *posuiv,
17 doublereal *chomat,
18 integer *iercod);
19
20
21
22
23static
24int mmrslss_(integer *mxcoef,
25 integer *dimens,
26 doublereal *smatri,
27 integer *sposit,
28 integer *posuiv,
29 doublereal *mscnmbr,
30 doublereal *soluti,
31 integer *iercod);
32
33static
34int mfac_(doublereal *f,
35 integer *n);
36
37static
38int mmaper0_(integer *ncofmx,
39 integer *ndimen,
40 integer *ncoeff,
41 doublereal *crvlgd,
42 integer *ncfnew,
43 doublereal *ycvmax,
44 doublereal *errmax);
45static
46int mmaper2_(integer *ncofmx,
47 integer *ndimen,
48 integer *ncoeff,
49 doublereal *crvjac,
50 integer *ncfnew,
51 doublereal *ycvmax,
52 doublereal *errmax);
53
54static
55int mmaper4_(integer *ncofmx,
56 integer *ndimen,
57 integer *ncoeff,
58 doublereal *crvjac,
59 integer *ncfnew,
60 doublereal *ycvmax,
61 doublereal *errmax);
62
63static
64int mmaper6_(integer *ncofmx,
65 integer *ndimen,
66 integer *ncoeff,
67 doublereal *crvjac,
68 integer *ncfnew,
69 doublereal *ycvmax,
70 doublereal *errmax);
71
72static
73int mmarc41_(integer *ndimax,
74 integer *ndimen,
75 integer *ncoeff,
76 doublereal *crvold,
77 doublereal *upara0,
78 doublereal *upara1,
79 doublereal *crvnew,
80 integer *iercod);
81
82static
83int mmatvec_(integer *nligne,
84 integer *ncolon,
85 integer *gposit,
86 integer *gnstoc,
87 doublereal *gmatri,
88 doublereal *vecin,
89 integer *deblig,
90 doublereal *vecout,
91 integer *iercod);
92
93static
94int mmcvstd_(integer *ncofmx,
95 integer *ndimax,
96 integer *ncoeff,
97 integer *ndimen,
98 doublereal *crvcan,
99 doublereal *courbe);
100
101static
102int mmdrvcb_(integer *ideriv,
103 integer *ndim,
104 integer *ncoeff,
105 doublereal *courbe,
106 doublereal *tparam,
107 doublereal *tabpnt,
108 integer *iercod);
109
110static
111int mmexthi_(integer *ndegre,
112 doublereal *hwgaus);
113
114static
115int mmextrl_(integer *ndegre,
116 doublereal *rootlg);
117
118
119
120static
121int mmherm0_(doublereal *debfin,
122 integer *iercod);
123
124static
125int mmherm1_(doublereal *debfin,
126 integer *ordrmx,
127 integer *iordre,
128 doublereal *hermit,
129 integer *iercod);
130static
131int mmloncv_(integer *ndimax,
132 integer *ndimen,
133 integer *ncoeff,
134 doublereal *courbe,
135 doublereal *tdebut,
136 doublereal *tfinal,
137 doublereal *xlongc,
138 integer *iercod);
139static
140int mmpojac_(doublereal *tparam,
141 integer *iordre,
142 integer *ncoeff,
143 integer *nderiv,
144 doublereal *valjac,
145 integer *iercod);
146
147static
148int mmrslw_(integer *normax,
149 integer *nordre,
150 integer *ndimen,
151 doublereal *epspiv,
152 doublereal *abmatr,
153 doublereal *xmatri,
154 integer *iercod);
155static
156int mmtmave_(integer *nligne,
157 integer *ncolon,
158 integer *gposit,
159 integer *gnstoc,
160 doublereal *gmatri,
161 doublereal *vecin,
162 doublereal *vecout,
163 integer *iercod);
164static
165int mmtrpj0_(integer *ncofmx,
166 integer *ndimen,
167 integer *ncoeff,
168 doublereal *epsi3d,
169 doublereal *crvlgd,
170 doublereal *ycvmax,
171 doublereal *epstrc,
172 integer *ncfnew);
173static
174int mmtrpj2_(integer *ncofmx,
175 integer *ndimen,
176 integer *ncoeff,
177 doublereal *epsi3d,
178 doublereal *crvlgd,
179 doublereal *ycvmax,
180 doublereal *epstrc,
181 integer *ncfnew);
182
183static
184int mmtrpj4_(integer *ncofmx,
185 integer *ndimen,
186 integer *ncoeff,
187 doublereal *epsi3d,
188 doublereal *crvlgd,
189 doublereal *ycvmax,
190 doublereal *epstrc,
191 integer *ncfnew);
192static
193int mmtrpj6_(integer *ncofmx,
194 integer *ndimen,
195 integer *ncoeff,
196 doublereal *epsi3d,
197 doublereal *crvlgd,
198 doublereal *ycvmax,
199 doublereal *epstrc,
200 integer *ncfnew);
201static
202integer pow__ii(integer *x,
203 integer *n);
204
205static
206int mvcvin2_(integer *ncoeff,
207 doublereal *crvold,
208 doublereal *crvnew,
209 integer *iercod);
210
211static
212int mvcvinv_(integer *ncoeff,
213 doublereal *crvold,
214 doublereal *crvnew,
215 integer *iercod);
216
217static
218int mvgaus0_(integer *kindic,
219 doublereal *urootl,
220 doublereal *hiltab,
221 integer *nbrval,
222 integer *iercod);
223static
224int mvpscr2_(integer *ncoeff,
225 doublereal *curve2,
226 doublereal *tparam,
227 doublereal *pntcrb);
228
229static
230int mvpscr3_(integer *ncoeff,
231 doublereal *curve2,
232 doublereal *tparam,
233 doublereal *pntcrb);
234
235static struct {
236 doublereal eps1, eps2, eps3, eps4;
237 integer niterm, niterr;
238} mmprcsn_;
239
240static struct {
241 doublereal tdebut, tfinal, verifi, cmherm[576];
242} mmcmher_;
243
244//=======================================================================
245//function : AdvApp2Var_MathBase::mdsptpt_
246//purpose :
247//=======================================================================
248int AdvApp2Var_MathBase::mdsptpt_(integer *ndimen,
249 doublereal *point1,
250 doublereal *point2,
251 doublereal *distan)
252
253{
254 static integer c__8 = 8;
255 /* System generated locals */
256 integer i__1;
257 doublereal d__1;
258
259 /* Local variables */
260 static integer i__;
261 static doublereal differ[100];
262 static integer ier;
263 long int iofset, j;
264
265/* **********************************************************************
266*/
267
268/* FONCTION : */
269/* ---------- */
270/* CALCULE LA DISTANCE ENTRE DEUX POINTS */
271
272/* MOTS CLES : */
273/* ----------- */
274/* DISTANCE,POINT. */
275
276/* ARGUMENTS D'ENTREE : */
277/* ------------------ */
278/* NDIMEN: Dimension de l' espace. */
279/* POINT1: Tableau des coordonnees du 1er point. */
280/* POINT2: Tableau des coordonnees du 2eme point. */
281
282/* ARGUMENTS DE SORTIE : */
283/* ------------------- */
284/* DISTAN: Distance des 2 points. */
285
286/* COMMONS UTILISES : */
287/* ---------------- */
288
289/* REFERENCES APPELEES : */
290/* ----------------------- */
291
292/* DESCRIPTION/REMARQUES/LIMITATIONS : */
293/* ----------------------------------- */
294
295/* $ HISTORIQUE DES MODIFICATIONS : */
296/* -------------------------------- */
297/* 21-07-94 : PMN ; La valeur seuil pour alloc passe de 3 a 100 */
298/* 15-07-93 : PMN ; Protection des points... */
299/* 08-09-90 : DHU ; Utilisation de MZSNORM */
300/* 18-07-88 : RBD ; AJOUT D' UN EN TETE STANDARD */
301/* ??-??-?? : XXX ; CREATION */
302/* > */
303/* **********************************************************************
304*/
305
306
307/* ***********************************************************************
308 */
309/* INITIALISATIONS */
310/* ***********************************************************************
311 */
312
313 /* Parameter adjustments */
314 --point2;
315 --point1;
316
317 /* Function Body */
318 iofset = 0;
319 ier = 0;
320
321/* ***********************************************************************
322 */
323/* TRAITEMENT */
324/* ***********************************************************************
325 */
326
327 if (*ndimen > 100) {
328 AdvApp2Var_SysBase::mcrrqst_(&c__8, ndimen, differ, &iofset, &ier);
329 }
330
331/* --- Si l'allocation est refuse, on applique la methode trivial */
332
333 if (ier > 0) {
334
335 *distan = 0.;
336 i__1 = *ndimen;
337 for (i__ = 1; i__ <= i__1; ++i__) {
338/* Computing 2nd power */
339 d__1 = point1[i__] - point2[i__];
340 *distan += d__1 * d__1;
341 }
342 *distan = sqrt(*distan);
343
344/* --- Sinon on utilise MZSNORM pour minimiser les risques d'overflow
345*/
346
347 } else {
348 i__1 = *ndimen;
349 for (i__ = 1; i__ <= i__1; ++i__) {
350 j=iofset + i__ - 1;
351 differ[j] = point2[i__] - point1[i__];
352 }
353
354 *distan = AdvApp2Var_MathBase::mzsnorm_(ndimen, &differ[iofset]);
355
356 }
357
358/* ***********************************************************************
359 */
360/* RETOUR PROGRAMME APPELANT */
361/* ***********************************************************************
362 */
363
364/* --- Desallocation dynamique */
365
366 if (iofset != 0) {
367 AdvApp2Var_SysBase::mcrdelt_(&c__8, ndimen, differ, &iofset, &ier);
368 }
369
370 return 0 ;
371} /* mdsptpt_ */
372
373//=======================================================================
374//function : mfac_
375//purpose :
376//=======================================================================
377int mfac_(doublereal *f,
378 integer *n)
379
380{
381 /* System generated locals */
382 integer i__1;
383
384 /* Local variables */
385 static integer i__;
386
387/* FORTRAN CONFORME AU TEXT */
388/* CALCUL DE MFACTORIEL N */
389 /* Parameter adjustments */
390 --f;
391
392 /* Function Body */
393 f[1] = (float)1.;
394 i__1 = *n;
395 for (i__ = 2; i__ <= i__1; ++i__) {
396/* L10: */
397 f[i__] = i__ * f[i__ - 1];
398 }
399 return 0;
400} /* mfac_ */
401
402//=======================================================================
403//function : AdvApp2Var_MathBase::mmapcmp_
404//purpose :
405//=======================================================================
406int AdvApp2Var_MathBase::mmapcmp_(integer *ndim,
407 integer *ncofmx,
408 integer *ncoeff,
409 doublereal *crvold,
410 doublereal *crvnew)
411
412{
413 /* System generated locals */
414 integer crvold_dim1, crvold_offset, crvnew_dim1, crvnew_offset, i__1,
415 i__2;
416
417 /* Local variables */
418 static integer ipair, nd, ndegre, impair, ibb, idg;
419 //extern int mgsomsg_();//mgenmsg_(),
420
421
422
423/* **********************************************************************
424*/
425
426/* FONCTION : */
427/* ---------- */
428/* Compression de la courbe CRVOLD en un tableau comprenant */
429/* les coeff. de rang pair : CRVNEW(*,0,*) */
430/* et de rang impair : CRVNEW(*,1,*). */
431
432/* MOTS CLES : */
433/* ----------- */
434/* COMPRESSION,COURBE. */
435
436/* ARGUMENTS D'ENTREE : */
437/* ------------------ */
438/* NDIM : Dimension de l' espace. */
439/* NCOFMX : Le nbre maximum de coeff. de la courbe a compacter. */
440/* NCOEFF : Le nbre maximum de coeff. de la courbe compactee. */
441/* CRVOLD : La courbe (0:NCOFMX-1,NDIM) a compacter. */
442
443/* ARGUMENTS DE SORTIE : */
444/* ------------------- */
445/* CRVNEW : La coube compactee en (0:(NCOEFF-1)/2,0,NDIM) (contenant
446*/
447/* les termes pairs) et en (0:(NCOEFF-1)/2,1,NDIM) */
448/* (contenant les termes impairs). */
449
450/* COMMONS UTILISES : */
451/* ---------------- */
452
453/* REFERENCES APPELEES : */
454/* ----------------------- */
455
456/* DESCRIPTION/REMARQUES/LIMITATIONS : */
457/* ----------------------------------- */
458/* Cette routine est utile pour preparer les coefficients d' une */
459/* courbe dans une base orthogonale (Legendre ou Jacobi) avant de */
460/* calculer les coefficients dans la base canonique [-1,1] par */
461/* MMJACAN. */
462
463/* $ HISTORIQUE DES MODIFICATIONS : */
464/* -------------------------------- */
465/* 12-04-1989 : RBD ; Creation. */
466/* > */
467/* ***********************************************************************
468 */
469
470/* Le nom de la routine */
471
472 /* Parameter adjustments */
473 crvold_dim1 = *ncofmx;
474 crvold_offset = crvold_dim1;
475 crvold -= crvold_offset;
476 crvnew_dim1 = (*ncoeff - 1) / 2 + 1;
477 crvnew_offset = crvnew_dim1 << 1;
478 crvnew -= crvnew_offset;
479
480 /* Function Body */
481 ibb = AdvApp2Var_SysBase::mnfndeb_();
482 if (ibb >= 3) {
483 AdvApp2Var_SysBase::mgenmsg_("MMAPCMP", 7L);
484 }
485
486 ndegre = *ncoeff - 1;
487 i__1 = *ndim;
488 for (nd = 1; nd <= i__1; ++nd) {
489 ipair = 0;
490 i__2 = ndegre / 2;
491 for (idg = 0; idg <= i__2; ++idg) {
492 crvnew[idg + (nd << 1) * crvnew_dim1] = crvold[ipair + nd *
493 crvold_dim1];
494 ipair += 2;
495/* L200: */
496 }
497 if (ndegre < 1) {
498 goto L400;
499 }
500 impair = 1;
501 i__2 = (ndegre - 1) / 2;
502 for (idg = 0; idg <= i__2; ++idg) {
503 crvnew[idg + ((nd << 1) + 1) * crvnew_dim1] = crvold[impair + nd *
504 crvold_dim1];
505 impair += 2;
506/* L300: */
507 }
508
509L400:
510/* L100: */
511 ;
512 }
513
514/* ---------------------------------- The end ---------------------------
515*/
516
517 if (ibb >= 3) {
518 AdvApp2Var_SysBase::mgsomsg_("MMAPCMP", 7L);
519 }
520 return 0;
521} /* mmapcmp_ */
522
523//=======================================================================
524//function : mmaper0_
525//purpose :
526//=======================================================================
527int mmaper0_(integer *ncofmx,
528 integer *ndimen,
529 integer *ncoeff,
530 doublereal *crvlgd,
531 integer *ncfnew,
532 doublereal *ycvmax,
533 doublereal *errmax)
534
535{
536 /* System generated locals */
537 integer crvlgd_dim1, crvlgd_offset, i__1, i__2;
538 doublereal d__1;
539
540 /* Local variables */
541 static integer ncut;
542 static doublereal bidon;
543 static integer ii, nd;
544
545
546/* ***********************************************************************
547 */
548
549/* FONCTION : */
550/* ---------- */
551/* Calcule l' erreur d' approximation maxi faite lorsque l' on */
552/* ne conserve que les premiers NCFNEW coefficients d' une courbe
553*/
554/* de degre NCOEFF-1 ecrite dans la base de Legendre (Jacobi */
555/* d' ordre 0). */
556
557/* MOTS CLES : */
558/* ----------- */
559/* LEGENDRE,POLYGONE,APPROXIMATION,ERREUR. */
560
561/* ARGUMENTS D'ENTREE : */
562/* ------------------ */
563/* NCOFMX : Degre maximum de la courbe. */
564/* NDIMEN : Dimension de l' espace. */
565/* NCOEFF : Le degre +1 de la courbe. */
566/* CRVLGD : La courbe dont on veut baisser le degre. */
567/* NCFNEW : Le degre +1 du polynome resultat. */
568
569/* ARGUMENTS DE SORTIE : */
570/* ------------------- */
571/* YCVMAX : Tableau auxiliaire (erreur max sur chaque dimension).
572*/
573/* ERRMAX : La precision de l' approximation. */
574
575/* COMMONS UTILISES : */
576/* ---------------- */
577
578/* REFERENCES APPELEES : */
579/* ----------------------- */
580
581/* DESCRIPTION/REMARQUES/LIMITATIONS : */
582/* ----------------------------------- */
583
584/* $ HISTORIQUE DES MODIFICATIONS : */
585/* -------------------------------- */
586/* 08-08-1991: RBD; Creation. */
587/* > */
588/* ***********************************************************************
589 */
590
591
592/* ------------------- Init pour calcul d' erreur -----------------------
593*/
594
595 /* Parameter adjustments */
596 --ycvmax;
597 crvlgd_dim1 = *ncofmx;
598 crvlgd_offset = crvlgd_dim1 + 1;
599 crvlgd -= crvlgd_offset;
600
601 /* Function Body */
602 i__1 = *ndimen;
603 for (ii = 1; ii <= i__1; ++ii) {
604 ycvmax[ii] = 0.;
605/* L100: */
606 }
607
608/* ------ Degre minimum pouvant etre atteint : Arret a 1 ou NCFNEW ------
609*/
610
611 ncut = 1;
612 if (*ncfnew + 1 > ncut) {
613 ncut = *ncfnew + 1;
614 }
615
616/* -------------- Elimination des coefficients de haut degre -----------
617*/
618/* ----------- Boucle sur la serie de Legendre: NCUT --> NCOEFF --------
619*/
620
621 i__1 = *ncoeff;
622 for (ii = ncut; ii <= i__1; ++ii) {
623/* Facteur de renormalisation (Maximum de Li(t)). */
624 bidon = ((ii - 1) * 2. + 1.) / 2.;
625 bidon = sqrt(bidon);
626
627 i__2 = *ndimen;
628 for (nd = 1; nd <= i__2; ++nd) {
629 ycvmax[nd] += (d__1 = crvlgd[ii + nd * crvlgd_dim1], abs(d__1)) *
630 bidon;
631/* L310: */
632 }
633/* L300: */
634 }
635
636/* -------------- L'erreur est la norme du vecteur erreur ---------------
637*/
638
639 *errmax = AdvApp2Var_MathBase::mzsnorm_(ndimen, &ycvmax[1]);
640
641/* --------------------------------- Fin --------------------------------
642*/
643
644 return 0;
645} /* mmaper0_ */
646
647//=======================================================================
648//function : mmaper2_
649//purpose :
650//=======================================================================
651int mmaper2_(integer *ncofmx,
652 integer *ndimen,
653 integer *ncoeff,
654 doublereal *crvjac,
655 integer *ncfnew,
656 doublereal *ycvmax,
657 doublereal *errmax)
658
659{
660 /* Initialized data */
661
662 static doublereal xmaxj[57] = { .9682458365518542212948163499456,
663 .986013297183269340427888048593603,
664 1.07810420343739860362585159028115,
665 1.17325804490920057010925920756025,
666 1.26476561266905634732910520370741,
667 1.35169950227289626684434056681946,
668 1.43424378958284137759129885012494,
669 1.51281316274895465689402798226634,
670 1.5878364329591908800533936587012,
671 1.65970112228228167018443636171226,
672 1.72874345388622461848433443013543,
673 1.7952515611463877544077632304216,
674 1.85947199025328260370244491818047,
675 1.92161634324190018916351663207101,
676 1.98186713586472025397859895825157,
677 2.04038269834980146276967984252188,
678 2.09730119173852573441223706382076,
679 2.15274387655763462685970799663412,
680 2.20681777186342079455059961912859,
681 2.25961782459354604684402726624239,
682 2.31122868752403808176824020121524,
683 2.36172618435386566570998793688131,
684 2.41117852396114589446497298177554,
685 2.45964731268663657873849811095449,
686 2.50718840313973523778244737914028,
687 2.55385260994795361951813645784034,
688 2.59968631659221867834697883938297,
689 2.64473199258285846332860663371298,
690 2.68902863641518586789566216064557,
691 2.73261215675199397407027673053895,
692 2.77551570192374483822124304745691,
693 2.8177699459714315371037628127545,
694 2.85940333797200948896046563785957,
695 2.90044232019793636101516293333324,
696 2.94091151970640874812265419871976,
697 2.98083391718088702956696303389061,
698 3.02023099621926980436221568258656,
699 3.05912287574998661724731962377847,
700 3.09752842783622025614245706196447,
701 3.13546538278134559341444834866301,
702 3.17295042316122606504398054547289,
703 3.2099992681699613513775259670214,
704 3.24662674946606137764916854570219,
705 3.28284687953866689817670991319787,
706 3.31867291347259485044591136879087,
707 3.35411740487202127264475726990106,
708 3.38919225660177218727305224515862,
709 3.42390876691942143189170489271753,
710 3.45827767149820230182596660024454,
711 3.49230918177808483937957161007792,
712 3.5260130200285724149540352829756,
713 3.55939845146044235497103883695448,
714 3.59247431368364585025958062194665,
715 3.62524904377393592090180712976368,
716 3.65773070318071087226169680450936,
717 3.68992700068237648299565823810245,
718 3.72184531357268220291630708234186 };
719
720 /* System generated locals */
721 integer crvjac_dim1, crvjac_offset, i__1, i__2;
722 doublereal d__1;
723
724 /* Local variables */
725 static integer idec, ncut;
726 static doublereal bidon;
727 static integer ii, nd;
728
729
730
731/* ***********************************************************************
732 */
733
734/* FONCTION : */
735/* ---------- */
736/* Calcule l' erreur d' approximation maxi faite lorsque l' on */
737/* ne conserve que les premiers NCFNEW coefficients d' une courbe
738*/
739/* de degre NCOEFF-1 ecrite dans la base de Jacobi d' ordre 2. */
740
741/* MOTS CLES : */
742/* ----------- */
743/* JACOBI,POLYGONE,APPROXIMATION,ERREUR. */
744
745/* ARGUMENTS D'ENTREE : */
746/* ------------------ */
747/* NCOFMX : Degre maximum de la courbe. */
748/* NDIMEN : Dimension de l' espace. */
749/* NCOEFF : Le degre +1 de la courbe. */
750/* CRVJAC : La courbe dont on veut baisser le degre. */
751/* NCFNEW : Le degre +1 du polynome resultat. */
752
753/* ARGUMENTS DE SORTIE : */
754/* ------------------- */
755/* YCVMAX : Tableau auxiliaire (erreur max sur chaque dimension).
756*/
757/* ERRMAX : La precision de l' approximation. */
758
759/* COMMONS UTILISES : */
760/* ---------------- */
761
762/* REFERENCES APPELEES : */
763/* ----------------------- */
764
765/* DESCRIPTION/REMARQUES/LIMITATIONS : */
766/* ----------------------------------- */
767
768/* $ HISTORIQUE DES MODIFICATIONS : */
769/* -------------------------------- */
770/* 12-02-1992: RBD; Correction d'indice de lecture de XMAXJ */
771/* 08-08-1991: RBD; Creation. */
772/* > */
773/* ***********************************************************************
774 */
775
776
777/* ------------------ Table des maximums de (1-t2)*Ji(t) ----------------
778*/
779
780 /* Parameter adjustments */
781 --ycvmax;
782 crvjac_dim1 = *ncofmx;
783 crvjac_offset = crvjac_dim1 + 1;
784 crvjac -= crvjac_offset;
785
786 /* Function Body */
787
788
789
790/* ------------------- Init pour calcul d' erreur -----------------------
791*/
792
793 i__1 = *ndimen;
794 for (ii = 1; ii <= i__1; ++ii) {
795 ycvmax[ii] = 0.;
796/* L100: */
797 }
798
799/* ------ Degre minimum pouvant etre atteint : Arret a 3 ou NCFNEW ------
800*/
801
802 idec = 3;
803/* Computing MAX */
804 i__1 = idec, i__2 = *ncfnew + 1;
805 ncut = max(i__1,i__2);
806
807/* -------------- Elimination des coefficients de haut degre -----------
808*/
809/* ----------- Boucle sur la serie de Jacobi :NCUT --> NCOEFF ----------
810*/
811
812 i__1 = *ncoeff;
813 for (ii = ncut; ii <= i__1; ++ii) {
814/* Facteur de renormalisation. */
815 bidon = xmaxj[ii - idec];
816 i__2 = *ndimen;
817 for (nd = 1; nd <= i__2; ++nd) {
818 ycvmax[nd] += (d__1 = crvjac[ii + nd * crvjac_dim1], abs(d__1)) *
819 bidon;
820/* L310: */
821 }
822/* L300: */
823 }
824
825/* -------------- L'erreur est la norme du vecteur erreur ---------------
826*/
827
828 *errmax = AdvApp2Var_MathBase::mzsnorm_(ndimen, &ycvmax[1]);
829
830/* --------------------------------- Fin --------------------------------
831*/
832
833 return 0;
834} /* mmaper2_ */
835
836/* MAPER4.f -- translated by f2c (version 19960827).
837 You must link the resulting object file with the libraries:
838 -lf2c -lm (in that order)
839*/
840
841/* Subroutine */
842//=======================================================================
843//function : mmaper4_
844//purpose :
845//=======================================================================
846int mmaper4_(integer *ncofmx,
847 integer *ndimen,
848 integer *ncoeff,
849 doublereal *crvjac,
850 integer *ncfnew,
851 doublereal *ycvmax,
852 doublereal *errmax)
853{
854 /* Initialized data */
855
856 static doublereal xmaxj[55] = { 1.1092649593311780079813740546678,
857 1.05299572648705464724876659688996,
858 1.0949715351434178709281698645813,
859 1.15078388379719068145021100764647,
860 1.2094863084718701596278219811869,
861 1.26806623151369531323304177532868,
862 1.32549784426476978866302826176202,
863 1.38142537365039019558329304432581,
864 1.43575531950773585146867625840552,
865 1.48850442653629641402403231015299,
866 1.53973611681876234549146350844736,
867 1.58953193485272191557448229046492,
868 1.63797820416306624705258190017418,
869 1.68515974143594899185621942934906,
870 1.73115699602477936547107755854868,
871 1.77604489805513552087086912113251,
872 1.81989256661534438347398400420601,
873 1.86276344480103110090865609776681,
874 1.90471563564740808542244678597105,
875 1.94580231994751044968731427898046,
876 1.98607219357764450634552790950067,
877 2.02556989246317857340333585562678,
878 2.06433638992049685189059517340452,
879 2.10240936014742726236706004607473,
880 2.13982350649113222745523925190532,
881 2.17661085564771614285379929798896,
882 2.21280102016879766322589373557048,
883 2.2484214321456956597803794333791,
884 2.28349755104077956674135810027654,
885 2.31805304852593774867640120860446,
886 2.35210997297725685169643559615022,
887 2.38568889602346315560143377261814,
888 2.41880904328694215730192284109322,
889 2.45148841120796359750021227795539,
890 2.48374387161372199992570528025315,
891 2.5155912654873773953959098501893,
892 2.54704548720896557684101746505398,
893 2.57812056037881628390134077704127,
894 2.60882970619319538196517982945269,
895 2.63918540521920497868347679257107,
896 2.66919945330942891495458446613851,
897 2.69888301230439621709803756505788,
898 2.72824665609081486737132853370048,
899 2.75730041251405791603760003778285,
900 2.78605380158311346185098508516203,
901 2.81451587035387403267676338931454,
902 2.84269522483114290814009184272637,
903 2.87060005919012917988363332454033,
904 2.89823818258367657739520912946934,
905 2.92561704377132528239806135133273,
906 2.95274375377994262301217318010209,
907 2.97962510678256471794289060402033,
908 3.00626759936182712291041810228171,
909 3.03267744830655121818899164295959,
910 3.05886060707437081434964933864149 };
911
912 /* System generated locals */
913 integer crvjac_dim1, crvjac_offset, i__1, i__2;
914 doublereal d__1;
915
916 /* Local variables */
917 static integer idec, ncut;
918 static doublereal bidon;
919 static integer ii, nd;
920
921
922
923/* ***********************************************************************
924 */
925
926/* FONCTION : */
927/* ---------- */
928/* Calcule l' erreur d' approximation maxi faite lorsque l' on */
929/* ne conserve que les premiers NCFNEW coefficients d' une courbe
930*/
931/* de degre NCOEFF-1 ecrite dans la base de Jacobi d' ordre 4. */
932
933/* MOTS CLES : */
934/* ----------- */
935/* JACOBI,POLYGONE,APPROXIMATION,ERREUR. */
936
937/* ARGUMENTS D'ENTREE : */
938/* ------------------ */
939/* NCOFMX : Degre maximum de la courbe. */
940/* NDIMEN : Dimension de l' espace. */
941/* NCOEFF : Le degre +1 de la courbe. */
942/* CRVJAC : La courbe dont on veut baisser le degre. */
943/* NCFNEW : Le degre +1 du polynome resultat. */
944
945/* ARGUMENTS DE SORTIE : */
946/* ------------------- */
947/* YCVMAX : Tableau auxiliaire (erreur max sur chaque dimension).
948*/
949/* ERRMAX : La precision de l' approximation. */
950
951/* COMMONS UTILISES : */
952/* ---------------- */
953
954/* REFERENCES APPELEES : */
955/* ----------------------- */
956
957/* DESCRIPTION/REMARQUES/LIMITATIONS : */
958/* ----------------------------------- */
959
960/* $ HISTORIQUE DES MODIFICATIONS : */
961/* -------------------------------- */
962/* 12-02-1992: RBD; Correction d'indice de lecture de XMAXJ */
963/* 08-08-1991: RBD; Creation. */
964/* > */
965/* ***********************************************************************
966 */
967
968
969/* ---------------- Table des maximums de ((1-t2)2)*Ji(t) ---------------
970*/
971
972 /* Parameter adjustments */
973 --ycvmax;
974 crvjac_dim1 = *ncofmx;
975 crvjac_offset = crvjac_dim1 + 1;
976 crvjac -= crvjac_offset;
977
978 /* Function Body */
979
980
981
982/* ------------------- Init pour calcul d' erreur -----------------------
983*/
984
985 i__1 = *ndimen;
986 for (ii = 1; ii <= i__1; ++ii) {
987 ycvmax[ii] = 0.;
988/* L100: */
989 }
990
991/* ------ Degre minimum pouvant etre atteint : Arret a 5 ou NCFNEW ------
992*/
993
994 idec = 5;
995/* Computing MAX */
996 i__1 = idec, i__2 = *ncfnew + 1;
997 ncut = max(i__1,i__2);
998
999/* -------------- Elimination des coefficients de haut degre -----------
1000*/
1001/* ----------- Boucle sur la serie de Jacobi :NCUT --> NCOEFF ----------
1002*/
1003
1004 i__1 = *ncoeff;
1005 for (ii = ncut; ii <= i__1; ++ii) {
1006/* Facteur de renormalisation. */
1007 bidon = xmaxj[ii - idec];
1008 i__2 = *ndimen;
1009 for (nd = 1; nd <= i__2; ++nd) {
1010 ycvmax[nd] += (d__1 = crvjac[ii + nd * crvjac_dim1], abs(d__1)) *
1011 bidon;
1012/* L310: */
1013 }
1014/* L300: */
1015 }
1016
1017/* -------------- L'erreur est la norme du vecteur erreur ---------------
1018*/
1019
1020 *errmax = AdvApp2Var_MathBase::mzsnorm_(ndimen, &ycvmax[1]);
1021
1022/* --------------------------------- Fin --------------------------------
1023*/
1024
1025 return 0;
1026} /* mmaper4_ */
1027
1028//=======================================================================
1029//function : mmaper6_
1030//purpose :
1031//=======================================================================
1032int mmaper6_(integer *ncofmx,
1033 integer *ndimen,
1034 integer *ncoeff,
1035 doublereal *crvjac,
1036 integer *ncfnew,
1037 doublereal *ycvmax,
1038 doublereal *errmax)
1039
1040{
1041 /* Initialized data */
1042
1043 static doublereal xmaxj[53] = { 1.21091229812484768570102219548814,
1044 1.11626917091567929907256116528817,
1045 1.1327140810290884106278510474203,
1046 1.1679452722668028753522098022171,
1047 1.20910611986279066645602153641334,
1048 1.25228283758701572089625983127043,
1049 1.29591971597287895911380446311508,
1050 1.3393138157481884258308028584917,
1051 1.3821288728999671920677617491385,
1052 1.42420414683357356104823573391816,
1053 1.46546895108549501306970087318319,
1054 1.50590085198398789708599726315869,
1055 1.54550385142820987194251585145013,
1056 1.58429644271680300005206185490937,
1057 1.62230484071440103826322971668038,
1058 1.65955905239130512405565733793667,
1059 1.69609056468292429853775667485212,
1060 1.73193098017228915881592458573809,
1061 1.7671112206990325429863426635397,
1062 1.80166107681586964987277458875667,
1063 1.83560897003644959204940535551721,
1064 1.86898184653271388435058371983316,
1065 1.90180515174518670797686768515502,
1066 1.93410285411785808749237200054739,
1067 1.96589749778987993293150856865539,
1068 1.99721027139062501070081653790635,
1069 2.02806108474738744005306947877164,
1070 2.05846864831762572089033752595401,
1071 2.08845055210580131460156962214748,
1072 2.11802334209486194329576724042253,
1073 2.14720259305166593214642386780469,
1074 2.17600297710595096918495785742803,
1075 2.20443832785205516555772788192013,
1076 2.2325216999457379530416998244706,
1077 2.2602654243075083168599953074345,
1078 2.28768115912702794202525264301585,
1079 2.3147799369092684021274946755348,
1080 2.34157220782483457076721300512406,
1081 2.36806787963276257263034969490066,
1082 2.39427635443992520016789041085844,
1083 2.42020656255081863955040620243062,
1084 2.44586699364757383088888037359254,
1085 2.47126572552427660024678584642791,
1086 2.49641045058324178349347438430311,
1087 2.52130850028451113942299097584818,
1088 2.54596686772399937214920135190177,
1089 2.5703922285006754089328998222275,
1090 2.59459096001908861492582631591134,
1091 2.61856915936049852435394597597773,
1092 2.64233265984385295286445444361827,
1093 2.66588704638685848486056711408168,
1094 2.68923766976735295746679957665724,
1095 2.71238965987606292679677228666411 };
1096
1097 /* System generated locals */
1098 integer crvjac_dim1, crvjac_offset, i__1, i__2;
1099 doublereal d__1;
1100
1101 /* Local variables */
1102 static integer idec, ncut;
1103 static doublereal bidon;
1104 static integer ii, nd;
1105
1106
1107
1108/* ***********************************************************************
1109 */
1110
1111/* FONCTION : */
1112/* ---------- */
1113/* Calcule l' erreur d' approximation maxi faite lorsque l' on */
1114/* ne conserve que les premiers NCFNEW coefficients d' une courbe
1115*/
1116/* de degre NCOEFF-1 ecrite dans la base de Jacobi d' ordre 6. */
1117
1118/* MOTS CLES : */
1119/* ----------- */
1120/* JACOBI,POLYGONE,APPROXIMATION,ERREUR. */
1121
1122/* ARGUMENTS D'ENTREE : */
1123/* ------------------ */
1124/* NCOFMX : Degre maximum de la courbe. */
1125/* NDIMEN : Dimension de l' espace. */
1126/* NCOEFF : Le degre +1 de la courbe. */
1127/* CRVJAC : La courbe dont on veut baisser le degre. */
1128/* NCFNEW : Le degre +1 du polynome resultat. */
1129
1130/* ARGUMENTS DE SORTIE : */
1131/* ------------------- */
1132/* YCVMAX : Tableau auxiliaire (erreur max sur chaque dimension).
1133*/
1134/* ERRMAX : La precision de l' approximation. */
1135
1136/* COMMONS UTILISES : */
1137/* ---------------- */
1138
1139/* REFERENCES APPELEES : */
1140/* ----------------------- */
1141
1142/* DESCRIPTION/REMARQUES/LIMITATIONS : */
1143/* ----------------------------------- */
1144
1145/* $ HISTORIQUE DES MODIFICATIONS : */
1146/* -------------------------------- */
1147/* 12-02-1992: RBD; Correction d'indice de lecture de XMAXJ */
1148/* 08-08-1991: RBD; Creation. */
1149/* > */
1150/* ***********************************************************************
1151 */
1152
1153
1154/* ---------------- Table des maximums de ((1-t2)3)*Ji(t) ---------------
1155*/
1156
1157 /* Parameter adjustments */
1158 --ycvmax;
1159 crvjac_dim1 = *ncofmx;
1160 crvjac_offset = crvjac_dim1 + 1;
1161 crvjac -= crvjac_offset;
1162
1163 /* Function Body */
1164
1165
1166
1167/* ------------------- Init pour calcul d' erreur -----------------------
1168*/
1169
1170 i__1 = *ndimen;
1171 for (ii = 1; ii <= i__1; ++ii) {
1172 ycvmax[ii] = 0.;
1173/* L100: */
1174 }
1175
1176/* ------ Degre minimum pouvant etre atteint : Arret a 3 ou NCFNEW ------
1177*/
1178
1179 idec = 7;
1180/* Computing MAX */
1181 i__1 = idec, i__2 = *ncfnew + 1;
1182 ncut = max(i__1,i__2);
1183
1184/* -------------- Elimination des coefficients de haut degre -----------
1185*/
1186/* ----------- Boucle sur la serie de Jacobi :NCUT --> NCOEFF ----------
1187*/
1188
1189 i__1 = *ncoeff;
1190 for (ii = ncut; ii <= i__1; ++ii) {
1191/* Facteur de renormalisation. */
1192 bidon = xmaxj[ii - idec];
1193 i__2 = *ndimen;
1194 for (nd = 1; nd <= i__2; ++nd) {
1195 ycvmax[nd] += (d__1 = crvjac[ii + nd * crvjac_dim1], abs(d__1)) *
1196 bidon;
1197/* L310: */
1198 }
1199/* L300: */
1200 }
1201
1202/* -------------- L'erreur est la norme du vecteur erreur ---------------
1203*/
1204
1205 *errmax = AdvApp2Var_MathBase::mzsnorm_(ndimen, &ycvmax[1]);
1206
1207/* --------------------------------- Fin --------------------------------
1208*/
1209
1210 return 0;
1211} /* mmaper6_ */
1212
1213//=======================================================================
1214//function : AdvApp2Var_MathBase::mmaperx_
1215//purpose :
1216//=======================================================================
1217int AdvApp2Var_MathBase::mmaperx_(integer *ncofmx,
1218 integer *ndimen,
1219 integer *ncoeff,
1220 integer *iordre,
1221 doublereal *crvjac,
1222 integer *ncfnew,
1223 doublereal *ycvmax,
1224 doublereal *errmax,
1225 integer *iercod)
1226
1227{
1228 /* System generated locals */
1229 integer crvjac_dim1, crvjac_offset;
1230
1231 /* Local variables */
1232 static integer jord;
1233
1234
1235/* **********************************************************************
1236*/
1237
1238/* FONCTION : */
1239/* ---------- */
1240/* Calcule l' erreur d' approximation maxi faite lorsque l' on */
1241/* ne conserve que les premiers NCFNEW coefficients d' une courbe
1242*/
1243/* de degre NCOEFF-1 ecrite dans la base de Jacobi d' ordre */
1244/* IORDRE. */
1245
1246/* MOTS CLES : */
1247/* ----------- */
1248/* JACOBI,LEGENDRE,POLYGONE,APPROXIMATION,ERREUR. */
1249
1250/* ARGUMENTS D'ENTREE : */
1251/* ------------------ */
1252/* NCOFMX : Degre maximum de la courbe. */
1253/* NDIMEN : Dimension de l' espace. */
1254/* NCOEFF : Le degre +1 de la courbe. */
1255/* IORDRE : Ordre de continuite aux extremites. */
1256/* CRVJAC : La courbe dont on veut baisser le degre. */
1257/* NCFNEW : Le degre +1 du polynome resultat. */
1258
1259/* ARGUMENTS DE SORTIE : */
1260/* ------------------- */
1261/* YCVMAX : Tableau auxiliaire. */
1262/* ERRMAX : La precision de l' approximation. */
1263/* IERCOD = 0, OK */
1264/* = 1, L'ordre des contraintes (IORDRE) n'est pas dans */
1265/* les valeurs autorisees. */
1266
1267/* COMMONS UTILISES : */
1268/* ---------------- */
1269
1270/* REFERENCES APPELEES : */
1271/* ----------------------- */
1272
1273/* DESCRIPTION/REMARQUES/LIMITATIONS : */
1274/* ----------------------------------- */
1275/* Annule et remplace MMAPERR. */
1276
1277/* $ HISTORIQUE DES MODIFICATIONS : */
1278/* -------------------------------- */
1279/* 08-08-91: RBD; Creation d'apres MMAPERR, utilisation des nouveaux
1280*/
1281/* majorants, appel aux MMAPER0, 2, 4 et 6. */
1282/* > */
1283/* ***********************************************************************
1284 */
1285
1286
1287 /* Parameter adjustments */
1288 --ycvmax;
1289 crvjac_dim1 = *ncofmx;
1290 crvjac_offset = crvjac_dim1 + 1;
1291 crvjac -= crvjac_offset;
1292
1293 /* Function Body */
1294 *iercod = 0;
1295/* --> L'ordre des polynomes de Jacobi */
1296 jord = ( *iordre + 1) << 1;
1297
1298 if (jord == 0) {
1299 mmaper0_(ncofmx, ndimen, ncoeff, &crvjac[crvjac_offset], ncfnew, &
1300 ycvmax[1], errmax);
1301 } else if (jord == 2) {
1302 mmaper2_(ncofmx, ndimen, ncoeff, &crvjac[crvjac_offset], ncfnew, &
1303 ycvmax[1], errmax);
1304 } else if (jord == 4) {
1305 mmaper4_(ncofmx, ndimen, ncoeff, &crvjac[crvjac_offset], ncfnew, &
1306 ycvmax[1], errmax);
1307 } else if (jord == 6) {
1308 mmaper6_(ncofmx, ndimen, ncoeff, &crvjac[crvjac_offset], ncfnew, &
1309 ycvmax[1], errmax);
1310 } else {
1311 *iercod = 1;
1312 }
1313
1314/* ----------------------------------- Fin ------------------------------
1315*/
1316
1317 return 0;
1318} /* mmaperx_ */
1319
1320//=======================================================================
1321//function : mmarc41_
1322//purpose :
1323//=======================================================================
1324 int mmarc41_(integer *ndimax,
1325 integer *ndimen,
1326 integer *ncoeff,
1327 doublereal *crvold,
1328 doublereal *upara0,
1329 doublereal *upara1,
1330 doublereal *crvnew,
1331 integer *iercod)
1332
1333{
1334 /* System generated locals */
1335 integer crvold_dim1, crvold_offset, crvnew_dim1, crvnew_offset, i__1,
1336 i__2, i__3;
1337
1338 /* Local variables */
1339 static integer nboct;
1340 static doublereal tbaux[61];
1341 static integer nd;
1342 static doublereal bid;
1343 static integer ncf, ncj;
1344
1345
1346/* IMPLICIT DOUBLE PRECISION(A-H,O-Z) */
1347/* IMPLICIT INTEGER (I-N) */
1348
1349/* ***********************************************************************
1350 */
1351
1352/* FONCTION : */
1353/* ---------- */
1354/* Creation de la courbe C2(v) definie sur (0,1) identique a la */
1355/* courbe C1(u) definie sur (U0,U1) (changement du parametre d' une */
1356/* courbe). */
1357
1358/* MOTS CLES : */
1359/* ----------- */
1360/* LIMITATION, RESTRICTION, COURBE */
1361
1362/* ARGUMENTS D'ENTREE : */
1363/* ------------------ */
1364/* NDIMAX : Dimensionnement de l' espace. */
1365/* NDIMEN : Dimension de la courbe. */
1366/* NCOEFF : Nbre de coefficients de la courbe. */
1367/* CRVOLD : La courbe a limiter. */
1368/* UPARA0 : Borne min de l' intervalle de restriction de la courbe.
1369*/
1370/* UPARA1 : Borne max de l' intervalle de restriction de la courbe.
1371*/
1372
1373/* ARGUMENTS DE SORTIE : */
1374/* ------------------- */
1375/* CRVNEW : La courbe relimitee, definie dans (0,1) et egale a */
1376/* CRVOLD definie dans (U0,U1). */
1377/* IERCOD : = 0, OK */
1378/* =10, Nbre de coeff. <1 ou > 61. */
1379
1380/* COMMONS UTILISES : */
1381/* ---------------- */
1382
1383/* .Neant. */
1384
1385/* REFERENCES APPELEES : */
1386/* ---------------------- */
1387/* Type Name */
1388/* MAERMSG MCRFILL MVCVIN2 */
1389/* MVCVINV */
1390
1391/* DESCRIPTION/REMARQUES/LIMITATIONS : */
1392/* ----------------------------------- */
1393/* ---> L' algorithme employe dans le cas general est base sur le */
1394/* principe suivant : */
1395/* Soient S(t) = a0 + a1*t + a2*t**2 + ... de degre NCOEFF-1, et */
1396/* U(t) = b0 + b1*t, on calcule alors les coeff. de */
1397/* S(U(t)) de proche en proche a l' aide du tableau TBAUX. */
1398/* A chaque etape numero N (N=2 a NCOEFF), TBAUX(n) contient le */
1399/* n-ieme coefficient de U(t)**N pour n=1 a N. (RBD) */
1400/* ---> Reference : KNUTH, 'The Art of Computer Programming', */
1401/* Vol. 2/'Seminumerical Algorithms', */
1402/* Ex. 11 p:451 et solution p:562. (RBD) */
1403
1404/* ---> L' ecrasement de l' argument d' entree CRVOLD par CRVNEW est */
1405/* possible, c' est a dire que l' appel : */
1406/* CALL MMARC41(NDIMAX,NDIMEN,NCOEFF,CURVE,UPARA0,UPARA1 */
1407/* ,CURVE,IERCOD) */
1408/* est tout a fait LEGAL. (RBD) */
1409
1410/* $ HISTORIQUE DES MODIFICATIONS : */
1411/* -------------------------------- */
1412/* 18-09-1995 : JMF ; Verfor + implicit none */
1413/* 18-10-88 : RBD ; Documentation de la FONCTION. */
1414/* 24-06-88 : RBD ; Refonte totale du code pour le cas general : */
1415/* optimisation et suppression du commun des CNP */
1416/* qui ne sert plus. */
1417/* 22-06-88 : NAK ; TRAITEMENT DES CAS PARTICULIERS SIMPLES ET */
1418/* FREQUENTS. */
1419/* 22-02-1988 : JJM ; Appel MFNDEB -> MNFNDEB. */
1420/* 22-02-1988 : JJM ; Appel GERMSG -> MAERMSG. */
1421/* 26-07-1985 : Remplacement de CAUX par CRVNEW, ajout du */
1422/* common MBLANK. */
1423/* 28-11-1985 : Creation JJM (NDIMAX en plus). */
1424
1425/* > */
1426/* **********************************************************************
1427*/
1428
1429/* Le nom de la routine */
1430
1431/* Tableau auxiliaire des coefficients de (UPARA1-UPARA0)T+UPARA0 a */
1432/* la puissance N=1 a NCOEFF-1. */
1433
1434
1435 /* Parameter adjustments */
1436 crvnew_dim1 = *ndimax;
1437 crvnew_offset = crvnew_dim1 + 1;
1438 crvnew -= crvnew_offset;
1439 crvold_dim1 = *ndimax;
1440 crvold_offset = crvold_dim1 + 1;
1441 crvold -= crvold_offset;
1442
1443 /* Function Body */
1444 *iercod = 0;
1445/* **********************************************************************
1446*/
1447/* CAS OU LE TRAITEMENT NE PEUT ETRE FAIT */
1448/* **********************************************************************
1449*/
1450 if (*ncoeff > 61 || *ncoeff < 1) {
1451 *iercod = 10;
1452 goto L9999;
1453 }
1454/* **********************************************************************
1455*/
1456/* SI PAS DE CHANGEMENT */
1457/* **********************************************************************
1458*/
1459 if (*ndimen == *ndimax && *upara0 == 0. && *upara1 == 1.) {
1460 nboct = (*ndimax << 3) * *ncoeff;
1461 AdvApp2Var_SysBase::mcrfill_((integer *)&nboct,
1462 (char *)&crvold[crvold_offset],
1463 (char *)&crvnew[crvnew_offset]);
1464 goto L9999;
1465 }
1466/* **********************************************************************
1467*/
1468/* INVERSION 3D : TRAITEMENT RAPIDE */
1469/* **********************************************************************
1470*/
1471 if (*upara0 == 1. && *upara1 == 0.) {
1472 if (*ndimen == 3 && *ndimax == 3 && *ncoeff <= 21) {
1473 mvcvinv_(ncoeff, &crvold[crvold_offset], &crvnew[crvnew_offset],
1474 iercod);
1475 goto L9999;
1476 }
1477/* ******************************************************************
1478**** */
1479/* INVERSION 2D : TRAITEMENT RAPIDE */
1480/* ******************************************************************
1481**** */
1482 if (*ndimen == 2 && *ndimax == 2 && *ncoeff <= 21) {
1483 mvcvin2_(ncoeff, &crvold[crvold_offset], &crvnew[crvnew_offset],
1484 iercod);
1485 goto L9999;
1486 }
1487 }
1488/* **********************************************************************
1489*/
1490/* TRAITEMENT GENERAL */
1491/* **********************************************************************
1492*/
1493/* -------------------------- Initialisations ---------------------------
1494*/
1495
1496 i__1 = *ndimen;
1497 for (nd = 1; nd <= i__1; ++nd) {
1498 crvnew[nd + crvnew_dim1] = crvold[nd + crvold_dim1];
1499/* L100: */
1500 }
1501 if (*ncoeff == 1) {
1502 goto L9999;
1503 }
1504 tbaux[0] = *upara0;
1505 tbaux[1] = *upara1 - *upara0;
1506
1507/* ----------------------- Calcul des coeff. de CRVNEW ------------------
1508*/
1509
1510 i__1 = *ncoeff - 1;
1511 for (ncf = 2; ncf <= i__1; ++ncf) {
1512
1513/* ------------ Prise en compte du NCF-ieme coeff. de CRVOLD --------
1514---- */
1515
1516 i__2 = ncf - 1;
1517 for (ncj = 1; ncj <= i__2; ++ncj) {
1518 bid = tbaux[ncj - 1];
1519 i__3 = *ndimen;
1520 for (nd = 1; nd <= i__3; ++nd) {
1521 crvnew[nd + ncj * crvnew_dim1] += crvold[nd + ncf *
1522 crvold_dim1] * bid;
1523/* L400: */
1524 }
1525/* L300: */
1526 }
1527
1528 bid = tbaux[ncf - 1];
1529 i__2 = *ndimen;
1530 for (nd = 1; nd <= i__2; ++nd) {
1531 crvnew[nd + ncf * crvnew_dim1] = crvold[nd + ncf * crvold_dim1] *
1532 bid;
1533/* L500: */
1534 }
1535
1536/* --------- Calcul des (NCF+1) coeff. de ((U1-U0)*t + U0)**(NCF) ---
1537---- */
1538
1539 bid = *upara1 - *upara0;
1540 tbaux[ncf] = tbaux[ncf - 1] * bid;
1541 for (ncj = ncf; ncj >= 2; --ncj) {
1542 tbaux[ncj - 1] = tbaux[ncj - 1] * *upara0 + tbaux[ncj - 2] * bid;
1543/* L600: */
1544 }
1545 tbaux[0] *= *upara0;
1546
1547/* L200: */
1548 }
1549
1550/* -------------- Prise en compte du dernier coeff. de CRVOLD -----------
1551*/
1552
1553 i__1 = *ncoeff - 1;
1554 for (ncj = 1; ncj <= i__1; ++ncj) {
1555 bid = tbaux[ncj - 1];
1556 i__2 = *ndimen;
1557 for (nd = 1; nd <= i__2; ++nd) {
1558 crvnew[nd + ncj * crvnew_dim1] += crvold[nd + *ncoeff *
1559 crvold_dim1] * bid;
1560/* L800: */
1561 }
1562/* L700: */
1563 }
1564 i__1 = *ndimen;
1565 for (nd = 1; nd <= i__1; ++nd) {
1566 crvnew[nd + *ncoeff * crvnew_dim1] = crvold[nd + *ncoeff *
1567 crvold_dim1] * tbaux[*ncoeff - 1];
1568/* L900: */
1569 }
1570
1571/* ---------------------------- The end ---------------------------------
1572*/
1573
1574L9999:
1575 if (*iercod != 0) {
1576 AdvApp2Var_SysBase::maermsg_("MMARC41", iercod, 7L);
1577 }
1578
1579 return 0 ;
1580} /* mmarc41_ */
1581
1582//=======================================================================
1583//function : AdvApp2Var_MathBase::mmarcin_
1584//purpose :
1585//=======================================================================
1586int AdvApp2Var_MathBase::mmarcin_(integer *ndimax,
1587 integer *ndim,
1588 integer *ncoeff,
1589 doublereal *crvold,
1590 doublereal *u0,
1591 doublereal *u1,
1592 doublereal *crvnew,
1593 integer *iercod)
1594
1595{
1596 /* System generated locals */
1597 integer crvold_dim1, crvold_offset, crvnew_dim1, crvnew_offset, i__1,
1598 i__2, i__3;
1599 doublereal d__1;
1600
1601 /* Local variables */
1602 static doublereal x0, x1;
1603 static integer nd;
1604 static doublereal tabaux[61];
1605 static integer ibb;
1606 static doublereal bid;
1607 static integer ncf;
1608 static integer ncj;
1609 static doublereal eps3;
1610
1611
1612
1613/* **********************************************************************
1614*/
1615
1616/* FONCTION : */
1617/* ---------- */
1618/* Creation de la courbe C2(v) definie sur [U0,U1] identique a */
1619/* la courbe C1(u) definie sur [-1,1] (changement du parametre */
1620/* d' une courbe) avec INVERSION des indices du tableau resultat. */
1621
1622/* MOTS CLES : */
1623/* ----------- */
1624/* LIMITATION GENERALISEE,RESTRICTION,INVERSION,COURBE */
1625
1626/* ARGUMENTS D'ENTREE : */
1627/* ------------------ */
1628/* NDIMAX : Dimensionnement maximal de l' espace. */
1629/* NDIM : Dimension de la courbe. */
1630/* NCOEFF : Nbre de coefficients de la courbe. */
1631/* CRVOLD : La courbe a limiter. */
1632/* U0 : Borne min de l' intervalle de restriction de la courbe. */
1633/* U1 : Borne max de l' intervalle de restriction de la courbe. */
1634
1635/* ARGUMENTS DE SORTIE : */
1636/* ------------------- */
1637/* CRVNEW : La courbe relimitee, definie dans [U0,U1] et egale a */
1638/* CRVOLD definie dans [-1,1]. */
1639/* IERCOD : = 0, OK */
1640/* =10, Nbre de coeff. <1 ou > 61. */
1641/* =13, L' intervalle de variation demande est nul. */
1642
1643/* COMMONS UTILISES : */
1644/* ---------------- */
1645
1646/* REFERENCES APPELEES : */
1647/* ----------------------- */
1648
1649/* DESCRIPTION/REMARQUES/LIMITATIONS : */
1650/* ----------------------------------- */
1651
1652/* $ HISTORIQUE DES MODIFICATIONS : */
1653/* -------------------------------- */
1654/* 21-11-1989 : RBD ; Correction Trait. general parametre X1. */
1655/* 12-04-1989 : RBD ; Creation d' apres MMARC41. */
1656/* > */
1657/* **********************************************************************
1658*/
1659
1660/* Le nom de la routine */
1661
1662/* Tableau auxiliaire des coefficients de X1*T+X0 a */
1663/* la puissance N=1 a NCOEFF-1. */
1664
1665
1666 /* Parameter adjustments */
1667 crvnew_dim1 = *ndimax;
1668 crvnew_offset = crvnew_dim1 + 1;
1669 crvnew -= crvnew_offset;
1670 crvold_dim1 = *ncoeff;
1671 crvold_offset = crvold_dim1 + 1;
1672 crvold -= crvold_offset;
1673
1674 /* Function Body */
1675 ibb = AdvApp2Var_SysBase::mnfndeb_();
1676 if (ibb >= 2) {
1677 AdvApp2Var_SysBase::mgenmsg_("MMARCIN", 7L);
1678 }
1679
1680/* On teste au zero machine que l' intervalle d' arrivee n' est pas nul */
1681
1682 AdvApp2Var_MathBase::mmveps3_(&eps3);
1683 if ((d__1 = *u1 - *u0, abs(d__1)) < eps3) {
1684 *iercod = 13;
1685 goto L9999;
1686 }
1687 *iercod = 0;
1688
1689/* **********************************************************************
1690*/
1691/* CAS OU LE TRAITEMENT NE PEUT ETRE FAIT */
1692/* **********************************************************************
1693*/
1694 if (*ncoeff > 61 || *ncoeff < 1) {
1695 *iercod = 10;
1696 goto L9999;
1697 }
1698/* **********************************************************************
1699*/
1700/* SI PAS DE CHANGEMENT DE L' INTERVALLE DE DEFINITION */
1701/* (SEULEMENT INVERSION DES INDICES DU TABLEAU CRVOLD) */
1702/* **********************************************************************
1703*/
1704 if (*ndim == *ndimax && *u0 == -1. && *u1 == 1.) {
1705 AdvApp2Var_MathBase::mmcvinv_(ndim, ncoeff, ndim, &crvold[crvold_offset], &crvnew[
1706 crvnew_offset]);
1707 goto L9999;
1708 }
1709/* **********************************************************************
1710*/
1711/* CAS OU LE NOUVEL INTERVALLE DE DEFINITION EST [0,1] */
1712/* **********************************************************************
1713*/
1714 if (*u0 == 0. && *u1 == 1.) {
1715 mmcvstd_(ncoeff, ndimax, ncoeff, ndim, &crvold[crvold_offset], &
1716 crvnew[crvnew_offset]);
1717 goto L9999;
1718 }
1719/* **********************************************************************
1720*/
1721/* TRAITEMENT GENERAL */
1722/* **********************************************************************
1723*/
1724/* -------------------------- Initialisations ---------------------------
1725*/
1726
1727 x0 = -(*u1 + *u0) / (*u1 - *u0);
1728 x1 = 2. / (*u1 - *u0);
1729 i__1 = *ndim;
1730 for (nd = 1; nd <= i__1; ++nd) {
1731 crvnew[nd + crvnew_dim1] = crvold[nd * crvold_dim1 + 1];
1732/* L100: */
1733 }
1734 if (*ncoeff == 1) {
1735 goto L9999;
1736 }
1737 tabaux[0] = x0;
1738 tabaux[1] = x1;
1739
1740/* ----------------------- Calcul des coeff. de CRVNEW ------------------
1741*/
1742
1743 i__1 = *ncoeff - 1;
1744 for (ncf = 2; ncf <= i__1; ++ncf) {
1745
1746/* ------------ Prise en compte du NCF-ieme coeff. de CRVOLD --------
1747---- */
1748
1749 i__2 = ncf - 1;
1750 for (ncj = 1; ncj <= i__2; ++ncj) {
1751 bid = tabaux[ncj - 1];
1752 i__3 = *ndim;
1753 for (nd = 1; nd <= i__3; ++nd) {
1754 crvnew[nd + ncj * crvnew_dim1] += crvold[ncf + nd *
1755 crvold_dim1] * bid;
1756/* L400: */
1757 }
1758/* L300: */
1759 }
1760
1761 bid = tabaux[ncf - 1];
1762 i__2 = *ndim;
1763 for (nd = 1; nd <= i__2; ++nd) {
1764 crvnew[nd + ncf * crvnew_dim1] = crvold[ncf + nd * crvold_dim1] *
1765 bid;
1766/* L500: */
1767 }
1768
1769/* --------- Calcul des (NCF+1) coeff. de [X1*t + X0]**(NCF) --------
1770---- */
1771
1772 tabaux[ncf] = tabaux[ncf - 1] * x1;
1773 for (ncj = ncf; ncj >= 2; --ncj) {
1774 tabaux[ncj - 1] = tabaux[ncj - 1] * x0 + tabaux[ncj - 2] * x1;
1775/* L600: */
1776 }
1777 tabaux[0] *= x0;
1778
1779/* L200: */
1780 }
1781
1782/* -------------- Prise en compte du dernier coeff. de CRVOLD -----------
1783*/
1784
1785 i__1 = *ncoeff - 1;
1786 for (ncj = 1; ncj <= i__1; ++ncj) {
1787 bid = tabaux[ncj - 1];
1788 i__2 = *ndim;
1789 for (nd = 1; nd <= i__2; ++nd) {
1790 crvnew[nd + ncj * crvnew_dim1] += crvold[*ncoeff + nd *
1791 crvold_dim1] * bid;
1792/* L800: */
1793 }
1794/* L700: */
1795 }
1796 i__1 = *ndim;
1797 for (nd = 1; nd <= i__1; ++nd) {
1798 crvnew[nd + *ncoeff * crvnew_dim1] = crvold[*ncoeff + nd *
1799 crvold_dim1] * tabaux[*ncoeff - 1];
1800/* L900: */
1801 }
1802
1803/* ---------------------------- The end ---------------------------------
1804*/
1805
1806L9999:
1807 if (*iercod > 0) {
1808 AdvApp2Var_SysBase::maermsg_("MMARCIN", iercod, 7L);
1809 }
1810 if (ibb >= 2) {
1811 AdvApp2Var_SysBase::mgsomsg_("MMARCIN", 7L);
1812 }
1813 return 0;
1814} /* mmarcin_ */
1815
1816//=======================================================================
1817//function : mmatvec_
1818//purpose :
1819//=======================================================================
1820int mmatvec_(integer *nligne,
1821 integer *,//ncolon,
1822 integer *gposit,
1823 integer *,//gnstoc,
1824 doublereal *gmatri,
1825 doublereal *vecin,
1826 integer *deblig,
1827 doublereal *vecout,
1828 integer *iercod)
1829
1830{
1831 /* System generated locals */
1832 integer i__1, i__2;
1833
1834 /* Local variables */
1835 static logical ldbg;
1836 static integer jmin, jmax, i__, j, k;
1837 static doublereal somme;
1838 static integer aux;
1839
1840
1841/* ***********************************************************************
1842 */
1843
1844/* FONCTION : */
1845/* ---------- */
1846/* EFFECUE LE PRODUIT MATRICE VECTEUR OU LA MATRICE EST SOUS FORME */
1847/* DE PROFIL */
1848
1849
1850/* MOTS CLES : */
1851/* ----------- */
1852/* RESERVE, MATRICE, PRODUIT, VECTEUR, PROFIL */
1853
1854/* ARGUMENTS D'ENTREE : */
1855/* -------------------- */
1856/* NLIGNE : NOMBRE DE LIGNE DE LA MATRICE DES CONTRAINTES */
1857/* NCOLON :NOMBRE DE COLONNE DE LA MATRICE DES CONTRAINTES */
1858/* GNSTOC: NOMBRE DE COEFFICIENTS DANS LE PROFILE de la matrice */
1859/* GMATRI */
1860
1861/* GPOSIT: TABLE DE POSITIONNEMENT DES TERMES DE STOCKAGE */
1862/* GPOSIT(1,I) CONTIENT LE NOMBRE DE TERMES-1 SUR LA LIGNE
1863*/
1864/* I DANS LE PROFIL DE LA MATRICE */
1865/* GPOSIT(2,I) CONTIENT L'INDICE DE STOCKAGE DU TERME DIAGONA
1866L*/
1867/* DE LA LIGNE I */
1868/* GPOSIT(3,I) CONTIENT L'INDICE COLONE DU PREMIER TERME DU
1869*/
1870/* PROFIL DE LA LIGNE I */
1871/* GNSTOC: NOMBRE DE COEFFICIENTS DANS LE PROFILE de la matrice */
1872/* GMATRI */
1873/* GMATRI : MATRICE DES CONTRAINTES SOUS FORME DE PROFIL */
1874/* VECIN : VECTEUR ENTRE */
1875/* DEBLIG : INDICE DE LIGNE A PARTIR DUQUEL ON VEUT CALCULER */
1876/* LE PRODUIT MATRICE VECTEUR */
1877/* ARGUMENTS DE SORTIE : */
1878/* --------------------- */
1879/* VECOUT : VECTEUR PRODUIT */
1880
1881/* IERCOD : CODE D'ERREUR */
1882
1883
1884/* COMMONS UTILISES : */
1885/* ------------------ */
1886
1887
1888/* REFERENCES APPELEES : */
1889/* --------------------- */
1890
1891
1892/* DESCRIPTION/REMARQUES/LIMITATIONS : */
1893/* ----------------------------------- */
1894
1895
1896/* $ HISTORIQUE DES MODIFICATIONS : */
1897/* ------------------------------ */
1898/* 22-09-95 : ...; ECRITURE VERSION ORIGINALE. */
1899/* > */
1900/* ***********************************************************************
1901 */
1902/* DECLARATIONS */
1903/* ***********************************************************************
1904 */
1905
1906
1907
1908/* ***********************************************************************
1909 */
1910/* INITIALISATIONS */
1911/* ***********************************************************************
1912 */
1913
1914 /* Parameter adjustments */
1915 --vecout;
1916 gposit -= 4;
1917 --vecin;
1918 --gmatri;
1919
1920 /* Function Body */
1921 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 2;
1922 if (ldbg) {
1923 AdvApp2Var_SysBase::mgenmsg_("MMATVEC", 7L);
1924 }
1925 *iercod = 0;
1926
1927/* ***********************************************************************
1928 */
1929/* TRAITEMENT */
1930/* ***********************************************************************
1931 */
1932 AdvApp2Var_SysBase::mvriraz_((integer *)nligne,
1933 (char *)&vecout[1]);
1934 i__1 = *nligne;
1935 for (i__ = *deblig; i__ <= i__1; ++i__) {
1936 somme = 0.;
1937 jmin = gposit[i__ * 3 + 3];
1938 jmax = gposit[i__ * 3 + 1] + gposit[i__ * 3 + 3] - 1;
1939 aux = gposit[i__ * 3 + 2] - gposit[i__ * 3 + 1] - jmin + 1;
1940 i__2 = jmax;
1941 for (j = jmin; j <= i__2; ++j) {
1942 k = j + aux;
1943 somme += gmatri[k] * vecin[j];
1944 }
1945 vecout[i__] = somme;
1946 }
1947
1948
1949
1950
1951
1952 goto L9999;
1953
1954/* ***********************************************************************
1955 */
1956/* TRAITEMENT DES ERREURS */
1957/* ***********************************************************************
1958 */
1959
1960
1961
1962
1963/* ***********************************************************************
1964 */
1965/* RETOUR PROGRAMME APPELANT */
1966/* ***********************************************************************
1967 */
1968
1969L9999:
1970
1971/* ___ DESALLOCATION, ... */
1972
1973 AdvApp2Var_SysBase::maermsg_("MMATVEC", iercod, 7L);
1974 if (ldbg) {
1975 AdvApp2Var_SysBase::mgsomsg_("MMATVEC", 7L);
1976 }
1977
1978 return 0 ;
1979} /* mmatvec_ */
1980
1981//=======================================================================
1982//function : mmbulld_
1983//purpose :
1984//=======================================================================
1985int AdvApp2Var_MathBase::mmbulld_(integer *nbcoln,
1986 integer *nblign,
1987 doublereal *dtabtr,
1988 integer *numcle)
1989
1990{
1991 /* System generated locals */
1992 integer dtabtr_dim1, dtabtr_offset, i__1, i__2;
1993
1994 /* Local variables */
1995 static logical ldbg;
1996 static doublereal daux;
1997 static integer nite1, nite2, nchan, i1, i2;
1998
1999/* ***********************************************************************
2000 */
2001
2002/* FONCTION : */
2003/* ---------- */
2004/* TRI PAR BULLE DES COLONNES D'UN TABLEAU D'ENTIER DANS LE SENS */
2005/* CROISSANT */
2006
2007/* MOTS CLES : */
2008/* ----------- */
2009/* POINT-ENTREE, TRI, BULLE */
2010
2011/* ARGUMENTS D'ENTREE : */
2012/* -------------------- */
2013/* - NBCOLN : NOMBRE DE COLONNES DU TABLEAU */
2014/* - NBLIGN : NOMBRE DE LIGNE DU TABLEAU */
2015/* - DTABTR : TABLEAU D'ENTIER A TRIER */
2016/* - NUMCLE : POSITION DE LA CLE SUR LA COLONNE */
2017
2018/* ARGUMENTS DE SORTIE : */
2019/* --------------------- */
2020/* - DTABTR : TABLEAU TRIE */
2021
2022/* COMMONS UTILISES : */
2023/* ------------------ */
2024
2025
2026/* REFERENCES APPELEES : */
2027/* --------------------- */
2028
2029
2030/* DESCRIPTION/REMARQUES/LIMITATIONS : */
2031/* ----------------------------------- */
2032/* PARTICULIEREMENT PERFORMANT LORSQUE LE TABLEAU EST PRESQUE TRIE */
2033/* Dans le cas contraire il vaut mieux utiliser MVSHELD */
2034
2035/* $ HISTORIQUE DES MODIFICATIONS : */
2036/* ------------------------------ */
2037/* 25-09-1995: PMN; ECRITURE VERSION ORIGINALE d'apres MBULLE */
2038/* > */
2039/* ***********************************************************************
2040 */
2041/* DECLARATIONS */
2042/* ***********************************************************************
2043 */
2044
2045
2046
2047/* ***********************************************************************
2048 */
2049/* INITIALISATIONS */
2050/* ***********************************************************************
2051 */
2052
2053 /* Parameter adjustments */
2054 dtabtr_dim1 = *nblign;
2055 dtabtr_offset = dtabtr_dim1 + 1;
2056 dtabtr -= dtabtr_offset;
2057
2058 /* Function Body */
2059 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 2;
2060 if (ldbg) {
2061 AdvApp2Var_SysBase::mgenmsg_("MMBULLD", 7L);
2062 }
2063 nchan = 1;
2064 nite1 = *nbcoln;
2065 nite2 = 2;
2066
2067/* ***********************************************************************
2068 */
2069/* TRAITEMENT */
2070/* ***********************************************************************
2071 */
2072
2073/* ---->ALGORITHME EN N^2 / 2 ITERATION AU PLUS */
2074
2075 while(nchan != 0) {
2076
2077/* ----> PARCOURS DE GAUCHE A DROITE */
2078
2079 nchan = 0;
2080 i__1 = nite1;
2081 for (i1 = nite2; i1 <= i__1; ++i1) {
2082 if (dtabtr[*numcle + i1 * dtabtr_dim1] < dtabtr[*numcle + (i1 - 1)
2083 * dtabtr_dim1]) {
2084 i__2 = *nblign;
2085 for (i2 = 1; i2 <= i__2; ++i2) {
2086 daux = dtabtr[i2 + (i1 - 1) * dtabtr_dim1];
2087 dtabtr[i2 + (i1 - 1) * dtabtr_dim1] = dtabtr[i2 + i1 *
2088 dtabtr_dim1];
2089 dtabtr[i2 + i1 * dtabtr_dim1] = daux;
2090 }
2091 if (nchan == 0) {
2092 nchan = 1;
2093 }
2094 }
2095 }
2096 --nite1;
2097
2098/* ----> PARCOURS DE DROITE A GAUCHE */
2099
2100 if (nchan != 0) {
2101 nchan = 0;
2102 i__1 = nite2;
2103 for (i1 = nite1; i1 >= i__1; --i1) {
2104 if (dtabtr[*numcle + i1 * dtabtr_dim1] < dtabtr[*numcle + (i1
2105 - 1) * dtabtr_dim1]) {
2106 i__2 = *nblign;
2107 for (i2 = 1; i2 <= i__2; ++i2) {
2108 daux = dtabtr[i2 + (i1 - 1) * dtabtr_dim1];
2109 dtabtr[i2 + (i1 - 1) * dtabtr_dim1] = dtabtr[i2 + i1 *
2110 dtabtr_dim1];
2111 dtabtr[i2 + i1 * dtabtr_dim1] = daux;
2112 }
2113 if (nchan == 0) {
2114 nchan = 1;
2115 }
2116 }
2117 }
2118 ++nite2;
2119 }
2120 }
2121
2122
2123 goto L9999;
2124
2125/* ***********************************************************************
2126 */
2127/* TRAITEMENT DES ERREURS */
2128/* ***********************************************************************
2129 */
2130
2131/* ----> PAS D'ERREURS EN APPELANT DES FONCTIONS, ON A UNIQUEMENT DES */
2132/* TESTS ET DES BOUCLES. */
2133
2134/* ***********************************************************************
2135 */
2136/* RETOUR PROGRAMME APPELANT */
2137/* ***********************************************************************
2138 */
2139
2140L9999:
2141
2142 if (ldbg) {
2143 AdvApp2Var_SysBase::mgsomsg_("MMBULLD", 7L);
2144 }
2145
2146 return 0 ;
2147} /* mmbulld_ */
2148
2149
2150//=======================================================================
2151//function : AdvApp2Var_MathBase::mmcdriv_
2152//purpose :
2153//=======================================================================
2154int AdvApp2Var_MathBase::mmcdriv_(integer *ndimen,
2155 integer *ncoeff,
2156 doublereal *courbe,
2157 integer *ideriv,
2158 integer *ncofdv,
2159 doublereal *crvdrv)
2160
2161
2162{
2163 /* System generated locals */
2164 integer courbe_dim1, courbe_offset, crvdrv_dim1, crvdrv_offset, i__1,
2165 i__2;
2166
2167 /* Local variables */
2168 static integer i__, j, k;
2169 static doublereal mfactk, bid;
2170
2171
2172/* ***********************************************************************
2173 */
2174
2175/* FONCTION : */
2176/* ---------- */
2177/* CALCUL DE LA MATRICE D'UNE COURBE DERIVEE D' ORDRE IDERIV. */
2178/* AVEC PARAMETRES D' ENTRE DISTINCT DES PARAMETRES DE SORTIE. */
2179
2180
2181/* MOTS CLES : */
2182/* ----------- */
2183/* COEFFICIENTS,COURBE,DERIVEE I-EME. */
2184
2185/* ARGUMENTS D'ENTREE : */
2186/* ------------------ */
2187/* NDIMEN : Dimension de l'espace (2 ou 3 en general) */
2188/* NCOEFF : Le degre +1 de la courbe. */
2189/* COURBE : Tableau des coefficients de la courbe. */
2190/* IDERIV : Ordre de derivation demande : 1=derivee 1ere, etc... */
2191
2192/* ARGUMENTS DE SORTIE : */
2193/* ------------------- */
2194/* NCOFDV : Le degre +1 de la derivee d' ordre IDERIV de la courbe. */
2195/* CRVDRV : Tableau des coefficients de la derivee d' ordre IDERIV */
2196/* de la courbe. */
2197
2198/* COMMONS UTILISES : */
2199/* ---------------- */
2200
2201/* REFERENCES APPELEES : */
2202/* ----------------------- */
2203
2204/* DESCRIPTION/REMARQUES/LIMITATIONS : */
2205/* ----------------------------------- */
2206
2207/* ---> Il est possible de prendre comme argument de sortie la courbe */
2208/* et le nombre de coeff passes en entree en faisant : */
2209/* CALL MMCDRIV(NDIMEN,NCOEFF,COURBE,IDERIV,NCOEFF,COURBE). */
2210/* Apres cet appel, NCOEFF doone le nbre de coeff de la courbe */
2211/* derivee dont les coefficients sont stockes dans COURBE. */
2212/* Attention alors aux coefficients de COURBE de rang superieur a */
2213/* NCOEFF : il ne sont pas mis a zero. */
2214
2215/* ---> Algorithme : */
2216/* Le code ci dessous a ete ecrit a partir de l' algorithme suivant:
2217*/
2218
2219/* Soit P(t) = a1 + a2*t + ... an*t**n. La derivee d' ordre k de P */
2220/* (comportant n-k coefficients) est calculee ainsi : */
2221
2222/* Pk(t) = a(k+1)*CNP(k,k)*k! */
2223/* + a(k+2)*CNP(k+1,k)*k! * t */
2224/* . */
2225/* . */
2226/* . */
2227/* + a(n)*CNP(n-1,k)*k! * t**(n-k-1). */
2228
2229/* $ HISTORIQUE DES MODIFICATIONS : */
2230/* -------------------------------- */
2231/* 09-01-90 : TE ; COMMON MCCNP -> MMCMCNP.INC & INDICES DES CNP */
2232/* 07-10-88 : RBD; Creation. */
2233/* > */
2234/* ***********************************************************************
2235 */
2236
2237
2238/* -------------- Cas ou l' ordre de derivee est plus -------------------
2239*/
2240/* ---------------- grand que le degre de la courbe ---------------------
2241*/
2242
2243/* **********************************************************************
2244*/
2245
2246/* FONCTION : */
2247/* ---------- */
2248/* Sert a fournir les coefficients du binome (triangle de Pascal). */
2249
2250/* MOTS CLES : */
2251/* ----------- */
2252/* Coeff du binome de 0 a 60. read only . init par block data */
2253
2254/* DEMSCRIPTION/REMARQUES/LIMITATIONS : */
2255/* ----------------------------------- */
2256/* Les coefficients du binome forment une matrice triangulaire. */
2257/* On complete cette matrice dans le tableau CNP par sa transposee. */
2258/* On a donc: CNP(I,J) = CNP(J,I) pour I et J = 0, ..., 60. */
2259
2260/* L'initialisation est faite a partir du block-data MMLLL09.RES, */
2261/* cree par le programme MQINICNP.FOR (voir l'equipe (AC) ). */
2262
2263/* $ HISTORIQUE DES MODIFICATIONS : */
2264/* ------------------------------ */
2265/* 03-07-90 : RBD; Ajout commentaires (nom du block-data). */
2266/* 19-06-90 : RBD; Le commun MMCMCNP remplace MCCNP qui est obsolete.
2267*/
2268/* 08-01-90 : TE ; CREATION */
2269/* > */
2270/* **********************************************************************
2271*/
2272
2273
2274
2275/* ***********************************************************************
2276 */
2277
2278 /* Parameter adjustments */
2279 crvdrv_dim1 = *ndimen;
2280 crvdrv_offset = crvdrv_dim1 + 1;
2281 crvdrv -= crvdrv_offset;
2282 courbe_dim1 = *ndimen;
2283 courbe_offset = courbe_dim1 + 1;
2284 courbe -= courbe_offset;
2285
2286 /* Function Body */
2287 if (*ideriv >= *ncoeff) {
2288 i__1 = *ndimen;
2289 for (i__ = 1; i__ <= i__1; ++i__) {
2290 crvdrv[i__ + crvdrv_dim1] = 0.;
2291/* L10: */
2292 }
2293 *ncofdv = 1;
2294 goto L9999;
2295 }
2296/* **********************************************************************
2297*/
2298/* Traitement general */
2299/* **********************************************************************
2300*/
2301/* --------------------- Calcul de Factorielle(IDERIV) ------------------
2302*/
2303
2304 k = *ideriv;
2305 mfactk = 1.;
2306 i__1 = k;
2307 for (i__ = 2; i__ <= i__1; ++i__) {
2308 mfactk *= i__;
2309/* L50: */
2310 }
2311
2312/* ------------ Calcul des coeff de la derivee d' ordre IDERIV ----------
2313*/
2314/* ---> Attention : le coefficient binomial C(n,m) est represente dans */
2315/* MCCNP par CNP(N+1,M+1). */
2316
2317 i__1 = *ncoeff;
2318 for (j = k + 1; j <= i__1; ++j) {
2319 bid = mmcmcnp_.cnp[j - 1 + k * 61] * mfactk;
2320 i__2 = *ndimen;
2321 for (i__ = 1; i__ <= i__2; ++i__) {
2322 crvdrv[i__ + (j - k) * crvdrv_dim1] = bid * courbe[i__ + j *
2323 courbe_dim1];
2324/* L200: */
2325 }
2326/* L100: */
2327 }
2328
2329 *ncofdv = *ncoeff - *ideriv;
2330
2331/* -------------------------------- The end -----------------------------
2332*/
2333
2334L9999:
2335 return 0;
2336} /* mmcdriv_ */
2337
2338//=======================================================================
2339//function : AdvApp2Var_MathBase::mmcglc1_
2340//purpose :
2341//=======================================================================
2342int AdvApp2Var_MathBase::mmcglc1_(integer *ndimax,
2343 integer *ndimen,
2344 integer *ncoeff,
2345 doublereal *courbe,
2346 doublereal *tdebut,
2347 doublereal *tfinal,
2348 doublereal *epsiln,
2349 doublereal *xlongc,
2350 doublereal *erreur,
2351 integer *iercod)
2352
2353
2354{
2355 /* System generated locals */
2356 integer courbe_dim1, courbe_offset, i__1;
2357 doublereal d__1;
2358
2359 /* Local variables */
2360 static integer ndec;
2361 static doublereal tdeb, tfin;
2362 static integer iter;
2363 static doublereal oldso;
2364 static integer itmax;
2365 static doublereal sottc;
2366 static integer kk, ibb;
2367 static doublereal dif, pas;
2368 static doublereal som;
2369
2370
2371/* ***********************************************************************
2372 */
2373
2374/* FONCTION : */
2375/* ---------- */
2376/* Permet de calculer la longueur d'un arc de courbe POLYNOMIAL */
2377/* sur un intervalle [A,B] quelconque. */
2378
2379/* MOTS CLES : */
2380/* ----------- */
2381/* LONGUEUR,COURBE,GAUSS,PRIVE. */
2382
2383/* ARGUMENTS DD'ENTREE : */
2384/* ------------------ */
2385/* NDIMAX : Nombre de lignes maximum des tableaux */
2386/* (i.e. nbre maxi des polynomes). */
2387/* NDIMEN : Dimension de l'espace (nbre de polynomes). */
2388/* NCOEFF : Nombre de coefficients du polynome. C'est le degre + 1.
2389*/
2390/* COURBE(NDIMAX,NCOEFF) : Coefficients de la courbe. */
2391/* TDEBUT : Borne inferieure de l'intervalle d'integration pour */
2392/* le calcul de la longueur. */
2393/* TFINAL : Borne superieure de l'intervalle d'integration pour */
2394/* le calcul de la longueur. */
2395/* EPSILN : Precision DEMANDEE sur le calcul de la longueur. */
2396
2397/* ARGUMENTS DE SORTIE : */
2398/* ------------------- */
2399/* XLONGC : Longueur de l'arc de courbe */
2400/* ERREUR : Precision OBTENUE sur le calcul de la longueur. */
2401/* IERCOD : Code d' erreur, 0 OK, >0 Erreur grave. */
2402/* = 1 Trop d'iterations, on sort le meilleur resultat */
2403/* calcule (a ERREUR pres) */
2404/* = 2 Pb MMLONCV (pas de resultat) */
2405/* = 3 NDIM ou NCOEFF invalides (pas de resultat) */
2406
2407/* COMMONS UTILISES : */
2408/* ---------------- */
2409
2410/* REFERENCES APPELEES : */
2411/* ----------------------- */
2412
2413/* DESCRIPTION/REMARQUES/LIMITATIONS : */
2414/* ----------------------------------- */
2415/* Le polynome est en fait un ensemble de polynomes dont les */
2416/* coefficients sont ranges dans un tableau a 2 indices, chaque */
2417/* ligne etant relative a 1 polynome. */
2418/* Le polynome est defini par ses coefficients ordonne par les */
2419/* puissances croissantes de la variable. */
2420/* Tous les polynomes ont le meme nombre de coefficients (donc le */
2421/* meme degre). */
2422
2423/* Ce programme annule et remplace LENGCV, MLONGC et MLENCV. */
2424
2425/* ATTENTION : si TDEBUT > TFINAL, la longueur est alors NEGATIVE. */
2426
2427/* $ HISTORIQUE DES MODIFICATIONS : */
2428/* -------------------------------- */
2429/* 22-04-1991: ALR; ITMAX en dur a 13 */
2430/* 14-05-1990: RBD; Appel MITERR au lieu de MEPSNR pour ITMAX */
2431/* 26-04-1990: RBD; Creation. */
2432/* > */
2433/* ***********************************************************************
2434 */
2435
2436/* Le nom de la routine */
2437
2438
2439/* ------------------------ Initialisation generale ---------------------
2440*/
2441
2442 /* Parameter adjustments */
2443 courbe_dim1 = *ndimax;
2444 courbe_offset = courbe_dim1 + 1;
2445 courbe -= courbe_offset;
2446
2447 /* Function Body */
2448 ibb = AdvApp2Var_SysBase::mnfndeb_();
2449 if (ibb >= 2) {
2450 AdvApp2Var_SysBase::mgenmsg_("MMCGLC1", 7L);
2451 }
2452
2453 *iercod = 0;
2454 *xlongc = 0.;
2455 *erreur = 0.;
2456
2457/* ------ Test d'egalite des bornes */
2458
2459 if (*tdebut == *tfinal) {
2460 *iercod = 0;
2461 goto L9999;
2462 }
2463
2464/* ------ Test de la dimension et du nombre de coefficients */
2465
2466 if (*ndimen <= 0 || *ncoeff <= 0) {
2467 goto L9003;
2468 }
2469
2470/* ------ Nbre de decoupe en cours, nbre d'iteration, */
2471/* nbre max d'iterations */
2472
2473 ndec = 1;
2474 iter = 1;
2475
2476/* ALR NE PAS APPELER DE NOMBRE D ITERATION VENANT */
2477/* D'ON NE SAIT OU !! 8 EST MIS EN DUR EXPRES !! */
2478
2479 itmax = 13;
2480
2481/* ------ Variation du nombre d'intervalles */
2482/* On multiplie par 2 a chaque iteration */
2483
2484L5000:
2485 pas = (*tfinal - *tdebut) / ndec;
2486 sottc = 0.;
2487
2488/* ------ Boucle sur tous les NDEC intervalles en cours */
2489
2490 i__1 = ndec;
2491 for (kk = 1; kk <= i__1; ++kk) {
2492
2493/* ------ Bornes de l'intervalle d'integration en cours */
2494
2495 tdeb = *tdebut + (kk - 1) * pas;
2496 tfin = tdeb + pas;
2497 mmloncv_(ndimax, ndimen, ncoeff, &courbe[courbe_offset], &tdeb, &tfin,
2498 &som, iercod);
2499 if (*iercod > 0) {
2500 goto L9002;
2501 }
2502
2503 sottc += som;
2504
2505/* L100: */
2506 }
2507
2508
2509/* ----------------- Test sur le nombre maximum d'iterations ------------
2510*/
2511
2512/* Test si passe au moins 1 fois ** */
2513
2514 if (iter == 1) {
2515 oldso = sottc;
2516 ndec <<= 1;
2517 ++iter;
2518 goto L5000;
2519 } else {
2520
2521/* ------ Prise en compte du DIF - Test de convergence */
2522
2523 ++iter;
2524 dif = (d__1 = sottc - oldso, abs(d__1));
2525
2526/* ------ Si DIF est OK, on va sortir..., sinon: */
2527
2528 if (dif > *epsiln) {
2529
2530/* ------ Si nbre iteration depasse, on sort */
2531
2532 if (iter > itmax) {
2533 *iercod = 1;
2534 goto L9000;
2535 } else {
2536
2537/* ------ Sinon on continue en decoupant l'intervalle initial.
2538 */
2539
2540 oldso = sottc;
2541 ndec <<= 1;
2542 goto L5000;
2543 }
2544 }
2545 }
2546
2547/* ------------------------------ THE END -------------------------------
2548*/
2549
2550L9000:
2551 *xlongc = sottc;
2552 *erreur = dif;
2553 goto L9999;
2554
2555/* ---> PB dans MMLONCV */
2556
2557L9002:
2558 *iercod = 2;
2559 goto L9999;
2560
2561/* ---> NCOEFF ou NDIM invalides. */
2562
2563L9003:
2564 *iercod = 3;
2565 goto L9999;
2566
2567L9999:
2568 if (*iercod > 0) {
2569 AdvApp2Var_SysBase::maermsg_("MMCGLC1", iercod, 7L);
2570 }
2571 if (ibb >= 2) {
2572 AdvApp2Var_SysBase::mgsomsg_("MMCGLC1", 7L);
2573 }
2574 return 0;
2575} /* mmcglc1_ */
2576
2577//=======================================================================
2578//function : mmchole_
2579//purpose :
2580//=======================================================================
2581int mmchole_(integer *,//mxcoef,
2582 integer *dimens,
2583 doublereal *amatri,
2584 integer *aposit,
2585 integer *posuiv,
2586 doublereal *chomat,
2587 integer *iercod)
2588
2589{
2590 /* System generated locals */
2591 integer i__1, i__2, i__3;
2592 doublereal d__1;
2593
2594 /* Builtin functions */
2595 //double sqrt();
2596
2597 /* Local variables */
2598 static logical ldbg;
2599 static integer kmin, i__, j, k;
2600 static doublereal somme;
2601 static integer ptini, ptcou;
2602
2603
2604/* ***********************************************************************
2605 */
2606
2607/* FONCTION : */
2608/* ---------- T */
2609/* Effectue la decomposition de choleski de la matrice A en S.S */
2610/* Calcul la matrice triangulaire inferieure S. */
2611
2612/* MOTS CLES : */
2613/* ----------- */
2614/* RESOLUTION, MFACTORISATION, MATRICE_PROFILE, CHOLESKI */
2615
2616/* ARGUMENTS D'ENTREE : */
2617/* -------------------- */
2618/* MXCOEF : Nombres maximale de termes dans le profile du hessien */
2619/* DIMENS : Dimension du probleme */
2620/* AMATRI(MXCOEF) : Coefficients du profil de la matrice */
2621/* APOSIT(1,*) : Distance diagonnale-extrimite gauche de la ligne
2622*/
2623/* APOSIT(2,*) : Position des termes diagonnaux dans HESSIE */
2624/* POSUIV(MXCOEF): premiere ligne inferieure non hors profil */
2625
2626/* ARGUMENTS DE SORTIE : */
2627/* --------------------- */
2628/* CHOMAT(MXCOEF) : Matrice triangulaire inferieure qui conserve */
2629/* le profil de AMATRI. */
2630/* IERCOD : code d'erreur */
2631/* = 0 : ok */
2632/* = 1 : Matrice non definie positive */
2633
2634/* COMMONS UTILISES : */
2635/* ------------------ */
2636
2637/* .Neant. */
2638
2639/* REFERENCES APPELEES : */
2640/* ---------------------- */
2641
2642/* DESCRIPTION/REMARQUES/LIMITATIONS : */
2643/* ----------------------------------- */
2644/* NIVEAU DE DEBUG = 4 */
2645
2646/* $ HISTORIQUE DES MODIFICATIONS : */
2647/* ------------------------------ */
2648/* 14-02-1994: PMN; ECRITURE VERSION ORIGINALE. */
2649/* > */
2650/* ***********************************************************************
2651 */
2652/* DECLARATIONS */
2653/* ***********************************************************************
2654 */
2655
2656
2657
2658/* ***********************************************************************
2659 */
2660/* INITIALISATIONS */
2661/* ***********************************************************************
2662 */
2663
2664 /* Parameter adjustments */
2665 --chomat;
2666 --posuiv;
2667 --amatri;
2668 aposit -= 3;
2669
2670 /* Function Body */
2671 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 4;
2672 if (ldbg) {
2673 AdvApp2Var_SysBase::mgenmsg_("MMCHOLE", 7L);
2674 }
2675 *iercod = 0;
2676
2677/* ***********************************************************************
2678 */
2679/* TRAITEMENT */
2680/* ***********************************************************************
2681 */
2682
2683 i__1 = *dimens;
2684 for (j = 1; j <= i__1; ++j) {
2685
2686 ptini = aposit[(j << 1) + 2];
2687
2688 somme = 0.;
2689 i__2 = ptini - 1;
2690 for (k = ptini - aposit[(j << 1) + 1]; k <= i__2; ++k) {
2691/* Computing 2nd power */
2692 d__1 = chomat[k];
2693 somme += d__1 * d__1;
2694 }
2695
2696 if (amatri[ptini] - somme < 1e-32) {
2697 goto L9101;
2698 }
2699 chomat[ptini] = sqrt(amatri[ptini] - somme);
2700
2701 ptcou = ptini;
2702
2703 while(posuiv[ptcou] > 0) {
2704
2705 i__ = posuiv[ptcou];
2706 ptcou = aposit[(i__ << 1) + 2] - (i__ - j);
2707
2708/* Calcul la somme de S .S pour k =1 a j-1 */
2709/* ik jk */
2710 somme = 0.;
2711/* Computing MAX */
2712 i__2 = i__ - aposit[(i__ << 1) + 1], i__3 = j - aposit[(j << 1) +
2713 1];
2714 kmin = max(i__2,i__3);
2715 i__2 = j - 1;
2716 for (k = kmin; k <= i__2; ++k) {
2717 somme += chomat[aposit[(i__ << 1) + 2] - (i__ - k)] * chomat[
2718 aposit[(j << 1) + 2] - (j - k)];
2719 }
2720
2721 chomat[ptcou] = (amatri[ptcou] - somme) / chomat[ptini];
2722 }
2723 }
2724
2725 goto L9999;
2726
2727/* ***********************************************************************
2728 */
2729/* TRAITEMENT DES ERREURS */
2730/* ***********************************************************************
2731 */
2732
2733L9101:
2734 *iercod = 1;
2735 goto L9999;
2736
2737/* ***********************************************************************
2738 */
2739/* RETOUR PROGRAMME APPELANT */
2740/* ***********************************************************************
2741 */
2742
2743L9999:
2744
2745 AdvApp2Var_SysBase::maermsg_("MMCHOLE", iercod, 7L);
2746 if (ldbg) {
2747 AdvApp2Var_SysBase::mgsomsg_("MMCHOLE", 7L);
2748 }
2749
2750 return 0 ;
2751} /* mmchole_ */
2752
2753//=======================================================================
2754//function : AdvApp2Var_MathBase::mmcvctx_
2755//purpose :
2756//=======================================================================
2757int AdvApp2Var_MathBase::mmcvctx_(integer *ndimen,
2758 integer *ncofmx,
2759 integer *nderiv,
2760 doublereal *ctrtes,
2761 doublereal *crvres,
2762 doublereal *tabaux,
2763 doublereal *xmatri,
2764 integer *iercod)
2765
2766{
2767 /* System generated locals */
2768 integer ctrtes_dim1, ctrtes_offset, crvres_dim1, crvres_offset,
2769 xmatri_dim1, xmatri_offset, tabaux_dim1, tabaux_offset, i__1,
2770 i__2;
2771
2772 /* Local variables */
2773 static integer moup1, nordr;
2774 static integer nd;
2775 static integer ibb, ncf, ndv;
2776 static doublereal eps1;
2777
2778
2779/* ***********************************************************************
2780 */
2781
2782/* FONCTION : */
2783/* ---------- */
2784/* Calcul d' une courbe polynomiale verifiant des */
2785/* contraintes de passages (interpolation) */
2786/* de derivees premieres etc... aux extremites. */
2787/* Les parametres aux extremites sont supposes etre -1 et 1. */
2788
2789/* MOTS CLES : */
2790/* ----------- */
2791/* TOUS, AB_SPECIFI::CONTRAINTES&,INTERPOLATION,&COURBE */
2792
2793/* ARGUMENTS D'ENTREE : */
2794/* ------------------ */
2795/* NDIMEN : Dimension de l' espace. */
2796/* NCOFMX : Nre de coeff. de la courbe CRVRES sur chaque */
2797/* dimension. */
2798/* NDERIV : Ordre de contrainte aux derivees : */
2799/* 0 --> interpolation simple. */
2800/* 1 --> interpolation+contraintes aux derivees 1eres. */
2801/* 2 --> cas (0)+ (1) + " " " 2emes. */
2802/* etc... */
2803/* CTRTES : Tableau des contraintes. */
2804/* CTRTES(*,1,*) = contraintes en -1. */
2805/* CTRTES(*,2,*) = contraintes en 1. */
2806
2807/* ARGUMENTS DE SORTIE : */
2808/* ------------------- */
2809/* CRVRES : La courbe resultat definie dans (-1,1). */
2810/* TABAUX : Matrice auxilliaire. */
2811/* XMATRI : Matrice auxilliaire. */
2812
2813/* COMMONS UTILISES : */
2814/* ---------------- */
2815
2816/* .Neant. */
2817
2818/* REFERENCES APPELEES : */
2819/* ---------------------- */
2820/* Type Name */
2821/* MAERMSG R*8 DFLOAT MGENMSG */
2822/* MGSOMSG MMEPS1 MMRSLW */
2823/* I*4 MNFNDEB */
2824
2825/* DESCRIPTION/REMARQUES/LIMITATIONS : */
2826/* ----------------------------------- */
2827/* Le polynome (ou la courbe) est calculee en resolvant un */
2828/* systeme d' equations lineaires. Si le degre impose est grand */
2829/* il est preferable de faire appel a une routine basee sur */
2830/* l' interpolation de Lagrange ou d' Hermite suivant le cas. */
2831/* (pour un degre eleve la matrice du systeme peut etre mal */
2832/* conditionnee). */
2833/* Cette routine retourne une courbe definie dans (-1,1). */
2834/* Pour un cas general, il faut utiliser MCVCTG. */
2835
2836/* $ HISTORIQUE DES MODIFICATIONS : */
2837/* -------------------------------- */
2838/* 18-09-1995 : JMF ; Verfor */
2839/* 14-02-1990 : RBD ; Correction declaration de NOMPRG. */
2840/* 12-04-1989 : RBD ; Suppression des chaines de caracteres pour */
2841/* les appel a MMRSLW. */
2842/* 31-05-1988 : JJM ; Reorganisation contraintes. */
2843/* 22-02-1988 : JJM ; Appel MFNDEB -> MNFNDEB */
2844/* 22-02-1988 : JJM ; Appel GERMSG -> MAERMSG */
2845/* 24-11-1987 : Cree par RBD. */
2846
2847/* > */
2848/* ***********************************************************************
2849 */
2850
2851/* Le nom de la routine */
2852
2853
2854 /* Parameter adjustments */
2855 crvres_dim1 = *ncofmx;
2856 crvres_offset = crvres_dim1 + 1;
2857 crvres -= crvres_offset;
2858 xmatri_dim1 = *nderiv + 1;
2859 xmatri_offset = xmatri_dim1 + 1;
2860 xmatri -= xmatri_offset;
2861 tabaux_dim1 = *nderiv + 1 + *ndimen;
2862 tabaux_offset = tabaux_dim1 + 1;
2863 tabaux -= tabaux_offset;
2864 ctrtes_dim1 = *ndimen;
2865 ctrtes_offset = ctrtes_dim1 * 3 + 1;
2866 ctrtes -= ctrtes_offset;
2867
2868 /* Function Body */
2869 ibb = AdvApp2Var_SysBase::mnfndeb_();
2870 if (ibb >= 3) {
2871 AdvApp2Var_SysBase::mgenmsg_("MMCVCTX", 7L);
2872 }
2873/* Les precisions. */
2874 AdvApp2Var_MathBase::mmeps1_(&eps1);
2875
2876/* ****************** CALCUL DES COEFFICIENTS PAIRS *********************
2877*/
2878/* ------------------------- Initialisation -----------------------------
2879*/
2880
2881 nordr = *nderiv + 1;
2882 i__1 = nordr;
2883 for (ncf = 1; ncf <= i__1; ++ncf) {
2884 tabaux[ncf + tabaux_dim1] = 1.;
2885/* L100: */
2886 }
2887
2888/* ---------------- Calcul des termes correspondants aux derivees -------
2889*/
2890
2891 i__1 = nordr;
2892 for (ndv = 2; ndv <= i__1; ++ndv) {
2893 i__2 = nordr;
2894 for (ncf = 1; ncf <= i__2; ++ncf) {
2895 tabaux[ncf + ndv * tabaux_dim1] = tabaux[ncf + (ndv - 1) *
2896 tabaux_dim1] * (doublereal) ((ncf << 1) - ndv);
2897/* L300: */
2898 }
2899/* L200: */
2900 }
2901
2902/* ------------------ Ecriture du deuxieme membre -----------------------
2903*/
2904
2905 moup1 = 1;
2906 i__1 = nordr;
2907 for (ndv = 1; ndv <= i__1; ++ndv) {
2908 i__2 = *ndimen;
2909 for (nd = 1; nd <= i__2; ++nd) {
2910 tabaux[nordr + nd + ndv * tabaux_dim1] = (ctrtes[nd + ((ndv << 1)
2911 + 2) * ctrtes_dim1] + moup1 * ctrtes[nd + ((ndv << 1) + 1)
2912 * ctrtes_dim1]) / 2.;
2913/* L500: */
2914 }
2915 moup1 = -moup1;
2916/* L400: */
2917 }
2918
2919/* -------------------- Resolution du systeme ---------------------------
2920*/
2921
2922 mmrslw_(&nordr, &nordr, ndimen, &eps1, &tabaux[tabaux_offset], &xmatri[
2923 xmatri_offset], iercod);
2924 if (*iercod > 0) {
2925 goto L9999;
2926 }
2927 i__1 = *ndimen;
2928 for (nd = 1; nd <= i__1; ++nd) {
2929 i__2 = nordr;
2930 for (ncf = 1; ncf <= i__2; ++ncf) {
2931 crvres[(ncf << 1) - 1 + nd * crvres_dim1] = xmatri[ncf + nd *
2932 xmatri_dim1];
2933/* L700: */
2934 }
2935/* L600: */
2936 }
2937
2938/* ***************** CALCUL DES COEFFICIENTS IMPAIRS ********************
2939*/
2940/* ------------------------- Initialisation -----------------------------
2941*/
2942
2943
2944 i__1 = nordr;
2945 for (ncf = 1; ncf <= i__1; ++ncf) {
2946 tabaux[ncf + tabaux_dim1] = 1.;
2947/* L1100: */
2948 }
2949
2950/* ---------------- Calcul des termes correspondants aux derivees -------
2951*/
2952
2953 i__1 = nordr;
2954 for (ndv = 2; ndv <= i__1; ++ndv) {
2955 i__2 = nordr;
2956 for (ncf = 1; ncf <= i__2; ++ncf) {
2957 tabaux[ncf + ndv * tabaux_dim1] = tabaux[ncf + (ndv - 1) *
2958 tabaux_dim1] * (doublereal) ((ncf << 1) - ndv + 1);
2959/* L1300: */
2960 }
2961/* L1200: */
2962 }
2963
2964/* ------------------ Ecriture du deuxieme membre -----------------------
2965*/
2966
2967 moup1 = -1;
2968 i__1 = nordr;
2969 for (ndv = 1; ndv <= i__1; ++ndv) {
2970 i__2 = *ndimen;
2971 for (nd = 1; nd <= i__2; ++nd) {
2972 tabaux[nordr + nd + ndv * tabaux_dim1] = (ctrtes[nd + ((ndv << 1)
2973 + 2) * ctrtes_dim1] + moup1 * ctrtes[nd + ((ndv << 1) + 1)
2974 * ctrtes_dim1]) / 2.;
2975/* L1500: */
2976 }
2977 moup1 = -moup1;
2978/* L1400: */
2979 }
2980
2981/* -------------------- Resolution du systeme ---------------------------
2982*/
2983
2984 mmrslw_(&nordr, &nordr, ndimen, &eps1, &tabaux[tabaux_offset], &xmatri[
2985 xmatri_offset], iercod);
2986 if (*iercod > 0) {
2987 goto L9999;
2988 }
2989 i__1 = *ndimen;
2990 for (nd = 1; nd <= i__1; ++nd) {
2991 i__2 = nordr;
2992 for (ncf = 1; ncf <= i__2; ++ncf) {
2993 crvres[(ncf << 1) + nd * crvres_dim1] = xmatri[ncf + nd *
2994 xmatri_dim1];
2995/* L1700: */
2996 }
2997/* L1600: */
2998 }
2999
3000/* --------------------------- The end ----------------------------------
3001*/
3002
3003L9999:
3004 if (*iercod != 0) {
3005 AdvApp2Var_SysBase::maermsg_("MMCVCTX", iercod, 7L);
3006 }
3007 if (ibb >= 3) {
3008 AdvApp2Var_SysBase::mgsomsg_("MMCVCTX", 7L);
3009 }
3010
3011 return 0 ;
3012} /* mmcvctx_ */
3013
3014//=======================================================================
3015//function : AdvApp2Var_MathBase::mmcvinv_
3016//purpose :
3017//=======================================================================
3018 int AdvApp2Var_MathBase::mmcvinv_(integer *ndimax,
3019 integer *ncoef,
3020 integer *ndim,
3021 doublereal *curveo,
3022 doublereal *curve)
3023
3024{
3025 /* Initialized data */
3026
3027 static char nomprg[8+1] = "MMCVINV ";
3028
3029 /* System generated locals */
3030 integer curve_dim1, curve_offset, curveo_dim1, curveo_offset, i__1, i__2;
3031
3032 /* Local variables */
3033 static integer i__, nd, ibb;
3034
3035
3036/* ***********************************************************************
3037 */
3038
3039/* FONCTION : */
3040/* ---------- */
3041/* Inversion des arguments de la courbe finale. */
3042
3043/* MOTS CLES : */
3044/* ----------- */
3045/* LISSAGE,COURBE */
3046
3047
3048/* ARGUMENTS D'ENTREE : */
3049/* ------------------ */
3050
3051/* NDIM: Dimension de l' espace. */
3052/* NCOEF: Degre du polynome. */
3053/* CURVEO: La courbe avant inversion. */
3054
3055/* ARGUMENTS DE SORTIE : */
3056/* ------------------- */
3057/* CURVE: La courbe apres inversion. */
3058
3059/* COMMONS UTILISES : */
3060/* ---------------- */
3061
3062/* REFERENCES APPELEES : */
3063/* ----------------------- */
3064
3065/* DESCRIPTION/REMARQUES/LIMITATIONS : */
3066/* ----------------------------------- */
3067
3068/* $ HISTORIQUE DES MODIFICATIONS : */
3069/* -------------------------------- */
3070/* 22-02-1988 : JJM ; Appel MFNDEB -> MNFNDEB */
3071/* 15-07-1987: Cree par JJM. */
3072
3073/* > */
3074/* ***********************************************************************
3075 */
3076
3077/* Le nom de la routine */
3078 /* Parameter adjustments */
3079 curve_dim1 = *ndimax;
3080 curve_offset = curve_dim1 + 1;
3081 curve -= curve_offset;
3082 curveo_dim1 = *ncoef;
3083 curveo_offset = curveo_dim1 + 1;
3084 curveo -= curveo_offset;
3085
3086 /* Function Body */
3087
3088 ibb = AdvApp2Var_SysBase::mnfndeb_();
3089 if (ibb >= 2) {
3090 AdvApp2Var_SysBase::mgenmsg_(nomprg, 6L);
3091 }
3092
3093 i__1 = *ncoef;
3094 for (i__ = 1; i__ <= i__1; ++i__) {
3095 i__2 = *ndim;
3096 for (nd = 1; nd <= i__2; ++nd) {
3097 curve[nd + i__ * curve_dim1] = curveo[i__ + nd * curveo_dim1];
3098/* L300: */
3099 }
3100 }
3101
3102/* L9999: */
3103 return 0;
3104} /* mmcvinv_ */
3105
3106//=======================================================================
3107//function : mmcvstd_
3108//purpose :
3109//=======================================================================
3110int mmcvstd_(integer *ncofmx,
3111 integer *ndimax,
3112 integer *ncoeff,
3113 integer *ndimen,
3114 doublereal *crvcan,
3115 doublereal *courbe)
3116
3117{
3118 /* System generated locals */
3119 integer courbe_dim1, crvcan_dim1, crvcan_offset, i__1, i__2, i__3;
3120
3121 /* Local variables */
3122 static integer ndeg, i__, j, j1, nd, ibb;
3123 static doublereal bid;
3124
3125
3126/* ***********************************************************************
3127 */
3128
3129/* FONCTION : */
3130/* ---------- */
3131/* Transforme une courbe definie entre [-1,1] a [0,1]. */
3132
3133/* MOTS CLES : */
3134/* ----------- */
3135/* LIMITATION,RESTRICTION,COURBE */
3136
3137/* ARGUMENTS D'ENTREE : */
3138/* ------------------ */
3139/* NDIMAX : Dimensionnement de l' espace. */
3140/* NDIMEN : Dimension de la courbe. */
3141/* NCOEFF : Degre de la courbe. */
3142/* CRVCAN(NCOFMX,NDIMEN): La courbe definie entre [-1,1]. */
3143
3144/* ARGUMENTS DE SORTIE : */
3145/* ------------------- */
3146/* COURBE(NDIMAX,NCOEFF): La courbe definie dans [0,1]. */
3147
3148/* COMMONS UTILISES : */
3149/* ---------------- */
3150
3151/* REFERENCES APPELEES : */
3152/* ----------------------- */
3153
3154/* DESCRIPTION/REMARQUES/LIMITATIONS : */
3155/* ----------------------------------- */
3156
3157/* $ HISTORIQUE DES MODIFICATIONS : */
3158/* -------------------------------- */
3159/* 09-01-90 : TE ; COMMON MCCNP -> MMCMCNP.INC & INDICES DES CNP */
3160/* 12-04-89 : RBD ; Appel MGSOMSG. */
3161/* 22-02-88 : JJM ; Appel MFNDEB -> MNFNDEB */
3162/* 19-02-88 : JJM ; Remontee des PARAMETER */
3163/* 14-01-88 : JJM ; Suppression de MINOMBR */
3164/* 28-11-86 : Creation JJM. */
3165/* > */
3166/* ***********************************************************************
3167 */
3168
3169/* Le nom du programme. */
3170
3171
3172/* **********************************************************************
3173*/
3174
3175/* FONCTION : */
3176/* ---------- */
3177/* Sert a fournir les coefficients du binome (triangle de Pascal). */
3178
3179/* MOTS CLES : */
3180/* ----------- */
3181/* Coeff du binome de 0 a 60. read only . init par block data */
3182
3183/* DEMSCRIPTION/REMARQUES/LIMITATIONS : */
3184/* ----------------------------------- */
3185/* Les coefficients du binome forment une matrice triangulaire. */
3186/* On complete cette matrice dans le tableau CNP par sa transposee. */
3187/* On a donc: CNP(I,J) = CNP(J,I) pour I et J = 0, ..., 60. */
3188
3189/* L'initialisation est faite a partir du block-data MMLLL09.RES, */
3190/* cree par le programme MQINICNP.FOR (voir l'equipe (AC) ). */
3191
3192/* $ HISTORIQUE DES MODIFICATIONS : */
3193/* ------------------------------ */
3194/* 03-07-90 : RBD; Ajout commentaires (nom du block-data). */
3195/* 19-06-90 : RBD; Le commun MMCMCNP remplace MCCNP qui est obsolete.
3196*/
3197/* 08-01-90 : TE ; CREATION */
3198/* > */
3199/* **********************************************************************
3200*/
3201
3202
3203
3204/* ***********************************************************************
3205 */
3206
3207 /* Parameter adjustments */
3208 courbe_dim1 = *ndimax;
3209 --courbe;
3210 crvcan_dim1 = *ncofmx;
3211 crvcan_offset = crvcan_dim1;
3212 crvcan -= crvcan_offset;
3213
3214 /* Function Body */
3215 ibb = AdvApp2Var_SysBase::mnfndeb_();
3216 if (ibb >= 3) {
3217 AdvApp2Var_SysBase::mgenmsg_("MMCVSTD", 7L);
3218 }
3219 ndeg = *ncoeff - 1;
3220
3221/* ------------------ Construction de la courbe resultat ----------------
3222*/
3223
3224 i__1 = *ndimen;
3225 for (nd = 1; nd <= i__1; ++nd) {
3226 i__2 = ndeg;
3227 for (j = 0; j <= i__2; ++j) {
3228 bid = 0.;
3229 i__3 = ndeg;
3230 for (i__ = j; i__ <= i__3; i__ += 2) {
3231 bid += crvcan[i__ + nd * crvcan_dim1] * mmcmcnp_.cnp[i__ + j
3232 * 61];
3233/* L410: */
3234 }
3235 courbe[nd + j * courbe_dim1] = bid;
3236
3237 bid = 0.;
3238 j1 = j + 1;
3239 i__3 = ndeg;
3240 for (i__ = j1; i__ <= i__3; i__ += 2) {
3241 bid += crvcan[i__ + nd * crvcan_dim1] * mmcmcnp_.cnp[i__ + j
3242 * 61];
3243/* L420: */
3244 }
3245 courbe[nd + j * courbe_dim1] -= bid;
3246/* L400: */
3247 }
3248/* L300: */
3249 }
3250
3251/* ------------------- Renormalisation de COURBE -------------------------
3252 */
3253
3254 bid = 1.;
3255 i__1 = ndeg;
3256 for (i__ = 0; i__ <= i__1; ++i__) {
3257 i__2 = *ndimen;
3258 for (nd = 1; nd <= i__2; ++nd) {
3259 courbe[nd + i__ * courbe_dim1] *= bid;
3260/* L510: */
3261 }
3262 bid *= 2.;
3263/* L500: */
3264 }
3265
3266/* ----------------------------- The end --------------------------------
3267*/
3268
3269 if (ibb >= 3) {
3270 AdvApp2Var_SysBase::mgsomsg_("MMCVSTD", 7L);
3271 }
3272 return 0;
3273} /* mmcvstd_ */
3274
3275//=======================================================================
3276//function : AdvApp2Var_MathBase::mmdrc11_
3277//purpose :
3278//=======================================================================
3279int AdvApp2Var_MathBase::mmdrc11_(integer *iordre,
3280 integer *ndimen,
3281 integer *ncoeff,
3282 doublereal *courbe,
3283 doublereal *points,
3284 doublereal *mfactab)
3285
3286{
3287 /* System generated locals */
3288 integer courbe_dim1, courbe_offset, points_dim2, points_offset, i__1,
3289 i__2;
3290
3291 /* Local variables */
3292
3293 static integer ndeg, i__, j, ndgcb, nd, ibb;
3294
3295
3296/* **********************************************************************
3297*/
3298
3299/* FONCTION : */
3300/* ---------- */
3301/* Calcul des derivees successives de l' equation COURBE au */
3302/* parametres -1, 1 de l' ordre 0 jusqu' a l' ordre IORDRE */
3303/* inclus.Le calcul se fait sans connaitre les coefficients des */
3304/* derivees de la courbe. */
3305
3306/* MOTS CLES : */
3307/* ----------- */
3308/* POSITIONNEMENT,EXTREMITES,COURBE,DERIVEE. */
3309
3310/* ARGUMENTS D'ENTREE : */
3311/* ------------------ */
3312/* IORDRE : Ordre maximal de calcul des derivees. */
3313/* NDIMEN : Dimension de l' espace. */
3314/* NCOEFF : Nombre de coefficients de la courbe (degre+1). */
3315/* COURBE : Tableau des coefficients de la courbe. */
3316
3317/* ARGUMENTS DE SORTIE : */
3318/* ------------------- */
3319/* POINTS : Tableau des valeurs des derivees successives */
3320/* au parametres -1.D0 et 1.D0. */
3321/* MFACTAB : Tableau auxiliaire pour le calcul de factorielle(I).
3322*/
3323
3324/* COMMONS UTILISES : */
3325/* ---------------- */
3326/* Aucun. */
3327
3328/* REFERENCES APPELEES : */
3329/* ----------------------- */
3330
3331/* DESCRIPTION/REMARQUES/LIMITATIONS : */
3332/* ----------------------------------- */
3333
3334/* ---> ATTENTION, les coefficients de la courbe sont ranges */
3335/* "A L' ENVERS". */
3336
3337/* ---> L' algorithme de calcul des derivees est base sur la */
3338/* generalisation du schema de Horner : */
3339/* k 2 */
3340/* Soit C(t) = uk.t + ... + u2.t + u1.t + u0 . */
3341
3342
3343/* On pose a0 = uk, b0 = 0, c0 = 0 et pour 1<=j<=k, on calcule : */
3344
3345/* aj = a(j-1).x + u(k-j) */
3346/* bj = b(j-1).x + a(j-1) */
3347/* cj = c(j-1).x + b(j-1) */
3348
3349/* On obtient alors : C(x) = ak, C'(x) = bk, C"(x) = 2.ck . */
3350
3351/* L' algorithme se generalise facilement pour le calcul de */
3352
3353/* (n) */
3354/* C (x) . */
3355/* --------- */
3356/* n! */
3357
3358/* Reference : D. KNUTH, "The Art of Computer Programming" */
3359/* --------- Vol. 2/Seminumerical Algorithms */
3360/* Addison-Wesley Pub. Co. (1969) */
3361/* pages 423-425. */
3362
3363
3364/* $ HISTORIQUE DES MODIFICATIONS : */
3365/* -------------------------------- */
3366/* 29-01-1990 : RBD ; Correction de l' en-tete, mise au normes. */
3367/* 22-02-1988 : JJM ; Appel MFNDEB -> MNFNDEB */
3368/* 25-11-1987 : Cree par JJM (d' apres MDRCRV). */
3369/* > */
3370/* **********************************************************************
3371*/
3372
3373/* Le nom de la routine */
3374
3375 /* Parameter adjustments */
3376 points_dim2 = *iordre + 1;
3377 points_offset = (points_dim2 << 1) + 1;
3378 points -= points_offset;
3379 courbe_dim1 = *ncoeff;
3380 courbe_offset = courbe_dim1;
3381 courbe -= courbe_offset;
3382
3383 /* Function Body */
3384 ibb = AdvApp2Var_SysBase::mnfndeb_();
3385 if (ibb >= 2) {
3386 AdvApp2Var_SysBase::mgenmsg_("MMDRC11", 7L);
3387 }
3388
3389 if (*iordre < 0 || *ncoeff < 1) {
3390 goto L9999;
3391 }
3392
3393/* ------------------- Initialisation du tableau POINTS -----------------
3394*/
3395
3396 ndgcb = *ncoeff - 1;
3397 i__1 = *ndimen;
3398 for (nd = 1; nd <= i__1; ++nd) {
3399 points[(nd * points_dim2 << 1) + 1] = courbe[ndgcb + nd * courbe_dim1]
3400 ;
3401 points[(nd * points_dim2 << 1) + 2] = courbe[ndgcb + nd * courbe_dim1]
3402 ;
3403/* L100: */
3404 }
3405
3406 i__1 = *ndimen;
3407 for (nd = 1; nd <= i__1; ++nd) {
3408 i__2 = *iordre;
3409 for (j = 1; j <= i__2; ++j) {
3410 points[((j + nd * points_dim2) << 1) + 1] = 0.;
3411 points[((j + nd * points_dim2) << 1) + 2] = 0.;
3412/* L400: */
3413 }
3414/* L300: */
3415 }
3416
3417/* Calcul au parametre -1 et 1 */
3418
3419 i__1 = *ndimen;
3420 for (nd = 1; nd <= i__1; ++nd) {
3421 i__2 = ndgcb;
3422 for (ndeg = 1; ndeg <= i__2; ++ndeg) {
3423 for (i__ = *iordre; i__ >= 1; --i__) {
3424 points[((i__ + nd * points_dim2) << 1) + 1] = -points[((i__ + nd
3425 * points_dim2) << 1) + 1] + points[((i__ - 1 + nd *
3426 points_dim2) << 1) + 1];
3427 points[((i__ + nd * points_dim2) << 1) + 2] += points[((i__ - 1
3428 + nd * points_dim2) << 1) + 2];
3429/* L800: */
3430 }
3431 points[(nd * points_dim2 << 1) + 1] = -points[(nd * points_dim2 <<
3432 1) + 1] + courbe[ndgcb - ndeg + nd * courbe_dim1];
3433 points[(nd * points_dim2 << 1) + 2] += courbe[ndgcb - ndeg + nd *
3434 courbe_dim1];
3435/* L700: */
3436 }
3437/* L600: */
3438 }
3439
3440/* --------------------- Multiplication par factorielle(I) --------------
3441*/
3442
3443 if (*iordre > 1) {
3444 mfac_(&mfactab[1], iordre);
3445
3446 i__1 = *ndimen;
3447 for (nd = 1; nd <= i__1; ++nd) {
3448 i__2 = *iordre;
3449 for (i__ = 2; i__ <= i__2; ++i__) {
3450 points[((i__ + nd * points_dim2) << 1) + 1] = mfactab[i__] *
3451 points[((i__ + nd * points_dim2) << 1) + 1];
3452 points[((i__ + nd * points_dim2) << 1) + 2] = mfactab[i__] *
3453 points[((i__ + nd * points_dim2) << 1) + 2];
3454/* L1000: */
3455 }
3456/* L900: */
3457 }
3458 }
3459
3460/* ---------------------------- Fin -------------------------------------
3461*/
3462
3463L9999:
3464 if (ibb >= 2) {
3465 AdvApp2Var_SysBase::mgsomsg_("MMDRC11", 7L);
3466 }
3467 return 0;
3468} /* mmdrc11_ */
3469
3470//=======================================================================
3471//function : mmdrvcb_
3472//purpose :
3473//=======================================================================
3474int mmdrvcb_(integer *ideriv,
3475 integer *ndim,
3476 integer *ncoeff,
3477 doublereal *courbe,
3478 doublereal *tparam,
3479 doublereal *tabpnt,
3480 integer *iercod)
3481
3482{
3483 /* System generated locals */
3484 integer courbe_dim1, tabpnt_dim1, i__1, i__2, i__3;
3485
3486 /* Local variables */
3487 static integer ndeg, i__, j, nd, ndgcrb, iptpnt, ibb;
3488
3489
3490/* ***********************************************************************
3491 */
3492
3493/* FONCTION : */
3494/* ---------- */
3495/* Calcul des derivees successives de l' equation COURBE au */
3496/* parametre TPARAM de l' ordre 0 jusqu' a l' ordre IDERIV inclus. */
3497/* Le calcul se fait sans utiliser les coefficients des */
3498/* derivees de COURBE. */
3499
3500/* MOTS CLES : */
3501/* ----------- */
3502/* POSITIONNEMENT,PARAMETRE,COURBE,DERIVEE. */
3503
3504/* ARGUMENTS D'ENTREE : */
3505/* ------------------ */
3506/* IDERIV : Ordre maximal de calcul des derivees. */
3507/* NDIM : Dimension de l' espace. */
3508/* NCOEFF : Nombre de coefficients de la courbe (degre+1). */
3509/* COURBE : Tableau des coefficients de la courbe. */
3510/* TPARAM : Valeur du parametre ou la courbe doit etre evaluee. */
3511
3512/* ARGUMENTS DE SORTIE : */
3513/* ------------------- */
3514/* TABPNT : Tableau des valeurs des derivees successives */
3515/* au parametre TPARAM. */
3516/* IERCOD : 0 = OK, */
3517/* 1 = Entrees incoherentes. */
3518
3519/* COMMONS UTILISES : */
3520/* ---------------- */
3521/* Aucun. */
3522
3523/* REFERENCES APPELEES : */
3524/* ----------------------- */
3525
3526/* DESCRIPTION/REMARQUES/LIMITATIONS : */
3527/* ----------------------------------- */
3528
3529/* L' algorithme de calcul des derivees est base sur la */
3530/* generalisation du schema de Horner : */
3531/* k 2 */
3532/* Soit C(t) = uk.t + ... + u2.t + u1.t + u0 . */
3533
3534
3535/* On pose a0 = uk, b0 = 0, c0 = 0 et pour 1<=j<=k, on calcule : */
3536
3537/* aj = a(j-1).x + u(k-j) */
3538/* bj = b(j-1).x + a(j-1) */
3539/* cj = c(j-1).x + b(j-1) */
3540
3541/* On obtient alors : C(x) = ak, C'(x) = bk, C"(x) = 2.ck . */
3542
3543/* L' algorithme se generalise facilement pour le calcul de */
3544
3545/* (n) */
3546/* C (x) . */
3547/* --------- */
3548/* n! */
3549
3550/* Reference : D. KNUTH, "The Art of Computer Programming" */
3551/* --------- Vol. 2/Seminumerical Algorithms */
3552/* Addison-Wesley Pub. Co. (1969) */
3553/* pages 423-425. */
3554
3555/* ----> Pour evaluer les derivees en 0 et en 1, il est preferable */
3556/* d' utiliser la routine MDRV01.FOR . */
3557
3558/* $ HISTORIQUE DES MODIFICATIONS : */
3559/* -------------------------------- */
3560/* 28-06-1988 : Cree par RBD. */
3561
3562/* > */
3563/* **********************************************************************
3564*/
3565
3566/* Le nom de la routine */
3567
3568 /* Parameter adjustments */
3569 tabpnt_dim1 = *ndim;
3570 --tabpnt;
3571 courbe_dim1 = *ndim;
3572 --courbe;
3573
3574 /* Function Body */
3575 ibb = AdvApp2Var_SysBase::mnfndeb_();
3576 if (ibb >= 2) {
3577 AdvApp2Var_SysBase::mgenmsg_("MMDRVCB", 7L);
3578 }
3579
3580 if (*ideriv < 0 || *ncoeff < 1) {
3581 *iercod = 1;
3582 goto L9999;
3583 }
3584 *iercod = 0;
3585
3586/* ------------------- Initialisation du tableau TABPNT -----------------
3587*/
3588
3589 ndgcrb = *ncoeff - 1;
3590 i__1 = *ndim;
3591 for (nd = 1; nd <= i__1; ++nd) {
3592 tabpnt[nd] = courbe[nd + ndgcrb * courbe_dim1];
3593/* L100: */
3594 }
3595
3596 if (*ideriv < 1) {
3597 goto L200;
3598 }
3599 iptpnt = *ndim * *ideriv;
3600 AdvApp2Var_SysBase::mvriraz_((integer *)&iptpnt,
3601 (char *)&tabpnt[tabpnt_dim1 + 1]);
3602L200:
3603
3604/* ------------------------ Calcul au parametre TPARAM ------------------
3605*/
3606
3607 i__1 = ndgcrb;
3608 for (ndeg = 1; ndeg <= i__1; ++ndeg) {
3609 i__2 = *ndim;
3610 for (nd = 1; nd <= i__2; ++nd) {
3611 for (i__ = *ideriv; i__ >= 1; --i__) {
3612 tabpnt[nd + i__ * tabpnt_dim1] = tabpnt[nd + i__ *
3613 tabpnt_dim1] * *tparam + tabpnt[nd + (i__ - 1) *
3614 tabpnt_dim1];
3615/* L700: */
3616 }
3617 tabpnt[nd] = tabpnt[nd] * *tparam + courbe[nd + (ndgcrb - ndeg) *
3618 courbe_dim1];
3619/* L600: */
3620 }
3621/* L500: */
3622 }
3623
3624/* --------------------- Multiplication par factorielle(I) -------------
3625*/
3626
3627 i__1 = *ideriv;
3628 for (i__ = 2; i__ <= i__1; ++i__) {
3629 i__2 = i__;
3630 for (j = 2; j <= i__2; ++j) {
3631 i__3 = *ndim;
3632 for (nd = 1; nd <= i__3; ++nd) {
3633 tabpnt[nd + i__ * tabpnt_dim1] = (doublereal) j * tabpnt[nd +
3634 i__ * tabpnt_dim1];
3635/* L1200: */
3636 }
3637/* L1100: */
3638 }
3639/* L1000: */
3640 }
3641
3642/* --------------------------- The end ---------------------------------
3643*/
3644
3645L9999:
3646 if (*iercod > 0) {
3647 AdvApp2Var_SysBase::maermsg_("MMDRVCB", iercod, 7L);
3648 }
3649 return 0;
3650} /* mmdrvcb_ */
3651
3652//=======================================================================
3653//function : AdvApp2Var_MathBase::mmdrvck_
3654//purpose :
3655//=======================================================================
3656int AdvApp2Var_MathBase::mmdrvck_(integer *ncoeff,
3657 integer *ndimen,
3658 doublereal *courbe,
3659 integer *ideriv,
3660 doublereal *tparam,
3661 doublereal *pntcrb)
3662
3663{
3664 /* Initialized data */
3665
3666 static doublereal mmfack[21] = { 1.,2.,6.,24.,120.,720.,5040.,40320.,
3667 362880.,3628800.,39916800.,479001600.,6227020800.,87178291200.,
3668 1.307674368e12,2.0922789888e13,3.55687428096e14,6.402373705728e15,
3669 1.21645100408832e17,2.43290200817664e18,5.109094217170944e19 };
3670
3671 /* System generated locals */
3672 integer courbe_dim1, courbe_offset, i__1, i__2;
3673
3674 /* Local variables */
3675 static integer i__, j, k, nd;
3676 static doublereal mfactk, bid;
3677
3678
3679/* IMPLICIT INTEGER (I-N) */
3680/* IMPLICIT DOUBLE PRECISION(A-H,O-Z) */
3681
3682
3683/* ***********************************************************************
3684 */
3685
3686/* FONCTION : */
3687/* ---------- */
3688/* CALCUL DE LA VALEUR D'UNE COURBE DERIVEE D' ORDRE IDERIV EN */
3689/* UN POINT DE PARAMETRE TPARAM. */
3690
3691/* MOTS CLES : */
3692/* ----------- */
3693/* POSITIONNEMENT,COURBE,DERIVEE D' ORDRE K. */
3694
3695/* ARGUMENTS D'ENTREE : */
3696/* ------------------ */
3697/* NCOEFF : Le degre +1 de la courbe. */
3698/* NDIMEN : Dimension de l'espace (2 ou 3 en general) */
3699/* COURBE : Tableau des coefficients de la courbe. */
3700/* IDERIV : Ordre de derivation demande : 1=derivee 1ere, etc... */
3701/* TPARAM : Valeur du parametre de la courbe. */
3702
3703/* ARGUMENTS DE SORTIE : */
3704/* ------------------- */
3705/* PNTCRB : Le point de parametre TPARAM sur la derivee d' ordre */
3706/* IDERIV de COURBE. */
3707
3708/* COMMONS UTILISES : */
3709/* ---------------- */
3710/* MMCMCNP */
3711
3712/* REFERENCES APPELEES : */
3713/* ---------------------- */
3714/* .Neant. */
3715/* DESCRIPTION/REMARQUES/LIMITATIONS : */
3716/* ----------------------------------- */
3717
3718/* Le code ci dessous a ete ecrit a partir de l' algorithme suivant :
3719*/
3720
3721/* Soit P(t) = a1 + a2*t + ... an*t**n. La derivee d' ordre k de P */
3722/* (comportant n-k coefficients) est calculee ainsi : */
3723
3724/* Pk(t) = a(k+1)*CNP(k,k)*k! */
3725/* + a(k+2)*CNP(k+1,k)*k! * t */
3726/* . */
3727/* . */
3728/* . */
3729/* + a(n)*CNP(n-1,k)*k! * t**(n-k-1). */
3730
3731/* L' evaluation se fait suivant un schema de Horner classique. */
3732
3733/* $ HISTORIQUE DES MODIFICATIONS : */
3734/* -------------------------------- */
3735/* 8-09-1995 : JMF ; Performance */
3736/* 09-01-90 : TE ; COMMON MCCNP -> MMCMCNP.INC & INDICES DES CNP */
3737/* 06-07-88 : RBD; Creation, sur une idee de GD. */
3738/* > */
3739/* ***********************************************************************
3740 */
3741
3742
3743/* Factorielles (1 a 21) caculees sur VAX en R*16 */
3744
3745
3746/* **********************************************************************
3747*/
3748
3749/* FONCTION : */
3750/* ---------- */
3751/* Sert a fournir les coefficients du binome (triangle de Pascal). */
3752
3753/* MOTS CLES : */
3754/* ----------- */
3755/* Coeff du binome de 0 a 60. read only . init par block data */
3756
3757/* DEMSCRIPTION/REMARQUES/LIMITATIONS : */
3758/* ----------------------------------- */
3759/* Les coefficients du binome forment une matrice triangulaire. */
3760/* On complete cette matrice dans le tableau CNP par sa transposee. */
3761/* On a donc: CNP(I,J) = CNP(J,I) pour I et J = 0, ..., 60. */
3762
3763/* L'initialisation est faite a partir du block-data MMLLL09.RES, */
3764/* cree par le programme MQINICNP.FOR (voir l'equipe (AC) ). */
3765
3766/* $ HISTORIQUE DES MODIFICATIONS : */
3767/* ------------------------------ */
3768/* 03-07-90 : RBD; Ajout commentaires (nom du block-data). */
3769/* 19-06-90 : RBD; Le commun MMCMCNP remplace MCCNP qui est obsolete.
3770*/
3771/* 08-01-90 : TE ; CREATION */
3772/* > */
3773/* **********************************************************************
3774*/
3775
3776
3777
3778/* ***********************************************************************
3779 */
3780
3781 /* Parameter adjustments */
3782 --pntcrb;
3783 courbe_dim1 = *ndimen;
3784 courbe_offset = courbe_dim1 + 1;
3785 courbe -= courbe_offset;
3786
3787 /* Function Body */
3788
3789/* -------------- Cas ou l' ordre de derivee est plus -------------------
3790*/
3791/* ---------------- grand que le degre de la courbe ---------------------
3792*/
3793
3794 if (*ideriv >= *ncoeff) {
3795 i__1 = *ndimen;
3796 for (nd = 1; nd <= i__1; ++nd) {
3797 pntcrb[nd] = 0.;
3798/* L100: */
3799 }
3800 goto L9999;
3801 }
3802/* **********************************************************************
3803*/
3804/* Traitement general */
3805/* **********************************************************************
3806*/
3807/* --------------------- Calcul de Factorielle(IDERIV) ------------------
3808*/
3809
3810 k = *ideriv;
3811 if (*ideriv <= 21 && *ideriv > 0) {
3812 mfactk = mmfack[k - 1];
3813 } else {
3814 mfactk = 1.;
3815 i__1 = k;
3816 for (i__ = 2; i__ <= i__1; ++i__) {
3817 mfactk *= i__;
3818/* L200: */
3819 }
3820 }
3821
3822/* ------- Calcul de la derivee d' ordre IDERIV de COURBE en TPARAM -----
3823*/
3824/* ---> Attention : le coefficient binomial C(n,m) est represente dans */
3825/* MCCNP par CNP(N,M). */
3826
3827 i__1 = *ndimen;
3828 for (nd = 1; nd <= i__1; ++nd) {
3829 pntcrb[nd] = courbe[nd + *ncoeff * courbe_dim1] * mmcmcnp_.cnp[*
3830 ncoeff - 1 + k * 61] * mfactk;
3831/* L300: */
3832 }
3833
3834 i__1 = k + 1;
3835 for (j = *ncoeff - 1; j >= i__1; --j) {
3836 bid = mmcmcnp_.cnp[j - 1 + k * 61] * mfactk;
3837 i__2 = *ndimen;
3838 for (nd = 1; nd <= i__2; ++nd) {
3839 pntcrb[nd] = pntcrb[nd] * *tparam + courbe[nd + j * courbe_dim1] *
3840 bid;
3841/* L500: */
3842 }
3843/* L400: */
3844 }
3845
3846/* -------------------------------- The end -----------------------------
3847*/
3848
3849L9999:
3850
3851 return 0 ;
3852
3853} /* mmdrvck_ */
3854//=======================================================================
3855//function : AdvApp2Var_MathBase::mmeps1_
3856//purpose :
3857//=======================================================================
3858int AdvApp2Var_MathBase::mmeps1_(doublereal *epsilo)
3859
3860{
3861/* ***********************************************************************
3862 */
3863
3864/* FONCTION : */
3865/* ---------- */
3866/* Extraction du EPS1 du COMMON MPRCSN. EPS1 est le zero spatial */
3867/* egal a 1.D-9 */
3868
3869/* MOTS CLES : */
3870/* ----------- */
3871/* MPRCSN,PRECISON,EPS1. */
3872
3873/* ARGUMENTS D'ENTREE : */
3874/* ------------------ */
3875/* Neant */
3876
3877/* ARGUMENTS DE SORTIE : */
3878/* ------------------- */
3879/* EPSILO : Valeur de EPS1 (Le zero spatial (10**-9)) */
3880
3881/* COMMONS UTILISES : */
3882/* ---------------- */
3883
3884/* REFERENCES APPELEES : */
3885/* ----------------------- */
3886
3887/* DESCRIPTION/REMARQUES/LIMITATIONS : */
3888/* ----------------------------------- */
3889/* EPS1 est le zero spatial ABSOLU , c.a.d. que l' on doit */
3890/* l' utiliser chaque fois que l' on veut tester si une variable */
3891/* est nulle. Par exemple, si la norme d' un vecteur est inferieure */
3892/* a EPS1, c' est que ce vecteur est NUL ! (lorsqu' on travaille en */
3893/* REAL*8) Il est vivement deconseille de tester des arguments par */
3894/* rapport a EPS1**2. Vu les erreurs d' arrondis inevitables lors */
3895/* des calculs, cela revient a tester par rapport a 0.D0. */
3896
3897/* $ HISTORIQUE DES MODIFICATIONS : */
3898/* -------------------------------- */
3899/* 29-01-90 : DH ; Nettoyage */
3900/* 27-07-88 : RBD; Ajouts de commentaires. */
3901/* 29-10-87 : Cree par JJM. */
3902/* > */
3903/* ***********************************************************************
3904 */
3905
3906
3907
3908/* ***********************************************************************
3909 */
3910
3911/* FONCTION : */
3912/* ---------- */
3913/* DONNE LES TOLERANCES DE NULLITE DANS STRIM */
3914/* AINSI QUE LES BORNES DES PROCESSUS ITERATIFS */
3915
3916/* CONTEXTE GENERAL, MODIFIABLE PAR L'UTILISATEUR */
3917
3918/* MOTS CLES : */
3919/* ----------- */
3920/* PARAMETRE , TOLERANCE */
3921
3922/* DEMSCRIPTION/REMARQUES/LIMITATIONS : */
3923/* ----------------------------------- */
3924/* INITIALISATION : PROFIL , **VIA MPRFTX** A L' ENTREE DANS STRI
3925M*/
3926
3927/* CHARGEMENT DES VALEURS PAR DEFAUT DU PROFIL DANS MPRFTX A L'ENTRE
3928E*/
3929/* DANS STRIM. ELLES SONT CONSERVEES DANS DES VARIABLES LOCALES */
3930/* DE MPRFTX */
3931
3932/* REMISE DES VALEURS PAR DEFAUT : MDFINT */
3933/* MODIFICATION INTERACTIVE PAR L'UTILISATEUR : MDBINT */
3934
3935/* FONCTION D'ACCES : MMEPS1 ... EPS1 */
3936/* MEPSPB ... EPS3,EPS4 */
3937/* MEPSLN ... EPS2, NITERM , NITERR */
3938/* MEPSNR ... EPS2 , NITERM */
3939/* MITERR ... NITERR */
3940
3941/* $ HISTORIQUE DES MODIFICATIONS : */
3942/* ------------------------------ */
3943/* 01-02-90 : NAK ; ENTETE */
3944/* > */
3945/* ***********************************************************************
3946 */
3947
3948/* NITERM : NB D'ITERATIONS MAXIMAL */
3949/* NITERR : NB D'ITERATIONS RAPIDES */
3950/* EPS1 : TOLERANCE DE DISTANCE 3D NULLE */
3951/* EPS2 : TOLERANCE DE DISTANCE PARAMETRIQUE NULLE */
3952/* EPS3 : TOLERANCE POUR EVITER LES DIVISIONS PAR 0.. */
3953/* EPS4 : TOLERANCE ANGULAIRE */
3954
3955
3956
3957/* ***********************************************************************
3958 */
3959 *epsilo = mmprcsn_.eps1;
3960
3961 return 0 ;
3962} /* mmeps1_ */
3963
3964//=======================================================================
3965//function : mmexthi_
3966//purpose :
3967//=======================================================================
3968int mmexthi_(integer *ndegre,
3969 doublereal *hwgaus)
3970
3971{
3972 /* System generated locals */
3973 integer i__1;
3974
3975 /* Local variables */
3976 static integer iadd, ideb, ndeg2, nmod2, ii, ibb;
3977 static integer kpt;
3978
3979/* **********************************************************************
3980*/
3981
3982/* FONCTION : */
3983/* ---------- */
3984/* Extrait du commun LDGRTL les poids des formules de quadrature de */
3985/* Gauss sur toutes les racines des polynomes de Legendre de degre */
3986/* NDEGRE defini sur [-1,1]. */
3987
3988/* MOTS CLES : */
3989/* ----------- */
3990/* TOUS, AB_SPECIFI::COMMON&, EXTRACTION, &POIDS, &GAUSS. */
3991
3992/* ARGUMENTS D'ENTREE : */
3993/* ------------------ */
3994/* NDEGRE : Degre mathematique du polynome de Legendre. On doit avoir */
3995/* 2 <= NDEGRE <= 61. */
3996
3997/* ARGUMENTS DE SORTIE : */
3998/* ------------------- */
3999/* HWGAUS : Le tableau des poids des formules de quadrature de Gauss */
4000/* relatifs aux NDEGRE racines d' un polynome de Legendre de */
4001/* degre NDEGRE. */
4002
4003/* COMMONS UTILISES : */
4004/* ---------------- */
4005/* MLGDRTL */
4006
4007/* REFERENCES APPELEES : */
4008/* ----------------------- */
4009
4010/* DESCRIPTION/REMARQUES/LIMITATIONS : */
4011/* ----------------------------------- */
4012/* ATTENTION: La condition sur NDEGRE ( 2 <= NDEGRE <= 61) n'est */
4013/* pas testee. A l'appelant de faire le test. */
4014
4015/* $ HISTORIQUE DES MODIFICATIONS : */
4016/* -------------------------------- */
4017/* 23-03-90 : RBD ; Mise a jour en-tete, declaration variables locales, */
4018/* correction poids associe racines negatives (bug */
4019/* ENORME). */
4020/* 15-01-90 : NAK ; MLGDRTL PAR INCLUDE MMLGDRT */
4021/* 22-04-88 : JJM ; Creation. */
4022/* > */
4023/* **********************************************************************
4024*/
4025
4026/* Le nom de la routine */
4027
4028
4029/* Le common MLGDRTL: */
4030/* Ce common comprend les racines POSITIVES des polynomes de Legendre */
4031/* ET les poids des formules de quadrature de Gauss sur toutes les */
4032/* racines POSITIVES des polynomes de Legendre. */
4033
4034
4035
4036/* ***********************************************************************
4037 */
4038
4039/* FONCTION : */
4040/* ---------- */
4041/* Le common des racines de Legendre. */
4042
4043/* MOTS CLES : */
4044/* ----------- */
4045/* BASE LEGENDRE */
4046
4047/* DEMSCRIPTION/REMARQUES/LIMITATIONS : */
4048/* ----------------------------------- */
4049
4050/* $ HISTORIQUE DES MODIFICATIONS : */
4051/* ------------------------------ */
4052/* 11-01-90 : NAK ; Creation version originale */
4053/* > */
4054/* ***********************************************************************
4055 */
4056
4057
4058
4059
4060/* ROOTAB : Tableau de toutes les racines des polynomes de Legendre */
4061/* comprises entre ]0,1]. Elles sont rangees pour des degres croissants
4062*/
4063/* de 2 a 61. */
4064/* HILTAB : Tableau des interpolants de Legendre concernant ROOTAB. */
4065/* L' adressage est le meme. */
4066/* HI0TAB : Tableau des interpolants de Legendre pour la racine x=0 */
4067/* des polynomes de degre IMPAIR. */
4068/* RTLTB0 : Tableau des Li(uk) ou les uk sont les racines d' un */
4069/* polynome de Legendre de degre PAIR. */
4070/* RTLTB1 : Tableau des Li(uk) ou les uk sont les racines d' un */
4071/* polynome de Legendre de degre IMPAIR. */
4072
4073
4074/************************************************************************
4075*****/
4076 /* Parameter adjustments */
4077 --hwgaus;
4078
4079 /* Function Body */
4080 ibb = AdvApp2Var_SysBase::mnfndeb_();
4081 if (ibb >= 3) {
4082 AdvApp2Var_SysBase::mgenmsg_("MMEXTHI", 7L);
4083 }
4084
4085 ndeg2 = *ndegre / 2;
4086 nmod2 = *ndegre % 2;
4087
4088/* Adresse du poids de Gauss associe a la 1ere racine strictement */
4089/* positive du polynome de Legendre de degre NDEGRE dans MLGDRTL. */
4090
4091 iadd = ndeg2 * (ndeg2 - 1) / 2 + 1;
4092
4093/* Indice du 1er element de HWGAUS associe a la 1ere racine */
4094/* strictement positive du polynome de Legendre de degre NDEGRE. */
4095
4096 ideb = (*ndegre + 1) / 2 + 1;
4097
4098/* Lecture des poids associes aux racines strictement positives. */
4099
4100 i__1 = *ndegre;
4101 for (ii = ideb; ii <= i__1; ++ii) {
4102 kpt = iadd + ii - ideb;
4103 hwgaus[ii] = mlgdrtl_.hiltab[kpt + nmod2 * 465 - 1];
4104/* L100: */
4105 }
4106
4107/* Pour les racines strictement negatives, les poids sont les memes. */
4108/* i.e HW(1) = HW(NDEGRE), HW(2) = HW(NDEGRE-1), etc... */
4109
4110 i__1 = ndeg2;
4111 for (ii = 1; ii <= i__1; ++ii) {
4112 hwgaus[ii] = hwgaus[*ndegre + 1 - ii];
4113/* L200: */
4114 }
4115
4116/* Cas NDEGRE impair, 0 est racine du polynome de Legendre, on */
4117/* charge le poids de Gauss associe. */
4118
4119 if (nmod2 == 1) {
4120 hwgaus[ndeg2 + 1] = mlgdrtl_.hi0tab[ndeg2];
4121 }
4122
4123/* --------------------------- The end ----------------------------------
4124*/
4125
4126 if (ibb >= 3) {
4127 AdvApp2Var_SysBase::mgsomsg_("MMEXTHI", 7L);
4128 }
4129 return 0;
4130} /* mmexthi_ */
4131
4132//=======================================================================
4133//function : mmextrl_
4134//purpose :
4135//=======================================================================
4136int mmextrl_(integer *ndegre,
4137 doublereal *rootlg)
4138{
4139 /* System generated locals */
4140 integer i__1;
4141
4142 /* Local variables */
4143 static integer iadd, ideb, ndeg2, nmod2, ii, ibb;
4144 static integer kpt;
4145
4146
4147/* **********************************************************************
4148*/
4149
4150/* FONCTION : */
4151/* ---------- */
4152/* Extrait du Common LDGRTL les racines du polynome de Legendre */
4153/* de degre NDEGRE defini sur [-1,1]. */
4154
4155/* MOTS CLES : */
4156/* ----------- */
4157/* TOUS, AB_SPECIFI::COMMON&, EXTRACTION, &RACINE, &LEGENDRE. */
4158
4159/* ARGUMENTS D'ENTREE : */
4160/* ------------------ */
4161/* NDEGRE : Degre mathematique du polynome de Legendre. On doit avoir */
4162/* 2 <= NDEGRE <= 61. */
4163
4164/* ARGUMENTS DE SORTIE : */
4165/* ------------------- */
4166/* ROOTLG : Le tableau des racines du polynome de Legendre de degre */
4167/* NDEGRE et defini sur [-1,1]. */
4168
4169/* COMMONS UTILISES : */
4170/* ---------------- */
4171/* MLGDRTL */
4172
4173/* REFERENCES APPELEES : */
4174/* ----------------------- */
4175
4176/* DESCRIPTION/REMARQUES/LIMITATIONS : */
4177/* ----------------------------------- */
4178/* ATTENTION: La condition sur NDEGRE ( 2 <= NDEGRE <= 61) n'est */
4179/* pas testee. A l'appelant de faire le test. */
4180
4181/* $ HISTORIQUE DES MODIFICATIONS : */
4182/* -------------------------------- */
4183/* 23-03-90 : RBD ; Ajout commentaires + declarations. */
4184/* 15-01-90 : NAK ; MLGDRTL PAR INCLUDE MMLGDRT */
4185/* 04-03-88 : JJM ; Raccoursissement de MLGDRTL. */
4186/* 22-02-88 : JJM ; Appel MFNDEB -> MNFNDEB */
4187/* 23-10-87 : JJM ; Cree par JJM */
4188/* > */
4189/* **********************************************************************
4190*/
4191
4192
4193/* Le nom de la routine */
4194
4195
4196/* Le common MLGDRTL: */
4197/* Ce common comprend les racines POSITIVES des polynomes de Legendre */
4198/* ET les poids des formules de quadrature de Gauss sur toutes les */
4199/* racines POSITIVES des polynomes de Legendre. */
4200
4201/* ***********************************************************************
4202 */
4203
4204/* FONCTION : */
4205/* ---------- */
4206/* Le common des racines de Legendre. */
4207
4208/* MOTS CLES : */
4209/* ----------- */
4210/* BASE LEGENDRE */
4211
4212/* DEMSCRIPTION/REMARQUES/LIMITATIONS : */
4213/* ----------------------------------- */
4214
4215/* $ HISTORIQUE DES MODIFICATIONS : */
4216/* ------------------------------ */
4217/* 11-01-90 : NAK ; Creation version originale */
4218/* > */
4219/* ***********************************************************************
4220 */
4221
4222
4223
4224
4225/* ROOTAB : Tableau de toutes les racines des polynomes de Legendre */
4226/* comprises entre ]0,1]. Elles sont rangees pour des degres croissants
4227*/
4228/* de 2 a 61. */
4229/* HILTAB : Tableau des interpolants de Legendre concernant ROOTAB. */
4230/* L' adressage est le meme. */
4231/* HI0TAB : Tableau des interpolants de Legendre pour la racine x=0 */
4232/* des polynomes de degre IMPAIR. */
4233/* RTLTB0 : Tableau des Li(uk) ou les uk sont les racines d' un */
4234/* polynome de Legendre de degre PAIR. */
4235/* RTLTB1 : Tableau des Li(uk) ou les uk sont les racines d' un */
4236/* polynome de Legendre de degre IMPAIR. */
4237
4238
4239/************************************************************************
4240*****/
4241 /* Parameter adjustments */
4242 --rootlg;
4243
4244 /* Function Body */
4245 ibb = AdvApp2Var_SysBase::mnfndeb_();
4246 if (ibb >= 3) {
4247 AdvApp2Var_SysBase::mgenmsg_("MMEXTRL", 7L);
4248 }
4249
4250 ndeg2 = *ndegre / 2;
4251 nmod2 = *ndegre % 2;
4252
4253/* Adresse de la 1ere racine strictement positive du polynome de */
4254/* Legendre de degre NDEGRE dans MLGDRTL. */
4255
4256 iadd = ndeg2 * (ndeg2 - 1) / 2 + 1;
4257
4258/* Indice, dans ROOTLG, de la 1ere racine strictement positive du */
4259/* polynome de Legendre de degre NDEGRE. */
4260
4261 ideb = (*ndegre + 1) / 2 + 1;
4262
4263/* Lecture des racines strictement positives. */
4264
4265 i__1 = *ndegre;
4266 for (ii = ideb; ii <= i__1; ++ii) {
4267 kpt = iadd + ii - ideb;
4268 rootlg[ii] = mlgdrtl_.rootab[kpt + nmod2 * 465 - 1];
4269/* L100: */
4270 }
4271
4272/* Les racines strictement negatives sont egales aux racines positives
4273*/
4274/* au signe pres i.e RT(1) = -RT(NDEGRE), RT(2) = -RT(NDEGRE-1), etc...
4275*/
4276
4277 i__1 = ndeg2;
4278 for (ii = 1; ii <= i__1; ++ii) {
4279 rootlg[ii] = -rootlg[*ndegre + 1 - ii];
4280/* L200: */
4281 }
4282
4283/* Cas NDEGRE impair, 0 est racine du polynome de Legendre. */
4284
4285 if (nmod2 == 1) {
4286 rootlg[ndeg2 + 1] = 0.;
4287 }
4288
4289/* -------------------------------- THE END -----------------------------
4290*/
4291
4292 if (ibb >= 3) {
4293 AdvApp2Var_SysBase::mgenmsg_("MMEXTRL", 7L);
4294 }
4295 return 0;
4296} /* mmextrl_ */
4297
4298//=======================================================================
4299//function : AdvApp2Var_MathBase::mmfmca8_
4300//purpose :
4301//=======================================================================
4302int AdvApp2Var_MathBase::mmfmca8_(integer *ndimen,
4303 integer *ncoefu,
4304 integer *ncoefv,
4305 integer *ndimax,
4306 integer *ncfumx,
4307 integer *,//ncfvmx,
4308 doublereal *tabini,
4309 doublereal *tabres)
4310
4311{
4312 /* System generated locals */
4313 integer tabini_dim1, tabini_dim2, tabini_offset, tabres_dim1, tabres_dim2,
4314 tabres_offset;
4315
4316 /* Local variables */
4317 static integer i__, j, k, ilong;
4318
4319
4320
4321/* **********************************************************************
4322*/
4323
4324/* FONCTION : */
4325/* ---------- */
4326/* Expansion d' un tableau ne contenant que l' essentiel */
4327/* en un tableau de donnees plus grand. */
4328
4329/* MOTS CLES : */
4330/* ----------- */
4331/* TOUS, MATH_ACCES:: CARREAU&, DECOMPRESSION, &CARREAU */
4332
4333/* ARGUMENTS D'ENTREE : */
4334/* ------------------ */
4335/* NDIMEN: Dimension de l' espace de travail. */
4336/* NCOEFU: Le degre +1 du tableau en u. */
4337/* NCOEFV: Le degre +1 du tableau en v. */
4338/* NDIMAX: Dimension maxi de l' espace. */
4339/* NCFUMX: Degre maximal +1 du tableau en u. */
4340/* NCFVMX: Degre maximal +1 du tableau en v. */
4341/* TABINI: Le tableau a decompacter. */
4342
4343/* ARGUMENTS DE SORTIE : */
4344/* ------------------- */
4345/* TABRES: Le tableau decompacte. */
4346
4347/* COMMONS UTILISES : */
4348/* ---------------- */
4349
4350/* REFERENCES APPELEES : */
4351/* ----------------------- */
4352
4353/* DESCRIPTION/REMARQUES/LIMITATIONS : */
4354/* ----------------------------------- */
4355/* L' appel suivant : */
4356
4357/* CALL MMFMCA8(NDIMEN,NCOEFU,NCOEFV,NDIMAX,NCFUMX,NCFVMX,TABINI,TABINI)
4358*/
4359
4360/* ou TABINI est un argument d' entree/sortie, est possible pourvu */
4361/* que l' appelant ait declare TABINI en (NDIMAX,NCFUMX,NCFVMX) */
4362
4363/* ATTENTION : on ne verifie pas que NDIMAX >= NDIMEN, */
4364/* NCOEFU >= NCFMXU et NCOEFV >= NCFMXV. */
4365
4366/* $ HISTORIQUE DES MODIFICATIONS : */
4367/* -------------------------------- */
4368/* 03-08-1989 : RBD; Creation */
4369/* > */
4370/* **********************************************************************
4371*/
4372
4373
4374 /* Parameter adjustments */
4375 tabini_dim1 = *ndimen;
4376 tabini_dim2 = *ncoefu;
4377 tabini_offset = tabini_dim1 * (tabini_dim2 + 1) + 1;
4378 tabini -= tabini_offset;
4379 tabres_dim1 = *ndimax;
4380 tabres_dim2 = *ncfumx;
4381 tabres_offset = tabres_dim1 * (tabres_dim2 + 1) + 1;
4382 tabres -= tabres_offset;
4383
4384 /* Function Body */
4385 if (*ndimax == *ndimen) {
4386 goto L1000;
4387 }
4388
4389/* ----------------------- decompression NDIMAX<>NDIMEN -----------------
4390*/
4391
4392 for (k = *ncoefv; k >= 1; --k) {
4393 for (j = *ncoefu; j >= 1; --j) {
4394 for (i__ = *ndimen; i__ >= 1; --i__) {
4395 tabres[i__ + (j + k * tabres_dim2) * tabres_dim1] = tabini[
4396 i__ + (j + k * tabini_dim2) * tabini_dim1];
4397/* L300: */
4398 }
4399/* L200: */
4400 }
4401/* L100: */
4402 }
4403 goto L9999;
4404
4405/* ----------------------- decompression NDIMAX=NDIMEN ------------------
4406*/
4407
4408L1000:
4409 if (*ncoefu == *ncfumx) {
4410 goto L2000;
4411 }
4412 ilong = (*ndimen << 3) * *ncoefu;
4413 for (k = *ncoefv; k >= 1; --k) {
4414 AdvApp2Var_SysBase::mcrfill_((integer *)&ilong,
4415 (char *)&tabini[(k * tabini_dim2 + 1) * tabini_dim1 + 1],
4416 (char *)&tabres[(k * tabres_dim2 + 1) * tabres_dim1 + 1]);
4417/* L500: */
4418 }
4419 goto L9999;
4420
4421/* ----------------- decompression NDIMAX=NDIMEN,NCOEFU=NCFUMX ----------
4422*/
4423
4424L2000:
4425 ilong = (*ndimen << 3) * *ncoefu * *ncoefv;
4426 AdvApp2Var_SysBase::mcrfill_((integer *)&ilong,
4427 (char *)&tabini[tabini_offset],
4428 (char *)&tabres[tabres_offset]);
4429 goto L9999;
4430
4431/* ---------------------------- The end ---------------------------------
4432*/
4433
4434L9999:
4435 return 0;
4436} /* mmfmca8_ */
4437
4438//=======================================================================
4439//function : AdvApp2Var_MathBase::mmfmca9_
4440//purpose :
4441//=======================================================================
4442 int AdvApp2Var_MathBase::mmfmca9_(integer *ndimax,
4443 integer *ncfumx,
4444 integer *,//ncfvmx,
4445 integer *ndimen,
4446 integer *ncoefu,
4447 integer *ncoefv,
4448 doublereal *tabini,
4449 doublereal *tabres)
4450
4451{
4452 /* System generated locals */
4453 integer tabini_dim1, tabini_dim2, tabini_offset, tabres_dim1, tabres_dim2,
4454 tabres_offset, i__1, i__2, i__3;
4455
4456 /* Local variables */
4457 static integer i__, j, k, ilong;
4458
4459
4460
4461/* **********************************************************************
4462*/
4463
4464/* FONCTION : */
4465/* ---------- */
4466/* Compression d' un tableau de donnees en un tableau ne */
4467/* contenant que l' essentiel (Le tableau d' entree n' est */
4468/* pas ecrase). */
4469
4470/* MOTS CLES : */
4471/* ----------- */
4472/* TOUS, MATH_ACCES:: CARREAU&, COMPRESSION, &CARREAU */
4473
4474/* ARGUMENTS D'ENTREE : */
4475/* ------------------ */
4476/* NDIMAX: Dimension maxi de l' espace. */
4477/* NCFUMX: Degre maximal +1 du tableau en u. */
4478/* NCFVMX: Degre maximal +1 du tableau en v. */
4479/* NDIMEN: Dimension de l' espace de travail. */
4480/* NCOEFU: Le degre +1 du tableau en u. */
4481/* NCOEFV: Le degre +1 du tableau en v. */
4482/* TABINI: Le tableau a compacter. */
4483
4484/* ARGUMENTS DE SORTIE : */
4485/* ------------------- */
4486/* TABRES: Le tableau compacte. */
4487
4488/* COMMONS UTILISES : */
4489/* ---------------- */
4490
4491/* REFERENCES APPELEES : */
4492/* ----------------------- */
4493
4494/* DESCRIPTION/REMARQUES/LIMITATIONS : */
4495/* ----------------------------------- */
4496/* L' appel suivant : */
4497
4498/* CALL MMFMCA9(NDIMAX,NCFUMX,NCFVMX,NDIMEN,NCOEFU,NCOEFV,TABINI,TABINI)
4499*/
4500
4501/* ou TABINI est un argument d' entree/sortie, est possible pourvu */
4502/* que l' appelant ait bien verifie que : */
4503
4504/* NDIMAX > NDIMEN, */
4505/* ou NDIMAX = NDIMEN et NCFUMX > NCOEFU */
4506/* ou NDIMAX = NDIMEN, NCFUMX = NCOEFU et NCFVMX > NCOEFV */
4507
4508/* Ces conditions ne sont pas testees dans le programme. */
4509
4510/* $ HISTORIQUE DES MODIFICATIONS : */
4511/* -------------------------------- */
4512/* 18-01-199O : RBD ; Creation. */
4513/* > */
4514/* **********************************************************************
4515*/
4516
4517
4518 /* Parameter adjustments */
4519 tabini_dim1 = *ndimax;
4520 tabini_dim2 = *ncfumx;
4521 tabini_offset = tabini_dim1 * (tabini_dim2 + 1) + 1;
4522 tabini -= tabini_offset;
4523 tabres_dim1 = *ndimen;
4524 tabres_dim2 = *ncoefu;
4525 tabres_offset = tabres_dim1 * (tabres_dim2 + 1) + 1;
4526 tabres -= tabres_offset;
4527
4528 /* Function Body */
4529 if (*ndimen == *ndimax) {
4530 goto L1000;
4531 }
4532
4533/* ----------------------- Compression NDIMEN<>NDIMAX -------------------
4534*/
4535
4536 i__1 = *ncoefv;
4537 for (k = 1; k <= i__1; ++k) {
4538 i__2 = *ncoefu;
4539 for (j = 1; j <= i__2; ++j) {
4540 i__3 = *ndimen;
4541 for (i__ = 1; i__ <= i__3; ++i__) {
4542 tabres[i__ + (j + k * tabres_dim2) * tabres_dim1] = tabini[
4543 i__ + (j + k * tabini_dim2) * tabini_dim1];
4544/* L300: */
4545 }
4546/* L200: */
4547 }
4548/* L100: */
4549 }
4550 goto L9999;
4551
4552/* ----------------------- Compression NDIMEN=NDIMAX --------------------
4553*/
4554
4555L1000:
4556 if (*ncoefu == *ncfumx) {
4557 goto L2000;
4558 }
4559 ilong = (*ndimen << 3) * *ncoefu;
4560 i__1 = *ncoefv;
4561 for (k = 1; k <= i__1; ++k) {
4562 AdvApp2Var_SysBase::mcrfill_((integer *)&ilong,
4563 (char *)&tabini[(k * tabini_dim2 + 1) * tabini_dim1 + 1],
4564 (char *)&tabres[(k * tabres_dim2 + 1) * tabres_dim1 + 1]);
4565/* L500: */
4566 }
4567 goto L9999;
4568
4569/* ----------------- Compression NDIMEN=NDIMAX,NCOEFU=NCFUMX ------------
4570*/
4571
4572L2000:
4573 ilong = (*ndimen << 3) * *ncoefu * *ncoefv;
4574 AdvApp2Var_SysBase::mcrfill_((integer *)&ilong,
4575 (char *)&tabini[tabini_offset],
4576 (char *)&tabres[tabres_offset]);
4577 goto L9999;
4578
4579/* ---------------------------- The end ---------------------------------
4580*/
4581
4582L9999:
4583 return 0;
4584} /* mmfmca9_ */
4585
4586//=======================================================================
4587//function : AdvApp2Var_MathBase::mmfmcar_
4588//purpose :
4589//=======================================================================
4590int AdvApp2Var_MathBase::mmfmcar_(integer *ndimen,
4591 integer *ncofmx,
4592 integer *ncoefu,
4593 integer *ncoefv,
4594 doublereal *patold,
4595 doublereal *upara1,
4596 doublereal *upara2,
4597 doublereal *vpara1,
4598 doublereal *vpara2,
4599 doublereal *patnew,
4600 integer *iercod)
4601
4602{
4603 static integer c__8 = 8;
4604 /* System generated locals */
4605 integer patold_dim1, patold_dim2, patnew_dim1, patnew_dim2,
4606 i__1, patold_offset,patnew_offset;
4607
4608 /* Local variables */
4609 static doublereal tbaux[1];
4610 static integer ksize, numax, kk;
4611 static long int iofst;
4612 static integer ibb, ier;
4613
4614/* ***********************************************************************
4615 */
4616
4617/* FONCTION : */
4618/* ---------- */
4619/* LIMITATION D'UN CARREAU DEFINI SUR (0,1)*(0,1) ENTRE LES ISOS */
4620/* UPARA1 ET UPARA2 (EN U) ET VPARA1 ET VPARA2 EN V. */
4621
4622/* MOTS CLES : */
4623/* ----------- */
4624/* LIMITATION , CARREAU , PARAMETRE */
4625
4626/* ARGUMENTS D'ENTREE : */
4627/* ------------------ */
4628/* NCOFMX: NBRE MAXI DE COEFF EN U DU CARREAU */
4629/* NCOEFU: NBRE DE COEFF EN U DU CARREAU */
4630/* NCOEFV: NBRE DE COEFF EN V DU CARREAU */
4631/* PATOLD : LE CARREAU A LIMITER SUIVANT UPARA1,UPARA2 ET VPARA1,VPARA2
4632.*/
4633/* UPARA1 : BORNE INF DES U */
4634/* UPARA2 : BORNE SUP DES U */
4635/* VPARA1 : BORNE INF DES V */
4636/* VPARA2 : BORNE SUP DES V */
4637
4638/* ARGUMENTS DE SORTIE : */
4639/* ------------------- */
4640/* PATNEW : LE CARREAU RELIMITE, DEFINI DANS (0,1)**2 */
4641/* IERCOD : =10 NBR DE COEFF TROP GRAND OU NUL */
4642/* =13 PB DANS L' ALLOCATION DYNAMIQUE */
4643/* = 0 OK. */
4644
4645/* COMMONS UTILISES : */
4646/* ---------------- */
4647
4648/* REFERENCES APPELEES : */
4649/* ----------------------- */
4650
4651/* DESCRIPTION/REMARQUES/LIMITATIONS : */
4652/* ----------------------------------- */
4653/* ---> L' appel suivant : */
4654/* CALL MMFMCAR(NCOFMX,NCOEFU,NCOEFV,PATOLD,UPARA1,UPARA2,VPARA1,VPARA2
4655*/
4656/* ,PATOLD), */
4657/* ou PATOLD est un argument d' entree/sortie est tout a fait */
4658/* legal. */
4659
4660/* ---> Le nombre maximum de coeff en u et en v de PATOLD est 61 */
4661
4662/* ---> Si NCOEFU < NCOFMX, on compresse les donnees par MMFMCA9 avant
4663*/
4664/* la limitation en v pour gagner du temps lors de l' execution */
4665/* de MMARC41 qui suit (le carreau est traite comme une courbe de
4666*/
4667/* dimension NDIMEN*NCOEFU possedant NCOEFV coefficients). */
4668
4669/* $ HISTORIQUE DES MODIFICATIONS : */
4670/* -------------------------------- */
4671/* 02-08-89 : RBD; CREATION. */
4672/* > */
4673/* ***********************************************************************
4674 */
4675
4676/* Le nom de la routine */
4677
4678
4679 /* Parameter adjustments */
4680 patnew_dim1 = *ndimen;
4681 patnew_dim2 = *ncofmx;
4682 patnew_offset = patnew_dim1 * (patnew_dim2 + 1) + 1;
4683 patnew -= patnew_offset;
4684 patold_dim1 = *ndimen;
4685 patold_dim2 = *ncofmx;
4686 patold_offset = patold_dim1 * (patold_dim2 + 1) + 1;
4687 patold -= patold_offset;
4688
4689 /* Function Body */
4690 ibb = AdvApp2Var_SysBase::mnfndeb_();
4691 if (ibb >= 2) {
4692 AdvApp2Var_SysBase::mgenmsg_("MMFMCAR", 7L);
4693 }
4694 *iercod = 0;
4695 iofst = 0;
4696
4697/* **********************************************************************
4698*/
4699/* TEST DES NOMBRES DE COEFFICIENTS */
4700/* **********************************************************************
4701*/
4702
4703 if (*ncofmx < *ncoefu) {
4704 *iercod = 10;
4705 goto L9999;
4706 }
4707 if (*ncoefu < 1 || *ncoefu > 61 || *ncoefv < 1 || *ncoefv > 61) {
4708 *iercod = 10;
4709 goto L9999;
4710 }
4711
4712/* **********************************************************************
4713*/
4714/* CAS OU UPARA1=VPARA1=0 ET UPARA2=VPARA2=1 */
4715/* **********************************************************************
4716*/
4717
4718 if (*upara1 == 0. && *upara2 == 1. && *vpara1 == 0. && *vpara2 == 1.) {
4719 ksize = (*ndimen << 3) * *ncofmx * *ncoefv;
4720 AdvApp2Var_SysBase::mcrfill_((integer *)&ksize,
4721 (char *)&patold[patold_offset],
4722 (char *)&patnew[patnew_offset]);
4723 goto L9999;
4724 }
4725
4726/* **********************************************************************
4727*/
4728/* LIMITATION EN U */
4729/* **********************************************************************
4730*/
4731
4732 if (*upara1 == 0. && *upara2 == 1.) {
4733 goto L2000;
4734 }
4735 i__1 = *ncoefv;
4736 for (kk = 1; kk <= i__1; ++kk) {
4737 mmarc41_(ndimen, ndimen, ncoefu, &patold[(kk * patold_dim2 + 1) *
4738 patold_dim1 + 1], upara1, upara2, &patnew[(kk * patnew_dim2 +
4739 1) * patnew_dim1 + 1], iercod);
4740/* L100: */
4741 }
4742
4743/* **********************************************************************
4744*/
4745/* LIMITATION EN V */
4746/* **********************************************************************
4747*/
4748
4749L2000:
4750 if (*vpara1 == 0. && *vpara2 == 1.) {
4751 goto L9999;
4752 }
4753
4754/* ----------- LIMITATION EN V (AVEC COMPRESSION I.E. NCOEFU<NCOFMX) ----
4755*/
4756
4757 numax = *ndimen * *ncoefu;
4758 if (*ncofmx != *ncoefu) {
4759/* ------------------------- Allocation dynamique -------------------
4760---- */
4761 ksize = *ndimen * *ncoefu * *ncoefv;
4762 AdvApp2Var_SysBase::mcrrqst_(&c__8, &ksize, tbaux, &iofst, &ier);
4763 if (ier > 0) {
4764 *iercod = 13;
4765 goto L9900;
4766 }
4767/* --------------- Compression en (NDIMEN,NCOEFU,NCOEFV) ------------
4768---- */
4769 if (*upara1 == 0. && *upara2 == 1.) {
4770 AdvApp2Var_MathBase::mmfmca9_(ndimen,
4771 ncofmx,
4772 ncoefv,
4773 ndimen,
4774 ncoefu,
4775 ncoefv,
4776 &patold[patold_offset],
4777 &tbaux[iofst]);
4778 } else {
4779 AdvApp2Var_MathBase::mmfmca9_(ndimen,
4780 ncofmx,
4781 ncoefv,
4782 ndimen,
4783 ncoefu,
4784 ncoefv,
4785 &patnew[patnew_offset],
4786 &tbaux[iofst]);
4787 }
4788/* ------------------------- Limitation en v ------------------------
4789---- */
4790 mmarc41_(&numax, &numax, ncoefv, &tbaux[iofst], vpara1, vpara2, &
4791 tbaux[iofst], iercod);
4792/* --------------------- Expansion de TBAUX dans PATNEW -------------
4793--- */
4794 AdvApp2Var_MathBase::mmfmca8_(ndimen, ncoefu, ncoefv, ndimen, ncofmx, ncoefv, &tbaux[iofst]
4795 , &patnew[patnew_offset]);
4796 goto L9900;
4797
4798/* -------- LIMITATION EN V (SANS COMPRESSION I.E. NCOEFU=NCOFMX) ---
4799---- */
4800
4801 } else {
4802 if (*upara1 == 0. && *upara2 == 1.) {
4803 mmarc41_(&numax, &numax, ncoefv, &patold[patold_offset], vpara1,
4804 vpara2, &patnew[patnew_offset], iercod);
4805 } else {
4806 mmarc41_(&numax, &numax, ncoefv, &patnew[patnew_offset], vpara1,
4807 vpara2, &patnew[patnew_offset], iercod);
4808 }
4809 goto L9999;
4810 }
4811
4812/* **********************************************************************
4813*/
4814/* DESALLOCATION */
4815/* **********************************************************************
4816*/
4817
4818L9900:
4819 if (iofst != 0) {
4820 AdvApp2Var_SysBase::mcrdelt_(&c__8, &ksize, tbaux, &iofst, &ier);
4821 }
4822 if (ier > 0) {
4823 *iercod = 13;
4824 }
4825
4826/* ------------------------------ The end -------------------------------
4827*/
4828
4829L9999:
4830 if (*iercod > 0) {
4831 AdvApp2Var_SysBase::maermsg_("MMFMCAR", iercod, 7L);
4832 }
4833 if (ibb >= 2) {
4834 AdvApp2Var_SysBase::mgsomsg_("MMFMCAR", 7L);
4835 }
4836 return 0;
4837} /* mmfmcar_ */
4838
4839
4840//=======================================================================
4841//function : AdvApp2Var_MathBase::mmfmcb5_
4842//purpose :
4843//=======================================================================
4844int AdvApp2Var_MathBase::mmfmcb5_(integer *isenmsc,
4845 integer *ndimax,
4846 integer *ncf1mx,
4847 doublereal *courb1,
4848 integer *ncoeff,
4849 integer *ncf2mx,
4850 integer *ndimen,
4851 doublereal *courb2,
4852 integer *iercod)
4853
4854{
4855 /* System generated locals */
4856 integer courb1_dim1, courb1_offset, courb2_dim1, courb2_offset, i__1,
4857 i__2;
4858
4859 /* Local variables */
4860 static integer i__, nboct, nd;
4861
4862
4863/* **********************************************************************
4864*/
4865
4866/* FONCTION : */
4867/* ---------- */
4868/* Reformattage (et compactage/decompactage eventuel) de courbe */
4869/* (ndim,.) en (.,ndim) et reciproquement . */
4870
4871/* MOTS CLES : */
4872/* ----------- */
4873/* TOUS , MATH_ACCES :: */
4874/* COURBE&, REORGANISATION,COMPRESSION,INVERSION , &COURBE */
4875
4876/* ARGUMENTS D'ENTREE : */
4877/* -------------------- */
4878/* ISENMSC : sens du transfert demande : */
4879/* 1 : passage de (NDIMEN,.) ---> (.,NDIMEN) sens vers AB
4880*/
4881/* -1 : passage de (.,NDIMEN) ---> (NDIMEN,.) sens vers TS,T
4882V*/
4883/* NDIMAX : format / dimension */
4884/* NCF1MX : format en t de COURB1 */
4885/* si ISENMSC= 1 : COURB1: La courbe a traiter (NDIMAX,.) */
4886/* NCOEFF : nombre de coef de la courbe */
4887/* NCF2MX : format en t de COURB2 */
4888/* NDIMEN : dimension de la courbe et format de COURB2 */
4889/* si ISENMSC=-1 : COURB2: La courbe a traiter (.,NDIMEN) */
4890
4891/* ARGUMENTS DE SORTIE : */
4892/* --------------------- */
4893/* si ISENMSC= 1 : COURB2: La courbe resultat (.,NDIMEN) */
4894/* si ISENMSC=-1 : COURB1: La courbe resultat (NDIMAX,.) */
4895
4896/* COMMONS UTILISES : */
4897/* ------------------ */
4898
4899/* REFERENCES APPELEES : */
4900/* --------------------- */
4901
4902/* DESCRIPTION/REMARQUES/LIMITATIONS : */
4903/* ----------------------------------- */
4904/* permet de traiter les transferts usuels suivant : */
4905/* | ---- ISENMSC = 1 ---- | | ---- ISENMSC =-1 ----- | */
4906/* TS (3,21) --> (21,3) AB ; AB (21,3) --> (3,21) TS */
4907/* TS (3,21) --> (NU,3) AB ; AB (NU,3) --> (3,21) TS */
4908/* (3,NU) --> (21,3) AB ; AB (21,3) --> (3,NU) */
4909/* (3,NU) --> (NU,3) AB ; AB (NU,3) --> (3,NU) */
4910
4911/* $ HISTORIQUE DES MODIFICATIONS : */
4912/* ------------------------------ */
4913/* .07-08-89 : JG ; VERSION ORIGINALE (ANNULE ET REMPLACE MMCVINV)
4914*/
4915/* > */
4916/* ***********************************************************************
4917 */
4918
4919
4920 /* Parameter adjustments */
4921 courb1_dim1 = *ndimax;
4922 courb1_offset = courb1_dim1 + 1;
4923 courb1 -= courb1_offset;
4924 courb2_dim1 = *ncf2mx;
4925 courb2_offset = courb2_dim1 + 1;
4926 courb2 -= courb2_offset;
4927
4928 /* Function Body */
4929 if (*ndimen > *ndimax || *ncoeff > *ncf1mx || *ncoeff > *ncf2mx) {
4930 goto L9119;
4931 }
4932
4933 if (*ndimen == 1 && *ncf1mx == *ncf2mx) {
4934 nboct = *ncf2mx << 3;
4935 if (*isenmsc == 1) {
4936 AdvApp2Var_SysBase::mcrfill_((integer *)&nboct,
4937 (char *)&courb1[courb1_offset],
4938 (char *)&courb2[courb2_offset]);
4939 }
4940 if (*isenmsc == -1) {
4941 AdvApp2Var_SysBase::mcrfill_((integer *)&nboct,
4942 (char *)&courb2[courb2_offset],
4943 (char *)&courb1[courb1_offset]);
4944 }
4945 *iercod = -3136;
4946 goto L9999;
4947 }
4948
4949 *iercod = 0;
4950 if (*isenmsc == 1) {
4951 i__1 = *ndimen;
4952 for (nd = 1; nd <= i__1; ++nd) {
4953 i__2 = *ncoeff;
4954 for (i__ = 1; i__ <= i__2; ++i__) {
4955 courb2[i__ + nd * courb2_dim1] = courb1[nd + i__ *
4956 courb1_dim1];
4957/* L400: */
4958 }
4959/* L500: */
4960 }
4961 } else if (*isenmsc == -1) {
4962 i__1 = *ndimen;
4963 for (nd = 1; nd <= i__1; ++nd) {
4964 i__2 = *ncoeff;
4965 for (i__ = 1; i__ <= i__2; ++i__) {
4966 courb1[nd + i__ * courb1_dim1] = courb2[i__ + nd *
4967 courb2_dim1];
4968/* L1400: */
4969 }
4970/* L1500: */
4971 }
4972 } else {
4973 *iercod = 3164;
4974 }
4975
4976 goto L9999;
4977
4978/* ***********************************************************************
4979 */
4980
4981L9119:
4982 *iercod = 3119;
4983
4984L9999:
4985 if (*iercod != 0) {
4986 AdvApp2Var_SysBase::maermsg_("MMFMCB5", iercod, 7L);
4987 }
4988 return 0;
4989} /* mmfmcb5_ */
4990
4991//=======================================================================
4992//function : AdvApp2Var_MathBase::mmfmtb1_
4993//purpose :
4994//=======================================================================
4995int AdvApp2Var_MathBase::mmfmtb1_(integer *maxsz1,
4996 doublereal *table1,
4997 integer *isize1,
4998 integer *jsize1,
4999 integer *maxsz2,
5000 doublereal *table2,
5001 integer *isize2,
5002 integer *jsize2,
5003 integer *iercod)
5004{
5005 static integer c__8 = 8;
5006
5007 /* System generated locals */
5008 integer table1_dim1, table1_offset, table2_dim1, table2_offset, i__1,
5009 i__2;
5010
5011 /* Local variables */
5012 static doublereal work[1];
5013 static integer ilong, isize, ii, jj, ier;
5014 static long int iofst,iipt, jjpt;
5015
5016
5017/************************************************************************
5018*******/
5019
5020/* FONCTION : */
5021/* ---------- */
5022/* Inversion des elements d'un tableau rectangulaire (T1(i,j) */
5023/* est charge dans T2(j,i)) */
5024
5025/* MOTS CLES : */
5026/* ----------- */
5027/* TOUS, MATH_ACCES :: TABLEAU&, INVERSION, &TABLEAU */
5028
5029/* ARGUMENTS D'ENTREE : */
5030/* ------------------ */
5031/* MAXSZ1: Nbre maxi d'elements suivant la 1ere dimension de */
5032/* TABLE1. */
5033/* TABLE1: Table de reels a deux dimensions. */
5034/* ISIZE1: Nbre d'elements utiles de TABLE1 sur la 1ere dimension */
5035/* JSIZE1: Nbre d'elements utiles de TABLE1 sur la 2eme dimension */
5036/* MAXSZ2: Nbre maxi d'elements suivant la 1ere dimension de */
5037/* TABLE2. */
5038
5039/* ARGUMENTS DE SORTIE : */
5040/* ------------------- */
5041/* TABLE2: Table de reels a deux dimensions, contenant la transposee
5042*/
5043/* du tableau rectangulaire TABLE1. */
5044/* ISIZE2: Nbre d'elements utiles de TABLE2 sur la 1ere dimension */
5045/* JSIZE2: Nbre d'elements utiles de TABLE2 sur la 2eme dimension */
5046/* IERCOD: Code d'erreur. */
5047/* = 0, ok. */
5048/* = 1, erreur dans le dimensionnement des tables */
5049/* soit MAXSZ1 < ISIZE1 (tableau TABLE1 trop petit). */
5050/* soit MAXSZ2 < JSIZE1 (tableau TABLE2 trop petit). */
5051
5052/* COMMONS UTILISES : */
5053/* ---------------- */
5054
5055/* REFERENCES APPELEES : */
5056/* ---------------------- */
5057
5058/* DESCRIPTION/REMARQUES/LIMITATIONS : */
5059/* ----------------------------------- */
5060/* On peut utiliser TABLE1 comme tableau d'entree et de sortie i.e. */
5061/* l'appel: */
5062/* CALL MMFMTB1(MAXSZ1,TABLE1,ISIZE1,JSIZE1,MAXSZ2,TABLE1 */
5063/* ,ISIZE2,JSIZE2,IERCOD) */
5064/* est valable. */
5065
5066/* $ HISTORIQUE DES MODIFICATIONS : */
5067/* -------------------------------- */
5068/* 07-06-91: RBD; Creation d'apres VCRINV de NAK. */
5069/* > */
5070/* **********************************************************************
5071*/
5072
5073
5074 /* Parameter adjustments */
5075 table1_dim1 = *maxsz1;
5076 table1_offset = table1_dim1 + 1;
5077 table1 -= table1_offset;
5078 table2_dim1 = *maxsz2;
5079 table2_offset = table2_dim1 + 1;
5080 table2 -= table2_offset;
5081
5082 /* Function Body */
5083 *iercod = 0;
5084 if (*isize1 > *maxsz1 || *jsize1 > *maxsz2) {
5085 goto L9100;
5086 }
5087
5088 iofst = 0;
5089 isize = *maxsz2 * *isize1;
5090 AdvApp2Var_SysBase::mcrrqst_(&c__8, &isize, work, &iofst, &ier);
5091 if (ier > 0) {
5092 goto L9200;
5093 }
5094
5095/* NE PAS CRAINDRE D'ECRASEMENT. */
5096
5097 i__1 = *isize1;
5098 for (ii = 1; ii <= i__1; ++ii) {
5099 iipt = (ii - 1) * *maxsz2 + iofst;
5100 i__2 = *jsize1;
5101 for (jj = 1; jj <= i__2; ++jj) {
5102 jjpt = iipt + (jj - 1);
5103 work[jjpt] = table1[ii + jj * table1_dim1];
5104/* L200: */
5105 }
5106/* L100: */
5107 }
5108 ilong = isize << 3;
5109 AdvApp2Var_SysBase::mcrfill_((integer *)&ilong,
5110 (char *)&work[iofst],
5111 (char *)&table2[table2_offset]);
5112
5113/* -------------- On recupere le nombre d'elements de TABLE2 ------------
5114*/
5115
5116 ii = *isize1;
5117 *isize2 = *jsize1;
5118 *jsize2 = ii;
5119
5120 goto L9999;
5121
5122/* ------------------------------- THE END ------------------------------
5123*/
5124/* --> Entree invalide. */
5125L9100:
5126 *iercod = 1;
5127 goto L9999;
5128/* --> Pb d'alloc. */
5129L9200:
5130 *iercod = 2;
5131 goto L9999;
5132
5133L9999:
5134 if (iofst != 0) {
5135 AdvApp2Var_SysBase::mcrdelt_(&c__8, &isize, work, &iofst, &ier);
5136 }
5137 if (ier > 0) {
5138 *iercod = 2;
5139 }
5140 return 0;
5141} /* mmfmtb1_ */
5142
5143//=======================================================================
5144//function : AdvApp2Var_MathBase::mmgaus1_
5145//purpose :
5146//=======================================================================
5147int AdvApp2Var_MathBase::mmgaus1_(integer *ndimf,
5148 int (*bfunx) (
5149 integer *ninteg,
5150 doublereal *parame,
5151 doublereal *vfunj1,
5152 integer *iercod
5153 ),
5154
5155 integer *k,
5156 doublereal *xd,
5157 doublereal *xf,
5158 doublereal *saux1,
5159 doublereal *saux2,
5160 doublereal *somme,
5161 integer *niter,
5162 integer *iercod)
5163{
5164 /* System generated locals */
5165 integer i__1, i__2;
5166
5167 /* Local variables */
5168 static integer ndeg;
5169 static doublereal h__[20];
5170 static integer j;
5171 static doublereal t, u[20], x;
5172 static integer idimf;
5173 static doublereal c1x, c2x;
5174/* **********************************************************************
5175*/
5176
5177/* FONCTION : */
5178/* -------- */
5179
5180/* Calcul de l'integrale de la fonction BFUNX passee en parametre */
5181/* entre les bornes XD et XF . */
5182/* La fonction doit etre calculable pour n'importe quelle valeur */
5183/* de la variable dans l'intervalle donne.. */
5184/* La methode utilisee est celle de GAUSS-LEGENDRE. Des explications
5185*/
5186/* peuvent etre obtenus sur le livre : */
5187/* Complements de mathematiques a l'usage des Ingenieurs de */
5188/* l'electrotechnique et des telecommunications. */
5189/* Par Andre ANGOT - Collection technique et scientifique du CNET
5190 */
5191/* page 772 .... */
5192/* Le degre des polynomes de LEGENDRE utilise est passe en parametre.
5193 */
5194
5195/* MOTS CLES : */
5196/* --------- */
5197/* INTEGRATION,LEGENDRE,GAUSS */
5198
5199/* ARGUMENTS D'ENTREE : */
5200/* ------------------ */
5201
5202/* NDIMF : Dimension de la fonction */
5203/* BFUNX : Fonction a integrer passee en argument */
5204/* Doit etre declaree en EXTERNAL dans la routine d'appel. */
5205/* SUBROUTINE BFUNX(NDIMF,X,VAL,IER) */
5206/* REAL *8 X,VAL */
5207/* K : Parametre determinant le degre du polynome de LEGENDRE qui
5208*/
5209/* peut prendre une valeur comprise entre 0 et 10. */
5210/* Le degre du polynome est egal a 4 k, c'est a dire 4, 8,
5211*/
5212/* 12, 16, 20, 24, 28, 32, 36 et 40. */
5213/* Si K n'est pas bon, le degre est pris a 40 directement.
5214*/
5215/* XD : Borne inferieure de l'intervalle d'integration. */
5216/* XF : Borne superieure de l'intervalle d'integration. */
5217/* SAUX1 : Tableau auxiliaire */
5218/* SAUX2 : Tableau auxiliaire */
5219
5220/* ARGUMENTS DE SORTIE : */
5221/* ------------------- */
5222
5223/* SOMME : Valeur de l'integrale */
5224/* NITER : Nombre d'iterations effectues. */
5225/* Il est egal au degre du polynome. */
5226
5227/* IER : Code d'erreur : */
5228/* < 0 ==> Attention - Warning */
5229/* = 0 ==> Tout est OK */
5230/* > 0 ==> Erreur severe - Faire un traitement special */
5231/* ==> Erreur dans le calcul de BFUNX (code de retour */
5232/* de cette routine */
5233
5234/* Si erreur => SOMME = 0 */
5235
5236/* COMMONS UTILISES : */
5237/* ----------------- */
5238
5239
5240
5241/* REFERENCES APPELEES : */
5242/* ---------------------- */
5243
5244/* Type Name */
5245/* @ BFUNX MVGAUS0 */
5246
5247/* DESCRIPTION/REMARQUES/LIMITATIONS : */
5248/* --------------------------------- */
5249
5250/* Voir les explications detaillees sur le listing */
5251
5252/* Utilisation de la methode de GAUSS (polynomes orthogonaux) */
5253/* On utilise la symetrie des racines de ces polynomes */
5254
5255/* En fonction de K, le degre du polynome d'interpolation augmente.
5256*/
5257/* Si vous voulez calculer l'integrale avec une precision donnee, */
5258/* boucler sur k variant de 1 a 10 et tester la difference de 2 iteres
5259*/
5260/* consecutifs. Arreter la boucle si cette difference est inferieure
5261*/
5262/* a une valeur epsilon fixee a 10E-6 par exemple. */
5263/* Si S1 et S2 sont 2 iteres successifs, tester suivant cet exemple :
5264 */
5265
5266/* AF=DABS(S1-S2) */
5267/* AS=DABS(S2) */
5268/* Si AS < 1 alors tester si FS < eps sinon tester AF/AS < eps
5269*/
5270/* -- ----- ----- */
5271
5272/* $ HISTORIQUE DES MODIFICATIONS : */
5273/* ---------------------------- */
5274/* 3-09-1993 : PMN; CREATION D'APRES VGAUS1 (SAUX1 et SAUX2 en */
5275/* arguments) */
5276/* . 04-10-89 : JP;AJOUT EXTERNAL BFUNX SGI_420_144 */
5277/* . 20-08-87 : JP;INTEGRATION D'UNE FONCTION VECTORIELLE */
5278/* . 08-08-87 : GD; Version originale */
5279
5280/* > */
5281/************************************************************************
5282******/
5283/* DECLARATIONS */
5284/************************************************************************
5285******/
5286
5287
5288
5289/* ****** Initialisation generale ** */
5290
5291 /* Parameter adjustments */
5292 --somme;
5293 --saux2;
5294 --saux1;
5295
5296 /* Function Body */
5297 AdvApp2Var_SysBase::mvriraz_((integer *)ndimf,
5298 (char *)&somme[1]);
5299 *iercod = 0;
5300
5301/* ****** Chargement des coefficients U et H ** */
5302/* -------------------------------------------- */
5303
5304 mvgaus0_(k, u, h__, &ndeg, iercod);
5305 if (*iercod > 0) {
5306 goto L9999;
5307 }
5308
5309/* ****** C1X => Point milieu intervalle [XD,XF] */
5310/* ****** C2X => 1/2 amplitude intervalle [XD,XF] */
5311
5312 c1x = (*xf + *xd) * .5;
5313 c2x = (*xf - *xd) * .5;
5314
5315/* ---------------------------------------- */
5316/* ****** Integration pour un degre NDEG ** */
5317/* ---------------------------------------- */
5318
5319 i__1 = ndeg;
5320 for (j = 1; j <= i__1; ++j) {
5321 t = c2x * u[j - 1];
5322
5323 x = c1x + t;
5324 (*bfunx)(ndimf, &x, &saux1[1], iercod);
5325 if (*iercod != 0) {
5326 goto L9999;
5327 }
5328
5329 x = c1x - t;
5330 (*bfunx)(ndimf, &x, &saux2[1], iercod);
5331 if (*iercod != 0) {
5332 goto L9999;
5333 }
5334
5335 i__2 = *ndimf;
5336 for (idimf = 1; idimf <= i__2; ++idimf) {
5337 somme[idimf] += h__[j - 1] * (saux1[idimf] + saux2[idimf]);
5338 }
5339
5340 }
5341
5342 *niter = ndeg << 1;
5343 i__1 = *ndimf;
5344 for (idimf = 1; idimf <= i__1; ++idimf) {
5345 somme[idimf] *= c2x;
5346 }
5347
5348/* ****** Fin du sous-programme ** */
5349
5350L9999:
5351
5352 return 0 ;
5353} /* mmgaus1_ */
5354//=======================================================================
5355//function : mmherm0_
5356//purpose :
5357//=======================================================================
5358int mmherm0_(doublereal *debfin,
5359 integer *iercod)
5360{
5361 static integer c__576 = 576;
5362 static integer c__6 = 6;
5363
5364
5365 /* System generated locals */
5366 integer i__1, i__2;
5367 doublereal d__1;
5368
5369 /* Local variables */
5370 static doublereal amat[36] /* was [6][6] */;
5371 static integer iord[2];
5372 static doublereal prod;
5373 static integer iord1, iord2;
5374 static doublereal miden[36] /* was [6][6] */;
5375 static integer ncmat;
5376 static doublereal epspi, d1, d2;
5377 static integer ii, jj, pp, ncf;
5378 static doublereal cof[6];
5379 static integer iof[2], ier;
5380 static doublereal mat[36] /* was [6][6] */;
5381 static integer cot;
5382 static doublereal abid[72] /* was [12][6] */;
5383/* ***********************************************************************
5384 */
5385
5386/* FONCTION : */
5387/* ---------- */
5388/* INIT DES COEFFS. DES POLYNOMES D'INTERPOL. D'HERMITE */
5389
5390/* MOTS CLES : */
5391/* ----------- */
5392/* MATH_ACCES :: HERMITE */
5393
5394/* ARGUMENTS D'ENTREE : */
5395/* -------------------- */
5396/* DEBFIN : PARAMETRES OU SONT DONNEES LES CONTRAINTES */
5397/* DEBFIN(1) : PREMIER PARAMETRE */
5398/* DEBFIN(2) : DEUXIEME PARAMETRE */
5399
5400/* ON DOIT AVOIR: */
5401/* ABS (DEBFIN(I)) < 100 */
5402/* et */
5403/* (ABS(DEBFIN(1)+ABS(DEBFIN(2))) > 1/100 */
5404/* (pour les overflows) */
5405
5406/* ABS(DEBFIN(2)-DEBFIN(1)) / (ABS(DEBFIN(1)+ABS(DEBFIN(2))) > 1/100
5407*/
5408/* (pour le conditionnement ) */
5409
5410
5411/* ARGUMENTS DE SORTIE : */
5412/* --------------------- */
5413
5414/* IERCOD : Code d'erreur : 0 : O.K. */
5415/* 1 : LES valeur de DEBFIN */
5416/* ne sont pas raisonnables */
5417/* -1 : L'init etait deja faite */
5418/* (OK mais pas de traitement) */
5419
5420/* COMMONS UTILISES : */
5421/* ------------------ */
5422
5423/* REFERENCES APPELEES : */
5424/* ---------------------- */
5425/* Type Name */
5426
5427/* DESCRIPTION/REMARQUES/LIMITATIONS : */
5428/* ----------------------------------- */
5429
5430/* Ce programme initialise les coefficients des polynomes */
5431/* d'Hermite qui sont ensuite lus par MMHERM1 */
5432
5433/* HISTORIQUE */
5434/* --------------------------------------------------------- */
5435/* 06-01-92: ALR; mise a 0 des termes de MAT non recalcules */
5436/* 23-12-91: ALR; 2 CORRECTIONS */
5437/* 12-11-91: ALR; ECRITURE VERSION ORIGINALE. */
5438/* > */
5439/* ***********************************************************************
5440 */
5441
5442
5443
5444/* **********************************************************************
5445*/
5446
5447/* FONCTION : */
5448/* ---------- */
5449/* Sert a STOCKER les coefficients des polynomes de */
5450/* l'interpolation d'Hermite */
5451
5452/* MOTS CLES : */
5453/* ----------- */
5454/* HERMITE */
5455
5456/* DEMSCRIPTION/REMARQUES/LIMITATIONS : */
5457/* ----------------------------------- */
5458
5459/* les coefficients des polynomes d'hermitesont calcules par */
5460/* la routine MMHERM0 et lus par la routine MMHERM1 */
5461
5462/* $ HISTORIQUE DES MODIFICATIONS : */
5463/* ------------------------------ */
5464/* 23-11-91: ALR; MODIF DIMENSIONNEMENT */
5465/* 12-11-91: ALR; CREATION */
5466/* > */
5467/* **********************************************************************
5468*/
5469
5470
5471
5472
5473
5474/* NBCOEF est la taille de CMHERM (voir plus bas) */
5475
5476
5477
5478/* ***********************************************************************
5479 */
5480
5481
5482
5483
5484
5485
5486
5487/* ***********************************************************************
5488 */
5489/* Verification des donnees */
5490/* ***********************************************************************
5491 */
5492
5493
5494 /* Parameter adjustments */
5495 --debfin;
5496
5497 /* Function Body */
5498 d1 = abs(debfin[1]);
5499 if (d1 > (float)100.) {
5500 goto L9101;
5501 }
5502
5503 d2 = abs(debfin[2]);
5504 if (d2 > (float)100.) {
5505 goto L9101;
5506 }
5507
5508 d2 = d1 + d2;
5509 if (d2 < (float).01) {
5510 goto L9101;
5511 }
5512
5513 d1 = (d__1 = debfin[2] - debfin[1], abs(d__1));
5514 if (d1 / d2 < (float).01) {
5515 goto L9101;
5516 }
5517
5518
5519/* ***********************************************************************
5520 */
5521/* Initialisations */
5522/* ***********************************************************************
5523 */
5524
5525 *iercod = 0;
5526
5527 epspi = 1e-10;
5528
5529
5530/* ***********************************************************************
5531 */
5532
5533/* EST-CE DEJA INITIALISE ? */
5534
5535 d1 = abs(debfin[1]) + abs(debfin[2]);
5536 d1 *= 16111959;
5537
5538 if (debfin[1] != mmcmher_.tdebut) {
5539 goto L100;
5540 }
5541 if (debfin[2] != mmcmher_.tfinal) {
5542 goto L100;
5543 }
5544 if (d1 != mmcmher_.verifi) {
5545 goto L100;
5546 }
5547
5548
5549 goto L9001;
5550
5551
5552/* ***********************************************************************
5553 */
5554/* CALCUL */
5555/* ***********************************************************************
5556 */
5557
5558
5559L100:
5560
5561/* Init. matrice identite: */
5562
5563 ncmat = 36;
5564 AdvApp2Var_SysBase::mvriraz_((integer *)&ncmat,
5565 (char *)miden);
5566
5567 for (ii = 1; ii <= 6; ++ii) {
5568 miden[ii + ii * 6 - 7] = 1.;
5569/* L110: */
5570 }
5571
5572
5573
5574/* Init a 0 du tableau CMHERM */
5575
5576 AdvApp2Var_SysBase::mvriraz_((integer *)&c__576, (char *)mmcmher_.cmherm);
5577
5578/* Calcul par resolution de systemes lineaires */
5579
5580 for (iord1 = -1; iord1 <= 2; ++iord1) {
5581 for (iord2 = -1; iord2 <= 2; ++iord2) {
5582
5583 iord[0] = iord1;
5584 iord[1] = iord2;
5585
5586
5587 iof[0] = 0;
5588 iof[1] = iord[0] + 1;
5589
5590
5591 ncf = iord[0] + iord[1] + 2;
5592
5593/* Calcul matrice MAT a inverser: */
5594
5595 for (cot = 1; cot <= 2; ++cot) {
5596
5597
5598 if (iord[cot - 1] > -1) {
5599 prod = 1.;
5600 i__1 = ncf;
5601 for (jj = 1; jj <= i__1; ++jj) {
5602 cof[jj - 1] = 1.;
5603/* L200: */
5604 }
5605 }
5606
5607 i__1 = iord[cot - 1] + 1;
5608 for (pp = 1; pp <= i__1; ++pp) {
5609
5610 ii = pp + iof[cot - 1];
5611
5612 prod = 1.;
5613
5614 i__2 = pp - 1;
5615 for (jj = 1; jj <= i__2; ++jj) {
5616 mat[ii + jj * 6 - 7] = (float)0.;
5617/* L300: */
5618 }
5619
5620 i__2 = ncf;
5621 for (jj = pp; jj <= i__2; ++jj) {
5622
5623/* tout se passe dans ces 3 lignes peu lisibles
5624 */
5625
5626 mat[ii + jj * 6 - 7] = cof[jj - 1] * prod;
5627 cof[jj - 1] *= jj - pp;
5628 prod *= debfin[cot];
5629
5630/* L400: */
5631 }
5632/* L500: */
5633 }
5634
5635/* L1000: */
5636 }
5637
5638/* Inversion */
5639
5640 if (ncf >= 1) {
5641 AdvApp2Var_MathBase::mmmrslwd_(&c__6, &ncf, &ncf, mat, miden, &epspi, abid, amat, &
5642 ier);
5643 if (ier > 0) {
5644 goto L9101;
5645 }
5646 }
5647
5648 for (cot = 1; cot <= 2; ++cot) {
5649 i__1 = iord[cot - 1] + 1;
5650 for (pp = 1; pp <= i__1; ++pp) {
5651 i__2 = ncf;
5652 for (ii = 1; ii <= i__2; ++ii) {
5653 mmcmher_.cmherm[ii + (pp + (cot + ((iord1 + (iord2 <<
5654 2)) << 1)) * 3) * 6 + 155] = amat[ii + (pp +
5655 iof[cot - 1]) * 6 - 7];
5656/* L1300: */
5657 }
5658/* L1400: */
5659 }
5660/* L1500: */
5661 }
5662
5663/* L2000: */
5664 }
5665/* L2010: */
5666 }
5667
5668/* ***********************************************************************
5669 */
5670
5671/* On positionne le flag initialise: */
5672
5673 mmcmher_.tdebut = debfin[1];
5674 mmcmher_.tfinal = debfin[2];
5675
5676 d1 = abs(debfin[1]) + abs(debfin[2]);
5677 mmcmher_.verifi = d1 * 16111959;
5678
5679
5680/* ***********************************************************************
5681 */
5682
5683 goto L9999;
5684
5685/* ***********************************************************************
5686 */
5687
5688L9101:
5689 *iercod = 1;
5690 goto L9999;
5691
5692L9001:
5693 *iercod = -1;
5694 goto L9999;
5695
5696/* ***********************************************************************
5697 */
5698
5699L9999:
5700
5701 AdvApp2Var_SysBase::maermsg_("MMHERM0", iercod, 7L);
5702
5703/* ***********************************************************************
5704 */
5705 return 0 ;
5706} /* mmherm0_ */
5707
5708//=======================================================================
5709//function : mmherm1_
5710//purpose :
5711//=======================================================================
5712int mmherm1_(doublereal *debfin,
5713 integer *ordrmx,
5714 integer *iordre,
5715 doublereal *hermit,
5716 integer *iercod)
5717{
5718 /* System generated locals */
5719 integer hermit_dim1, hermit_dim2, hermit_offset;
5720
5721 /* Local variables */
5722 static integer nbval;
5723 static doublereal d1;
5724 static integer cot;
5725
5726/* ***********************************************************************
5727 */
5728
5729/* FONCTION : */
5730/* ---------- */
5731/* lecture des coeffs. des polynomes d'interpol. d'HERMITE */
5732
5733/* MOTS CLES : */
5734/* ----------- */
5735/* MATH_ACCES :: HERMITE */
5736
5737/* ARGUMENTS D'ENTREE : */
5738/* -------------------- */
5739/* DEBFIN : PARAMETRES OU SONT DONNEES LES CONTRAINTES */
5740/* DEBFIN(1) : PREMIER PARAMETRE */
5741/* DEBFIN(2) : DEUXIEME PARAMETRE */
5742
5743/* Doivent etre egaux aux argeuments correspondant lors */
5744/* du dernier appel a MMHERM0 pour l'init. des coeffs. */
5745
5746/* ORDRMX : sert a indiquer le dimensionnent de HERMIT: */
5747/* on n'a pas le choix : ORDRMX doit etre egal a la valeur */
5748/* du PARAMETER IORDMX de l'INCLUDE MMCMHER, soit 2 pour */
5749/* l'instant. */
5750
5751/* IORDRE (2) : Ordres de contraintes en chaque parametre DEBFIN(I)
5752*/
5753/* corrspondant. doivent etre compris entre -1 (pas de */
5754/* contrainte) et ORDRMX. */
5755
5756
5757/* ARGUMENTS DE SORTIE : */
5758/* --------------------- */
5759
5760/* HERMIT : HERMIT(1:IORDRE(1)+IORDRE(2)+2, j, cote) sont les */
5761/* coefficients dans la base canonique du polynome d'Hermite */
5762/* correspondant aux ordres IORDRE aux paramtres DEBFIN pour */
5763/* la contrainte d'ordre j en DEBFIN(cote). j est compris entre */
5764/* 0 et IORDRE(cote). */
5765
5766
5767/* IERCOD : Code d'erreur : */
5768/* -1: O.K mais on a du reinitialise les coefficients */
5769/* (info pour optimisation) */
5770/* 0 : O.K. */
5771/* 1 : Erreur dans MMHERM0 */
5772/* 2 : arguments invalides */
5773
5774/* COMMONS UTILISES : */
5775/* ------------------ */
5776
5777/* REFERENCES APPELEES : */
5778/* ---------------------- */
5779/* Type Name */
5780
5781/* DESCRIPTION/REMARQUES/LIMITATIONS : */
5782/* ----------------------------------- */
5783
5784/* Ce programme lit les coefficients des polynomes */
5785/* d'Hermite qui ont ete au prealable initialise par MMHERM0 */
5786
5787/* PMN : L'initialisation n'est plus a la charge de l'appelant. */
5788
5789/* HISTORIQUE */
5790/* --------------------------------------------------------- */
5791/* 14-01-94: PMN; On appelle MMHERM0 si pas initialise. */
5792/* 12-11-91: ALR; ECRITURE VERSION ORIGINALE. */
5793/* > */
5794/* ***********************************************************************
5795 */
5796
5797
5798
5799/* **********************************************************************
5800*/
5801
5802/* FONCTION : */
5803/* ---------- */
5804/* Sert a STOCKER les coefficients des polynomes de */
5805/* l'interpolation d'Hermite */
5806
5807/* MOTS CLES : */
5808/* ----------- */
5809/* HERMITE */
5810
5811/* DEMSCRIPTION/REMARQUES/LIMITATIONS : */
5812/* ----------------------------------- */
5813
5814/* les coefficients des polynomes d'hermitesont calcules par */
5815/* la routine MMHERM0 et lus par la routine MMHERM1 */
5816
5817/* $ HISTORIQUE DES MODIFICATIONS : */
5818/* ------------------------------ */
5819/* 23-11-91: ALR; MODIF DIMENSIONNEMENT */
5820/* 12-11-91: ALR; CREATION */
5821/* > */
5822/* **********************************************************************
5823*/
5824
5825
5826
5827
5828
5829/* NBCOEF est la taille de CMHERM (voir plus bas) */
5830
5831
5832
5833/* ***********************************************************************
5834 */
5835
5836
5837
5838
5839
5840/* ***********************************************************************
5841 */
5842/* Initialisations */
5843/* ***********************************************************************
5844 */
5845
5846 /* Parameter adjustments */
5847 --debfin;
5848 hermit_dim1 = (*ordrmx << 1) + 2;
5849 hermit_dim2 = *ordrmx + 1;
5850 hermit_offset = hermit_dim1 * hermit_dim2 + 1;
5851 hermit -= hermit_offset;
5852 --iordre;
5853
5854 /* Function Body */
5855 *iercod = 0;
5856
5857
5858/* ***********************************************************************
5859 */
5860/* Verification des donnees */
5861/* ***********************************************************************
5862 */
5863
5864
5865 if (*ordrmx != 2) {
5866 goto L9102;
5867 }
5868
5869 for (cot = 1; cot <= 2; ++cot) {
5870 if (iordre[cot] < -1) {
5871 goto L9102;
5872 }
5873 if (iordre[cot] > *ordrmx) {
5874 goto L9102;
5875 }
5876/* L100: */
5877 }
5878
5879
5880/* EST-CE BIEN INITIALISE ? */
5881
5882 d1 = abs(debfin[1]) + abs(debfin[2]);
5883 d1 *= 16111959;
5884
5885/* SINON ON INITIALISE */
5886
5887 if (debfin[1] != mmcmher_.tdebut || debfin[2] != mmcmher_.tfinal || d1
5888 != mmcmher_.verifi) {
5889 *iercod = -1;
5890 mmherm0_(&debfin[1], iercod);
5891 if (*iercod > 0) {
5892 goto L9101;
5893 }
5894 }
5895
5896
5897/* ***********************************************************************
5898 */
5899/* LECTURE */
5900/* ***********************************************************************
5901 */
5902
5903 nbval = 36;
5904
5905 AdvApp2Var_SysBase::msrfill_(&nbval, &mmcmher_.cmherm[((((iordre[1] + (iordre[2] << 2)) << 1)
5906 + 1) * 3 + 1) * 6 + 156], &hermit[hermit_offset]);
5907
5908/* ***********************************************************************
5909 */
5910
5911 goto L9999;
5912
5913/* ***********************************************************************
5914 */
5915
5916L9101:
5917 *iercod = 1;
5918 goto L9999;
5919
5920L9102:
5921 *iercod = 2;
5922 goto L9999;
5923
5924/* ***********************************************************************
5925 */
5926
5927L9999:
5928
5929 AdvApp2Var_SysBase::maermsg_("MMHERM1", iercod, 7L);
5930
5931/* ***********************************************************************
5932 */
5933 return 0 ;
5934} /* mmherm1_ */
5935
5936//=======================================================================
5937//function : AdvApp2Var_MathBase::mmhjcan_
5938//purpose :
5939//=======================================================================
5940int AdvApp2Var_MathBase::mmhjcan_(integer *ndimen,
5941 integer *ncourb,
5942 integer *ncftab,
5943 integer *orcont,
5944 integer *ncflim,
5945 doublereal *tcbold,
5946 doublereal *tdecop,
5947 doublereal *tcbnew,
5948 integer *iercod)
5949
5950{
5951 static integer c__2 = 2;
5952 static integer c__21 = 21;
5953 /* System generated locals */
5954 integer tcbold_dim1, tcbold_dim2, tcbold_offset, tcbnew_dim1, tcbnew_dim2,
5955 tcbnew_offset, i__1, i__2, i__3, i__4, i__5;
5956
5957
5958 /* Local variables */
5959 static logical ldbg;
5960 static integer ndeg;
5961 static doublereal taux1[21];
5962 static integer d__, e, i__, k;
5963 static doublereal mfact;
5964 static integer ncoeff;
5965 static doublereal tjacap[21];
5966 static integer iordre[2];
5967 static doublereal hermit[36]/* was [6][3][2] */, ctenor, bornes[2];
5968 static integer ier;
5969 static integer aux1, aux2;
5970
5971/* ***********************************************************************
5972 */
5973
5974/* FONCTION : */
5975/* ---------- */
5976/* CONVERSION LA TABLE TCBOLD DES COEFFICIENTS DES COURBES */
5977/* POLYNOMIALES EXPRIMEES DANS LA BASE HERMITE JACOBI, EN UNE */
5978/* TABLE DE COEFFICIENTS TCBNEW DES COURBES EXPRIMEES DANS LA */
5979/* BASE CANONIQUE */
5980
5981/* MOTS CLES : */
5982/* ----------- */
5983/* CANNONIQUE, HERMITE, JACCOBI */
5984
5985/* ARGUMENTS D'ENTREE : */
5986/* -------------------- */
5987/* ORDHER : ORDRE DES POLYNOMES D'HERMITE OU ORDRE DE CONTINUITE */
5988/* NCOEFS : NOMBRE DE COEFFICIENTS DE UNE LA COURBE POLYNOMIALE */
5989/* POUR UNE DE SES NDIM COMPOSANTS;(DEGRE+1 DE LA COURBE)
5990*/
5991/* NDIM : DIMENSION DE LA COURBE */
5992/* CBHEJA : TABLE DE COEFFICIENTS DE LA COURBE DANS LA BASE */
5993/* HERMITE JACOBI */
5994/* (H(0,-1),..,H(ORDHER,-1),H(0,1),..,H(ORDHER,1), */
5995/* JA(ORDHER+1,2*ORDHER+2),....,JA(ORDHER+1,NCOEFS-1) */
5996
5997/* ARGUMENTS DE SORTIE : */
5998/* --------------------- */
5999/* CBRCAN : TABLE DE COEFFICIENTS DE LA COURBE DANS LA BASE */
6000/* CANONIQUE */
6001/* (1, t, ...) */
6002
6003/* COMMONS UTILISES : */
6004/* ------------------ */
6005
6006
6007/* REFERENCES APPELEES : */
6008/* --------------------- */
6009
6010
6011/* DESCRIPTION/REMARQUES/LIMITATIONS : */
6012/* ----------------------------------- */
6013
6014
6015/* $ HISTORIQUE DES MODIFICATIONS : */
6016/* ------------------------------ */
6017/* 8-09-95 : KHN/PMN; ECRITURE VERSION ORIGINALE. */
6018/* > */
6019/* ***********************************************************************
6020 */
6021/* DECLARATIONS */
6022/* ***********************************************************************
6023 */
6024
6025
6026/* ***********************************************************************
6027 */
6028
6029/* FONCTION : */
6030/* ---------- */
6031/* Sert a fournir les constantes entieres de 0 a 1000 */
6032
6033/* MOTS CLES : */
6034/* ----------- */
6035/* TOUS,ENTIERS */
6036
6037/* DEMSCRIPTION/REMARQUES/LIMITATIONS : */
6038/* ----------------------------------- */
6039
6040/* $ HISTORIQUE DES MODIFICATIONS : */
6041/* ------------------------------ */
6042/* 11-10-89 : DH ; Creation version originale */
6043/* > */
6044/* ***********************************************************************
6045 */
6046
6047
6048/* ***********************************************************************
6049 */
6050
6051
6052
6053
6054/* ***********************************************************************
6055 */
6056/* INITIALISATIONS */
6057/* ***********************************************************************
6058 */
6059
6060 /* Parameter adjustments */
6061 --ncftab;
6062 tcbnew_dim1 = *ndimen;
6063 tcbnew_dim2 = *ncflim;
6064 tcbnew_offset = tcbnew_dim1 * (tcbnew_dim2 + 1) + 1;
6065 tcbnew -= tcbnew_offset;
6066 tcbold_dim1 = *ndimen;
6067 tcbold_dim2 = *ncflim;
6068 tcbold_offset = tcbold_dim1 * (tcbold_dim2 + 1) + 1;
6069 tcbold -= tcbold_offset;
6070
6071 /* Function Body */
6072 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 2;
6073 if (ldbg) {
6074 AdvApp2Var_SysBase::mgenmsg_("MMHJCAN", 7L);
6075 }
6076 *iercod = 0;
6077
6078 bornes[0] = -1.;
6079 bornes[1] = 1.;
6080
6081/* ***********************************************************************
6082 */
6083/* TRAITEMENT */
6084/* ***********************************************************************
6085 */
6086
6087 if (*orcont > 2) {
6088 goto L9101;
6089 }
6090 if (*ncflim > 21) {
6091 goto L9101;
6092 }
6093
6094/* CALCUL DES POLYNOMES D'HERMITE DANS LA BASE CANONIQUE SUR (-1,1) */
6095
6096
6097 iordre[0] = *orcont;
6098 iordre[1] = *orcont;
6099 mmherm1_(bornes, &c__2, iordre, hermit, &ier);
6100 if (ier > 0) {
6101 goto L9102;
6102 }
6103
6104
6105 aux1 = *orcont + 1;
6106 aux2 = aux1 << 1;
6107
6108 i__1 = *ncourb;
6109 for (e = 1; e <= i__1; ++e) {
6110
6111 ctenor = (tdecop[e] - tdecop[e - 1]) / 2;
6112 ncoeff = ncftab[e];
6113 ndeg = ncoeff - 1;
6114 if (ncoeff > 21) {
6115 goto L9101;
6116 }
6117
6118 i__2 = *ndimen;
6119 for (d__ = 1; d__ <= i__2; ++d__) {
6120
6121/* CONVERSION DES COEFFICIENTS DE LA PARTIE DE LA COURBE EXPRI
6122MEE */
6123/* DANS LA BASE HERMITE, DANS LA BASE CANONIQUE */
6124
6125 AdvApp2Var_SysBase::mvriraz_((integer *)&ncoeff, (char *)taux1);
6126
6127 i__3 = aux2;
6128 for (k = 1; k <= i__3; ++k) {
6129 i__4 = aux1;
6130 for (i__ = 1; i__ <= i__4; ++i__) {
6131 i__5 = i__ - 1;
6132 mfact = AdvApp2Var_MathBase::pow__di(&ctenor, &i__5);
6133 taux1[k - 1] += (tcbold[d__ + (i__ + e * tcbold_dim2) *
6134 tcbold_dim1] * hermit[k + (i__ + 2) * 6 - 19] +
6135 tcbold[d__ + (i__ + aux1 + e * tcbold_dim2) *
6136 tcbold_dim1] * hermit[k + (i__ + 5) * 6 - 19]) *
6137 mfact;
6138 }
6139 }
6140
6141
6142 i__3 = ncoeff;
6143 for (i__ = aux2 + 1; i__ <= i__3; ++i__) {
6144 taux1[i__ - 1] = tcbold[d__ + (i__ + e * tcbold_dim2) *
6145 tcbold_dim1];
6146 }
6147
6148/* CONVERSION DES COEFFICIENTS DE LA PARTIE DE LA COURBE EXPRI
6149MEE */
6150/* DANS LA BASE CANONIQUE-JACOBI , DANS LA BASE CANONIQUE */
6151
6152
6153 AdvApp2Var_MathBase::mmapcmp_(&minombr_.nbr[1], &c__21, &ncoeff, taux1, tjacap);
6154 AdvApp2Var_MathBase::mmjacan_(orcont, &ndeg, tjacap, taux1);
6155
6156/* RECOPIE DES COEFS RESULTANT DE LA CONVERSION DANS LA TA
6157BLE */
6158/* DES RESULTAT */
6159
6160 i__3 = ncoeff;
6161 for (i__ = 1; i__ <= i__3; ++i__) {
6162 tcbnew[d__ + (i__ + e * tcbnew_dim2) * tcbnew_dim1] = taux1[
6163 i__ - 1];
6164 }
6165
6166 }
6167 }
6168
6169 goto L9999;
6170
6171/* ***********************************************************************
6172 */
6173/* TRAITEMENT DES ERREURS */
6174/* ***********************************************************************
6175 */
6176
6177L9101:
6178 *iercod = 1;
6179 goto L9999;
6180L9102:
6181 *iercod = 2;
6182 goto L9999;
6183
6184/* ***********************************************************************
6185 */
6186/* RETOUR PROGRAMME APPELANT */
6187/* ***********************************************************************
6188 */
6189
6190L9999:
6191
6192 AdvApp2Var_SysBase::maermsg_("MMHJCAN", iercod, 7L);
6193 if (ldbg) {
6194 AdvApp2Var_SysBase::mgsomsg_("MMHJCAN", 7L);
6195 }
6196 return 0 ;
6197} /* mmhjcan_ */
6198
6199//=======================================================================
6200//function : AdvApp2Var_MathBase::mminltt_
6201//purpose :
6202//=======================================================================
6203 int AdvApp2Var_MathBase::mminltt_(integer *ncolmx,
6204 integer *nlgnmx,
6205 doublereal *tabtri,
6206 integer *nbrcol,
6207 integer *nbrlgn,
6208 doublereal *ajoute,
6209 doublereal *,//epseg,
6210 integer *iercod)
6211{
6212 /* System generated locals */
6213 integer tabtri_dim1, tabtri_offset, i__1, i__2;
6214
6215 /* Local variables */
6216 static logical idbg;
6217 static integer icol, ilgn, nlgn, noct, inser;
6218 static doublereal epsega;
6219 static integer ibb;
6220
6221/* ***********************************************************************
6222 */
6223
6224/* FONCTION : */
6225/* ---------- */
6226/* . Insertion d'une ligne dans une table triee sans redondance */
6227
6228/* MOTS CLES : */
6229/* ----------- */
6230/* TOUS,MATH_ACCES :: TABLEAU&,INSERTION,&TABLEAU */
6231
6232/* ARGUMENTS D'ENTREE : */
6233/* -------------------- */
6234/* . NCOLMX : Nombre de colonnes du tableau */
6235/* . NLGNMX : Nombre de lignes du tableau */
6236/* . TABTRI : Tableau trie par lignes sans redondances */
6237/* . NBRCOL : Nombre de colonnes utilisees */
6238/* . NBRLGN : Nombre de lignes utilisees */
6239/* . AJOUTE : Ligne a ajouter */
6240/* . EPSEGA : Epsilon pour le test de redondance */
6241
6242/* ARGUMENTS DE SORTIE : */
6243/* --------------------- */
6244/* . TABTRI : Tableau trie par lignes sans redondances */
6245/* . NBRLGN : Nombre de lignes utilisees */
6246/* . IERCOD : 0 -> Pas de probleme */
6247/* 1 -> La table est pleine */
6248
6249/* COMMONS UTILISES : */
6250/* ------------------ */
6251
6252/* REFERENCES APPELEES : */
6253/* --------------------- */
6254
6255/* DESCRIPTION/REMARQUES/LIMITATIONS : */
6256/* ----------------------------------- */
6257/* . On n'insere la ligne que si il n'y a pas de ligne tq tous ses
6258*/
6259/* elements soient egaux a ceux qu'on veut inserer a epsilon pres. */
6260
6261/* . Niveau de debug = 3 */
6262
6263/* $ HISTORIQUE DES MODIFICATIONS : */
6264/* ------------------------------ */
6265/* . 24-06-91 : RBD; Suppression des accents (Pb. Bull). */
6266/* . 01-10-89 : VV ; Version originale */
6267/* > */
6268/* ***********************************************************************
6269 */
6270/* DECLARATIONS , CONTROLE DES ARGUMENTS D'ENTREE , INITIALISATION */
6271/* ***********************************************************************
6272 */
6273
6274/* --- Parametres */
6275
6276
6277/* --- Fonctions */
6278
6279
6280/* --- Variables locales */
6281
6282
6283/* --- Messagerie */
6284
6285 /* Parameter adjustments */
6286 tabtri_dim1 = *ncolmx;
6287 tabtri_offset = tabtri_dim1 + 1;
6288 tabtri -= tabtri_offset;
6289 --ajoute;
6290
6291 /* Function Body */
6292 ibb = AdvApp2Var_SysBase::mnfndeb_();
6293 idbg = ibb >= 3;
6294 if (idbg) {
6295 AdvApp2Var_SysBase::mgenmsg_("MMINLTT", 7L);
6296 }
6297
6298/* --- Controle arguments */
6299
6300 if (*nbrlgn >= *nlgnmx) {
6301 goto L9001;
6302 }
6303
6304/* -------------------- */
6305/* *** INITIALISATIONS */
6306/* -------------------- */
6307
6308 *iercod = 0;
6309
6310/* ---------------------------- */
6311/* *** RECHERCHE DE REDONDANCE */
6312/* ---------------------------- */
6313
6314 i__1 = *nbrlgn;
6315 for (ilgn = 1; ilgn <= i__1; ++ilgn) {
6316 if (tabtri[ilgn * tabtri_dim1 + 1] >= ajoute[1] - epsega) {
6317 if (tabtri[ilgn * tabtri_dim1 + 1] <= ajoute[1] + epsega) {
6318 i__2 = *nbrcol;
6319 for (icol = 1; icol <= i__2; ++icol) {
6320 if (tabtri[icol + ilgn * tabtri_dim1] < ajoute[icol] -
6321 epsega || tabtri[icol + ilgn * tabtri_dim1] >
6322 ajoute[icol] + epsega) {
6323 goto L20;
6324 }
6325/* L10: */
6326 }
6327 goto L9999;
6328 } else {
6329 goto L30;
6330 }
6331 }
6332L20:
6333 ;
6334 }
6335
6336/* ----------------------------------- */
6337/* *** RECHERCHE DU POINT D'INSERTION */
6338/* ----------------------------------- */
6339
6340L30:
6341
6342 i__1 = *nbrlgn;
6343 for (ilgn = 1; ilgn <= i__1; ++ilgn) {
6344 i__2 = *nbrcol;
6345 for (icol = 1; icol <= i__2; ++icol) {
6346 if (tabtri[icol + ilgn * tabtri_dim1] < ajoute[icol]) {
6347 goto L50;
6348 }
6349 if (tabtri[icol + ilgn * tabtri_dim1] > ajoute[icol]) {
6350 goto L70;
6351 }
6352/* L60: */
6353 }
6354L50:
6355 ;
6356 }
6357
6358 ilgn = *nbrlgn + 1;
6359
6360/* -------------- */
6361/* *** INSERTION */
6362/* -------------- */
6363
6364L70:
6365
6366 inser = ilgn;
6367 ++(*nbrlgn);
6368
6369/* --- Decalage vers le bas */
6370
6371 nlgn = *nbrlgn - inser;
6372 if (nlgn > 0) {
6373 noct = (*ncolmx << 3) * nlgn;
6374 AdvApp2Var_SysBase::mcrfill_((integer *)&noct,
6375 (char *)&tabtri[inser * tabtri_dim1 + 1],
6376 (char *)&tabtri[(inser + 1)* tabtri_dim1 + 1]);
6377 }
6378
6379/* --- Copie de la ligne */
6380
6381 noct = *nbrcol << 3;
6382 AdvApp2Var_SysBase::mcrfill_((integer *)&noct,
6383 (char *)&ajoute[1],
6384 (char *)&tabtri[inser * tabtri_dim1 + 1]);
6385
6386 goto L9999;
6387
6388/* ******************************************************************** */
6389/* SORTIE ERREUR , RETOUR PROGRAMME APPELANT , MESSAGERIE */
6390/* ******************************************************************** */
6391
6392/* --- La table est deja pleine */
6393
6394L9001:
6395 *iercod = 1;
6396
6397/* --- Fin */
6398
6399L9999:
6400 if (*iercod != 0) {
6401 AdvApp2Var_SysBase::maermsg_("MMINLTT", iercod, 7L);
6402 }
6403 if (idbg) {
6404 AdvApp2Var_SysBase::mgsomsg_("MMINLTT", 7L);
6405 }
6406 return 0 ;
6407} /* mminltt_ */
6408
6409//=======================================================================
6410//function : AdvApp2Var_MathBase::mmjacan_
6411//purpose :
6412//=======================================================================
6413 int AdvApp2Var_MathBase::mmjacan_(integer *ideriv,
6414 integer *ndeg,
6415 doublereal *poljac,
6416 doublereal *polcan)
6417{
6418 /* System generated locals */
6419 integer poljac_dim1, i__1, i__2;
6420
6421 /* Local variables */
6422 static integer iptt, i__, j, ibb;
6423 static doublereal bid;
6424
6425/* ***********************************************************************
6426 */
6427
6428/* FONCTION : */
6429/* ---------- */
6430/* Routine de transfert de Jacobi normalise a canonique [-1,1], les */
6431/* tableaux etant ranges en termes de degre pair puis impair. */
6432
6433/* MOTS CLES : */
6434/* ----------- */
6435/* LEGENDRE,JACOBI,PASSAGE. */
6436
6437/* ARGUMENTS D'ENTREE : */
6438/* ------------------ */
6439/* IDERIV : Ordre de Jacobi compris entre -1 et 2. */
6440/* NDEG : Le degre vrai du polynome. */
6441/* POLJAC : Le polynome dans la base de Jacobi. */
6442
6443/* ARGUMENTS DE SORTIE : */
6444/* ------------------- */
6445/* POLCAN : La courbe exprimee dans la base canonique [-1,1]. */
6446
6447/* COMMONS UTILISES : */
6448/* ---------------- */
6449
6450/* REFERENCES APPELEES : */
6451/* ----------------------- */
6452
6453/* DESCRIPTION/REMARQUES/LIMITATIONS : */
6454/* ----------------------------------- */
6455
6456/* $ HISTORIQUE DES MODIFICATIONS : */
6457/* -------------------------------- */
6458/* 04-01-90 : NAK ; COMMON MMJCOBI PAR INCLUDE MMJCOBI */
6459/* 12-04-1989 : RBD ; Appel MGSOMSG. */
6460/* 27-04-1988 : JJM ; Test NDEG=0 */
6461/* 01-03-1988 : JJM ; Creation. */
6462
6463/* > */
6464/* ***********************************************************************
6465 */
6466
6467/* Le nom de la routine */
6468
6469/* Matrices de conversion */
6470
6471
6472/* ***********************************************************************
6473 */
6474
6475/* FONCTION : */
6476/* ---------- */
6477/* MATRICE DE TRANSFORMATION DS LA BASE DE LEGENDRE */
6478
6479/* MOTS CLES : */
6480/* ----------- */
6481/* MATH */
6482
6483/* DEMSCRIPTION/REMARQUES/LIMITATIONS : */
6484/* ----------------------------------- */
6485
6486/* $ HISTORIQUE DES MODIFICATIONS : */
6487/* ------------------------------ */
6488/* 04-01-90 : NAK ; Creation version originale */
6489/* > */
6490/* ***********************************************************************
6491 */
6492
6493
6494
6495/* Common de Legendre/Casteljau comprime. */
6496
6497/* 0:1 0 Concerne les termes pairs, 1 les termes impairs. */
6498/* CANPLG : Matrice de passage de canonique vers Jacobi avec parites */
6499/* comptees */
6500/* PLGCAN : Matrice de passage de Jacobi vers canonique avec parites */
6501/* comptees. */
6502
6503
6504
6505
6506/* ***********************************************************************
6507 */
6508
6509 /* Parameter adjustments */
6510 poljac_dim1 = *ndeg / 2 + 1;
6511
6512 /* Function Body */
6513 ibb = AdvApp2Var_SysBase::mnfndeb_();
6514 if (ibb >= 5) {
6515 AdvApp2Var_SysBase::mgenmsg_("MMJACAN", 7L);
6516 }
6517
6518/* ----------------- Expression des termes de degre pair ----------------
6519*/
6520
6521 i__1 = *ndeg / 2;
6522 for (i__ = 0; i__ <= i__1; ++i__) {
6523 bid = 0.;
6524 iptt = i__ * 31 - (i__ + 1) * i__ / 2 + 1;
6525 i__2 = *ndeg / 2;
6526 for (j = i__; j <= i__2; ++j) {
6527 bid += mmjcobi_.plgcan[iptt + j + *ideriv * 992 + 991] * poljac[
6528 j];
6529/* L310: */
6530 }
6531 polcan[i__ * 2] = bid;
6532/* L300: */
6533 }
6534
6535/* --------------- Expression des termes de degre impair ----------------
6536*/
6537
6538 if (*ndeg == 0) {
6539 goto L9999;
6540 }
6541
6542 i__1 = (*ndeg - 1) / 2;
6543 for (i__ = 0; i__ <= i__1; ++i__) {
6544 bid = 0.;
6545 iptt = i__ * 31 - (i__ + 1) * i__ / 2 + 1;
6546 i__2 = (*ndeg - 1) / 2;
6547 for (j = i__; j <= i__2; ++j) {
6548 bid += mmjcobi_.plgcan[iptt + j + ((*ideriv << 1) + 1) * 496 +
6549 991] * poljac[j + poljac_dim1];
6550/* L410: */
6551 }
6552 polcan[(i__ << 1) + 1] = bid;
6553/* L400: */
6554 }
6555
6556/* -------------------------------- The end -----------------------------
6557*/
6558
6559L9999:
6560 if (ibb >= 5) {
6561 AdvApp2Var_SysBase::mgsomsg_("MMJACAN", 7L);
6562 }
6563 return 0;
6564} /* mmjacan_ */
6565
6566//=======================================================================
6567//function : AdvApp2Var_MathBase::mmjaccv_
6568//purpose :
6569//=======================================================================
6570 int AdvApp2Var_MathBase::mmjaccv_(integer *ncoef,
6571 integer *ndim,
6572 integer *ider,
6573 doublereal *crvlgd,
6574 doublereal *polaux,
6575 doublereal *crvcan)
6576
6577{
6578 /* Initialized data */
6579
6580 static char nomprg[8+1] = "MMJACCV ";
6581
6582 /* System generated locals */
6583 integer crvlgd_dim1, crvlgd_offset, crvcan_dim1, crvcan_offset,
6584 polaux_dim1, i__1, i__2;
6585
6586 /* Local variables */
6587 static integer ndeg, i__, nd, ii, ibb;
6588
6589/* ***********************************************************************
6590 */
6591
6592/* FONCTION : */
6593/* ---------- */
6594/* Passage de la base de Jacobi normalisee a la base canonique. */
6595
6596/* MOTS CLES : */
6597/* ----------- */
6598/* LISSAGE,BASE,LEGENDRE */
6599
6600
6601/* ARGUMENTS D'ENTREE : */
6602/* ------------------ */
6603/* NDIM: Dimension de l' espace. */
6604/* NCOEF: Degre +1 du polynome. */
6605/* IDER: Ordre des polynomes de Jacobi. */
6606/* CRVLGD : La courbe dans la base de Jacobi. */
6607
6608/* ARGUMENTS DE SORTIE : */
6609/* ------------------- */
6610/* POLAUX : Espace auxilliaire. */
6611/* CRVCAN : La courbe dans la base canonique [-1,1] */
6612
6613/* COMMONS UTILISES : */
6614/* ---------------- */
6615
6616/* REFERENCES APPELEES : */
6617/* ----------------------- */
6618
6619/* DESCRIPTION/REMARQUES/LIMITATIONS : */
6620/* ----------------------------------- */
6621
6622/* $ HISTORIQUE DES MODIFICATIONS : */
6623/* -------------------------------- */
6624/* 26-04-1988 : RBD ; Cas de la courbe reduite a 1 point. */
6625/* 01-03-1988 : JJM ; Creation. */
6626
6627/* > */
6628/* *********************************************************************
6629*/
6630
6631/* Le nom de la routine */
6632 /* Parameter adjustments */
6633 polaux_dim1 = (*ncoef - 1) / 2 + 1;
6634 crvcan_dim1 = *ncoef - 1 + 1;
6635 crvcan_offset = crvcan_dim1;
6636 crvcan -= crvcan_offset;
6637 crvlgd_dim1 = *ncoef - 1 + 1;
6638 crvlgd_offset = crvlgd_dim1;
6639 crvlgd -= crvlgd_offset;
6640
6641 /* Function Body */
6642
6643 ibb = AdvApp2Var_SysBase::mnfndeb_();
6644 if (ibb >= 3) {
6645 AdvApp2Var_SysBase::mgenmsg_(nomprg, 6L);
6646 }
6647
6648 ndeg = *ncoef - 1;
6649
6650 i__1 = *ndim;
6651 for (nd = 1; nd <= i__1; ++nd) {
6652/* Chargement du tableau auxilliaire. */
6653 ii = 0;
6654 i__2 = ndeg / 2;
6655 for (i__ = 0; i__ <= i__2; ++i__) {
6656 polaux[i__] = crvlgd[ii + nd * crvlgd_dim1];
6657 ii += 2;
6658/* L310: */
6659 }
6660
6661 ii = 1;
6662 if (ndeg >= 1) {
6663 i__2 = (ndeg - 1) / 2;
6664 for (i__ = 0; i__ <= i__2; ++i__) {
6665 polaux[i__ + polaux_dim1] = crvlgd[ii + nd * crvlgd_dim1];
6666 ii += 2;
6667/* L320: */
6668 }
6669 }
6670/* Appel a la routine de changement de base. */
6671 AdvApp2Var_MathBase::mmjacan_(ider, &ndeg, polaux, &crvcan[nd * crvcan_dim1]);
6672/* L300: */
6673 }
6674
6675
6676/* L9999: */
6677 return 0;
6678} /* mmjaccv_ */
6679
6680//=======================================================================
6681//function : mmloncv_
6682//purpose :
6683//=======================================================================
6684int mmloncv_(integer *ndimax,
6685 integer *ndimen,
6686 integer *ncoeff,
6687 doublereal *courbe,
6688 doublereal *tdebut,
6689 doublereal *tfinal,
6690 doublereal *xlongc,
6691 integer *iercod)
6692
6693{
6694 /* Initialized data */
6695
6696 static integer kgar = 0;
6697
6698 /* System generated locals */
6699 integer courbe_dim1, courbe_offset, i__1, i__2;
6700
6701 /* Local variables */
6702 static doublereal tran;
6703 static integer ngaus;
6704 static doublereal c1, c2, d1, d2, wgaus[20], uroot[20], x1, x2, dd;
6705 static integer ii, jj, kk;
6706 static doublereal som;
6707 static doublereal der1, der2;
6708
6709
6710
6711
6712/* **********************************************************************
6713*/
6714
6715/* FONCTION : Longueur d'un arc de courbe sur un intervalle donne */
6716/* ---------- pour une fonction dont la representation mathematique */
6717/* est faite un polynome multidimensionnel. */
6718/* Le polynome est en fait un ensemble de polynomes dont les coeffi-
6719*/
6720/* cients sont ranges dans un tableau a 2 indices, chaque ligne */
6721/* etant relative a 1 polynome. */
6722/* Le polynome est defini par ses coefficients ordonne par les puis-
6723*/
6724/* sances croissantes de la variable. */
6725/* Tous les polynomes ont le meme nombre de coefficients (donc le */
6726/* meme degre). */
6727
6728/* MOTS CLES : LONGUEUR, COURBE */
6729/* ----------- */
6730
6731/* ARGUMENTS D'ENTREE : */
6732/* -------------------- */
6733
6734/* NDIMAX : Nombre de lignes maximum des tableaux */
6735/* (nombre maxi de polynomes). */
6736/* NDIMEN : Dimension du polynome (Nombre de polynomes). */
6737/* NCOEFF : Nombre de coefficients du polynome (pas de limitation) */
6738/* C'est le degre + 1 */
6739/* COURBE : Coefficients du polynome ordonne par les puissances */
6740/* croissantes. A dimensionner a (NDIMAX,NCOEFF). */
6741/* TDEBUT : Bornes inferieure de l'integration pour calcul de la */
6742/* longueur. */
6743/* TFINAL : Bornes superieure de l'integration pour calcul de la */
6744/* longueur. */
6745
6746/* ARGUMENTS DE SORTIE : */
6747/* --------------------- */
6748/* XLONGC : Longueur de l'arc de courbe */
6749
6750/* IERCOD : Code d'erreur : */
6751/* = 0 ==> Tout est OK */
6752/* = 1 ==> NDIMEN ou NCOEFF negatif ou nul */
6753/* = 2 ==> Pb chargement racines Legendre et poids de Gauss */
6754/* par MVGAUS0. */
6755
6756/* Si erreur => XLONGC = 0 */
6757
6758/* COMMONS UTILISES : */
6759/* ------------------ */
6760
6761/* .Neant. */
6762
6763/* REFERENCES APPELEES : */
6764/* ---------------------- */
6765/* Type Name */
6766/* MAERMSG R*8 DSQRT I*4 MIN */
6767/* MVGAUS0 */
6768
6769/* DESCRIPTION/REMARQUES/LIMITATIONS : */
6770/* ----------------------------------- */
6771
6772/* Voir VGAUSS pour bien comprendre la technique. */
6773/* On integre en verite SQRT (dpi^2) pour i=1,nbdime */
6774/* Le calcul de la derivee est mele dans le code pour ne pas faire */
6775/* un appel supplementaire a une routine. */
6776
6777/* La fonction que l'on integre est strictement croissante, il */
6778/* n'est pas necessaire d'utiliser un haut degre pour la methode */
6779/* GAUSS */
6780
6781/* Le degre du polynome de LEGENDRE est fonction du degre du */
6782/* polynome a integrer. Il peut varier de 4 a 40 (par pas de 4). */
6783
6784/* La precision (relative) de l'integration est de l'ordre */
6785/* de 1.D-8. */
6786
6787/* ATTENTION : si TDEBUT > TFINAL, la longueur est alors NEGATIVE. */
6788
6789/* Attention : la precision sur le resultat n'est pas controlee. */
6790/* Si vous desirez la controler utiliser plutot MMCGLC1, tout en */
6791/* sachant que les performances (en temps) seront quand meme moins */
6792/* bonnes. */
6793
6794/* $ HISTORIQUE DES MODIFICATIONS : */
6795/* ------------------------------ */
6796/* 8-09-1995 : Performance */
6797/* 08-04-94 : JMC ; Rem: Appeler MMCGLC1 pour controler la precision
6798*/
6799/* 26-04-90 : RBD ; Augmentation du nbre de points KK pour calcul */
6800/* + precis, appel a MXVINIT et MXVSAVE, recup */
6801/* code d'erreur MVGAUS0, ajout commentaires. */
6802/* 08-06-89 : GD ; Suppression des 2 parties de l'integration, */
6803/* MVGAUS0 est appelle que si le degre a change. */
6804/* 10-06-88 : GD ; Variation dynamique du degre LEGENDRE */
6805/* 18-08-87 : GD ; Version originale */
6806
6807/* >=====================================================================
6808*/
6809
6810/* ATTENTION : SAUVER KGAR WGAUS et UROOT EVENTUELLEMENT */
6811/* ,IERXV */
6812/* INTEGER I1,I20 */
6813/* PARAMETER (I1=1,I20=20) */
6814
6815 /* Parameter adjustments */
6816 courbe_dim1 = *ndimax;
6817 courbe_offset = courbe_dim1 + 1;
6818 courbe -= courbe_offset;
6819
6820 /* Function Body */
6821
6822/* ****** Initialisation generale ** */
6823
6824 *iercod = 999999;
6825 *xlongc = 0.;
6826
6827/* ****** Initialisation de UROOT, WGAUS, NGAUS et KGAR ** */
6828
6829/* CALL MXVINIT(IERXV,'INTEGER',I1,KGAR,'INTEGER',I1,NGAUS */
6830/* 1 ,'DOUBLE PRECISION',I20,UROOT,'DOUBLE PRECISION',I20,WGAUS) */
6831/* IF (IERXV.GT.0) KGAR=0 */
6832
6833/* ****** Test d'egalite des bornes ** */
6834
6835 if (*tdebut == *tfinal) {
6836 *iercod = 0;
6837 goto L9900;
6838 }
6839
6840/* ****** Test de la dimension et du nombre de coefficients ** */
6841
6842 if (*ndimen <= 0 || *ncoeff <= 0) {
6843 *iercod = 1;
6844 goto L9900;
6845 }
6846
6847/* ****** Calcul du degre optimum ** */
6848
6849 kk = *ncoeff / 4 + 1;
6850 kk = min(kk,10);
6851
6852/* ****** Recuperation des coefficients pour l'integrale (DEGRE=4*KK) */
6853/* si KK <> KGAR. */
6854
6855 if (kk != kgar) {
6856 mvgaus0_(&kk, uroot, wgaus, &ngaus, iercod);
6857 if (*iercod > 0) {
6858 kgar = 0;
6859 *iercod = 2;
6860 goto L9900;
6861 }
6862 kgar = kk;
6863 }
6864
6865/* C1 => Point milieu intervalle */
6866/* C2 => 1/2 amplitude intervalle */
6867
6868 c1 = (*tfinal + *tdebut) * .5;
6869 c2 = (*tfinal - *tdebut) * .5;
6870
6871/* ----------------------------------------------------------- */
6872/* ****** Integration - Boucle sur les intervalles de GAUSS ** */
6873/* ----------------------------------------------------------- */
6874
6875 som = 0.;
6876
6877 i__1 = ngaus;
6878 for (jj = 1; jj <= i__1; ++jj) {
6879
6880/* ****** Integration en tenant compte de la symetrie ** */
6881
6882 tran = c2 * uroot[jj - 1];
6883 x1 = c1 + tran;
6884 x2 = c1 - tran;
6885
6886/* ****** Derivation sur la dimension de l'espace ** */
6887
6888 der1 = 0.;
6889 der2 = 0.;
6890 i__2 = *ndimen;
6891 for (kk = 1; kk <= i__2; ++kk) {
6892 d1 = (*ncoeff - 1) * courbe[kk + *ncoeff * courbe_dim1];
6893 d2 = d1;
6894 for (ii = *ncoeff - 1; ii >= 2; --ii) {
6895 dd = (ii - 1) * courbe[kk + ii * courbe_dim1];
6896 d1 = d1 * x1 + dd;
6897 d2 = d2 * x2 + dd;
6898/* L100: */
6899 }
6900 der1 += d1 * d1;
6901 der2 += d2 * d2;
6902/* L200: */
6903 }
6904
6905/* ****** Integration ** */
6906
6907 som += wgaus[jj - 1] * c2 * (sqrt(der1) + sqrt(der2));
6908
6909/* ****** Fin de boucle dur les intervalles de GAUSS ** */
6910
6911/* L300: */
6912 }
6913
6914/* ****** Travail termine ** */
6915
6916 *xlongc = som;
6917
6918/* ****** On force IERCOD = 0 ** */
6919
6920 *iercod = 0;
6921
6922/* ****** Traitement de fin ** */
6923
6924L9900:
6925
6926/* ****** Sauvegarde de UROOT, WGAUS, NGAUS et KGAR ** */
6927
6928/* CALL MXVSAVE(IERXV,'INTEGER',I1,KGAR,'INTEGER',I1,NGAUS */
6929/* 1 ,'DOUBLE PRECISION',I20,UROOT,'DOUBLE PRECISION',I20,WGAUS) */
6930/* IF (IERXV.GT.0) KGAR=0 */
6931
6932/* ****** Fin du sous-programme ** */
6933
6934 if (*iercod != 0) {
6935 AdvApp2Var_SysBase::maermsg_("MMLONCV", iercod, 7L);
6936 }
6937 return 0 ;
6938} /* mmloncv_ */
6939
6940//=======================================================================
6941//function : AdvApp2Var_MathBase::mmpobas_
6942//purpose :
6943//=======================================================================
6944 int AdvApp2Var_MathBase::mmpobas_(doublereal *tparam,
6945 integer *iordre,
6946 integer *ncoeff,
6947 integer *nderiv,
6948 doublereal *valbas,
6949 integer *iercod)
6950
6951{
6952 static integer c__2 = 2;
6953 static integer c__1 = 1;
6954
6955
6956 /* Initialized data */
6957
6958 static doublereal moin11[2] = { -1.,1. };
6959
6960 /* System generated locals */
6961 integer valbas_dim1, i__1;
6962
6963 /* Local variables */
6964 static doublereal vjac[80], herm[24];
6965 static integer iord[2];
6966 static doublereal wval[4];
6967 static integer nwcof, iunit;
6968 static doublereal wpoly[7];
6969 static integer ii, jj, iorjac;
6970 static doublereal hermit[36] /* was [6][3][2] */;
6971 static integer kk1, kk2, kk3;
6972 static integer khe, ier;
6973
6974
6975/* ***********************************************************************
6976 */
6977
6978/* FONCTION : */
6979/* ---------- */
6980/* Positionnement sur les polynomes de la base hermite-Jacobi */
6981/* et leurs derives succesives */
6982
6983/* MOTS CLES : */
6984/* ----------- */
6985/* PUBLIC, POSITIONEMENT, HERMITE, JACOBI */
6986
6987/* ARGUMENTS D'ENTREE : */
6988/* -------------------- */
6989/* TPARAM : Parametre pour lequel on se positionne. */
6990/* IORDRE : Ordre d'hermite-Jacobi (-1,0,1, ou 2) */
6991/* NCOEFF : Nombre de coeeficients des polynomes (Nb de valeur a */
6992/* calculer) */
6993/* NDERIV : Nombre de derive a calculer (0<= N <=3) */
6994/* 0 -> Positionement simple sur les fonctions de base */
6995/* N -> Positionement sur les fonctions de base et lerive */
6996/* d'ordre 1 a N */
6997
6998/* ARGUMENTS DE SORTIE : */
6999/* --------------------- */
7000/* VALBAS (NCOEFF, 0:NDERIV) : les valeur calculee */
7001/* i */
7002/* d vj(t) = VALBAS(J, I) */
7003/* -- i */
7004/* dt */
7005
7006/* IERCOD : Code d'erreur */
7007/* 0 : Ok */
7008/* 1 : Incoherance des arguments d'entre */
7009
7010/* COMMONS UTILISES : */
7011/* ------------------ */
7012
7013
7014/* REFERENCES APPELEES : */
7015/* --------------------- */
7016
7017
7018/* DESCRIPTION/REMARQUES/LIMITATIONS : */
7019/* ----------------------------------- */
7020
7021
7022/* $ HISTORIQUE DES MODIFICATIONS : */
7023/* ------------------------------ */
7024/* 19-07-1995: PMN; ECRITURE VERSION ORIGINALE. */
7025/* > */
7026/* ***********************************************************************
7027 */
7028/* DECLARATIONS */
7029/* ***********************************************************************
7030 */
7031
7032
7033
7034 /* Parameter adjustments */
7035 valbas_dim1 = *ncoeff;
7036 --valbas;
7037
7038 /* Function Body */
7039
7040/* ***********************************************************************
7041 */
7042/* INITIALISATIONS */
7043/* ***********************************************************************
7044 */
7045
7046 *iercod = 0;
7047
7048/* ***********************************************************************
7049 */
7050/* TRAITEMENT */
7051/* ***********************************************************************
7052 */
7053
7054 if (*nderiv > 3) {
7055 goto L9101;
7056 }
7057 if (*ncoeff > 20) {
7058 goto L9101;
7059 }
7060 if (*iordre > 2) {
7061 goto L9101;
7062 }
7063
7064 iord[0] = *iordre;
7065 iord[1] = *iordre;
7066 iorjac = (*iordre + 1) << 1;
7067
7068/* (1) Calculs generiques .... */
7069
7070/* (1.a) Calcul des polynomes d'hermite */
7071
7072 if (*iordre >= 0) {
7073 mmherm1_(moin11, &c__2, iord, hermit, &ier);
7074 if (ier > 0) {
7075 goto L9102;
7076 }
7077 }
7078
7079/* (1.b) Evaluation des polynomes d'hermite */
7080
7081 jj = 1;
7082 iunit = *nderiv + 1;
7083 khe = (*iordre + 1) * iunit;
7084
7085 if (*nderiv > 0) {
7086
7087 i__1 = *iordre;
7088 for (ii = 0; ii <= i__1; ++ii) {
7089 mmdrvcb_(nderiv, &c__1, &iorjac, &hermit[(ii + 3) * 6 - 18],
7090 tparam, &herm[jj - 1], &ier);
7091 if (ier > 0) {
7092 goto L9102;
7093 }
7094
7095 mmdrvcb_(nderiv, &c__1, &iorjac, &hermit[(ii + 6) * 6 - 18],
7096 tparam, &herm[jj + khe - 1], &ier);
7097 if (ier > 0) {
7098 goto L9102;
7099 }
7100 jj += iunit;
7101 }
7102
7103 } else {
7104
7105 i__1 = *iordre;
7106 for (ii = 0; ii <= i__1; ++ii) {
7107 AdvApp2Var_MathBase::mmpocrb_(&c__1, &iorjac, &hermit[(ii + 3) * 6 - 18], &c__1,
7108 tparam, &herm[jj - 1]);
7109
7110 AdvApp2Var_MathBase::mmpocrb_(&c__1, &iorjac, &hermit[(ii + 6) * 6 - 18], &c__1,
7111 tparam, &herm[jj + khe - 1]);
7112 jj += iunit;
7113 }
7114 }
7115
7116/* (1.c) Evaluation des polynomes de Jaccobi */
7117
7118 ii = *ncoeff - iorjac;
7119
7120 mmpojac_(tparam, &iorjac, &ii, nderiv, vjac, &ier);
7121 if (ier > 0) {
7122 goto L9102;
7123 }
7124
7125/* (1.d) Evaluation de W(t) */
7126
7127/* Computing MAX */
7128 i__1 = iorjac + 1;
7129 nwcof = max(i__1,1);
7130 AdvApp2Var_SysBase::mvriraz_((integer *)&nwcof,
7131 (char *)wpoly);
7132 wpoly[0] = 1.;
7133 if (*iordre == 2) {
7134 wpoly[2] = -3.;
7135 wpoly[4] = 3.;
7136 wpoly[6] = -1.;
7137 } else if (*iordre == 1) {
7138 wpoly[2] = -2.;
7139 wpoly[4] = 1.;
7140 } else if (*iordre == 0) {
7141 wpoly[2] = -1.;
7142 }
7143
7144 mmdrvcb_(nderiv, &c__1, &nwcof, wpoly, tparam, wval, &ier);
7145 if (ier > 0) {
7146 goto L9102;
7147 }
7148
7149 kk1 = *ncoeff - iorjac;
7150 kk2 = kk1 << 1;
7151 kk3 = kk1 * 3;
7152
7153/* (2) Evaluation a l'ordre 0 */
7154
7155 jj = 1;
7156 i__1 = iorjac;
7157 for (ii = 1; ii <= i__1; ++ii) {
7158 valbas[ii] = herm[jj - 1];
7159 jj += iunit;
7160 }
7161
7162 i__1 = kk1;
7163 for (ii = 1; ii <= i__1; ++ii) {
7164 valbas[ii + iorjac] = wval[0] * vjac[ii - 1];
7165 }
7166
7167/* (3) Evaluation a l'ordre 1 */
7168
7169 if (*nderiv >= 1) {
7170 jj = 2;
7171 i__1 = iorjac;
7172 for (ii = 1; ii <= i__1; ++ii) {
7173 valbas[ii + valbas_dim1] = herm[jj - 1];
7174 jj += iunit;
7175 }
7176
7177
7178 i__1 = kk1;
7179 for (ii = 1; ii <= i__1; ++ii) {
7180 valbas[ii + iorjac + valbas_dim1] = wval[0] * vjac[ii + kk1 - 1]
7181 + wval[1] * vjac[ii - 1];
7182 }
7183 }
7184
7185/* (4) Evaluation a l'ordre 2 */
7186
7187 if (*nderiv >= 2) {
7188 jj = 3;
7189 i__1 = iorjac;
7190 for (ii = 1; ii <= i__1; ++ii) {
7191 valbas[ii + (valbas_dim1 << 1)] = herm[jj - 1];
7192 jj += iunit;
7193 }
7194
7195 i__1 = kk1;
7196 for (ii = 1; ii <= i__1; ++ii) {
7197 valbas[ii + iorjac + (valbas_dim1 << 1)] = wval[0] * vjac[ii +
7198 kk2 - 1] + wval[1] * 2 * vjac[ii + kk1 - 1] + wval[2] *
7199 vjac[ii - 1];
7200 }
7201 }
7202
7203/* (5) Evaluation a l'ordre 3 */
7204
7205 if (*nderiv >= 3) {
7206 jj = 4;
7207 i__1 = iorjac;
7208 for (ii = 1; ii <= i__1; ++ii) {
7209 valbas[ii + valbas_dim1 * 3] = herm[jj - 1];
7210 jj += iunit;
7211 }
7212
7213 i__1 = kk1;
7214 for (ii = 1; ii <= i__1; ++ii) {
7215 valbas[ii + iorjac + valbas_dim1 * 3] = wval[0] * vjac[ii + kk3 -
7216 1] + wval[1] * 3 * vjac[ii + kk2 - 1] + wval[2] * 3 *
7217 vjac[ii + kk1 - 1] + wval[3] * vjac[ii - 1];
7218 }
7219 }
7220
7221 goto L9999;
7222
7223/* ***********************************************************************
7224 */
7225/* TRAITEMENT DES ERREURS */
7226/* ***********************************************************************
7227 */
7228
7229L9101:
7230 *iercod = 1;
7231 goto L9999;
7232
7233L9102:
7234 *iercod = 2;
7235
7236/* ***********************************************************************
7237 */
7238/* RETOUR PROGRAMME APPELANT */
7239/* ***********************************************************************
7240 */
7241
7242L9999:
7243
7244 if (*iercod > 0) {
7245 AdvApp2Var_SysBase::maermsg_("MMPOBAS", iercod, 7L);
7246 }
7247 return 0 ;
7248} /* mmpobas_ */
7249
7250//=======================================================================
7251//function : AdvApp2Var_MathBase::mmpocrb_
7252//purpose :
7253//=======================================================================
7254 int AdvApp2Var_MathBase::mmpocrb_(integer *ndimax,
7255 integer *ncoeff,
7256 doublereal *courbe,
7257 integer *ndim,
7258 doublereal *tparam,
7259 doublereal *pntcrb)
7260
7261{
7262 /* System generated locals */
7263 integer courbe_dim1, courbe_offset, i__1, i__2;
7264
7265 /* Local variables */
7266 static integer ncof2;
7267 static integer isize, nd, kcf, ncf;
7268
7269
7270/* ***********************************************************************
7271 */
7272
7273/* FONCTION : */
7274/* ---------- */
7275/* CALCULE LES COORDONNEES D'UN POINT D'UNE COURBE DE PARAMETRE */
7276/* DONNE TPARAM ( CECI EN 2D, 3D OU PLUS) */
7277
7278/* MOTS CLES : */
7279/* ----------- */
7280/* TOUS , MATH_ACCES :: COURBE&,PARAMETRE& , POSITIONNEMENT , &POINT
7281 */
7282
7283/* ARGUMENTS D'ENTREE : */
7284/* ------------------ */
7285/* NDIMAX : format / dimension de la courbe */
7286/* NCOEFF : Nbre de coefficients de la courbe */
7287/* COURBE : Matrice des coefficients de la courbe */
7288/* NDIM : Dimension utile de l'espace de travail */
7289/* TPARAM : Valeur du parametre ou est calcule le point */
7290
7291/* ARGUMENTS DE SORTIE : */
7292/* ------------------- */
7293/* PNTCRB : Coordonnees du point calcule */
7294
7295/* COMMONS UTILISES : */
7296/* ---------------- */
7297
7298/* .Neant. */
7299
7300/* REFERENCES APPELEES : */
7301/* ---------------------- */
7302/* Type Name */
7303/* MIRAZ MVPSCR2 MVPSCR3 */
7304
7305/* DESCRIPTION/REMARQUES/LIMITATIONS : */
7306/* ----------------------------------- */
7307
7308/* $ HISTORIQUE DES MODIFICATIONS : */
7309/* -------------------------------- */
7310/* 20-11-89 : JG : VERSION ORIGINALE */
7311/* > */
7312/* ***********************************************************************
7313 */
7314
7315
7316/* ***********************************************************************
7317 */
7318
7319 /* Parameter adjustments */
7320 courbe_dim1 = *ndimax;
7321 courbe_offset = courbe_dim1 + 1;
7322 courbe -= courbe_offset;
7323 --pntcrb;
7324
7325 /* Function Body */
7326 isize = *ndim << 3;
7327 AdvApp2Var_SysBase::miraz_((integer *)&isize,
7328 (char *)&pntcrb[1]);
7329
7330 if (*ncoeff <= 0) {
7331 goto L9999;
7332 }
7333
7334/* Traitement optimal 3d */
7335
7336 if (*ndim == 3 && *ndimax == 3) {
7337 mvpscr3_(ncoeff, &courbe[courbe_offset], tparam, &pntcrb[1]);
7338
7339/* Traitement optimal 2d */
7340
7341 } else if (*ndim == 2 && *ndimax == 2) {
7342 mvpscr2_(ncoeff, &courbe[courbe_offset], tparam, &pntcrb[1]);
7343
7344/* Dimension quelconque - schema de HORNER */
7345
7346 } else if (*tparam == 0.) {
7347 i__1 = *ndim;
7348 for (nd = 1; nd <= i__1; ++nd) {
7349 pntcrb[nd] = courbe[nd + courbe_dim1];
7350/* L100: */
7351 }
7352 } else if (*tparam == 1.) {
7353 i__1 = *ncoeff;
7354 for (ncf = 1; ncf <= i__1; ++ncf) {
7355 i__2 = *ndim;
7356 for (nd = 1; nd <= i__2; ++nd) {
7357 pntcrb[nd] += courbe[nd + ncf * courbe_dim1];
7358/* L300: */
7359 }
7360/* L200: */
7361 }
7362 } else {
7363 ncof2 = *ncoeff + 2;
7364 i__1 = *ndim;
7365 for (nd = 1; nd <= i__1; ++nd) {
7366 i__2 = *ncoeff;
7367 for (ncf = 2; ncf <= i__2; ++ncf) {
7368 kcf = ncof2 - ncf;
7369 pntcrb[nd] = (pntcrb[nd] + courbe[nd + kcf * courbe_dim1]) * *
7370 tparam;
7371/* L500: */
7372 }
7373 pntcrb[nd] += courbe[nd + courbe_dim1];
7374/* L400: */
7375 }
7376 }
7377
7378L9999:
7379 return 0 ;
7380} /* mmpocrb_ */
7381
7382//=======================================================================
7383//function : AdvApp2Var_MathBase::mmmpocur_
7384//purpose :
7385//=======================================================================
7386 int AdvApp2Var_MathBase::mmmpocur_(integer *ncofmx,
7387 integer *ndim,
7388 integer *ndeg,
7389 doublereal *courbe,
7390 doublereal *tparam,
7391 doublereal *tabval)
7392
7393{
7394 /* System generated locals */
7395 integer courbe_dim1, courbe_offset, i__1;
7396
7397 /* Local variables */
7398 static integer i__, nd;
7399 static doublereal fu;
7400
7401
7402/* ***********************************************************************
7403 */
7404
7405/* FONCTION : */
7406/* ---------- */
7407/* Positionnement d'un point sur une courbe (ncofmx,ndim). */
7408
7409/* MOTS CLES : */
7410/* ----------- */
7411/* TOUS , AB_SPECIFI :: COURBE&,POLYNOME&,POSITIONNEMENT,&POINT */
7412
7413/* ARGUMENTS D'ENTREE : */
7414/* ------------------ */
7415/* NCOFMX: Format / degre de la COURBE. */
7416/* NDIM : Dimension de l' espace. */
7417/* NDEG : Degre du polynome. */
7418/* COURBE: Les coefficients de la courbe. */
7419/* TPARAM: parametre sur la courbe */
7420
7421/* ARGUMENTS DE SORTIE : */
7422/* ------------------- */
7423/* TABVAL(NDIM): Le point resultat (ou tableau de valeurs) */
7424
7425/* COMMONS UTILISES : */
7426/* ---------------- */
7427
7428/* REFERENCES APPELEES : */
7429/* ----------------------- */
7430
7431/* DESCRIPTION/REMARQUES/LIMITATIONS : */
7432/* ----------------------------------- */
7433
7434/* $ HISTORIQUE DES MODIFICATIONS : */
7435/* -------------------------------- */
7436/* 05-01-90 : JG : optimisation (supprim appel a MGENMSG) , nettoyage
7437*/
7438/* 18-09-85 : Cree par JJM. */
7439/* > */
7440/* ***********************************************************************
7441 */
7442
7443 /* Parameter adjustments */
7444 --tabval;
7445 courbe_dim1 = *ncofmx;
7446 courbe_offset = courbe_dim1 + 1;
7447 courbe -= courbe_offset;
7448
7449 /* Function Body */
7450 if (*ndeg < 1) {
7451 i__1 = *ndim;
7452 for (nd = 1; nd <= i__1; ++nd) {
7453 tabval[nd] = 0.;
7454/* L290: */
7455 }
7456 } else {
7457 i__1 = *ndim;
7458 for (nd = 1; nd <= i__1; ++nd) {
7459 fu = courbe[*ndeg + nd * courbe_dim1];
7460 for (i__ = *ndeg - 1; i__ >= 1; --i__) {
7461 fu = fu * *tparam + courbe[i__ + nd * courbe_dim1];
7462/* L120: */
7463 }
7464 tabval[nd] = fu;
7465/* L300: */
7466 }
7467 }
7468 return 0 ;
7469} /* mmmpocur_ */
7470
7471//=======================================================================
7472//function : mmpojac_
7473//purpose :
7474//=======================================================================
7475int mmpojac_(doublereal *tparam,
7476 integer *iordre,
7477 integer *ncoeff,
7478 integer *nderiv,
7479 doublereal *valjac,
7480 integer *iercod)
7481
7482{
7483 static integer c__2 = 2;
7484
7485 /* Initialized data */
7486
7487 static integer nbcof = -1;
7488
7489 /* System generated locals */
7490 integer valjac_dim1, i__1, i__2;
7491
7492 /* Local variables */
7493 static doublereal cofa, cofb, denom, tnorm[100];
7494 static integer ii, jj, kk1, kk2;
7495 static doublereal aux1, aux2;
7496
7497
7498/* ***********************************************************************
7499 */
7500
7501/* FONCTION : */
7502/* ---------- */
7503/* Positionnement sur les polynomes de Jacobi et leurs derives */
7504/* successives par un algorithme de recurence */
7505
7506/* MOTS CLES : */
7507/* ----------- */
7508/* RESERVE, POSITIONEMENT, JACOBI */
7509
7510/* ARGUMENTS D'ENTREE : */
7511/* -------------------- */
7512/* TPARAM : Parametre pour lequel on se positionne. */
7513/* IORDRE : Ordre d'hermite-?? (-1,0,1, ou 2) */
7514/* NCOEFF : Nombre de coeeficients des polynomes (Nb de valeur a */
7515/* calculer) */
7516/* NDERIV : Nombre de derive a calculer (0<= N <=3) */
7517/* 0 -> Positionement simple sur les fonctions de jacobi */
7518/* N -> Positionement sur les fonctions de jacobi et leurs */
7519/* derive d'ordre 1 a N. */
7520
7521/* ARGUMENTS DE SORTIE : */
7522/* --------------------- */
7523/* VALJAC (NCOEFF, 0:NDERIV) : les valeur calculee */
7524/* i */
7525/* d vj(t) = VALJAC(J, I) */
7526/* -- i */
7527/* dt */
7528
7529/* IERCOD : Code d'erreur */
7530/* 0 : Ok */
7531/* 1 : Incoherance des arguments d'entre */
7532
7533/* COMMONS UTILISES : */
7534/* ------------------ */
7535
7536
7537/* REFERENCES APPELEES : */
7538/* --------------------- */
7539
7540
7541/* DESCRIPTION/REMARQUES/LIMITATIONS : */
7542/* ----------------------------------- */
7543
7544
7545/* $ HISTORIQUE DES MODIFICATIONS : */
7546/* ------------------------------ */
7547/* 19-07-1995: PMN; ECRITURE VERSION ORIGINALE. */
7548/* > */
7549/* ***********************************************************************
7550 */
7551/* DECLARATIONS */
7552/* ***********************************************************************
7553 */
7554
7555
7556/* varaibles statiques */
7557
7558
7559
7560 /* Parameter adjustments */
7561 valjac_dim1 = *ncoeff;
7562 --valjac;
7563
7564 /* Function Body */
7565
7566/* ***********************************************************************
7567 */
7568/* INITIALISATIONS */
7569/* ***********************************************************************
7570 */
7571
7572 *iercod = 0;
7573
7574/* ***********************************************************************
7575 */
7576/* TRAITEMENT */
7577/* ***********************************************************************
7578 */
7579
7580 if (*nderiv > 3) {
7581 goto L9101;
7582 }
7583 if (*ncoeff > 100) {
7584 goto L9101;
7585 }
7586
7587/* --- Calcul des normes */
7588
7589/* IF (NCOEFF.GT.NBCOF) THEN */
7590 i__1 = *ncoeff;
7591 for (ii = 1; ii <= i__1; ++ii) {
7592 kk1 = ii - 1;
7593 aux2 = 1.;
7594 i__2 = *iordre;
7595 for (jj = 1; jj <= i__2; ++jj) {
7596 aux2 = aux2 * (doublereal) (kk1 + *iordre + jj) / (doublereal) (
7597 kk1 + jj);
7598 }
7599 i__2 = (*iordre << 1) + 1;
7600 tnorm[ii - 1] = sqrt(aux2 * (kk1 * 2. + (*iordre << 1) + 1) / pow__ii(&
7601 c__2, &i__2));
7602 }
7603
7604 nbcof = *ncoeff;
7605
7606/* END IF */
7607
7608/* --- Positionements triviaux ----- */
7609
7610 valjac[1] = 1.;
7611 aux1 = (doublereal) (*iordre + 1);
7612 valjac[2] = aux1 * *tparam;
7613
7614 if (*nderiv >= 1) {
7615 valjac[valjac_dim1 + 1] = 0.;
7616 valjac[valjac_dim1 + 2] = aux1;
7617
7618 if (*nderiv >= 2) {
7619 valjac[(valjac_dim1 << 1) + 1] = 0.;
7620 valjac[(valjac_dim1 << 1) + 2] = 0.;
7621
7622 if (*nderiv >= 3) {
7623 valjac[valjac_dim1 * 3 + 1] = 0.;
7624 valjac[valjac_dim1 * 3 + 2] = 0.;
7625 }
7626 }
7627 }
7628
7629/* --- Positionement par reccurence */
7630
7631 i__1 = *ncoeff;
7632 for (ii = 3; ii <= i__1; ++ii) {
7633
7634 kk1 = ii - 1;
7635 kk2 = ii - 2;
7636 aux1 = (doublereal) (*iordre + kk2);
7637 aux2 = aux1 * 2;
7638 cofa = aux2 * (aux2 + 1) * (aux2 + 2);
7639 cofb = (aux2 + 2) * -2. * aux1 * aux1;
7640 denom = kk1 * 2. * (kk2 + (*iordre << 1) + 1) * aux2;
7641 denom = 1. / denom;
7642
7643/* --> Pi(t) */
7644 valjac[ii] = (cofa * *tparam * valjac[kk1] + cofb * valjac[kk2]) *
7645 denom;
7646/* --> P'i(t) */
7647 if (*nderiv >= 1) {
7648 valjac[ii + valjac_dim1] = (cofa * *tparam * valjac[kk1 +
7649 valjac_dim1] + cofa * valjac[kk1] + cofb * valjac[kk2 +
7650 valjac_dim1]) * denom;
7651/* --> P''i(t) */
7652 if (*nderiv >= 2) {
7653 valjac[ii + (valjac_dim1 << 1)] = (cofa * *tparam * valjac[
7654 kk1 + (valjac_dim1 << 1)] + cofa * 2 * valjac[kk1 +
7655 valjac_dim1] + cofb * valjac[kk2 + (valjac_dim1 << 1)]
7656 ) * denom;
7657 }
7658/* --> P'i(t) */
7659 if (*nderiv >= 3) {
7660 valjac[ii + valjac_dim1 * 3] = (cofa * *tparam * valjac[kk1 +
7661 valjac_dim1 * 3] + cofa * 3 * valjac[kk1 + (
7662 valjac_dim1 << 1)] + cofb * valjac[kk2 + valjac_dim1 *
7663 3]) * denom;
7664 }
7665 }
7666 }
7667
7668/* ---> Normalisation */
7669
7670 i__1 = *ncoeff;
7671 for (ii = 1; ii <= i__1; ++ii) {
7672 i__2 = *nderiv;
7673 for (jj = 0; jj <= i__2; ++jj) {
7674 valjac[ii + jj * valjac_dim1] = tnorm[ii - 1] * valjac[ii + jj *
7675 valjac_dim1];
7676 }
7677 }
7678
7679 goto L9999;
7680
7681/* ***********************************************************************
7682 */
7683/* TRAITEMENT DES ERREURS */
7684/* ***********************************************************************
7685 */
7686
7687L9101:
7688 *iercod = 1;
7689 goto L9999;
7690
7691
7692/* ***********************************************************************
7693 */
7694/* RETOUR PROGRAMME APPELANT */
7695/* ***********************************************************************
7696 */
7697
7698L9999:
7699
7700 if (*iercod > 0) {
7701 AdvApp2Var_SysBase::maermsg_("MMPOJAC", iercod, 7L);
7702 }
7703 return 0 ;
7704} /* mmpojac_ */
7705
7706//=======================================================================
7707//function : AdvApp2Var_MathBase::mmposui_
7708//purpose :
7709//=======================================================================
7710 int AdvApp2Var_MathBase::mmposui_(integer *dimmat,
7711 integer *,//nistoc,
7712 integer *aposit,
7713 integer *posuiv,
7714 integer *iercod)
7715
7716{
7717 /* System generated locals */
7718 integer i__1, i__2;
7719
7720 /* Local variables */
7721 static logical ldbg;
7722 static integer imin, jmin, i__, j, k;
7723 static logical trouve;
7724
7725/* ***********************************************************************
7726 */
7727
7728/* FONCTION : */
7729/* ---------- */
7730/* REMPLISSAGE DE LA TABLE DE POSITIONNEMENT POSUIV QUI PERMET DE */
7731/* PARCOURIR EN COLONNE LA PARTIE TRAINGULAIRE INFERIEUR DE LA */
7732/* MATRICE SOUS FORME DE PROFIL */
7733
7734
7735/* MOTS CLES : */
7736/* ----------- */
7737/* RESERVE, MATRICE, PROFIL */
7738
7739/* ARGUMENTS D'ENTREE : */
7740/* -------------------- */
7741
7742/* NISTOC: NOMBRE DE COEFFICIENTS DANS LE PROFILE */
7743/* DIMMAT: NOMBRE DE LIGNE DE LA MATRICE CARRE SYMETRIQUE */
7744/* APOSIT: TABLE DE POSITIONNEMENT DES TERMES DE STOCKAGE */
7745/* APOSIT(1,I) CONTIENT LE NOMBRE DE TERMES-1 SUR LA LIGNE
7746*/
7747/* I DANS LE PROFIL DE LA MATRICE */
7748/* APOSIT(2,I) CONTIENT L'INDICE DE STOCKAGE DU TERME DIAGONA
7749L*/
7750/* DE LA LIGNE I */
7751
7752
7753/* ARGUMENTS DE SORTIE : */
7754/* --------------------- */
7755/* POSUIV: POSUIV(K) (OU K EST L'INDICE DE STOCKAGE DE MAT(I,J)) */
7756/* CONTIENT LE PLUS PETIT NUMERO IMIN>I DE LA LIGNE QUI */
7757/* POSSEDE UN TERME MAT(IMIN,J) QUI EST DANS LE PROFIL. */
7758/* S'IL N'Y A PAS LE TERME MAT(IMIN,J) DANS LE PROFIL */
7759/* ALORS POSUIV(K)=-1 */
7760
7761
7762
7763
7764/* COMMONS UTILISES : */
7765/* ------------------ */
7766
7767
7768/* REFERENCES APPELEES : */
7769/* --------------------- */
7770
7771
7772/* DESCRIPTION/REMARQUES/LIMITATIONS : */
7773/* ----------------------------------- */
7774
7775
7776/* $ HISTORIQUE DES MODIFICATIONS : */
7777/* ------------------------------ */
7778/* 23-08-95 : KHN; ECRITURE VERSION ORIGINALE. */
7779/* > */
7780/* ***********************************************************************
7781 */
7782/* DECLARATIONS */
7783/* ***********************************************************************
7784 */
7785
7786
7787
7788/* ***********************************************************************
7789 */
7790/* INITIALISATIONS */
7791/* ***********************************************************************
7792 */
7793
7794 /* Parameter adjustments */
7795 aposit -= 3;
7796 --posuiv;
7797
7798 /* Function Body */
7799 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 2;
7800 if (ldbg) {
7801 AdvApp2Var_SysBase::mgenmsg_("MMPOSUI", 7L);
7802 }
7803 *iercod = 0;
7804
7805
7806/* ***********************************************************************
7807 */
7808/* TRAITEMENT */
7809/* ***********************************************************************
7810 */
7811
7812
7813
7814 i__1 = *dimmat;
7815 for (i__ = 1; i__ <= i__1; ++i__) {
7816 jmin = i__ - aposit[(i__ << 1) + 1];
7817 i__2 = i__;
7818 for (j = jmin; j <= i__2; ++j) {
7819 imin = i__ + 1;
7820 trouve = FALSE_;
7821 while(! trouve && imin <= *dimmat) {
7822 if (imin - aposit[(imin << 1) + 1] <= j) {
7823 trouve = TRUE_;
7824 } else {
7825 ++imin;
7826 }
7827 }
7828 k = aposit[(i__ << 1) + 2] - i__ + j;
7829 if (trouve) {
7830 posuiv[k] = imin;
7831 } else {
7832 posuiv[k] = -1;
7833 }
7834 }
7835 }
7836
7837
7838
7839
7840
7841 goto L9999;
7842
7843/* ***********************************************************************
7844 */
7845/* TRAITEMENT DES ERREURS */
7846/* ***********************************************************************
7847 */
7848
7849
7850
7851
7852/* ***********************************************************************
7853 */
7854/* RETOUR PROGRAMME APPELANT */
7855/* ***********************************************************************
7856 */
7857
7858L9999:
7859
7860/* ___ DESALLOCATION, ... */
7861
7862 AdvApp2Var_SysBase::maermsg_("MMPOSUI", iercod, 7L);
7863 if (ldbg) {
7864 AdvApp2Var_SysBase::mgsomsg_("MMPOSUI", 7L);
7865 }
7866 return 0 ;
7867} /* mmposui_ */
7868
7869//=======================================================================
7870//function : AdvApp2Var_MathBase::mmresol_
7871//purpose :
7872//=======================================================================
7873 int AdvApp2Var_MathBase::mmresol_(integer *hdimen,
7874 integer *gdimen,
7875 integer *hnstoc,
7876 integer *gnstoc,
7877 integer *mnstoc,
7878 doublereal *matsyh,
7879 doublereal *matsyg,
7880 doublereal *vecsyh,
7881 doublereal *vecsyg,
7882 integer *hposit,
7883 integer *hposui,
7884 integer *gposit,
7885 integer *mmposui,
7886 integer *mposit,
7887 doublereal *vecsol,
7888 integer *iercod)
7889
7890{
7891 static integer c__100 = 100;
7892
7893 /* System generated locals */
7894 integer i__1, i__2;
7895
7896 /* Local variables */
7897 static logical ldbg;
7898 static doublereal mcho[100];
7899 static integer jmin, jmax, i__, j, k, l;
7900 static long int iofv1, iofv2, iofv3, iofv4;
7901 static doublereal v1[100], v2[100], v3[100], v4[100];
7902 static integer deblig, dimhch;
7903 static doublereal hchole[100];
7904 static long int iofmch, iofmam, iofhch;
7905 static doublereal matsym[100];
7906 static integer ier;
7907 static integer aux;
7908
7909
7910
7911/* ***********************************************************************
7912 */
7913
7914/* FONCTION : */
7915/* ---------- */
7916/* RESOLUTION DU SYSTEME */
7917/* H t(G) V B */
7918/* = */
7919/* G 0 L C */
7920
7921/* MOTS CLES : */
7922/* ----------- */
7923/* RESERVE, RESOLUTION, SYSTEME, LAGRANGIEN */
7924
7925/* ARGUMENTS D'ENTREE : */
7926/* -------------------- */
7927/* HDIMEN: NOMBRE DE LIGNE(OU COLONNE) DE LA MATRICE HESSIENNE */
7928/* GDIMEN: NOMBRE DE LIGNE DE LA MATRICE DES CONTRAINTES */
7929/* HNSTOC: NOMBRES DE TERMES DANS LE PROFIL DE LA MATRICE HESSIENNE
7930*/
7931/* GNSTOC: NOMBRES DE TERMES DANS LE PROFIL DE LA MATRICE DES */
7932/* CONTRAINTES */
7933/* MNSTOC: NOMBRES DE TERMES DANS LE PROFIL DE LA MATRICE */
7934/* M= G H t(G) */
7935/* ou H EST LA MATRICE HESSIENNE ET G LA MATRICE DES */
7936/* CONTRAINTES */
7937/* MATSYH: PARTIE TRIANGULAIRE INFERIEUR DE LA MATRICE */
7938/* HESSIENNE SOUS FORME DE PROFIL */
7939/* MATSYG: MATRICE DES CONTRAINTES SOUS FORME DE PROFIL */
7940/* VECSYH: VECTEUR DU SECOND MEMBRE ASSOCIE A MATSYH */
7941/* VECSYG: VECTEUR DU SECOND MEMBRE ASSOCIE A MATSYG */
7942/* HPOSIT: TABLE DE POSITIONNEMENT DE LA MATRICE HESSIENNE */
7943/* HPOSIT(1,I) CONTIENT LE NOMBRE DE TERMES -1 */
7944/* QUI SONT DANS LE PROFIL A LA LIGNE I */
7945/* HPOSIT(2,I) CONTIENT L'INDICE DE STOCKAGE DU TERME */
7946/* DIAGNALE DE LA MATRICE A LA LIGNE I */
7947/* HPOSUI: TABLE PERMETTANT DE BALAYER EN COLONNE LA MATRICE */
7948/* HESSIENNE SOUS FORME DE PROFIL */
7949/* HPOSUI(K) CONTIENT LE NUMERO DE LIGNE IMIN SUIVANT LA LIGN
7950E*/
7951/* COURANT I OU H(I,J)=MATSYH(K) TEL QUE IL EXISTE DANS LA */
7952/* MEME COLONNE J UN TERME DANS LE PROFIL DE LA LIGNE IMIN */
7953/* SI UN TEL TERME N'EXISTE PAS IMIN=-1 */
7954/* GPOSIT: TABLE DE POSITIONNEMENT DE LA MATRICE DES CONTRAINTES */
7955/* GPOSIT(1,I) CONTIENT LE NOMBRE DE TERMES DE LA LIGNE I */
7956/* QUI SONT DANS LE PROFIL */
7957/* GPOSIT(2,I) CONTIENT L'INDICE DE STOKAGE DU DERNIER TERME
7958*/
7959/* DE LA LIGNE I QUI EST DANS LE PROFIL */
7960/* GPOSIT(3,I) CONTIENT LE NUMERO DE COLONNE CORRESPONDANT */
7961/* AU PREMIER TERME DE LA LIGNE I QUI EST DANS */
7962/* LE PROFIL */
7963/* MMPOSUI, MPOSIT: MEME STRUCTURE QUE HPOSUI, MAIS POUR LA MATRICE
7964*/
7965/* M=G H t(G) */
7966
7967
7968/* ARGUMENTS DE SORTIE : */
7969/* --------------------- */
7970/* VECSOL: VECTEUR SOLUTION V DU SYSTEME */
7971/* IERCOD: CODE D'ERREUR */
7972
7973/* COMMONS UTILISES : */
7974/* ------------------ */
7975
7976
7977/* REFERENCES APPELEES : */
7978/* --------------------- */
7979
7980
7981/* DESCRIPTION/REMARQUES/LIMITATIONS : */
7982/* ----------------------------------- */
7983
7984
7985/* $ HISTORIQUE DES MODIFICATIONS : */
7986/* ------------------------------ */
7987/* 21-09-96 : KHN; ECRITURE VERSION ORIGINALE. */
7988/* > */
7989/* ***********************************************************************
7990 */
7991/* DECLARATIONS */
7992/* ***********************************************************************
7993 */
7994
7995/* ***********************************************************************
7996 */
7997/* INITIALISATIONS */
7998/* ***********************************************************************
7999 */
8000
8001 /* Parameter adjustments */
8002 --vecsol;
8003 hposit -= 3;
8004 --vecsyh;
8005 --hposui;
8006 --matsyh;
8007 --matsyg;
8008 --vecsyg;
8009 gposit -= 4;
8010 --mmposui;
8011 mposit -= 3;
8012
8013 /* Function Body */
8014 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 2;
8015 if (ldbg) {
8016 AdvApp2Var_SysBase::mgenmsg_("MMRESOL", 7L);
8017 }
8018 *iercod = 0;
8019 iofhch = 0;
8020 iofv1 = 0;
8021 iofv2 = 0;
8022 iofv3 = 0;
8023 iofv4 = 0;
8024 iofmam = 0;
8025 iofmch = 0;
8026
8027/* ***********************************************************************
8028 */
8029/* TRAITEMENT */
8030/* ***********************************************************************
8031 */
8032
8033/* Allocation dynamique */
8034
8035 AdvApp2Var_SysBase::macrar8_(hdimen, &c__100, v1, &iofv1, &ier);
8036 if (ier > 0) {
8037 goto L9102;
8038 }
8039 dimhch = hposit[(*hdimen << 1) + 2];
8040 AdvApp2Var_SysBase::macrar8_(&dimhch, &c__100, hchole, &iofhch, &ier);
8041 if (ier > 0) {
8042 goto L9102;
8043 }
8044
8045/* RESOL DU SYST 1 H V1 = b */
8046/* ou H=MATSYH et b=VECSYH */
8047
8048 mmchole_(hnstoc, hdimen, &matsyh[1], &hposit[3], &hposui[1], &hchole[
8049 iofhch], &ier);
8050 if (ier > 0) {
8051 goto L9101;
8052 }
8053 mmrslss_(hnstoc, hdimen, &hchole[iofhch], &hposit[3], &hposui[1], &vecsyh[
8054 1], &v1[iofv1], &ier);
8055 if (ier > 0) {
8056 goto L9102;
8057 }
8058
8059/* CAS OU IL Y A DES CONTRAINTES */
8060
8061 if (*gdimen > 0) {
8062
8063/* CALCUL LE VECTEUR DU SECOND MEMBRE V2=G H(-1) b -c = G v1-c */
8064/* DU SYSTEME D'INCONNU LE VECTEUR MULTIP DE LAGRANGE */
8065/* ou G=MATSYG */
8066/* c=VECSYG */
8067
8068 AdvApp2Var_SysBase::macrar8_(gdimen, &c__100, v2, &iofv2, &ier);
8069 if (ier > 0) {
8070 goto L9102;
8071 }
8072 AdvApp2Var_SysBase::macrar8_(hdimen, &c__100, v3, &iofv3, &ier);
8073 if (ier > 0) {
8074 goto L9102;
8075 }
8076 AdvApp2Var_SysBase::macrar8_(gdimen, &c__100, v4, &iofv4, &ier);
8077 if (ier > 0) {
8078 goto L9102;
8079 }
8080 AdvApp2Var_SysBase::macrar8_(mnstoc, &c__100, matsym, &iofmam, &ier);
8081 if (ier > 0) {
8082 goto L9102;
8083 }
8084
8085 deblig = 1;
8086 mmatvec_(gdimen, hdimen, &gposit[4], gnstoc, &matsyg[1], &v1[iofv1], &
8087 deblig, &v2[iofv2], &ier);
8088 if (ier > 0) {
8089 goto L9101;
8090 }
8091 i__1 = *gdimen;
8092 for (i__ = 1; i__ <= i__1; ++i__) {
8093 v2[i__ + iofv2 - 1] -= vecsyg[i__];
8094 }
8095
8096/* CALCUL de la matrice M= G H(-1) t(G) */
8097/* RESOL DU SYST 2 : H qi = gi */
8098/* ou gi est un vecteur colonne de t(G) */
8099/* qi=v3 */
8100/* puis calcul G qi */
8101/* puis construire M sous forme de profil */
8102
8103
8104
8105 i__1 = *gdimen;
8106 for (i__ = 1; i__ <= i__1; ++i__) {
8107 AdvApp2Var_SysBase::mvriraz_((integer *)hdimen, (char *)&v1[iofv1]);
8108 AdvApp2Var_SysBase::mvriraz_((integer *)hdimen, (char *)&v3[iofv3]);
8109 AdvApp2Var_SysBase::mvriraz_((integer *)gdimen, (char *)&v4[iofv4]);
8110 jmin = gposit[i__ * 3 + 3];
8111 jmax = gposit[i__ * 3 + 1] + gposit[i__ * 3 + 3] - 1;
8112 aux = gposit[i__ * 3 + 2] - gposit[i__ * 3 + 1] - jmin + 1;
8113 i__2 = jmax;
8114 for (j = jmin; j <= i__2; ++j) {
8115 k = j + aux;
8116 v1[j + iofv1 - 1] = matsyg[k];
8117 }
8118 mmrslss_(hnstoc, hdimen, &hchole[iofhch], &hposit[3], &hposui[1],
8119 &v1[iofv1], &v3[iofv3], &ier);
8120 if (ier > 0) {
8121 goto L9101;
8122 }
8123
8124 deblig = i__;
8125 mmatvec_(gdimen, hdimen, &gposit[4], gnstoc, &matsyg[1], &v3[
8126 iofv3], &deblig, &v4[iofv4], &ier);
8127 if (ier > 0) {
8128 goto L9101;
8129 }
8130
8131 k = mposit[(i__ << 1) + 2];
8132 matsym[k + iofmam - 1] = v4[i__ + iofv4 - 1];
8133 while(mmposui[k] > 0) {
8134 l = mmposui[k];
8135 k = mposit[(l << 1) + 2] - l + i__;
8136 matsym[k + iofmam - 1] = v4[l + iofv4 - 1];
8137 }
8138 }
8139
8140
8141/* RESOL SYST 3 M L = V2 */
8142/* AVEC L=V4 */
8143
8144
8145 AdvApp2Var_SysBase::mvriraz_((integer *)gdimen, (char *)&v4[iofv4]);
8146 AdvApp2Var_SysBase::macrar8_(mnstoc, &c__100, mcho, &iofmch, &ier);
8147 if (ier > 0) {
8148 goto L9102;
8149 }
8150 mmchole_(mnstoc, gdimen, &matsym[iofmam], &mposit[3], &mmposui[1], &
8151 mcho[iofmch], &ier);
8152 if (ier > 0) {
8153 goto L9101;
8154 }
8155 mmrslss_(mnstoc, gdimen, &mcho[iofmch], &mposit[3], &mmposui[1], &v2[
8156 iofv2], &v4[iofv4], &ier);
8157 if (ier > 0) {
8158 goto L9102;
8159 }
8160
8161
8162/* CALCUL LE VECTEUR DU SECOND MEMBRE DU SYSTEME Hx = b - t(G) L
8163*/
8164/* = V1 */
8165
8166 AdvApp2Var_SysBase::mvriraz_((integer *)hdimen, (char *)&v1[iofv1]);
8167 mmtmave_(gdimen, hdimen, &gposit[4], gnstoc, &matsyg[1], &v4[iofv4], &
8168 v1[iofv1], &ier);
8169 if (ier > 0) {
8170 goto L9101;
8171 }
8172 i__1 = *hdimen;
8173 for (i__ = 1; i__ <= i__1; ++i__) {
8174 v1[i__ + iofv1 - 1] = vecsyh[i__] - v1[i__ + iofv1 - 1];
8175 }
8176
8177/* RESOL SYST 4 Hx = b - t(G) L */
8178
8179
8180 mmrslss_(hnstoc, hdimen, &hchole[iofhch], &hposit[3], &hposui[1], &v1[
8181 iofv1], &vecsol[1], &ier);
8182 if (ier > 0) {
8183 goto L9102;
8184 }
8185 } else {
8186 i__1 = *hdimen;
8187 for (i__ = 1; i__ <= i__1; ++i__) {
8188 vecsol[i__] = v1[i__ + iofv1 - 1];
8189 }
8190 }
8191
8192 goto L9999;
8193
8194/* ***********************************************************************
8195 */
8196/* TRAITEMENT DES ERREURS */
8197/* ***********************************************************************
8198 */
8199
8200
8201L9101:
8202 *iercod = 1;
8203 goto L9999;
8204
8205L9102:
8206 AdvApp2Var_SysBase::mswrdbg_("MMRESOL : PROBLEME AVEC DIMMAT", 30L);
8207 *iercod = 2;
8208
8209/* ***********************************************************************
8210 */
8211/* RETOUR PROGRAMME APPELANT */
8212/* ***********************************************************************
8213 */
8214
8215L9999:
8216
8217/* ___ DESALLOCATION, ... */
8218 AdvApp2Var_SysBase::macrdr8_(hdimen, &c__100, v1, &iofv1, &ier);
8219 if (*iercod == 0 && ier > 0) {
8220 *iercod = 3;
8221 }
8222 AdvApp2Var_SysBase::macrdr8_(&dimhch, &c__100, hchole, &iofhch, &ier);
8223 if (*iercod == 0 && ier > 0) {
8224 *iercod = 3;
8225 }
8226 AdvApp2Var_SysBase::macrdr8_(gdimen, &c__100, v2, &iofv2, &ier);
8227 if (*iercod == 0 && ier > 0) {
8228 *iercod = 3;
8229 }
8230 AdvApp2Var_SysBase::macrdr8_(hdimen, &c__100, v3, &iofv3, &ier);
8231 if (*iercod == 0 && ier > 0) {
8232 *iercod = 3;
8233 }
8234 AdvApp2Var_SysBase::macrdr8_(gdimen, &c__100, v4, &iofv4, &ier);
8235 if (*iercod == 0 && ier > 0) {
8236 *iercod = 3;
8237 }
8238 AdvApp2Var_SysBase::macrdr8_(mnstoc, &c__100, matsym, &iofmam, &ier);
8239 if (*iercod == 0 && ier > 0) {
8240 *iercod = 3;
8241 }
8242 AdvApp2Var_SysBase::macrdr8_(mnstoc, &c__100, mcho, &iofmch, &ier);
8243 if (*iercod == 0 && ier > 0) {
8244 *iercod = 3;
8245 }
8246
8247 AdvApp2Var_SysBase::maermsg_("MMRESOL", iercod, 7L);
8248 if (ldbg) {
8249 AdvApp2Var_SysBase::mgsomsg_("MMRESOL", 7L);
8250 }
8251 return 0 ;
8252} /* mmresol_ */
8253
8254//=======================================================================
8255//function : mmrslss_
8256//purpose :
8257//=======================================================================
8258int mmrslss_(integer *,//mxcoef,
8259 integer *dimens,
8260 doublereal *smatri,
8261 integer *sposit,
8262 integer *posuiv,
8263 doublereal *mscnmbr,
8264 doublereal *soluti,
8265 integer *iercod)
8266{
8267 /* System generated locals */
8268 integer i__1, i__2;
8269
8270 /* Local variables */
8271 static logical ldbg;
8272 static integer i__, j;
8273 static doublereal somme;
8274 static integer pointe, ptcour;
8275
8276/* ***********************************************************************
8277 */
8278
8279/* FONCTION : */
8280/* ---------- T */
8281/* Resoud le systeme lineaire SS x = b ou S est une matrice */
8282/* triangulaire inferieure donnee sous forme profil */
8283
8284/* MOTS CLES : */
8285/* ----------- */
8286/* RESERVE, MATRICE_PROFILE, RESOLUTION, CHOLESKI */
8287
8288/* ARGUMENTS D'ENTREE : */
8289/* -------------------- */
8290/* MXCOEF : Nombre maximal de coefficient non nuls dans la matrice */
8291/* DIMENS : Dimension de la matrice */
8292/* SMATRI(MXCOEF) : Valeurs des coefficients de la matrice */
8293/* SPOSIT(2,DIMENS): */
8294/* SPOSIT(1,*) : Distance diagonnal-extrimite de la ligne */
8295/* SPOSIT(2,*) : Position des termes diagonnaux dans AMATRI */
8296/* POSUIV(MXCOEF): premiere ligne inferieure non hors profil */
8297/* MSCNMBR(DIMENS): Vecteur second membre de l'equation */
8298
8299/* ARGUMENTS DE SORTIE : */
8300/* --------------------- */
8301/* SOLUTI(NDIMEN) : Vecteur resultat */
8302/* IERCOD : Code d'erreur 0 : ok */
8303
8304/* COMMONS UTILISES : */
8305/* ------------------ */
8306
8307
8308/* REFERENCES APPELEES : */
8309/* --------------------- */
8310
8311
8312/* DESCRIPTION/REMARQUES/LIMITATIONS : */
8313/* ----------------------------------- */
8314/* T */
8315/* SS est la decomposition de choleski d'une matrice symetrique */
8316/* definie postive, qui peut s'obtenir par la routine MMCHOLE. */
8317
8318/* Pour une matrice pleine on peut utiliser MRSLMSC */
8319
8320/* NIVEAU DE DEBUG = 4 */
8321
8322/* $ HISTORIQUE DES MODIFICATIONS : */
8323/* ------------------------------ */
8324/* 14-02-1994: PMN; ECRITURE VERSION ORIGINALE. */
8325/* > */
8326/* ***********************************************************************
8327 */
8328/* DECLARATIONS */
8329/* ***********************************************************************
8330 */
8331
8332
8333
8334/* ***********************************************************************
8335 */
8336/* INITIALISATIONS */
8337/* ***********************************************************************
8338 */
8339
8340 /* Parameter adjustments */
8341 --posuiv;
8342 --smatri;
8343 --soluti;
8344 --mscnmbr;
8345 sposit -= 3;
8346
8347 /* Function Body */
8348 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 4;
8349 if (ldbg) {
8350 AdvApp2Var_SysBase::mgenmsg_("MMRSLSS", 7L);
8351 }
8352 *iercod = 0;
8353
8354/* ***********************************************************************
8355 */
8356/* TRAITEMENT */
8357/* ***********************************************************************
8358 */
8359
8360/* ----- Resolution de Sw = b */
8361
8362 i__1 = *dimens;
8363 for (i__ = 1; i__ <= i__1; ++i__) {
8364
8365 pointe = sposit[(i__ << 1) + 2];
8366 somme = 0.;
8367 i__2 = i__ - 1;
8368 for (j = i__ - sposit[(i__ << 1) + 1]; j <= i__2; ++j) {
8369 somme += smatri[pointe - (i__ - j)] * soluti[j];
8370 }
8371
8372 soluti[i__] = (mscnmbr[i__] - somme) / smatri[pointe];
8373 }
8374/* T */
8375/* ----- Resolution de S u = w */
8376
8377 for (i__ = *dimens; i__ >= 1; --i__) {
8378
8379 pointe = sposit[(i__ << 1) + 2];
8380 j = posuiv[pointe];
8381 somme = 0.;
8382 while(j > 0) {
8383 ptcour = sposit[(j << 1) + 2] - (j - i__);
8384 somme += smatri[ptcour] * soluti[j];
8385 j = posuiv[ptcour];
8386 }
8387
8388 soluti[i__] = (soluti[i__] - somme) / smatri[pointe];
8389 }
8390
8391 goto L9999;
8392
8393/* ***********************************************************************
8394 */
8395/* TRAITEMENT DES ERREURS */
8396/* ***********************************************************************
8397 */
8398
8399
8400/* ***********************************************************************
8401 */
8402/* RETOUR PROGRAMME APPELANT */
8403/* ***********************************************************************
8404 */
8405
8406L9999:
8407
8408 AdvApp2Var_SysBase::maermsg_("MMRSLSS", iercod, 7L);
8409 if (ldbg) {
8410 AdvApp2Var_SysBase::mgsomsg_("MMRSLSS", 7L);
8411 }
8412 return 0 ;
8413} /* mmrslss_ */
8414
8415//=======================================================================
8416//function : mmrslw_
8417//purpose :
8418//=======================================================================
8419int mmrslw_(integer *normax,
8420 integer *nordre,
8421 integer *ndimen,
8422 doublereal *epspiv,
8423 doublereal *abmatr,
8424 doublereal *xmatri,
8425 integer *iercod)
8426{
8427 /* System generated locals */
8428 integer abmatr_dim1, abmatr_offset, xmatri_dim1, xmatri_offset, i__1,
8429 i__2, i__3;
8430 doublereal d__1;
8431
8432 /* Local variables */
8433 static integer kpiv;
8434 static doublereal pivot;
8435 static integer ii, jj, kk;
8436 static doublereal akj;
8437
8438
8439/* **********************************************************************
8440*/
8441
8442/* FONCTION : */
8443/* ---------- */
8444/* Resolution d' un systeme lineaire A.x = B de N equations a N */
8445/* inconnues par la methode de Gauss (pivot partiel) ou : */
8446/* A est une matrice NORDRE * NORDRE, */
8447/* B est une matrice NORDRE (lignes) * NDIMEN (colonnes), */
8448/* x est une matrice NORDRE (lignes) * NDIMEN (colonnes). */
8449/* Dans ce programme, A et B sont stockes dans la matrice ABMATR dont */
8450/* les lignes et les colonnes ont ete inversees. ABMATR(k,j) est le */
8451/* terme A(j,k) si k <= NORDRE, B(j,k-NORDRE) sinon (cf. exemple). */
8452
8453/* MOTS CLES : */
8454/* ----------- */
8455/* TOUS, MATH_ACCES::EQUATION&, MATRICE&, RESOLUTION, GAUSS, &SOLUTION */
8456
8457/* ARGUMENTS D'ENTREE : */
8458/* ------------------ */
8459/* NORMAX : Taille maximale du premier indice de XMATRI. Cet argument */
8460/* ne sert que pour la declaration de dimension de XMATRI et */
8461/* doit etre superieur ou egal a NORDRE. */
8462/* NORDRE : Ordre de la matrice i.e. nombre d'equations et */
8463/* d'inconnues du systeme lineaire a resoudre. */
8464/* NDIMEN : Nombre de second membre. */
8465/* EPSPIV : Valeur minimale d'un pivot. Si au cours du calcul la */
8466/* valeur absolue du pivot est inferieure a EPSPIV, le */
8467/* systeme d'equations est declare singulier. EPSPIV doit */
8468/* etre un "petit" reel. */
8469
8470/* ABMATR(NORDRE+NDIMEN,NORDRE) : Matrice auxiliaire contenant la */
8471/* matrice A et la matrice B. */
8472
8473/* ARGUMENTS DE SORTIE : */
8474/* ------------------- */
8475/* XMATRI : Matrice contenant les NORDRE*NDIMEN solutions. */
8476/* IERCOD=0 indique que toutes les solutions sont calculees. */
8477/* IERCOD=1 indique que la matrice est de rang inferieur a NORDRE */
8478/* (le systeme est singulier). */
8479
8480/* COMMONS UTILISES : */
8481/* ---------------- */
8482
8483/* REFERENCES APPELEES : */
8484/* ----------------------- */
8485
8486/* DESCRIPTION/REMARQUES/LIMITATIONS : */
8487/* ----------------------------------- */
8488/* ATTENTION : les indices de ligne et de colonne sont inverses */
8489/* par rapport aux indices habituels. */
8490/* Le systeme : */
8491/* a1*x + b1*y = c1 */
8492/* a2*x + b2*y = c2 */
8493/* doit etre represente par la matrice ABMATR : */
8494
8495/* ABMATR(1,1) = a1 ABMATR(1,2) = a2 */
8496/* ABMATR(2,1) = b1 ABMATR(2,2) = b2 */
8497/* ABMATR(3,1) = c1 ABMATR(3,2) = c2 */
8498
8499/* Pour resoudre ce systeme, il faut poser: */
8500
8501/* NORDRE = 2 (il y a 2 equations a 2 inconnues), */
8502/* NDIMEN = 1 (il y a un seul second membre), */
8503/* NORMAX peut etre pris quelconque >= NORDRE. */
8504
8505/* Pour utiliser cette routine, il est conseille de se */
8506/* servir de l'une des interfaces : MMRSLWI ou de MMMRSLWD. */
8507
8508/* HISTORIQUE DES MODIFICATIONS : */
8509/* -------------------------------- */
8510/* 24-11-1995 : JPI ; annulation des modifs concernant la factorisation
8511*/
8512/* de 1/PIVOT (Pb numerique) */
8513/* 08-09-1995 : JMF ; performances */
8514/* 06-04-1990 : RBD ; Ajout commentaires et Implicit none. */
8515/* 22-02-1988 : JJM ; Appel MFNDEB -> MNFNDEB */
8516/* 22-02-1988 : JJM ; Appel GERMSG -> MAERMSG */
8517/* 21-09-1987 : creation de la matrice unique ABMATR et des */
8518/* interfaces MMRSLWI et MMMRSLWD (RBD). */
8519/* 01-07-1987 : Cree par R. Beraud. */
8520/* > */
8521/* **********************************************************************
8522*/
8523
8524/* Le nom de la routine */
8525
8526/* INTEGER IBB,MNFNDEB */
8527
8528/* IBB=MNFNDEB() */
8529/* IF (IBB.GE.2) CALL MGENMSG(NOMPR) */
8530 /* Parameter adjustments */
8531 xmatri_dim1 = *normax;
8532 xmatri_offset = xmatri_dim1 + 1;
8533 xmatri -= xmatri_offset;
8534 abmatr_dim1 = *nordre + *ndimen;
8535 abmatr_offset = abmatr_dim1 + 1;
8536 abmatr -= abmatr_offset;
8537
8538 /* Function Body */
8539 *iercod = 0;
8540
8541/* *********************************************************************
8542*/
8543/* Triangulation de la matrice ABMATR. */
8544/* *********************************************************************
8545*/
8546
8547 i__1 = *nordre;
8548 for (kk = 1; kk <= i__1; ++kk) {
8549
8550/* ---------- Recherche du pivot maxi sur la colonne KK. ------------
8551--- */
8552
8553 pivot = *epspiv;
8554 kpiv = 0;
8555 i__2 = *nordre;
8556 for (jj = kk; jj <= i__2; ++jj) {
8557 akj = (d__1 = abmatr[kk + jj * abmatr_dim1], abs(d__1));
8558 if (akj > pivot) {
8559 pivot = akj;
8560 kpiv = jj;
8561 }
8562/* L100: */
8563 }
8564 if (kpiv == 0) {
8565 goto L9900;
8566 }
8567
8568/* --------- Permutation de la ligne KPIV et avec la ligne KK. ------
8569--- */
8570
8571 if (kpiv != kk) {
8572 i__2 = *nordre + *ndimen;
8573 for (jj = kk; jj <= i__2; ++jj) {
8574 akj = abmatr[jj + kk * abmatr_dim1];
8575 abmatr[jj + kk * abmatr_dim1] = abmatr[jj + kpiv *
8576 abmatr_dim1];
8577 abmatr[jj + kpiv * abmatr_dim1] = akj;
8578/* L200: */
8579 }
8580 }
8581
8582/* -------------------- Elimination et triangularisation. -----------
8583--- */
8584
8585 pivot = -abmatr[kk + kk * abmatr_dim1];
8586 i__2 = *nordre;
8587 for (ii = kk + 1; ii <= i__2; ++ii) {
8588 akj = abmatr[kk + ii * abmatr_dim1] / pivot;
8589 i__3 = *nordre + *ndimen;
8590 for (jj = kk + 1; jj <= i__3; ++jj) {
8591 abmatr[jj + ii * abmatr_dim1] += akj * abmatr[jj + kk *
8592 abmatr_dim1];
8593/* L400: */
8594 }
8595/* L300: */
8596 }
8597
8598
8599/* L1000: */
8600 }
8601
8602/* *********************************************************************
8603*/
8604/* Resolution du systeme d'equations triangulaires. */
8605/* La matrice ABMATR(NORDRE+JJ,II), contient les second membres du */
8606/* systeme pour 1<=j<=NDIMEN et 1<=i<=NORDRE. */
8607/* *********************************************************************
8608*/
8609
8610
8611/* ---------------- Calcul des solutions en remontant. -----------------
8612*/
8613
8614 for (kk = *nordre; kk >= 1; --kk) {
8615 pivot = abmatr[kk + kk * abmatr_dim1];
8616 i__1 = *ndimen;
8617 for (ii = 1; ii <= i__1; ++ii) {
8618 akj = abmatr[ii + *nordre + kk * abmatr_dim1];
8619 i__2 = *nordre;
8620 for (jj = kk + 1; jj <= i__2; ++jj) {
8621 akj -= abmatr[jj + kk * abmatr_dim1] * xmatri[jj + ii *
8622 xmatri_dim1];
8623/* L800: */
8624 }
8625 xmatri[kk + ii * xmatri_dim1] = akj / pivot;
8626/* L700: */
8627 }
8628/* L600: */
8629 }
8630 goto L9999;
8631
8632/* ------Si la valeur absolue de l' un des pivot est plus petit --------
8633*/
8634/* ------------ que EPSPIV: recuperation du code d' erreur. ------------
8635*/
8636
8637L9900:
8638 *iercod = 1;
8639
8640
8641
8642L9999:
8643 if (*iercod > 0) {
8644 AdvApp2Var_SysBase::maermsg_("MMRSLW ", iercod, 7L);
8645 }
8646/* IF (IBB.GE.2) CALL MGSOMSG(NOMPR) */
8647 return 0 ;
8648} /* mmrslw_ */
8649
8650//=======================================================================
8651//function : AdvApp2Var_MathBase::mmmrslwd_
8652//purpose :
8653//=======================================================================
8654 int AdvApp2Var_MathBase::mmmrslwd_(integer *normax,
8655 integer *nordre,
8656 integer *ndim,
8657 doublereal *amat,
8658 doublereal *bmat,
8659 doublereal *epspiv,
8660 doublereal *aaux,
8661 doublereal *xmat,
8662 integer *iercod)
8663
8664{
8665 /* System generated locals */
8666 integer amat_dim1, amat_offset, bmat_dim1, bmat_offset, xmat_dim1,
8667 xmat_offset, aaux_dim1, aaux_offset, i__1, i__2;
8668
8669 /* Local variables */
8670 static integer i__, j;
8671 static integer ibb;
8672
8673/* IMPLICIT DOUBLE PRECISION (A-H,O-Z) */
8674/* IMPLICIT INTEGER (I-N) */
8675
8676
8677/* **********************************************************************
8678*/
8679
8680/* FONCTION : */
8681/* ---------- */
8682/* Resolution d' un systeme lineaire par la methode de Gauss ou */
8683/* le second membre est un tableau de vecteurs. Methode du pivot */
8684/* partiel. */
8685
8686/* MOTS CLES : */
8687/* ----------- */
8688/* TOUS , MATH_ACCES :: */
8689/* SYSTEME&,EQUATION&, RESOLUTION,GAUSS ,&VECTEUR */
8690
8691/* ARGUMENTS D'ENTREE : */
8692/* ------------------ */
8693/* NORMAX : Dimensionnement maxi de AMAT. */
8694/* NORDRE : Ordre de la matrice. */
8695/* NDIM : Nombre de colonnes de BMAT et XMAT. */
8696/* AMAT(NORMAX,NORDRE) : La matrice traitee. */
8697/* BMAT(NORMAX,NDIM) : La matrice des second membre. */
8698/* XMAT(NORMAX,NDIM) : La matrice des solutions. */
8699/* EPSPIV : Valeur minimale d'un pivot. */
8700
8701/* ARGUMENTS DE SORTIE : */
8702/* ------------------- */
8703/* AAUX(NORDRE+NDIM,NORDRE) : Matrice auxiliaire. */
8704/* XMAT(NORMAX,NDIM) : La matrice des solutions. */
8705/* IERCOD=0 indique que les solutions dans XMAT sont valables. */
8706/* IERCOD=1 indique que la matrice AMAT est de rang inferieur */
8707/* a NORDRE. */
8708
8709/* COMMONS UTILISES : */
8710/* ---------------- */
8711
8712/* .Neant. */
8713
8714/* REFERENCES APPELEES : */
8715/* ---------------------- */
8716/* Type Name */
8717/* MAERMSG MGENMSG MGSOMSG */
8718/* MMRSLW I*4 MNFNDEB */
8719
8720/* DESCRIPTION/REMARQUES/LIMITATIONS : */
8721/* ----------------------------------- */
8722/* ATTENTION :les lignes et les colonnes sont dans l' ordre */
8723/* habituel : */
8724/* 1er indice = indice ligne */
8725/* 2eme indice = indice colonne */
8726/* Exemple, Le systeme : */
8727/* a1*x + b1*y = c1 */
8728/* a2*x + b2*y = c2 */
8729/* est represente par la matrice AMAT : */
8730
8731/* AMAT(1,1) = a1 AMAT(2,1) = a2 */
8732/* AMAT(1,2) = b1 AMAT(2,2) = b2 */
8733
8734/* Le premier indice est l' indice de ligne, le second indice */
8735/* est l' indice des colonnes (Comparer avec MMRSLWI qui est */
8736/* plus rapide). */
8737
8738/* $ HISTORIQUE DES MODIFICATIONS : */
8739/* -------------------------------- */
8740/* 11-09-1995 : JMF ; Implicit none */
8741/* 22-02-1988 : JJM ; Appel MFNDEB -> MNFNDEB */
8742/* 22-02-1988 : JJM ; Appel GERMSG -> MAERMSG */
8743/* 17-09-1987: Cree par RBD */
8744/* > */
8745/* **********************************************************************
8746*/
8747
8748/* Le nom de la routine */
8749
8750 /* Parameter adjustments */
8751 amat_dim1 = *normax;
8752 amat_offset = amat_dim1 + 1;
8753 amat -= amat_offset;
8754 xmat_dim1 = *normax;
8755 xmat_offset = xmat_dim1 + 1;
8756 xmat -= xmat_offset;
8757 aaux_dim1 = *nordre + *ndim;
8758 aaux_offset = aaux_dim1 + 1;
8759 aaux -= aaux_offset;
8760 bmat_dim1 = *normax;
8761 bmat_offset = bmat_dim1 + 1;
8762 bmat -= bmat_offset;
8763
8764 /* Function Body */
8765 ibb = AdvApp2Var_SysBase::mnfndeb_();
8766 if (ibb >= 3) {
8767 AdvApp2Var_SysBase::mgenmsg_("MMMRSLW", 7L);
8768 }
8769
8770/* Initialisation de la matrice auxiliaire. */
8771
8772 i__1 = *nordre;
8773 for (i__ = 1; i__ <= i__1; ++i__) {
8774 i__2 = *nordre;
8775 for (j = 1; j <= i__2; ++j) {
8776 aaux[j + i__ * aaux_dim1] = amat[i__ + j * amat_dim1];
8777/* L200: */
8778 }
8779/* L100: */
8780 }
8781
8782/* Second membre. */
8783
8784 i__1 = *nordre;
8785 for (i__ = 1; i__ <= i__1; ++i__) {
8786 i__2 = *ndim;
8787 for (j = 1; j <= i__2; ++j) {
8788 aaux[j + *nordre + i__ * aaux_dim1] = bmat[i__ + j * bmat_dim1];
8789/* L400: */
8790 }
8791/* L300: */
8792 }
8793
8794/* Resolution du systeme d' equations. */
8795
8796 mmrslw_(normax, nordre, ndim, epspiv, &aaux[aaux_offset], &xmat[
8797 xmat_offset], iercod);
8798
8799
8800 if (*iercod != 0) {
8801 AdvApp2Var_SysBase::maermsg_("MMMRSLW", iercod, 7L);
8802 }
8803 if (ibb >= 3) {
8804 AdvApp2Var_SysBase::mgsomsg_("MMMRSLW", 7L);
8805 }
8806 return 0 ;
8807} /* mmmrslwd_ */
8808
8809//=======================================================================
8810//function : AdvApp2Var_MathBase::mmrtptt_
8811//purpose :
8812//=======================================================================
8813 int AdvApp2Var_MathBase::mmrtptt_(integer *ndglgd,
8814 doublereal *rtlegd)
8815
8816{
8817 static integer ideb, nmod2, nsur2, ilong, ibb;
8818
8819
8820/* **********************************************************************
8821*/
8822
8823/* FONCTION : */
8824/* ---------- */
8825/* Extrait du Common LDGRTL les racines STRICTEMENT positives du */
8826/* polynome de Legendre de degre NDGLGD, pour 2 <= NDGLGD <= 61. */
8827
8828/* MOTS CLES : */
8829/* ----------- */
8830/* TOUS, AB_SPECIFI::COMMON&, EXTRACTION, &RACINE, &LEGENDRE. */
8831
8832/* ARGUMENTS D'ENTREE : */
8833/* ------------------ */
8834/* NDGLGD : Degre mathematique du polynome de Legendre. */
8835/* Ce degre doit etre superieur ou egal a 2 et */
8836/* inferieur ou egal a 61. */
8837
8838/* ARGUMENTS DE SORTIE : */
8839/* ------------------- */
8840/* RTLEGD : Le tableau des racines strictement positives du */
8841/* polynome de Legendre de degre NDGLGD. */
8842
8843/* COMMONS UTILISES : */
8844/* ---------------- */
8845
8846/* REFERENCES APPELEES : */
8847/* ----------------------- */
8848
8849/* DESCRIPTION/REMARQUES/LIMITATIONS : */
8850/* ----------------------------------- */
8851/* ATTENTION: La condition sur NDEGRE ( 2 <= NDEGRE <= 61) n'est */
8852/* pas testee. A l'appelant de faire le test. */
8853
8854/* $ HISTORIQUE DES MODIFICATIONS : */
8855/* -------------------------------- */
8856/* 23-03-1990 : RBD ; Ajout commentaires + declaration. */
8857/* 15-01-1990 : NAK ; MLGDRTL PAR INCLUDE MMLGDRT */
8858/* 21-04-1989 : RBD ; Creation. */
8859/* > */
8860/* **********************************************************************
8861*/
8862/* Le nom de la routine */
8863
8864
8865/* Le common MLGDRTL: */
8866/* Ce common comprend les racines POSITIVES des polynomes de Legendre */
8867/* ET les poids des formules de quadrature de Gauss sur toutes les */
8868/* racines POSITIVES des polynomes de Legendre. */
8869
8870
8871/* ***********************************************************************
8872 */
8873
8874/* FONCTION : */
8875/* ---------- */
8876/* Le common des racines de Legendre. */
8877
8878/* MOTS CLES : */
8879/* ----------- */
8880/* BASE LEGENDRE */
8881
8882/* DEMSCRIPTION/REMARQUES/LIMITATIONS : */
8883/* ----------------------------------- */
8884
8885/* $ HISTORIQUE DES MODIFICATIONS : */
8886/* ------------------------------ */
8887/* 11-01-90 : NAK ; Creation version originale */
8888/* > */
8889/* ***********************************************************************
8890 */
8891
8892
8893
8894
8895/* ROOTAB : Tableau de toutes les racines des polynomes de Legendre */
8896/* comprises entre ]0,1]. Elles sont rangees pour des degres croissants
8897*/
8898/* de 2 a 61. */
8899/* HILTAB : Tableau des interpolants de Legendre concernant ROOTAB. */
8900/* L' adressage est le meme. */
8901/* HI0TAB : Tableau des interpolants de Legendre pour la racine x=0 */
8902/* des polynomes de degre IMPAIR. */
8903/* RTLTB0 : Tableau des Li(uk) ou les uk sont les racines d' un */
8904/* polynome de Legendre de degre PAIR. */
8905/* RTLTB1 : Tableau des Li(uk) ou les uk sont les racines d' un */
8906/* polynome de Legendre de degre IMPAIR. */
8907
8908
8909/************************************************************************
8910*****/
8911 /* Parameter adjustments */
8912 --rtlegd;
8913
8914 /* Function Body */
8915 ibb = AdvApp2Var_SysBase::mnfndeb_();
8916 if (ibb >= 3) {
8917 AdvApp2Var_SysBase::mgenmsg_("MMRTPTT", 7L);
8918 }
8919 if (*ndglgd < 2) {
8920 goto L9999;
8921 }
8922
8923 nsur2 = *ndglgd / 2;
8924 nmod2 = *ndglgd % 2;
8925
8926 ilong = nsur2 << 3;
8927 ideb = nsur2 * (nsur2 - 1) / 2 + 1;
8928 AdvApp2Var_SysBase::mcrfill_((integer *)&ilong,
8929 (char *)&mlgdrtl_.rootab[ideb + nmod2 * 465 - 1],
8930 (char *)&rtlegd[1]);
8931
8932/* ----------------------------- The end --------------------------------
8933*/
8934
8935L9999:
8936 if (ibb >= 3) {
8937 AdvApp2Var_SysBase::mgsomsg_("MMRTPTT", 7L);
8938 }
8939 return 0;
8940} /* mmrtptt_ */
8941
8942//=======================================================================
8943//function : AdvApp2Var_MathBase::mmsrre2_
8944//purpose :
8945//=======================================================================
8946 int AdvApp2Var_MathBase::mmsrre2_(doublereal *tparam,
8947 integer *nbrval,
8948 doublereal *tablev,
8949 doublereal *epsil,
8950 integer *numint,
8951 integer *itypen,
8952 integer *iercod)
8953{
8954 /* System generated locals */
8955 doublereal d__1;
8956
8957 /* Local variables */
8958 static integer ideb, ifin, imil, ibb;
8959
8960/* ***********************************************************************
8961 */
8962
8963/* FONCTION : */
8964/* -------- */
8965
8966/* Recherche l'intervalle correspondant a une valeur donnee dans */
8967/* une suite croissante de reels double precision. */
8968
8969/* MOTS CLES : */
8970/* --------- */
8971/* TOUS,MATH_ACCES::TABLEAU&,POINT&,CORRESPONDANCE,&RANG */
8972
8973/* ARGUMENTS D'ENTREE : */
8974/* ------------------ */
8975
8976/* TPARAM : Valeur a tester. */
8977/* NBRVAL : Taille de TABLEV */
8978/* TABLEV : Tableau de reels. */
8979/* EPSIL : Epsilon de precision */
8980
8981/* ARGUMENTS DE SORTIE : */
8982/* ------------------- */
8983
8984/* NUMINT : Numero de l'intervalle (entre 1 et NBRVAL-1). */
8985/* ITYPEN : = 0 TPARAM est a l'interieur de l'intervalle NUMINT */
8986/* = 1 : TPARAM correspond a la borne inferieure de */
8987/* l'intervalle fourni. */
8988/* = 2 : TPARAM correspond a la borne superieure de */
8989/* l'intervalle fourni. */
8990
8991/* IERCOD : Code d'erreur */
8992/* = 0 : OK */
8993/* = 1 : TABLEV ne contient pas assez d' elements. */
8994/* = 2 : TPARAM hors des bornes de TABLEV. */
8995
8996/* COMMONS UTILISES : */
8997/* ---------------- */
8998
8999/* REFERENCES APPELEES : */
9000/* ------------------- */
9001
9002/* DESCRIPTION/REMARQUES/LIMITATIONS : */
9003/* --------------------------------- */
9004/* Il y a NBRVAL valeurs dans TABLEV soit NBRVAL-1 intervalles. */
9005/* On fait une recherche de l' intervalle contenant TPARAM par */
9006/* dichotomie. Complexite de l' algorithme : Log(n)/Log(2).(RBD). */
9007
9008
9009/* $ HISTORIQUE DES MODIFICATIONS : */
9010/* ---------------------------- */
9011/* 13-07-93 : MCL ; Version originale (a partir de MSRREI) */
9012/* > */
9013/* ***********************************************************************
9014 */
9015
9016
9017/* Initialisations */
9018
9019 /* Parameter adjustments */
9020 --tablev;
9021
9022 /* Function Body */
9023 ibb = AdvApp2Var_SysBase::mnfndeb_();
9024 if (ibb >= 6) {
9025 AdvApp2Var_SysBase::mgenmsg_("MMSRRE2", 7L);
9026 }
9027
9028 *iercod = 0;
9029 *numint = 0;
9030 *itypen = 0;
9031 ideb = 1;
9032 ifin = *nbrval;
9033
9034/* TABLEV doit contenir au moins deux valeurs */
9035
9036 if (*nbrval < 2) {
9037 *iercod = 1;
9038 goto L9999;
9039 }
9040
9041/* TPARAM doit etre entre les bornes extremes de TABLEV. */
9042
9043 if (*tparam < tablev[1] || *tparam > tablev[*nbrval]) {
9044 *iercod = 2;
9045 goto L9999;
9046 }
9047
9048/* ----------------------- RECHERCHE DE L'INTERVALLE --------------------
9049*/
9050
9051L1000:
9052
9053/* Test de fin de boucle (on a trouve). */
9054
9055 if (ideb + 1 == ifin) {
9056 *numint = ideb;
9057 goto L2000;
9058 }
9059
9060/* Recherche par dichotomie sur les valeurs croissantes de TABLEV. */
9061
9062 imil = (ideb + ifin) / 2;
9063 if (*tparam >= tablev[ideb] && *tparam <= tablev[imil]) {
9064 ifin = imil;
9065 } else {
9066 ideb = imil;
9067 }
9068
9069 goto L1000;
9070
9071/* -------------- TEST POUR VOIR SI TPARAM N'EST PAS UNE VALEUR ---------
9072*/
9073/* ------------------------ DE TABLEV A EPSIL PRES ----------------------
9074*/
9075
9076L2000:
9077 if ((d__1 = *tparam - tablev[ideb], abs(d__1)) < *epsil) {
9078 *itypen = 1;
9079 goto L9999;
9080 }
9081 if ((d__1 = *tparam - tablev[ifin], abs(d__1)) < *epsil) {
9082 *itypen = 2;
9083 goto L9999;
9084 }
9085
9086/* --------------------------- THE END ----------------------------------
9087*/
9088
9089L9999:
9090 if (*iercod > 0) {
9091 AdvApp2Var_SysBase::maermsg_("MMSRRE2", iercod, 7L);
9092 }
9093 if (ibb >= 6) {
9094 AdvApp2Var_SysBase::mgsomsg_("MMSRRE2", 7L);
9095 }
9096 return 0 ;
9097} /* mmsrre2_ */
9098
9099//=======================================================================
9100//function : mmtmave_
9101//purpose :
9102//=======================================================================
9103int mmtmave_(integer *nligne,
9104 integer *ncolon,
9105 integer *gposit,
9106 integer *,//gnstoc,
9107 doublereal *gmatri,
9108 doublereal *vecin,
9109 doublereal *vecout,
9110 integer *iercod)
9111
9112{
9113 /* System generated locals */
9114 integer i__1, i__2;
9115
9116 /* Local variables */
9117 static logical ldbg;
9118 static integer imin, imax, i__, j, k;
9119 static doublereal somme;
9120 static integer aux;
9121
9122
9123/* ***********************************************************************
9124 */
9125
9126/* FONCTION : */
9127/* ---------- */
9128/* t */
9129/* EFFECUE LE PRODUIT G V */
9130/* OU LA MATRICE G EST SOUS FORME DE PROFIL */
9131
9132/* MOTS CLES : */
9133/* ----------- */
9134/* RESERVE, PRODUIT, MATRICE, PROFIL, VECTEUR */
9135
9136/* ARGUMENTS D'ENTREE : */
9137/* -------------------- */
9138/* NLIGNE : NOMBRE DE LIGNE DE LA MATRICE */
9139/* NCOLON : NOMBRE DE COLONNE DE LA MATRICE */
9140/* GPOSIT: TABLE DE POSITIONNEMENT DES TERMES DE STOCKAGE */
9141/* GPOSIT(1,I) CONTIENT LE NOMBRE DE TERMES-1 SUR LA LIGNE
9142*/
9143/* I DANS LE PROFIL DE LA MATRICE */
9144/* GPOSIT(2,I) CONTIENT L'INDICE DE STOCKAGE DU TERME DIAGONA
9145L*/
9146/* DE LA LIGNE I */
9147/* GPOSIT(3,I) CONTIENT L'INDICE COLONE DU PREMIER TERME DU
9148*/
9149/* PROFIL DE LA LIGNE I */
9150/* GNSTOC : NOMBRE DE TERME DANS LE PROFIL DE GMATRI */
9151/* GMATRI : MATRICE DES CONTRAINTES SOUS FORME DE PROFIL */
9152/* VECIN : VECTEUR D'ENTRE */
9153
9154/* ARGUMENTS DE SORTIE : */
9155/* --------------------- */
9156/* VECOUT :VECTEUR PRODUIT */
9157/* IERCOD : CODE D'ERREUR */
9158
9159
9160/* COMMONS UTILISES : */
9161/* ------------------ */
9162
9163
9164/* REFERENCES APPELEES : */
9165/* --------------------- */
9166
9167
9168/* DESCRIPTION/REMARQUES/LIMITATIONS : */
9169/* ----------------------------------- */
9170
9171
9172/* $ HISTORIQUE DES MODIFICATIONS : */
9173/* ------------------------------ */
9174/* 21-08-95 : KHN; ECRITURE VERSION ORIGINALE. */
9175/* > */
9176/* ***********************************************************************
9177 */
9178/* DECLARATIONS */
9179/* ***********************************************************************
9180 */
9181
9182
9183
9184/* ***********************************************************************
9185 */
9186/* INITIALISATIONS */
9187/* ***********************************************************************
9188 */
9189
9190 /* Parameter adjustments */
9191 --vecin;
9192 gposit -= 4;
9193 --vecout;
9194 --gmatri;
9195
9196 /* Function Body */
9197 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 2;
9198 if (ldbg) {
9199 AdvApp2Var_SysBase::mgenmsg_("MMTMAVE", 7L);
9200 }
9201 *iercod = 0;
9202
9203/* ***********************************************************************
9204 */
9205/* TRAITEMENT */
9206/* ***********************************************************************
9207 */
9208
9209
9210
9211 i__1 = *ncolon;
9212 for (i__ = 1; i__ <= i__1; ++i__) {
9213 somme = 0.;
9214 i__2 = *nligne;
9215 for (j = 1; j <= i__2; ++j) {
9216 imin = gposit[j * 3 + 3];
9217 imax = gposit[j * 3 + 1] + gposit[j * 3 + 3] - 1;
9218 aux = gposit[j * 3 + 2] - gposit[j * 3 + 1] - imin + 1;
9219 if (imin <= i__ && i__ <= imax) {
9220 k = i__ + aux;
9221 somme += gmatri[k] * vecin[j];
9222 }
9223 }
9224 vecout[i__] = somme;
9225 }
9226
9227
9228
9229
9230
9231 goto L9999;
9232
9233/* ***********************************************************************
9234 */
9235/* TRAITEMENT DES ERREURS */
9236/* ***********************************************************************
9237 */
9238
9239
9240/* ***********************************************************************
9241 */
9242/* RETOUR PROGRAMME APPELANT */
9243/* ***********************************************************************
9244 */
9245
9246L9999:
9247
9248/* ___ DESALLOCATION, ... */
9249
9250 AdvApp2Var_SysBase::maermsg_("MMTMAVE", iercod, 7L);
9251 if (ldbg) {
9252 AdvApp2Var_SysBase::mgsomsg_("MMTMAVE", 7L);
9253 }
9254 return 0 ;
9255} /* mmtmave_ */
9256
9257//=======================================================================
9258//function : mmtrpj0_
9259//purpose :
9260//=======================================================================
9261int mmtrpj0_(integer *ncofmx,
9262 integer *ndimen,
9263 integer *ncoeff,
9264 doublereal *epsi3d,
9265 doublereal *crvlgd,
9266 doublereal *ycvmax,
9267 doublereal *epstrc,
9268 integer *ncfnew)
9269
9270{
9271 /* System generated locals */
9272 integer crvlgd_dim1, crvlgd_offset, i__1, i__2;
9273 doublereal d__1;
9274
9275 /* Local variables */
9276 static integer ncut, i__;
9277 static doublereal bidon, error;
9278 static integer nd;
9279
9280
9281/* ***********************************************************************
9282 */
9283
9284/* FONCTION : */
9285/* ---------- */
9286/* Baisse le degre d' une courbe definie sur (-1,1) au sens de */
9287/* Legendre a une precision donnee. */
9288
9289/* MOTS CLES : */
9290/* ----------- */
9291/* LEGENDRE,POLYGONE,TRONCONNAGE,COURBE,LISSAGE. */
9292
9293/* ARGUMENTS D'ENTREE : */
9294/* ------------------ */
9295/* NCOFMX : Nbre maxi de coeff. de la courbe (dimensionnement). */
9296/* NDIMEN : Dimension de l' espace. */
9297/* NCOEFF : Le degre +1 du polynome. */
9298/* EPSI3D : La precision demandee pour l' approximation. */
9299/* CRVLGD : La courbe dont on veut baisser le degre. */
9300
9301/* ARGUMENTS DE SORTIE : */
9302/* ------------------- */
9303/* EPSTRC : La precision de l' approximation. */
9304/* NCFNEW : Le degre +1 du polynome resultat. */
9305
9306/* COMMONS UTILISES : */
9307/* ---------------- */
9308
9309/* REFERENCES APPELEES : */
9310/* ----------------------- */
9311
9312/* DESCRIPTION/REMARQUES/LIMITATIONS : */
9313/* ----------------------------------- */
9314
9315/* $ HISTORIQUE DES MODIFICATIONS : */
9316/* -------------------------------- */
9317/* 17-05-1991 : RBD ; Si le degre n'est pas baisse, l'erreur est nulle */
9318/* 12-12-1989 : RBD ; Creation. */
9319/* > */
9320/* ***********************************************************************
9321 */
9322
9323
9324/* ------- Degre minimum pouvant etre atteint : Arret a 1 (RBD) ---------
9325*/
9326
9327 /* Parameter adjustments */
9328 --ycvmax;
9329 crvlgd_dim1 = *ncofmx;
9330 crvlgd_offset = crvlgd_dim1 + 1;
9331 crvlgd -= crvlgd_offset;
9332
9333 /* Function Body */
9334 *ncfnew = 1;
9335/* ------------------- Init pour calcul d' erreur -----------------------
9336*/
9337 i__1 = *ndimen;
9338 for (i__ = 1; i__ <= i__1; ++i__) {
9339 ycvmax[i__] = 0.;
9340/* L100: */
9341 }
9342 *epstrc = 0.;
9343 error = 0.;
9344
9345/* Coupure des coefficients. */
9346
9347 ncut = 2;
9348/* ------ Boucle sur la serie de Legendre :NCOEFF --> 2 (RBD) -----------
9349*/
9350 i__1 = ncut;
9351 for (i__ = *ncoeff; i__ >= i__1; --i__) {
9352/* Facteur de renormalisation. */
9353 bidon = ((i__ - 1) * 2. + 1.) / 2.;
9354 bidon = sqrt(bidon);
9355 i__2 = *ndimen;
9356 for (nd = 1; nd <= i__2; ++nd) {
9357 ycvmax[nd] += (d__1 = crvlgd[i__ + nd * crvlgd_dim1], abs(d__1)) *
9358 bidon;
9359/* L310: */
9360 }
9361/* On arrete de couper si la norme devient trop grande. */
9362 error = AdvApp2Var_MathBase::mzsnorm_(ndimen, &ycvmax[1]);
9363 if (error > *epsi3d) {
9364 *ncfnew = i__;
9365 goto L9999;
9366 }
9367
9368/* --- Erreur max cumulee lorsque le I-eme coeff est ote. */
9369
9370 *epstrc = error;
9371
9372/* L300: */
9373 }
9374
9375/* --------------------------------- Fin --------------------------------
9376*/
9377
9378L9999:
9379 return 0;
9380} /* mmtrpj0_ */
9381
9382//=======================================================================
9383//function : mmtrpj2_
9384//purpose :
9385//=======================================================================
9386int mmtrpj2_(integer *ncofmx,
9387 integer *ndimen,
9388 integer *ncoeff,
9389 doublereal *epsi3d,
9390 doublereal *crvlgd,
9391 doublereal *ycvmax,
9392 doublereal *epstrc,
9393 integer *ncfnew)
9394
9395{
9396 /* Initialized data */
9397
9398 static doublereal xmaxj[57] = { .9682458365518542212948163499456,
9399 .986013297183269340427888048593603,
9400 1.07810420343739860362585159028115,
9401 1.17325804490920057010925920756025,
9402 1.26476561266905634732910520370741,
9403 1.35169950227289626684434056681946,
9404 1.43424378958284137759129885012494,
9405 1.51281316274895465689402798226634,
9406 1.5878364329591908800533936587012,
9407 1.65970112228228167018443636171226,
9408 1.72874345388622461848433443013543,
9409 1.7952515611463877544077632304216,
9410 1.85947199025328260370244491818047,
9411 1.92161634324190018916351663207101,
9412 1.98186713586472025397859895825157,
9413 2.04038269834980146276967984252188,
9414 2.09730119173852573441223706382076,
9415 2.15274387655763462685970799663412,
9416 2.20681777186342079455059961912859,
9417 2.25961782459354604684402726624239,
9418 2.31122868752403808176824020121524,
9419 2.36172618435386566570998793688131,
9420 2.41117852396114589446497298177554,
9421 2.45964731268663657873849811095449,
9422 2.50718840313973523778244737914028,
9423 2.55385260994795361951813645784034,
9424 2.59968631659221867834697883938297,
9425 2.64473199258285846332860663371298,
9426 2.68902863641518586789566216064557,
9427 2.73261215675199397407027673053895,
9428 2.77551570192374483822124304745691,
9429 2.8177699459714315371037628127545,
9430 2.85940333797200948896046563785957,
9431 2.90044232019793636101516293333324,
9432 2.94091151970640874812265419871976,
9433 2.98083391718088702956696303389061,
9434 3.02023099621926980436221568258656,
9435 3.05912287574998661724731962377847,
9436 3.09752842783622025614245706196447,
9437 3.13546538278134559341444834866301,
9438 3.17295042316122606504398054547289,
9439 3.2099992681699613513775259670214,
9440 3.24662674946606137764916854570219,
9441 3.28284687953866689817670991319787,
9442 3.31867291347259485044591136879087,
9443 3.35411740487202127264475726990106,
9444 3.38919225660177218727305224515862,
9445 3.42390876691942143189170489271753,
9446 3.45827767149820230182596660024454,
9447 3.49230918177808483937957161007792,
9448 3.5260130200285724149540352829756,
9449 3.55939845146044235497103883695448,
9450 3.59247431368364585025958062194665,
9451 3.62524904377393592090180712976368,
9452 3.65773070318071087226169680450936,
9453 3.68992700068237648299565823810245,
9454 3.72184531357268220291630708234186 };
9455
9456 /* System generated locals */
9457 integer crvlgd_dim1, crvlgd_offset, i__1, i__2;
9458 doublereal d__1;
9459
9460 /* Local variables */
9461 static integer ncut, i__;
9462 static doublereal bidon, error;
9463 static integer ia, nd;
9464 static doublereal bid, eps1;
9465
9466
9467/* ***********************************************************************
9468 */
9469
9470/* FONCTION : */
9471/* ---------- */
9472/* Baisse le degre d' une courbe definie sur (-1,1) au sens de */
9473/* Legendre a une precision donnee. */
9474
9475/* MOTS CLES : */
9476/* ----------- */
9477/* LEGENDRE,POLYGONE,TRONCONNAGE,COURBE,LISSAGE. */
9478
9479/* ARGUMENTS D'ENTREE : */
9480/* ------------------ */
9481/* NCOFMX : Nbre maxi de coeff. de la courbe (dimensionnement). */
9482/* NDIMEN : Dimension de l' espace. */
9483/* NCOEFF : Le degre +1 du polynome. */
9484/* EPSI3D : La precision demandee pour l' approximation. */
9485/* CRVLGD : La courbe dont on veut baisser le degre. */
9486
9487/* ARGUMENTS DE SORTIE : */
9488/* ------------------- */
9489/* YCVMAX : Tableau auxiliaire (erreur max sur chaque dimension).
9490*/
9491/* EPSTRC : La precision de l' approximation. */
9492/* NCFNEW : Le degre +1 du polynome resultat. */
9493
9494/* COMMONS UTILISES : */
9495/* ---------------- */
9496
9497/* REFERENCES APPELEES : */
9498/* ----------------------- */
9499
9500/* DESCRIPTION/REMARQUES/LIMITATIONS : */
9501/* ----------------------------------- */
9502
9503/* $ HISTORIQUE DES MODIFICATIONS : */
9504/* -------------------------------- */
9505/* 17-05-1991 : RBD ; Si le degre n'est pas baisse, l'erreur est nulle */
9506/* 15-01-1991 : RBD ; Correction coupure des coeff. nuls du polynome */
9507/* d' interpolation. */
9508/* 12-12-1989 : RBD ; Creation. */
9509
9510/* > */
9511/* ***********************************************************************
9512 */
9513
9514
9515 /* Parameter adjustments */
9516 --ycvmax;
9517 crvlgd_dim1 = *ncofmx;
9518 crvlgd_offset = crvlgd_dim1 + 1;
9519 crvlgd -= crvlgd_offset;
9520
9521 /* Function Body */
9522
9523
9524
9525/* Degre minimum pouvant etre atteint : Arret a IA (RBD). -------------
9526*/
9527 ia = 2;
9528 *ncfnew = ia;
9529/* Init pour calcul d' erreur. */
9530 i__1 = *ndimen;
9531 for (i__ = 1; i__ <= i__1; ++i__) {
9532 ycvmax[i__] = 0.;
9533/* L100: */
9534 }
9535 *epstrc = 0.;
9536 error = 0.;
9537
9538/* Coupure des coefficients. */
9539
9540 ncut = ia + 1;
9541/* ------ Boucle sur la serie de Jacobi :NCOEFF --> IA+1 (RBD) ----------
9542*/
9543 i__1 = ncut;
9544 for (i__ = *ncoeff; i__ >= i__1; --i__) {
9545/* Facteur de renormalisation. */
9546 bidon = xmaxj[i__ - ncut];
9547 i__2 = *ndimen;
9548 for (nd = 1; nd <= i__2; ++nd) {
9549 ycvmax[nd] += (d__1 = crvlgd[i__ + nd * crvlgd_dim1], abs(d__1)) *
9550 bidon;
9551/* L310: */
9552 }
9553/* On arrete de couper si la norme devient trop grande. */
9554 error = AdvApp2Var_MathBase::mzsnorm_(ndimen, &ycvmax[1]);
9555 if (error > *epsi3d) {
9556 *ncfnew = i__;
9557 goto L400;
9558 }
9559
9560/* --- Erreur max cumulee lorsque le I-eme coeff est ote. */
9561
9562 *epstrc = error;
9563
9564/* L300: */
9565 }
9566
9567/* ------- Coupure des coeff. nuls du pol. d' interpolation (RBD) -------
9568*/
9569
9570L400:
9571 if (*ncfnew == ia) {
9572 AdvApp2Var_MathBase::mmeps1_(&eps1);
9573 for (i__ = ia; i__ >= 2; --i__) {
9574 bid = 0.;
9575 i__1 = *ndimen;
9576 for (nd = 1; nd <= i__1; ++nd) {
9577 bid += (d__1 = crvlgd[i__ + nd * crvlgd_dim1], abs(d__1));
9578/* L600: */
9579 }
9580 if (bid > eps1) {
9581 *ncfnew = i__;
9582 goto L9999;
9583 }
9584/* L500: */
9585 }
9586/* --- Si tous les coeff peuvent etre otes, c'est un point. */
9587 *ncfnew = 1;
9588 }
9589
9590/* --------------------------------- Fin --------------------------------
9591*/
9592
9593L9999:
9594 return 0;
9595} /* mmtrpj2_ */
9596
9597//=======================================================================
9598//function : mmtrpj4_
9599//purpose :
9600//=======================================================================
9601int mmtrpj4_(integer *ncofmx,
9602 integer *ndimen,
9603 integer *ncoeff,
9604 doublereal *epsi3d,
9605 doublereal *crvlgd,
9606 doublereal *ycvmax,
9607 doublereal *epstrc,
9608 integer *ncfnew)
9609{
9610 /* Initialized data */
9611
9612 static doublereal xmaxj[55] = { 1.1092649593311780079813740546678,
9613 1.05299572648705464724876659688996,
9614 1.0949715351434178709281698645813,
9615 1.15078388379719068145021100764647,
9616 1.2094863084718701596278219811869,
9617 1.26806623151369531323304177532868,
9618 1.32549784426476978866302826176202,
9619 1.38142537365039019558329304432581,
9620 1.43575531950773585146867625840552,
9621 1.48850442653629641402403231015299,
9622 1.53973611681876234549146350844736,
9623 1.58953193485272191557448229046492,
9624 1.63797820416306624705258190017418,
9625 1.68515974143594899185621942934906,
9626 1.73115699602477936547107755854868,
9627 1.77604489805513552087086912113251,
9628 1.81989256661534438347398400420601,
9629 1.86276344480103110090865609776681,
9630 1.90471563564740808542244678597105,
9631 1.94580231994751044968731427898046,
9632 1.98607219357764450634552790950067,
9633 2.02556989246317857340333585562678,
9634 2.06433638992049685189059517340452,
9635 2.10240936014742726236706004607473,
9636 2.13982350649113222745523925190532,
9637 2.17661085564771614285379929798896,
9638 2.21280102016879766322589373557048,
9639 2.2484214321456956597803794333791,
9640 2.28349755104077956674135810027654,
9641 2.31805304852593774867640120860446,
9642 2.35210997297725685169643559615022,
9643 2.38568889602346315560143377261814,
9644 2.41880904328694215730192284109322,
9645 2.45148841120796359750021227795539,
9646 2.48374387161372199992570528025315,
9647 2.5155912654873773953959098501893,
9648 2.54704548720896557684101746505398,
9649 2.57812056037881628390134077704127,
9650 2.60882970619319538196517982945269,
9651 2.63918540521920497868347679257107,
9652 2.66919945330942891495458446613851,
9653 2.69888301230439621709803756505788,
9654 2.72824665609081486737132853370048,
9655 2.75730041251405791603760003778285,
9656 2.78605380158311346185098508516203,
9657 2.81451587035387403267676338931454,
9658 2.84269522483114290814009184272637,
9659 2.87060005919012917988363332454033,
9660 2.89823818258367657739520912946934,
9661 2.92561704377132528239806135133273,
9662 2.95274375377994262301217318010209,
9663 2.97962510678256471794289060402033,
9664 3.00626759936182712291041810228171,
9665 3.03267744830655121818899164295959,
9666 3.05886060707437081434964933864149 };
9667
9668 /* System generated locals */
9669 integer crvlgd_dim1, crvlgd_offset, i__1, i__2;
9670 doublereal d__1;
9671
9672 /* Local variables */
9673 static integer ncut, i__;
9674 static doublereal bidon, error;
9675 static integer ia, nd;
9676 static doublereal bid, eps1;
9677
9678
9679
9680/* ***********************************************************************
9681 */
9682
9683/* FONCTION : */
9684/* ---------- */
9685/* Baisse le degre d' une courbe definie sur (-1,1) au sens de */
9686/* Legendre a une precision donnee. */
9687
9688/* MOTS CLES : */
9689/* ----------- */
9690/* LEGENDRE,POLYGONE,TRONCONNAGE,COURBE,LISSAGE. */
9691
9692/* ARGUMENTS D'ENTREE : */
9693/* ------------------ */
9694/* NCOFMX : Nbre maxi de coeff. de la courbe (dimensionnement). */
9695/* NDIMEN : Dimension de l' espace. */
9696/* NCOEFF : Le degre +1 du polynome. */
9697/* EPSI3D : La precision demandee pour l' approximation. */
9698/* CRVLGD : La courbe dont on veut baisser le degre. */
9699
9700/* ARGUMENTS DE SORTIE : */
9701/* ------------------- */
9702/* YCVMAX : Tableau auxiliaire (erreur max sur chaque dimension).
9703*/
9704/* EPSTRC : La precision de l' approximation. */
9705/* NCFNEW : Le degre +1 du polynome resultat. */
9706
9707/* COMMONS UTILISES : */
9708/* ---------------- */
9709
9710/* REFERENCES APPELEES : */
9711/* ----------------------- */
9712
9713/* DESCRIPTION/REMARQUES/LIMITATIONS : */
9714/* ----------------------------------- */
9715
9716/* $ HISTORIQUE DES MODIFICATIONS : */
9717/* -------------------------------- */
9718/* 17-05-1991 : RBD ; Si le degre n'est pas baisse, l'erreur est nulle */
9719/* 15-01-1991 : RBD ; Correction coupure des coeff. nuls du polynome */
9720/* d' interpolation. */
9721/* 12-12-1989 : RBD ; Creation. */
9722
9723/* > */
9724/* ***********************************************************************
9725 */
9726
9727
9728 /* Parameter adjustments */
9729 --ycvmax;
9730 crvlgd_dim1 = *ncofmx;
9731 crvlgd_offset = crvlgd_dim1 + 1;
9732 crvlgd -= crvlgd_offset;
9733
9734 /* Function Body */
9735
9736
9737
9738/* Degre minimum pouvant etre atteint : Arret a IA (RBD). -------------
9739*/
9740 ia = 4;
9741 *ncfnew = ia;
9742/* Init pour calcul d' erreur. */
9743 i__1 = *ndimen;
9744 for (i__ = 1; i__ <= i__1; ++i__) {
9745 ycvmax[i__] = 0.;
9746/* L100: */
9747 }
9748 *epstrc = 0.;
9749 error = 0.;
9750
9751/* Coupure des coefficients. */
9752
9753 ncut = ia + 1;
9754/* ------ Boucle sur la serie de Jacobi :NCOEFF --> IA+1 (RBD) ----------
9755*/
9756 i__1 = ncut;
9757 for (i__ = *ncoeff; i__ >= i__1; --i__) {
9758/* Facteur de renormalisation. */
9759 bidon = xmaxj[i__ - ncut];
9760 i__2 = *ndimen;
9761 for (nd = 1; nd <= i__2; ++nd) {
9762 ycvmax[nd] += (d__1 = crvlgd[i__ + nd * crvlgd_dim1], abs(d__1)) *
9763 bidon;
9764/* L310: */
9765 }
9766/* On arrete de couper si la norme devient trop grande. */
9767 error = AdvApp2Var_MathBase::mzsnorm_(ndimen, &ycvmax[1]);
9768 if (error > *epsi3d) {
9769 *ncfnew = i__;
9770 goto L400;
9771 }
9772
9773/* --- Erreur max cumulee lorsque le I-eme coeff est ote. */
9774
9775 *epstrc = error;
9776
9777/* L300: */
9778 }
9779
9780/* ------- Coupure des coeff. nuls du pol. d' interpolation (RBD) -------
9781*/
9782
9783L400:
9784 if (*ncfnew == ia) {
9785 AdvApp2Var_MathBase::mmeps1_(&eps1);
9786 for (i__ = ia; i__ >= 2; --i__) {
9787 bid = 0.;
9788 i__1 = *ndimen;
9789 for (nd = 1; nd <= i__1; ++nd) {
9790 bid += (d__1 = crvlgd[i__ + nd * crvlgd_dim1], abs(d__1));
9791/* L600: */
9792 }
9793 if (bid > eps1) {
9794 *ncfnew = i__;
9795 goto L9999;
9796 }
9797/* L500: */
9798 }
9799/* --- Si tous les coeff peuvent etre otes, c'est un point. */
9800 *ncfnew = 1;
9801 }
9802
9803/* --------------------------------- Fin --------------------------------
9804*/
9805
9806L9999:
9807 return 0;
9808} /* mmtrpj4_ */
9809
9810//=======================================================================
9811//function : mmtrpj6_
9812//purpose :
9813//=======================================================================
9814int mmtrpj6_(integer *ncofmx,
9815 integer *ndimen,
9816 integer *ncoeff,
9817 doublereal *epsi3d,
9818 doublereal *crvlgd,
9819 doublereal *ycvmax,
9820 doublereal *epstrc,
9821 integer *ncfnew)
9822
9823{
9824 /* Initialized data */
9825
9826 static doublereal xmaxj[53] = { 1.21091229812484768570102219548814,
9827 1.11626917091567929907256116528817,
9828 1.1327140810290884106278510474203,
9829 1.1679452722668028753522098022171,
9830 1.20910611986279066645602153641334,
9831 1.25228283758701572089625983127043,
9832 1.29591971597287895911380446311508,
9833 1.3393138157481884258308028584917,
9834 1.3821288728999671920677617491385,
9835 1.42420414683357356104823573391816,
9836 1.46546895108549501306970087318319,
9837 1.50590085198398789708599726315869,
9838 1.54550385142820987194251585145013,
9839 1.58429644271680300005206185490937,
9840 1.62230484071440103826322971668038,
9841 1.65955905239130512405565733793667,
9842 1.69609056468292429853775667485212,
9843 1.73193098017228915881592458573809,
9844 1.7671112206990325429863426635397,
9845 1.80166107681586964987277458875667,
9846 1.83560897003644959204940535551721,
9847 1.86898184653271388435058371983316,
9848 1.90180515174518670797686768515502,
9849 1.93410285411785808749237200054739,
9850 1.96589749778987993293150856865539,
9851 1.99721027139062501070081653790635,
9852 2.02806108474738744005306947877164,
9853 2.05846864831762572089033752595401,
9854 2.08845055210580131460156962214748,
9855 2.11802334209486194329576724042253,
9856 2.14720259305166593214642386780469,
9857 2.17600297710595096918495785742803,
9858 2.20443832785205516555772788192013,
9859 2.2325216999457379530416998244706,
9860 2.2602654243075083168599953074345,
9861 2.28768115912702794202525264301585,
9862 2.3147799369092684021274946755348,
9863 2.34157220782483457076721300512406,
9864 2.36806787963276257263034969490066,
9865 2.39427635443992520016789041085844,
9866 2.42020656255081863955040620243062,
9867 2.44586699364757383088888037359254,
9868 2.47126572552427660024678584642791,
9869 2.49641045058324178349347438430311,
9870 2.52130850028451113942299097584818,
9871 2.54596686772399937214920135190177,
9872 2.5703922285006754089328998222275,
9873 2.59459096001908861492582631591134,
9874 2.61856915936049852435394597597773,
9875 2.64233265984385295286445444361827,
9876 2.66588704638685848486056711408168,
9877 2.68923766976735295746679957665724,
9878 2.71238965987606292679677228666411 };
9879
9880 /* System generated locals */
9881 integer crvlgd_dim1, crvlgd_offset, i__1, i__2;
9882 doublereal d__1;
9883
9884 /* Local variables */
9885 static integer ncut, i__;
9886 static doublereal bidon, error;
9887 static integer ia, nd;
9888 static doublereal bid, eps1;
9889
9890
9891
9892/* ***********************************************************************
9893 */
9894
9895/* FONCTION : */
9896/* ---------- */
9897/* Baisse le degre d' une courbe definie sur (-1,1) au sens de */
9898/* Legendre a une precision donnee. */
9899
9900/* MOTS CLES : */
9901/* ----------- */
9902/* LEGENDRE,POLYGONE,TRONCONNAGE,COURBE,LISSAGE. */
9903
9904/* ARGUMENTS D'ENTREE : */
9905/* ------------------ */
9906/* NCOFMX : Nbre maxi de coeff. de la courbe (dimensionnement). */
9907/* NDIMEN : Dimension de l' espace. */
9908/* NCOEFF : Le degre +1 du polynome. */
9909/* EPSI3D : La precision demandee pour l' approximation. */
9910/* CRVLGD : La courbe dont on veut baisser le degre. */
9911
9912/* ARGUMENTS DE SORTIE : */
9913/* ------------------- */
9914/* YCVMAX : Tableau auxiliaire (erreur max sur chaque dimension).
9915*/
9916/* EPSTRC : La precision de l' approximation. */
9917/* NCFNEW : Le degre +1 du polynome resultat. */
9918
9919/* COMMONS UTILISES : */
9920/* ---------------- */
9921
9922/* REFERENCES APPELEES : */
9923/* ----------------------- */
9924
9925/* DESCRIPTION/REMARQUES/LIMITATIONS : */
9926/* ----------------------------------- */
9927
9928/* $ HISTORIQUE DES MODIFICATIONS : */
9929/* -------------------------------- */
9930/* 17-05-1991 : RBD ; Si le degre n'est pas baisse, l'erreur est nulle */
9931/* 15-01-1991 : RBD ; Correction coupure des coeff. nuls du polynome */
9932/* d' interpolation. */
9933/* 12-12-1989 : RBD ; Creation. */
9934
9935/* > */
9936/* ***********************************************************************
9937 */
9938
9939
9940 /* Parameter adjustments */
9941 --ycvmax;
9942 crvlgd_dim1 = *ncofmx;
9943 crvlgd_offset = crvlgd_dim1 + 1;
9944 crvlgd -= crvlgd_offset;
9945
9946 /* Function Body */
9947
9948
9949
9950/* Degre minimum pouvant etre atteint : Arret a IA (RBD). -------------
9951*/
9952 ia = 6;
9953 *ncfnew = ia;
9954/* Init pour calcul d' erreur. */
9955 i__1 = *ndimen;
9956 for (i__ = 1; i__ <= i__1; ++i__) {
9957 ycvmax[i__] = 0.;
9958/* L100: */
9959 }
9960 *epstrc = 0.;
9961 error = 0.;
9962
9963/* Coupure des coefficients. */
9964
9965 ncut = ia + 1;
9966/* ------ Boucle sur la serie de Jacobi :NCOEFF --> IA+1 (RBD) ----------
9967*/
9968 i__1 = ncut;
9969 for (i__ = *ncoeff; i__ >= i__1; --i__) {
9970/* Facteur de renormalisation. */
9971 bidon = xmaxj[i__ - ncut];
9972 i__2 = *ndimen;
9973 for (nd = 1; nd <= i__2; ++nd) {
9974 ycvmax[nd] += (d__1 = crvlgd[i__ + nd * crvlgd_dim1], abs(d__1)) *
9975 bidon;
9976/* L310: */
9977 }
9978/* On arrete de couper si la norme devient trop grande. */
9979 error = AdvApp2Var_MathBase::mzsnorm_(ndimen, &ycvmax[1]);
9980 if (error > *epsi3d) {
9981 *ncfnew = i__;
9982 goto L400;
9983 }
9984
9985/* --- Erreur max cumulee lorsque le I-eme coeff est ote. */
9986
9987 *epstrc = error;
9988
9989/* L300: */
9990 }
9991
9992/* ------- Coupure des coeff. nuls du pol. d' interpolation (RBD) -------
9993*/
9994
9995L400:
9996 if (*ncfnew == ia) {
9997 AdvApp2Var_MathBase::mmeps1_(&eps1);
9998 for (i__ = ia; i__ >= 2; --i__) {
9999 bid = 0.;
10000 i__1 = *ndimen;
10001 for (nd = 1; nd <= i__1; ++nd) {
10002 bid += (d__1 = crvlgd[i__ + nd * crvlgd_dim1], abs(d__1));
10003/* L600: */
10004 }
10005 if (bid > eps1) {
10006 *ncfnew = i__;
10007 goto L9999;
10008 }
10009/* L500: */
10010 }
10011/* --- Si tous les coeff peuvent etre otes, c'est un point. */
10012 *ncfnew = 1;
10013 }
10014
10015/* --------------------------------- Fin --------------------------------
10016*/
10017
10018L9999:
10019 return 0;
10020} /* mmtrpj6_ */
10021
10022//=======================================================================
10023//function : AdvApp2Var_MathBase::mmtrpjj_
10024//purpose :
10025//=======================================================================
10026 int AdvApp2Var_MathBase::mmtrpjj_(integer *ncofmx,
10027 integer *ndimen,
10028 integer *ncoeff,
10029 doublereal *epsi3d,
10030 integer *iordre,
10031 doublereal *crvlgd,
10032 doublereal *ycvmax,
10033 doublereal *errmax,
10034 integer *ncfnew)
10035{
10036 /* System generated locals */
10037 integer crvlgd_dim1, crvlgd_offset;
10038
10039 /* Local variables */
10040 static integer ia;
10041
10042
10043/* ***********************************************************************
10044 */
10045
10046/* FONCTION : */
10047/* ---------- */
10048/* Baisse le degre d' une courbe definie sur (-1,1) au sens de */
10049/* Legendre a une precision donnee. */
10050
10051/* MOTS CLES : */
10052/* ----------- */
10053/* LEGENDRE,POLYGONE,TRONCONNAGE,COURBE,LISSAGE. */
10054
10055/* ARGUMENTS D'ENTREE : */
10056/* ------------------ */
10057/* NCOFMX : Nbre maxi de coeff. de la courbe (dimensionnement). */
10058/* NDIMEN : Dimension de l' espace. */
10059/* NCOEFF : Le degre +1 du polynome. */
10060/* EPSI3D : La precision demandee pour l' approximation. */
10061/* IORDRE : Ordre de continuite aux extremites. */
10062/* CRVLGD : La courbe dont on veut baisser le degre. */
10063
10064/* ARGUMENTS DE SORTIE : */
10065/* ------------------- */
10066/* ERRMAX : La precision de l' approximation. */
10067/* NCFNEW : Le degre +1 du polynome resultat. */
10068
10069/* COMMONS UTILISES : */
10070/* ---------------- */
10071
10072/* REFERENCES APPELEES : */
10073/* ----------------------- */
10074
10075/* DESCRIPTION/REMARQUES/LIMITATIONS : */
10076/* ----------------------------------- */
10077
10078/* $ HISTORIQUE DES MODIFICATIONS : */
10079/* -------------------------------- */
10080/* 06-08-91 : RBD; Declaration de dimension de YCVMAX. */
10081/* 18-01-90 : RBD; Creation. */
10082
10083/* > */
10084/* ***********************************************************************
10085 */
10086
10087
10088 /* Parameter adjustments */
10089 --ycvmax;
10090 crvlgd_dim1 = *ncofmx;
10091 crvlgd_offset = crvlgd_dim1 + 1;
10092 crvlgd -= crvlgd_offset;
10093
10094 /* Function Body */
10095 ia = (*iordre + 1) << 1;
10096
10097 if (ia == 0) {
10098 mmtrpj0_(ncofmx, ndimen, ncoeff, epsi3d, &crvlgd[crvlgd_offset], &
10099 ycvmax[1], errmax, ncfnew);
10100 } else if (ia == 2) {
10101 mmtrpj2_(ncofmx, ndimen, ncoeff, epsi3d, &crvlgd[crvlgd_offset], &
10102 ycvmax[1], errmax, ncfnew);
10103 } else if (ia == 4) {
10104 mmtrpj4_(ncofmx, ndimen, ncoeff, epsi3d, &crvlgd[crvlgd_offset], &
10105 ycvmax[1], errmax, ncfnew);
10106 } else {
10107 mmtrpj6_(ncofmx, ndimen, ncoeff, epsi3d, &crvlgd[crvlgd_offset], &
10108 ycvmax[1], errmax, ncfnew);
10109 }
10110
10111/* ------------------------ Fin -----------------------------------------
10112*/
10113
10114 return 0;
10115} /* mmtrpjj_ */
10116
10117//=======================================================================
10118//function : AdvApp2Var_MathBase::mmunivt_
10119//purpose :
10120//=======================================================================
10121 int AdvApp2Var_MathBase::mmunivt_(integer *ndimen,
10122 doublereal *vector,
10123 doublereal *vecnrm,
10124 doublereal *epsiln,
10125 integer *iercod)
10126{
10127
10128 static doublereal c_b2 = 10.;
10129
10130 /* System generated locals */
10131 integer i__1;
10132 doublereal d__1;
10133
10134 /* Local variables */
10135 static integer nchif, iunit, izero;
10136 static doublereal vnorm;
10137 static integer ii;
10138 static doublereal bid;
10139 static doublereal eps0;
10140
10141
10142
10143
10144/* ***********************************************************************
10145 */
10146
10147/* FONCTION : */
10148/* ---------- */
10149/* CALCUL DU VECTEUR NORME A PARTIR D'UN VECTEUR QUELCONQUE */
10150/* AVEC UNE PRECISION DONNEE PAR L' UTILISATEUR. */
10151
10152/* MOTS CLES : */
10153/* ----------- */
10154/* TOUS, MATH_ACCES :: */
10155/* VECTEUR&, NORMALISATION, &VECTEUR */
10156
10157/* ARGUMENTS D'ENTREE : */
10158/* ------------------ */
10159/* NDIMEN : DIMENSION DE L'ESPACE */
10160/* VECTOR : VECTEUR A NORMER */
10161/* EPSILN : L' EPSILON EN DESSOUS DUQUEL ON CONSIDERE QUE LA */
10162/* NORME DU VECTEUR EST NULLE. SI EPSILN<=0, UNE VALEUR */
10163/* PAR DEFAUT EST IMPOSEE (10.D-17 SUR VAX). */
10164
10165/* ARGUMENTS DE SORTIE : */
10166/* ------------------- */
10167/* VECNRM : VECTEUR NORME */
10168/* IERCOD 101 : LE VECTEUR EST NUL A EPSILN PRES. */
10169/* 0 : OK. */
10170
10171/* COMMONS UTILISES : */
10172/* ---------------- */
10173
10174/* REFERENCES APPELEES : */
10175/* ----------------------- */
10176
10177/* DESCRIPTION/REMARQUES/LIMITATIONS : */
10178/* ----------------------------------- */
10179/* VECTOR et VECNRM peuvent etre identiques. */
10180
10181/* On calcule la norme du vecteur et on divise chaque composante par
10182*/
10183/* cette norme. Apres cela on verifie si toutes les composantes du */
10184/* vecteur sauf une vaut 0 a la precision machine pres. Dans */
10185/* ce cas on met les composantes quasi-nulles a 0.D0. */
10186
10187/* $ HISTORIQUE DES MODIFICATIONS : */
10188/* -------------------------------- */
10189/* 14-12-90 : RBD; Correction cas ou une seule composante est */
10190/* significative, appel a MAOVSR8 pour la precision */
10191/* machine. */
10192/* 11-01-89 : RBD; Correction precision par defaut. */
10193/* 05-10-88 : RBD; Creation d' apres UNITVT. */
10194/* 23-01-85 : DH ; Creation version originale de UNITVT. */
10195/* > */
10196/* ***********************************************************************
10197 */
10198
10199
10200 /* Parameter adjustments */
10201 --vecnrm;
10202 --vector;
10203
10204 /* Function Body */
10205 *iercod = 0;
10206
10207/* -------- Precision par defaut : le zero machine 10.D-17 sur Vax ------
10208*/
10209
10210 AdvApp2Var_SysBase::maovsr8_(&nchif);
10211 if (*epsiln <= 0.) {
10212 i__1 = -nchif;
10213 eps0 = AdvApp2Var_MathBase::pow__di(&c_b2, &i__1);
10214 } else {
10215 eps0 = *epsiln;
10216 }
10217
10218/* ----------------------------- Calcul de la norme ---------------------
10219*/
10220
10221 vnorm = AdvApp2Var_MathBase::mzsnorm_(ndimen, &vector[1]);
10222 if (vnorm <= eps0) {
10223 AdvApp2Var_SysBase::mvriraz_((integer *)ndimen, (char *)&vecnrm[1]);
10224 *iercod = 101;
10225 goto L9999;
10226 }
10227
10228/* ---------------------- Calcul du vecteur norme -----------------------
10229*/
10230
10231 izero = 0;
10232 i__1 = (-nchif - 1) / 2;
10233 eps0 = AdvApp2Var_MathBase::pow__di(&c_b2, &i__1);
10234 i__1 = *ndimen;
10235 for (ii = 1; ii <= i__1; ++ii) {
10236 vecnrm[ii] = vector[ii] / vnorm;
10237 if ((d__1 = vecnrm[ii], abs(d__1)) <= eps0) {
10238 ++izero;
10239 } else {
10240 iunit = ii;
10241 }
10242/* L20: */
10243 }
10244
10245/* ------ Cas ou toutes les coordonnees sauf une sont presque nulles ----
10246*/
10247/* ------------- alors l' une des coordonnees vaut 1.D0 ou -1.D0 --------
10248*/
10249
10250 if (izero == *ndimen - 1) {
10251 bid = vecnrm[iunit];
10252 i__1 = *ndimen;
10253 for (ii = 1; ii <= i__1; ++ii) {
10254 vecnrm[ii] = 0.;
10255/* L30: */
10256 }
10257 if (bid > 0.) {
10258 vecnrm[iunit] = 1.;
10259 } else {
10260 vecnrm[iunit] = -1.;
10261 }
10262 }
10263
10264/* -------------------------------- The end -----------------------------
10265*/
10266
10267L9999:
10268 return 0;
10269} /* mmunivt_ */
10270
10271//=======================================================================
10272//function : AdvApp2Var_MathBase::mmveps3_
10273//purpose :
10274//=======================================================================
10275 int AdvApp2Var_MathBase::mmveps3_(doublereal *eps03)
10276{
10277 /* Initialized data */
10278
10279 static char nomprg[8+1] = "MMEPS1 ";
10280
10281 static integer ibb;
10282
10283
10284
10285/************************************************************************
10286*******/
10287
10288/* FONCTION : */
10289/* ---------- */
10290/* Extraction du EPS1 du COMMON MPRCSN. */
10291
10292/* MOTS CLES : */
10293/* ----------- */
10294/* MPRCSN,PRECISON,EPS3. */
10295
10296/* ARGUMENTS D'ENTREE : */
10297/* ------------------ */
10298/* Humm. */
10299
10300/* ARGUMENTS DE SORTIE : */
10301/* ------------------- */
10302/* EPS3 : Le zero spatial du denominateur (10**-9) */
10303/* EPS3 devrait valoir 10**-15 */
10304
10305/* COMMONS UTILISES : */
10306/* ---------------- */
10307
10308/* REFERENCES APPELEES : */
10309/* ----------------------- */
10310
10311/* DESCRIPTION/REMARQUES/LIMITATIONS : */
10312/* ----------------------------------- */
10313
10314/* $ HISTORIQUE DES MODIFICATIONS : */
10315/* -------------------------------- */
10316/* 08-01-90 : ACS ; MPRCSN REMPLACE PAR INCLUDE */
10317/* 21-01-1988: JJM ; Creation. */
10318
10319/* > */
10320/* ***********************************************************************
10321 */
10322
10323
10324
10325/* ***********************************************************************
10326 */
10327
10328/* FONCTION : */
10329/* ---------- */
10330/* DONNE LES TOLERANCES DE NULLITE DANS STRIM */
10331/* AINSI QUE LES BORNES DES PROCESSUS ITERATIFS */
10332
10333/* CONTEXTE GENERAL, MODIFIABLE PAR L'UTILISATEUR */
10334
10335/* MOTS CLES : */
10336/* ----------- */
10337/* PARAMETRE , TOLERANCE */
10338
10339/* DEMSCRIPTION/REMARQUES/LIMITATIONS : */
10340/* ----------------------------------- */
10341/* INITIALISATION : PROFIL , **VIA MPRFTX** A L' ENTREE DANS STRI
10342M*/
10343
10344/* CHARGEMENT DES VALEURS PAR DEFAUT DU PROFIL DANS MPRFTX A L'ENTRE
10345E*/
10346/* DANS STRIM. ELLES SONT CONSERVEES DANS DES VARIABLES LOCALES */
10347/* DE MPRFTX */
10348
10349/* REMISE DES VALEURS PAR DEFAUT : MDFINT */
10350/* MODIFICATION INTERACTIVE PAR L'UTILISATEUR : MDBINT */
10351
10352/* FONCTION D'ACCES : MMEPS1 ... EPS1 */
10353/* MEPSPB ... EPS3,EPS4 */
10354/* MEPSLN ... EPS2, NITERM , NITERR */
10355/* MEPSNR ... EPS2 , NITERM */
10356/* MITERR ... NITERR */
10357
10358/* $ HISTORIQUE DES MODIFICATIONS : */
10359/* ------------------------------ */
10360/* 01-02-90 : NAK ; ENTETE */
10361/* > */
10362/* ***********************************************************************
10363 */
10364
10365/* NITERM : NB D'ITERATIONS MAXIMAL */
10366/* NITERR : NB D'ITERATIONS RAPIDES */
10367/* EPS1 : TOLERANCE DE DISTANCE 3D NULLE */
10368/* EPS2 : TOLERANCE DE DISTANCE PARAMETRIQUE NULLE */
10369/* EPS3 : TOLERANCE POUR EVITER LES DIVISIONS PAR 0.. */
10370/* EPS4 : TOLERANCE ANGULAIRE */
10371
10372
10373
10374/* ***********************************************************************
10375 */
10376
10377 ibb = AdvApp2Var_SysBase::mnfndeb_();
10378 if (ibb >= 5) {
10379 AdvApp2Var_SysBase::mgenmsg_(nomprg, 6L);
10380 }
10381
10382 *eps03 = mmprcsn_.eps3;
10383
10384 return 0;
10385} /* mmveps3_ */
10386
10387//=======================================================================
10388//function : AdvApp2Var_MathBase::mmvncol_
10389//purpose :
10390//=======================================================================
10391 int AdvApp2Var_MathBase::mmvncol_(integer *ndimen,
10392 doublereal *vecin,
10393 doublereal *vecout,
10394 integer *iercod)
10395
10396{
10397 /* System generated locals */
10398 integer i__1;
10399
10400 /* Local variables */
10401 static logical ldbg;
10402 static integer d__;
10403 static doublereal vaux1[3], vaux2[3];
10404 static logical colin;
10405 static doublereal valaux;
10406 static integer aux;
10407 static logical nul;
10408
10409/* ***********************************************************************
10410 */
10411
10412/* FONCTION : */
10413/* ---------- */
10414/* CALCUL UN VECTEUR NON COLINEAIRE A UN VECTEUR DONNEE */
10415/* NON NUL */
10416
10417/* MOTS CLES : */
10418/* ----------- */
10419/* PUBLIC, VECTEUR, LIBRE */
10420
10421/* ARGUMENTS D'ENTREE : */
10422/* -------------------- */
10423/* ndimen :dimension de l'espace */
10424/* vecin :vecteur entre */
10425
10426
10427/* ARGUMENTS DE SORTIE : */
10428/* --------------------- */
10429
10430/* vecout : vecteur non colineaire a vecin */
10431/* COMMONS UTILISES : */
10432/* ------------------ */
10433
10434
10435/* REFERENCES APPELEES : */
10436/* --------------------- */
10437
10438
10439/* DESCRIPTION/REMARQUES/LIMITATIONS : */
10440/* ----------------------------------- */
10441
10442
10443/* $ HISTORIQUE DES MODIFICATIONS : */
10444/* ------------------------------ */
10445/* 25-08-95 : KHN; ECRITURE VERSION ORIGINALE. */
10446/* > */
10447/* ***********************************************************************
10448 */
10449/* DECLARATIONS */
10450/* ***********************************************************************
10451 */
10452
10453
10454
10455/* ***********************************************************************
10456 */
10457/* INITIALISATIONS */
10458/* ***********************************************************************
10459 */
10460
10461 /* Parameter adjustments */
10462 --vecout;
10463 --vecin;
10464
10465 /* Function Body */
10466 ldbg = AdvApp2Var_SysBase::mnfndeb_() >= 2;
10467 if (ldbg) {
10468 AdvApp2Var_SysBase::mgenmsg_("MMVNCOL", 7L);
10469 }
10470 *iercod = 0;
10471
10472/* ***********************************************************************
10473 */
10474/* TRAITEMENT */
10475/* ***********************************************************************
10476 */
10477
10478 if (*ndimen <= 1 || *ndimen > 3) {
10479 goto L9101;
10480 }
10481 nul = FALSE_;
10482 d__ = 1;
10483 aux = 0;
10484 while(d__ <= *ndimen) {
10485 if (vecin[d__] == 0.) {
10486 ++aux;
10487 }
10488 ++d__;
10489 }
10490 if (aux == *ndimen) {
10491 goto L9101;
10492 }
10493
10494
10495 for (d__ = 1; d__ <= 3; ++d__) {
10496 vaux1[d__ - 1] = 0.;
10497 }
10498 i__1 = *ndimen;
10499 for (d__ = 1; d__ <= i__1; ++d__) {
10500 vaux1[d__ - 1] = vecin[d__];
10501 vaux2[d__ - 1] = vecin[d__];
10502 }
10503 colin = TRUE_;
10504 d__ = 0;
10505 while(colin) {
10506 ++d__;
10507 if (d__ > 3) {
10508 goto L9101;
10509 }
10510 vaux2[d__ - 1] += 1;
10511 valaux = vaux1[1] * vaux2[2] - vaux1[2] * vaux2[1];
10512 if (valaux == 0.) {
10513 valaux = vaux1[2] * vaux2[0] - vaux1[0] * vaux2[2];
10514 if (valaux == 0.) {
10515 valaux = vaux1[0] * vaux2[1] - vaux1[1] * vaux2[0];
10516 if (valaux != 0.) {
10517 colin = FALSE_;
10518 }
10519 } else {
10520 colin = FALSE_;
10521 }
10522 } else {
10523 colin = FALSE_;
10524 }
10525 }
10526 if (colin) {
10527 goto L9101;
10528 }
10529 i__1 = *ndimen;
10530 for (d__ = 1; d__ <= i__1; ++d__) {
10531 vecout[d__] = vaux2[d__ - 1];
10532 }
10533
10534 goto L9999;
10535
10536/* ***********************************************************************
10537 */
10538/* TRAITEMENT DES ERREURS */
10539/* ***********************************************************************
10540 */
10541
10542
10543L9101:
10544 *iercod = 1;
10545 goto L9999;
10546
10547
10548/* ***********************************************************************
10549 */
10550/* RETOUR PROGRAMME APPELANT */
10551/* ***********************************************************************
10552 */
10553
10554L9999:
10555
10556
10557 AdvApp2Var_SysBase::maermsg_("MMVNCOL", iercod, 7L);
10558 if (ldbg) {
10559 AdvApp2Var_SysBase::mgsomsg_("MMVNCOL", 7L);
10560 }
10561 return 0 ;
10562} /* mmvncol_ */
10563
10564//=======================================================================
10565//function : AdvApp2Var_MathBase::mmwprcs_
10566//purpose :
10567//=======================================================================
10568void AdvApp2Var_MathBase::mmwprcs_(doublereal *epsil1,
10569 doublereal *epsil2,
10570 doublereal *epsil3,
10571 doublereal *epsil4,
10572 integer *niter1,
10573 integer *niter2)
10574
10575{
10576
10577
10578/* ***********************************************************************
10579 */
10580
10581/* FONCTION : */
10582/* ---------- */
10583/* ACCES EN ECRITURE POUR LE COMMON MPRCSN */
10584
10585/* MOTS CLES : */
10586/* ----------- */
10587/* ECRITURE */
10588
10589/* ARGUMENTS D'ENTREE : */
10590/* -------------------- */
10591/* EPSIL1 : TOLERANCE DE DISTANCE 3D NULLE */
10592/* EPSIL2 : TOLERANCE DE DISTANCE PARAMETRIQUE NULLE */
10593/* EPSIL3 : TOLERANCE POUR EVITER LES DIVISIONS PAR 0.. */
10594/* EPSIL4 : TOLERANCE ANGULAIRE */
10595/* NITER1 : NB D'ITERATIONS MAXIMAL */
10596/* NITER2 : NB D'ITERATIONS RAPIDES */
10597
10598/* ARGUMENTS DE SORTIE : */
10599/* --------------------- */
10600/* NEANT */
10601
10602/* COMMONS UTILISES : */
10603/* ------------------ */
10604
10605
10606/* REFERENCES APPELEES : */
10607/* --------------------- */
10608
10609
10610/* DESCRIPTION/REMARQUES/LIMITATIONS : */
10611/* ----------------------------------- */
10612
10613/* $ HISTORIQUE DES MODIFICATIONS : */
10614/* ------------------------------ */
10615/* 13-05-96 : JPI; ECRITURE VERSION ORIGINALE. */
10616/* > */
10617/* ***********************************************************************
10618 */
10619/* DECLARATIONS */
10620/* ***********************************************************************
10621 */
10622
10623
10624/* ***********************************************************************
10625 */
10626/* INITIALISATIONS */
10627/* ***********************************************************************
10628 */
10629
10630/* ***********************************************************************
10631 */
10632/* TRAITEMENT */
10633/* ***********************************************************************
10634 */
10635
10636/* ***********************************************************************
10637 */
10638
10639/* FONCTION : */
10640/* ---------- */
10641/* DONNE LES TOLERANCES DE NULLITE DANS STRIM */
10642/* AINSI QUE LES BORNES DES PROCESSUS ITERATIFS */
10643
10644/* CONTEXTE GENERAL, MODIFIABLE PAR L'UTILISATEUR */
10645
10646/* MOTS CLES : */
10647/* ----------- */
10648/* PARAMETRE , TOLERANCE */
10649
10650/* DEMSCRIPTION/REMARQUES/LIMITATIONS : */
10651/* ----------------------------------- */
10652/* INITIALISATION : PROFIL , **VIA MPRFTX** A L' ENTREE DANS STRI
10653M*/
10654
10655/* CHARGEMENT DES VALEURS PAR DEFAUT DU PROFIL DANS MPRFTX A L'ENTRE
10656E*/
10657/* DANS STRIM. ELLES SONT CONSERVEES DANS DES VARIABLES LOCALES */
10658/* DE MPRFTX */
10659
10660/* REMISE DES VALEURS PAR DEFAUT : MDFINT */
10661/* MODIFICATION INTERACTIVE PAR L'UTILISATEUR : MDBINT */
10662
10663/* FONCTION D'ACCES : MMEPS1 ... EPS1 */
10664/* MEPSPB ... EPS3,EPS4 */
10665/* MEPSLN ... EPS2, NITERM , NITERR */
10666/* MEPSNR ... EPS2 , NITERM */
10667/* MITERR ... NITERR */
10668
10669/* $ HISTORIQUE DES MODIFICATIONS : */
10670/* ------------------------------ */
10671/* 01-02-90 : NAK ; ENTETE */
10672/* > */
10673/* ***********************************************************************
10674 */
10675
10676/* NITERM : NB D'ITERATIONS MAXIMAL */
10677/* NITERR : NB D'ITERATIONS RAPIDES */
10678/* EPS1 : TOLERANCE DE DISTANCE 3D NULLE */
10679/* EPS2 : TOLERANCE DE DISTANCE PARAMETRIQUE NULLE */
10680/* EPS3 : TOLERANCE POUR EVITER LES DIVISIONS PAR 0.. */
10681/* EPS4 : TOLERANCE ANGULAIRE */
10682
10683
10684
10685/* ***********************************************************************
10686 */
10687 mmprcsn_.eps1 = *epsil1;
10688 mmprcsn_.eps2 = *epsil2;
10689 mmprcsn_.eps3 = *epsil3;
10690 mmprcsn_.eps4 = *epsil4;
10691 mmprcsn_.niterm = *niter1;
10692 mmprcsn_.niterr = *niter2;
10693 return ;
10694} /* mmwprcs_ */
10695
10696
10697//=======================================================================
10698//function : AdvApp2Var_MathBase::pow__di
10699//purpose :
10700//=======================================================================
10701 doublereal AdvApp2Var_MathBase::pow__di (doublereal *x,
10702 integer *n)
10703{
10704
10705 register integer ii ;
10706 doublereal result ;
10707 integer absolute ;
10708 result = 1.0e0 ;
10709 if ( *n > 0 ) {absolute = *n;}
10710 else {absolute = -*n;}
10711 /* System generated locals */
10712 for(ii = 0 ; ii < absolute ; ii++) {
10713 result *= *x ;
10714 }
10715 if (*n < 0) {
10716 result = 1.0e0 / result ;
10717 }
10718 return result ;
10719}
10720
10721
10722/* **********************************************************************
10723*/
10724
10725/* FONCTION : */
10726/* ---------- */
10727/* Calcul la fonction puissance entiere pas forcement de la maniere
10728 la plus efficace ;
10729*/
10730
10731/* MOTS CLES : */
10732/* ----------- */
10733/* PUISSANCE */
10734
10735/* ARGUMENTS D'ENTREE : */
10736/* ------------------ */
10737/* X : argument de X**N */
10738/* N : puissance */
10739
10740/* ARGUMENTS DE SORTIE : */
10741/* ------------------- */
10742/* retourne X**N */
10743
10744/* COMMONS UTILISES : */
10745/* ---------------- */
10746
10747/* REFERENCES APPELEES : */
10748/* ----------------------- */
10749
10750/* DESCRIPTION/REMARQUES/LIMITATIONS : */
10751/* ----------------------------------- */
10752
10753/* $ HISTORIQUE DES MODIFICATIONS : */
10754/* -------------------------------- */
10755/* 16-10-95 : XAB ; Creation */
10756/* > */
10757/* ***********************************************************************/
10758
10759//=======================================================================
10760//function : pow__ii
10761//purpose :
10762//=======================================================================
10763integer pow__ii(integer *x,
10764 integer *n)
10765
10766{
10767 register integer ii ;
10768 integer result ;
10769 integer absolute ;
10770 result = 1 ;
10771 if ( *n > 0 ) {absolute = *n;}
10772 else {absolute = -*n;}
10773 /* System generated locals */
10774 for(ii = 0 ; ii < absolute ; ii++) {
10775 result *= *x ;
10776 }
10777 if (*n < 0) {
10778 result = 1 / result ;
10779 }
10780 return result ;
10781}
10782
10783
10784/* **********************************************************************
10785*/
10786
10787/* FONCTION : */
10788/* ---------- */
10789/* Calcul la fonction puissance entiere pas forcement de la maniere
10790 la plus efficace ;
10791*/
10792
10793/* MOTS CLES : */
10794/* ----------- */
10795/* PUISSANCE */
10796
10797/* ARGUMENTS D'ENTREE : */
10798/* ------------------ */
10799/* X : argument de X**N */
10800/* N : puissance */
10801
10802/* ARGUMENTS DE SORTIE : */
10803/* ------------------- */
10804/* retourne X**N */
10805
10806/* COMMONS UTILISES : */
10807/* ---------------- */
10808
10809/* REFERENCES APPELEES : */
10810/* ----------------------- */
10811
10812/* DESCRIPTION/REMARQUES/LIMITATIONS : */
10813/* ----------------------------------- */
10814
10815/* $ HISTORIQUE DES MODIFICATIONS : */
10816/* -------------------------------- */
10817/* 16-10-95 : XAB ; Creation */
10818/* > */
10819/* ***********************************************************************/
10820
10821//=======================================================================
10822//function : AdvApp2Var_MathBase::msc_
10823//purpose :
10824//=======================================================================
10825 doublereal AdvApp2Var_MathBase::msc_(integer *ndimen,
10826 doublereal *vecte1,
10827 doublereal *vecte2)
10828
10829{
10830 /* System generated locals */
10831 integer i__1;
10832 doublereal ret_val;
10833
10834 /* Local variables */
10835 static integer i__;
10836 static doublereal x;
10837
10838
10839
10840/************************************************************************
10841*******/
10842
10843/* FONCTION : */
10844/* ---------- */
10845/* Calcul du produit scalaire de 2 vecteurs dans l' espace */
10846/* de dimension NDIMEN. */
10847
10848/* MOTS CLES : */
10849/* ----------- */
10850/* PRODUIT MSCALAIRE. */
10851
10852/* ARGUMENTS D'ENTREE : */
10853/* ------------------ */
10854/* NDIMEN : Dimension de l' espace. */
10855/* VECTE1,VECTE2: Les vecteurs. */
10856
10857/* ARGUMENTS DE SORTIE : */
10858/* ------------------- */
10859
10860/* COMMONS UTILISES : */
10861/* ---------------- */
10862
10863/* REFERENCES APPELEES : */
10864/* ----------------------- */
10865
10866/* DESCRIPTION/REMARQUES/LIMITATIONS : */
10867/* ----------------------------------- */
10868
10869/* $ HISTORIQUE DES MODIFICATIONS : */
10870/* -------------------------------- */
10871/* 18-07-1988: RBD ; Changement de nom des arguments pour plus */
10872/* de lisibilite. */
10873/* 16-01-1987: Verification implicite NDIMEN >0 JJM. */
10874
10875/* > */
10876/* ***********************************************************************
10877 */
10878
10879
10880/* PRODUIT MSCALAIRE */
10881 /* Parameter adjustments */
10882 --vecte2;
10883 --vecte1;
10884
10885 /* Function Body */
10886 x = 0.;
10887
10888 i__1 = *ndimen;
10889 for (i__ = 1; i__ <= i__1; ++i__) {
10890 x += vecte1[i__] * vecte2[i__];
10891/* L100: */
10892 }
10893 ret_val = x;
10894
10895/* ----------------------------------- THE END --------------------------
10896*/
10897
10898 return ret_val;
10899} /* msc_ */
10900
10901//=======================================================================
10902//function : mvcvin2_
10903//purpose :
10904//=======================================================================
10905int mvcvin2_(integer *ncoeff,
10906 doublereal *crvold,
10907 doublereal *crvnew,
10908 integer *iercod)
10909
10910{
10911 /* System generated locals */
10912 integer i__1, i__2;
10913
10914 /* Local variables */
10915 static integer m1jm1, ncfm1, j, k;
10916 static doublereal bid;
10917 static doublereal cij1, cij2;
10918
10919
10920
10921/************************************************************************
10922*******/
10923
10924/* FONCTION : */
10925/* ---------- */
10926/* INVERSION DU PARAMETRAGE SUR UNE CRBE 2D. */
10927
10928/* MOTS CLES : */
10929/* ----------- */
10930/* COURBE,2D,INVERSION,PARAMETRE. */
10931
10932/* ARGUMENTS D'ENTREE : */
10933/* ------------------ */
10934/* NCOEFF : NBRE DE COEFF DE LA COURBE. */
10935/* CRVOLD : LA COURBE D'ORIGINE */
10936
10937/* ARGUMENTS DE SORTIE : */
10938/* ------------------- */
10939/* CRVNEW : LA CRBE RESULTAT APRES CHANGT DE T EN 1-T */
10940/* IERCOD : 0 OK, */
10941/* 10 NBRE DE COEFF NUL OU TROP GRAND. */
10942
10943/* COMMONS UTILISES : */
10944/* ---------------- */
10945/* MCCNP */
10946
10947/* REFERENCES APPELEES : */
10948/* ---------------------- */
10949/* Neant */
10950/* DESCRIPTION/REMARQUES/LIMITATIONS : */
10951/* ----------------------------------- */
10952/* L' APPEL SUIVANT EST TOUT A FAIT LEGAL : */
10953/* CALL MVCVIN2(NCOEFF,CURVE,CURVE,IERCOD), LE TABLEAU CURVE */
10954/* DEVENANT UN ARGUMENT D' ENTREE ET DE SORTIE (RBD). */
10955/* A CAUSE DE MCCNP, LE NBRE DE COEFF DE LA COURBE EST LIMITE A */
10956/* NDGCNP+1 = 61. */
10957
10958/* $ HISTORIQUE DES MODIFICATIONS : */
10959/* -------------------------------- */
10960/* 24-09-93 : MPS ; PRISE EN COMPTE NCOEFF=1 */
10961/* IMPLICIT NONE */
10962/* 09-01-90 : TE ; COMMON MCCNP -> MCNCNP.INC & INDICES DES CNP */
10963/* 05-08-88 : RBD ; ACTIVATION DE L' IERCOD */
10964/* 27-06-88 : RBD ; VERIFICATION QUE LES IDENTIFICATEURS CRVNEW ET */
10965/* CRVOLD PEUVENT DESIGNER LA MEME COURBE. */
10966/* 14-04-88 : NAK ; VERSION ORIGINALE */
10967/* > */
10968/* ***********************************************************************
10969 */
10970
10971
10972/* **********************************************************************
10973*/
10974
10975/* FONCTION : */
10976/* ---------- */
10977/* Sert a fournir les coefficients du binome (triangle de Pascal). */
10978
10979/* MOTS CLES : */
10980/* ----------- */
10981/* Coeff du binome de 0 a 60. read only . init par block data */
10982
10983/* DEMSCRIPTION/REMARQUES/LIMITATIONS : */
10984/* ----------------------------------- */
10985/* Les coefficients du binome forment une matrice triangulaire. */
10986/* On complete cette matrice dans le tableau CNP par sa transposee. */
10987/* On a donc: CNP(I,J) = CNP(J,I) pour I et J = 0, ..., 60. */
10988
10989/* L'initialisation est faite a partir du block-data MMLLL09.RES, */
10990/* cree par le programme MQINICNP.FOR (voir l'equipe (AC) ). */
10991
10992/* $ HISTORIQUE DES MODIFICATIONS : */
10993/* ------------------------------ */
10994/* 03-07-90 : RBD; Ajout commentaires (nom du block-data). */
10995/* 19-06-90 : RBD; Le commun MMCMCNP remplace MCCNP qui est obsolete.
10996*/
10997/* 08-01-90 : TE ; CREATION */
10998/* > */
10999/* **********************************************************************
11000*/
11001
11002
11003
11004/* ***********************************************************************
11005 */
11006
11007 /* Parameter adjustments */
11008 crvnew -= 3;
11009 crvold -= 3;
11010
11011 /* Function Body */
11012 if (*ncoeff < 1 || *ncoeff - 1 > 60) {
11013 *iercod = 10;
11014 goto L9999;
11015 }
11016 *iercod = 0;
11017
11018
11019/* TERME CONSTANT DE LA NOUVELLE COURBE */
11020
11021 cij1 = crvold[3];
11022 cij2 = crvold[4];
11023 i__1 = *ncoeff;
11024 for (k = 2; k <= i__1; ++k) {
11025 cij1 += crvold[(k << 1) + 1];
11026 cij2 += crvold[(k << 1) + 2];
11027 }
11028 crvnew[3] = cij1;
11029 crvnew[4] = cij2;
11030 if (*ncoeff == 1) {
11031 goto L9999;
11032 }
11033
11034/* PUISSANCES INTERMEDIAIRES DU PARAMETRE */
11035
11036 ncfm1 = *ncoeff - 1;
11037 m1jm1 = 1;
11038 i__1 = ncfm1;
11039 for (j = 2; j <= i__1; ++j) {
11040 m1jm1 = -m1jm1;
11041 cij1 = crvold[(j << 1) + 1];
11042 cij2 = crvold[(j << 1) + 2];
11043 i__2 = *ncoeff;
11044 for (k = j + 1; k <= i__2; ++k) {
11045 bid = mmcmcnp_.cnp[k - 1 + (j - 1) * 61];
11046 cij1 += crvold[(k << 1) + 1] * bid;
11047 cij2 += crvold[(k << 1) + 2] * bid;
11048 }
11049 crvnew[(j << 1) + 1] = cij1 * m1jm1;
11050 crvnew[(j << 1) + 2] = cij2 * m1jm1;
11051 }
11052
11053/* TERME DE PLUS HAUT DEGRE */
11054
11055 crvnew[(*ncoeff << 1) + 1] = -crvold[(*ncoeff << 1) + 1] * m1jm1;
11056 crvnew[(*ncoeff << 1) + 2] = -crvold[(*ncoeff << 1) + 2] * m1jm1;
11057
11058L9999:
11059 if (*iercod > 0) {
11060 AdvApp2Var_SysBase::maermsg_("MVCVIN2", iercod, 7L);
11061 }
11062 return 0 ;
11063} /* mvcvin2_ */
11064
11065//=======================================================================
11066//function : mvcvinv_
11067//purpose :
11068//=======================================================================
11069int mvcvinv_(integer *ncoeff,
11070 doublereal *crvold,
11071 doublereal *crvnew,
11072 integer *iercod)
11073
11074{
11075 /* System generated locals */
11076 integer i__1, i__2;
11077
11078 /* Local variables */
11079 static integer m1jm1, ncfm1, j, k;
11080 static doublereal bid;
11081 //extern /* Subroutine */ int maermsg_();
11082 static doublereal cij1, cij2, cij3;
11083
11084
11085/* **********************************************************************
11086*/
11087
11088/* FONCTION : */
11089/* ---------- */
11090/* INVERSION DU PARAMETRAGE SUR UNE CRBE 3D (I.E. INVERSION DU */
11091/* SENS DE PARCOURS). */
11092
11093/* MOTS CLES : */
11094/* ----------- */
11095/* COURBE,INVERSION,PARAMETRE. */
11096
11097/* ARGUMENTS D'ENTREE : */
11098/* ------------------ */
11099/* NCOEFF : NBRE DE COEFF DE LA COURBE. */
11100/* CRVOLD : lA COURBE D'ORIGINE */
11101
11102/* ARGUMENTS DE SORTIE : */
11103/* ------------------- */
11104/* CRVNEW : LA CRBE RESULTAT APRES CHANGT DE T EN 1-T */
11105/* IERCOD : 0 OK, */
11106/* 10 NBRE DE COEFF NUL OU TROP GRAND. */
11107
11108/* COMMONS UTILISES : */
11109/* ---------------- */
11110/* MCCNP */
11111
11112/* REFERENCES APPELEES : */
11113/* ---------------------- */
11114/* Neant */
11115/* DESCRIPTION/REMARQUES/LIMITATIONS : */
11116/* ----------------------------------- */
11117/* L' APPEL SUIVANT EST TOUT A FAIT LEGAL : */
11118/* CALL MVCVINV(NCOEFF,CURVE,CURVE,IERCOD), LE TABLEAU CURVE */
11119/* DEVENANT UN ARGUMENT D' ENTREE ET DE SORTIE (RBD). */
11120/* LE NOMBRE DE COEFF DE LA COURBE EST LIMITE A NDGCNP+1 = 61 */
11121/* A CAUSE DE L' UTILISATION DU COMMUN MCCNP. */
11122
11123/* $ HISTORIQUE DES MODIFICATIONS : */
11124/* -------------------------------- */
11125/* 10-05-90 : JG ; NCOEFF=1 n'etait pas gere */
11126/* 09-01-90 : TE ; COMMON MCCNP -> MMCMCNP.INC & INDICES DES CNP */
11127/* 05-08-88 : RBD ; ACTIVATION DE L' IERCOD */
11128/* 27-06-88 : RBD ; VERIFICATION QUE LES IDENTIFICATEURS CRVNEW ET */
11129/* CRVOLD PEUVENT DESIGNER LA MEME COURBE. */
11130/* 02-03-87 : NAK ; BRSTN --> MCCNP */
11131/* 01-10-86 : NAK ; PRISE EN COMPTE LES ISOS DE LA FORME 1-T */
11132/* > */
11133/* ***********************************************************************
11134 */
11135
11136/* **********************************************************************
11137*/
11138
11139/* FONCTION : */
11140/* ---------- */
11141/* Sert a fournir les coefficients du binome (triangle de Pascal). */
11142
11143/* MOTS CLES : */
11144/* ----------- */
11145/* Coeff du binome de 0 a 60. read only . init par block data */
11146
11147/* DEMSCRIPTION/REMARQUES/LIMITATIONS : */
11148/* ----------------------------------- */
11149/* Les coefficients du binome forment une matrice triangulaire. */
11150/* On complete cette matrice dans le tableau CNP par sa transposee. */
11151/* On a donc: CNP(I,J) = CNP(J,I) pour I et J = 0, ..., 60. */
11152
11153/* L'initialisation est faite a partir du block-data MMLLL09.RES, */
11154/* cree par le programme MQINICNP.FOR (voir l'equipe (AC) ). */
11155
11156/* $ HISTORIQUE DES MODIFICATIONS : */
11157/* ------------------------------ */
11158/* 03-07-90 : RBD; Ajout commentaires (nom du block-data). */
11159/* 19-06-90 : RBD; Le commun MMCMCNP remplace MCCNP qui est obsolete.
11160*/
11161/* 08-01-90 : TE ; CREATION */
11162/* > */
11163/* **********************************************************************
11164*/
11165
11166
11167
11168/* ***********************************************************************
11169 */
11170
11171 /* Parameter adjustments */
11172 crvnew -= 4;
11173 crvold -= 4;
11174
11175 /* Function Body */
11176 if (*ncoeff < 1 || *ncoeff - 1 > 60) {
11177 *iercod = 10;
11178 goto L9999;
11179 }
11180 *iercod = 0;
11181
11182/* TERME CONSTANT DE LA NOUVELLE COURBE */
11183
11184 cij1 = crvold[4];
11185 cij2 = crvold[5];
11186 cij3 = crvold[6];
11187 i__1 = *ncoeff;
11188 for (k = 2; k <= i__1; ++k) {
11189 cij1 += crvold[k * 3 + 1];
11190 cij2 += crvold[k * 3 + 2];
11191 cij3 += crvold[k * 3 + 3];
11192/* L30: */
11193 }
11194 crvnew[4] = cij1;
11195 crvnew[5] = cij2;
11196 crvnew[6] = cij3;
11197 if (*ncoeff == 1) {
11198 goto L9999;
11199 }
11200
11201/* PUISSANCES INTERMEDIAIRES DU PARAMETRE */
11202
11203 ncfm1 = *ncoeff - 1;
11204 m1jm1 = 1;
11205 i__1 = ncfm1;
11206 for (j = 2; j <= i__1; ++j) {
11207 m1jm1 = -m1jm1;
11208 cij1 = crvold[j * 3 + 1];
11209 cij2 = crvold[j * 3 + 2];
11210 cij3 = crvold[j * 3 + 3];
11211 i__2 = *ncoeff;
11212 for (k = j + 1; k <= i__2; ++k) {
11213 bid = mmcmcnp_.cnp[k - 1 + (j - 1) * 61];
11214 cij1 += crvold[k * 3 + 1] * bid;
11215 cij2 += crvold[k * 3 + 2] * bid;
11216 cij3 += crvold[k * 3 + 3] * bid;
11217/* L40: */
11218 }
11219 crvnew[j * 3 + 1] = cij1 * m1jm1;
11220 crvnew[j * 3 + 2] = cij2 * m1jm1;
11221 crvnew[j * 3 + 3] = cij3 * m1jm1;
11222/* L50: */
11223 }
11224
11225/* TERME DE PLUS HAUT DEGRE */
11226
11227 crvnew[*ncoeff * 3 + 1] = -crvold[*ncoeff * 3 + 1] * m1jm1;
11228 crvnew[*ncoeff * 3 + 2] = -crvold[*ncoeff * 3 + 2] * m1jm1;
11229 crvnew[*ncoeff * 3 + 3] = -crvold[*ncoeff * 3 + 3] * m1jm1;
11230
11231L9999:
11232 AdvApp2Var_SysBase::maermsg_("MVCVINV", iercod, 7L);
11233 return 0;
11234} /* mvcvinv_ */
11235
11236//=======================================================================
11237//function : mvgaus0_
11238//purpose :
11239//=======================================================================
11240int mvgaus0_(integer *kindic,
11241 doublereal *urootl,
11242 doublereal *hiltab,
11243 integer *nbrval,
11244 integer *iercod)
11245
11246{
11247 /* System generated locals */
11248 integer i__1;
11249
11250 /* Local variables */
11251 static doublereal tamp[40];
11252 static integer ndegl, kg, ii;
11253
11254/* **********************************************************************
11255*/
11256
11257/* FONCTION : */
11258/* -------- */
11259/* Chargement pour un degre donne des racines du polynome de LEGENDRE */
11260/* DEFINI SUR [-1,1] et des poids des formules de quadrature de Gauss */
11261/* (bases sur les interpolants de LAGRANGE correspondants). */
11262/* La symetrie par rapport a 0 entre [-1,0] et [0,1] est utilisee. */
11263
11264/* MOTS CLES : */
11265/* --------- */
11266/* . VOLUMIQUE,LEGENDRE,LAGRANGE,GAUSS */
11267
11268/* ARGUMENTS D'ENTREE : */
11269/* ------------------ */
11270
11271/* KINDIC : Prends les valeurs de 1 a 10 en fonction du degre du */
11272/* polynome a utiliser. */
11273/* Le degre du polynome est egal a 4 k, c'est a dire 4, 8, */
11274/* 12, 16, 20, 24, 28, 32, 36 et 40. */
11275
11276/* ARGUMENTS DE SORTIE : */
11277/* ------------------- */
11278
11279/* UROOTL : Racines du polynome de LEGENDRE dans le domaine [1,0] */
11280/* ordonnees en decroissant. Pour le domaine [-1,0], il faut */
11281/* prendre les valeurs opposees. */
11282/* HILTAB : Interpolant de LAGRANGE associes aux racines. Pour les */
11283/* racines opposes, les interpolants sont egaux. */
11284/* NBRVAL : Nombre de coefficients. C'est egal a la moitie du degre en */
11285/* raison de la symetrie (i.e. 2*KINDIC). */
11286
11287/* IERCOD : Code d'erreur : */
11288/* < 0 ==> Attention - Warning */
11289/* =-1 ==> Valeur de KINDIC erronne. NBRVAL est force a 20 */
11290/* (ordre 40) */
11291/* = 0 ==> Tout est OK */
11292
11293/* COMMON UTILISES : */
11294/* ---------------- */
11295
11296/* REFERENCES APPELEES : */
11297/* ------------------- */
11298
11299/* DESCRIPTION/REMARQUES/LIMITATIONS : */
11300/* --------------------------------- */
11301/* Si KINDIC n'est pas bon (i.e < 1 ou > 10), le degre est pris */
11302/* a 40 directement (ATTENTION au debordement - pour l'eviter, */
11303/* prevoir UROOTL et HILTAB dimensionne a 20 au moins). */
11304
11305/* La valeur des coefficients a ete calculee en quadruple precision
11306*/
11307/* par JJM avec l'aide de GD. */
11308/* La verification des racines a ete faite par GD. */
11309
11310/* Voir les explications detaillees sur le listing */
11311
11312/* $ HISTORIQUES DES MODIFICATIONS : */
11313/* ----------------------------- */
11314/* . 23-03-90 : RBD; Les valeurs sont extraites du commun MLGDRTL
11315*/
11316/* via MMEXTHI et MMEXTRL. */
11317/* . 28-06-88 : JP; DECLARATIONS REAL *8 MAL PLACEES */
11318/* . 08-08-87 : GD; Version originale */
11319/* > */
11320/* **********************************************************************
11321*/
11322
11323
11324/* ------------------------------------ */
11325/* ****** Test de validite de KINDIC ** */
11326/* ------------------------------------ */
11327
11328 /* Parameter adjustments */
11329 --hiltab;
11330 --urootl;
11331
11332 /* Function Body */
11333 *iercod = 0;
11334 kg = *kindic;
11335 if (kg < 1 || kg > 10) {
11336 kg = 10;
11337 *iercod = -1;
11338 }
11339 *nbrval = kg << 1;
11340 ndegl = *nbrval << 1;
11341
11342/* ----------------------------------------------------------------------
11343*/
11344/* ****** Chargement des NBRVAL racines positives en fonction du degre **
11345*/
11346/* ----------------------------------------------------------------------
11347*/
11348/* ATTENTION : Le signe moins (-) dans la boucle est intentionnel. */
11349
11350 mmextrl_(&ndegl, tamp);
11351 i__1 = *nbrval;
11352 for (ii = 1; ii <= i__1; ++ii) {
11353 urootl[ii] = -tamp[ii - 1];
11354/* L100: */
11355 }
11356
11357/* ------------------------------------------------------------------- */
11358/* ****** Chargement des NBRVAL poids de Gauss en fonction du degre ** */
11359/* ------------------------------------------------------------------- */
11360
11361 mmexthi_(&ndegl, tamp);
11362 i__1 = *nbrval;
11363 for (ii = 1; ii <= i__1; ++ii) {
11364 hiltab[ii] = tamp[ii - 1];
11365/* L200: */
11366 }
11367
11368/* ------------------------------- */
11369/* ****** Fin du sous-programme ** */
11370/* ------------------------------- */
11371
11372 return 0;
11373} /* mvgaus0_ */
11374
11375//=======================================================================
11376//function : mvpscr2_
11377//purpose :
11378//=======================================================================
11379int mvpscr2_(integer *ncoeff,
11380 doublereal *curve2,
11381 doublereal *tparam,
11382 doublereal *pntcrb)
11383{
11384 /* System generated locals */
11385 integer i__1;
11386
11387 /* Local variables */
11388 static integer ndeg, kk;
11389 static doublereal xxx, yyy;
11390
11391
11392
11393/* **********************************************************************
11394*/
11395
11396/* FONCTION : */
11397/* ---------- */
11398/* POSITIONNEMENT SUR UNE COURBE (NCF,2) DANS L'ESPACE DE DIMENSION 2. */
11399
11400/* MOTS CLES : */
11401/* ----------- */
11402/* TOUS,MATH_ACCES:: COURBE&,POSITIONNEMENT,&POINT. */
11403
11404/* ARGUMENTS D'ENTREE : */
11405/* ------------------ */
11406/* NCOEFF : NOMBRE DE COEFFICIENTS DE LA COURBE */
11407/* CURVE2 : EQUATION DE LA COURBE 2D */
11408/* TPARAM : VALEUR DU PARAMETRE AU POINT CONSIDERE */
11409
11410/* ARGUMENTS DE SORTIE : */
11411/* ------------------- */
11412/* PNTCRB : COORDONNEES DU POINT CORRESPONDANT AU PARAMETRE */
11413/* TPARAM SUR LA COURBE 2D CURVE2. */
11414
11415/* COMMONS UTILISES : */
11416/* ---------------- */
11417
11418/* REFERENCES APPELEES : */
11419/* ---------------------- */
11420
11421/* DESCRIPTION/REMARQUES/LIMITATIONS : */
11422/* ----------------------------------- */
11423/* MSCHEMA DE HORNER. */
11424
11425/* $ HISTORIQUE DES MODIFICATIONS : */
11426/* -------------------------------- */
11427/* 16-05-90 : RBD; Optimisation sur une idee de GD. */
11428/* 12-09-86 : NAK;ECRITURE VERSION ORIGINALE */
11429/* > */
11430/* **********************************************************************
11431*/
11432
11433
11434/* -------- INITIALISATIONS ET TRAITEMENT DES CAS PARTICULIERS ----------
11435*/
11436
11437/* ---> Cas ou NCOEFF > 1 (cas STANDARD). */
11438 /* Parameter adjustments */
11439 --pntcrb;
11440 curve2 -= 3;
11441
11442 /* Function Body */
11443 if (*ncoeff >= 2) {
11444 goto L1000;
11445 }
11446/* ---> Cas ou NCOEFF <= 1. */
11447 if (*ncoeff <= 0) {
11448 pntcrb[1] = 0.;
11449 pntcrb[2] = 0.;
11450 goto L9999;
11451 } else if (*ncoeff == 1) {
11452 pntcrb[1] = curve2[3];
11453 pntcrb[2] = curve2[4];
11454 goto L9999;
11455 }
11456
11457/* -------------------- MSCHEMA DE HORNER (CAS PARTICULIER) --------------
11458 */
11459
11460L1000:
11461
11462 if (*tparam == 1.) {
11463 xxx = 0.;
11464 yyy = 0.;
11465 i__1 = *ncoeff;
11466 for (kk = 1; kk <= i__1; ++kk) {
11467 xxx += curve2[(kk << 1) + 1];
11468 yyy += curve2[(kk << 1) + 2];
11469/* L100: */
11470 }
11471 goto L5000;
11472 } else if (*tparam == 0.) {
11473 pntcrb[1] = curve2[3];
11474 pntcrb[2] = curve2[4];
11475 goto L9999;
11476 }
11477
11478/* ---------------------------- MSCHEMA DE HORNER ------------------------
11479 */
11480/* ---> Ici TPARAM est different de 1.D0 et de 0.D0. */
11481
11482 ndeg = *ncoeff - 1;
11483 xxx = curve2[(*ncoeff << 1) + 1];
11484 yyy = curve2[(*ncoeff << 1) + 2];
11485 for (kk = ndeg; kk >= 1; --kk) {
11486 xxx = xxx * *tparam + curve2[(kk << 1) + 1];
11487 yyy = yyy * *tparam + curve2[(kk << 1) + 2];
11488/* L200: */
11489 }
11490 goto L5000;
11491
11492/* ------------------------ RECUPERATION DU POINT CALCULE ---------------
11493*/
11494
11495L5000:
11496 pntcrb[1] = xxx;
11497 pntcrb[2] = yyy;
11498
11499/* ------------------------------ THE END -------------------------------
11500*/
11501
11502L9999:
11503 return 0;
11504} /* mvpscr2_ */
11505
11506//=======================================================================
11507//function : mvpscr3_
11508//purpose :
11509//=======================================================================
11510int mvpscr3_(integer *ncoeff,
11511 doublereal *curve3,
11512 doublereal *tparam,
11513 doublereal *pntcrb)
11514
11515{
11516 /* System generated locals */
11517 integer i__1;
11518
11519 /* Local variables */
11520 static integer ndeg, kk;
11521 static doublereal xxx, yyy, zzz;
11522
11523
11524
11525/* **********************************************************************
11526*/
11527
11528/* FONCTION : */
11529/* ---------- */
11530/* POSITIONNEMENT SUR UNE COURBE (3,NCF) DANS L'ESPACE DE DIMENSION 3. */
11531
11532/* MOTS CLES : */
11533/* ----------- */
11534/* TOUS, MATH_ACCES:: COURBE&,POSITIONNEMENT,&POINT. */
11535
11536/* ARGUMENTS D'ENTREE : */
11537/* ------------------ */
11538/* NCOEFF : NOMBRE DE COEFFICIENTS DE LA COURBE */
11539/* CURVE3 : EQUATION DE LA COURBE 3D */
11540/* TPARAM : VALEUR DU PARAMETRE AU POINT CONSIDERE */
11541
11542/* ARGUMENTS DE SORTIE : */
11543/* ------------------- */
11544/* PNTCRB : COORDONNEES DU POINT CORRESPONDANT AU PARAMETRE */
11545/* TPARAM SUR LA COURBE 3D CURVE3. */
11546
11547/* COMMONS UTILISES : */
11548/* ---------------- */
11549
11550/* REFERENCES APPELEES : */
11551/* ---------------------- */
11552/* Neant */
11553
11554/* DESCRIPTION/REMARQUES/LIMITATIONS : */
11555/* ----------------------------------- */
11556/* MSCHEMA DE HORNER. */
11557
11558/* $ HISTORIQUE DES MODIFICATIONS : */
11559/* -------------------------------- */
11560/* 16-05-90 : RBD; Optimisation sur une idee de GD (gain=10 pour */
11561/* cent pour des courbes de degre 10 a 20). */
11562/* 12-09-86 : NAK; ECRITURE VERSION ORIGINALE */
11563/* > */
11564/* **********************************************************************
11565*/
11566/* DECLARATIONS */
11567/* **********************************************************************
11568*/
11569
11570
11571/* -------- INITIALISATIONS ET TRAITEMENT DES CAS PARTICULIERS ----------
11572*/
11573
11574/* ---> Cas ou NCOEFF > 1 (cas STANDARD). */
11575 /* Parameter adjustments */
11576 --pntcrb;
11577 curve3 -= 4;
11578
11579 /* Function Body */
11580 if (*ncoeff >= 2) {
11581 goto L1000;
11582 }
11583/* ---> Cas ou NCOEFF <= 1. */
11584 if (*ncoeff <= 0) {
11585 pntcrb[1] = 0.;
11586 pntcrb[2] = 0.;
11587 pntcrb[3] = 0.;
11588 goto L9999;
11589 } else if (*ncoeff == 1) {
11590 pntcrb[1] = curve3[4];
11591 pntcrb[2] = curve3[5];
11592 pntcrb[3] = curve3[6];
11593 goto L9999;
11594 }
11595
11596/* -------------------- MSCHEMA DE HORNER (CAS PARTICULIER) --------------
11597 */
11598
11599L1000:
11600
11601 if (*tparam == 1.) {
11602 xxx = 0.;
11603 yyy = 0.;
11604 zzz = 0.;
11605 i__1 = *ncoeff;
11606 for (kk = 1; kk <= i__1; ++kk) {
11607 xxx += curve3[kk * 3 + 1];
11608 yyy += curve3[kk * 3 + 2];
11609 zzz += curve3[kk * 3 + 3];
11610/* L100: */
11611 }
11612 goto L5000;
11613 } else if (*tparam == 0.) {
11614 pntcrb[1] = curve3[4];
11615 pntcrb[2] = curve3[5];
11616 pntcrb[3] = curve3[6];
11617 goto L9999;
11618 }
11619
11620/* ---------------------------- MSCHEMA DE HORNER ------------------------
11621 */
11622/* ---> Ici TPARAM est different de 1.D0 et de 0.D0. */
11623
11624 ndeg = *ncoeff - 1;
11625 xxx = curve3[*ncoeff * 3 + 1];
11626 yyy = curve3[*ncoeff * 3 + 2];
11627 zzz = curve3[*ncoeff * 3 + 3];
11628 for (kk = ndeg; kk >= 1; --kk) {
11629 xxx = xxx * *tparam + curve3[kk * 3 + 1];
11630 yyy = yyy * *tparam + curve3[kk * 3 + 2];
11631 zzz = zzz * *tparam + curve3[kk * 3 + 3];
11632/* L200: */
11633 }
11634 goto L5000;
11635
11636/* ------------------------ RECUPERATION DU POINT CALCULE ---------------
11637*/
11638
11639L5000:
11640 pntcrb[1] = xxx;
11641 pntcrb[2] = yyy;
11642 pntcrb[3] = zzz;
11643
11644/* ------------------------------ THE END -------------------------------
11645*/
11646
11647L9999:
11648 return 0;
11649} /* mvpscr3_ */
11650
11651//=======================================================================
11652//function : AdvApp2Var_MathBase::mvsheld_
11653//purpose :
11654//=======================================================================
11655 int AdvApp2Var_MathBase::mvsheld_(integer *n,
11656 integer *is,
11657 doublereal *dtab,
11658 integer *icle)
11659
11660{
11661 /* System generated locals */
11662 integer dtab_dim1, dtab_offset, i__1, i__2;
11663
11664 /* Local variables */
11665 static integer incr;
11666 static doublereal dsave;
11667 static integer i3, i4, i5, incrp1;
11668
11669
11670/************************************************************************
11671*******/
11672
11673/* FONCTION : */
11674/* ---------- */
11675/* TRI LES COLONNES D'UN TABLEAU DE REAL*8 SUIVANT LA METHODE DE SHE
11676LL*/
11677/* (DANS L'ORDRE CROISSANT) */
11678
11679/* MOTS CLES : */
11680/* ----------- */
11681/* POINT-ENTREE, TRI, SHELL */
11682
11683/* ARGUMENTS D'ENTREE : */
11684/* ------------------ */
11685/* N : NOMBRE DE COLONNES DU TABLEAU */
11686/* IS : NOMBRE DE LIGNE DU TABLEAU */
11687/* DTAB : TABLEAU DE REAL*8 A TRIER */
11688/* ICLE : POSITION DE LA CLE SUR LA COLONNE */
11689
11690/* ARGUMENTS DE SORTIE : */
11691/* ------------------- */
11692/* DTAB : TABLEAU TRIE */
11693
11694/* COMMONS UTILISES : */
11695/* ---------------- */
11696
11697
11698/* REFERENCES APPELEES : */
11699/* ---------------------- */
11700/* Neant */
11701
11702/* DESCRIPTION/REMARQUES/LIMITATIONS : */
11703/* ----------------------------------- */
11704/* METHODE CLASSIQUE DE SHELL : TRI PAR SERIES */
11705/* La declaration DTAB(IS, 1) correspond en fait a DTAB(IS, *) */
11706
11707/* $ HISTORIQUE DES MODIFICATIONS : */
11708/* -------------------------------- */
11709/* 24-09-93 : PMN; NETTOYAGE ET CORRECTION DE L'EN-TETE */
11710/* 13-07-84 : BF ; VERSION D'ORIGINE */
11711
11712/* > */
11713/* ***********************************************************************
11714 */
11715
11716
11717 /* Parameter adjustments */
11718 dtab_dim1 = *is;
11719 dtab_offset = dtab_dim1 + 1;
11720 dtab -= dtab_offset;
11721
11722 /* Function Body */
11723 if (*n <= 1) {
11724 goto L9900;
11725 }
11726/* ------------------------ */
11727
11728/* INITIALISATION DE LA SUITE DES INCREMENTS */
11729/* RECHERCHE DU PLUS GRAND INCREMENT TEL QUE INCR < N/9 */
11730
11731 incr = 1;
11732L1001:
11733 if (incr >= *n / 9) {
11734 goto L1002;
11735 }
11736/* ----------------------------- */
11737 incr = incr * 3 + 1;
11738 goto L1001;
11739
11740/* BOUCLE SUR LES INCREMENTS JUSQU'A INCR = 1 */
11741/* TRI PAR SERIES DISTANTES DE INCR */
11742
11743L1002:
11744 incrp1 = incr + 1;
11745/* ----------------- */
11746 i__1 = *n;
11747 for (i3 = incrp1; i3 <= i__1; ++i3) {
11748/* ---------------------- */
11749
11750/* METTRE L'ELEMENT I3 A SA PLACE DANS SA SERIE */
11751
11752 i4 = i3 - incr;
11753L1004:
11754 if (i4 < 1) {
11755 goto L1003;
11756 }
11757/* ------------------------- */
11758 if (dtab[*icle + i4 * dtab_dim1] <= dtab[*icle + (i4 + incr) *
11759 dtab_dim1]) {
11760 goto L1003;
11761 }
11762
11763 i__2 = *is;
11764 for (i5 = 1; i5 <= i__2; ++i5) {
11765/* ------------------ */
11766 dsave = dtab[i5 + i4 * dtab_dim1];
11767 dtab[i5 + i4 * dtab_dim1] = dtab[i5 + (i4 + incr) * dtab_dim1];
11768 dtab[i5 + (i4 + incr) * dtab_dim1] = dsave;
11769 }
11770/* -------- */
11771 i4 -= incr;
11772 goto L1004;
11773
11774L1003:
11775 ;
11776 }
11777/* -------- */
11778
11779/* PASSAGE A L'INCREMENT SUIVANT */
11780
11781 incr /= 3;
11782 if (incr >= 1) {
11783 goto L1002;
11784 }
11785
11786L9900:
11787 return 0 ;
11788} /* mvsheld_ */
11789
11790//=======================================================================
11791//function : AdvApp2Var_MathBase::mzsnorm_
11792//purpose :
11793//=======================================================================
11794 doublereal AdvApp2Var_MathBase::mzsnorm_(integer *ndimen,
11795 doublereal *vecteu)
11796
11797{
11798 /* System generated locals */
11799 integer i__1;
11800 doublereal ret_val, d__1, d__2;
11801
11802 /* Local variables */
11803 static doublereal xsom;
11804 static integer i__, irmax;
11805
11806
11807
11808/* ***********************************************************************
11809 */
11810
11811/* FONCTION : */
11812/* ---------- */
11813/* Sert a calculer la norme euclidienne d'un vecteur : */
11814/* ____________________________ */
11815/* Z = V V(1)**2 + V(2)**2 + ... */
11816
11817/* MOTS CLES : */
11818/* ----------- */
11819/* SURMFACIQUE, */
11820
11821/* ARGUMENTS D'ENTREE : */
11822/* ------------------ */
11823/* NDIMEN : Dimension du vecteur */
11824/* VECTEU : vecteur de dimension NDIMEN */
11825
11826/* ARGUMENTS DE SORTIE : */
11827/* ------------------- */
11828/* MZSNORM : Valeur de la norme euclidienne du vecteur VECTEU */
11829
11830/* COMMONS UTILISES : */
11831/* ---------------- */
11832
11833/* .Neant. */
11834
11835/* REFERENCES APPELEES : */
11836/* ---------------------- */
11837/* Type Name */
11838/* R*8 ABS R*8 SQRT */
11839
11840/* DESCRIPTION/REMARQUES/LIMITATIONS : */
11841/* ----------------------------------- */
11842/* Pour limiter les risques d'overflow, on met en facteur */
11843/* le terme de plus forte valeur absolue : */
11844/* _______________________ */
11845/* Z = !V(1)! * V 1 + (V(2)/V(1))**2 + ... */
11846
11847/* $ HISTORIQUE DES MODIFICATIONS : */
11848/* -------------------------------- */
11849/* 11-09-1995 : JMF ; implicit none */
11850/* 20-03-89 : DH ; Creation version originale */
11851/* > */
11852/* ***********************************************************************
11853 */
11854/* DECLARATIONS */
11855/* ***********************************************************************
11856 */
11857
11858
11859/* ***********************************************************************
11860 */
11861/* TRAITEMENT */
11862/* ***********************************************************************
11863 */
11864
11865/* ___ Recherche du terme de plus forte valeur absolue */
11866
11867 /* Parameter adjustments */
11868 --vecteu;
11869
11870 /* Function Body */
11871 irmax = 1;
11872 i__1 = *ndimen;
11873 for (i__ = 2; i__ <= i__1; ++i__) {
11874 if ((d__1 = vecteu[irmax], abs(d__1)) < (d__2 = vecteu[i__], abs(d__2)
11875 )) {
11876 irmax = i__;
11877 }
11878/* L100: */
11879 }
11880
11881/* ___ Calcul de la norme */
11882
11883 if ((d__1 = vecteu[irmax], abs(d__1)) < 1.) {
11884 xsom = 0.;
11885 i__1 = *ndimen;
11886 for (i__ = 1; i__ <= i__1; ++i__) {
11887/* Computing 2nd power */
11888 d__1 = vecteu[i__];
11889 xsom += d__1 * d__1;
11890/* L200: */
11891 }
11892 ret_val = sqrt(xsom);
11893 } else {
11894 xsom = 0.;
11895 i__1 = *ndimen;
11896 for (i__ = 1; i__ <= i__1; ++i__) {
11897 if (i__ == irmax) {
11898 xsom += 1.;
11899 } else {
11900/* Computing 2nd power */
11901 d__1 = vecteu[i__] / vecteu[irmax];
11902 xsom += d__1 * d__1;
11903 }
11904/* L300: */
11905 }
11906 ret_val = (d__1 = vecteu[irmax], abs(d__1)) * sqrt(xsom);
11907 }
11908
11909/* ***********************************************************************
11910 */
11911/* RETOUR PROGRAMME APPELANT */
11912/* ***********************************************************************
11913 */
11914
11915 return ret_val;
11916} /* mzsnorm_ */
11917
Open CASCADE Technology repository